/DIAG.PA : ERROR DIAGNOSER

/
/	GEORGE GONZALEZ
/	H.R.L.
/	JULY 20, 1977
/
/	DOCUMENTATION UPDATE: AUG 1, 1978
/
/
/
/	'DIAG' IS INVOKED BY THE FORTRAN II ERROR ROUTINES TO
/	PRINT AN EXPLANATORY ERROR MESSAGE AND TRACEBACK THE
/	CALLING SEQUENCE FROM THE POINT OF ERROR BACK TO THE
/	MAIN PROGRAM.
/
/	   THE FORTRAN II ERROR ROUTINE FIRST WRITES THE CONTENTS
/	OF 3000-4777 TO THE USR SCRATCH BLOCKS, PLACES THE ERROR
/	INFORMATION INTO 7-15, AND THEN LOADS 'DIAG' INTO 3000-UP
/	AND ENTERS IT AT 3000.
/
/	   'DIAG' THEN USES THE ERROR INFORMATION TO PRINT THE
/	MESSAGE AND TRACEBACK. IF THE ERROR WAS NON-FATAL, THEN
/	THE CONTENTS OF 3000-4777 ARE RESTORED AND THE FORTRAN
/	PROGRAM IS CONTINUED.
/
//	TO ASSEMBLE:
/
/	.PAL DIAG,ERRS/L
/	.SAVE SYS:DIAG;3000
/
/	   'DIAG' MUST BE PRESENT ON THE SYSTEM DEVICE UNDER THE
/	NAME 'DIAG.SV' TO BE CALLED UP BY THE FORTRAN ERROR ROUTINE.
/
/
/////////////////////////////////////////////////////////////////////////////

	EJECT	ASSEMBLY CONSTANTS

T=	7
X0=	10
X1=	11
X2=	12
X6=	16
X7=	17
/
/	INFO PACKET LEFT BY ERROR ROUTINE
/
MS0=	0		/ERROR MESSAGE CHARS 1,2
MS1=	1		/3,4
FATFLG=	2		/FATAL ERROR FLAG
ERCDF=	3		/ERROR FIELD
ERADR=	4		/ERROR ADDRESS
RETF=	5		/RETURN FIELD (CDF)
RETA=	6		/RETURN ADDRESS

SUBR=	HLT
FIXMRI	INC=ISZ

BASE=	3000		/PROGRAM BASE
END=	BASE+2200	/END OF PROG
SCRAT=	27		/OUR SCRATCH BLOCK

	EJECT	MAIN PROGRAM
*BASE

START,	JMP I	(7600)	/IF .R DIAG, QUIT
	TLS
	JMS	MOVDN	/MOVE MESSAGE DOWN SOME
	JMS	CRLF
	JMS	QMARK
	JMS	LOOKUP	/FIND IN TABLE
	JMP	SHORT	/IF NOT FOUND
	JMS	PRINT	/PRINT LONG MESSAGE
	0
	JMP	TRCB	/NOW TRACE BACK

SHORT,	JMS	PRINT
	MS0
	JMS	PRINT
	ERRTXT

TRCB,	JMS	QMARK
	JMS	TRCBAK	/TRACE BACK

RETURN,	TAD	FATFLG
	SZA CLA
	JMP	RETPRG	/RETURN TO PROGRAM

	TAD	(CDF CIF 0)
	DCA	RETCIF		/SET RETURN TO OS8
	TAD	(7600)
	DCA	RETAD
	JMP	RETG

RETPRG,	CLA STL RTL	/AC=2
	TAD	RETF	/SET FIELD
	DCA	RETCIF
	TAD	RETA
	DCA	RETAD	/SET RETURN ADDRESS

RETG,	STA		/NON-FATAL, RESTORE MEMORY
	DCA	X7	/BUILD HANDLER CALL AT 00000
	TAD	(-CODLEN)
	DCA	W1	/WORD COUNT
	TAD	(HCODE-1)
	DCA	X6

HCM,	TAD I	X6	/MOVE HANDLER CALL
	DCA I	X7	/TO LOW CORE
	ISZ	W1
	JMP	HCM		/MOVE MORE CODE
	JMP	0	/GO READ IN FORTRAN CODE


