TP3/Resources/turbopascal3source/TP3/TPSRC8

	OR.B	CL,BH
	CALL	errnz	;yes:
	B	$46	;70:Set base type out of range
	MOV	CL,#$03	;calculate component size
	SHR	AX,CL	;(upper/8)-(lower/8)+1
	MOV	CL,#$03
	SHR	BX,CL
	SUB	AX,BX
	INC	AX
	MOV	varsize,AX	;-> component size
	MOV	AX,vartp	;type ptr
	MOV	lower,AX	;-> type
	MOV.B	varctp,#$03	;tag: set
	CALL	stotype	;store type
setret	RET		;"
pointer	CALL	cptr	;pointer: prelim def
	JNZ	ptrret	;ptr ? no: ret
	MOV	AX,#$0000	;tag: invisible
	CALL	symword	;store in symtab
	PUSH	symtop	;save pos
	CALL	rdsymnew	;get name of ptr
	CALL	symoffs	;write symtab offset
	POP	lower	;restore pos of prelim offset
	MOV.B	varctp,#$04	;tag: pointer
	MOV.B	varnest,#$FF	;flag: not fully defined
	MOV	varsize,#$0004	;size: 4 bytes
	CALL	stotype	;store type
ptrret	RET		;"
file	CALL	ctoken	;FILE ?
	W	tkfile
	JNZ	fileret	;no: ret
	CALL	ctoken	;OF ?
	W	tkof
	JNZ	filuntp	;no: untyped file
	CALL	rdtype	;read type
	CMP.B	varctp,#$05	;component type = file ?
	JB	file2	;:no
	CMP.B	varctp,#$07
	JA	file2	;:no
	CALL	err	;yes:
	B	$44	;'68:File components may not be files
file2	MOV	AX,vartp	;type ptr
	MOV	lower,AX	;store it
	MOV.B	varctp,#$05	;typed file
	MOV	varsize,#$004C	;set size
	CALL	stotype	;store type
fileret	RET		;'
filuntp	MOV	BP,ptcbeg	;untyped file
	B	$81,$ED,$02,$00	;point to it
	JMP	stdtype	;"standard type
text	CALL	ctoken	;TEXT ?
	W	tktext
	JNZ	textret	;no:ret
	CALL	csqr1	;[ ?
	JNZ	textstd	;no: standard text file
	CALL	rdintcn	;get integer constant
	OR	BX,BX	;buffer size = 0 ?
	CALL	errz	;yes:
	B	$2D	;45:Constant out of range
	CALL	esqr2	;! ]
	ADD	BX,#$4C	;add size of file var
	MOV	varsize,BX	;-> var size
	MOV.B	varctp,#$06	;text file
	CALL	stotype	;store type
textret	RET		;'
textstd	MOV	BP,ptcbeg	;set ptr to std TEXT file
	B	$81,$ED,$3E,$00
	JMP	stdtype	;'standard type
string	CALL	ctoken	;STRING ?
	W	tkstr
	JNZ	strrt	;no: ret
	CALL	esqr1	;! [
	CALL	rdintcn	;get integer constant
	OR.B	BH,BH	;> 255 ?
	CALL	errnz	;yes:
	B	$31	;49:Invalid string length
	OR.B	BL,BL	;length = 0 ?
	CALL	errz	;yes:
	B	$31	;49:Invalid string length
	CALL	esqr2	;! ]
	INC	BX	;len+1 (for length byte)
	MOV	varsize,BX	;-> component size
	MOV.B	varctp,#$08	;tag: string
	CALL	stotype	;store type
strrt	RET		;"
scalar	CALL	cbrack1	;do scalar list
	JNZ	scalret	;( ? no: ret
	MOV	BX,#$FFFF	;init counter
scallp	PUSH	BX
	MOV	AX,#$0200	;tag: const
	CALL	symword	;store tag word
	CALL	rdsym	;read symbol
	MOV	AL,scalcnt	;number of scalar type
	CALL	symbyte	;store (elementary type)
	POP	AX	;restore counter
	INC	AX	;inc it
	PUSH	AX	;save it again
	CALL	symword	;store value of that const
	CALL	symoffs	;write symtab offset
	CALL	ccomma	;, ?
	POP	BX
	JZ	scallp	;yes: another element
	CALL	ebrack2	;! )
	MOV.B	CL,scalcnt	;number of this type
	INC.B	scalcnt	;count scalar types
	XOR	DX,DX	;clear lower bound
scalsto	MOV.B	varctp,CL	;store component type
	MOV	upper,BX	;store upper bound
	MOV	lower,DX	;store lower bound
	OR.B	DH,BH	;byte possible ?
	MOV	AX,#$0001	;size = 1
	JZ	scalbyt	;yes: ok
	INC	AX	;size = 2
scalbyt	MOV	varsize,AX	;store component size
	CALL	stotype	;store type
scalret	RET		;"
subrange	CALL	rdconst	;do subrange: read constant
	JNZ	subret	;no good: ret
	PUSH	CX	;save type, result
	PUSH	BX
	CMP.B	CL,#$0A	;scalar ?
	CALL	errb	;no:
	B	$33	;51:Invalid subrange base type
	CALL	ctoken	;.. ?
	W	tk2dot
	CALL	errnz	;no:
	B	$0B	;11: .. expected
	CALL	rdnumcn	;get constant
	POP	DX	;restore component type
	POP	AX	;restore lower bound
	CMP.B	CL,AL	;same component type ?
	CALL	errnz	;no:
	B	$2C	;44:Type mismatch
	CMP	BX,DX	;upper >= lower ?
	JGE	scalsto	;yes: ok
	CALL	err	;52:Lower bound > upper bound
	B	$34	;'
subret	RET		;"
rdscaltp	CALL	subrange	;get scalar type: do subrange
	JZ	rdscret	;done: ret
	CALL	scalar	;do scalar list
	JZ	rdscret	;done: ret
	CALL	srchtype	;search type
	CALL	errnz	;complex ?
	B	$1E	;30:Simple type expected
	CMP.B	varctp,#$0A	;scalar ?
	JNB	rdscret	;:yes
	CALL	err	;30:Simple type expected
	B	$1E	;'
rdscret	RET		;"
progpart	MOV.B	stklev,#$00	;Program part
	MOV.B	withnest,#$00	;no with nesting
	CALL	block	;do block
	PUSH	pc	;save PC: jump to end of exit codes
	CALL	ejump	;emit jump
	MOV	BP,symtop2
prpatch	CMP	BP,symtop	;= actual symtab top ?
	JZ	prpend	;yes: end it
	MOV	BX,[BP]-$02	;get dest addr
	OR	BX,BX	;exit ?
	JZ	prpexit	;:yes
	SS:	
	MOV	AX,[BX]-$02	;get dest offset (from label)
	SS:	
	MOV.B	CH,[BX]-$04	;label defined ?
	CMP.B	CH,#$FF	;no:
	CALL	errz	;40:Undefined label
	B	$28
	JMP.b	prpgoto	;'patch GOTO
prpexit	POP	AX	;get PC of end jump
	PUSH	AX	;= dest
	MOV	CH,#$00	;level: 0
prpgoto	MOV	BX,[BP]-$04	;get addr of jump
	INC	BX	;+1: point to offset
	MOV.B	CL,[BP]-$05	;stack level-dest stack level
	SUB.B	CL,CH
	JNZ	prpremov	;not zero: remove from stack
	CALL	ptcjmp	;patch jump
	JMP.b	prpnxt	;'
prpremov	CALL	errb	;trying to jump into a WITH/FOR ?
	B	$47	;71:Invalid GOTO
	PUSH	AX	;save PC of end jump
	CALL	ptcjmppc	;patch jump to current pos
prpremlp	CALL	epopax	;* POP AX
	DEC.B	CL	;remove another var from stack ?
	JNZ	prpremlp	;:no
	POP	AX	;restore PC of end jump
	CALL	ejump	;emit jump to end jump
prpnxt	SUB	BP,#$05	;go to next entry
	JMP	prpatch	;'next one
prpend	POP	BX	;restore PC of end jump
	INC	BX	;point to offset
	JMP	ptcjmppc	;"patch jump
block	CALL	statemnt	;do block: do statement
	CALL	ctoken	;END ?
	W	tkend
	JZ	blkret	;yes: done
	CALL	esemi2	;! ;
	JMP	block	;'next statement
blkret	RET		;"
statemnt	MOV.B	semiflg,#$FF	;Do statement
	MOV	AX,direct	;get compiler directives
	MOV	direcsv,AX	;use copy during statement
	TEST	direcsv,#$0010	;user interrupt ?
	JZ	stmnoint	;:no
	MOV.B	usrint,#$FF	;set flag: used
	CALL	ecode	;* INT 3
	B	$01,$CC
