ssproc.asm

[随书类]Dos6.0源代码

assumes cs,SCAN

cProc	Insert1Op_Far,<FAR>		
	;NOTE: oTx of insertion is in di
cBegin					
	GETSEGTXTCUR			
	mov	bx,di			; Insert right here
	call	Insert1Op
cEnd					


	;ES:BX = pPRS of procedure

InterpProc:
	    jcxz    CheckParams
	    mov     ax,MSG_DupLibPrs	;UL and interp proc. with same name
	    jmp     short ULError

OKtoUse:
	    jcxz    DeclError		    ;Didn't find proc in UL
	    mov     PTRRS[bx].PRS_txd.TXD_oCompiled,ax	    
	    mov     PTRRS[bx].PRS_txd.TXD_segCompiled,cx    

CheckParams:
	GETSEGTXTCUR			
	pop	ax			;Declared count of parameters
	mov	cx,[SsParmCnt]
	inc	ax			;Have parameter list?
	jz	NoParamList
	dec	ax
	cmp	ax,cx			;Same as actual count?
	jz	ParamCountOK
	inc	[SsDelayCnt]		;First ArgCntErr on line?
	jnz	NoParamList		;If not, don't update its oTx
	mov	[SsDelayLoc],si		;Save source oTx of error
	mov	[SsDelayErr],ER_AC	;It's an Arg Cnt error
NoParamList:
	or	dh,NoParamsFlag
ParamCountOK:
	pop	ax			;oRS to ax
	jcxz	SsParamsOK
NextParam:
;ax = oRS of declaration
;cx = count of remaining arguments
;dx has flags
;es:[di-2] = oTx of declaration, if any
	xchg	bx,ax			;oRS to bx
	and	dx,not ResetBits	;Reset ByVal, Seg, Array (and CallFlag)
	mov	ax,[SsCbParmCur]
	inc	ax
	inc	ax
	mov	[SsCbParmCur],ax	;Assume near reference - 2-byte param

	;Pop stack and check for BYVAL or SEG flag

	pop	ax			;Get oTyp with BYVAL/SEG flag
	test	dl,FP_DEFINED		; Interpreted function?
	jz	@F			; Brif not
	test	ah,ST_ByVal OR ST_Seg	; ByVal or Seg present
	call	TmErrorNZ		
@@:					
	xor	dh,ah			;Flip flag bits
	and	ah,not (ST_ByVal + ST_Seg) ;Mask out ByVal & Seg
	xor	dh,ah			;Restore all but ByVal & Seg
	pop	PTRTX[di+2]		;oTx of end of argument
	push	cx			;Save count of params
	call	CoerceParam		;Adjust parameter to match calling conv.

;ax = oRS of decl.
;bx adjusted to continue to point to end of argument
;dx preserved

	test	dl,FP_CDECL		;If CDECL, must re-order params
	jz	NoReorder
	cmp	[SsParmCnt],2		;If less than 2 parms, no re-order
	jl	NoReorder

;Re-order parameters for CDECL by inserting branch after each.
;Target of branch will be assigned later.

	push	ax
	call	InsertBranch
	pop	ax
NoReorder:
	pop	cx
	loop	NextParam

	DbPub	SsParamsOK
SsParamsOK:
;Done with parameter processing
;bx = oTx of end of first parameter (if any)
;dx = flags
;Start of [27]
;Find oTx before first parameter
	mov	cx,bx			;save otx of call if 1 parm
	cmp	sp,[SsBosStack]		;Any entries on stack for this stmt?
	mov	bx,[SsOTxStart] 	;Assume not - use start of stmt
;Note that SsBosStack is the SP at BOS, except it was saved with one extra
;word pushed on it.  Thus SP will actually be larger that SsBosStack when
;the stack is empty.
	ja	HaveStartOtx		;Stack empty?
;Get first oTx by looking at scanner entry on stack
	pop	ax			;oTyp
	pop	bx			;oTx
	push	bx			;Put them back
	push	ax
