; Pascal/Z run-time support interface -- WITH PROFILER
; COPYRIGHT 1978, 1979, 1980, 1981 BY JEFF MOSKOW
	NAME MAIN
	ENTRY .FLTERR,.HPERR,.REFERR,.STKERR,.RNGERR,.DIVERR,.MLTERR,L98,.CRLF
	ENTRY .PERROR,.STMTMSG,.CHIN$,.STRERR,.MAXOUT,.MXOUT,.MXUT1,.STRMSG
	ENTRY .START
	EXT .ILDV,.ILDV1,.ILDV2,.ILD1,.ILD11,.ILD12,.ILD2,.ILD21
	EXT .ILD22
	EXT .ISTR,.ISTR1,.ISTR2,.XADDR,.YADDR,.FSUB,.FADD,.ENTRSC,.ENTER
	EXT .EXITF,.FPEQ,.SEQUL,.FPNEQ,.SNE,.FPLTE,.SLE,.ILE,.FPLT,.SLT,.ILT
	EXT .FPGTE,.SGE,.IGE,.FPGT,.SGT,.IGT,.FMULT,.IMULT,.QMULT,.IDIVD,.IMOD
	EXT .NCDVD,.NCMOD,.ERROR,.CSTS,.CI,.CO,.CHKDE,.CHKHL,.PSTAT,.CONSET
	EXT .RCSET,.UNION,.INN,.LTEQ
	EXT .GTEQ,.INSECT,.ORGAN,.COMP,.FUSS,.FOUT,.FXDCVT,.CVTFLT,.TOUT
	EXT .TXTYP 
	EXT .FDIVD,.STREQL,.STRNQL,.STRLEQ,.STRLSS,.STRGEQ,.STRGRT,.LAST
	EXT	.WRITELN,L109,L110,L111,L112,L115,L116,L117,L118,L120
	EXT	.READLN,L121,L122,L123,L124,L125,L126,L127,L128,L129
	EXT	.WRITE,L130,L131,L132,L133,L134,L135,L136,L0
	EXT	.READ,L137,.ABS,.FPABS,.SQR,.FPSQR,.EOLN,.EOF,.RESET,.REWRITE
	EXT	.FTXTIN,.CHAIN,.NEW,.MARK,.RELEASE,.TRUNC,.ROUND,.ARCTAN,.COS
	EXT	.EXPFCT,.LN,.SQRT,.SIN
R:	SET	0FFFFH
C:	SET	0FFFFH
M:	SET	0FFFFH
S:	SET	0FFFFH
D:	SET	0FFFFH
E:	SET	00000H
F:	SET	0FFFFH
T:	SET	00000H
VALID:	SET	00000H
FIRSTMT SET	00000H ; NO 'STMT' CALLS YET
MINSTMT SET	00000H ; LOWEST, HIGHEST TRACED
MAXSTMT SET	00000H ; ..STATEMENT NUMBERS
.MAXOUT EQU	4
.MXOUT	EQU	.MAXOUT*256
.MXUT1	EQU	.MXOUT*2
CR	EQU	13
LF	EQU	10
EOFMRK	EQU	1AH
BUFLEN	EQU	80
TOPFRM	EQU	.MAXOUT+.MAXOUT+BUFLEN+3+1
MARGIN	EQU	50
COMPILER EQU	0H
MAXDRV	EQU	16
CPM	EQU	5
.START: MVI	C,25
	CALL	CPM
	LHLD	6
	DCX	H
	MOV	M,A
	LXI	B,0
	LXI	H,.LAST
	EXX
	LHLD	6
	LXI	D,0-TOPFRM-1
	DAD	D
	PUSH	H
	PUSH	H
	POP	X
	POP	Y
	SPHL
	MVI	B,.MAXOUT*2+1
	XRA	A
CLRSTK: MOV	M,A
	INX	H
	DJNZ	CLRSTK
	INX	H
	MOV	M,A
	LXI	H,80H
	MOV	A,M
	CPI	2
	JRC	NOCOM
	MOV	B,M
	DCR	B
	INX	H
INITLP	INX	H
	MOV	C,M
	CALL	.TOUT
	DJNZ	INITLP
NOCOM	MVI	C,CR
	CALL	.TOUT
; code to clear the profile table to zero
	lbcd	proclear	; bytes in stmt buckets
	lxi	h,proftab	; start of bucket area
	mvi	m,00h		; begin zeros
	lxi	d,proftab+1
	ldir			; propogate zero
; end inserted code
	JMP	L99
