{ f77dctl15:
{           15/6/82 - Proceed from Ctl-shiftC }
{           17/6/82 - corrupt stack error message }
{           21/6/82 - recognition of diagnostic responses in f77diags changed }
{           24/6/82 - scrounge info o/p with /help }

module  f77dctl;
exports
imports filedefs from filedefs;

procedure ndiag(raiseap,dumpc,err,extra:fsbit16);
procedure ssmess(i:integer);

function loadss:fsbit16;
function loadap:fsbit16;
procedure diags(raiseap,es,er,pstart,pend:fsbit16);

private

imports f77init from f77init;
imports f77idiag from f77idiag;
imports f77fdiag from f77fdiag;
imports f77rmess from f77rmess;
imports F77QCODE from F77QCODE;

imports system from system;
imports except from except;
imports scrounge from scrounge;
imports perq_string from perq_string;
imports memory from memory;
imports filesystem from filesystem;
imports runread from runread;
imports screen from screen;
imports IO_Others from IO_Others;
imports io_unit from io_unit;
imports code from code;
imports stream from stream;
imports clock from clock;



const {$Include acb.dfs}
      {$Include rd.dfs}
      {$Include except.dfs}
const Dosysnamesfirst=true;

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;
var debugseg:INTEGER;
    buf:mybuf;
    acbx:acbptr;
    firstseg,lastseg:psegnode;
    stopshowall,everdlist:boolean;
    rtnName,firstrtnname: SimpleName;
    Diagraiseap,orgraiseap:fsbit16;
    

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

function stoi( var str:string;var num:integer):boolean;
{ converts string up to 1st space to integer in num }
{ returns rest of string (after space) in str }
label 10;
var len,i,dig,base,start:integer;
begin
num:=0;
stoi:=false;
len:=length(str);
if len=0 then exit(stoi);
if (str[1]='X') or (str[1]='x') then begin
  base:=16;
  start:=2;
  end else
  begin
  base:=10;
  start:=1
  end;
for i:=start to len do
  begin
  case str[i] of
    ' ':goto 10;
    '0'..'9':dig:=ord(str[i])-ord('0');
    'A'..'F':begin
             if base=10 then exit(stoi);
             dig:=ord(str[i])-ord('A')+10;
             end;
    'a'..'f':begin
             if base=10 then exit(stoi);
             dig:=ord(str[i])-ord('a')+10;
             end;
    otherwise:exit(stoi);
  end;
  num:=num*base+dig;
  end;
10:
if i+1>len then str:='' else str:=substr(str,i+1,len-i);
stoi:=true;
end; { stoi }

procedure strip(var str:string);
label 10,20;
var i,len:integer;
begin
len:=length(str);
for i:=1 to len do if str[i]<>' ' then goto 10;
str:=' ';
exit(strip);
10:
str:=substr(str,i,len+1-i);
len:=length(str);
for i:=1 to len do if str[len+1-i]<>' ' then goto 20;
20:
str:=substr(str,1,len+1-i);
convupper(str);
end; { strip }

function loadss:fsbit16;
var ss:fsbit16;
begin
  inlinebyte(99); { lssn }
  storexpr(ss);
  loadss:=ss;
end;
 
function loadap:fsbit16;
var ap,ss:fsbit16;
    dl:fsbit32;
begin
  inlinebyte(244); { ldap }
  storexpr(ap);
  ss:=loadss;
  dl:=makeptr(ss,ap+2,fsbit32);
  loadap:=dl^;
end;

procedure dumpacb(ap:fsbit16);
var acb1:acbptr;
    sl,lp,dl,gl,tl,rs,ra,rr,ep:fsbit16;
begin
acb1:=makeptr(ss,ap,acbptr);
sl:=acb1^.sl; lp:=acb1^.lp;
dl:=acb1^.dl; gl:=acb1^.gl;
tl:=acb1^.tl; rs:=acb1^.rs;
ra:=acb1^.ra; rr:=acb1^.rr;
ep:=acb1^.ep;
writeln(curout^,' sl (',ap:4:-16,')',sl:5:-16,'   (',ap:5,')',sl:6);
writeln(curout^,' lp (',(ap+1):4:-16,')',lp:5:-16,'   (',(ap+1):5,')',lp:6);
writeln(curout^,' dl (',(ap+2):4:-16,')',dl:5:-16,'   (',(ap+2):5,')',dl:6);
writeln(curout^,' gl (',(ap+3):4:-16,')',gl:5:-16,'   (',(ap+3):5,')',gl:6);
writeln(curout^,' tl (',(ap+4):4:-16,')',tl:5:-16,'   (',(ap+4):5,')',tl:6);
writeln(curout^,' rs (',(ap+5):4:-16,')',rs:5:-16,'   (',(ap+5):5,')',rs:6);
writeln(curout^,' ra (',(ap+6):4:-16,')',ra:5:-16,'   (',(ap+6):5,')',ra:6);
writeln(curout^,' rr (',(ap+7):4:-16,')',rr:5:-16,'   (',(ap+7):5,')',rr:6);
writeln(curout^,' ep (',(ap+8):4:-16,')',ep:5:-16,'   (',(ap+8):5,')',ep:6);
end;

procedure dumpseg(ssn,disp,len:fsbit16);
type arr8=array[1..8] of fsbit16;  
     arr8ptr=^arr8;
     char16=packed array[1..16] of char;
var darr:arr8ptr;
    charr:char16;
    i,j,lcount:integer;
begin
if ssn=0 then ssn:=ss;
lcount:=len div 8;
for i:=0 to lcount do
  begin
  write(curout^,'(',disp+i*8:4:-16,') (',i*8:5,') ');
  darr:=makeptr(ssn,disp+i*8,arr8ptr);
  for j:=1 to 8 do write(curout^,' ',darr^[j]:4:-16);
  charr:=recast(darr^,char16);
  write(curout^,'  [');
  for j:=1 to 16 do
    begin
    case charr[j] of
      'a'..'z','A'..'Z','0'..'9':write(curout^,charr[j]);
      otherwise:write(curout^,'.');
    end;
    end;
  writeln(curout^,']');
  end;
end; { dump }
                

procedure f77diag(raiseap:fsbit16;diag,asize:long);forward;
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;
   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 (Swapinfo.DiskId <> 0) and not inDanger then
                begin
                FSBlkRead(Swapinfo.DiskId,0,Buf.p);
                for L := 1 to SegLength do
                    if Buf.s^.ModuleName[L] <> ' ' then
                    AppendChar(SegName,Buf.s^.ModuleName[L]);
                PrintRoutineName(rtn, Swapinfo.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);
      
    {stop trace back on F77 main program  and hide bottom stack from user}          if rtnname='F_MAIN' then stopshowall := true;
    
end { WriteLocation};

{$r+ }

Procedure ShowAll(RaiseAP, curAP:integer; isDump : boolean);
{-------------------------------------------------------------------------
 Abstract: Shows all of stack from RaiseAP to system 0
 Parameters: RaiseAP is the offset for AP for Raise itself (caller is person
               who did the raise)
             curAp is the current AP and it is marked with a <**>
------------------------------------------------------------------------}
   var AP, seg, rtn, addr: integer;
       acb:acbptr;
       LocStr : String[21];
   begin
   if isDump then LocStr := 'Debug at    '
   else LocStr := 'Aborted at Qcode: ';
   acb:=makeptr(ss,raiseap,acbptr);
   stopshowall := false;
   Firstrtnname := '';
   repeat
     Seg := acb^.rs;
     Rtn := acb^.rr;
     Addr := acb^.ra;
     Write(curout^,LocStr);
     WriteLocation(Seg, Rtn, Addr, False, False);
     AP := acb^.dl;
     if curAP=AP then WriteLn(curout^,'.    <**>')
     else Writeln(curout^,'.');
     if firstrtnname='' then firstrtname:=rtnname;
     acb:=makeptr(ss,ap,acbptr);
     LocStr := 'Called from Qcode: '
   until ((Rtn = 0) and (Seg = FirstSystemSeg)) or (stopshowall=true);
   end;

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
 { WRITELN(CUROUT^,'entering getsysrun');}
  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);
  {WRITELN(CUROUT^,'exit from getsysrun');}
  end; {GetSysRun}

