;
;	ERROR.M68
;	
;	This subroutine gets an argument list of errors and reports
;	them to the terminal, And optionally logs it to a file.
;
;	FORMAT :  XCALL ERROR,ERR'0,ERR'1,ERR'2,LOG'ERR
;								
;	07/25/87	flm(bb) 
;
;	Author : Fred L. McMaster (A.K.A.'BIBI')  Computer Resources,Inc.
;	               				  101 39th Street North
;						  Birmingham , AL 35222
;						  (205) 591-8810
;
;	7/30/87		dfp
;	"Streamlined" by Dave Pallmann, UltraSoft Corp.

 	SEARCH SYS
	SEARCH SYSSYM
	SEARCH TRM
	SEARCH MACLIB

	EXTERN $GTARG,$ODTIM

	VMAJOR = 1
	VMINOR = 0
	VEDIT  = 1
	VWHO   = 1

	OBJNAM	.SBR

       	PHDR	-1,0,PH$REE!PH$REU

.OFINI
.OFDEF 	F.DDB,D.DDB
.OFDEF 	F.BUF,512.
.OFDEF 	J.DEV,2
.OFDEF	J.DRV,2
.OFDEF	J.PPN,2
.OFDEF	J.JOB,2
.OFDEF	J.TRM,2
.OFDEF	J.PRG,2
.OFSIZ IMPSIZ

IMP=A4

; XCALL OFFSETS

XC.ARG=0			;number of arguments
XC.TY1=2			;err'0 type
XC.AD1=4			;err'0 address
XC.SZ1=10			;err'0 size
XC.TY2=14			;err'1 type
XC.AD2=16			;err'1 address
XC.SZ2=22			;err'1 size
XC.TY3=26			;err'2 type
XC.AD3=30			;err'2 address
XC.SZ3=34			;err'2 size
XC.TY4=40			;err'L type
XC.AD4=42			;err'L address
XC.SZ4=46			;err'L size

