declare.asm

Turbo Pascal 6.0编译器源码

	mov	al,2
	test	es:[di].psFlags,pfMethod
	jz	@@1
	mov	al,4
	test	es:[di].psFlags,pfConstructor+pfDestructor
	jz	@@1
	mov	al,6
@@1:	mov	cx,es:[di].psType.ptParamCount
	jcxz	@@3
	push	di
	add	di,psType.ptParams
@@2:	push	cx
	push	ax es di
	mov	al,es:[di].ppFlags
	xor	ah,ah
	mov	bx,es:[di].ppType.Segm
	mov	di,es:[di].ppType.Offs
	mov	es,es:[bx]
	call	ParamSize
	pop	di es ax
	add	ax,cx
	pop	cx
	add	di,size TProcParam
	loop	@@2
	pop	di
@@3:	mov	dx,ax
	test	es:[di].psFlags,pfInterrupt
	jnz	@@4
	add	dx,4
	test	es:[di].psFlags,pfFar
	jz	@@4
	inc	dx
	inc	dx
@@4:	ret
StackRequired	endp

ParamSize	proc	near
	xor	dx,dx
	test	al,vfAddress
	jnz	@@3
	mov	bl,es:[di].tdType
	mov	cx,es:[di].tdSizeOf
	cmp	bl,tt8087
	jae	@@1
	cmp	bl,ttString
	je	@@2
	cmp	bl,ttPointer
	je	@@1
	cmp	bl,ttSet
	je	@@2
	cmp	cx,1
	je	@@1
	cmp	cx,2
	je	@@1
	cmp	cx,4
	jne	@@2
@@1:	inc	cx
	and	cx,0fffeh
	ret
@@2:	or	ah,ah
	jnz	@@4
	mov	dx,cx
@@3:	mov	cx,4
	ret
@@4:	or	al,vfAddress
	cmp	bl,ttSet
	jne	@@3
	mov	bx,es:[di].stBase.Segm
	mov	di,es:[di].stBase.Offs
	mov	es,es:[bx]
	mov	bx,es:[di].itBase.Segm
	mov	di,es:[di].itBase.Offs
	mov	es,es:[bx]
	add	di,size TOrdinalType
	jmp	@@3
ParamSize	endp

LocalSize	proc	near
	xor	ax,ax
	mov	dx,ax
	mov	bx,es:[di].psType.ptResult.Segm
	or	bx,bx
	jz	@@2
	test	es:[di].psFlags,pfAssembler
	jnz	@@2
	push	es di
	mov	di,es:[di].psType.ptResult.Offs
	mov	es,es:[bx]
	cmp	es:[di].tdType,ttString
	je	@@1
	sub	ax,es:[di].tdSizeOf
@@1:	pop	di es
@@2:	ret
LocalSize	endp

FlushProcMap	proc	near
	push	es di bx
	mov	ax,size TProcMap
	lea	bx,ProcMap
	Invoke	GetMemory
	pop	bx
	mov	dx,di
	xor	ax,ax
	stosw
	stosw
	dec	ax
	stosw
	mov	ax,bx
	stosw
	pop	di es
	mov	es:[di].psProcMap,dx
	ret
FlushProcMap	endp

FlushCodeMap	proc	near
	mov	ax,size TSegMap
	lea	bx,CodeMap
	Invoke	GetMemory
	xor	ax,ax
	stosw
	mov	ax,CompiledCode.Offs
	sub	ax,CodeSectStart
	stosw
	mov	ax,CodeFixups.Offs
	sub	ax,LastCodeFixup
	stosw
	mov	ax,LastTraceTable
	cmp	ax,TraceTable.Offs
	jne	@@1
	mov	ax,-1
@@1:	stosw
	mov	ax,CompiledCode.offs
	mov	CodeSectStart,ax
	mov	ax,CodeFixups.Offs
	mov	LastCodeFixup,ax
	mov	ax,TraceTable.Offs
	mov	LastTraceTable,ax
	ret
FlushCodeMap	endp

FlushConstMap		 proc near
	Invoke	WordAlignConst
	mov	ax,CompiledConst.Offs
	sub	ax,ConstSectStart
	jnz	@@1
	cmp	FirstOnConst,0
	je	@@2
