title	TURBO Pascal Immediate Control Generator
	name	('TPCTL')
	maclib	base80

; Build .CTL file for DASM of TURBO Pascal COM file

; There are two RTL calls where immediate code follows.
; The format is:

; CALL RTL_function
; DB   len
; DB   b1,b2,...,blen

; Copyright (C)	Werner Cirsovius
;		Hohe Weide 44
;		D-20253 Hamburg
;		Tel.: +49-40-4223247

;		Version 1.0 June 1989

; Call it:	TPCTL file [C]
; Option C allows log to console

	entry	$memry

	ext	wcard,hexout,string,open,fseek,delete,creatd
	ext	dskget,puteof,dskput,emplin,rdbfp,wrbuf,wrfcb
	ext	@crlf,closef,filsiz

_JP	equ	0c3h

_LDA	equ	03ah		; LD A,(adr)
_STA	equ	032h		; LD (adr),A
_LHLD	equ	02ah		; LD HL,(adr)
_SHLD	equ	022h		; LD (adr),HL
_CCF	equ	03fh		; First one byte code - CCF
_POP.BC	equ	0c1h		; Last  one byte code - POP BC
_BIT	equ	0cbh		; Bit prefix
_DD	equ	0ddh		; Special prefixes
_ED	equ	0edh
_FD	equ	0fdh
_LD.IXo	equ	036h		; LD (I?+offs),d8
_LD.IXi	equ	021h		; LD I?,d16
_LD.a.I	equ	022h		; LD (adr),I?
_LD.I.a	equ	02ah		; LD I?,(adr)
	dseg
;
$PRO:
	db	'0103,S'
	db	cr,lf
$PRO.1:
	db	'20E2,I'
	db	cr,lf,eot
$EPI:
	db	'xxxx,E'
	db	cr,lf,eot
$CAL.1:
	db	'xxxx,H'	; <- PC
	db	cr,lf
$CAL.2:
	db	'xxxx,B'	; <- PC+1
	db	cr,lf
$CAL.3:
	db	'xxxx,I'	; <- PC+n
	db	cr,lf,eot
$CAL0.1:
	db	'xxxx,H'	; <- PC
	db	cr,lf
$CAL0.2:
	db	'xxxx,I'	; <- PC+1
	db	cr,lf,eot
$HEAD:
	db	cr,lf,'Scanning program '
$HEAD.1:
	db	'xxxx - '
$HEAD.2:
	db	'xxxx'
	db	cr,lf,lf,eot
;
; One byte instructions
;
OneByteCodes:
	db	000h,002h,003h,004h,005h,007h,008h,009h
	db	00ah,00bh,00ch,00dh,00fh,012h,013h,014h
	db	015h,017h,019h,01ah,01bh,01ch,01dh,01fh
	db	023h,024h,025h,027h,029h,02bh,02ch,02dh
	db	02fh,033h,034h,035h,037h,039h,03bh,03ch
	db	03dh,0c5h,0c7h,0c8h,0c9h,0cfh,0d0h,0d1h
	db	0d5h,0d7h,0d8h,0d9h,0dfh,0e0h,0e1h,0e3h
	db	0e5h,0e7h,0e8h,0e9h,0ebh,0efh,0f0h,0f1h
	db	0f3h,0f5h,0f7h,0f8h,0f9h,0fbh,0ffh
OB.Len	equ	$-OneByteCodes
;
; Two byte instructions
;
TwoByteCodes:
	db	006h,00eh,016h,01eh,026h,02eh,036h,03eh
	db	0c6h,0ceh,0d6h,0deh,0e6h,0eeh,0f6h,0feh
	db	0d3h,0dbh
TB.Len	equ	$-TwoByteCodes
;
; Relative jump instructions
;
JRcodes:
	db	010h,018h,020h,028h,030h,038h
JR.Len	equ	$-JRcodes
;
; Jump instructions
;
JPcodes:
	db	0c2h,0c3h,0cah,0d2h,0dah,0e2h,0eah,0f2h
	db	0fah
JP.Len	equ	$-JPcodes
;
; Call instructions
;
CALLcodes:
	db	0c4h,0cch,0cdh,0d4h,0dch,0e4h,0ech,0f4h
	db	0fch
CAL.Len	equ	$-CALLcodes
;
; Immediate load instructions
;
D16codes:
	db	001h,011h,021h,031h