procedure diags;
label 1,5,10,15,20,25,30,35,40,50,59,60,99,100;
type pstring=^string;
     gdbchars = packed array [1..2] of char;
var ans,fname,dumpmess:string;
    newap,dumpssn,messaddr,diagsap:fsbit16;
    wantdebug,userdump,quitflag,recursivedebug,ok:boolean;
    off,len,i,newes,newer:integer;
    param1,param2:fsbit32;
    stringparam:pstring;
    curwin:winrange;
    dateandtime:timestring;
    asize,diag:long;
    gdb:fsbit32;
    dchars:gdbchars;
    language:char;
    rap:fsbit16;
    s:simplename;

Procedure DoCleanUp(abortProg: Boolean);
{-------------------------------------------------------------------------
Abstract: Does final cleanup of shell and system state before scrounge
          returns
Parameters: if abortProg then raises ExitProgram to abort program after
           cleaning up command file;  otherwise, continue execution
------------------------------------------------------------------------}
  Handler All(ES, ER, PS, PE: integer);
  {--------------------------------------------------------------
  Abstract: Handle all in cleanup and just abort; won't reset command
            files and all that stuff
  -------------------------------------------------------------}
  begin
  if (ES = ExcSeg) and ((ER = ErrSegmentFault) or (ER = ErrStackOverflow))
    then RaiseP(ES, ER, PS, PE)
  else begin
    if (ES <> FirstSystemSeg) or (ER <> ErrExitProgram) then
    WriteLn('Scrounge aborted during Cleanup; Exception ',ER:1,
            ' in ',ES:1);
    Raise ExitProgram;
    end;
  end; { all }