; code inserted to increment a statement count
.profinc:
	push	psw
	push	b
	push	h
	lhld	profset 	; -(lowest number)
	dad	b		; relative stmt number
	dad	h		; relative byte
	lxi	b,proftab	; base address
	dad	b		; hl->stmt bucket
	mov	b,m		; pick up stmt's counter
	inx	h
	mov	c,m
	inx	b		; ..increment,
	mov	m,c		; ..put back
	dcx	h
	mov	m,b
	pop	h
	pop	b
	pop	psw
	ret
; end of insertion
FINI:	MACRO	; as modified to write profile table
	mvi	c,19
	lxi	d,profile
	call	cpm		; erase existing profile
	mvi	c,22
	lxi	d,profile
	call	cpm		; create 'A:PROFILER.DAT'
	lxi	h,proferr
	inr	a
	jz	.ERROR		; -- make failed
	lxi	h,prodata	; hl->next record
	lda	pronio
	mov	b,a		; b=record count
profout:
	xchg			; de->next record
	push	d		; (save it)
	mvi	c,26
	push	b		; (save loop count)
	call	cpm		; set buffer address
	lxi	d,profile
	mvi	c,21
	call	cpm		; write one record
	lxi	h,proferr
	ora	a
	jnz	.ERROR
	pop	b
	pop	h
	lxi	d,128
	dad	d		; hl->next record
	djnz	profout 	; repeat for all sectors
;
	lxi	d,profile
	mvi	c,16
	call	cpm		; close file
	lxi	h,proferr
	inr	a
	jz	.ERROR
; end of insertion
	JMP	L0
; the profile work areas
proferr:	; error message for make, write, close
	dbs	'Error writing A:PROFILE.DAT'
profile:	; file control block: A:PROFILER.DAT
	db	1,'PROFILER','DAT',0,0,0,0
	dw	0,0,0,0,0,0,0,0
	db	0,0,0,0
; the following definitions have to be at the end of
; the program, following the last set of MAX/MINSTMT.
	IF	MINSTMT
pronums set	MAXSTMT-MINSTMT+1 ; number of traced stmts
	ELSE
pronums set	0
	ENDIF
prosize set	pronums*2	; bytes of stmt buckets
prorecs set	prosize+6	; allow for count, lo, hi
prorecs set	prorecs+127	; round to logical sector
prorecs set	prorecs/128	; number of logical sectors
;
	IF	PRONUMS
proclear dw	prosize 	; for clearing the array
	ELSE
proclear set	2
	ENDIF
profset dw	-MINSTMT	; for addressing buckets
pronio	db	prorecs 	; for write-loop
;
prodata equ	$		; start of profiler.dat
promsb	set	pronums/256
prolsb	set	promsb*256
prolsb	set	pronums-prolsb
	db	promsb,prolsb	; integer number of stmts
promsb	set	MINSTMT/256
prolsb	set	promsb*256
prolsb	set	MINSTMT-prolsb
	db	promsb,prolsb	; int. lowest stmt number
promsb	set	MAXSTMT/256
prolsb	set	promsb*256
prolsb	set	MAXSTMT-prolsb
	db	promsb,prolsb	; int. highest ditto
proftab ds	prosize 	; statement buckets
	db	0		; force .rel file to size
; end of insertion
	END	.START
	ENDMAC
EXTD:	MACRO	INTN,EXTN
	EXT	EXTN
INTN:	equ	EXTN
	ENDMAC
SPSH:	MACRO	Q,SIZE
	IF	SIZE
	IF	SIZE&8000H
	LXI	H,SIZE
	DAD	S
	SPHL
	ELSE
	MVI	A,SIZE
	CMP	M
	JC	.STRERR
	MOV	B,A
	INR	B
PSHLP:	SET	$
	MOV	D,M
	PUSH	D
	INX	S
	DCX	H
	DJNZ	PSHLP
	XRA	A
	ENDIF
	ENDIF
	ENDMAC
MLOAD:	MACRO	WHERE,VALUE
	IF	VALUE
	IF	VALUE&0FF00H
	LXI	B,VALUE
	CALL	WHERE!2
	ELSE
	MVI	C,VALUE
	CALL	WHERE!1
	ENDIF
	ELSE
	CALL	WHERE
	ENDIF
	ENDMAC
ILOD:	MACRO	Q,SIZE,OFST
	IF	SIZE&8000H
	MLOAD	.ILDV,OFST
	ELSE
	IF	SIZE-1
	MLOAD	.ILD2,OFST
	ELSE
	MLOAD	.ILD1,OFST
	ENDIF
	ENDIF
	ENDMAC
ISTR:	MACRO	Q,SIZE,OFST
	MLOAD	.ISTR,OFST
	IF	R
	JC	.REFERR
	ENDIF
	ENDMAC