@@1:	mov	FirstOnConst,0
	push	ax
	mov	ax,size TSegMap
	lea	bx,ConstMap
	Invoke	GetMemory
	xor	ax,ax
	stosw
	pop	ax
	stosw
	mov	ax,ConstFixups.Offs
	sub	ax,LastConstFixup
	stosw
	mov	ax,CurOwner
	stosw
	mov	ax,CompiledConst.Offs
	mov	ConstSectStart,ax
	mov	ConstSectStart2,ax
	mov	ax,ConstFixups.Offs
	mov	LastConstFixup,ax
@@2:	ret
FlushConstMap	endp

FlushDataMap		 proc near
	mov	ax,VarsSize
	inc	ax
	jz	@@3
	and	ax,0fffeh
	mov	VarsSize,ax
	sub	ax,DataSectStart
	jnz	@@1
	cmp	FirstOnData,0
	je	@@2
@@1:	mov	FirstOnData,0
	push	ax
	mov	ax,size TSegMap
	lea	bx,DataMap
	Invoke	GetMemory
	xor	ax,ax
	stosw
	pop	ax
	stosw
	xor	ax,ax
	stosw
	stosw
	mov	ax,VarsSize
	mov	DataSectStart,ax
@@2:	ret
@@3:	mov	ax,96
	Chain	CompileError
FlushDataMap	endp

GetTypeNoForw	proc	near
	mov	ForwardTypes,0
	call	GetTypeNoObj
	push	es di
	Invoke	GetDirective
	call	ResolveForward
	pop	di es
	ret
GetTypeNoForw	endp

GetType	proc	near
	cmp	CurrentToken,tObject
	jne	GetTypeNoObj
	jmp	ObjectType
GetType	endp

GetTypeNoObj	proc	near
	mov	al,tPacked
	Invoke	CheckToken
	Invoke	GetSymbol
	lea	bx,@@2
	Invoke	ChooseToken
	jnz	@@1
	jmp	word ptr cs:[bx+1]
@@1:	mov	ax,21
	Chain	CompileError
@@2	db	16,3
	db	t_Type
	dw	TypeName
	db	tArray
	dw	ArrayType
	db	tRecord
	dw	RecordType
	db	tCaret
	dw	PointerType
	db	tString
	dw	StringType
	db	tFile
	dw	FileType
	db	tSet
	dw	SetType
	db	tOParen
	dw	EnumType
	db	tProcedure
	dw	ProcedureType
	db	tFunction
	dw	ProcedureType
	db	t_Constant
	dw	RangeType
	db	t_Const
	dw	RangeType
	db	tMinus
	dw	RangeType
	db	tPlus
	dw	RangeType
	db	t_StdFun
	dw	RangeType
	db	tNot
	dw	RangeType
GetTypeNoObj	endp

_GetTypeName	proc	near
	Invoke	GetSymbol
	cmp	CurrentToken,t_StdType
	je	TypeName
GetTypeName	label	near
	mov	al,CurrentToken
	mov	di,_String
	cmp	al,tString
	je	@@1
	mov	di,_File
	cmp	al,tFile
	jne	@@2
@@1:	mov	es,SystemUnit
	Chain	GetToken
@@2:	Invoke	GetSymbol
	cmp	CurrentToken,t_Type
	je	TypeName
	mov	ax,12
	Chain	CompileError
_GetTypeName	endp

TypeName	proc	near
	les	di,CurrentSymbol
	mov	bx,es:[di].tsType.Segm
	mov	di,es:[di].tsType.Offs
	mov	es,es:[bx]
	Chain	GetToken
TypeName	endp

ArrayType	proc	near
	Invoke	GetToken
	mov	al,tOBracket
	Invoke	NeedToken
	xor	cx,cx
@@1:	push	cx
	call	GetBound
	pop	cx
	push	es di
	inc	cx
	mov	al,tComma
	Invoke	CheckToken
	jz	@@1
	push	cx
	mov	al,tCBracket
	Invoke	NeedToken
	mov	al,tOf
	Invoke	NeedToken
	call	GetTypeNoObj
	pop	cx
@@2:	call	_SearchUnit
	mov	bx,es:[di].tdSizeOf
	pop	di es
	push	cx dx ax
	mov	ax,es:[di].itUpperBound.W0
	sub	ax,es:[di].itLowerBound.W0
	inc	ax
	jz	@@3
	mul	bx
	jc	@@3
	mov	bx,ax
	call	_SearchUnit
	push	dx ax
	mov	ax,size TArrayType
	mov	cx,ttArray
	call	PutTypePrefix
	pop	es:[di].atBounds
	pop	es:[di].atBase
	pop	cx
	loop	@@2
	ret
