prslex.asm

[随书类]Dos6.0源代码

ScanGotOne:
	ret
ScanTok ENDP

;Entry:
;	ax = error code
;	bx = token descriptor
;
IdErr	PROC NEAR
	cmp	[ps.PS_errCode],0
	jne	Not1stErr		;brif not 1st error for this line
	call	ParseErr
Not1stErr:
	ret
IdErr	ENDP

;*********************************************************************
; VOID NEAR Peek1Tok()
;
; Purpose:
;	Set 'pTokPeek' pointing to the 1st non white-space token after
;	'pTokScan' for look-ahead.
; Exit:
;	bx points to current token (same as pTokPeek)
;
;*********************************************************************
;*********************************************************************
; VOID NEAR PeekNextTok()
;
; Purpose:
;	Advance 'pTokPeek' to point to the next non white-space token in
;	the circular token queue for look-ahead.
; Exit:
;	bx points to current token (same as pTokPeek)
;
;*********************************************************************
PUBLIC	Peek1Tok
Peek1Tok PROC NEAR
	mov	ax,[pTokScan]		;pTokPeek = pTokScan
	mov	[pTokPeek],ax
	;fall into PeekNextTok
Peek1Tok ENDP
PUBLIC	PeekNextTok
PeekNextTok PROC NEAR
	mov	ax,[pTokPeek]		;ax points to current 'peek' token
	mov	bx,ax			;bx points to current 'peek' token
	add	ax,CB_TOK		;advance to next token
	cmp	ax,dataOFFSET tLookAhead + (LOOK_AHEAD * CB_TOK)
	jb	PeekNoWrap		;brif if not wrapped around
	mov	ax,dataOFFSET tLookAhead;ax points to 1st token descriptor
PeekNoWrap:
	mov	[pTokPeek],ax		;save ptr to new 'peek' token
	jmp	SHORT ScanFetch 	;share code with ScanToken
PeekNextTok	ENDP

;**********************************************************************
; boolean NEAR TestScan_AX
; Purpose:
;	See if current token is a particular reserved word
; Entry:
;	pTokScan points to current token
;	ax = IRW_xxx for reserved word to be tested
; Exit:
;	bx = [pTokScan]
;	psw.z set if current token is desired reserved word
;
;*******************************************************************
PUBLIC	TestScan_AX
TestScan_AX PROC NEAR
	mov	bx,[pTokScan]		;bx points to current token
TestPeek_AX1:
	cmp	[bx.TOK_class],CL_resWord
	jne	TestScan_AXExit 	;if not res word, return NE
	cmp	ax,[bx.TOK_rw_iRw]	;if not expected one, return NE
TestScan_AXExit:
	ret
TestScan_AX ENDP

;**********************************************************************
; boolean NEAR TryScan_AX
; Purpose:
;	See if current token is a particular reserved word and if it
;	is then consume it.
; Entry:
;	pTokScan points to current token
;	ax = IRW_xxx for reserved word to be tested
; Exit:
;	if not matched then psw.z is cleared and bx = [pTokScan]  
;	otherwise psw.z is set
;
;*******************************************************************
PUBLIC	TryScan_AX
TryScan_AX PROC NEAR
	call	TestScan_Ax		;test for the reserved word
	jne	TrySExit		;brif not matched
	call	ScanTok			;consume it
	xor	ax,ax			;set psw.z
TrySExit:
	ret
TryScan_AX ENDP

;**********************************************************************
; boolean NEAR TestPeek_AX
; Purpose:
;	See if current PEEK token is a particular reserved word
; Entry:
;	pTokPeek points to next token
;	ax = IRW_xxx for reserved word to be tested
; Exit:
;	bx = [pTokPeek]
;	psw.z set if token is desired reserved word
;
;******************************************************************
PUBLIC	TestPeek_AX
TestPeek_AX PROC NEAR
	mov	bx,[pTokPeek]		;bx points to next token
	jmp	SHORT TestPeek_AX1
TestPeek_AX ENDP

