ssdeclar.asm

[随书类]Dos6.0源代码

	add	bx,[bp-SsCom].COM_bdType.BD_pb	;Point into type table

	;First check no. of dimensions

	cmp	ch,[bx+1]			;Make sure both are arrays
	jnz	TypTabErrNz
	or	cl,cl				;cDims not set in Var Table?
	jz	CompArElem			;Ignore count if not known
	cmp	cl,[bx]				;cDims match with type table?
	jz	CompArElem
	cmp	byte ptr [bx],0			;cDims not set in type table?
	mov	ax,MSG_SubCnt
	jnz	ComErr				;Index count error
	mov	[bx],cl				;Set cDims in type table
CompArElem:
	;Compare element type
	inc	bx
	inc	bx				;Point to element type
CompType:
	cmp	dx,ET_MAX			;Record type?
	ja	CompRec 			; Must compare across modules
	cmp	dx,[bx]				;ET types match?
TypTabErrNz:
	jne	TypTabErr
	.erre	ET_MAX LE 100h			; ET_FS in single byte
	cmp	dl,ET_FS			
	jb	SkipOTyp			; brif not fixed string
	inc	bx				
	inc	bx				; Point to length
	mov	ax,[bp-SsCom].COM_cbFixed	; Get length to Var table
	cmp	ax,word ptr [bx]		; Compare to common length
	jne	TypTabErr			

SkipOTyp:
	inc	bx
	inc	bx
	sub	bx,[bp-SsCom].COM_bdType.BD_pb	;pTypCur --> oTypCur
	mov	[bp-SsCom].COM_oTypCur,bx	;Update position in type table
CommonX:
	GetSegTxtCur				
	jmp	[ScanRet]

CompRec:
	mov	cx,[bx]				;Get oType
	cmp	cx,ET_MAX			;Is it a record?
	jbe	TypTabErr			; brif not record
	cmp	ch,LengthFlag			;Reduced to just a length?
	jz	CompLength

	mov	ax,[bx+2]			;Get oRS of this oTyp
	push	bx
	mov	bx,[grs.GRS_oRsCur]
	cCall	CompareTyps,<ax,bx,cx,dx>	
	REFRESH_ES				
	pop	bx
	or	ax,ax				
CompRecResults:
	jnz	TypTabErr
	inc	bx
	inc	bx
	jmp	SkipOTyp

CompLength:
	xchg	ax,dx				;oTyp to ax
	call	CbTypOTypSCAN			; Get its length
	cmp	ax,[bx+2]			;Match type table?
	jmp	CompRecResults

TypTabErr:
	mov	ax,ER_TM
ComErr:
	call	SsError
	jmp	CommonX
	
StaticCommon:
	;See if there's a type in table
	;cl = cDims
	;dx = oTyp
	;ds:bx = pVar

        mov     ch,cDimsFlag+StaticFlag
	push	[bx].VAR_value.ACOM_oValue	; Push oTxDim
	mov	ax,[bp-SsCom].COM_oTypCur	;Current type table offset
	inc	ax
	inc	ax				;Skip cDims
	mov	[bx].VAR_value.ACOM_oValue,ax	;Value is offset to AD
	dec	ax
	dec	ax
	xchg	bx,ax				;oTypCur to bx
	cmp	bx,[bp-SsCom].COM_bdType.BD_cbLogical	;Have entry in table?
	jae	NewStatic

	;Compare with existing type

	add	bx,[bp-SsCom].COM_bdType.BD_pb	;Point into type table

	;First check no. of dimensions

	cmp	cx,[bx]				;Make sure both are arrays
	xchg	ax,cx				;cDims to al
	pop	cx				;Get oTxDim
	jnz	TypTabErr
	cbw					;Zero ah
