prsid.asm

Dos6.0

;				SEG x, or BYVAL x is seen
;if     FV_ARYELEM
;		NTEL_STOPONTO is set if TO was encountered
;endif ;FV_ARYELEM
;endif ;NOT FV_QB4LANG
;
;*********************************************************************
DbPub	NtExprList
cProc	NtExprList,<NEAR>,<di>
cBegin
	xor	di,di			;initialize arg count to 0
	mov	ax,IRW_LPAREN
	call	TryScan_AX		;consume "(" if present
	mov	ax,PR_NotFound		;assume "(" not found
	jne	NoArrayArg		;brif "(" not found

NtELLoop:
	call	NtExp			
	jg	NtELGotArg		;brif result is PR_GoodSyntax
	jl	NtELBadSyn		;brif result is PR_BadSyntax
	call	PErrExpExpr		;error "Expected expression"
	jmp	SHORT NtELBadSyn
NtELGotArg:
	inc	di			;bump arg count
.erre	MAXARG EQ MAXDIM		;since NtExprList used for parsing
					; both arg list Call-Less call w/
					; parens and array on lhs of assgn
	cmp	di,MAXARG		
	jae	ConsumeRParen		
	mov	ax,IRW_Comma
	call	TryScan_AX		;try to consume a ","
	je	NtELLoop		;if "," found then repeat loop


ConsumeRParen:
	mov	ax,IRW_RPAREN
	call	ConsumeRw_AX		;consume ")" if present
	jc	NtELBadSyn		;brif not found al = PR_BadSyntax
	mov	al,PR_GoodSyntax	;found it --- return PR_GoodSyntax
	
NoArrayArg:
	mov	cx,di			;return cx = arg count
NtELBadSyn:
	or	al,al			;set condition codes for caller
cEnd

;*********************************************************************
; EnsRude
; Purpose:
;	This is called by parser non-terminals that require current
;	text table to be in SS_RUDE state.  If current table isn't
;	an error is generated that will force ParseLine's caller
;	to descan to SS_RUDE.
;	The reason we need to retry the call to ParseLine after
;	calling AskRudeEdit is because the pcode already emitted for this
;	line could have been emitted in SS_PARSE, and the pcode for
;	the rest of the line would be emitted in SS_RUDE.
; Exit:
;	if already in SS_RUDE
;	   Condition codes = Z
;	else
;	   Condition codes = NZ
;	   Either PSF_UndoEdit or PSF_fRetry bits are set in ps.flags
;	
;*********************************************************************
EnsRude PROC NEAR
	cmp	[txdCur.TXD_scanState],SS_RUDE
	je	AlreadyRude		;brif scan-state = SS_RUDE

	call	ParseUndo		;We must call this before ModuleRudeEdit
					; or else we will try to free some
					; DEF FN prs's which no-longer exist
	call	AskRudeEdit		;see if user wants to back out of edit
	mov	al,PSF_UndoEdit
	je	ErBackOut		;brif user wants to back out
	mov	al,PSF_fRetry		;tell caller to call ParseLine again
ErBackOut:
	or	[ps.PS_flags],al
	mov	ax,ER_IER
	call	ParseErr0		;stop's subsequent calls to MakeVariable
	or	al,al			;set nz condition codes
AlreadyRude:
	ret
EnsRude	ENDP


;*=========================================================================
;*    I D    R E L A T E D    N O N - T E R M I N A L    F U N C T I O N S
;*
;*    NOTE:  These functions are arranged alphabetically
;*
;*=========================================================================

;*********************************************************************
; PARSE_RESULT NEAR NtACTIONidCommon()
; Purpose:
;	Remember that subsequent ids in this statement have this attribute.
;	This occurs in the following statement:
;	   COMMON [/id/] ACTIONidCommon ...
;
;*********************************************************************
PUBLIC NtACTIONidCommon
NtACTIONidCommon PROC NEAR
	call	EnsRude
	mov	ax,FVI_COMMON
	jmp	SHORT SetIdMask
NTACTIONidCommon ENDP

;*********************************************************************
; PARSE_RESULT NEAR NtACTIONidShared()
; Purpose:
;	Remember that subsequent ids in this statement have this attribute.
;	This occurs in the following statement:
;	   SHARED ACTIONidShared IdAry {tkComma IdAry}
;
;*********************************************************************
PUBLIC NtACTIONidShared
NtACTIONidShared PROC NEAR
	mov	ax,FVI_SHARED
	jmp	SHORT SetIdMask
