varutil.asm

Dos6.0

	or	[mkVar.MKVAR_flags2],MV_fConstFound
						;remember we've seen a CONST
	jmp	short StdSearch_Cont6

StdSearch_Array_Checks:
	;ensure the existing array entry was built assuming at least as many
	;dimensions as actually exist. In addition, consider that we might
	;have found a module shared entry here, in which case we must make our
	;checks with the actual module level entry

	;new register use: bx = pVarEntry, i.e., ptr to the actual array entry
	;                  cx is updated if bx changes
	;                  dx = 0 if bx doesn't change, oVar of SHARED entry
	;                         if so

	xor	dx,dx				;assume pVar is correct (flag)
	mov	bx,di				;assume pVar is correct (pVar)
	cmp	[vm_fPVCur],FALSE
	jz	Not_PVCur			;brif procedure not active

	TESTX	cx,FVSHARED			; is this a SHARED entry?
	jz	Not_PVCur			;  brif not

	mov	dx,di
	sub	dx,si				;dx = oVar of proc. SHARED entry
	mov	bx,[di.VAR_value]		;ax = oVar
	add	bx,si				;ax = pVar of module entry
	mov	cx,[bx.VAR_flags]		;update for this entry	
Not_PVCur:
	mov	[oVarShared],dx			;0 in typical case
	mov	al,[bx.VAR_value.ASTAT_cDims]
	mov	ah,[mkVar.MKVAR_cDimensions]
	cmp	ah,al
	jz	StdSearch_Cont7a1		;brif entry cDims matches input

	or	ah,ah
	jz	StdSearch_Cont7a1		;brif input cDims == 0 (i.e.,
						;  if we don't want to change
						;  existing entry)
	TESTX	cx,FVVALUESTORED		; is entry a static variable?
	jz	StdSearch_Cont7a1		;  brif not - - no problem,
						;  var entry size is okay
	or	al,al				;entry cDims == 0?
	jnz	Wrong_Num_Subscripts		;  brif not - - - error

	cmp	ah,1				;input cDims == 1?
	jnz	Check_Var_Size			;  brif not

	mov	BYTE PTR [bx.VAR_value.ASTAT_cDims],1
						;already enough space, just
						;update cDims in var entry
StdSearch_Cont7a1:
	jmp	StdSearch_Cont7a
Check_Var_Size:
	test	cl,FVSTATIC			;was var declared STATIC?
	jz	Redirect_Array_Var		;  brif not

	cmp	ah,8
	jbe	Redirect_Array_Var		;brif okay - redirect entry to
						;  one that's big enough for
						;  new cDims count
Wrong_Num_Subscripts:
	mov	ax,PRS_ER_RE OR MSG_SubCnt	;'Wrong number of subscripts'
	jmp	StdSearch_Exit

Redirect_Array_Var:
	and	[bx.VAR_value.ASTAT_ad.AD_fFeatures],NOT FADF_STATIC
						;so B$IErase will deallocate

	mov	ax,bx
	sub	ax,si
	push	ax				;save oVar across call

	push	cx				;save entry flags across call	

	add	bx,VAR_value.ASTAT_ad		;bx points to array descriptor
	push	bx
	call	B$IERASE			;deallocate existing array

	pop	cx				;restore entry flags

	;Now create the new larger entry
	mov	ax,UNDEFINED			;assume module level
	cmp	[oVarShared],0			;special case of SHARED in prs?
	jnz	Create_The_Var			;  brif so

	cmp	[vm_fPVCur],FALSE		;procedure active?
	jz	Create_The_Var			;  brif not

	mov	ax,[prsCur.PRS_oVarHash]
Create_The_Var:
	push	[mkVar.MKVAR_oTyp]		;preserve in case of error
	mov	dx,[oTypNew]
	inc	dx
	.errnz	UNDEFINED - 0FFFFH
	jz	Create_The_Var1			;brif oTyp not changed

	dec	dx
	mov	[mkVar.MKVAR_oTyp],dx		;in case entry oTyp different
						;  from assumed one
