TP3/Resources/turbopascal3source/TP3/TPSRC7

	CMP.B	cpmode,#$00	;memory ?
	JNZ	turfil2	;:no
	MOV.B	txcomp,#$FF	;set flag: compiled
	JMP.b	turret	;'
turfil2	CMP.B	cpmode,#$02	;COM / CHN ?
	JB	turret	;:no
	CALL	codflush	;flush code buffer
turret	XOR.B	AL,AL
	JMP	errexit	;"return: no error
inittur	MOV.B	txcomp,#$00	;Init variables: not compiled
	MOV.B	cdinval,#$00	;code invalid
	MOV	BX,txend	;store ^Z at source end
	MOV.B	[BX],#$1A
	MOV	CL,#$04	;(size/16)+1+DS
	SHR	BX,CL
	INC	BX
	MOV	AX,DS
	ADD	AX,BX
	MOV	destseg,AX	;-> code dest segment
	MOV	AX,freemem	;free memory - size
	SUB	AX,BX
	MOV	minstksz,AX	;-> minimum stack size
	MOV	DI,stackpt	;stack pointer - 1024
	SUB	DI,#$0400
	MOV	ptcend,DI	;-> end of patch list space
	SUB	DI,#$0400	;- 1024
	MOV	ptctop,DI	;-> top of patch list
	MOV	ptcbeg,DI	;-> beg of patch list
	DEC	DI	;destination for var table
	MOV	SI,#stdvars	;copy std vars into symbol table
	MOV	CX,SS	;SS -> ES
	MOV	ES,CX
	PUSH	DS	;save DS
	MOV	CX,CS	;CS -> DS
	MOV	DS,CX
	MOV	CX,#$036A	;count
	STD	
	REPZ	
	MOVS.B	
	POP	DS	;restore DS
	INC	DI
	MOV	symtop,DI	;-> top of symtab
	MOV	symtop2,DI
	MOV	fence,DI	;-> current var fence
	MOV	BX,#varpatch	;patch in ptrs to type defs
	MOV	CX,#$0019
itpatch	CS:	
	MOV	BP,[BX]	;pointer
	ADD	[BP_DI],DI	;+ offset
	INC	BX
	INC	BX	;next one
	LOOP	itpatch	;:another one
	MOV	AX,txbeg	;text beg
	MOV	srcptr,AX	;-> src ptr
	MOV	DI,#pnbuf	;line buffer
	MOV	chptr,DI	;-> char ptr
	MOV.B	[DI],#$00	;clear line
	XOR	AX,AX	;clear vars:
	MOV	recnum,AL	;record nesting
	MOV	reccnt,AL
	MOV	lexnest,AL	;lexical nesting
	MOV	srcend,AL	;not end of source
	MOV	flgpshax,AL	;no PUSH AX
	MOV	flgpshes,AL	;no PUSH ES
	MOV	flgpshdi,AL	;no PUSH DI
	MOV	usrint,AL	;user int not used
	MOV	ovrcnt,AL	;no overlays used
	MOV	inclflg,AL	;no include
	MOV	cdptr,AX	;code ptr
	MOV	cdbufpt,AX	;code pos in buffer
	MOV	cdbegpt,AX	;beg of code buffer
	MOV	cdfoff,AX	;current file offset
	MOV	cdfoff1,AX
	MOV	lincnt,AX	;line counter
	MOV	cinpsize,AX	;std in buffer size
	MOV	coutsize,AX	;std out buffer size
	MOV	cmaxfil,#$0010	;max 16 open files
	MOV.B	scalcnt,#$0D	;counter for scalar types
	MOV	direct,#$00ED	;set compiler directive
	CALL	disline	;display line, test brk
	MOV	pc,#$2D7C	;PC: start of code
	MOV	dc,#$0240	;DC: start of file list
	CMP.B	cpmode,#$02	;COM ?
	JZ	itcom	;:yes
	JA	itret	;CHN:ret
	MOV	cdptr,#$2D7C	;code pos of buffer
	RET		;'
itcom	MOV	cdptr,#$2C7C	;code ptr
	MOV	cdbufpt,#$2C7C	;code pos of buffer
itret	RET		;"
copyrt	MOV	AX,#start	;Test for memory overflow
	MOV	cdptr,AX
	MOV	CL,#$04	;(../16)+1
	SHR	AX,CL
	INC	AX
	ADD	AX,destseg	;+ dest segment
	MOV	BX,symtop	;(symtop/16)+SS
	SHR	BX,CL
	MOV	CX,SS
	ADD	BX,CX
	CMP	AX,BX	;compare them
	CALL	errnb	;99:compiler overflow
	B	$63
	XOR	SI,SI	;clear addr
	XOR	DI,DI
	MOV	ES,destseg	;dest seg
	PUSH	DS	;save DS
	PUSH	CS	;CS -> DS
	POP	DS
	MOV	CX,#start	;copy runtime library into code
	CLD	
	REPZ	
	MOVS.B	
	POP	DS	;restore DS
	RET		;"
opendest	MOV	AH,#$3C	;Open dest file
	XOR	CX,CX	;no attribute
	MOV	DX,#destpn	;dest name ptr
	PUSH	DS	;DS -> ES
	POP	ES
	CALL	dos	;create it
	CALL	errb
	B	$C9
	MOV	dstfile,AX	;store file handle
	CMP.B	cpmode,#$02	;COM file ?
	JNZ	odret	;:no
	MOV	BX,AX	;file handle
	MOV	AH,#$40	;write byte block
	MOV	CX,#$2C7C	;size of runtime code
	MOV	DX,#$0100	;offset
	PUSH	DS	;save DS
	PUSH	CS	;CS -> DS
	POP	DS
	CALL	dos	;write runtime library
	POP	DS	;restore DS
	JB	oderr	;:error
	CMP	AX,CX	;length = expected ?
	JNZ	oderr	;no: error
odret	RET		;'
oderr	CALL	err	;C9:dest file not written
	B	$C9	;"
cvmemdsk	PUSH	DS	;Change mem code to disk code
	PUSH	DS	;save DS
	POP	ES	;DS -> ES
	MOV	DS,destseg	;code dest segment
	MOV	SI,#memparm	;ptr to memory parameters
	MOV	DI,#pnbuf	;dest: buffer
	MOV	CX,#$0007	;7 words
	CLD	
	REPZ	
	MOVS		;move it into buffer
	PUSH	DS	;DS -> ES
	POP	ES
	POP	DS	;restore DS
	MOV	DI,#memparm	;ptr to memory parameters
	ES:	
	AND	[DI],#$FFFE	;clear direct mode
	MOV	AX,codesize	;code size > min CS size ?
	CMP	AX,mincssz
	JNB	cvdcs	;:ok
	MOV	AX,mincssz	;at least min CS size
cvdcs	ES:	
	MOV	[DI]$06,AX	;store CS size
	MOV	AX,datasize	;data size > min DS size ?
	CMP	AX,mindssz
	JNB	cvdds	;:ok
	MOV	AX,mindssz	;at least min DS size
cvdds	ES:	
	MOV	[DI]$08,AX	;store DS size
	MOV	AX,minhpsz	;min free heap
	ES:	
	MOV	[DI]$0A,AX	;-> heap, stack size
	CMP	AX,maxhpsz	;> max free heap ?
	JNB	cvdhp	;:yes
	MOV	AX,maxhpsz	;take that size
cvdhp	ES:	
	MOV	[DI]$0C,AX	;store max heap,stack size
	MOV	AH,#$40	;Write code to disk
	MOV	BX,dstfile	;dest file handle
	MOV	CX,cdptr	;code end
	MOV	DX,#start	;offset: end of run-time
	SUB	CX,DX	;calc length
	PUSH	DS	;save DS
	PUSH	ES	;ES -> DS
	POP	DS
	CALL	dos	;write it
	POP	DS	;restore DS
	PUSH	AX	;save results
	PUSH	CX
	PUSHF	
	MOV	SI,#pnbuf	;restore memory code
	MOV	DI,#memparm
	MOV	ES,destseg
	MOV	CX,#$0007	;7 words
	CLD	
	REPZ		;do it
	MOVS	
	POPF		;restore results
	POP	CX
	POP	AX
	JB	cvderr	;:error
	CMP	AX,CX	;length = expected ?
	JNZ	cvderr	;:no
	RET		;'