stmnoint	CALL	ckey	;search keyword - code level
	B	$02
	W	tkbegin
	JZ	stmstd2	;:found
	CALL	rdvar	;search var
	JNZ	stmproc	;:not found
	JMP	cassign	;'do assignment
stmproc	MOV	CX,#$0500	;search procedure
	CALL	search
	JNZ	stmlabel	;:not found
	JMP	cproc	;'do procedure
stmlabel	MOV	CX,#$0100	;search label
	CALL	search
	JZ	clabel	;:found
	MOV	CX,#$0600	;search function
	CALL	search
	JNZ	stmstd	;:not found
	JMP	assgnvar	;'do function: assign return var
stmstd	CALL	ckey	;search keyword: std procedures
	B	$02
	W	stdprocs
	JZ	stmstd2	;:found
	RET		;'
stmstd2	CS:		;jump to procedure compilation
	JMP	[BX]	;"routine
clabel	CALL	ecolon	;! : - do label
	MOV	AL,lexnest	;lexical level
	CMP.B	AL,[BP]-$03	;= that of label ?
	CALL	errnz	;no:
	B	$48	;72:Label not within current block
	CMP.B	[BP]-$04,#$FF	;label already defined ?
	CALL	errnz	;43:Duplicate ID or label
	B	$2B
	MOV	AL,stklev	;store stack level
	MOV.B	[BP]-$04,AL	;in label entry
	MOV	AX,pc	;store offset
	MOV	[BP]-$02,AX
	JMP	statemnt	;"do statement
if	CALL	excond	;IF: evaluate condition
	MOV	AL,brnchop	;branch opcode
	MOV	AH,#$03	;offset
	CALL	eword	;emit branch
	PUSH	pc	;save pos of jump
	CALL	ejump	;emit jump
	CALL	ctoken	;THEN ?
	W	tkthen
	CALL	errnz	;no:
	B	$11	;17:THEN expected
	CALL	statemnt	;do statement
	CALL	ctoken	;ELSE ?
	W	tkelse
	JNZ	ifnoelse	;:no
	POP	BX	;get pos of THEN-jump
	PUSH	pc	;save pos of second jump
	CALL	ejump	;emit second jump
	INC	BX	;point to offset
	CALL	ptcjmppc	;patch jump addr: to ELSE-part
	CALL	statemnt	;do statement
ifnoelse	POP	BX	;restore pos
	INC	BX	;point to offset
	JMP	ptcjmppc	;"patch jump offset
while	PUSH	pc	;WHILE: save loop beg addr
	CALL	excond	;evaluate condition
	MOV	AL,brnchop	;branch opcode
	MOV	AH,#$03	;offset
	CALL	eword	;emit branch
	PUSH	pc	;save pos of jump to end
	CALL	ejump	;emit it
	CALL	ctoken	;DO ? Bug: not checked
	W	tkdo	;(try it !!)
	CALL	statemnt	;do statement
	POP	BX	;pos of jump
	POP	AX	;pos of loop beg
	CALL	ejump	;emit jump to loop beg
	INC	BX	;point to offset
	JMP	ptcjmppc	;"patch jump to loop end
repeat	PUSH	pc	;REPEAT: save loop beg addr
reploop	CALL	statemnt	;do statement
	CALL	ctoken	;UNTIL ?
	W	tkuntil
	JZ	repend	;yes: end it
	CALL	esemi2	;! ;
	JMP	reploop	;'
repend	CALL	excond	;evaluate condition
	MOV	AL,brnchop	;branch opcode
	MOV	AH,#$03	;offset
	CALL	eword	;emit branch
	POP	AX	;restore pos: loop beg
	JMP	ejump	;"emit jump to loop beg
for	MOV	CX,#$0400	;FOR
	CALL	search	;search loop var
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
	CALL	getvprm	;get var parms
	MOV.B	indflg,#$00	;not indexed
	CMP.B	indptflg,#$00	;var indirect ?
	JNZ	forerr	;yes: error
	CMP.B	varctp,#$0A	;scalar ?
	JNB	forstrt	;:yes, ok
forerr	CALL	err	;30:Simple type expected
	B	$1E	;'
forstrt	CALL	pushe1	;push var entry
	MOV	AL,varctp	;save component type
	PUSH	AX
	CALL	eassign	;! :=
	CALL	exprax	;expression -> AX
	CALL	epushax	;* PUSH AX
	POP	AX	;component type
	PUSH	AX
	CMP.B	AL,CL	;= type read ?
	CALL	errnz	;no:
	B	$2C	;44:Type mismatch
	CALL	ckey	;TO or DOWNTO ?
	B	$04
	W	tkto
	CALL	errnz	;not found:
	B	$12	;18:TO or DOWNTO expected
	MOV	forptr,BX	;store direction pointer
	CALL	exprax	;expression -> AX
	POP	AX	;test component type
	CMP.B	AL,CL
	CALL	errnz	;44:Type mismatch
	B	$2C
	CALL	ctoken	;DO ?
	W	tkdo
	CALL	errnz	;no:
	B	$0D	;13:DO expected
	CALL	pope1	;restore entry from stack
	CALL	ecode	;* POP CX
	B	$04,$59,$91,$2B,$C8	;* XCHG CX,AX
	MOV	BX,forptr	;* SUB CX,AX
	CS:		;get flag: pointer to table entry
	MOV.B	AL,[BX]	;get branch
	CALL	ebyte	;emit it
	CALL	ecode	;* branch offset
	B	$04,$03,$E9,$00,$00	;* JUMP ....
	PUSH	pc	;save jump pos
	CS:	
	MOV.B	AL,[BX]$01	;emit INC/DEC
	CALL	ebyte
	CALL	estore2	;store var
	PUSH	pc	;save PC
	CALL	ecode	;* PUSH CX
	B	$01,$51
	CALL	pushe1	;save var entry
	PUSH	forptr	;save for-ptr
	INC.B	stklev	;space used on stack (counter!)
	CALL	statemnt	;do statement
	DEC.B	stklev	;remove from stack
	POP	forptr	;restore FOR-ptr
	CALL	pope1	;restore var entry
	CALL	ecode	;* POP CX
	B	$01,$59	;(get counter var from stack)
	MOV	BX,forptr
	CS:	
	MOV.B	AL,[BX]$02	;INC/DEC CX
	CALL	ebyte	;emit
	PUSH	pc	;save PC
	CALL	eword	;emit (dummy) branch to loop end
	CS:	
	MOV.B	DH,[BX]$03	;INC or DEC var ?
	MOV	DL,#$FF	;word opcode
	CMP	varsize,#$01	;test component size
	JA	forword	;:word
	MOV	DL,#$FE	;byte obcode
forword	CALL	einstr	;emit INC loop var
	POP	BX	;restore PC
	POP	AX	;restore PC: beg of loop
	CALL	ejump	;emit jump to loop beg
	MOV	AX,pc	;PC-dest-2
	SUB	AX,BX
	DEC	AX
	DEC	AX
	MOV.B	AH,AL	;-> offset
	MOV	AL,#$74	;JZ
	CALL	ptcjmp2	;patch branch: to loop end
	POP	BX	;restore addr: loop beg-2
	DEC	BX
	DEC	BX
	JMP	ptcjmppc	;"patch jump to loop end
case	CALL	exscal	;CASE: get scalar expression
	MOV.B	casectp,CL	;store CASE-type
	CALL	expof	;! OF
	XOR	CX,CX	;clear counter: main
	PUSH	CX
caselp1	XOR	CX,CX	;clear counter: sub
caselp2	PUSH	CX	;save it
	CALL	cmpbound	;get element / lower bound
	CALL	ctoken	;.. ?
	W	tk2dot
	MOV	DL,#$74	;JZ
	JNZ	casenrng	;:no
	CALL	ecode	;* JL +05
	B	$02,$7C,$05
	CALL	cmpbound	;get upper bound
	MOV	DL,#$7E	;JG
	POP	CX	;count: range done
	INC.B	CH	;count space used
	PUSH	CX
casenrng	POP	CX	;restore counter
	INC.B	CH	;count space used
	INC.B	CL	;count labels
	PUSH	DX	;save opcode
	PUSH	pc	;save pos
	CALL	eword	;emit branch op
	CALL	ccomma	;, ?
	JNZ	caselab	;:no
	CMP.B	CH,#$14	;branch distance ok ?
	JB	caselp2	;:yes
	CALL	ecode	;* JMP +02
	B	$02,$EB,$02	;make a hip
	XOR.B	CH,CH	;clear space used
