.title	CDPARSE- Change directory AKA Unix/MSDOS
	.ident	'CDPARSE V4.3'
	.library "sys$share:lib"
;
; Program:	CDPARSE.MAR V4.3
;
; Author:	David G. North, CCP
;		1333 Maywood Ct
;		Plano, Texas  75023
;		(214) 653-1231
;
; Date:		90.11.16
;
; Revisions:
;   Who		Date	Description
;   D.North	901116	DECUS release
;
; License:
;    Ownership of and rights to these programs is retained by the author(s).
;    Limited license to use and distrubute 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 executables.
;      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.
;


	$libdef			;LIB$ routine return codes
	$lnmdef			;Logical name translation codes
	$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

.IF EQ,1
Program:	CD.MAR V4.3 DNORTH 90.10.19
Author:		D.North, CCP
Date:		90.10.19
Description:
   CD is a simulation of an MSDOS/UNIX CD command with a large number of
   extensions.  Basic usage summary follows:

   DCL definition:
	$ CD:==$dev:[dir1.dir2]CD.EXE
	$ CD:==$dev:[dir1.dir2]CD.EXE/LOG
   Standard operations:
	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 logical_w_dir:		- move to spec'd directory
	CD .dirname			- change to subdir named
	CD dev:				- change to new dev same dir, not useful
   Personal identifiers (idents):
	CD IDN				- move to 'CDI_IDN' contents
   Personal devices:
	CD FMT$:parm			- move to 'CDF_FMT$' contents formatted
					  $FAO using 'parm'
	CD FMT$:parm1.parm2...parm16	- move to 'CDF_FMT$' contents formatted
					  $FAO using 'parm1'..'parm16'
   Switches: (must be specified *BEFORE* pathname!!!)
	/LOG				- log changes in directory
	/VERIFY				- verify target dir... don't set def
	/FULL				- complete dirspecs in messages
   Logical names used:
	LAST_DEFAULT_DIRECTORY		- always defined as last dir on ok
					  directory change

Useful hints:
   Personal device names override physical device names. Period.
   If you have an ident/logical conflict, use ':' for forcing logical usage.
   If you have a logical/subdirname conflict, use the '.name' to force
     subdirname usage instead of logical translation/

Revision history:
   Who      Facility When      Why
   DNORTH   DSC      871103    Initial release
   DNORTH   DSC      880115    Conversion to C
   DNORTH   DSC      880120    V3.0 pre-release and internal structuring
   DAVIDN   DSC      890109    Add extension processing to x$ format names
   D_NORTH  ITI      891024    Add OSDG CMS library names ITI
   D_NORTH  ITI      901017    Conversion to MACRO32
   D_NORTH  ITI      901017    Revision of CDx_qq.. name formats
   D_NORTH  ITI      901017    Addition of switch processing
   D_NORTH  ITI      901019    Change PRINTF to SIGNAL w/message file
.ENDC


;++
;  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>

.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		'FULL',swful
	$TRAN		'LOG',swlog
	$TRAN		'VERIFY_ONLY',swver
	$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		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		;_dirloop		...nice try for now
	$TRAN		TPA$_SYMBOL,TPA$_EXIT

	$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

; Primary translation buffer
	.long		80
buffer:	.long		80
	.address	.+4
	.blkb		80

; Temporary storage places for LNM xlat, etc.
	.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		9		;CALLx format frame
	.address	buffer,retsts
	.address	curd0,curdf0
	.address	curd1,curdf1
	.address	prev,prevf
	.address	vector

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
fildev:	.ascid		/LNM$FILE_DEV/
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
cdidn:	.ascid	/CDI_/
cdfmt:	.ascid	/CDF_/
root:	.ascid	/[000000]/
nulstr:	.ascid	//
sysdsk:	.ascid	/SYS$DISK/
prvdir:	.ascid	/LAST_DEFAULT_DIRECTORY/
unavl:	.ascid	/Requested information unavailable/
notdef:	.ascid	/not defined/
help:	.ascid	-
|CD V4.3 ©1990, 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 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!/|-
|	/FULL			- verbose messages|

	.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:	;'$<eos>'
	clrw	buffer				;blast to 'no prev dir' state
	movab	buffer+8,buffer+4		;reset pointers
	blbc	prevf,10$			;no previous dir found ok
	movzwl	prev,buffer
	movc3	prev,@prev+4,@buffer+4		;copy prev dir as target
10$:	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	15$
	clrl	@8(AP)			;make bufblk pointer unavailable
15$:
	movaq	@4(AP),r6
	movc3	(r6),@4(r6),@buffer+4
	movzwl	(r6),buffer		;make local copy of data

; Force buffer uppercase
	pushaq	buffer
	pushaq	buffer
	calls	#2,G^STR$UPCASE		;force to uppercase
	blbs	r0,20$
	ret

; local init
20$:
	clrl	retsts
	clrl	curdf0
	clrl	curdf1
	clrl	prevf
	clrl	vector

	tstl	8(AP)
	beql	25$
	moval	bufblk,@8(AP)		;point user to return parameter block
25$:
	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

	clrl	devnam			;no device seen yet!
	clrl	switches

; 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
	blbc	r0,barf				;do nothing for bum return
	bbc	#0,12(AP),40$			;simply return the code
	bbc	#1,12(AP),30$			;do not set sig_to_ret trap
	movaw	b^CD_SIG_TO_RET,(FP)		;set up trap
30$:	bsbw	stsid				;do operation
40$:	movl	retsts,r0
barf:	ret

.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:	;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$
	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
; 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
do_target:
	tstw	buffer
	bneq	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$
	brw	do_fail

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)

	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!

	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	30$
10$:	movzwl	help,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,20$				;memory gotten ok
	SIGVEC	#CD_MEMALCFAI,#1,r0,r0		;return memory alc failure
	brb	30$
20$:	$fao_s		-
		ctrstr	=	help,-
		outlen	=	dsc0,-
		outbuf	=	dsc0
	pushaq	dsc0			;formatted text
	calls	#1,G^LIB$PUT_OUTPUT	;print the stuff
	SIGVEC	#CD_HELPDONE
30$:	SIGNAL	savsts=retsts
	movzbl	#SS$_NORMAL,r0
	rsb

	.end