declare.asm

Turbo Pascal 6.0编译器源码

	model	large compiler_text,pascal
	include	compiler.inc

	.data
SelfStr		db	4,'SELF'
PrivateStr	db	7,'PRIVATE'
FirstOnConst	db	0
FirstOnData	db	0

	.data?

ForwardTypes	dw	?
NameListPtr	dw	?
PrevField	dw	?
ConstPtr	dw	?
DummyCount	dw	?
FirstVar	dw	?
VarCount	dw	?
VarSize		dw	?
TempStub	TVarStub	<>

	.code	compiler_text

	public	DeclarationPart
	public	CheckUndefs
	public	Number2Ident
	public	StackRequired
	public	ParamSize
	public	FlushProcMap
	public	FlushCodeMap
	public	FlushConstMap
	public	FlushDataMap
	public	GetTypeName
	public	SearchUnit
	public	GetConstExpr
	public	GetIntConstExpr
	public	FitConstType
	public	IntExtension

DeclarationPart	proc	near
@@1:	mov	ax,GlobalOptions
	mov	CompilerOptions,ax
	lea	bx,@@4
	Invoke	ChooseToken
	jz	@@2
	cmp	ProgramSection,psInterface
	je	@@3
	lea	bx,@@5
	Invoke	ChooseToken
	jnz	@@3
@@2:	call	word ptr cs:[bx+1]
	jmp	@@1
@@3:	ret
@@4	db	5,3
	db	tConst
	dw	ConstDecl
	db	tType
	dw	TypeDecl
	db	tVar
	dw	VarDecl
	db	tProcedure
	dw	ProcDecl
	db	tFunction
	dw	ProcDecl
@@5	db	3,3
	db	tLabel
	dw	LabelDecl
	db	tConstructor
	dw	ProcDecl
	db	tDestructor
	dw	ProcDecl
DeclarationPart	endp

CheckUndefs	proc	near
	mov	di,size TProcMap
CheckLocUndefs	label	near
	les	dx,ProcMap
	mov	ax,-1
	jmp	short @@2
@@1:	cmp	ax,es:[di].pmCodeMap
	je	@@3
	add	di,size TProcMap
@@2:	cmp	di,dx
	jne	@@1
	ret
@@3:	mov	di,es:[di].pmEntryPoint
	mov	es,Dictionary.Segm
	lea	si,IdentBuf
	mov	bl,es:[di].seName.B0
	mov	bh,0
	mov	dl,es:[di+size TSymbol+bx].psFlags
	test	dl,pfMethod
	jz	@@4
	push	di
	mov	di,es:[di+size TSymbol+bx].psScope
	mov	di,es:[di].otName
	add	di,seName
	Invoke	Pas2C
	mov	byte ptr [si-1],'.'
	pop	di
@@4:	add	di,seName
	Invoke	Pas2C
	mov	ax,59
	test	dl,pfExternal
	jz	@@5
	mov	ax,46
@@5:	lea	dx,IdentBuf
	Chain	ParamError2
CheckUndefs	endp

Number2Ident	proc	near
	cmp	CurrentToken,t_Constant
	jne	@@2
	cmp	SymbolType.Offs,_Longint
	jne	@@2
	mov	ax,SymbolValue.W0
	mov	dx,SymbolValue.W2
	or	dx,dx
	jnz	@@2
	or	ax,ax
	jl	@@2
	cmp	ax,9999
	jg	@@2
	mov	bx,4
	xor	cx,cx
	mov	di,10
	mov	IdentBuf[0],bl
@@1:	cwd
	div	di
	add	dl,'0'
	mov	IdentBuf[bx],dl
	dec	dl
	add	cl,dl
	dec	bx
	jnz	@@1
	shl	cl,1
	mov	SymbolHash,cl
	mov	CurrentToken,t_Ident
@@2:	ret
Number2Ident	endp

LabelDecl	proc	near
	Invoke	GetToken
@@1:	call	Number2Ident
	mov	ax,size TLabelStub
	Invoke	AddIdent2Dict
	mov	es:[bx].seType,t_Label
	mov	al,tComma
	Invoke	CheckToken
	jz	@@1
	mov	al,tSemicolon
	Chain	NeedToken
LabelDecl	endp

ConstDecl	proc	near
	Loc	Temp,byte,<size TExpr>
	Entry
	Invoke	GetToken
