	model	large compiler_text,pascal
	include	compiler.inc

	.code	compiler_text

	public	GetReturnVar
	public	Store
	public	PutCall
	public	ReturnValue
	public	DiscardReturn
	public	TypeCompat
	public	ProcCompat
	public	CastOrdinal
	public	CastByte
	public	CastInt
	public	CastWord
	public	CastLong

GetReturnVar	proc	near
	les	si,CurrentSymbol
	mov	ax,es
	cmp	ax,Dictionary.Segm
	jne	@@2
	cmp	es:[si].psType.ptResult.Offs,0
	je	@@2
	mov	bx,es:[si].psProcMap
	push	ds
	mov	ds,ProcMap.Segm
	cmp	[bx].pmCodeMap,-2
	pop	ds
	jne	@@2
	xor	ax,ax
	mov	bx,es:[si].psType.ptResult.Offs
	mov	si,es:[si].psType.ptResult.Segm
	mov	es,es:[si]
	sub	ax,es:[bx].tdSizeOf
	cmp	es:[bx].tdType,ttString
	jne	@@1
	push	es di bx
	les	di,CurrentSymbol
	Invoke	StackRequired
	pop	bx di es
	mov	ax,dx
@@1:	clc
	ret
@@2:	stc
	ret
GetReturnVar	endp

Store	proc	near
	les	bx,[di].exType
	mov	bl,es:[bx].tdType
	xor	bh,bh
	shl	bx,1
	jmp	cs:@@1[bx]
@@1	dw	StoreCompound
	dw	StoreCompound
	dw	StoreCompound
	dw	StoreObject
	dw	StoreCompound
	dw	StoreCompound
	dw	StoreOrdinal
	dw	StoreSet
	dw	StoreOrdinal
	dw	StoreString
	dw	Store8087
	dw	StoreReal
	dw	StoreOrdinal
	dw	StoreOrdinal
	dw	StoreOrdinal
	dw	StoreOrdinal
Store	endp

StoreObject	proc	near
	les	bx,[di].exType
	mov	ax,_CopyObject
	mov	dx,es:[bx].otVMTOffset
	cmp	es:[bx].otVMTSize,0
	jne	@@1
StoreCompound	label	near
	xchg	si,di
	call	ShortRecord
	xchg	si,di
	call	ShortRecord
	jz	StoreOrdinal
	les	bx,[di].exType
	mov	ax,_BlockMove
	mov	dx,es:[bx].tdSizeOf
@@1:	push	ax dx
	xchg	si,di
	Invoke	Push2Addrs
	Invoke	Use2Exprs
	xchg	si,di
	pop	ax
	Invoke	PushWord
	pop	ax
	Invoke	PutSystemCall
	Chain	DoneExpr
StoreObject	endp

StoreOrdinal	proc	near
	cmp	[si].exLocation,elImmediate
	jne	@@4
	mov	ax,[si].exValue.W0
	or	ax,[si].exValue.W2
	jnz	@@2
	test	[di].exModifier,emX
	jz	@@2
	Invoke	UseExpr
	mov	ax,0c031h		; xor	ax,ax
	Invoke	PutWord
	mov	al,lvAX
	Invoke	StoreReg
	test	[di].exModifier,emXX
	jz	@@1
	add	[di].exOffset,2
	mov	al,lvAX
	Invoke	StoreReg
	sub	[di].exOffset,2
@@1:	or	[di].exRegsUsed,erAX
	Chain	DoneExpr
@@2:	Invoke	UseExpr
	mov	ax,[si].exValue.W0
	Invoke	PutMovRMImm
	test	[di].exModifier,emXX
	jz	@@3
	add	[di].exOffset,2
	mov	ax,[si].exValue.W2
	Invoke	PutMovRMImm
	sub	[di].exOffset,2
@@3:	Chain	DoneExpr
@@4:	xchg	si,di
	Invoke	UseExpr
	mov	al,[si].exRegsUsed
	Invoke	FindEmptyReg
	xchg	si,di
	Invoke	UseExpr
	xchg	si,di
	xor	al,al
	Invoke	PopValue
	xchg	si,di
	mov	al,[si].exMisc
	Invoke	StoreValue
	Chain	DoneExpr
StoreOrdinal	endp

