;STATUS.MAC contains subroutines for diagnosing the data structures of TRAC80
	PAGE 80
	.Z80
	TITLE DIAG
	SUBTTL DIAGNOSE SUBROUTINES
	ENTRY STATUS
	GLOBAL STOP
	EXTERNAL STATE,MODE,CHAR
	EXTERNAL ACTST,$ACTST,ARGST,$ARGST
	EXTERNAL ENTST,$ENTST,FRMST,$FRMST,VALST,$VALST
	EXTERNAL ALIST,$ALIST,FLIST,$FLIST,STACK,$STACK

	EXTERNAL BDOS

STATUS:
	LD (SAVEHL),HL
	POP HL		;get return address
	LD (STKPTR),HL
	LD HL,(SAVEHL)
	PUSH AF
	PUSH BC
	PUSH DE
	PUSH IX
	PUSH IY

	CALL CRLF

	LD DE,STATE$	;show STATE 
	LD C,9
	CALL BDOS
	LD HL,(STATE)
	CALL PRTINT
	LD DE,BLNK3$
	LD C,9
	CALL BDOS

	LD DE,MODE$	;show MODE
	LD C,9
	CALL BDOS
	LD HL,(MODE)
	BIT 7,L
	LD H,0
	JP Z,MODPOS
	LD H,0FFH
MODPOS:	CALL PRTINT
	LD DE,BLNK3$
	LD C,9
	CALL BDOS

	LD DE,CHAR$	;show CHAR
	LD C,9
	CALL BDOS
	LD A,(CHAR)
	CP 20H
	JP NC,OUTCH
	LD E,'^'
	LD C,2
	CALL BDOS
	LD A,(CHAR)
	ADD A,40H
OUTCH:	LD E,A
	LD C,2
	CALL BDOS

	LD DE,BLNKF$	;show parameter string
	LD C,9
	CALL BDOS

	LD DE,(STKPTR)
	LD C,9
	CALL BDOS

	LD HL,(STKPTR)
	LD A,'$'
LOOP:	CP (HL)
	INC HL
	JP NZ,LOOP
	LD (STKPTR),HL

	CALL CRLF

	LD DE,STACK$	;show STACK
	LD C,9
	CALL BDOS
	LD HL,(STACK)
	CALL PRTADR
	LD DE,BLNK1$
	LD C,9
	CALL BDOS
	LD HL,($STACK)
	CALL PRTADR
	LD DE,BLNK2$
	LD C,9
	CALL BDOS

	LD DE,VALST$	;show VALST
	LD C,9
	CALL BDOS
	LD HL,(VALST)
	CALL PRTADR
	LD DE,BLNK1$
	LD C,9
	CALL BDOS
	LD HL,($VALST)
	CALL PRTADR
	LD DE,BLNKF$
	LD C,9
	CALL BDOS

	LD DE,ACTST$	;show ACTST
	LD C,9
	CALL BDOS
	LD HL,(ACTST)
	CALL PRTADR
	LD DE,BLNK1$
	LD C,9
	CALL BDOS
	LD HL,($ACTST)
	CALL PRTADR
	LD DE,BLNK2$
	LD C,9
	CALL BDOS

	LD DE,FLIST$	;show FLIST
	LD C,9
	CALL BDOS
	LD HL,(FLIST)
	CALL PRTADR
	LD DE,BLNK1$
	LD C,9
	CALL BDOS
	LD HL,($FLIST)
	CALL PRTADR

	CALL CRLF

	LD DE,ALIST$	;show ALIST
	LD C,9
	CALL BDOS
	LD HL,(ALIST)
	CALL PRTADR
	LD DE,BLNK1$
	LD C,9
	CALL BDOS
	LD HL,($ALIST)
	CALL PRTADR
	CALL BLNK49

	LD DE,FRMST$	;show FRMST
	LD C,9
	CALL BDOS
	LD HL,(FRMST)
	CALL PRTADR
	LD DE,BLNK1$
	LD C,9
	CALL BDOS
	LD HL,($FRMST)
	CALL PRTADR

	CALL CRLF

	LD DE,ARGST$	;show ARGST
	LD C,9
	CALL BDOS
	LD HL,(ARGST)
	CALL PRTADR
	LD DE,BLNK1$
	LD C,9
	CALL BDOS
	LD HL,($ARGST)
	CALL PRTADR
	CALL BLNK49

	LD DE,ENTST$	;show ENTST
	LD C,9
	CALL BDOS
	LD HL,(ENTST)
	CALL PRTADR
	LD DE,BLNK1$
	LD C,9
	CALL BDOS
	LD HL,($ENTST)
	CALL PRTADR

	CALL CRLF

	LD HL,($STACK)	;dump neutral string (up to max($STACK,$ALIST,$ARGST))
	PUSH HL
	LD DE,($ALIST)
	SCF
	CCF
	SBC HL,DE
	POP HL
	JP NC,COMP1	;$STACK > $ALIST?
	EX DE,HL	;no
