;SETSTS.SBR
;
;	Copyright (C) 1994 by Jeff Kreider, Consultant
;
;	Provided "as is" for use by AMUS members for any purpose except
;		for resale. For conditions of resale, contact:
;
;		Jeff Kreider, Consultant
;		210 N. Iris Ave
;		Rialto, CA 92376-5727
;		(909) 874-6214
;
;	Permission for resale will be granted only in writting.
;
;This routine assembles on 2.x systems and the resulting SBR will run on
;	any system 1.3B or later. It will not assemble properly on the 1.x
;	O/S, however, due the the length of some of the symbol names. The
;	can not be longer than 6 characters on the 1.x O/S
;
;Sample set up and usage within AlphaBASIC:
;		
;MAP1 SET'STATUS
; MAP2 SET'RADIX,B,1,1
; MAP2 SET'ECHO,B,1,2
; MAP2 SET'DSKERR,B,1,3
; MAP2 SET'VERIFY,B,1,4
; MAP2 SET'GUARD,B,1,5
; MAP2 SET'CTRLC,B,1,6
; MAP2 SET'DIRECT,B,1,7
; MAP2 SET'LOCK,B,1,8
; MAP2 SET'RESULT,B,1          ! Returns -1 for formating error
;                              ! good results depend on call
;                              ! RADIX   0 = OCTAL
;                              !         1 = HEX
;                              ! ECHO    0 = ECHO
;                              !         1 = NOECHO
;                              ! THE REST
;                              !         0 = NOT SET
;                              !         1 = SET
;
;XCALL SETSTS,SET'ECHO,SET'RESULT
;IF SET'RESULT<0 PRINT "ERROR IN FORMAT" : END
;IF SET'RESULT = 0 THEN &
;          PRINT "ECHO IS SET" &
;   ELSE &
;          PRINT "NOECHO IS SET"
;
;END
;
	SEARCH	SYS
	SEARCH	SYSSYM
	SEARCH	TRM

	OBJNAM	0,0,[SBR]		; change to XBR for BASIC Plus
					;  or COMPLP with /S option

;
; AlphaBASIC XCALL argument block format
;
.OFINI
.OFDEF	XC.ARG,2			; number of args
.OFDEF	XC.TYP1,2			; 1 type	
.OFDEF	XC.ADR1,4			; 1 address	
.OFDEF	XC.SIZ1,4			; 1 size
.OFDEF	XC.TYP2,2			; 2 type
.OFDEF	XC.ADR2,4			; 2 address
.OFDEF	XC.SIZ2,4			; 2 size
.OFSIZ	XC.SIZ				; size of list

XC$UNF=0				; symbol for unformatted
XC$STR=2				; symbol for string
XC$FLT=4				; symbol for floating point
XC$BIN=6				; symbol for binary
;
;

	VMAJOR=1
	VMINOR=0
	VSUB=0
	VEDIT=100.

	PHDR	-1,PV$RSM,PH$REU!PH$REE

SETSTS:	CMPW	XC.ARG(A3),#2		; enough args?
	JEQ	10$			; yes
	TYPECR	<?Insufficient arguments passed to SETSTS.SBR>
	EXIT
10$:	CMPW	XC.TYP1(A3),#XC$BIN	; is parm a binary?
	JEQ	20$			; yes
15$:	TYPECR	<?Wrong variable type in SETSTS.SBR>
	EXIT
20$:	CMPW	XC.TYP2(A3),#XC$BIN	; is second parm a binary?
	JNE	15$			; no
	CMP	XC.SIZ1(A3),#1		; one byte?
	JEQ	30$			; yep
25$:	TYPECR	<?Wrong size of variable in SETSTS.SBR>
	EXIT
30$:	CMP	XC.SIZ2(A3),#1		; size check on second
	JNE	25$			; oops
	MOV	XC.ADR1(A3),A1		; get request var
	MOV	XC.ADR2(A3),A2		; get return var
	CLRB	@A2			; set default
	CLR	D0			; clear upper bits on request
	CLR	D2			; clear upper bits on jobtyp
	JOBIDX				; get JCB
	MOVW	JOBTYP(A6),D2		; get job type
	MOVB	@A1,D0			; get request
	CMPB	D0,#1			; radix?
	JEQ	RADIX			; yes
	CMPB	D0,#2			; echoing?
	JEQ	ECHO			; yes
	CMPB	D0,#3			; dskerr?
	JEQ	DSKERR			; yes
	CMPB	D0,#4			; verify?
	JEQ	VERIFY			; yes
	CMPB	D0,#5			; guard?
	JEQ	GUARD			; yes
	CMPB	D0,#6			; ctrlc?
	JEQ	CTRLC			; yes
	CMPB	D0,#7			; redirection?
	JEQ	DIRECT			; yes
	CMPB	D0,#8.			; locking
	JEQ	LOCKING			; yes
	MOVB	#-1,@A2			; format error
EXIT:	RTN				; return to basic
EXIT2:	MOVB	#1,@A2			; 
	RTN

RADIX:	ANDW	#J.HEX,D2		; is hex set?
	JEQ	EXIT			; no, is octal (default)
	JMP	EXIT2			; yes

ECHO:	CLR	D2			; get rid of status
	TRMRST	D2			; get terminal status word
	ANDW	#T$ECS,D2		; echo suppressed?
	JEQ	EXIT			; no, ECHO is SET
	JMP	EXIT2			; yes

DSKERR:	ANDW	#J.DER,D2		; is DSKERR SET?
	JEQ	EXIT			; no
	JMP	EXIT2			; yes

VERIFY:	ANDW	#J.VER,D2		; is VERIFY SET?
	JEQ	EXIT			; no
	JMP	EXIT2			; yes

GUARD:	ANDW	#J.GRD,D2		; is GUARD SET?
	JEQ	EXIT			; no
	JMP	EXIT2			; yes

CTRLC:	ANDW	#J.CCA,D2		; is CTRLC SET?
	JEQ	EXIT			; no
	JMP	EXIT2			; yes
;
;SET REDIRECTION and SET LOCK are supported only on 2.2 and later
;	This routine checks only that the O/S supports 2.0 and later.
;	If used on 2.x system prior to 2.2, these options will probably
;	return a NOT SET condition.
;
DIRECT:	MOV	SYSTEM,D7		; get system bit
	AND	#SY$EXD,D7		; 2.x?
	JNE	10$			; yes, valid call
	MOVB	#-1,@A2			; not valid call
	JMP	EXIT
10$:	MOVW	JOBTY2(A6),D2		; Get second job type
	ANDW	#J2$RED,D2		; redirection set?
	JEQ	EXIT			; no
	JMP	EXIT2			; yes

LOCKING:
	MOV	SYSTEM,D7		; get system bit
	AND	#SY$EXD,D7		; 2.x?
	JNE	10$			; yes, valid call
	MOVB	#-1,@A2			; not valid call
	JMP	EXIT
10$:	ANDW	#J.NLK,D2		; locking set?
	JNE	EXIT			; yes
	JMP	EXIT2			; no

	END