D16.Len	equ	$-D16codes
;
; Special prefixed (ED) load instructions
;
ED.code1:
	db	04bh,05bh,07bh
ED.Len1	equ	$-ED.code1
;
ED.code2:
	db	043h,053h,073h
ED.Len2	equ	$-ED.code2

; Special prefixed (DD-FD) bit instructions

FD.code:
	db	034h,035h,046h,04eh,056h,05eh,066h,06eh
	db	070h,071h,072h,073h,074h,075h,077h,07eh
	db	086h,08eh,096h,09eh,0a6h,0aeh,0b6h,0beh
FD.Len	equ	$-FD.code
;
; Head of TURBO program
;
$$HEAD:
	LD	SP,$-$		; Load stack
	LD	HL,$-$		; Set top memory
	LD	BC,$-$		; Set mode
	CALL	0364h
	LD	HL,$-$		; Set 1st free address
	LD	DE,$-$		; Set last free address
	LD	BC,$-$		; Set top of memory
	LD	A,1		; Set run mode
	CALL	04d4h
HeadExe:
	dw	tstbyte,dummy
	dw	tstbyte,dummy
	dw	tstbyte,dummy
	dw	tstbyte,tstbyte,tstbyte
	dw	tstbyte,dummy
	dw	tstbyte,dummy
	dw	tstbyte,dummy
	dw	tstbyte,tstbyte
	dw	tstbyte,tstbyte,tstbyte
	dw	0
$memry:
	ds	2
PClen:
	ds	2
Console:
	ds	1
XFER.PC:
	ds	2
TBbegp:
	ds	2
PC:
	ds	2
TBstop:
	ds	2
StkSav:
	ds	2
PrgRec:
	ds	2
ErrExtend:
	ds	2
TBoffs:
	ds	2
TBbeg:
	dw	000dh		; Address of end of TURBO
TBlib:
	dw	20e2h		; End of TURBO lib
;
specLIB:
	db	special		; Special calls
@TBsp:	dw	054dh
	dw	17bah		; >> Immediate string output
special equ	($-@TBsp) / 2
$COM:
	db	'COM'
$CTL:
	db	'CTL'
$HELP:
	db	'Generate base control .CTL file required for DASM'
	db	cr,lf
	db	'based upon TURBO PASCAL v.3 generated .COM file'
	db	cr,lf,lf
	db	'Call it:',tab,'TPCTL file [C]'
	db	cr,lf,lf
	db	'Option C allows log to console'
	db	cr,lf,eot
$ILL.WILD:
	db	'Wildcard not allowed in file name',eot
$NO.FILE:
	db	'Cannot open file',eot
$ERR.FILE:
	db	'File is not TURBO COM file',eot
$DONE:
	db	'File decoding done',eot
$WRT.ERR:
	db	'CTL file write error',cr,lf,eot
$EMP.FILE:
	db	'(Zero length)',cr,lf,eot
$NO.JP:
	db	'(Missing JP)',cr,lf,eot
$RD.ERR:
	db	'(File read error)',cr,lf,eot
$ILL.HD:
	db	'(Invalid header)',cr,lf,eot
$ILL.LEN:
	db	'(Invalid length)',cr,lf,eot
	cseg
;
; Prepare CTL file
;
rewrite:
	ld	hl,($memry)	; Get start of memory
	ld	(wrbuf),hl	; For disk buffer
	ld	de,reclng
	add	hl,de
	ld	(wrfcb),hl	; Set FCB
	ex	de,hl
	push	de
	ld	hl,FCB
	ld	bc,.fdrv+.fname
	ldir			; Copy main file
	ld	hl,$CTL
	ld	bc,.fext
	ldir			; Set .CTL
	pop	de
	call	creatd		; Create file
	ret	nc
	jp	wrterr
;
; Position file to record and read it
; ENTRY	Reg HL holds PC
;
fpos:
	dec	h		; Base is 0100h
	ld	a,l
	and	01111111b	; Get record pointer
	ld	(rdbfp),a	; Set for reading
	ld	a,l		; Divide address by 128
	ld	l,h
	ld	h,0
	add	a,a
	adc	hl,hl
	xor	a
	ld	de,FCB
	call	fseek		; Seek recotd
	ret	nc
	jp	geterr		; Error
