ssbos.asm

Microsoft MS-DOS6.0 完整源代码

	pop	dx
NoPcUpdate:
	pop	ax			; AX = oTx of BOS in emitted code
	mov	[SsOTxBos],ax		; Save oTx of BOS
	mov	[SsOTxStart],di 	;New first location for DIM
	mov	bx,UNDEFINED		; No patch indicator
	xchg	bx,[SsOTxPatchBos]	; BX = Address to be patched ?
	.erre	UNDEFINED EQ 0ffffh	; Assure INC/JZ is sufficient
	inc	bx			; Any?
	jz	@F			; No
	mov	PTRTX[bx+1],ax		; Patch Bos address
@@:					
	test	[SsBosFlags],SSBOSF_StCommon	;Finishing up COMMON?
	jz	CheckCase
;Have COMMON entry on stack to clean up
	push	dx
	push	es
	mov	ax,[bp-SsCom].COM_oCom
	add	ax,[grs.GRS_bdtComBlk.BD_pb] ;oCommon --> pCommon
	xchg	bx,ax			;pCommon to bx
	mov	ax,[bp-SsCom].COM_oValCur
	mov	[bx].COM_oValCur,ax
	mov	ax,[bp-SsCom].COM_oTypCur
	mov	[bx].COM_oTypCur,ax
.errnz	SsCom - COM_bdType
	add	bx,COM_bdType
	push	bp			;Current owner
	push	bx			;New owner
	add	bx,COM_bdValue - COM_bdType
	cmp	[bp-SsCom].COM_bdValue.BD_cbPhysical,UNDEFINED ;User Library?
	jz	CopyTypOwner
	lea	ax,[bp-SsCom].COM_bdValue
	push	ax			;Current owner
	push	bx			;New owner
	call	BdChgOwner		;Copy BD back to COMMON table
CopyTypOwner:
	call	BdChgOwner
	mov	[pSsCOMcur],0		;reset to default
	pop	es
	pop	dx
	pop	cx			;Return address
	add	sp,SsComSize+4		; Eat oCommon and cbFixed
	pop	bp
	push	cx			;Return address back
CheckCase:

;
;	Binds CASE true branches to BOS.  The line may only consist of
;	constant expressions and case executors, thus the CASE frame
;	must be on the top of the scan stack.  If this is not the case,
;	it was the result of a CASE without SELECT error which is detected
;	by Ss_Case.

	test	[SsBosFlags],SSBOSF_StCase ;Need to bind TRUE Case branch?
	jz	ResetFlags

	pop	cx			;pop return address
	pop	ax			;get frame type
	test	ax,STYP_Case		;is this a CASE frame?
	push	ax
	push	cx
	jz	ResetFlags		;brif not, must have been an error (CASE w/o SELECT)

	mov	bx,sp			;get ptr to CASE frame
	inc	bx
	inc	bx			;skip return address
	mov	ax,UNDEFINED		;reset start of TRUE branch chain
	xchg	ax,[bx].FCASE_oTxTrue	;get ptr to start of TRUE branch chain
	xchg	ax,bx			;bx = start of TRUE branch chain
	mov	cx,[SsoTxBos]		;bind to start of BOS
	call	BindExit		;bind the chain

ResetFlags:
	mov	SsBosFlags,0		;Reset statement flags
	mov	[SsBosStack],sp 	; SP at BOS
	ret

SsProc	OptionBase1
	or	[mrsCur].MRS_flags,FM_OptionBase1
	jmp	short CheckOption

SsProc	OptionBase0			;Already set by default
CheckOption:
	test	[SsFlags],SSF_HaveDimmed;DIM already occured?
	jz	SetDimmed		;If not, it's OK
	xchg	cx,ax			;Save executor in cx
	mov	ax,MSG_OBA		;Array already dimensioned
	jmp	short NestError

SetDimmed:
	or	[SsFlags],SSF_HaveDimmed;Don't allow another OPTION BASE
	jmp	short NotInProc


SsProc	Shared,rude
	jmp	short NotInProc

SsProc	StShared,rude
	or	SsBosFlags,SSBOSF_StShared
	jmp	short Ss_StDim		

SsProc	StStatic,rude
	or	SsBosFlags,SSBOSF_StStatic
	jmp	short Ss_StDim		


SsProc	StDim,rude

	mov	[SsOTxPatchBos],di	; Patch this with next Bos address
	add	di,4			; Address after this opcode
	mov	[SsOTxStart],di 	; New first location for DIM
	sub	di,4			; Restore current emit address
	jmp	short Ss_0_0


SsProc	NotInProc
NotInProc:
	test	byte ptr [grs.GRS_oRsCur+1],80H	;In a procedure?
	jz	Ss_0_0			;If not, it's OK
	xchg	cx,ax			;Save executor in cx
	mov	ax,MSG_InvProc		;Illegal in procedure
