lex.asm

Turbo Pascal 6.0编译器源码

	model	large compiler_text,pascal
	include	compiler.inc

	.data

Defines	db	5,'VER60'
	db	5,'MSDOS'
	db	5,'CPU86'
DefL1	equ	$-Defines
	db	5,'CPU87'
DefL2	equ	$-Defines

	.data?

StartToken	db	?
SymbolToken	db	?
SymbolTextPos	dw	?

	.code	compiler_text

	public	CreateHashTable
	public	AddIdent2Dict
	public	AddNewIdent
	public	LocalAddIdent
	public	AddIdent
	public	GetHash
	public	NeedIdent
	public	CompareSymbol
	public	CalcHash
	public	GetSymbol
	public	SearchSymbol
	public	SearchField
	public	LocalSearch
	public	SearchHash
	public	ChooseToken
	public	GetPlusMinus
	public	GetDirective
	public	CheckDirective
	public	CheckToken
	public	NeedToken
	public	GetToken
	public	ProcessCaret
	public	StandardDefines
	public	GetRawToken
	public	AddToFileStack
	public	MarkFileTime
	public	PopFileStack
	public	UpperCase
	public	CopyPasStr
	public	CopyDSCStr
	public	Pas2C
	public	DSPas2C
	public	CompareStrings
	public	MoveBlock
	public	MoveBlockRev
	public	AllocTempBuf
	public	AddToSourceList

CreateHashTable	proc	near
	mov	cx,ax
	shl	ax,1
	add	ax,2
	Invoke	GetDictMem
	mov	ax,cx
	dec	ax
	shl	ax,1
	stosw
	xor	ax,ax
	rep	stosw
	ret
CreateHashTable	endp

AddIdent2Dict	proc	near
	call	NeedIdent
	call	AddNewIdent
	jmp	GetToken
AddIdent2Dict	endp

AddNewIdent	proc	near
	push	ax
	call	LocalSearch
	pop	ax
	jnz	LocalAddIdent
	mov	ax,4
	Chain	IdentError
AddNewIdent	endp

LocalAddIdent	proc	near
	call	GetHash
AddIdent	label	near
	push	ax
	mov	cl,IdentBuf[0]
	mov	ch,0
	inc	cx
	add	ax,size TSymbol-1
	add	ax,cx
	Invoke	GetDictMem
	mov	bl,SymbolHash
	and	bx,es:[si]
	lea	bx,[bx+si+2]
	mov	ax,es:[bx]
	mov	es:[bx],di
	mov	bx,di
	stosw
	xor	ax,ax
	stosb
	lea	si,IdentBuf
	rep	movsb
	pop	cx
	push	di
	rep	stosb
	pop	di
	ret
LocalAddIdent	endp

GetHash	proc	near
	mov	es,Dictionary.Segm
	mov	si,CurOwner
	or	si,si
	jnz	@@1
	mov	si,CurProc
	or	si,si
	jnz	@@2
	mov	si,es:uhInterface
	ret
@@1:	mov	si,es:[si].rtHash
	ret
@@2:	mov	si,es:[si].psHash
	ret
GetHash	endp

NeedIdent	proc	near
	cmp	CurrentToken,t_Ident
	jne	@@1
	ret
@@1:	mov	ax,2
	Chain	CompileError
NeedIdent	endp

CompareSymbol	proc	near
	cmp	CurrentToken,t_Ident
	jne	@@1
	cmp	al,SymbolHash
	jne	@@1
	push	cx
	lea	si,IdentBuf
	push	ds
	pop	es
	mov	cl,[si]
	xor	ch,ch
	inc	cx
	repe	cmpsb
	pop	cx
@@1:	ret
CompareSymbol	endp

CalcHash	proc	near
	lea	si,IdentBuf
	mov	ah,es:[di]
	mov	[si],ah
	inc	di
	inc	si
	xor	bl,bl
@@1:	mov	al,es:[di]
	cmp	al,'a'
	jb	@@2
	cmp	al,'z'
	ja	@@2
	sub	al,'a'-'A'