HaveStartOtx:
;bx = oTx of start of first parameter
;cx = oTx of call if 1 parameter
;Save 8087 registers if function call
	xchg	ax,cx			;ax = otx of call if 1 parm
	and	dh,ProcType
	cmp	dh,PT_SUB		;Was it a SUB?
	jz	No87Save
	push	ax
	mov	ax,codeOFFSET exSave87
	call	Insert
	pop	ax			;ax = otx of call if 1 parm
	inc	ax
	inc	ax			;adjust for insertion

No87Save:
;end of [27]
	cmp	[SsErr],0		;Any errors so far?
	DJMP	jnz	FuncCheck	;If so, don't try this stuff
	test	dl,FP_CDECL		;If CDECL, must re-order params
	jz	NotCDECL
	mov	cx,[SsParmCnt]
        jcxz    NotCDECL                ;No work if 0 parameters
        dec     cx
	xchg	ax,bx			;bx = otxCall if 1 parm, ax = otx first
					; param
        jz      EatParams               ;Just eat parameter on return
	xchg	ax,bx			;swap em back
	push	dx			;Save flags
	call	InsertBranch		;Jmp to last arg--don't know oTx yet
;Have inserted exBranch's to re-order parameters.  Now go find them
;and set their target operand.
	push	bx			;Remember this spot for patching later
	call	FindBranch
	pop	ax			;Restore "previous"
	push	bx			;1st param's jump to be patched later
	push	ax
PatchBranch:
;ax = oTx of previous branch
;bx = oTx of current branch
	push	ax
	push	bx
	call	FindBranch
	pop	ax			;oTx of previous branch
	pop	dx			;dx = target of branch
	call	PatchBranchRel		;compute and patch relative addr
	loop	PatchBranch
;bx = Otx after last branch == otx of call instruction
	mov	cx,bx			;save otx of call
	pop	bx			;oTx of 1st param's branch
	xchg	dx,ax			;target in dx
	call	PatchBranchRel		;patch relative addr
	pop	bx			;oTx of 2nd param's branch
	mov	dx,cx			;target is call instruction
	call	PatchBranchRel		
	mov	bx,cx			;Location of CALL
        pop     dx			;Restore flags
EatParams:
;Insert pcode to eat parameters
	mov	cx,[SsCbParmCur]
;cx = amount of stack space to release
;bx = oTx of CALL
	mov	ax,codeOFFSET exParamCnt
	call	Insert1Op
;bx = oTx of CALL
NotCDECL:
	test	dl,FP_DEFINED		;Interpreted function?
	jnz	FuncCheck
;Compiled code - add temp to save return oTx and cbParams
	mov	ax,4
	call	AllocTemp
FuncCheck:
	cmp	dh,PT_SUB			;Was it a SUB?
	je	ProcExit			;If so, we're done
;Make stack entry for function return value
	push	di				;Save oTx
	mov	al,[FuncOtyp]
	cbw
	push	ax			;Leave oType on stack
	test	dl,FP_DEFINED		;Interpreted function?
	jnz	ProcExit
	test	dl,FP_CDECL		;C function?
	jnz	ProcExit
;PL/M function - allocate temp for return value
	.erre	ET_MAX LT 100h		; Assure we can use AL
	cmp	al,ET_I4		;Returned in registers?
	jle	ProcExit
	cmp	al,ET_SD		;Returned in registers?
	jae	ProcExit		
	call	CbTypOTypSCAN		; Get size of this type
	call	AllocTemp		;Make space for return value
ProcExit:
	jmp	[ScanRet]

;*** PatchBranchRel
;
;	Added with [49].
;Inputs:
;    dx = location to jump to
;    bx = ptr to pcode AFTER exBranchRel operand
;Outputs:
;    [bx-2] is patched to contain offset of target relative to bx-2.
;Preserves:
;    all except dx.
;
PatchBranchRel:
	mov	PTRTX[bx-4],codeOFFSET exBranchRel ;backpatch exbranch
				; to exBranchRel
	sub	dx,bx		;dx = offset target relative to next pcode
	inc	dx
	inc	dx		;compute offset relative to ExBranchRel operand
	mov	PTRTX[bx-2],dx	;patch it
	ret