casehip	POP	BX	;get branch pos
	POP	DX	;get opcode
	MOV	AX,pc	;PC-pos-2
	SUB	AX,BX
	DEC	AX
	DEC	AX
	MOV.B	AH,AL	;-> offset
	MOV.B	AL,DL	;branch opcode
	CALL	ptcjmp2	;patch in branch
	LOOP	casehip	;:another one
	MOV	DL,#$EB	;JMP
	PUSH	DX	;remember opcode
	PUSH	pc	;& position
	CALL	eword	;emit it (dummy)
	MOV	CX,#$0101	;space counter
	JMP	caselp2	;'continue
caselab	CALL	ecolon	;! :
	CALL	ejump	;emit jump to next case label
	XOR.B	CH,CH	;clear space counter
caseres	POP	BX	;fill in branches - as above !
	POP	DX
	MOV	AX,pc
	SUB	AX,BX
	DEC	AX
	DEC	AX
	MOV.B	AH,AL
	MOV.B	AL,DL
	CALL	ptcjmp2	;patch it
	LOOP	caseres	;:another
	POP	CX	;restore main counter
	PUSH	pc	;save current pos
	INC	CX	;count case labels
	PUSH	CX	;save again
	MOV	AL,casectp	;save type
	PUSH	AX	;(CASE may be nested !)
	CALL	statemnt	;do statement
	POP	AX	;restore type
	MOV	casectp,AL
	CALL	csemi	;semicolon ?
	MOV	DL,#$FF	;set flag
	JZ	casesemi	;:yes
	XOR.B	DL,DL	;clr flag
casesemi	PUSH	DX	;save it
	CALL	ctoken	;END ?
	W	tkend
	POP	DX	;restore flag
	JZ	caseres2	;:yes
	CALL	ejump	;emit jump to end of CASE
	POP	CX	;counter
	POP	BX	;pos of last comparison
	PUSH	pc	;save pos of jump to CASE-end
	PUSH	CX	;save counter
	DEC	BX	;pos-2
	DEC	BX
	CALL	ptcjmppc	;patch jump
	PUSH	DX	;flag
	CALL	ctoken	;ELSE ?
	W	tkelse
	POP	DX	;'flag
	JZ	caseelse	;:yes
	OR.B	DL,DL	;test flag
	JZ	caseend	;:no semicolon
	JMP	caselp1	;'case loop
caseend	CMP.B	semiflg,#$00	;flag for semi error
	CALL	errz	;cleared:
	B	$0E	;14:END expected
	CALL	err
	B	$29	;"41:Unknown ID or syntax error
caseelse	CALL	statemnt	;ELSE-part: do statement
	CALL	ctoken	;END ?
	W	tkend
	JZ	caseres2	;:yes
	CALL	esemi2	;! ;
	JMP	caseelse	;'
caseres2	POP	CX	;number of jumps
caseres3	POP	BX	;addr of jump-2
	DEC	BX
	DEC	BX	;patch jumps to end of CASE
	CALL	ptcjmppc
	LOOP	caseres3	;:another
	RET		;"
cmpbound	CALL	rdnumcn	;get bound: read num constant
	CMP.B	CL,casectp	;correct type ?
	CALL	errnz	;46:Constant and CASE selector type
	B	$2E	;does not match
	MOV	AL,#$3D	;* CMP AX,i
	CALL	ebyte
	XCHG	AX,BX	;emit constant: bound
	JMP	eword	;"
goto	MOV	CX,#$0100	;do GOTO
	CALL	search	;search label
	CALL	errnz	;not found:
	B	$28	;40:Undefined label
	MOV.B	AL,[BP]-$03	;lexical level
	CMP.B	AL,lexnest	;= current ?
	CALL	errnz	;no:
	B	$48	;72:Label not within current block
	MOV	AX,BP	;symtab-ptr of label
exit	CALL	symword	;store in symtab
	MOV	AX,pc	;store PC
	CALL	symword
	MOV	AL,stklev	;store stack level
	CALL	symbyte
	JMP	ejump	;"emit jump - resolved at block end
with	MOV	AL,withnest	;WITH: nesting level
	MOV.B	AH,stklev	;stack level
	PUSH	AX	;save them
withlp	CMP.B	withnest,#$10	;too much ?
	CALL	errz	;yes:
	B	$61
	CALL	rdvar	;get var
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
	CMP.B	varctp,#$02	;type = record ?
	CALL	errnz	;no:
	B	$1D	;29:Record variable expected
	CMP.B	indflg,#$00	;indexed ?
	JNZ	withindx	;:yes
	MOV.B	AH,varseg	;segment and offset
	MOV	DX,varofs	;already known
	JMP.b	withsto	;'store in WITH-buffer
withindx	CALL	varptr2	;get var ptr
	CALL	epushdi	;* PUSH DI
	ADD.B	stklev,#$02	;4 bytes on stack
	MOV.B	AH,stklev	;get stack level
	MOV	DX,#$FFFF	;dummy pos: variable
withsto	MOV.B	BL,withnest
	XOR.B	BH,BH	;nesting level*4 -> BX
	SHL	BX,1 	;offset into WITH-buffer
	SHL	BX,1 
	MOV	AL,varnest	;store type, position
	MOV	[BX]withtab,AX	;-> WITH-buffer
	MOV	[BX]withtab1,DX
	INC.B	withnest	;inc nesting level
	CALL	ccomma	;, ?
	JZ	withlp	;yes: repeat
	CALL	ctoken	;DO ?
	W	tkdo
	CALL	errnz	;no:
	B	$0D	;13:DO expected
	CALL	statemnt	;do statement
	MOV.B	CL,stklev	;stack usage
	POP	AX	;restore stack usage, nesting level
	MOV	withnest,AL
	MOV.B	stklev,AH
	SUB.B	CL,AH	;remove from stack ?
	JZ	withret	;:nothing to remove
	MOV	AX,#$C483	;* ADD SP,...
	CALL	eword
	MOV.B	AL,CL	;var count * 2
	SHL.B	AL,1 
	CALL	ebyte	;emit byte
withret	RET		;"
inline	CALL	ebrack1	;! ( - Inline
inllp	MOV.B	inlinflg,#$02	;flag: byte mode
	MOV	AL,#$3E
	CALL	chkal	;> ?
	JZ	inltp	;:yes
	MOV.B	inlinflg,#$01	;word mode
	MOV	AL,#$3C	;< ?
	CALL	chkal
	JZ	inltp	;:yes
	MOV.B	inlinflg,#$00	;normal mode
inltp	XOR	BX,BX	;clear number
	XOR	CX,CX	;clear neg flag
inlexlp	PUSH	BX	;save
	PUSH	CX
	CALL	rdconst	;read num constant
	JNZ	inlnocn	;:no good
	CMP.B	CL,#$0A	;type = integer ?
	CALL	errnz	;no:
	B	$16	;22:Integer constant expected
	XCHG	AX,BX	;result -> AX
	JMP.b	inlatom	;'
inlnocn	CMP.B	inlinflg,#$00	;normal mode ?
	JNZ	inlpc	;:no
	MOV.B	inlinflg,#$02	;set word mode
inlpc	MOV	AL,#$2A	;* ?
	CALL	chkal
	JNZ	inlvar	;:no
	MOV	AX,pc	;PC -> result
	JMP.b	inlatom	;'
inlvar	MOV	CX,#$0400	;search var
	CALL	search
	JNZ	inlproc	;:not found
	CALL	getvprm	;get var parms
	MOV	AX,varofs	;get var offset
	JMP.b	inlatom	;'
inlproc	MOV	CX,#$0500	;search proc
	CALL	search
	JZ	inlproc2	;:found
	MOV	CX,#$0600	;search func
	CALL	search
	CALL	errnz	;not found:
	B	$4A	;74:Inline error
inlproc2	MOV	AX,[BP]-$08	;get offset
inlatom	POP	CX	;restore
	POP	BX
	JCXZ	inlnoneg	;:no negation
	NEG	AX	;negate result
inlnoneg	ADD	BX,AX	;add to number
	XOR	CX,CX	;clear neg flag
	MOV	AL,#$2B	;+ ?
	CALL	chkal
	JZ	inlexlp	;:yes
	DEC	CX	;set neg flag
	MOV	AL,#$2D	;- ?
	CALL	chkal
	JZ	inlexlp	;:yes
	XCHG	AX,BX	;else: end of expression
	CMP.B	inlinflg,#$01	;byte mode ?
	JA	inlword	;:word mode
	JZ	inlbyte	;:byte mode
	OR.B	AH,AH	;normal mode: result > 255 ?
	JNZ	inlword	;:yes
inlbyte	CALL	ebyte	;emit byte
	JMP.b	inlchk	;'
inlword	CALL	eword	;emit word
inlchk	MOV	AL,#$2F	;/ ?
	CALL	chkal
	JNZ	inlend	;no: end it
	JMP	inllp	;'loop back: next expression
inlend	CALL	ebrack2	;! )
	RET		;"