LPOP:	MACRO	REG,DISTANCE
	IF	DISTANCE
	PUSH	H
	LXI	H,DISTANCE+2
	DAD	S
	MOV	E,M
	INX	H
	MOV	D,M
	PUSH	D
	MOV	D,H
	MOV	E,L
	DCX	H
	DCX	H
	LXI	B,DISTANCE
	LDDR
	POP	D
	POP	H
	POP	B
	ELSE
	POP	D
	ENDIF
	ENDMAC
LPUSH:	MACRO	REG,SIZE
	IF	SIZE-2 
	PUSH	REG
	LXI	H,0
	DAD	S
	XCHG
	LXI	H,-2
	DAD	S	
	SPHL
	XCHG
	LXI	B,SIZE+2
	LDIR
	POP	D
	LXI	H,SIZE
	DAD	S
	MOV	M,E
	INX	H
	MOV	M,D
	ELSE
	IF	'REG'-'H'
	XCHG
	ENDIF
	XTHL
	PUSH	H
	ENDIF
	ENDMAC
ADDR:	MACRO	Q
TEMP	SET	'Q'-'IY'
	IF	'Q'-'Y'*TEMP
	CALL	.XADDR
	ELSE
	CALL	.YADDR
	ENDIF
	ENDMAC
MIDL:	MACRO	REG,LEVEL
	PUSH	X
	MVI	A,LEVEL
MIDL1:	SET	$
	MOV	C,4(X)
	MOV	B,5(X)
	PUSH	B
	POP	X
	CMP	1(X)
	JRNZ	MIDL1
	XRA	A
	ENDMAC
DSUB:	MACRO	Q,SIZE
	IF	0!SIZE&8000H
	CALL	.FSUB
	IF	F
	JC	.FLTERR
	ENDIF
	ELSE
	XRA	A
	DSBC	Q D
	ENDIF
	ENDMAC
DADD	MACRO	Q,SIZE
	IF	0!SIZE&8000H
	CALL	.FADD
	IF	F
	JC	.FLTERR
	ENDIF
	ELSE
	IF	'Q'-'C'
	DAD	Q D
	ELSE
	IF	M
	XRA	A
	DADC	H
	JV	.MLTERR
	ELSE
	DAD	H
	ENDIF
	ENDIF
	ENDIF
	ENDMAC
ENTR:	MACRO	Q,LVL,VSIZ
	IF	LVL-1
	MVI	B,LVL
	LXI	D,1-VSIZ
	IF	S
	CALL	.ENTRSC
	ELSE
	CALL	.ENTER
	ENDIF
	ELSE
	LXI	H,1-VSIZ
	DAD	S
	SPHL
.CHIN$:
	EXX
	LXI	H,.LAST
	EXX
	LXI	H,-MARGIN
	DAD	S
	LXI	D,.LAST
	DSUB	D
	JC	.STKERR
	ENDIF
	ENDMAC
EXIT:	MACRO	Q,SSIZ
	LXI	H,SSIZ+8
	JMP	.EXITF
	ENDMAC
L98:	DAD	D
	DAD	D
	MOV	E,M
	INX	H
	MOV	D,M
	XCHG
	PCHL
EQUL:	MACRO	Q,SIZE1,SIZE2
	IF	'Q'-'S'
	IF	SIZE1
	IF	SIZE1&8000H
	CALL	.FPEQ
	ELSE
	LXI	B,SIZE1
	CALL	.SEQUL
	ENDIF
	ENDIF
	ELSE
	LXI	B,255*SIZE1-257+SIZE1+SIZE2
	CALL	.STREQL
	ENDIF
	ENDMAC
NEQL:	MACRO	Q,SIZE1,SIZE2
	IF	'Q'-'S'
	IF	SIZE1
	IF	SIZE1&8000H
	CALL	.FPNEQ
	ELSE
	LXI	B,SIZE1
	CALL	.SNE
	ENDIF
	ENDIF
	ELSE
	LXI	B,255*SIZE1-257+SIZE1+SIZE2
	CALL	.STRNQL
	ENDIF
	ENDMAC
LE:	MACRO	Q,SIZE1,SIZE2
	IF	'Q'-'S'
	IF	SIZE1
	IF	SIZE1&8000H
	CALL	.FPLTE
	ELSE
	LXI	B,SIZE1
	CALL	.SLE
	ENDIF
	ELSE
	CALL	.ILE
	ENDIF
	ELSE
	LXI	B,255*SIZE1-257+SIZE1+SIZE2
	CALL	.STRLEQ
	ENDIF
	ENDMAC