Create_The_Var1:
	push	ax				;oVarHash
	push	cx				;entry flags
	call	CreateVar			;create larger array var entry
	pop	[mkVar.MKVAR_oTyp]		;restore in case of error
	pop	bx				;oVar saved from before erase
	or	ax,ax
	jnz	StdSearch_Exit			;brif some error

	mov	ax,[vm_oVarCur]
	mov	[vm_oVarTmp],ax			;oVar for new entry

	mov	[vm_oVarCur],bx			;existing entry
	push	[vm_fPVCur]
	cmp	[oVarShared],0			;found proc. shared entry, but
						;  need to ReDirect the module
						;  entry it points to?
	jz	Redirect_The_Var		;brif not

	mov	[vm_fPVCur],FALSE		;reference tMV if so
Redirect_The_Var:
	call	ReDirect			;redirect old entry
	pop	[vm_fPVCur]			;restore to entry value

	mov	si,[mrsCur.MRS_bdVar.BD_pb]	;in case of heap movement

	mov	bx,[vm_oVarTmp]			;oVar of newly created entry
	mov	di,[oVarShared]
	or	di,di
	jz	Get_oVarEntry			;brif typical case
	;di contains the oVar for the proc. SHARED entry we were searching for
	;  replace the value field in this entry with the oVar of the new
	;  entry and continue
	add	di,si				;pVar = proc SHARED entry
	mov	[di.VAR_value],bx		;replace oVar in SHARED entry
						;  with new value (old entry
						;  got ReDirected)
	add	bx,si				;pVarDims = new entry
	jmp	short Got_oVarEntry
Get_oVarEntry:
	add	bx,si				;pVarDims = new entry
	mov	di,bx				;pVar = new entry
Got_oVarEntry:

StdSearch_Cont7a:
	mov	al,[mkVar.MKVAR_cDimensions]
	or	al,al
	jz	StdSearch_Cont7			;brif input cDims == 0



	mov	[bx.VAR_value.ASTAT_cDims],al
StdSearch_Cont7:
	
	;note: we must do the following check AFTER we check for array vs.
	;      non-array, or we would be flagging some bogus DD errors

	TESTM	mkVar.MKVAR_flags,<FVSHARED OR FVCONST>	
	jnz	StdSearch_Shared_Or_Const	;brif either flag bit is set

StdSearch_Cont8:
	mov	[vm_fVarFound],TRUE
	mov	ax,[oTypNew]
	inc	ax
	.errnz	UNDEFINED - 0FFFFH
	jz	StdSearch_Cont9			;brif oTyp not changed

	mov	ax,[oTypNew]
	mov	[mkVar.MKVAR_oTyp],ax		;in case entry oTyp different
						;  from assumed one
StdSearch_Cont9:
	mov	[vm_pVarCur],di			;a return value
	sub	di,si
	mov	[vm_oVarCur],di

	sub	ax,ax				;return FALSE - no error
StdSearch_Exit:
	pop	di
StdSearch_Exit_1:
	pop	si
	ret

StdSearch_Shared_Or_Const:
	TESTM	di.VAR_flags,<FVFUN OR FVSTATIC OR FVFORMAL OR FVCONST>	
	jz	StdSearch_Cont8			;brif none of the above are set
	jmp	StdSearch_DD_Err1

StdSearch	ENDP

;***
;MakeVariableFar - Same as MakeVariable, but a far entry point
;Purpose:
;	Added as part of revision [12].
;	See MakeVariable.
;Entry:
;	See MakeVariable.
;Exit:
;	See MakeVariable.
;******************************************************************************/
cProc	MakeVariableFar,<FAR,PUBLIC,NODATA>
cBegin	MakeVariableFar
	call	MakeVariable
cEnd	MakeVariableFar