@@2:	mov	[si],al
	inc	di
	inc	si
	dec	al
	add	bl,al
	dec	ah
	jnz	@@1
	add	bl,bl
	mov	SymbolHash,bl
	ret
CalcHash	endp

GetSymbol	proc	near
	cmp	CurrentToken,t_Ident
	jne	@@2
	test	CompilerFlags.B0,cfDebugging
	jnz	@@4
	push	si di
	call	SearchSymbol
	jnz	@@3
	cmp	al,t_Unit
	jne	@@1
	call	GetToken
	mov	al,tPoint
	call	NeedToken
	call	NeedIdent
	mov	es,es:[di]
	mov	di,es:uhInterface
	call	SearchHash
	jnz	@@3
@@1:	mov	CurrentToken,al
	mov	CurrentHash,bx
	mov	CurrentSymbol.Offs,di
	mov	CurrentSymbol.Segm,es
	pop	di si
@@2:	ret
@@3:	mov	ax,3
	Chain	CompileError
@@4:	push	si di
	call	FindUnitName
	jz	@@7
	call	SearchSymbol
	jz	@@7
	mov	ax,FirstUnit
@@5:	mov	es,ax
	call	DebuggingSearch
	jz	@@7
	mov	ax,es:uhNext
	or	ax,ax
	jnz	@@5
@@6:	mov	ax,3
	Chain	CompileError
@@7:	call	GiveSymbol
	cmp	al,t_Unit
	jne	@@8
	call	NeedField
	jnz	@@11
	call	DebuggingSearch
	jnz	@@6
	call	GiveSymbol
@@8:	cmp	al,t_Type
	jne	@@9
	mov	si,es:[di].tsType.Offs
	mov	di,es:[di].tsType.Segm
	mov	es,es:[di]
	cmp	es:[si].tdType,ttObject
	jne	@@11
	call	NeedField
	jnz	@@11
	call	SearchField
	jnz	@@6
	call	GetToken
	cmp	al,t_Proc
	jne	@@11
	jmp	short @@10
@@9:	cmp	al,t_Proc
	jne	@@11
	test	es:[di].psFlags,pfInline+pfMethod
	jnz	@@11
@@10:	call	NeedField
	jnz	@@11
	mov	di,es:[di].psHash
	call	SearchHash
	jnz	@@6
	call	GiveSymbol
	jmp	@@9
@@11:	mov	ax,SymbolTextPos
	mov	bx,FileStackPtr
	mov	[bx],ax
	call	GetToken
	mov	al,SymbolToken
	mov	CurrentToken,al
	pop	di si
	ret
GetSymbol	endp

DebuggingSearch	proc	near
	mov	di,es:uhDebugHash
	call	SearchHash
	jz	@@1
	mov	ax,es
	cmp	ax,SystemUnit
	jne	@@1
	lea	di,RegVars
	push	cs
	pop	es
	call	SearchHash
	jz	@@1
	mov	es,SystemUnit
@@1:	ret
DebuggingSearch	endp

GiveSymbol	proc	near
	mov	SymbolToken,al
	mov	CurrentHash,bx
	mov	CurrentSymbol.offs,di
	mov	CurrentSymbol.segm,es
	mov	bx,TextPos
	mov	SymbolTextPos,bx
	jmp	GetToken
GiveSymbol	endp

NeedField	proc	near
	cmp	CurrentToken,tPoint
	jne	@@1
	call	GetToken
	jmp	NeedIdent
@@1:	ret
NeedField	endp

SearchSymbol	proc	near
	mov	si,WithChain
	jmp	short @@2
@@1:	les	si,[si].wcOwner
	call	SearchField
	jz	@@8
	mov	si,CurrentWith
	mov	si,[si].wcNext
@@2:	mov	CurrentWith,si
	or	si,si
	jnz	@@1
	mov	es,Dictionary.Segm
	mov	si,CurScope
	jmp	short @@4