;**********************************************************************
; boolean NEAR ConsumeRw_AX(ax:iRw)
; Purpose:
;	Make sure that the current token is the reserved word 'iRw'.
; Entry:
;	ax is offset into reserved word table for res word to be consumed
; Exit:
;	If reserved word was not found
;	   a complete error message is generated
;	   al = PR_BadSyntax
;	   carry is set
;	Else
;	   token is consumed
;	   bx = [pTokScan]
;	   carry is clear
;
;*******************************************************************
PUBLIC	ConsumeRw_AX
ConsumeRw_AX PROC NEAR
	mov	bx,[pTokScan]		;bx points to current token
	cmp	[bx.TOK_class],CL_resWord
	jne	ConRwErr		;branch if token isn't reserved word
	cmp	[bx.TOK_rw_iRw],ax	;compare with expected res word
	jne	ConRwErr		;branch if didn't get expected one
	call	ScanTok 		;consume token
	clc				;return SUCCESS
	ret

ConRwErr:
	call	PErrExpRw_AX		;Error "Expected <reserved word>"
					; al = PR_BadSyntax
	stc				;return error flag
	ret
ConsumeRw_AX ENDP

;*********************************************************************
; LexReset
; Purpose:
;	Reset the lexical analyzer's source pointer to the 1st char
;	of pTokScan's token.  This flushes the token peek-ahead queue.
;
;*********************************************************************
PUBLIC	LexReset
LexReset PROC NEAR
	mov	bx,[pTokScan]
	mov	[pTokLast],bx
	mov	ax,[bx.TOK_oSrc]
	add	ax,[ps.PS_bdpSrc.BDP_pb]
	mov	[ps.PS_bdpSrc.BDP_pbCur],ax ;setup to rescan same token
	jmp	ScanTok 		;bx points to current token
					;return to caller
LexReset ENDP

sEnd	CP


sBegin	CODE
assumes CS,CODE

;*********************************************************************
; void ScanLit
;	This function is based on code lifted from BASCOM
; Purpose:
;	Scan a number
; Entry:
;	si points beyond 1st source char in number
;	di points to token descriptor to be filled in on exit
; Exit:
;	si points to char which terminates number
;	token pointed to by di is filled in
;	If an error occurred, a runtime error is generated with
;	   a standard error msg (ER_xxx or MSG_xxx)
;
;*********************************************************************
l_s16inv=	80h		; 16 bit signed value is invalid
l_ind=		80h		; indefinite
l_inv=		40h		; invalid (no digits or syntax error)
l_s32inv=	20h		; 32 bit signed value is invalid
l_u32inv=	10h		; 32 bit unsigned value is invalid
l_long= 	08h		; l_Dexp or more than 7 digits
l_Dexp= 	04h		; explicit 'D' or 'd' seen
l_Rexp= 	02h		; explicit 'E' or 'e' seen
l_inf=		01h		; DP overflow

dbPub	ScanLit
cProc	ScanLit,<FAR>			
cBegin	ScanLit				
	dec	si			;si points to 1st letter of number
	mov	[di.TOK_CLASS],CL_LIT	;token class = Literal
	push	di			;save pointer to token descriptor
	add	di,TOK_lit_value_R8	;di points to number's result field
	cmp	byte ptr [si],'&'	; check for special radix constant
	jne	DNSgetnum		;   no - normal number

;	read special radix numbers as unsigned 16 or 32 bit integers

	inc	si			; skip past 1st &
	lodsb				; get next character (H or O)
	or	al,20h			; map letter to lower case
	mov	bx,(LIT_H4 * 100h) + 10h; assume hex
	cmp	al,'h'
	je	DNSerad 		;   yes

	mov	bx,(LIT_O4 * 100h) + 8	; assume octal
	cmp	al,'o'
	je	DNSerad 		;   yes


	dec	si			; must be octal - move back pointer