cproc	CALL	estkchk	;procedure call: stack checking
cproc2	PUSH	BP	;save symtab pos
	MOV.B	CL,[BP]-$10	;parameter count
	SUB	BP,#$10	;go to parameter
	OR.B	CL,CL	;any parms ?
	JNZ	cprparms	;:yes
	JMP	cprnoprm	;'none - end it
cprparms	CALL	ebrack1	;! (
cprlp1	PUSH	CX	;parameter loop
	PUSH	BP	;save counter, symtab pos
	MOV	CX,[BP]-$04	;parm count same type
	MOV	BP,[BP]-$02	;type ptr
	CALL	getvprm2	;get type parms
cprlp2	PUSH	CX	;save counter
	OR.B	CH,CH	;VAR-parameter ?
	JNZ	cprvar	;:yes
	CMP.B	varctp,#$03	;set ?
	JB	cprcpl	;:below, complex var
	CALL	exprsave	;get expression -> AX/stack
	CALL	typechk	;type checking, conversions
	CALL	erngchk	;range check
	CMP.B	varctp,#$0A	;scalar ?
	JNB	cprscal	;:yes
	CMP.B	varctp,#$04	;ptr ?
	JNZ	cprstr	;:no
	CALL	ecode	;* PUSH DX
	B	$01,$52
cprscal	CALL	epushax	;* PUSH AX
	JMP.b	cprnext	;'next parm
cprstr	CMP.B	varctp,#$08	;string ?
	JNZ	cprset	;:no
	MOV.B	AH,varsize	;get max length
	DEC.B	AH
	MOV	AL,#$B1
	CALL	eword	;* MOV CL,max_len
	MOV	AX,#xstrparm	;adapt string size
	CALL	ecall	;* CALL xstrparm
	JMP.b	cprnext	;'next parm
cprset	CMP.B	varctp,#$03	;set ?
	JNZ	cprnext	;no:next parm
	CALL	esetfac	;calc set crunch factor
	MOV	AX,#xsetparm	;adapt set size
	CALL	ecall	;* CALL xsetparm
	JMP.b	cprnext	;'next parm
cprcpl	CALL	pushe1	;save var entry: complex var
	CALL	fullvar	;do full var
	CALL	errnz	;no good:
	B	$29	;41:Unknown ID or syntax error
	CALL	varptr2	;get var ptr
	MOV	AX,varsize	;component size
	CALL	emovcxi	;* MOV CX,compo_size
	MOV	AX,#xblkparm	;copy complex var to stack
	CALL	ecall	;* CALL xblkparm
	JMP.b	cprchk	;'check type
cprvar	CALL	pushe1	;save entry - VAR-parameter
	CALL	varptr	;get var ptr
	CALL	epushdi	;* PUSH DI
cprchk	CALL	copye2	;copy entry from stack
	CMP.B	var2ctp,#$00	;type = 0 ?
	JZ	cpruntyp	;yes: untyped
	CALL	tchkstrc	;type checking struct vars
cpruntyp	CALL	pope1	;restore entry
cprnext	POP	CX	;restore counter
	DEC.B	CL	;another parm of same type ?
	JZ	cprskip	;:no
	CALL	ecomma	;! ,
	JMP	cprlp2	;'loop back - same type
cprskip	POP	BP	;restore symtab pos
	SUB	BP,#$04	;go to next parm
	MOV.B	AL,[BP]$00	;get cnt
cprsklp	DEC	BP
	MOV.B	CL,[BP]$00	;skip var entries
	XOR.B	CH,CH
	SUB	BP,CX	;skip name
	DEC.B	AL	;count down
	JNZ	cprsklp	;:another
	POP	CX	;restore count
	DEC.B	CL	;another parameter ?
	JZ	cprend	;:no
	CALL	ecomma	;! ,
	JMP	cprlp1	;'loop back
cprend	CALL	ebrack2	;! )
cprnoprm	POP	BP	;symtab pos
	MOV	AX,[BP]-$0E	;overlay ?
	OR	AX,AX
	JZ	cprnoovr	;:no
	CALL	emovaxi	;* MOV AX,proc_len
	MOV	AX,[BP]-$0C	;get file offset
	CALL	emovdxi	;* MOV DX,file_offs
cprnoovr	MOV	AX,[BP]-$08	;get proc offset
	JMP	ecall	;"* CALL proc
estkchk	TEST	direcsv,#$0020	;Stack checking ?
	JZ	estkret	;:switched off
	MOV	AX,[BP]-$0A	;get space needed
	CALL	emovcxi	;* MOV CX,space_needed
	MOV	AX,#xchkstk
	CALL	ecall	;* CALL xchkstk
estkret	RET		;"
cassign	CMP.B	varctp,#$00	;Do assignment: untyped ?
	JZ	asnerr	;yes: error
	CMP.B	varctp,#$05	;file var ?
	JB	asnscal	;:no
	CMP.B	varctp,#$07
	JA	asnscal	;:no
asnerr	CALL	err	;files cannot be assigned !
	B	$36	;'54:Illegal assignment
asnscal	CMP.B	varctp,#$0A	;scalar ?
	JNB	asnscal2	;:yes
	CMP.B	varctp,#$04	;pointer ?
	JNZ	asnvar	;:no
asnscal2	CMP.B	varseg,#$FD	;segment = ES ?
	JNZ	asnnoseg	;:no
	MOV.B	flgpshes,#$01	;set flag: PUSH ES
asnnoseg	CMP.B	indflg,#$00	;indexed ?
	JZ	asn2	;:no
	MOV.B	flgpshdi,#$01	;set flag: PUSH DI
	JMP.b	asn2	;'
asnvar	CALL	varptr2	;get var ptr
	CALL	epushdi	;* PUSH DI
asn2	CALL	eassign	;! :=
	CMP.B	varctp,#$03	;set ?
	JB	asncpl	;:no, complex type
	CALL	pushe1	;save dest var entry
	PUSH	pc	;save PC
	CALL	expr	;evaluate expression
	POP	AX	;old = new PC ?
	SUB	AX,pc
	MOV	flgpshes,#$0000	;clear flag: PUSH ES
	PUSH	AX	;save difference
	CALL	expload	;get expression, ready for store
	POP	AX
	CALL	pope1	;restore dest var entry
	PUSH	AX	;save diff
	CALL	typechk	;type checking, conversions
	POP	AX
	CMP.B	varctp,#$0A	;scalar ?
	JNB	asnscal3	;:yes
	CMP.B	varctp,#$04	;pointer ?
	JNZ	asnstore	;:no
asnscal3	OR	AX,AX	;test diff
	JZ	asnstore	;none: ok
	CMP.B	indflg,#$00	;indexed ?
	JZ	asnnoind	;:no
	CALL	ecode	;* POP DI - restore ptr
	B	$01,$5F
asnnoind	CMP.B	varseg,#$FD	;segment = ES ?
	JNZ	asnstore	;:no
	CALL	ecode	;* POP ES
	B	$01,$07
asnstore	JMP	estore	;'Store var
asncpl	CALL	pushe1	;store dest var entry
	CALL	fullvar	;do full var
	CALL	errnz	;no good:
	B	$29	;41:Unknown ID or syntax error
	CALL	varptr2	;get var ptr
	CALL	pope2	;restore dest var entry
	CALL	tchkstrc	;type checking - struct vars
	MOV	AX,var2size	;component size
	CALL	emovcxi	;* MOV CX,comp_size
	MOV	AX,#xmovevar
	JMP	ecall	;'* CALL xmovevar
typechk	CMP.B	varctp,#$09	;Type checking, conversions
	JNZ	tckstr	;:no real
	CMP.B	CL,#$0A	;now integer ?
	JNZ	tckchk	;:no
	MOV	AX,#xintreal	;conversion int -> real
	CALL	ecall	;* CALL xintreal
	MOV	CL,#$09	;now real
	JMP.b	tckchk	;'
tckstr	CMP.B	varctp,#$08	;string expected ?
	JNZ	tckch	;:no
	CMP.B	CL,#$0C	;result = char ?
	JNZ	tckchk	;:no
	CALL	ecode	;* MOV AH,AL
	B	$05,$8A,$E0,$B0,$01,$50	;* MOV AL,01
	MOV	CL,#$08	;* PUSH AX
	JMP.b	tckchk	;'now string