begin { docleanup }
  {WRITELN(CUROUT^,'entering DOCLEANUP');}
  if everdlist then close(dfile);
  everdlist:=false;
  dlist:=false;
  if DebugSeg <> 0 then
    begin
    DecRefCount(DebugSeg);
    DebugSeg := 0;
    end;
  if abortProg then
    begin
      if (cfvrd1<>0) and (cfvrd2<>0) then begin {closefiles}
        loadexpr(cfvrd4);
        loadexpr(cfvrd3);
        loadexpr(cfvrd2);
        loadexpr(cfvrd1);
        inlinebyte(187);   {callV}
      end;    
    InCmdFile := False;
    SFullWindow;                  { make it full size}
    Raise ExitProgram;
    end
  else ChangeWindow(curWin);
end; {DoCleanUp}


handler all(aes,aer,aps,ape:integer);
begin
{writeln(curout^,'entering ALL in diags');}
  if (aES = ExcSeg) and (aER = ErrDump) then {nothing}
  else if (aES = FirstSystemSeg) and (aER = ErrHelpKey) then {nothing}
  else if (aES = ExcSeg) and ((aER = ErrSegmentFault)
          or (aER = ErrStackOverflow)) then RaiseP(aES, aER, aPS, aPE)
  else if (aES = FirstSystemSeg) and (aER = ErrExitProgram) then
          Raise Exitprogram
  else if RecursiveDebug then {double recursive debug}
    begin
    WriteLn(curout^);
    Writeln(curout^,'diag aborted; Exception ',aer:1,' in ',aes:1);
    docleanup(true);
    end
  else begin
    newES := aES;
    newER := aER;
    PStart := aPS;
    PEnd := aPE;
    RecursiveDebug := true;
    UserDump := (aES = ExcSeg) and (aER = ErrDump);
    goto 1;
  end;
end; { all }

{-------------------------------------}
{  soft calls on diags enter here     }
{-------------------------------------}
   