@@3:	mov	ax,22
	Chain	CompileError
ArrayType	endp

RecordType	proc	near
	push	ForwardTypes PrevField FirstVar VarCount
	mov	ax,size TRecordType
	xor	bx,bx
	mov	cx,ttRecord
	call	PutTypePrefix
	mov	CurOwner,di
	mov	ax,Dictionary.Offs
	mov	es:[di].rtHash,ax
	mov	es:[di].rtFirst,0
	lea	ax,[di].rtFirst
	mov	PrevField,ax
	push	es di
	mov	ax,4
	Invoke	CreateHashTable
	mov	ax,tRecord+tEnd*256
	call	RecordSection
	pop	di es
	xor	ax,ax
	mov	CurOwner,ax
	pop	VarCount FirstVar PrevField ForwardTypes
	ret
RecordType	endp

RecordSection	proc	near
	Loc	EndingToken,byte,2
	Loc	Temp,byte,<size TExpr>
	Entry
	mov	EndingToken,ah
	Invoke	NeedToken
@@1:	mov	al,CurrentToken
	cmp	al,EndingToken
	je	@@8
	mov	al,tCase
	Invoke	CheckToken
	jz	@@2
	call	RecordGroup
	mov	al,tSemicolon
	Invoke	CheckToken
	jz	@@1
	jmp	short @@8
@@2:	Invoke	NeedIdent
	Invoke	SearchSymbol
	jnz	@@3
	cmp	al,t_Type
	jnz	@@3
	Invoke	GetToken
	jmp	short @@4
@@3:	call	RecordGroup
@@4:	mov	al,tOf
	Invoke	NeedToken
	mov	es,Dictionary.Segm
	mov	di,CurOwner
	mov	dx,es:[di].tdSizeOf
@@5:	mov	ax,dx
	xchg	ax,es:[di].tdSizeOf
	push	ax dx es di
@@6:	lea	di,Temp
	call	GetConstExpr
	mov	al,tComma
	Invoke	CheckToken
	jz	@@6
	mov	al,tColon
	Invoke	NeedToken
	mov	ax,tOParen+tCParen*256
	call	RecordSection
	pop	di es dx ax
	cmp	ax,es:[di].tdSizeOf
	jbe	@@7
	mov	es:[di].tdSizeOf,ax
@@7:	mov	al,tSemicolon
	Invoke	CheckToken
	jnz	@@8
	mov	al,CurrentToken
	cmp	al,EndingToken
	jne	@@5
@@8:	mov	al,EndingToken
	Invoke	NeedToken
	Exit
RecordSection	endp

RecordGroup	proc	near
	call	GetVarList
	mov	al,tColon
	Invoke	NeedToken
	push	CurOwner
	xor	ax,ax
	mov	CurOwner,ax
	call	GetVarType
	pop	CurOwner
	mov	TempStub.vsFlags,vfField
	xor	ax,ax
	mov	TempStub.vsScope,ax
	jmp	FillVarTypes
@@1:	mov	ax,22
	Chain	CompileError
RecordGroup	endp

ObjectType	proc	near
	push	ForwardTypes
	cmp	CurScope,0
	jne	@@1
	Invoke	GetToken
	push	bx
	mov	ax,size TObjectType
	xor	bx,bx
	mov	cx,ttObject
	call	PutTypePrefix
	pop	es:[di].otName
	mov	es:[di].otReserved3.Offs,ax
	mov	es:[di].otReserved3.Segm,ax
	mov	CurOwner,di
	mov	al,tOParen
	Invoke	CheckToken
	jnz	@@3
	call	GetTypeName
	cmp	es:[di].tdType,ttObject
	jne	@@2
	mov	al,tCParen
	Invoke	NeedToken
	push	es:[di].otReserved2
	push	es:[di].otVMTOffset
	push	es:[di].otVMTSize
	push	es:[di].tdSizeOf
	call	_SearchUnit
	jmp	short @@4
@@1:	mov	ax,148
	Chain	CompileError
@@2:	mov	ax,147
	Chain	CompileError