;
; Set prolog
;
SetPRO:
	ld	hl,($HEAD.1)
	ld	($PRO.1),hl	; Copy ASCII address
	ld	hl,($HEAD.1+2)
	ld	($PRO.1+2),hl
	ld	de,$PRO
	call	puts
	ret
;
; Set epilog
;
SetEPI:
	ld	de,$EPI
	ld	hl,(TBstop)
	call	hexout		; Get end of program
	ld	de,$EPI
	call	puts
	ret
;
; Get PC from CALL
; Test if address library related
; EXIT	Reg HL holds address
;	Carry set if lib access
;
isLibPC?:
	ld	de,(TBlib)
	ld	hl,(XFER.PC)	; Find PC
	or	a
	sbc	hl,de		; Check in LIB
	ld	hl,(XFER.PC)	; Get back PC
	ret
;
; ==>> I/O routing <<==
;
; Give new line
;
NL:
	push	de
	ld	de,@crlf
	call	puts		; Print new line
	pop	de
	ret
;
; Print string at ^DE
;
puts:
	push	de
	push	bc
	ld	b,eot
	call	emplin		; Put to file
	pop	bc
	pop	de
	jp	c,wrterr
	ld	a,(Console)	; Test console, too
	or	a
	call	z,string	; Yeap
	ret
;
; Get word, convert to ASCII hex
; Sequence xx LO HI
; ENTRY	Reg DE holds buffer
;	Reg BC holds inc/decrement
;
xtoa:
	push	bc
	call	fgetc		; Skip byte
	call	fgetw		; Get word
	pop	bc
	add	hl,bc		; Fix address
	call	hexout		; Convert to hex
	ret
;
; Check valid header beginning at address in ^HL
;
ChkHead:
	call	fpos		; Position file
	ld	ix,$$HEAD	; Init pointers
	ld	iy,HeadExe
ChkHdLoop:
	ld	l,(iy+0)
	ld	h,(iy+1)
	ld	a,l
	or	h		; Test end of list
	ret	z		; Yeap
	call	j.r		; Execute it
	inc	iy
	inc	iy
	jr	ChkHdLoop
;
; Following byte must match
;
tstbyte:
	call	fgetc		; Get it
	cp	(ix)		; Verify it
	ld	hl,$ILL.HD
	call	nz,setErrx	; Set error if not
	jp	nz,comer	; Tell error
	inc	ix
	ret
;
; Skip following word
;
dummy:
	call	fgetw		; Get it
	inc	ix		; And forget it
	inc	ix
	ret
;
j.r:
	jp	(hl)
;
; Set default extension
; ENTRY	Reg DE points to extension of FCB
;	Reg HL points to extension to be set
;
setdef.ext:
	ld	a,(de)		; Get extension
	cp	' '		; Test defined
	ret	nz		; Yeap
	ld	bc,.fext
	ldir			; Set default
	ret
;
; Process the file
;
AnalyzeTB:
	ld	(StkSav),sp	; Save stack
TBloop:
	call	DecodeOPC	; Decode the OPCode
	ld	(PClen),bc	; Save length of instruction
	inc	e
	dec	e
	call	nz,CAL		; Got CALL
	ld	de,(PC)		; Fetch PC
	ld	hl,(PClen)
	add	hl,de		; Add length of code
	ld	(PC),hl
	ld	de,(TBstop)
	or	a
	sbc	hl,de		; Test end
	jr	nz,TBloop	; Nope, get next
	ld	de,$DONE
	ret
;
; Get byte from file, check error
; EXIT	Accu holds byte read
;
fgetc:
	call	dskget		; Load a byte
	ret	nc		; Ok
geterr:
	ld	sp,(StkSav)
	ld	hl,$RD.ERR
setErrx:
	ld	(ErrExtend),hl	; Save extended error address
	ld	de,$ERR.FILE
	ret			; NOT ok
;
; Get word from file
; EXIT	Reg HL holds word read
;
fgetw:
	call	fgetc		; Load LO byte
	ld	l,a
	call	fgetc		; And HI byte
	ld	h,a
	ret
;
; Decode an OPCode - especially search for CALL
;
; Reg E returns	0 - No call instruction
;		1 - Call instruction
;
; Reg BC returns length of code
;
DecodeOPC:
	call	fgetc		; Get OPcode
	ld	bc,2		; Preset length
	ld	e,0		; And type
	cp	_BIT		; Check bit manipulating