@@1:	xor	ax,ax
	Invoke	AddIdent2Dict
	mov	al,tColon
	Invoke	CheckToken
	jnz	@@3
	push	bx
	mov	ax,size TVarStub
	Invoke	GetDictMem
	push	es di
	mov	EqualToken,tConstEqual
	call	GetTypeNoForw
	mov	EqualToken,tEqual
	test	GlobalOptions,coWordAlign
	jz	@@2
	cmp	es:[di].tdSizeOf,1
	je	@@2
	Invoke	WordAlignConst
@@2:	mov	FirstOnConst,1
	mov	TempStub.vsFlags,vfConst
	mov	ax,CompiledConst.Offs
	sub	ax,ConstSectStart
	mov	TempStub.vsOffset,ax
	mov	ax,ConstMap.Offs
	mov	TempStub.vsMap,ax
	call	_SearchUnit
	mov	TempStub.vsType.Offs,ax
	mov	TempStub.vsType.Segm,dx
	mov	al,tConstEqual
	Invoke	NeedToken
	call	GetInitializer
	pop	di es bx
	mov	es:[bx].seType,t_Var
	lea	si,TempStub
	mov	cx,size TVarStub
	rep	movsb
	jmp	short @@5
@@3:	push	es bx
	mov	al,tEqual
	Invoke	NeedToken
	lea	di,Temp
	call	GetConstExpr
	pop	bx es
	mov	es:[bx].seType,t_Const
	lea	si,[di].exValue
	les	di,[di].exType
	mov	al,es:[di].tdType
	mov	cx,4
	cmp	al,ttInteger
	jae	@@4
	cmp	al,ttPointer
	je	@@4
	mov	cl,10
	cmp	al,tt8087
	je	@@4
	mov	si,[si].Offs
	mov	cl,32
	cmp	al,ttSet
	je	@@4
	mov	cl,[si]
	inc	cx
@@4:	call	_SearchUnit
	push	dx ax
	mov	ax,size TConstStub
	add	ax,cx
	Invoke	GetDictMem
	pop	ax
	stosw
	pop	ax
	stosw
	rep	movsb
@@5:	mov	al,tSemicolon
	Invoke	NeedToken
	cmp	CurrentToken,t_Ident
	jne	@@6
	jmp	@@1
@@6:	call	FlushConstMap
	Exit
ConstDecl	endp

TypeDecl	proc	near
	Invoke	GetToken
	mov	ForwardTypes,0
@@1:	mov	ax,size TTypeStub
	Invoke	AddIdent2Dict
	push	bx di es
	mov	al,tEqual
	Invoke	NeedToken
	call	GetStdType
	call	GetType
	call	_SearchUnit
	pop	es di bx
	mov	es:[bx].seType,t_Type
	stosw
	mov	ax,dx
	stosw
	mov	al,tSemicolon
	Invoke	NeedToken
	cmp	CurrentToken,t_Ident
	je	@@1
ResolveForward	label	near
@@2:	mov	di,ForwardTypes
	or	di,di
	jz	@@3
	mov	es,Dictionary.Segm
	mov	di,es:[di].ptBase.Segm
	mov	es,TempDict.Segm
	Invoke	CalcHash
	Invoke	SearchSymbol
	jnz	@@4
	cmp	al,t_Type
	jne	@@4
	mov	bx,es:[di].tsType.Segm
	mov	di,es:[di].tsType.Offs
	mov	es,es:[bx]
	call	_SearchUnit
	mov	di,ForwardTypes
	mov	es,Dictionary.Segm
	xchg	ax,es:[di].ptBase.Offs
	mov	es:[di].ptBase.Segm,dx
	mov	ForwardTypes,ax
	jmp	@@2
@@3:	ret
@@4:	mov	ax,19
	Chain	IdentError
TypeDecl	endp

GetStdType	proc	near
	mov	al,CurrentToken
	cmp	al,tObject
	je	@@1
	cmp	al,tProcedure
	je	@@1
	cmp	al,tFunction
	je	@@1
	ret
@@1:	mov	es:[bx].seType,t_StdType
	push	es di
	les	di,Dictionary
	call	_SearchUnit
	pop	di es
	stosw
	mov	ax,dx
	stosw
	ret
GetStdType	endp

VarDecl	proc	near
	Invoke	GetToken
@@1:	call	GetVarList
	mov	al,tColon
	Invoke	NeedToken
	call	GetVarType
	mov	al,tAbsolute
	Invoke	CheckDirective
	jnz	@@3
	Invoke	GetSymbol
	mov	al,t_Var
	Invoke	CheckToken
	jnz	@@2
	les	di,CurrentSymbol
	call	_SearchUnit
	mov	TempStub.vsLink.Offs,ax
	mov	TempStub.vsLink.Segm,dx
	mov	al,vfAlias
	jmp	short @@5