@@3:	xor	ax,ax
	xor	dx,dx
	push	ax
	dec	ax
	push	ax
	inc	ax
	push	ax ax
@@4:	mov	es,Dictionary.Segm
	mov	di,CurOwner
	pop	es:[di].tdSizeOf
	pop	es:[di].otVMTSize
	pop	es:[di].otVMTOffset
	pop	es:[di].otReserved2
	mov	es:[di].otParent.Offs,ax
	mov	es:[di].otParent.Segm,dx
	xor	ax,ax
	mov	es:[di].rtFirst,ax
	mov	es:[di].otReserved3.Offs,ax
	mov	es:[di].otReserved3.Segm,ax
	dec	ax
	mov	es:[di].otVMTAddr,ax
	mov	es:[di].otReserved,ax
	mov	ax,Dictionary.Offs
	mov	es:[di].rtHash,ax
	lea	ax,[di].rtFirst
	mov	PrevField,ax
	xor	ax,ax
	mov	DummyCount,ax
	push	es di
	mov	ax,4
	Invoke	CreateHashTable
	call	ObjectGroup
	mov	al,tPrivate
	Invoke	CheckToken
	jnz	@@5
	mov	PrivateFlag,t_Private
	call	ObjectGroup
	mov	PrivateFlag,0
@@5:	mov	al,tEnd
	Invoke	NeedToken
	pop	di es
	call	PutVMT
	xor	ax,ax
	mov	CurOwner,ax
	pop	ForwardTypes
	ret
ObjectType	endp

	HValue	PRIVATE,128

ObjectGroup	proc	near
@@1:	xor	cx,cx
@@2:	mov	al,@HS
	lea	di,PrivateStr
	Invoke	CompareSymbol
	jnz	@@3
	mov	CurrentToken,tPrivate
@@3:	mov	al,CurrentToken
	cmp	al,tProcedure
	je	@@5
	cmp	al,tFunction
	je	@@5
	cmp	al,tConstructor
	je	@@4
	cmp	al,tDestructor
	je	@@4
	or	cx,cx
	jnz	@@6
	cmp	al,tPrivate
	je	@@6
	cmp	al,tEnd
	je	@@6
	call	RecordGroup
	mov	al,tSemicolon
	Invoke	NeedToken
	jmp	@@1
@@4:	call	InitVMT
@@5:	call	Method
	mov	cx,-1
	jmp	@@2
@@6:	ret
ObjectGroup	endp

InitVMT	proc	near
	mov	es,Dictionary.Segm
	mov	di,CurOwner
	cmp	es:[di].otVMTSize,0
	jne	@@1
	mov	es:[di].otVMTSize,4
@@1:	ret
InitVMT	endp

Method	proc	near
	Loc	CurMethod,dword,1
	Loc	OldMethod,dword,1
	Entry
	push	ax
	Invoke	GetToken
	Invoke	NeedIdent
	Invoke	LocalSearch
	jnz	@@2
	cmp	al,t_Proc
	jne	@@1
	mov	ax,es
	cmp	ax,Dictionary.Segm
	jne	@@3
	mov	ax,es:[di].psScope
	cmp	ax,CurOwner
	jne	@@3
@@1:	mov	ax,4
	Chain	CompileError
@@2:	xor	di,di
	mov	es,di
@@3:	mov	OldMethod.Offs,di
	mov	OldMethod.Segm,es
	mov	ax,size TProcStub
	Invoke	LocalAddIdent
	Invoke	GetToken
	mov	CurMethod.Offs,di
	mov	CurMethod.Segm,es
	mov	al,PrivateFlag
	or	al,t_Proc
	mov	es:[bx].seType,al
	mov	ax,CurOwner
	mov	es:[di].psScope,ax
	mov	ax,TempDict.Offs
	mov	es:[di].psHash,ax
	mov	si,PrevField
	mov	es:[si],bx
	lea	si,[di].psType.tdNext
	mov	PrevField,si
	call	FlushProcMap
	pop	ax
	mov	ah,pfFar+pfMethod+pfConstructor
	cmp	al,tConstructor
	je	@@4
	mov	ah,pfFar+pfMethod+pfDestructor
	cmp	al,tDestructor
	je	@@4
	mov	ah,pfFar+pfMethod