begin
if listing then
  begin
  close(lfile);
  listing:=false;
  end;
setout(tout,curout);
{writeln(curout^,'entering diags');}
iokeyclear;
iokeyenable(true);
curwin:=0;
firstseg:=nil;
lastseg:=nil;
debugseg:=0;
everdlist:=false;
newes:=0;
newer:=0;
ctrlspending:=false;
recursivedebug:=false;
userdump:=(es=excseg) and (er=errdump);
rungotten:=false;

{--------------------------------------------}
{   interrupts enter here from handler all   }
{--------------------------------------------}

1:
IOBEEP;
if userdump and recursivedebug then exit(diags);
inlinebyte(106); { INTON }
if recursivedebug then
    if (newES = FirstSystemSegment) and
        ((newER = ErrCtlC) or (newER = ErrCtlCAbort) or
        (newER = ErrCtlShftC)) then
      begin { ^C abort while in debugger}
      IOKeyClear;
      WriteLn(curout^,'^C');
      goto 100;
      end
    else begin
      WriteLn(curout^);
      Write(curout^,'Diag aborted. Original exception was: ');
      WriteLocation(ES, ER, 0, True, True);
      WriteLn(curout^);
      Write(curout^,'New error is: ');
      ES := newES;
      ER := newER;
    end
else begin
  getwindow(curwin,i,i,i,i,wantdebug);
  changewindow(0);
  writeln(curout^);
  createsegment(debugseg,1,3,20);
  new(debugseg,256,buf.p);
  if userdump then quitflag:=false else quitflag:=true;
end;
wantdebug:=true; 
if ioinprogress then
  begin
  write(curout^,'Waiting for IO...');
  while ioinprogress do; { wait IO complete }
  writeln(curout^,'Done');
  end;

if (es=0) or (es=-1) then goto 5;

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
                        param1:=makeptr(ss,pstart+i,fsbit32);
                        write(curout^,param1^:1);
                        end;
                      end;
     errstackoverflow: Write(curout^,'stack overflow');
     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');
     ErrOvrreal:     Write(curout^,'floating point overflow');
     ErrUnderReal:   Write(curout^,'floating point underflow');
     ErrRealdivzero: Write(curout^,'floating point division by zero');
     ErrRtoiovfl:    Write(curout^,'floating point real to integer overflow');
     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=errctlshitc) then
  begin { only ctlshiftc left }
  wantdebug:=false;
  write(curout^,'Ctrl,shift-C');
  ctrlcpending:=false;
  end 
else begin
        Write(curout^,'Uncaught Exception: ');
      {$ifc DoSysNamesFirst then}
         GetSysRun;
      {$endc}
         WriteLocation(ES, ER, 0, True, false);
end;
5:

{---------------------------------------}
{    Work out AP to report down from.   }
{---------------------------------------}

Writeln(curout^);
if raiseap=0 then begin
  inlinebyte(244); { ldap }
  storexpr(raiseap);
  orgraiseap:=raiseap;{ remember original failure point }
  Diagraiseap:= raiseap;
   { lose ndiag frame on %monitor call}
  {if es=0 then begin      
    acbx := makeptr(ss,raiseap,acbptr);
    raiseap := acbx^.dl;
  end;}
  if es=-1 then begin        {rterror or ioerror}
    repeat;  {lose rterror etc frames from report }
      acbx := makeptr(ss,raiseap,acbptr);
      gdb := makeptr(ss,acbx^.gl,fsbit32);
      dchars := recast(gdb^,gdbchars);
      language := dchars[2];
      if language<>'F' then raiseap := acbx^.dl;
    until language = 'F';
  end
end else begin
  orgraiseap := raiseap;
  diagraiseap := raiseap;
end;

showall(raiseap,-1,userdump);     { Output ROUTINE TRACEBACK }