@@2:	call	GetIntConstExpr
	mov	TempStub.vsAddress.Segm,ax
	mov	al,tColon
	Invoke	NeedToken
	call	GetIntConstExpr
	mov	TempStub.vsAddress.Offs,ax
	mov	al,vfAbsolute
	jmp	short @@5
@@3:	mov	ax,CurScope
	or	ax,ax
	jz	@@4
	mov	TempStub.vsScope,ax
	mov	al,vfLocal
	jmp	short @@5
@@4:	mov	FirstOnData,1
	mov	ax,DataMap.offs
	mov	TempStub.vsMap,ax
	mov	al,vfVar
@@5:	mov	TempStub.vsFlags,al
	call	FillVarTypes
	mov	al,tSemicolon
	Invoke	NeedToken
	cmp	CurrentToken,t_Ident
	je	@@1
	jmp	FlushDataMap
VarDecl	endp

GetVarList	proc	near
	mov	ax,Dictionary.Offs
	mov	FirstVar,ax
	xor	ax,ax
	mov	VarCount,ax
@@1:	mov	ax,size TVarStub
	Invoke	AddIdent2Dict
	inc	VarCount
	mov	al,tComma
	Invoke	CheckToken
	jz	@@1
	ret
GetVarList	endp

GetVarType	proc near
	call	GetTypeNoForw
	mov	ax,es:[di].tdSizeOf
	mov	VarSize,ax
	call	_SearchUnit
	mov	TempStub.vsType.Offs,ax
	mov	TempStub.vsType.Segm,dx
	ret
GetVarType	endp

FillVarTypes	proc	near
	mov	dx,VarSize
	mov	di,FirstVar
	mov	es,Dictionary.Segm
@@1:	mov	si,di
	mov	al,PrivateFlag
	or	al,t_Var
	mov	es:[di].seType,al
	mov	bl,es:[di].seName.B0
	mov	bh,0
	lea	di,[di+size TSymbol+bx]
	mov	al,TempStub.vsFlags
	cmp	al,vfVar
	jne	@@3
	mov	ax,VarsSize
	test	GlobalOptions,coWordAlign
	jz	@@2
	cmp	dx,1
	je	@@2
	inc	ax
	jz	@@5
	and	ax,0fffeh
@@2:	add	ax,dx
	jc	@@5
	mov	VarsSize,ax
	sub	ax,dx
	sub	ax,DataSectStart
	jmp	short @@7
@@3:	cmp	al,vfLocal
	jne	@@6
	mov	ax,LocalsSize
	dec	ax
	sub	ax,dx
	inc	ax
	jc	@@5
	test	GlobalOptions,coWordAlign
	jz	@@4
	cmp	dx,1
	je	@@4
	and	ax,0fffeh
@@4:	mov	LocalsSize,ax
	jmp	short @@7
@@5:	mov	ax,96
	Chain	CompileError
@@6:	cmp	al,vfField
	jne	@@8
	mov	bx,PrevField
	mov	es:[bx],si
	lea	ax,[di].vsNext
	mov	PrevField,ax
	mov	bx,CurOwner
	mov	ax,es:[bx].tdSizeOf
	add	es:[bx].tdSizeOf,dx
	jnc	@@7
	mov	ax,22
	Chain	CompileError
@@7:	mov	TempStub.vsOffset,ax
@@8:	lea	si,TempStub
	mov	cx,size TVarStub
	rep	movsb
	dec	VarCount
	jz	@@9
	jmp	@@1
@@9:	ret
FillVarTypes	endp

ProcDecl	proc	near
	push	ax
	Invoke	GetToken
	Invoke	NeedIdent
	Invoke	LocalSearch
	mov	cl,al
	pop	ax
	jnz	@@7
	cmp	ProgramSection,psInterface
	je	@@4
	cmp	cl,t_Proc
	je	@@1
	cmp	cl,t_Type
	jne	@@3
	mov	bx,es:[di].tsType.Segm
	mov	di,es:[di].tsType.Offs
	mov	es,es:[bx]
	cmp	es:[di].tdType,ttObject
	jne	@@3
	push	ax
	Invoke	GetToken
	mov	al,tPoint
	Invoke	NeedToken
	Invoke	NeedIdent
	mov	di,es:[di].rtHash
	Invoke	SearchHash
	jnz	@@6
	cmp	al,t_Proc
	jne	@@6
	pop	ax
	jmp	short @@2
@@1:	test	es:[di].psFlags,pfMethod
	jnz	@@4
