TITLE	DIAGS for RPGII
	SUBTTL	Diagnositic Messages

	TWOSEG
	RELOC	400000

	XALL

	ENTRY	SETDN
	INTERN	SETFAK
	EXTERN	FAKERA

;SETDN		Routine to set up TE to point to the message
;		whose number is in TB.
;
;

SETDN:	LDB	TE,TBNUM		; get the number
	CAILE	TE,LASTLO		; is it defined?
	  JRST	SETDN2			; no - fake it

SETDN1:	MOVE	TE,TABLE1(TE)		; get the pointer
	JUMPE	TE,SETDN2		; jump if not defined
	POPJ	PP,			; else exit with pointer

SETDN2:	LDB	TE,TBNUM		; convert diagnostic number to decimal
	IDIVI	TE,^D10			; by dividing
	LSHC	TD,-7			; shifting
	IDIVI	TE,12			; dividing again
	LSHC	TD,-7			; shifting again
	MOVEI	TD,"0"(TE)		; get that last digit
	LSHC	TD,16			; shift into line
	ADDI	TD,14060		; make ASCII
	DPB	TD,[POINT 32,FAKERA+3,27]; stash number into message
	LDB	TE,TBFAZE		; get compiler phase
	DPB	TE,[POINT 4,FAKERA+6,13]; stash phase
	MOVE	TE,[POINT 7,FAKERA,6]	; get pointer
	POPJ	PP,			; and exit

SETFAK:	XWD	.+1,7
	ASCIZ	/FDiagnostic No. xxx from Phase A/
;Define MACRO's and tables
;
;
;

	LASTLO==0

DEFINE	ERR (TYPE,X,Y,C),<
ERA'X:	ASCIZ	%'Y'RG'X' -- 'C'%
	IFG	^D'X-LASTLO,<
	LASTLO==^D'X>
	>

;Define diagnositics
;
;
;

	.XCREF
	XLIST

	DIAG;;

	LIST
;Define misc byte pointers
;
;

TBNUM:	POINT	10,TB,35		; pointer to get diagnostic number
TBFAZE:	POINT	4,TB,25			; pointer to get current phase

;Define big index table
;
;

DEFINE	TABLE (A,B) <
	IFDEF	ERA'B''A' <POINT 7,ERA'B''A',6>
	IFNDEF	ERA'B''A' <0>
	>

	RADIX	10

DEFINE	TABLEA	(A,B),<
	XLIST
	I==A
	REPEAT	B-A+1,<
		IFL	I-10,<	TABLE \I,00>
		IFGE	I-10,<
			IFL	I-100,<	TABLE	\I,0>>
		IFGE	I-100,<	TABLE \I>
	I==I+1	>
	LIST
	>

	.XCREF

TABLE1:	TABLEA	0,LASTLO;;

	.CREF

	RADIX	8

	END