LESS:	MACRO	Q,SIZE1,SIZE2
	IF	'Q'-'S'
	IF	SIZE1
	IF	SIZE1&8000H
	CALL	.FPLT
	ELSE
	LXI	B,SIZE1
	CALL	.SLT
	ENDIF
	ELSE
	CALL	.ILT
	ENDIF
	ELSE
	LXI	B,255*SIZE1-257+SIZE1+SIZE2
	CALL	.STRLSS
	ENDIF
	ENDMAC
GE:	MACRO	Q,SIZE1,SIZE2
	IF	'Q'-'S'
	IF	SIZE1
	IF	SIZE1&8000H
	CALL	.FPGTE
	ELSE
	LXI	B,SIZE1
	CALL	.SGE
	ENDIF
	ELSE
	CALL	.IGE
	ENDIF
	ELSE
	LXI	B,255*SIZE1-257+SIZE1+SIZE2
	CALL	.STRGEQ
	ENDIF
	ENDMAC
GRET:	MACRO	Q,SIZE1,SIZE2
	IF	'Q'-'S'
	IF	SIZE1
	IF	SIZE1&8000H
	CALL	.FPGT
	ELSE
	LXI	B,SIZE1
	CALL	.SGT
	ENDIF
	ELSE
	CALL	.IGT
	ENDIF
	ELSE
	LXI	B,255*SIZE1-257+SIZE1+SIZE2
	CALL	.STRGRT
	ENDIF
	ENDMAC
FDVD:	MACRO	Q,SIZE
	CALL	.FDIVD
	IF	F
	JC	.DIVERR
	ENDIF
	ENDMAC
MULT:	MACRO	Q,SIZE
	IF	0!SIZE&8000H
	CALL	.FMULT
	IF	F
	JC	.MLTERR
	ENDIF
	ELSE
	IF	M
	CALL	.IMULT
	ELSE
	CALL	.QMULT
	ENDIF
	ENDIF
	ENDMAC
DIVD:	MACRO
	IF	M
	CALL	.IDIVD
	ELSE
	CALL	.NCDVD
	ENDIF
	ENDMAC
MMOD:	MACRO
	IF	M
	CALL	.IMOD
	ELSE
	CALL	.NCMOD
	ENDIF
	ENDMAC
NEGT:	MACRO	REG
	IF	'REG'-'H'
	IF	'REG'-'D'
	POP	H
	POP	D
	MVI	A,80H
	XRA	E
	MOV	E,A
	PUSH	D
	PUSH	H
	ELSE
	MOV	A,E
	CMA
	MOV	E,A
	MOV	A,REG
	CMA
	MOV	REG,A
	INX	REG
	ENDIF
	ELSE
	MOV	A,L
	CMA
	MOV	L,A
	MOV	A,REG
	CMA
	MOV	REG,A
	INX	REG
	ENDIF
	XRA	A
	ENDMAC
CTRL:	MACRO	Q,X
	STMT	M,X
	IF	C
	CALL	.CSTS
	JRZ	$+16
	CALL	.CI
	CPI	'C'&3FH
	JZ	.ERROR
	MVI	C,7
	CALL	.CO
	XRA	A
	ENDIF
	ENDMAC
RCHK:	MACRO	REG,LBND,HBND
	LXI	B,LBND
	IF	'REG'-'H'
	IF	'REG'-'S'
	PUSH	H
	LXI	H,HBND
	CALL	.CHKDE
	POP	H
	ELSE
	MVI	A,LBND
	CMP	M
	JC	.STRERR
	XRA	A
	ENDIF
	ELSE
	PUSH	D
	LXI	D,HBND
	CALL	.CHKHL
	POP	D
	ENDIF
	ENDMAC
STMT:	MACRO	Q,NUMBER
	IF	T+E
VALID	SET	0FFFFH
	EXX
	LXI	B,NUMBER
	IF	T
	IF	NOT FIRSTMT
MINSTMT SET	NUMBER
FIRSTMT SET	0FFFFH
	ENDIF	; FIRST STMT
MAXSTMT SET	NUMBER
	IF	'M'-'Q'
	call	.profinc
	ENDIF	; Q IS D
	ENDIF	; T TRUE
	EXX
	ELSE	; NEITHER T NOR E
	IF	VALID
	EXX
	MOV	B,A
	MOV	C,A
	EXX
VALID	SET	00000H
	ENDIF	; VALID
	ENDIF	; T+E
	ENDMAC
