	PROGRAM SD

**
*	SET/SHOW DEFAULT DIRECTORY
*
*
*	 Inputs:  DCL Symbol PARAM
*		  Current default device/directory
*
*	Outputs:  DCL Symbol CHANGE  \__ (Not set if
*		  DCL Symbol COMMAND /    error occurs)
*		  (Current default device/directory unchanged)
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*			   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	CHARACTER*256 STRING

	COMMON /SD_WORK/ VALUE,EXPDEV,SLEN,STRING

	CHARACTER*256 DEFAULT,COMMAND,PARAM

	COMMON /SD_COMMAND/ PLEN,CLEN,PARAM,COMMAND

	LOGICAL PRIV,USER_HAS_PRIV

	CHARACTER*5 SGS_VERSION

	DATA CLEN,COMMAND / 4,'EXIT' /

	STATUS = LIB$GET_SYMBOL('PARAM',PARAM,PLEN)

	PLEN = STR_LEN(PARAM(1:PLEN))

	IF (.NOT.STATUS .OR. PLEN.EQ.0) CALL ERROR(1)

	IF (PARAM(1:PLEN).EQ.'$') THEN
	    sgs_version = '3.1'
	    L = STR_LEN(SGS_VERSION)
	    CALL LIB$PUT_LINE('	 SD.EXE Version '//SGS_VERSION(1:L)//
	1							 ' ',,2)
	    CALL EXIT
	ENDIF

	CALL CHECK_COMMAND('*','TREE')

	CALL CHECK_COMMAND('<<','STACK')

	CALL CHECK_COMMAND('DIR','DIR')

	IF (PLEN.EQ.0) GO TO 10

	CALL DEFAULT_DIRECTORY(DEFAULT,DLEN)

	SLEN = DLEN

	STRING(1:SLEN) = DEFAULT(1:DLEN)

	PRIV = USER_HAS_PRIV('SYSPRV')

	STATUS = SD_(PARAM(1:PLEN),PRIV)

	IF (.NOT.STATUS) THEN

	    IF (STATUS.EQ.'184CC'X) CALL ERROR(3)	! Bad directory name
	    IF (STATUS.EQ.'1C04A'X) CALL ERROR(4)	! No such directory
	    IF (STATUS.EQ.'00024'X) CALL ERROR(5)	! No privilege
	    IF (STATUS.EQ.'00908'X) CALL ERROR(6)	! No such device
	    IF (STATUS.EQ.'00930'X) CALL ERROR(7)	! No more files

	ENDIF

	DEVICE(DEVLEN+1:DEVLEN+DIRLEN) = DIRECTORY(1:DIRLEN)

	DEVLEN = DEVLEN + DIRLEN

	IF (DEVICE(1:DEVLEN).NE.DEFAULT(1:DLEN)) THEN

	    STATUS = LIB$SET_SYMBOL('CHANGE',DEVICE(1:DEVLEN))

	ELSE

10	    STATUS = LIB$SET_SYMBOL('CHANGE',' ')

	ENDIF

	IF (.NOT.STATUS) CALL ERROR(2,STATUS)

	STATUS = LIB$SET_SYMBOL('COMMAND',COMMAND(1:CLEN))

	IF (.NOT.STATUS) CALL ERROR(2,STATUS)

	END
	SUBROUTINE CHECK_COMMAND(KEY_STRING,COMMAND_STRING)

*	 5 Jun 1986	Make sure asterisks in wildcard directory
*			specifications are not mistaked for re-
*			quests for tree displays.

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) KEY_STRING,COMMAND_STRING

	CHARACTER*256 COMMAND,PARAM

	COMMON /SD_COMMAND/ PLEN,CLEN,PARAM,COMMAND

	COL = INDEX(PARAM(1:PLEN),KEY_STRING) - 1

	IF (COL.LT.0) RETURN

	IF (COL.GT.0 .AND. PARAM(COL:COL).NE.' ') RETURN	!WILD

	COL2 = COL + LEN(KEY_STRING) + 1			!WILD

	IF (COL2.LE.PLEN .AND. PARAM(COL2:COL2).NE.' ') RETURN	!WILD

	CALL LIB$SET_SYMBOL('REST',PARAM(COL+LEN(KEY_STRING)+1:PLEN))

	PLEN = STR_LEN(PARAM(1:COL))

	CLEN = LEN(COMMAND_STRING)

	COMMAND(1:CLEN) = COMMAND_STRING

	END
	SUBROUTINE ERROR(CODE,STATUS)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	CHARACTER*2 B

	PARAMETER ( B = CHAR(7) // CHAR(7) )

	CALL LIB$PUT_LINE(' ')

	GO TO (1,2,3,4,5,6,7),CODE

1	CALL LIB$PUT_LINE('  Syntax Error  '//B,2,3)
	GO TO 100

2	CALL LIB$PUT_LINE('  Error defining symbols  '//B,2,3)
	CALL LIB$STOP(%VAL(STATUS))

3	CALL LIB$PUT_LINE('  Invalid Directory Name  '//B,2,3)
	GO TO 100

4	CALL LIB$PUT_LINE('  No Such Directory '//DIRECTORY(1:DIRLEN)
	1			//' on '//DEVICE(1:DEVLEN)//'  '//B,2,3)
	GO TO 100

5	CALL LIB$PUT_LINE('  No Privilege To Use '//DIRECTORY(1:DIRLEN)
	1						  //'  '//B,2,3)
	GO TO 100

6	CALL LIB$PUT_LINE('  Device '//DEVICE(1:DEVLEN)
	1				    //' Not Available  '//B,2,3)
	GO TO 100

7	CALL LIB$PUT_LINE('  End of traversal reached  '//B,2,3)

100	CALL EXIT('10000004'X)		! Abort, without a message

	END