@@4:	mov	es:[di].psFlags,ah
	call	GetProcHeader
	mov	al,tSemicolon
	Invoke	NeedToken
	les	di,OldMethod
	or	di,di
	jz	@@5
	cmp	es:[di].psOwner,0
	je	@@5
	call	Override
	jmp	short @@6
@@5:	call	NewMethod
@@6:	les	di,CurMethod
	mov	es:[di].psOwner,ax
	Exit

Override	proc	near
	mov	al,tVirtual
	Invoke	CheckDirective
	jnz	@@1
	les	di,OldMethod
	mov	al,es:[di].psFlags
	les	di,CurMethod
	xor	al,es:[di].psFlags
	and	al,pfConstructor+pfDestructor
	jnz	@@2
	lea	di,CurMethod
	lea	si,OldMethod
	add	[di].Offs,psType
	add	[si].Offs,psType
	Invoke	ProcCompat
	jnz	@@2
	sub	[di].Offs,psType
	sub	[si].Offs,psType
	mov	al,tSemicolon
	Invoke	NeedToken
	les	di,OldMethod
	mov	ax,es:[di].psOwner
	ret
@@1:	mov	ax,149
	Chain	CompileError
@@2:	mov	ax,131
	Chain	CompileError
Override	endp

NewMethod	proc	near
	mov	al,tVirtual
	Invoke	CheckDirective
	mov	ax,0
	jnz	@@1
	les	di,CurMethod
	test	es:[di].psFlags,pfConstructor
	jnz	@@2
	mov	al,tSemicolon
	Invoke	NeedToken
	call	InitVMT
	mov	ax,es:[di].otVMTSize
	add	es:[di].otVMTSize,4
@@1:	ret
@@2:	mov	ax,151
	Chain	CompileError
NewMethod	endp

Method	endp

PutVMT	proc	near
	mov	ax,es:[di].otVMTSize
	or	ax,ax
	jnz	@@1
	ret
@@1:	mov	dx,es:[di].tdSizeOf
	cmp	es:[di].otVMTOffset,-1
	jne	@@2
	mov	es:[di].otVMTOffset,dx
	inc	dx
	inc	dx
	mov	es:[di].tdSizeOf,dx
@@2:	push	es di
	mov	cx,ax
	lea	bx,CompiledConst
	Invoke	GetMemory
	mov	ConstPtr,di
	mov	ax,dx
	stosw
	neg	ax
	stosw
	sub	cx,4
	mov	al,-1
	rep	stosb
	pop	di es
	mov	ax,ConstMap.Offs
	mov	es:[di].otVMTAddr,ax
	push	es di
@@3:	push	di
	mov	di,es:[di].rtFirst
	jmp	short @@8
@@4:	mov	al,es:[di].seType
	mov	bl,es:[di].seName.B0
	xor	bh,bh
	lea	di,[di+size TSymbol+bx]
	and	al,not t_Private
	cmp	al,t_Var
	jne	@@5
	mov	di,es:[di].vsNext
	jmp	short @@8
@@5:	mov	si,es:[di].psOwner
	or	si,si
	jz	@@7
	mov	ax,es
	mov	bx,es:[di].psProcMap
	mov	cx,ffProc+ffPtr
	xor	dx,dx
	add	si,ConstPtr
	push	es
	mov	es,CompiledConst.Segm
	cmp	dx,es:[si].Offs
	je	@@6
	mov	es:[si].Offs,dx
	mov	es:[si].Segm,dx
	Invoke	PutConstFixup
@@6:	pop	es
@@7:	mov	di,es:[di].psType.tdNext
@@8:	or	di,di
	jnz	@@4
	pop	di
	mov	bx,es:[di].otParent.Segm
	or	bx,bx
	jz	@@9
	mov	di,es:[di].otParent.Offs
	mov	es,es:[bx]
	jmp	@@3
@@9:	call	FlushConstMap
	pop	di es
	ret
PutVMT	endp

ProcedureType	proc	near
	Invoke	GetToken
	push	TempDict.Offs
	call	GetProcHeader
	pop	TempDict.Offs
	ret
ProcedureType	endp

GetProcHeader	proc	near
	push	ax
	mov	ax,size TProcType
	mov	bx,4
	mov	cx,ttProc+emLongint*256
	call	PutTypePrefix
	xor	ax,ax
	mov	es:[di].ptResult.Offs,ax
	mov	es:[di].ptResult.Segm,ax
	mov	es:[di].ptParamCount,ax