StoreSet	proc	near
	xchg	si,di
	Invoke	_LoadSet
	Invoke	Push2Addrs
	Invoke	Use2Exprs
	xchg	si,di
	les	bx,[di].exType
	Invoke	PushSetAddr
	mov	ax,_ZStore
	Invoke	PutSystemCall
	Chain	DoneExpr
StoreSet	endp

StoreString	proc	near
	cmp	[si].exLocation,elImmediate
	jne	@@1
	mov	bx,[si].exOffset
	cmp	[bx].B0,0
	jne	@@1
	Invoke	UseExpr
	mov	dx,0c6h			; mov	[...],0
	Invoke	AddReg
	xor	al,al
	Invoke	PutByte
	Chain	DoneExpr
@@1:	xchg	si,di
	Invoke	PutImmedString
	Invoke	Push2Addrs
	Invoke	Use2Exprs
	xchg	si,di
	les	bx,[di].exType
	mov	ax,es:[bx].tdSizeOf
	dec	ax
	Invoke	PushWord
	mov	ax,_SStore
	Invoke	PutSystemCall
	Chain	DoneExpr
StoreString	endp

Store8087	proc	near
	xchg	si,di
	Invoke	PushExt
	Invoke	Use2Exprs
	xchg	si,di
	mov	dx,18d9h		; fstp
	test	[di].exModifier,emExtended
	jz	@@1
	mov	dh,38h
@@1:	or	dl,[di].exModifier
	Invoke	PutFloatRM
	Invoke	PutFwait
	Chain	DoneExpr
Store8087	endp

StoreReal	proc	near
	cmp	[si].exLocation,elImmediate
	jne	@@1
	Invoke	UseExpr
	mov	ax,[si].exValue.W0
	Invoke	PutMovRMImm
	add	[di].exOffset,2
	mov	ax,[si].exValue.W2
	Invoke	PutMovRMImm
	add	[di].exOffset,2
	mov	ax,[si].exValue.W4
	Invoke	PutMovRMImm
	jmp	short @@4
@@1:	xchg	si,di
	Invoke	UseExpr
	mov	al,lrR1
	Invoke	LoadReal
	xchg	si,di
	cmp	[di].exRegsUsed,0
	je	@@2
	mov	ax,5352h		; push	dx	push	bx
	Invoke	PutWord
	mov	al,50h			; push	ax
	Invoke	PutByte
@@2:	Invoke	UseExpr
	cmp	[di].exRegsUsed,0
	je	@@3
	mov	al,58h			; pop	ax
	Invoke	PutByte
	mov	ax,5a5bh		; pop	bx	pop	dx
	Invoke	PutWord
@@3:	mov	al,lvAX
	Invoke	StoreReg
	add	[di].exOffset,2
	mov	al,lvBX
	Invoke	StoreReg
	add	[di].exOffset,2
	mov	al,lvDX
	Invoke	StoreReg
@@4:	sub	[di].exOffset,4
	Chain	DoneExpr
StoreReal	endp

ShortRecord	proc	near
	les	bx,[di].exType
	mov	ax,es:[bx].tdSizeOf
	cmp	ax,1
	je	@@1
	cmp	ax,2
	je	@@2
	cmp	ax,4
	je	@@3
	ret
@@1:	mov	[di].exModifier,0
	ret
@@2:	mov	[di].exModifier,emX
	ret
@@3:	mov	[di].exModifier,emX+emXX
	ret
ShortRecord	endp

PutCall	proc	near
	cmp	[di].exLocation,elMemory
	je	@@2
	test	[di].exModifier,emNotVirtual
	jnz	@@3
	les	bx,[di].exType
	cmp	es:[bx-psType].psOwner,0
	je	@@3
	call	GetActualParams
	les	si,[di].exType
	call	HiddenParams
	and	[di].exMisc,efDS+efSS+efCS
	or	[di].exMisc,efES
	Invoke	PutPrefix
	mov	si,es:[si-psType].psScope
	mov	ax,es:[si].otVMTOffset
	mov	dx,3d8bh		; mov	di,[di+...]
	Invoke	AddOffset
	test	CompilerOptions,coRangeChk
	jz	@@1
	mov	ax,_MethodCheck
	Invoke	PutSystemCall
