module f77ctl;

exports
imports impprocs from impprocs;
imports system from system;
imports stack from stack;
imports except from except;
imports memory from memory;
imports filesystem from filesystem;
imports runread from runread;
imports screen from screen;
imports stream from stream;

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

type pcharar=^charar;
     charar=packed array[0..511] of char;
     mybuf=record case integer of
                    1:(s:psegblock);
                    2:(p:pdirblk);
                    4:(c:pcharar);
                  end;
      header = record
                dict:fsbit16;
                rts:fsbit16;
                ldata:fsbit16;
                area:fsbit16
              end;           
     headptr=^header;
     codemaprec = record
                    start:fsbit16;
                    props:fsbit16;
                    len:fsbit32
                  end;
     codemap=array[1..10] of codemaprec;
     codemapptr=^codemap;
     arearange=1..10;
     ldatamap=array[0..10] of fsbit16;
     ldataptr=^ldatamap;
     listrange=0..10;
     string255=string[255];
     pstr=^string255;
var INITFLAG,outptr,debugseg:INTEGER;
    buf:mybuf;
    firstseg,lastseg:psegnode;
    wantdebug,rungotten:boolean;
    imprs,imprr,impgp:fsbit16;

const Dosysnamesfirst=true;
      Excseg=26;

procedure initmain;
procedure INITGLA;
function iocp(ep,off,seg:integer):integer;
procedure stop;
procedure iwrite(val0,val1,place0,place1:integer);
procedure recdiag(p1,p2,p3,p4:fsbit16);
                  
private
function indiag(gp,ap,cs,rn:fsbit16):fsbit16;forward;

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

procedure setout(var outfile:text;var outptr:txtptr);
var outadr:fsbit16;
begin
loadadr(outfile);
storexpr(outadr);
outptr:=makeptr(ss,outadr,txtptr);
end; { setout }

Function GetSysSeg(seg: integer): pSegNode;
{-------------------------------------------------------------------------
 Abstract: Gets the SegNode or the syste segment number seg
 Parameters: seg is the number of the system segment to get node for
 Returns: a pointer to node or NIL if not found
 Environment: if runfile not found, then FirstSeg and LastSeg are NIL,
              otherwise, they are set up
------------------------------------------------------------------------}
   var p: pSegNode;
       i: integer;
   begin
   GetSysSeg := NIL;
   if seg < FirstSystemSegment then exit(GetSysSeg);
   p := FirstSeg;
   for i := 1 to seg-FirstSystemSegment do
     begin
     if p = LastSeg then exit(GetSysSeg);
     p := p^.next;
     end;
   GetSysSeg := p;
   end; {GetSysSeg}

{$r- }
Procedure PrintRoutineName(rtn: integer; f: FileID);
{-------------------------------------------------------------------------
 Abstract: Prints the routine name for rtn specified in file specified.
 Parameters: rtn is routine number and f is fileID
 Environment: Block zero of file better be read into buf.p.
------------------------------------------------------------------------}
   var i, blk, offset: integer;
       rtnName: SimpleName;
   begin
   blk := buf.s^.ImportBlock;
   offset := buf.s^.NumSeg*WordSize(CImpInfo)+rtn*4;
   blk := blk+offset div 256;
   offset := (offset mod 256)*2;
   rtnName := '';
   FSBlkRead(f, blk, buf.p);
   for i := 0 to 7 do
       begin
       if offset = 512 then
            begin
            offset := 0;
            FSBlkRead(f, blk+1, buf.p);
            end;
       if buf.c^[offset] > ' ' then AppendChar(RtnName,buf.c^[offset]);
       offset := offset+1;
       end;
   if rtnName <> '' then Write(curout^,rtnName,' (',rtn:1,')')
   else Write(curout^,rtn:1);
   end; {PrintRoutineName}