;*** SsFindOpNoList1,FindBranch
;
;Inputs:
;	ax = Executor whose opcode is opNoList1 (SsFindOpNoList1 only)
;	bx = start of search range
;	di = end of search range
;Outputs:
;	bx = oTx of point after opcode if found
;	Carry flag set if not found
;Preserves:
;	cx

	public	SsFindOpNoList1

FindBranch:
	mov	ax,codeOFFSET exBranch	;Look for this executor
SsFindOpNoList1:
	GetCodeIntoDs	SCAN		
assumes	ds,NOTHING
LookOpNoList1:
	mov	dx,PTRTX[bx]		;Get executor
	cmp	ax,dx			;Find it?
	jz	FoundNoList
	xchg	dx,bx
	mov	bx,[bx-2]		;Get opcode
	and	bx,OPCODE_MASK		;Just want the opcode!
	mov	bl,mpOpAtr[bx]		;Load attribute byte
	and	bx,OPA_CntMask		;Get the operand count from attribute
	cmp	bl,OPA_CntMask		;Check for cnt field in operand
	xchg	bx,dx
	jne	SkipOps 		;No cnt field
	inc	bx
	inc	bx
	mov	dx,PTRTX[bx]		;Get count of operands
	inc	dx
	and	dl,not 1		;Round up to even
SkipOps:
	add	bx,dx
	inc	bx
	inc	bx
	cmp	bx,di
	jb	LookOpNoList1
	stc				;No more found
FoundNoList:
	lea	bx,[bx+4]		;Point to next pcode w/o affecting flags
	push	ss
	pop	ds
	ret

;*** CoerceParam
;
;Purpose:
;	Perform whatever translations are necessary to make the
;	parameter match its declaration and get passed securely.
;Inputs:
;	ax = current type, high bits set
;	bx = oRS of declaration
;	dx = flags
;	es:[di+2] = oTx of end of argument
;	es:[di] = oTx of declaration
;Outputs:
;	ax = oRS of declaration
;	bx = oTx of end of argument (after any insertions)
;Preserves:
;	dx

	extrn	GetTrueType:near	; From ssrefarg.asm


	assumes ds,DATA

	DbPub	CoerceParam
CoerceParam:
	push	bx
	mov	cx,ax
	.erre	ST_Typ_Mask EQ 0FFh	;Assure XOR is sufficient
	xor	ch,ch			;Use current type if none declared
	test	dh,NoParamsFlag
	jnz	NoType
	xchg	si,PTRTX[di]		;Get oTx of declaration
	sub	si,6			;Point to next parameter
	call	GetDeclSeg		;ds:si point to parameter
	assumes ds,NOTHING		
	mov	bh,[si+DCLP_atr+1]	;Get high byte of ParamAtr
	and	bh,HIGH ResetBits
	or	dh,bh			;Combine ByVal and Seg bits
	mov	bx,[si+DCLP_oTyp]	;Get oType
	push	ss
	pop	ds			;Set ds = ss
	assumes ds,DATA 		
	xchg	si,PTRTX[di]		;Restore text source
	or	bx,bx			;Typed "as any"?
	jz	NoType	 		;If so, use attributes but not type
;Re-written with [37]
	pop	cx			;cx = oRS of declaration
	push	cx
	push	ax			;Current oTyp, high bits set
	push	bx			;Required oTyp
	push	cx
	mov	bx,PTRTX[di+2]
	call	GetTrueType
	xchg	ax,cx			;Actual oTyp to ax
	pop	bx			;Get oRs of declaration back
	pop	cx			;Get required oTyp back
	push	cx
	cmp	al,ET_FS		;Have an FS?
	jnz	LongCompare
	dec	ax			;FS-->SD, FT-->TX
	test	dh,ArrayFlag		;Passing whole array?
	jnz	NoMatch			;FS not allowed if so
LongCompare:
	push	dx
	xchg	ax,dx			;Current type to dx
	mov	ax,[grs.GRS_oRsCur]
	xchg	ax,bx			;oRS of decl. to ax, oRScur to bx
;bx:dx = oRS:oType of current type
;ax:cx = oRS:oType of target type
	cCall	CompareTyps,<ax,bx,cx,dx>	; Are types the same?
	REFRESH_ES			
	pop	dx
	or	ax,ax			; set PSW.Z flag
	jz	TypeMatch