ERROR:	CMMW	XC.ARG(A3),#3		; test number of arguments
 	JLT	ARGERR			; if not report it
 	CMMW	XC.TY1(A3),#6		; compare type with binary
 	JNE	TYPERR			; if not report it
 	CMMW	XC.TY2(A3),#4		; compare with floating point var
 	JNE	TYPERR 			; if not report it
  	CMMW	XC.TY3(A3),#4		; compare with floating point var
 	JNE	TYPERR			; if not report it
	MOV	XC.AD1(A3),A2		; move err'0 into A2
	MOVB	(A2)+,D1		; move byte into D1
	CMPB	D1,#0			; compare error with 0
	JLOS	RNGERR			; jump lower or same to range error
	CMPB	D1,#47.			; compare error with current max err's
	JHIS	RNGERR			; jump higher or same to range error
	CRT	#24.,#1			; position Cursor @ 24,1
	OUTS	OT$TRM,<Program Error(>	; print header
	MOVB	#7,D1			; move bell character into d1
	TTY				; and sound it.
	MOV	XC.AD1(A3),A2		; move error code into register
	CLR	D1			; clear data register
	MOVB	(A2)+,D1		; move byte into d1
 	DCVT	0,OT$TRM		; Print error number
	SUB	#1,D1			; subtract one from error
					; this puts displacement of table to 0
					; i.e. put error table on even boundaries
					; 0,2,4 etc..
	MUL	D1,#30.			; multiply to find msg offset   [DP]
	LEA	A5,ERR1			; point to err msg table	[DP]
	ADD	D1,A5			; A5 now points to right msg	[DP]

RPTER2:	TYPESP	)			; type parenthesis.		[DP]
	TTYL	@A5			; output error desc. to screen	[DP]
	CRT	#9.			; clear to eol
	CLR	D1			; clear register
 	MOV	#14,D1			; move offset from A3 into D1
	CALL	$GTARG			; call macro
	CMP 	D1,#0			; see if there is an error line #
	JEQ	RPTER3			; if not exit this routine
	OUTS	OT$TRM,< -On Line(>	; display header
	DCVT	0,OT$TRM		; convert and print string	
	MOVB	#'),D1			; close up error number
	TTY				; output to screen

RPTER3:	CRT	#9.			; clear to eol
	CLR	D1			; clear register
 	MOV	#26,D1			; move offset from A3 into D1
	CALL	$GTARG			; call macro
	CMP 	D1,#0			; see if there is an error line #
	JEQ	RETURN			; if not exit this routine
	OUTS	OT$TRM,< -Channel(>	; output header
	DCVT	0,OT$TRM		; convert and print string	
	MOVB	#'),D1			; wrap error 
	TTY				; and print it

WRTERR:	CMMW	XC.ARG(A3),#4		; test for a fourth argument
 	JNE	RETURN			; if not exit routine.
	LEA	A2,FILNAM		; move address into a2 for next call
	FSPEC	F.DDB(IMP)		; process filespec
	ORB	#D$INI,F.DDB+D.FLG(IMP)	; set inited flag
	LEA	A6,F.BUF(IMP)		; get address of impure buffer	
	MOV	A6,F.DDB+D.BUF(IMP)	; move address into ddb
	MOV	#512.,F.DDB+D.SIZ(IMP)	; move buffer size to ddb
	LOOKUP	F.DDB(IMP)		; see if she's there
 	JNE	MAKEIT			; if one is not there create it.
	OPENA	F.DDB(IMP)		; open file for append mode

PUTDSH:	MOV	#'|,D1			; move vertical bar
	CALL	PUTBYT			; output it
	MOV	#78.,D0			; move decimal 78 into D0 for count	
   	MOVB	#'-,D1			; put dash into D1
5$:	CALL	PUTBYT			; output byte
	SOB	D0,5$			; subtract one and branch
	CALL	SETFIL			; index a2 with DDB
	OUTCR	OT$DDB,<|>		; close error seperator with vert. bar

PUTERR:	OUTS	OT$DDB,<| Program Error(>
	MOV	XC.AD1(A3),A6		; move error code into register
	CLR	D1			; clear data register
	MOVB	(A6)+,D1		; move byte into d1
 	DCVT	0,OT$DDB		; Print error number

LOGMSG:	OUTS	OT$DDB,<) >		; [DP]	output the message we are
	MOV	A5,A1			;  |    pointing to with A5.
	MOV	#26.,D0			;  v	Replace nulls with spaces.
10$:	MOVB	(A1)+,D1
	BNE	20$
	MOVB	#40,D1			;  ^
20$:	FILOTB	@A2			;  |
	SOB	D0,10$			; [DP]

PUTER1:	CALL	SETFIL			; setup A2 to reference F.DDB
 	OUTS	OT$DDB,< >		; output a space
	GDATES	D3			; setup reg with current date
	GTIMES	D4			; setup reg with current time
 	MOV	#140366,D5		; set flags for full date display
	CALL	$ODTIM			; call it
	OUTCR	OT$DDB,< >		; output a space with a cr

PRTJOB:	OUTS	OT$DDB,<| Job Name : >	; ouput a header
	JOBIDX	A6			; index our jobidx
	LEA	A1,JOBNAM(A6)		; load A1 with job name word
	MOV	J.JOB(IMP),A2		; move destination var into A2
	UNPACK				; unpack first word
	UNPACK				;   "    second word
	MOV	J.JOB(IMP),A1		; move destination into a1 for display
	CALL	SETFIL			; setup A2 to reference F.DDB
	OUTL	@A1,OT$DDB		; output string indexed  to DDB
	OUTS	OT$DDB,<  >		; output spaces to DDB

PRTTRM:	OUTS	OT$DDB,<  Terminal : >	; output header
	JOBIDX	A6			; index our job
	MOV	JOBTRM(A6),A1		; move terminal name into source pos
 	SUB	#4,A1			; subtract 4 to get to terminal name
	MOV	J.TRM(IMP),A2		; move destination into A2
	UNPACK				; unpack first word
	UNPACK				; unpack second word
	MOV	J.TRM(IMP),A1		; move unpacked string to destination
	CALL	SETFIL			; lea a2,f.ddb(imp)
	OUTL	@A1,OT$DDB		; output indexed string to DDB
	OUTS	OT$DDB,<  >		; output some spaces

PRTPRG:	OUTS	OT$DDB,<   Program : >	; another header
	JOBIDX	A6			; index our job
	LEA	A1,JOBPRG(A6)		; load program name 
	MOV	J.PRG(IMP),A2		; move address of program buffer
	UNPACK				; unpack first word
	UNPACK				;    "   second word
	MOV	J.PRG(IMP),A1		; move ascii string to destination 
	CALL	SETFIL			; load a2 with DDB address
	OUTL	@A1,OT$DDB		; output string
	OUTCR	OT$DDB,< >		; output a cr

PRTLIN:	CLR	D1			; clear register
 	MOV	#14,D1			; move offset from A3 into D1
	CALL	$GTARG			; call macro
	CMP 	D1,#0			; see if there is an error line #
	JEQ	PRTFIL			; if not exit this routine
	OUTS	OT$DDB,<|  On Line : >	; another header
	DCVT	5,OT$DDB		; convert and print string	

PRTFIL:	CLR	D1			; clear register
 	MOV	#26,D1			; move offset from A3 into D1
	CALL	$GTARG			; call macro
	CMP 	D1,#0			; see if there is an error line #
	JEQ	PRTPRG			; if not exit this routine
	OUTS	OT$DDB,<      Channel : > ; and yet another header
	DCVT	5,OT$DDB		; convert and print string	

PRTLOG:	OUTS	OT$DDB,<      logged  : > ; whew !!
	JOBIDX	A6			; get our jobidx
	MOV	J.DEV(IMP),A2		; move address of work var
	LEA	A1,JOBDEV(A6)		; get address of current device (dsk,phx,win,etc...)
 	UNPACK				; unpack this word
 	MOV	J.DEV(IMP),A1		; move device into a1
 	CLRB	3(A1)			; I had to do this here, if i didn't
 	CLRB	4(A1)			; i get an 'OR ' when i display this
	CALL	SETFIL			; field.
	OUTL	@A1,OT$DDB		; output indexed string
 	CLR	D1			; clear work register

PRTDRV:	JOBIDX	A6			; index our job
 	MOVW	JOBDRV(A6),D1		; 
 	DCVT	0,OT$DDB		; 
 	CLR	D1			; 
 	CALL	SETFIL			; 
 	MOVB	#':,D1			; 
 	CALL	PUTBYT			; 
	MOVB	#'[,D1			; 
	CALL	PUTBYT			; 

PRTPPN:	JOBIDX	A6			; 
	MOVW	JOBUSR(A6),J.PPN(IMP)	; 
	CLR	D1			; 
	MOVB	J.PPN+1(IMP),D1		; 
	OCVT	0,OT$DDB		; 
	MOVB	#<',>,D1		; 
	CALL	PUTBYT			; 
	CLR	D1			; 
	MOVB	J.PPN(IMP),D1		; 
	OCVT	0,OT$DDB		; 
	CLR	D1			; 
 	MOVB	#'],D1			; 
 	CALL	PUTBYT			; 
	CALL	SETFIL			;
	OUTCR	OT$DDB,<  >  		;
	CLOSE 	F.DDB(IMP)		; 

RETURN:	KBD				;  input a byte
	RTN				;  return to basic

MAKEIT:	OPENO	F.DDB(IMP)		; create new file
	JMP	PUTDSH			; jump to first line of error logging

SETFIL:	LEA	A2,F.DDB(IMP)		; index ddb
	RTN				; return from call

PUTBYT:	FILOTB	F.DDB(IMP)		; output a byte
	RTN				; return from call

TTYERR:					; display to terminal

DEFINE	MSG	TEXT
1$$:	ASCIZ	/TEXT/
	BLKB	30.-<.-1$$>
	ENDM

ERR1:	MSG	Control-C interrupt
ERR2:	MSG	System Error
ERR3:	MSG	Out of Memory
ERR4:	MSG	Out of Data
ERR5:	MSG	Next without FOR
ERR6:	MSG	RETURN without GOSUB
ERR7:	MSG	RESUME without ERROR
ERR8:	MSG	Subscript out of range
ERR9:	MSG	Floating Point overflow
ERR10:	MSG	Divide by zero
ERR11:	MSG	Illegal function value
ERR12:	MSG	XCALL subroutine not found
ERR13:	MSG	File already open
ERR14:	MSG	IO to unopened file
ERR15:	MSG	Record size overflow
ERR16:	MSG	File specification error
ERR17:	MSG	File not found
ERR18:	MSG	Device not ready
ERR19:	MSG	Device full
ERR20:	MSG	Device error
ERR21:	MSG	Device in use
ERR22:	MSG	Illegal user code
ERR23:	MSG	Protection Violation
ERR24:	MSG	Write protected
ERR25:	MSG	File type mismatch
ERR26:	MSG	Device does not exist
ERR27:	MSG	Bitmap kaput
ERR28:	MSG	Disk not mounted
ERR29:	MSG	File already exists
ERR30:	MSG	Redimentioned array
ERR31:	MSG	Illegal record number
ERR32:	MSG	Invalid filename
ERR33:	MSG	Stack overflow
ERR34:	MSG	Invalid syntax code
ERR35:	MSG	Unsupported function
ERR36:	MSG	Invalid subroutine version
ERR37:	MSG	File in use
ERR38:	MSG	Record in use
ERR39:	MSG	Deadly embrace
ERR40:	MSG	File cannot be deleted
ERR41:	MSG	File cannot be renamed
ERR42:	MSG	Record not locked
ERR43:	MSG	Multiple link translation
ERR44:	MSG	LOKSER queue is full
ERR45:	MSG	Device not file structured
ERR46:	MSG	Illegal ISAM sequence

DEFINE	ERROR	TEXT
	TYPE	<? 'TEXT'>
	JMP	ABORT
	ENDM

ARGERR:	ERROR	improper number of arguments
TYPERR:	ERROR	argument type error
SIZERR:	ERROR	argument size error
MISERR:	ERROR	missing numeric parameter
FILERR:	ERROR	Invalid variable type passed as filespec
RNGERR:	ERROR	error out of range

ABORT:	TYPECR	< in ERROR.SBR>
	RTN

ERRHDR: ASCII	/Program Error(/
	BYTE	0	
	EVEN

LINENO: ASCII	/ -On Line(/
	BYTE	0	
	EVEN

FILCHN: ASCII	/ -Channel(/
	BYTE	0	
	EVEN

FILNAM:	ASCII	/ERROR.LOG/
	BYTE	0
	EVEN

	END

.