lsid.asm

Dos6.0

;***************************************************************************
; LrStReDimTo
; Purpose:
;	if 1st DIM opcode in this statement, list DIM, else list ','
;
;	[[")" expZ "," expY "," expX ... exp1 "(" typeChar oNam]] ==>
;	  [[")" expZ TO expY "," expX ... exp1 "(" typeChar oNam]]
;	opDimOptionBase gets listed as "?" internally, so this function
;	eliminates those nodes when found.
;
;***************************************************************************
ListRule LrStReDimTo
	mov	ax,ORW_REDIM		;ax = reserved word of stmt 
	call	PushTempRwOrComma	;push "," or RW of stmt
	call	PushTempShared		;list SHARED if opShared was seen
	call	PopRoot			;ax = offset to node to be DIMed
; handle the special case where an StReDimTo is being used in place
; of what used to be a StReDimScalar in QB4.0
	test	BYTE PTR[opList+1],HIGH(OPCODE_MASK+1) 
	jnz	GotRedimScalar		;brif if normal ReDimTo
	call	StripOptBase		;walk through list ax, eliminating
					; nodes created by opDimOptionBase
					; and converting ',' to TO.
					; ax still = offset to node to DIM
GotRedimScalar:
	call	PushTemp		;push array node to temp stack
	jmp	PushListStg1		;push temp list to root as 1 node
					; and return to outer loop

;***************************************************************************
; StripOptBase
; Purpose:
;	ax = offset to [[")" exp ", " exp ", " exp "(" typeChar oNam]]
;	walk through this list, eliminating "?" "," nodes (which
;	were created by opDimOptionBase), and converting every other
;	comma to " TO "
; Preserves: ax
;
;***************************************************************************
StripOptBase PROC NEAR
	push	ax
	push	si
	call	ListOffToPtr		;bx = ptr to node ax
	mov	ax,WORD PTR [bx.LN_val_list]
					;bx = offset to 1st node in list
					; This could be ")" or [AS <type>]
	call	ListOffToPtr		;bx = ptr to node ax
	cmp	BYTE PTR [bx.LN_type],LNT_CHAR
	je	StripLoop		;brif it is ")"
	call	ListSibPtr		;bx = sibbling(bx) ")"