@@1:	les	si,[di].exType
	mov	ax,es:[si-psType].psOwner
	mov	dx,1dffh		; call	[di+...]
	Invoke	AddOffset
	Chain	DoneExpr
@@2:	call	GetActualParams
	Invoke	UseExpr
	mov	dx,18ffh		; call	[...]
	Invoke	AddReg
	Chain	DoneExpr
@@3:	call	GetActualParams
	mov	bx,si
	les	si,[di].exType
	test	es:[si-psType].psFlags,pfInterrupt
	jnz	@@4
	test	es:[si-psType].psFlags,pfInline
	jz	@@5
	mov	cx,es:[si-psType].psInlineLen
	push	di
	mov	di,bx
	Invoke	PutInline
	pop	di
	jmp	short @@11
@@4:	mov	ax,114
	Chain	CompileError
@@5:	test	es:[si-psType].psFlags,pfMethod
	jz	@@6
	call	HiddenParams
	jmp	short @@8
@@6:	mov	dx,es:[si-psType].psScope
	or	dx,dx
	jz	@@8
	cmp	dx,CurScope
	jne	@@7
	mov	al,55h			; push	bp
	Invoke	PutByte
	jmp	short @@8
@@7:	mov	cx,76ffh		; push	[bp+...]
	Invoke	GetNestedRef
@@8:	test	es:[si-psType].psFlags,pfFar
	jz	@@10
	mov	ax,es
	cmp	ax,Dictionary.Segm
	je	@@9
	mov	al,9ah			; call
	Invoke	PutByte
	mov	ax,es
	mov	bx,es:[si-psType].psProcMap
	mov	cx,ffProc+ffPtr
	xor	dx,dx
	Invoke	PutFixup
	jmp	short @@11
@@9:	mov	al,0eh			; push	cs
	Invoke	PutByte
@@10:	mov	al,0e8h			; call
	Invoke	PutByte
	mov	ax,es
	mov	bx,es:[si-psType].psProcMap
	mov	cx,ffProc
	xor	dx,dx
	Invoke	PutFixup
@@11:	Chain	DoneExpr
PutCall	endp

HiddenParams	proc	near
	test	es:[si-psType].psFlags,pfConstructor
	jz	@@1
	test	[di].exModifier,emNotVirtual
	jnz	@@2
	push	es
	mov	al,0b8h			; mov	ax,
	Invoke	PutByte
	les	bx,[di].exOwner
	mov	ax,es
	mov	bx,es:[bx].otVMTAddr
	mov	cx,ffConst+ffOffs
	xor	dx,dx
	Invoke	PutFixup
	pop	es
	jmp	short @@4
@@1:	test	es:[si-psType].psFlags,pfDestructor
	jz	@@5
	mov	ax,0ffb0h		; mov	al,0ffh
	test	[di].exModifier,emDisposeDestr
	jnz	@@3
@@2:	mov	ax,0c031h		; xor	ax,ax
@@3:	Invoke	PutWord
@@4:	mov	al,50h			; push	ax
	Invoke	PutByte
@@5:	test	[di].exModifier,emNotVirtual
	jnz	@@7
	test	[di].exModifier,emNewConstruct
	jnz	@@6
	Invoke	UseExpr
	Invoke	LoadSegDI
	or	al,6
	mov	ah,57h			; push	?s	push	di
	Chain	PutWord
@@6:	mov	ax,0c031h		; xor	ax,ax
	Invoke	PutWord
	mov	ax,5050h		; push	ax	push	ax
	Chain	PutWord
@@7:	push	es si
	Invoke	GetTopScope
	jz	@@8
	mov	bx,es:[si].psScope
	mov	ax,[di].exOwner.Offs
	mov	dx,[di].exOwner.Segm
	Invoke	CheckInherit
	jnz	@@8
	pop	si es
	mov	cx,7ec4h		; les	di,[bp+...]
	xor	dx,dx
	Invoke	GetNestedRef
	mov	[di].exMisc,efES+efDI
	mov	[di].exOffset,0
	mov	ax,5706h		; push	es	push	di
	Chain	PutWord
@@8:	mov	ax,143
	Chain	CompileError
HiddenParams	endp