COMP1:	PUSH HL
	LD DE,($ARGST)
	SCF
	CCF
	SBC HL,DE
	POP HL
	JP C,COMP2	;max($STACK,$ALIST) > $ARGST?
	INC HL		;yes, include 2nd pointer byte
	EX DE,HL
COMP2:	LD HL,(STACK)
	CALL DMPSTR	

	CALL CRLF

	LD HL,(FLIST)	;dump formstore
	LD DE,($FLIST)
	CALL DMPSTR

WAIT:	LD C,6
	LD E,0FFH	;wait for keystroke
	CALL BDOS
	OR A
	JP Z,WAIT

	CP 03H		;abort if CTRL/C
	JP NZ,EXIT
STOP:	NOP		;set passpoint here
EXIT:	CALL CRLF

	POP IY
	POP IX
	POP DE
	POP BC
	POP AF

	LD HL,(STKPTR)
	PUSH HL		;store return address
	LD HL,(SAVEHL)	;and HL
	RET

SAVEHL: DW 0
STKPTR:	DW 0

STRG4$:	DW 0
STRG2$:	DW 0
	DB '$'

CRLF$:	DB 0DH
	DB 0AH
	DB '$'

BLNKF$:	DB '            '	;12 BLANKS
BLNK3$:	DB ' '
BLNK2$:	DB ' '
BLNK1$:	DB ' '
	DB '$'
STATE$:	DB 'STATE $'
MODE$:	DB 'MODE $'
CHAR$:	DB 'CHAR $'
ACTST$:	DB 'ACTST $'
ARGST$:	DB 'ARGST $'
ENTST$:	DB 'ENTST $'
FRMST$:	DB 'FRMST $'
VALST$:	DB 'VALST $'
ALIST$:	DB 'ALIST $'
FLIST$:	DB 'FLIST $'
STACK$:	DB 'STACK $'

CRLF:	LD DE,CRLF$
	LD C,9
	CALL BDOS
	RET

BLNK49:	LD DE,BLNK2$	;2 BLANKS
	LD C,9
	CALL BDOS
	LD DE,BLNKF$	;+15
	LD C,9
	CALL BDOS
	LD DE,BLNKF$	;+15
	LD C,9
	CALL BDOS
	LD DE,BLNKF$	;+15
	LD C,9
	CALL BDOS
	LD DE,BLNK2$	;+2 = 49 BLANKS
	LD C,9
	CALL BDOS
	RET

PRTADR:	;prints the 2-byte HEX-address in HL as a 4-byte string
	LD DE,STRG4$
	EX DE,HL
	LD A,D
	CALL NIBBL1
	LD A,D
	CALL NIBBL2
	LD A,E
	CALL NIBBL1
	LD A,E
	CALL NIBBL2
	LD DE,STRG4$
	LD C,9
	CALL BDOS
	RET

NIBBL1:	SRL A
	SRL A
	SRL A
	SRL A
NIBBL2:	AND 0FH
	ADD A,30H
	CP 3AH
	JP C,NIBBL0
	ADD A,7H
NIBBL0: LD (HL),A
	INC HL
	RET

DMPSTR:	;dumps the string between HL und DE as HEX-Codes
	PUSH HL
	SCF
	SBC HL,DE
	POP HL
	JP NC,DMPST9	;finished?
	PUSH DE
	LD DE,STRG2$	;not yet, code next byte
	LD A,(HL)	;into 2-byte string
	LD B,A
	EX DE,HL
	CALL NIBBL1
	LD A,B
	CALL NIBBL2
	EX DE,HL
	PUSH HL
	LD DE,STRG2$	;and print that out
	LD C,9
	CALL BDOS	
	LD DE,BLNK1$	;followed by a blank.
	LD C,9
	CALL BDOS
	POP HL
	INC HL
	POP DE
	JP DMPSTR
