compile.asm

Turbo Pascal 6.0编译器源码

	model	large compiler_text,pascal
	include	compiler.inc

	.data

DefProgramName	db	7,'PROGRAM'
SystemName	db	6,'SYSTEM'
SystemTps	db	'SYSTEM.TPS',0
Extensions	db	'PAS',0
		db	'EXE',0
		db	'TPU',0
		db	'OBJ',0
		db	'MAP',0
		db	'OVR',0
ErrorNumbers	dw	123,123,123,123,123,123,123,123,123,123,48,49,48,49,124
Signature	db	'$*$*$*',0,4,8,5,'COMPILER',0

	.code	compiler_text

	public	CompilerEntry
	public	SearchUnitName
	public	CreateFile
	public	CloseFile
	public	ReadObjectFile
	public	CloseObjectFile
	public	BigWrite
	public	GetFileSize
	public	ConvertName
	public	FileCreate
	public	FileClose
	public	FileWrite
	public	WriteBig
	public	GetFlatMem
	public	GetProcStackSize
	public	FlatMemAvail

CompilerEntry	proc	near
	cld
	lea	ax,@@3
	Invoke	SetErrHandler
	lea	di,ProgramLocation
	push	ds
	pop	es
	lea	cx,CompilerFlags
	sub	cx,di
	xor	ax,ax
	rep	stosb
	mov	SavedDepth,ax
	dec	ax
	mov	SavedDepth2,ax
	lea	ax,CompMemPtr
	mov	FileStackPtr,ax
	mov	SaveFileStack,ax
	mov	TempBufPtr,offset TempBuffer
	mov	DefinesPtr,offset DefinesBuf
	call	PutHeader
	call	CompileFile
	cmp	ProgramSection,0
	jge	@@2
	inc	ProgramLocation
	test	CompilerFlags.B0,cfDisk
	jnz	@@1
	inc	ProgramLocation
@@1:	ret
@@2:	mov	StackSize,ax
	mov	MinHeapSize,ax
	mov	MaxHeapSize,ax
	ret
@@3:	mov	di,FileStackPtr
	cmp	di,offset CompMemPtr
	je	@@4
	mov	ErrorPos,di
	mov	ax,TextPos
	mov	[di].fsTextPos,ax
@@4:	cmp	FileHandle,0
	je	@@5
	lea	dx,FileNameBuf
	Invoke	DeleteFile
@@5:	cmp	ExeHandle,0
	jz	@@6
	lea	dx,ExeName
	Invoke	DeleteFile
@@6:	ret
CompilerEntry	endp

PutHeader	proc	near
	lea	di,UnitNameLen
	push	ds
	pop	es
	lea	cx,ConstSectStart2+2
	sub	cx,di
	xor	al,al
	rep	stosb
	mov	ax,InitOptions
	mov	GlobalOptions,ax
	lea	si,ErrorNumbers
	lea	di,Dictionary
	lea	dx,StmtPart+8
	Invoke	InitHeap
	mov	ax,size TUnitHeader
	Invoke	GetDictMem
	mov	ax,'PT'
	stosw
	mov	ax,'9U'
	stosw
	mov	ax,FirstUnit
	stosw
	mov	FirstUnit,es
ZeroHeader	label	near
	mov	es,Dictionary.Segm
	mov	di,uhLink
	mov	cx,(size TUnitHeader-uhLink) shr 1
	xor	ax,ax
	rep	stosw
	mov	Dictionary.Offs,di
	ret
PutHeader	endp

CompileFile	proc	near
	mov	SlashToken,tSlash
	mov	EqualToken,tEqual
	mov	al,fdUnitDir
	mov	dx,UnitName
	add	dx,UnitNameLen
	Invoke	AddToSourceList
	mov	dx,UnitName
	Invoke	AddToFileStack
	Invoke	MarkFileTime
	push	SaveFileStack SaveDefinesPtr
	mov	ax,FileStackPtr
	mov	SaveFileStack,ax
	mov	ax,DefinesPtr
	mov	SaveDefinesPtr,ax
	Invoke	StandardDefines
	Invoke	GetToken
	test	CompilerFlags.B0,cfForceUnit
	jnz	@@1
	cmp	CurrentToken,tUnit
	je	@@1
	call	CompileProgram
	jmp	short @@2
