TP3/Resources/turbopascal3source/TP3/TPSRC9

	JNB	exscret	;:ok
	CMP.B	CL,#$08	;string ?
	CALL	errnz	;no:
	B	$1F	;31:Simple expression expected
	MOV	AX,#xstrch	;(string -> char)
	CALL	ecall	;* CALL xstrch
	MOV	CX,#$020C	;type: char in AX
exscret	RET		;"
exstr	CALL	expr	;get string expression: do expr
	CMP.B	CL,#$08	;string ?
	JZ	exstrret	;:yes
	CMP.B	CL,#$0C	;char ?
	CALL	errnz	;no:
	B	$21	;33:String expression expected
	OR.B	CH,CH	;constant ?
	JNZ	ecstrch	;:no
	MOV	AX,exres	;get result
	MOV.B	AH,AL	;char
	MOV	AL,#$01	;length
	CALL	emovaxi	;* MOV AX,#...
	JMP.b	exstrch2	;'
ecstrch	CALL	loadatom	;get atom
	CALL	ecode	;* MOV AH,AL
	B	$04,$8A,$E0,$B0,$01	;* MOV AL,#01
exstrch2	CALL	epushax	;* PUSH AX
	MOV	CL,#$08	;type = string
exstrret	RET		;"
excond	CALL	expr	;evaluate boolean expr: do expr
	CMP.B	CL,#$0B	;boolean ?
	CALL	errnz	;no:
	B	$14	;20:Boolean expression expected
	CALL	loadatom	;get atom
	CMP.B	CH,#$04	;comparision outside ?
	JZ	excondrt	;yes: ok
	MOV	AL,#$75	;store branch op: JNZ
	MOV	brnchop,AL
	CMP.B	CH,#$03	;flags set ?
	JZ	excondrt	;:yes
	CALL	ecode	;* OR AX,AX
	B	$02,$0B,$C0
excondrt	RET		;"
exprax	CALL	expr	;read expression
expload	CMP.B	CL,#$0A	;scalar ?
	JB	excondrt	;below: ret
	CALL	loadatom	;get atom
	JMP	flgbool	;"flags -> boolean
expvar	MOV	AX,#expload	;do expression - var pre-read
	PUSH	AX	;set up return stack
	MOV	AX,#expr2
	PUSH	AX
	MOV	AX,#add2
	PUSH	AX
	MOV	AX,#mul2
	PUSH	AX
	JMP	cvar2	;"start with var
expconst	MOV	AX,#expload	;do expression - const pre-read
	PUSH	AX	;set up return stack
	MOV	AX,#expr2
	PUSH	AX
	MOV	AX,#add2
	PUSH	AX
	MOV	AX,#mul2
	PUSH	AX
	JMP	cconst2	;"start with const
expr	CALL	addlevel	;Comparison level: do add level
expr2	PUSH	CX	;save type
	CALL	ckey	;check comparisons
	B	$02
	W	tkcmp
	POP	CX	;restore type
	JZ	cmp1	;found: do comparison
	RET		;'
cmp1	INC.B	AL	;IN ?
	JZ	cmpin	;:yes
	PUSH	BX	;save op ptr, type
	PUSH	CX
	CALL	pushres	;save entry
	PUSH	pc	;save PC
	PUSH	functp	;save type ptr
	CALL	addlevel	;addition level
	POP	comptp	;restore type ptr
	POP	oldpc	;restore PC
	POP	DX	;restore type
	CALL	typeconv	;do type conversion
	POP	BX	;restore op ptr
	CMP.B	CL,#$0A	;scalar ?
	JB	cmpdiff	;:no
	CS:	
	MOV.B	AL,[BX]$01	;set branch opcode
	MOV	brnchop,AL	;(from comparison table)
	MOV	BX,#cmpcode	;emit parms for comparison
	CALL	ecalc	;emit instruction
	MOV	CX,#$040B	;return type: boolean, flags set
	RET		;'
cmpdiff	CS:		;real, string, set, ptr comparisons
	MOV.B	BL,[BX]	;get offset in cmp table
	XOR.B	BH,BH	;-> table index
	CMP.B	CL,#$09	;real ?
	JZ	cmpfnd	;:yes
	INC	BX	;+2
	INC	BX
	CMP.B	CL,#$08	;string ?
	JZ	cmpfnd	;:yes
	INC	BX	;+2
	INC	BX
	CMP.B	CL,#$03	;set ?
	JZ	cmpfnd	;:yes
	INC	BX	;+2;(pointer)
	INC	BX
cmpfnd	CS:	
	MOV	AX,[BX]vcompare	;get vector from table
	OR	AX,AX	;test it
	CALL	errz	;47:Operand type(s) do
	B	$2F	;not match operator
	JMP.b	cmpemit	;'end it
cmpin	CALL	loadatom	;IN: get atom
	CALL	epushax	;* PUSH AX
	PUSH	CX	;save type
	CALL	addlevel	;do addition level
	POP	DX	;restore type
	CMP.B	CL,#$03	;set ?
	CALL	errnz	;47:Operand type(s) do
	B	$2F	;not match operator
	OR.B	CH,CH	;constant ?
	JZ	cmpconst	;:yes
	CMP.B	DL,CH	;compare types
	CALL	errnz	;different base type:
	B	$2C	;44:Type mismatch
cmpconst	MOV	AX,#xsetin
cmpemit	CALL	ecall	;* CALL xsetin
	MOV	CX,#$030B	;boolean, flags set
	RET		;"
vcompare	W	realeq,csteq,seteq,ptreq	;= vector table for comparisons
	W	realne,cstne,setne,ptrne	;<>
	W	realge,cstge,setge	;>=
	W	$0000
	W	realle,cstle,setle	;<=
	W	$0000
	W	realg,cstg	;>
	W	$0000,$0000
	W	reall,cstl	;<
	W	$0000,$0000	;"
addlevel	CALL	mullevel	;Addition level: do mult level
add2	PUSH	CX	;save type
	CALL	ckey	;check add ops
	B	$05
	W	tkadd
	POP	CX	;restore type
	JZ	addptr	;:found
	RET		;'
addptr	CMP.B	CL,#$04	;pointer ?
	CALL	errz	;yes:
	B	$2F	;47:Operand type(s) does not match op
	PUSH	BX	;save op ptr
	PUSH	CX	;save type
	CALL	pushres	;save first result
	PUSH	pc	;save PC
	CALL	mullevel	;mult level
	CMP.B	CL,#$0C	;char ?
	JNZ	add3	;:no
	OR.B	CH,CH	;constant ?
	JNZ	addch	;:no
	MOV	AX,exres	;get resulting char
	MOV.B	AH,AL
	MOV	AL,#$01	;convert to string
	CALL	emovaxi	;* MOV AX,#..
	JMP.b	addch2	;'
addch	CALL	loadatom	;load second result
	CALL	ecode	;* MOV AH,AL
	B	$04,$8A,$E0,$B0,$01	;* MOV AL,#01
addch2	CALL	epushax	;* PUSH AX
	MOV	CL,#$08	;convert to string
add3	POP	oldpc	;restore PC
	POP	DX	;type first part
	CALL	typeconv	;do type conversions
	POP	BX	;restore op ptr
	CS:	
	CMP.B	[BX],#$02	;OR, XOR ?
	JNB	addbool	;:yes
	MOV	AX,#sunion	;(set +)
	MOV	DX,#sdiff	;(set -)
	CMP.B	CL,#$03	;set ?
	JZ	addset	;:yes
	MOV	AX,#xadd	;(add real)
	MOV	DX,#xsub	;(sub real)
	CMP.B	CL,#$09	;real ?
	JNZ	addstr	;:no
addset	CS:	
	CMP.B	[BX],#$00	;add ?
	JZ	addadd	;:yes
	XCHG	AX,DX	;get subtract vector
addadd	CALL	ecall	;emit call
	JMP	add2	;'loop back
addstr	CMP.B	CL,#$08	;string ?
	JNZ	addscal	;:no
	CS:	
	CMP.B	[BX],#$00	;add ?
	CALL	errnz	;no:
	B	$2F	;47:Operand type(s) does not match op
	MOV	AX,#xconcat	;(concat strings)
	JMP	addadd	;'emit call, loop back
addbool	CMP.B	CL,#$0B	;boolean ?
	JZ	addsc2	;:yes
addscal	CMP.B	CL,#$0A	;scalar ?
	CALL	errnz	;no:
	B	$2F	;47:Operand type(s) does not match op
addsc2	CALL	ecalc	;emit instructions
	JMP	add2	;"loop back