tckch	CMP.B	varctp,#$0C	;char expected ?
	JNZ	tckchk	;:no
	CMP.B	CL,#$08	;result = string ?
	JNZ	tckchk	;:no
	MOV	AX,#xstrch	;convert to char
	CALL	ecall	;* CALL xstrch
	MOV	CL,#$0C	;now char
tckchk	CMP.B	CL,varctp	;type = expected ?
	JNZ	tckerr	;no: error
	CMP.B	CL,#$03	;set ?
	JNZ	tckptr	;:no
	OR.B	CH,CH	;constant ?
	JZ	tckret	;yes: ret
	MOV	BP,lower	;same base type ?
	CMP.B	CH,[BP]-$08
	JZ	tckret	;yes: ret
tckerr	CALL	err	;44:Type mismatch
	B	$2C	;'
tckptr	CMP.B	CL,#$04	;pointer ?
	JNZ	tckret	;no: ret
	MOV	AX,functp	;type pointer
	OR	AX,AX	;untyped ?
	JZ	tckret	;yes: ret
	CMP	AX,lower	;compare types
	JNZ	tckerr	;different: error
tckret	RET		;"
tchkstrc	MOV	AL,varctp	;Type checking struct vars
	CMP	AL,#$00	;type expected: untyped ?
	JZ	tcserr	;yes: type mismatch
	MOV	DL,#$BF	;check everything
	CMP	AL,#$0A	;scalar ?
	JNB	tcschk	;yes: check it
	CMP	AL,#$08	;string ?
	JNZ	tcsnostr	;:no
	MOV	DL,#$80	;check type only
	TEST	direcsv,#$0040	;string checking ?
	JZ	tcschk	;:no
tcsnostr	MOV	DL,#$83	;check type, component size
	CMP	AL,#$06	;text, untyped file ?
	JNB	tcschk	;:check it
	MOV	DL,#$B3
	CMP	AL,#$03	;set ?
	JNB	tcschk	;:check it
	MOV	DL,#$C3	;check type, rec nest, size
	CMP	AL,#$02	;record ?
	JNB	tcschk	;:check it
	CMP	upper,#$00	;second type
	MOV	DL,#$BF	;check everything
	JNZ	tcschk	;:check it
	MOV	BP,upper2	;second type
	CMP.B	[BP]-$08,#$0A	;scalar index ?
	JNZ	tcserr	;no: type mismatch
	MOV	DL,#$B3	;check type, lower, upper, size
tcschk	MOV	SI,#varctp	;check buffers
	MOV	DI,#var2ctp
	MOV	CX,#$0008	;check 8 bytes
tcschklp	ROL.B	DL,1 	;test this byte ?
	JNB	tcsnochk	;:no
	MOV.B	AL,[SI]	;compare
	CMP.B	AL,[DI]
	JNZ	tcserr	;different: error
tcsnochk	INC	SI	;next byte
	INC	DI
	LOOP	tcschklp	;:another
	RET		;'
tcserr	CALL	err	;44:Type mismatch
	B	$2C	;"
assgnvar	CALL	getvprm	;get var parms
	CMP.B	indptflg,#$00	;indirect ?
	CALL	errnz	;yes:
	B	$29	;41:Unknown ID or syntax error
	CALL	rdvarind	;do indexing
	JMP	cassign	;"do assignment
passign	CALL	brfilvar	;ASSIGN: get file var
	MOV	AX,#xassign	;normal Assign
	CMP.B	CL,#$06	;text file ?
	JNZ	pasgn2	;:no
	MOV	AX,#xassgntx	;assign text file
	CALL	pasgn2	;get params
	JMP.b	pfilchk	;'do checking
pasgn2	PUSH	AX	;save call addr
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	exstr	;get string expr
	POP	AX	;restore call addr
pemit	PUSH	AX	;save call addr
	CALL	ebrack2	;! )
	POP	AX	;call addr
	JMP	ecall	;"emit call
prename	CALL	brfilvar	;RENAME: get file var
	MOV	AX,#xrename
	CALL	pasgn2	;get string, emit call
	JMP.b	pfilchk	;"do checking
perase	CALL	brfilvar	;ERASE: get file var
	MOV	AX,#xerase
	JMP.b	pfilend	;'put it
pchain	MOV	AX,#xchain	;CHAIN
	JMP.b	pexec2	;'put it
pexecute	MOV	AX,#xexecute	;EXECUTE
pexec2	PUSH	AX	;save addr
	CALL	brfilvar	;get file var
pexec3	POP	AX	;restore addr
pfilend	CALL	pemit	;test ), emit call
pfilchk	JMP	efilchk	;"do checking
pseek	CALL	brfilvar	;SEEK, LONGSEEK: get file var
	CMP.B	CL,#$06	;text file ?
	CALL	errz	;yes:
	B	$3F	;63:Textfiles are not allowed here
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	exnum	;get num expr
	MOV	AX,#xseek
	CMP.B	CL,#$0A	;integer ?
	JZ	pseekint	;:yes
	MOV	AX,#xlngseek	;real...
pseekint	JMP	pfilend	;"test ), emit call, check
pappend	CALL	brfilvar	;APPEND: get file var
	CMP.B	CL,#$06	;text file ?
	CALL	errnz	;no:
	B	$23	;35:Textfile expected
	MOV	AX,varsize	;component size
	SUB	AX,#$004C	;sub size of file var
	CALL	emovcxi	;* MOV CX,buf_size
	MOV	AX,#xappndtx
	JMP	pfilend	;"test ), emit call, check
preset	MOV	BX,#vreset	;RESET
	JMP.b	prw2	;'ptr into vector table
prewrite	MOV	BX,#vrewrite	;REWRITE
prw2	PUSH	BX	;save ptr
	CALL	brfilvar	;get file var
	CMP.B	varctp,#$05	;typed file ?
	JNZ	prwtext	;:no
	MOV	BP,lower	;type ptr
	CALL	getparm	;get var parms
	MOV	AX,var2size	;component size
	CALL	emovcxi	;* MOV CX,compo_size
	JMP.b	prwemit	;'
prwtext	CMP.B	varctp,#$06	;text file ?
	JNZ	prwuntp	;:no
	MOV	AX,varsize	;var size-base size
	SUB	AX,#$004C
	CALL	emovcxi	;* MOV CX,buf_size
	JMP.b	prwemit	;'
prwuntp	CALL	epushdi	;* PUSH DI - untyped file
	CALL	ccomma	;, ?
	JNZ	prwuntp2	;:no
	CALL	pushe1	;save var entry
	CALL	exint	;get int expr: block size
	CALL	pope1	;restore var entry
	JMP.b	prwemit	;'
prwuntp2	MOV	AX,#$0080	;std blk size
	CALL	emovaxi	;* MOV AX,0080
prwemit	POP	BX	;restore table index
	JMP.b	pclose3	;'
ptruncat	MOV	BX,#vtruncat	;TRUNCATE
	JMP.b	pclose2	;'
pflush	MOV	BX,#vflush	;FLUSH
	JMP.b	pclose2	;'
pclose	MOV	BX,#vclose	;CLOSE
pclose2	PUSH	BX	;save table index
	CALL	brfilvar	;get file var
	POP	BX	;restore index
pclose3	CALL	ebrack2	;! )
	CALL	ecallio	;emit call
	JMP	pfilchk	;"do checking
ecallio	MOV	AL,varctp	;emit call for I/O
	SUB	AL,#$05	;(component type-5)*2
	XOR.B	AH,AH
	ADD	AX,AX
	ADD	BX,AX	;+ BX -> pointer
	CS:	
	MOV	AX,[BX]	;get vector
	JMP	ecall	;"emit call