@@2:	push	es
	mov	si,es:[di].psProcMap
	mov	es,ProcMap.Segm
	cmp	es:[si].pmCodeMap,-1
	pop	es
	jne	@@4
	Invoke	GetToken
	call	MatchForward
	jmp	@@15
@@3:	cmp	al,tConstructor
	je	@@5
	cmp	al,tDestructor
	je	@@5
@@4:	mov	ax,4
	Chain	CompileError
@@5:	mov	ax,147
	Chain	CompileError
@@6:	mov	ax,150
	Chain	CompileError
@@7:	cmp	al,tConstructor
	je	@@5
	cmp	al,tDestructor
	je	@@5
	push	ax
	mov	ax,size TProcStub
	Invoke	LocalAddIdent
	mov	es:[bx].seType,t_Proc
	Invoke	GetToken
	pop	ax
	push	TempDict.Offs bx es di
	call	GetProcHeader
	pop	di es bx dx
	mov	al,tSemicolon
	Invoke	NeedToken
	mov	al,tInline
	Invoke	CheckToken
	jnz	@@8
	push	es di
	Invoke	ProcessInline
	pop	di es
	or	es:[di].psFlags,pfInline
	mov	es:[di].psInlineLen,cx
	mov	al,tSemicolon
	Chain	NeedToken
@@8:	mov	es:[di].psHash,dx
	call	FlushProcMap
	mov	ax,CurScope
	mov	es:[di].psScope,ax
	or	ax,ax
	jnz	@@9
	mov	al,tInterrupt
	Invoke	CheckDirective
	jnz	@@9
	or	es:[di].psFlags,pfInterrupt
	mov	al,tSemicolon
	Invoke	NeedToken
	jmp	short @@13
@@9:	cmp	ProgramSection,psInterface
	je	@@12
	mov	al,tNear
	Invoke	CheckDirective
	jz	@@10
	mov	al,tFar
	Invoke	CheckDirective
	jnz	@@11
	or	es:[di].psFlags,pfFar
@@10:	mov	al,tSemicolon
	Invoke	NeedToken
	jmp	short @@13
@@11:	test	CompilerOptions,coForceFarCalls
	jz	@@13
@@12:	or	es:[di].psFlags,pfFar
@@13:	cmp	ProgramSection,psInterface
	je	@@14
	mov	al,tForward
	Invoke	CheckDirective
	jnz	@@15
	mov	al,tSemicolon
	Chain	NeedToken
@@14:	ret
@@15:	cmp	CurScope,0
	jne	@@16
	mov	al,tExternal
	Invoke	CheckDirective
	jnz	@@16
	or	es:[di].psFlags,pfExternal
	mov	es:[di].psHash,0
	jmp	@@18
@@16:	mov	al,tAssembler
	Invoke	CheckDirective
	jnz	@@17
	or	es:[di].psFlags,pfAssembler
	mov	al,tSemicolon
	Invoke	NeedToken
@@17:	push	ParamsSize ParamsBottom ProcResult LocalsSize LocalsBottom
	push	CurProc CurScope
	push	ProcMap.Offs
	mov	CurScope,bx
	mov	CurProc,di
	mov	ax,es:[di].psHash
	mov	NameListPtr,ax
	mov	ax,Dictionary.offs
	mov	es:[di].psHash,ax
	mov	di,es:[di].psProcMap
	mov	es,ProcMap.segm
	mov	es:[di].pmCodeMap,-2
	mov	ax,4
	Invoke	CreateHashTable
	call	CreateProcDict
	call	DeclarationPart
	Invoke	StatementPart
	mov	es,Dictionary.segm
	mov	di,CurProc
	mov	di,es:[di].psProcMap
	mov	es,ProcMap.segm
	mov	es:[di].psHash,ax
	mov	ax,CodeMap.offs
	mov	es:[di].psScope,ax
	call	FlushCodeMap
	call	FlushConstMap
	pop	di
	call	CheckLocUndefs
	mov	es,Dictionary.segm
	mov	di,CurProc
	pop	CurScope CurProc
	pop	LocalsBottom LocalsSize ProcResult ParamsBottom ParamsSize
	mov	ax,GlobalOptions
	and	ax,coDebugInfo+coLocalSymbols
	cmp	ax,coDebugInfo+coLocalSymbols
	je	@@18
	xor	ax,ax
	xchg	ax,es:[di].psHash
	mov	Dictionary.offs,ax
@@18:	mov	al,tSemicolon
	Chain	NeedToken
ProcDecl	endp