mullevel	CALL	neglevel	;Multiplication level: do unary level
mul2	PUSH	CX	;save result type
	CALL	ckey	;check multiplication ops
	B	$05
	W	tkmul
	POP	CX	;restore type
	JZ	mulptr	;:found
	RET		;'
mulptr	CMP.B	CL,#$04	;pointer ?
	CALL	errz	;yes:
	B	$2F	;47:Operand type(s) does not match op
	PUSH	BX	;save op ptr, type
	PUSH	CX
	CALL	pushres	;emit push first value
	PUSH	pc
	CALL	neglevel	;do unary level
	POP	oldpc	;restore old PC
	POP	DX	;type first op
	POP	BX	;op ptr
	PUSH	BX	;save it again
	CS:	
	CMP.B	[BX],#$01	;division ?
	JNZ	mulnodiv	;:no
	CMP.B	CL,#$0A	;second = integer ?
	JNZ	mulnodiv	;:no
	CALL	loadatom	;load result
	MOV	AX,#xintreal	;convert to real
	CALL	ecall	;* CALL xintreal
	MOV	CL,#$09	;now real
mulnodiv	CALL	typeconv	;do type conversions
	POP	BX	;op ptr
	CS:	
	CMP.B	[BX],#$01	;division ?
	JA	muland	;higher: no reals, sets
	JZ	muldiv	;:division
	MOV	AX,#xmul	;(multiply real)
	CMP.B	CL,#$09	;real ?
	JZ	mulreal	;:yes
	MOV	AX,#sinter	;(set *)
	CMP.B	CL,#$03	;set ?
	JNZ	muland	;no: go out
mulreal	CALL	ecall	;emit call
	JMP	mul2	;'loop back
muldiv	MOV	AX,#xdiv	;(divide real)
	CMP.B	CL,#$09	;real ?
	JZ	mulreal	;:yes
	CALL	err	;47:Operand type(s) does not match op
	B	$2F	;'
muland	CS:		;AND ?
	CMP.B	[BX],#$02
	JNZ	mulscal	;:no
	CMP.B	CL,#$0B	;boolean ?
	JZ	mulemit	;:yes
mulscal	CMP.B	CL,#$0A	;scalar ?
	CALL	errnz	;no:
	B	$2F	;47:Operand type(s) does not match op
mulemit	CALL	ecalc	;emit arithmetic op
	JMP	mul2	;"loop back
neglevel	CALL	ctoken	;Unary level
	W	tknot	;NOT ?
	JNZ	negneg	;:no
	CALL	negneg	;do negation level
	CALL	flgbool	;flags -> boolean
	CMP.B	CL,#$0A	;integer ?
	JZ	negnot	;:ok
	CMP.B	CL,#$0B	;boolean ?
	CALL	errnz	;no:
	B	$2F	;47:Operand type(s) does not match op
	CALL	loadatom	;load value
	CALL	ecode	;* XOR AL,#01
	B	$02,$34,$01
	MOV	CH,#$03	;flags set...
	RET		;'
negnot	CALL	loadatom	;get value
	CALL	ecode	;* NOT AX
	B	$02,$F7,$D0
	RET		;'
negneg	PUSH	negflg	;do negation: save flag
	CALL	testsign	;test sign
	MOV	negflg,DX	;store it
	CALL	atom	;do atom
	MOV	DX,negflg	;get neg flag
	CALL	testnum	;test type
	JZ	negend	;:ok
	CMP.B	CL,#$0A	;integer ?
	JNZ	negreal	;:no
	CALL	loadatom	;get value
	CALL	ecode	;* NEG AX
	B	$02,$F7,$D8
	JMP.b	negend	;'
negreal	MOV	AX,#xneg	;(negate real)
	CALL	ecall
negend	POP	negflg	;restore neg flag
	RET		;"
pushres	CALL	flgbool	;store result on stack
	CMP.B	CL,#$0A	;integer ?
	JB	pushptr	;:no
	CALL	loadatom	;get value
	MOV.B	flgpshax,#$01	;set flag: PUSH AX
	RET		;'
pushptr	CMP.B	CL,#$04	;pointer ?
	JNZ	pushret	;:no
	CALL	ecode	;* PUSH DX
	B	$02,$52,$50	;* PUSH AX
pushret	RET		;"
typeconv	CALL	flgbool	;Do type conversions
	MOV.B	flgpshax,#$00	;no PUSH AX
	CMP.B	DL,#$09	;first = real ?
	JNZ	tcvstr	;:no
	CMP.B	CL,#$0A	;second = integer ?
	JNZ	tcvreal	;:no
	CALL	loadatom	;get value
	MOV	AX,#xintreal
	CALL	ecall	;* CALL xintreal
	MOV	CL,#$09	;-> real
	JMP.b	tcvreal	;'
tcvstr	CMP.B	DL,#$08	;first = string ?
	JNZ	tcvreal	;:no
	CMP.B	CL,#$0C	;second = char ?
	JNZ	tcvreal	;:no
	OR.B	CH,CH	;constant ?
	JNZ	tcvchstr	;:no
	MOV	AX,exres	;get char
	MOV.B	AH,AL	;convert to string
	MOV	AL,#$01
	CALL	emovaxi	;* MOV AX,#i
	JMP.b	tcvchst2	;'
tcvchstr	CALL	loadatom	;get value
	CALL	ecode	;* MOV AH,AL (convert to string)
	B	$04,$8A,$E0,$B0,$01	;* MOV AL,#01
tcvchst2	CALL	epushax	;* PUSH AX
	MOV	CL,#$08	;-> string
tcvreal	CMP.B	CL,#$09	;second = real ?
	JNZ	tcvchst1	;:no
	CMP.B	DL,#$0A	;first = integer ?
	JNZ	tcvint	;:no
	MOV	AX,#xintre2	;convert first number
	CALL	ecall
	MOV	DL,#$09	;first -> real
	JMP.b	tcvint	;'
tcvchst1	CMP.B	CL,#$08	;second = string ?
	JNZ	tcvint	;:no
	CMP.B	DL,#$0C	;first = char ?
	JNZ	tcvint	;:no
	MOV	AX,#xchstr	;first -> string
	CALL	ecall	;* CALL xchstr1
	MOV	DL,#$08	;-> string
tcvint	CMP.B	CL,#$0A	;second = integer ?
	JB	tcvnoint	;:no
	CMP.B	CH,#$02	;calculated ?
	JNZ	tcvpop	;:no
	CALL	ecode	;* POP CX
	B	$01,$59
	JMP.b	tcvchk	;'
tcvpop	MOV	AX,pc	;PC = old PC ?
	CMP	AX,oldpc
	JZ	tcvchk	;:yes
	CALL	epopax	;* POP AX
	JMP.b	tcvchk	;'
tcvnoint	CMP.B	CL,#$04	;pointer ?
	JNZ	tcvchk	;:no
	CALL	ecode	;* POP BX
	B	$02,$5B,$59	;* POP DX
tcvchk	CMP.B	CL,DL	;first = second ?
	CALL	errnz	;no:
	B	$2C	;44:Type mismatch
	CMP.B	CL,#$03	;set ?
	JNZ	tcvset	;:no
	CMP.B	CH,DH	;same base types !
	JZ	tcvret	;:ok
	OR.B	DH,DH	;constant 1 ?
	JZ	tcvret	;yes: ret
	OR.B	CH,CH	;constant 2 ?
	MOV.B	CH,DH	;copy base type
	JZ	tcvret	;yes: ret
	CALL	err	;44:Type mismatch
	B	$2C	;'
tcvset	CMP.B	CL,#$04	;pointer ?
	JNZ	tcvret	;:no
	CMP	functp,#$00	;untyped ?
	JZ	tcvret	;yes: ret
	CMP	comptp,#$00	;untyped ?
	JZ	tcvret	;yes: ret
	MOV	AX,functp	;get type ptr
	CMP	AX,comptp	;compare
	JZ	tcvret	;equal: ok
	CALL	err	;44:Type mismatch
	B	$2C	;'
tcvret	RET		;"
loadatom	OR.B	CH,CH	;load value -> AX
	JNZ	latvar	;:no constant
	MOV	AX,exres	;get result
	CALL	emovaxi	;* MOV AX,#result
	JMP.b	latres	;'
latvar	CMP.B	CH,#$01	;var ?
	JNZ	latret	;no: ret - already in AX
	PUSH	CX	;save
	PUSH	DX
	CALL	eload	;load var
	POP	DX
	POP	CX