.errnz  size DM - 4
        shl     ax,1
        shl     ax,1
        add     ax,size AD-1		;ax = size of AD
        sub     sp,ax
	mov	bx,sp			;bx = pAD
	call	ExecDim

	;AX = Size of array in bytes

	push	si
	push	di
	mov	si,sp
	add	si,(size AD-1)+4	;Point to start of DM fields
	mov	di,bx			;pTypCur
	mov	cl,[di]			;Get cDims again
	add	di,(size AD-1)+2	;Skip cDims and AD header
	xor	ch,ch
	shl	cx,1			;2 words/dimension
	mov	ax,cx
	push	ds
	pop	es
	rep	cmpsw			;Compare dimensions
	mov	bx,di			;Pointer to element type
	pop	di
	pop	si
	call	TMErrorNz
	shl	ax,1			;cb of dimensions
	add	ax,size AD-1
	add	sp,ax			;Remove AD from stack
	jmp	CompType

NewStatic:
	;cl = cDims, ch = $STATIC array flags
	;dx = oTyp
	;bx = oTypCur
	;[sp] = oTxDim

	mov	ax,cx
	cbw				;Zero ah
        shl     ax,1
        shl     ax,1
	add	ax,(size AD-1)+2	;cDims, size, and AD header
	push	bx			;oTypCur
	add	bx,ax			;Make room for dimensions
	call	ExtendType
	pop	ax
	jc	ShrinkType		;Didn't fit
	xchg	bx,ax			;oTypCur to bx, ax points after AD
	add	bx,[bp-SsCom].COM_bdType.BD_pb	;Point into type table
	mov	[bx],cx			;Set array type, cDims
	pop	cx			;Get oTxDim
	push	ax			;points after AD
	inc	bx
	inc	bx			;bx = pAD
	call	ExecDim
	jc	ShrinkType		;Remove this entry from type table
	mov	[bx+2].AD_fhd.FHD_hData,DGROUPSEG   ;Allocated in DGROUP
	mov	[bx+2].AD_fhd.FHD_cPara,ax ;Use size that's been rounded even
	neg	ax
	add	ax,[bp-SsCom].COM_oValCur ;Array starts at oValCur
	add	ax,[bp-SsCom].COM_bdValue.BD_pb
	mov	[bx+2].AD_fhd.FHD_oData,ax
	pop	bx			;Offset to element type
	add	bx,[bp-SsCom].COM_bdType.BD_pb
	jmp	short SetOTyp

ShrinkType:
	pop	dx			;Clean off stack
	mov	bx,[bp-SsCom].COM_oTypCur
	mov	[bp-SsCom].COM_bdType.BD_cbLogical,bx
CommonXj:
	jmp	CommonX

ComErrJ:
	jmp	ComErr

NewArType:
	inc	bx
	inc	bx				;Skip over cDims word
NewType:
	call	ExtendType
	jc	CommonXj
	add	bx,[bp-SsCom].COM_bdType.BD_pb	;Point into type table
	cmp	ch,cDimsFlag			;Have an array?
	jnz	SetOTyp
	mov	[bx-2],cx			;Set cDims
	cmp	cl,ComDimCnt			;Max allowed dimensions
	mov	ax,MSG_SubCnt			;Wrong no. of dimensions
	ja	ComErrJ
SetOTyp:
	mov	[bx],dx 			;Set oTyp
	cmp	dx,ET_FS			; Fixed? Record?
	jb	SkipOTypJ			; brif numeric, SD, or TX
	    .erre   ET_FS EQ ET_MAX		
	    je	    SetLength			
	mov	ax,[grs.GRS_oRsCur]
SetExtension:					
	inc	bx
	inc	bx
	mov	[bx],ax				;Add oRS for records
SkipOTypJ:
	jmp	SkipOTyp
SetLength:					
	mov	ax,[bp-SsCom].COM_cbFixed	; Length of FS
	jmp	SetExtension			

VtRfCommon:
        cmp     [SsErr],0                       ;Any errors so far?
	jnz	CommonXj			;Don't risk it if so

	;Set oCommon and oValue in variable table

	mov	ax,[bp-SsCom].COM_oCom		;Get oCommon
	mov	[bx].VAR_value.COMREF_oCommon,ax
	mov	cx,[bp-SsCom].COM_oValCur	;Get oValue
	mov	[bx].VAR_value.COMREF_oValue,cx
	GetOtyp ax,[bx] 			; Get oTyp of element
	mov	dx,ax				; Save
	call	CbTypOTypSCAN			; Get size of this type
	jnz	Check_Size			; Brif not fixed length
	mov	ax,[bx].VAR_cbFixed		; Get length of FS
	mov	[bp-SsCom].COM_cbFixed,ax	; Save

	;See if this stuff fits