cvderr	CALL	err	;C9:file error
	B	$C9	;"
compile	CALL	skip	;Compile program: get word
	CALL	ctoken	;PROGRAM ?
	W	tkprog
	JNZ	comnoprm	;:no
	CALL	dummysym	;read dummy symbol
	CALL	cbrack1	;( ?
	JNZ	comprmen	;:no
comprmlp	CALL	dummysym	;read dummy symbol
	CALL	ccomma	;, ?
	JZ	comprmlp	;yes: repeat
	CALL	ebrack2	;! )
comprmen	CALL	esemi	;! ;
comnoprm	MOV	AX,#initmem	;* CALL initmem
	CALL	ecall	;emit CALL
	XOR	AX,AX	;set mode flag
	CMP.B	cpmode,#$00	;to memory ?
	JNZ	comcom	;:no
	OR	AX,#$0001	;flag: direct mode
comcom	TEST	direct,#$0080	;device checking ?
	JZ	comdevck	;:no
	OR	AX,#$0002	;set flag
comdevck	TEST	direct,#$0008	;test ^C and ^S ?
	JZ	comctcs	;:no
	OR	AX,#$0004	;set flag
comctcs	PUSH	AX	;save flag
	PUSH	cdptr	;save code ptr
	CALL	eword	;emit mode flag
	MOV	AX,CS	;emit Turbo CS
	CALL	eword
	MOV	AX,DS	;emit Turbo DS
	CALL	eword
	PUSH	cdptr	;save code ptr
	CALL	eword	;emit 4 dummy words:
	CALL	eword	;memory size is not yet known
	CALL	eword
	CALL	eword
	MOV	AX,cmaxfil	;max number of open files
	ADD	dc,AX	;add to data counter
	ADD	dc,AX	;(file handle list)
	CALL	eword	;emit file count
	MOV	AX,cinpsize	;std in buf size
	ADD	dc,AX	;add to DC
	CALL	eword	;emit
	MOV	AX,coutsize	;std out buf size
	ADD	dc,AX	;add to DC
	CALL	eword	;emit
	CALL	ecode	;* MOV BP,SP
	B	$02,$8B,$EC
	MOV	varspc,#$0000	;clear var space used
	CALL	emcrunch	;emit overlay uncrunch
	CALL	defpart	;declaration part
	CALL	progpart	;program part
	MOV	DI,chptr
	CMP.B	[DI],#$2E
	CALL	errnz
	B	$0A
	CALL	ecode	;* XOR AX,AX
	B	$02,$33,$C0
	MOV	AX,#progend	;* CALL progend
	CALL	ecall
	CALL	ptcrunch	;end overlay crunch list
	MOV	AX,pc	;(PC+15)/16
	ADD	AX,#$000F
	MOV	CL,#$04
	SHR	AX,CL
	MOV	codesize,AX	;-> CS size
	MOV	AX,dc	;(DC+15)/16
	ADD	AX,#$000F
	MOV	CL,#$04
	SHR	AX,CL
	MOV	datasize,AX	;-> DS size
	POP	BX	;code ptr: memory sizes
	MOV	AX,codesize	;CS size > min CS size ?
	CMP	AX,mincssz
	JNB	comcs	;:ok
	MOV	AX,mincssz	;at least min CS size
comcs	CALL	patch	;patch in
	INC	BX
	INC	BX
	MOV	AX,datasize	;DS size > min DS size ?
	CMP	AX,mindssz
	JNB	comds	;:ok
	MOV	AX,mindssz	;at least min DS size
comds	CALL	patch	;patch in
	INC	BX
	INC	BX
	MOV	AX,minhpsz	;min free heap
	CMP.B	cpmode,#$02	;COM / CHN ?
	JNB	comfile	;:yes
	MOV	AX,minstksz	;min stack size
	SUB	AX,codesize	;- code size - data size
	SUB	AX,datasize
	MOV	minstksz,AX	;-> min stack size
comfile	PUSH	AX	;save it
	CALL	patch	;patch in
	POP	AX	;restore
	INC	BX
	INC	BX
	CMP	AX,maxhpsz	;> max free heap size ?
	JNB	comhp	;:ok
	MOV	AX,maxhpsz	;at least max free heap
comhp	CALL	patch	;patch in
	POP	BX	;code ptr mode flag
	POP	AX	;flag
	CMP.B	usrint,#$00	;user interrupt used ?
	JZ	comnobrk	;:no
	OR	AX,#$0008	;set flag: user interrupt
comnobrk	CALL	patch	;patch in
	JMP	ptcflush	;"patch code in file
dummysym	PUSH	symtop	;read dummy symbol
	CALL	rdsym	;read symbol
	POP	symtop	;restore symtob: forget symbol read
	RET		;"
chkovrfl	PUSH	AX	;Test for overflow
	PUSH	BX
	PUSH	CX	;save regs
	CMP.B	cpmode,#$00	;to memory ?
	JNZ	ckvfil	;:no
	MOV	AX,pc	;(PC/16)+1
	MOV	CL,#$04
	SHR	AX,CL
	INC	AX
	MOV	BX,dc	;+(DC/16)+64
	MOV	CL,#$04
	SHR	BX,CL
	ADD	BX,AX
	ADD	BX,#$40
	CMP	BX,minstksz	;>= free memory ?
	CALL	errnb	;98:memory overflow
	B	$62
	JMP.b	ckvmem	;'ok
ckvfil	MOV	AX,cdptr	;code ptr
	SUB	AX,cdbufpt	;-code pos of buffer
	ADD	AX,cdbegpt	;+beg of code buffer
	MOV	CL,#$04	;convert to paragraphs
	SHR	AX,CL
	INC	AX
ckvmem	ADD	AX,destseg	;+ dest segment
	ADD	AX,#$0020	;+ spare
	MOV	BX,symtop	;(symtab top/16)+SS
	SHR	BX,CL
	MOV	CX,SS
	ADD	BX,CX
	CMP	AX,BX	;crash ?
	JB	ckvok	;:no
	PUSH	DX	;save
	CALL	codflush	;flush code buffer
	CALL	errb	;99:compiler overflow
	B	$63
	POP	DX	;restore
ckvok	POP	CX	;restore regs
	POP	BX
	POP	AX
	RET		;"
alpha	CMP	AL,#$41	;valid symbol char ?
	JB	alpharet	;:no
	CMP	AL,#$5B	;A..Z ?
	CMC	
	JNB	alpharet	;:ok
	CMP	AL,#$5F	;_ ?
	JZ	alpharet	;yes: ok
	CMP	AL,#$61	;a..z ?
	JB	alpharet	;:no
	CMP	AL,#$7B
	CMC	
alpharet	RET		;"
alphanum	CALL	alpha	;valid alphanumeric char ?
	JNB	alnret	;:ok
number	CMP	AL,#$30	;0..9 ?
	JB	alnret	;:no
	CMP	AL,#$3A
	CMC	
alnret	RET		;"
perrb	MOV	chptr,DI	;Error if below: store error pos
errb	JNB	skiperr	;:no error
	JMP.b	err	;'
	MOV	chptr,DI	;Error if not below
errnb	JB	skiperr	;:no error
	JMP.b	err	;'
perrz	MOV	chptr,DI	;Error if equal
errz	JNZ	skiperr	;:no error
	JMP.b	err	;'
perrnz	MOV	chptr,DI	;Error if not equal
errnz	JNZ	err	;:error
skiperr	PUSH	BP	;no error: skip inline parameter
	MOV	BP,SP
	INC	[BP]$02
	POP	BP
	RET		;'
perr	MOV	chptr,DI	;store error position
err	POP	BX	;Error: get return addr
	CS:	
	MOV.B	AL,[BX]	;get error number (inline)
errexit	MOV	cperr,AL	;store it
	CALL	disline	;write line number
	OR.B	AL,AL	;test error
	JZ	exitcom	;:no error
	MOV	AX,chptr	;calculate error position
	SUB	AX,#pnbuf	;pos in buffer - buffer beg
	CMP.B	inclflg,#$00	;include file ?
	JNZ	errfil	;:yes
	SUB	AX,txbeg	;- text beg
	ADD	AX,srclnbeg	;+ beginning of source line
	JMP.b	errmem	;'