NTACTIONidShared ENDP



;*********************************************************************
; PARSE_RESULT NEAR NtACTIONidStatic()
; Purpose:
;	Remember that subsequent ids in this statement have this attribute.
;	This occurs in the following statement:
;	   STATIC ACTIONidStatic IdAryI {tkComma IdAryI}
;
;*********************************************************************

;*********************************************************************
; STATICF(PARSE_RESULT) SetIdMask(mask)
;
; Purpose:
;	Set one or more of the following flags into mkVar.flags:
;	   FVI_COMMON    if input is from a COMMON statement [QB4]
;	   FVI_STATIC    if input is from a STATIC statement
;	   FVI_SHARED    if SHARED keyword associated with var [QB4]
;
; NOTE:  NtExp() preserves the value of mkVar.flags and
;	      sets it to 0 for all id's encountered within the expression
;
;*********************************************************************
PUBLIC NtACTIONidStatic
NtACTIONidStatic PROC NEAR
	mov	ax,FVI_STATIC
NTACTIONidStatic ENDP
	;fall into SetIdMask
SetIdMask PROC NEAR
	or	[mkVar.MKVAR_flags],ax
RetGoodSyntax:
	mov	al,PR_GoodSyntax
	ret
SetIdMask ENDP


;*********************************************************************
; PARSE_RESULT NEAR NtAsClause(al=flags, bx=pTokId)
; Purpose:
;	Parse AS (ANY | INTEGER | LONG | SINGLE | DOUBLE | STRING * n | id)
;
; Entry:
;	al = flags, set as follows:
;	     FAS_fNoVarLenStr if no var length STRING syntax is allowed
;		(this flag is ignored if FV_FARSTR is true)
;	     FAS_fNoFixLenStr if no fixed length STRING/TEXT syntax is allowed
;	     FAS_fAllowAny if AS ANY or AS FIELD (EB) is allowed
;	     FAS_fDontBind if we're not to call RefType(x) for
;	       id as x  (set if AS clause is seen inside TYPE/END TYPE block)
;	     FAS_fDontSetONam if we're not to set FOO's NM_fAs [QB4]
;	       bit if we see FOO AS BAR.  Setting this bit prevents any
;	       variables/constants/procedures named FOO.xxx
;	     FAS_fNoUserType if AS <userType> is not allowed and
;				FORMs not allowed (EB).
;	     FAS_fField if As Field allowed (EB)
;	bx = pTokId points to token for variable (i.e. to FOO for case
;	     FOO AS BAR)
;	pTokScan points to AS token
;	If RefTyp is not to be called for this variable, pTokId = NULL
;
; Exit:
;	If good syntax, emits the following pcode and returns PR_GoodSyntax:
;	  AS ANY ==> opAsTypeExp(ET_IMP,column)
;	  AS INTEGER ==> opAsTypeExp(ET_I2,column)
;	  AS LONG ==> opAsTypeExp(ET_I4,column)
;	  AS SINGLE ==> opAsTypeExp(ET_R4,column)
;	  AS DOUBLE ==> opAsTypeExp(ET_R8,column)
;	  AS STRING ==> opAsTypeExp(ET_SD,column)
;	  AS STRING * nn ==> opAsTypeFixed(0x8000 + ET_SD, nn, column)
;	     (only valid if fInType is TRUE)
;	  AS STRING * <symbolic const> ==> 
;			opAsTypeExp(0x8000 + ET_SD,oNam,column)
;	     (only valid if fInType is TRUE)
;	  AS CURRENCY (if FV_CURRENCY)  ==> opAsTypeExp(ET_Cy,column)
;	  AS TEXT (if EB) ==> opAsTypeExp(ET_Tx,column)
;	  AS FORM <command equivalent> (if EB) ==> opCmdAsType(iCe , column)
;	  AS <id> ==> opAsType(<oNam for id>,column)
;	  if pTokId is not NULL, pTokId->id.oTyp = oTyp from AS clause
;
;	Else returns PR_NotFound or PR_BadSyntax
;	Condition codes set based on result in al
;
;*********************************************************************
FAS_fNoVarLenStr	EQU 01h
FAS_fAllowAny		EQU 02h
FAS_fDontBind		EQU 04h
FAS_fDontSetONam	EQU 08h
FAS_fNoFixLenStr	EQU 10h
FAS_fNoUserType		EQU 20h

PUBLIC	NtAsClause	;for debugging
cProc	NtAsClause,<NEAR>,<si,di>
	localB	flags
	localW	columnAs		;source column where AS occurred
	;register si = pTokId
	;register di = oTyp
