Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-ots-debugger/forerr.mac
There are 27 other files named forerr.mac in the archive. Click here to see a list.
SEARCH FORPRM
TV FORERR ERROR HANDLER,6(2031)
;COPYRIGHT (C) 1981 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
COMMENT \
***** Begin Revision History *****
1100 CKS 13-Jun-79
New
1403 DAW 6-Apr-81
Get rid of magic JOBDAT numbers that prevents users
from loading FOROTS at places other than 400K.
1437 DAW 17-Apr-81
Change FILOP error code 12 from "No such device" to "Can't OPEN
device"-- open of LPT could cause this.
1464 DAW 21-May-81
Put all "ERR" and "IOERR" messages in this file.
1473 CKS 21-May-81
Many error message fixes.
1504 BL 1-Jun-81 Q10-06141
Prevent TRACEBACK default call from displaying itself.
1532 DAW 14-Jul-81
OPEN rewrite: Base level 1
1533 DAW 14-Jul-81
Errors that were supposed to print input record didn't.
Also they would mess up the error message text for ERRSNS.
1537 DAW 16-Jul-81
More work on OPEN for TOPS-20.
1560 DAW 28-Jul-81
OPEN rewrite: Base level 2
1573 DAW 31-Jul-81
Eliminate typing random CRLF's when ERR= branch taken.
1603 DAW 12-Aug-81
Don't type statement name more than once if many IOERR's
are done.
1611 DAW 17-Aug-81
"%integer overflow" bombed out pgm instead of continuing..
1624 DAW 21-Aug-81
"?Illegal record number" got record number from wrong ac.
1625 DAW 21-Aug-81
Get rid of "DF".
1630 JLC 24-Aug-81
Illegal magtape OP's now illegal.
1642 JLC 27-Aug-81
Replace %FILOP calls with FILOPs.
1645 DAW 28-Aug-81
Get to column 1 before errors on TOPS-10.
1651 DAW 31-Aug-81
Do TRMOP. function to wait for output done before getting HPOS.
(Fix to 1645).
1652 DAW 1-Sep-81
Make "IOE" a "?" error.
1656 DAW 2-Sep-81
Get rid of magic numbers.
1661 BL 4-Sep-81
Fix incorrect info coming from TRACE; & illegal instruction return.
1662 DAW 4-SEP-81
%CALU; user error handling routine.
1665 DAW 8-Sep-81
D.TTY hack.
1706 DAW 11-Sep-81
Lots of changes to error messages, codes, etc.
1725 DAW 18-Sep-81
Better error reporting in OPEN args & dialog strings.
1737 DAW 23-Sep-81
Fix "RBR" error.
1753 DAW 29-Sep-81
IOERR's and LERR's to type the PC.
1760 JLC 5-Oct-81
Print 2 decimal places for time typouts.
1762 DAW 6-Oct-81 Q10-06581
Don't print format with error in wrong place.
1763 DAW 7-Oct-81
Fatal error "?Can't write to LINED file".
1766 DAW 7-Oct-81
Don't type PC flags as part of the PC.
1773 DAW 8-Oct-81
Change "CMU" to "IEM" - internal error in mem. management.
1774 DAW 8-Oct-81
Change message for FILOP. code 52 to "Device is assigned by
another job".
2003 BL 14-Oct-81 Q10-06574
Change data type "0" from "U" to "I".
2013 DAW 19-Oct-81
Fix TRACE to store "..." at end of string, not into a literal.
2022 DAW 22-Oct-81
Better error message for TOPS-20 when the JFNs run out.
2031 DAW 27-Oct-81
Fix smashing of AC if no symbols loaded.
***** End Revision History *****
\
ENTRY FORER%,%forer,%ERARG
ENTRY %ERRST,%EMSGT,%FOREC,%ERSVV,%ERRRS
ENTRY TRACE%,%TRACE
IFN FTSHR,<
EXTERN F.CODE,Z.ERR,F.HSM >
EXTERN %SAVE,%SAVE1,%SAVE2,%SAVE3
EXTERN %APRCT,%APRLM,%APRSB
EXTERN %POPJ,%POPJ1,%ABORT,%CRLF
IF10,< EXTERN I.MSG,G.IS,%TIOS,%RESP >
IF20,< EXTERN G.LJE >
EXTERN I.SA,G.FERR,I.FLAG
EXTERN %RPOS,%SPOS,%IBYTE,%OBYTE
EXTERN %OPNK1,%OPNV1,%OPNK2,%OPNV2
EXTERN FMT.BP,FMT.BG,FMT.SZ
EXTERN %IONAM
IF10,< EXTERN %ARGNM ;Name of argument where error occured.
EXTERN %NCHRR ;# chars parsed in string
EXTERN %SRCBP ;Current BP to source string containing error.
>;END IF10
EXTERN I.RUNTM
EXTERN U.ERR ;If errors are diverted, this is non-zero.
EXTERN D.TTY ;DDB address of TTY: (if OPEN)
EXTERN %CALU ;Routine to call a user error handling routine.
SEGMENT ERR
; *** LIST OF FOROTS ERRORS ***
RADIX 10
; *** The following errors do NOT type a filename ***
ERR (SNH,?,Internal FOROTS error at $P)
ERR (EDE,$,$A error at $1L,<T1,%IONAM,T3>)
ERR (INI,?,INQUIRE not implemented)
ERR (IEM,?,FOROTS internal error in memory management)
ERR (MFU,?,Memory full)
ERR (APR,%,$A at $1L,<T3,T2>)
ERR (FFX,?,FOROP function code exceeds range)
ERR (TIM,,CPU time $Y Elapsed time $Y,<I.RUNTM,T1>)
ERR (SM1,,$D$3T$A$A,<T2,T4,T3>)
ERR (CLA,%,CLOSE unit $D: arguments ignored because unit is not open,<T2>)
ERR (RFN,[,Attempted RENAME to $F)
ERR (NAM,$,$A unit $D $F at $1L,<T2,%IONAM,T1,T3>)
IF20,<
ERR (IJE,?,"Impossible" JSYS error at $P - $J)
ERR (IGN,?,Illegal generation number $A,<0(L)>)
>;END IF20
IF10,<
ERR (DST,$,Error in dialog string,<T2>)
ERR (CCP,?,Can't create page $O (PAGE. error $O),<T1,P4>)
ERR (CDP,?,Can't destroy page $O (PAGE. error $O),<T2,T1>)
>;END IF10
; *** IO ERRORS **
;These type out the filename first, set ERSNS numbers,
; take ERR= branch if specified.
;0 -- No error detected
IOERR (EFS,0,0,[,Enter correct file specs)
IF10, IOERR (QUE,0,0,[,$A,<[%RESP]>)
;23 -- Error in magtape operations
IF20, IOERR (ILM,23,0,?,Unexpected MTOPR% error: $J)
IF10,<
IOERR (UTE,23,530,?,Unexpected TAPOP error $O,<T1>)
IOERR (UME,23,531,?,Unexpected MTCHR error $O,<T1>)
IOERR (UTO,23,537,?,Unexpected TAPOP. error $O trying to set $A,<T3,P1>)
>
;24 -- End of file
IOERR (EOF,24,-1,?,End of file)
;25 -- Record or record number error
IOERR (BBF,25,302,?,Bad format binary file)
IOERR (RNR,25,510,?,Record $D has not been written,<T1>)
IOERR (IRN,25,512,?,Illegal record number $D,<T3>)
IF20, IOERR (CBI,25,536,?,Can't backspace image file with no RECORDSIZE)
;28 -- CLOSE error
IF20, IOERR (CLF,28,0,?,Can't CLOSE file: $J)
IF20, IOERR (RNM,28,0,?,Can't rename file: $J)
IF10, IOERR (CLS,28,250,?,CLOSE failed, $I,<T1>) ;Type IO error bits
IF10, IOERR (DEL,28,250,?,Can't delete file: $E,<T1>)
IF10, IOERR (RNM,28,250,?,Can't rename file: $E,<T1>)
IF20, IOERR (FD1,28,527,?,File to RENAME is not on DISK)
IF10, IOERR (FD1,28,527,?,File to RENAME is not on DISK or DECTAPE)
IF20, IOERR (FD2,28,528,?,File to RENAME to is not on DISK)
IF10, IOERR (FD2,28,528,?,File to RENAME to is not on DISK or DECTAPE)
IOERR (DSS,28,549,%,DISPOSE='SAVE' assumed - device is not disk)
IF10, IOERR (CQF,28,550,%,<Can't queue file, QUEUE. error $O>,<T1>)
;30 -- OPEN error
IF20, IOERR (OPE,30,0,?,Can't OPEN file: $J)
IF20, IOERR (UFS,30,0,?,Can't switch file to UNFORMATTED: $J)
IF20, IOERR (UMO,30,0,%,$J trying to set tape $A,<P1>)
IF20, IOERR (APP,30,0,?,Can't setup to append to magtape file: $J)
IOERR (RRR,30,240,?,Random IO requires /RECORDSIZE)
IOERR (RR1,30,240,?,Random IO requires RECORDSIZE specifier in OPEN statement,,I%UNI)
IF10, IOERR (NFC,30,242,?,Too many open units)
IF20, IOERR (NSD,30,245,?,No such device $A,<T1>)
IF10, IOERR (NSD,30,245,?,No such device $S,<DEV(D)>)
IOERR (IAC,30,248,?,/ACCESS:$Z illegal for this device,<T1>)
IOERR (IDM,30,249,?,/MODE:$Z illegal for this device,<T1>)
IF10, IOERR (OPN,30,250,?,Can't OPEN file: $E,<T1>)
IF20, IOERR (PPN,30,405,?,Error translating PPN to DIRECTORY: $J)
IOERR (ISW,30,506,?,Incompatible attributes /$Z$Z /$Z$Z,<%OPNK1,%OPNV1,%OPNK2,%OPNV2>)
IOERR (SNM,30,523,?,No filespec information allowed for SCRATCH files)
IOERR (BSI,30,535,%,BLOCKSIZE ignored: device is not a magnetic tape)
IOERR (SDO,30,540,?,Same device open on unit $D with conflicting specifiers,<T2>)
;31 -- Mixed ACCESS modes
IOERR (CDI,31,315,?,Can't do $A I/O to $A file,<T2,T3>)
;32 -- Illegal logical unit number
IOERR (IUN,32,239,?,Illegal unit number $D,<T2>,I%UNI)
;39 -- REREAD error
IOERR (RBR,39,310,?,REREAD not proceeded by READ,,I%UNI)
;45 -- OPEN/CLOSE statement syntax error
IF20, IOERR (JSE,45,0,?,$J)
IF20, IOERR (JSA,45,0,?,$J - $Z,<T1>) ;For COMND errors
IOERR (ESV,45,241,?,$A keyword value /$Z$Z,<P2,T1,T5>)
IF10, IOERR (USW,45,241,?,Unknown switch /$S,<T5>)
IF10, IOERR (ASW,45,241,?,Ambiguous switch /$S,<T5>)
IOERR (DTL,45,533,?,Dialog string too long)
IF20, IOERR (EDS,45,539,?,Error in dialog string - $J)
IF20, IOERR (EDA,45,539,?,Error in dialog string - $J - $Z,<T1>) ;For COMND errors
IOERR (UOA,45,541,%,<Unknown OPEN keyword $D, ignored>,<P1>)
IOERR (NCK,45,542,%,$Z in CLOSE is meaningless - ignored,<T1>)
IOERR (RND,45,543,%,No filename specified-- DISPOSE='RENAME' ignored)
IF10, IOERR (NDI,45,544,?,No device specified with ":")
IF10, IOERR (IPP,45,545,?,Illegal PPN)
IF10, IOERR (TMF,45,546,?,Too many SFDs)
IF10, IOERR (NSI,45,547,?,Null SFD)
IF10, IOERR (IDD,45,548,?,Illegal character $C in $A argument,<T1,%ARGNM>,I%TCH)
IOERR (NQS,45,551,?,PADCHAR must be single char in double quotes)
;47 -- WRITE on READ-only file
IOERR (CDT,47,263,?,Can't $A an $A-only file,<T1,T2>)
IOERR (CWL,47,554,?,Can't write a file with MODE='LINED')
;59 -- List-directed input data error
IOERR (IDL,59,313,?,Illegal delimiter in list-directed input,,I%REC)
;62 -- Syntax error in FORMAT
IOERR (ILF,62,301,?,Illegal character in format,,I%FMT)
IOERR (DLF,62,306,?,Data in IO list but not in format,,I%FMT)
IOERR (ARC,62,532,?,Ambiguous repeat count,,I%FMT)
IOERR (IRC,62,538,?,Illegal repeat count,,I%FMT)
IOERR (IHC,62,552,?,Illegal Hollerith constant,,I%FMT)
IOERR (IFW,62,553,?,Illegal field width,,I%FMT)
;63 -- Output conversion error
IOERR (ETL,63,509,%,Record length exceeds string length) ;ENCODE
IOERR (FTS,63,534,%,Output field width too small)
;64 -- Input conversion error
IOERR (ILC,64,307,?,Illegal character in data,,I%REC)
IOERR (IL1,64,307,?,Illegal character in data,,I%REC1)
IOERR (IOV,64,571,%,Integer overflow,,I%REC)
;81 -- FOROTS calling error
IOERR (UNS,81,501,?,Unit not specified,,I%UNI)
IOERR (WNA,81,504,?,<Wrong number of arguments>)
IOERR (IOL,81,508,?,Bad IO list)
;799 -- Unclassifiable data error
IOERR (VNN,799,309,?,Variable $S not in namelist,<T1>,I%REC)
IOERR (NEQ,799,513,?,Found "$C" when expecting "=",<T1>,I%REC)
IOERR (NRP,799,514,?,Missing right paren,,I%REC)
IOERR (ILN,799,515,?,Variable or namelist does not start with letter,,I%REC)
IOERR (ILS,799,516,?,Illegal Subscript,,I%REC)
IOERR (CCC,799,519,?,Can't convert constant to correct type,,I%REC)
IOERR (STL,799,520,?,Alpha string too long,,I%REC)
IOERR (RPE,799,521,?,Illegal repeat count,,I%REC) ;In NAMELIST
IOERR (SNV,799,522,?,Sign with null value,,I%REC)
;899 -- Unclassifiable device errors
IF20, IOERR (OSW,899,0,?,Can't switch to output: $J)
IF10, IOERR (OSW,899,250,?,Can't switch to output: $E,<T1>)
IF20, IOERR (INP,899,401,%,$J) ;Input error bits - warn user
IF20, IOERR (INX,899,401,?,$J) ;Too many "INP" errors happened
IF20, IOERR (OUT,899,401,%,$J) ;Output error bit - warning
IF20, IOERR (OUX,899,401,?,$J) ;Too many "OUT" errors happened
IF20, IOERR (INY,899,401,?,$J) ;Input error bits (DISK) fatal.
IF20, IOERR (OUY,899,401,?,$J) ;Output error bits (DISK) fatal.
IF10, IOERR (IOE,899,400,?,$I,<T1>) ;General-purpose I/O error
RADIX 8
;HERE FROM ERROR MACROS
;
;CALLS:
;
; ERR (COD,CHR,MSG,ARGS)
; LERR (COD,CHR,MSG,ARGS)
;
;COD 3-CHARACTER PREFIX
;CHR INITIAL CHAR FOR ERROR MESSAGE ([, %, ?)
; IF [, MESSAGE IS TERMINATED WITH ]
; IF ?, TYPEAHEAD CLEARED AFTER MESSAGE
; IF NULL, 3-CHAR PREFIX ISN'T TYPED
; IF $, FIRST ARG IS INITIAL CHAR
;MSG TEXT OF ERROR MESSAGE
; $ INDICATES AN ARG TO BE SUBSTITUTED INTO THE MESSAGE
; THE CHAR AFTER THE $ GIVES THE FORMAT OF THE SUBSTITUTION
;ARGS LIST OF ARGUMENT ADDRESSES, ONE-TO-ONE CORRESPONDENCE WITH $S
; IN MESSAGE TEXT
;
;THE ERR AND LERR MACROS GENERATE 1 WORD IN LINE, SO CAN BE SKIPPED OVER.
;LERR DOES NOT ALTER ANY ACS, AND ERR DOES NOT ALTER ANY EXCEPT T0.
'FORER.' ;LERR ENTRY, FOR FORLIB USE
FORER%: POP P,T1 ;RESTORE T1, SAVED BY ENTRY CODE
PUSHJ P,SVEACS ;Save acs in ERRACS
POP P,P1 ;GET POINTER TO ERROR ARG BLOCK
POP P,T1 ;GET ARG COUNT
JUMPE T1,LIMCHK ;IF NONE, SKIP ARG TRANSFER
MOVEI T2,%ERARG-1(T1) ;SET DESTINATION ADDRESS FOR TRANSFER
ARGXFR: POP P,(T2) ;MOVE AN ARG FROM STACK TO %ERARG LIST
SUBI T2,1 ;INCREMENT DEST ADDRESS
SOJG T1,ARGXFR ;MOVE ALL ARGS
LIMCHK: PUSHJ P,GTCONT ;Get continue address
SETOM LIBFLG ;FLAG ERROR IS FROM LIBRARY
MOVE F,I.FLAG ;CLEAR FLAGS
AOS T1,%APRCT+.ETLRE ;INCREMENT LIBRARY ERROR COUNT
CAMLE T1,%APRLM+.ETLRE ;PAST LIMIT?
JRST ERET ;YES, RETURN WITHOUT TYPING MESSAGE
MOVE P2,P1 ;Save P1 (GETPC uses it)
XMOVEI P1,(P) ;Point to current stack position
PUSHJ P,GETPC
MOVEM T1,LERRPC ;Store PC for the LERR message
MOVE P1,P2 ;Restore ptr to error block
JRST %FOREC ;Continue below
;ERR ENTRY, FOR INTERNAL FOROTS USE
%FORER: PUSHJ P,%ERRST ;Get set to start error message
;Enter here from %IOERR or LERR to get message text and
; type out the error, then continue at the appropriate address.
%FOREC: PUSHJ P,EMSGT0 ;Get error message text
SKIPN LIBFLG ;LERR?
JRST FOREC1 ;No
PUSHJ P,ADDPCM ;Add PC to message text.
FOREC1: PUSHJ P,EMSGT1 ;Append null to string so can output msg.
MOVE T1,INICHR ;Get initial char
PUSHJ P,POSEFL ;if ?, do a CLRBFI; position to column 1
MOVEI T1,ERRBUF ;POINT TO MESSAGE
PUSHJ P,%EOREC## ;TYPE MESSAGE
MOVE T1,0(P1) ;GET FLAGS
TRNE T1,I%REC ;TYPE RECORD WITH ARROW UNDER IT IF REQUESTED
JRST RECT0
TRNE T1,I%REC1 ;TYPE RECORD WITH ARROW MOVED OVER 1
JRST RECT1
TRNE T1,I%FMT ;TYPE FORMAT WITH ARROW UNDER IT
JRST [PUSHJ P,FMTTYP
JRST ERET]
IF10,<
TRNE T1,I%TCH ;Type character string in error?
PUSHJ P,CHSTYP
>;END IF10
JRST ERET ;Done
;Type REC with arrow under it
RECT0: PUSHJ P,RECTYP
JRST RECT2 ;Go see if also type FORMAT
;Type REC with arrow under .-1
RECT1: PUSHJ P,RECTY1
RECT2:
; JRST ERET
;Call user routine (if specified)
ERET: SKIPE LIBFLG ;ERROR FROM LIBRARY ROUTINE?
SKIPN T1,%APRSB+.ETLRE ;YES, ANY USER TRAP ROUTINE SPECIFIED?
JRST ERET1 ;NO, GO RETURN
MOVEI T2,1(P) ;PUSH ERRACS SO USER ROUTINE CAN CALL FORERR
HRLI T2,ERRACS
ADJSP P,17
BLT T2,(P)
PUSH P,CONT ;And continue address
MOVEI T2,.ETLRE ;T2= error number
MOVE T3,ERRPC ;T3= PC
PUSHJ P,%CALU ;** Call user routine **
POP P,CONT ;Restore our continue address
ADJSP P,-17 ;POP ERRACS
MOVSI T1,1(P)
HRRI T1,ERRACS
BLT T1,ERRACS+16
ERET1: MOVE T1,CONT ;Continue from error
XMOVEI T1,(T1)
MOVEM T1,CONT ;Get address we can JRST @
MOVSI 16,ERRACS ;RESTORE 0-16
BLT 16,16
JRST @CONT ;Continue from error
SEGMENT DATA
CONT: BLOCK 1 ;Continue address from errors
RTADRE: BLOCK 1 ;Return address from various routines
; (Useful if the routine has to mess
; with the stack).
ERRSRA: BLOCK 1 ;Return address from %ERRST
LERRPC: BLOCK 1 ;Pc to type out in LERR.
SEGMENT ERR
;%ERRST - Routine to setup for ERR or IOERR
;Call: PUSHJ P,%ERRST ;at the start
; <return here>
;Saves the acs in ERRACS, clears LIBFLG, gets return address
%ERRST: POP P,ERRSRA ;Get return address of this routine
PUSHJ P,SVEACS ;Save the acs
POP P,P1 ;Get ptr to arg address
PUSHJ P,GTCONT ;Get continue address
SETZM LIBFLG ;Note error is from inside FOROTS
JRST @ERRSRA ;Return
;Routine to save the acs in ERRACS
;Call: PUSHJ P,SVEACS
; <return here>
SVEACS: POP P,RTADRE ;Get return address from this routine
MOVEM 17,ERRACS+17 ;SAVE ALL ACS
MOVEI 17,ERRACS
BLT 17,ERRACS+16
MOVE 17,ERRACS+17
JRST @RTADRE ;Return from SVEACS
;Routine to get continue address
;Call:
; PUSHJ P,GTCONT
; <return here>
; This routine sets CONT to continue address (or 0 if none supplied),
; and finds ERRPC = PC of the error PUSHJ.
GTCONT: POP P,RTADRE ;Get return address from routine
SETZM CONT ;Assume no continue address
MOVE T1,0(P) ;See if top of stack is continue address
TLC T1,-1
TLCN T1,-1 ;Skip if it's not
POP P,CONT ;It is, get it
POP P,T1 ;Get return PC of error call
SKIPN CONT ;Did we get a continue address?
MOVEM T1,CONT ;No, store it
SOJ T1, ;Decrement to get PC of the PUSHJ
MOVEM T1,ERRPC
JRST @RTADRE ;Return from GTCONT
;%ERSVV - Save error parameters on stack so we can call ERR again
;Called from %IOERR routine.
%ERSVV: POP P,RTADRE ;Get return address
MOVEI T1,1(P) ;Push ERRACS
HRLI T1,ERRACS
ADJSP P,17
BLT T1,(P)
PUSH P,CONT ;Push continue address
MOVEI T2,^D6 ;Push err macro's args
PUSH P,%ERARG(T2)
SOJGE T2,.-1
JRST @RTADRE ;Return from %ERSVV
;%ERRRS - Restore error parameters
;Called from %IOERR routine as compliment to %ERRSV
%ERRRS: POP P,RTADRE ;Get return address
MOVSI T2,-<^D6+1> ;Pop err macro's args
POP P,%ERARG(T2)
AOBJN T2,.-1
POP P,CONT ;POP continue address
ADJSP P,-17 ;POP ERRACS
MOVSI T1,1(P)
HRRI T1,ERRACS
BLT T1,ERRACS+16
ANDX F,F%NION ;Remember flags possibly set
IORM F,ERRACS+F ; in %IOERR
JRST @RTADRE ;Return from %ERRRS
;%EMSGT - Get error message text in ERRBUF.
; This routine just sets it up, it does not type it.
; (In case of taking the ERR= branch you don't want to!).
;Input:
;P1 points to error arg block.
%EMSGT: PUSHJ P,EMSGT0 ;Get message text with no null
;Enter here to append null to error string
EMSGT1: SETZ T1, ;And store a null
IDPB T1,ERRPTR
POPJ P, ;Return
EMSGT0: MOVEI P2,2(P1) ;MAKE POINTER TO INPUT ERROR STRING
HRLI P2,(POINT 7,)
MOVE T1,[POINT 7,ERRBUF] ;SET POINTER TO START OF OUTPUT ERR STRING
MOVEM T1,ERRPTR
MOVEI T1,5*LERRBF-1 ;SET COUNT (LEAVE SPACE FOR A NULL)
MOVEM T1,ERRCNT
MOVEI T1,%ERARG-1 ;SET POINTER TO START OF ARGS
MOVEM T1,ARGPTR
LDB T1,[POINT 7,0(P1),6] ;GET INITIAL PREFIX CHAR
CAIN T1,"$" ;INDIRECT CHAR?
PUSHJ P,GETARG ;YES, GET PREFIX CHAR
MOVEM T1,INICHR ;SAVE IT
PUSHJ P,TYPEQM ;Type it.
ENXTCH: ILDB T1,P2 ;GET NEXT CHAR FROM MSG
JUMPE T1,ETYPIT ;END, GO TYPE IT
CAIE T1,"$" ;SPECIAL CHAR?
JRST ECHR ;NO, JUST NORMAL TEXT CHAR
SETZ T2, ;CLEAR ARG
ERARGL: ILDB T1,P2 ;GET CHAR AFTER $
CAIL T1,"0" ;DIGIT?
CAILE T1,"9"
JRST ERRCMD ;NO, GO EXECUTE COMMAND CHAR
IMULI T2,^D10 ;ADD DIGIT INTO ARGUMENT
ADDI T2,-"0"(T1)
JRST ERARGL ;GO FINISH ARG
ERRCMD: MOVEM T2,ERRARG ;SAVE ARGUMENT TO COMMAND
MOVSI T2,-LERRTB ;GET AOBJN POINTER TO ERR TABLE
ERTBLP: HLRZ T3,ERRTAB(T2) ;GET CHAR
CAIE T1,(T3) ;MATCH?
AOBJN T2,ERTBLP ;NO, KEEP LOOKING
JUMPGE T2,ENXTCH ;NOT FOUND, IGNORE
HRRZ T2,ERRTAB(T2) ;GET ROUTINE ADDRESS
PUSHJ P,(T2) ;CALL ROUTINE
JRST ENXTCH ;LOOP
ECHR: PUSHJ P,EPUTCH ;PUT CHAR IN OUTPUT STRING
JRST ENXTCH ;LOOP
ETYPIT: MOVE T1,INICHR ;GET INITIAL CHAR AGAIN
CAIE T1,"[" ;OPEN BRACKET?
POPJ P, ;No, return now
MOVEI T1,"]" ;YES, TYPE CLOSING BRACKET
PJRST EPUTCH ; and return
;TABLE OF SPECIAL CHAR ACTIONS IN MESSAGES
ERRTAB: XWD "$",$$ ;TYPE $
XWD "[",$LAB ;TYPE LEFT ANGLE BRACKET
XWD "O",$O ;OCTAL NUMBER
XWD "D",$D ;DECIMAL NUMBER
XWD "A",$A ;ASCIZ STRING
XWD "C",$C ;ASCII CHAR, RIGHT-JUSTIFIED
XWD "S",$S ;SIXBIT WORD
XWD "X",$X ;XWD FORMAT, OCTAL
XWD "5",$5 ;RADIX50 WORD
XWD "L",$L ;ADDRESS AS LABEL+OFFSET
XWD "T",$T ;SPACES TO GET TO COL N
IF20,< XWD "J",$J > ;JSYS ERROR MESSAGE [NO ARG]
XWD "Y",$Y ;MS TIME AS HH:MM:SS.S
XWD "P",$P ;ERROR PC, OCTAL [NO ARG]
IF10,< XWD "E",$E > ;LOOKUP/ENTER/RENAME ERROR STRING
IF10,< XWD "I",$I > ;IO ERROR BITS CONVERTED TO ASCII [USES (D)]
XWD "F",$F ;FILESPEC FROM DDB [NO ARG, USES (D)]
IF10,< XWD "Z",$Z > ;SIXBIZ OR ASCIZ STRING
IF20,< XWD "Z",$A > ;SIXBIZ OR ASCIZ STRING
LERRTB==.-ERRTAB
$LAB: SKIPA T1,["<"] ;TYPE LEFT ANGLE BRACKET [BALANCING >]
$$: MOVEI T1,"$" ;TYPE $
PJRST EPUTCH
$D: PUSHJ P,GETARG ;GET NUMBER TO TYPE
DNOUT: JUMPGE T1,DPOS ;ALL OK IF IT'S POSITIVE
PUSH P,T1 ;NEGATIVE, TYPE MINUS SIGN
MOVEI T1,"-"
PUSHJ P,EPUTCH
POP P,T1
MOVM T1,T1
DPOS: MOVEI T3,^D10 ;RADIX 10
JRST NUMLP
$C: PUSHJ P,GETARG
CAIL T1," "
PJRST EPUTCH
PUSH P,T1
MOVEI T1,"^"
PUSHJ P,EPUTCH
POP P,T1
ADDI T1,100
PJRST EPUTCH
$S: PUSHJ P,GETARG
SIXTYP: MOVE T2,T1
S1: JUMPE T2,%POPJ
SETZ T1,
LSHC T1,6
ADDI T1,40
PUSHJ P,EPUTCH
JRST S1
$X: PUSHJ P,GETARG
XWDTYP: PUSH P,T1
HLRZ T1,T1
PUSHJ P,OCTTYP
MOVEI T1,","
PUSHJ P,EPUTCH
POP P,T1
MOVEI T1,(T1)
PJRST OCTTYP
$OFFS: PUSHJ P,GETARG ;GET ARG
OFFTYP: JUMPE T1,%POPJ ;DON'T TYPE 0
PUSH P,T1 ;SAVE IT
CAIGE T1,0 ;POSITIVE?
SKIPA T1,["-"] ;NO
MOVEI T1,"+" ;YES
PUSHJ P,EPUTCH ;TYPE SIGN
POP P,T1
MOVM T1,T1
JRST OCTTYP ;TYPE OCTAL NUMBER
$O: SKIPE ERRARG ;$1O MEANS TYPE SIGN FIRST
JRST $OFFS
PUSHJ P,GETARG ;GET ARG IN T1
OCTTYP: MOVEI T3,^D8
NUMLP: LSHC T1,-^D35
LSH T2,-1
DIVI T1,(T3)
JUMPE T1,.+4
PUSH P,T2
PUSHJ P,NUMLP
POP P,T2
MOVEI T1,"0"(T2)
PJRST EPUTCH
$P: HRRZ T1,ERRPC ;GET PC OF ERROR
PJRST OCTTYP ;TYPE IT IN OCTAL
$Y: PUSHJ P,GETARG ;GET TIME IN MS
ADDI T1,5 ;ROUND TO HUNDREDTHS
IDIVI T1,^D10
IDIVI T1,^D100 ;GET SECONDS AND HUNDREDTHS
PUSH P,T2 ;SAVE HUNDREDTHS
PUSHJ P,XTIME ;TYPE HH:MM:SS
MOVEI T1,"." ;TYPE .S
PUSHJ P,EPUTCH
POP P,T1 ;GET HUNDREDTHS
IDIVI T1,^D10 ;BREAK INTO 2 DIGITS
ADDI T1,"0" ;MAKE ASCII
PUSHJ P,EPUTCH ;OUTPUT IT
MOVEI T1,"0"(T2) ;MAKE 2ND DIGIT ASCII
PJRST EPUTCH ;TYPE IT
XTIME: IDIVI T1,^D60 ;GET BASE-60 DIGIT
JUMPE T1,TIMEX ;IF LAST ONE, DONE
PUSH P,T2 ;SAVE A DIGIT
PUSHJ P,XTIME ;TYPE REST OF NUMBER
MOVEI T1,":" ;TYPE COLON
PUSHJ P,EPUTCH
POP P,T2 ;GET DIGIT BACK
IDIVI T2,^D10 ;GET 2 DECIMAL DIGITS
MOVEI T1,"0"(T2) ;TYPE 2-DIGIT NUMBER
PUSHJ P,EPUTCH
MOVEI T1,"0"(T3)
PJRST EPUTCH
TIMEX: IDIVI T2,^D10 ;GET HIGH-ORDER DIGITS
MOVEI T1,"0"(T2)
CAIE T1,"0"
PUSHJ P,EPUTCH
MOVEI T1,"0"(T3)
PJRST EPUTCH
;Routine called by LERR's to append the PC to the error string.
ADDPCM: MOVEI T1,[ASCIZ/ at /]
PUSHJ P,ASCTYP
MOVE T1,LERRPC ;Get PC
SETOM ERRARG ;Set ERRARG non-zero so it types
; "in <module name>" if it can.
PJRST LERR$L ;Append the string and return
$L: PUSHJ P,%SAVE2##
PUSHJ P,GETARG
;Enter here if you have T1= PC.
;Set ERRARG= 1 to type "in Module name", 0 if you don't want that.
LERR$L: XMOVEI T1,(T1) ;Just get the PC
PUSH P,T1 ;To type out
HRRZ T1,T1 ;Just get RH to search local section sym tab.
PUSHJ P,SYMCNV ;CONVERT TO LABEL+OFFSET
PJRST NOSYM
PUSH P,T2 ;STORE OFFSET ON STACK
PUSHJ P,R50TYP ;TYPE RADIX50 SYMBOL
POP P,T1 ;GET OFFSET BACK
PUSHJ P,OFFTYP ;TYPE IT AS SIGNED OCTAL
SKIPN ERRARG ;IS THAT ALL WE WANT?
JRST [ADJSP P,-1 ;YES, RETURN
POPJ P,]
MOVEI T1,[ASCIZ / in /] ;TYPE NOISE WORD FOR MODULE NAME
PUSHJ P,ASCTYP
MOVE T1,MODNAM ;GET MODULE
PUSHJ P,R50TYP ;TYPE IT TOO
PCTYP: MOVEI T1,[ASCIZ / (PC /] ;FINISH UP WITH THE OCTAL ADDRESS
PUSHJ P,ASCTYP ; FOR LUCK
POP P,T1
TLNE T1,-1 ;Extended section?
JRST PCTYP1 ;Yes, type N,,M
PCTYP0: PUSHJ P,OCTTYP
MOVEI T1,")"
PJRST EPUTCH
PCTYP1: PUSH P,T1
HLRZ T1,T1
PUSHJ P,OCTTYP ;Type section #
MOVEI T1,","
PUSHJ P,EPUTCH
PUSHJ P,EPUTCH ;",,"
POP P,T1
HRRZ T1,T1 ;RH of PC
JRST PCTYP0
NOSYM: DMOVEM P1,SVP12 ;Save P1 and P2
MOVE P2,(P) ;Get address we're searching for
MOVE P1,P ;Copy stack ptr.
STKVAR <ADDR> ;ALLOCATE LOCAL VARIABLES
SETZM ADDR
NSYM0: PUSHJ P,GETPC ;GET A PC FROM STACK
JUMPE P1,NSYM1 ;NONE LEFT, DONE
CAML T2,ADDR ;BETTER THAN PREVIOUS BEST APPROXIMATION?
CAMLE T2,P2 ;YES, BUT NOT PAST ARG PC?
JRST NSYM0 ;NO, SKIP IT
MOVEM T2,ADDR ;SAVE ROUTINE ADDRESS
JRST NSYM0 ;LOOK THROUGH WHOLE STACK
NSYM1: SKIPN P1,ADDR ;GET ROUTINE ADDRESS
SKIPA P1,I.SA ;NONE FOUND, USE MAIN START ADDRESS
SKIPA T1,-1(P1) ;GET ROUTINE NAME
MOVE T1,['MAIN. '] ;OR MAIN PROGRAM NAME
UNSTK ;DISCARD STACK VARS
;PC still on top of stack
PUSHJ P,SIXTYP ;TYPE IT
MOVE T1,P2 ;GET ARG PC
SUB T1,P1 ;SUBTRACT ROUTINE ADDRESS
PUSHJ P,OFFTYP ;TYPE OFFSET
DMOVE P1,SVP12 ;Restore P1 and P2..
SKIPE ERRARG ;IS THAT ALL?
PJRST PCTYP ;NO, ADD PC IN OCTAL
ADJSP P,-1 ;DISCARD PC
POPJ P, ;RETURN
SEGMENT DATA
SVP12: BLOCK 2 ;Saved P1, P2 for duration of NOSYM
SEGMENT ERR
$5: PUSHJ P,GETARG ;GET ARG IN T1
JUMPE T1,%POPJ
PUSH P,T1
MOVEI T1," "
PUSHJ P,EPUTCH
POP P,T1
R50TYP:
R50LP: IDIVI T1,50
JUMPE T1,.+4
PUSH P,T2
PUSHJ P,R50LP
POP P,T2
JUMPE T2,%POPJ
MOVEI T1,<"0"-R50(0)>(T2)
CAILE T1,"9"
ADDI T1,"A"-R50(A)-"0"+R50(0)
CAILE T1,"Z"
SUBI T1,-<"$"-R50($)-"A"+R50(A)>
CAIN T1,"$"-1
MOVEI T1,"."
JRST EPUTCH
EPUTCH: AOS COLCNT ;KEEP TRACK OF WHAT COL WE'RE ON
SOSL ERRCNT ;DECREMENT COUNT OF CHARS LEFT
IDPB T1,ERRPTR ;SPACE LEFT, STORE CHAR
POPJ P,
GETARG: AOS T1,ARGPTR ;BUMP TO NEXT ARG IN LIST
MOVE T1,(T1) ;GET ARG
POPJ P,
IF10,<
XLIST
LIT
LIST
$E: PUSHJ P,GETARG ;GET ERR CODE
CAIL T1,0 ;NEGATIVE?
CAILE T1,LERMAX ;OR TOO BIG?
JRST LERUNK ;YES, TYPE GENERAL-PURPOSE MSG
ADDM T1,G.IS ;Fix error number
SKIPE T2,%TIOS ;Any IOSTAT= variable?
ADDM T1,(T2) ;Yes, fix that number, too.
IDIVI T1,4 ;GET STRING OFFSET
LDB T1,LERTBL(T2)
CAIN T1,777 ;NO MSG FOR THIS ERROR?
JRST LERUNK ;YES, GO TYPE G.P. MSG
MOVEI T1,LERMSG(T1) ;GET STRING ADDRESS
PJRST ASCTYP ;GO TYPE IT
LERUNK: MOVEI T1,[ASCIZ /Unknown FILOP error, code /]
PUSHJ P,ASCTYP
MOVE T1,@ARGPTR ;GET ERROR CODE BACK
PJRST OCTTYP ;TYPE IT
LERTBL: POINT 9,LERPTR(T1),8
POINT 9,LERPTR(T1),17
POINT 9,LERPTR(T1),26
POINT 9,LERPTR(T1),35
DEFINE X (STRG) <
XOFFS==[ASCIZ \STRG\]-LERMSG
XXX (XOFFS)
>
DEFINE XX (STRG) <
XXX (-1)
>
DEFINE XXX (OFFS) <
XXXWD==XXXWD + <OFFS&777>_<XXXCT*9>
XXXCT==XXXCT-1
IFL XXXCT,<
EXP XXXWD
XXXWD==0
XXXCT==3
>
>
XXXWD==0
XXXCT==3
LERPTR: X No such file ;0
X No such directory ;1
X Protection failure ;2
X File is being modified ;3
X File already exists ;4
XX Illegal sequence of UUOs ;5
X RIB error ;6
XX Bad format .SAV file ;7
XX Insufficient memory ;10
X Device is not available ;11
X Can't OPEN device ;12
XX Illegal UUO ;13
X Device full ;14
X Device is write locked ;15
X Insufficient monitor table space ;16
XX Can't allocate contiguous space ;17
XX Requested block not free ;20
X Can't write a directory ;21
X Directory is not empty ;22
X No such directory ;23
X Search list empty ;24
X SFDs nested too deep ;25
X All structures have NOCREATE set ;26
XX Segment not in swap space ;27
X Can't update file ;30
XX Page overlap ;31
XX Not logged in ;32
X Locks still set ;33
XX Bad format .EXE file ;34
XX Extension must be .EXE ;35
XX .EXE directory too big ;36
X Network full ;37
X Task not available ;40
X No such node ;41
X SFD in use ;42
X File has an NDR lock ;43
X Monitor use count overflow ;44
X Can't rename SFD downward ;45
XX Channel not open ;46
X Device is down ;47
X Device is restricted ;50
X Device must be mounted ;51
X Device is assigned to another job ;52
XX Illegal data mode ;53
XX Unknown OPEN bits ;54
X Device is not available ;55
X Funny space full ;56
X Too many open units ;57
XX Unknown function code ;60
XX Illegal channel number ;61
XX Illegal channel number ;62
LERMAX==62 ;MAX STRING IN TABLE
IFN XXXCT-3,<EXP XXXWD>
LERMSG: ;LIT
XLIST
LIT
LIST
;STILL IF10
;TYPE IO ERROR MESSAGE
$I: PUSHJ P,%SAVE3 ;SAVE P ACS
MOVEI T1,[ASCIZ /IO error /]
PUSHJ P,ASCTYP
PUSHJ P,GETARG ;GET BITS
PUSHJ P,OCTTYP ;TYPE THEM IN OCTAL
MOVE D,ERRACS+D ;GET DDB POINTER
HRLZ P1,@ARGPTR ;GET BITS BACK, IN LH
TLZ P1,-1-IO.ERR-IO.EOF-IO.EOT ;CLEAR BORING BITS
LOAD T4,DVTYP(D) ;GET DEVTYP
CAIN T4,.TYMTA ;MTA?
TLZ P1,IO.EOT ;NO, EOT ISN'T REALLY EOT, SO IS BORING
LOAD T1,INDX(D) ;GET DEV INDEX
CAIN T1,DI.DSK ;DISK?
MOVEI T4,.TYDSK ;YES, SPOOLED DEV OR REAL DISK
MOVEI P3,IBUF-1 ;POINT TO BUFFER FOR MSGS
JRST IOENXT ;GO DO FIRST BIT
IOELP: ANDCM P1,[EXP 1B0,1B1,1B2,1B3,1B4,1B5,1B6,1B7](P2) ;CLEAR BIT
DPB P2,[POINT 3,T4,29] ;STORE ERROR CODE WITH DEVTYP
MOVEI T3,(T4) ;COPY ERR BIT & DEV TYP
IOELP1: MOVE T2,[-LITAB,,ITAB] ;POINT TO TABLE
IOELP2: LDB T1,[POINT 9,(T2),9] ;GET ERR BIT & DEVTYP
CAIE T1,(T3) ;MATCH?
AOBJN T2,IOELP2 ;NO, KEEP LOOKING
JUMPL T2,IOEEND ;JUMP IF WE FOUND IT
ORI T3,.TYXXX ;USE DEFAULT IF NOT FOUND
JRST IOELP1
IOEEND: MOVE T2,(T2) ;GET MESSAGE POINTER
TLNE T2,(1B10) ;FATAL?
JRST [XMOVEI T1,%ABORT ;Yes, change continue address
MOVEM T1,CONT ;So job will be aborted.
JRST .+1]
PUSH P3,T2 ;SAVE MESSAGE FOR THIS BIT
IOENXT: JFFO P1,IOELP ;DO NEXT BIT
PUSH P3,[0] ;FLAG END OF LIST
MOVEI P1,IBUF
SKIPA T1,[[ASCIZ / (/]] ;FIRST MSG GETS PAREN
MSGLP: MOVEI T1,[ASCIZ /, /] ;OTHERS GET COMMAS
SKIPN P2,(P1) ;GET A MSG
JRST MSGEND ;NONE LEFT
PUSHJ P,ASCTYP ;TYPE PAREN OR COMMA
CAIL P2,0 ;ROUTINE TO CALL?
PUSHJ P,(P2) ;YES, CALL IT
SKIPE T1,P2 ;POINT TO STRING
PUSHJ P,ASCTYP ;TYPE IT
AOJA P1,MSGLP ;LOOP OVER ALL MSGS
MSGEND: MOVEI T1,")" ;TYPE CLOSE PAREN
SKIPE IBUF
PUSHJ P,EPUTCH
HLLZ T2,CHAN(D) ;CLEAR ERROR BITS
HRRI T2,.FOSET
MOVE T3,@ARGPTR ;GET BITS BACK
ANDI T3,-1-IO.ERR ;CLEAR ERR BITS, LEAVE EOF AND EOT
MOVE T1,[2,,T2] ;SET LENGTH, ADDRESS
FILOP. T1, ;DO FILOP
JFCL
POPJ P,
;STILL IF10
.TYXXX==77 ;FAKE DEVTYP FOR DEFAULT DEVICE
DEFINE X (DEV,ERR,FATAL<0>,MSG) <
BYTE (1)1(3)^L<IO.'ERR,,0>(6).TY'DEV(1)FATAL(7)0(18)[ASCIZ \MSG\]
>
DEFINE XS (DEV,ERR,FATAL<0>,SUB) <
BYTE (1)0(3)^L<IO.'ERR,,0>(6).TY'DEV(1)FATAL(7)0(18)SUB
>
ITAB: X CDP,BKT,,card too large
X CDR,IMP,,nonbinary card
X CDR,DTE,,checksum error
X MTA,IMP,1,write locked
X MTA,DTE,,parity error
X MTA,BKT,,record exceeds BLOCKSIZE
X MTA,EOT,1,EOT
X PTR,IMP,,block incomplete
X PTR,DTE,,checksum error
X PTY,BKT,,char lost
X TTY,IMP,1,not assigned
X TTY,DER,1,^C typed
X TTY,DTE,,echo check
X TTY,BKT,,char lost
XS DSK,IMP,1,DSKIMP ;write locked or RIB error
X DSK,DTE,,parity error
XS DSK,BKT,1,DSKBKT ;str full or quota exceeded
X DTA,IMP,1,write locked
X DTA,DTE,,parity error
X DTA,BKT,1,tape full
X XXX,IMP,1,improper mode (whatever that means)
XS XXX,DER,,XXXDER ;device error
X XXX,DTE,,data error
X XXX,BKT,,block too large
X XXX,EOF,,end of file
X XXX,EOT,,EOT ;SNH
LITAB==.-ITAB
SEGMENT DATA
IBUF: BLOCK 6 ;ONE MESSAGE EACH FOR 5 POSSIBLE BITS
DCBLK: BLOCK 1+.DCFCT ;ARG BLOCK FOR DSKCHR
SEGMENT ERR
;STILL IF10
DSKBKT: SKIPN T1,RDEV(D) ;GET STR FILE IS ON
JRST DSKFUL ;CAN'T, JUST SAY DISK FULL
MOVEM T1,DCBLK ;SAVE FOR DSKCHR
MOVE T1,[1+.DCFCT,,DCBLK] ;SET UP FOR DSKCHR
DSKCHR T1,UU.PHY ;FIND SPACE REMAINING
JRST DSKFUL
MOVE P2,[X (DSK,BKT,1,quota or storage exceeded)]
SKIPG DCBLK+.DCUFT ;CHECK BLOCKS LEFT IN QUOTA
MOVE P2,[X (DSK,BKT,1,quota exceeded)]
SKIPG DCBLK+.DCFCT ;CHECK BLOCKS LEFT ON STR
DSKFUL: MOVE P2,[X (DSK,BKT,1,structure full)]
POPJ P,
DSKIMP: SKIPN T1,RDEV(D) ;GET STR NAME
JRST DSKWL ;CAN'T
MOVEM T1,DCBLK ;SAVE FOR DSKCHR
MOVE T1,[1,,DCBLK] ;SET FOR DSKCHR
DSKCHR T1,UU.PHY ;FIND WRITE-LOCK STATUS
JRST DSKWL
TXNE T1,DC.HWP+DC.SWP ;CHECK WRITE PROTECTION
JRST DSKWL ; IT'S WRITE-LOCK
MOVE T1,LKPB+.RBSTS(D) ;GET RIB STATUS WORD
MOVE P2,[X (DSK,IMP,1,checksum error)]
TXNN T1,RP.FCE ;CHECKSUM ERROR?
MOVE P2,[X (DSK,IMP,1,RIB error)] ;NO
POPJ P,
DSKWL: MOVE P2,[X (DSK,IMP,1,write locked)]
POPJ P,
XXXDER: SETZ P2, ;CLEAR OUTPUT MSG, WE'LL DO THE TYPING
MOVEI T1,[ASCIZ /device error/]
PUSHJ P,ASCTYP
LDB T1,[POINTR CHAN(D),FO.CHN] ;GET CHANNEL NUMBER
DEVSTS T1, ;GET CONI AT LAST INTERRUPT
POPJ P, ;CAN'T
PUSH P,T1 ;TYPE IT
MOVEI T1,[ASCIZ /, CONI /]
PUSHJ P,ASCTYP
POP P,T1
PJRST OCTTYP
;STILL IF10
;TYPE FILESPEC FROM DDB POINTED TO BY D
$F: MOVE D,ERRACS+D ;RESTORE D
SKIPN T1,DEV(D) ;DEVICE
POPJ P, ;NO DEVICE, NO INFO AT ALL
PUSHJ P,SIXTYP
MOVEI T1,":"
PUSHJ P,EPUTCH
SKIPN T1,FILE(D) ;FILENAME
POPJ P,
PUSHJ P,SIXTYP
MOVEI T1,"."
SKIPE EXT(D)
PUSHJ P,EPUTCH
HLLZ T1,EXT(D)
PUSHJ P,SIXTYP
SKIPN PTHB+.PTPPN(D) ;PATH
POPJ P,
MOVEI T1,"["
PUSHJ P,EPUTCH
MOVE T1,PTHB+.PTPPN(D)
PUSHJ P,XWDTYP
XMOVEI T1,PTHB+.PTPPN+1(D)
PUSH P,T1
SFDLP: SKIPN @(P)
JRST SFDEND
MOVEI T1,","
PUSHJ P,EPUTCH
MOVE T1,@(P)
PUSHJ P,SIXTYP
AOS (P)
JRST SFDLP
SFDEND: POP P,(P)
MOVEI T1,"]"
PUSHJ P,EPUTCH
POPJ P, ;DONE
> ;IF10
IF20,<
$J: HRRZ T2,G.LJE ;Get last JSYS error number
CAIN T2,GJFX3 ;"No JFNs available"?
JRST NOJFNA ;Yes, doing ERSTR% doesn't help!
MOVE T1,ERRPTR ;GET POINTER TO DESTINATION STRING
HRLI T2,.FHSLF
MOVN T3,ERRCNT ;NEGATIVE OF NUMBER OF CHARS IN BUFFER
MOVSI T3,(T3) ;IN LEFT HALF
ERSTR% ;GET ERROR STRING
JRST ERNSE ;NO SUCH ERROR
JRST ERERR ;;; STRING TOO SHORT, MSG TRUNCATED
MOVEM T1,ERRPTR ;STORE NEW STRING POINTER
;;;DO SOMETHING ABOUT ERRCNT
POPJ P,
NOJFNA: MOVEI T1,[ASCIZ/no JFNs available/] ;Get error
PJRST ASCTYP
ERNSE: SKIPA T1,[[ASCIZ /(undefined error number)/]]
ERERR: MOVEI T1,[ASCIZ /(error in ERSTR)/]
PJRST ASCTYP
;Type filespec from DDB
; (uses no args except "D")
$F: MOVE D,ERRACS+D ;Restore D
LOAD T2,IJFN(D) ;Get JFN of file
JUMPE T2,FNOJFN ;None yet
CAIN T2,.PRIIN ;Can't do JFNS on .PRIIN
JRST NJFNS1
HRROI T1,JFNBUF ;Store filespec in temp buffer
SETZ T3, ;Set for default JFNS
JFNS%
ERJMP FNOJFN ;?can't, JFN must be bogus
JRST NJFNS2
;The JFN is actually .PRIIN
NJFNS1: MOVE T1,[ASCIZ/TTY:/]
MOVEM T1,JFNBUF
NJFNS2: MOVEI T1,JFNBUF ;Point to ASCIZ string to append
PJRST ASCTYP ;Append it and return
;No JFN available
FNOJFN: XMOVEI T1,DEV(D) ;Put device
PUSHJ P,ASCTYP ;into buffer
MOVEI T1,":"
PUSHJ P,EPUTCH
SKIPN DIR(D) ;Directory known yet?
JRST FLEXGN ;No
TXNE F,F%PPN ;PPN instead of directory string?
JRST NJFNE3 ;Yes, another special case
MOVEI T1,"<"
PUSHJ P,EPUTCH
XMOVEI T1,DIR(D)
PUSHJ P,ASCTYP ;DIRECTORY
MOVEI T1,">"
PUSHJ P,EPUTCH
;Here to finish putting out FILE.EXT.GEN
FLEXGN: XMOVEI T1,FILE(D)
PUSHJ P,ASCTYP
MOVEI T1,"."
PUSHJ P,EPUTCH
XMOVEI T1,EXT(D)
PUSHJ P,ASCTYP
MOVEI T1,"."
PUSHJ P,EPUTCH
MOVE T1,XGEN(D) ;Get gen number
PJRST DNOUT ;Print decimal # and return
NJFNE3: MOVEI T1,"["
PUSHJ P,EPUTCH
MOVE T1,DEV(D)
PUSHJ P,XWDTYP ;Type nn,,nn
MOVEI T1,"]"
PUSHJ P,EPUTCH
JRST FLEXGN ;Type FILE.EXT.GN and return
SEGMENT DATA
JFNBUF: BLOCK ^D60 ;Buffer for JFNS string
SEGMENT ERR
>;END IF20
$T: MOVE T2,ERRARG ;GET COL TO TAB TO
SUB T2,COLCNT ;GET NUMBER OF SPACES WE NEED
MOVEI T1," "
PUSHJ P,EPUTCH ;TYPE A SPACE
SOJG T2,.-1 ;LOOP UNTIL AT DESIRED COL
POPJ P, ;DONE
IF10,<
$Z: PUSHJ P,GETARG ;GET ADDRESS OF STRING
HRLI T1,(POINT 6,) ;MAKE INTO BYTE POINTER
MOVE T4,T1 ;IN SAFE PLACE
SIXLP: ILDB T1,T4 ;GET CHAR
JUMPE T1,%POPJ ;SPACE TERMINATES STRING
ADDI T1,40 ;CONVERT TO ASCII
PUSHJ P,EPUTCH ;TYPE IT
JRST SIXLP ;LOOP
> ;IF10
$A: PUSHJ P,GETARG ;GET ADDRESS OF STRING
ASCTYP: HRLI T1,(POINT 7,) ;MAKE INTO BYTE POINTER
MOVE T4,T1 ;PUT IN SAFE PLACE
ASCLP: ILDB T1,T4 ;GET CHAR OF STRING
JUMPE T1,%POPJ ;NULL TERMINATES STRING
PUSHJ P,EPUTCH ;TYPE CHAR
JRST ASCLP ;LOOP
;Routine to get initial PREFIX part of message
;CAll: t1/ prefix char
TYPEQM: JUMPE T1,TYPQM1 ;Don't type anything if no char
PUSHJ P,EPUTCH ;Type char
IF10,<
MOVE T1,I.MSG ;Get message level
TXNN T1,JW.WPR ;Does user want prefix?
JRST NPR ;No, skip it
HLRZ T1,1(P1) ;Get 3-letter error code
HRLI T1,'FRS' ;Put in FOROTS prefix
PUSHJ P,SIXTYP ;Type it
MOVEI T1," " ;Follow with space
PUSHJ P,EPUTCH
NPR:
>;END IF10
TYPQM1: SETZM COLCNT ;Start counting cols for tabs
POPJ P, ;Return
;Routine to position terminal to column 1, and clear user's
; input buffer if error starts with "?".
;Call:
; t1/ initial character
POSEFL: JUMPE T1,%POPJ ;IF NO SPECIAL FIRST CHAR, NO SPECIAL ACTION
SKIPE U.ERR ;Don't screw around with TTY if diverting errors
POPJ P,
PUSHJ P,CLRCTO ;Clear Control-O
SKIPE D.TTY ;Any TTY DDB?
POPJ P, ;Yes, let EOREC worry about positioning
;Make sure TTY is at column 1 before typing the error
IF20,<
PUSH P,T1 ;Save 1st char
MOVEI T1,.PRIOU ;READ COL TERMINAL IS AT
RFPOS%
HRROI T1,%CRLF ;GET SET TO TYPE CRLF
TRNE T2,-1 ;IS TERMINAL AT COL 1?
PSOUT% ;NO, GET IT THERE
POP P,T1 ;Restore 1st char
POPJ P, ;Return
>;END IF20
IF10,<
PUSH P,T1 ;Save char
MOVNI T1,1 ;Get the controlling TTY's UDX.
TRMNO. T1,
JRST ATCL1 ;?Can't, assume at column 1
MOVEM T1,TRMPAL+1 ;Save UDX in arg list
;Wait for any terminal output in progress to finish
MOVEI T1,.TOOIP ;Return "output-in-progress" bit setting
MOVEM T1,TRMPAL
WAITOU: MOVE T1,[XWD 2,TRMPAL] ;Ready for TRMOP.
TRMOP. T1, ;Get output-in-progress bit
JRST ATCL1 ;?can't, assume at column 1
JUMPE T1,GTHPOS ;Jump if all output done
MOVEI T1,^D250 ;Wait a little while (1/4 sec.)
HIBER T1,
$SNH ;?Shouldn't ever fail
JRST WAITOU
;Read TTY's horizonal position
GTHPOS: MOVEI T1,.TOHPS ;Return horizontal position of TTY
MOVEM T1,TRMPAL
MOVE T1,[XWD 2,TRMPAL] ;Length,,arglist address
TRMOP. T1, ;Do the TRMOP.
JRST ATCL1 ;?Can't, assume at column 1
JUMPE T1,ATCL1 ;0 means at column 1 now
OUTSTR %CRLF ;Else type a CRLF
ATCL1: POP P,T1 ;Restore ac
CAIE T1,"?" ;SERIOUS ERROR?
POPJ P, ;No, done
CLRBFI ;CLEAR TYPEAHEAD
POPJ P, ;Return
SEGMENT DATA
TRMPAL: BLOCK 2 ;TRMOP. arg block
SEGMENT CODE
> ;IF10
;Routine to clear terminal's CTRL/O.
;Preserves T1
CLRCTO:
IF20,<
PUSH P,T1 ;SAVE CHAR
MOVEI T1,.PRIOU ;CLEAR ^O
RFMOD%
TXZE T2,TT%OSP
SFMOD%
POP P,T1
POPJ P, ;Return
>
IF10,<
SKPINL ;Clear ^O
JFCL
POPJ P,
>
;TYPE INPUT RECORD (PRESUMABLY CONTAINING AN ERROR) AND PUT AN ARROW
;UNDER THE ERRONEOUS CHARACTER. THE ERROR POSITION IS GOTTEN FROM RPOS.
RECTYP: TDZA T1,T1 ;CLEAR OFFSET
RECTY1: MOVEI T1,1 ;SET OFFSET (NECESSARY BECAUSE NAMELIST
; HAS BACKSPACED THE RECORD POINTER)
STKVAR <ERRPOS,ERROFS> ;ALLOCATE SPACE ON STACK
MOVEM T1,ERRPOS ;STORE OFFSET
PUSHJ P,%RPOS ;READ RECORD POINTER
SUBI T1,1
ADDM T1,ERRPOS ;SAVE FOR PRINTING THE ARROW
MOVEI T1,1 ;Reset to start of record
PUSHJ P,%SPOS
SETZM ERROFS ;CLEAR ARROW OFFSET CAUSED BY CONTROL CHARS
MOVE T2,[POINT 7,ER1BUF] ;PREPARE TO COPY RECORD TO ERROR BUFFER
MOVX T1,D%EOR ;Clear "END OF RECORD" bit
ANDCAM T1,FLAGS(D)
ILCLP: PUSHJ P,%IBYTE ;GET CHAR FROM RECORD
MOVE T0,FLAGS(D)
TXNE T0,D%EOR ;End of record?
JRST ILCEND ;YES, FINE
CAIL T1," " ;CONTROL CHAR?
CAIL T1,177 ;OR RUBOUT?
JRST ILCCTL ;YES, HANDLE PROPERLY
IDPB T1,T2 ;STORE CHAR IN ERROR BUFFER
JRST ILCLP ;COPY WHOLE RECORD
ILCCTL: CAIN T1,177 ;RUBOUT?
SETO T1, ;YES, TURN INTO CONTROL-?
MOVEI T3,"^" ;GET CONTROL CHAR PREFIX
IDPB T3,T2 ;STORE IN BUFFER
ADDI T1,100 ;CONVERT CONTROL CHAR TO UPPER CASE
IDPB T1,T2 ;STORE IT
PUSHJ P,%RPOS ;GET CURRENT POS
SUBI T1,1
CAMGE T1,ERRPOS ;ARE WE AFTER ERROR CHAR?
AOS ERROFS ;NO, THE ARROW WILL MOVE THE ERROR CHAR OVER ONE
JRST ILCLP ;CONTINUE
ILCEND: PUSHJ P,BUFTYP ;TYPE ERROR RECORD
MOVE T2,[POINT 7,ER1BUF] ;START AT BEGINNING OF BUFFER AGAIN
MOVE T3,ERRPOS ;GET COL TO PUT ARROW IN
ADD T3,ERROFS ;MOVED OVER ONE FOR EACH CONTROL CHAR
MOVEI T1," " ;GET MOVING-OVER CHAR
SOJLE T3,ARROW ;IF COL 1, GO TYPE ARROW
IDPB T1,T2 ;STORE SPACE IN BUFFER
SOJG T3,.-1 ;STORE A BUNCH OF THEM
ARROW: MOVEI T1,"^" ;GET POINTER
IDPB T1,T2 ;STORE IT TOO
PUSHJ P,BUFTYP ;TYPE THE ARROW
UNSTK ;REMOVE STACK VARIABLES
POPJ P, ;return
BUFTYP: MOVEI T1,0 ;End with <NUL>
IDPB T1,T2
MOVEI T1,ER1BUF ;Point to buffer
PJRST %EOREC## ;Type it and return
;TYPE FORMAT (PRESUMABLY CONTAINING AN ERROR) AND PUT AN ARROW UNDER THE
;ERRONEOUS CHARACTER. THE ERROR POSITION IS GOTTEN FROM FMT.BP.
FMTTYP: STKVAR <INCR,ARRW> ;ALLOCATE TEMPS
SETZM INCR ;FORMAT LENGTH IS FMT.SZ CHARS COUNTING FROM
;FMT.BP, FORMAT STARTS AT FMT.BG. INCR IS 0
;BETWEEN FMT.BG AND FMT.BP, 1 AFTERWARD
MOVE T1,FMT.BG ;POINT TO BEGINNING OF FORMAT
MOVE T2,[POINT 7,ER1BUF] ;POINT TO PLACE TO COPY IT TO
MOVE T3,FMT.SZ ;GET COUNT OF CHARS AFTER ARROW
SETOM ARRW ;INIT ARROW POSITION
FMTTLP: CAME T1,FMT.BP ;POINTING TO CURRENT FORMAT POSITION?
JRST FMTT1 ;NO
MOVEI T0,1 ;YES, SET INCR TO 1
MOVEM T0,INCR
JRST FMTT2
FMTT1: SKIPN INCR ;INCREMENT ARROW POSITION
AOS ARRW
FMTT2: SUB T3,INCR ;CHECK COUNT
JUMPL T3,FMTTE ;FORMAT IS COPIED
ILDB T0,T1 ;GET CHAR FROM FORMAT
IDPB T0,T2 ;COPY INTO OUR BUFFER
JRST FMTTLP ;COPY WHOLE FORMAT
FMTTE: PUSHJ P,BUFTYP ;TYPE ERRONEOUS FORMAT
MOVE T1,ARRW ;GET COUNT OF SPACES BEFORE ARROW
MOVE T2,[POINT 7,ER1BUF] ;POINT TO BUFFER
JUMPLE T1,FMTA1 ;NO SPACES, SKIP
MOVEI T3," " ;GET A SPACE
IDPB T3,T2 ;STORE A SPACE
SOJG T1,.-1 ;STORE BUNCHES OF SPACES
FMTA1: MOVEI T3,"^" ;GET THE ARROW
IDPB T3,T2 ;STORE IT
PUSHJ P,BUFTYP ;TYPE THE ARROW
UNSTK ;DISCARD LOCALS
POPJ P, ;Return
IF10,<
;Type string with error in it, with arrow under the current char.
; %NCHRR is # of chars parsed so far (and the error position).
;%SRCBP is the CURRENT source byte ptr.
CHSTYP: HRRZ T1,%NCHRR ;Get # chars
IDIVI T1,5 ;This gets us to old B.P.
MOVE T3,%SRCBP ;Get source byte ptr
SUBI T3,1(T1) ;Backup # words + 1
MOVEI T1,5 ;# chars in full word
SUB T1,T2 ;Get # byte to go forward now
IBP T3 ;(At least 1)
SOJG T1,.-1 ;Get correct BP.
MOVE T2,[POINT 7,ER1BUF] ;Place to put it
HRRZ T4,%NCHRR ;Get # chars
ILDB T0,T3 ;Get char
IDPB T0,T2 ;Store in ER1BUF
SOJG T4,.-2 ;Loop till copied
PUSHJ P,BUFTYP ;Type the buffer
HRRZ T4,%NCHRR ;Get # chars again
MOVE T2,[POINT 7,ER1BUF] ;Put spaces here until arrow
MOVEI T0," " ;Get a space
CHSTP1: SOJLE T4,CHSTP2 ;Go print arrow
IDPB T0,T2 ;Store a space
JRST CHSTP1
CHSTP2: MOVEI T0,"^" ;Up-arrow
IDPB T0,T2
PUSHJ P,BUFTYP ;Type that line
POPJ P, ;Return.
>;END IF10
SEGMENT DATA
LERRBF==30 ;LENGTH OF MESSAGE BUFFER, WORDS
G.ERBF:: ;GLOBAL TAG
ERRBUF: BLOCK LERRBF ;BUFFER FOR THE ERROR MESSAGE
ERRCNT: BLOCK 1 ;COUNT OF CHARS LEFT IN IT
ERRPTR: BLOCK 1 ;POINTER TO NEXT FREE CHAR
ER1BUF: BLOCK LERRBF ;Buffer for the record
INICHR: BLOCK 1 ;PREFIX CHAR OF ERROR MESSAGE
ERRPC: BLOCK 1 ;PC OF THE PUSHJ TO FORER%
ERRARG: BLOCK 1 ;ARG TO $<N>X COMMAND
COLCNT: BLOCK 1 ;COLUMN NUMBER
LIBFLG: BLOCK 1 ;-1 IF FROM LIBRARY, 0 IF FROM INSIDE FOROTS
ARGPTR: BLOCK 1 ;POINTER TO NEXT ARG
%ERARG: BLOCK 10 ;THE ARG VALUES
ERRACS: BLOCK 20 ;SAVED ACS
MODNAM: BLOCK 1 ;RADIX50 MODULE NAME FROM SYMBOL SEARCH
SUBTTL ERROR CLEANUP
;%ERSET SETS A CLEANUP ROUTINE TO BE CALLED IF AN ERROR OCCURS IN A ROUTINE OR
;ANY OF ITS SUBROUTINES.
;
;ARGS: T1 = CLEANUP ROUTINE ADDRESS
;
;IF THE ERR OR IOERR MACRO IS ENCOUNTERED BEFORE THE POPJ AT THE END OF THE
;ROUTINE, THE CLEANUP ROUTINE IS CALLED BEFORE THE ERROR MESSAGE IS TYPED.
;CLEANUP ROUTINES ARE CALLED FOR ALL NESTED ROUTINES THAT LEAD TO THE POINT OF
;THE ERROR. IF ALL CLEANUP ROUTINES RETURN NORMALLY, THE ERROR MESSAGE IS
;TYPED AND EXECUTION CONTINUES WITH THE CONTINUE ADDRESS IN THE ERR MACRO
;(USUALLY %ABORT TO STOP THE JOB).
;TRACE
SEGMENT ERR
SIXBIT /TRACE./
TRACE%:
PUSHJ P,%SAVE ;SAVE USER'S ACS
%TRACE:
PUSHJ P,%SAVE1 ;SAVE P ACS
HRRZ P1,P ;SAVE POINTER TO TOP OF STACK
PUSHJ P,GETPC ;GET TOP CALL ON STACK
JUMPE P1,TRCRET ;NONE THERE, RETURN NOW
ERR ()
ERR (TRC,,<Name (Loc) $[$[--- Caller (Loc) Args Types>)
TRACEL: HRRZM T1,CPC ;SAVE CALLER PC
HRRZM T2,RPC ;SAVE ROUTINE ADDRESS
HLL T3,-1(T3) ;-COUNT,,ARGLST
MOVEM T3,TRARGS ;SAVE FOR LATER
MOVE T3,-1(T2) ;GET SIXBIT SUBROUTINE NAME
MOVEM T3,RNAME ;SAVE IT
PUSHJ P,GETPC ;GET NEXT PC ON STACK
PUSH P,T1 ;SAVE INFO FOR NEXT LOOP
PUSH P,T2
PUSH P,T3
MOVE T4,CPC ;GET CALLER PC
SUBI T4,(T2) ;SUBTRACT START OF CALLER'S ROUTINE
MOVEM T4,OFFS
CAIN P1,0 ;MAIN PROGRAM?
SKIPA T4,[SIXBIT /MAIN./] ;YES, GET ITS NAME
MOVE T4,-1(T2) ;SUBROUTINE, GET NAME
MOVEM T4,CNAME ;SAVE AS CALLER'S NAME
SETZM STRNG ;INIT TO NULLS
MOVE T1,[STRNG,,STRNG+1] ;SETUP
BLT T1,STRNG+STRWDS-1 ;INIT STRING
MOVE T1,[POINT 7,STRNG] ;PTR TO STRING
MOVEM T1,RGPTR ;STORE FOR ERR MACRO
MOVE T3,TRARGS ;RETRIEVE [-COUNT,,ARGLST]
HLRE T4,T3 ;COUNT
MOVNM T4,TRARGS ;STORE FOR ERR MACRO
SKIPN T4,TRARGS ;ANY ARGS?
JRST TRCSHO ; NOPE, GO DISPLAY
CAIG T4,STRLEN ;TOO MANY ARGS TO DISPLAY?
JRST TRCPTR ; NOPE, GO FINISH SETTING UP
HRLI T3,-STRLEN ;SET AOBJ PTR TO MAX
MOVE T4,[ASCIZ/.../] ;UNDISPLAYED ARGS
MOVEM T4,STRNG+STRWDS ;STORE
TRCPTR: MOVE T4,[POINT 7,STRNG] ;DEST PTR
TRCRGL: LDB T1,[POINT 4,(T3),12] ;GET DATA TYPE
IDIVI T1,5 ;IN WHICH WORD IS SYMBOL?
MOVE T0,TYPCOD(T1) ;LOAD THE WORD
IMULI T2,7 ;REMAINDER TO BIT OFFSET
ROT T0,7(T2) ;RIGHT JUSTIFY DATA TYPE SYMBOL
IDPB T0,T4 ;SYMBOL TO STRNG
AOBJN T3,TRCRGL ;LOOP IF MORE ARGS
TRCSHO: ERR (TR1,,<$S$7T($O)$16T$[$[---$23T$S$1O$34T($L)$48T$O$54T$A>,<RNAME,RPC,CNAME,OFFS,CPC,TRARGS,RGPTR>)
POP P,T3 ;RESTORE 'GETPC' DATA FOR LOOP
POP P,T2
POP P,T1
JUMPN P1,TRACEL ;LOOP
TRCRET:
POPJ P,
STRWDS==3 ;WORDS TO ACCOMODATE ARGUMENT SYMBOL STRING
STRLEN==5*STRWDS ;5 ASCII BYTES PER WORD
; 0123456701234567
TYPCOD: ASCII /OLIUFUOSDIOGCXUK/
repeat 0,<
DATA TYPE
0 INTEGER
1 LOGICAL
2 INTEGER
3
4 REAL
5
6 OCTAL
7 STATEMENT LABEL
10 DOUBLE REAL
11 DOUBLE INTEGER
12 DOUBLE OCTAL
13 G-FLOATING
14 COMPLEX
15 CHARACTER
16
17 LITERAL STRING
>
SEGMENT DATA
STRNG: BLOCK STRWDS+1 ;SYMBOL STRING + '...'
CPC: BLOCK 1 ;CALLER PC
RPC: BLOCK 1 ;ROUTINE PC
CNAME: BLOCK 1 ;CALLER NAME
RNAME: BLOCK 1 ;ROUTINE NAME
OFFS: BLOCK 1 ;OFFSET FROM BEGINNING OF CALLER
TRARGS: BLOCK 1 ;# ARGUMENTS
RGPTR: BLOCK 1 ;STRING POINTER FOR ERROR MACRO
SEGMENT CODE
;ROUTINE TO FIND THE NEXT PC ON THE STACK
;ARG: P1 = POINTER TO STACK
;RETURN: P1 = UPDATED TO PAST RETURNED PC, 0 IF NO PC FOUND
; T1 = PC OF PUSHJ
; T2 = DEST ADDRESS OF PUSHJ
; T3 = ADDRESS OF ARG LIST
GETPC: MOVE T1,(P1) ;GET SOMETHING OFF STACK
CAMN T1,['STOP!!'] ;MAGIC END-OF-STACK CONSTANT?
JRST GETPCE ;YES, GO RETURN END-OF-STACK INDICATION
;[***] FOLLOWING CODE WON'T WORK IN NONZERO SECTION
TLC T1,010000 ;USER MODE MUST BE ON
TLNE T1,031637 ;OTHER BITS MUST BE OFF
GETPCN: SOJA P1,GETPC ;NOT SO, NOT A POSSIBLE PC
MOVEI T1,(T1) ;DISCARD LH
PUSHJ P,ADRCHK ;CHECK THAT ADDRESS IS REASONABLE
SOJA P1,GETPC ;NOT, NOT A PC
MOVEI T1,-1(T1) ;DECREMENT PC
HLRZ T2,(T1) ;GET INSTRUCTION POINTED TO BY STACK
CAIE T2,(PUSHJ P,) ;A SUBROUTINE CALL?
CAIN T2,(PUSHJ P,@) ;OR INDIRECT CALL?
JRST .+2 ;YES, OK
SOJA P1,GETPC ;NO, NOT A PC
HLRZ T2,-1(T1) ;GET INSTRUCTION BEFORE THE PUSHJ
CAIE T2,(MOVEI L,) ;CORRECT?
CAIN T2,(XMOVEI L,) ; (The other choice)
TRNA ;Yes
SOJA P1,GETPC ;NO
MOVEI T2,@(T1) ;GET DEST ADDRESS OF PUSHJ
HLRZ T3,(T2) ;GET INSTRUCTION AT THAT ADDRESS
CAIE T3,(JSP 1,) ;POSSIBLE OVRLAY CALL?
JRST GETPC1 ;NO
HRRZ T3,(T2) ;GET RH OF JSP
MOVE T4,-1(T3) ;GET WORD BEFORE JSP TARGET
CAME T4,['.OVRLA'] ;IS IT LINK'S OVERLAY ROUTINE?
JRST GETPC1 ;NO, NOT AN OVERLAY CALL
HRRZ T2,@1(T3) ;GET DEST POINTED TO BY WORD AFTER JSP
GETPC1: HLRZ T3,(T2) ;GET INSTRUCTION AT TARGET ADDRESS
CAIE T3,(PUSHJ P,) ;POSSIBLE FOROTS DISPATCH IN RESET.?
JRST GETPC2 ;NO
HRRZ T3,(T2) ;GET EFFECTIVE ADDRESS OF PUSHJ
MOVS T4,(T3) ;GET INST AT THAT ADDRESS
CAIE T4,(EXCH 1,(P)) ;CORRECT?
JRST GETPC2 ;NO
HLRZ T4,1(T3) ;GET NEXT INST
CAIE T4,(ADD 1,) ;CORRECT?
JRST GETPC2 ;NO
MOVE T4,2(T3) ;GET NEXT INST
CAME T4,[TLZ 1,-1] ;CORRECT?
JRST GETPC2 ;NO
HLRZ T4,3(T3) ;GET NEXT INST
CAIE T4,(JRST (1)) ;CORRECT?
JRST GETPC2 ;NO
HRRE T4,3(T3) ;GET EFFECTIVE ADDRESS OF JRST
ADD T4,@1(T3) ;ADD IN FOROTS BASE FROM ADD
ADDI T2,1(T4) ;ADJUST PUSHJ DEST TO REAL DEST
GETPC2: HLRZ T3,(T2) ;GET INST AT DEST ADDRESS
CAIN T3,(PORTAL) ;ENTRY POINT?
MOVEI T2,@(T2) ;YES, FOLLOW TO ITS EFFECTIVE ADDRESS
HRRZ T3,-1(T1) ;GET ARG LIST ADDRESS FROM MOVEI INSTRUCTION
MOVS T4,-1(T3) ;GET ARG COUNT FROM -1 WORD OF LIST
CAIL T4,400000 ;MUST BE NEGATIVE
CAILE T4,777777
JUMPN T4,GETPCN ;OR ZERO
SOJA P1,%POPJ ;DONE
GETPCE: SETZ P1, ;FLAG THAT PDL IS DONE
SETZ T1, ;Return a zero.
MOVE T2,I.SA ;GET START ADDRESS
MOVEI T3,1+[0] ;NO ARGS
POPJ P, ;DONE
;ROUTINE TO ADDRESS CHECK A PC
;ARG: T1 = ADDRESS
;SKIP RETURN IF ADDRESS OK, NONSKIP OTHERWISE
;ADDRESS IS OK IF IT'S IN LOW SEGMENT, HIGH SEGMENT, OR FOROTS
;PRESERVES T1
ADRCHK: CAIGE T1,140 ;BELOW LOW SEG START?
POPJ P, ;NO, BAD
CAMG T1,.JBREL ;BELOW LOW SEG END?
JRST %POPJ1 ;YES, FINE
SKIPE T2,.JBHRL ;GET HIGH SEG POINTER
CAILE T1,(T2) ;COULD ADDRESS BE IN HIGH SEG?
JRST ADRCK1 ;NO
HLRZ T3,T2 ;GET HIGH SEG LENGTH
SUBI T2,(T3) ;GET HIGH SEG ORIGIN
CAIL T1,(T2) ;IS ADDRESS IN HIGH SEG?
JRST %POPJ1 ;YES, IT'S OK
ADRCK1:
IFN FTSHR,< ;IF FOROTS LOADED OUTSIDE HIGH AND LOW SEGS
CAIL T1,F.CODE ;IS ADDRESS IN FOROTS?
CAILE T1,Z.ERR
POPJ P, ;NO, ILLEGAL ADDRESS
JRST %POPJ1 ;YES, OK
>
IFE FTSHR,<
POPJ P, ;ADDRESS IS ILLEGAL
>
;ROUTINE TO CONVERT AN ADDRESS INTO SYMBOL+OFFSET
;ARG: T1 = ADDRESS TO CONVERT
;RETURN: T1 = RADIX50 SYMBOL NAME
; T2 = OFFSET FROM SYMBOL
;SKIP RETURN IF A SUITABLE SYMBOL FOUND, NONSKIP OTHERWISE
;THIS ROUTINE FINDS THE LARGEST SYMBOL LESS THAN OR EQUAL TO THE ADDRESS.
;IT IS DESIGNED FOR CONVERTING PCS ... IT ASSUMES THAT THE USEFUL SYMBOLS
;IN ANY ROUTINE HAVE VALUES GREATER THAN THE ROUTINE START ADDRESS.
;THE NONSKIP RETURN IS TAKEN IF THERE IS NO SYMBOL TABLE OR IF THE ADDRESS
;IS NOT IN ANY MODULE (FUNCTION, SUBROUTINE, OR MAIN PROGRAM) IN THE TABLE.
;MODULE NAMES ARE USED AS LAST-DITCH CANDIDATES FOR SYMBOLS.
SYMCNV: MOVEM T1,ADR ;SAVE THE ADDR WE WANT TO MATCH
SETZM TSYM ;CLEAR THE MATCHED SYMBOL & VALUE
SETZM TVAL
SETZM TMOD ;AND MODULE NAME
MOVE T2,.JBSYM ;GET LOW SYMTAB START
JUMPE T2,TRYFRS ;None. Try FOROTS's one.
PUSHJ P,SYMSRH ;DO A SEARCH
JRST TRYFRS ;No valid symbols
DMOVEM T1,TSYM ;SAVE THE RESULT
MOVEM T3,TMOD ;AND MODULE NAME
TRYFRS:
IFN FTSHR,<
MOVE T2,F.HSM ;GET FOROTS SYMBOL TABLE PNTR
JUMPE T2,CNVDON ;DONE IF IT'S ZERO
PUSHJ P,SYMSRH ;SEARCH YET AGAIN
JRST CNVDON ;NO VALID SYMBOLS
CAMG T2,TVAL ;IF IT IS NOT A BETTER FIT
JRST CNVDON ;LEAVE
DMOVEM T1,TSYM ;ELSE REPLACE IT
MOVEM T3,TMOD ;AND MODULE NAME
> ;FTSHR
CNVDON: SKIPE T1,TSYM ;DID WE GET ANYTHING?
AOS (P) ;YES. SKIP RETURN
MOVE T2,ADR ;GET ORIG ADDR
SUB T2,TVAL ;TURN SYMBOL ADDR INTO OFFSET
MOVE T3,TMOD ;GET THE BEST MODULE NAME
MOVEM T3,MODNAM ;SAVE FOR ERROR TYPEOUT
POPJ P,
SYMSRH: HRRZM T2,SYMBEG ;SAVE ADDRESS
HLRE T2,T2 ;GET SYMTAB LENGTH
SUB T2,SYMBEG ;GET NEG (SYMTAB END + 1)
MOVM T2,T2 ;GET POSITIVE
SETZB T4,MODEND ;CLEAR MODULE NAME AND END ADDRESS
SETZM VAL ;INITIALIZE BEST-SO-FAR MODULE ADDRESS
SETZM SYM ;AND SYMBOL
MODLP: MOVE T1,T2 ;POINT TO START OF MODULE
CAMG T1,SYMBEG ;STILL IN SYMBOL TABLE?
JRST MODLPE ;NO, SEARCH DONE
HLRE T2,-1(T1) ;GET -LENGTH OF MODULE SYMBOLS
JUMPGE T2,SYMRET ;IF POSITIVE, JUNK SYMBOL TABLE FORMAT
TRNE T2,1 ;MUST ALSO BE EVEN
JRST SYMRET ;ODD, GO DIE
HRRZ T3,-1(T1) ;GET LAST WORD IN MODULE, START ADDRESS
MOVE T4,-2(T1) ;AND NEXT TO LAST, MODULE NAME
TLNE T4,740000 ;AN ACTUAL MODULE NAME?
JRST SYMRET ;NO, INVALID SYMBOL TABLE FORMAT
ADD T2,T1 ;POINT TO START OF MODULE SYMBOLS
CAMG T3,ADR ;DOES MODULE START AFTER ADDRESS TO CONVERT?
CAMGE T3,VAL ;NO, IS MODULE BETTER THAN PREVIOUS BEST?
JRST MODLP ;NO, LOOP UNTIL FIND APPROPRIATE MODULE
MOVEM T1,MODEND ;SAVE END+1 ADDRESS OF MODULE SYMBOLS
MOVEM T3,VAL ;SAVE MODULE ADDRESS
MOVEM T4,SYM ;AND MODULE NAME AS SYMBOL NAME
MOVEM T4,MODNAM ;ALSO SAVE MODULE NAME FOR MESSAGES
JRST MODLP ;SEARCH WHOLE SYMBOL TABLE
MODLPE: SKIPN T1,MODEND ;GET END+1 ADDRESS OF SYMBOLS
JRST SYMRET ;NO SUITABLE MODULE FOUND, CAN'T DO CONVERSION
HLRE T2,-1(T1) ;FIND START ADDRESS OF SYMBOLS
ADD T1,T2
;NOW HAVE T1 POINTING TO FIRST SYMBOL IN MODULE, AND
;MODEND = END+1 ADDRESS OF SYMBOLS IN MODULE
SYMLP: MOVE T2,1(T1) ;GET A SYMBOL VALUE
CAMG T2,ADR ;BELOW DESIRED ADDRESS?
CAMGE T2,VAL ;YES, BETTER VALUE THAN PREVIOUS BEST?
JRST SYMLPN ;NO, FORGET IT
PUSHJ P,SUPCHK ;IS SYMBOL OF FORM <n>M?
JRST SYMLPN ;YES, FORGET IT EVER HAPPENED
DMOVE T2,(T1) ;GET SYMBOL AND VALUE
MOVEM T2,SYM ;SAVE NEW SYMBOL NAME
MOVEM T3,VAL ;SAVE NEW BEST VALUE
SYMLPN: ADDI T1,2 ;BUMP TO NEXT SYMBOL
CAMGE T1,MODEND ;AT END OF MODULE?
JRST SYMLP ;NO, SEARCH WHOLE THING
AOS (P) ;INCREMENT RETURN ADDRESS
DMOVE T1,SYM ;GET SYMBOL AND ADDRESS TO CONVERT
TLZ T1,740000 ;CLEAR HIGH BITS OF SYMBOL
MOVE T3,MODNAM ;AND GET THE MODULE NAME
SYMRET: POPJ P,
SEGMENT DATA
SYM: BLOCK 1 ;SYMBOL
VAL: BLOCK 1 ;ITS VALUE
ADR: BLOCK 1 ;ADDR WE'RE TRYING TO MATCH
SYMBEG: BLOCK 1 ;BEG OF SYMBOL TABLE
MODEND: BLOCK 1 ;MODULE END
TSYM: BLOCK 1 ;TEST SYMBOL
TVAL: BLOCK 1 ;TEST VALUE
TMOD: BLOCK 1 ;TEST MODULE NAME
SEGMENT ERR
;ROUTINE TO DECIDE IF A SYMBOL SHOULD BE SUPPRESSED FROM TYPEOUT
;ARG: T1 = POINTER TO SYMBOL
;NONSKIP RETURN IF SYMBOL SHOULD BE SUPPRESSED.
;SUPPRESSED SYMBOLS ARE:
; COMPILER-GENERATED TEMP LABELS OF THE FORM <DIGITS>M
; SYMBOLS (CURRENTLY GENERATED ONLY BY MACRO) DEFINED WITH ==
;PRESERVES T1
SUPCHK: MOVE T2,(T1) ;GET RADIX50 SYMBOL NAME
JUMPL T2,%POPJ ;IF SUPPRESS BIT SET, SUPPRESS SYMBOL
TLZ T2,740000 ;CLEAR EXTRA BITS
IDIVI T2,50 ;GET LOW-ORDER CHAR IN T4
JUMPE T2,%POPJ1 ;IF SYMBOL WAS ONLY 1 CHAR, NOT AN M-SYMBOL
CAIE T3,R50(M) ;DOES SYMBOL END WITH M?
JRST %POPJ1 ;NO, NOT AN M-SYMBOL
SCHKLP: IDIVI T2,50 ;GET NEXT CHAR
CAIL T3,R50(0) ;IS IT A DIGIT?
CAILE T3,R50(9)
JRST %POPJ1 ;NONDIGIT, NOT AN M-SYMBOL
JUMPN T2,SCHKLP ;CHECK WHOLE SYMBOL FOR DIGITNESS
POPJ P, ;SYMBOL IS AN M-SYMBOL, SUPPRESS IT
;HERE FROM ADJSP MACRO ON NON-KL IF ADD MAKES P GO POSITIVE
IFE FTKL,<
%STKOV::
ERR (POV,?,PDL overflow,,%HALT##)
>
PURGE $SEG$
END