errfil	ADD	AX,srclnbg	;pos of line begin
errmem	MOV	txerrpos,AX	;store relative error pos
exitcom	MOV	AH,#$80	;close all files
	CALL	dos
	MOV	SP,spsav	;restore stack pointer
	RET		;"return to user-interface
defpart	PUSH	cdptr	;Definition part: save code pointer
	CALL	ejump	;* JMP ....
	PUSH	pc	;save PC
defloop	CALL	ckey	;search keyword
	B	$01	;offset between keywords
	W	tklabel	;keyword pointer
	CALL	errnz	;not found ?
	B	$0C	;12:BEGIN expected
deflab	CMP	AL,#$01	;LABEL ?
	JNZ	defconst	;:no
	CALL	label	;do label
	JMP	defloop	;'next def
defconst	CMP	AL,#$02	;CONST ?
	JNZ	deftype	;:no
	CALL	const	;do const
	JMP	deflab	;'next def, already searched
deftype	CMP	AL,#$03	;TYPE ?
	JNZ	defvar	;:no
	CALL	type	;do type
	JMP	deflab	;'next def
defvar	CMP	AL,#$04	;VAR ?
	JNZ	defover	;:no
	CALL	var	;do var
	JMP	deflab	;'next def
defover	CMP	AL,#$07	;OVERLAY ?
	JNZ	defproc	;:no
	CALL	overlay	;do overlay
	JMP	defloop	;'next def
defproc	CMP	AL,#$08	;BEGIN ?
	JZ	defend	;:yes
	MOV.B	ovrproc,#$00	;flag: not overlay procedure
	CALL	procfunc	;do procedure / function def
	JMP	defloop	;'next def
defend	CALL	resforw	;resolve forward definitions
	POP	CX	;restore beginning PC
	MOV	AX,pc	;new PC
	SUB	AX,CX	;calc offset
	POP	BX	;code ptr of beginning
	INC	BX	;+1: offset
	JMP	patch	;"patch it
emcrunch	MOV	AX,#uncrunch	;emit code for overlay uncrunch
	CALL	ecall	;* CALL uncrunch
	MOV	AX,cdptr	;code ptr
	MOV	uncrlink,AX	;-> link
	CALL	eword	;emit it (dummy)
	MOV	AX,pc	;PC+2
	INC	AX
	INC	AX
	JMP	eword	;"emit it
ptcrunch	MOV	BX,uncrlink	;do overlay uncrunch list
	MOV	AX,cdptr	;code ptr
	SUB	AX,BX	;- pos old link
	CALL	patch	;patch offset
	XOR	AX,AX	;emit a zero:
	JMP	eword	;"current end of the list
label	MOV	AX,#$0100	;label definition
	CALL	symword	;store word in symtab
	MOV	DI,chptr	;current pos
	MOV.B	AL,[DI]	;get char
	CALL	alphanum	;in alphanum ?
	CALL	rdsym0	;get sym - numbers allowed
	MOV.B	AH,lexnest	;lexical nesting
	MOV	AL,#$FF	;flag: unresolved
	CALL	symword	;store word
	CALL	symword	;store dummy: offset
	CALL	symoffs	;write symtab offset
	CALL	ccomma	;, ?
	JZ	label	;yes: do another definition
	JMP	esemi	;"! ;
const	PUSH	symtop	;Constant definition
	XOR	AX,AX	;tag: invisible
	CALL	symword	;store in symtab
	CALL	rdsym	;get symbol name
	CALL	cequal	;= ?
	JNZ	cnstruct	;no: structured constant
	CALL	rdconst	;read constant
	MOV.B	AL,CL	;type
	CALL	symbyte	;store in symtab
	CMP.B	CL,#$09	;real ?
	JNZ	cnstr	;:no
	MOV	AX,creal3	;store real number in symtab
	CALL	symword	;6 bytes
	MOV	AX,creal2
	CALL	symword
	MOV	AX,creal1
	CALL	symword
	JMP.b	cnput	;'do end of entry
cnstr	CMP.B	CL,#$08	;string ?
	JNZ	cnint	;:no
	MOV	BX,#wordbuf	;buffer pointer
	MOV.B	AL,CH	;get length
	INC.B	CH	;counter
cnstlp	CALL	symbyte	;store byte in symtab
	MOV.B	AL,[BX]	;get next char
	INC	BX
	DEC.B	CH	;another ?
	JNZ	cnstlp	;:yes
	JMP.b	cnput	;'do end of entry
cnint	XCHG	AX,BX	;integer constant: result -> AX
	CALL	symword	;store in symtab
cnput	CALL	symoffs	;write symtab offset
	MOV	AL,#$02	;set tag: normal constant
	JMP.b	cnput2	;'do it
cnstruct	CALL	ecolon	;! : (structured constant)
	PUSH	symtop	;save symtab pos
	CALL	symword	;store dummy type
	MOV	AX,pc	;store offset in symtab
	CALL	symword
	MOV	AX,#$FE00	;segment CS
	CALL	symword
	CALL	symoffs	;write symtab offset
	CALL	rdtype	;get type
	POP	BP	;restore symtab pos
	MOV	AX,vartp	;store type ptr
	MOV	[BP]-$02,AX
	CALL	eequal	;! =
	CALL	structcn	;read structured constant
	MOV	AL,#$04	;tag: structured constant
cnput2	POP	BP	;restore symtab pos
	MOV.B	[BP]-$01,AL	;set tag byte: entry type
	CALL	esemi	;! ;
	CALL	ckey	;search keyword: definitions
	B	$01
	W	tklabel
	JZ	cnrt	;:found, exit
	JMP	const	;'do another const definition
cnrt	RET		;"
structcn	MOV	AL,varctp	;read structured constant
	CMP	AL,#$04	;test component type
	JB	scnok	;:ok
	CMP	AL,#$08	;file / pointer ?
	JNB	scnok	;:no
	CALL	err	;61:Files and pointers
	B	$3D	;'are not allowed here
scnok	CMP	AL,#$01	;array ?
	JNZ	scnrec	;:no
	CALL	pushe1	;save entry to stack
	MOV	BP,upper	;index type
	CALL	getparm	;get parameters
	MOV	AX,upper2	;upper bound - lower bound + 1
	SUB	AX,lower2
	INC	AX
	PUSH	AX	;save count
	MOV	BP,lower	;component type pointer
	CALL	getvprm2	;get parms
	POP	CX	;restore count
	CMP.B	varctp,#$0C	;array of char ?
	JNZ	scnarray	;:no
	OR.B	CH,CH	;test count
	JNZ	scnarray	;:more than 256
	CALL	cbrack1	;( ?
	JNZ	scnarrch	;no: defined by string constant
	JMP.b	scnarrlp	;'
scnarray	CALL	ebrack1	;! (
scnarrlp	PUSH	CX	;save count
	CALL	structcn	;read structured constant (recursive !)
	POP	CX	;restore count
	DEC	CX	;count down
	JCXZ	scnaend	;:done
	CALL	ecomma	;! ,
	JMP	scnarrlp	;'do next entry
scnarrch	PUSH	CX	;save count
	CALL	rdstrcn	;read constant
	POP	DX	;restore expected length
	CMP.B	CH,DL	;= length read ?
	CALL	errnz	;50:String const length does not
	B	$32	;match type
	CALL	estr2	;emit string (without length byte)
	JMP.b	scnaend2	;'done
scnaend	CALL	ebrack2	;! )
scnaend2	CALL	pope1	;restore entry
	RET		;'
scnrec	CMP	AL,#$02	;record ?
	JNZ	scset	;:no
	CALL	pushe1	;save entry to stack
	CALL	ebrack1	;! (
	MOV.B	CL,varnest	;record nesting level
	PUSH	varsize	;save component size
	XOR	AX,AX	;offset in record: size done
scnrlp	PUSH	CX	;save nesting, size
	PUSH	AX
	MOV	CH,#$04	;search variable
	CALL	search
	CALL	errnz	;41:Unknown ID or syntax error
	B	$29
	CALL	getvprm	;get parms
	POP	AX	;restore size
	CMP	AX,varofs	;= offset of record sub-var ?
	CALL	errnz	;69:Invalid ordering of fields
	B	$45
	ADD	AX,varsize	;add size to offset
	PUSH	AX	;save it
	CALL	ecolon	;! :
	CALL	structcn	;read structured constant
	CALL	csemi	;, ?
	POP	AX	;restore size, nesting level
	POP	CX
	JZ	scnrlp	;yes: continue
	PUSH	AX	;save size
	CALL	ebrack2	;! )
	POP	AX	;current size
	POP	CX	;component size of record type
	SUB	CX,AX	;compare them
	JZ	scnrok	;:ok
scnrfill	XOR.B	AL,AL	;emit zeroes to fill
	CALL	ebyte
	LOOP	scnrfill	;:another
scnrok	CALL	pope1	;restore entry from stack
	RET		;'
scset	CMP	AL,#$03	;set ?
	JNZ	scstr	;:no
	CALL	pushe1	;save entry to stack
	PUSH	varsize	;save component size
	MOV	BP,lower	;type ptr
	CALL	getvprm2	;get type parms
	CALL	esqr1	;! [
	MOV	DI,#wordbuf	;buffer ptr
	PUSH	DS	;DS,DI: dest ptr
	PUSH	DI
	CALL	sldempty	;make empty set (on stack)
	CALL	csqr2	;] ?
	JZ	scssto	;:yes
scslp	CALL	rdscalar	;get scalar element
	PUSH	AX	;save
	CALL	ctoken
	W	tk2dot
	JNZ	scsincl	;:no
	CALL	rdscalar	;get scalar element
	CALL	setinrng	;include range in set
	JMP.b	scsrng	;'
scsincl	POP	AX	;restore scalar element
	CALL	setincl	;include element in set
scsrng	CALL	ccomma	;, ?
	JZ	scslp	;yes: continue
	CALL	esqr2	;! ]
