.title	CDPARSE- Change directory AKA Unix/MSDOS
	.ident	'CDPARSE V4.7D'
	.library "sys$share:lib"

;
; Program:	CDPARSE.MAR V4.7D
;
; Author:	David G. North, CCP
;		1333 Maywood Ct
;		Plano, Texas  75023-1914
;		(214) 902-3957
;
; Date:		91.11.13
;
; Revisions:
;   Who		Date	Description
;   D.North     871103  Initial release
;   D.North     880115  Conversion to C
;   D.North     880120  V3.0 pre-release and internal restructuring
;   D.North     890109  Add extension processing to x$ format names
;   D.North     901017  Conversion to MACRO32
;   D.North     901017  Revision of CDx_qq.. name formats
;   D.North     901017  Addition of switch processing
;   D.North     901019  Change PRINTF to SIGNAL w/message file
;   D.North	901116	DECUS release (V4.2)
;   D.North	910502	[000000.xxx... fixed
;   D.North	910812	Bug in do_syntax fixed (CD /FULL [asdf -- ACCVIO!)
;   D.North	910813	Added /COM processing
;   D.North	910813	Added all CD$n processing
;   D.North	911113	DECUS release (V4.7D)
;
; License:
;    Ownership of and rights to these programs is retained by the author(s).
;    Limited license to use and distribute the software in this library is
;    hereby granted under the following conditions:
;      1. Any and all authorship, ownership, copyright or licensing
;         information is preserved within any source copies at all times.
;      2. Under absolutely *NO* circumstances may any of this code be used
;         in any form for commercial profit without a written licensing
;         agreement from the author(s).  This does not imply that such
;         a written agreement could not be obtained.
;      3. Except by written agreement under condition 2, source shall
;         be freely provided with all binaries.
;      4. Library contents may be transferred or copied in any form so
;         long as conditions 1, 2, and 3 are met.  Nominal charges may
;         be assessed for media and transferral labor without such charges
;         being considered 'commercial profit' thereby violating condition 2.
;
; Warranty:
;    These programs are distributed in the hopes that they will be useful, but
;    WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;    or FITNESS FOR A PARTICULAR PURPOSE.
;

	$dcdef			;Device class definitions
	$devdef			;DEVCHAR bits
	$dvidef			;$GETDVI junk
	$iodef			;IO function codes
	$libdef			;LIB$ routine return codes
	$lnmdef			;Logical name translation codes
	$rmsalldef		;Get most RMS structures
	$rmsdef			;RMS return codes etc.
	$ssdef			;System return codes
	$stsdef			;Status structure
	$tpadef			;LIB$TPARSE table generation junk

	.psect	$local,pic,noshr,noexe,rd,wrt,long
	.psect	$tpastuff,pic,shr,noexe,rd,nowrt
	.psect	$code,pic,shr,exe,rd,nowrt


;++
;  Local constants and macros
;do_op() opcodes
OP_C_BSL = 1  ;'\<eos>' processing
OP_C_RST = 2  ;reset parser to top of string
OP_C_DOL = 3  ;'$<eos>' processing
OP_C_DD  = 4  ;'..' --> '-' processing
OP_C_DEV = 5  ;devnam extraction
OP_C_BRI = 6  ;'['..']' add w/insert
OP_C_BRO = 7  ;'['..']' add w/overwrite
OP_C_BDI = 8  ;'[.'..']' add w/insert
OP_C_DOT = 9  ;change something at current token to '.'
OP_C_DEL = 10 ;Deletes current char
OP_C_RMV = 11 ;Deletes present parse position to beginning of line
OP_C_BCK = 12 ;Back parser up one char
; Switch values
SW_V_LOG == 0
SW_M_LOG == <1@SW_V_LOG>
SW_V_VER == 1
SW_M_VER == <1@SW_V_VER>
SW_V_FUL == 2
SW_M_FUL == <1@SW_V_FUL>
SW_V_COM == 3
SW_M_COM == <1@SW_V_COM>

GK_UPARROW = ^x101
GK_DNARROW = ^x102
GK_RTARROW = ^x103
GK_LFARROW = ^x104
GK_E1 = ^x105
GK_E2 = ^x106
GK_E3 = ^x107
GK_E4 = ^x108
GK_E5 = ^x109
GK_E6 = ^x10a
GK_F7 = ^x10b
GK_F8 = ^x10c
GK_F9 = ^x10d
GK_F10 = ^x10e
GK_F11 = ^x10f
GK_F12 = ^x110
GK_F13 = ^x111
GK_F14 = ^x112
GK_F15 = ^x113
GK_F16 = ^x114
GK_F17 = ^x115
GK_F18 = ^x116
GK_F19 = ^x117
GK_F20 = ^x118
GK_PF1 = ^x119
GK_PF2 = ^x11a
GK_PF3 = ^x11b
GK_PF4 = ^x11c
GK_KP0 = ^x11d
GK_KP1 = ^x11e
GK_KP2 = ^x11f
GK_KP3 = ^x120
GK_KP4 = ^x121
GK_KP5 = ^x122
GK_KP6 = ^x123
GK_KP7 = ^x124
GK_KP8 = ^x125
GK_KP9 = ^x126
GK_KPMINUS = ^x127
GK_KPPERIOD = ^x128
GK_KPCOMMA = ^x129
GK_KPENTER = ^x12a

.MACRO	retc	src=r0,?l1
	blbs	src,l1
	ret
l1:
.ENDM	retc

.MACRO	rsbc	src=r0,?l1
	blbs	src,l1
	rsb
l1:
.ENDM	rsbc

.MACRO	SIGVEC	V1,V2,V3,V4,V5,V6,V7,V8,V9,V10
	DBG_K_ACNT = 1
	pushl	#SS$_OPCCUS!STS$M_INHIB_MSG	;eat a bogus PC/PSL
  .irp	faoarg,<<v10>,<v9>,<v8>,<v7>,<v6>,<v5>,<v4>,<v3>,<v2>,<v1>>
    .if	nb, <faoarg>
	pushl	faoarg
	DBG_K_ACNT = DBG_K_ACNT + 1
    .endc
  .endr
	movl	#DBG_K_ACNT,r0
.ENDM	SIGVEC

.MACRO	SIGNAL	savsts
    .if	nb,<savsts>
	movl	(SP),savsts
    .endc
	calls	r0,g^LIB$SIGNAL
.ENDM	SIGNAL

.MACRO	case	source,displist,base=#0,type=b,?table,?etable
	.iif ne %LENGTH(TYPE)-1, .ERROR 1;illegal case: type
	.iif ne %LENGTH(TYPE)-1, .MEXIT
	.iif eq %LOCATE(TYPE,<BWLbwl>)-6, .ERROR 1 ;illegal case: type
	.iif eq %LOCATE(TYPE,<BWLbwl>)-6, .MEXIT
	case'type	source,base,#<<etable-table>/2>-1
table:	.IRP	dest,<displist>
	.word	dest-table
	.ENDR
etable:
.ENDM	case
;--

	.psect	$tpastuff
;++
; TPA Parse table for command line main
;--

;	$INIT_STATE	state_table, key_table
;	$STATE		[label]
;	$TRAN		type[,label][,action][,mask][,msk-adr][,argument]
;	$END_STATE
;
	$INIT_STATE	sttbl0,kytbl0

; Main parse state ... delete quotes if present
	$STATE		start
	$TRAN		'"',start,do_op,,,OP_C_DEL
	$TRAN		TPA$_EOS,,do_op,,,OP_C_RST
	$TRAN		TPA$_ANY,start

; Process switches (w/abbreviation OK)
	$STATE		switch
	$TRAN		!_isswitch,switch
	$TRAN		!_rmvsp,switch
	$TRAN		TPA$_LAMBDA,,do_op,,,OP_C_RMV

; Single special processing
	$STATE		single
	$TRAN		TPA$_BLANK,TPA$_EXIT,,SS$_BADPARAM,retsts
	$TRAN		':',TPA$_EXIT,,SS$_BADPARAM,retsts
	$TRAN		'/',TPA$_EXIT,,SS$_BADPARAM,retsts
	$TRAN		!_iseos,TPA$_EXIT,,SS$_WASCLR,retsts
	$TRAN		!_isdot,TPA$_EXIT,,SS$_OPINCOMPL,retsts
	$TRAN		!_ispnd,TPA$_EXIT,,SS$_WASSET,retsts
	$TRAN		!_isque,TPA$_EXIT,,SS$_RESIGNAL,retsts
	$TRAN		!_isbsl,setddir		;substitute, reset & go
	$TRAN		!_isdol,setddir		;substitute, reset & go
	$TRAN		TPA$_LAMBDA		;continue testing

; Personal ident testing
	$STATE		prsid
	$TRAN		!_isprsident,,isprsid	;check for personal IDENT
	$TRAN		TPA$_LAMBDA		;continue testing

; Logical testing
	$STATE		tstlog
	$TRAN		!_islogical,setddir,islog	;check for logical
	$TRAN		TPA$_LAMBDA			;continue testing

; String repair for all UNIX/MSDOS translations to VMS
	$STATE		repair			;null state for reset & label
	$TRAN		TPA$_LAMBDA,,do_op,,,OP_C_RST

	$STATE		getdev			;extract device if present
	$TRAN		':',,do_op,,,OP_C_DEV	;found one!  Go do chop suey!
	$TRAN		TPA$_EOS,,do_op,,,OP_C_RST	;all done
	$TRAN		TPA$_ANY,getdev		;do all chars

	$STATE					;force '\' to work right
	$TRAN		!_isbsl,adjroot,do_op,,,OP_C_RST
	$TRAN		TPA$_LAMBDA,adjroot

	$STATE		forcerbreos		;force correct [] syntax
	$TRAN		']'
	$TRAN		TPA$_EOS,TPA$_EXIT,,SS$_BADPARAM,retsts
	$TRAN		TPA$_ANY,forcerbreos
	$STATE
	$TRAN		TPA$_EOS,ddscan,do_op,,,OP_C_RST
	$TRAN		TPA$_LAMBDA,TPA$_EXIT,,SS$_BADPARAM,retsts

	$STATE		adjroot			;adjust rooting chars
	$TRAN		'[',forcerbreos		;brackets exist... fix rest
	$TRAN		'\',adjroot,do_op,,,OP_C_BRO	;force brackets in
	$TRAN		'.',,do_op,,,OP_C_BRI	;ok for '..' and '.' first
	$TRAN		'-',,do_op,,,OP_C_BRI		;ok for '-'
	$TRAN		TPA$_EOS,,do_op,,,OP_C_BRI	;ok for <eos>
	$TRAN		TPA$_LAMBDA,,do_op,,,OP_C_BDI	;force '[.'...']'

	$STATE		ddscan			;change all '..' to '-'
	$TRAN		!_isa_dd,ddscan		;fixes '..'
	$TRAN		TPA$_EOS,,do_op,,,OP_C_RST
	$TRAN		TPA$_ANY,ddscan

	$STATE		bsscan
	$TRAN		'\',bsscan,do_op,,,OP_C_DOT	;fixes '\' to '.'
	$TRAN		TPA$_EOS,,do_op,,,OP_C_RST
	$TRAN		TPA$_ANY,bsscan

; ***!! Note: device name has been removed here...
; Personal device parsing & recombine
	$STATE		prsdev
	$TRAN		!_isprsdev		;check for personal device
	$TRAN		TPA$_LAMBDA		;continue testing

; Actual setddir attempt
	$STATE		setddir
	$TRAN		TPA$_LAMBDA,TPA$_EXIT,,SS$_CREATED,retsts

;++
; Begin callable states
;--
; Try to get a switch value
	$STATE		_isswitch
	$TRAN		TPA$_BLANK,_isswitch
	$TRAN		'/'
	$TRAN		TPA$_LAMBDA,TPA$_FAIL
	$STATE
	$TRAN		'COM',swcom
	$TRAN		'FULL',swful
	$TRAN		'LOG',swlog
	$TRAN		'VERIFY_ONLY',swver
	$STATE		swcom
	$TRAN		TPA$_BLANK,TPA$_EXIT,do_op,SW_M_COM,switches,OP_C_BCK
	$TRAN		'/',TPA$_EXIT,do_op,SW_M_COM,switches,OP_C_BCK
	$TRAN		TPA$_EOS,TPA$_EXIT,,SW_M_COM,switches
	$STATE		swful
	$TRAN		TPA$_BLANK,TPA$_EXIT,do_op,SW_M_FUL!SW_M_LOG,switches,OP_C_BCK
	$TRAN		'/',TPA$_EXIT,do_op,SW_M_FUL!SW_M_LOG,switches,OP_C_BCK
	$TRAN		TPA$_EOS,TPA$_EXIT,,SW_M_FUL!SW_M_LOG,switches
	$STATE		swlog
	$TRAN		TPA$_BLANK,TPA$_EXIT,do_op,SW_M_LOG,switches,OP_C_BCK
	$TRAN		'/',TPA$_EXIT,do_op,SW_M_LOG,switches,OP_C_BCK
	$TRAN		TPA$_EOS,TPA$_EXIT,,SW_M_LOG,switches
	$STATE		swver
	$TRAN		TPA$_BLANK,TPA$_EXIT,do_op,SW_M_VER,switches,OP_C_BCK
	$TRAN		'/',TPA$_EXIT,do_op,SW_M_VER,switches,OP_C_BCK
	$TRAN		TPA$_EOS,TPA$_EXIT,,SW_M_VER,switches

; Consume spaces at current token
	$STATE		_rmvsp
	$TRAN		TPA$_BLANK
	$TRAN		TPA$_LAMBDA,TPA$_FAIL
	$STATE		_rmvsp0
	$TRAN		TPA$_BLANK,_rmvsp0
	$TRAN		TPA$_LAMBDA,TPA$_EXIT

; Checking and repair of '..' to '-'
	$STATE		_isa_dd
	$TRAN		'.'
	$STATE
	$TRAN		'.',TPA$_EXIT,do_op,,,OP_C_DD

; Personal device checking
	$STATE		_isprsdev		;check for personal devices
	$TRAN		TPA$_ANY,TPA$_EXIT,isprsdev

; Personal ident format enforcement
	$STATE		_isprsident		;check for personal IDENTs
	$TRAN		TPA$_SYMBOL
	$STATE
	$TRAN		TPA$_EOS,TPA$_EXIT

; Logical name checking
	$STATE		_islogical		;check for LNM equiv
	$TRAN		TPA$_ANY,_islogical
	$TRAN		TPA$_EOS,TPA$_EXIT

; Special character checking...
	$STATE		_iseos		;check for '<eos>'
	$TRAN		TPA$_EOS,TPA$_EXIT

	$STATE		_isdot		;check for '.<eos>'
	$TRAN		'.'		;required for success
	$STATE				;now require EOS
	$TRAN		TPA$_EOS,TPA$_EXIT

	$STATE		_ispnd		;check for '#<eos>'
	$TRAN		'#'		;required for success
	$STATE				;now require EOS
	$TRAN		TPA$_EOS,TPA$_EXIT

	$STATE		_isque		;check for '?<eos>'
	$TRAN		'?'		;required for success
	$STATE				;now require EOS
	$TRAN		TPA$_EOS,TPA$_EXIT

	$STATE		_isdol		;check for '$<eos>'
	$TRAN		'$'		;required for success
	$STATE				;now require EOS
	$TRAN		'0'		;allowable constant for dirchange
	$TRAN		'1'		;allowable constant for dirchange
	$TRAN		'2'		;allowable constant for dirchange
	$TRAN		'3'		;allowable constant for dirchange
	$TRAN		'4'		;allowable constant for dirchange
	$TRAN		'5'		;allowable constant for dirchange
	$TRAN		'6'		;allowable constant for dirchange
	$TRAN		'7'		;allowable constant for dirchange
	$TRAN		'8'		;allowable constant for dirchange
	$TRAN		'9'		;allowable constant for dirchange
	$TRAN		'*'		;do select operation
	$TRAN		TPA$_EOS,TPA$_EXIT,do_op,,,OP_C_DOL
	$STATE				;now require EOS
	$TRAN		TPA$_EOS,TPA$_EXIT,do_op,,,OP_C_DOL

	$STATE		_isbsl		;check for '\<eos>'
	$TRAN		'\'		;required for success
	$STATE				;now require EOS
	$TRAN		TPA$_EOS,TPA$_EXIT,do_op,,,OP_C_BSL

	$END_STATE
;----------------------END STATE TABLE------------------------------------------

;++
; TPA Parse table for chopping up 'dirtxt'
;--

	$INIT_STATE	sttbl1,kytbl1

; Ancillary parse state ... chop 'dirtxt' to pieces
	$STATE		chop
	$TRAN		TPA$_EOS,TPA$_EXIT
	$TRAN		'['
	$TRAN		']',TPA$_EXIT
	$TRAN		TPA$_LAMBDA

	$STATE		diritm1
	$TRAN		TPA$_EOS,TPA$_EXIT
	$TRAN		']',TPA$_EXIT
	$TRAN		'-',diritm1	;remove leading '-'
	$TRAN		'.'		;remove leading '.'
	$TRAN		TPA$_LAMBDA

	$STATE		diritm2
	$TRAN		TPA$_EOS,TPA$_EXIT
	$TRAN		']',TPA$_EXIT
	$TRAN		!_up,diritm2	;remove '.-'
	$TRAN		!_dirid,diritm2,adddir
	$TRAN		TPA$_LAMBDA,TPA$_EXIT

	$STATE		_up
	$TRAN		'.'
	$TRAN		'-',TPA$_EXIT
	$STATE
	$TRAN		'-',TPA$_EXIT

	$STATE		_dirid
	$TRAN		'.'
	$TRAN		TPA$_LAMBDA
	$STATE
	$TRAN		TPA$_STRING
	$TRAN		'*'
	$TRAN		'%'
	$TRAN		'-'
	$TRAN		'_'
	$TRAN		'$'
	$STATE		_dirid2
	$TRAN		TPA$_STRING,_dirid2
	$TRAN		'*',_dirid2
	$TRAN		'%',_dirid2
	$TRAN		'-',_dirid2
	$TRAN		'_',_dirid2
	$TRAN		'$',_dirid2
	$TRAN		']',TPA$_EXIT,do_op,,,OP_C_BCK
	$TRAN		'.',TPA$_EXIT,do_op,,,OP_C_BCK

	$END_STATE
;----------------------END STATE TABLE------------------------------------------

	.psect	$local
;++
; *** Local data storage, macros, etc.
;--
;---------------------END MACRO DEFINITIONS-------------------------------------

argb0:	.blkb	TPA$K_LENGTH0	;space for argblk
argb1:	.blkb	TPA$K_LENGTH0	;space for argblk

protofab:	$fab		;FAB prototype for re-init
tmpfab:		$fab		;for 'parse' operations
FABSIZ = tmpfab-protofab

protonam:	$nam		;NAM prototype for re-init
tmpnam:		$nam		;for 'parse' operations
NAMSIZ = tmpnam-protonam
 assume NAM$C_MAXRSS LE 256
rssstr:	.blkb	256
essstr:	.blkb	256

; Tranlation buffers --- NOTE: LENGTHS MUST BE EQUIVALENT!!
; Primary translation buffer (Holds cmd string segment being parsed/executed)
	.long		80
buffer:	.long		80
	.address	.+4
	.blkb		80

; Secondary translation buffer (Holds first command string)
	.long		80
cmdbuf:	.long		80
	.address	.+4
	.blkb		80

; Temporary storage places for LNM xlat, etc.
; Note: Lengths must be minimum size of buffer/cmdbuf
	.long		80
tmp1:	.long		80
	.address	.+4
	.blkb		80
	.long		80
tmp2:	.long		80
	.address	.+4
	.blkb		80

; Used to hold a 'device' name
	.long		32
devnam:	.long		0
	.address	.+4
	.blkb		32

; Blank descriptors for various uses
dsc0:	.quad
dsc1:	.quad

; Used to hold directory names & flag values
curdf0:	.long		0
	.long		80
curd0:	.long		80
	.address	.+4
	.blkb		80
curdf1:	.long		0
	.long		80
curd1:	.long		80
	.address	.+4
	.blkb		80
prevf:	.long		0
	.long		80
prev:	.long		80
	.address	.+4
	.blkb		80

; return buffer block
bufblk:	.long		11		;CALLx AP format list
	.address	buffer,retsts
	.address	curd0,curdf0
	.address	curd1,curdf1
	.address	prev,prevf
	.address	vector,switches
	.address	cmdbuf
vector:	.blkl		16

; Array of descriptors into 'dirtxt', and a counter into the array
SEGMAX = 16
segcnt:	.long
segarr:	.blkq		SEGMAX
seglst:			;build $FAOL list of arguments
  $$$tmp = 0
  .rept	SEGMAX
	.address	segarr+$$$tmp
  $$$tmp = $$$tmp+8
  .endr

retsts:		.long
switches:	.long
lflags:		.long
trnatt:	.long		LNM$M_CASE_BLIND
attrib:	.long
lnmlst:	.long		<LNM$_STRING@16>!80
	.address	tmp2+8,tmp2
	.long		<LNM$_ATTRIBUTES@16>!4
	.address	attrib
	.long		0,0
gbltab:	.long	2

syscom_chn:	.long	0
syscom_crpen:	.long	0
trmlst:	.long	32
	.address	.+4
	.long	-1,-1,-1,-1,-1,-1,-1,-1

;
;  Begin byte-aligned data area
;
syscom:	.ascid	/SYS$COMMAND/
fildev:	.ascid	/LNM$FILE_DEV/
cdidn:	.ascid	/CDI_/
cdfmt:	.ascid	/CDF_/
root:	.ascid	/[000000]/
nulstr:	.ascid	//
sysdsk:	.ascid	/SYS$DISK/
prvdir:	.ascid	/LAST_DEFAULT_DIRECTORY/
stkdir:	.ascid	/CD$!UL/		;CD$0...CD$9
unavl:	.ascid	/Requested information unavailable/
notdef:	.ascid	/not defined/
help:	.address	-
		help1,help2,help3,help4
	.long	0
pressakey:	.ascid	<^x0a><^x0d>/Press a key to continue.../
help1:	.ascid	-
<^x1b>|[H|<^x1b>|[2JCD V4.7D ©1991, D_North, CCP!/|-
|  CD			- give current dir!/|-
|  CD ?			- give brief help guide!/|-
|  CD #			- give previous dir!/|-
|  CD $			- change to prev dir!/|-
|  CD dirname		- change to subdir named!/|-
|  CD \dirname		- change to default device, dir named!/|-
|  CD dev:\dirname	- change to named device, dir named!/|-
|  CD ..			- move up one dir level!/|-
|  CD ..\dirname		- move to adjacent dirname!/|-
|  CD logical_w_dir[:]	- move to spec'd directory!/|-
|  CD .dirname		- change to subdir named!/|-
|  CD dev:		- change to new dev same dir, not useful!/|-
|  CD IDN		- move to 'CDI_IDN' contents!/|-
|  CD FM$:[txt[.txt..]]	- move to 'CDF_FM$' contents $FAO formatted w/txt!/|-
|  Switches: (must be specified *BEFORE* pathname!!)!/|-
|	/LOG			- log changes in directory!/|-
|	/VERIFY			- verify target dir... don't set def!/|-
|	/COM			- Execute CD.COM in target dir if present!/|-
|	/FULL			- verbose messages|
help2:	.ascid	-
<^x1b>|[H|<^x1b>|[2JCD V4.7D ©1991, D_North, CCP!/|-
|  CD path1 path2	- Goto 'path1' then 'path2' from there!/|-
|			  Note: special operations like '#', '?' cannot be!/|-
|			        mixed in with this type operation!/|-
|  CD $n			- Goto previous directory #n!/|-
|  CD $*			- List all known previous directories & select one!/|-
|  CD *			- Goto a wildcard subdirectory!/|-
|  CD P *		- Goto Personal Ident P, then to wildcard subdirectory!/|-
|!/|-
|  Logicals:!/|-
|	CD$n			- n = {0..9} list of most recently used!/|-
|				  previous directories... note: this is *not*!/|-
|				  necessarily in a readily predictable order!/|-
|	LAST_DEFAULT_DIRECTORY	- Previous directory name!/|-
|			Note: LAST_DEFAULT_DIRECTORY and CD$n are maintained!/|-
|			      separately, but since LAST_DEFAULT_DIRECTORY is!/|-
|			      an exact copy of CD$0, it may go away in a future!/|-
|			      release of the CD program.!/|-
|!/|-
|  Installation:!/|-
|	$ CD == "$DEV:[DIR1.DIR2]CD"   !!Add switches if desired!/|

help3:	.ascid	-
<^x1b>|[H|<^x1b>|[2JCD V4.7D ©1991, D_North, CCP!/|-
|!/|-
|  Notes on using the CD utility:!/|-
|	* Full wildcarding has been added to this version of the CD program.!/|-
|	    o Note that specifying multiple levels of wildcards works ok,!/|-
|	      but the lowest wildcarded level should exist, or you will!/|-
|	      get a 'Directory does not exist' message.!/|-
|	    o Valid wildcard characters are '%' and '*'... use of the '...'!/|-
|	      has no meaning in this context.!/|-
|	* Conflicts between program functions and valid directory names!/|-
|	    o Personal device names override physical device names. Period.!/|-
|	    o If you have an ident/logical conflict, use ':' for forcing!/|-
|	      logical usage.!/|-
|	    o If you have a logical/subdirname conflict, use the '.name'!/|-
|	      to force subdirname usage instead of logical translation!/|-
|	* Personal device formatting example:!/|-
|	    o Parameters for the format string are parsed off 1 at a time,!/|-
|	      format "p1", ".p2"... ".p16".  Note that missing "pn" is blank!/|-
|	    o CDF_ZZ$ == "DVL$ROO:[I_USER.!!AS.WRK!!15(AS)]"!/|-
|	      $ CD/LOG ZZ$:tst.fred!/|-
|	      -CD-I-PRVIS, Previous directory is ZC1:[A.B]!/|-
|	      -CD-I-CURIS, Current directory is DVL$ROO:[I_USER.TST.WRK.FRED]!/|
help4:	.ascid	-
<^x1b>|[H|<^x1b>|[2JCD V4.7D ©1991, D_North, CCP!/|-
|!/|-
|  In case you experience bugs or strange behavior of the CD program:!/|-
|	Please write & mail a report including the following information:!/|-
|	  A detailed description of the bug!/|-
|	  What conditions (switches, parameters) cause[d] the bug!/|-
|	  Whether or not the bug is reproducible!/|-
|	  The exact pathname of your original directory!/|-
|	  Whether or not the original directory existed!/|-
|	  Whether or not you had read access to the original directory!/|-
|	  The exact pathname[s] of the target directory[ies]!/|-
|	  Whether or not the target directory[ies] existed!/|-
|	  Whether or not you had read access to the target directory[ies]!/|-
|	  Your final default directory after the bug!/|-
|  Please also feel free to submit suggestions as to how this program!/|-
|  could be made better or more useful.!/|-
|!/|-
|  Thank you.!/|-
|  David G. North, CCP, 91.11.13!/|-
|  1333 Maywood Court!/|-
|  Plano, Texas  75023-1914|

	.psect	$code
;++
;  Begin main CODE section
;--
;+
; TPARSE action routines
;-
; Perform an operation by operation number
.entry	do_op,^m<r2,r3,r4,r5>
	movzbl	TPA$L_PARAM(AP),r2		;only low byte is used
	case	r2,-
		<op_bsl,op_rst,op_dol,op_dd,op_dev,op_bri,op_bro,op_bdi,-
		 op_dot,op_del,op_rmv,op_bck>,base=#1
	$exit_s	-
		code	=	#SS$_BUGCHECK
op_bsl:	;'\<eos>'
	movc3	root,@root+4,@buffer+4
	movw	root,buffer			;copy '[000000]' into place
op_rst:	;reset operation
	movzwl	buffer,TPA$L_STRINGCNT(AP)	;and reset parser
	movab	@buffer+4,TPA$L_STRINGPTR(AP)
	movzbl	#SS$_NORMAL,r0
	ret
op_dol:	;'$[n]<eos>'
	movab	@TPA$L_STRINGPTR(AP),r3		;point to <eos>
	decl	r3				;backup 1 char
	clrl	r2				;use translation 0 for now
	cmpb	(r3),#^a/$/			;is it the "$" character?
	beql	10$				;go do it
	xorb3	(r3),#^a/0/,r2			;change decimal digit to BIN
	bsbw	dol_set_prv			;go try to get translation
10$:	clrw	buffer				;blast to 'no prev dir' state
	movab	buffer+8,buffer+4		;reset pointers
	blbc	prevf,20$			;no previous dir found ok
	movzwl	prev,buffer
	movc3	prev,@prev+4,@buffer+4		;copy prev dir as target
20$:	brw	op_rst				;reset the parser
op_dd:	;'..'  --> '-'
	movl	TPA$L_STRINGCNT(AP),r1		;get sizeof remaining string
	movab	@TPA$L_STRINGPTR(AP),r3		;point to 'after ..'
	movab	-2(r3),r2			;point to 'before ..'
	movb	#^a/-/,(r2)+			;change to '-.'
	movab	(r2),TPA$L_STRINGPTR(AP)	;reset parser to relocated str
	movc3	r1,(r3),(r2)			;slide string back a char
	decw	buffer				;note the deduction
	movzbl	#SS$_NORMAL,r0
	ret
op_dev:	;Used to remove chunk of buffer & insert to devnam
	;state is:	current token = ':'
	;		current string is all past ':'
	movzwl	buffer,r0			;get total length
	movl	TPA$L_STRINGCNT(AP),r1		;get sizeof remaining string
	subl3	r1,r0,r2			;sizeof 'dev:'
	subl	r2,buffer			;remove it from the buffer size
	decl	r2				;sizeof 'dev'
	movw	r2,devnam			;set devnam descriptor up
	movc3	r2,@buffer+4,@devnam+4		;copy device name
	movl	TPA$L_STRINGCNT(AP),r1		;get sizeof remaining string
	movab	@TPA$L_STRINGPTR(AP),r3		;point to 'after :'
	movab	@buffer+4,r2			;point to start of buffer
	movc3	r1,(r3),(r2)			;slide string back -dev
	brw	op_rst				;reset the parser
op_bdi:	;insert '[.'...']' to buffer
	movab	@buffer+4,r2
	movc3	buffer,(r2),1(r2)		;scoot in 1 char
	incw	buffer				;add it in to the buffer cnt
	movb	#^a/./,@buffer+4		;insert leading '.'
op_bri:	;Insert '['...']' to buffer
	movab	@buffer+4,r2
	movc3	buffer,(r2),1(r2)		;scoot in 1 char
	incw	buffer				;add it in to the buffer cnt
op_bro:	;Overwrite '['... insert ']' to buffer
	movzwl	buffer,r3			;get current buffersize
	addl3	#1,r3,buffer			;add in future ']'
	movab	@buffer+4,r2			;get first char
	movb	#^a/[/,(r2)			;overwrite '[' into buffer
	movb	#^a/]/,(r2)[r3]			;insert ']' into buffer
	brw	op_rst				;reset the parser
op_dot:	;change char to '.'
	movl	TPA$L_STRINGCNT(AP),r1		;get sizeof remaining string
	movab	@TPA$L_STRINGPTR(AP),r3		;point to 'after char'
	movab	-1(r3),r2			;point to 'before char'
	movb	#^a/./,(r2)+			;change to '-.'
	movab	(r2),TPA$L_STRINGPTR(AP)	;reset parser to 'fixed' str
	movzbl	#SS$_NORMAL,r0
	ret
op_del:	;delete matched char
	movl	TPA$L_STRINGCNT(AP),r1		;get sizeof remaining string
	movab	@TPA$L_STRINGPTR(AP),r3		;point to 'after char'
	movab	-1(r3),r2			;point to 'at char'
	movab	(r2),TPA$L_STRINGPTR(AP)	;reset parser to relocated str
	movc3	r1,(r3),(r2)			;slide string back a char
	decw	buffer				;note the deduction
	movzbl	#SS$_NORMAL,r0
	ret
op_rmv:	;delete to BOL
	movl	TPA$L_STRINGCNT(AP),r1		;get sizeof remaining string
	movab	@TPA$L_STRINGPTR(AP),r3		;point to 'rest_of_line'
	movab	@buffer+4,r2			;point to new 'start_of_line'
	subl3	r2,r3,r4			;get sizeof removal
	beql	10$				;no move needed
	movab	(r2),TPA$L_STRINGPTR(AP)	;reset parser to relocated str
	pushl	r4				;save sizeof removal
	movc3	r1,(r3),(r2)			;slide string back a char
	popl	r4				;recover sizeof removal
	subw	r4,buffer			;note the deduction
10$:	movzbl	#SS$_NORMAL,r0
	ret
op_bck:	;back the parser up one char (known to exist)
	incl	TPA$L_STRINGCNT(AP)		;note additional char
	decl	TPA$L_STRINGPTR(AP)		;backup one char
	movzbl	#SS$_NORMAL,r0
	ret

; Test for personal device
.entry	isprsdev,^m<r2,r3,r4,r5>
	tstw	devnam
	bneq	10$				;there is one...
	clrl	r0				;fail this state
	ret
10$:	movzwl	cdfmt,tmp1
	movc3	cdfmt,@cdfmt+4,@tmp1+4
	movq	tmp1,r2
	movzwl	r2,r2
	movc3	devnam,@devnam+4,(r3)[r2]
	addl	devnam,tmp1

	movl	tmp2-4,tmp2		;force max length
	pushl	gbltab
	pushaw	tmp2
	pushaq	tmp2
	pushaq	tmp1
	calls	#3,g^LIB$GET_SYMBOL	;try to get an equivalence
	blbs	r0,20$
	brw	copy_device
20$:	;got a translation (tmp2).... now $FAO it!
	movc3	buffer,@buffer+4,@tmp1+4
	movzwl	buffer,tmp1		;copy user data to tmp1
 ;---here: chop tmp1 into pieces & format it with tmp2

; local init
	clrl	segcnt		;no segments present yet
	clrl	r0		;counter
	movaq	segarr,r1
30$:	movq	nulstr,(r1)[r0]	;preset to be 'null' string
	aoblss	#SEGMAX,r0,30$	;waste the descriptor array

; TPA init
	movc5	#0,#0,#0,#TPA$K_LENGTH0,argb1
	moval	argb1,r2
	movl	#TPA$K_COUNT0,TPA$L_COUNT(r2)
	movzwl	tmp1,TPA$L_STRINGCNT(r2)
	movab	@tmp1+4,TPA$L_STRINGPTR(r2)

; call TPA again to chop up the user data string
	pushab	kytbl1
	pushab	sttbl1
	pushal	argb1
	calls	#3,G^LIB$TPARSE		;result is irrelevant

	movl	buffer-1,buffer		;restore max buflen
	$FAOL_S	-
		ctrstr	=	tmp2,-
		outlen	=	buffer,-
		outbuf	=	buffer,-
		prmlst	=	seglst
	blbc	r0,40$			;oops!
	brw	op_rst			;reset parser & fly w/result
40$:	brw	copy_device		;try to do it w/o formatting

.entry	adddir,	^m<r2,r3,r4,r5>
	movl	segcnt,r0	
	cmpl	segcnt,#SEGMAX
	blssu	20$
10$:	movzwl	#SS$_NORMAL,r0
	ret
20$:	movaq	segarr,r1
	movaq	(r1)[r0],r2
	movq	TPA$L_TOKENCNT(AP),(r2)
	incl	segcnt
	brb	10$

copy_device:
	movzwl	devnam,r0			;length of device name
	movzwl	buffer,r1			;current length of dirtxt
	incl	r0
	addl3	r0,r1,buffer			;build new length
	movab	@buffer+4,r2			;source address
	movab	(r2)[r0],r3			;target address
	pushl	r0
	pushl	r2
	movc3	r1,(r2),(r3)			;move dirtxt
	movl	(SP),r2				;recover r2
	movl	4(SP),r0			;recover r0
	movc3	r0,@devnam+4,(r2)		;move devtxt
	popl	r2
	subl3	#1,(SP)+,r0			;recover len-1 of devnam
	movb	#^a/:/,(r2)[r0]			;re-insert ':'
	brw	op_rst				;reset parser

; Test for personal ident
.entry	isprsid,^m<r2,r3,r4,r5>
	movzwl	cdidn,tmp1
	movc3	cdidn,@cdidn+4,@tmp1+4
	movq	tmp1,r2
	movzwl	r2,r2
	movc3	TPA$L_TOKENCNT(AP),@TPA$L_TOKENPTR(AP),(r3)[r2]
	addl	TPA$L_TOKENCNT(AP),tmp1

	movl	tmp2-4,tmp2		;force max length
	pushl	gbltab
	pushaw	tmp2
	pushaq	tmp2
	pushaq	tmp1
	calls	#3,g^LIB$GET_SYMBOL	;try to get an equivalence
	blbs	r0,10$
	ret
10$:	;got a translation.... now copy it!
	movc3	tmp2,@tmp2+4,@buffer+4
	movzwl	tmp2,buffer
	brw	op_rst

; Test for LNM equivalence
.entry	islog,^m<r2,r3,r4,r5>
	pushaq	tmp2				;place to dump translation
	pushaq	TPA$L_TOKENCNT(AP)		;lnm to look for
	calls	#2,w^get_lnm			;try to translate it
	blbs	r0,10$
	ret
; copy translation
10$:	movc3	tmp2,@tmp2+4,@buffer+4
	movzwl	tmp2,buffer
	brw	op_rst				;reset parser

; Translate a logical name & block out any 'funny' logicals
.entry	get_lnm,	^m<r2,r3,r4,r5>		;(lnmdsc_addr,target_idsc_addr)
	movq	4(AP),r2			;get args 1&2
	movzwl	-4(r3),(r3)			;restore target idsc
	movw	(r3),lnmlst			;set buffersize in list
	movab	@4(r3),lnmlst+4			;set target address
	movaw	(r3),lnmlst+8			;set return length address
	movab	@4(r2),r4			;address of source buffer
	movzwl	(r2),r0				;len of source buffer
	decl	r0				;backup to last char
	beql	10$				;can't be simple ':'
	cmpb	(r4)[r0],#^a/:/			;is last char a ':'?
	bneq	10$				;no... use as is
	clrq	-(SP)				;must make a bogus descrip
	movaq	(SP),r2				;point at new descrip
	movw	r0,(SP)				;set new length
	movab	(r4),4(SP)			;new descrip -':'
10$:	$trnlnm_s	-
		attr	=	trnatt,-
		tabnam	=	fildev,-
		lognam	=	(r2),-
		itmlst	=	lnmlst		;try to translate dflt device
	blbs	r0,30$
20$:	ret
30$:	movzwl	#SS$_NOLOGNAM,r0
	bbs	#LNM$V_TABLE,attrib,20$
	bbs	#LNM$V_CONCEALED,attrib,20$
	bbs	#LNM$V_TERMINAL,attrib,20$	;all bogus types booted out
	movzbl	#SS$_NORMAL,r0
	ret

; Directory retrieval stuff
.entry	get_current_directory,	^m<r2,r3,r4,r5>	;(target_idsc_addr)
	pushaq	tmp2		;target fo logical translation
	pushaw	sysdsk		;logical to grab
	calls	#2,w^get_lnm	;get translation
	blbs	r0,30$		;got something ok
10$:	movaq	unavl,r1	;source for data copy
20$:	pushl	r0		;save return code
	movaq	@4(AP),r2
	cmpl	r1,r2		;see if we really need to move the data
	beql	25$
	movq	r1,-(SP)	;save source & dest addrs
	movc3	(r1),@4(r1),@4(r2)	;copy results to target
	movq	(SP)+,r1	;restore source & dest addrs
	movzwl	(r1),(r2)	;copy length too
25$:	popl	r0		;recover return code
	ret
; tmp2 now filled with SYS$DISK translation
30$:	movzwl	tmp1-4,tmp1	;restore descriptor
	pushaq	tmp1
	pushaw	tmp1
	clrl	-(SP)
	calls	#3,g^SYS$SETDDIR		;get dirtxt
	blbs	r0,40$
	brw	10$				;set noavail
40$:	;append dirtxt to drive in tmp2
	movq	tmp2,r0				;point to text
	movzwl	r0,r0
	movc3	tmp1,@tmp1+4,(r1)[r0]
	addw3	tmp1,tmp2,r0
	movzwl	r0,tmp2				;set total length
	movzbl	#SS$_NORMAL,r0
	movaq	tmp2,r1				;point to text
	brw	20$				;copy & ret ok

; Parser setup & call only... LIB$TPARSE calls all action routines
.entry	CD_PARSE,	^m<r2,r3,r4,r5,r6,r7,r8,r9,r10,r11>
	cmpb	(AP),#3
	beql	10$
	movl	#LIB$_WRONUMARG,r0
	ret

10$:	tstl	8(AP)
	beql	20$
	clrl	@8(AP)			;make bufblk pointer unavailable
20$:
	movaq	@4(AP),r6
	movc3	(r6),@4(r6),@cmdbuf+4
	movzwl	(r6),cmdbuf		;make local copy of data

; Force buffer uppercase & remove all extraneous spaces
	bsbw	fix_cmdbuf
	blbs	r0,30$
	ret

; local init
30$:
	tstl	8(AP)
	beql	40$
	moval	bufblk,@8(AP)		;point user to return parameter block
40$:
	pushaq	prev			;target idsc
	pushaq	prvdir			;previous directory name
	calls	#2,w^get_lnm		;try to translate it
	movl	r0,prevf		;stuff the flags w/result code

	pushaq	curd0			;try to get current directory
	calls	#1,w^get_current_directory
	movl	r0,curdf0		;stuff flags w/result code
	blbs	r0,60$			;all is OK... keep trying
50$:	movl	#SS$_BADIRECTORY,retsts	;set bad dir code
	brw	do_stsid		;blast us outta the water
60$:	bsbw	dir_reset		;make sure we can reset the dir ok
	blbc	r0,50$			;blow up if we can't set to cur dir

	clrl	switches		;switches cleared here & preserved later
	clrl	lflags			;loop flags are cleared now

; Now we begin a processing loop to separate the buffer by 'blank' delimiters
; and sequentially re-call the parser to allow relative jumping for each
; space-delimited element in the command line... note the possibility that
; the switches can now appear at almost any location... we will test for the
; result code that shows switches only (SS$_WASCLR) and we will abort command
; processing if this does not occur in the corerct place.  This method also
; allows a pathological command sequence like CD # $ to occur... we will check
; for illegal terminal characters also & abort processing if such occur.

FL_V_ONE == 0		;At least once thru CD parse routines
FL_M_ONE == <1@FL_V_ONE>
FL_V_EOP == 1		;Next time *MUST* be End of OPeration
FL_M_EOP == <1@FL_V_EOP>
FL_V_VER == 2		;Verify set a directory... need to fix
FL_M_VER == <1@FL_V_VER>
FL_V_IEX == 3		;Immediate EXit requested
FL_M_IEX == <1@FL_V_IEX>
FL_V_SWS == 4		;SWitches Set ... if seen twice or not first, blow up
FL_M_SWS == <1@FL_V_SWS>
FL_V_SW1 == 5		;1-SWitcheSet operation... used w/NFT to allow switching
FL_M_SW1 == <1@FL_V_SW1>
FL_V_NFT == 6		;Not First Time ... used for SWS checking
FL_M_NFT == <1@FL_V_NFT>

; !! Loop re-entry point
70$:	bsbw	get_chunk		;get a chunk of CMDBUF to BUFFER
	bbcs	#FL_V_ONE,lflags,100$	;go thru at least once!
	bbs	#FL_V_IEX,lflags,80$	;if immediate exit... then go do it!
	tstl	r0			;is this EOS?
	bneq	90$			;nope... go try another operation
80$:	brw	do_stsid		;Go do stsid operation & leave

90$:	bbc	#FL_V_EOP,lflags,100$	;Jmp if non-EOS is ok
	movl	#SS$_BADPARAM,retsts	;set syntax error
	brw	do_stsid		;Go do stsid operation & leave

100$:	clrl	devnam			;no device seen yet!
	clrl	retsts
	clrl	curdf1
	clrl	vector

; TPA init
	movc5	#0,#0,#0,#TPA$K_LENGTH0,argb0
	moval	argb0,r2
	movb	#1,TPA$B_MCOUNT(r2)
	movl	#TPA$K_COUNT0,TPA$L_COUNT(r2)
	movzwl	buffer,TPA$L_STRINGCNT(r2)
	movab	@buffer+4,TPA$L_STRINGPTR(r2)
	bisl	#<1@TPA$V_BLANKS>,TPA$L_OPTIONS(r2)

; call TPA
	pushab	kytbl0
	pushab	sttbl0
	pushal	argb0
	calls	#3,G^LIB$TPARSE
	blbs	r0,110$
	ret					;simply return bombcode
110$:	;dispatch on result codes & do local op for code
	cmpl	retsts,#SS$_NOSUCHDEV	;Op failure... not used here (BUG)
	beql	120$
	cmpl	retsts,#SS$_WASCLR	;empty cmdlin (CD) NOOP ... switches set
	beql	130$
	cmpl	retsts,#SS$_WASSET	;pound sign (CD #) EOP/mb~NFT (SWS ok)
	beql	150$
	cmpl	retsts,#SS$_RESIGNAL	;Help operation EOP/mb~NFT (SWS ok)
	beql	150$
	cmpl	retsts,#SS$_BADPARAM	;syntax... EOP
	beql	160$
	cmpl	retsts,#SS$_OPINCOMPL	;nochange (CD .)  NOOP / return if EOS
	beql	170$
	cmpl	retsts,#SS$_CREATED	;new dir parsed (temp set new dir/ver)
	beql	180$			;do a temporary set def
120$:	movl	#SS$_BUGCHECK,retsts
	bisl	#FL_M_IEX!FL_M_VER,lflags	;blow off w/syntax
	brw	70$
130$:	bbss	#FL_V_SWS,lflags,140$	;not ok twice
	bisl	#FL_M_SW1,lflags	;set 1-check for switches flag
	bbc	#FL_V_NFT,lflags,170$	;ok if first time thru
140$:	movl	#SS$_BADPARAM,retsts
	bisl	#FL_M_IEX!FL_M_VER,lflags ;blow off w/syntax
	brb	170$			;go blow
150$:	bbsc	#FL_V_SW1,lflags,160$	;allow 1-switch to be ok even for NFT
	bbs	#FL_V_NFT,lflags,140$	;Whoops! Must be a first time operation
160$:	bisl	#FL_M_EOP,lflags	;set required End of OPeration
170$:	bisl	#FL_M_NFT,lflags	;it is Not First Time thru anymore
	brw	70$			;go back for more chunks
180$:	tstw	buffer			;see if we said to go anywhere
	bneq	190$
	movl	#SS$_NOSUCHDEV,retsts
	bisl	#FL_M_IEX!FL_M_VER,lflags	;mark 'immediate exit' flag
	brb	170$			;get lost & dispatch retsts
190$:	movaq	buffer,r8		;setdef source address
	movab	tmpfab,r9		;point to fab for operations
	movc3	#FABSIZ,protofab,(r9)	;copy proto fab
	movab	tmpnam,r10		;point to nam for operations
	movc3	#NAMSIZ,protonam,(r10)	;copy proto nam

	bisl	#FAB$M_NAM,FAB$L_FOP(r9)
	movab	(r10),FAB$L_NAM(r9)
	movab	@4(r8),FAB$L_FNA(r9)
	movb	(r8),FAB$B_FNS(r9)

	movb	#NAM$C_MAXRSS,NAM$B_RSS(r10)
	movab	rssstr,NAM$L_RSA(r10)
	movb	#NAM$C_MAXRSS,NAM$B_ESS(r10)
	movab	essstr,NAM$L_ESA(r10)

	$parse	fab=(r9)		;parse the sucker!
	blbs	r0,200$
195$:	movl	#SS$_NOSUCHDEV,retsts
	bisl	#FL_M_IEX!FL_M_VER,lflags	;mark 'immediate exit' flag
	brw	170$			;get lost & dispatch retsts

200$:	movaq	dsc0,r6		;device descriptor address
	movaq	dsc1,r7		;dirtxt descriptor address
	movzbl	NAM$B_DEV(r10),(r6)
	movl	NAM$L_DEV(r10),4(r6)
	movzbl	NAM$B_DIR(r10),(r7)
	movl	NAM$L_DIR(r10),4(r7)
	bsbw	normalize_r7		;remove any [000000...]
	bbc	#NAM$V_WILDCARD,NAM$L_FNB(r10),205$	;not a wildcard
	bsbw	sel_wild		;go select a wildcard dir
	blbc	r0,203$			;Whoops! abort operation
	brw	190$			;restart... may be more wildcards
203$:	movl	r0,retsts		;blast us / r0=completion code
	bisl	#FL_M_IEX!FL_M_VER,lflags	;mark 'immediate exit' flag
	brw	170$			;get lost & dispatch retsts
205$:	bbc	#SW_V_VER,switches,210$	;are we simply verifying directory?
;we're simply verifying the directory... need to go ahead & tempset the dir
;for subsequent operations, but we also need to put it back when we're done!
	bisl	#FL_M_VER,lflags	;set 'need reset' flag in lflags
;Now we can set the new directory for subsequent segmental jumps
210$:	;r6->dev, r7->dir
	clrq	-(SP)
	clrl	-(SP)
	pushaq	(r6)		;text to insert to logical
	pushaq	sysdsk
	calls	#5,g^LIB$SET_LOGICAL
	clrq	-(SP)
	pushaq	(r7)
	calls	#3,g^SYS$SETDDIR

;new dir is set... duplication doesn't matter here
	brw	170$		;back to main loop for more work

do_stsid:
	bbc	#0,12(AP),20$			;simply return the code
	bbc	#1,12(AP),10$			;do not set sig_to_ret trap
	movaw	w^CD_SIG_TO_RET,(FP)		;set up trap
10$:	bsbw	stsid				;do operation
20$:	movl	retsts,r0
	ret

fix_cmdbuf:
; First ... force entire string to upper case
	pushaq	cmdbuf
	pushaq	cmdbuf
	calls	#2,G^STR$UPCASE		;force to uppercase
	rsbc

; Next... Change all tabs to spaces
	pushr	#^xffc			;save r2-11
	movq	cmdbuf,r6		;r6'r7 is cmdbuf descrip
	clrl	r5			;char index
	movzwl	r6,r6			;remove any descriptor junk
	bneq	20$
10$:	popr	#^xffc			;recover r2-11
	movzwl	#SS$_NORMAL,r0
	rsb				;back to caller
20$:	cmpb	(r7)[r5],#9		;is char a tab?
	bneq	30$			;nope... leave it be
	movb	#^a/ /,(r7)[r5]		;insert a space over the tab
30$:	aoblss	r6,r5,20$		;do for all characters

; Next... remove any trailing spaces
40$:	cmpb	b^-1(r7)[r6],#^a/ /	;is last char a space?
	bneq	50$			;nope... leave this section
	decw	cmdbuf			;remove trailing char
	sobgtr	r6,40$			;remove trailer & go more
	brw	10$			;string got eaten

; Now... remove any leading spaces
50$:	movzwl	cmdbuf,r6		;get new copy of cmdbuf length
60$:	cmpb	(r7),#^a/ /		;is first char a space?
	bneq	70$			;nope... leave this section
	incl	r7			;point one more char into string
	incl	cmdbuf+4		;advance cmdbuf also
	decw	cmdbuf			;take char from cmdbuf descrip
	sobgtr	r6,60$			;remove leader char & go more
65$:	brw	10$			;string got eaten

; Now... remove any multi-spaces from string
70$:	movzwl	cmdbuf,r6		;get new copy of cmdbuf length
	decl	r6			;use EQ length (i.e. len==last char idx)
	beql	65$			;no multi-space for 1 char string
	clrl	r8			;new string index register
80$:	cmpb	(r7)[r8],#^a/ /		;is *this* char a space?
	bneq	86$			;nope... leave it be
	cmpl	r8,r6			;cur index best be .LT. max index
	bgequ	65$			;we're done!
85$:	cmpb	1(r7)[r8],#^a/ /	;is *next* char a space?
	beql	87$			;yep... go munch it
86$:	aobleq	r6,r8,80$
	brw	65$			;done
; Now we must subtract *NEXT* character from string
; r8 = index of *THIS* char, r6 = max char index
87$:	subl3	r8,r6,r0		;number of chars to move + 1
	decl	r0			;remove '+1' character count
	beql	90$
	movc3	r0,2(r7)[r8],1(r7)[r8]	;backmove the string by 1 char
90$:	decw	cmdbuf			;remove char from cmdbuf length
	decl	r6			;remove char from counter
	bneq	80$			;string still OK... restart 'next' test
	brw	65$			;string got eaten... go away

get_chunk:
	pushr	#^xffc			;save all regs but r0'r1
	movq	cmdbuf,r2		;r2'r3 = CMDBUF descriptor
	movq	buffer,r4		;r4'r5 = BUFFER descriptor (len wrong)
	movzwl	r2,r2			;remove any descrip crap
	clrl	r6			;no characters copied to buffer yet
	tstl	r2			;are there any characters left?
	beql	30$			;bug off - no more characters left
10$:	cmpb	(r3),#^a/ /		;is current source byte a space?
	beql	20$			;go remove it & return buffer
	movb	(r3)+,(r5)+		;copy the byte to BUFFER
	incl	r6			;register another char copied
	sobgtr	r2,10$			;back for full string
	clrw	cmdbuf			;zero cmdbuf now that we're EOS
	brb	30$			;and leave
20$:	decl	r2			;remove current space
	movb	r2,cmdbuf		;update cmdbuf size
	addl3	#1,r3,cmdbuf+4		;update cmdbuf address
30$:	movl	r6,r0			;return # of chars copied
	movw	r6,buffer		;and insert to buffer
	popr	#^xffc
	rsb				;return

.entry	CD_SIG_TO_RET,^m<r4,r5>
	movl	CHF$L_SIGARGLST(AP),r4
	cmpl	CHF$L_SIG_NAME(r4),#SS$_UNWIND
	beql	30$
	movl	CHF$L_MCHARGLST(AP),r5
	movl	CHF$L_SIG_NAME(r4),r1
	extzv	#STS$V_FAC_NO,#STS$S_FAC_NO,r1,r1
	cmpl	r1,#CD$_FACILITY
	bneq	20$
	movl	r1,CHF$L_MCH_SAVR0(r5)	; copy signal name as condition code
	moval	vector,r5		;target to copy vector to
	movl	(r4),r1			;get count of lwords to copy
10$:	movl	(r4)+,(r5)+		;copy an argument
	sobgeq	r1,10$			;copy signal array
	$unwind_s			;blow away establisher frame
20$:	movl	#SS$_RESIGNAL,r0
30$:	ret

stsid:	bbc	#FL_V_VER,lflags,5$	;skip dir reset opertion
	bsbw	dir_reset		;always do dir_reset first
5$:	;dispatch on result codes
	cmpl	retsts,#SS$_BADPARAM
	beql	10$
	cmpl	retsts,#SS$_OPINCOMPL
	beql	20$
	cmpl	retsts,#SS$_WASCLR
	beql	30$
	cmpl	retsts,#SS$_WASSET
	beql	40$
	cmpl	retsts,#SS$_CREATED
	beql	50$
	cmpl	retsts,#SS$_NOSUCHDEV
	beql	60$
	cmpl	retsts,#SS$_RESIGNAL
	beql	70$
	cmpl	retsts,#SS$_BADIRECTORY
	beql	80$
	cmpl	retsts,#SS$_BUGCHECK
	beql	90$
	brw	do_unknown
10$:	brw	do_syntax
20$:	brw	do_nochange
30$:	brw	do_current
40$:	brw	do_prev
50$:	brw	do_target
60$:	brw	do_fail
70$:	brw	do_help
80$:	brw	do_baddir
90$:	brw	do_bugcheck
; result execution routines
do_syntax:
	bbs	#SW_V_FUL,switches,10$
	SIGVEC	#CD_SYNTAX
	brw	do_isdone
10$:	SIGVEC	#CD_SYNTAX,#0,#CD_SYNTXT,#1,#buffer
	brw	do_isdone
do_current:
	bbs	#SW_V_FUL,switches,10$
	SIGVEC	#CD_CURDIR,#1,#curd0
	brw	do_isdone
10$:	SIGVEC	#CD_CURIS,#1,#curd0
	brw	do_isdone
do_nochange:
	bbs	#SW_V_FUL,switches,10$
	SIGVEC	#CD_NOCHNG
	brw	do_isdone
10$:	SIGVEC	#CD_NOCHNG,#0,#CD_CURIS,#1,#curd0
	brw	do_isdone
do_dirisok:
	bbs	#SW_V_FUL,switches,10$
	SIGVEC	#CD_DIREX
	brw	do_isdone
10$:	SIGVEC	#CD_DIREX,#0,#CD_TRGWAS,#2,#dsc0,#dsc1
	brw	do_isdone
do_prev:
	blbs	prevf,10$
	movc3	notdef,@notdef+4,@buffer+4
	movzwl	notdef,buffer
	brw	do_fail
10$:	bbs	#SW_V_FUL,switches,20$
	SIGVEC	#CD_PRVDIR,#1,#prev
	brw	do_isdone
20$:	SIGVEC	#CD_PRVIS,#1,#prev
	brw	do_isdone
do_fail:
	bbs	#SW_V_FUL,switches,10$
	SIGVEC	#CD_DIRNEX
	brw	do_isdone
10$:	tstw	buffer
	beql	20$
	SIGVEC	#CD_DIRNEX,#0,#CD_TRGWAS,#2,#buffer,#nulstr
	brw	do_isdone
20$:	SIGVEC	#CD_DIRNEX,#0,#CD_PRVNDF
;	brw	do_isdone
do_isdone:
	SIGNAL	savsts=retsts
	movzbl	#SS$_NORMAL,r0
	rsb

do_unknown:
	bbs	#SW_V_FUL,switches,10$
	SIGVEC	#CD_UNKSTS,#1,retsts
	brb	20$
10$:	SIGVEC	#CD_UNKSTS,#1,retsts,#CD_UNKTXT,#1,#buffer
20$:	SIGNAL	savsts=retsts
	movl	retsts,r0
	rsb

normalize_r7:
	movo	r6,-(SP)
	movl	r7,r8
	movq	(r8),r6
	movzwl	r6,r6
10$:	cmpl	#8,r6
	blssu	30$
20$:	movo	(SP)+,r6
	rsb			;return... no longer big enough for '[000000.'
30$:	cmpl	(r7),#^a/[000/
	bneq	20$
	cmpl	4(r7),#^a/000./
	bneq	20$
	subw	#7,(r8)
	movc3	(r8),8(r7),1(r7)	;slam remaining string over '[000000.'
	movo	(SP)+,r6
	rsb

do_target:
	pushaq	buffer			;try to get current directory
	calls	#1,w^get_current_directory
	blbs	r0,10$
	brw	do_fail

10$:	movaq	buffer,r8		;setdef source address
	movab	tmpfab,r9		;point to fab for operations
	movc3	#FABSIZ,protofab,(r9)	;copy proto fab
	movab	tmpnam,r10		;point to nam for operations
	movc3	#NAMSIZ,protonam,(r10)	;copy proto nam

	bisl	#FAB$M_NAM,FAB$L_FOP(r9)
	movab	(r10),FAB$L_NAM(r9)
	movab	@4(r8),FAB$L_FNA(r9)
	movb	(r8),FAB$B_FNS(r9)

	movb	#NAM$C_MAXRSS,NAM$B_RSS(r10)
	movab	rssstr,NAM$L_RSA(r10)
	movb	#NAM$C_MAXRSS,NAM$B_ESS(r10)
	movab	essstr,NAM$L_ESA(r10)

	$parse	fab=(r9)		;parse the sucker!
	blbs	r0,20$
15$:	brw	do_fail

20$:	bbs	#NAM$V_WILDCARD,NAM$L_FNB(r10),15$	;wildcards illegal
	movaq	dsc0,r6		;device descriptor address
	movaq	dsc1,r7		;dirtxt descriptor address
	movzbl	NAM$B_DEV(r10),(r6)
	movl	NAM$L_DEV(r10),4(r6)
	movzbl	NAM$B_DIR(r10),(r7)
	movl	NAM$L_DIR(r10),4(r7)
	bsbw	normalize_r7		;remove any [000000...]

	bbc	#SW_V_VER,switches,30$
	brw	do_dirisok

30$:	;r6->dev, r7->dir
	clrq	-(SP)
	clrl	-(SP)
	pushaq	(r6)		;text to insert to logical
	pushaq	sysdsk
	calls	#5,g^LIB$SET_LOGICAL
	clrq	-(SP)
	pushaq	(r7)
	calls	#3,g^SYS$SETDDIR

;new dir is set... test for duplication
	pushaq	curd1
	calls	#1,w^get_current_directory
	movl	r0,curdf1
	blbs	r0,40$
	SIGVEC	#CD_DIRERR,#1,curdf1
	SIGNAL	savsts=retsts
	$exit_s	-
		code	=	curdf1
40$:
	cmpw	curd0,curd1
	bneq	50$
	cmpc3	curd0,@curd0+4,@curd1+4
	bneq	50$
	brw	do_nochange
50$:	;directory has changed ok... set prev logical
	clrq	-(SP)
	clrl	-(SP)
	pushaq	curd0		;text to insert to logical
	pushaq	prvdir		;prev logical
	calls	#5,g^LIB$SET_LOGICAL	;Poof! saved it!

	pushaq	curd0		;insert this logical text
	calls	#1,stack_dirs	;to the stack of previous directories

	bbc	#SW_V_LOG,switches,60$
	SIGVEC	#CD_DIRSET,#0,#CD_PRVIS,#1,#curd0,#CD_CURIS,#1,#curd1
	brb	70$
60$:	SIGVEC	#CD_DIRSET
70$:	SIGNAL	savsts=retsts
	movzbl	#SS$_NORMAL,r0
	rsb

do_help:
	bbc	#2,12(AP),10$			;Help is not inhibited
	SIGVEC	#CD_NOHELP
	brw	90$
10$:	moval	help,r9				;point to help list
	clrl	r8				;no access to SYSCOM yet
20$:	movl	(r9)+,r11			;point to current help entry
	bneq	40$				;not eolist
30$:	brw	80$				;done... bugoff
40$:	bbss	#0,r8,50$
	bsbw	acc_syscom
	blbc	r0,30$
	brb	60$
50$:	movaq	pressakey,r10
	bsbw	prt_syscom_r10
	calls	#0,syscom_getkey		;go get a single keystroke
	blbc	r0,30$				;jmp if returned an error
60$:	movzwl	(r11),dsc0			;sizeof helptext
	addl	#32,dsc0			;fudgefactor
	clrl	-(SP)				;use default zone
	pushal	dsc0+4				;Addr to stuff returned addr
	pushal	dsc0				;pointer to lento get
	calls	#3,g^LIB$GET_VM			;get memory for $FAO
	blbs	r0,70$				;memory gotten ok
	SIGVEC	#CD_MEMALCFAI,#1,r0,r0		;return memory alc failure
	brw	90$
70$:	$fao_s		-
		ctrstr	=	(r11),-
		outlen	=	dsc0,-
		outbuf	=	dsc0
	pushaq	dsc0				;formatted text
	calls	#1,G^LIB$PUT_OUTPUT		;print the stuff
	brw	20$				;back for help 'til eolist
80$:	bsbw	deacc_syscom			;blast it anyway
	SIGVEC	#CD_HELPDONE
90$:	SIGNAL	savsts=retsts
	movzbl	#SS$_NORMAL,r0
	rsb

do_baddir:
	SIGVEC	#CD_CURDIRBAD
	brw	do_isdone
do_bugcheck:
	SIGVEC	#CD_BUGCHECK
	brw	do_isdone

;This resets directory from CURD0 for testing & if it was changed by /VER
dir_reset:
	blbs	curdf0,10$		;ok so far
4$:	$exit_s	-			;blow up hard
		code = #CD_CURDIRBAD
10$:	movaq	curd0,r8		;setdef source address
	movab	tmpfab,r9		;point to fab for operations
	movc3	#FABSIZ,protofab,(r9)	;copy proto fab
	movab	tmpnam,r10		;point to nam for operations
	movc3	#NAMSIZ,protonam,(r10)	;copy proto nam

	bisl	#FAB$M_NAM,FAB$L_FOP(r9)
	movab	(r10),FAB$L_NAM(r9)
	movab	@4(r8),FAB$L_FNA(r9)
	movb	(r8),FAB$B_FNS(r9)

	movb	#NAM$C_MAXRSS,NAM$B_RSS(r10)
	movab	rssstr,NAM$L_RSA(r10)
	movb	#NAM$C_MAXRSS,NAM$B_ESS(r10)
	movab	essstr,NAM$L_ESA(r10)
	bisb	#NAM$M_SYNCHK,NAM$B_NOP(r10)	;syntax only!!

	$parse	fab=(r9)		;parse the sucker!
	blbs	r0,20$
	brw	4$			;blow hard

20$:	movaq	dsc0,r6		;device descriptor address
	movaq	dsc1,r7		;dirtxt descriptor address
	movzbl	NAM$B_DEV(r10),(r6)
	movl	NAM$L_DEV(r10),4(r6)
	movzbl	NAM$B_DIR(r10),(r7)
	movl	NAM$L_DIR(r10),4(r7)
	bsbw	normalize_r7		;remove any [000000...]

	;r6->dev, r7->dir
	clrq	-(SP)
	clrl	-(SP)
	pushaq	(r6)		;text to insert to logical
	pushaq	sysdsk
	calls	#5,g^LIB$SET_LOGICAL
	clrq	-(SP)
	pushaq	(r7)
	calls	#3,g^SYS$SETDDIR
	rsb

.entry	stack_dirs,	^xffc			;Stack name into logical stack
	pushaq	@4(AP)				;this is the LNM to insert
	pushaq	@4(AP)				;this is previous XLT also
	clrl	-(SP)				;start @ 0
	calls	#3,mov_stack			;do insert operation
	ret

.entry	mov_stack,	^xffc
; This is a recursive procedure so we will never stack a duplicate...
; we will just swap the duplicate up to CD$0 so it has less tendancy
; to roll off the bottom.
	movl	4(AP),r8			;current string for move
	subl	#40,SP				;space4 source text+descr (32+8)
	moval	8(SP),4(SP)
	movl	#^x010e0020,(SP)
	movaq	(SP),r6				;source descriptor
	$fao_s	-				;create source name
		ctrstr = stkdir,-
		outlen = (r6),-
		outbuf = (r6),-
		p1 = r8

	subl	#104,SP				;space4 trans text+descr (96+8)
	moval	8(SP),4(SP)
	movl	#^x010e0060,(SP)
	movaq	(SP),r10			;trans descriptor
	pushl	(r10)				;place4 len-restore in get_lnm
	pushaq	(r10)				;place to dump translation
	pushaq	(r6)				;lnm to get trans for
	calls	#2,w^get_lnm			;try to translate it
	blbc	r0,10$				;skip any funny business
; Now we got a good translation... see if it's dup of current insert
	cmpw	@12(AP),(r10)			;are lengths same?
	bneq	5$
	movq	@12(AP),r0			;get descrip of source insert
	movzwl	r0,r0				;strip descrip stuff
	cmpc3	r0,(r1),@4(r10)			;see if strings are a match
	beql	10$				;stringmatch... replace this 1

5$:	;strings didn't match - recurse a level if possible
	cmpl	r8,#9				;was this the last level?
	beql	10$				;yep... scrappit

	pushaq	@12(AP)				;current insert string
	pushaq	(r10)				;current translation
	addl3	#1,r8,-(SP)			;new level
	calls	#3,mov_stack			;do it again

10$:	;Now we need to define current (r8,r6) lognam to prev, or new
	clrq	-(SP)
	clrl	-(SP)
	tstl	4(AP)				;see if we are at top level
	beql	20$				;yop... spl treat
	pushaq	@8(AP)				;text to insert to logical
	pushaq	(r6)				;target name
	calls	#5,g^LIB$SET_LOGICAL		;Poof! saved it!
	ret
20$:	pushaq	@12(AP)				;text to insert to logical
	pushaq	(r6)				;*source* name
	calls	#5,g^LIB$SET_LOGICAL		;Poof! saved it!
	ret

dol_set_prv:
	clrl	prevf				;invalidate prev dir
	cmpl	r2,#^a/0/\^a/*/			;was it a '*'?
	bneq	20$
	bsbw	get_dol_r2			;do a select
	blbc	r0,10$				;blow off change for errors
	cmpl	r2,#10				;is r2 flag value for nochange?
	bneq	20$				;nope... process it normally
10$:	brw	30$				;yep... go copy current for NOCH
20$:	movq	r6,-(SP)			;save r6'r7
	movl	SP,r7				;save stack pointer

	subl	#40,SP				;space4 source text+descr (32+8)
	moval	8(SP),4(SP)
	movl	#^x010e0020,(SP)
	movaq	(SP),r6				;source descriptor
	$fao_s	-				;create source name
		ctrstr = stkdir,-
		outlen = (r6),-
		outbuf = (r6),-
		p1 = r2

	pushaq	prev				;target idsc
	pushaq	(r6)				;formatted previous dir name
	calls	#2,w^get_lnm			;try to translate it
	movl	r0,prevf			;stuff the flags w/result code

	movl	r7,SP				;restore stack pointer
	movq	(SP)+,r6			;recover r6'r7
	rsb					;Home to momma!
30$:	pushr	#^x3f
	movw	curd0,prev			;copy length
	movzwl	prev,r0
	movc3	r0,@curd0+4,@prev+4		;copy text for match
	popr	#^x3f
	movl	#1,prevf			;set PREVF is OK
	rsb

get_dol_r2:					;call user to select of CD$*
	pushr	#^m<r4,r5,r6,r7,r8,r9,r10>	;save r4-r10
	movzbl	#10,r2				;prepare invalid r2
	bsbw	acc_syscom			;access SYS$COMMAND
	clrq	r4				;r4=MAX valid, r5=#_of_valid
	blbs	r0,10$				;all was OK... proceed
	brw	40$				;oops! die
10$:	bsbw	prt_dol_tran			;print a DOL translation
	blbc	r0,20$				;Oops! Out of translations
	aobleq	#9,r4,10$			;do for CD$0..9
20$:	tstl	r5				;were any translations found?
	beql	30$				;nope... skippit
	bsbw	get_syscom_num_r5		;get a number, n = {0..r5-1}
	blbc	r0,30$				;whoops... no number
	movl	r5,r2				;recover gotten number
30$:	bsbw	deacc_syscom			;deaccess SYS$COMMAND
40$:	popr	#^m<r4,r5,r6,r7,r8,r9,r10>	;recover r4-r10
	rsb					;back home

prt_dol_tran:
	subl	#40,SP				;space4 target text+descr (32+8)
	moval	8(SP),4(SP)
	movl	#^x010e0020,(SP)
	movaq	(SP),r7				;target descriptor
	$fao_s	-				;create target name
		ctrstr = stkdir,-
		outlen = (r7),-
		outbuf = (r7),-
		p1 = r4
	subl	#104,SP				;space4 trans text+descr (96+8)
	moval	8(SP),4(SP)
	addl	#4,4(SP)			;fwd 4 chars for 'n - '
	movl	#^x010e005c,(SP)		;minus 4 chars for 'n - '
	movaq	(SP),r10			;trans descriptor
	pushl	(r10)				;place4 len-restore in get_lnm
	pushaq	(r10)				;place to dump translation
	pushaq	(r7)				;lnm to get trans for
	calls	#2,w^get_lnm			;try to translate it
	addl	#4,SP				;remove extra 'restore' lword
	blbc	r0,10$				;skip any funny business
	addl	#4,(r10)			;add back in the 'n - '
	subl	#4,4(r10)			;backup the translation 'n - '
	addl3	r4,#^a/0 - /,@4(r10)		;insert 'n - '
	bsbw	prt_syscom_r10_cr		;prt descr (r10) on SYS$COMMAND
	incl	r5				;increment # of OK translations
	movzwl	#SS$_NORMAL,r0			;indicate OK
10$:	addl	#144,SP				;restore stack
	rsb					;and return


acc_syscom:		;r4 & 5 available
	$assign_s	-
		devnam	=	syscom,-
		chan	=	syscom_chn
	rsbc
	movl	SP,r4			;save stack pointer
	clrl	-(SP)			;place for returned device class
	clrl	-(SP)			;place for returned dev chars
	clrq	-(SP)			;IOSB place
	clrl	-(SP)			;eoitmlst
	clrl	-(SP)			;no return for devclass
	moval	b^-4(r4),-(SP)		;address to return device class
	pushl	#<DVI$_DEVCLASS@16>!4	;get device class code+len
	clrl	-(SP)			;no return for devchars
	moval	b^-8(r4),-(SP)		;address to return device chars
	pushl	#<DVI$_DEVCHAR@16>!4	;get device chars code+len
	moval	(SP),r5			;point to ITMLST
	movab	30$,-(SP)		;shove a cleanup routine onstack
	$getdviw_s	-
		chan	=	syscom_chn,-
		itmlst	=	(r5),-
		iosb	=	b^-12(r4)
	rsbc				;die if $GETDVI hated us
	movzwl	b^-12(r4),r0		;retrieve IOSB status
	rsbc				;die if $GETDVI hated us
	movzwl	#SS$_IVDEVNAM,r0
	cmpl	b^-4(r4),#DC$_TERM	;wasita TERMINAL?
	beql	20$
	bbc	#DEV$V_TRM,b^-8(r4),10$	;*MUST* be terminal
	bbs	#DEV$V_NET,b^-8(r4),10$	;NET types are illegal
	bbs	#DEV$V_MBX,b^-8(r4),10$	;Cannot be a mailbox either
	brb	20$			;done this way for clarity!
10$:	rsb				;return an OOPS... not a terminal
20$:	movzwl	#SS$_NORMAL,r0
	movl	r4,SP			;restore stack & Dont use cleanup rtn
	rsb
30$:	movl	r4,SP			;restore stack
	pushl	r0			;save r0
	$dassgn_s	-		;zap channel to SYS$COMMAND
		chan	=	syscom_chn
	clrl	syscom_chn		;indicate no channel
	popl	r0			;recover r0
	rsb				;back to caller

deacc_syscom:
	$dassgn_s	-		;zap channel to SYS$COMMAND
		chan	=	syscom_chn
	clrl	syscom_chn		;indicate no channel
	movzwl	#SS$_NORMAL,r0
	rsb

prt_syscom_r10_cr:
	bsbb	prt_syscom_r10
	rsbc
prt_syscom_cr:
	clrl	syscom_crpen
	clrq	-(SP)
	moval	(SP),r0
	$qiow_s	-
		chan	=	syscom_chn,	-
		func	=	#IO$_WRITEVBLK,-
		iosb	=	(r0),-
		p1	=	20$,-
		p2	=	#2
	addl	#8,SP
	rsb
20$:	.byte	10,13

prt_syscom_r10:
	tstl	syscom_chn
	bneq	10$
	movzwl	#SS$_IVCHAN,r0
	rsb
10$:	tstl	syscom_crpen
	beql	20$
	bsbw	prt_syscom_cr
20$:	clrq	-(SP)
	moval	(SP),r0
	movzwl	(r10),r1
	$qiow_s	-
		chan	=	syscom_chn,	-
		func	=	#IO$_WRITEVBLK,-
		iosb	=	(r0),-
		p1	=	@4(r10),-
		p2	=	r1
	addl	#8,SP
	rsb

prmptx:	.ascid	/_Selection: /
exits:	.ascid	<^x1b>/[7mExit/<^x1b>/[m/
quits:	.ascid	<^x1b>/[7mQuit/<^x1b>/[m/
get_syscom_num_r5:		;get a number, n = {0..r5-1}
	pushr	#^xffc
	movl	SP,r8
	movaq	prmptx,r10
	bsbw	prt_syscom_r10
10$:	calls	#0,syscom_getkey	;go get a single keystroke
	blbc	r0,30$			;jmp if returned an error
	movzwl	#SS$_ABORT,r0		;prep a fake error
	bicl3	#^x20,r1,r2
	cmpl	r2,#^a/Q/		;Quit command
	beql	30$
	cmpl	r1,s^#13		;is it a CR (==Quit)
	beql	30$
	subl	s^#^a/0/,r1		;change to bin0..9
	blssu	20$			;Whoops! Too small!
	cmpl	r5,r1			;see if r5 is bigger (should be)
	blequ	20$			;Nope... invalid number
	addl3	s^#^a/0/,r1,-(SP)	;stack & reconvert to character
	movl	r1,r2			;save bin value
	pushal	(SP)
	movl	#^x010e0001,-(SP)
	moval	(SP),r10
	bsbw	prt_syscom_r10		;echo character
	movl	r2,r1			;restore bin value of key
	brw	50$			;leave
20$:	bsbw	syscom_bel		;indicate an error
	brw	10$
30$:	cmpl	r0,#SS$_ENDOFFILE	;was it ^Z?
	bneq	40$
	movaq	exits,r10
	pushl	r0
	bsbw	prt_syscom_r10		;print Exit annunciation
	popl	r0
	brb	50$
40$:	cmpl	r0,#SS$_ABORT		;was it Quit?
	bneq	50$
	movaq	quits,r10
	pushl	r0
	bsbw	prt_syscom_r10		;print Exit annunciation
	popl	r0
50$:	movl	r8,SP
	popr	#^xffc
	movl	r1,r5
	rsb

prmpty:	.ascid	| ? (Y/N/Q) [N]: |
get_syscom_yn_r5:		;get 'Y','N','Q' into r5
	pushr	#^xffc
	movl	SP,r8
	movaq	prmpty,r10
	bsbw	prt_syscom_r10
10$:	calls	#0,syscom_getkey	;go get a single keystroke
	blbc	r0,30$			;jmp if returned an error
	bicl3	#^x20,r1,r2
	movzbl	#^a/N/,r5		;prep a 'N'
	cmpl	r2,#^a/N/		;'No' command
	beql	30$
	cmpl	r1,s^#13		;is it a CR (=='No')
	beql	30$
	movzbl	#^a/Y/,r5		;prep a 'Y'
	cmpl	r2,#^a/Y/		;'Yes' command
	beql	30$
	movzbl	#^a/Q/,r5		;prep a 'Q'
	cmpl	r2,#^a/Q/		;'Quit' command
	beql	30$
	bsbw	syscom_bel		;indicate an error
	brw	10$
30$:	blbc	r0,40$			;go annunciate other operations
	movzbl	r5,-(SP)		;stack & reconvert to character
	pushal	(SP)
	movl	#^x010e0001,-(SP)
	moval	(SP),r10		;describe the char
	brb	45$			;go print result
40$:	cmpl	r0,#SS$_ENDOFFILE	;was it ^Z?
	bneq	50$
	movzbl	#^a/Q/,r5		;indicate a quit op
	movzwl	#SS$_NORMAL,r0		;indicate an OK end anyway
	movaq	exits,r10
45$:	pushl	r0
	bsbw	prt_syscom_r10		;print Exit annunciation
	popl	r0
50$:	bisl	#1,syscom_crpen
	movl	r5,r1
	movl	r8,SP
	popr	#^xffc
	movl	r1,r5
	rsb

syscom_getchr:
	$qiow_s	-
		chan	=	syscom_chn,	-
		func	=	#IO$_READVBLK!IO$M_NOFILTR!IO$M_NOECHO!IO$M_TRMNOECHO,-
		iosb	=	(r4),-
		p1	=	@4(r2),-
		p2	=	(r2),-
		p4	=	#trmlst
	rsb

.entry	syscom_getkey,	^xffc
	clro	-(SP)
	moval	8(SP),4(SP)
	movzbl	#1,(SP)				;make a 1 byte buffer
	movaq	(SP),r2				;point to input buffer (1 char)
	clrq	-(SP)				;space for IOSB
	movaq	(SP),r4				;point at it with r4
10$:	bsbw	syscom_getchr			;go get a character
	blbc	r0,12$
	bsbw	20$				;go translate escape sequence
	bneq	10$
	tstl	r1
	beql	15$
12$:	ret
15$:	movzbl	b^4(r4),r1
	ret
20$:	cmpb	b^4(r4),#^x1a
	beql	30$
	cmpb	b^4(r4),#^x1b
	beql	40$
	xorl	r1,r1
	rsb
30$:	movzwl	#SS$_ENDOFFILE,r0
	ret
40$:	bsbw	syscom_getchr
	cmpb	b^4(r4),#^a/[/
	beql	60$
	cmpb	b^4(r4),#^a/O/
	beql	50$
	bsbw	syscom_bel
	movzbl	#1,r0
	rsb
50$:	brw	110$
60$:	bsbw	syscom_getchr
	subb3	#^x30,b^4(r4),r0
	blssu	100$
	cmpb	#^xa,r0
	blequ	100$
	clrl	r8
70$:	mull	#10,r8
	addl	r0,r8
	bsbw	syscom_getchr
	subb3	#^x30,b^4(r4),r0
	blssu	80$
	cmpb	#^xa,r0
	bgtru	70$
80$:	cmpb	b^4(r4),#^a/~/
	beql	90$
	bsbw	syscom_bel
	movzbl	#1,r0
	rsb
90$:	brw	fkeyr8
100$:	cmpb	b^4(r4),#^a/A/
	bneq	.+4
	brw	upar
	cmpb	b^4(r4),#^a/B/
	bneq	.+4
	brw	dnar
	cmpb	b^4(r4),#^a/C/
	bneq	.+4
	brw	rtar
	cmpb	b^4(r4),#^a/D/
	bneq	.+4
	brw	lfar
	bsbw	syscom_bel
	movzbl	#1,r0
	rsb
110$:	bsbw	syscom_getchr
	clrl	r8
	movb	b^4(r4),r0
120$:	cmpb	r0,140$[r8]
	beql	130$
	incl	r8
	tstb	140$[r8]
	bneq	120$
	bsbw	syscom_bel
	movzbl	#1,r0
	rsb
130$:	movzwl	150$[r8],r1
	xorl	r0,r0
	rsb
140$:	.asciz	/PQRSwxymtuvlqrsMpn/
150$:	.word	GK_PF1,GK_PF2,GK_PF3,GK_PF4
	.word	GK_KP7,GK_KP8,GK_KP9,GK_KPMINUS
	.word	GK_KP4,GK_KP5,GK_KP6,GK_KPCOMMA
	.word	GK_KP1,GK_KP2,GK_KP3,GK_KPENTER
	.word	GK_KP0,GK_KPPERIOD
fkeyr8:	cmpl	r8,#34
	blequ	20$
10$:	bsbw	syscom_bel
	movzbl	#1,r0
	rsb
20$:	cmpl	r8,#30
	beql	10$
	cmpl	r8,#27
	beql	10$
	cmpl	r8,#22
	beql	10$
	cmpl	r8,#17
	bgtru	30$
	cmpl	r8,#6
	bgtru	10$
	tstl	r8
	beql	10$
30$:	movzwl	40$[r8],r1
	xorl	r0,r0
	rsb
40$:	.word	0	;0
	.word	GK_E1,GK_E2,GK_E3,GK_E4,GK_E5,GK_E6
	.word	0,0,0,0,0,0,0,0,0,0,0
	.word	GK_F7,GK_F8,GK_F9,GK_F10
	.word	0	;22
	.word	GK_F11,GK_F12,GK_F13,GK_F14
	.word	0	;27
	.word	GK_F15,GK_F16
	.word	0	;30
	.word	GK_F17,GK_F18,GK_F19,GK_F20
upar:	movl	#GK_UPARROW,r1
	xorl	r0,r0
	rsb
dnar:	movl	#GK_DNARROW,r1
	xorl	r0,r0
	rsb
rtar:	movl	#GK_RTARROW,r1
	xorl	r0,r0
	rsb
lfar:	movl	#GK_LFARROW,r1
	xorl	r0,r0
	rsb

syscom_bel:
	$qiow_s	-
		chan	=	syscom_chn,	-
		func	=	#IO$_WRITEVBLK,-
		p1	=	10$,-
		p2	=	#1
	rsb
10$:	.byte	7

sel_wild:	;do a wildcard selection... buffer contains string
	bsbw	acc_syscom		;access SYS$COMMAND
	blbs	r0,10$			;SYS$COMMAND got to ok
	movzwl	#SS$_OPINCOMPL,r0	;indicate nochange
	rsb				;and blow out
10$:	pushr	#^xffc			;save all registers
	bsbw	cre_wild		;create filespec for wildcard
	blbs	r0,20$
	popr	#^xffc			;recover registers
	pushl	r0
	bsbw	deacc_syscom		;drop access to SYS$COMMAND
	popl	r0
	rsb
20$:	pushaq	tmp1
	pushaw	cnf_wild
	calls	#2,fscan		;do the file scan
	blbs	r0,40$			;it was a success.. musta got one
	cmpl	r0,#RMS$_DNF		;see if 'dir not found' error
	bneq	30$			;nope... try another
	movzwl	#SS$_NOSUCHDEV,r0	;indicate 'dirnex'
	brb	40$
30$:	cmpl	r0,#RMS$_NMF		;see if 'no more files' error
	bneq	40$			;nope... return 'as is'
	movzwl	#SS$_OPINCOMPL,r0	;indicate 'nochange'
40$:	popr	#^xffc			;recover registers
	pushl	r0
	bsbw	deacc_syscom		;drop access to SYS$COMMAND
	popl	r0
	rsb				;blow us off

.entry	cnf_wild,	^xffc
.IF DF,OLD_WCARDS
;See note in 'cre_wild' on why the .IF DF,OLD_WCARDS
	movl	4(AP),r11		;point @ FAB
	movaq	@8(AP),r10		;found this dir
;Ok... need to locate ']????.' seq & insert in place of the original wildcard
;r10 is address of descrip of whole selection
	movq	(r10),r6		;get descrip
	movzwl	r6,r6			;remove descrip junk
	clrl	r8			;index register
10$:	cmpb	(r7)[r8],#^a/]/		;find the ']'
	beql	20$			;found it
	aoblss	r6,r8,10$		;do 'til found
	brw	90$			;buggit... should be a ']' around here
20$:	aoblss	r6,r8,30$		;skip off the ']'
	brw	90$			;buggit... string shouldn't be MT
30$:	movab	(r7)[r8],r9		;address of ??? stuff
	subl	r8,r6			;len of remaining string
	clrl	r8			;start r8 index over
40$:	cmpb	(r9)[r8],#^a/./		;find the '.'
	beql	50$			;found it
	aoblss	r6,r8,40$		;do 'til found
	brw	90$			;buggit... should be a '.' around here
50$:	;r8'r9 describes replacement dirtext
	movzwl	buffer,r6		;get buffer strlen
	movc3	r6,@buffer+4,@tmp2+4	;make copy of buffer string
	movw	r6,tmp2			;tmp2 now's a copy of the buffer
	pushaq	tmp2
	pushaq	tmp2
	calls	#2,g^STR$UPCASE		;force result to upper case
	movq	dsc0,r6			;get r6'r7 of buffer wild guy
	subl	buffer+4,r7		;convert address to offset
	addl	tmp2+4,r7		;convert offset backto address
	movab	(r7)[r6],r5		;point to remaining string in buffer
	subl3	tmp2+4,r5,r4
	movzwl	tmp2,r3			;get current buffer length
	subl3	r4,r3,r4		;len of move is in r4, src is in r5
	subl3	r6,r3,r10		;get len of buffer - wild guy
	addl	r8,r10			;add back len of insertion
	addl3	r7,r8,r3		;addr of target
	movc3	r4,(r5),(r3)		;insert space for translation
	movc3	r8,(r9),(r7)		;insert translation
	movw	r10,tmp2		;reset tmp2 length
; Now go get input crap & start the real confirm
	movl	4(AP),r11		;point @ FAB
	movaq	tmp2,r10		;found this dir (munged)
	bsbw	prt_syscom_r10		;print the dir name
	bsbw	get_syscom_yn_r5	;get an answer from user
	blbs	r0,70$
60$:	mnegl	#SS$_OPINCOMPL,fab$l_ctx(r11)	;this stops the wild proc
	ret				;kablamma
70$:	cmpb	#^a/Q/,r5		;user wanna quit?
	beql	60$
	cmpb	#^a/N/,r5		;user wanna skippit?
	bneq	80$
	ret				;skippit
80$:	cmpb	#^a/Y/,r5		;user wanna take it?
	beql	100$
90$:	mnegl	#SS$_BUGCHECK,fab$l_ctx(r11)	;this stops the wild proc
	ret				;kablamma
100$:	;Ok... dir selected... need to recopy tmp2 to buffer
	;in place of the original wildcard
	mnegl	#SS$_CREATED,fab$l_ctx(r11)	;insert completion code
	movzwl	tmp2,r6			;get tmp2 strlen
	movc3	r6,@tmp2+4,@buffer+4	;make copy to buffer
	movw	r6,buffer		;tmp2's ben copied to buffer
	ret				;exit & try again
.IFF
	movl	4(AP),r11		;point @ FAB
	movaq	@8(AP),r10		;found this dir

	movzwl	(r10),r6		;get strlen of retrieved dirname
	movc3	r6,@4(r10),@tmp2+4	;make copy of retrieved dirname
	movw	r6,tmp2			;tmp2 now's a copy of retrieved dirname

	movaq	tmp2,r10		;get address if copied retrieved dirname

;Ok... need to locate ']????.' seq & patch to be a full directory spec.
;r10 is address of descrip of whole selection
	movq	(r10),r6		;get descrip
	movzwl	r6,r6			;remove descrip junk
	clrl	r8			;index register
10$:	cmpb	(r7)[r8],#^a/]/		;find the ']'
	beql	20$			;found it
	aoblss	r6,r8,10$		;do 'til found
	brw	90$			;buggit... should be a ']' around here
20$:	movb	#^a/./,(r7)[r8]		;force ']' to be a '.'
	aoblss	r6,r8,30$		;skip off the '.'
	brw	90$			;buggit... string shouldn't be MT
30$:	cmpb	(r7)[r8],#^a/./		;find the next '.'
	beql	40$			;found the '.'
	aoblss	r6,r8,30$		;search 'til '.'
	brw	90$			;buggit... string shouldn't end
40$:	movb	#^a/]/,(r7)[r8]		;complete the dirspec
	addw3	#1,r8,(r10)		;punch in new length

	pushaq	tmp2
	pushaq	tmp2
	calls	#2,g^STR$UPCASE		;force result to upper case

	movq	(r10),r6		;get a copy of the descriptor
	movzwl	r6,r6			;remove descriptor trash
50$:	cmpb	(r7),#^a/[/		;see if we got the '['
	beql	55$			;found the leading '['
	incl	r7			;skippabyte
	sobgtr	r6,50$			;scan whole string
	brw	90$			;buggit... string shouldn't end
55$:	movq	r6,-(SP)
	movl	r6,r8			;save length
	movaq	(SP),r7			;point at descriptor
	bsbw	normalize_r7		;go fixup any leading [000000.
	movw	(SP)+,r6		;recover [modified] descriptor
	subl	r6,r8			;r8 is oversize count
	subw	r8,(r10)		;patch main descriptor

; Now go get input crap & start the real confirm
	movl	4(AP),r11		;point @ FAB
	movaq	tmp2,r10		;found this dir (munged)
	bsbw	prt_syscom_r10		;print the dir name
	bsbw	get_syscom_yn_r5	;get an answer from user
	blbs	r0,70$
60$:	mnegl	#SS$_OPINCOMPL,fab$l_ctx(r11)	;this stops the wild proc
	ret				;kablamma
70$:	cmpb	#^a/Q/,r5		;user wanna quit?
	beql	60$
	cmpb	#^a/N/,r5		;user wanna skippit?
	bneq	80$
	ret				;skippit
80$:	cmpb	#^a/Y/,r5		;user wanna take it?
	beql	100$
90$:	mnegl	#SS$_BUGCHECK,fab$l_ctx(r11)	;this stops the wild proc
	ret				;kablamma
100$:	;Ok... dir selected... need to recopy tmp2 to buffer
	;in place of the original wildcard
	mnegl	#SS$_CREATED,fab$l_ctx(r11)	;insert completion code
	movzwl	tmp2,r6			;get tmp2 strlen
	movc3	r6,@tmp2+4,@buffer+4	;make copy to buffer
	movw	r6,buffer		;tmp2's ben copied to buffer
	ret				;exit & try again
.ENDC

cre_wild:	;all registers legal here!
.IF DF,OLD_WCARDS
;Following section was first-pass attempt at getting the wildcard stuff
;working... What I tried to do for a command like: 'CD [DIR1.*.*]' was to
;present the user with all files [DIR1.*]... then proceed to the subsequent
;[.*]. This turns out to be incorrect when dealing with a command like:
;'CD [DIR1.*.*.DIR2]' because the user is presented with selections for the
;first and second wildcards as if [.DIR2] exists, when in fact, .DIR2 does
;not necessarily exist at all.  I have replaced this with an algorithm that
;searches down to the tail-end of the specification, and presents *ALL*
;matching directory choices, since this does not exhibit the aforementioned
;anomalous behavior.  Additionally, the preceeding functionality can be
;recovered by using a multipath specification such as (for the first command):
;'CD [DIR1.*] *'. Ha! Nailed *THAT* sukker!
	movq	buffer,r2		;r2'r3 describes buffer
	movzwl	r2,r2			;clean out any descrip junk
	bsbw	fnd_wild		;find marker for start of wild name
	rsbc				;return an oops
	movl	tmp1+4,r8		;get data address for tmp1
	movc3	r9,(r3),(r8)		;move non-wild text to tmp1
	addw3	r7,r9,tmp1		;set length (include to be added '/0/]')
	movb	#^a/]/,(r8)[r9]		;insert trailing ']'
	cmpl	r7,#1			;see if we should've stuffed only 1
	beql	10$			;branch... we already stuffed it
	movab	(r8)[r9],r0		;get address to insert to
	movl	#^a/0000/,(r0)+		;insert '0000'
	movw	#^a/00/,(r0)+		;insert '00'
	movb	#^a/]/,(r0)+		;insert ']'
10$:	movc3	r10,(r11),@tmp2+4
	movw	r10,tmp2
	movq	tmp1,r6			;get tmp1
	movzwl	r6,r6
	movq	tmp2,r8			;get tmp2
	movzwl	r8,r8
	movc3	r8,(r9),(r7)[r6]	;append tmp2 to tmp1
	addw3	r8,r6,tmp1		;and set length accordingly
	movq	r10,dsc0		;save descriptor of wild guy
	movzwl	#SS$_NORMAL,r0		;indicate all's well that ends well
	rsb				;go home

fnd_wild:	;r2'r3 marks search address
	clrl	r8			;char count of non-wild chars
	clrl	r9			;char count of non-wild segments
	clrl	r7			;indexer register
10$:	cmpb	(r3)[r7],#^a/./		;is it a separator?
	beql	20$
	cmpb	(r3)[r7],#^a/[/		;is it a separator?
	bneq	40$
20$:	movl	r7,r9			;mark position of last separator
30$:	movl	r7,r8			;update count of non-wild chars
	aoblss	r2,r7,10$		;go do next char
	movzwl	#SS$_ENDOFFILE,r0	;indicate out of chars
	rsb
40$:	cmpb	(r3)[r7],#^a/*/		;is it a '*'?
	beql	50$			;go process it
	cmpb	(r3)[r7],#^a/%/		;is it a '%'?
	bneq	30$			;continue ripping up the string
50$:	;now... we've found a wildcard...
	movl	r9,r11			;make new copy of r9 (last set pos)
	movzbl	#7,r1			;indicate requirement to add '000000]'
	cmpb	(r3)[r9],#^a/[/		;see if there was a separator
	beql	60$
	bicb	#6,r1			;change to add simply ']'
	cmpb	(r3)[r9],#^a/./		;see if there was a separator
	bneq	70$			;nope... don't remove one
	decl	r9			;remove separator
60$:	incl	r11			;remove separator
70$:	movl	r11,r7			;reset to start of wild guy
80$:	cmpb	(r3)[r7],#^a/./		;is it a '.'?
	beql	90$			;found end
	cmpb	(r3)[r7],#^a/]/		;is it a ']'?
	beql	90$			;found end
	aoblss	r2,r7,80$		;do for whole string remainder
	movzwl	#SS$_ENDOFFILE,r0	;indicate out of chars
	rsb
90$:	subl3	r11,r7,r10		;len of wild guy
	incl	r9			;change from index to length
	movab	(r3)[r11],r11		;convert r11 from index to address
	movl	r1,r7			;move len of extra insert to r7
	movzwl	#SS$_NORMAL,r0		;indicate normal completion
	rsb
.IFF
;Following is the replacement code for the old wildcarding routines
	movq	buffer,r2		;r2'r3 describes buffer
	movzwl	r2,r2			;clean out any descrip junk
	bsbw	fnd_tail		;find tail directory spec
	rsbc				;return an oops
;returns r10'r11 describing tail item
;returns r9 as length of valid header text
;returns r7 as length of insert for '000000]' or ']'
	movl	tmp1+4,r8		;get data address for tmp1
	movc3	r9,(r3),(r8)		;move pre-tail text to tmp1
	addw3	r7,r9,tmp1		;set length (include to be added '/0/]')
	movb	#^a/]/,(r8)[r9]		;insert trailing ']'
	cmpl	r7,#1			;see if we should've stuffed only 1
	beql	10$			;branch... we already stuffed it
	movab	(r8)[r9],r0		;get address to insert to
	movl	#^a/0000/,(r0)+		;insert '0000'
	movw	#^a/00/,(r0)+		;insert '00'
	movb	#^a/]/,(r0)+		;insert ']'
10$:	movc3	r10,(r11),@tmp2+4
	movw	r10,tmp2
	movq	tmp1,r6			;get tmp1
	movzwl	r6,r6
	movq	tmp2,r8			;get tmp2
	movzwl	r8,r8
	movc3	r8,(r9),(r7)[r6]	;append tmp2 to tmp1
	addw3	r8,r6,tmp1		;and set length accordingly
	movq	r10,dsc0		;save descriptor of wild guy
	movzwl	#SS$_NORMAL,r0		;indicate all's well that ends well
	rsb				;go home

fnd_tail:	;r2'r3 marks search address
	clrl	r8			;char count of non-wild chars
	clrl	r9			;char count of non-wild segments
	clrl	r7			;indexer register
10$:	cmpb	(r3)[r7],#^a/./		;is it a separator?
	beql	20$
	cmpb	(r3)[r7],#^a/[/		;is it a separator?
	bneq	40$
20$:	movl	r7,r9			;mark position of last separator
30$:	movl	r7,r8			;update count of non-wild chars
	aoblss	r2,r7,10$		;go do next char
	movzwl	#SS$_BUGCHECK,r0	;indicate a big BooBoo
	rsb
40$:	cmpb	(r3)[r7],#^a/]/		;is it the trailing ']'?
	bneq	30$			;continue ripping up the string
50$:	;now... we've found the tail directory segment spanned by r9..r7
;This r9..r7 segment is of the following forms:
;  [xxxx'.tail]'  -> substitute as [xxxx]tail.dir;1
;  '[tail]'       -> substitute as [000000]tail.dir;1
	movl	r9,r11			;make new copy of r9 (last sep. pos)
	movzbl	#7,r1			;indicate requirement to add '000000]'
	cmpb	(r3)[r9],#^a/[/		;see if there was a separator
	beql	60$
	bicb	#6,r1			;change to add simply ']'
	cmpb	(r3)[r9],#^a/./		;see if there was a separator
	bneq	70$			;nope... don't remove one
	decl	r9			;remove separator
60$:	incl	r11			;remove separator
70$:	subl3	r11,r7,r10		;length of tail item
	incl	r9			;change from index to length
	movab	(r3)[r11],r11		;convert r11 from index to address
	movl	r1,r7			;move len of extra insert to r7
;returns r10'r11 describing tail item
;returns r9 as length of valid header text
;returns r7 as length of insert for '000000]' or ']'
	movzwl	#SS$_NORMAL,r0		;indicate normal completion
	rsb
.ENDC

;args are (actrtn, string_by_descriptor)
starstar:	.ascid		/sys$disk:[]*.dir;1/
.entry	fscan,	^xffc
ASSUME <FAB$C_BLN&3> EQ 0		;assume FAB length is LWORD aligned
	subl	#FAB$C_BLN,SP		;make space for fab
	moval	(SP),r6			;point to FAB
	movc5	#0,#0,#0,#FAB$C_BLN,(r6);zero FAB
	movb	#FAB$C_BID,FAB$B_BID(r6);set type as FAB
	movb	#FAB$C_BLN,FAB$B_BLN(r6);set length of FAB
ASSUME <NAM$C_BLN&3> EQ 0		;assume NAM length is LWORD aligned
	subl	#NAM$C_BLN,SP		;make space for nam
	moval	(SP),r7			;point to NAM
	movc5	#0,#0,#0,#NAM$C_BLN,(r7);zero NAM
	movb	#NAM$C_BID,NAM$B_BID(r7);set type as NAM
	movb	#NAM$C_BLN,NAM$B_BLN(r7);set length of NAM
ASSUME 256 GE NAM$C_MAXRSS
	subl	#256,SP			;make room for resultant string
	movab	(SP),r8			;point to resultant string
	subl	#256,SP			;make room for expanded string
	movab	(SP),r9			;point to expanded string

	moval	(r7),fab$l_nam(r6)	;insert NAM address into FAB
	movq	@8(AP),r0		;get string in r0'r1
	movzwl	r0,r0			;clean off descrip stuff
	movl	r1,fab$l_fna(r6)	;insert filename address into FAB
	movb	r0,fab$b_fns(r6)	;insert name len into FAB
	movl	starstar+4,fab$l_dna(r6);insert default "*.*;*" into FAB
	movb	starstar,fab$b_dns(r6)	;set default size into FAB
	movl	4(AP),fab$l_ctx(r6)	;insert action routine offset
	movb	#FAB$C_RFM_DFLT,fab$b_rfm(r6)	;set default RFM

	movb	#NAM$C_MAXRSS,nam$b_rss(r7)	;set max resultant size
	movl	r8,nam$l_rsa(r7)		;insert RSA address
	movb	#NAM$C_MAXRSS,nam$b_ess(r7)	;set max expanded size
	movl	r9,nam$l_esa(r7)		;insert ESA address

10$:	mnegl	fab$l_ctx(r6),r0	;recover possible completion code
	bgeq	20$			;ctx was negative... return a code
	pushaw	fsc_error		;error routine
	pushaw	fsc_success		;success routine
	pushal	(r6)			;address of source FAB
	calls	#3,g^LIB$FILE_SCAN	;go scan for matching files
	blbs	r0,10$
	mnegl	fab$l_ctx(r6),r1	;recover possible completion code
	blss	20$			;ctx was positive... this err's real
	movl	r1,r0			;return ctx error instead
20$:	pushl	r0
	pushal	(r6)
	calls	#1,g^LIB$FILE_SCAN_END
	popl	r0
	ret

.entry	fsc_error,	0
	ret

.entry	fsc_success,	^xffc
	moval	@4(AP),r2		;point at OK FAB
	movl	fab$l_nam(r2),r3	;point at OK NAM

	pushl	nam$l_rsa(r3)		;push resultant address
	movzbl	nam$b_rsl(r3),-(SP)	;shove len on top making descrip
	moval	(SP),r4			;point to descrip
	bisl	#^x010e0000,(r4)	;change to static descrip

	pushaq	(r4)			;pass described resultant string
	pushl	4(AP)			;pass FAB also
	calls	#2,@fab$l_ctx(r2)	;callback the action routine
	mnegl	fab$l_ctx(r2),r0	;is a status there?
	blss	10$			;went neg... must not be
	pushl	4(AP)
	calls	#1,g^LIB$FILE_SCAN_END	;try to abort file_scan
10$:	movzwl	#1,r0
	ret
	.end