{ This is a horrible frig to get over the fact that a failure in the
private pseudo-rtns F_io etc will cause the diagnostics to fail.
Drop the ap by two to lose the F_ frame and the F77IO frame if approp.}

 
s := substr(firstrtnname,1,2);
if (s='F_') and (firstrtnname<>'F_MAIN') then begin
  acbx := makeptr(ss,raiseap,acbptr);
  raiseap := acbx^.dl;
  diagraiseap := raiseap;
  s := substr(firstrtnname,1,4);
  if s='F_IO' then begin
    acbx := makeptr(ss,raiseap,acbptr);
    raiseap := acbx^.dl
  end
end;

{ if not recursivedebug then      }
{ begin                           }
{  if not wantdebug then goto 100; }
if wantdebug then
  begin
  10:
  streamkeyboardreset(tin);
  if userdump then
    begin
    writeln(curout^);
    write(curout^,' Debug? [no] ');
    readln(tin,ans);
    strip(ans);
    if (ans=' ') or (ans='N') or (ans='NO') then goto 100;
    end;
  15:
  writeln(curout^);
  write(curout^,'< (F)ile , (L)ocals , (C)ommon and Locals , (A)ll , ? , [Quit] >:');
  readln(tin,ans);
  writeln(curout^);
  strip(ans);
  if ans='/HELP' then ans:='?';
  case ans[1] of
  'S':
    begin
    if (ans='SCROUNGE') or (ans='SC') then          {*** SCROUNGE ***} 
      begin
      dumpmess:='dump from diags';
      loadadr(dumpmess);
      storexpr(messaddr);
      inlinebyte(244); { ldap }
      storexpr(diagsap);
      scrounge(excseg,errdump,messaddr,messaddr+7,excseg,diagsap);
      end else
      begin                                       {*** SNAP ***}
      20:
      write(curout^,'[ ssn disp len ]:');
      readln(tin,ans);
      ok:=stoi(ans,dumpssn);
      if not ok then goto 20;
      ok:=stoi(ans,off);
      if not ok then goto 20;
      ok:=stoi(ans,len);
      if not ok then goto 20;
      dumpseg(dumpssn,off,len);
      if dlist then
        begin
        setout(dfile,curout);
        dumpseg(dumpssn,off,len);
        setout(tout,curout);
        end;
      end;
    end;
  '?','H':
    begin
    if (length(ans)>1) then if (ans[2]='?') then
      begin                                          {*** ?? ***}
      writeln(curout^);
      writeln(curout^,'Full diagnostic commands are:');
      writeln(curout^);
      writeln(curout^,'(SN)ap:      dump an area of store. Will prompt for seg/disp/length');
      writeln(curout^);
      writeln(curout^,'(R)aiseacb:  Print out ACB on exception.');
      writeln(curout^);
      writeln(curout^,'acb:         Print out any acb. Will prompt for stack offset.');
      writeln(curout^);
      writeln(curout^,'(D)iag:      Full diagnostic traceback. Includes Imp diagnostics');
      writeln(curout^);
      writeln(curout^,'code:        List code. Will prompt for seg/disp/len');
      writeln(curout^);
      writeln(curout^,'(COM)ment:   Place text in diagnostic output file. Prompts for text');
      writeln(curout^);
      
      writeln(curout^,'(P)roceed:   Resume execution at next instruction.');
      goto 25;
      end;
    writeln(curout^);                          {*** ? HELP ***}
    writeln(curout^,'Diagnostic commands are:');
    25:
    writeln(curout^);
    writeln(curout^,'(F)ile:    Prompts for a file to which further diagnostic output will be sent.');
    writeln(curout^,'           A reply of CONSOLE: directs future output to the screen.');
    writeln(curout^);
    writeln(curout^,'(L)ocals:  A diagnostic traceback of stack giving local variable values.');
    writeln(curout^);
    writeln(curout^,'(C)ommon:  As Locals command plus common variables.');
    writeln(curout^);
    writeln(curout^,'(A)ll:     As Common command plus contents of arrays.');
    writeln(curout^,'           (Will prompt for Arraysize - number of elements to be printed out');
    writeln(curout^,'             for each array.)');
    writeln(curout^);
    writeln(curout^,'[(Q)uit]:   The default obtained on typing <RETURN>. Returns to POS command level');
    writeln(curout^);
    writeln(curout^,'(SC)rounge:  Call scrounge.');
    writeln(curout^);
    end;
  'F':                                           {*** FILE ***}
    begin
    30:
    if dlist then
      begin
      writeln(curout^);
      writeln(curout^,'Warning - diagnostic file already selected. You may type:');
      writeln(curout^); 
      writeln(curout^,'         <RETURN> to take no action.');
      writeln(curout^,'         filename to open a new file.');
      writeln(curout^,'         console: to direct output to the screen.');
      writeln(curout^);
      end;
    write(curout^,'< filename >:');
    readln(tin,fname);
    strip(fname);
    if fname=' ' then goto 15;
    if fname=':CONSOLE' then
      begin
      dlist := false;
      setout(tout,curout);
      end else
      begin
      dlist := true;
      everdlist:=true;
      gettstring(dateandtime);
      rewrite(dfile,fname);
      setout(dfile,curout);
      writeln(curout^,dateandtime);
      setout(tout,curout);
      end
    end;
  'C':
    begin
    if (ans='COMMENT') or (ans='COM') then              {*** COMMENT ***}
      begin
      write(curout^,'[ comment ]:');
      35:
      readln(tin,ans);
      if ans='' then goto 35;
      writeln(curout^,ans);
      if dlist then writeln(dfile,ans);
      end
    else if (ans='CODE') or (ans='COD') then            {*** CODE ***}
      begin
      50:
      write(curout^,'[ssn disp len]:');
      readln(tin,ans);
      ok:=stoi(ans,dumpssn);
      if not ok then goto 50;
      ok:=stoi(ans,off);
      if not ok then goto 50;
      ok:=stoi(ans,len);
      if not ok then goto 50;
      if dumpssn=0 then dumpssn:=ss;
      param1:=makeptr(dumpssn,off,fsbit32);
      param2:=makeptr(dumpssn,off+len-1,fsbit32);
      qcode(param1,param2,recast(param1,long),0);
      if dlist then
        begin
        setout(dfile,curout);
        qcode(param1,param2,recast(param1,long),0);
        setout(tout,curout);
        end;
      end
    else begin                                             {*** COMMON ***}
      diag := 4;
      asize := 0;
      rap := raiseap;
      goto 60;
      end;
    end;
  'R':
    begin                                             {*** RAISEACB ***}
    dumpacb(orgraiseap);
    if dlist then
      begin
      setout(dfile,curout);
      dumpacb(orgraiseap);
      setout(tout,curout);
      end;
    end; 
  'A':
    begin
    if ans='ACB' then
      begin                                           {*** ACB ***}
      40:
      write(curout^,'[ ap ]:');
      readln(tin,ans);
      ok:=stoi(ans,newap);
      if not ok then goto 40;
      dumpacb(newap);
      if dlist then
        begin
        setout(dfile,curout);
        dumpacb(newap);
        setout(tout,curout);
        end;
      end
    else begin                                        {*** ALL ***}
      diag := 4;