scssto	MOV	CX,#$0020	;32 bytes
	CALL	setsto	;store set into buffer
	MOV	BX,lower	;crunch set constant:
	MOV	CL,#$03	;(lower bound)/8
	SHR	BX,CL
	ADD	BX,#wordbuf	;+ buffer offset
	POP	CX	;restore component size
scsemit	MOV.B	AL,[BX]	;get byte
	CALL	ebyte	;emit it
	INC	BX	;next one
	LOOP	scsemit	;:another
	CALL	pope1	;restore entry from stack
	RET		;'
scstr	CMP	AL,#$08	;string ?
	JNZ	screal	;:no
	CALL	rdstrcn	;read string constant
	MOV.B	CL,varsize	;component size - 1
	DEC.B	CL
	SUB.B	CL,CH	;>= actual size ?
	JNB	scstok	;:ok
	ADD.B	CL,CH	;limit to max size
	MOV.B	CH,CL
	XOR.B	CL,CL	;nothing to fill up
scstok	CALL	estring	;emit string
	OR.B	CL,CL	;fill up ?
	JZ	scstret	;:no
scstfill	XOR.B	AL,AL	;emit zeroes to reserve space
	CALL	ebyte
	DEC.B	CL	;another ?
	JNZ	scstfill	;:yes
scstret	RET		;'
screal	CMP	AL,#$09	;real ?
	JNZ	scint	;:no
	CALL	rdnumcn	;get numeric constant
	CMP.B	CL,#$09	;real ?
	JZ	scrok	;:ok
	CMP.B	CL,#$0A	;integer ?
	CALL	errnz	;25:Integer or real const expected
	B	$19
	XCHG	AX,BX	;get result
	CALL	intreal	;convert to real
	MOV	creal1,AX	;store it in buffer
	MOV	creal2,BX
	MOV	creal3,DX
scrok	MOV	AX,creal1	;emit resulting real number
	CALL	eword
	MOV	AX,creal2
	CALL	eword
	MOV	AX,creal3
	JMP	eword	;'done
scint	CALL	rdscalar	;integer: get scalar element
	CMP	varsize,#$01	;component size = 1 ?
	JZ	scbyte	;:yes
	JMP	eword	;'emit word
scbyte	JMP	ebyte	;"emit byte
rdscalar	CALL	rdnumcn	;get scalar element
	CMP.B	CL,varctp	;= component type ?
	CALL	errnz	;44:Type mismatch
	B	$2C
	XCHG	AX,BX	;result -> AX
	CMP	AX,lower	;< lower bound ?
	JL	rscalerr	;:yes
	CMP	AX,upper	;> upper bound ?
	JG	rscalerr	;:yes
	RET		;'
rscalerr	CALL	err	;45:Constant out of range
	B	$2D	;"
type	PUSH	symtop	;Type definition
typelp	PUSH	symtop	;save symtab top
	MOV	AX,#$0000	;tag: invisible
	CALL	symword	;store in symtab
	CALL	rdsym	;get symbol
	PUSH	symtop	;save symtab top
	CALL	symword	;store dummy
	CALL	symoffs	;write symtab offset
	CALL	eequal	;! =
	CALL	rdtype	;get type
	POP	BP	;restore pos
	MOV	AX,vartp	;store type ptr
	MOV	[BP]-$02,AX
	POP	BP	;pos of tag
	MOV.B	[BP]-$01,#$03	;set tag: type definition
	CALL	esemi	;! ;
	CALL	ckey	;search keyword: definitions
	B	$01
	W	tklabel
	JNZ	typelp	;not found: another type def
	POP	tyfence	;old symtab top -> type fence
	PUSH	AX	;save next element
	CALL	resptr	;fill in pointer types
	POP	AX	;restore next element
	RET		;"
var	CALL	vardef	;Var definition: define var
	CALL	esemi	;! ;
	CALL	ckey	;search keyword: definitions
	B	$01
	W	tklabel
	JNZ	var	;not found: another var
	RET		;"
overlay	MOV.B	cdinval,#$FF	;Overlay: always recompile
	MOV	DI,#destpn	;get filename
	XOR	DX,DX	;end pos
ovnm1	MOV.B	AL,[DI]	;get char
	OR.B	AL,AL	;end ?
	JZ	ovnmend	;:yes
	CMP	AL,#$2E	;. ?
	JNZ	ovnm2	;:no
	MOV	DX,DI	;remember end pos
ovnm2	INC	DI	;next char
	CMP	AL,#$5C	;\ ?
	JNZ	ovnm1	;no: loop back
	MOV	BX,DI	;set beg position
	XOR	DX,DX	;clear end position
	JMP	ovnm1	;'loop
ovnmend	OR	DX,DX	;end position set ?
	JZ	ovnm3	;:no
	MOV	DI,DX	;set it
ovnm3	CMP	DI,#destpne	;too much ?
	CALL	errnb	;92:Unable to create overlay file
	B	$5C
	MOV	AL,ovrcnt	;overlay counter
	XOR.B	AH,AH	;clear high byte
	INC.B	ovrcnt	;count up
	MOV	[DI],#$302E
	MOV	CL,#$0A	;get 10-digit
	DIV.B	CL
	ADD	AX,#$3030	;-> ASCII
	MOV	[DI]$02,AX	;store number
	MOV.B	[DI]$04,#$00	;mark end
	MOV	AX,#rdover	;* CALL readovr
	CALL	ecall
	MOV	AX,#$FFFF	;invalid overlay in mem
	CALL	eword	;emit word
	MOV	CX,#$000D	;13 bytes
ovnmem	MOV.B	AL,[BX]	;emit file name
	CALL	ebyte
	INC	BX
	LOOP	ovnmem	;:another
	CALL	ptcflush	;patch code in file
	CALL	codflush	;flush code buffer
	MOV	AL,cpmode	;save code destination
	PUSH	AX
	PUSH	dstfile	;save dest file handle
	PUSH	cdptr	;save code ptr
	PUSH	cdbufpt	;save code pos buf beg
	PUSH	cdbegpt	;save beg of buf
	PUSH	cdfoff	;save current offset in file
	PUSH	cdfoff1
	PUSH	uncrlink	;save uncrunch link
	PUSH	ovrlen	;save max length of overlay part
	CMP.B	cpmode,#$00	;compile to memory ?
	JNZ	ovfil	;:no
	MOV.B	cpmode,#$02	;set: to COM