DNSerad:
	push	bx			; save bh = LIT_xxx
	xor	bh,bh			; bx = bl = base
	call	DoInput			; [bx:ax] = result if integer/long
	pop	dx			; [dh] = LIT_xxx
	pop	di			; di points to token descriptor

	test	cl,l_u32inv		; check if overflow error
	jnz	DNSovr
	test	cl,l_inv		; check syntax err
	jnz	DNSsyn
	cmp	byte ptr [si],'&'	; long?
	je	EatExpLng		; brif explicitly LONG
	or	bx,bx			; if BX<>0, can't be 16-bit integer
	je	ItsShort		
	cmp	byte ptr [si],'%'	; short?
	jne	DNSradlng		; brif not explicitly SHORT
;Overflow error
DNSovr:
	mov	ax,ER_OV		; input number overflow
	jmp	SHORT DNSerr

EatExpLng:
	inc	si			; consume '&'
	jmp	SHORT DNSradlng

ItsShort:
	sub	dh,3			; map LIT_x4 to LIT_x2
.errnz	LIT_H4 - LIT_H2 - 3		; in case values of constants change
.errnz	LIT_O4 - LIT_O2 - 3		; in case values of constants change
	cmp	byte ptr [si],'%'	; short?
	jne	DNSradint		; brif not explicit SHORT
	inc	si			; consume '&'
;dh = literal type (LIT_xxx)
DNSradint:
	mov	dl,ET_I2		; integer
DNSradintlng:
	mov	[di.TOK_lit_value_I2],ax	; save low part of integer
	xchg	ax,dx			; al = value type, ah = literal type
	jmp	DNSchkdbl		; save type and exit

;dh = literal type (LIT_xxx)
DNSradlng:
	mov	dl,ET_I4		; long integer
	mov	[di.TOK_lit_value_I2+2],bx	; save high part of long integer
	jmp	SHORT DNSradintlng

DNStyp:
	inc	si			; eat invalid type character
DNSsyn:
	mov	ax,MSG_IllegalNumber	; input number syntax error
DNSerr:
	call	RtErrorCODE		; error (ax)

DNSgetnum:
	call	TryI2		;if its an I2, don't call $i8_input (pig slow)
	jc	NotAnI2		;brif not a valid I2
	pop	di		;restore token pointer
	mov	dh,LIT_I2
	jmp	SHORT DNSradint	;brif AX = valid I2

NotAnI2:
	xor	bx,bx		; (BX) = 0 (default radix)
	call	DoInput		; [bx:ax] = result if integer/long
				; [di] = R8 result
	pop	di		; di points to token descriptor

	test	cl,l_inv+l_ind	; check if syntax error
	jnz	DNSsyn
	test	cl,l_inf	; check if d.p. overflow
	jnz	DNSovr

;	check if number could be 16-bit integer

	test	cl,l_s32inv	; check if valid 32-bit integer
	jnz	DNSinv16	;   no - not valid 16-bit either
	cwd
	cmp	bx,dx
	je	DNSchkexp

DNSinv16:
	or	cl,l_s16inv	; mark as invalid 16-bit integer

;	check for explicit E or D

DNSchkexp:
	test	cl,l_Rexp+l_Dexp ; check if explicit E or D
	jz	DNSchktyp	;  no - test for explicit type char
	or	[di.TOK_lit_flags],FLIT_exp
	jmp	SHORT DNSsav	;  explicit types not allowed

;	check if trailing type character

DNSchktyp:
	cmp	byte ptr [si],'#' ; double precision?
	je	DNSdbl		  ;   yes
	cmp	byte ptr [si],'!' ; single precision?
	je	DNSsng		  ;   yes
	cmp	byte ptr [si],'%' ; integer?
	je	DNSint		  ;   yes
	cmp	byte ptr [si],'&' ; long?
	jne	DNSsav		  ;   no

DNSlng:
	test	cl,l_s32inv	; check if valid 32-bit integer
	jnz	DNStyp		;   no - type character error
	or	cl,l_s16inv	; force it long
	jmp	SHORT DNSsavi

DNSint:
	test	cl,l_s16inv	; check if valid 16-bit integer
	jnz	DNStyp		;   no - type character error
	jmp	SHORT DNSsavi

DNSdbl:
	or	cl,l_long+l_s32inv+l_s16inv ; force it double
	jmp	SHORT DNSsavi