Procedure WriteLocation(seg, rtn, addr: integer; suppressAddr,
              inDanger: Boolean );
{-------------------------------------------------------------------------
 Abstract: WriteLocation writes out a code location or an exception number.
            It writes the location (Seg, Rtn, Addr) using the segment table
            to determine the name of Seg (if possible) and the routine
            dictionary of Seg to determine the relative address within
            Rtn.  For an exception, only the segment name and routine number
            are printed.
 Parameters: seg is the number of the segment to be printed;
             rtn is the routine number of the exception or routine to be shown
             addr is the address in the procedure that currently at
             if suppressAddr is true then doesn't print address; otherwise
               does.  Make this false for Exceptions
             inDanger tells WriteLoc not to do any disk addresses since
               these are likely to fail
------------------------------------------------------------------------}
type pInteger = ^Integer;
var P:pInteger;
    SegName: SimpleName;
    L, dum: Integer;
    SystemNames: pSysNameArray;
    ok : boolean;
    s: pSegNode;
    fid: FileID;
begin
      if not suppressAddr then
        begin
          P := MakePtr(Seg, 0, pInteger);
          P := MakePtr(Seg, P^ + Rtn * 8 + RDEntry, pInteger);
          Write(curout^,Addr - P^:5);
          Write(curout^,' in routine ')
        end;
      SegName := '';
      with SIT^[Seg] do
        if BootLoaded then
            begin
            ok := false;
            if inDanger then s := NIL
            else s := GetSysSeg(seg);
            if s <> NIL then
              if s^.RootNam <> NIL then
                 begin
                 fid := FSInternalLookUp(Concat(s^.RootNam^,'.SEG'), dum, dum);
                 if fid <> 0 then begin
                                  FSBlkRead(fid, 0, buf.p);
                                  PrintRoutineName(rtn, fid);
                                  ok := true;
                                  end;
                 end;
            if not ok then Write(curout^,rtn:2);
            SystemNames := MakePtr(SysNameSeg,0,pSysNameArray);
            for L := 1 to SysSegLength do
              if SystemNames^[Seg][L] <> ' ' then
                AppendChar(SegName,SystemNames^[Seg][L]);
            end {bootLoaded}
        else begin
             if (DiskId <> 0) and not inDanger then
                begin
                FSBlkRead(DiskId,0,Buf.p);
                for L := 1 to SegLength do
                    if Buf.s^.ModuleName[L] <> ' ' then
                    AppendChar(SegName,Buf.s^.ModuleName[L]);
                PrintRoutineName(rtn, DiskID);
                end {have a fileID}
             else Write(curout^,rtn:2);
             end; {not Bootloaded}
      if SegName = '' then Write(' in segment ', Seg:2)
      else Write(curout^,' in ', SegName);
end { WriteLocation};

{$r+ }

Procedure GetSysRun;
{-------------------------------------------------------------------------
 Abstract: Reads the system run file if not already read in
 SideEffects: Reads in run file (sets FirstSeg and LastSeg) and sets
                runGotten to true
------------------------------------------------------------------------}
  var fuSeg: pSegNode;
      r: RunFileType;
      RunFileName: PathName;
      dum: integer;
      header: RunInfo;
  Handler ResetError(fileName: PathName);
    begin
    SClearChar('.', RXor); {will be two dots before reset is done}
    SClearChar('.', RXor);
    exit(GetSysRun);
    end;
  begin
  if runGotten then exit(GetSysRun);
  Write(curout^,'.');
  runGotten := true;
  SysVers(SystemVersion, RunFileName);
  RunFileName := Concat('SYSTEM.',RunFileName);
  AppendString(RunFileName, '.RUN');
  Write(curout^,'.');
  Reset(r, RunFileName);
  Write(curout^,'.');
  ReadRunFile(r, DebugSeg, header, FirstSeg, fuSeg, LastSeg, false);
  Write(curout^,'.');
  ReadSegNames(r, DebugSeg, fuSeg);
  SClearChar('.',RXor);
  SClearChar('.',RXor);
  SClearChar('.',RXor);
  SClearChar('.',RXor);
  end; {GetSysRun}

procedure prexcept(es,er,pstart:fsbit16);
type pstring=^string;
var param:fsbit32;
    i:integer;
    stringparam:pstring;