ReturnValue	proc	near
	les	bx,[di].exType
	mov	si,es:[bx].ptResult.Segm
	mov	bx,es:[bx].ptResult.Offs
	mov	es,es:[si]
	mov	[di].exType.Offs,bx
	mov	[di].exType.Segm,es
	mov	[di].exRegsUsed,erAll
	cmp	es:[bx].tdType,ttInteger
	jae	@@1
	cmp	es:[bx].tdType,ttPointer
	je	@@1
	cmp	es:[bx].tdType,ttReal
	jne	@@2
@@1:	mov	al,es:[bx].tdModifier
	mov	[di].exLocation,elRegister
	mov	[di].exModifier,al
	mov	[di].exMisc,lvAX
	ret
@@2:	cmp	es:[bx].tdType,tt8087
	jne	@@3
	mov	[di].exLocation,elStack
	mov	[di].exModifier,emExtended
	ret
@@3:	mov	ax,256
	Invoke	CreateLocalVar
	Invoke	UseExpr
	Chain	DoneExpr
ReturnValue	endp

DiscardReturn	proc	near
	les	bx,[di].exType
	cmp	es:[bx].tdType,ttString
	je	@@1
	cmp	es:[bx].tdType,tt8087
	je	@@2
	ret
@@1:	Invoke	UseExpr
	mov	ax,0c483h		; add	sp,4
	Invoke	PutWord
	mov	al,4
	Invoke	PutByte
	Chain	DoneExpr
@@2:	Invoke	UseExpr
	Invoke	PutEmulInt
	mov	ax,0d835h		; fstp	st(0)
	Invoke	PutWord
	Chain	DoneExpr
DiscardReturn	endp

GetActualParams	proc	near
	Loc	ParamType,dword,1
	Loc	Param,byte,<size TExpr>
	Loc	Buffer,word,64
	Entry
	les	si,[di].exType
	mov	cx,es:[si].ptParamCount
	add	si,ptParams
	jcxz	@@3
	mov	Buffer[0],0
	mov	al,tOParen
	Invoke	NeedToken
	push	di
@@1:	push	cx si es
	call	GetActualParam
	pop	es si cx
	add	si,size TProcParam
	dec	cx
	jz	@@2
	mov	al,tComma
	Invoke	NeedToken
	jmp	@@1
@@2:	pop	di
	mov	al,tCParen
	Invoke	NeedToken
	lea	bx,Buffer
	Invoke	FlushGoals
@@3:	Exit

GetActualParam	proc	near
	mov	al,es:[si].ppFlags
	mov	bx,es:[si].ppType.Segm
	mov	si,es:[si].ppType.Offs
	mov	es,es:[bx]
	mov	ParamType.offs,si
	mov	ParamType.segm,es
	lea	di,Param
	test	al,vfAddress
	jnz	@@6
	lea	si,ParamType
	Invoke	GetExpression
	lea	si,ParamType
	Invoke	AssignmentCast
	call	TypeCompat
	call	CastOrdinal
	les	bx,[di].exType
	mov	al,es:[bx].tdType
	cmp	al,ttInteger
	jae	@@1
	cmp	al,ttPointer
	je	@@1
	cmp	al,ttProc
	je	@@1
	cmp	al,ttSet
	je	@@2
	cmp	al,ttString
	je	@@3
	cmp	al,tt8087
	je	@@4
	cmp	al,ttReal
	je	@@5
	call	ShortRecord
	jnz	@@10
@@1:	Invoke	PushValue
	jmp	short @@11
@@2:	Invoke	_LoadSet
	call	NeedCopyParam
	jz	@@10
	Invoke	LoadSet
	jmp	short @@10
@@3:	Invoke	PutImmedString
	call	NeedCopyParam
	jz	@@10
	Invoke	_LoadString
	jmp	short @@10
@@4:	Invoke	PushFloat
	jmp	short @@11
@@5:	Invoke	PushReal
	jmp	short @@11
@@6:	Invoke	GetReference
	les	bx,ParamType
	mov	al,es:[bx].tdType
	cmp	al,ttVoid
	je	@@10
	cmp	al,ttString
	je	@@7
	cmp	al,ttObject
	jne	@@9
	mov	ax,bx
	mov	dx,es
	les	bx,[di].exType
	Invoke	CheckInherit
	jz	@@10
	jmp	short @@8
@@7:	test	CompilerOptions,coVarStringChk
	jnz	@@9
	les	bx,[di].exType
	cmp	es:[bx].tdType,ttString
	je	@@10