vreset	W	xresetty,xresettx,xresetun	;vector table for I/O
vrewrite	W	xrewrtty,xrewrttx,xrewrtun
vclose	W	xclosety,xclosetx,xclosety
vflush	W	xflushty,xflush,xflushty
vtruncat	W	xtruncat,xtrunctx,xtruncat	;"
brfilvar	CALL	ebrack1	;! (
	CALL	rdfilvar	;get file var
	JZ	brfilret	;ok:ret
	CALL	err
	B	$15	;'21:File variable expected
brfilret	RET		;"
rdfilvar	CALL	rdvar	;get file var: get var
	JZ	rdfil2	;:found
	STC		;not found
	RET		;'
rdfil2	CMP.B	varctp,#$05	;file var ?
	JB	rdfilnf	;:no
	CMP.B	varctp,#$07
	JA	rdfilnf	;:no
	CALL	varptr2	;get var ptr
	MOV.B	CL,varctp	;get type
	XOR	AX,AX	;ok
rdfilnf	CLC	
	RET		;"
preadln	MOV	AL,#$FF	;READLN: set flag
	JMP.b	prd1	;'
pread	XOR.B	AL,AL	;READ
prd1	MOV	rdlnflg,AL	;store flag
	CALL	cbrack1	;( ?
	JZ	prdfil	;:yes
	CALL	setinp	;set input path
	JMP	prdrdln	;'do checking
prdfil	CALL	rdfilvar	;get file var
	JB	prderr	;:error
	JNZ	prdsetin	;no file var: use std
	CMP.B	CL,#$05	;typed file ?
	JNZ	prdtext	;:no
	JMP	prdtyped	;'do read typed file
prdtext	CMP.B	CL,#$06	;text file ?
	CALL	errnz	;no:
	B	$41	;65:Untyped files are not allowed here
	MOV	AX,#xrdfil	;(prepare for input)
	CALL	ecall	;* CALL xrdfil
	JMP	prdnxt	;'
prderr	CALL	err	;41:Unknown ID or syntax error
	B	$29	;'
prdsetin	CALL	setinp	;set input path
	JMP.b	prdlp2	;'
prdloop	CALL	rdvar	;parameter loop: read var
	CALL	errnz	;not found:
	B	$29	;41:Unknown ID or syntax error
prdlp2	CALL	varptr2	;get var ptr
	MOV.B	CL,varctp	;component type
	CMP.B	CL,#$01	;array ?
	JZ	prdarrch	;yes: read as byte block
	CMP.B	CL,#$08	;file, ptr, set, record ?
	JB	prderrtp	;:not allowed
	CMP.B	CL,#$0B	;boolean ?
	JZ	prderrtp	;:not allowed
	CMP.B	CL,#$0D	;scalar ?
	JB	prdstr	;below: ok
prderrtp	CALL	err	;66:I/O not allowed here
	B	$42	;'
prdarrch	MOV	BP,lower	;type ptr - test array of char
	CMP.B	[BP]-$08,#$0C	;component type = char ?
	JNZ	prderrtp	;no:error
	MOV	BP,upper	;index type = integer ?
	CMP.B	[BP]-$08,#$0A
	JNZ	prderrtp	;no:error
	MOV	AX,varsize	;component size
	OR.B	AH,AH	;> 255 ?
	JNZ	prderrtp	;yes:error
	MOV.B	AH,AL	;* MOV CL,len
	MOV	AL,#$B1
	CALL	eword
	MOV	AX,#xrdarrch	;(read array of char)
	JMP.b	prdemit	;'
prdstr	CMP.B	CL,#$08	;string ?
	JNZ	prdnum	;:no
	MOV.B	AH,varsize	;max len-1
	DEC.B	AH
	MOV	AL,#$B1
	CALL	eword	;* MOV CL,max_len
	MOV	AX,#xrdstr	;(read string)
	JMP.b	prdemit	;'
prdnum	MOV	AX,#xrdreal	;(read real)
	CMP.B	CL,#$09	;real ?
	JZ	prdemit	;:yes
	MOV	AX,#xrdchar	;(read char)
	CMP.B	CL,#$0C	;char ?
	JZ	prdemit	;:yes
	MOV	AX,#xrdint	;(read integer)
	CMP	varsize,#$01	;word ?
	JA	prdemit	;:yes
	MOV	AX,#xrdbyte	;(read byte)
prdemit	CALL	ecall	;emit call
prdnxt	CALL	ccomma	;another var ?
	JNZ	prdend	;no: end it
	JMP	prdloop	;'parameter loop
prdend	CALL	ebrack2	;! )
prdrdln	MOV	AX,#xreadln	;(readln)
prdln	CMP.B	rdlnflg,#$00	;ReadLn ?
	JZ	efilchk	;:no
	CALL	ecall	;emit call
efilchk	TEST	direcsv,#$0001	;do I/O-checking ?
	JZ	prdret	;:no
	MOV	AX,#xiochk	;(I/O-check)
	CALL	ecall
prdret	RET		;"
setinp	MOV	AX,#xstdin	;set input path: std input
	CMP	cinpsize,#$00	;buffer > 0 ?
	JNZ	setinprt	;yes: do it
	TEST	direcsv,#$0004	;test I/O-mode
	JZ	setinprt	;:MS-DOS std input
	MOV	AX,#xrdln	;(read with editing)
	CMP.B	rdlnflg,#$00	;ReadLn ?
	JZ	setinprt	;:no
	MOV.B	rdlnflg,#$00	;clear flag
	MOV	AX,#xrd	;(Readln with editing)
setinprt	JMP	ecall	;"emit call
pwriteln	MOV	AL,#$FF	;WRITELN
	JMP.b	pwr1	;'
pwrite	XOR.B	AL,AL	;WRITE
pwr1	MOV	rdlnflg,AL	;set flag
	CALL	cbrack1	;( ?
	JZ	pwrfil	;yes: ok
	MOV	AX,#xstdout	;set std output
	CALL	ecall	;emit call
	JMP	pwrend2	;'end it
pwrfil	CALL	rdfilvar	;get file var
	JB	pwrstd2	;:none
	JNZ	pwrstd	;no file var
	CMP.B	CL,#$05	;typed file ?
	JNZ	pwrtext	;:no
	JMP	pwrtyped	;'write typed file
pwrtext	CMP.B	CL,#$06	;text file ?
	CALL	errnz	;no:
	B	$41	;65:Untyped files are not allowed here
	MOV	AX,#xwrfil	;(prepare for write)
	CALL	ecall	;* CALL xwrfil
	JMP	pwrnext	;'
pwrstd	MOV	AX,#xstdout	;set std output
	CALL	ecall	;* CALL xstdout
	CALL	expvar	;expression (var pre-read)
	JMP.b	pwrstr	;'check type
pwrstd2	MOV	AX,#xstdout	;set std output
	CALL	ecall	;* CALL xstdout
pwrloop	CALL	constel	;get const element
	JNZ	pwrexpv	;:no, try expression
	CMP.B	CL,#$08	;string ?
	JNZ	pwrexpc	;:no
	MOV	DI,chptr	;check current char
	CMP.B	[DI],#$2C	;, ?
	JZ	pwrinlin	;:yes
	CMP.B	[DI],#$29	;) ?
	JNZ	pwrexpc	;no: normal
pwrinlin	MOV	AX,#xwrtinl	;(write inline string)
	CALL	ecall	;* CALL xwrtinl
	CALL	estring	;emit string
	JMP.b	pwrnext	;'get next element
	NOP	
pwrexpc	CALL	expconst	;expression (const pre-read)
	JMP.b	pwrstr	;'check type
pwrexpv	CALL	exprax	;expression (var pre-read)
pwrstr	CMP.B	CL,#$08	;string ?
	JB	pwrerrtp	;below:illegal
	CMP.B	CL,#$0D	;scalar ?
	JB	pwrint	;below: ok
pwrerrtp	CALL	err	;66:I/O not allowed here
	B	$42	;'
pwrint	CMP.B	CL,#$0A	;integer ?
	JB	pwrnoint	;below: real, string
	CALL	epushax	;* PUSH AX - stack it
pwrnoint	CALL	ccolon	;: ?
	JNZ	pwrdef	;no:default format
	PUSH	CX	;save type
	CALL	exint	;get int expression
	POP	CX
	CMP.B	CL,#$09	;real ?
	JNZ	pwrchk	;no: no second parm
	CALL	ccolon	;: ?
	JNZ	pwrdef3	;no: use default
	CALL	epushax	;* PUSH AX
	PUSH	CX	;save type
	CALL	exint	;get int expression
	POP	CX
	JMP.b	pwrchk	;'continue
pwrdef	XOR	AX,AX	;standard format
	CMP.B	CL,#$09	;real ?
	JNZ	pwrdef2	;:no
	MOV	AL,#$12	;default: 18 chars
pwrdef2	CALL	emovaxi	;* MOV AX,field_len
	CMP.B	CL,#$09	;real ?
	JNZ	pwrchk	;:no
pwrdef3	CALL	epushax	;* PUSH AX
	MOV	AX,#$FFFF
	CALL	emovaxi	;* MOV AX,#FFFF
pwrchk	MOV	AX,#xwrtstr	;(write string)
	CMP.B	CL,#$08	;string ?
	JZ	pwremit	;:yes
	MOV	AX,#xwrreal	;(write real)
	CMP.B	CL,#$09	;real ?
	JZ	pwremit	;:yes
	MOV	AX,#xwrint	;(write integer)
	CMP.B	CL,#$0A	;integer ?
	JZ	pwremit	;:yes
	MOV	AX,#xwrbool	;(write boolean)
	CMP.B	CL,#$0B	;boolean ?
	JZ	pwremit	;:yes
	MOV	AX,#xwrchar	;(write char)
pwremit	CALL	ecall	;emit call
pwrnext	CALL	ccomma	;, ?
	JNZ	pwrend	;no: end it
	JMP	pwrloop	;'do param loop
pwrend	CALL	ebrack2	;! )
pwrend2	MOV	AX,#xwrln	;(writeln)
	JMP	prdln	;"like read/readln
prdtyped	MOV	AX,#xrdvar	;Read typed file
	JMP.b	pwt2	;'(read byte block)
pwrtyped	MOV	AX,#xwrvar	;Write typed file
pwt2	CMP.B	rdlnflg,#$00	;ReadLn/WriteLn ?
	CALL	errnz	;yes:
	B	$23	;35:Textfile expected
	PUSH	AX	;save addr
	MOV	AX,#xfilsel	;(select file)
	CALL	ecall	;* CALL xfilsel
	MOV	BP,lower	;type ptr
	CALL	getparm	;get type parms
pwtloop	CALL	ccomma	;, ?
	JNZ	pwtend	;no: end it
	CALL	pushe2	;push entry
	CALL	varptr	;get var ptr
	CALL	pope2	;pop entry
	CALL	tchkstrc	;check type struct vars
	POP	AX	;get routine addr
	PUSH	AX
	CALL	ecall	;* CALL xwrvar / xrdvar
	JMP	pwtloop	;'parameter loop
pwtend	POP	AX	;remove
	CALL	ebrack2	;! )
	JMP	efilchk	;"do checking