;***
;OVarOfRetVal
;Purpose:
;	In certain cases, the parser will emit the wrong pcode for return
;	values to FUNCTIONs and DEF FNs, with the result that the pcode will
;	be bound instead to the function reference instead of the return
;	value oVar.  The execute scanner will detect this case, and call this
;	routine for such cases to get the oVar for the return value.
;
;	Note: Guaranteed to cause no heap movement
;Entry:
;	AX = oVar is given for the reference (that was erroneously placed in
;		the pcode).
;Exit:
;	Returns AX = oVar for the return value, or AX has high bit set.
;******************************************************************************/
cProc	OVarOfRetVal,<PUBLIC,FAR>,<DI>		
cBegin
	DbChk	ConStatStructs
	DbHeapMoveOff				;depending on no heap movement
						;  in this routine
	xchg	ax,di				;di = oVar 
	mov	ax,[grs.GRS_oPrsCur]
	inc	ax
	.errnz	UNDEFINED - 0FFFFH
	jz	OVarOfRetVal_Err_Exit		;brif no active procedure
	dec	ax
	cCall	FieldsOfPrs,<ax>		;ax = oNam of prs
						;bx = pPrs (== prsCur)
						;dl = procType of prs
	cmp	dl,PT_SUB
	jz	OVarOfRetVal_Err_Exit		;brif active proc is a SUB

	add	di,[mrsCur.MRS_bdVar.BD_pb]	;di = pVar
	cmp	ax,[di.VAR_oNam]		;was given oVar for a ref. to
						;  prsCur?
	jnz	OVarOfRetVal_Err_Exit		;brif not

	mov	[mkVar.MKVAR_oNam],ax		;setup for MakeVariable call
	mov	al,[prsCur.PRS_oType]
	and	ax,M_PT_OTYPE			
	mov	[mkVar.MKVAR_oTyp],ax		;setup for MakeVariable call
	mov	[mkVar.MKVAR_flags],FVLVAL
	call	MakeVariable			;MUST succeed, because we always
						;  create the retval when we
						;  create a function ref. entry
	DbAssertTst  ah,z,080H,CP,<OVarOfRetVal: MakeVariable returned an error>
	jmp	short OVarOfRetVal_Exit

OVarOfRetVal_Err_Exit:
	or	ah,080H				;signal error return
OVarOfRetVal_Exit:
	DbHeapMoveOn				;heap movement allowed again
cEnd

;***
;AdjustVarTable
;Purpose:
;	This routine is called when a variable table is about to be moved.
;	Due to the overhead that would be required for the runtime to update
;	backpointers to AD's and SD's in static variable tables, we do this
;	work here.
;Input:
;	SI = ptr to the MRS_bdVar.BD_pb field in some mrs
;	DI = adjustment factor
;Output:
;	none
;Modifies:
;	SI
;***************************************************************************
cProc	AdjustVarTable,<FAR,PUBLIC,NODATA>
cBegin	
 	;Calculate the oMrs for this variable table, so we can get
	;at the hash tables for all the prs's
	mov	bx,[grs.GRS_oMrsCur]	;assume tVar is for mrsCur
	mov	ax,si
	mov	si,[si]			;si = pVarTable
	sub	ax,[MRS_bdVar.BD_pb]	;ax = pMrs
	cmp	ax,dataOFFSET mrsCur	;is tVar for mrsCur?
	jz	Got_oMrsBx		;  brif so

	sub	ax,[grs.GRS_bdRs.BD_pb] 
	xchg	ax,bx
Got_oMrsBx:				;bx = oMrs
	mov	ax,UNDEFINED		;start w/first prs in module
PrsAdjustLoop:
	xor	cx,cx			;cx == 0 --> include prs's for DEF FN's
	push	bx			;save oMrs
	call	GetNextPrsInMrs		;ax = an oPrs in module
	js	AdjustMrs		;brif no (more) prs's in this module

	push	ax			;save oPrs
	call	PPrsOPrs		;bx = pPrs
	mov	ax,PTRRS[bx.PRS_oVarHash] 
	inc	ax
	.errnz	UNDEFINED - 0FFFFH
	jz	AdjustNextPrs		;brif this prs has no hash table
	dec	ax

	push	si			;ptr to variable table
	push	ax			;offset to tPV hash table
	push	di			;adjustment factor
	call	AdjustPrsVarTable