latres	MOV	CH,#$02	;flag: in AX
latret	RET		;"
flgbool	CMP.B	CL,#$0B	;Flags -> boolean
	JNZ	flgbret	;:no boolean
	CMP.B	CH,#$03	;flags set ?
	JB	flgbret	;:constant, var, AX
	JZ	flgbres	;flags set: ok
	CALL	ecode	;convert
	B	$03,$B8,$01,$00	;* MOV AX,#0001
	MOV	AL,brnchop
	CALL	ebyte	;emit branch op
	CALL	ecode	;* offset
	B	$02,$01,$48	;* DEC AX
flgbres	MOV	CH,#$02	;flag: result in AX
flgbret	RET		;"
ecalc	PUSH	CX	;Emit arithmetic operation
	OR.B	CH,CH	;second = const ?
	JNZ	ecvar	;:no
	CS:	
	TEST.B	[BX]$04,#$02	;is there a const form ?
	JNZ	ecnocn	;:no
	CS:	
	MOV.B	AL,[BX]$01	;get its opcode
	CALL	ebyte	;emit it
	MOV	AX,exres	;emit the result
	CALL	eword	;as immediate value
	JMP.b	ecxchg2	;'done
ecnocn	MOV	AX,exres	;take immediate
	CALL	emovcxi	;* MOV CX,#result
	JMP.b	ecnoxchg	;'
ecvar	CMP.B	CH,#$01	;variable ?
	JNZ	eccalc	;:no
	CS:	
	TEST.B	[BX]$04,#$04	;is there a var form ?
	JNZ	ecnovar	;:no
	CS:	
	TEST.B	[BX]$04,#$08	;CWD needed ?
	JZ	eccwd1	;:no
	CALL	ecode
	B	$01,$99	;* CWD
eccwd1	CS:	
	MOV	DX,[BX]$02	;base opcode
	AND.B	DH,#$38	;convert to AX,var
	CALL	einstr	;emit instruction
	JMP.b	ecxchg2	;'done
ecnovar	MOV	DX,#$088B	;* MOV CX,...
	CALL	einstr	;emit instruction
	JMP.b	ecnoxchg	;'
eccalc	CS:		;second number in AX
	TEST.B	[BX]$04,#$01	;XCHG needed ?
	JZ	ecnoxchg	;:no
	CALL	ecode
	B	$01,$91	;* XCHG CX,AX
ecnoxchg	CS:	
	TEST.B	[BX]$04,#$08	;CWD needed ?
	JZ	eccwd2	;:no
	CALL	ecode
	B	$01,$99	;* CWD
eccwd2	CS:	
	MOV	DX,[BX]$02	;base opcode
	CALL	emitdx	;emit it
ecxchg2	CS:	
	TEST.B	[BX]$04,#$10	;second XCHG needed ?
	JZ	ecres	;:no
	CALL	ecode
	B	$01,$92	;* XCHG DX,AX (for MOD)
ecres	POP	CX	;restore type
	MOV	CH,#$02	;result in AX
	RET		;"
atom	CALL	cvar	;Do atom: do var
	JZ	atomret	;:done
	CALL	cconst	;do constant
	JZ	atomret	;:done
	CALL	cfunc	;do function
	JZ	atomret	;:done
	CALL	cset	;do set
	JZ	atomret	;:done
	CALL	cparens	;do parentheses
	JZ	atomret	;:done
	CALL	cstdfn	;do standard functions
	JZ	atomret	;:done
	CALL	ctype	;do type conversions
	JZ	atomret	;:done
	CALL	cnil	;test for NIL
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
atomret	RET		;"
cvar	CALL	rdvar	;get var
	JNZ	atomret	;no:ret
cvar2	MOV	AL,varctp	;component type:
	CMP	AL,#$0A	;integer ?
	JB	cvareal	;:below
	MOV	CH,#$01	;var
	CMP	varsize,#$01	;byte ?
	JA	cvaint	;:no, word
	CALL	eload	;load var
	MOV	CH,#$02	;now in AX
cvaint	MOV.B	CL,varctp	;get component type
	JMP.b	cvaok	;'ok
cvareal	CMP	AL,#$09	;real ?
	JZ	cvaload	;:yes
	CMP	AL,#$08	;string ?
	JZ	cvaload	;:yes
	CMP	AL,#$03	;set ?
	JZ	cvaload	;:yes
	CMP	AL,#$04	;pointer ?
	JNZ	cvaarrch	;:no
cvaload	CALL	eload	;load var
	MOV	BP,lower	;type ptr
	MOV	functp,BP
	MOV.B	CL,varctp	;component type
	CMP.B	CL,#$03	;set ?
	JNZ	cvaok	;:no, ok
	MOV.B	CH,[BP]-$08	;get base type
	JMP.b	cvaok	;'ok
cvaarrch	CMP	AL,#$01	;array ?
	CALL	errnz	;no:
	B	$3E	;62:Struct vars are not allowed here
	CALL	varptr2	;get var ptr
	MOV	BP,lower	;type ptr
	CMP.B	[BP]-$08,#$0C	;array of char ?
	CALL	errnz	;no:
	B	$3E	;62:Struct vars are not allowed here
	MOV	BP,upper	;index type
	CMP.B	[BP]-$08,#$0A	;= scalar ?
	CALL	errnz	;no:
	B	$3E	;62:Struct vars are not allowed here
	MOV	AX,varsize	;component size
	OR.B	AH,AH	;> 255 ?
	CALL	errnz	;yes:
	B	$3E	;62:Struct vars are not allowed here
	MOV.B	AH,AL
	MOV	AL,#$B1
	CALL	eword	;* MOV CL,#len
	MOV	AX,#xldarrch	;(load array of char)
	CALL	ecall	;* CALL xldarrch
	MOV	CL,#$08
cvaok	XOR	AX,AX	;ok
	RET		;"
cconst	CALL	constel	;get constant element
	JNZ	ccnret	;no good: ret
	MOV	DX,negflg	;negation flag
	CALL	donegate	;do negation
	MOV	negflg,#$0000	;clear neg flag
cconst2	CMP.B	CL,#$09	;real ?
	JNZ	ccnstr	;:no
	MOV	AX,#xrealcn	;(load real constant)
	CALL	ecall	;* CALL xrealcn
	MOV	AX,creal1	;emit real constant
	CALL	eword	;as inline code
	MOV	AX,creal2
	CALL	eword
	MOV	AX,creal3
	CALL	eword
	JMP.b	ccnok	;'ok
ccnstr	CMP.B	CL,#$08	;string ?
	JNZ	ccnscal	;:no
	MOV	AX,#xstrcn	;(get inline string)
	CALL	ecall	;* CALL xstrcn
	PUSH	CX	;save
	CALL	estring	;emit string
	POP	CX
	JMP.b	ccnok	;'ok
ccnscal	MOV	exres,BX	;store result
	XOR.B	CH,CH	;type: constant
ccnok	XOR	AX,AX	;ok
ccnret	RET		;"
cfunc	MOV	CX,#$0600	;Do function
	CALL	search	;search it
	JNZ	cfnret	;not found: ret
	CALL	estkchk	;emit stack check
	MOV	BX,[BP]-$02	;result type ptr
	SS:	
	MOV	AX,[BX]-$02	;result type size
	CALL	allotstk	;allot stack space for result
	CALL	cproc2	;call function (like procedure)
	CALL	getvprm	;get var parms
	MOV	AX,lower	;result type ptr
	MOV	functp,AX
	MOV.B	CL,varctp	;component type
	MOV	CH,#$02	;result in AX / on stack
	CMP.B	CL,#$0B	;boolean ?
	JNZ	cfnok	;:no
	MOV	CH,#$03	;flags set
cfnok	XOR	AX,AX	;ok
cfnret	RET		;"
allotstk	CMP	AX,#$0002	;Allocate space on stack
	JA	astksub	;:offset > 2
	XCHG	AX,CX	;offset -> CX
	JCXZ	cfnret	;:nothing to allot
astkdec	CALL	ecode	;* DEC SP
	B	$01,$4C
	LOOP	astkdec	;:another byte
	RET		;'
astksub	CALL	offslen	;short or long offset
	MOV	DX,#$EC83	;short
	JZ	astkshrt	;:short
	MOV	DL,#$81	;long
astkshrt	PUSH	AX	;save AX
	CALL	emitdx	;* SUB SP,#....
	POP	AX	;restore
	TEST.B	DL,#$02	;short ?
	JZ	astklong	;:no
	JMP	ebyte	;'emit byte offset
astklong	JMP	eword	;"emit word offset
cset	CALL	csqr1	;Do set: [ ?
	JNZ	csetret	;no:ret
	MOV	AX,#sldempty	;(make empty set)
	CALL	ecall	;* CALL sldempty
	CALL	csqr2	;] ?
	MOV	CX,#$0003	;type: untyped set
	JZ	csetret	;:yes