ovfil	MOV	AX,cdptr	;code ptr - code pos of buffer
	SUB	AX,cdbufpt	;add to beg of code buffer
	ADD	cdbegpt,AX
	XOR	AX,AX	;length = 0
	MOV	ovrlen,AX
	MOV	cdfoff,AX	;no offset in file
	MOV	cdfoff1,AX
	CMP.B	cpmode,#$01	;find error ?
	JZ	ovloop
	MOV	AH,#$3C	;create file
	XOR	CX,CX	;no attribute
	MOV	DX,#destpn	;name ptr
	PUSH	DS	;DS -> ES
	POP	ES
	CALL	dos	;open it
	CALL	errb	;92:Unable to create overlay file
	B	$5C
	MOV	dstfile,AX	;store dest file handle
ovloop	XOR	AX,AX
	MOV	cdptr,AX	;clear code ptr
	MOV	cdbufpt,AX	;code pos of buffer
	CALL	ckey	;search key word
	B	$01	;(procedure or function)
	W	tkproc
	CALL	errnz	;16:PROC or FUNC expected
	B	$10
	PUSH	pc	;save PC
	PUSH	cdptr	;save code ptr
	PUSH	AX	;save keyword
	CALL	emcrunch	;emit overlay uncrunch code
	POP	AX	;restore keyword
	MOV.B	ovrproc,#$FF	;set flag: in overlay
	CALL	procfunc	;do proc/func
	CALL	ptcrunch	;end overlay uncrunch list
	CALL	ptcflush	;patch code in file
	POP	CX	;restore code ptr, PC
	POP	DX
	PUSH	BP	;save
ovfill	MOV	AX,cdptr	;new - old code ptr
	SUB	AX,CX
	OR.B	AL,AL	;emit zeroes, until length
	JZ	ovnofill	;a multiple of 256
	XOR.B	AL,AL
	CALL	ebyte
	JMP	ovfill	;'
ovnofill	POP	BP	;restore
	MOV	[BP]-$0E,AX	;store code pos in proc def
	ADD	cdfoff,AX	;add to pos in file
	ADC	cdfoff1,#$00
	MOV	AX,pc	;PC - old PC
	SUB	AX,DX
	MOV	pc,DX	;restore old PC
	CMP	AX,ovrlen	;>= previous procedures ?
	JB	ovshort	;:no
	MOV	ovrlen,AX	;set as max length
ovshort	CALL	codflush	;flush code buffer
	CALL	ctoken	;OVERLAY ?
	W	tkover
	JZ	ovloop	;yes: repeat
	CMP.B	cpmode,#$01	;find error ?
	JZ	ovfind	;yes: no file
	MOV	AH,#$3E	;close file
	MOV	BX,dstfile	;file handle
	CALL	dos
ovfind	MOV	DX,ovrlen	;get maximum length
	POP	ovrlen	;restore variables
	POP	uncrlink	;same as above
	POP	cdfoff1
	POP	cdfoff
	POP	cdbegpt
	POP	cdbufpt
	POP	cdptr
	POP	dstfile
	POP	AX
	MOV	cpmode,AL	;restore code destination
	ADD	DX,pc	;max length + PC
	MOV	BX,uncrlink	;uncrunch link
	MOV	AX,cdptr	;code ptr -> uncrunch link
	MOV	uncrlink,AX
	SUB	AX,BX	;code pos - link
	CALL	patch	;patch link
	CALL	eword	;emit word
	MOV	AX,DX	;max length + PC
	CALL	eword	;emit word
	MOV	pc,DX	;set new PC
	RET		;"
procfunc	MOV	procfnc,AL	;define proc / func: set flag
	MOV.B	CH,AL	;-> type
	XOR.B	CL,CL
	PUSH	CX	;save type
	CALL	srchvar	;search
	POP	AX
	JNZ	prfnew	;not found: new definition
	JMP	prffwd	;'complete forward definition
prfnew	CALL	symword	;store tag word in symbol table
	CALL	rdsym	;get symbol
	PUSH	fence	;save current var fence
	MOV	AX,symtop2	;current sym top
	MOV	fence,AX	;-> new var fence
	PUSH	symtop	;save symtab pos
	SUB	symtop,#$10	;make space
	CALL	chkovrfl	;test overflow
	MOV	BX,#$0004	;size of stack frame
	XOR	CX,CX	;parameter counter
	CALL	cbrack1	;( ?
	JNZ	prfnil	;no:no parms
prfloop	PUSH	BX	;save
	PUSH	CX
	PUSH	symtop	;save symtab pos
	SUB	symtop,#$04	;make space
	CALL	chkovrfl	;test overflow
	CALL	ctoken	;VAR ?
	W	tkvar
	MOV	CX,#$0000	;normal: 0
	JNZ	prfcnt	;no: normal
	DEC.B	CH	;flag: FF00
prfcnt	PUSH	CX	;save flag
	CALL	rdsym	;read symbol
	POP	CX	;restore type
	INC.B	CL	;count vars of same type
	CALL	ccomma	;, ?
	JZ	prfcnt	;yes: repeat
	PUSH	CX	;save count
	OR.B	CH,CH	;VAR-parameter ?
	JNZ	prfnotyp	;:yes
	CALL	ecolon	;! :
	JMP.b	prftype	;'
prfnotyp	CALL	ccolon	;: ?
	JZ	prftype	;yes: ok
	MOV	AX,ptcbeg	;bottom of symtab
	SUB	AX,#$000E	;point to untyped var
	MOV	vartp,AX	;-> type ptr
	JMP.b	prfnot2	;'
prftype	MOV.B	flgvar,CH	;set VAR flag
	CALL	testtp	;get type
	CALL	tstscal	;limit component size
prfnot2	POP	CX	;restore type, count
	POP	BP	;restore symtab pos
	MOV	AX,vartp	;type ptr
	MOV	[BP]-$02,AX	;-> type
	MOV	[BP]-$04,CX	;store count
	MOV	AX,varsize	;component size
	OR.B	CH,CH	;VAR-parameter ?
	JZ	prfnovar	;:no
	MOV	AX,#$0004	;size 4: pointer
prfnovar	XOR.B	CH,CH	;clear hi
	MUL	CX	;count * component size
	POP	CX
	POP	BX	;restore
	ADD	BX,AX	;add to size of stack frame
	INC.B	CL	;count entries
	CALL	csemi	;semicolon ?
	JZ	prfloop	;yes: another parm
	CALL	ebrack2	;! )
prfnil	CALL	symoffs	;write symtab offset
	CMP.B	procfnc,#$06	;function ?
	JNZ	prfprc1	;:no
	CALL	ecolon	;! :
	PUSH	BX	;save parm count,
	PUSH	CX	;stack frame size
	MOV.B	flgvar,#$00	;clear flag: normal var
	CALL	testtp	;get type
	POP	CX	;restore
	POP	BX
	CMP.B	varctp,#$08	;legal type ?
	JNB	prfresok	;:no
	CMP.B	varctp,#$04	;pointer ?
	CALL	errnz	;48:Invalid result type
	B	$30
prfresok	POP	BP	;symtab ptr
	PUSH	BP
	MOV	AX,vartp	;get type ptr
	MOV	[BP]-$02,AX	;store it
	MOV	[BP]-$04,BX	;store stack frame size
	MOV.B	AH,lexnest	;lexical nesting level
	INC.B	AH	;+1
	MOV	AL,#$FF
	MOV	[BP]-$06,AX	;store segment
	ADD	BX,varsize	;add to size of stack frame
prfprc1	CALL	esemi	;! ;
	POP	BP	;restore symtab ptr
	POP	AX	;restore var fence
	MOV	fence,AX
	MOV	AX,pc	;get PC
	CMP.B	ovrproc,#$00	;overlay procedure ?
	JZ	prfnoovr	;:no
	SUB	AX,#$0019	;entry code...
prfnoovr	MOV	[BP]-$08,AX	;store position
	MOV	[BP]-$0A,BX	;store stack frame size
	XOR.B	CH,CH	;store param count
	MOV	[BP]-$10,CX
	MOV	AX,cdprcoff	;position in overlay file
	MOV	[BP]-$0C,AX
	MOV	[BP]-$0E,#$0000	;no forward
	CMP.B	ovrproc,#$00	;overlay procedure ?
	JNZ	prfovr	;:yes
	CALL	ctoken	;FORWARD ?
	W	tkforwrd
	JNZ	prfnofwd	;:no
	MOV	AX,cdptr	;remember code position
	MOV	[BP]-$0C,AX	;for patching
	DEC.B	[BP]-$0F	;set flag: forward def
	CALL	ejump	;emit jump
	JMP	esemi	;'! ;