DMPST9:	
	RET	

PRTINT:	;prints the 2-byte integer in HL as a 2-byte string
	LD A,H
	OR A
	JP M,PRTIN1
	CALL CONVRT
	LD DE,STRG2$
PRTIN0:	LD C,9
	CALL BDOS
	RET
PRTIN1:	EX DE,HL	;negative number
	LD HL,0
	SCF
	CCF
	SBC HL,DE
	CALL CONVRT
	LD HL,STRG2$
	LD A,' '
PRTIN2:	CP (HL)
	JP Z,PRTIN3
	DEC HL
	JP PRTIN2
PRTIN3:	LD A,'-'
	LD (HL),A
	EX DE,HL
	JP PRTIN0

CONVRT:	LD DE,STRG2$	;INTEGER IN HL 2-STELLIG
	LD BC,2		;NACH STRING KONVERTIEREN

	EX DE,HL
	ADD HL,BC
	DEC HL
	EX DE,HL
	LD B,C

	PUSH DE		;HL GROESSER GLEICH HEX A000 ?
	EX DE,HL
	LD HL,0A000H
	SCF
	SBC HL,DE
	JR NC,CONVR0

	EX DE,HL	;JA, ERSTMAL A000H = 40960 ABZIEHEN
	LD DE,0A000H
	CCF
	SBC HL,DE
	CALL DIV10	;UND DIE DIFFERENZ ALLEIN TEILEN
	POP DE
	CALL RCODE	;REST CODIEREN
	DEC B		;1 STELLE WENIGER
	PUSH DE
	LD DE,1000H	;AUF DEN QUOTIENTEN 1000H = 4096
	ADD HL,DE	;WIEDER DRAUF
	POP DE
	JR CONVR1	;UND NORMAL WEITER

CONVR0:	EX DE,HL	;NEIN
	POP DE

CONVR1: CALL DIV10	;HL DURCH 10 DIVIDIEREN
	CALL RCODE	;REST CODIEREN
	DJNZ CONVR1	;ALLE STELLEN GENERIERT ?

	LD HL,STRG2$	;JA, FUEHRENDE NULLEN BLANKEN
	LD B,2-1
CONVR2:	LD A,30H
	CP (HL)
	RET NZ
	LD A,20H
	LD (HL),A
	INC HL
	DJNZ CONVR2
	RET

DIV10:	PUSH BC		;DIVIDIERT HL DURCH 10.
	PUSH DE
	LD B,12		;DIVIDEND HAT 12+4 BITS.
	LD D,0A0H	;DIVISOR (=10) IM OBEREN HALBBYTE VON D
	LD E,0
DIVBIT:	XOR A		;CLEAR CARRY FLAG
	ADD HL,HL	;HL 1 BIT NACH LINKS
	PUSH AF		;SAVE CARRY FLAG
	XOR A		;CLEAR CARRY FLAG
	SBC HL,DE	;"GEHT DE IN HL"?
	INC HL		;ANGENOMMEN, JA.
	JR NC,DIVCNT	;FALLS NICHT
	POP AF		;UND FALLS VORHER
	JR C,DIVNXT	;KEIN CARRY,
	ADD HL,DE	;SUBTRAKTION UND
	DEC HL		;QUOTIENTEN-STELLE
	JR DIVNXT	;ZURUECKNEHMEN.
DIVCNT:	POP AF
DIVNXT:	DJNZ DIVBIT
	POP DE
	POP BC
	RET

RCODE:	LD A,H		;REST AUS DEM OBEREN HALBBYTE
	RR A		;VON H INS UNTERE SCHIEBEN,
	RR A
	RR A
	RR A
	AND 0FH		;HERAUSMASKIEREN,
	OR 30H		;ALS ASCII-ZEICHEN CODIEREN
	LD (DE),A	;UND ABSPEICHERN.
	LD A,H		;QUOTIENT STEHT IN L UND 
	AND 0FH		;UNTEREM HALBBYTE VON H
	LD H,A
	DEC DE
	RET


	END