csetlp	PUSH	CX	;save type
	CALL	exscal	;get scalar expression
	MOV.B	AL,CL	;type read
	POP	CX	;restore type
	OR.B	CH,CH	;typed set ?
	JNZ	csetcn	;:yes
	MOV.B	CH,AL	;set type from const read
csetcn	CMP.B	AL,CH	;compare base type
	CALL	errnz	;not equal:
	B	$2C	;44:Type mismatch
	PUSH	CX	;save type
	CALL	ctoken	;.. ?
	W	tk2dot
	MOV	AX,#setincl	;(include element in set)
	JNZ	csetincl	;:no
	CALL	epushax	;* PUSH AX
	CALL	exscal	;get scalar expr
	MOV.B	AL,CL	;result type
	POP	CX
	PUSH	CX
	CMP.B	AL,CH	;= type of set ?
	CALL	errnz	;no:
	B	$2C	;44:Type mismatch
	MOV	AX,#setinrng	;(include range in set)
csetincl	CALL	ecall	;emit call
	POP	CX	;restore type
	CALL	ccomma	;, ?
	JZ	csetlp	;yes: loop back
	CALL	esqr2	;! ]
	XOR	AX,AX	;ok
csetret	RET		;"
cparens	CALL	cbrack1	;Do parentheses: ( ?
	JNZ	cparret	;no:ret
	CALL	expr	;get expression
	CALL	ebrack2	;! )
	XOR	AX,AX	;ok
cparret	RET		;"
ctype	MOV	CX,#$0300	;Do type conversions
	CALL	search	;search type
	JNZ	ctpret	;not found: ret
	MOV	BP,[BP]-$02	;get type ptr
	MOV.B	AL,[BP]-$08	;get component type
	CMP	AL,#$0A	;scalar ?
	CALL	errb	;no:
	B	$1E	;30:Simple type expected
	PUSH	AX	;save type
	CALL	ebrack1	;! (
	CALL	expr	;get expression
	CALL	ebrack2	;! )
	CALL	chksimpl	;check simple type
	POP	AX	;restore type
	MOV.B	CL,AL	;convert to type wanted
	XOR	AX,AX	;ok
ctpret	RET		;"
cnil	CALL	ctoken	;test for NIL
	W	tknil
	JNZ	cnilret	;no:ret
	CALL	ecode	;* XOR AX,AX
	B	$04,$33,$C0,$33,$D2	;* XOR DX,DX
	MOV	CL,#$04	;type: pointer
	XOR	AX,AX	;ok
	MOV	functp,AX	;untyped ptr
cnilret	RET		;"
cstdfn	CALL	ckey	;Do standard functions
	B	$02
	W	stdfuncs
	JNZ	csfret	;not found: ret
	CS:	
	CALL	[BX]	;call compiler routine
	MOV	CH,#$02	;flag: result in AX
	CMP.B	CL,#$0B	;boolean ?
	JNZ	csfok	;:no
	MOV	CH,#$03	;flags set
csfok	XOR	AX,AX	;ok
csfret	RET		;"
fsqr	CALL	getnum	;SQR (num)
	CMP.B	CL,#$0A	;integer ?
	JNZ	fsqr2	;:no
	CALL	ecode
	B	$02,$F7,$E8	;* IMUL AX
	RET		;'
fsqr2	MOV	AX,#xsqr	;(sqr real)
fsqremit	JMP	ecall	;"emit call
fabs	CALL	getnum	;ABS (num)
	MOV	AX,#iabs	;(abs integer)
	CMP.B	CL,#$0A	;integer ?
	JZ	fsqremit	;yes: emit call
	MOV	AX,#xabs	;(abs real)
	JMP	fsqremit	;"
fsqrt	MOV	AX,#xsqrt	;SQRT
	JMP.b	freal	;'
fsin	MOV	AX,#xsin	;SIN
	JMP.b	freal	;'
fcos	MOV	AX,#xcos	;COS
	JMP.b	freal	;'
farctan	MOV	AX,#xarctan	;ARCTAN
	JMP.b	freal	;'
fln	MOV	AX,#xln	;LN
	JMP.b	freal	;'
fexp	MOV	AX,#xexp	;EXP
	JMP.b	freal	;'
fint2	MOV	AX,#xint	;INT
	JMP.b	freal	;'
ffrac	MOV	AX,#xfrac	;FRAC
freal	PUSH	AX	;save function addr
	CALL	getnum	;(num)
	CMP.B	CL,#$09	;real ?
	JZ	freal2	;:yes
	MOV	AX,#xintreal	;(integer -> real)
	CALL	ecall
	MOV	CL,#$09	;now: real
freal2	POP	AX	;restore addr
	JMP	ecall	;"emit call
ftrunc	MOV	AX,#xtrunc	;TRUNC
	JMP.b	frnd2	;'
fround	MOV	AX,#xround	;ROUND
frnd2	PUSH	AX	;save addr
	CALL	getnum	;(num)
	POP	AX	;restore
	CMP.B	CL,#$0A	;integer ?
	JNZ	frndemit	;:no
	RET		;'int: do nothing
frndemit	MOV	CL,#$0A	;convert to integer
	JMP	ecall	;"emit call
fsucc	MOV	AL,#$40	;SUCC: INC AX
	JMP.b	fpred2	;'
fpred	MOV	AL,#$48	;PRED: DEC AX
fpred2	PUSH	AX	;save opcode
	CALL	getscal	;(scal)
	POP	AX	;restore op
	JMP	ebyte	;"emit it
flo	CALL	getint	;LO: (int)
	CALL	ecode
	B	$02,$32,$E4	;* XOR AH,AH
	RET		;"
fhi	CALL	getint	;HI: (int)
	CALL	ecode	;* MOV AL,AH
	B	$04,$8A,$C4,$32,$E4	;* XOR AH,AH
	RET		;"
fswap	CALL	getint	;SWAP: (int)
	CALL	ecode
	B	$02,$86,$C4	;* XCHG AH,AL
	RET		;"
fodd	CALL	getint	;ODD: (int)
	CALL	ecode
	B	$03,$25,$01,$00	;* AND AX,#0001
	MOV	CL,#$0B	;boolean result
	RET		;"
fkeypres	MOV	AX,#xkeypres	;KEYPRESSED
	MOV	CL,#$0B	;result: boolean
	JMP	ecall	;"emit call
ford	CALL	getscal	;ORD: (scalar)
	MOV	CL,#$0A	;result: integer
	RET		;"
fchr	CALL	getint	;CHR: (int)
	MOV	CL,#$0C	;result: char
	RET		;"
flength	CALL	ebrack1	;! ( : LENGTH
	MOV	AX,#xlength
flen2	PUSH	AX	;save addr
	CALL	exstr	;get string expression
	CALL	ebrack2	;! )
	POP	AX	;restore addr
	JMP	frndemit	;"int result, emit call