prfnofwd	CALL	ctoken	;EXTERNAL ?
	W	tkext
	JNZ	prfovr	;:no
	JMP	rdextnal	;'do external procedure
prffwd	CMP.B	[BP]-$0F,#$00	;complete forward definition
	CALL	errz	;test flag. Defined:
	B	$2B	;43:Duplicate ID or label
	CMP.B	ovrproc,#$00	;overlay procedure ?
	CALL	errnz	;yes:
	B	$4C	;76:Overlays cannot be forwarded
	CALL	skipdi	;skip spaces
	CALL	esemi	;! ;
	MOV.B	[BP]-$0F,#$00	;clear forward flag
	MOV	BX,[BP]-$0C	;get addr of forward jump
	INC	BX
	MOV	AX,pc	;PC-proc pos-3 -> offset
	SUB	AX,[BP]-$08
	SUB	AX,#$0003
	CALL	patch	;patch it in
prfovr	PUSH	varspc	;save memory usage
	PUSH	fence	;save fence
	MOV	AX,symtop	;symtab top
	MOV	fence,AX	;-> current fence
	PUSH	BP	;save pos in symtab
	MOV	AX,[BP]-$0A	;get stack frame size
	CMP.B	procfnc,#$05	;procedure ?
	JZ	prfprc2	;:yes
	MOV	BX,[BP]-$02	;subtract size of result
	SS:	
	SUB	AX,[BX]-$02
prfprc2	MOV	varspc,AX	;-> memory usage
	INC.B	lexnest	;inc nesting
	MOV.B	[BP]-$06,#$00
	MOV.B	CL,[BP]-$10	;parameter count
	MOV	BX,BP	;pos
	SUB	BX,#$10
prfsto	OR.B	CL,CL	;all parms done ?
	JZ	prfentry	;:yes
	PUSH	CX	;save count
	SS:	
	MOV	BP,[BX]-$02	;get variable pointer
	PUSH	BX	;save current pos
	MOV	vartp,BP	;set type ptr
	CALL	getvprm2	;get var parms
	POP	BX	;restore pos
	SS:	
	MOV	CX,[BX]-$04	;get type
	MOV.B	flgvar,CH
	XOR.B	CH,CH
	PUSH	CX	;save type
	PUSH	symtop	;save symtab top
	SUB	BX,#$04	;go down
prfsto2	MOV	BP,symtop	;symtab top
	DEC	BP
	DEC	BP
	MOV	[BP]$00,#$0400	;store: var
	DEC	BX
	DEC	BP
	SS:	
	MOV.B	DL,[BX]	;get length
	MOV.B	[BP]$00,DL	;store length
prfsto3	DEC	BX	;go down
	DEC	BP
	SS:	
	MOV.B	AL,[BX]	;get char
	MOV.B	[BP]$00,AL	;store it
	DEC.B	DL	;another ?
	JNZ	prfsto3	;:yes
	SUB	BP,#$06	;go down
	MOV	symtop,BP	;set new symtab top
	CALL	symoffs	;write offset
	LOOP	prfsto2	;:another var
	POP	BP	;restore pos
	POP	CX	;restore count
	PUSH	BX
	CALL	rdvnrm	;store offset, segment
	CALL	tstscal	;scalar var: 2 bytes on stack
	CALL	vardef2	;do var definitions
	POP	BX	;restore pos, cnt
	POP	CX
	DEC.B	CL	;another ?
	JMP	prfsto	;'
prfentry	CALL	ecode	;emit stack frame code
	B	$01,$55	;* PUSH BP
	CMP.B	lexnest,#$01	;lexical nesting = 1 ?
	JNZ	prflong	;:no
	CALL	ecode
	B	$02,$8B,$EC	;* MOV BP,SP
	JMP.b	prfshort	;'
prflong	CALL	ecode	;complicated - do display
	B	$02,$8B,$C4	;* MOV AX,SP
	XOR.B	CH,CH
	MOV.B	CL,lexnest	;lexical nesting -> count
	DEC.B	CL
prfcopy	CALL	ecode	;* PUSH [BP+..]
	B	$02,$FF,$76
	DEC.B	CH	;count down two bytes
	DEC.B	CH
	MOV.B	AL,CH	;offset into display
	CALL	ebyte	;emit offset
	DEC.B	CL	;another level ?
	JNZ	prfcopy	;:no
	CALL	ecode
	B	$02,$8B,$E8	;* MOV BP,AX
prfshort	CALL	ecode	;now push current display !
	B	$01,$55	;* PUSH BP
	MOV	AL,lexnest	;lexical nesting * 2
	XOR.B	AH,AH
	ADD	AX,AX
	NEG	AX
	MOV	varspc,AX	;-> stack usage
	PUSH	AX
	MOV	AL,procfnc	;proc or func ?
	PUSH	AX	;save flag
	CALL	defpart	;do definition part
	POP	AX	;restore... (defs may be recursive)
	MOV	procfnc,AL
	POP	AX
	SUB	AX,varspc	;mem usage - current
	CALL	allotstk	;make space on stack
	POP	BP	;restore symtab ptr
	PUSH	BP
	PUSH	[BP]-$0A	;store memory size
	MOV	AX,varspc	;memory usage
	NEG	AX
	ADD	[BP]-$0A,AX	;add to mem size
	CALL	errb	;98:Memory overflow
	B	$62
	CALL	progpart	;do program part
	POP	AX	;restore memory size - 4
	SUB	AX,#$0004
	CMP.B	procfnc,#$06	;function ?
	JNZ	prfret	;:no
	POP	BP	;restore symtab pos
	PUSH	BP
	PUSH	AX	;save mem size
	CALL	getvprm	;get var parms
	MOV.B	indflg,#$00	;flag: not indexed
	POP	AX	;mem size
	CMP.B	varctp,#$09	;component type = real ?
	JNZ	prfstr	;:no
	SUB	AX,#$0006	;6 bytes on stack
	JMP.b	prfret	;'
prfstr	CMP.B	varctp,#$08	;string ?
	JNZ	prfelse	;:no
	SUB	AX,varsize	;- component size -> pos on stack
	CALL	emovdxi	;* MOV DX,..
	MOV	AX,varsize	;component size: max length - 1
	DEC	AX
	MOV.B	AH,AL	;max string length
	MOV	AL,#$B1	;* MOV CL,..
	CALL	eword
	CALL	ecode	;* MOV SP,BP
	B	$03,$8B,$E5,$5D	;* POP BP
	MOV	AX,#retstr	;* JMP retstr
	CALL	ejump
	JMP.b	prfret2	;'
prfelse	PUSH	AX	;save pos
	CALL	eload	;load var
	POP	AX	;restore
	CMP.B	varctp,#$0B	;boolean ?
	JNZ	prfret	;:no
	CALL	ecode	;* OR AX,AX (set flags)
	B	$02,$0B,$C0
prfret	CALL	ecode	;* MOV SP,BP
	B	$03,$8B,$E5,$5D	;* POP BP
	OR	AX,AX	;stack frame ?
	JNZ	prfretn	;:yes
	CALL	ecode	;none:
	B	$01,$C3	;* RET
	JMP.b	prfret2	;'
prfretn	CALL	ecode	;remove stack frame
	B	$01,$C2	;* RET ....
	CALL	eword	;emit stack frame size
prfret2	CALL	esemi	;! ;
	POP	BP	;restore symtab pos
	DEC.B	[BP]-$06	;clear flag
	DEC.B	lexnest	;restore lexical nesting
	MOV	AX,fence	;fence -> symtab top
	MOV	symtop,AX	;= remove all local vars
	MOV	symtop2,AX
	POP	fence	;restore fence
	POP	varspc	;restore mem usage
	RET		;"
rdextnal	PUSH	BP	;read external proc
	MOV	CX,#$0500	;tag: procedure
	CALL	search
	JZ	rdxold	;: found
	MOV	CX,#$0600	;tag: function
	CALL	search
	JNZ	rdxnew	;:not found
rdxold	PUSH	[BP]-$08	;get offset
	CALL	esqr1	;! [
	CALL	rdintcn	;get integer constant
	CALL	esqr2	;! ]
	POP	AX	;offset + number
	ADD	AX,BX
	JMP.b	rdxsto	;'-> offset of this proc