@@3:	mov	bl,es:[si].seName.B0
	mov	bh,0
	lea	si,[si+size TSymbol+bx]
	push	si
	call	SearchLocal
	pop	si
	jz	@@7
	mov	es,Dictionary.Segm
	test	es:[si].psFlags,pfMethod
	jnz	@@5
	mov	si,es:[si].psScope
@@4:	or	si,si
	jnz	@@3
@@5:	mov	si,es:uhName
@@6:	mov	bl,es:[si].seName.B0
	mov	bh,0
	lea	si,[si+size TSymbol+bx]
	mov	es,es:[si]
	mov	di,es:uhInterface
	push	si
	call	SearchHash
	pop	si
	jz	@@7
	mov	es,Dictionary.Segm
	mov	si,es:[si].usPrev
	or	si,si
	jnz	@@6
	dec	si
	ret
@@7:	xor	si,si
@@8:	ret
SearchSymbol	endp

SearchLocal	proc	near
	mov	di,es:[si].psHash
	push	si
	call	SearchHash
	pop	si
	jz	@@1
	test	es:[si].psFlags,pfMethod
	jnz	@@2
	or	si,si
@@1:	ret
@@2:	mov	si,es:[si].psScope
SearchField	label	near
	mov	CurrentOwner.Offs,si
	mov	CurrentOwner.Segm,es
@@3:	mov	di,es:[si].rtHash
	push	si
	call	SearchHash
	pop	si
	jz	@@5
	cmp	es:[si].tdType,ttObject
	jne	@@5
	mov	bx,es:[si].otParent.Segm
	or	bx,bx
	jz	@@4
	mov	si,es:[si].otParent.Offs
	mov	es,es:[bx]
	jmp	@@3
@@4:	dec	bx
@@5:	ret
SearchLocal	endp

LocalSearch	proc	near
	mov	es,Dictionary.Segm
	mov	si,CurOwner
	or	si,si
	jnz	SearchField
	mov	si,CurProc
	or	si,si
	jnz	SearchLocal
	mov	di,es:uhInterface
SearchHash	label	near
	mov	bl,SymbolHash
	and	bx,es:[di]
	mov	bx,es:[bx+di+2]
	or	bx,bx
	jz	@@3
	lea	ax,IdentBuf
	mov	dl,IdentBuf[0]
	mov	dh,0
	inc	dx
@@1:	lea	di,[bx].seName
	mov	si,ax
	mov	cx,dx
	repe	cmpsb
	je	@@4
@@2:	mov	bx,es:[bx]
	or	bx,bx
	jnz	@@1
@@3:	dec	bx
	ret
@@4:	mov	al,es:[bx].seType
	test	al,t_Private
	jnz	@@5
	ret
@@5:	and	al,not t_Private
	mov	cx,es
	cmp	cx,Dictionary.Segm
	jne	@@2
	ret
LocalSearch	endp

FindUnitName	proc	near
	lea	bx,IdentBuf
_FindUnitName	label	near
	mov	ax,FirstUnit
	mov	dl,[bx]
	mov	dh,0
	inc	dx
@@1:	mov	es,ax
	mov	di,es:uhName
	add	di,seName
	mov	cx,dx
	mov	si,bx
	repe	cmpsb
	je	@@2
	mov	ax,es:uhNext
	or	ax,ax
	jnz	@@1
	dec	ax
	ret
@@2:	mov	al,t_Unit
	mov	bx,es:uhName
	ret
FindUnitName	endp

ChooseToken	proc	near
	mov	cl,cs:[bx]
	xor	ch,ch
	inc	bx
	mov	dl,cs:[bx]
	xor	dh,dh
	inc	bx
	mov	al,CurrentToken
@@1:	cmp	al,cs:[bx]
	je	@@2
	add	bx,dx
	loop	@@1
	dec	cx
@@2:	ret
ChooseToken	endp

GetPlusMinus	proc	near
	mov	al,CurrentToken
	cmp	al,tMinus
	je	@@1
	cmp	al,tPlus
	je	@@1
	xor	al,al
	ret