NestError:
	call	SsError
NestCont:
	xchg	ax,cx			;Restore executor to ax
	jmp	short Ss_0_0

SsProc	ElemRef
	test	[SsFlags],SSF_InType	;In a TYPE declaration?
	jnz	Ss_0_0			;If so, it' OK
	xchg	cx,ax			;Save executor in cx
	mov	ax,MSG_InType
	jmp	short NestError


SsProc	StConst,rude

	mov	cl,[SsExecFlag]
	mov	[SsExecTmp],cl		    ;Save current state of OPA_fExecute
	or	[SsBosFlags],SSBOSF_Const   ;Flag that we're in a CONST statement
	jmp	short Ss_0_0

SsProc	AsType,rude
	jmp	short Ss_0_0


SsProc	Static
	mov	f_Static,TRUE
	jmp	short Ss_0_0

SsProc	Dynamic
	mov	f_Static,FALSE
	jmp	short Ss_0_0

SsProc	0_0
	push	[ScanRet]	;Push address of main scan loop
				;And fall into EmitExCopyOps to handle standard
				; 0 consume 0 emit issues
;EmitExCopyOps - Emit executor and copy operands
;Purpose:
;	Emit the executor for the current opcode.
;	Copy all operands from source to destination.
;
;NOTE:	SsProc 0_0 falls into this code.
;
;Input:
;	ax	 = executor
;	bx	 = opcode * 2
;	es:si/di = scan source and destination
;Output:
;	bx    = opcode
;	si/di	updated
;
;Preserves:
;	dx
Public	EmitExCopyOps
EmitExCopyOps:
	STOSWTX 			;Emit the executor
;	jmp	short CopyOperands	;Fall into CopyOperands

;***
;CopyOperands
;Purpose:
;	Copy the operands for opcode in bx from si to di.
;
;	This routine handles the following special cases:
;	- no operands for this opcode
;	- operand count is the first operand
;
;NOTE:	EmitExCopyOps falls into this code.
;
;Input:
;	bx = opcode * 2
;	si = source of copy
;	di = destination
;	es = segment of copy
;
;Output:
;	bx = opcode
;	si/di updated
;
;Preserves:
;	dx
;*****************************************************************
Public	CopyOperands
CopyOperands:
	shr	bx,1			;Back to opcode
	mov	cl,mpOpAtr.[bx] 	;Load atribute byte
	and	cx,OPA_CntMask		;Get the operand count from atribute
.errnz	OPA_CntMask AND 0FF00H		;must use cx in next line if non-zero
	cmp	cl,OPA_CntMask		;Check for cnt field in operand
	jne	CopyOp	 		;No cnt field
	LODSWTX 			;Load the cnt field
	STOSWTX 			;Emit the byte cnt field
	mov	cx,ax
	inc	cx			;Round to even byte count
CopyOp:
	shr	cx,1			;Move to word count
	cli				;Double prefix! No interrupts!
rep	movs	PTRTX[si],PTRTX[di]	;Copy the operands
	sti
	ret


subttl	Label Reference Scanning
page
;***
;Ss_MrsMrsLabRef - scan dispatch for RESUME/RETURN <line/label>
;Purpose:
;	Scope and bind RESUME/RETURN <line/label> reference to definition.
;	Check to ensure that the RESUME/RETURN statement was at the module
;	level.	If not, issue an Illegal in PROC or DEF FN error.
;	bind the RESUME/RETURN to a module level label.  If the label
;	definition is in a DEF FN, SUB, or FUNCTION, issue a
;	scoping error.
;Entry:
;	standard scan entry
;Exit:
;	standard scan exit
;Exceptions:
;	Illegal in proc or DEF FN.
;	Label not defined.
;****************************************************************************


SsProc	MrsMrsLabRef
	STOSWTX 			;emit executor
	test	grs.GRS_oRsCur,8000H	;are we in DEF FN, SUB, or FUNCTION?
	jz	LabelBindMrs		;brif not, at main level
	mov	ax,MSG_InvProc		;Illegal in PROC or DEF FN
	call	SsError 		;remember error
	jmp	short LabelBindMrs	;bind to module level label