@@8:	mov	ax,26
	Chain	CompileError
@@9:	cmp	bx,[di].exType.Offs
	jne	@@8
	mov	ax,es
	cmp	ax,[di].exType.Segm
	jnz	@@8
@@10:	Invoke	PushAddr
@@11:	mov	ax,[di].exCode
	lea	bx,Buffer
	Chain	AddGoal
GetActualParam	endp

GetActualParams	endp

NeedCopyParam	proc	near
	test	CompilerOptions,coOverlayCode
	jz	@@1
	cmp	[di].exLocation,elStack
	je	@@1
	test	[di].exMisc,efCS
@@1:	ret
NeedCopyParam	endp

TypeCompat	proc	near
	les	bx,[di].exType
	mov	al,es:[bx].tdType
	les	bx,[si].exType
	cmp	al,es:[bx].tdType
	jne	@@1
	mov	bl,al
	xor	bh,bh
	shl	bx,1
	call	cs:@@2[bx]
	jnz	@@1
	ret
@@1:	mov	ax,26
	Chain	CompileError
@@2	dw	StrictCompat
	dw	StrictCompat
	dw	StrictCompat
	dw	StrictCompat
	dw	StrictCompat
	dw	StrictCompat
	dw	ProcCompat
	dw	SetCompat
	dw	PointerCompat
	dw	AnyCompat
	dw	AnyCompat
	dw	AnyCompat
	dw	AnyCompat
	dw	AnyCompat
	dw	AnyCompat
	dw	EnumCompat
TypeCompat	endp

AnyCompat	proc	near
	xor	ax,ax
	ret
AnyCompat	endp

StrictCompat	proc	near
	mov	ax,[di].exType.Offs
	cmp	ax,[si].exType.Offs
	jne	@@1
	mov	ax,[di].exType.Segm
	cmp	ax,[si].exType.Segm
@@1:	ret
StrictCompat	endp

ProcCompat	proc	near
	push	si di ds
	les	di,[di].exType
	lds	si,[si].exType
	cmpsw
	jne	@@2
	cmpsw
	jne	@@2
	cmpsw
	call	ParamCompat
	jnz	@@2
	lodsw
	scasw
	jne	@@2
	xchg	ax,cx
	jcxz	@@2
@@1:	call	ParamCompat
	jnz	@@2
	cmpsb
	jne	@@2
	loop	@@1
@@2:	pop	ds di si
	ret
ProcCompat	endp

ParamCompat	proc	near
	cmpsw
	jne	@@1
	lodsw
	mov	bx,es:[di]
	inc	di
	inc	di
	or	ax,ax
	jz	@@1
	mov	bx,es:[bx]
	xchg	ax,bx
	cmp	ax,[bx]
@@1:	ret
ParamCompat	endp

SetCompat	proc	near
	les	bx,[di].exType
	cmp	es:[bx].stBase.Offs,0
	je	@@2
	mov	cx,es:[bx].stBase.Offs
	mov	bx,es:[bx].stBase.Segm
	mov	es,es:[bx]
	mov	bx,cx
	mov	ax,es:[bx].itBase.Offs
	mov	bx,es:[bx].itBase.Segm
	mov	dx,es:[bx]
	les	bx,[si].exType
	cmp	es:[bx].stBase.Offs,0
	je	@@1
	mov	cx,es:[bx].stBase.Offs
	mov	bx,es:[bx].stBase.Segm
	mov	es,es:[bx]
	mov	bx,cx
	cmp	ax,es:[bx].itBase.Offs
	jne	@@1
	mov	bx,es:[bx].itBase.Segm
	cmp	dx,es:[bx]
@@1:	ret
@@2:	mov	ax,[si].exType.Offs
	mov	[di].exType.Offs,ax
	mov	ax,[si].exType.Segm
	mov	[di].exType.Segm,ax
	ret
SetCompat	endp

