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; 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; 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); {stop trace back on RUN and hide bottom stack from user} if (rtn=1) and (segname='F77INIT') 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 '; acb:=makeptr(ss,raiseap,acbptr); stopshowall := false; 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)) 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,28,30,35,40,50,59,60,99,100; type pstring=^string; 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; 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 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: 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 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: Writeln(curout^); if raiseap=0 then begin inlinebyte(244); { ldap } storexpr(raiseap); if es=0 then begin {ndiag entry} acbx := makeptr(ss,raiseap,acbptr); raiseap := acbx^.dl {lose ndiag frame from report} end end; showall(raiseap,-1,userdump); writeln(curout^); { if not recursivedebug then } { begin } { if not wantdebug then goto 100; } if wantdebug then begin 10: streamkeyboardreset(tin); 15: write(curout^,'< (F)ile , (L)ocals , (C)ommon and Locals , (A)ll , ? , [Quit] >:'); readln(tin,ans); strip(ans); if ans='/HELP' then ans:='?'; if (ans='SNAP') or (ans='SN') then {*** SNAP ***} begin 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 else if ans='??' 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^,'(SC)rounge: Call scrounge. You cannot return to F77 diagnostics.'); writeln(curout^); writeln(curout^,'(P)roceed: Resume execution at next instruction.'); writeln(curout^); goto 28; end else if (ans='?') or (ans='HELP') then begin {*** ? HELP ***} 28: if (ans='?') or (ans='HELP') then begin writeln(curout^); writeln(curout^,'Diagnostic commands are:'); end; 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 . Returns to POS command level'); writeln(curout^); end else if (ans='FILE') or (ans='F') then {*** FILE ***} begin 30: if dlist then begin writeln(curout^); writeln(curout^,'Warning - diagnostic file already selected. You may type:'); writeln(curout^); writeln(curout^,' 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 else 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='RAISEACB') or (ans='R') then {*** RAISEACB ***} begin dumpacb(raiseap); if dlist then begin setout(dfile,curout); dumpacb(raiseap); setout(tout,curout); end; end else if (ans='ACB') then {*** ACB ***} begin 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 if (ans='LOCAL') or (ans='L') then begin {*** LOCALS ***} diag := 2; asize:=0; goto 60; end else if (ans='COMMON') or (ans='C') then begin {*** COMMON ***} diag := 4; asize := 0; goto 60; end else if (ans='ALL') or (ans='A') then 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); goto 60; end else if (ans='DIAG') or (ans='D') then {*** DIAG ***} begin diag:=3; asize:=0; 60: if dlist then begin writeln(curout^); writeln(curout^,'Diagnostic directed to ',fname); writeln(curout^); setout(dfile,curout); end; f77diag(raiseap,diag,asize); if dlist then setout(tout,curout); 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 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 if (ans='QUIT') or (ans='Q') or (ans='') then {*** QUIT ***} begin quitflag:=true; goto 99; end else if (ans='PROCEED') or (ans='P') then {*** PROCEED ***} begin quitflag:=false; goto 99; end else writeln(curout^,'unrecognised command'); 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: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 } 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 calling procedure'); 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^,'help - entry point record not found'); exit(f77diag); 10: lp:=acb^.lp; ll:=makeptr(ss,lp,fsbit32); acb0:=makeptr(ss,ap,fsbit32); mode:=0; first:=1; 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 qidiag(ll,gdb,acb0,adiags,ddisp,mode,3,0,first,newacb); if newacb=0 then ap:=0 else ap:=acb^.dl; 99: {WRITELN(CUROUT^,'exit from f77diag');} end; end; { f77diag } procedure ndiag; var ap:fsbit16; acb:acbptr; begin {writeln(curout^,'entering ndiag');} writeln(curout^,'err no.=',err); if err<>0 then ssmess(err); diags(raiseap,0,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 }