rterror.asm

Microsoft MS-DOS6.0 完整源代码

	;		this one
	;Therefore, we use our knowledge of what QB frames look like to restore
	;oRsCur, otxCur, and pGosubLast for the next previous frame, set ax to
	;tell the runtime to keep looking for an error handler to activate, 
	;and exit.
	mov	ax,[si].FR_pGosubLast	;pGosubLast for previous frame
	mov	[pGosubLast],ax
	push	[si].FR_oRsRet		;oRs part of return address to next
					;	previous frame
	call	RsActivate		;activate that register set
	mov	ax,[si].FR_otxRet	;otx part of return address to next
					;	previous frame
	mov	[grs.GRS_otxCur],ax	
	mov	ax,sp			;signal runtime "okay to keep looking"
BIONERR_Exit1:
	jmp	BIONERR_Exit		
BIONERR_Cont3a:
	;There is an error trap to invoke; start it going - - -

	;release any owners on the stack below those we should keep for
	;  the current frame. This includes possible frame temp owners for the
	;  current frame.
	call	far ptr ResetSP_IONERR	;release all owners on stack below
					;  most recent QBI frame
	push	dx
	popf
	ja	BIONERR_Cont4		;  brif sufficient stack for context

	mov	[b$errnum],ER_OM
	mov	[b$errinfo],OMErr_STK	;note that this is an out of stack err
	jmp	J1_BIONERR_NoCont_Exit
BIONERR_Cont4:
	mov	sp,ax
	call	far ptr SetERL		;set b$errlin, activate static structs
					;sets grs.otxCur beyond opBos of
					; stmt that caused the error.
					; AX = otx of stmt that caused error


	call	DisStaticStructs	;deactivate static structs again
					; (activated by SetERL)

	mov	[b$inonerr],TRUE
	mov	[fNonQBI_Active],0	;regardless of where error occurred,
					; QB code is active now
	push	[pGosubLast]		;save so RESUME can restore
	push	[grs.GRS_oRsCur]	;oRs of return address	
	mov	di,[grs.GRS_oMrsCur]	; di points to active mrs in table
	RS_BASE add,di			
	GETRS_SEG es			
	mov	ax,PTRRS[di.MRS_otxHandler]	


	xchg	ax,[grs.GRS_otxCur]	;Set error trap context, fetch oTx
					;  of BOS/BOL of line error occured in
	push	ax			;oTx of return address (for RESUME)
	push	bp
	mov	bp,sp
	push	[b$curframe]		
	mov	[b$curframe],bp
	push	[grs.GRS_oMrsCur]
	cCall	RsActivate		;deactivate prsCur if a procedure is
					;  active (must use RsActivate here, 
					;  since static structs are inactive)
	;NOTE: No reason to copy existing module frame vars+temps to and back
	;NOTE: from this new frame, nor to zero them. Frame temps are only
	;NOTE: meaningful within the context of a statement. Frame vars are
	;NOTE: only used by FOR loops; not too worried about what happens if
	;NOTE: user jumps into the middle of a FOR loop; we can't match what
	;NOTE: BC does for that case anyway.

	jmp	StartGrsContext 	;jmp to dispatch first opcode in trap
					;  note that this also sets SP based
					;  on BP and current context, and
					;  checks for stack overflow ...

BIONERR_Exit:				;no trap or in trap; ret to RT
cEnd

;***
;ResetSP_BP_Far
;Purpose:
;	Common code called in case non-QBI code is executing and the user
;	hits ctl-BREAK, a STOP statement is executed, or a runtime
;	error occurs that is not trapped by the compiler.
;
;	If fNonQBI_Active == FALSE, just resets SP and BP based on b$curframe
;	and current context and returns.
;
;	If fNonQBI_Active != FALSE, sets BP to fNonQBI_Active (last active
;	QBI frame), sets SP based on this BP, releases all owners on
;	stack below this frame, restores proper b$curlevel value for this 
;	frame, and decrements the count of non-QBI frames on the stack.
;
;	NOTE: doesn't actually set SP, for ease in returning, and because
;	that hoses caller from B$IONERR. Caller must set sp if desired.
;Entry:
;	b$curframe gives pointer to reset BP to if fNonQBI_Active == FALSE.
;	fNonQBI_Active == FALSE or value to reset BP to.
;	if fNonQBI_Active != FALSE, bcurlevel_QBI assumed to contain the
;		value that b$curlevel is to be reset to.
;	grs.GRS_oRsCur assumed to be set for most recently active QBI frame.
;Exit:
;	AX is set to appropriate location for SP to be set to at each
;		BOS based on BP.
;	dx is a copy of PSW flags, because windows can trash
;		PSW on exit from far routines.
;Uses:
;	di,bp
;Exceptions:
;	none.
;*******************************************************************************
cProc	ResetSP_IONERR,<FAR>
cBegin
	mov	di,[b$curframe]
	jmp	short ResetSP_BP_Cont