rdxnew	PUSH	pc	;save PC
	CALL	rdstrcn	;read string constant
	MOV.B	BL,CH	;length
	XOR.B	BH,BH
	MOV.B	[BX]wordbuf,#$00	;store a 0 at the end
	MOV	BX,#wordbuf	;name ptr
	MOV	SI,#extcom	;extension .COM
	CALL	kextdef	;parse filename
	MOV	AX,#$3D00	;open file
	MOV	DX,#scrpn	;name ptr
	PUSH	DS	;DS -> ES
	POP	ES
	CALL	dos	;open it
	CALL	errb	;90:File not found
	B	$5A
	MOV	BX,AX	;file handle
rdxloop	MOV	AH,#$3F	;read from file
	MOV	CX,#$0080	;128 bytes
	MOV	DX,#wordbuf	;dest buffer
	CALL	dos	;do it
	CALL	errb	;90:File not found
	B	$5A
	XCHG	AX,CX	;length read -> CX
	JCXZ	rdxend	;0: end
	MOV	SI,#wordbuf	;source ptr
rdxcopy	MOV.B	AL,[SI]	;get byte from external file
	CALL	ebyte	;and emit it
	INC	SI	;next one
	LOOP	rdxcopy	;:again
	JMP	rdxloop	;'try another block
rdxend	MOV	AH,#$3E	;close file
	CALL	dos
	POP	AX	;restore offset
rdxsto	POP	BP	;restore symtab pos
	MOV	[BP]-$08,AX	;store offset
	JMP	esemi	;"! ;
tstscal	CMP.B	varctp,#$0A	;scalar var ?
	JB	tsc2	;:no
	MOV	varsize,#$0002	;on stack at least 2 bytes
tsc2	RET		;"
resforw	MOV	BP,symtop	;Resolve forward definitions
rfwloop	CMP	BP,fence	;= var fence ?
	JZ	rfwret	;yes: end
	ADD	BP,[BP]$00	;go to next entry
	CMP.B	[BP]-$01,#$06	;function ?
	JZ	rfwfunc	;:yes
	CMP.B	[BP]-$01,#$05	;procedure ?
	JNZ	rfwloop	;:no, next one
rfwfunc	MOV	BX,BP	;entry ptr
	SUB	BX,#$03
	SS:	
	MOV.B	AL,[BX]	;length of name
	XOR.B	AH,AH
	SUB	BX,AX	;go down
	SS:	
	CMP.B	[BX]-$0F,#$00	;defined ?
	CALL	errnz	;no:
	B	$49	;73:Undefined FORWARD procedure
	JMP	rfwloop	;'next one
rfwret	RET		;"
vardef	MOV.B	flgvar,#$00	;define var: clear VAR-flag
	CALL	rdvarlst	;get variable list
	PUSH	CX	;save counter
	PUSH	BP	;save symtab ptr
	CALL	ecolon	;! :
	CALL	rdvartp	;get type, test absolute
	POP	BP	;restore
	POP	CX
vardef2	MOV	DX,varsize	;component size
	CMP.B	flgvar,#$00	;VAR-parameter ?
	JZ	vdvar	;:no
	MOV	DX,#$0004	;yes: pointer !
vdvar	MOV	AX,var3ofs	;var offset
	CMP.B	absflg,#$00	;absolute ?
	JNZ	vdstore	;:yes
	CMP.B	recnum,#$00	;record nesting level ?
	JNZ	vdrec	;:in record
	CMP.B	lexnest,#$00	;inside procedure ?
	JNZ	vdstk	;:yes
	MOV	AX,dc	;DC -> offset
	ADD	dc,DX	;add size to DC
	CALL	errb	;overflow:
	B	$62	;98:Memory overflow
	JMP.b	vdstore	;'
vdstk	SUB	varspc,DX	;go down (stack !)
	CALL	errb	;overflow ?
	B	$62	;98:Memory overflow
	MOV	AX,varspc	;get offset
	JMP.b	vdstore	;'
vdrec	MOV	AX,varspc	;get offset
	ADD	varspc,DX	;add to var space
	CALL	errb	;overflow ?
	B	$62	;98:memory overflow
vdstore	SUB	BP,#$03	;go down in var list
	MOV.B	BL,[BP]$00	;get length
	XOR.B	BH,BH
	SUB	BP,BX	;go down
	MOV	[BP]-$04,AX	;store offset
	MOV	AX,var3seg	;store segment
	MOV	[BP]-$06,AX
	MOV	AX,vartp	;store type ptr
	MOV	[BP]-$02,AX
	SUB	BP,#$08	;make space
	LOOP	vdvar	;another definition ?
	JMP	chkovrfl	;"test for overflow
rdvarlst	PUSH	symtop	;get variable list
	XOR	CX,CX	;clear counter
rdvloop	PUSH	CX	;save
	MOV	AH,#$04	;tag: var, record nesting
	MOV	AL,recnum
	CALL	symword	;store in symtab
	CALL	rdsym	;store name in symtab
	SUB	symtop,#$06	;reserve some space
	CALL	symoffs	;write symtab offset
	POP	CX	;restore counters
	INC	CX
	CALL	ccomma	;, ?
	JZ	rdvloop	;yes: next var
	POP	BP	;restore symtab pos
	RET		;"(beginning of list)
rdvartp	PUSH	symtop	;get var type, test ABSOLUTE
	CALL	rdtype	;read type
	POP	tyfence	;symtab top -> type fence
	CALL	resptr	;fill in pointer types
	CALL	ctoken	;ABSOLUTE ?
	W	tkabs
	JNZ	rdvnrm	;:no
	MOV.B	absflg,#$FF	;set flag
	CMP.B	recnum,#$00	;in record ?
	CALL	errnz	;yes:
	B	$4B	;75:Illegal use of ABSOLUTE
	MOV	CX,#$0400	;search var
	CALL	search
	JNZ	rdvabs	;:not found
	MOV	AX,[BP]-$06	;get offset
	MOV	DX,[BP]-$04	;get segment
	JMP.b	rdvofs	;'store parms
rdvabs	CALL	rdconst	;read constant -> segment
	JNZ	rdvseg	;:no good
	CALL	testint	;test type: integer
	PUSH	BX	;save segment
	CALL	ecolon	;! :
	CALL	rdintcn	;get integer constant
	MOV	DX,pc	;get PC: pos of pointer
	XCHG	AX,BX
	CALL	eword	;emit result = offset
	POP	AX	;emit segment
	CALL	eword
	MOV	AX,#$FEFF	;flag: CS indirect
	JMP.b	rdvofs	;'
rdvseg	CALL	ctoken	;DSEG ?
	W	tkdseg
	MOV	AX,#$FF00	;flag: DS
	JZ	rdvseg2	;:yes
	CALL	ctoken	;CSEG ?
	W	tkcseg
	MOV	AX,#$FE00	;flag: CS
	JZ	rdvseg2	;:yes
	JMP	snerror	;'Unknown ID or syntax error
rdvseg2	PUSH	AX	;save segment flag
	CALL	ecolon	;! :
	CALL	rdintcn	;get integer constant
	POP	AX	;restore segment
	MOV	DX,BX	;offset -> DX
rdvofs	MOV	var3ofs,DX
	JMP.b	rdvsto	;'
rdvnrm	MOV.B	absflg,#$00	;clear absolute flag
	MOV	AL,flgvar	;VAR-parameter ?
	MOV.B	AH,lexnest	;lexical nesting
	OR.B	AH,AH	;inside proc ?
	JNZ	rdvofs	;:yes, use stack segment
	MOV	AH,#$FF	;data segment
rdvsto	MOV	var3seg,AX	;store segment
	RET		;"
testtp	CALL	srchtype	;Test file type: search type
	JZ	ttpsto	;:found
	CALL	ctoken	;TEXT ?
	W	tktext
	JNZ	ttpnotxt	;:no
	CALL	textstd	;get ptr to that type
	JMP.b	ttpsto	;'
ttpnotxt	CALL	ctoken	;FILE ?
	W	tkfile
	CALL	errnz	;no:
	B	$24	;36:Type ID expected
	CALL	filuntp	;point to typed/untyped file
