Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-BB_1985_short
-
forerr.mac
There are 27 other files named forerr.mac in the archive. Click here to see a list.
SEARCH MTHPRM,FORPRM
TV FORERR ERROR HANDLER,10(4156)
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1985
;ALL RIGHTS RESERVED.
;
;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.
***** Begin Version 7 *****
3035 JLC 5-Feb-82
Add error messages for new binary code. Combine
error message for ordinary I/O and ENCODE/DECODE.
3037 JLC 11-Feb-82
Add new error msg for dump mode IO list too long.
Removed non-fatal error messages for magtape.
3056 JLC 23-Mar-82
Separated error messages from FORERR into FORMSG.MAC.
Fixed error buffer typeout so it doesn't trash the FOROTS
data area if the record is very long. Make TRACE work
in extended sections.
3122 JLC 28-May-82
Rework of error entry. Moved %IOERR into FORERR. Rework
of calling user program.
3125 JLC 3-May-82
Moved the error character to the beginning of the error macros.
3136 JLC 26-Jun-82
Separated the 2nd error number from the type code in the
trap subroutine block.
3140 JLC 2-Jul-82
Get proper PC for $P in extended sections.
3141 JLC 2-Jul-82
Fix to edit 3140.
3147 AHM 8-Jul-82
Fix GETPC so that it doesn't die trying to evaluate the jump
address of PUSHJs and overlay calls. Merely setting the sign
bit on a word that has bit 1 set (such as the PUSHJ
instruction) resulted in a type 3 indirect word that causes an
ill mem ref. Bit 0 must be set and bit 1 must be cleared.
3151 AHM 13-Jul-82
Add a whole new ADRCHK for Tops-20 that decides whether or not
a PC is believable by checking whether it refers to an
existing section. Also, preserve section numbers in GETPC.
3155 AHM 19-Jul-82
Remove a lot of code that discards section numbers around
ADDPCM, TRACEL and SYMSRH. Also, make ADRCHK punt on section
numbers that are greater than 37.
3161 JLC 16-Aug-82
Added $R, to print out a record number from CREC(D).
3162 AHM 23-Aug-82
Make the Tops-20 ADRCHK light FH%EPR when running in a
non-zero section so that addresses getting checked don't have
section 0 interpreted as "our section".
3165 JLC 28-Aug-82
Fix error record typout by rewriting it.
3166 JLC 31-Aug-82
Eliminate ER2PTR ref, fix SYMSRH so it doesn't need XHLLI,
which isn't defined on the -10.
3172 JLC 2-Sep-82
Fix code at NERR1 to get proper PDP to use for NOSYM. Fix
NOSYM so it wasn't fooled by T2 pointing to MAIN. if no
stuff on stack.
3175 JLC 8-Sep-82
Fix $I to get the error bits from the right place.
3176 JLC 9-Sep-82
Installed disk quota exceeded trap.
3200 JLC 24-Sep-82
Save ACs in 3 separate local areas instead of on the stack,
to avoid problems with global stacks. Fix I/O within I/O,
that is, used A.UNIT instead of UNUM(U) to type the unit
number in the fatal message.
3201 JLC 4-Oct-82
Add kluge to prevent tracing arg lists of MTHCPX routines which
don't have an arglist.
3202 JLC 26-Oct-82
Fix AC save routines so they don't use the stack, so that
non-zero section stacks are TRACEable.
3216 JLC 16-Nov-82
Restore the ERSTKP on ERR= and IOSTAT=.
3217 PLB 17-Nov-82
Change ADRCHK to check %FSECT to get FOROTS section.
3225 JLC 24-Nov-82
Type nulls in records and FORMATs as spaces. Fix TRACE for
calls from APR traps.
3231 JLC 14-Dec-82
Fix GETPC for multiple sections of code, allow indexed PUSHJs
and indexed and indirected XMOVEIs.
3240 JLC 20-Dec-82
Fix TRACE called from a user program - was using last stored
trace stack.
3250 JLC 7-Jan-83
Use SVEACS for TRACE instead of %SAVAC, so user can trace
from ERRSET subroutine on I/O warnings.
3252 JLC 12-Jan-83
Fix RENAME error msg reporting, by making $F get an argument,
supplied in the error msg macro.
3253 JLC 14-Jan-83
Fix TRACE so it saves and restores the GETPC return PC.
3260 JLC 17-Jan-83
Fix library error reporting with no symbols so that positive
PC offsets get out. Fix TRACE not to print PCs on every line
if it is the ERRSET routine.
***** End V7 Development *****
3271 JLC 14-Feb-83
Restore the AC's before jumping out of TRACE or exiting it.
3275 RJD 18-Mar-83
Have TRACE routine print the number of arguments in decimal
rather than in octal.
3352 MRB 27-Sep-83
Insert a check for arithmetic trap errors and change the
second number to the number of the occurances (of the error).
3353 RJD 30-Sep-83
Have XTIME routine handle elapsed times with greater
than 99 hours.
3375 RJD 14-Dec-83 SPR:10-34341
Have XTIME use the DPOS routine to print hours.
3406 TGS 25-Jan-84 SPR:NONE
Fix SYMCNV/SYMSRH to properly handle extended addresses. Values
fetched from the symbol table were not always having a section
number inserted. If the symbol+offset found is an offset from
MAIN. and there is also a PROGRAM name symbol, prefer the latter.
***** Begin Version 10 *****
4000 JLC 22-Feb-83
Save/restore ACs around TRACE calls correctly. Move code
around to prevent GETPC call for library warnings unless
an ERRSET or break address is set.
4013 PLB 1-Jun-83
Fix FOREC to be able to type out library errors when
the error text resides in a different section from FORERR.
4014 JLC 14-Jun-83
Changed names of some DDB variables so they wouldn't conflict
with definitions in MACSYM and MONSYM.
4015 PLB 21-Jun-83
Fix SYMSRH to handle symbol table from another section.
4021 PLB 24-Jun-83
Teach TRACE% not to use AOBJN.
4031 JLC 7-Jul-83
Fix FORER% so it uses the lowseg arg list for the user
subroutine call.
4036 JLC 8-Aug-83
Widen TRACE output for extended addressing.
4037 JLC 11-Aug-83
Fix error messages which have no unit number printed
Also fix TRACE output so it's aligned.
4044 JLC 27-Sep-83
Changed type code for immediate args to "I" for tracebacks.
4046 JLC 3-Oct-83
Repair edit 3352. Return sense of %CHKEL is opposite from
V7.
4047 JLC 5-Oct-83
Fix GETPC for routines in overlays.
4050 JLC 6-Oct-83
Modify TRACE to give special trace line for ERRSET subroutine
calls.
4051 JLC 6-Oct-83
Fix edit 4050. Setup of L was moved to after it was used.
4052 JLC 12-Oct-83
Don't print magtape attributes in error lines. Code changes
necessary for minor performance enhancements for formatted
I/O.
4061 JLC 4-Nov-83
Fix IOSTAT bug, set %ERIOS instead of IOSTAT variable,
set IOSTAT variable in %SETAV at end of I/O.
4064 JLC 14-Nov-83
Fix updated IOSTAT processing, was not recording IOSTAT value
if no DDB.
4065 JLC 6-Dec-83
Remove some unused code.
4066 JLC 11-Jan-84
More preparations for RMS.
4076 TGS 6-Feb-84
Fix SYMSRH so it does not depend on the module count word in
the symble table containing an 18-bit module start address in
the right half. Future LINKs may not supply this in non-zero
sections. Search for the global symbol corresponding to the
module name instead.
4077 JLC 6-Feb-84
Fix tracebacks so they print more information, especially
in the case of I/O errors where ERRSET has been used. This
code depends on the previous development effort which
eliminated IOPDL.
4102 JLC 17-Feb-84
Use the "standard" filename string code to get the
filename for error messages. Eliminate the extraneous
blank in non-filename typeouts. Create a new entry point
for compatibility message output.
4104 JLC 22-Feb-84
More compatibility flagging code.
4105 JLC 28-Feb-84
Change the handling of fatal ("?") error messages to
always go to a fatal error handler (e.g., %ABORT).
Add a new entry for DIALOG error handling: %DERR, called
with a $DCALL, which sets the fatal error handler to
REQDIA.
4106 JLC 2-Mar-84
Fix ADRCHK bug - we were calling it with the address in
the stack entry, then actually peeking at that address-1,
creating pages on the -20 and getting ill mem ref on the -10.
4107 JLC 5-Mar-84
Add $E to TOPS-20 message handler, same as $J.
4111 JLC 16-Mar-84
Add two new entry points (%AERR and %DERR) for fatal error messages.
Ignore the continuation address, and substitute a fatal
error handler address (%ABORT or REQDIA) for $AERR and $DERR.
4114 JLC 28-Mar-84
Remove I%TCH on TOPS-10, as it is almost useless
and didn't work anyhow.
4116 JLC 4-Apr-84
Remove $E, substitute (smarter) $J.
4122 JLC 2-May-84
A whole raft of changes to make the TOPS-10 and TOPS-20
DDB databases the same.
4123 JLC 5-May-84
Fix ADRCHK on TOPS-10 for twoseg programs.
4127 JLC 15-May-84
Partial fix for ERR= and IOSTAT= freeing of UDB and DDB.
Eliminate F%DCU.
4131 JLC 12-Jun-84
Hopefully final fix for ERR= and IOSTAT= freeing of UDB and
DDB. Add $E for memory full diagnostic. For TOPS-20, save the
I/O error (retrieved with GETER%) in saved T1, so that recursive
errors (such as an error on the DIVERT unit) will not lose it.
Fix the TOPS-10 error diagnostic for "wrong direction for device".
4152 JLC 24-Sep-84
Use %SVCNV to convert the contents of .JBSYM into address
and length of symbol table.
4153 JLC 27-Sep-84
Reference the user program start address indirectly, as it is now
the address of a location containing the start address.
4154 JLC 1-Oct-84
Don't call error break subroutine for informational messages
or FOROTS internal errors.
4155 JLC 17-Oct-84
Deallocate the rename DDB and UDB on errors with IOSTAT= or ERR=.
4156 JLC 23-Oct-84
Since we set %UDBAD to -1 in %SAVAC so that it is really a flag
of whether I/O is in progress, we must check for %UDBAD being
negative or zero.
***** End V10 Development *****
***** End Revision History *****
\
ENTRY %TRACX,%IOERR,%OTSER,%TRPER
EXTERN %UDBAD,%DDBTAB,%FSECT,I.BAT,%PC1,%ABORT,%ABFLG,I.XSIR,O.DIAL
EXTERN %SETAV,%FREBL,%EOREC,%HALT,%CIPOS,%CLSCL,%RNAMD,%RNAMU
EXTERN E.NAM,%MSGVX,%MSG77,%MSGB,%FLIDX,%IONAM
EXTERN %SAVE1,%SAVE2,%SAVE3,AU.ACS
EXTERN %ERRCT,%ERRLM,%ERRSB,%ERRSZ,%ERRBK,%NAMLN,%LALAD
EXTERN %POPJ,%POPJ1
EXTERN %STADD
EXTERN %RIPOS,%SIPOS,%IBYTE,%ERFNS,%SVCNV
EXTERN FMT.BP,FMT.BG,FMT.SZ,USR.SZ
EXTERN A.END,A.ERR,A.IOS,%CUNIT
EXTERN %FSECT
EXTERN %MSLVL
INTERN %ERNM1,%ERNM2,%UNFXD,%FIXED,%ERTYP,%ERPDP,%ERRPC,%ERCHR
INTERN %DFERR,%ERNAM,%LERN1,%LERN2,%ERIOS,%EOPTR,%EOCNT,%ERINI
INTERN %DERR,%AERR
SEGMENT CODE
IF10,<
%DFERR: $SNH ;NO DISK-FULL HANDLER NEEDED ON TOPS-10
>
IF20,<
;DISK FULL ERROR HANDLER
;GETS HERE VIA THE SOFWARE INTERRUPT SYSTEM IF THE USER HAS NOT
;STOLEN THE CHANNEL FROM FOROTS. TREATED LIKE ANY OTHER I/O ERROR,
;EXCEPT THAT IF THE PROCESS IS INTERACTIVE, IT DOES A HALTF% TO
;LET THE USER EXPUNGE OR OTHERWISE CLEAN UP THE DISK, AND THEN,
;IF CONTINUED, WILL DEBRK% TO CONTINUE THE PROCESS. IF THE PROCESS
;IS BATCH, WE JUST JUMP OFF TO %ABORT TO CLOSE ALL FILES.
;FOR THE ERR= AND IOSTAT= CASE, IT IS COMPLICATED BY THE FACT
;THAT WE MUST DO A DEBRK%, BUT WE DO NOT WANT TO CONTINUE
;THE PROCESS AT THE INTERRUPTED LOCATION, SO WE MUST SUBSTITUTE
;THE ERR= OR (FOR IOSTAT WITH OLDER .REL FILES) THE RETURN ADDRESS
;FROM THE FOROTS CALL FOR THE INTERRUPT ADDRESS.
%DFERR: SKIPE I.BAT ;BATCH JOB?
JRST SETDBK ;YES. DEBREAK AND HANDLE ERR= OR ABORT
SKIPN A.ERR ;ERR= OR IOSTAT= SPECIFIED?
SKIPE A.IOS
JRST SETDBK ;YES. SET DEBREAK ADDRESS TO ERROR HANDLER
$ECALL DQW ;NO. PRINT DISK QUOTA EXCEEDED MESSAGE
HALTF% ;HALT THE PROCESS
DEBRK% ;CONTINUE THE PROCESS IF CONTINUED
SETDBK: PUSH P,T1 ;SAVE T1 VERY TEMPORARILY
XMOVEI T1,DFDBK ;SET DEBREAK ADDRESS HERE
SKIPN I.XSIR ;USING EXTENDED PSI TABLE?
JRST STDBS0 ;NO
MOVEM T1,%PC1+1
POP P,T1 ;RESTORE T1
DEBRK%
STDBS0: HRRM T1,%PC1 ;STORE PC
POP P,T1 ;RESTORE T1
DEBRK% ;AND DEBREAK
DFDBK: $ACALL DQE ;AND PRINT ERROR MESSAGE AND DIE
> ;END IF20
;HERE FROM ERROR MACROS
;
;CALLS:
;
; $DERR (CHR,COD,N1,N2,MSG,ARGS,FLGS) ;ERROR WITH DIALOG REQUEST
; $ERR (CHR,COD,N1,N2,MSG,ARGS,FLGS) ;FOROTS ERROR OR PROMPT LINE
; $IOERR (CHR,COD,N1,N2,MSG,ARGS,FLGS) ;I/O ERROR
; $LERR (CHR,COD,N1,N2,MSG,ARGS,FLGS) ;MATHLIB ERROR
; $FERR (CHR,COD,N1,N2,MSG,ARGS,FLGS) ;FORLIB ERROR
; $TERR (CHR,COD,N1,N2,MSG,ARGS,FLGS) ;APR TRAP CALL
;
;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
;COD 3-CHARACTER PREFIX
;N1 ERROR CLASS NUMBER
;N2 2ND ERROR NUMBER
;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
;FLGS ERROR FLAGS
;
;THE ERROR MACROS GENERATE 1 WORD IN LINE, SO CAN BE SKIPPED OVER.
;THEY DO NOT ALTER ANY ACS.
%ERINI: XMOVEI T1,ERRSTK ;SETUP ERROR STACK
MOVEM T1,ERSTKP
POPJ P,
%CMSG: 0 ;NO COMPATIBILITY MESSAGE
%MSGVX ;VAX COMPATIBILITY MESSAGE
%MSG77 ;ANSI-77 COMPATIBILITY MESSAGE
%MSGB ;BOTH VAX AND ANSI-77
%IOERR: POP P,IOERP ;SAVE ARG POINTER
PUSHJ P,SVEACS ;SAVE THE ACS ON THE ERROR STACK
SETZM FERADR ;NO FATAL ERROR ADDRESS
JRST IOER1 ;JOIN COMMON CODE
%DERR: POP P,IOERP ;SAVE ARG POINTER
PUSHJ P,SVEACS ;SAVE THE ACS ON THE ERROR STACK
XMOVEI T1,REQDIA ;GET ADDR OF DIALOG REQUEST
SKIPE %ABFLG ;[4131] BUT IF WE ARE ABORTING
XMOVEI T1,%ABORT ;[4131] ABORT IT AGAIN
MOVEM T1,FERADR ;SAVE AS FATAL ERROR ADDRESS
JRST IOER1 ;JOIN COMMON CODE
%AERR: POP P,IOERP ;SAVE ARG POINTER
PUSHJ P,SVEACS ;SAVE THE ACS ON THE ERROR STACK
XMOVEI T1,%ABORT ;GET ADDR OF ABORT ENTRY
MOVEM T1,FERADR ;SAVE AS FATAL ERROR ADDRESS
IOER1: MOVE P2,IOERP ;GET ARG POINTER
MOVEM P2,%ERPTR ;SAVE FOR COMMON ROUTINES
MOVE T2,%NUM1(P2) ;GET ERROR CLASS NUMBER
MOVEM T2,%ERNM1 ;SAVE ERROR CLASS NUMBER
MOVEM T2,%LERN1 ;ALSO SAVE IT SEMI-PERMANENTLY
MOVE T2,%NUM2(P2) ;GET 2ND ERROR NUMBER
MOVEM T2,%ERNM2 ;SAVE 2ND ERROR NUMBER
MOVEM T2,%LERN2 ;ALSO SAVE IT SEMI-PERMANENTLY
XMOVEI T1,%ARGS-1(P2) ;GET ARGUMENT POINTER
MOVEM T1,ARGPTR ;SAVE IT
MOVE T1,%FLGS(P2) ;[4131] GET ERROR FLAGS
TXNE T1,I%JERR ;[4131] $J IN ERROR MSG?
PUSHJ P,ESAVE ;[4131] YES. GET ERROR CODE INTO SAVED T1
MOVE T1,%CHR(P2) ;GET CHARACTER
CAIN T1,"$" ;CHARACTER IN ARGUMENT?
PUSHJ P,GETARG ;YES. GET IT
MOVEM T1,%ERCHR ;SAVE IT FOR MESSAGE
;If this is a "?" error, do the ERR= or END= stuff
CAIE T1,"?" ;"?" says take ERR= if we can.
JRST NERR1 ;Not fatal, just go type message
;Fatal error. Clear %UDBAD
; This is so all the IOLST. calls that follow an IO call that gets
; a fatal error will not screw up things any more.
SKIPGE %ERNM2 ;EOF?
SKIPN T1,A.END ;Yes, use END= address not ERR=
;But if no END= specified, use ERR=
MOVE T1,A.ERR ;Get ERR= Address
JUMPE T1,NERR ;IF ANY
XMOVEI T1,@T1 ;DO EA CALC
;Take END= or ERR= branch.
;Address of where to go is in T1.
;T2 contains the error number
MOVE P,AU.ACS ;GET ADDR OF USER'S ACS
MOVE P,P(P) ;GET THE OLD STACK
MOVEM T1,(P) ;Store return address
ADJSP P,1 ;WE NEED OUR ACS BACK
PUSHJ P,%EMSGT ;Get error message text for ERRSNS.
MOVE T1,%ERNM2 ;GET 2ND ERROR NUMBER
MOVEM T1,%ERIOS ;SAVE FOR IOSTAT VARIABLE SETTING
PUSHJ P,FXTRET ;FIXUP STUFF TO RETURN
MOVNI T1,20 ;ADJUST ERROR STACK POINTER
ADDM T1,ERSTKP ;TOSS THE SAVED FOROTS ACS
PJRST %SETAV ;RETURN TO USER PROGRAM
;No END= or ERR= specified
NERR: SKIPN A.IOS ;How about IOSTAT=?
JRST NERR1 ;No
;Return to next statement in the program.
;For V7 and beyond, this code should never be
;executed, since IOSTAT= gets a gratutious ERR= to avoid
;character stack unwinding and function call problems.
PUSHJ P,%EMSGT ;Get error message text for ERRSNS.
MOVE T1,%ERNM2 ;GET 2ND ERROR NUMBER
MOVEM T1,%ERIOS ;SAVE FOR IOSTAT VARIABLE SETTING
PUSHJ P,FXTRET ;Fixup stuff to return
MOVE P,AU.ACS ;GET ADDR OF USER'S ACS
MOVE P,P(P) ;RESET STACK
ADJSP P,1 ; Fix so we get our acs back
MOVNI T1,20 ;ADJUST ERROR STACK POINTER
ADDM T1,ERSTKP ;TOSS THE SAVED FOROTS ACS
PJRST %SETAV ;RETURN TO USER'S PROGRAM
;Routine to fixup stuff to return from IO error.
;[4131] NEW CODE
FXTRET: SKIPE T1,%RNAMU ;[4155] ANY UDB FOR RENAME?
PUSHJ P,%FREBL ;[4155] YES. DEALLOCATE IT
SKIPE T1,%RNAMD ;[4155] ANY DDB FOR RENAME?
PUSHJ P,%FREBL ;[4155] YES. DEALLOCATE IT
SETZM %RNAMU ;[4155] NOW CLEAR THEIR POINTERS
SETZM %RNAMD ;[4155]
SKIPG U,%UDBAD ;[4156] ANY DDB ALLOCATED?
POPJ P, ;No. Don't deallocate
HXRE T1,UNUM(U) ;GET THE UNIT NUMBER
CAIG T1,MAXUNIT ;IS IT A REAL UNIT?
CAMGE T1,[MINUNIT]
POPJ P, ;NO. LEAVE
SKIPE %DDBTA(T1) ;IS DDB ESTABLISHED?
POPJ P, ;YES. DON'T FREE IT
MOVE D,DDBAD(U) ;GET DDB ADDRESS TO TOSS
PJRST %CLSCL ;CLEAN UP AS IF AFTER CLOSE
;Print out the error.
NERR1: MOVE P1,P ;USE CURRENT STACK PNTR
PUSHJ P,GETPC ;GET CALLER, CALLED ADDR
MOVEM P1,%ERPDP ;SAVE NEXT STACK IN CASE NO SYMBOLS
MOVEM T1,%ERRPC ;SAVE PC OF CALL
MOVE T1,-1(T2) ;[4131] GET NAME OF FOROTS ROUTINE
MOVEM T1,%ERNAM ;[4131] SAVE FOR MESSAGE
SETZM MSGPC ;ASSUME NO PC DESIRED IN MESSAGE
PUSHJ P,%CHKEL ;CHECK IF WE SHOULD PRINT MESSAGE
PUSHJ P,IOMSG ;YES. OUTPUT MESSAGE
XMOVEI T1,%EARGL ;GET ADDRESS OF OTS ERROR BLOCK
MOVEM T1,EARGPT ;SAVE IT FOR USER SUBR CALL
SKIPN FERADR ;ANY FATAL ERROR ADDRESS SET?
JRST CALRET ;NO. GO CALL USER, RETURN
PUSHJ P,CALRET ;YES. CALL USER
JRST @FERADR ;AND GO TO FATAL ERROR HANDLER
IOMSG: SKIPE %NAMLN ;NAME LINE ALREADY OUT?
JRST FOREC ;YES. JUST OUTPUT MESSAGE DIRECTLY
MOVE T1,%ERRPC ;GET ERROR PC
MOVEM T1,MSGPC ;SAVE IT FOR MESSAGE
XMOVEI T2,E.NAM+%EOFF ;POINT TO MESSAGE DESIRED
MOVEM T2,%ERPTR ;SAVE POINTER
PUSHJ P,FOREC ;OUTPUT IT
SETZM MSGPC ;NO PC PRINTOUT ON SUBSEQUENT LINES
MOVE T1,IOERP ;GET ORIGINAL POINTER BACK
MOVEM T1,%ERPTR ;SAVE POINTER
SETOM %NAMLN ;SET FLAG SO WE DON'T GET NAME LINE AGAIN
PJRST FOREC ;OUTPUT THE MESSAGE
REQDIA: SKIPGE I.BAT## ;BATCH?
JRST %ABORT ;YES, DON'T TRY TO DIALOG WITH A .CTL FILE
SETOM O.DIAL ;[4131] SET REQUEST FOR DIALOG
POPJ P, ;RETURN FROM ROUTINE CONTAINING ERROR
%TRPER: POP P,%ERPTR ;GET ERROR BLOCK POINTER
PUSHJ P,SVEACS ;SAVE THE ACS ON THE ERROR STACK
MOVE T1,%ERRPC ;GET ERROR PC
MOVEM T1,MSGPC ;SAVE FOR MESSAGE
MOVE T1,%ERPTR ;GET ERROR BLOCK POINTER
MOVE T2,%NUM1(T1) ;GET ERROR CLASS NUMBER
MOVEM T2,%ERNM1 ;SAVE ERROR CLASS NUMBER
MOVE T2,%NUM2(T1) ;GET 2ND ERROR NUMBER
MOVEM T2,%ERNM2 ;SAVE 2ND ERROR NUMBER
PUSHJ P,%CHKEL ;CHECK IF WE WANT MESSAGE
PUSHJ P,FOREC ;YES. OUTPUT THE MESSAGE
XMOVEI T1,%EARGL ;GET ADDRESS OF OTS ERROR BLOCK
MOVEM T1,EARGPT ;SAVE IT FOR USER SUBR CALL
JRST CALRET ;GO CALL USER, RETURN
%OTSER: POP P,%ERPTR ;GET ERROR BLOCK POINTER
MOVEM P,%ERPDP ;SAVE CALLER ADDR FOR MSG
PUSHJ P,SVEACS ;SAVE ACS
MOVE T1,%ERPTR ;GET ERROR BLOCK POINTER
MOVE T2,%NUM1(T1) ;GET ERROR CLASS NUMBER
MOVEM T2,%ERNM1 ;SAVE ERROR CLASS NUMBER
MOVE T2,%NUM2(T1) ;GET 2ND ERROR NUMBER
MOVEM T2,%ERNM2 ;SAVE 2ND ERROR NUMBER
SETZM %ERRPC ;NO PC TO GIVE
SETZM MSGPC ;DON'T PRINT PC IN GENERAL
PUSHJ P,%CHKEL ;CHECK IF WE WANT MESSAGE
PUSHJ P,FOREC ;YES. OUTPUT MESSAGE
XMOVEI T1,%EARGL ;GET ADDRESS OF OTS ERROR BLOCK
MOVEM T1,EARGPT ;SAVE IT FOR USER SUBR CALL
JRST CALRET ;GO CALL USER, RETURN
FENTRY (MTHER,FORER)
POP P,%ERPTR ;SAVE ERROR BLOCK POINTER
MOVEM P,%ERPDP ;SAVE PDP FOR NOSYM
PUSHJ P,SVEACS ;SAVE ACS
MOVE T1,%ERPTR ;GET ERROR BLOCK POINTER
MOVE T2,%NUM1(T1) ;GET ERROR CLASS NUMBER
MOVEM T2,%ERNM1 ;SAVE ERROR CLASS NUMBER
MOVE T2,%NUM2(T1) ;GET 2ND ERROR NUMBER
MOVEM T2,%ERNM2 ;SAVE 2ND ERROR NUMBER
MOVE T1,%LALAD ;GET LOWSEG ARG LIST ADDRESS
MOVEM T1,EARGPT ;SAVE FOR USER SUBR CALL
PUSHJ P,%CHKEL ;CHECK IF WE WANT MESSAGE
JRST FOMSG ;YES. GO GET PC AND OUTPUT MESSAGE
PUSHJ P,ECHKU ;CHECK IF USER SUBR TO CALL
JRST FOCALU ;YES. GO GET PC AND CALL USER
PUSHJ P,ECHKB ;CHECK IF BREAK SPECIFIED
JRST FOCALB ;YES. GO GET PC AND BREAK
JRST ERRET ;RETURN
FOMSG: PUSHJ P,FOGPC ;GET PC
PUSHJ P,FOREC ;OUTPUT MESSAGE
JRST CALRET ;GO CALL USER, RETURN
FOCALU: PUSHJ P,FOGPC ;GET PC
JRST CALRET ;CALL USER, RETURN
FOCALB: PUSHJ P,FOGPC ;GET PC
PUSHJ P,ECALB ;CALL BREAK
JRST ERRET
FOGPC: MOVE P1,%ERPDP ;GET ERROR STACK PNTR AGAIN
PUSHJ P,GETPC ;GET CALLER ADDR
MOVEM T1,%ERRPC ;SAVE IT
MOVEM T1,MSGPC ;SAVE FOR MESSAGE
MOVE T1,-1(T2) ;GET NAME OF LIBRARY ROUTINE
MOVEM T1,%ERNAM ;SAVE FOR MESSAGE
MOVEM P1,%ERPDP ;SAVE USER'S STACK PNTR
POPJ P,
CALRET: PUSHJ P,ECALU ;CALL USER IF SPECIFIED
PUSHJ P,ECALB ;CALL BREAK ROUTINE
ERRET: MOVNI T1,20 ;DROP THE ERROR STACK POINTER
ADDM T1,ERSTKP ;A BLOCK OF ACS
HRLZ 16,ERSTKP ;RESTORE ACS
BLT 16,16
POPJ P,
FOREC: MOVE P2,%ERPTR ;POINT TO ERROR BLOCK
PUSHJ P,EMSGT0 ;Get error message text
SKIPE MSGPC ;PC TO PRINT?
PUSHJ P,ADDPCM ;YES. Add PC to message text.
PUSHJ P,EMSGT1 ;FINISH ERROR MESSAGE
MOVE T1,[POINT 7,ERRBUF] ;GET POINTER TO ERROR BUFFER
MOVEM T1,%EOPTR ;SAVE IT
MOVEI T1,5*LERRBF-1 ;GET ORIGINAL COUNT
SUB T1,ERRCNT ;GET # CHARS IN MESSAGE
MOVEM T1,%EOCNT ;SAVE IT
PUSHJ P,%EOREC ;TYPE MESSAGE
MOVE T1,%FLGS(P2) ;GET FLAGS
TXNE T1,I%REC ;TYPE RECORD WITH ARROW UNDER IT IF REQUESTED
JRST RECTYP
TXNE T1,I%REC1 ;TYPE RECORD WITH ARROW MOVED back 1
JRST RCTYB1
TXNE T1,I%FMT ;TYPE FORMAT WITH ARROW UNDER IT
JRST FMTTYP
MOVE T1,INICHR ;GET THE INITIAL CHAR AGAIN
CAIN T1,"@" ;WAS IT REALLY BAD?
JRST %HALT ;YES. STOP EVERYTHING
POPJ P,
%CHKEL: MOVE T1,%ERPTR ;GET ERROR BLOCK POINTER
SKIPGE T2,%NUM1(T1) ;GET 1ST ERROR NUMBER
POPJ P, ;IF NEGATIVE, DON'T CHECK LIMITS
CAIL T2,%ERRSZ ;WITHIN ERROR TABLE?
POPJ P, ;NO. DON'T CHECK ANYTHING
AOS T4,%ERRCT(T2) ;INCREMENT LIBRARY ERROR COUNT
MOVE T3,%CHR(T1) ;GET INITIAL CHARACTER
CAIN T3,"?" ;FATAL ERROR?
POPJ P, ;YES. DON'T CHECK LIMITS
MOVE T1,%ERNM1 ;[3352]get first number
CAIGE T1,10 ;[3352]Is it less than 10?
MOVEM T4,%ERNM2 ;[3352]Yes; save new second number!
CAMLE T4,%ERRLM(T2) ;[3352]PAST LIMIT?
AOS (P) ;YES. SKIP RETURN
POPJ P,
ECHKB: SKIPN %ERRBK ;ANY BREAK ADDR?
AOS (P) ;NONE
POPJ P,
ECALB: SKIPE P1,%ERRBK ;[4154] GET BREAK ADDR
SKIPGE %ERNM1 ;[4154] DON'T BREAK ON ERRORS WITH NUM1=-1
POPJ P, ;[4154] NO BREAK ADDR OR NUM1 NEGATIVE
ECALB1: MOVE L,EARGPT ;GET ARG POINTER
MOVE T1,%ERNM1 ;GET ERROR CLASS AGAIN
MOVEM T1,@%OECN(L) ;SAVE IT
MOVE T1,%ERRPC ;GET PC
MOVEM T1,@%OEPC(L) ;SAVE IT
MOVE T1,%ERNM2 ;GET 2ND ERROR NUMBER
MOVEM T1,@%OIEN(L) ;SAVE IT
PJRST @%ERRBK ;** Call user routine **
ECHKU: SKIPGE T1,%ERNM1 ;GET ERROR CLASS, NO SUBR IF NEGATIVE
JRST %POPJ1
CAIGE T1,%ERRSZ ;WITHIN TABLE?
SKIPN P1,%ERRSB(T1) ;YES. ANY USER TRAP ROUTINE SPECIFIED?
AOS (P) ;NO. SKIP RETURN
POPJ P,
ECALU: SKIPGE T1,%ERNM1 ;GET ERROR CLASS, NO SUBR IF NEGATIVE
POPJ P,
CAIGE T1,%ERRSZ ;WITHIN TABLE?
SKIPN P1,%ERRSB(T1) ;YES. ANY USER TRAP ROUTINE SPECIFIED?
POPJ P, ;NO. RETURN
MOVEM P1,USRADR ;SAVE ADDR FOR CALL
MOVE L,EARGPT ;GET ARG POINTER
MOVE T1,%ERNM1 ;GET ERROR CLASS AGAIN
MOVEM T1,@%OECN(L) ;SAVE IT
MOVE T1,%ERRPC ;GET PC
MOVEM T1,@%OEPC(L) ;SAVE IT
MOVE T1,%ERNM2 ;GET 2ND ERROR NUMBER
MOVEM T1,@%OIEN(L) ;SAVE IT
XMOVEI L,@EARGPT ;GET ARG POINTER IN WAY SO TRACE LIKES IT
UTRAPC: PUSHJ P,@USRADR ;CALL USER ROUTINE SO TRACE CAN FIND IT
POPJ P,
-%EAEND+%EARGL,,0
%EARGL: IFIW TP%INT,%EARG1
IFIW TP%INT,%EARG2
IFIW TP%INT,%EARG3
IFIW TP%INT,%ERTYP
IFIW TP%UDF,%UNFXD
IFIW TP%UDF,%FIXED
%EAEND=.
SEGMENT DATA
ERSTKP: BLOCK 1 ;ERROR AC STACK POINTER
AERACS: BLOCK 1 ;LOCAL ADDR OF SAVED ACS
ERRSTK: BLOCK 60 ;ERROR AC STACK
MSGPC: BLOCK 1 ;PC FOR MESSAGE
IOERP: BLOCK 1 ;IOERR PNTR SAVE LOC
EARGPT: BLOCK 1 ;ARG LIST POINTER
USRADR: BLOCK 1 ;USER ROUTINE ADDR
FERADR: BLOCK 1 ;FATAL ERROR HANDLER ADDRESS
;ARGS FOR USER ROUTINE
%EARG1: BLOCK 1 ;ERROR CLASS NUMBER
%EARG2: BLOCK 1 ;PC
%EARG3: BLOCK 1 ;ERROR 2ND NUMBER
%ERTYP: BLOCK 1 ;VARIABLE TYPE
%UNFXD: BLOCK 4 ;UNFIXED RESULT
%FIXED: BLOCK 4 ;FIXED RESULT
%LERN1: BLOCK 1 ;ERROR CLASS NUMBER, NOT CLEARED
%LERN2: BLOCK 1 ;2ND ERROR NUMBER, NOT CLEARED
%ERNM1: BLOCK 1 ;ERROR CLASS NUMBER
%ERNM2: BLOCK 1 ;2ND ERROR NUMBER
%ERIOS: BLOCK 1 ;2ND ERROR NUMBER FOR IOSTAT
%ERNAM: BLOCK 1 ;ROUTINE NAME FOR MESSAGE
%ERRPC: BLOCK 1 ;PC TO TYPE
%ERPTR: BLOCK 1 ;POINTER TO ERROR BLOCK
%ERPDP: BLOCK 1 ;STACK POINTER FOR GETPC, NOSYM
%ERCHR: BLOCK 1 ;ERROR CHAR FOR I/O ERRORS
%EOPTR: BLOCK 1 ;OUTPUT ERROR MESSAGE POINTER
%EOCNT: BLOCK 1 ;OUTPUT ERROR MESSAGE COUNT
SEGMENT CODE
;Routine to save the acs
;Call: PUSHJ P,SVEACS
; <return here>
SVEACS: DMOVEM 0,@ERSTKP ;SAVE 0 AND 1
HRRZ 1,ERSTKP ;GET BASE OF SAVED ACS
MOVEM 1,AERACS ;SAVE LOCAL ADDR OF SAVED ACS
MOVEI 0,(1) ;SETUP FOR BLT
ADD 0,[2,,2] ;SAVE 2-17
BLT 0,17(1)
MOVEI 0,20 ;AND ADJUST THE ERROR STACK
ADDM 0,ERSTKP
POPJ P,
;%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:
;P2 points to error arg block.
%EMSGT: PUSHJ P,EMSGT0 ;Get message text with no null
;Enter here to finish error string
EMSGT1: MOVE T1,INICHR ;GET INITIAL CHAR AGAIN
CAIE T1,"[" ;OPEN BRACKET?
JRST EMSGNL ;PUT A NULL CHAR AT END OF MESSAGE
MOVEI T1,"]" ;YES, TYPE CLOSING BRACKET
PUSHJ P,EPUTCH
EMSGNL: SETZ T1, ;PUT A NULL AT END OF STRING
IDPB T1,ERRPTR ;BUT DON'T COUNT IT AS A CHARACTER
POPJ P,
EMSGT0: XMOVEI P3,%MSG(P2) ;[4013] GET GLOBAL ADDR OF LOCAL BYTE POINTER
HRR P3,%MSG(P2) ;[4013] STEAL Y FIELD OF BYTE POINTER
$BLDBP P3 ;[4013] MAKE POINTER TO INPUT ERROR STRING
MOVE T1,[POINT 7,ERRBUF] ;SET POINTER TO START OF OUTPUT ERR STRING
MOVEM T1,ERRPTR
MOVEI T1,5*LERRBF-1 ;SET COUNT (LEAVE ROOM FOR NULL)
MOVEM T1,ERRCNT
XMOVEI T1,%ARGS-1(P2) ;GET ARG POINTER
MOVEM T1,ARGPTR
MOVE T1,%CHR(P2) ;GET INITIAL CHAR
CAIN T1,"$" ;INDIRECT CHAR?
PUSHJ P,GETARG ;YES, GET PREFIX CHAR
MOVEM T1,INICHR ;SAVE IT
CAIN T1,"@" ;IS IT REALLY BAD?
MOVEI T1,"?" ;YES. SUBSTITUTE A QUERY
PUSHJ P,TYPEQM ;Type it.
ENXTCH: ILDB T1,P3 ;GET NEXT CHAR FROM MSG
JUMPE T1,%POPJ ;END. WE'RE DONE
CAIE T1,"$" ;SPECIAL CHAR?
JRST ECHR ;NO, JUST NORMAL TEXT CHAR
SETZ T2, ;CLEAR ARG
ERARGL: ILDB T1,P3 ;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
;TABLE OF SPECIAL CHAR ACTIONS IN MESSAGES
ERRTAB: XWD "$",$$ ;TYPE $
XWD "[",$LAB ;TYPE LEFT ANGLE BRACKET
XWD "5",$5 ;RADIX50 WORD
XWD "A",$A ;ASCIZ STRING
XWD "C",$C ;ASCII CHAR, RIGHT-JUSTIFIED
XWD "D",$D ;DECIMAL NUMBER
XWD "E",$E ;ADD A USER PC TO THE LINE [4131]
XWD "F",$F ;FILESPEC FROM DDB [NO ARG, USES (D)]
XWD "I",$I ;INCOMPATIBILITY FLAGGER INDEX
XWD "J",$J ;JSYS (TOPS-20) OR I/O (TOPS-10) ERROR
XWD "L",$L ;TYPE VALUE AS SYMBOL+OFFSET
XWD "N",$N ;NAME OF ROUTINE (SIXBIT) FROM %ERNAM [NO ARG]
XWD "O",$O ;OCTAL NUMBER
XWD "P",$P ;ERROR PC, OCTAL [NO ARG]
XWD "R",$R ;RECORD NUMBER
XWD "S",$S ;SIXBIT WORD
XWD "T",$T ;SPACES TO GET TO COL N
XWD "U",$U ;UNIT NUMBER, DON'T TYPE IF NEGATIVE [NO ARG]
XWD "X",$X ;XWD FORMAT, OCTAL
XWD "Y",$Y ;MS TIME AS HH:MM:SS.SS
LERRTB==.-ERRTAB
$LAB: SKIPA T1,["<"] ;TYPE LEFT ANGLE BRACKET [BALANCING >]
$$: MOVEI T1,"$" ;TYPE $
PJRST EPUTCH
$U: SKIPLE %UDBAD ;[4156] ARE WE IN AN I/O STATEMENT?
SKIPGE %CUNIT ;YES. GET UNIT #
POPJ P, ;NOT I/O OR NEG UNIT, NO UNIT NUMBER
MOVEI T1,[ASCIZ / unit /]
PUSHJ P,ASCTYP
MOVE T1,%CUNIT ;GET THE UNIT NUMBER
MOVEI T3,^D10 ;RADIX 10
PJRST NUMLP ;OUTPUT IT
$R: MOVE T1,CREC(D) ;GET CURRENT RECORD NUMBER
JRST DPOS ;GO PRINT IT
$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
$I: PUSHJ P,GETARG ;GET OFFENDING COMP INDEX
AND T1,%FLIDX ;CALC COMPOSITE INDEX
MOVE T1,%CMSG(T1) ;GET ADDRESS OF PROPER STRING
PJRST ASCTYP ;OUTPUT MESSAGE
$N: MOVE T2,%ERNAM
NOPLP: JUMPE T2,%POPJ ;DONE IF ONLY SPACES LEFT
SETZ T1, ;CLEAR CHAR
LSHC T1,6 ;GET CHAR
ADDI T1,40 ;CONVERT TO ASCII
CAIE T1,"." ;PRINT IF NOT DOT
PUSHJ P,EPUTCH ;OUTPUT CHAR
JRST NOPLP
$S: PUSHJ P,GETARG
SIXTYP: MOVE T2,T1
SIX1: JUMPE T2,%POPJ
SETZ T1,
LSHC T1,6
ADDI T1,40
PUSHJ P,EPUTCH
JRST SIX1
$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: MOVE T1,%ERPDP ;GET PDP OF ERROR.
MOVE T1,(T1) ;GET THE CALLER ADDR+1
SUBI T1,1 ;GET ADDR OF CALL
SKIPN %FSECT ;NON-ZERO SECTION?
MOVEI T1,(T1) ;NO. EXCLUDE FLAGS
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 SECONDS
JUMPE T1,TIMEX ;ANY MINUTES?
PUSH P,T2 ;YES, SAVE SECONDS
IDIVI T1,^D60 ;[3353] GET MINUTES
JUMPE T1,PRMIN ;[3353] ANY HOURS?
PUSH P,T2 ;[3353] YES, SAVE MINUTES
MOVE T2,T1 ;[3353] GET HOURS
PUSHJ P,DPOS ;[3375] TYPE HOURS
MOVEI T1,":" ;[3353] TYPE COLON
PUSHJ P,EPUTCH ;[3353]
POP P,T2 ;[3353] GET MINUTES
PUSHJ P,TIMEZ ;[3353] TYPE MINUTES
TRNA ;[3353]
PRMIN: PUSHJ P,TIMEX ;[3353] TYPE MINUTES
MOVEI T1,":" ;TYPE COLON
PUSHJ P,EPUTCH ;
POP P,T2 ;GET SECONDS
TIMEZ: IDIVI T2,^D10 ;[3353] 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
$L: PUSHJ P,GETARG ;GET PC TO CONVERT
MOVEM T1,ORGADR ;SAVE IT
PUSHJ P,SYMCNV ;CONVERT TO LABEL + OFFSET
SKIPN T1,SYMNAM ;GET SYMBOL NAME
JRST MODCNV ;NONE. PRINT MODULE + OFFSET
PUSHJ P,R50TYP ;TYPE IT
MOVE T1,SYMOFF ;GET OFFSET FROM SYMBOL
PJRST OFFTYP ;TYPE IT
MODCNV: MOVE P1,%ERPDP ;GET USER'S PDP
SETZM EADDR
NSYM0: PUSHJ P,GETPC ;GET A PC FROM STACK
JUMPE P1,NSYM1 ;NONE LEFT, DONE
CAML T2,EADDR ;BETTER THAN PREVIOUS BEST APPROXIMATION?
CAMLE T2,ORGADR ;YES, BUT NOT PAST ARG PC?
JRST NSYM0 ;NO, SKIP IT
MOVEM T2,EADDR ;SAVE ROUTINE ADDRESS
JRST NSYM0 ;LOOK THROUGH WHOLE STACK
NSYM1: SKIPN P1,EADDR ;GET ROUTINE ADDRESS
SKIPA P1,@%STADD ;NONE FOUND, USE MAIN START ADDRESS
SKIPA T1,-1(P1) ;GET ROUTINE NAME
MOVE T1,['MAIN. '] ;OR MAIN PROGRAM NAME
PUSHJ P,SIXTYP ;TYPE IT
MOVE T1,ORGADR ;GET ARG PC
SUB T1,P1 ;SUBTRACT ROUTINE ADDRESS
PJRST OFFTYP ;TYPE OFFSET
;Routine called to append the PC to the error message.
$E:
ADDPCM: MOVEI T1,[ASCIZ/ at /]
PUSHJ P,ASCTYP
MOVE T1,MSGPC ;[3155] Get PC
MOVEM T1,ORGADR ;SAVE FOR CONVERSION
PUSHJ P,SYMCNV ;CONVERT TO LABEL+OFFSET
SKIPN T1,SYMNAM ;GET SYMBOL NAME
JRST NOSYM ;NONE. TRY SEARCHING MODULE NAMES
PUSHJ P,R50TYP ;TYPE RADIX50 SYMBOL
MOVE T1,SYMOFF ;GET OFFSET FROM SYMBOL
PUSHJ P,OFFTYP ;TYPE IT AS SIGNED OCTAL
MOVEI T1,[ASCIZ / in /] ;TYPE NOISE WORD FOR MODULE NAME
PUSHJ P,ASCTYP
MOVE T1,SYMMOD ;GET MODULE NAME
PUSHJ P,R50TYP ;TYPE IT TOO
PCTYP: MOVEI T1,[ASCIZ / (PC /] ;FINISH UP WITH THE OCTAL ADDRESS
PUSHJ P,ASCTYP
HLRZ T1,MSGPC ;GET SECTION #
JUMPE T1,PCTYP0
PUSHJ P,OCTTYP ;Type section #
MOVEI T1,","
PUSHJ P,EPUTCH
PUSHJ P,EPUTCH ;",,"
PCTYP0: HRRZ T1,MSGPC ;GET LOCAL ADDR
PUSHJ P,OCTTYP
MOVEI T1,")"
PJRST EPUTCH
NOSYM: MOVE P1,%ERPDP ;GET USER'S PDP
PUSHJ P,GETPC ;GET A PC FROM STACK
JUMPE P1,USMAIN ;NONE. USE MAIN.
MOVE P1,T2 ;GET ROUTINE ADDR
MOVE T1,-1(P1) ;GET ROUTINE NAME
JRST NSTYPE ;GO TYPE THEM
USMAIN: MOVE P1,@%STADD ;NONE FOUND, USE MAIN START ADDRESS
MOVE T1,['MAIN. '] ;AND MAIN PROGRAM NAME
NSTYPE: PUSHJ P,SIXTYP ;TYPE IT
MOVE T1,ORGADR ;GET ARG PC
SUB T1,P1 ;SUBTRACT ROUTINE ADDRESS
PUSHJ P,OFFTYP ;TYPE OFFSET
PJRST PCTYP ;GO TYPE PC IN OCTAL
$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 - GETS THE NEXT ARG ON THE ARGUMENT LIST.
;DOES NOT SUPPORT INDEXING OR INDIRECTION
GETARG: AOS T1,ARGPTR ;GET CURRENT POINTER
MOVE T1,(T1) ;GET ARG ADDR
CAIG T1,17 ;IS ARG IN AC?
JRST ACARG ;YES. GO GET IT
HLL T1,ARGPTR ;ADD SECTION # OF CALLER
MOVE T1,(T1) ;GET ACTUAL ARG
POPJ P,
ACARG: ADD T1,AERACS ;POINT TO SAVED AC
MOVE T1,(T1) ;GET ACTUAL ARG
POPJ P,
IF10,<
ESAVE: POPJ P, ;[4131] ERROR CODE IS ALREADY IN T1!
$J: MOVE T1,AERACS ;GET ADDRESS OF SAVED ACS
MOVE T1,T1(T1) ;GET SAVED T1
TXNE T1,IO.IMP!IO.DER!IO.DTE!IO.BKT!IO.EOF ;[4131] I/O ERROR?
JRST IEROUT ;YES
CAIL T1,0 ;NEGATIVE?
CAILE T1,LERMAX ;OR TOO BIG?
JRST LERUNK ;YES, TYPE GENERAL-PURPOSE MSG
MOVEI T2,(T1) ;COPY ERROR CODE
ADDI T2,^D250 ;ADD 250, BECAUSE V5A DID IT...
MOVEM T2,%ERNM2 ;Fix error number
JUMPN T1,LERNAM ;[4131] NOT AMBIGUOUS
LOAD T2,INDX(D) ;[4131] GET DEVICE INDEX
CAIE T2,DI.DSK ;[4131] DISK?
JRST WRGDIR ;[4131] NO. GIVE "WRONG DIRECTION" MSG
LERNAM: IDIVI T1,4 ;[4131] 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,AERACS ;GET ADDRESS OF SAVED ACS
MOVE T1,T1(T1) ;GET SAVED T1
PJRST OCTTYP ;TYPE IT
WRGDIR: MOVEI T1,[ASCIZ /Wrong direction for device/] ;[4131]
PJRST ASCTYP ;[4131] TYPE MESSAGE AND LEAVE
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
X 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
IEROUT: PUSHJ P,%SAVE3 ;SAVE P ACS
MOVEI T1,[ASCIZ /IO error /]
PUSHJ P,ASCTYP
MOVE T1,AERACS ;GET ADDRESS OF SAVED ACS
MOVE T1,T1(T1) ;GET SAVED T1
SKIPN %ERNM2 ;IF NO 2ND NUMBER YET
MOVEM T1,%ERNM2 ;STORE I/O ERROR BITS
HRLZ P1,T1 ;SAVE THEM, IN LH
PUSHJ P,OCTTYP ;TYPE THEM IN OCTAL
MOVE D,AERACS ;GET ADDRESS OF SAVED ACS
MOVE D,D(D) ;GET DDB POINTER
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
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 CODE
;STILL IF10
DSKBKT: SKIPN T1,PTHB+.PTSTR(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,PTHB+.PTSTR(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
> ;IF10
IF20,<
;[4131] NEW CODE
ESAVE: MOVEI T1,.FHSLF ;GET JSYS ERROR NUMBER FOR LAST ERROR
GETER%
ERJMP .+1
MOVE T1,AERACS ;GET ADDRESS OF SAVED ACS
MOVEM T2,T1(T1) ;SAVE ERROR CODE IN SAVED AC1
POPJ P,
;[4131] NEW CODE
$J: MOVE T1,AERACS ;GET ADDRESS OF SAVED ACS
MOVE T1,T1(T1) ;GET SAVED T1
MOVEI T2,(T1) ;GET JUST RIGHT HALF
SKIPN %ERNM2 ;IS 2ND ERROR NUMBER 0?
MOVEM T2,%ERNM2 ;YES. STORE 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
TRN ;STRING TOO SHORT, MSG TRUNCATED
EXCH T1,ERRPTR ;SAVE NEW PNTR, GET OLD ONE BACK
MOVEI T2,(T1) ;GET JUST RIGHT HALF
HRRZ T3,ERRPTR ;GET JUST ADDRESS OF NEW PNTR
SUBI T3,(T2) ;GET # WORDS USED
IMULI T3,IBPW ;GET # CHARS USED
MULI T1,IBPW ;GET # BYTES NOT USED BY OLD PNTR
ADDI T3,(T1) ;ADD THEM
MOVE T1,ERRPTR ;GET NEW PNTR AGAIN
MULI T1,IBPW ;GET # BYTES NOT USED BY NEW PNTR
SUBI T3,(T1) ;SUBTRACT THEM
MOVNI T3,(T3) ;GET NEGATIVE
ADDM T3,ERRCNT ;DECREMENT COUNT
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
>;END IF20
;Type filespec from DDB
$F: PUSHJ P,GETARG ;GET UDB ADDRESS
JUMPLE T1,%POPJ ;[4156] IF ZERO, NOTHING TO PRINT
SKIPN D,DDBAD(T1) ;GET DDB POINTER
POPJ P, ;NONE. DON'T PRINT TRASH
MOVEI T1," " ;OUTPUT SPACE
PUSHJ P,EPUTCH
MOVE T1,[POINT 7,JFNBUF] ;GET FILESPEC
PUSHJ P,%ERFNS
MOVEI T1,JFNBUF ;POINT TO FILESPEC BUFFER
PJRST ASCTYP ;OUTPUT IT
SEGMENT DATA
JFNBUF: BLOCK LTEXTW ;Buffer for JFNS string
SEGMENT CODE
$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
$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,%MSLVL ;Get message level
TXNN T1,JW.WPR ;Does user want prefix?
JRST NPR ;No, skip it
HLRZ T1,%COD(P2) ;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
;TYPE INPUT RECORD (PRESUMABLY CONTAINING AN ERROR) AND PUT AN ARROW
;UNDER THE ERRONEOUS CHARACTER. THE ERROR POSITION IS GOTTEN FROM RPOS.
RCTYB1: MOVNI T1,1 ;MOVE POINTER BACK 1 CHAR
PUSHJ P,%CIPOS
RECTYP: SETZM ERRCNT ;CLEAR # CHARS IN ERROR BUFFER
PUSHJ P,%RIPOS ;GET POSITION OF NEXT CHAR
SUBI T1,1 ;GET POSITION OF BAD CHAR
MOVEI T2,(T1) ;COPY IT
CAILE T2,BEFSIZ ;MORE THAN WILL FIT?
MOVEI T2,BEFSIZ ;YES. SUBSTITUTE JUST ENOUGH
MOVEM T2,ERRPOS ;SAVE FOR PRINTING THE ARROW
SUBI T1,(T2) ;CHOP OFF UNNEEDED CHARS
ADDI T1,1 ;POINT TO CORRECT CHAR
PUSHJ P,%SIPOS
MOVE T1,[POINT 7,ER1BUF] ;PREPARE TO COPY RECORD TO ERROR BUFFER
MOVEM T1,ER1PTR ;SAVE PNTR
MOVE T3,ERRPOS ;GET POSITION OF BAD CHAR
SOJLE T3,ILCPEC ;GET # CHARS PRECEDING IT FOR ARROW
ILCLP: PUSHJ P,%IBYTE ;GET CHAR FROM RECORD
PUSHJ P,PUTERC ;PUT IN BUFFER
SOJG T3,ILCLP ;COPY RECORD UP TO BAD CHAR
ILCPEC: PUSHJ P,%IBYTE ;GET BAD CHAR
PUSHJ P,PUTER1 ;STORE IT
MOVEI T3,BEFSIZ+AFTSIZ ;GET TOTAL ALLOWED SANDWICH
SUB T3,ERRPOS ;MINUS CHARS ALREADY OUT
ILCLP2: SKIPG IRCNT(D) ;AND CHARS IN RECORD?
JRST ILCEND ;NO
PUSHJ P,%IBYTE ;GET NEXT CHAR
PUSHJ P,PUTER1 ;STORE IT
SOJG T3,ILCLP2
ILCEND: PUSHJ P,BUFTYP ;TYPE RECORD
PJRST AROUT ;NOW OUTPUT ARROW LINE
PUTERC: CAIN T1,177 ;RUBOUT?
MOVNI T1,1 ;YES. MAKE IT -1
CAIN T1,0 ;NULL?
MOVEI T1," " ;YES. MAKE IT A SPACE
CAIGE T1," " ;OR OTHER NON-PRINTING CHAR?
JRST ERCTL ;YES. GO PRECEDE WITH "^"
IDPB T1,ER1PTR ;NO. JUST DEPOSIT IT
AOS ERRCNT ;INCR # CHARS IN BUFFER
POPJ P,
PUTER1: CAIN T1,177 ;RUBOUT?
MOVNI T1,1 ;YES. MAKE IT -1
CAIN T1,0 ;NULL?
MOVEI T1," " ;YES. MAKE IT A SPACE
CAIGE T1," " ;OTHER NON-PRINTING CHAR?
JRST ER1CTL ;YES. PRECEDE WITH "^"
IDPB T1,ER1PTR ;NO. JUST STORE IT
AOS ERRCNT ;INCR # CHARS IN BUFFER
POPJ P,
ERCTL: AOS ERRPOS ;INCR ARROW SPACE COUNT FOR "^"
ER1CTL: MOVEI T2,"^" ;OUTPUT UP-ARROW
IDPB T2,ER1PTR
ADDI T1,100 ;CTL CHARS TO UPPER CASE, RUBOUT TO "?"
IDPB T1,ER1PTR ;STORE IT
MOVEI T1,2 ;ADD 2 TO COUNT
ADDM T1,ERRCNT
POPJ P,
BUFTYP: SETZ T1, ;DEPOSIT A NULL AT THE END
IDPB T1,ER1PTR
MOVE T1,[POINT 7,ER1BUF] ;ERROR BUFFER
MOVEM T1,%EOPTR ;SAVE IT
MOVE T1,ERRCNT ;GET # CHARS IN IT
MOVEM T1,%EOCNT ;SAVE IT
PJRST %EOREC ;Type it and return
AROUT: MOVE T4,[POINT 7,ER1BUF] ;POINT TO ERROR BUFFER AGAIN
MOVE T3,ERRPOS ;GET SPACE COUNT
SOJLE T3,PUTARO ;IF 1, JUST OUTPUT THE ARROW
SETZB T0,T1 ;NO SOURCE
EXTEND T0,[EXP <MOVSLJ>," "] ;PAD WITH SPACES
$SNH
PUTARO: MOVEI T1,"^" ;PUT IN ARROW
IDPB T1,T4
SETZ T1, ;AND FINALLY A NULL CHAR
IDPB T1,T4
MOVE T1,[POINT 7,ER1BUF] ;POINT TO IT YET AGAIN
MOVEM T1,%EOPTR ;SAVE IT
MOVE T1,ERRPOS ;AND SAVE # CHARS IN ARROW LINE
MOVEM T1,%EOCNT
PJRST %EOREC ;TYPE IT
;TYPE FORMAT (PRESUMABLY CONTAINING AN ERROR) AND PUT AN ARROW UNDER THE
;ERRONEOUS CHARACTER. THE ERROR POSITION IS GOTTEN FROM FMT.BP.
FMTTYP: SETZM ERRCNT ;CLEAR # CHARS IN ERROR BUFFER
MOVE T1,USR.SZ ;GET FORMAT SIZE
SUB T1,FMT.SZ ;GET CURRENT POSITION
MOVEI T2,(T1) ;COPY IT
CAILE T2,BEFSIZ ;TOO BIG?
MOVEI T2,BEFSIZ ;YES. TRUNCATE IT
MOVEM T2,ERRPOS ;SAVE ERROR CHAR POSITION
SUBI T1,(T2) ;GET NUMBER OF CHARS TO SKIP
MOVE T3,USR.SZ ;GET # CHARS IN FORMAT AGAIN
SUBI T3,(T1) ;GET # CHARS IN TRUNCATED FORMAT
CAILE T3,BEFSIZ+AFTSIZ ;BUT NOT MORE THAN A PROPER SANDWICH
MOVEI T3,BEFSIZ+AFTSIZ
MOVEM T3,FMTCNT ;SAVE IT
ADJBP T1,FMT.BG ;GET A POINTER TO THE FORMAT
MOVEM T1,ERRPTR ;SAVE IT
MOVE T1,[POINT 7,ER1BUF] ;POINT TO ERROR BUFFER
MOVEM T1,ER1PTR
MOVE T3,ERRPOS ;GET # CHARS PRECEDING ERROR CHAR
SOJLE T3,FMTPEC ;IF NONE, GO OUTPUT ERROR CHAR
FMTELP: ILDB T1,ERRPTR ;GET A CHAR
PUSHJ P,PUTERC ;STORE IN ERROR BUFFER, SPACE IN ARROW LINE
SOJG T3,FMTELP
FMTPEC: ILDB T1,ERRPTR ;GET ERROR CHAR
PUSHJ P,PUTER1 ;STORE IN ERROR BUFFER
MOVE T3,FMTCNT ;GET TOTAL # CHARS AGAIN
SUB T3,ERRPOS ;GET SIZE OF REST OF FORMAT
FMTEL2: ILDB T1,ERRPTR ;GET ANOTHER FORMAT CHAR
PUSHJ P,PUTER1 ;STORE IN ERROR BUFFER
SOJG T3,FMTEL2
PUSHJ P,BUFTYP ;OUTPUT FORMAT
PJRST AROUT ;OUTPUT ARROW LINE
SEGMENT DATA
BEFSIZ==^D50 ;50 CHARS BEFORE ILCHR PRINTED
AFTSIZ==^D20 ;20 CHARS AFTER ILCHR
RERRBF==30 ;LENGTH OF RECORD AND FORMAT BUFFER
LERRBF==60 ;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
ER1PTR: BLOCK 1 ;POINTER TO ERROR LINE BUFFER
ER1BUF: BLOCK RERRBF ;Buffer for the record
FMTCNT: BLOCK 1 ;FORMAT SIZE FOR PRINTING
ERRPOS: BLOCK 1 ;POSITION OF ERROR CHARACTER
INICHR: BLOCK 1 ;PREFIX CHAR OF ERROR MESSAGE
ERRARG: BLOCK 1 ;ARG TO $<N>X COMMAND
COLCNT: BLOCK 1 ;COLUMN NUMBER
ARGPTR: BLOCK 1 ;POINTER TO NEXT ARG
EADDR: BLOCK 1 ;ERROR ADDRESS TEMP
SUBTTL TRACE
SEGMENT CODE
$ERR (,TR0,-1,0)
$ERR (,TR1,-1,0,<$S$7T($O)$18T$[$[---$25T$S$1O$36T($L)$50T$D$56T$A>,<RNAME,RPC,CNAME,OFFS,CPC,TRARGS,RGPTR>) ;[3275]
$ERR (,TR2,-1,0,<$S$7T($O)$18T$[$[---$25TERRSET subroutine call$50T$D$56T$A>,<RNAME,RPC,TRARGS,RGPTR>) ;[3275]
$ERR (,TRC,-1,0,<Name (Loc) $[$[--- Caller (Loc) Args Types>)
FENTRY (TRACE)
MOVEM P,%ERPDP ;AND ERROR STACK FOR MODCNV
%TRACX: PUSHJ P,SVEACS ;SAVE USER'S ACS
SETZM MSGPC ;NO PC ON EACH MESSAGE, PLEASE
MOVE P1,P ;GET TRACE PDP
PUSHJ P,GETPC ;GET TOP CALL ON STACK
JUMPE P1,ERRET ;NONE THERE, RESTORE ACS AND RETURN
MOVEM P1,SAVPC ;SAVE DECREMENTED PC
MOVEM T1,CPC ;[3155] Save caller PC
MOVEM T2,RPC ;[3155] Save routine address
MOVEM T3,TRARGS ;[4021] SAVE ARGLIST FOR LATER
MOVE T3,-1(T2) ;GET SIXBIT SUBROUTINE NAME
MOVEM T3,RNAME ;SAVE IT
XMOVEI T1,E.TR0+%EOFF ;OUTPUT BLANK LINE
MOVEM T1,%ERPTR
PUSHJ P,FOREC
XMOVEI T1,E.TRC+%EOFF ;OUTPUT TRACE HEADER
MOVEM T1,%ERPTR
PUSHJ P,FOREC
TRACEL: MOVE P1,SAVPC ;GET DECREMENTED PC FROM LAST CALL
PUSHJ P,GETPC ;GET NEXT PC ON STACK
MOVEM P1,SAVPC ;AND SAVE DECREMENTED ONE
PUSH P,T1 ;SAVE INFO FOR NEXT LOOP
PUSH P,T2
PUSH P,T3
MOVE T4,CPC ;GET CALLER PC
SUB T4,T2 ;[3155] 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 ;[4021] RETRIEVE ARGLST
HLRE T4,-1(T3) ;[4021] COUNT
MOVNM T4,TRARGS ;STORE FOR ERR MACRO
SKIPN T5,TRARGS ;[4021] ANY ARGS?
JRST TRCSHO ; NOPE, GO DISPLAY
CAIG T5,STRLEN ;[4021] TOO MANY ARGS TO DISPLAY?
JRST TRCPTR ; NOPE, GO FINISH SETTING UP
MOVEI T5,STRLEN ;[4021] SET COUNTR 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
AOJ T3, ;[4021] BUMP ARG PTR
SOJG T5,TRCRGL ;[4021] LOOP IF MORE ARGS
TRCSHO: XMOVEI T1,E.TR1+%EOFF ;OUTPUT A TRACE LINE
MOVE T2,CPC ;GET CALLER PC
XMOVEI T3,UTRAPC ;GET EXTENDED ADDR OF ERRSET CALL LOC
CAMN T2,T3 ;IS IT AN ERRSET CALL?
XMOVEI T1,E.TR2+%EOFF ;YES. USE AN ALTERNATE TRACE LINE
MOVEM T1,%ERPTR
PUSHJ P,FOREC
POP P,T3 ;RESTORE 'GETPC' DATA FOR LOOP
POP P,T2
POP P,T1
MOVEM T1,CPC ;[3155] Save caller PC
MOVEM T2,RPC ;[3155] Save routine address
MOVEM T3,TRARGS ;[4021] SAVE ARGLST FOR LATER
MOVE T3,-1(T2) ;GET SIXBIT SUBROUTINE NAME
MOVEM T3,RNAME ;SAVE IT
SKIPE SAVPC ;ANY MORE STACK TO TRACE?
JRST TRACEL ;YES. GO DO IT
XMOVEI T1,E.TR0+%EOFF ;NO. OUTPUT BLANK LINE
MOVEM T1,%ERPTR
PUSHJ P,FOREC ;AND LEAVE
JRST ERRET ;GO RESTORE ACS
STRWDS==3 ;WORDS TO ACCOMODATE ARGUMENT SYMBOL STRING
STRLEN==5*STRWDS ;5 ASCII BYTES PER WORD
; 0123456701234567
TYPCOD: ASCII /ILIUFUOSDIOGXCUH/
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 + '...'
SAVPC: BLOCK 1 ;PLACE FOR DECREMENTED PC FROM GETPC
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: JUMPE P1,%POPJ ;DON'T PROCEED ON ZERO!
MOVE T1,(P1) ;GET SOMETHING OFF STACK
CAMN T1,['STOP!!'] ;MAGIC END-OF-STACK CONSTANT?
JRST GETPCE ;YES, GO RETURN END-OF-STACK INDICATION
SKIPN %FSECT ;NON-ZERO SECTION?
TLZ T1,-1 ;[3151] No, discard section 0 flag bits
SUBI T1,1 ;LOOK AT THAT ADDR-1
MOVEM T1,PCADR ;SAVE IT
HLLZM T1,PCSECT ;SAVE SECTION #
PUSHJ P,ADRCHK ;CHECK THAT ADDRESS IS REASONABLE
SOJA P1,GETPC ;NOT, NOT A PC
MOVE T1,PCADR ;GET ADDRESS AGAIN
HLRZ T2,(T1) ;GET INSTRUCTION POINTED TO BY STACK
TRZ T2,37 ;TURN OFF INDIRECT AND INDEX
CAIE T2,(PUSHJ P,) ;A SUBROUTINE CALL?
SOJA P1,GETPC ;NO, NOT A PC
HLRZ T2,-1(T1) ;GET INSTRUCTION BEFORE THE PUSHJ
TRZ T2,37 ;TURN OFF INDEIRECT AND INDEX
CAIE T2,(MOVEI L,) ;CORRECT?
CAIN T2,(XMOVEI L,) ; (The other choice)
TRNA ;Yes
SOJA P1,GETPC ;NO
MOVE T3,(T1) ;GET THE PUSHJ INST
TLNE T3,17 ;INDEXED?
JRST UNKDST ;YES. DESTINATION UNKNOWN
HRRZ T2,(T1) ;GET THE PUSHJ INST DEST
HLL T2,PCSECT ;GET SECTION FROM CALLER ADDR
TLNE T3,(@) ;INDIRECT?
XMOVEI T2,@(T2) ;YES. GET DEST ADDR 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
MOVE T2,1(T2) ;GET THE WORD AFTER THE JSP
MOVE T2,(T2) ;GET THE DEST ADDR OF THE OVERLAY CALL
JRST GETPC1 ;AND PROCESS IT
UNKDST: XMOVEI T2,1+[EXP <SIXBIT /UNKNWN/>,0]
GETPC1: MOVE T3,-1(T2) ;GET ROUTINE NAME
TLNN T3,770000 ;FIRST 6 BITS NON-ZERO?
JRST ZERARG ;YES. THERE IS NO ARG LIST
MOVE T4,-1(T1) ;GET XMOVEI OR MOVEI AGAIN
TLNE T4,17 ;INDEXED?
JRST ZERARG ;YES. UNKNOWN ARG LIST
HRRZ T3,-1(T1) ;GET ARG LIST ADDRESS FROM MOVEI INSTRUCTION
HLL T3,PCSECT ;ADD IN SECTION #
TLNE T4,(@) ;INDIRECT XMOVEI?
XMOVEI T3,@(T3) ;YES. RESOLVE IT
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
GETPCN: SOJA P1,GETPC ;NOT SO, NOT A POSSIBLE PC
ZERARG: XMOVEI T3,1+[EXP 0,0] ;POINT T3 AT NULL ARG LIST
SOJA P1,%POPJ ;DONE
GETPCE: SETZ P1, ;FLAG THAT PDL IS DONE
SETZ T1, ;Return a zero.
MOVE T2,@%STADD ;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
ADRCHK: TXNE T1,777B8 ;[3155] Does the page number fit on a KL ?
POPJ P, ;[3155] No, can't be a good address
IF10,<
HLLZ T3,T1 ;GET SECTION NUMBER OF PC
MOVEI T1,(T1) ;AND MAKE PC SECTION-LOCAL
HRRZ T2,.JBREL(T3) ;GET LOWSEG END IN PC SECTION
CAMG T1,T2 ;BELOW LOW SEG END?
JRST %POPJ1 ;YES, FINE
HRRZ T2,.JBHRL(T3) ;GET HIGH SEG HIGHEST ADDRESS
JUMPE T2,%POPJ ;NONE
CAILE T1,(T2) ;COULD ADDRESS BE IN HIGH SEG?
POPJ P, ;NO
HLRZ T3,.JBHRL(T3) ;GET HIGH SEG LENGTH
SUBI T2,-1(T3) ;GET HIGH SEG ORIGIN
TRZ T2,777
CAIL T1,(T2) ;IS ADDRESS IN HIGH SEG?
AOS (P) ;YES, IT'S OK
POPJ P, ;ADDRESS IS ILLEGAL
> ;END IF10
IF20,<
FH%EPN==1B19 ;[3162] Extended page number (Release 5 symbol)
LSH T1,-^D9 ;[3151] Change to page number
HRLI T1,.FHSLF ;[3151] Inquire about our process
SKIPE %FSECT ;[3217] Running in a non-zero section ?
TXO T1,(FH%EPN) ;[3162] Yes, don't let section 0 be defaulted
RPACS% ;[3151] See what the page's attributes are
ERJMP RETURN ;[3151] Definitely not a return PC, punt
TXNE T2,PA%PEX ;[3151] Does the page exist ?
AOS (P) ;[3151] Yes, set up for skip (success return)
RETURN: POPJ P, ;[3151] Return
> ;[3151] End of IF20
;ROUTINE TO CONVERT AN ADDRESS INTO SYMBOL+OFFSET
;ARG: ORGADR = ADDRESS TO CONVERT
;RETURN: SYMNAM = RADIX50 SYMBOL NAME
; SYMVAL = VALUE OF SYMBOL
; SYMOFF = OFFSET FROM SYMBOL
; SYMMOD = RADIX50 MODULE NAME
;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.
;ZERO IS RETURNED IN SYMNAM 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: SETZM SYMNAM ;CLEAR THE MATCHED SYMBOL & VALUE
SETZM SYMVAL
SETZM SYMMOD ;AND MODULE NAME
SKIPE T1,.JBSYM ;[4152] GET SYMTAB POINTER OR VECTOR ADDRESS
PUSHJ P,%SVCNV ;[4152] CONVERT VECTOR OR IOWD TO ADDRESS/LENGTH
JUMPE T1,CNVDON ;[4152] NONE.
PUSHJ P,SYMSRH ;DO A SEARCH
JRST CNVDON ;NO VALID SYMBOLS
MOVEM T1,SYMNAM ;SAVE THE SYMBOL NAME
MOVEM T2,SYMVAL ;AND ITS VALUE
MOVEM T3,SYMMOD ;AND MODULE NAME
MOVE T1,ORGADR ;GET ORIGINAL ADDR
SUB T1,SYMVAL ;TURN INTO OFFSET FROM SYMBOL FOUND
MOVEM T1,SYMOFF ;AND SAVE IT
CNVDON: POPJ P,
; SYMBOL SEARCH ROUTINE:
; T2/ SYMBOL TABLE LEN
; T3/ SYMBOL TABLE ADDR
;[4076]
; SEARCHS THE SYMBOL TABLE POINTED TO BY T3 FROM BOTTOM TO TOP. THE MODLP
; PASS THROUGH THE TABLE LOOKS FOR THE BEST MODULE CANDIDATE WITHIN WHICH
; THE PC TO BE CONVERTED IS LOCATED. RETRIEVE THE RADIX 50 MODULE NAME
; AND SEARCH BACKWARDS FOR ITS GLOBAL EQUIVALENT R50 NAME WITHIN THE MODULE.
; FETCH ITS GLOBAL VALUE. IF THIS VALUE IS THE CLOSEST VALUE YET FOUND
; LESS THAN/EQUAL THE ORIGINAL PC, STORE IT IN SRHVAL, THE END+1 SYMTAB ADDRESS
; OF THE MODULE IN MODEND, AND THE MODULE NAME IN SRHSYM AND SRHMOD. AFTER
; ONE PASS THROUGH THE SYMBOL TABLE, THE CLOSEST MODULE WILL EITHER HAVE
; BEEN FOUND OR A +1 RETURN WILL INDICATE SEARCH FAILURE.
;
;SYMBOL TABLE FORMAT:
; ~----------------------------~<= Symbol table start
; ~ ~
; |----------------------------|<= Module symbol table start
; / | F ! Radix50 name |<= MODBEG
; symbol pair |----------------------------|
; \ | value |
; |----------------------------|
; / | F ! Radix50 name |
; symbol pair |----------------------------|
; \ | value |
; |----------------------------|
; ~ ~
; ~ ~
; |----------------------------|
; / | F ! Radix50 Module name |<= Flags=0
; end pair |----------------------------|
; \ | -length,,start addr | -length,,0 in non-zero sections
; |----------------------------|<= End module symbols, start next
; | F ! Radix50 name |<= MODEND (END+1)
; |----------------------------|
; | value |
; |----------------------------|
; ~ ~
; ~ ~
; |----------------------------|<= End symbol table
;
; F => bits 0-3 in the Radix50 word, where:
;
; bit 0 (400000) => On if symbol is deleted output
; bit 1 (200000) => On if symbol is deleted input
; bit 2 (100000) => On if symbol is local
; bit 3 (040000) => On if symbol is global
; If 0-3 are off (740000), the symbol is a program name
; ALL FORTRAN MODULES WILL HAVE A GLOBAL R50 MODULE NAME. MACRO MODULES
; MAY NOT, IN WHICH CASE A SYMBOL+OFFSET FROM THE CLOSEST PREVIOUS FORTRAN
; MODULE (OR MACRO MODULE WITH GLOBAL MODULE SYMBOL) WILL BE RETURNED.
; IF THERE ARE NO PREVIOUS FORTRAN OR GLOBAL MACRO MODULES, A +1 RETURN
; DEFAULTS TO "MAIN.+n".
; ONCE A MODULE CANDIDATE IS FOUND, SYMLP SEARCHES THE MODULE FROM TOP DOWN
; FOR THE CLOSEST SYMBOL PLUS OFFSET.
SYMSRH: MOVEM T1,SYMBEG ;[4015] SAVE ADDRESS
ADD T2,T1 ;[4015] GET SYMBOL TABLE END + 1
MOVEM T2,MODBEG ;[4076] INITIALIZE MODULE BEGINNING ADDRESS
SETZM MODEND ;[3406] CLEAR MODULE END ADDRESS
SETZM SRHVAL ;INITIALIZE BEST-SO-FAR MODULE ADDRESS
SETZM SRHSYM ;AND SYMBOL
MODLP: MOVE T1,MODBEG ;[4076] 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
CAIGE T2,0 ;[4015] IF POSITIVE, JUNK SYMBOL TABLE FORMAT
TRNE T2,1 ;MUST ALSO BE EVEN
POPJ P, ;[3155] Odd, go die
MOVE T4,-2(T1) ;AND NEXT TO LAST, MODULE NAME
TLNE T4,740000 ;AN ACTUAL MODULE NAME?
POPJ P, ;[3155] No, invalid symbol table format
TLO T4,040000 ;[4076] SET ITS GLOBAL FLAG FOR COMPARISON
ADD T2,T1 ;POINT TO START OF MODULE SYMBOLS
MOVEM T2,MODBEG ;[4076] SAVE
XMOVEI T2,-4(T1) ;[4076] POINT AT LAST PAIR IN MODULE
MODLP2: MOVE T3,(T2) ;[4076] GET ENTRY
CAMN T3,T4 ;[4076] SAME AS MODULE NAME?
JRST MODLPM ;[4076] YES, GET GLOBAL ADDRESS
SUBI T2,2 ;[4076] NO, POINT TO PREVIOUS ENTRY PAIR
CAML T2,MODBEG ;[4076] AT START OF MODULE?
JRST MODLP2 ;[4076] NO, KEEP TRYING
JRST MODLP ;[4076] YES, TRY NEXT MODULE
MODLPM: MOVE T3,1(T2) ;[4076] YES, GET ITS GLOBAL VALUE
TLNN T3,-1 ;[4076] ALREADY A SECTION NUMBER?
HLL T3,T2 ;[4076] NO, INSERT IT
CAMG T3,ORGADR ;DOES MODULE START AFTER ADDRESS TO CONVERT?
CAMGE T3,SRHVAL ;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,SRHVAL ;SAVE MODULE ADDRESS
TLZ T4,040000 ;[4076] CLEAR GLOBAL FLAG
MOVEM T4,SRHSYM ;AND MODULE NAME AS SYMBOL NAME
MOVEM T4,SRHMOD ;ALSO SAVE MODULE NAME FOR MESSAGES
JRST MODLP ;SEARCH WHOLE SYMBOL TABLE
MODLPE: SKIPN T1,MODEND ;GET END+1 ADDRESS OF SYMBOLS
POPJ P, ;[3155] No suitable module, 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
XMOVEI T2,(T2) ;[3406] GET SECTION NUMBER
CAMG T2,ORGADR ;BELOW DESIRED ADDRESS?
CAMG T2,SRHVAL ;[3046] 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,SRHSYM ;SAVE NEW SYMBOL NAME
XMOVEI T3,(T3) ;[3406] GET SECTION NUMBER
MOVEM T3,SRHVAL ;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
MOVE T1,SRHSYM ;GET SYMBOL
TLZ T1,740000 ;CLEAR HIGH BITS OF SYMBOL
MOVE T2,SRHVAL ;GET ITS VALUE
MOVE T3,SRHMOD ;AND GET THE MODULE NAME
POPJ P,
SEGMENT DATA
PCADR: BLOCK 1 ;ADDRESS FOUND IN STACK ENTRY
PCSECT: BLOCK 1 ;SECTION # FOR GETPC IN LEFT HALF
SRHSYM: BLOCK 1 ;SYMBOL
SRHVAL: BLOCK 1 ;ITS VALUE
SRHMOD: BLOCK 1 ;RADIX50 MODULE NAME FROM SYMBOL SEARCH
ORGADR: BLOCK 1 ;ADDR WE'RE TRYING TO MATCH
SYMBEG: BLOCK 1 ;BEG OF SYMBOL TABLE
MODEND: BLOCK 1 ;MODULE END
MODBEG: BLOCK 1 ;[4076] MODULE START
SYMNAM: BLOCK 1 ;FINAL SYMBOL
SYMVAL: BLOCK 1 ;FINAL VALUE
SYMOFF: BLOCK 1 ;OFFSET OF ADDR FROM SYMBOL
SYMMOD: BLOCK 1 ;FINAL MODULE NAME
SEGMENT CODE
;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
PURGE $SEG$
END