LOOKUP,	SUBR		/FIND MS0,2 IN ERROR TABLE
	TAD	(SHMSG-1)
	DCA	X0	/--> SHORT MESSAGES

GMSG,	TAD I	X0	/GET SHORT WORD
	SNA
	JMP I	LOOKUP	/NOT FOUND
	CIA
	DCA	W1
	TAD I	X0
	CIA
	DCA	W2
	INC	X0
	TAD I	X0	/GET TEXT POINTER
	DCA	TXTP
	TAD	W1
	TAD	MS0	/MATCHED?
	SZA CLA
	JMP	GMSG	/NO, TRY ANOTHER
	TAD	W2
	TAD	MS1	/MATCHED?
	SZA CLA
	JMP	GMSG	/NO, TRY ANOTHER
	INC	LOOKUP	/FOUND IT
	TAD	TXTP
	JMP I	LOOKUP
W1,	0
W2,	0
TXTP,	0

FINDLO,	SUBR		/FIND NEXT SMALLEST E.P.
	DCA	LOWEPT	/CLEAR LOWEST E.P.
	TAD	(177)
	DCA	X0	/--> CDF TABLES

NEP,	TAD I	X0	/GET A CDF
	SNA
	JMP I	FINDLO	/ALL OF TABLE SCANNED
	CIA
	TAD	ERCDF	/COMPARE WITH ERROR FIELD
	SZA CLA
	JMP	NEP	/WRONG FIELD
	TAD	X0	/NOW GET THE ADDRESS
	TAD I	(507)	/TABLE DISPLACEMENT
	DCA	T
	TAD I	T	/GET ADDR
	DCA	T
	TAD	T
	CIA
	STL
	TAD	ERADR	/IS IT BELOW ERROR ADDRESS?
	SZL CLA
	JMP	NEP	/NO, IGNORE IT

	TAD	T
	CIA
	STL
	TAD	LOWEPT	/AND ABOVE CURRENT CANDIDATE?
	SNL CLA
	JMP	NEP	/NO, IGNORE IT
	TAD	T	/YES, SET NEW MAXIMUM
	DCA	LOWEPT
	JMP	NEP

	PAGE
/
/	DO ERROR TRACEBACK
/

TRCBAK,	SUBR
TRCTOP,	JMS	FINDLO	/FIND NEXT LOWEST E.P.
	DCA	OFFST	/CLEAR BACK OFFSET
	TAD	ERADR
	DCA	GETA	/SET GET PTR.

NXBW,	TAD	WRD
	DCA	PAST
	JMS	GETW	/GET A WORD (BACKING UP)
	DCA	WRD
	TAD	GETA	/ARE WE BEFORE E.P.?
	CIA
	STL
	TAD	LOWEPT
	SNL CLA
	JMP	BELOW	/YES, WE WENT TOO FAR!!

	TAD	WRD
	CIA
	TAD	STMDEL	/IS IT A STATEMENT DELIMITER?
	SNA CLA
	INC	OFFST	/YES, BUMP OFFSET COUNTER
	TAD	WRD
	CIA
	TAD	MSKCLA	/IS IT A LABELED STATEMENT?
	SZA CLA
	JMP	NXBW	/NO, LOOK BACK AGAIN
	TAD	PAST	/IS THE LABEL A LEGAL ONE?
	SPA CLA
	JMP	NXBW	/NO, IGNORE IT

PSTN,	JMS	PRINT
CFM,	ATTXT		/' AT ' OR 'CALLED FROM'
	TAD	PAST
	JMS	DECIM	/ STMT #
	TAD	OFFST	/ANY OFFSET?
	SNA CLA
	JMP	NOOFF	/NO, DONT PRINT 0
	JMS	PRINT
	PLSTXT		/' + '
	TAD	OFFST
	JMS	DECIM	/ OFFSET