@@1:	call	CompileUnit
@@2:	mov	ax,SaveDefinesPtr
	mov	DefinesPtr,ax
	pop	SaveDefinesPtr SaveFileStack
	Chain	PopFileStack
CompileFile	endp

CompileProgram	proc	near
	mov	ProgramSection,psMainProgram
	mov	al,tProgram
	Invoke	CheckToken
	jnz	@@3
	Invoke	NeedIdent
	call	PutProgramName
	Invoke	GetToken
	mov	al,tOParen
	Invoke	CheckToken
	jnz	@@2
@@1:	mov	al,t_Ident
	Invoke	NeedToken
	mov	al,tComma
	Invoke	CheckToken
	jz	@@1
	mov	al,tCParen
	Invoke	NeedToken
@@2:	mov	al,tSemicolon
	Invoke	NeedToken
	jmp	short @@4
@@3:	lea	di,DefProgramName
	push	ds
	pop	es
	Invoke	CalcHash
	call	PutProgramName
@@4:	call	UsesClause
	Invoke	DeclarationPart
	call	MainProgram
	call	EndOfFile
	Invoke	LinkObjects
	Invoke	CheckUndefs
	call	FlushUnit
	call	FlushSegments
	Chain	LinkProgram
CompileProgram	endp

CompileUnit	proc	near
	mov	ProgramSection,psInterface
	mov	al,tUnit
	Invoke	NeedToken
	Invoke	NeedIdent
	call	PutUnitName
	Invoke	GetToken
	mov	al,tSemicolon
	Invoke	NeedToken
	mov	al,tInterface
	Invoke	NeedToken
	call	UsesClause
	Invoke	DeclarationPart
	call	CalcChecksum
	mov	ax,Dictionary.Offs
	mov	InterfaceEnd,ax
	mov	ProgramSection,psImplementation
	mov	al,tImplementation
	Invoke	NeedToken
	call	UsesClause
	call	CreateDebugHash
	Invoke	DeclarationPart
	cmp	CurrentToken,tBegin
	jne	@@1
	call	MainProgram
	jmp	short @@2
@@1:	mov	al,tEnd
	Invoke	NeedToken
@@2:	call	EndOfFile
	Invoke	LinkObjects
	Invoke	CheckUndefs
	call	FlushSymbols
	call	FlushUnit
	call	SaveUnit
	jmp	FlushSegments
CompileUnit	endp

	HValue	SYSTEM,128

PutUnitName	proc	near
	mov	al,@HS
	lea	di,SystemName
	Invoke	CompareSymbol
	jnz	@@1
	mov	CompilingSystem,1
	lea	si,SystemTps
	lea	di,FileNameBuf
	Invoke	CopyDSCStr
	mov	ax,fdUnitDir*256
	lea	dx,FileNameBuf
	call	ConvertName
	lea	dx,FileNameBuf
	call	ReadUnit
	jmp	short @@2
PutProgramName	label	near
@@1:	les	di,Dictionary
	mov	es:uhInterface,di
	mov	es:uhDebugHash,di
	mov	ax,64
	Invoke	CreateHashTable
@@2:	les	di,Dictionary
	mov	es:uhName,di
	mov	ax,size TUnitStub
	Invoke	AddNewIdent
	mov	es:[bx].seType,t_Unit
	mov	NextUnit,di
	mov	ax,es
	stosw
	xor	ax,ax
	stosw
	stosw
	stosw
	mov	ax,size TProcMap
	lea	bx,ProcMap
	Invoke	GetMemory
	xor	ax,ax
	stosw
	stosw
	dec	ax
	stosw
	stosw
	ret
PutUnitName	endp

UsesClause	proc	near
	mov	es,Dictionary.Segm
	or	GlobalOptions,coGlobal
	test	GlobalOptions,coOverlayCode
	jz	@@1
	or	es:uhFlags,ufOverlay