cEnd	<nogen>

cProc	ResetSP_BP_Far,<PUBLIC,FAR>	
cBegin	ResetSP_BP_Far			
	mov	di,[b$curframe]
	xor	cx,cx
	xchg	[fNonQBI_Active],cx	;error in non-QBI code?
	jcxz	ResetSP_BP_Cont		;  brif not

	mov	di,cx			;reset bp to most recent QBI frame
	push	[bcurlevel_QBI]		;restore b$curlevel to what it was
	pop	[b$curlevel]		;  when most recent QBI frame was active
	DbAssertRel b$cNonQBIFrames,nz,0,RT,<ResetSP_BP: b$cNonQBIFrames == 0>
	dec	[b$cNonQBIFrames]	;decrement count of non-QBI frames on
					;  the stack
ResetSP_BP_Cont:
	mov	[b$curframe],di
	mov	bp,di

	;Don't release owners in local var space on stack if a procedure
	;  is active
	;Note that MODULE frame var space cannot have owners
	sub	bx,bx			
	RS_BASE add,bx			
	GETRS_SEG es			
	mov	ax,[grs.GRS_oRsCur]	
	DbAssertRel ax,nz,UNDEFINED,RT,<ResetSP_BP: grs.GRS_oRsCur == UNDEFINED>
	or	ax,ax
	jns	Proc_Not_Active		;brif oRsCur is a module, not a proc

	and	ah,07FH			; oRs --> oPrs
	DbChk	ConNoStatStructs	;following statement counts on finding
					;  current prs in table, not prsCur
Proc_Not_Active:
	add	bx,ax			
	.errnz	MRS_cbFrameVars - PRS_cbFrameVars	
	sub	di,PTRRS[bx.PRS_cbFrameVars] ; don't release any local proc variable
					;  owners
	jnc	@F			;[J2]
	mov	di,bp			;[J2]
@@:					;[J2]
	dec	di			; point to first potential value
	dec	di			; to release
	push	[b$pend]		;ptr to low word on stack
	push	di			;ptr to top of range to clear
	call	B$ClearRange		;free all owners below latest QBI frame

	mov	ax,[b$curlevel]
	call	B$STDALCALLTMP		;deallocate all string temp.s that were
					; created above the level for this frame
	call	SetSpFar		;ax = clean BOS SP value based on BP
					;return PSW flags as returned by
					;SetSpFar (in dx)
cEnd	ResetSP_BP_Far			

;***
;B$FERROR - interpreter-specific clean-up when runtime error occurs
;Purpose:
;	The runtime calls this routine when a runtime error occurs that is
;	not trapable, or there is no error trap, or the error occured in
;	an error trap. It cleans the stack frame back to b$curframe and
;	the stack pointer back to where it was at the last BOS/BOL,
;	resets si to the opBOS prior to the otx in grs.otxCur (set by
;	B$IONERR), gives the appropriate error message to the user, and puts
;	QBI in direct mode.
;Entry:
;	b$curframe gives pointer to reset BP to.
;	b$errnum contains the BASIC error number.
;	b$cCSubs non-0 if error occured in compiled BASIC code.
;Exit:
;	none.
;Exceptions:
;	Never returns, just sets the stack up, and jumps ...
;*******************************************************************************
cProc	B$FERROR,<PUBLIC,NEAR,NODATA>
cBegin	B$FERROR
	mov	ax,[b$errnum]
	or	ah,ah			;some internal error?
	jz	Normal_Error		; brif not
	cmp	ax,FE_NOSTACK		; convert FE_NOSTACK to ER_OM?
	jne	Term_Error		; brif not
	mov	[b$errnum],ER_OM	; convert to Out of Memory Error
	mov	[b$errinfo],OMErr_STK	; and set Out of Stack Space flag