NOOFF,	CLA STL RTL	/AC=2
	TAD	LOWEPT	/GET ENTRY POINT WORD INTO ERROR ADDR
	DCA	GETA
	JMS	GETW	/GET CALL ADDR.
	DCA	ERADR
	JMS	GETW	/GET CALL FIELD
	DCA	EFCDF	/SAVE FOR NEXT LOOP
	TAD	EFCDF	/VALIDATE CDF
	AND	(7707)
	TAD	(-CDF)	/REALLY A CDF?
	SNA CLA
	JMP	TRCM	/YES, TRACE BACK AS SUBROUTINE
	JMS	PRINT
	MAINTXT		/'MAIN'

	JMS	CRLF
	JMP I	TRCBAK	/RETURN FROM TRACING


TRCM,	JMS	PRINT
	ROUTXT
	TAD	(CFMTXT)	/SET 'CALLED FROM' MESSAGE
	DCA	CFM
	TAD	(-4)	/SET BACKUP COUNT
	DCA	WC
	TAD	(ETXT)	/SET TEXT PTR
	DCA	TXP

BNAM,	JMS	GETW	/GET A TEXT WORD
	DCA	T
	TAD	T
	DCA I	TXP	/PLACE IN NAME BUFFER
	STA		/BACK UP NAME PTR.
	TAD	TXP
	DCA	TXP
	TAD	T
	AND	(7700)
	TAD	(-7700)	/'g
	SNA CLA
	JMP	ENAME	/YES, END OF NAME
	ISZ	WC	/NO, GONE TOO FAR BACK?
	JMP	BNAM	/NO, LOOK BACK SOME MORE
	JMS	QMARK
	JMP	CREXT

ENAME,	INC	TXP	/--> REAL WORD
	TAD I	TXP	/ELIMINATE THE '?'
	AND	(0077)
	TAD	(4200)	/ADD IN A '"'
	DCA I	TXP
	JMS	PRINT
TXP,	0		/PRINT ENTRY POINT NAME
	TAD	("")
	JMS	TYPE
CREXT,	JMS	CRLF	/NEW LINE

	TAD	FATFLG	/FATAL ERROR? (FULL TRACEBACK?)
	SZA CLA
	JMP I	TRCBAK	/RETURN RIGHT NOW
	TAD	EFCDF	/SET NEW ERR FIELD
	DCA	ERCDF
	ISZ	TRCLIM	/OVER TRACEBACK LIMIT?
	JMP	TRCTOP	/TRACE BACK CALLER ROUTINE
	JMP I	TRCBAK	/YES, QUIT NOW


BELOW,	DCA	PAST	/CLEAR LAST LINE #
	JMP	PSTN

MSKCLA,	SKP CLA
STMDEL,	CLA CLL RTL
OFFST,	0
PAST,	0
LOWEPT,	0
EFCDF,	0
WC,	0
WRD,	0
TRCLIM,	-10		/8 TRACEBACKS IS ENOUGH

	PAGE



STXT,	ZBLOCK	3
ETXT,	0;0

/
/	GET ONE WORD, BACK UP POINTER
/
GETW,	SUBR
	STA
	TAD	GETA
	DCA	GETA
	TAD	ERCDF	/FIELD 0
	TAD	(-CDF)
	SZA CLA
	JMP	MEMGET	/NO, NO NEED TO LOOK IN SCRATCH
	CLL
	TAD	GETA
	TAD	(-BASE)	/BELOW BASE?
	SNL CLA
	JMP	MEMGET	/YES, DON'T
	TAD	GETA
	TAD	(-END)
	SNL CLA
	JMP	MEMGET	/ABOVE US

	TAD	GETA	/IN US, COMPUTE BLOCK #
	TAD	(-BASE)
	RTL
	RTL
	RAL
	AND	(7)
	TAD	(SCRAT)	/ADD IN BASE BLOCK
	DCA	T
	TAD	T	/IS THIS BLOCK IN MEM?
	CIA
	TAD	RESBLK
	SNA CLA
	JMP	NOREF	/YES, DON'T BOTHER REFRESHING

	TAD	T
	DCA	RESBLK	/NO, READ IT IN
	JMS I	(7607)
	0200		/READ IN ONE BLOCK
BUF,	SCRBUF		/TO OUR BUFFER
RESBLK,	0
	HLT		/WHAT ELSE CAN WE DO??

NOREF,	TAD	GETA	/FIND WORD
	AND	(377)
	TAD	BUF	/IN BUFFER
	DCA	T
	TAD I	T	/FINALLY GET THE WORD
	JMP	GETEXT	/RETURN