cBegin
	mov	[flags],al
	mov	si,bx			;si = pTokId
	mov	ax,IRW_AS
	call	TestScan_AX
	mov	al,PR_NotFound		;prepare to return NotFound
	jne	J1_NtAsExit		;brif current token isn't 'AS'
	mov	ax,[bx.TOK_oSrc]	;ax = column for AS
	mov	[columnAs],ax
	call	ScanTok			;consume 'AS' token


	mov	ax,STI_AsClausePrim + OFFSET CP:tState
	test	[flags],FAS_fNoUserType
	jne	CallParse		;brif AS <userType> not allowed
	mov	ax,STI_AsClauseAny + OFFSET CP:tState ;parse AS <type>
	test	[flags],FAS_fAllowAny
	jne	CallParse		;brif AS ANY not allowed
	mov	ax,STI_AsClause + OFFSET CP:tState ;parse AS <type | userType>
CallParse:
	mov	[pStateLastScan],ax	;setup for call to PErrState below
	call	NtParse			;al = parse result for AS <clause>
	jg	GoodAs			;brif good syntax
	jl	J1_NtAsExit		;brif bad syntax -- only occurs if 
					; user defined types are allowed and
					; an invalid identifier was encountered
	call	PErrState		;output 'expected INTEGER, SINGLE, ...
					; based on pStateLastScan above
					;al = PR_BadSyntax
J1_NtAsExit:
	jmp	NtAsExit		;brif NtParse=PR_BadSyntax/PR_NotFound

;Pcode emitted by NtParse(AsClause) is:
; opAsType(oTyp)
; opAsTypeExp(ET_I2)
;   :
; opAsTypeExp(ET_SD)
;
GoodAs:
	call	RudeIfErr		;if this line gets any kind of error,
					; we will descan to ss-rude.  First,
					; ask user if he wants to back out of
					; edit for Edit & Continue.
	cmp	[si.TOK_id_oTyp],ET_IMP
	je	NotAsExplicitId		;brif not implicit id
; Got As Explicit Id
	mov	bx,[pTokScan]
	mov	ax,[si.TOK_oSrc]	;ax = column id began in
	mov	[bx.TOK_oSrc],ax	;set field used by PErrMsg
	mov	ax,MSG_IdImp		;error: id can't end with $!#&%
	jmp	NtAsErrMsg

NotAsExplicitId:
	mov	bx,[ps.PS_bdpDst.BDP_pbCur]
	mov	di,[bx-2]		;di = oTyp or oNam from AS clause
	cmp	WORD PTR [bx-4],opAsType 
	jne	NtAsNotUser		;brif didn't get id AS <user type>
					; may have been id AS INTEGER
					; or id AS ANY

;Got user type like FOO AS BAR
;di = oNam for BAR, not oTyp
;Set namtbl bit NM_fAS for x, so lexer knows all future references to A.B
; are 3 tokens.
;
	test	[flags],FAS_fDontSetONam
	jne	DontSetAsBit
	mov	al,MSG_BadElemRef	;identifier cannot have "."
	test	[si.TOK_id_lexFlags],FLX_hasPeriod
	jne	NtAsErrSiAl		;brif id.anything AS <usertype>

	mov	al,PUNDO_oNamAs		;pass entry type in al
	mov	dx,[si.TOK_id_oNam]	;pass oNam in dx
	call	ParseUndoLog		;remember to undo SetONamMask if
					; we turn this line into a reparse

	push	[si.TOK_id_oNam]	;pass oNam
	PUSHI	ax,NM_fAS		;pass mask for bit to be set
	call	SetONamMask		;set flag, dl=old value of flag
	test	dl,NM_fAS
	jne	DontSetAsBit		;brif bit was already set, no change
	or	[mrsCur.MRS_flags],FM_asChg
					;causes PreScanAsChg before scanning
					;to convert any A.B id references
					;into record elements
DontSetAsBit:
	test	[flags],FAS_fDontBind
	jne	J1_NtAsEnd		;brif no need to call RefTyp
	test	[psFlags],PSIF_fBindVars
	je	J1_NtAsEnd		;brif parser not binding variables

	mov	ax,[ps.PS_otxLine]	;pass source offset of reference
	mov	dx,UNDEFINED
	;can't test [txdCur.TXD_flags],FTX_mrs because prs's text table
	; isn't created until after parsing "SUB id(x AS foo)" line
	
	cmp	[grs.GRS_oPrsCur],dx
	je	NotInSubOrFunc		;brif ref isn't in SUB/FUNCTION
	cmp	[prsCur.PRS_procType],PT_DEFFN
	je	NotInSubOrFunc		;brif ref is in DEF FN
	xchg	ax,dx			;ax = UNDEFINED, because all
					; TYPEs are defined at module level,
					; so are available to any SUB/FUNCTION