pblockrd	MOV	AX,#xblkrdrd	;BLOCKREAD
	MOV	BX,#xblkrd	;with / without res var
	JMP.b	pbl1	;'
pblockwr	MOV	AX,#xblkwrrs	;BLOCKWRITE
	MOV	BX,#xblkwr
pbl1	PUSH	AX	;save addr
	PUSH	BX
	CALL	brfilvar	;get file var
	CMP.B	CL,#$07	;untyped ?
	CALL	errnz	;no:
	B	$25	;37:Untyped file expected
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	varptr	;get var ptr (src/dst var)
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	exint	;get int expr (count)
	CALL	ccomma	;, ?
	POP	BX	;restore addr
	POP	AX
	JZ	pblres	;yes: with result var
	PUSH	BX	;without result var
	JMP.b	pblend	;'
pblres	PUSH	AX	;save routine addr
	CALL	epushax	;* PUSH AX (save count)
	CALL	varptr	;get res var ptr
	CMP.B	varctp,#$0A	;integer ?
	JNZ	pblerr	;no: error
	CMP	varsize,#$02	;word ?
	JZ	pblend	;yes: ok
pblerr	CALL	err	;24:Integer variable expected
	B	$18	;'
pblend	JMP	pexec3	;"emit call, check end
pchdir	MOV	AX,#xchdir	;CHDIR
	JMP.b	prmd2	;'
pmkdir	MOV	AX,#xmkdir	;MKDIR
	JMP.b	prmd2	;'