59: write(curout^,'< Number of elements to be printed from each array? >: ');
      readln(tin,ans);
      ok := stoi(ans,len);
      if not ok then goto 59;
      asize := stretch(len);
      rap:=raiseap;
      goto 60;
      end
    end;
  'L':
    begin                                            {*** LOCALS ***}
    diag := 2;
    asize:=0;
    rap := raiseap;
    goto 60;
    end;
  'D':
    begin                                            {*** DIAG ***}
    diag:=3;
    asize:=0;
    rap := diagraiseap;
    60:
    if dlist then
      begin
      writeln(curout^);
      writeln(curout^,'Output sent to ',fname);
      writeln(curout^);
      setout(dfile,curout);
      end;
    f77diag(rap,diag,asize);
    if dlist then setout(tout,curout);
    end;    
  'Q',' ':
    begin                                            {*** QUIT ***}
    quitflag:=true;
    goto 99;
    end;
  'P':
    begin                                            {*** PROCEED ***}
    quitflag:=false;
    goto 99;
    end;
  otherwise:
    writeln(curout^,'unrecognised command');
  end;
  goto 15;
end;
99: {tidy up }
if recursivedebug and (not quitflag) then 
      begin
      recursivedebug:=false;
      quitflag:=true;
      writeln(curout^,'continuing from recursive bug');
      goto 10;
      end;