Normal_Error:				

	jmp	far ptr BFERROR_CONT	;do the rest of this work in CP
Term_Error:
	call	B$PUTNUM		;print error message to stdout

	;NOTE: We don't try to print out module name, ERL, etc. of message
	;NOTE: here, partly to save code (this is an unusual case), and partly
	;NOTE: because it's pretty risky trying to do much of anything after
	;NOTE: an error such as String Space Corrupt, DOS Arena trashed, etc.
	;NOTE: For the same reason we don't give the user the chance to save
	;NOTE: his program after such an error either; we probably couldn't
	;NOTE: do it, and it's just too risky.

	jmp	B$END			;terminate BASIC

cEnd	<nogen>

sEnd	RT

sBegin	CP
assumes CS, CP

BFERROR_CONT:
	call	ReleaseSpace		;just in case GrabSpace had been called
					;  in exStClear
	call	EnStaticStructs 	;required prior to calling txtmgr stuff
	mov	ax,[b$errnum]
	cmp	ax,ER_OM		;out of memory error?
	jz	BFErr_Clear		;  brif so

	cmp	ax,ER_OS		;out of string space error?
	jnz	BFErr_Cont		;  brif not - only clear if need space
BFErr_Clear:
	call	ClearStmt		;clear all variables to free up memory
	mov	ax,[b$mainframe]
	mov	[b$curframe],ax	;reset this now in case of Out of Stack
					;  space error - - - this ensures
					;  enough stack space for UserInterface
	mov	[BosFlags],0		;don't want to leave the 'reset the
					;  stack' bit set ...
	or	[debugFlags],DEBUG_CANT_CONT
					;remember that we can't continue now