TwoBytes:
	push	af
	call	z,fgetc		; Skip next on two byte code
	pop	af
	ret	z		; Exit on match
	dec	bc		; Set to length of one
	cp	_CCF		; Test one byte possible
	jr	c,NotOneByte	; Nope
	cp	_POP.BC+1	; Verify
	ret	c		; Ok, got it
NotOneByte:
	ld	hl,OneByteCodes
	ld	bc,OB.Len
	cpir			; Find one byte codes
	ld	bc,1
	ret	z		; Got it
	ld	hl,TwoByteCodes
	ld	bc,TB.Len
	cpir			; Find two byte code
	ld	bc,2
	jr	z,TwoBytes	; Got it
	ld	hl,JRcodes
	ld	bc,JR.Len
	cpir			; Test relative jump
	jr	nz,NotJR	; Nope
	ld	bc,2		; Set length
	call	fgetc		; Get relative offset
	ret
NotJR:
	ld	hl,JPcodes
	ld	bc,JP.Len
	cpir			; Find JP codes
WordCode:
	ld	bc,3
	jr	nz,NotJP	; Not jump/call
XFER.adr:
	call	fgetw		; Get address
	ld	(XFER.PC),hl	; Save
	ret
NotJP:
	ld	hl,CALLcodes
	ld	bc,CAL.Len
	cpir
	ld	e,1
	jr	z,WordCode	; Got call
	dec	e
	ld	hl,D16codes
	ld	bc,D16.Len
	cpir
	jr	z,WordCode	; Got immediate load
	cp	_LDA		; Test accu load
	jr	z,WordCode
	cp	_STA		; Test accu save
	jr	z,WordCode
	cp	_LHLD		; Test HL load
	jr	z,WordCode
	cp	_SHLD		; Test HL save
	jr	z,WordCode
	ld	bc,1
	cp	_DD		; Test prefix
	jr	z,DD.FD.code
	cp	_FD
	jr	z,DD.FD.code
	cp	_ED
	ret	nz
	call	fgetc		; Get opcode
	ld	hl,ED.code1
	ld	bc,ED.Len1
	cpir			; Test load
	ld	bc,4
	jr	z,XFER.adr	; Get address
	ld	hl,ED.code2
	ld	bc,ED.Len2
	cpir
	ld	bc,4
	jr	z,XFER.adr	; Dtto.
	ld	bc,2
	ret
DD.FD.code:
	call	fgetc		; Get opcode
	cp	_BIT		; Test bit manipulation
IDX.wrd.offs:
	ld	bc,4
	jr	nz,More.DD.FD	; Try other code
	call	fgetw		; Get next two values
IDX.offs:
	ret
More.DD.FD:
	ld	hl,FD.code
	ld	bc,FD.Len
	cpir			; Test bit manipulation
	jr	nz,LD.?D?
	call	fgetc		; Get offset
	ret
LD.?D?:
	cp	_LD.IXo		; Test very special
	jr	z,IDX.wrd.offs
	ld	bc,4
	cp	_LD.IXi		; Test load
	jp	z,XFER.adr	; Yeap, get address
	cp	_LD.a.I
	jp	z,XFER.adr
	cp	_LD.I.a
	jp	z,XFER.adr
	ld	bc,2
	ret
;
; Process call instruction
;
CAL:
	call	isLibPC?	; Get PC, check LIB
	ret	nc		; Not in lib
;
; Find lib address with immediate parameters following
; Format:
;	CALL	LIB
;	DB	N
;	DB	B1,B2,...,BN
;
	ex	de,hl
	ld	ix,specLIB+1	; Init address array
	ld	b,(ix-1)	; Get length of check table
callop:
	ld	l,(ix+0)	; Fetch special address
	ld	h,(ix+1)
	or	a
	sbc	hl,de
	jr	z,spcfnd	; Match
	inc	ix
	inc	ix
	djnz	callop
	ret