@@1:	mov	di,es:uhName
	mov	bl,es:[di].seName.B0
	mov	bh,0
	mov	ax,es:[di+size TSymbol+bx].usPrev
	mov	PrevUnit,ax
	cmp	CompilingSystem,0
	jne	@@2
	cmp	ProgramSection,psImplementation
	je	@@2
	lea	di,SystemName
	push	ds
	pop	es
	Invoke	CalcHash
	call	Insert2UsesList
@@2:	mov	al,tUses
	Invoke	CheckToken
	pushf
	jnz	@@4
@@3:	Invoke	NeedIdent
	call	Insert2UsesList
	Invoke	GetToken
	mov	al,tComma
	Invoke	CheckToken
	jz	@@3
@@4:	call	UseUnit
	popf
	jnz	@@5
	mov	al,tSemicolon
	Invoke	NeedToken
@@5:	mov	es,Dictionary.Segm
	mov	di,es:uhName
	mov	bl,es:[di].seName.B0
	mov	bh,0
	mov	ax,PrevUnit
	mov	es:[di+size TSymbol+bx].usPrev,ax
	cmp	CompilingSystem,0
	jne	@@6
	mov	di,es:[di+size TSymbol+bx].usNext
	mov	bl,es:[di].seName.B0
	mov	bh,0
@@6:	mov	ax,es:[di+size TSymbol+bx].usAddress
	mov	SystemUnit,ax
	ret
UsesClause	endp

Insert2UsesList	proc	near
	mov	ax,size TUnitStub
	Invoke	AddNewIdent
	mov	es:[bx].seType,t_Unit
	mov	si,NextUnit
	mov	es:[si].usNext,bx
	mov	NextUnit,di
	mov	si,PrevUnit
	mov	es:[di].usPrev,si
	mov	PrevUnit,bx
	ret
Insert2UsesList	endp

CalcChecksum	proc	near
	call	PushLinks
	push	ds
	lds	cx,Dictionary
	mov	si,es:uhInterface
	sub	cx,si
	shr	cx,1
	xor	dx,dx
@@1:	lodsw
	rol	dx,1
	add	dx,ax
	loop	@@1
	or	dx,dx
	jnz	@@2
	dec	dx
@@2:	mov	di,ds:uhName
	mov	bl,[di].seName.B0
	mov	bh,0
	mov	[di+size TSymbol+bx].usChecksum,dx
	pop	ds
	call	PopLinks
	ret
CalcChecksum	endp

PushLinks	proc	near
	pop	dx
	xor	cx,cx
	mov	es,Dictionary.segm
	mov	di,es:uhName
@@1:	mov	bl,es:[di].seName.B0
	mov	bh,0
	lea	di,[di+size TSymbol+bx]
	push	es:[di].usAddress
	push	di
	mov	es:[di].usAddress,0
	inc	cx
	mov	di,es:[di].usNext
	or	di,di
	jnz	@@1
	push	cx
	jmp	dx
PushLinks	endp

PopLinks	proc	near
	pop	dx cx
@@1:	pop	di
	pop	es:[di].usAddress
	loop	@@1
	jmp	dx
PopLinks	endp

CreateDebugHash	proc	near
	mov	es,Dictionary.Segm
	mov	di,es:uhInterface
	mov	ax,es:[di]
	add	ax,4
	Invoke	GetDictMem
	mov	es:uhDebugHash,di
	ret
CreateDebugHash	endp

MainProgram	proc	near
	xor	ax,ax
	mov	LocalsSize,ax
	mov	LocalsBottom,ax
	Invoke	StatementPart
	mov	es,ProcMap.Segm
	mov	es:pmEntryPoint,ax
	mov	ax,CodeMap.Offs
	mov	es:pmCodeMap,ax
	Invoke	FlushCodeMap
	Chain	FlushConstMap
MainProgram	endp

EndOfFile	proc	near
	cmp	CurrentToken,tPoint
	jne	@@1
	mov	di,FileStackPtr
	cmp	di,SaveFileStack
	jne	@@2
	Chain	StartFileInfo
@@1:	mov	ax,94
	Chain	CompileError
@@2:	mov	ax,10
	Chain	CompileError