Check_Size:					
	add	ax,cx				;New allocation
	inc	ax
	and	al,not 1			;Round up to even
	call	ChkComSize			;bx = oTypCur
	jc	CommonXj			;Quit if no room in value table

	;See if there's a type in table

	xor	cx,cx				;Ensure cDimsFlag is clear
	cmp	bx,[bp-SsCom].COM_bdType.BD_cbLogical	;Have entry in table?
	jae	NewType

	;Compare with existing type

	add	bx,[bp-SsCom].COM_bdType.BD_pb	;Point into type table
	jmp	CompType

VtRfCommonJ:
	jmp	SHORT VtRfCommon


;***
;Ss_VtRf - scan simple VtRf opcodes
;
;Purpose:
;
;   Functions are referenced using the same opcodes as variables.
;   The VtRf variants may reference a function.  However, if they do
;   it is an error.
;
;   Tasks:
;	1. bind to executor.
;	2. handle redirection.
;	3. handle references to functions (errors).
;	4. complete the scan task for COMMON.
;	5. if not COMMON, STATIC or SHARED then assume DIM of a
;	   simple variable.
;
;Algorithm:
;
;   Load and emit executor
;   Copy operand
;   Ensure that the variable is not a function.
;   If COMMON
;      Complete COMMON work
;   If not COMMON, SHARED or STATIC, assume DIM
;   Return to scnner main loop
;
;Input:
;
;   ax	  = opcode
;   bx	  = 2 * opcode
;   es:di = pcode emission address
;   es:si = pcode source address
;
;Output:
;
;   si updated
;
;Modifies:
;Exceptions:
;	Ss_Error
;
;******************************************************************
page

VtRfRedirect:
	mov	ax,[bx].VAR_value	;Get new oVar
	mov	PTRTX[di-2],ax		;Patch into pcode
	jmp	short VtRfRetry

SsProc	VtRf,Rude
	xchg	ax,bx			; BX = executor map address
	mov	al,byte ptr es:[si-1]	; High byte of opcode
	.erre	OPCODE_MASK EQ 03ffh	
	and	ax,HIGH (NOT OPCODE_MASK)
	shr	ax,1			; Convert to word offset
	add	bx,ax			; Index into map
	mov	ax,cs:[bx]		; Load executor
	STOSWTX 			;Emit the executor
	LODSWTX 			;Load operand
	STOSWTX 			;Emit the operand
VtRfRetry:
	    add     ax,[MrsCur.MRS_bdVar.BD_pb] ;oVar --> pVar
	xchg	bx,ax
	DbChk	pVar,bx 		;Verify that this is a variable
	mov	ax,[bx].VAR_Flags	;[5]
	    ;Check for VtRf to redirected variable.

	    TestX   ax,FVREDIRECT	;Is the variable redirected?
	    jnz     VtRfRedirect	;Brif Redirected variable.

	;Check for VtRf to a function error.

	TestX	ax,FVFUN		;Is this a ref to a function?
	jnz	VtRfToFun		;Error - VtRf to a function.

	mov	dx,ax			; Preserve var flags in dx
	    TestX   ax,FRAME		;Is it a frame var?
	    jnz     @F			;Brif not

	call	SsAllocOFrame		;Allocate an oFrame for this var
@@:

	    mov     al,[SsBosFlags]
	    test    al,SSBOSF_StCommon	;Is it a COMMON statement?
	    jnz     VtRfCommonJ		;Not a COMMON array - done
	    test    al,SSBOSF_StShared	;Is it SHARED?
	    jnz     VtRfX		;No work for SHARED

	;If NOT first ref, it's an error

	TestX	dx,FV_STATICSET 	; First reference?
	mov	ax,ER_DD		; Duplicate definition if not
	jnz	VtRfError		; Brif not first reference