fpos	CALL	ebrack1	;! ( : POS
	CALL	exstr	;get string expression
	CALL	ecomma	;! ,
	MOV	AX,#xpos
	JMP	flen2	;"get second string expr
fcopy	CALL	ebrack1	;! ( : COPY
	CALL	exstr	;get string expr
	CALL	ecomma	;! ,
	CALL	exint	;get int expr
	CALL	ecomma	;! ,
	CALL	epushax	;* PUSH AX
	CALL	exint	;get int expr
	MOV	AX,#xcopy
	CALL	ecall	;emit call
fcopemit	CALL	ebrack2	;! )
	MOV	CL,#$08	;result: string
	RET		;"
fconcat	CALL	ebrack1	;! ( : CONCAT
	CALL	exstr	;get string expr
fconlp	CALL	ccomma	;, ?
	JNZ	fcopemit	;no:end it
	CALL	exstr	;get string expr
	MOV	AX,#xconcat
	CALL	ecall	;emit call
	JMP	fconlp	;"another string ?
fparmcnt	MOV	AX,#xparmcnt	;PARAMCOUNT
	JMP	frndemit	;"result: integer
fparmstr	CALL	getint	;PARAMSTR: (int)
	MOV	AX,#xparmstr
	MOV	CL,#$08	;result: string
	JMP	ecall	;"emit call
frandom	CALL	cbrack1	;RANDOM: ( ?
	MOV	AX,#xrandom	;(random real)
	MOV	CL,#$09	;result: real
	JNZ	frndreal	;no (: take real
	CALL	exint	;get int expr
	CALL	ebrack2	;! )
	MOV	AX,#irandom	;(random int)
femitint	MOV	CL,#$0A	;result: integer
frndreal	JMP	ecall	;"emit call
fiores	MOV	AX,#xiores	;IORESULT
	JMP	femitint	;"-> integer
feof	CALL	getfil	;EOF: (file)
	MOV	BX,#veof	;ptr to vector table
	CALL	ecallio	;emit call for I/O
femitboo	MOV	CL,#$0B	;result: boolean
	RET		;"
fseekeof	MOV	AX,#xseekeof	;SEEKEOF
	JMP.b	feo2	;'
fseekeol	MOV	AX,#xseekeol	;SEEKEOLN
	JMP.b	feo2	;'
feoln	MOV	AX,#xeoln	;EOLN
feo2	PUSH	AX	;save addr
	CALL	getfil	;(file)
	CMP.B	CL,#$06	;text file ?
	CALL	errnz	;no:
	B	$23	;35:Textfile expected
	POP	AX	;restore addr
	CALL	ecall	;emit call
	JMP	femitboo	;"result: boolean
ffilpos	MOV	AX,#xfilepos	;FILEPOS
	JMP.b	ffil2	;'
ffilsize	MOV	AX,#xfilesiz	;FILESIZE
ffil2	PUSH	AX	;save addr
	CALL	getfil	;(file)
	POP	AX	;addr
	CMP.B	CL,#$06	;text file ?
	CALL	errz	;yes:
	B	$3F	;63:Textfiles are not allowed here
	JMP	femitint	;"int result, emit call
flfilpos	MOV	AX,#xlfilpos	;LONGFILEPOS
	JMP.b	flf2	;'
flfilsiz	MOV	AX,#xlfilsiz	;LONGFILESIZE
flf2	PUSH	AX	;save addr
	CALL	getfil	;(file)
	POP	AX	;addr
	CMP.B	CL,#$06	;text file ?
	CALL	errz	;yes:
	B	$3F	;63:Textfiles are not allowed here
	MOV	CL,#$09	;result: real
	JMP	ecall	;"emit call
fmemavl	MOV	AX,#xmemavl	;MEMAVAIL
	JMP	femitint	;"int result, emit call
fmaxavl	MOV	AX,#xmaxavl	;MAXAVAIL
	JMP	femitint	;"int result, emit call
faddr	CALL	ebrack1	;! ( : ADDR
	CALL	varptr	;get var ptr
	CALL	ecode	;* POP DX
	B	$02,$5A,$97	;* XCHG DI,AX
fretptr	CALL	ebrack2	;! )
	MOV	CL,#$04	;result: pointer
	MOV	functp,#$0000	;untyped
	RET		;"
fptr	CALL	ebrack1	;! ( : PTR
	CALL	exint	;get int expr
	CALL	ecomma	;! ,
	CALL	epushax	;* PUSH AX
	CALL	exint	;get int expr
	CALL	ecode	;* POP DX (segment)
	B	$01,$5A
	JMP	fretptr	;"expect ), pointer
fofs	CALL	ebrack1	;! ( : OFS
	MOV	CX,#$0500	;search procedure
	CALL	search
	JZ	fofsproc	;:found
	MOV	CX,#$0600	;search function
	CALL	search
	JNZ	fofsvar	;:not found
fofsproc	MOV	AX,[BP]-$08	;get offset
fofsimme	CALL	emovaxi	;* MOV AX,#proc_offset
	JMP.b	fofsint	;'type: integer
fofsvar	CALL	rdvar	;get var
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
	CALL	loadoffs	;get offset
	CALL	ecode	;* XCHG DI,AX
	B	$01,$97	;(offset -> AX)
fofsint	CALL	ebrack2	;! )
	MOV	CL,#$0A	;result: integer
	RET		;"
fseg	CALL	ebrack1	;! ( : SEG
	CALL	rdvar	;get var
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
	MOV	AL,#$8C	;(MOV AX,DS)
	MOV	AH,#$D8
	CMP.B	varseg,#$FF	;DS ?
	JZ	fsegemit	;yes: ok
	MOV	AH,#$C0	;(MOV AX,ES)
	CMP.B	varseg,#$FD	;ES ?
	JZ	fsegemit	;yes: ok
	MOV	AH,#$D0	;(MOV AX,SS)
	JB	fsegemit	;below: ok
	MOV	AH,#$C8	;(MOV AX,CS)
fsegemit	CALL	eword	;emit word
	JMP	fofsint	;"expect ), integer
fsizeof	CALL	ebrack1	;! ( : SIZEOF
	MOV	CX,#$0300	;search type
	CALL	search
	JNZ	fszvar	;:not found
	MOV	BP,[BP]-$02	;type ptr
	MOV	AX,[BP]-$02	;get component size
	CALL	emovaxi	;* MOV AX,#compo_size
	JMP	fofsimme	;'(Bug: redundant load !)
fszvar	CALL	rdvar	;get var
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
	MOV	AX,varsize	;get component size
	JMP	fofsimme	;"emit MOV AX,#.., integer
fdseg	CALL	ecode	;DSEG
	B	$02,$8C,$D8	;* MOV AX,DS
	JMP.b	fsseg2	;'int result
fcseg	CALL	ecode	;CSEG
	B	$02,$8C,$C8	;* MOV AX,CS
	JMP.b	fsseg2	;'int result
fsseg	CALL	ecode	;SSEG
	B	$02,$8C,$D0	;* MOV AX,SS
fsseg2	MOV	CL,#$0A	;integer
	RET		;"
fportw	MOV	AL,#$ED	;PORTW
	JMP.b	fprt2	;'(IN AX,[DX])
fport	MOV	AL,#$EC	;PORT (INB AL,[DX])
fprt2	PUSH	AX	;save opcode
	CALL	esqr1	;! [
	CALL	exint	;get int expr
	CALL	esqr2	;! ]
	CALL	ecode
	B	$01,$92	;* XCHG DX,AX (port number)
	POP	AX	;restore opcode
	CALL	ebyte	;emit it
	CMP	AL,#$ED	;integer ?
	JZ	fsseg2	;:yes
	CALL	ecode	;byte:
	B	$02,$32,$E4	;* XOR AH,AH
	JMP	fsseg2	;"int result
fupcase	CALL	getscal	;UPCASE: (scalar)
	MOV	CL,#$0C	;result: char
	MOV	AX,#xupcase
	JMP	ecall	;"emit call
fwherex	MOV	AX,#xwherex	;WHEREX
	JMP	femitint	;"int result, emit call
fwherey	MOV	AX,#xwherey	;WHEREY
	JMP	femitint	;"int result, emit call
veof	W	xeofty,xeoftx,xeofty	;"EOF vector table
getint	CALL	ebrack1	;! ( : get (int)
	CALL	exint	;get int expr
	JMP	ebrack2	;"! )
getnum	CALL	ebrack1	;! ( : get (num)
	CALL	exnum	;get num expr
	JMP	ebrack2	;"! )
getscal	CALL	ebrack1	;! ( : get (scalar)
	CALL	exscal	;get scalar expr
	JMP	ebrack2	;"! )
getfil	CALL	cbrack1	;get (file): ( ?
	JNZ	gtfstd	;:no
	CALL	rdfilvar	;get file var
	JNB	gtf2	;:ok
	CALL	err	;41:Unknown ID or syntax error
	B	$29	;'
gtf2	CALL	errnz	;not file var:
	B	$15	;21:File var expected
	JMP	ebrack2	;'! )
gtfstd	CALL	ecode	;set ptr to std input file
	B	$04,$BF,$5A,$01,$1E	;* MOV DI,#stdin
	MOV	CL,#$06	;* PUSH DS
	MOV.B	varctp,CL	;type: text file
	RET		;"
fullvar	CALL	rdconst	;Do full var: read constant
	JNZ	rdvar	;no good: read var
	CMP.B	CL,#$08	;string constant ?
	CALL	errnz	;no:
	B	$3C	;60:Constants are not allowed here
	MOV	AL,#$EB	;JMP
	MOV.B	AH,CH	;offset: length of string
	CALL	eword	;emit branch around string constant
	MOV	AX,pc	;save current pos
	MOV	varofs,AX	;-> offset of var
	MOV.B	indflg,#$00	;not indexed
	MOV.B	varseg,#$FE	;segment CS
	MOV.B	varctp,#$01	;type: array
	MOV	AX,ptcbeg	;std type: char
	SUB	AX,#$0062
	MOV	lower,AX	;-> type pointer
	XOR	AX,AX	;no index type
	MOV	upper,AX
	MOV.B	AL,CH	;length -> component size
	MOV	varsize,AX
	CALL	estr2	;emit array of char
	XOR	AX,AX	;ok
	RET		;'
rdvar	CALL	indwith	;do WITH-indexing
	JZ	rdvarlp	;:done
	MOV	CX,#$0400	;search var
	CALL	search
	JNZ	rvamem	;not found: try MEM
	CALL	getvprm	;get var parms
rdvarind	MOV.B	indflg,#$00	;flag: not indexed
	CMP.B	indptflg,#$00	;indirect by ptr ?
	JZ	rdvarlp	;:no
	CALL	indptrld	;get ptr to var
rdvarlp	CALL	indarray	;do array indexing
	JZ	rdvarlp	;done: loop
	CALL	indrec	;do record indexing
	JZ	rdvarlp	;done: loop
	CALL	indptr	;do pointer indexing
	JZ	rdvarlp	;done: loop
	CALL	indstr	;do string indexing
	XOR	AX,AX	;ok
	RET		;'
rvamem	CALL	ckey	;search keyword:
	B	$01	;MEM / MEMW
	W	tkmem
	JNZ	rvaret	;not found: ret
	CS:	
	MOV.B	AL,[BX]	;get component size
	PUSH	AX	;save it
	CALL	esqr1	;! [
	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX (segment)
	CALL	ecolon	;! :
	CALL	exint	;get int expr
	CALL	esqr2	;! ]
	CALL	ecode	;* XCHG DI,AX
	B	$02,$97,$07	;* POP ES
	POP	AX	;get length flag
	XOR.B	AH,AH	;clr hi
	MOV	varsize,AX	;-> component size
	MOV.B	varctp,#$0A	;type integer
	CMP	AL,#$01	;byte ?
	JNZ	rvamemw	;:no
	MOV	lower,#$0000	;set lower, upper bound
	MOV	upper,#$00FF
	JMP.b	rvamemb	;'
rvamemw	MOV	lower,#$8000	;set lower, upper bound
	MOV	upper,#$7FFF
rvamemb	MOV	varofs,#$0000	;var offset: none
	MOV.B	indflg,#$FF	;indexed
	MOV.B	varseg,#$FD	;segment ES
	XOR	AX,AX	;ok
rvaret	RET		;"
indwith	MOV.B	BL,withnest	;Do WITH indexing
	XOR.B	BH,BH	;with nesting -> count
iwloop	DEC	BX	;count down
	JNS	iw1	;:another level to test
	RET		;'
iw1	PUSH	BX	;save counter
	SHL	BX,1 	;* 4
	SHL	BX,1 	;-> pointer into with-table
	MOV	CX,[BX]withtab	;type
	PUSH	CX
	PUSH	[BX]withtab1	;position
	MOV	CH,#$04	;search var (record num)
	CALL	search
	POP	AX	;restore pos, type, counter
	POP	CX
	POP	BX
	JNZ	iwloop	;not found: do next level
	MOV.B	indflg,#$00	;flag: not indexed
	CMP	AX,#$FFFF	;indexed WITH ?
	JZ	iwvar	;:yes
	MOV.B	varseg,CH	;get offset from with-table
	MOV	varofs,AX
	JMP.b	iwconst	;'do record indexing
iwvar	PUSH	BP	;save symtab pos
	MOV.B	BL,CH	;get stack offset
	SHL	BX,1 
	MOV	AX,varspc	;stack usage
	SUB	AX,BX	;- position
	MOV	varofs,AX	;-> offset
	MOV	AL,lexnest	;lexical nesting
	MOV	varseg,AL	;-> var segment
	CALL	indptrld	;get pointer to var
	POP	BP	;restore symtab ptr
iwconst	JMP	iraddofs	;"do record indexing
indstr	CMP.B	varctp,#$08	;Do string indexing
	JNZ	iaret	;no string: ret
	CALL	csqr1	;[ ?
	JNZ	iaret	;no: ret
	MOV	AX,ptcbeg	;point to char type
	SUB	AX,#$0062
	MOV	lower,AX	;-> type ptr
	JMP.b	ialoop	;"get index
indarray	CMP.B	varctp,#$01	;Do array indexing
	JNZ	iaret	;no array: ret
	CALL	csqr1	;[ ?
	JZ	ialoop	;yes: do it
iaret	RET		;'
ialoop	MOV	AX,flgpshes	;flag: emit PUSH ES
	CMP.B	varseg,#$FD	;segment ES ?
	JNZ	ialp2	;:no
	MOV.B	flgpshes,#$01	;set flag
ialp2	CMP.B	indflg,#$00	;indexed ?
	JZ	ianoind	;:no
	MOV.B	flgpshdi,#$01	;set flag: emit PUSH DI
ianoind	CALL	pushe1	;push entry
	PUSH	pc	;save PC, flag
	PUSH	AX
	CALL	expr	;evaluate expression
	POP	AX	;restore
	CMP	flgpshes,#$00	;flag = 0 ?
	JZ	iarest	;:yes
	MOV	flgpshes,AX	;restore flag
iarest	POP	AX	;old PC
	SUB	AX,pc	;anything emitted ?
	OR.B	CH,CH	;constant ?
	JZ	ianosto	;:yes
	PUSH	AX	;save
	PUSH	CX
	CALL	expload	;load result
	POP	CX
	POP	AX
ianosto	CALL	pope1	;restore entry
	OR	AX,AX	;test flag
	JZ	ianopop	;:not set
	CMP.B	indflg,#$00	;indexed ?
	JZ	ianoind2	;:no
	CALL	ecode	;* POP DI
	B	$01,$5F
ianoind2	CMP.B	varseg,#$FD	;segment ES ?
	JNZ	ianopop	;:no
	CALL	ecode	;* POP ES
	B	$01,$07
ianopop	CMP.B	varctp,#$08	;string ?
	JNZ	ianostr	;:no
	MOV.B	var2ctp,#$0A	;component type = scalar
	MOV	lower2,#$0000	;lower bound
	MOV	AX,varsize	;component size - 1
	DEC	AX
	MOV	upper2,AX	;-> upper bound
	JMP.b	iastr	;'
ianostr	MOV	BP,upper	;index type ptr
	CALL	getparm	;get type parms
iastr	MOV	BP,lower	;type ptr
	CALL	getvprm2	;get type parms
	CMP.B	CL,var2ctp	;type = index type ?
	CALL	errnz	;no:
	B	$2C	;44:Type mismatch
	OR.B	CH,CH	;constant index ?
	JNZ	iavarind	;:no
	MOV	AX,exres	;get result
	CMP	AX,lower2	;< lower bound ?
	JL	iaerr	;yes: error
	CMP	AX,upper2	;> upper bound ?
	JLE	iacnind	;no: ok
iaerr	CALL	err	;45:Constant out of range
	B	$2D	;'
iacnind	SUB	AX,lower2	;subtract lower bound
	MOV	CX,varsize	;* component size
	MUL	CX
	ADD	varofs,AX	;add to var offset
	JMP	iaind	;'store it
iavarind	MOV	AX,lower2	;lower bound
	TEST	direcsv,#$0002	;range check ?
	JNZ	iarngind	;:yes
	MOV	CX,varsize	;lower bound * component size
	MUL	CX
	SUB	varofs,AX	;subtract from var offset
	JMP.b	iacnind2	;'-> faster array indexing
iarngind	OR	AX,AX	;subtract lower bound from index
	JZ	iaoff2	;0:done
	CMP	AX,#$0001	;1 ?
	JNZ	iaoff	;:no
	CALL	ecode
	B	$01,$48	;* DEC AX
	JMP.b	iaoff2	;'
iaoff	CALL	ecode
	B	$01,$2D	;* SUB AX,#lower_bound
	CALL	eword
iaoff2	MOV	AX,upper2	;upper bound-lower bound+1
	SUB	AX,lower2
	INC	AX
	CALL	emovcxi	;* MOV CX,#ind_count
	MOV	AX,#xindchk	;(range check)
	CALL	ecall	;* CALL xindchk
iacnind2	MOV	AX,varsize	;index * component size
	CMP	AX,#$0001	;component size = 1 ?
	JZ	iacsend	;yes: ok
	CMP	AX,#$0002	;= 2 ?
	JNZ	iacs4	;:no
	CALL	ecode
	B	$02,$D1,$E0	;* SHL AX,1
	JMP.b	iacsend	;'
iacs4	CMP	AX,#$0004	;= 4 ?
	JNZ	iacs6	;:no
	CALL	ecode	;* SHL AX,1
	B	$04,$D1,$E0,$D1,$E0	;* SHL AX,1
	JMP.b	iacsend	;'
iacs6	CMP	AX,#$0006	;= 6 ?
	JNZ	iacs	;:no
	CALL	ecode	;* SHL AX,1
	B	$08,$D1,$E0,$8B,$C8	;* MOV CX,AX
	B	$D1,$E0,$03,$C1	;* SHL AX,1
	JMP.b	iacsend	;'* ADD AX,CX
iacs	CALL	emovcxi	;* MOV CX,#compo_size
	CALL	ecode
	B	$02,$F7,$E1	;* MUL CX
iacsend	CMP.B	indflg,#$00	;already indexed ?
	JZ	ianotind	;:no
	CALL	ecode	;add to previous index
	B	$02,$03,$F8	;* ADD DI,AX
	JMP.b	iaind	;'
ianotind	CALL	ecode
	B	$01,$97	;* XCHG DI,AX
	MOV.B	indflg,#$FF	;flag: indexed
iaind	CMP.B	varctp,#$01	;component type = array ?
	JNZ	iaend	;no: end it
	CALL	ccomma	;, ?
	JNZ	iaend	;no: end it
	JMP	ialoop	;'get next index
iaend	CALL	esqr2	;! ]
	XOR	AX,AX	;ok
	RET		;"
indrec	CMP.B	varctp,#$02	;Do record indexing
	JNZ	irret	;no record: ret
	CALL	cdot	;. ?
	JNZ	irret	;no: ret
	MOV.B	CL,varnest	;record nesting level
	MOV	CH,#$04	;var
	CALL	search	;search subvar
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
iraddofs	PUSH	indptflg	;save base parms
	PUSH	varofs
	CALL	getvprm	;get var parms
	POP	AX	;restore offset
	ADD	varofs,AX	;add to new offset
	POP	indptflg	;restore indirection ptr
	XOR	AX,AX	;ok
irret	RET		;"
indptr	CMP.B	varctp,#$04	;Do pointer indexing
	JNZ	iptret	;no pointer: ret
	CALL	cptr	;^ ?
	JNZ	iptret	;no: ret
	MOV	BP,lower	;type ptr
	CALL	getvprm2	;get type parms
indptrld	MOV	DX,#$38C4	;* LES DI,pointer_var
	CALL	einstr	;emit instruction
	MOV	varofs,#$0000	;offset = 0
	MOV.B	varseg,#$FD	;segment = ES
	MOV.B	indflg,#$FF	;indexed
	XOR	AX,AX	;ok
iptret	RET		;"
einstr	MOV	AL,varseg	;Emit instruction with addressing
	CMP	AL,#$FD	;ES ?
	JB	eistk	;:stack segment
	CALL	esegment	;emit segment prefix
	CMP.B	indflg,#$00	;indexed ?
	JNZ	eiind	;:yes
	MOV	CH,#$06	;mode: direct
	OR.B	DH,CH
	CALL	emitdx	;emit DX
	MOV	AX,varofs	;get offset
	CALL	eword	;emit offset
	JMP.b	eiret	;'ret
eiind	MOV	AX,varofs	;get offset
	OR	AX,AX	;test offset
	MOV	CH,#$05	;[DI]
	JZ	eiindofs	;:yes
	CALL	offslen	;short or long offset ?
	MOV	CH,#$45	;short
	JZ	eiindofs	;:ok
	MOV	CH,#$85	;long offset
eiindofs	OR.B	DH,CH	;set addressing mode
	CALL	emitdx	;emit opcode
	TEST.B	DH,#$C0	;offset ?
	JZ	eiret	;no: ret
	JMP.b	eioffs	;'emit offset
eistk	CMP.B	AL,lexnest	;in current procedure ?
	MOV	CX,#$0306	;[BP]offs / [BP+DI]offs
	JZ	eistk2	;:yes
	CALL	ecode	;* MOV BX,[BP]lex_level
	B	$02,$8B,$5E	;(get ptr from display)
	ADD.B	AL,AL	;- nesting level * 2
	NEG.B	AL
	CALL	ebyte	;emit offset
	MOV	AL,#$36	;* SS:
	CALL	ebyte
	MOV	CX,#$0107	;[BX]offs / [BX+DI]offs
eistk2	CMP.B	indflg,#$00	;indexed ?
	JZ	eistk3	;:no
	MOV.B	CL,CH	;use [B.+DI]
eistk3	MOV	AX,varofs	;get offset
	CALL	offslen	;short or long ?
	MOV	CH,#$40	;short
	JZ	eistksh	;:ok
	MOV	CH,#$80	;long
eistksh	OR.B	DH,CL	;set addressing mode
	OR.B	DH,CH
	CALL	emitdx	;emit opcode
eioffs	MOV	AX,varofs	;get offset
	TEST.B	DH,#$40	;long ?
	JNZ	eioffbyt	;:no
	CALL	eword	;emit word offset
	JMP.b	eiret	;'
eioffbyt	CALL	ebyte	;emit byte offset
eiret	RET		;"
offslen	OR.B	AL,AL	;Short or long offset ?
	JS	offneg	;:negative
	OR.B	AH,AH	;high byte must be zero
	RET		;'
offneg	CMP.B	AH,#$FF	;high byte must be FF
	RET		;"
esegment	CMP.B	varseg,#$FF	;emit segment prefix
	JZ	eseges	;DS:no prefix needed
	CMP.B	varseg,#$FD	;ES ?
	MOV	AL,#$26	;(ES:)
	JZ	esegret	;:yes
	MOV	AL,#$2E	;(CS:)
esegret	CALL	ebyte	;emit prefix
eseges	RET		;"
loadoffs	CMP.B	varseg,#$FD	;Get offset
	JB	ldostk	;:stack segment
	MOV	AX,varofs	;var offset
	CMP.B	indflg,#$00	;indexed ?
	JNZ	ldoind	;:yes
	JMP	emovdii	;'* MOV DI,#offset
ldoind	OR	AX,AX	;test offset
	JZ	eseges	;0:ret
	CALL	offslen	;short or long offset ?
	MOV	DX,#$C783	;(ADD DI,#byte)
	JZ	ldobyt	;:short
	MOV	DL,#$81	;(ADD DI,#word)
ldobyt	PUSH	AX	;save offset
	CALL	emitdx	;emit operation
	POP	AX	;offset
	TEST.B	DL,#$02	;short ?
	JZ	ldoword	;:no
	JMP	ebyte	;'emit byte offset
ldoword	JMP	eword	;'emit word offset
ldostk	MOV	DX,#$388D	;(LEA DI,..)
	JMP	einstr	;"get effective addr -> DI
varptr	CALL	rdvar	;Get var ptr: get var
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
varptr2	CALL	loadoffs	;get offset -> DI
	MOV	AL,#$1E	;(PUSH DS) push offset
	CMP.B	varseg,#$FF	;DS ?
	JZ	varptret	;:yes
	MOV	AL,#$06	;(PUSH ES)
	CMP.B	varseg,#$FD	;ES ?
	JZ	varptret	;:yes
	MOV	AL,#$16	;(PUSH SS)
	JB	varptret	;:yes
	MOV	AL,#$0E	;(PUSH CS)
varptret	JMP	ebyte	;"emit op
eload	CMP.B	varctp,#$0A	;Load var
	JB	eldptr	;:no scalar
	CMP.B	varseg,#$FD	;ES ?
	JB	eldstk	;:SS: no shortcuts
	CMP.B	indflg,#$00	;indexed ?
	JZ	elddir	;:no
eldstk	MOV	DL,#$8B	;(MOV)
	CMP	varsize,#$01	;byte ?
	JA	eldword	;:no
	MOV	DL,#$8A	;(MOVB)
eldword	MOV	DH,#$00	;MOV AX,...
	CALL	einstr	;emit instruction
	JMP.b	eldpbyt	;'byte: clr hi byte
elddir	CALL	esegment	;emit segment prefix
	MOV	AL,#$A1	;(MOV AX,var)
	CMP	varsize,#$01	;byte ?
	JA	elddbyt	;:no
	MOV	AL,#$A0	;(MOVB AL,var)
elddbyt	CALL	ebyte	;emit operation
	MOV	AX,varofs	;emit offset
	CALL	eword
eldpbyt	CMP	varsize,#$01	;byte ?
	JA	eldret	;:no
	CALL	ecode
	B	$02,$32,$E4	;* XOR AL,AL
eldret	RET		;'
eldptr	CMP.B	varctp,#$04	;load other types
	JNZ	eldreal	;:no ptr
	MOV	DX,#$00C4	;LES AX,ptr_var
	CALL	einstr	;emit instruction
	CALL	ecode
	B	$02,$8C,$C2	;* MOV DX,ES
	RET		;'
eldreal	CALL	varptr2	;get ptr -> DI,stack
	MOV	AX,#xldreal	;(load real)
	CMP.B	varctp,#$09	;real ?
	JZ	eldemit	;:yes
	MOV	AX,#strload	;(load string)
	CMP.B	varctp,#$08	;string ?
	JZ	eldemit	;:yes
	CALL	esetfac	;emit set crunch factor
	MOV	AX,#xldset	;(load set)
eldemit	JMP	ecall	;"emit call
estore	CALL	erngchk	;Store var: emit range check
estore2	CMP.B	varctp,#$0A	;scalar ?
	JB	estcpl	;:no
eststo	CMP.B	varseg,#$FD	;SS ?
	JB	eststk	;yes: no shortcuts
	CMP.B	indflg,#$00	;indexed ?
	JZ	estdir	;no: optimize
eststk	MOV	DL,#$89	;(MOV dest_var,AX)
	CMP	varsize,#$01	;byte ?
	JA	estword	;:no
	MOV	DL,#$88	;(MOVB dest_var,AL)
estword	MOV	DH,#$00	;mode
	JMP	einstr	;'emit instruction
estdir	CALL	esegment	;emit segment prefix
	MOV	AL,#$A3	;(MOV var,AX)
	CMP	varsize,#$01	;byte ?
	JA	estdbyt	;:no
	MOV	AL,#$A2	;(MOVB var,AL)
estdbyt	CALL	ebyte	;emit opcode
	MOV	AX,varofs	;emit var offset
	JMP	eword	;'
estptr	CALL	eststo	;store ptr: emit store AX
	ADD	varofs,#$02	;offs second word
	MOV	DX,#$1089	;emit store DX
	JMP	einstr	;'emit instruction
estcpl	CMP.B	varctp,#$04	;pointer ?
	JZ	estptr	;:yes
	MOV	AX,#xstoreal	;(store real)
	CMP.B	varctp,#$09	;real ?
	JZ	estemit	;:yes
	CMP.B	varctp,#$08	;string ?
	JNZ	estset	;:no
	MOV.B	AH,varsize	;get string length
	DEC.B	AH
	MOV	AL,#$B1
	CALL	eword	;* MOV CL,max_len
	MOV	AX,#strstore	;(store string)
	JMP.b	estemit	;'emit call
estset	CALL	esetfac	;set crunch factor
	MOV	AX,#setsto	;(store set)
estemit	JMP	ecall	;"emit call
esetfac	MOV	BP,lower	;calculate set crunch factor
	CALL	getparm	;get parms of base type
	MOV	AL,varsize	;component size
	MOV.B	AH,lower2	;lower bound/8
	MOV	CL,#$03
	SHR.B	AH,CL
	JMP	emovcxi	;"* MOV CX,#crunch
erngchk	CMP.B	varctp,#$0A	;Emit range check
	JB	erngret	;no scalar: ret
	TEST	direcsv,#$0002	;range checking on ?
	JZ	erngret	;:no
	MOV	AX,lower	;lower bound-1 = upper bound ?
	DEC	AX
	CMP	AX,upper
	JZ	erngret	;yes: no check
	INC	AX	;restore lower
	CALL	emovcxi	;* MOV CX,#lower_bound
	MOV	AX,upper	;upper bound
	CALL	emovdxi	;* MOV DX,#upper_bound
	MOV	AX,#xrngchk	;(range check)
	CALL	ecall	;emit call
erngret	RET		;"
rdnumcn	CALL	rdconst	;read numeric constant
snerror	CALL	errnz	;no good:
	B	$29	;41:Unknown ID or syntax error
	RET		;"
rdintcn	CALL	rdnumcn	;get integer constant
testint	CMP.B	CL,#$0A	;integer ?
	CALL	errnz	;no:
	B	$16	;22:Integer constant expected
	RET		;"
rdstrcn	CALL	rdnumcn	;get string constant
	CMP.B	CL,#$08	;string ?
	JZ	rdstrret	;yes: ok
	CMP.B	CL,#$0C	;char ?
	CALL	errnz	;no:
	B	$20	;32:String constant expected
	MOV	CL,#$08	;convert to string
rdstrret	RET		;"
rdconst	CALL	testsign	;Read constant: test sign
	PUSH	DX	;save it
	CALL	constel	;get constant element
	POP	DX	;restore sign
	JZ	donegate	;:ok
	OR	DX,DX	;didn't work
	CALL	errnz	;25:Int or real const expected
	B	$19
	DEC	DX	;ok
rdcnret	RET		;'
donegate	CALL	testnum	;test type
	JZ	rdcnret	;:ret - no negation
	CMP.B	CL,#$09	;real ?
	JNZ	rdcnnegi	;:no
	CMP.B	creal1,#$00	;0 ?
	JZ	rdcnok	;yes: don't negate
	XOR.B	cresign,#$80	;negate it
	JMP.b	rdcnok	;'ok
rdcnnegi	NEG	BX	;negate result
rdcnok	XOR	DX,DX	;ok
	RET		;"
testsign	MOV	DI,chptr	;Test sign:test char
	MOV	DX,#$FFFF	;flag: negative
	CMP.B	[DI],#$2D	;- ?
	JZ	tsminus	;:yes
	INC	DX	;clear neg flag
	CMP.B	[DI],#$2B	;+ ?
	JNZ	tsret	;no: don't skip char
	INC	DX	;set + flag
tsminus	INC	DI	;skip that char
	CALL	skipdi	;read next word
tsret	RET		;"
testnum	OR	DX,DX	;Test type
	JZ	tnret	;:no negation - ok
	CMP.B	CL,#$0A	;integer ?
	JZ	tndec	;:ok
	CMP.B	CL,#$09	;real ?
	CALL	errnz	;no:
	B	$19	;25:Int or real constant expected
tndec	DEC	DX	;clear plus flag
tnret	RET		;"
constel	CALL	immecn	;Get const element: immediate const
	JNZ	clconst	;:no
	RET		;'
clconst	MOV	CX,#$0200	;search constant
	CALL	search
	JNZ	clret	;:not found
	MOV.B	CL,[BP]-$01	;get component type
	CMP.B	CL,#$0A	;scalar ?
	JB	clreal	;:no
	MOV	BX,[BP]-$03	;get value
	JMP.b	clok	;'ok
clreal	CMP.B	CL,#$09	;real ?
	JNZ	clstring	;:no
	MOV	AX,[BP]-$07	;get real const
	MOV	creal1,AX	;store in buffer
	MOV	AX,[BP]-$05
	MOV	creal2,AX
	MOV	AX,[BP]-$03
	MOV	creal3,AX
	JMP.b	clok	;'ok
clstring	MOV.B	CH,[BP]-$02	;string: get length
	MOV.B	DL,CH
	MOV	BX,#wordbuf	;dest buffer
clstrlp	OR.B	DL,DL	;test len
	JZ	clok	;:done
	DEC	BP	;stored backwards !
	MOV.B	AL,[BP]-$02	;get char
	MOV.B	[BX],AL	;copy into buffer
	INC	BX	;next pos
	DEC.B	DL	;another char ?
	JMP	clstrlp	;'
clok	XOR	DX,DX	;ok
clret	RET		;"
immecn	MOV	DI,chptr	;get immediate constant
	MOV.B	AL,[DI]	;current char
	CMP	AL,#$27	; ' ?
	JZ	icstr	;yes: string const
	CMP	AL,#$5E	;^ ?
	JZ	icstr	;yes: string const
	CMP	AL,#$23	;# ?
	JNZ	icnum	;no: numeric const
icstr	MOV	BX,#wordbuf	;dest buffer
	MOV	CH,#$00	;length = 0
icsloop	MOV.B	AL,[DI]	;current char
	CMP	AL,#$5E	;^ ?
	JZ	icscntrl	;:yes
	CMP	AL,#$23	;# ?
	JZ	icsnum	;:yes
	CMP	AL,#$27	; ' ?
	JNZ	icsend	;no: end of string const
icslp2	INC	DI	;next char
	MOV.B	AL,[DI]	;get char
	OR.B	AL,AL	;line end ?
	CALL	perrz	;yes:
	B	$37	;55:String constant exceeds line
	CMP	AL,#$27	; ' ?
	JNZ	icssto	;:no
	INC	DI	;test next char: may be ''
	CMP.B	[DI],#$27	; ' ?
	JNZ	icsloop	;no: end of string
icssto	MOV.B	[BX],AL	;store in buffer
	INC	BX	;next pos
	INC.B	CH	;count length
	JMP	icslp2	;'continue
icscntrl	INC	DI	;next char: do ^char
	MOV.B	AL,[DI]	;get it