EndOfFile	endp

FlushSymbols	proc	near
	mov	ax,GlobalOptions
	and	ax,coDebugInfo+coLocalSymbols
	cmp	ax,coDebugInfo+coLocalSymbols
	jne	@@1
	push	ds
	mov	ds,Dictionary.Segm
	mov	si,ds:uhInterface
	mov	di,ds:uhDebugHash
	mov	cx,[si]
	add	cx,4
	push	ds
	pop	es
	rep	movsb
	pop	ds
	jmp	short @@2
@@1:	mov	es,Dictionary.Segm
	mov	ax,es:uhDebugHash
	mov	Dictionary.Offs,ax
	mov	ax,es:uhInterface
	mov	es:uhDebugHash,ax
@@2:	mov	es,Dictionary.Segm
	mov	di,es:uhInterface
	mov	cx,es:[di]
	shr	cx,1
	inc	cx
	mov	ax,InterfaceEnd
@@3:	inc	di
	inc	di
	mov	bx,di
@@4:	mov	bx,es:[bx]
	cmp	bx,ax
	jae	@@4
	mov	es:[di],bx
	loop	@@3
	ret
FlushSymbols	endp

FlushUnit	proc	near
	mov	es,UnitList.Segm
	xor	ax,ax
	xor	bx,bx
	xor	di,di
	jmp	short @@2
@@1:	mov	es:[di].ulSegment,ax
	mov	bl,es:[di].ulName.B0
	lea	di,[di+size TUnitList+bx]
@@2:	cmp	di,UnitList.Offs
	jne	@@1
	mov	es,Dictionary.Segm
	mov	ax,DefUnitFlags
	or	es:uhFlags,ax
	Chain	FormUnit
FlushUnit	endp

SaveUnit	proc	near
	test	CompilerFlags.B0,cfDisk
	jz	@@1
	call	PushLinks
	mov	es,Dictionary.Segm
	push	es:uhNext
	xor	ax,ax
	mov	es:uhNext,ax
	mov	ax,feTpu+feForceExt+(fdOutputDir+fdNoEditor)*256
	call	CreateFile
	Invoke	WriteUnit
	call	CloseFile
	mov	es,Dictionary.Segm
	pop	es:uhNext
	call	PopLinks
@@1:	mov	ax,CompiledCode.Offs
	mov	CodeSize.W0,ax
	xor	ax,ax
	mov	CodeSize.W2,ax
	mov	ax,CompiledConst.Offs
	add	ax,VarsSize
	mov	DataSize,ax
	ret
SaveUnit	endp

FlushSegments	proc	near
	mov	es,Dictionary.Segm
	mov	di,uhCodeSeg
	mov	ax,CompiledCode.Segm
	stosw
	mov	ax,CompiledConst.Segm
	stosw
	mov	ax,CodeFixups.Segm
	stosw
	mov	ax,ConstFixups.Segm
	stosw
	ret
FlushSegments	endp

UseUnit	proc	near
	inc	CurDepth
	mov	es,FirstUnit
	mov	ax,UsedUnit
	xchg	ax,es:uhNext
	mov	FirstUnit,ax
	mov	UsedUnit,es
	mov	di,es:uhName
	mov	bl,es:[di].seName
	mov	bh,0
	mov	dx,es
@@1:	mov	es:[di+size TSymbol+bx].usAddress,dx
	mov	di,es:[di+size TSymbol+bx].usNext
	or	di,di
	jz	@@3
	push	di
	add	di,seName
	call	LoadUnit
	mov	di,es:uhName
	mov	bl,es:[di].seName.B0
	mov	bh,0
	mov	ax,es:[di+size TSymbol+bx].usChecksum
	mov	dx,es
	pop	di
	mov	es,UsedUnit
	mov	bl,es:[di].seName.B0
	mov	bh,0
	mov	cx,es:[di+size TSymbol+bx].usChecksum
	or	cx,cx
	jnz	@@2
	mov	es:[di+size TSymbol+bx].usChecksum,ax
	jmp	@@1
@@2:	cmp	ax,cx
	je	@@1