PointerCompat	proc	near
	call	StrictCompat
	jz	@@1
	les	bx,[si].exType
	mov	ax,es:[bx].ptBase.Offs
	mov	bx,es:[bx].ptBase.Segm
	mov	es,es:[bx]
	mov	bx,ax
	cmp	es:[bx].tdSizeOf,0
	je	@@1
	mov	dx,es
	les	bx,[di].exType
	mov	cx,es:[bx].ptBase.Offs
	mov	bx,es:[bx].ptBase.Segm
	mov	es,es:[bx]
	mov	bx,cx
	cmp	es:[bx].tdSizeOf,0
	jne	@@1
	mov	ax,[si].exType.Offs
	mov	[di].exType.Offs,ax
	mov	ax,[si].exType.Segm
	mov	[di].exType.Segm,ax
@@1:	ret
PointerCompat	endp

EnumCompat	proc	near
	les	bx,[di].exType
	mov	ax,es:[bx].itBase.Offs
	mov	bx,es:[bx].itBase.Segm
	mov	dx,es:[bx]
	les	bx,[si].exType
	cmp	ax,es:[bx].itBase.Offs
	jne	@@1
	mov	bx,es:[bx].itBase.Segm
	cmp	dx,es:[bx]
@@1:	ret
EnumCompat	endp

CastOrdinal	proc	near
	les	bx,[si].exType
	cmp	es:[bx].tdType,ttInteger
	jae	_Cast
	ret
CastOrdinal	endp

CastByte	proc	near
	mov	bx,_Byte
	mov	es,SystemUnit
	jmp	short _Cast
CastByte	endp

CastInt	proc	near
	mov	bx,_Integer
	mov	es,SystemUnit
	jmp	short _Cast
CastInt	endp

CastWord	proc	near
	mov	bx,_Word
	mov	es,SystemUnit
	jmp	short _Cast
CastWord	endp

CastLong	proc	near
	mov	bx,_Longint
	mov	es,SystemUnit
_Cast	label	near
	cmp	[di].exLocation,elImmediate
	jne	@@2
	mov	ax,[di].itUpperBound.W0
	mov	dx,[di].itUpperBound.W2
	call	ImmedRangeCheck
	jc	@@1
	mov	al,es:[bx].tdModifier
	or	al,IndexModifier
	mov	[di].exModifier,al
	ret
@@1:	mov	ax,76
	Chain	CompileError
@@2:	test	CompilerOptions,coRangeChk
	jnz	@@4
@@3:	mov	al,es:[bx].tdModifier
	or	al,IndexModifier
	Chain	ConvertOrdinal
@@4:	xor	ax,ax
	mov	dx,ax
	test	[di].exModifier,emSigned
	jz	@@5
	mov	ax,-128
	dec	dx
	test	[di].exModifier,emX
	jz	@@5
	mov	ax,-32768
	test	[di].exModifier,emXX
	jz	@@5
	xchg	ax,dx
	inc	ax
@@5:	call	ImmedRangeCheck
	jc	@@8
	mov	ax,127
	xor	dx,dx
	test	[di].exModifier,emUnsigned
	jz	@@6
	mov	al,255
@@6:	test	[di].exModifier,emX
	jz	@@7
	mov	ah,al
	mov	al,255
	test	[di].exModifier,emXX
	jz	@@7
	mov	dx,ax
	mov	ax,65535
@@7:	call	ImmedRangeCheck
	jnc	@@3
@@8:	push	es bx
	push	es:[bx].itUpperBound
	push	es:[bx].itLowerBound
	mov	bx,sp
	mov	ax,8
	Invoke	PutCodeConst
	push	ax bx dx
	mov	al,emLongint
	Invoke	ConvertOrdinal
	Invoke	UseExpr
	mov	al,lvAX
	Invoke	LoadValue
	mov	al,0bfh			; mov	ax,
	Invoke	PutByte
	pop	dx bx ax
	mov	cx,ffCode+ffOffs
	Invoke	PutFixup
	mov	ax,_RangeCheck
	Invoke	PutSystemCall
	Invoke	DoneExpr
	add	sp,8
	pop	bx es
	jmp	@@3
CastLong	endp

ImmedRangeCheck	proc	near
	cmp	dx,es:[bx].itLowerBound.W2
	jg	@@1
	jl	@@3
	cmp	ax,es:[bx].itLowerBound.W0
	jb	@@3
@@1:	cmp	dx,es:[bx].itUpperBound.W2
	jl	@@2
	jg	@@3
	cmp	ax,es:[bx].itUpperBound.W0
	ja	@@3
@@2:	clc
	ret
@@3:	stc
	ret
ImmedRangeCheck	endp

	end