begin
if (ES = ExcSeg) then
   case ER of
     ErrAbort, ErrDump: begin
                        StringParam := MakePtr(ss,PStart,pString);
                        Write(curout^,StringParam^);
                        end;
     ErrSegmentFault: begin
                      Write(curout^,'Segment fault, segments');
                      for I := 0 to 3 do 
                        begin
                        param:=makeptr(ss,pstart+i,fsbit32);
                        write(curout^,param^:1);
                        end;
                      end;
     ErrDivZero: Write(curout^,'Division by zero');
     ErrMulOvfl: Write(curout^,'Overflow in multiplication');
     ErrStrIndx: Write(curout^,'String index out of range');
     ErrStrLong: Write(curout^,'String to be assigned is too long');
     ErrInxCase: Write(curout^,'Expression out of range');
     ErrSTLATE:  Write(curout^,'Parameter in STLATE instruction is too large');
     ErrUndfQcd: Write(curout^,'Execution of an undefined Q-code');
     ErrUndfInt: Write(curout^,'Undefined device interrupt detected');
     ErrIOSFlt:  Write(curout^,'Segment fault detected during I/O');
     ErrMParity: Write(curout^,'Memory parity error');
     ErrEStk:    Write(curout^,'Expression stack not empty at INCDDS');
     ErrOvflLI:  Write(curout^,'Overflow in conversion Long Integer ==> Integer');
     otherwise:  begin
                 Write(curout^,'Uncaught Exception: ');
               {$ifc DoSysNamesFirst then}
                 GetSysRun;
               {$endc}
                 WriteLocation(ES, ER, 0, True, false);
                 end;
     end
else if (ES = FirstSystemSegment) and
            ((ER = ErrCtlC) or (ER = ErrCtlCAbort) or (ER = ErrCtlShftC)) then
               begin
               Write(curout^,'Control-C Abort');
               wantDebug := false;
               end
else begin
        Write(curout^,'Uncaught Exception: ');
      {$ifc DoSysNamesFirst then}
         GetSysRun;
      {$endc}
         WriteLocation(ES, ER, 0, True, false);
end;
Writeln(curout^);
end; { prexcept }

PROCEDURE INITIALISE;
BEGIN
ss:=loadss;
reset(tin,'console:');
setout(tout,curout);
rewrite(curout^,'console:');
writeln(curout^,'entering initialise');
INITFLAG:=999;
OUtPTR:=0;
dlist:=false;
listing:=false;
rungotten:=false;
wantdebug:=true;
writeln(curout^,'exit from initialise');
END; { INITIALISE }

PROCEDURE copygla(cs,gp:fsbit16);
label 10;
type list7rec=record
                area,link:fsbit16;
                disp:fsbit32;
                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;
     list7ptr=^list7rec;
     list8ptr=^list8rec;
     list9ptr=^list9rec;
     dbleptr=^fsbit32;
var gdb,srce,word,data,areaptr:fsbit32;
    dest:array[1..2] of fsbit32;
    startad:array[1..10] of fsbit32;
    codearea:codemapptr;
    codehd:headptr;
    areaind:arearange;
    ldata:ldataptr;
    lind:listrange;
    ldat7:list7ptr;
    ldat8:list8ptr;
    ldat9:list9ptr;
    dbleword:dbleptr;
    len,dstart,ldataoff,link,num,glaoff,i,j:fsbit16;

begin
gdb:=makeptr(ss,gp,fsbit32);
codehd:=makeptr(cs,0,headptr);
codearea:=makeptr(cs,codehd^.area,codemapptr);

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

{ deal with areas 2 & 5 only }

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

areaind:=2;
dest[1]:=gdb;
for i:=1 to 2 do
  begin
  len:=intdouble(codearea^[areaind].len);
  if len=0 then goto 10;
  srce:=makeptr(cs,codearea^[areaind].start,fsbit32);
  move(srce,dest[i],len);
  10:
  startad[areaind] := dest[i];  { adjust startad to loaded address}
  if i=1 then
    begin
    areaind:=5;
    dest[2]:=makeptr(ss,gp+len,fsbit32);
    end;
  end;