StripLoop:
	call	ListSibPtr		;bx = sibbling(bx) (dim's UPPER index)
	call	ListSibPtr		;bx = sibbling(bx) (comma)
	mov	si,bx			;save ptr to it
	mov	WORD PTR [si.LN_val_char],'OT'	;convert comma to TO
	call	ListSibPtr		;bx = sibbling(bx) (dim's LOWER index
					; or "?" put there by opDimOptionBase)
	cmp	BYTE PTR [bx.LN_type],LNT_CHAR
	jne	NotDefault		;brif couldn't be "?"
	cmp	BYTE PTR [bx.LN_val_char],'?'
	jne	NotDefault		;brif not "?"
	sub	ax,ax			;ax = 0
	mov	WORD PTR [si.LN_val_char],ax	;convert comma node to NULL
	mov	WORD PTR [bx.LN_val_char],ax	; and LOWER index node to NULL
NotDefault:
	call	ListSibPtr		;bx = sibbling(bx) (comma or '(')
	cmp	BYTE PTR [bx.LN_val_char],','
	je	StripLoop		;brif ","
StripExit:				
	pop	si
	pop	ax			;ax = offset to node to be DIMed
	ret
StripOptBase ENDP

ListRule LrStErase
	call	PushTempOpRwSpc		;emit opcode's resword (ERASE)
	lods	WORD PTR es:[si]	;ax = opStErase's cnt operand
	mov	[cLsArgs],al
	call	PushCommaArgs		;copy cLsArgs from root to temp
					; and separate them by commas
	jmp	PushListStg1		;push temp list to root as 1 node
					; and return to outer loop

; The statement "COMMON SHARED /foo/ a,b" produces the pcode:
; opShared, opCommon(oNam(foo)), opIdVTRef(a), opIdVTRef(b)
;
ListRule LrStCommon
	call	PushRootOpRwSpc		;emit opcode's resword (COMMON)
	call	PushRootShared		;list SHARED if opShared seen
	inc	si			;skip cntEos operand
	inc	si
	lods	WORD PTR es:[si]	;ax = common block's oNam (FFFF if none)
	cmp	ax,UNDEFINED
	je	NotBlockCommon
	push	ax
	mov	al,'/'			;list "/"
	call	PushRootChar
	pop	ax
	call	PushRootONam		;list block's name
	mov	ax,' /'
	call	PushRootChars		;list "/ "
NotBlockCommon:
	or	[lsBosFlags],FBOS_DoIdCommas
					;every opIdVTRef in this statement
					; is to be preceeded by "," except
					; the first.
	jmp	Stg1Loop		;return to outer loop

; The statement "SHARED a,b" produces the pcode:
; opStShared opIdVTRef(a), opIdVTRef(b)
;
ListRule LrStStatic
ListRule LrStShared
	inc	si			;skip oText operand
	inc	si
	call	PushRootOpRwSpc		;emit opcode's resword (SHARED/STATIC)
	or	[lsBosFlags],FBOS_DoIdCommas
					;every opIdVTRef in this statement
					; is to be preceeded by "," except
					; the first.
	jmp	Stg1Loop		;return to outer loop

;	DIM, AUTO, PUBLIC, and EB STATIC
ListRule LrStoClassDecl
	inc	si			; skip oText operand
	inc	si			
	or	[lsBosFlags2],FBOS2_DIM 
	call	PushRootOpRwSpc		
	call	PushRootShared		;list SHARED if opShared seen
	jmp	Stg1Loop		;return to outer loop


;***************************************************************************
; LrStDefType
; Purpose:
;	List opStDefType opcode.  Opcode's operand is link field followed
;	by 32 bit mask/type as follows:
;	   high 26 bits, 1 bit for each letter A..Z
;	   low 6 bits = ET_xx
; Algorithm:
;	letterCur = 'A'-1
;	cLetters = 0
;	fNotFirst = FALSE
;	while mask != 0
;	   letterCur = letterCur + 1
;	   shift mask left 1 bit
;	   if carry is set
;	      if cLetters == 0
;	         if fNotFirst
;	            list ", "
;	         list letterCur
;	         fNotFirst = TRUE
;	      cLetters++
;	   else
;	      if cLetters > 0
;	         if cLetters > 1
;	            list "-"
;	            list letterCur-1
;		 cLetters = 0
;
; Register allocation:
;	letterCur = si
;	cLetters = cl
;	mask = dx:ax
;	fNotFirst = ch
;
;***************************************************************************
ListRule LrStDefType
	inc	si			;skip link field
	inc	si
	lods	WORD PTR es:[si]	;ax = low 16 bits of operand
	xchg	ax,dx			;dx = low 16 bits of operand
	lods	WORD PTR es:[si]	;ax = high 16 bits of operand
	xchg	ax,dx			;[dx:ax] = 32 bit operand
	mov	bl,al			;bl = type
	and	ax,0FFC0H		;ax = bit mask for last 10 letters
	push	si			;save si for duration of routine

	push	ax			;save low 16 bits of operand
	push	dx			;save high 16 bits of operand
	and	bx,03FH			;bx = type
	shl	bx,1			;bx = type * 2
	mov	ax,tRwDefType - 2[bx]	;ax = ORW_DEFINT .. ORW_DEFSTR
	call	PushRootRwSpc		;list DEFINT..DEFSTR

	mov	si,'A'-1		;si = letterCur = 'A'-1
	sub	cx,cx			;cLetters = 0, fNotFirst = 0
DefTypeLoop:
	pop	dx			;dx = bit mask for first 16 letters
	pop	ax			;ax = bit mask for last 10 letters
	mov	bx,ax			;test mask
	or	bl,cl			;don't exit if we're within a range
					; (like A-Z), so we can terminate it
	or	bx,dx			;test high word of mask as well
	je	EndDefType		;brif mask is 0
	inc	si			;letterCur = letterCur + 1
	shl	ax,1			;shift mask left 1 bit
	rcl	dx,1
	push	ax			;save mask on stack
	push	dx			; (gets popped by DefTypeLoop)
	push	cx			;save cLetters, fNotFirst
	jnc	NotThisLetter		;brif this letter is not set
	or	cl,cl
	jne	BumpCLetters		;brif we're already in a range
					; (ie we're at B in an A-Z range)
	or	ch,ch
	je	Not1stLetter		;brif this is the 1st letter output
	call	PushRootCommaSpc	;list ", "
Not1stLetter:
	mov	ax,si			;al = letterCur
	call	PushRootChar		;list letterCur
BumpCLetters:
	pop	cx			;restore cLetters, fNotFirst
	inc	cx			;cLetters++ (inc cl is bigger opcode)
	mov	ch,1			;fNotFirst = FALSE
	jmp	SHORT DefTypeLoop

NotThisLetter:
	or	cl,cl
	je	NotWithinRange		;brif cLetters = 0
	dec	cl
	je	NotWithinRange		;brif cLetters was 1
	mov	al,'-'
	call	PushRootChar		;list "-"
	mov	ax,si			;al = letterCur
	dec	al			;al = letterCur - 1
	call	PushRootChar
NotWithinRange:
	pop	cx
	sub	cl,cl			;cLetters = 0
	jmp	SHORT DefTypeLoop	;set fNotFirst = TRUE

EndDefType:
	pop	si			;restore si=text pointer
	jmp	Stg1Loop		;return to outer loop

subttl	Procedure related opcodes

;------------------------------------------------------------------
;		Procedure related opcodes
;------------------------------------------------------------------

tcEt LABEL BYTE
	.erre	ET_I2 EQ 1		
	DB	'%'			;ET_I2
	.erre	ET_I4 EQ 2		
	DB	'&'			;ET_I4
	.erre	ET_R4 EQ 3		
	DB	'!'			;ET_R4
	DB	'#'			;ET_R8
	db	'$'			;ET_SD

;***************************************************************************
; ListProc
; Purpose:
;	List a [DECLARE] SUB/FUNCTION/DEF [QB4] statement
; Entry:
;	ax = cnt operand
;	es:si points to oPrs operand
;	lsBosFlags2 & FBOS2_DECLARE is non-zero for DECLARE
;
;***************************************************************************
DbPub	ListProc
cProc	ListProc,<NEAR>
	localW	parmFlags
	localW	cbAlias
	localB	procType
	localW	procAtr				
	procAtr_LO EQU BYTE PTR (procAtr)
	procAtr_HI EQU BYTE PTR (procAtr+1)
cBegin
	add	ax,si			;ax -> beyond end of opcode's operands
	push	ax			;save till function exit
	lods	WORD PTR es:[si]	;ax = oPrs operand (oNam if opStDefFn
					; and we're in SS_RUDE scan state)

	;--------------------------------------------------------\
	;NOTE: Temp data is on stack until end of this block
	;      Don't branch into or out of this block
	push	es			;save es (restored after FieldsOfPrsFar)
	push	ax			;pass oPrs to FieldsOfPrsFar

	lods	WORD PTR es:[si]	;ax = procAtr operand
	mov	[procAtr],ax		;save procAtr
	.errnz	DCLA_procType - 0300h
	and	ah,3			;ah = procType
	mov	[procType],ah		;save for later
	xchg	dx,ax			;dh = procType

	mov	ax,ORW_SUB
	cmp	dh,PT_SUB
	je	LpGotOPrs		;brif we're in a SUB
	mov	ax,ORW_FUNCTION
	cmp	dh,PT_FUNCTION
	je	LpGotOPrs		;brif we're in a FUNCTION
	DbAssertRelB dh,e,PT_DEFFN,LIST,<LrStDeclare has invalid proc type>
	mov	ax,ORW_DEF
	cmp	[txdCur.TXD_scanState],SS_RUDE
	jb	LpGotOPrs		;brif not in SS_RUDE
	;opStDefFn has oNam as operand, not oPrs in RUDE state
	call	PushRootRwSpc		;push DEF to root stack
	pop	ax			;ax = oNam
	jmp	SHORT LpDefFn

LpGotOPrs:
	call	PushRootRwSpc		;push SUB/FUNCTION/DEF to root stack

					;parm to FieldsOfPrsFar pushed shortly
					; after entry to ListProc
	call	FieldsOfPrsFar		;ax = oNam of prs
;ax = oNam for procedure
LpDefFn:
	pop	es			;restore es = seg adr of txt table
	;NOTE: Temp data is now off stack
	;--------------------------------------------------------/

	call	PushRootONam		;list sub/func/def's name
					;high byte contains proc type
	mov	al,[procAtr_LO]
	.errnz	DCLA_Explicit - 0080h
	or	al,al
	jns	ImplicitTyp
	and	al,DCLA_oTyp		;al = explicit type
	DbAssertRelB al,ne,0,LIST,<ListProc: invalid explicit oTyp1>
	DbAssertRelB al,be,ET_MAX,LIST,<ListProc: invalid explicit oTyp2>
	mov	bx,LISTOFFSET tcEt - 1	;bx points to tcEt mapping table
	xlat	cs:[bx]			;al = explicit type char (%,&,etc.)
	call	PushRootChar		;list it
	call	CharToCharTok		;convert it to a LNT_CHARS_TOK node
ImplicitTyp:
	call	PushRootSpc
	test	[procAtr_HI],DCLA_cdecl / 100h
	.errnz	DCLA_cdecl - 8000h
	je	NotCDECL		;brif not declared as CDECL
	mov	ax,ORW_CDECL
	call	PushRootRwSpc		;list "CDECL "
NotCDECL:
	lods	WORD PTR es:[si]	;ax = parm cnt operand
	mov	[cLsArgs],al		;save parm count

	;List ALIAS "string" or LIB "string"
	mov	cl,[procAtr_HI]
	.errnz	DCLA_cbAlias - 7C00h
	and	cx,DCLA_cbAlias / 100h	;cx = cbAlias * 4
	shr	cl,1
	shr	cl,1			;cx = cbAlias
	jcxz	NoAliasOrLib		;brif alias clause not specified
	push	si			;save si points to 1st arg
	push	cx			;save byte count of ALIAS/LIB id

	; set si to point to ALIAS/LIB name
	mov	al,[cLsArgs]
	inc	al			;map 0 and UNDEFINED to 0
	je	NoParms			; brif cLsArgs was UNDEFINED
	dec	al			; restore dx = cLsArgs
NoParms:
	sub	ah,ah			;ax = cLsArgs
	mov	dx,ax			;dx = cLsArgs
	shl	ax,1			;ax = cLsArgs * 2
	add	ax,dx			;ax = cLsArgs * 3
	shl	ax,1			;ax = cLsArgs * 6
	add	si,ax			;si points to ALIAS or LIB name

	mov	ax,ORW_ALIAS
	call	PushRootRwSpc		;list ALIAS
	pop	ax			;restore ax = cbAlias
PushQStr:				
	call	PushRootQstr		
	call	PushRootSpc		;list " "
NoAlias:
	pop	si			;restore si points to 1st arg

NoAliasOrLib:
	cmp	[cLsArgs],0
	jg	GotProcParms		;brif cParms != UNDEFINED and != 0
					; (for DECLARE, UNDEFINED means 0
					;  parms, and no type checking - see
					;  pcode document)
	jl	NoTypeChk		;brif cParms == UNDEFINED
	test	[lsBosFlags2],FBOS2_DECLARE
	je	NoTypeChk		;brif not listing DECLARE
EnforceNoParms:
	mov	ax,')('
	call	PushRootChars		;list "() "
	call	PushRootSpc
NoTypeChk:
	jmp	NoProcParms

GotProcParms:
	call	PushRootLParen		;push '('
ProcParmLoop:
	cmp	si,[otxLsCursorTmp]
	jb	NotNdLsCursor		;brif not token of interest
	mov	[ndLsCursor],di
	mov	[otxLsCursorTmp],UNDEFINED ;make sure we don't set it again
NotNdLsCursor:
	test	[lsBosFlags2],FBOS2_DECLARE
	je	NotDeclParm		;brif not listing DECLARE
	lods	WORD PTR es:[si]	;ax = parm's oNam
	call	NewONam			;ax = offset to oNam node
					;bx = oNam
	jmp	SHORT ChkPrmFlgs
NotDeclParm:
	call	NewId			;consume id's operand, ax = node
					;bx = oNam
ChkPrmFlgs:
	push	bx			;save