NoMatch:
	or	dl,TypeMatchFlag
TypeMatch:
	pop	cx			;Restore target type
	pop	ax			;Restore current type with flag bits
;End of [37] re-write
NoType:
	mov	bx,PTRTX[di+2]		;Get oTx to end of argument

;ax = current type, high bits set
;bx = oTx of end of argument
;cx = target type (ET_RC ok)
;dx = flags

;Check for consistency between BYVAL, SEG, and CALLS
	test    dh,SegFlag+CallSFlag    ;Specified as segmented?
	jz	AttrOk			;If not, BYVAL would be OK
	test    dh,ByValFlag		;BYVAL and SEG/CALLS?
	jnz     BadType			;Can't have both
AttrOk:

	TestX	ax,ST_Var?		;Is it a variable or expression?
	jz	Expr
;Determine if whole array is being passed
	TestX	ax,ST_Array?		;Is this the actual array reference?
	jnz	NotWhole
	cmp	PTRTX[bx-4],0		;Any indices?
	jnz	NotWhole
;Passing whole array - see if that is what's needed
	test	dh,ArrayFlag+NoParamsFlag
	jnz	WholeArray
BadType:
	mov	ax,MSG_ParmTM
ReportErr:
	call	SsErrorBx
	jmp	short ParamXpop

NotWhole:
	test	dh,ArrayFlag		;Passing whole array?
	jnz	BadType
	test	dh,DefFnFlag+ByValFlag	;Pass by value?
	jnz	Expr
;Handle a variable
	test	dl,TypeMatchFlag	;Types match?
	jnz	BadType
	test	dh,FarArg		;SEG specified?
	jz	MakeSafeRef
;Passing by far reference.  Disable any copying of arguments,
;allowing user to screw himself with far heap movement.
	add	[SsCbParmCur],2		;Add 2 bytes to parm size
	mov	[SsOtxHeapMove],0	;Tell SsRefArg there's no heap movement
MakeSafeRef:
	call	SsRefArg
	mov	[SsOtxHeapMove],di	;Make sure we know we moved
ParamXpop:
	pop	ax			;Leave oRS of decl. in ax
	ret

CountSize:
	cmp	cx,ET_SD		;Don't allow string with ByVal
	jae	BadType 		;Error if string or form
	dec	ax
	dec	ax			;Already assumed near ref.
	add	[SsCbParmCur],ax
	mov	ax,codeOFFSET exR8ToStack
	sub	cx,ET_R8		; Is this an R8 ByVal param?
	    jz	    @F			; Brif yes, insert
	    .erre   ET_R4 EQ ET_R8-1	
	    inc     cx			; Is this an R4 ByVal param?
	    jnz     ParamXPop		; Brif not, no work to do
	    mov     ax,codeOFFSET exR4ToStack
@@:					
InsertExit2:
	call	Insert			; Insert executor to move to 8086
	jmp	short ParamXPop

WholeArray:
	test	dl,TypeMatchFlag	;Types match?
	jnz	BadType

	;Convert AIdLd to AdRf

	call	MakeArrayRef		
	jmp	short SegCheck

Expr:
	test	dh,ArrayFlag		;[J2] Is a whole array expected?
	jnz	BadType 		;[J2] Brif so
	cmp	cx,ET_MaxStr		;Is this numeric or string?
	ja	BadType			;Can't pass expr. to field/form/menu


	;If no type checking is enabled for this parameter, then fixed
	;strings will come here with an invalid target type of fixed
	;string or fixed text.	In this case, the target is converted to
	;variable string (ET_SD) to force the correct handling of temp
	;string arguments.  Using ET_SD is safe in FV_TEXT products
	;because the representation of Text and String are identical
	;as is the handling by this code.

	    .erre   ET_FS EQ ET_MaxStr	
	jb	@F			; Brif not ET_FS
	mov	cx,ET_SD		; Ok for ET_FT also