AdjustNextPrs:
	pop	ax			;current oPrs - use to fetch next oPrs
	pop	bx			;oMrs of vartable
	jmp	short PrsAdjustLoop

AdjustMrs:
	pop	bx			;clean stack
	push	si			;ptr to variable table
	push	di			;adjustment factor
	call	AdjustMrsVarTable
cEnd	

;***
;oTypOfONamDefault
;Purpose:
;	Given an oNam, return the default oTyp of that name.
;	Note that 'logical first char' implies the third char of a
;	name which starts with 'FN' and the first char of any other name.
;Entry:
;	oNam
;	ps.tEtCur is filled with default types for 26 letters
;Exit:
;	ax = oTyp
;Exceptions:
;	none.
;Preserves:
;	ES
;
;******************************************************************************/
cProc	oTypOfONamDefault,<PUBLIC,FAR>,<ES>	
	parmW	oNam			
cBegin
	push	[oNam]			; pass oNam
	call	GetVarNamChar		;al = 1st logical char of name
	push	ax
	call	GetDefaultType		;al = default oTyp
cEnd

;***
;VarRudeReset - reset module Variable/Type table for Rude Edit
;Purpose:
;	This routine is called as part of descanning to SS_RUDE. The module
;	variable and type tables are reset, i.e., existing variables and types
;	are thrown out, and the table reinitialized.
;Entry:
;	mrsCur.bdVar is currently a heap owner.
;Exit:
;	None. Since the table is at least the same size on entry as it will
;	be on exit, Out of Memory is not possible.
;	The table is set to the same state it was at module creation time.
;Exceptions:
;	none.
;******************************************************************************/
cProc	VarRudeReset,<PUBLIC,NEAR>
cBegin
	PUSHI	ax,<dataOFFSET mrsCur.MRS_bdVar>
	cCall	BdFree

	cCall	MakeMrsTVar
	DbAssertRel  ax,nz,0,CP,<VarRudeReset: MakeMrsTVar returned OM error>
cEnd	VarRudeReset


;###############################################################################
;#                                                                             #
;#                            COMMON Support                                   #
;#                                                                             #
;###############################################################################
; For implementation details, see ..\id\common.doc

;***
;ClearCommon() - CLEAR all variables in all COMMON Blocks
;Purpose:
;	CLEAR all COMMON variables; this includes zeroing numeric vars, 
;	releasing all strings, and ERASing all arrays.
;	Note that this also removes all common blocks (except for blank
;	common) when fResetCommon is TRUE.
;	Note that this skips clearing blank common when fChaining is TRUE.
;Key Assumptions:
;	- Blank (a.k.a. unnamed) COMMON is always present, and is always the
;		first COM structure in bdtComBlk
;Entry:
;	grs.bdtComBlk is assumed to be set up.
;	fChaining flag
;	fResetCommon flag
;	fQlbCommon flag false
;Exit:
;	none.
;Exceptions:
;	none.
;*******************************************************************************
cProc	ClearCommon,<PUBLIC,NEAR,NODATA>,<SI,DI>
cBegin
	;Register Use:	SI points to current COM entry in bdtComBlk
	;		DI points just past last allocated COM entry
	mov	si,[grs.GRS_bdtComBlk.BD_pb]
	mov	di,si
	add	di,[grs.GRS_bdtComBlk.BD_cbLogical]

	cmp	[fChaining],FALSE	;Want to clear blank common too?
	jz	ClearCommon_Cont	;  brif so
ClearCommon_Loop:
	add	si,SIZE COM		;skip to next entry	
ClearCommon_Cont:
	cmp	si,di
	jae	ClearCommon_Exit	;brif no more COM entries