GLBP	MACRO	Q,OFFSET,SIZE
	PUSH	Y
	POP	B
	DAD	B
	MOV	B,M
	DCX	H
	MOV	L,M
	MOV	H,B
	LXI	B,OFFSET
	DAD	B
	IF	SIZE-1
	MOV	B,M
	DCX	H
	MOV	L,M
	MOV	H,B
	ELSE
	MOV	L,M
	MOV	H,A
	ENDIF
	ENDMAC
	IF	NOT COMPILER
.STRERR:	LXI	H,.STRMSG
	JR	.PERROR
.REFERR:	LXI	H,.REFMSG
	JR	.PERROR
.RNGERR:	LXI	H,.RNGMSG
	JR	.PERROR
	ENDIF
.HPERR: LXI	H,.STKMSG
	JR	.PERROR
.FLTERR:	LXI	H,.FLTMSG
	JR	.PERROR
.STKERR:	LXI	H,.STKMSG
	JR	.PERROR
.DIVERR:	LXI	H,.OUMSG
	JR	.PERROR
.MLTERR LXI	H,.MLTMSG
.PERROR:	CALL	.TXTYP
	JMP	.ERROR
	IF	NOT COMPILER
.STRMSG DB	'String too lon','g'+80H
.REFMSG DB	'Call by reference precision erro','r'+80H
.RNGMSG DB	'Index or value out of rang','e'+80H
	ENDIF
.OUMSG	DB	'Attempted divide by zer','o'+80H
.MLTMSG IF	COMPILER
	DB	'Too many error','s'+80H
	ELSE
	DB	'Multiply overflo','w'+80H
	ENDIF
.STKMSG IF	COMPILER
	DB	'Program too comple','x'+80H
	ELSE
	DB	'Stack overflo','w'+80H
	ENDIF
.FLTMSG DB	'Floating point overflow/underflo','w'+80H
.STMTMSG	DB	' -- statement',' '+80H
.CRLF	DB	CR,LF+80H
CSET:	MACRO	Q,OFF
	IF	OFF
	IF	OFF-1
	CALL	.RCSET
	ELSE
	CALL	.CONSET
	ENDIF
	ELSE
	MVI	B,16
	LXI	H,0
CSETCL: SET	$
	PUSH	H
	DJNZ	CSETCL
	ENDIF
	ENDMAC
UNIN:	MACRO	Q,OFFSET,OFF1
	CALL	.UNION
	ENDMAC
MEMB:	MACRO	Q,OFFSET,OFF2
	CALL	.INN
	ENDMAC
INCL:	MACRO	Q,OFFSET,OFF1
	CALL	.LTEQ
	ENDMAC
SBST:	MACRO	Q,OFFSET,OFF1
	CALL	.GTEQ
	ENDMAC
INTR:	MACRO	Q,OFFSET,OFF1
	CALL	.INSECT
	ENDMAC
DIFF:	MACRO	Q,OFFSET,OFF1
	CALL	.ORGAN
	ENDMAC
MTCH:	MACRO	Q,OFFSET,OFF1
	CALL	.COMP
	ENDMAC
NOMT:	MACRO	Q,OFFSET,OFF1
	CALL	.FUSS
	ENDMAC
xcfp:	macro
	pop	d
	pop	h
	pop	b
	xthl
	push	d
	push	h
	push	b
	endmac
cvtf:	macro	where,value
	if	'A'-'where'
	if	'B'-'where'
	if	'C'-'where'
	if	'D'-'where'
	if	'H'-'where'
	if	value-4
	mov	a,l
	pop	b
	pop	d
	pop	h
	mov	h,a
	push	h
	push	d
	push	b
	xra	a
	call	.fout
	dcx	s
	lxi	h,14
	dad	s
	push	h
	call	.fxdcvt
	else
	call	.fout
	dcx	s
	lxi	h,0
	dad	s
	xchg
	lxi	h,1
	dad	d
	lxi	b,14
	ldir
	dcx	h
	mvi	m,14
	endif
	else
	call	.cvtflt
	endif
	else
	xchg
	call	.cvtflt
	endif
	else
	pop	b
	pop	d
	pop	h
	push	d
	push	b
	call	.cvtflt
	xcfp
	endif
	else
	pop	h
	call	.cvtflt
	endif
	else
	lxi	h,value
	call	.cvtflt
	endif
	endmac
dsb1	macro	reg
	xra	a
	dsbc	reg d
	endmac
cmpi	macro	q,value
	cpi	value
	endmac

svln:	macro
	mov	a,m
	exx
	mov	e,a
	xra	a
	exx
	dcx	h
	endmac

gtln:	macro	reg,size
	exx
	mov	a,e
	exx
	mov	c,a
	xra	a
	mov	b,a
	lxi	h,size
	dsub	b
	dad	s
	mvi	m,cr
	endmac