DNSsng:
	and	cl,not l_long	; force it single
	or	cl,l_s32inv+l_s16inv

DNSsavi:
	inc	si		; skip over explicit type character

;	have number - now save it

DNSsav:
	mov	dh,LIT_I2
	test	cl,l_s16inv	; check if 16-bit integer
	jz	jDNSradint	;   yes

DNSchklng:
	mov	dh,LIT_I4
	test	cl,l_s32inv	; check if 32-bit integer
	jz	jDNSradlng	;   yes

DNSchksng:
	mov	ax,(LIT_R8 * 100h) + ET_R8	;assume double precision
	test	cl,l_long	; check if double
	jnz	DNSchkdbl	;   yes

	push	di		;save ptr to token descriptor

	add	di,TOK_lit_value_R8	;di -> number's result field
	fld	qword ptr [di]	;pass R8 value
	fstp	dword ptr [di]	;pop R4 value
	pop	di		;di points to token descriptor
	mov	ax,(LIT_R4 * 100h) + ET_R4	;single precision
	fwait			

; al = value type, ah = literal type
DNSchkdbl:
	mov	[di.TOK_lit_type],al	; value type (ET_xxx)
	mov	[di.TOK_lit_litType],ah ; constant type (LIT_xxx)
DNSxit:
cEnd	ScanLit				


jDNSradint:
	jmp	DNSradint

jDNSradlng:
	jmp	DNSradlng

DoInput PROC NEAR
	mov	cx,[ps.PS_bdpSrc.BDP_pb] ;cx = start of bdpSrc buffer
	add	cx,[ps.PS_bdpSrc.BDP_cbLogical] ;cx = end of bdpSrc buffer+1
	sub	cx,si			;cx = remaining number of bytes in
					;     buffer past si
	xor	ax,ax			; no scale factor
	cwd				; (DX) = 0 (FORTRAN garbage)
	mov	[$i8_inpbas],1		; use BASIC sematics for E and D
	push	bp
	extrn	$i8_input:near
	call	$i8_input		; [bx:ax] = long integer
	pop	bp
	mov	[$i8_inpbas],0		; clear BASIC input flag
	ret
DoInput ENDP


;*********************************************************************
;TryI2
;Purpose:
;	Try to parse an I2 so we don't have to call $i8_input (its slow)
;Entry:
;	si points to 1st digit of number
;Exit:
;	if valid I2 was consumed,
;	   carry is clear
;	   si points beyond last digit of number
;	else
;	   carry is set
;	   si points to 1st digit of number
;
;*********************************************************************
dbpub	TryI2
cProc	TryI2,<NEAR>
cBegin
	push	si
	sub	dx,dx			;acc=0
NextDigit:
	lodsb				;al = next digit
	sub	al,'0'			;map '0'..'9' to 0..9
	jc	EndOfDigits		;brif < '0'
	cmp	al,9
	ja	EndOfDigits
	cmp	dx,3275d
	ja	NotI2			;brif result could be > 32759
	add	dx,dx			;acc = acc*2
	mov	cx,dx			;cx  = acc*2
	add	dx,dx			;acc = acc*4
	add	dx,dx			;acc = acc*8
	add	dx,cx			;acc = acc*10
	cbw
	add	dx,ax			;acc = acc*10 + new digit
	jmp	SHORT NextDigit

;al = terminating digit - '0'
EndOfDigits:
	mov	bx,ax			;bl = terminating digit - '.'
	push	di
	push	ds
	pop	es			;es = DGROUP
	lea	di,tbFloat		;si points to table of letters that
					; would mean the number is not an I2
	mov	cx,CB_tbFloat
	repne	scasb			;search for found opcode in table
	pop	di
	je	NotI2			;brif terminated with '.'
	pop	ax			;discard entry si
	dec	si			;si points to terminating digit
	xchg	ax,dx			;return result in dx
	clc
	jmp	SHORT TryI2Exit

NotI2:
	pop	si			;restore ptr to start of digits
	stc
TryI2Exit:
cEnd

sEnd	CODE

end