{------------------------------------
{        perform relocation
{------------------------------------
{ ldata - deal with ldata[8] & [9] only }


{ ldata[8] }
LDATAOFF:=CODEHD^.LDATA;
LDATA:=MAKEPTR(CS,LDATAOFF,LDATAPTR);
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:=MAKEPTR(SS,GP+LDAT8^.fix[i],FSBIT32);
    WORD^:=WORD^+GP;
    END;
  LINK:=LDAT8^.LINK;
  END;

{ 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;
    DBLEWORD:=MAKEPTR(SS,GP+LDAT9^.fix[i].DISP,DBLEPTR);
    DBLEWORD^:=DOUBLEADD(DBLEWORD^,startad[areaind]);
    END;
  LINK:=LDAT9^.LINK;
  END;

end; { copyGLA }

procedure diags(raiseap:fsbit16);
label 10,15,20,30,40;
var ans,fname:string;
    raiseacb:acbptr;
    ssn,rn,pc,gp,ap,newap:fsbit16;
    off,len,i:integer;
begin
10:
writeln(curout^);
raiseacb:=makeptr(ss,raiseap,acbptr); {acb of raise }
ssn:=raiseacb^.rs; { ssn of caller }
rn:=raiseacb^.rr; { rn of caller }
pc:=raiseacb^.ra; { pc of caller }
gp:=raiseacb^.gl; { gdb of caller }
ap:=raiseacb^.dl; {ap of caller }
writeln(curout^,'contingency at offset ',pc:5,' in ssn ',ssn:4);
writeln(curout^,'routine number ',rn:3);
writeln(curout^,'ap is ',ap:6);
writeln(curout^,'gp is ',gp:6);
if not wantdebug then exit(diags);
write(curout^,'DEBUG? [no] :');
readln(tin,ans); 
if (ans='no') or (ans='n') or (ans='') then exit(diags);
if (ans='yes') or (ans='y') then else goto 10;
15:
write(curout^,'[ DUMP ACB FILE INDIAG SCROUNGE QUIT ]:');
readln(tin,ans);
if ans='dump' then
  begin
  20:
  write(curout^,'[ ssn disp len ]:');
  readln(tin,ssn,off,len);
  if (ssn<0) or (off<0) or (len<0) then goto 20;
  dumpseg(ssn,off,len);
  if dlist then
    begin
    setout(dfile,curout);
    dumpseg(ssn,off,len);
    setout(tout,curout);
    end;
  end
else if ans='file' then
  begin
  30:
  write(curout^,'[ filename ]:');
  readln(tin,fname);if fname='' then goto 30;
  dlist:=true;
  rewrite(dfile,fname);
  end
else if ans='acb' then
  begin
  40:
  write(curout^,'[ ap ]:');
  readln(tin,newap); if newap<0 then goto 40;
  dumpacb(newap);
  end
else if ans='indiag' then newap:=indiag(gp,ap,ssn,rn)
else if ans='scrounge' then raise dump('dump from diags')
else if ans='quit' then
  begin
  if dlist then close(dfile);
  exit(diags)
  end
else writeln(curout^,'unrecognised command');
goto 15;
end; { diags }


function indiag;
label 10;

handler all(es,er,pstart,pend:integer);
var raiseap,ap:fsbit16;
    acball:acbptr;
    i,j:integer;
begin
prexcept(es,er,pstart);
ap:=loadap;
acball:=makeptr(ss,ap,acbptr); {acb of all }
raiseap:=acball^.dl; {ap of raise }
diags(raiseap);
raise exitprogram;
end; { ALL }

type gdbchars=packed array[1..2] of char;
     list1rec=record
                ddisp,rn,props,link:fsbit16;
                name:string[31]
              end;
     list1ptr=^list1rec;
var gdb,ll,acb0,adiags,ddisp,newacb:fsbit32;
    link,ldataoff,lp:fsbit16;
    acb:acbptr;
    dchars:gdbchars;
    codehd:headptr;
    codearea:codemapptr;
    ldata:ldataptr;
    ldat1:list1ptr;
begin
indiag:=-1;
gdb:=makeptr(ss,gp,fsbit32);
dchars:=recast(gdb^,gdbchars);
if dchars[2]<>'I' then 
  begin
  writeln(curout^,'indiag only implemented for imp');
  writeln(curout^,'code is ',dchars[1]:1,dchars[2]:2);
  exit(indiag);
  end;
codehd:=makeptr(cs,0,headptr);
codearea:=makeptr(cs,codehd^.area,codemapptr);
adiags:=makeptr(cs,codearea^[4].start,fsbit32);
ldataoff:=codehd^.ldata;
ldata:=makeptr(cs,ldataoff,ldataptr);
link:=ldata^[1];
while link<>0 do
  begin
  ldat1:=makeptr(cs,ldataoff+link,list1ptr);
  if ldat1^.rn=rn then
    begin
    ddisp:=doubleint(ldat1^.ddisp);
    goto 10;
    end;
  link:=ldat1^.link;
  end;
writeln(curout^,'help - entry point record not found');
exit(indiag);
10:
acb:=makeptr(ss,ap,acbptr);
lp:=acb^.lp;
ll:=makeptr(ss,lp,fsbit32);
acb0:=makeptr(ss,ap,fsbit32);
qindiag(ll,gdb,acb0,adiags,ddisp,0,2,8,1,newacb);
loadadr(newacb);
storexpr(ap);
writeln(curout^,'newacb disp is',ap:4:-16);
indiag:=ap;
end; { indiag }

procedure run;

handler all(es,er,pstart,pend:integer);
var raiseap,ap:fsbit16;
    acball:acbptr;
    param:fsbit32;
    i,j:integer;
begin
prexcept(es,er,pstart);
ap:=loadap;
acball:=makeptr(ss,ap,acbptr); {acb of all }
raiseap:=acball^.dl; {ap of raise }
diags(raiseap);
raise exitprogram;
end; { ALL }

begin { run }
{ load variable routine descriptor }
loadexpr(0);
loadexpr(IMPrr);
loadexpr(IMPgp);
loadexpr(IMPrs);
inlinebyte(187); { callv }
writeln(curout^,'exit from imp program - should we reach here');
if dlist then close(dfile);
if listing then close(lfile);
raise exitprogram;
end; { run }
procedure initmain;
var ap,dl:fsbit16;
    gdb1:fsbit32;
    acb0:acbptr;
begin {initmain }

IF INITFLAG=0 THEN INITIALISE;
writeln(curout^,'entering initmain');
ap:=loadap; { ap of initnain }
acb0:=makeptr(ss,ap,acbptr); { acb of initmain }
imprs:=acb0^.rs; { ssn of calling prog }
impgp:=acb0^.gl;{ gp of calling prog }
copygla(imprs,impgp);
imprr:=acb0^.rr;{ return routine of calling prog }
run;

{ return here from STOP }
raise exitprogram;
end; { INITMAIN }
 
PROCEDURE initgla;
var ssn,ap,gp:fsbit16;
    gdb1:fsbit32;
    acb0:acbptr;
begin
writeln(curout^,'entering initgla');
if initflag=0 then initialise;
ap:=loadap; { 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;
    lf:boolean;
begin
case ep of
  3,5:begin
        j:=land(off,#177);
        if (j=nl) or (j=np) then begin
          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 writeln(curout^);
      case off of
       0:setout(tout,curout);
       1:setout(lfile,curout);
       2,107:setout(dfile,curout);
      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(curout^,'%stop called ***');
exit(run);
writeln(curout^,'end of stop');
end;

procedure iwrite;
begin
write(curout^,val1:place1);
write(curout^,val0);
end;

procedure recdiag;
begin
writeln(curout^,'dummy indiag entered');
end.