@@1:	jmp	GetToken
GetPlusMinus	endp

GetDirective	proc	near
	cmp	CurrentToken,t_Ident
	jne	@@2
	push	es di si dx cx bx ax
	lea	di,ProcDirs
	push	cs
	pop	es
	call	SearchHash
	jnz	@@1
	mov	CurrentToken,al
@@1:	pop	ax bx cx dx si di es
@@2:	ret
GetDirective	endp

CheckDirective	proc	near
	call	GetDirective
CheckToken	label	near
	cmp	al,CurrentToken
	je	@@1
	ret
@@1:	jmp	GetToken
CheckDirective	endp

Codes	db	t_Ident,2
	db	t_Label,35
	db	tBegin,36
	db	tEnd,37
	db	tDo,50
	db	tOf,54
	db	tInterface,55
	db	tThen,57
	db	tImplementation,73
	db	tUnit,84
	db	tSemicolon,85
	db	tColon,86
	db	tComma,87
	db	tOParen,88
	db	tCParen,89
	db	tEqual,90
	db	tConstEqual,90
	db	tAssign,91
	db	tOBracket,92
	db	tCBracket,93
	db	tPoint,94
	db	tRange,95
	db	tNil,120
CodesS	equ	($-Codes) shr 1

NeedToken	proc	near
	cmp	al,CurrentToken
	jne	@@1
	jmp	GetToken
@@1:	lea	bx,Codes
	mov	cx,CodesS
@@2:	mov	dx,cs:[bx]
	cmp	al,dl
	je	@@3
	inc	bx
	inc	bx
	loop	@@2
	mov	dh,5
@@3:	mov	al,dh
	xor	ah,ah
	Chain	CompileError
NeedToken	endp

GetToken	proc	near
	push	ax bx cx dx si di es
	test	CompilerFlags.B0,cfDebugging
	jnz	@@1
	Invoke	UpdateCompInfo
@@1:	call	GetRawToken
	mov	TextPos,si
	mov	ax,[si]
	or	al,al
	jz	@@4
	cmp	al,'0'
	jb	@@7
	cmp	al,'9'
	jbe	@@3
	cmp	al,'A'
	jb	@@6
	cmp	al,'Z'
	jbe	@@2
	cmp	al,'a'
	jb	@@5
	cmp	al,'z'
	ja	@@10
@@2:	call	Ident
	jmp	short @@8
@@3:	call	Number
	jmp	short @@8
@@4:	mov	al,0
	jmp	short @@8
@@5:	sub	al,'Z'-'A'+1
@@6:	sub	al,'9'-'0'+1
@@7:	sub	al,' '+1
	mov	bl,al
	xor	bh,bh
	add	bx,bx
	call	cs:@@11[bx]
@@8:	mov	CurrentToken,al
	mov	di,FileStackPtr
	mov	[di],si
	xor	ax,ax
	pop	es di si dx cx bx
@@9:	pop	ax
	ret
@@10:	mov	ax,5
	Chain	CompileError