@@:

	push	dx
	push	cx			;Remember target type
	call	SsCoerceReg		;bx will be updated if coercion performed
	pop	cx
	pop	dx			;Recover flags bits
	mov	ax,cx			;oTyp to ax
	call	CbTypOTypSCAN		; AX = Size of this type
	test	dh,ByValFlag		;Passing by value?
	jnz	CountSize		;Done, but add up size of params
	    push    cx
	call	AllocTemp		;oTemp in cx, oTyp in ax
	xchg	ax,bx			;Type to bx, oTx in ax
	shl	bx,1			;Make it a word index
	mov	bx,[bx].tTmpType-2	;Get temp executor for this type
	xchg	ax,bx
	call	Insert1Op
	pop	ax			;Recover type
	cmp	al,ET_SD		;String?
	jne	SegCheck		;If not, go see if SEG specified
;Insert executor to delete string data
	mov     ax,codeOFFSET exDelTmpSD
;ax has executor, cx has oTemp
	push    bx
	mov     bx,di
	call    Insert1Op
	pop     bx
SegCheck:
	    test    dh,FarArg
	    jz	    ParamXPop
	    add     [SsCbParmCur],2	;Add 2 bytes to parm size
	    mov     ax,codeOFFSET exPushSeg ;Executor to add segment
	    jmp     short InsertExit2	; Insert opNoList0 and exit
@@:
	jmp	short ParamXPop

	;Added with [37]


	;End of [37]



DbPub	GetDecl 			
GetDecl:
;Get ds:si to point to procedure's declaration given pPRS in bx
;Returns oRS of declaration in ax
	mov	si,PTRRS[bx].PRS_oTxDef ; oText of declaration
	add	si,DCL_atr+2		;Position of attributes field
	mov	ax,PTRRS[bx].PRS_oRsDef ; Get oRs of decl.
	test	dh,DefFnFlag
	jz	GetDecSeg
	test	PTRRS[bx].PRS_flags,FP_DEFSCANNED ; Has definition been scanned?
	jnz	ValidDefFn
	xchg	ax,bx			;[J2] Save oRs across call to SsError
	mov	ax,ER_UF		;Undefined function
	xchg	si,PTRTX[di]		;[J2] Restore source pointer
	call	SsError
	xchg	si,PTRTX[di]		;[J2] Resave source pointer
	xchg	ax,bx			;[J2] restore AX = oRs
ValidDefFn:
	inc	si
	inc	si			;Skip over link field in DefFN
GetDecSeg:
	mov	bx,ax

GetDeclSeg:
;Get segment of text table into ds given oRS in bx.
;Inputs:
;	es:bx = pRS
;Outputs:
;	ds = segment of text table
;	es = text segment for scanning
;Preserves:
;	ax,cx,dx
	cmp	bx,[grs.GRS_oRsCur]	;Is it current?
	jz	CurText
	cmp	bx,[grs.GRS_oMrsCur]	;Current MRS?
	jz	IsMrsCur
	or	bx,bx
	jns	GetMRS
	and	bh,7Fh			;bx = oPrs
	lea	bx,[bx].PRS_txd.TXD_bdlText_seg		
	jmp	short SetDS		;	

IsMrsCur:
	test	[txdCur].TXD_flags,FTX_mrs ;does prs have a text table?
	jne	CurText 		;brif not, txdCur is for Mrs.
	mov	bx,dataOFFSET mrsCur.MRS_txd.TXD_bdlText_seg	
	jmp	short SetDS_2		;[5]

GetMRS:
	lea	bx,[bx].MRS_txd.TXD_bdlText_seg		
	jmp	short SetDS		;	

CurText:
	mov	bx,dataOFFSET txdCur.TXD_bdlText_seg	
SetDS_2:				;[5]
	SETSEG_EQ_SS  es		; set es = ds if Rs table is far
	jmp	short SetDS_1		;[5]
SetDS:					
	    RS_BASE add,bx		
	GETRS_SEG es,bx,<SIZE,LOAD>	;[9]
SetDS_1:				;[5]
	GETSEG	bx,PTRRS[bx],,<SIZE,LOAD> ;[9][5]
	GETSEGTXTCUR			
	mov	ds,bx			
	ret

sEnd	SCAN
	end