module  diags;
exports

imports impprocs from impprocs;

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;


exception reseterror(filename:pathname); { also defined in module stream }


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;
     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;
     arearange=1..10;
     ldatamap=array[0..10] of fsbit16;
     ldataptr=^ldatamap;
     listrange=0..10;

var tin,tout,dfile,lfile:text;
    curout:txtptr;
    ss:fsbit16;
    dlist,listing:boolean;
    debugseg:INTEGER;
    buf:mybuf;
    firstseg,lastseg:psegnode;
    rungotten:boolean;

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

private

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

function stoi(str:string):integer;
{ converts string to integer - returns -1 if invalid string }
label 999;
var l,i,num,dig:integer;
      neg:boolean;
begin
l:=length(str);
if l=0 then goto 999;
if str[1]='-' then
  begin
  l:=l-1;
  if l=0 then goto 999;
  neg:=true;
  str:=substr(str,2,l);
  end else neg:=false;
num:=0;
for i:=1 to l do
  begin
  dig:=ord(str[i])-ord('0');
  if (dig<0) or (dig>9) then goto 999;
  num:=num*10+dig;
  end;
if neg then num:=-num;
stoi:=num;
exit(stoi);
999:
stoi:=-1;
end; { stoi }

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 8 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 }
                

function indiag(gp,ap,cs,rn:fsbit16):fsbit16;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;
       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 (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);
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  ';
   acb:=makeptr(ss,raiseap,acbptr);
   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^,'.');
     acb:=makeptr(ss,ap,acbptr);
     LocStr := 'Called from '
   until (Rtn = 0) and (Seg = FirstSystemSeg);
   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
  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 diags;
label 10,15,20,30,40;
type pstring=^string;
var ans,fname,dumpmess:string;
    raiseacb:acbptr;
    ssn,rn,gp,ap,newap,dumpssn,messaddr:fsbit16;
    wantdebug,wantshow,userdump:boolean;
    off,len,i:integer;
    param:fsbit32;
    stringparam:pstring;

begin
if (es=firstsystemseg) and (er=errexitprogram) then raise exitprogram;
wantdebug:=true; wantshow:=true;
userdump:=(es=excseg) and (er=errdump);
firstseg:=nil;
lastseg:=nil;
debugseg:=0;
createsegment(debugseg,1,3,20);
new(debugseg,256,buf.p);
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) then
  begin
  wantdebug:=false;
  if (ER = ErrCtlC) or (ER = ErrCtlCAbort) then Write(curout^,'Control-C Abort')  else if er=errctlshftc then
    begin
    write(curout^,'Ctrl,shift-C');
    wantshow:=false;
    end;
  end { only other exception in firtsysseg is exitprogram }
else begin
        Write(curout^,'Uncaught Exception: ');
      {$ifc DoSysNamesFirst then}
         GetSysRun;
      {$endc}
         WriteLocation(ES, ER, 0, True, false);
end;
if not wantshow then raise exitprogram;
Writeln(curout^);
raiseacb:=makeptr(ss,raiseap,acbptr);
ssn:=raiseacb^.rs; { ssn of caller }
rn:=raiseacb^.rr; { rn of caller }
gp:=raiseacb^.gl; { gdb of caller }
ap:=raiseacb^.dl; { ap of caller }
showall(raiseap,-1,userdump);
if not wantdebug then raise exitprogram;
10:
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 RAISEACB ACB FILE INDIAG SCROUNGE QUIT ]:');
readln(tin,ans);
if ans='dump' then
  begin
  20:
  write(curout^,'[ ssn disp len ]:');
  readln(tin,dumpssn,off,len);
  if (ssn<0) or (off<0) or (len<0) then goto 20;
  dumpseg(dumpssn,off,len);
  if dlist then
    begin
    setout(dfile,curout);
    dumpseg(dumpssn,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='raiseacb' then dumpacb(raiseap)
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 
  begin
  dumpmess:='dump from diags';
  loadadr(dumpmess);
  storexpr(messaddr);
  scrounge(excseg,errdump,messaddr,messaddr+7,excseg,loadap);
  end
else if ans='quit' then
  begin
  if dlist then close(dfile);
  if userdump then exit(diags) else raise exitprogram;
  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
ap:=loadap;
acball:=makeptr(ss,ap,acbptr); {acb of all }
raiseap:=acball^.dl; {ap of raise }
diags(raiseap,es,er,pstart);
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,newacb:fsbit32;
    ddisp,mode,diag,asize,first:long;
    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:=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);
mode:=0;
diag:=2;
asize:=8;
first:=1;
qindiag(ll,gdb,acb0,adiags,ddisp,mode,diag,asize,first,newacb);
loadadr(newacb);
storexpr(ap);
writeln(curout^,'newacb disp is',ap:4:-16);
indiag:=ap;
end. { indiag }