BFErr_Cont:
	xor	cx,cx			;note that we're resetting b$cCSubs
	xchg	[b$cCSubs],cx		;here in addition to testing it; this
					;is necessary in case another runtime
					;error occurs (so B$CONERR doesn't
					;get called when it shouldn't ...)
	mov	si,[grs.GRS_otxCur]	
	cmp	[grs.GRS_fDirect],FALSE ; error in Direct Mode?
	jnz	BFerr_Cont2		;	brif so - leave otx alone

	jcxz	BFErr_InQB_Code		;brif error occured in QB code

	;In the event that the most recent BASIC frame on the stack is
	;  for compiled BASIC code and the error was untrapped, we must
	;  leave ERL alone, but must reset oTxCur back to the previous BOS 
	mov	ax,[grs.GRS_otxCur]
	DbAssertRel ax,nz,UNDEFINED,CP,<B$FERROR: otxCur=FFFF, b$cCSubs non-0>

	dec	ax			;move back to opcode that caused the
	dec	ax			;  error, to ensure we're in the same
					;  statement/line.
	push	ax
	cCall	OtxBosOfOtx		;ax = oTx of BOS/BOL of stmt in which 
					;  the error occured
	mov	[grs.GRS_otxCur],ax
	jmp	short BFErr_Cont1
BFErr_InQB_Code:
 	mov	si,[grs.GRS_otxCur]	
 	cmp	[grs.GRS_fDirect],FALSE	; error in Direct Mode?
 	jnz	BFErr_Cont2		;   brif so - leave otx alone
 
	call	far ptr SetERL		;set b$errlin, activate static structs
					;sets grs.otxCur beyond opBos of
					; stmt that caused the error.
BFErr_Cont1:
	sub	ax,ax
	push	[grs.GRS_otxCur]	;oTx of BOS/BOL
	push	ax			;0 = "skip to next pcode, please"
	call	TxtFindNextOp		;ax = oTx of first opcode past BOS/BOL
	xchg	ax,si			;si = otx of first opcode past BOS/BOL

BFErr_Cont2:				
	sub	ax,ax
	mov	[DimAtScanType],al	; In case of error during Dim
	mov	[grs.GRS_flagsDir],al	;reset flags which get reset every
					; time we begin executing pcode,
					; or when a runtime error occurs.
	call	DisStaticStructs	;deactivate stat structs for ResetSP_BP
	call	ResetSP_BP_Far		;reset SP and BP
	push	dx			;[J2]
	popf				;[J2]
	jbe	B$FERROR_Exit		;brif insufficient stack space for
					;  the module frame (special case)
	mov	sp,ax
B$FERROR_Exit:
	or	[debugFlags],DEBUG_ERROR;tell UserInterface an error occured
	mov	[grs.GRS_flagsDir],0
	jmp	far ptr StopGrsContext 	;back to user interface

;***
;SetERL - set up b$errlin for ERL and otxCur of BOS/BOL where error occured.
;Purpose:
;	updates b$errlin and updates GRS_otxCur to the BOS of stmt in which 
;	the error occurred.  If the error occurred during a single line if
;	the otx past the opStIf or opStElse operand will be used.
;	This function is in CP, since it calls txtmgr routines which are
;	NEAR in CP.
;	Note that, if no line number is found prior to the oTx where the error
;	occured, b$errlin is set to 0.
;Entry:
;	[grs.GRS_otxCur] = oTx just past the opcode which caused the error
;Exit:
;	b$errlin set appropriately
;	Static structs active
;	AX = otx of stmt that caused the error
;Modifies:
;	SI,ES
;*******************************************************************************
cProc	SetERL,<FAR>
cBegin	SetERL
	call	EnStaticStructs 	;required prior to calling OtxLabOfOtx
	mov	si,[grs.GRS_otxCur]
	cmp	si,UNDEFINED
	jnz	SetERL_Cont
	;error occured after end of text or an END or SYSTEM statement
	inc	si
	mov	[b$errlin],si		;ERL = 0 in this case
	jmp	short SetERL_Exit	;this will set otxCur to zero, i.e.,
					;  the error will be reported as if it
					;  occured at the start of the txt tbl
SetERL_Cont:
	or	si,si
	jz	No_oTx_Dec		;special case - - - if we've done a
					;  GOSUB back to oTx 0 and then see
					;  we're out of stack space ...
	dec	si			;move back to opcode that caused the
	dec	si			;  error, to ensure we're in the same
					;  statement/line.
No_oTx_Dec:
	DbAssertRel si,b,0FFFDh,CP,<SetERL: bad grs.otxCur>
	push	si			;popped below by OtxResume
LoopForERL:
	xchg	ax,si			;put current oTx in ax, garbage in si
	cCall	OtxLabOfOtx		;ax = oTx of preceding opBolLab or opLab
	mov	si,ax			;si = ax == oTx op preceding opBolLab
	inc	ax			;no more opBolLab's or opLab's?
.errnz	UNDEFINED - 0FFFFH
	jz	ERL_Set 		;  brif so; leave ERL == 0

	GetSegTxtTblCur			;ES = txdCur.TXD_bdlText_seg
	mov	bx,es:[si+2]		;pass oNam of Ln/Lab from pcode in bx
	cCall	LnOfOnam,<bx>		; ax = line # or UNDEFINED if label
	inc	ax
.errnz	UNDEFINED - 0FFFFH
	jz	LoopForERL		;found a label, not a Ln - try again

	dec	ax			;set this back to actual line number
ERL_Set:
	mov	[b$errlin],ax
	cCall	OtxResume		;oTx of error pcode still on stack
	;now ax = oTx of BOS/BOL of statement in which the error occured
SetERL_Exit:
	mov	[grs.GRS_otxCur],ax
cEnd	SetERL

sEnd	CP

sBegin	CODE
assumes CS, CODE

;***
;RtErrorCODE - Near interface for runtime error in CODE segment
;Purpose:
;	This entry point is jumped to from any point in the CODE segment where
;	a runtime error is detected. Having a NEAR interface like this saves
;	code.
;Entry:
;	AL is the error code of the runtime error to generate
;Exit:
;	None - doesn't return
;*******************************************************************************

PUBLIC	RtError_INI
PUBLIC	RtErrorOM_INI
;here for the special case of some internal error
RtError_Initialization	PROC FAR
RtError_INI:
	DbAssertRelB  ah,z,0,CODE,<RtError_INI called with ax GT 255>
	xchg	al,bl			;put error code in bl
	SKIP2_PSW
RtErrorOM_INI:
	mov	bl,ER_OM
					;OM error during initialization
	mov	bh,QB_RTERR_MASK	;special mask - - - fatal error, but
					; allows us to use an existing message
					; string
	push	ss			;in case error occured before DS was
	pop	ds			;  set up originally
	call	B$RUNERRINFO		;doesn't return
	DbHalt	CODE,<B$RUNERRINFO returned when passed a fatal error (1)>