;****************************************************************************
;*									    *
;*				   SETLOG				    *
;*		     AlphaBASIC subroutine to Set Login			    *
;*									    *
;****************************************************************************
;Copyright (C) 1988 UltraSoft Corp.  All Rights Reserved.
;
;Written by: David Pallmann
;
;Calling Format:  XCALL SETLOG, "Devn:[p,pn]"
;
;Compatibility: all releases of AMOS/L and AMOS/32
;
;Edit History:
;1.0(100)  06-Aug-88  created. /DFP

	VMAJOR=1
	VMINOR=0
	VEDIT=100.

	OBJNAM	.SBR

	ASMMSG	"== Generating SETLOG.SBR =="
	SEARCH	SYS
	SEARCH	SYSSYM

;****************************************
;*  XCALL argument list, indexed by A3  *
;****************************************

	.OFINI
	.OFDEF	COUNT,2			; number of arguments
	.OFDEF	TYPE1,2			; type of first argument
	.OFDEF	ADDR1,4			; address of first argument
	.OFDEF	SIZE1,4			; size of first argument

        STRING=2			; code for STRING argument

;*****************
;*  Entry Point  *
;*****************

SETLOG:	PHDR	-1,0,PH$REE!PH$REU	; reentrant, reusable
	CMPW	COUNT(A3),#1		; exactly one argument specified?
	JNE	CNTERR			;  no - error
	CMPW	TYPE1(A3),#STRING	; is argument a string?
	JNE	TYPERR			;  no - error

SETUP:	MOV	ADDR1(A3),A2		; point A2 to argument
	JOBIDX	A4			; point A4 to Job Control Block

;*************************
;*  Process Device Code  *
;*************************

DEVICE:	BYP				; skip spaces
	ALF				; was a device code specified?
	BNE	PPN			;  no
	LEA	A1,JOBDEV(A4)		; point to JCB device code
	PACK				; set new device code
	GTDEC				; get device number
	MOVW	D1,JOBDRV(A4)		; set drive number
	CMPB	@A2,#':			; colon present?
	JNE	FMTERR			;  no - error
	INC	A2			; skip colon

;*****************
;*  Process PPN  *
;*****************

PPN:	BYP				; skip spaces
	CMPB	@A2,#'[			; left bracket present?
	BNE	10$			;  no
	INC	A2			;  yes - skip it
10$:	NUM				; PPN present?
	JNE	FMTERR			;  no - error
	GTPPN				; get PPN
	MOVW	D1,JOBUSR(A4)		; set new PPN
	RTN				; return to BASIC program

;********************
;*  Error Handling  *
;********************

CNTERR:	TYPESP	?Argument count
	BR	ERROR
TYPERR:	TYPESP	?Argument type
	BR	ERROR
FMTERR:	TYPESP	?Command format
ERROR:	TYPECR	error in SETLOG.SBR
	EXIT

	END

.