NotInSubOrFunc:
	push	di			;pass oNam to RefType
	push	ax			;pass otx to RefType
	call	RefTyp			;ask type mgr for oTyp of AS id
	mov	di,ax			;di = ax = oTyp
	or	ax,ax
	jns	J1_NtAsEnd		;brif no error
;si = id token ptr, al = error code
NtAsErrSiAl:
	sub	ah,ah			;low byte has QBI Std Error Code
	mov	bx,si
	call	ParseErr		;ParseErr(ax,bx)

J1_NtAsEnd:
	jmp	SHORT NtAsEnd	

;Got explicit type like AS INTEGER or AS ANY
NtAsNotUser:
	cmp	di,ET_SD
	jne	NtAsEnd			;brif not STRING in TYPE stmt
NtAsTestFlags:
	test	[flags],FAS_fNoFixLenStr
	jne	NtAsEnd			;brif can't accept fixed len string
	test	[flags],FAS_fNoVarLenStr
	jne	GetFixed		;brif can't accept var len string

	;We can accept either fixed length, or variable length string syntax
	mov	ax,IRW_Mult		;Consume "* const" clause
	call	TestScan_AX
	jne	NtAsEnd			;brif didn't get * (fixed len string)
GetFixed:
	mov	ax,IRW_Mult		;Consume "*"
	call	ConsumeRw_AX
	jc	NtAsExit		;brif syntax error (al = PR_BadSyntax)
	add	di,ET_FS-ET_SD		;Convert oTyp to fixed variant
	call	IdTok			;bx points to current token
	jne	NotSymConst		;brif its not an id token
	push	[bx.TOK_id_oNam]	;preserve oNam
	call	ScanTok			;consume symbolic constant's token
	pop	ax			;ax = oNam of symbolic constant
	mov	bx,[ps.PS_bdpDst.BDP_pbCur]
	mov	dx,di			;dx = oTyp
	or	dh,80h			;set high bit of oTyp to store
					;  in pcode
	;set flag so we can tell MakeVariable that fsLength is oNam
	; of symbolic constant.
	
	or	[si.TOK_id_lexFlags],FLX_asSymConst

	jmp	SHORT UpdatePcode
NotSymConst:
	call	NtLitI2NoCode		;consume integer (if any)
					;bx points to I2 value in pcode buf
	jl	NtAsExit		;brif PR_BadSyntax
	je	NtAsSnErr		;brif PR_NotFound
	mov	ax,[bx]			;ax = string length
	or	ax,ax			
	jnz	GotGoodLen		;brif string length is > zero
	mov	ax,MSG_IllegalNumber	
	call	PErrPrevTok_Ax		
	jmp	SHORT NtAsExit
GotGoodLen:
	mov	dx,di			;dx = oTyp
UpdatePcode:
	mov	[bx-2],dx		;replace the old oTyp operand in pcode
	mov	dx,opAsTypeFixed	;change opcode from opAsTypeExp to
	mov	[bx-4],dx		;  opAsType2

.errnz MKVAR_fsLength - MKVAR_oNamForm	
NtAsEmitExtraOperand:
	mov	[mkvar.MKVAR_fsLength],ax ;oNam/cb passed to makevariable
	call	Emit16_Ax		;emit number of bytes or oNam
					; of constant which gives # of bytes
NtAsEnd:
	mov	ax,[columnAs]		
	call	Emit16_AX		;emit column operand
	mov	[si.TOK_id_oTyp],di	;set the variable's oTyp
	or	[si.TOK_id_vmFlags],FVI_ASCLAUSE
	mov	al,PR_GoodSyntax	;return PR_GoodSyntax
NtAsExit:
	or	al,al			;set condition codes for caller
cEnd

NtAsSnErr:
	mov	ax,ER_SN		;Syntax Error
NtAsErrMsg:
	call	PErrMsg_AX		;al = PR_BadSyntax
	jmp	SHORT NtAsExit		;return PR_BadSyntax


;*********************************************************************
; NtLitI2NoCode
; Purpose:
;	Parse a signed integer