;***
;Ss_MrsLabelRef - scan dispatch for binding labels to module level
;Purpose:
;	Scanner entry point to scope and bind labels which must always
;	be bound to the module level.  The statements that get bound
;	here include ON event GOSUB <lab/line>, ON ERROR GOTO <lab/line>,
;	RESTORE <lab/line>, and RUN <lab/line>.
;
;	NOTE: RESTORE <lab/line> may bind within a DEF FN, or to the
;	Module level.
;
;	If the label definition is in a DEF FN, SUB, or FUNCTION, issue a
;	scoping error.
;Entry:
;	standard scan entry
;Exit:
;	standard scan exit
;Exceptions:
;	Label not defined.
;****************************************************************************
SsProc	MrsLabelRef
	STOSWTX 				;Emit executor
	    cmp     ax,CODEOffset exStRestore1	;Is this a RESTORE <lab/line>
	    jnz     LabelBindMrs		;Brif not
	mov	fRestoreLab,TRUE		;Set special RESTORE flag
;fall into LabelBindMrs

page
;LabelBindMrs, LabelBindMrsCx - bind label refs to module level
;Purpose:
;	Binds one(LabelBindMrs), or more (LabelBindMrsCx) label
;	references to module level label defs.	Scoping errors
;	and undefined label refs are checked.
;Entry:
;	cx - count of labels to bind
;	es:si - start of label oNam list to bind.
;	es:di - emit address for bound label oTx.
;Exit:
;	source and emit addresses advances appropriately.
;Exceptions:
;	Label not defined.


;public  LabelBindMrs			 ;Entry point to bind to a module level
LabelBindMrs:				;label
	mov	cx,1			;will bind 1 label

;public  LabelBindMrsCx 		 ;Entry point to bind a list of label
LabelBindMrsCx: 			;refs to module level label defs
	mov	ax,grs.GRS_oMrsCur	;scope it to MODULE level
	GETSEG	dx,[mrsCur.MRS_txd.TXD_bdlText_seg],,<SIZE,LOAD> ;[3] get module text table
	mov	bx,mrsCur.MRS_txd.TXD_otxLabLink  ;get module label chain

	test	txdCur.TXD_flags,FTX_mrs ;are we in a module level text table?
	jz	LabelBind		;brif not, use module text table
	jmp	short LabelBindCom	;bind to current text table

page
;***
;Ss_nLabelRef - scan dispatch for binding a list of labels to same scope
;Purpose:
;	Scanner entry point to scope and bind labels which must always
;	be bound to the same scoping level. This scanner dispatch
;	handles a list of labels.  Statemtents that are bound by this
;	routine include ON <exp> GOSUB <lab/line, ...>, and
;	ON <exp> GOTO <lab/line, ...>.
;
;	If the label definition is not at the same scoping level, (e.g.
;	into or out of DEF FN) then a scoping error is generated.
;Entry:
;	standard scan entry
;Exit:
;	standard scan exit
;Exceptions:
;	Label not defined.
;****************************************************************************
SsProc	nLabelRef
	STOSWTX 			;emit executor
	mov	ax,ET_I2		;enumerated GOTO, GOSUB must have I2 arg
	call	EnsureArgType		;coerce to I2 if necessary
	LODSWTX 			;get operand byte count
	STOSWTX 			;and emit it
	shr	ax,1			;byte => word count
	xchg	ax,cx			;set up label count
	jmp	short LabelBindCur

;***
;Ss_LabelRef - scan dispatch for binding a labels to the same scope
;Purpose:
;	Scanner entry point to scope and bind labels which must always
;	be bound to the same scoping level. This scanner dispatch
;	handles a list of labels.  Statemtents that are bound by this
;	routine include GOSUB <lab/line, ...>, GOTO <lab/line>, and
;	RETURN <lab/line>
;
;	If the label definition is not at the same scoping level, (e.g.
;	into or out of DEF FN) then a scoping error is generated.
;Entry:
;	standard scan entry
;Exit:
;	standard scan exit
;Exceptions:
;	Label not defined.
;****************************************************************************
SsProc	LabelRef
	STOSWTX 			;emit executor
	mov	cx,1			;will bind one label
;fall into LabelBindCur

page
;LabelBindCur, LabelBindCom, LabelBind - label binders
;Purpose:
;	Label binder routines for the various styles of label
;	binding.
;
;	LabelBindCur - binds the label ref and def to the same
;	    scope, using the current text table.
;	LabelBindCom - binds the label ref to a label def in
;	    the current text table.  The scoping rule for the
;	    the target label has already been determined.
;	LabelBind - binds the label ref to the specified text
;	    table, with the specified target scoping rule.
;
;	The label ref scope is defined by grs.GRS_oRsCur, which defines
;	the oRs for the Module, DEF FN, SUB, or FUNCTION of the label
;	ref.  If we are scanning the direct mode buffer, then the
;	current CONTINUE context is used to define the label ref scope.
;
;	The label def scope is the expected oRs of the actual
;	definition.  This may, or may not be within the current text
;	table.	The label def scope is kept in the variable oRsExpected.
;	If bit 0 of oRsExpected is set then the label def (if found)