spcfnd:
	ld	de,$CAL.1
	ld	hl,(PC)
	inc	hl		; Skip to hex
	inc	hl
	inc	hl
	push	hl
	call	hexout		; Set current PC
	pop	hl
	inc	hl
	ld	de,$CAL.2
	call	hexout
	call	fgetc		; Fetch length
	ld	c,a
	ld	b,0
	ld	hl,(PClen)
	add	hl,bc
	inc	hl
	ld	(PClen),hl	; Fix PC length
	ld	de,(PC)
	add	hl,de
	ld	de,$CAL.3
	call	hexout
	inc	c
	dec	c		; Test zero length
	jr	nz,put.CAL	; Nope
	ld	hl,($CAL.1)	; Unpack for special case
	ld	($CAL0.1),hl
	ld	hl,($CAL.1+2)
	ld	($CAL0.1+2),hl
	ld	hl,($CAL.3)
	ld	($CAL0.2),hl
	ld	hl,($CAL.3+2)
	ld	($CAL0.2+2),hl
	ld	de,$CAL0.1
	call	puts
	ret
put.CAL:
	ld	de,$CAL.1
	call	puts
	ld	b,c		; Get length
	ld	a,b
	or	a		; Test zero
	ret	z		; Ignore if so
spclop:
	call	fgetc		; Skip string
	djnz	spclop
	ret
;
; %%%%%%%%%%%%%%%%%%%%
; %%% Main program %%%
; %%%%%%%%%%%%%%%%%%%%
;
TPCTL:
	ld	sp,(TPATOP)	; Get stack
	ld	a,(FCBnam)
	cp	' '		; Test filename given
	ld	de,$HELP
	jp	z,ErrEnd	; Nope, error
	ld	a,(FCB+DIRlen+.fdrv)
	sub	'C'
	ld	(Console),a	; Set or reset Console
	ld	de,FCB
	call	wcard		; Verify no wildcard
	ld	de,$ILL.WILD
	jp	z,comer
	ld	hl,$COM
	ld	de,FCBext
	call	setdef.ext	; Set default extension
	ld	de,FCB
	call	open		; Find file
	call	nc,filsiz	; And it's size
	ld	de,$NO.FILE
	jp	c,comer		; Cannot open
	ld	(PrgRec),hl	; Save it
	ld	a,l
	or	h		; Verify correct file
	ld	hl,$EMP.FILE
	call	z,setErrx	; Set error if not
	jp	z,comer		; Tell error
	ld	a,1
	ld	(fseek-1),a	; Enable increment after read
	ld	hl,TPA
	call	fpos		; Position to start address
	call	fgetc		; Get first byte
	cp	_JP		; Verify legal start of file
	ld	hl,$NO.JP
	call	nz,setErrx	; Set error if not
	jp	nz,comer	; Should be
	call	fgetw		; Get word follows
	ld	(TBoffs),hl	; For offset address
	push	hl
	call	ChkHead		; Check valid header
	pop	de
	ld	hl,(TBbeg)
	add	hl,de
	ld	(TBbeg),hl	; Fix adress for top
	call	fpos		; Position file
	ld	de,(FCBrnd)	; Check legal range
	ld	hl,(PrgRec)
	or	a
	sbc	hl,de		; Test legal size of file
	ld	hl,$ILL.LEN
	call	c,setErrx
	jp	c,comer
	call	fgetw		; Get end
	ld	(TBstop),hl	; For top
	ld	de,$HEAD.1
	ld	hl,(TBoffs)
	push	hl
	call	hexout		; Get start of program
	ld	de,$HEAD.2
	ld	hl,(TBstop)
	dec	hl
	call	hexout		; Get end of program
	pop	de
	ld	hl,(TBbegp)
	add	hl,de
	ld	(TBbegp),hl
	ld	(PC),hl		; Get TURBO start
	call	fpos		; Position file
	ld	de,$HEAD
	call	string		; Tell range
	call	rewrite		; Prepare .CTL file
	call	SetPRO		; Set prolog
	call	AnalyzeTB	; Process TURBO program
	ld	de,(ErrExtend)	; Test extended error
	ld	a,e
	or	d
	call	nz,string	; Yeap, do it
	call	SetEPI		; Set epilog
	call	closef		; Close .CTL file
	jp	OS
comer:
	ld	de,(ErrExtend)	; Test extended error
	ld	a,e
	or	d
	call	nz,string	; Yeap, do it
	jp	OS
;
; Error processing
;
wrterr:
	ld	de,(wrfcb)
	call	delete		; Delete file
	ld	de,$WRT.ERR
	call	string		; Tell error
;
; Give error message and go
;
ErrEnd:
	call	string
	jp	OS

	end	TPCTL