MEMGET,	TAD	ERCDF
	DCA	.+1	/GO TO ERROR FIELD
	HLT
	TAD I	GETA

GETEXT,	CDF 00
	JMP I	GETW
MOVL,
GETA,	-7

/
/	MOVE MEMORY BLOCK
/
NUMB,
MOVDN,	SUBR
MOVMM,	TAD I	HI
	DCA I	LO
	INC	HI
	INC	LO
	ISZ	MOVL
	JMP	MOVMM
	JMP I	MOVDN
HI,	7
LO,	0

/
/	PRINT DECIMAL NUMBER
/
DECIM,	SUBR		/ENTRY-EXIT
	DCA	NUMB
	TAD	(-3)
	DCA	X0
	DCA	X1
	TAD	TADTBL
	DCA	TPNTR
TRY0,	DCA	X2
TRY1,	CLA CLL
	TAD	NUMB
TPNTR,	TAD	TBL
	SNL
	JMP	NOVL
	INC	X2
	DCA	NUMB
	JMP	TRY1
NOVL,	CLA
	TAD	X2
	SZA
	JMP	NOZR
	TAD	X1
	SNA CLA
	JMP	IGNOR
NOZR,	TAD	("0)
	JMS	TYPE
	INC	X1
IGNOR,	INC	TPNTR
	ISZ	X0
	JMP	TRY0
	TAD	NUMB
	TAD	("0)
	JMS	TYPE
	JMP I	DECIM

TADTBL,	TAD	TBL
TBL,	-1750
	-144
	-12

	PAGE

/
/	RETURN TO FORTRAN CODE
/

HCODE,	JMS I	SYSH	/READIN
	1200		/12 PAGES
	BASE		/TO OUR BASE
	SCRAT		/FROM USR SCRATCH AREA
SYSH,	7607		/ALSO A HALT (I THINK)
RETCIF,	HLT		/CHANGED TO CDF CIF RETURN
	JMP I	RETAD	/RETURN THRU  GIVEN VALUE
RETAD,	0		/FILLED IN WITH RETURN ADDRESS
CODLEN=.-HCODE


/
/	PRINT A ? <BELL>
/

QMARK,	SUBR
	TAD	("?)
	JMS	TYPE
	TAD	(207)
	JMS	TYPE
	JMP I	QMARK

/
/	START A NEW LINE
/

CRLF,	SUBR
	TAD	(212)
	JMS	TYPE
	TAD	(215)
	JMS	TYPE
	JMP I	CRLF

/
/	PRINT 6-BIT STRING
/

PRINT,	SUBR
	TAD I	PRINT
	INC	PRINT
	DCA	SPTR

PLP,	TAD I	SPTR
	RTR
	RTR
	RTR
	JMS	SIX
	TAD I	SPTR
	JMS	SIX
	INC	SPTR
	JMP	PLP
SPTR,	0

/
/	PRINT A 6-BIT CHARACTER
/

SIX,	SUBR
	AND	(77)
	SNA
	JMP I	PRINT	/RETURN
	TAD	(-40)
	SPA
	TAD	(100)
	TAD	(240)
	JMS	TYPE
	JMP I	SIX

/
/	TYPE ONE CHAR
/

TYPE,	SUBR
	TSF
	JMP	.-1
	TLS
C7600,	7600	/FUNNY CLA
	KSF		/CHECK KEYBOARD
	JMP I	TYPE
	TAD	C7600
	KRS		/ANYTHING THERE?
	TAD	(-7603)	/^C?
	SZA CLA
	JMP I	TYPE	/NO, RETURN
	JMP I	(7600)	/YES, EXIT

/
/	PERMANENT TEXT STRINGS (NOT CLOBBERED BY SCR BUFFER)
/

ERRTXT,	TEXT	' ERROR'
ATTXT,	TEXT	' AT STATEMENT '
PLSTXT,	TEXT	'.'
ROUTXT,	TEXT	' OF ROUTINE '
MAINTXT,	TEXT	' OF MAIN PROGRAM.'
CFMTXT,	TEXT	'CALLED FROM STATEMENT '
	PAGE