@@11	dw	@@10			; !
	dw	@@10			; "
	dw	String			; #
	dw	IntNumber		; $
	dw	@@10			; %
	dw	@@10			; &
	dw	String			; '
	dw	OParen			; (
	dw	CParen			; )
	dw	Times			; *
	dw	Plus			; +
	dw	Comma			; ,
	dw	Minus			; -
	dw	Point			; .
	dw	Slash			; /
	dw	Colon			; :
	dw	Semicolon		; ;
	dw	Less			; <
	dw	Equal			; =
	dw	Greater			; >
	dw	@@10			; ?
	dw	At			; @
	dw	OBracket		; [
	dw	@@10			; \
	dw	CBracket		; ]
	dw	Caret			; ^
	dw	Ident			; _
	dw	@@10			; `
GetToken	endp

Ident	proc	near
	lea	di,IdentBuf
	xor	cx,cx
@@1:	mov	al,[si]
	cmp	al,'0'
	jb	@@3
	cmp	al,'9'
	jbe	@@2
	cmp	al,'_'
	je	@@2
	and	al,0dfh
	cmp	al,'A'
	jb	@@3
	cmp	al,'Z'
	ja	@@3
@@2:	inc	si
	cmp	cl,63
	je	@@1
	inc	di
	inc	cl
	mov	[di],al
	dec	al
	add	ch,al
	jmp	@@1
@@3:	mov	IdentBuf[0],cl
	add	ch,ch
	mov	SymbolHash,ch
	lea	di,KeyWords
	push	cs
	pop	es
	push	si
	call	SearchHash
	pop	si
	jz	@@4
	mov	al,t_Ident
@@4:	ret
Ident	endp

Number	proc	near
	mov	bx,si
@@1:	inc	bx
	mov	ax,[bx]
	cmp	al,'0'
	jb	@@2
	cmp	al,'9'
	jbe	@@1
@@2:	call	UpperCase
	cmp	al,'E'
	je	@@3
	cmp	al,'.'
	jne	IntNumber
	cmp	ah,'.'
	je	IntNumber
	cmp	ah,')'
	je	IntNumber
@@3:	lea	bx,SymbolValue
	Invoke	Str2Extended
	jc	@@4
	mov	ax,_Extended
	jmp	GiveConst
@@4:	mov	TextPos,si
	mov	ax,6
	Chain	CompileError
Number	endp

IntNumber	proc	near
	Invoke	Str2Long
	jc	@@1
	mov	SymbolValue.W0,ax
	mov	SymbolValue.W2,dx
	mov	ax,_Longint
	jmp	GiveConst
@@1:	mov	TextPos,si
	mov	ax,7
	Chain	CompileError
IntNumber	endp

String	proc	near
	mov	ax,128
	call	AllocTempBuf
	mov	SymbolValue.W0,bx
	inc	bx
	xor	cx,cx
@@1:	mov	al,[si]
	cmp	al,''''
	jne	@@5
@@2:	inc	si
	mov	al,[si]
	or	al,al
	jz	@@4
	cmp	al,''''
	jne	@@3
	inc	si
	mov	al,[si]
	cmp	al,''''
	jne	@@1
@@3:	mov	[bx],al
	inc	bx
	inc	cx
	jmp	@@2
@@4:	mov	TextPos,si
	mov	ax,8
	Chain	CompileError
@@5:	cmp	al,'^'
	jne	@@7
	inc	si
	mov	al,[si]
	call	UpperCase
	or	al,al
	jz	@@4
	inc	si
	xor	al,40h
@@6:	mov	[bx],al
	inc	bx
	inc	cx
	jmp	@@1
@@7:	cmp	al,'#'
	jne	@@8
	inc	si
	push	bx cx
	Invoke	Str2Long
	pop	cx bx
	jnc	@@6
	mov	TextPos,si
	mov	ax,7
	Chain	CompileError
@@8:	mov	byte ptr [bx],0
	inc	bx
	mov	TempBufPtr,bx
	mov	bx,SymbolValue.W0
	mov	[bx],cl
	mov	ax,_String
	dec	cx
	jnz	GiveConst
	mov	al,[bx+1]
	xor	ah,ah
	cwd
	mov	SymbolValue.W0,ax
	mov	SymbolValue.W2,dx
	mov	ax,_Char
GiveConst	label	near
	mov	SymbolType.offs,ax
	mov	ax,SystemUnit
	mov	SymbolType.segm,ax
	mov	al,t_Constant
	ret
String	endp

OParen	proc	near
	mov	al,tOParen
	cmp	ah,'.'
	jne	@@1
	mov	al,tOBracket
	inc	si
@@1:	inc	si
	ret
OParen	endp

CParen	proc	near
	mov	al,tCParen
	inc	si
	ret
CParen	endp

Times	proc	near
	mov	al,tTimes
	inc	si
	ret
Times	endp

Plus	proc	near
	mov	al,tPlus
	inc	si
	ret
Plus	endp

Comma	proc	near
	mov	al,tComma
	inc	si
	ret
Comma	endp

Minus	proc	near
	mov	al,tMinus
	inc	si
	ret
Minus	endp

Point	proc	near
	mov	al,tRange
	cmp	ah,'.'
	je	@@1
	mov	al,tPoint
	cmp	ah,')'
	jne	@@2
	mov	al,tCBracket
@@1:	inc	si
@@2:	inc	si
	ret
Point	endp

Slash	proc	near
	mov	al,SlashToken
	inc	si
	ret
Slash	endp

Colon	proc	near
	mov	al,tColon
	cmp	ah,'='
	jne	@@1
	mov	al,tAssign
	inc	si
@@1:	inc	si
	ret
Colon	endp

Semicolon	proc	near
	mov	al,tSemicolon
	inc	si
	ret
Semicolon	endp

Less	proc	near
	mov	al,tNotEqual
	cmp	ah,'>'
	je	@@1
	mov	al,tLess
	cmp	ah,'='
	jne	@@2
	mov	al,tLEq
@@1:	inc	si
@@2:	inc	si
	ret
Less	endp

Equal	proc	near
	mov	al,EqualToken
	inc	si
	ret
Equal	endp

Greater	proc	near
	mov	al,tGreater
	cmp	ah,'='
	jne	@@1
	mov	al,tGEq
	inc	si
@@1:	inc	si
	ret
Greater	endp

At	proc	near
	mov	al,tAt
	inc	si
	ret
At	endp

OBracket	proc	near
	mov	al,tOBracket
	inc	si
	ret
OBracket	endp

CBracket	proc	near
	mov	al,tCBracket
	inc	si
	ret
CBracket	endp

Caret	proc	near
	mov	al,tCaret
	inc	si
	ret
Caret	endp

ProcessCaret	proc	near
	cmp	CurrentToken,tCaret
	jne	@@1
	push	si di
	mov	di,FileStackPtr
	mov	si,[di].fsTextPos
	dec	si
	call	String
	mov	CurrentToken,al
	mov	di,FileStackPtr
	mov	[di],si
	pop	di si
@@1:	ret
ProcessCaret	endp

StandardDefines	proc	near
	mov	cx,DefL1
	Invoke	CheckFpu
	jnz	@@1
	mov	cx,DefL2
@@1:	lea	si,Defines
	mov	ax,DefinesPtr
	mov	di,ax
	add	ax,cx
	cmp	ax,offset DefinesBuf+1024
	ja	@@4
	mov	DefinesPtr,ax
	push	ds
	pop	es
	rep	movsb
	mov	si,InitDefines
@@2:	call	ParseString
	cmp	byte ptr [si],0
	je	@@3
	call	GetWord
	cmp	FileNameBuf[0],0
	je	@@5
	call	AddDefine
	jmp	@@2
@@3:	ret
@@4:	mov	ax,127
	Chain	CompileError
@@5:	mov	ax,130
	Chain	CompileError
StandardDefines	endp

GetRawToken	proc	near
@@1:	mov	di,FileStackPtr
	mov	si,[di].fsTextPos
@@2:	lodsb
	or	al,al
	jz	@@4
	cmp	al,' '
	jbe	@@2
	dec	si
	test	CompilerFlags.B0,cfDebugging
	jnz	@@6
	mov	ax,[si]
	cmp	al,'{'
	je	@@3
	cmp	ax,'*('
	jne	@@6
	inc	si
@@3:	inc	si
	call	ProcessComment
	jmp	@@2
@@4:	test	CompilerFlags.B0,cfDebugging
	jnz	@@5
	call	GetChar
	jnz	@@2
	mov	di,FileStackPtr
	mov	[di].fsTextPos,si
	call	PopFileStack
	jmp	@@1
@@5:	dec	si
@@6:	ret
GetRawToken	endp

ProcessComment	proc	near
	mov	StartToken,al
	cmp	byte ptr [si],'$'
	je	@@1
	jmp	SkipComment
@@1:	inc	si
	call	SearchDirective
	jc	DirError