prmdir	MOV	AX,#xrmdir	;RMDIR
prmd2	PUSH	AX	;save addr
	CALL	ebrack1	;! (
	CALL	exstr	;get string expr
	JMP	pexec3	;"complete it
pgetdir	CALL	ebrack1	;! ( : GETDIR
	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	CALL	ecomma	;! ,
	CALL	rdstrvar	;get string var
	MOV.B	AH,varsize	;max len-1
	DEC.B	AH
	MOV	AL,#$B1
	CALL	eword	;* MOV CL,max_len
	MOV	AX,#xgetdir
	JMP	pemit	;"end it
povrpath	CALL	ebrack1	;! ( : OVRPATH
	CALL	exstr	;get string expr
	MOV	AX,#xovrpath
	JMP	pemit	;"end it
pdelete	CALL	ebrack1	;! ( : DELETE
	CALL	rdstrvar	;get string var
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	CALL	ecomma	;! ,
	CALL	exint	;get int expr
	MOV	AX,#xdelete
	JMP	pemit	;"end it
pinsert	CALL	ebrack1	;! ( : INSERT
	CALL	exstr	;get string expr
	CALL	ecomma	;! ,
	CALL	rdstrvar	;get string var
	CALL	epushdi	;* PUSH DI
	MOV.B	AH,varsize	;component size - 1
	DEC.B	AH
	MOV	AL,#$B1
	PUSH	AX	;save it
	CALL	ecomma	;! ,
	CALL	exint	;get integer expr
	POP	AX	;restore
	CALL	eword	;* MOV CL,max_len
	MOV	AX,#xinsert
	JMP	pemit	;"end it
rdstrvar	CALL	varptr	;get string var: get var ptr
	CMP.B	varctp,#$08	;string ?
	CALL	errnz	;no:
	B	$22	;34:String variable expected
	RET		;"
pstr	CALL	ebrack1	;! ( : STR
	CALL	exnum	;get num expr
	CMP.B	CL,#$0A	;integer ?
	JNZ	pstnoint	;real: is already on stack !
	CALL	epushax	;* PUSH AX
pstnoint	CALL	ccolon	;: ?
	JNZ	pstdef1	;:no formatting
	PUSH	CX	;save type
	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	POP	CX	;restore type
	CMP.B	CL,#$0A	;integer ?
	JZ	pstnxt	;yes: no second parm
	CALL	ccolon	;: ?
	JNZ	pstdef3	;no: get default
	PUSH	CX	;save type
	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	POP	CX	;restore type
	JMP.b	pstnxt	;'
pstdef1	XOR	AX,AX	;set default
	CMP.B	CL,#$0A	;integer ?
	JZ	pstdef2	;:yes
	MOV	AL,#$12	;real: 18 chars
pstdef2	CALL	emovaxi	;* MOV AX,i
	CALL	epushax	;* PUSH AX
	CMP.B	CL,#$0A	;integer ?
	JZ	pstnxt	;:yes
pstdef3	MOV	AX,#$FFFF	;default for second parm:
	CALL	emovaxi	;* MOV AX,#FFFF
	CALL	epushax	;* PUSH AX
pstnxt	CALL	ecomma	;! ,
	PUSH	CX	;save type
	CALL	rdstrvar	;get string var
	MOV.B	AH,varsize	;component size-1
	DEC.B	AH
	MOV	AL,#$B1
	CALL	eword	;* MOV CL,max_len
	POP	CX	;restore type
	MOV	AX,#xstrint	;(str integer)
	CMP.B	CL,#$0A	;integer ?
	JZ	pstemit	;:yes
	MOV	AX,#xstrreal	;(str real)
pstemit	JMP	pemit	;"emit call, check )
pval	CALL	ebrack1	;! ( : VAL
	CALL	exstr	;get string expression
	CALL	ecomma	;! ,
	CALL	varptr	;get dest var ptr
	MOV.B	CL,varctp	;test type
	CMP.B	CL,#$0A	;integer ?
	JZ	pvalint	;:yes
	CMP.B	CL,#$09	;real
	JZ	pvalreal	;:yes
	CALL	err	;27:Integer or real var expected
	B	$1B	;'
pvalint	CMP	varsize,#$02	;test component size
	JNZ	pvalerr	;byte: error
pvalreal	PUSH	CX	;save type
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	varptr	;get status var ptr
	CMP.B	varctp,#$0A	;integer ?
	JNZ	pvalerr	;no: error
	CMP	varsize,#$02	;byte ?
	JZ	pvalok	;word:ok
pvalerr	CALL	err	;24:Int var expected
	B	$18	;'
pvalok	POP	CX	;restore type
	MOV	AX,#xvalint	;(val integer)
	CMP.B	CL,#$0A	;integer ?
	JZ	pstemit	;:yes
	MOV	AX,#xvalreal	;(val real)
	JMP	pstemit	;"emit call, check )
pgotoxy	CALL	ebrack1	;! ( : GOTOXY
	CALL	exint	;get integer expr
	CALL	epushax	;* PUSH AX
	MOV	AX,#xgotoxy
pgxy2	PUSH	AX	;save addr
	CALL	ecomma	;! ,
	CALL	exint	;get integer expr
	POP	AX	;restore addr
	JMP	pemit	;"emit call, check )
prndmize	MOV	AX,#xrndmize	;RANDOMIZE
	JMP	ecall	;"emit call
pnew	MOV	AX,#xnew	;NEW
pnew2	PUSH	AX	;save addr
	CALL	ebrack1	;! (
	CALL	varptr	;get var ptr
	CMP.B	varctp,#$04	;pointer var ?
	JNZ	prelerr	;no: error
	MOV	BP,lower	;get type ptr
	CALL	getparm	;get type parms
	MOV	AX,var2size	;get its component size
	CALL	emovcxi	;* MOV CX,compo_size
	POP	AX	;restore addr
	JMP	pemit	;"emit call, check )
pgetmem	MOV	AX,#xgetmem	;GETMEM
pgm2	PUSH	AX	;save addr
	CALL	ebrack1	;! (
	CALL	varptr	;get var ptr
	CMP.B	varctp,#$04	;pointer ?
	JNZ	prelerr	;no: error
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	exint	;get int expr
	POP	AX	;restore addr
	JMP	pemit	;"emit call, check )
pdispose	MOV	AX,#xdispose	;DISPOSE
	JMP	pnew2	;"like New
pfreemem	MOV	AX,#xfreemem	;FREEMEM
	JMP	pgm2	;"like Getmem
pmark	MOV	AX,#xmark	;MARK
	JMP.b	prel2	;'like Release
prelease	MOV	AX,#xrelease	;RELEASE
prel2	PUSH	AX	;save addr
	CALL	ebrack1	;! (
	CALL	varptr	;get var ptr
	POP	AX	;restore addr
	CMP.B	varctp,#$04	;pointer ?
	JNZ	prelerr	;no: error
	JMP	pemit	;'emit call, check )
prelerr	CALL	err	;28:Pointer var expected
	B	$1C	;"
pmove	CALL	ebrack1	;! ( : MOVE
	CALL	varptr	;get src var ptr
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	varptr	;get dest var ptr
	CALL	epushdi	;* PUSH DI
	MOV	AX,#xmove
	JMP	pgxy2	;"get int expr, end it
pfillchr	CALL	ebrack1	;! ( : FILLCHAR
	CALL	varptr	;get dest var ptr
	CALL	epushdi	;* PUSH DI
	CALL	ecomma	;! ,
	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	CALL	ecomma	;! ,
	CALL	exscal	;get scalar expr
	MOV	AX,#xfillchr
	JMP	pemit	;"end it
pexit	XOR	AX,AX	;EXIT: clear flag
	JMP	exit	;"do it
phalt	CALL	cbrack1	;HALT: ( ?
	JNZ	phlt2	;no: normal
	CALL	exint	;get int expr
	CALL	ebrack2	;! )
	JMP.b	phlt3	;'
phlt2	CALL	ecode	;* XOR AX,AX
	B	$02,$33,$C0
phlt3	MOV	AX,#progend
	JMP	ejump	;"emit jump
pmsdos	CALL	ebrack1	;! ( : MSDOS
	MOV	BX,#$0021	;int number 21
	PUSH	BX	;save it
	JMP.b	pint2	;'like INTR
pintr	CALL	ebrack1	;! ( : INTR
	CALL	rdintcn	;read integer constant
	PUSH	BX	;save it
	CALL	ecomma	;! ,
pint2	CALL	varptr	;get var ptr
	MOV	AX,#xsetregs	;(set registers from rec)
	CALL	ecall	;* CALL xsetregs
	POP	AX	;interrupt number
	MOV.B	AH,AL
	MOV	AL,#$CD	;* INT nn
	CALL	eword
	MOV	AX,#xgetregs	;(get registers back)
	JMP	pemit	;"emit call, check )
pportw	MOV	AL,#$EF	;PORTW: opcode OUT
	JMP.b	pprt2	;'
pport	MOV	AL,#$EE	;PORT: opcode OUTB
pprt2	PUSH	AX	;save opcode
	CALL	esqr1	;! [
	CALL	exint	;get int expr
	CALL	esqr2	;! ]
	CALL	epushax	;* PUSH AX (port number)
	CALL	eassign	;! :=
	CALL	exint	;get int expr
	CALL	ecode	;* POP DX
	B	$01,$5A
	POP	AX	;restore opcode
	JMP	ebyte	;"emit OUT [DX],AX
pcrtinit	MOV	AX,#xcrtinit	;CRTINIT
	JMP.b	pdelemit	;'
pcrtexit	MOV	AX,#xcrtexit	;CRTEXIT
	JMP.b	pdelemit	;'
pclrscr	MOV	AX,#xclrscr	;CLRSCR
	JMP.b	pdelemit	;'
pclreol	MOV	AX,#xclreol	;CLREOL
	JMP.b	pdelemit	;'
pnrmvid	MOV	AX,#xnormvid	;NORMVIDEO, HIGHVIDEO
	JMP.b	pdelemit	;'
plowvid	MOV	AX,#xlowvid	;LOWVIDEO
	JMP.b	pdelemit	;'
pinsline	MOV	AX,#xinsline	;INSLINE
	JMP.b	pdelemit	;'
pdelline	MOV	AX,#xdelline	;DELLINE
pdelemit	JMP	ecall	;"emit call
pdelay	MOV	AX,#xdelay	;DELAY
pdel2	PUSH	AX	;save addr
	CALL	ebrack1	;! (
	CALL	exint	;get int expr
	POP	AX	;restore addr
	JMP	pemit	;"emit, check )
pwindow	MOV	AX,#xwindow	;WINDOW
pwind4	PUSH	AX	;save addr
	CALL	ebrack1	;! (
pwind3	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	CALL	ecomma	;! ,
pwind2	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	CALL	ecomma	;! ,
	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	POP	AX	;restore addr
	JMP	pgxy2	;"get int, end it
ptextcol	MOV	AX,#xtxtcol	;TEXTCOLOR
	JMP	pdel2	;"(int)
ptextbg	MOV	AX,#xtxtbg	;TEXTBACKGROUND
	JMP	pdel2	;"(int)
pgraphbg	MOV	AX,#xgrbg	;GRAPHBACKGROUND
	JMP	pdel2	;"(int)
ppalette	MOV	AX,#xpalette	;PALETTE
	JMP	pdel2	;"(int)
phirscol	MOV	AX,#xhirscol	;HIRESCOLOR
	JMP	pdel2	;"(int)
pgrcolmd	MOV	AX,#xgrcolmd	;GRAPHCOLORMODE
pgremit	JMP	ecall	;'emit call
pgrmode	MOV	AX,#xgrmode	;GRAPHMODE
	JMP	pgremit	;'emit call
phires	MOV	AX,#xhires	;HIRES
	JMP	pgremit	;"emit call
ptxtmode	CALL	cbrack1	;TEXTMODE
	JZ	ptxtmd2	;( ? yes: get mode
	MOV	AX,#$00FF
	CALL	emovaxi	;* MOV AX,#00FF
	JMP.b	ptxtdef	;'
ptxtmd2	CALL	exint	;get int expr
	CALL	ebrack2	;! )
ptxtdef	MOV	AX,#xtxtmode
	JMP	ecall	;"emit call
pgrwind	MOV	AX,#xgrwindw	;GRAPHWINDOW
	JMP	pwind4	;"like window
pplot	CALL	ebrack1	;! ( : PLOT
	MOV	AX,#xplot
	PUSH	AX	;save it
	JMP	pwind2	;"like window - only 3 parms
pdraw	CALL	ebrack1	;! ( : DRAW
	CALL	exint	;get int expr
	CALL	epushax	;* PUSH AX
	CALL	ecomma	;! ,
	MOV	AX,#xdraw
	PUSH	AX	;save addr
	JMP	pwind3	;"now like window
psound	MOV	AX,#xsound	;SOUND
	JMP	pdel2	;"(int)
pnosound	MOV	AX,#xnosound	;NOSOUND
	JMP	ecall	;"emit call
exprsave	CALL	pushe1	;push entry
	CALL	exprax	;read expression
	CALL	pope1	;restore entry
exintrt	RET		;"
exint	CALL	exprax	;get integer expression: rd expr
	CMP.B	CL,#$0A	;integer ?
	JZ	exintrt	;yes:ret
	CALL	err	;23:Integer expression expected
	B	$17	;"
exnum	CALL	exprax	;get numeric expression: rd expr
	CMP.B	CL,#$0A	;integer ?
	JZ	exintrt	;yes: ret
	CMP.B	CL,#$09	;real ?
	JZ	exintrt	;yes: ret
	CALL	err	;26:Int or real expression expected
	B	$1A	;"
exscal	CALL	exprax	;get scalar expression: rd expr
chksimpl	CMP.B	CL,#$0A	;scalar ?