100:
docleanup(quitflag);
end; { diags }


function f77diag;
label 10,99;
type gdbchars=packed array[1..2] of char;
     list1rec=record
                ddisp,rn,props,link:fsbit16;
                name:string[31]
              end;
     list1ptr=^list1rec;
var gdb,ll,pcl,acb0,adiags:fsbit32;
    ddisp,mode,first,newacb,firstimp:long;
    cs,rn,gp,ap,pc,lp,link,ldataoff,seg:fsbit16;
    cc:char;
    acb:acbptr;
    dchars:gdbchars;
    codehd:headptr;
    codearea:codemapptr;
    ldata:ldataptr;
    ldat1:list1ptr;
begin
{writeln(curout^,'entered f77diag');}
ap:=raiseap;
acb:=makeptr(ss,ap,acbptr); { acb of raise/ndiag }
first:=1;
firstimp:=1;
while ap<>0 do
begin
  cs:=acb^.rs; { ssn of caller }
  rn:=acb^.rr; { rn of caller }
  gp:=acb^.gl; { gdb of caller }
  ap:=acb^.dl; { ap of caller }
  pc:=acb^.ra; { pc of caller }
  acb:=makeptr(ss,ap,acbptr); { acb of caller }
  gdb:=makeptr(ss,gp,fsbit32);
  dchars:=recast(gdb^,gdbchars);
  cc:=dchars[2];
  if (cc<>'F') and (cc<>'I') then
    begin
    {writeln(curout^,'no diagnostics for procedure');}
    if first=1 then write(curout^,'Diagnostics entered');
    if first=0 then write(curout^,'Entered');
    write(curout^,' from Pascal(?), Qcode:');
    writelocation(cs,rn,pc,false,false);
    writeln(curout^);
    ap:=acb^.dl; { ap of next module }
    goto 99;
    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:=ldat1^.ddisp;
      goto 10;
      end;
    link:=ldat1^.link;
    end;
  writeln(curout^,'corrupt stack - you may have to reboot!');
  exit(f77diag);
  10:
  lp:=acb^.lp;
  ll:=makeptr(ss,lp,fsbit32);
  acb0:=makeptr(ss,ap,fsbit32);
  mode:=0;
  if cc='F' then
    begin
    pcl:=makeptr(cs,pc,fsbit32);
    qfdiag(ll,gdb,pcl,acb0,adiags,ddisp,mode,diag,asize,first,newacb);
    {writeln(curout^,'returned from fortran diagnostics');}
    end else begin
      qidiag(ll,gdb,acb0,adiags,ddisp,mode,3,0,firstimp,newacb);
      firstimp:=0;
    end;
  if newacb=0 then ap:=0 else ap:=acb^.dl;
  99:
  first:=0;
  {WRITELN(CUROUT^,'exit from f77diag');}
  end;
end; { f77diag }

procedure ndiag;

var ap:fsbit16;
    acb:acbptr;
    es:fsbit16;
    
begin
{writeln(curout^,'entering ndiag');}
{writeln(curout^,'err no.=',err);}
if err<>0 then ssmess(err);
if extra=1 then es:=-1 else es:=0; {extra=1 ==> ignore all non f77 frames}
diags(raiseap,es,0,0,0); 
{writeln(curout^,'exit from ndiag');}
end; { ndiag }

procedure ssmess;
var flag,messlen:long;
    errmess:string;
begin
qrmess(stretch(i),flag,messlen,errmess);
if flag=-1 then errmess:='unknown error number';
writeln(curout^,errmess);
end. { ssmess }