MatchForward	proc	near
	mov	ah,tFunction
	cmp	es:[di].psType.ptResult.Offs,0
	jne	@@1
	mov	ah,tConstructor
	test	es:[di].psFlags,pfConstructor
	jnz	@@1
	mov	ah,tDestructor
	test	es:[di].psFlags,pfDestructor
	jnz	@@1
	mov	ah,tProcedure
@@1:	cmp	al,ah
	jne	@@4
	cmp	CurrentToken,tOParen
	je	@@2
	cmp	CurrentToken,tColon
	jne	@@3
@@2:	push	TempDict.Offs
	push	es di bx
	call	GetProcHeader
	mov	si,di
	pop	bx di es
	push	di ds
	mov	cx,Dictionary.Offs
	mov	Dictionary.Offs,si
	sub	cx,si
	add	di,psType
	push	es
	pop	ds
	mov	ax,[di].tdNext
	mov	[si].tdNext,ax
	repe	cmpsb
	pop	ds di
	pop	si
	jne	@@4
	push	di ds es
	mov	cx,TempDict.Offs
	mov	TempDict.Offs,si
	sub	cx,si
	mov	di,es:[di].psHash
	mov	es,TempDict.Segm
	push	es
	pop	ds
	repe	cmpsb
	pop	es ds di
	jne	@@4
@@3:	mov	al,tSemicolon
	Chain	NeedToken
@@4:	mov	ax,131
	Chain	CompileError
MatchForward	endp

CreateProcDict	proc	near
	Loc	ParamOffset,word,1
	Loc	AsmFlag,byte,2
	Entry
	mov	es,Dictionary.Segm
	mov	di,CurProc
	mov	al,es:[di].psFlags
	and	al,pfAssembler
	mov	AsmFlag,al
	call	StackRequired
	mov	ParamsSize,ax
	mov	ParamsBottom,dx
	mov	ParamOffset,dx
	call	LocalSize
	mov	ProcResult,ax
	mov	LocalsSize,ax
	mov	LocalsBottom,dx
	push	NameListPtr
	mov	cx,es:[di].psType.ptParamCount
	add	di,psType.ptParams
	jcxz	@@4
@@1:	push	cx es di
	mov	al,es:[di].ppFlags
	mov	ah,AsmFlag
	mov	bx,es:[di].ppType.Segm
	mov	di,es:[di].ppType.Offs
	mov	es,es:[bx]
	call	ParamSize
	or	al,vfParam
	mov	TempStub.vsFlags,al
	mov	bx,dx
	call	_SearchUnit
	mov	TempStub.vsType.Offs,ax
	mov	TempStub.vsType.Segm,dx
	sub	ParamOffset,cx
	mov	ax,ParamOffset
	or	bx,bx
	jz	@@3
	mov	ax,LocalsSize
	sub	ax,bx
	test	GlobalOptions,coWordAlign
	jz	@@2
	cmp	bx,1
	je	@@2
	and	ax,0fffeh
@@2:	mov	LocalsSize,ax
@@3:	mov	TempStub.vsOffset,ax
	mov	ax,CurScope
	mov	TempStub.vsScope,ax
	mov	di,NameListPtr
	mov	es,TempDict.Segm
	Invoke	CalcHash
	mov	NameListPtr,di
	mov	ax,size TVarStub
	Invoke	AddNewIdent
	mov	es:[bx].seType,t_Var
	lea	si,TempStub
	mov	cx,size TVarStub
	rep	movsb
	pop	di es cx
	add	di,size TProcParam
	loop	@@1
@@4:	mov	di,CurProc
	test	es:[di].psFlags,pfMethod
	jz	@@5
	mov	TempStub.vsFlags,vfLocal+vfAddress
	mov	TempStub.vsOffset,6
	mov	ax,CurScope
	mov	TempStub.vsScope,ax
	mov	di,es:[di].psScope
	call	_SearchUnit
	mov	TempStub.vsType.Offs,ax
	mov	TempStub.vsType.Segm,dx
	lea	di,SelfStr
	push	ds
	pop	es
	Invoke	CalcHash
	mov	ax,size TVarStub
	Invoke	AddNewIdent
	mov	es:[bx].seType,t_Var
	lea	si,TempStub
	mov	cx,size TVarStub
	rep	movsb
@@5:	mov	ax,NameListPtr
	cmp	ax,TempDict.Offs
	pop	ax
	jne	@@6
	mov	TempDict.Offs,ax
@@6:	Exit
CreateProcDict	endp

StackRequired	proc	near
	xor	ax,ax
	cmp	es:[di].psScope,0
	je	@@1