ttpsto	CMP.B	flgvar,#$00	;VAR-parameter ?
	JNZ	rdvnrm	;yes: ok
	CMP.B	varctp,#$05	;typed file ?
	JB	rdvnrm	;:below
	CMP.B	varctp,#$07	;above file ?
	JA	rdvnrm	;yes: ok
	CALL	err
	B	$43	;"67:Files must be VAR parameters
resptr	MOV	BP,symtop	;Fill in pointer types
rptlp	CMP	BP,tyfence	;= type fence ?
	JZ	rptret	;yes: done
	ADD	BP,[BP]$00	;go to next var
	CMP.B	[BP]-$01,#$08	;subtype ?
	JNZ	rptlp	;no: next one
	MOV.B	[BP]-$01,#$00	;make it invisible
	CMP.B	[BP]-$0A,#$04	;pointer ?
	JNZ	rptlp	;no: next one
	CMP.B	[BP]-$09,#$00	;filled in ?
	JZ	rptlp	;:yes
	MOV.B	[BP]-$09,#$00	;flag: filled in
	MOV	BX,[BP]-$08	;get pos of type name
	SS:	
	MOV.B	DL,[BX]-$01	;name length
	XOR.B	DH,DH
	INC	DX	;-> count
	PUSH	BP	;save pos
	MOV	BP,symtop	;search from top
rptsrch	CMP	BP,ptcbeg	;bottom of symbol table ?
	JZ	rpterr	;yes: error
	ADD	BP,[BP]$00	;go to next var
	CMP.B	[BP]-$01,#$03	;type ?
	JNZ	rptsrch	;:no, search next
	MOV	SI,BP	;pointer
	DEC	SI
	DEC	SI
	MOV	DI,BX	;pos of searched string
	MOV	CX,DX	;len -> count
rptcmp	DEC	SI	;go back
	DEC	DI
	SS:	
	MOV.B	AL,[SI]	;compare chars
	SS:	
	CMP.B	AL,[DI]
	JNZ	rptsrch	;:not the right one
	LOOP	rptcmp	;:test another char
	POP	BP	;restore symtab pos
	SS:	
	MOV	AX,[SI]-$02	;get type pointer
	MOV	[BP]-$08,AX	;store into pointer entry
	JMP	rptlp	;'next one
rptret	RET		;'
rpterr	CALL	err	;42:Undefd ptr type in preceding
	B	$2A	;"type defs
rdtype	CALL	srchtype	;get type: search type ID
	JZ	rdtpret	;found: ret
	CALL	ctoken	;PACKED ?
	W	tkpacked	;(ignored)
	CALL	array	;array ?
	JZ	rdtpret	;:done
	CALL	record	;record ?
	JZ	rdtpret	;:done
	CALL	set	;set ?
	JZ	rdtpret	;:done
	CALL	pointer	;pointer ?
	JZ	rdtpret	;:done
	CALL	file	;file ?
	JZ	rdtpret	;:done
	CALL	text	;text ?
	JZ	rdtpret	;:done
	CALL	string	;string ?
	JZ	rdtpret	;:done
	CALL	scalar	;scalar list ?
	JZ	rdtpret	;:done
	CALL	subrange	;subrange ?
	JZ	rdtpret	;:done
	CALL	err	;36:Type identifier expected
	B	$24	;'
rdtpret	RET		;"
srchtype	MOV	CX,#$0300	;search type
	CALL	search
	JNZ	srtret	;:not found - ret
	MOV	BP,[BP]-$02	;type pointer
stdtype	MOV	vartp,BP	;store it
	CALL	getvprm2	;get type parms
	XOR	AX,AX	;ok
srtret	RET		;"
array	CALL	ctoken	;ARRAY ?
	W	tkarray
	JNZ	arret	;:no
	CALL	esqr1	;! [
	XOR	CX,CX	;clear dimension count
arrlp	PUSH	CX	;save
	CALL	rdscaltp	;get scalar type
	POP	CX
	PUSH	vartp	;save type pointer: index type
	MOV	AX,upper	;upper bound - lower bound
	SUB	AX,lower
	INC	AX	;+ 1
	CALL	errz	;98:Memory overflow
	B	$62
	PUSH	AX	;save component count
	INC	CX	;count dimensions
	CALL	ccomma	;, ?
	JZ	arrlp	;yes: another dimension
	PUSH	CX	;save dim count
	CALL	esqr2	;! ]
	CALL	expof	;! OF
	CALL	rdtype	;get type
	POP	CX	;dim count
arrlp2	MOV	AX,vartp	;type ptr
	MOV	lower,AX	;-> type
	MOV	AX,varsize	;component size
	POP	BX	;* component count
	MUL	BX
	CALL	errb	;too much ?
	B	$62	;98:Memory overflow
	MOV	varsize,AX	;-> component size
	POP	AX	;index type
	MOV	upper,AX	;store it
	MOV.B	varctp,#$01	;tag: array
	CALL	stotype	;store type
	LOOP	arrlp2	;:another dimension
arret	RET		;"
record	CALL	ctoken	;RECORD ?
	W	tkrec
	JNZ	recret	;no: ret
	MOV	AL,vrecflg	;save variant rec nesting
	PUSH	AX
	MOV	AL,recnum	;save rec nesting
	PUSH	AX
	INC.B	reccnt	;one more level
	MOV	AL,reccnt	;record counter
	MOV	recnum,AL	;-> record number
	PUSH	varspc	;save space used
	PUSH	maxsize	;save max size of variant rec
	MOV	varspc,#$0000	;clear them
	MOV	maxsize,#$0000
	MOV.B	vrecflg,#$00	;no variant record
	CALL	recdef	;do record definition
	MOV	AX,maxsize	;max component size
	MOV	varsize,AX	;-> variable size
	POP	maxsize	;restore vars
	POP	varspc
	MOV	AL,recnum	;record number
	MOV	varnest,AL	;-> subtype
	POP	AX
	MOV	recnum,AL
	POP	AX
	MOV	vrecflg,AL
	MOV.B	varctp,#$02	;type: record
	CALL	stotype	;store type
recret	RET		;"
recdef	CALL	rectest	;do record def: test end
	JZ	rcdret	;yes: ret
	CALL	ctoken	;CASE ?
	W	tkcase
	JZ	rcdvrec	;:yes
	CALL	vardef	;define variables
	MOV	AX,varspc	;memory used
	CMP	AX,maxsize	;>= max size ?
	JB	rcdsmall	;below: forget
	MOV	maxsize,AX	;store as new max size
rcdsmall	CALL	csemi	;semicolon ?
	JZ	recdef	;yes: loop back
	JMP.b	rcde	;'end it
rcdvrec	CALL	srchtype	;variant record: search type
	JZ	rcdnotag	;:found
	CALL	vardef	;define var: tag field
rcdnotag	CALL	expof	;! OF
rcdvlp	CALL	rectest	;test for end
	JZ	rcdret	;yes: ret
	PUSH	varspc	;save mem used
rcdtag	CALL	rdnumcn	;get constant
	CALL	ccomma	;, ?
	JZ	rcdtag	;:another constant
	CALL	ecolon	;! :
	CALL	ebrack1	;! (
	MOV	AL,vrecflg	;save variant rec flag
	PUSH	AX
	MOV.B	vrecflg,#$FF	;set it
	CALL	recdef	;do type definition list
	POP	AX	;restore flag
	MOV	vrecflg,AL
	POP	varspc	;restore memory used
	CALL	csemi	;semicolon ?
	JZ	rcdvlp	;yes: another
rcde	CMP.B	vrecflg,#$00	;variant record ?
	JZ	rcde1	;:no
	JMP	ebrack2	;'! )
rcde1	CALL	ctoken	;END ?
	W	tkend
	CALL	errnz	;no:
	B	$0E	;14:END expected
rcdret	RET		;"
rectest	CMP.B	vrecflg,#$00	;test end
	JZ	rectest2	;:normal rec
	JMP	cbrack2	;'in variant rec: ) ?
rectest2	CALL	ctoken	;END ?
	W	tkend
	RET		;"
set	CALL	ctoken	;SET ?
	W	tkset
	JNZ	setret	;no: ret
	CALL	expof	;! OF
	CALL	rdscaltp	;get scalar type
	MOV	AX,upper	;upper bound
	MOV	BX,lower	;lower bound
	MOV.B	CL,AH	;one of them > 255 ?