VtRfX:
	;The oTx of the next emitted executor must be saved so that the
	;subsequent declaration can evaluate the array bounds by starting
	;execution at the saved address.

	mov	[SsOTxStart],di 	;Update pointer for next Dim clause
	jmp	[ScanRet]

VtRfToFun:
	call	TMError
	jmp	VtRfX


VtRfError:
	call	SsError 		
	jmp	VtRfX			

	public	mpAVtRfOpExe			
mpAVtRfOpExe	label	word			
	DWEXT	exAVtRfImp			
	DWEXT	exAVtRfI2			
	DWEXT	exAVtRfI4			
	DWEXT	exAVtRfR4
	DWEXT	exAVtRfR8			
	DWEXT	exAVtRfSD			


	public	mpVtRfOpExe			
mpVtRfOpExe	label	word			
	DWEXT	exVtRfImp			
	DWEXT	exVtRfI2			
	DWEXT	exVtRfI4			
	DWEXT	exVtRfR4
	DWEXT	exVtRfR8			
	DWEXT	exVtRfSD			

page
;***
;Subroutines for COMMON

ChkComSize:
;See if COMMON block is big enough, grow if needed (and possible)
;
;Input:
;       ax = New total length needed
;Output:
;       bx = oTypCur
;       CY set if unable to fit
;cx,dx preserved

	mov	[bp-SsCom].COM_oValCur,ax	;Update position
 	mov	bx,[bp-SsCom].COM_bdValue.BD_cbLogical	
 	sub	ax,bx				;Fit within present size?
	jz	BigEnough
	cmc					;Success if CY clear
	jnc	BigEnough
;COMMON block growing - unless it's in user library
	    cmp     [bp-SsCom].COM_bdValue.BD_cbPhysical,UNDEFINED ;UL COMMON?
	    jz	    NoGrowULCommon
	push	cx
	push	dx
	push	bx				
	lea	bx,[bp-SsCom].COM_bdValue
	push	ax				;Remember how much space
	push	bx				;Owner to grow
	push	ax				;additional space needed
	call	BdGrowVar			;Extend COMMON block value table
	pop	cx				;Amount of new space
	pop	bx				;Position in COMMON
	call	OMEcheck			;See if it worked
	jc	NoZero				;If alloc failed, don't init
;Zero out new COMMON block space
	push	di				;Save emit oTx
	mov	di,bx				;Position in COMMON
	push	ds
	pop	es				;es = ds
	add	di,[bp-SsCom].COM_bdValue.BD_pb	;Point to new COMMON block space
	xor	ax,ax
rep	stosb					;Zero out COMMON block
	pop	di				;Restore emit oTx
NoZero:
	pop	dx
	pop	cx
BigEnough:
	mov	bx,[bp-SsCom].COM_oTypCur	;Current type table offset
	ret

NoGrowULCommon:
	mov	ax,MSG_ULCom
	call	CyError
	jmp	BigEnough

OMECheck:
	or	ax,ax
	jnz	OkRet
OMError:
	mov	ax,ER_OM
CyError:
	call	SsError
	stc				;Unable to grow COMMON
OkRet:	ret


ExecDim:
;Execute the DIM statement for a $STATIC array in COMMON
;The array space is allocated in the COMMON value table if possible,
;or the error is reported.
;
;Inputs:
;	bx = pAD
;	cx = oTxDim
;Outputs:
;	CY set if failed (error reported)
;	ax = size of array, rounded up to whole words
;	bx = pTypCur
;Preserves:
;	dx

	mov	[SsScanExSrc],bx	;Pass pAD to DIM
	DbAssertRel cx,nz,NULL,SCAN,<No DIM for $STATIC COMMON array>
        mov     [SsScanExStart],cx
	mov	[bx].AD_fhd.FHD_hData,0	;Flag it as not allocated
	push	dx
	mov	[DimAtScanType],SSDIM_COMMON
	push	ax			; ExecuteFromScan requires
	push	ax			; two garbage parameters
        call    ExecuteFromScan
	pop	dx
        jnz	CyError			;Error reported by runtime (in ax)?
	mov	ax,[SsScanExSrc]	;Size of array returned by DIM