          <<< NOTED::DISK$NOTES7:[NOTES$LIBRARY_7OF4]HACKERS.NOTE;1 >>>
                               -< ** Hackers ** >-
================================================================================
Note 1613.3            ramdisk(fddriver) & shadowing(hbs)                3 of 15
TKTVFS::SHINOSAKI                                  5118 lines  26-JAN-1994 19:42
                       -< procedure to build images... >-
--------------------------------------------------------------------------------
  A couple of procedure contained;

	o rebuild.com - change facility name (default "DG" - i.g., DGDRIVER.EXE)

	o build.com - build images

  First, extract each procedure into indivisual files
  Next, execute rebuild.com to create fddriver building procedure
  (@rebuild.com FD)  and then
  Finally, execute build_fd.com to build images of fddriver (@build_fd)

&&&&&&&&&&&&&&&& procedure to change driver name from DG &&&&&&&&&&&&&&&&&&&&&&&
$! rebuild.com - change product name
$! p1=prefix (a couple of character) of product (i.g., FD)
$! p2=output file specification (default is BUILD_'p1'.COM)
$	savvfy	='f$ve(0)
$	tpf	="temp"+f$getj(0,"pid")
$	out	="wr dro"
$	say	="wr sys$output"
$	hdr	="%" + f$pa(f$en("procedure"),,,"name") - "$" + "-"
$	ss$_badparam=20
$	set	on
$	set	control_y
$	on	warning then goto 90$
$	on	error then goto 90$
$	on	severe_error then goto 90$
$	on	control_y then goto ss_controly
$! compute media ident
$	if 	"".nes.p3 .and. p2.eqs."" .and. "".eqs.p1 then goto cmedia
$! check calling parameters and apply default
$	if ""	.eqs. p1 then p1="dm"
$	if ""	.eqs. p2 then p2="build_" + p1 + ".com"
$	p1	=f$ed(p1,"upcase")
$	p2	=f$ed(p2,"upcase")
$	sts	=ss$_badparam
$	if 2	.ne. f$length(p1) then goto fine
$	if "."	.eqs. f$pa(p2,,,"type") then p2=p2 + ".com"
$	if ""	.nes. f$tr("build")
$	then	srcfil=f$tr("build")
$	else	srcfil="BUILD.COM"
$	endif
$! beginning of real work
$	say	hdr,"I-BEGIN, started                ",f$ti()
$	clo/nol	dro
$	clo/nol	dri
$	if ""	.nes. f$sea(tpf+".*") then delete 'tpf'.*;*
$	if ""	.nes. f$sea(p2) then purge/keep=1 'p2'
$	if ""	.eqs. f$sea(srcfil) then goto ss_nosuchfile
$	src	="DG"
$	dst	=p1
$! highspeed processing to change from "DM" to "DM"
$	if dst	.eqs. src
$	then
$	 copy	build.com 'p2'
$	 goto	80$
$	endif
$! create procedure for edt editor  and then replace string
$	gosub	build_mediaid
$! following strings may be swaped to build images according to driver name
$!	  DGDRIVER         FDDRIVER
$!	=============    =============
$!	"DG$SETCHR"  --> "FD$SETCHR"
$!	"DGDRIVER"   --> "FDDRIVER"
$!	"DGA"        --> "FDA"
$!	"DG$"        --> "FD$"
$!	"DG_"        --> "FD_"
$!	"=DG"        --> "=FD"
$!	"%DG"        --> "%FD"
$!	"DG DG"      --> "FD FD"
$!	"2348D001"   --> "310C4001"
$
$	copy	nl: 'tpf'.tmp
$	ope/a	dro 'tpf'.tmp
$	out	"set search exact"
$	out	"substitute/",f$ed("''src'$SETCHR","lowercase"),"/",f$ed("''dst'$SETCHR","lowercase"),	"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src'DRIVER","lowercase"),	"/",f$ed("''dst'DRIVER","lowercase"),	"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src'A","lowercase"),	"/",f$ed("''dst'A","lowercase"),		"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src'$","lowercase"),	"/",f$ed("''dst'$","lowercase"),		"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src'_","lowercase"),	"/",f$ed("''dst'_","lowercase"),		"/ 1:99999 /notype"
$	out	"substitute/",f$ed("=''src'","lowercase"),	"/",f$ed("=''dst'","lowercase"),	"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src' ''src'","lowercase"),"/",f$ed("''dst' ''dst'","lowercase"),	"/ 1:99999 /notype"
$	out	"set search exact"
$	out	"substitute/",f$ed("''src'$SETCHR","upcase"),	"/",f$ed("''dst'$SETCHR","upcase"),	"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src'DRIVER","upcase"),	"/",f$ed("''dst'DRIVER","upcase"),	"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src'A","upcase"),	"/",f$ed("''dst'A","upcase"),		"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src'$","upcase"),	"/",f$ed("''dst'$","upcase"),		"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src'_","upcase"),	"/",f$ed("''dst'_","upcase"),		"/ 1:99999 /notype"
$	out	"substitute/",f$ed("=''src'","upcase"),	"/",f$ed("=''dst'","upcase"),	"/ 1:99999 /notype"
$	out	"substitute/",f$ed("%''src'","upcase"),	"/",f$ed("%''dst'","upcase"),	"/ 1:99999 /notype"
$	out	"substitute/",f$ed("''src' ''src'","upcase"),"/",f$ed("''dst' ''dst'","upcase"),	"/ 1:99999 /notype"
$	out	"set search general"
$	out	"substitute/2348D001/",mediaid,"/ 1:99999 /notype"
$	out	"exit"
$	clo	dro
$	say	hdr,"I-PROCEED, creating source procedure..."
$	define/user sys$output nl:
$	edit/edt/command='tpf'.tmp/nojournal/output='p2' build.com
$	deas	sys$output
$! end of real work
$80$:	say	hdr,"I-CREATED, build procedure created, ",p2
$! termination
$90$:	sts	=$status
$fine:	p8	='f$ve(0)
$	if ""	.nes. f$sea(tpf+".*") then delete 'tpf'.*;*
$	if ""	.nes. f$sea(p2)
$	then
$	 if	sts
$	 then	purge/keep=1 'p2'
$	 else	delete 'p2';*
$	 endif
$	endif
$	say	hdr,"I-FINE, termination             ",f$ti()
$	p8	=f$ve(savvfy)
$	exit	sts
$ss_controly:
$	sts	=%x610
$	goto	fine
$ss_nosuchfile:
$	say	hdr,F-NOSUCHFILE, no source file ''srcfil' exists"
$	sts	=%x910
$	goto	fine
$cmedia:dst	=f$ed(f$ex(0,2,p3),"upcase")
$	gosub	build_mediaid
$	say	hdr,"I-NEWMEDIA, /''dst'''dst' 1/ is /",mediaid,"/"
$	goto	90$
$!==============================================================================
$!	entry	dst=two upcase characters as media type and ident
$!	return	mediaid=hex-decimal string for ucb$l_media_id field
$!	destroy	p7-p8,mediaid
$!	calling	gosub
$
$build_mediaid:
$	mediaid	=0
$	p8	=0
$102:	mediaid	=mediaid*32		! shift left 5 bits
$	p7	=f$ex(p8,1,dst+dst)
$	if ""	.eqs. p7 then goto 104
$	mediaid	=mediaid+(f$cvui(0,8,p7)-64)
$	p8	=1+p8
$	goto	102
$104:	mediaid	=mediaid*128+1		! shift left 7 bits and add media number
$	mediaid	=f$ed(f$fa("!XL",mediaid),"lowercase")
$	return
$!==============================================================================

&&&&&&&&&&&&&&&&&&&&&&% procedure to build images &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
$! build.com - build memory_resident_psuedo_disk i/o driver and utility
$! p1=function (driver,utility,install,debug,list,all - default is "help")
$	savvfy	='f$ve(0)
$	savmsg	=f$en("message")
$	savdef	=f$en("default")
$	tpf	="temp"+f$getj(0,"pid")
$	jcl	=f$el(0,";",f$en("procedure"))
$	hdr	="%" + f$pa(jcl,,,"name") + "-"
$	say	="wr sys$output"
$!	alpha32	=f$gets("arch_name") .eqs. "Alpha"
$	alpha32	=f$gets("archflag") .ne. 14576
$	set mes	/f/s/i/t
$	set	on
$	set	control_y
$	on	severe_error then goto 90$
$	on	control_y then goto 90$
$	on	warning then goto 90$
$	on	error then goto 90$
$	clo/nol	dro
$	clo/nol	dri
$	if ""	.nes. f$sea(tpf+".*") then delete 'tpf'.*;*
$	pur/k=1	'jcl
$	rename	'jcl' *.*;1
$! get calling parameters
$	fnc	=0	! function code
$	p1	=","+P1+","+P2+","+P3+","+P4+","+P5+","+P6+","+P7+","+P8+","
$	p1	=f$ed(p1,"upcase,collapse,trim")
$	oldvfy	='f$ve(0)
$	p8	=0
$12:	p8	=1+p8
$	p6	=f$el(p8,",",p1)
$	if ","	.nes. p6
$	then
$	 if p6	.eqs. "" then goto 12
$	 p5	=fnc
$	 if p6	.eqs. f$ex(0,f$le(p6),"DGDRIVER") then	fnc=fnc.or.1	! driver
$	 if p6	.eqs. f$ex(0,f$le(p6),"DRIVER") then	fnc=fnc.or.1
$	 if p6	.eqs. f$ex(0,f$le(p6),"SETCHAR") then	fnc=fnc.or.2
$	 if p6	.eqs. f$ex(0,f$le(p6),"STARTUP") then	fnc=fnc.or.4	! proc
$	 if p6	.eqs. f$ex(0,f$le(p6),"RAMFILE") then	fnc=fnc.or.4	! proc
$	 if p6	.eqs. f$ex(0,f$le(p6),"UTILITY") then	fnc=fnc.or.6	! util
$	 if p6	.eqs. f$ex(0,f$le(p6),"LIST") then	fnc=fnc.or.16	! list
$	 if p6	.eqs. f$ex(0,f$le(p6),"DEBUG") then	fnc=fnc.or.32	! debug
$	 if p6	.eqs. f$ex(0,f$le(p6),"HELP") then	fnc=fnc.or.64	! help
$	 if p6	.eqs. f$ex(0,f$le(p6),"INSTALL") then	fnc=fnc.or.128	! instal
$	 if p6	.eqs. f$ex(0,f$le(p6),"ALL") then	fnc=fnc.or.(1+2+4+128)
$	 if p5	.ne. fnc then goto 12
$	 say	hdr,"E-IVKEYW, illegal function ''p6' requested"
$	 goto	90$
$	endif
$	p8	=f$ve(oldvfy)
$	if	0.eq.(fnc.and.(128+7)) .or. fnc/64 then gosub c_help
$! check current system version
$	p8	=f$ex(1,1,f$gets("version"))+f$ex(3,1,f$gets("version"))
$	if 0	.lt. f$ex(5,1,f$gets("version")) then p8=p8+f$ex(5,1,f$gets("version"))
$	sysver	='f$ex(0,3,p8+"000")
$	if	552.gt.sysver .and. 200.ne.sysver
$	then
$	 say	hdr,"W-SYSVIRDIF, unsupported system version, ",f$gets("version")
$	endif
$! point "alpha$library" to appropriate directory
$	if	alpha32
$	then
$!	 if ""	.eqs. f$tr("alpha$library","lnm$process",,"supervisor") then -
$!	  define/proc/exe alpha$library 'f$en("default")','f$tr("alpha$library","lnm$system",,"executive")'
$	 if ""	.nes. f$tr("sys$base_image","lnm$process") then -
$	  if ""	.eqs. f$sea("sys$base_image") then deas/proc sys$base_image
$	 if ""	.eqs. f$tr("sys$base_image","lnm$process") then -
$	  if ""	.nes. f$sea("sys$base_image.exe") then -
$	   define/proc/exe sys$base_image 'f$sea("sys$base_image.exe")
$	endif
$! start processing
$	p8	=f$el(0.eq.(fnc.and.16+32),"|","|no")
$	p7	=f$el(alpha32,"|","|/migration/''p8'machine_code/warn=warn")
$	asm	="macro''p7'/enable=(global)/obj/''p8'list"
$	map	="link/''p8'map/''p8'full/''p8'cross/''p8'symbol_table"
$	p8	=f$el(0.eq.(fnc.and.32),"|","|no")
$	asm	=asm+"/''p8'debug=(symbol,traceback)/''p8'show=binary"+p7
$	map	=map+"/''p8'debug/''p8'traceback"
$! assemble
$	if 0	.ne. (fnc.and.3) then call build_mlb 'tpf'.mlb
$!	build dg$setchr.exe utility program
$	if	fnc/2
$	then
$	 say	hdr,"I-UTILITY, creating DG$SETCHR image"
$	 if ""	.nes. f$sea("dg$setchr.*") then delete dg$setchr.*;*
$	 call	create_src_utility 'tpf'.tmp
$	 call	build_absolute dg$setchr 'tpf'.tmp
$	 sts	=$status
$	 if	.not.sts then goto fine
$	endif
$!	build dgdriver psuedo i/o driver
$	if	fnc/1
$	then
$	 say	hdr,"I-DRIVER, creating DGDRIVER image"
$	 if ""	.nes. f$sea("dgdriver.*") then delete dgdriver.*;*
$	 call	create_src_driver dgdriver.asm
$	 call	build_obj dgdriver.asm
$	 sts	=$status
$	 delete	dgdriver.asm;*
$	 if	.not.sts then goto fine
$	if	alpha32
$	then
$	 call	create_option dgdriver.opt
$	 p8	=f$el(0.eq.(fnc.and.16+32),"|","|no")
$	 if 0	.gt. 0!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$	 then	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$	 link/alpha/userlib=proc/native_only/bpage=14/section_bindings -
	 /nodemand_zero/notraceback/nodebug/sysexe/nosysshr -
	 /'p8'symbol=dgdriver/'p8'map=dgdriver/'p8'full/'p8'cross -
	 /vms_exec/replace/share=dgdriver.exe -
	  dgdriver -
-!	 ,RESOBJ$:BASE_LEVEL.OPT/OPTION -
	 ,'savdef'dgdriver.opt/OPTION
$	 sts	=$status
$	 else	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$	 link/native_only/bpage=14/section_bindings/info -
	 /nodemand_zero/notraceback/nodebug/sysexe=selective_search/nosysshr -
	 /'p8'symbol=dgdriver/'p8'map=dgdriver/'p8'full/'p8'cross -
	 /share=dgdriver.exe -
	 'savdef'dgdriver.opt/option
$	 sts	=$status
$	 delete	dgdriver.opt;*
$	 endif	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$	else
$	 map/nodebug/notraceback/share=dgdriver dgdriver -
	 ,sys$system:sys.stb/selective_search
$	 sts	=$status
$	endif
$	 delete	dgdriver.obj;*
$	 if	.not.sts then goto fine
$	endif
$	sts	=$status
$	if	.not.sts then goto fine
$! mount procedure, dg$startup.com
$	if	fnc/4
$	then
$	 say	hdr,"I-PROCEDURE, creating DG$STARTUP procedure"
$	 call	create_startup dg$startup.com
$	endif
$! application procedure, dg$ramfile.com
$	if	fnc/4
$	then
$	 say	hdr,"I-PROCEDURE, creating DG$RAMFILE procedure"
$	 call	create_ramfile dg$ramfile.com
$	endif
$! installation
$	if	fnc/128
$	then
$	 say	hdr,"I-INSTALL, move files to system directory"
$	 call	imgins
$	endif
$! service message
$	if	0.ne.(fnc.and.7) .and. .not.(fnc/128) then -
$	 say	hdr,"I-BUILT, issue /@''f$pa(jcl,,,"name")' INSTALL/ to move files to system directory"
$! termination
$90$:	sts	=$status
$fine:	p8	='f$ve(0)
$	set mes	'savmsg
$	clo/nol	dro
$	clo/nol	dri
$	if ""	.nes. f$sea(tpf+"*.*") then delete 'tpf'*.*;*
$	exit	(sts.and.%x0fffffff) .or. (f$ve(savvfy,savvfy/2)*0)
$!==============================================================================
$imgins:subr
$	savprv	=f$setpriv("bypass")
$! fd
$!	if ""	.nes. f$sea("sys$loadable_images:fddriver.exe") then delete sys$loadable_images:fddriver.exe;*
$!	if ""	.nes. f$sea("sys$system:fd$setchr.exe") then delete sys$system:fd$setchr.exe;*
$!	if ""	.nes. f$sea("sys$manager:fd$startup.com") then delete sys$manager:fd$startup.com;*
$!	if ""	.nes. f$sea("sys$manager:syfastdisk.com") then delete sys$manager:syfastdisk.com;*
$! dm
$	if ""	.nes. f$sea("sys$loadable_images:dmdriver.exe") then delete sys$loadable_images:dmdriver.exe;*
$	if ""	.nes. f$sea("sys$system:dm$setchr.exe") then delete sys$system:dm$setchr.exe;*
$	if ""	.nes. f$sea("sys$manager:dm$startup.com") then delete sys$manager:dm$startup.com;*
$	if ""	.nes. f$sea("sys$manager:dm$ramfile.com") then delete sys$manager:dm$ramfile.com;*
$! dgdriver
$	if ""	.nes. f$sea("dgdriver.exe")
$	then
$	 if ""	.nes. f$sea("sys$loadable_images:dgdriver.exe") then -
$	  delet	sys$loadable_images:dgdriver.exe;*
$	 copy	dgdriver.exe sys$common:[sys$ldr]*.*;1 /log
$	 set	file/prot=w:""/own=[1,4] sys$loadable_images:dgdriver.exe
$	 delete	dgdriver.exe;*
$	endif
$! dg$setchr
$	if ""	.nes. f$sea("dg$setchr.exe")
$	then
$	 if ""	.nes. f$sea("sys$system:dg$setchr.exe") then -
$	  delet	sys$system:dg$setchr.exe;*
$	 copy	dg$setchr.exe sys$common:[sysexe]*.*;1 /log
$	 set	file/prot=w:re/own=[1,4] sys$common:[sysexe]dg$setchr.*
$	 delete	dg$setchr.exe;*
$	endif
$! dg$startup
$	if ""	.nes. f$sea("dg$startup.com")
$	then
$	 if ""	.nes. f$sea("sys$manager:dg$startup.com") then -
$	  delet	sys$manager:dg$startup.com;*
$	 copy	dg$startup.com sys$common:[sysmgr]*.*;1 /log /replace
$	 set	file/prot=w:""/own=[1,4] sys$common:[sysmgr]dg$startup.*
$	 delete	dg$startup.com;*
$	endif
$! dg$ramfile
$	if ""	.nes. f$sea("dg$ramfile.com")
$	then
$	 if ""	.nes. f$sea("sys$manager:dg$ramfile.com") then -
$	  delet	sys$manager:dg$ramfile.com;*
$	 copy	dg$ramfile.com sys$common:[sysmgr]*.*;1 /log /replace
$	 set	file/prot=w:""/own=[1,4] sys$common:[sysmgr]dg$ramfile.*
$	 delete	dg$ramfile.com;*
$	endif
$! finish
$	p8	=f$setpriv(savprv)
$	ends
$!==============================================================================
$!	entry	p1=result module name
$!		p2=source module file spec.
$build_absolute:
$	subr
$	savvfy	='f$ve()
$	set	noon
$	on	control_y then goto 99$
$!	on	error then goto 70$
$!	on	severe_error then goto 70$
$	p8	=f$pa(p1,,,"name")
$	if ""	.nes. f$sea(p8+".lis") then delete 'p8'.lis;*
$	if ""	.nes. f$sea(p8+".obj") then delete 'p8'.obj;*
$	if ""	.nes. f$sea(p8+".map") then delete 'p8'.map;*
$	if ""	.nes. f$sea(p8+".exe") then delete 'p8'.exe;*
$	if ""	.nes. f$sea(p8+".stb") then delete 'p8'.stb;*
$! build reloactable module
$	call	build_obj 'p2'
$	sts	=$status
$	if ""	.nes. f$sea(p2) then delete 'f$el(0,";",p2)';*
$	if.not.	sts then goto 90$
$! build absolute module
$	if	alpha32
$	then
$	 map/section_binding/sysexe=selective 'tpf' -
	 -!	,sys$loadable_images:sys$base_image.exe/selective -
		,sys$input/options
$	 sts	=$status
$	else
$	 map	'tpf' -
		,SYS$SHARE:imagelib.olb/library -
		,sys$system:sys.stb/selective_search -
		,sys$input/options
$	 sts	=$status
$	endif
$	if ""	.nes. f$sea(tpf+".obj") then delete 'tpf'.obj;*
$	if.not.	sts then goto 90$
$!	patch/absolute/journal=nl: 'tpf'.exe
!deposit	0b0=0
!update
$	if ""	.nes. f$sea(tpf+".exe") then rename 'tpf'.exe 'p1'.*
$	if ""	.nes. f$sea(tpf+".map") then rename 'tpf'.map 'p1'.*
$! termination
$	sts	=$status
$90$:	p8	='f$ve(0)
$	if ""	.nes. f$sea(tpf+".lis") then rename 'tpf'.lis 'p1'.*
$	if ""	.nes. f$sea(tpf+".map") then rename 'tpf'.map 'p1'.*
$	if ""	.nes. f$sea(tpf+"*.*") then delete 'tpf'*.*;* /exc=(*.mlb)
$	if ""	.nes. f$sea(p1+".*")
$	then
$	 purge/keep=1 'p1'.*
$	 rename	'p1'.* *.*;1
$	endif
$	exit	sts .or. %x10000000 .or. (f$ve(savvfy,savvfy/2)*0)
$99$:	deas	sys$output
$	set mes	/f/s/i/t
$	sts	=%x610
$	goto	90$
$	ends
$!==============================================================================
$build_obj:
$	subr
$	savvfy	='f$ve()
$	set	noon
$	on	control_y then goto 99$
$	p8	=f$pa(p1,,,"name")
$	p7	=f$el(0.eq.(fnc.and.16+32),"|","|no")
$	asm	=asm - "/nolist" - "/list" + "/''p7'list=" +p8
$	if ""	.nes. f$sea(p8+".lis") then delete 'p8'.lis;*
$	if ""	.nes. f$sea(p8+".obj") then delete 'p8'.obj;*
$	if ""	.nes. f$sea("SYS$SHARE:arch_defs.mar") then -
$	 p1	="/obj=" + p8 + " SYS$SHARE:arch_defs.mar+" + f$pa(p1)
$! gather name of macro library file
$	p8	=0
$	p7	='f$ve(0)
$12$:	p8	=1+p8
$	f'p8'	=f$sea("*.mlb")
$	if ""	.nes. f'p8'
$	then
$	 if 1	.ge. p8 then goto 12$
$	 p7	=p8-1
$	 if	f'p7' .nes. f'p8' then goto 12$
$	endif
$	clo/nol	dro
$	ope/w	dro 'tpf'.zzz
$	wr	dro "$set noon"
$	wr	dro "$on control_y then exit %x10000610"
$	wr	dro "$delete ",tpf,".zzz;*"
$	wr	dro "$define sys$error nl:
$	wr	dro "$define sys$output ",tpf,".zzz"
$	wr	dro "$",asm," ",p1," -"
$	p7	="TRUE"
$14$:	p8	=p8-1
$	if 0	.lt. p8
$	then
$	 p6	=f$sea("SYS$SHARE:"+f$pa(f'p8',,,"name")+f$pa(f'p8',,,"type"))
$	 if "" .nes. p6		! explicits lib.mlb/starlet.mlb presented?
$	 then			! yes,
$	  if	alpha32
$	  then	p7="FALSE"	! say that should not use library in SYS$SHARE
$	  else	goto 14$	! ignore alpha explicits library
$	  endif
$	 endif
$	 wr	dro "+",f$el(0,";",f'p8'),"/library -"
$	 goto	14$
$	endif
$	if	p7 then wr dro "+SYS$SHARE:lib.mlb/library -"
$	if	p7 then wr dro "+SYS$SHARE:starlet.mlb/library"
$	if.not.	p7 then wr dro ""
$	wr	dro "$sts =$status
$	wr	dro "$deas sys$output"
$	wr	dro "$deas sys$error"
$	wr	dro "$exit sts"
$	close	dro
$	p7	=f$ve(savvfy)
$	if	savvfy then type 'tpf'.zzz
$	@'tpf'.zzz
$	sts	=$status
$	if.not.	sts then goto 70$
$	if ""	.eqs. f$sea(tpf+".zzz") then goto 90$
$! evaluate result
$	set mes	/nof/nos/noi/not
$	sea/out=nl:/match=or 'tpf'.zzz "-F-","-E-","-W-"
$	sts	=$status
$	set mes	/f/s/i/t
$	if.not.	sts then goto 90$
$70$:	if 3	.ne. (sts.and.7)
$	then
$	 type	'tpf'.zzz
$	 if	sts then sts=%x2c
$	endif
$90$:	if ""	.nes. f$sea(tpf+".zzz") then delete 'tpf'.zzz;*
$	exit	sts .or. %x10000000 .or. (f$ve(savvfy,savvfy/2)*0)
$99$:	deas	sys$output
$	set mes	/f/s/i/t
$	sts	=%x610
$	goto	90$
$	ends
$!==============================================================================
$build_mlb:
$	subr
$	if ""	.nes f$sea(p1) then delete 'p1';*
$	savvfy	='f$ve(0)
$	create	'tpf'.tmp
$	deck/dollar=%%
; local macro procedure
	.macro	$banki	name		; instruction ban
	.iif gt	alpha32, .psect	$banki,shr,pic,byte,exe,nord,nowrt
	.endm
	.macro	$bankd_r name		; data bank (write inhibit gaurd mode)
	.iif gt	alpha32, .psect	$bankd_r,pic,long,noexe,rd,nowrt
	.endm
	.macro	$bankd_w name		; data bank
	.iif gt	alpha32, .psect	$bankd_w,pic,long,noexe,rd,wrt
	.endm
	.macro	.asect
	 .save
	 .psect	$abs$,abs
	 .=0
	.endm
	.macro	.endasect
	 .restore
	.endm
; output a message on sys$output
	.macro	putasc buffer
	.iif gt	alpha32, movab buffer,R0
	.iif le	alpha32, pushab buffer
	 bsbw	output_asc
	.endm
; output a message on sys$output
	.macro	putdsc desc
	.iif gt	alpha32, movaq desc,R0
	.iif le	alpha32, pushaq desc
	 bsbw	output_dsc
	.endm
; create scratch buffer and descriptor on stack
	.macro	crework
	.if gt	alpha32
	 movab	-256(sp),sp
	 pushab	(sp)		; dsc$a_pointer
	 movzbl	#255,-(sp)	; dsc$w_length (=dsc$b_length)
	.iff
	 bsbw	crewrkb
	.endc
	.endm
; free stack that used as scratch buffer and descriptor
	.macro	rlswork
	.iif gt	alpha32, movab	256+8(sp),sp
	.iif le	alpha32, bsbw	rlswrkb
	.endm
; AMACRO32 macro procedures for VAX/VMS v5.52 and earlier
	.macro	call_jsb_entry
	.if le	alpha32
	.if lt	exec_version-600
	.macro	.call_entry max_args=?,home_args=?,input=<>,output=<>,scratch=<>,preserve=<>
	 .word	^m<preserve>
	.endm	.call_entry
	.macro	.jsb_entry max_args=?,input=<>,output=<>,scratch=<>,preserve=<>
	.endm	.jsb_entry
	.endc
	.endc
	.endm	call_jsb_entry
	.macro	parmdef
	parm_k=4*0
	parm_1=4*1
	parm_2=4*2
	parm_3=4*3
	parm_4=4*4
	parm_5=4*5
	parm_6=4*6
	parm_7=4*7
	parm_8=4*8
	parm_9=4*9
	.endm
%%
$	p7	=f$ve(savvfy)
$	p8	=f$gets("version")
$	if 0	.lt. f$ex(5,1,p8)
$	then	p8=f$ex(1,1,p8)+f$ex(3,1,p8)+f$ex(5,1,p8)
$	else	p8=f$ex(1,1,p8)+f$ex(3,1,p8)+"0"
$	endif
$	copy	nl: 'tpf'.tmp
$	ope/a	dro 'tpf'.tmp
$	wr	dro "	.macro	exec_version"
$	wr	dro "	exec_version=",p8
$!	wr	dro "	alpha32=",f$str(f$gets("arch_name").eqs."Alpha")
$	wr	dro "	alpha32=",f$str(f$gets("archflag").ne.14576)
$	wr	dro "	.endm"
$	close	dro
$	append	'tpf'.tmp;1 'tpf'.tmp
$	purge	'tpf'.tmp
$	libr/create/macro 'p1' 'tpf'.tmp
$	sts	=$status
$	if ""	.nes. f$sea(tpf+".tmp") then delete 'tpf'.tmp;*
$	exit	sts .or. %x10000000 .or. (f$ve(savvfy,savvfy/2)*0)
$	ends
$!==============================================================================
$create_option:
$	subr
$	savvfy	='f$ve()
$	p1	=f$el(0,";",p1)
$	if ""	.nes. f$sea(p1) then delete 'p1';*
$	copy	nl: 'p1'
$	ope/a	dro 'p1'
$	wr	dro "CLUSTER=DGDRIVER,,,''savdef'DGDRIVER,-"
$	close	dro
$	create	'p1'
$	deck/dollar=%%
 ALPHA$LIBRARY:STARLET.OLB/INCLUDE=(SYS$DOINIT,SYS$DRIVER_INIT),-
 ALPHA$LIBRARY:VMS$VOLATILE_PRIVATE_INTERFACES.OLB/INCLUDE=(BUGCHECK_CODES)
PSECT_ATTR=_AMAC$CODE,PIC,USR,CON,REL,GBL,NOSHR,EXE,RD,NOWRT,NOVEC
PSECT_ATTR=$CODE$,PIC,USR,CON,REL,GBL,NOSHR,EXE,RD,NOWRT,NOVEC
PSECT_ATTR=_AMAC$LINKAGE,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=EXEC$NONPAGED_DATA,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,C
PSECT_ATTR=EXEC$NONPAGED_LINKAGE,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT
PSECT_ATTR=$LINK$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$PLIT$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$OWN$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$GLOBAL$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$LITERAL$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$INITIAL$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$DATA$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC,MOD
PSECT_ATTR=.BLANK.,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=EXEC$INIT_CODE,NOSHR
PSECT_ATTR=EXEC$INIT_LINKAGE,PIC,USR,CON,REL,GBL,NOSHR,EXE,RD,WRT,NOVEC
PSECT_ATTR=$$$115_LINKAGE,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
COLLECT=NONPAGED_READONLY_PSECTS/ATTRIBUTES=RESIDENT,-
 _AMAC$CODE,-
 EXEC$NONPAGED_CODE,-
 $$$115_DRIVER,-
 $CODE$
COLLECT=NONPAGED_READWRITE_PSECTS/ATTRIBUTES=RESIDENT,-
 _AMAC$LINKAGE,-
 EXEC$NONPAGED_DATA,-
 EXEC$NONPAGED_LINKAGE,-
 $$$105_PROLOGUE,-
 $$$110_DATA,-
 $$$115_LINKAGE,-
 $PLIT$,-
 $GLOBAL$,-
 $OWN$,-
 $LINK$,-
 $LITERAL$,-
 . BLANK .,-
 .BLANK.,-
 $DATA$,-
 $INITIAL$
COLLECT=INITIALIZATION_PSECTS/ATTRIBUTES=INITIALIZATION_CODE,-
 EXEC$INIT_LINKAGE,-
 EXEC$INIT_CODE,-
 EXEC$INIT_000,-
 EXEC$INIT_001,-
 EXEC$INIT_002,-
 EXEC$INIT_SSTBL_000,-
 EXEC$INIT_SSTBL_001,-
 EXEC$INIT_SSTBL_002
%%
$	append	'p1' 'p1';1	
$	delete	'p1';2
$	exit
$
$	create	dgdriver.opt
$	deck/dollar=%%
SYMBOL_TABLE=GLOBALS
CLUSTER=VMSDRIVER,,,-
-!	RESOBJ$:SYS.OLB/INCLUDE:(SYS$DOINIT,PATA_NONPAGED),-
	SYS$SHARE:VMS$VOLATILE_PRIVATE_INTERFACES.OLB/INCLUDE=(BUGCHECK_CODES),-
	SYS$SHARE:STARLET.OLB/INCLUDE:(SYS$DRIVER_INIT)
PSECT_ATTR=_AMAC$CODE,PIC,USR,CON,REL,GBL,NOSHR,EXE,RD,NOWRT,NOVEC
PSECT_ATTR=_AMAC$LINKAGE,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$CODE$,PIC,USR,CON,REL,GBL,NOSHR,EXE,RD,NOWRT,NOVEC
PSECT_ATTR=$LINK$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$PLIT$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$INITIAL$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$LITERAL$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$OWN$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$DATA$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=$GLOBAL$,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
PSECT_ATTR=EXEC$INIT_CODE,NOSHR
PSECT_ATTR=EXEC$INIT_LINKAGE,PIC,USR,CON,REL,GBL,NOSHR,EXE,RD,WRT,NOVEC
PSECT_ATTR=$$$115_LINKAGE,PIC,USR,CON,REL,GBL,NOSHR,NOEXE,RD,WRT,NOVEC
COLLECT=NONPAGED_READONLY_PSECTS/ATTRIBUTES=RESIDENT,-
	_AMAC$CODE,EXEC$NONPAGED_CODE,$$$115_DRIVER,$CODE$
COLLECT=NONPAGED_READWRITE_PSECTS/ATTRIBUTES=RESIDENT,-
	_AMAC$LINKAGE,EXEC$NONPAGED_DATA,EXEC$NONPAGED_LINKAGE,-
	$$$105_PROLOGUE,$$$110_DATA,$$$115_LINKAGE,-
	$PLIT$,$INITIAL$,$LITERAL$,$GLOBAL$,$OWN$,$DATA$,$LINK$
COLLECT=INITIALIZATION_PSECTS/ATTRIBUTES=INITIALIZATION_CODE,-
	EXEC$INIT_LINKAGE,EXEC$INIT_CODE,-
	EXEC$INIT_000,EXEC$INIT_001,EXEC$INIT_002,-
	EXEC$INIT_SSTBL_000,EXEC$INIT_SSTBL_001,EXEC$INIT_SSTBL_002
IDENTIFICATION="AlphaX5K4-D3A"
%%
$	p8	=f$ve(savvfy)
$	ends
$!==============================================================================
$c_help:
$	p8	='f$ve(0)
$	type	sys$input
$	deck/dollar=%%

Subj:	ramdisk (dgdriver) to support vax/vms level-ii volume shadowing (hbs)

	Building images
	---------------
	Excute this procedure, build.com (standard vms installation kit is
	unavailable).

	  $ @BUILD.COM DRIVER,UTILITY	! create images

	Thus, three images dgdriver.exe, dg$setchr.exe, dg$startup.com and
	dg$ramfile.com will be created in current default directory.

	Installation
	------------
	To move images to system directory, issue this procedure again with
	"install" string in parameter-1.

	  $ @BUILD.COM INSTALL		! move images to system directory

	Thus, a few images will be moved to system directories such as;

	  SYS$COMMON:[SYS$LDR]DGDRIVER.EXE;1  - kernel code (real work)
	  SYS$COMMON:[SYSEXE]DG$SETCHR.EXE;1  - utility
	  SYS$COMMON:[SYSMGR]DG$STARTUP.COM;1 - create/init/mount procedure
	  SYS$COMMON:[SYSMGR]DG$RAMFILE.COM;1 - setup file on ramdisk
	                                        (site specific example)
	Using image
	-----------
	To create unit, initialize volume, mount volume, you may use provided
	convinient procedure DG$STASRT.COM.  For example;

	  $ @SYS$MANAGER:DG$STARTUP  devnam  volnam/lognam/volsiz
	    or
	  $ @SYS$MANAGER:DG$STARTUP  shadow_set_name  volnam/lognam/volsiz -
	                                                list_of_shadow_member

	To setting up file on ramdisk (copy,reinstall), you may modify example
	procedure, DG$RAMFILE.COM.   Before using that procedure, you should 
	modify it for your site.

	Description
	-----------
	Bellow is short description.

	<device type>
	To meet 6.0 initialize command, device type DT$_RAM_DISK introduced
	to memory resident psuedo disk.    However, current version  of vms
	(T6.1 and earlier) not display it correctly,  I hope that corrected
	at V6.1

	<unit number>
	unit number available to you is range 0-1999 and they identified
	in a couple of group  in according to decram2.0 implementation
	to avoid confusion of operation.
	 o 0-999 for local node operation (it available on local the node)
	 o 1000-1999 for mscp served unit

	<initialize volume>
	Use standard "initialize" dcl command with "/size=?" qualifier.
	for example;
	  $ INITIALIZE/SIZE=16384/NOHIGHWATER/INDEX=BEGINNING DGA0 volnam

	however, if vms 5.5-2 and earlier running on your system, set volume
	size using provided utility DG$SETCHR before initialize it.
	for example;
	  $ MCR DG$SETCHR DGA0/SIZE=4096
	  $ INITIALIZE/NOHIGHWATER/INDEX=BEGINNING DGA0 volnam

	<volume shadowing>
	Before mount DM psuedo disk unit as member of shadow set, you should 
	change device type. bellow is recommended operation sequence to
	mount shadow set  and restore after the unit unbound from shadow set.
	  $! create psuedo disk unit
	  $ MCR SYSMAN IO CONNECT DGA1000/NOADAPATER
	  $! set volume size and initialize volume
	  $ INITIALIZE/SIZE=16384/NOHIGHWATER/INDEX=BEGINNING DGA1000 volnam
	  $! change device type to meet mscp server
	  $ MCR DG$SETCHR DGA1000/SHADOW
	  $! mount shadow set
	  $ MOUNT/SYS/NOASSIST DSA1000/SHADOW=($1$DGA1000,$3$DGA1000) volnam
	     |
	  $ dismount DSA1000
	  $! restore device type as non shadow device
	  $ MCR DG$SETCHR DGA1000/NOSHADOW
	  $ MOUNT/OVER=(IDENT,SHADOW_MEMBERSHIP) DGA1000

	and convienient examples;
	  $! initialize volume for ramdisk
	  $ INITIALIZE/NOHIGHWATER/INDEX=BEGINNING DGA1000 volnam

	<free physical memoty>
	you may issue following command line to release physical memory space
	which allocated as internal surface buffer.
	  $ INITIALIZE/SIZE=0 DGA1000 volnam

%%
$	p8	=f$ve(p8)
$	return
$!==============================================================================
$!	entry	p1=result file spec
$create_startup:
$	subr
$	savvfy	='f$ve(0)
$	if ""	.nes. f$sea(p1) then delete 'f$el(0,";",p1)';*
$	create	'p1'
$	deck	/dollar=%%
$! dg$startup.com
$!	p1=drive name or shadow set name
$!	p2=volume_label/logical_name/volume_size[/CLUSTER]
$!	p3=list of device name of shadow member (if p1 is shadow set name)
$!	   if p3 omitted, unit which specified in p1 only be mounted,
$!	   othrwise, p1 treated as shadow set name (DSAxxx)
$!	examples:
$!	 @dg$startup dga1000 volnam//8192
$!	 @dg$startup dsa1001 volnam//65536/cluster vax000$dga1001,vax001$dga1001
$! This command procedure will conditionally load the dgdriver pseudo driver,
$! size, initialize and mount it.  This procedure is included as an example
$! with the dgdriver kit.  Include a call to this procedure from your 
$! systartup_vms.com
$	savvfy	='f$ve()
$	savprv	=f$setprv("all")
$	savmsg	=f$en("message")
$	synode	=f$gets("nodename")
$!	sysgen	="$"+f$el(f$gets("arch_name").eqs."Alpha","|","sysgen|sysman io")
$	sysgen	="$"+f$el(f$gets("archflag").eq.14576,"|","sysman io|sysgen")
$	alpha32	=%x38f0 .ne. f$gets("archflag")
$!!!	alpha32	="Alpha" .eq. f$gets("arch_name")
$	if	.not. $status then alpha32=0
$	set	on
$	on	warning then goto 90$
$	on	error then goto 90$
$	on	severe_error then goto 90$
$! activate scs communication server
$	if	f$gets("cluster_member") .and. .not.f$getd("sca0","exists")
$	then
$	 if ""	.nes. f$sea("sys$loadable_images:scsdriver.exe") then -
$	 sysgen	connect sca0/noadapter/driver=scsdriver
$	endif
$! extract calling parameters
$	p2	=f$edit(p2,"upcase,collapse,trim")
$	p3	=f$ed(p3,"upcase,collapse,trim")
$	volsiz	=f$element(2,"/",p2) - "/"	! volume size
$	lognam	=f$el(1,"/",p2) - "/"		! unit logical name
$	volnam	=f$el(0,"/",p2)			! volume name
$	mbrlst	=p3				! list of member of shadow set
$	if ""	.eqs. mbrlst then mbrlst=p1
$	p2	=f$ex(f$loc("/",p2)+1,999,p2)
$	p2	=f$ex(f$loc("/",p2)+1,999,p2)
$	p2	=f$ex(f$loc("/",p2)+1,999,p2)
$	if ""	.nes. p2 then p2="/"+p2		! qualifiers of mount command
$	mntsts	=f$loc("/CL",p2) .lt. f$le(p2)	! if <1>, mount with "/cluster"
$! build shadow set name (apply default value)
$	if ""	.nes. p1
$	then
$	 if	f$getdvi(p1,"exists") then if f$getd(p1,"mnt") then goto ss_devmount
$	else
$	 p1	=f$el(0,":",f$el(0,",",p3)) - "_"
$	 if ""	.eqs. p1 then goto ss_insfarg
$	 if	f$locate("$",p1) .lt. f$length(p1) then p1=f$ex(f$loc("$",p1)+1,99,p1)
$	 if	f$loc("$",p1) .lt. f$le(p1) then p1=f$ex(f$loc("$",p1)+1,99,p1)
$	 if 0	.ge. f$ex(3,9,p1) then goto ss_ivdevnam
$	 p1	="DSA" + f$ex(3,9,p1)
$	endif
$! confirm that system has capability of host-based-shadowing
$	if	"".nes.p3 .and. .not. f$gets("shadowing")/2 then goto ss_cpucap
$	if	f$loc(",",p3) .lt. f$le(p3) then -
$	 if 0	.ge. f$gets("shadow_max_copy") then goto ss_cpucap
$! memory that shadow set already active on other node in cluster.
$	if	mntsts				! be mounted cluster wide?
$	then	mcr dg$setchr 'p1'/vmsnode=mntlst
$	else	mcr dg$setchr 'p1'/mounted=mntlst
$	endif
$	mntlst	=mntlst - ",''synode'" - "''synode'," - synode
$	mntsts	=2*("".nes.mntlst) .or. mntsts
$! extract local shadow set member unit by allocation class and/or host name
$	p7	=f$getsyi("alloclass")
$	p6	=0
$12$:	p0	=f$el(p6,",",mbrlst)
$	if ","	.nes. p0
$	then
$	 p6	=1+p6
$	 if	f$loc("$",p0) .lt. f$le(p0)
$	 then
$	  if	f$el(0,"$",p0) .eqs. synode then p0=f$ex(f$loc("$",p0)+1,99,p0)
$	  if	f$el(1,"$",p0) .eq. p7 then p0=f$el(2,"$",p0)
$	  if	f$loc("$",p0) .lt. f$le(p0) then goto 12$
$	 endif
$	 p4	=p4 + "," + p0
$	 goto	12$
$	endif
$	p4	=f$ex(1,999,p4)	! p4=list of local unit
$! create local unit which is described in shadow member list
$	p6	=0
$	newlst	=""
$22$:	p0	=f$el(p6,",",p4)
$	if	",".eqs. p0 .or. "".eqs.p0 then goto 26$
$	p6	=1+p6
$!	!create psuedo disk unit
$	if	.not.f$getd(p0,"exists")
$	then
$	 if	"".eqs.volsiz .or. "".eqs.volnam then gosub getsiz
$	 sysgen	connect 'p0'/noadapter !/driver=dgdriver
$	 if	.not.f$getd(p0,"exists") then goto ss_nosuchdev
$	endif
$!	!initialize unit and volume
$	if	.not.f$getd(p0,"mnt") .and. 1.ge.f$getd(p0,"maxblock")
$	then
$	 mcr	dg$setchr 'p0'/mounted=p8
$	 if ""	.nes. p8 then goto ss_shdgaster
$	 if	"".eqs.volsiz .or. "".eqs.volnam then gosub getsiz
$	 init	="initialize/nohighwater/index=beginning/noverified"
$	 vax500	=0.eq.alpha32
$	 if	vax500 then vax500=6.gt.f$ex(1,1,f$gets("version")) .or. 58.ne.f$getd(p0,"devtype")
$	 if	vax500				! VAXVMS 5.5 and earlier?
$	 then					! yes,
$	  mcr	dg$setchr 'p0'/size='volsiz'
$	  init	/system 'p0' 'volnam'	!/cluster_size=1
$	 else
$	  init	/system/size='volsiz' 'p0' 'volnam'
$	 endif
$	 if 1	.ge. f$getd(p0,"maxblock") then goto ss_abort
$	 mntsts	=4.or.mntsts
$	 newlst	=newlst+","+f$ex(1,99,f$el(0,":",f$getd(p0,"fulldevnam")))
$	endif
$!	!adjust device type to same to remote mscp served disk (generic_du)
$	if	"".nes.p3 .and. .not.f$getd(p0,"devchar2")/32	! dev$m_mscp
$	then
$	 if	f$getd(p0,"mnt") then goto ss_devmount
$	 mcr	dg$setchr 'p0'/shadow
$	endif
$	goto	22$
$26$:	newlst	=f$ex(1,999,newlst)	! newlst=list of just init'ed local unit
$
$!	symbols here;
$!	p1	=psuedo disk unit name to be mounted (or shadow set master name)
$!	p2	=qualifiers of mount command
$!	p3	=if not null, flag to mount shadow set 
$!	p4	=list of local unit
$!	newlst	=list of unit just initialized
$!	mbrlst	=list of shadow member unit
$!	mntlst	=list of node name that should configure units just initialized
$!	mntsts	=control bit mask
$!		 bit0=1, mount with /cluster qualifier
$!		 bit1=1, the shadow set already active on remote node
$!		 bit2=1, there are local units just initialized
$
$! reconstruct list of shadow memeber unit name (neglect non-existant unit)
$	p6	=0
$	p5	=""
$32$:	p0	=f$el(p6,",",mbrlst)
$	if	",".nes. p0 .and. "".nes.p0
$	then
$	 p6	=1+p6
$	 if	.not. f$getd(p0,"exists") then goto 32$
$	 p5	=p5+","+f$ex(1,99,f$el(0,":",f$getd(p0,"fulldevnam")))
$	 goto	32$
$	endif
$	mbrlst	=f$ex(1,999,p5)		! mbrlst=list of name of shadow member
$	if ""	.eqs. mbrlst then goto ss_nosuchdev
$! make sure all shadow member units are as mscp-served unit
$! [ mntsts: <bit0>cluster mount, <1>shadow set is already active in cluster ]
$! [ devchar2: <bit0>dev$v_clu, <5>dev$v_mscp, <7>dev$v_srv, <22>dev$v_noclu ]
$	if	"".nes.p4 .and. (mntsts .or ("".nes.p3 .and. mntsts/2))
$	then
$	 p6	=0
$42$:	 p0	=f$el(p6,",",p4)
$	 if	",".nes. p0 .and. "".nes.p0
$	 then
$	  p6	=1+p6
$	  if	.not.f$getd(p0,"devchar2") then set device/served 'p0'
$	  if	.not.f$getd(p0,"devchar2") then mcr dg$setchr 'p0'/served
$43$:	  if	f$getd(p0,"devchar2")/%x400000 then got ss_nodevavl !dev$m_noclu
$	  if	f$getd(p0,"devchar2")/128 then goto 42$		! dev$m_srv
$	  wait	0:0:1
$	  goto	43$
$	 endif
$	endif
$! if mscp served unit just created, waiting for it configured on all nodes
$	if	mntsts/4 .and. (mntsts .or. ("".nes.p3 .and. mntsts/2)) then gosub wtconf
$! mount shadow set in whole cluster
$	if	f$getd(p1,"exists") then if 58 .eq. f$getd(p1,"devtype") then p2="/nocache " + p2
$	if ""	.nes. p3 then p3="/shadow=(" + mbrlst +")"
$	mount/system/noassist'p2' 'p1''p3' 'volnam' 'lognam'
$	sts	=$status
$	set	noon
$!	if	f$getd(p1,"mnt") then set volume/prot=w:rwcd 'p1'
$! termination
$fine:	p8	='f$ve(0)
$	p8	=f$setprv(savprv)
$	set mes	'savmsg
$	exit	sts .or. (f$ve(savvfy,savvfy/2)*0)
$	exit
$90$:	sts	=$status
$	goto	fine
$ss_devmount:
$	sts	=108	! ss$_devmount
$	goto	fine
$ss_nosuchdev:
$	sts	=%x908
$	goto	fine
$ss_abort:
$	sts	=44
$	goto	fine
$ss_insfarg:
$	sts	=%x114
$	goto	fine
$ss_badparam:
$	sts	=%x14
$	goto	fine
$ss_ivdevnam:
$	sts	=324
$	goto	fine
$ss_nonlocal:
$	sts	=2288
$	goto	fine
$ss_cpucap:
$	sts	=9236	! ss$_cpucap
$	goto	fine
$ss_shdgaster:
$	hdr	="%"+f$pa(f$en("procedure"),,,"name")+"-"
$	say	hdr,"F-DEVALLOC, device ''f$getd(p0,"fulldevnam")' already allocated as shadow member"
$	say	"-''f$ex(1,99,hdr)'F-DEVALLOC, free it on node ",p8
$ss_nodevavl:
$	sts	=2480	! ss$_nodevavl
$	goto	fine
$!+
$! getsiz - retrieve volume label and size from shadow master
$!	entry	p1=shadow set name
$!		p3=list of device name of shadow member
$!		volnam=volume_label
$!		volsiz=volume_size
$!		p3=list of name of shadow member - required for shadow set mount
$!	return	p8-p6, volsiz,volnam
$!	destroy	none
$!	calling	gosub
$!-
$getsiz:set	noon
$	p8	=p1 + "," + p3
$	p7	=0
$gs2:	p6	=f$el(p7,",",p8)
$	if ","	.nes. p6
$	then
$	 p7	=1+p7
$	 if ""	.eqs. p6 then goto gs2
$	 if	.not. f$getd(p6,"exists") then goto gs2		! configured?
$	 if 1	.ge. f$getd(p6,"maxblock") then goto gs2	! initialized?
$	 if	f$getd(p6,"mnt")
$	 then
$	  gosub	gs4
$	 else
$	  mount/over=id/noassist/nowrite 'p6'
$	  if	.not. $status then goto gs2
$	  gosub	gs4
$	  dismount/nounl 'p6'
$	 endif
$	endif
$	set	on
$	if	"".eqs.volsiz .or. "".eqs.volnam then goto ss_insfarg
$	return
$gs4:	if ""	.eqs. volsiz then volsiz=f$getd(p6,"maxblock")
$	if ""	.eqs. volnam then volnam=f$getd(p6,"volnam")
$	return
$!+
$! wtconf - wait for nodes configure units which just initialized
$! if the shadow set already mounted on other nodes in cluster, psuedo disk
$! units just configured and be joined to shadow set as a member  are served
$! by mscp server since the unit should be added to shadow set on all
$! shadowing nodes.
$! Also, we must assure that psuedo disk unit just created has been configured
$! on all shadowing nodes before beginning of shadow mounting (shadow member
$! addition) operation.  In OpenVMS 6.1 and earlier, When new unit configured
$! on certain node in cluster, the long delay (formally two minutes) required
$! to configure the unit on all nodes in cluster. current host-based-shadowing
$! implementation abandon (crash the host system in shdriver) the shadow member
$! addition process if unit be added to the shadow set is not configured yet
$! on the node.
$!	entry	mntlst=list of node name to be configure new units
$!		newlst=list of unit name to be configured on nodes
$!	return	$status=completion code
$!		result=list of node name which not conformed yet
$!	destroy	result
$!	calling	gosub
$!-
$wtconf:tpf	="temp"+f$getj(0,"pid")
$	p8	=0
$	result	==mntlst
$wc2:	call	confirm_via_scsutl "''result'" 'newlst'
$	if 1	.eq. ($status.and.7) then goto wc4
$	call	confirm_via_sysman 'result' 'newlst'
$	if 1	.eq. ($status.and.7) then goto wc4
$	call	confirm_via_batch 'result' 'newlst'
$wc4:	if	$status
$	then
$	 if ""	.eqs. result then return	! configured on all nodes?
$	 p8	=10+p8				! no, failed
$	 if p8	.gt. 60 then return
$	 wait	0:0:10
$	 goto	wc2
$	endif
$	wait	0:1:0				! sysman and batch unavilable
$	return
$!+
$! confirm that device already configured at remote nodes
$!	entry	p1=list of node name to be configure units
$!		p2=list of unit name should be configured on nodes
$!	return	$status (bit0=sts, bit1=scs comm server unavlailable)
$!		result=list of node name which not confirmed yet
$!	destroy	result
$!	calling	call
$!-
$confirm_via_scsutl:
$	subr
$	set	noon
$	if.not.	f$getd("sca0","exists") then exit %x90f	! nosuchpgm
$	if.not.	f$getd("sca0","avl") then sysgen reload scsdriver
$	p1	=f$ed(p1,"upcase")
$	p2	=f$ed(p2,"upcase")
$	p3	=p2
$	wait	0:0:1
$12:	p6	=f$el(p7,",",p3)
$	if ","	.nes. p6
$	then
$	 p7	=1+p7
$	 p5	=f$ex(1,99,f$el(0,":",f$getd(p6,"fulldevnam")))
$	 mcr	dg$setchr 'p5'/exists="''p1'"
$	 sts	=$status
$	 if	sts .eq. %x908 then goto 12	! ss$_nosuchdev
$	 if	.not.sts then exit sts.or.3	! exit on failure
$	 if	.not. (sts/2)/16 then goto 12	! dev$m_onl
$	 p2	=p2 - ",''p6'" - "''p6'," - p6
$	 goto	12
$	endif
$	if ""	.eqs. p2 then result==""
$	exit	1
$	ends
$!+
$! confirm that device already configured at remote nodes
$!	entry	p1=list of node name to be configure units
$!		p2=list of unit name should be configured on nodes
$!	return	$status (bit0=sts, bit1=sysman unavlailable at remote node
$!		result=list of node name which not confirmed yet
$!	destroy	result
$!	calling	call
$!-
$confirm_via_sysman:
$	subr
$	errflg	=0
$	p1	=f$ed(p1,"upcase")
$	clo/nol	dro
$	clo/nol	dri
$20:	errflg	=errflg .and. 2	! remove all except sysman unavailable flag
$	wait	0:0:1
$	ope/w	dro 'tpf'.tmp
$	wr	dro "$delete ",tpf,".*;*"
$	wr	dro "$define sys$output ''tpf'.tmp"
$	wr	dro "$mcr sysman"
$	wr	dro "set tim 0:0:2"
$	wr	dro "set env/node=(",p1,")"
$	wr	dro ""				! response for password prompt
$	p7	=0
$21:	p6	=f$el(p7,",",p2)
$	if ","	.nes. p6
$	then
$	 wr	dro "do wr sys$output ""//''p7'|''p6'/"",f$getd(""''p6'"",""exists""),""/"",f$gets(""nodename"")"
$	 p7	=1+p7
$	 goto	21
$	endif
$	clo	dro
$	@'tpf'.tmp
$	p1	=""
$	ope/r	dri 'tpf'.tmp
$22:	rea/en=27/er=27 dri rcd
$	if "%"	.nes. f$ex(0,1,rcd) then goto 22
$23:	p6	=f$ex(f$loc(" node ",rcd)+6,9,rcd)
$	if	"%SYSMAN-I-NODERR" .nes. f$el(0,",",rcd) then goto 25
$	errflg	=errflg .or. 2	! node unreachable
$24:	if	f$loc(p6,p1) .ge. f$le(p1) then p1=p1+","+p6
$25:	rea/en=27/er=27 dri rcd
$	if "%"	.eqs. f$ex(0,1,rcd) then goto 23
$	if "/"	.nes. f$ex(0,1,rcd) then goto 25
$	if	"TRUE" .eqs. f$el(3,"/",rcd) then goto 25
$	p6	=f$el(4,"/",rcd)
$	errflg	=errflg .or. 4	! unit not configured yet
$	goto	24
$27:	sts	=$status
$	clo/nol	dri
$	p1	=f$ex(1,999,p1)
$! try more retrieval session
$	if	"".nes.p1 .and. errflg/4
$	then			! device configured on all nodes?
$	 p8	=1+p8		! no,
$	 if 2	.gt. p8 then goto 20
$	endif
$! termination
$	result	==p1
$	if	sts .or. (sts.and.%x0ffff).eq.%x827a then sts=1.or.errflg
$	exit	sts
$	ends
$!+
$! confirm that device already configured on remote nodes
$!	entry	p1=list of node name to be confirmed
$!		p2=list of unit name should be configured on nodes
$!	return	$status (bit0=sts, bit1=batch queue unavlailable for the node)
$!		result=list of node name which not confirmed yet
$!	destroy	result
$!	calling	call
$!-
$confirm_via_batch:
$	subr
$	errflg	=0
$! submit the configuration retrieval procedure in node's batch queue
$11:	p9	=""			! init node list
$	p7	=0			! init pending batch job counter
$	p6	=0			! init node counter
$12:	p5	=f$el(p6,",",p1)	! p1=node
$	if ","	.eqs. p5 then goto 20	! finish
$	p6	=1+p6
$	if	p5.eqs."" .or. p5.eqs.synode then goto 12
$	call	availq 'p5'		! batch queue on node exists?
$	if	.not.$status then got 15! no, error (no batch queue)
$	clo/nol	dro
$	ope/w	dro 'tpf''p5'.tmp
$	wr	dro "$p8='f$ve(0)"
$	wr	dro "$set def ",f$en("default")
$	wr	dro "$delete ",tpf,p5,".tmp;*"
$	p4	=0
$13:	p3	=f$el(p4,",",p2)
$	if ","	.nes. p3
$	then
$	 wr	dro "$wr sys$output ""//''p4'|''p3'/"",f$getd(""''p3'"",""exists""),""/"",f$gets(""nodename"")"
$	 p4	=1+p4
$	 goto	13
$	endif
$	close	dro
$	submit/q='result'/log='f$en("default")''tpf''p5'.log/u=system/noident 'tpf''p5'.tmp
$	if.not.	$status then goto 15
$	p7	=1+p7		! count pending batch job
$	goto	12
$15:	errflg	=2.or. errflg	! mark that batch queue unavailable for node
$	if	f$loc(p5,p9) .ge. f$le(p9) then p9=p9+","+p5
$	goto	12
$! waiting for completion of batch job
$20:	p6	=0
$21:	p6	=1+p6
$	if 10	.lt. p6 then goto 29
$	wait	0:0:1
$	p5	=f$sea("a.a")
$22:	p5	=f$sea(tpf+"*.log")
$	if ""	.eqs. p5 then goto 21
$	if 0	.ge. f$fil(p5,"eof") then goto 22
$	p7	=p7-1			! decrement pending batch job count
$	search/out='tpf'.tmp 'p5' "//"
$	delete	'f$el(0,";",p5)';*
$	clo/nol	dri
$	ope/r	 dri 'tpf'.tmp
$23:	rea/er=27/en=27 dri rcd
$	if	"TRUE" .eqs. f$el(3,"/",rcd) then goto 23
$	p5	=f$el(4,"/",rcd)
$	errflg	=4.or. errflg		! unit not configured yet
$	if	f$loc(p5,p9) .ge. f$le(p9) then p9=p9+","+p5
$27:	clo/nol	dri
$	delete	'tpf'.tmp;*
$	if 0	.lt. p7 then goto 22	! check batch job completion
$29:	p1	=f$ex(1,999,p9)
$	if	"".nes.p1 .and. errflg/4 .and. 0.eq.p7
$	then				! device configured on all nodes?
$	 p8	=1+p8			! no, increment retry count
$	 if 2	.gt. p8 then goto 11	! retry one more
$	endif
$	if ""	.nes. f$sea(tpf+"*.*") then delete 'tpf'*.*;*
$	result	==p1
$	exit	1.or.errflg
$	ends
$!+
$! availq - search available batch queue for the node
$!	entry	p1=node name of queue owner
$!	return	$status (bit0=sts, bit24-16=number of batch queue found)
$!		result=name of available batch queue
$!	destroy	result
$!	calling	call
$!-
$availq:subr
$	savvfy	='f$ve(0)
$	p8	=f$getq("")
$	p8	=0
$12:	p8	=p8+1
$	q'p8	=f$getq("display_queue","queue_name","*","batch")
$	if ""	.nes. q'p8 then got 12
$	sts	=(p8-1) * 65536			! number of batch-q
$14:	p8	=p8-1
$	if 0	.lt. p8
$	then
$!!!	 if	f$getq("display_queue",p3,q'p8,"freeze_context") then got 14
$	 if p1	.nes. f$getq("display_queue","scsnode_name",q'p8,"freeze_context") then got 14
$	 if 0	.eq. (%x40002.and.f$getq("display_queue","queue_status",q'p8,"freeze_context")) then got 14
$	 p6	=f$getq("display_queue","executing_job_count",q'p8,"freeze_context") 
$	 p6	=f$getq("display_queue","job_limit",q'p8,"freeze_context") - p6
$	 if 0	.ge. p6 then got 14
$	 result	== q'p8
$	 sts	=sts .or. 1
$	else	result == q1
$	endi
$	exit	sts .or. %x10000000 + f$ve(savvfy,savvfy/2)*0
$	endsub
%%
$	exit	$status .or. (f$ve(savvfy,savvfy/2)*0)
$	endsub
$!==============================================================================
$!	entry	p1=result file spec
$create_ramfile:
$	subr
$	savvfy	='f$ve(0)
$	if ""	.nes. f$sea(p1) then delete 'f$el(0,";",p1)';*
$	create	'p1'
$	deck	/dollar=%%
$! dg$ramfile.template - create/initialize/mount ramdisk and reinstall images
$! parameter:
$!	p1=unit_name  (or "SIZE" to calicurate total required volume size)
$!	p2=volume_name/logical_name/size  (or "RESTORE" restore original env.)
$!	p3=list of shadow member unit (if P1 is shadow set name)
$! format:
$!	@sys$startup:dg$ramfile 'drive' 'label'/'lognam'/'volsiz'
$!	@sys$startup:dg$ramfile 'drive' RESTORE
$!	@sys$startup:dg$ramfile SIZE
$! example:
$!	@sys$startup:dg$ramfile dga432:  432/drum$432/3000
$!	@sys$startup:dg$ramfile dsa1782: 1782//3000  $1$dga1782,$3$dga1782
$! description:
$! 	this procedure create/initialize/mount psuedo disk specified in P1
$!	(or P3 if it presented) and then move some files  from SYS$SYSROOT
$!	to psuedo disk unit.
$!	1) create/initialize/mount psuedo disk specified in P1 (or P3)
$!	2) create directories [SYSMGR],[SYSEXE],[SYSLIB],[SYSMSG] on volume
$!	   of the psuedo disk
$!	3) copy files from SYS$SYSROOT to created directories on psuedo disk
$!	   volume.
$!	4) redefine system logical name SYS$SHARE,SYS$LIBRARY,SYS$MESSAGE 
$!	   to include directories on psuedo disk volume.
$!	   create SYSUAF,RIGHTSLIST and PROXY to point psuedo disk.
$!	5) reinstall known files which copied to psuedo disk volume.
$
$	savvfy	='f$ve()
$	savprv	=f$setprv("sysnam,phy_io,bypass")
$	savmsg	=f$en("message")
$	instll	="$install/command_mode"
$	synode	=f$gets("nodename")
$	alpha32	=%x38f0 .ne. f$gets("archflag")
$!!!	alpha32	="Alpha" .eq. f$gets("arch_name")
$	if	.not. $status then alpha32=0
$	say	="wr sys$output"
$	hdr	="%"+f$pa(f$en("procedure"),,,"name")+"-"
$	tpf	="temp"+f$getj(0,"pid")
$	set	on
$	on	error then goto 90
$	on	severe_error then goto 90
$	sts	=%x24
$	if.not.	f$privile("sysnam,phy_io,bypass") then goto fine
$	p1	=f$ed(p1,"upcase,collapse")
$	p2	=f$ed(p2,"upcase,collapse")
$	p3	=f$ed(p3,"upcase,collapse")
$	calsiz	="".nes.p1 .and. p1.eqs.f$ex(0,f$le(p1),"SIZE")
$	if	calsiz then goto 54
$	if	"".eqs.p1 .and. "".eqs.p2 then goto er114
$! apply default parameter vaue
$	volsiz	=f$el(2,"/",p2)-"/"	! volume size
$	lognam	=f$el(1,"/",p2)-"/"	! logical name
$	volnam	=f$el(0,"/",p2)		! volume label
$	p1	=f$el(0,":",p1)		! device name
$	if ""	.eqs. p1 then goto er114
$	p2	=f$ex(f$loc("/",p2)+1,99,p2)
$	p2	=f$ex(f$loc("/",p2)+1,99,p2)
$	p2	=f$ex(f$loc("/",p2)+1,99,p2)
$	if ""	.nes. p2 then p2="/"+p2
$	if ""	.eqs. p3 then p2="/over=(shadow_membership)"+p2
$! apply default value for volume size
$	if	"".eqs.volsiz .and. .not.(p2.nes."" .and. p2.nes.f$ex(0,f$le(p2),"RESTORE"))
$	then
$	 @'f$en("procedure") size
$	 sts	=$status
$	 if	.not. sts then goto fine
$	 volsiz	=sts/2+32
$	endif
$	if 0	.eq. f$in(volsiz) then goto er014
$! restore original environment
$	if	f$getd(p1,"exists")
$	then
$	 p1	=f$el(0,":",f$getd(p1,"fulldevnam")) - "_"
$	 call	install_orgimg 'p1'
$	 sts	=$status
$	 if	.not.sts then goto fine
$	 call	lnmdel vcs$ifex   'p1'		! @@@ site specific @@@
$	 call	lnmdel vcs$iodl   'p1'		! @@@ site specific @@@
$	 call	lnmdel sysuaf     'p1'		! @@@ site specific @@@
$	 call	lnmdel rightslist 'p1'		! @@@ site specific @@@
$	else
$	 if	f$loc("$",p1) .lt. f$le(p1)	! device name with hostname?
$	 then					! yes,
$	  if	f$el(0,"$",p1).nes.synode .and. f$el(1,"$",p1).ne.f$gets("alloclass") then goto er8f0
$	  p1	=f$ex(f$loc("$",p1)+1,99,p1)
$	  if	f$loc("$",p1) .lt. f$le(p1) then p1=f$ex(f$loc("$",p1)+1,99,p1)
$	 endif
$	endif
$	if	"".nes.p2 .and. p2.eqs.f$ex(0,f$le(p2),"RESTORE") then goto 90
$	if	f$getd(p1,"exists") then if f$getd(p1,"remote_device") then goto install_from_remote
$! create unit, initialize and mount volume
$	p6	=f$getd(p1,"exists")
$	if	p6 then p6=f$getd(p1,"mnt")
$	if.not.	p6 then @sys$startup:dg$startup 'p1' 'volnam'/'lognam'/'volsiz''p2' 'p3'
$	sts	=$status
$	if.not.	sts then goto fine
$	p1	=f$el(0,":",f$getd(p1,"fulldevnam")) - "_"
$! @@@@@@@@@@@@@@@@@@@ (beginning of site specific portion) @@@@@@@@@@@@@@@@@@@@
$! copy files to psuedo disk
$	if ""	.nes. f$sea(p1+":[000000]sysmgr.dir") then goto 120
$!	save start time of file copy operation in expire_date field
$51:	cre/dir	'p1':[sysmgr] /own=[1,4]/prot=w:re
$52:	set	file/exp="''f$ex(0,7,f$tim())'''f$in(1000+f$ex(0,4,f$cvt()))'''f$ex(11,12,f$tim())'" 'p1':[000000]sysmgr.dir
$!	create directory
$	if ""	.eqs. f$sea(p1+":[000000]sysmgr.dir") then cre/di 'p1':[sysmgr] /own=[1,4]/prot=w:re
$	if ""	.eqs. f$sea(p1+":[000000]sysexe.dir") then cre/di 'p1':[sysexe] /own=[1,4]/prot=w:re
$	if ""	.eqs. f$sea(p1+":[000000]syslib.dir") then cre/di 'p1':[syslib] /own=[1,4]/prot=w:re
$	if ""	.eqs. f$sea(p1+":[000000]sysmsg.dir") then cre/di 'p1':[sysmsg] /own=[1,4]/prot=w:re
$!	if ""	.nes. f$sea(p1+":[sysmgr]*.*") then delete 'p1':[sysmgr...]*.*;*
$!	if ""	.nes. f$sea(p1+":[sysexe]*.*") then delete 'p1':[sysexe...]*.*;*
$!	if ""	.nes. f$sea(p1+":[syslib]*.*") then delete 'p1':[syslib...]*.*;*
$!	if ""	.nes. f$sea(p1+":[sysmsg]*.*") then delete 'p1':[sysmsg...]*.*;*
$!	copy files to psuedo disk
$54:	call	copfil sys$manager 'p1':[sysmgr] SYLOGIN.COM
$	p8	="SYSUAF.DAT,RIGHTSLIST.DAT"	!,DCL"
$	p8	=p8+",VCS$IFEX,VCS$IODL"
$	call	copfil sys$system  'p1':[sysexe] 'p8'
$	p8	="LBRSHR,LIBRTL,LIBRTL2,MTHRTL,TPUSHR,VAXCRTL,DECW$DWTLIBSHR,DECW$TRANSPORT_*,DECW$XLIBSHR,CMA$TIS_SHR"
$	if	alpha32 then p8=p8+",LIBOTS,LIBOTS2"
$	p8	=p8+",VCS$USS,VCS$ENS_ACCESS,VCS$ENSSHR,VCS$ELOG" !,DCLTABLES"
$	call	copfil sys$share   'p1':[syslib] 'p8'
$	p8	="VAXCMSG,DECW$TRANSPORTMSG,DECW$XLIBMSG,TPUMSG"
$	p8	=p8+",VCS$MSG"
$	call	copfil sys$message 'p1':[sysmsg] 'p8'
$	if	calsiz then goto dsiz
$	if ""	.nes. f$sea(p1+":[sysexe]*.*") then set file/own=[1,4]/prot=w:re 'p1':[sysexe...]*.*;*
$	if ""	.nes. f$sea(p1+":[syslib]*.*") then set file/own=[1,4]/prot=w:re 'p1':[syslib...]*.*;*
$	if ""	.nes. f$sea(p1+":[sysmgr]*.*") then set file/own=[1,4]/prot=w:re 'p1':[sysmgr...]*.*;*
$	if ""	.nes. f$sea(p1+":[sysmsg]*.*") then set file/own=[1,4]/prot=w:re 'p1':[sysmsg...]*.*;*
$!	file protection for inspect v2.2b
$	set acl	/ACL=(DEFAULT_PROTECTION,SYSTEM:RWED,OWNER:RWED,GROUP:RE,WORLD:,OPTIONS=PROTECTED+NOPROPAGATE) -
		'p1':[000000]000000.DIR;1
$	set 	protect=(w) 'p1':[SYSEXE]SYSUAF.DAT
$	set acl	/ACL=(ALARM=SECURITY,ACCESS=DELETE+CONTROL+SUCCESS) -
		'p1':[SYSEXE]SYSUAF.DAT
$	set acl	/ACL=(ALARM=SECURITY,ACCESS=WRITE+DELETE+CONTROL+SUCCESS) -
		'p1':[SYSMGR]SYLOGIN.COM
$	set acl	/ACL=(ALARM=SECURITY,ACCESS=WRITE+DELETE+CONTROL+SUCCESS) -
		'p1':[SYSEXE]RIGHTSLIST.DAT
$!	mark for setup completion
$	set	file/exp="31-dec-9999" 'p1':[000000]sysmgr.dir
$! reinstall images and redefine system logicals
$80:	if	0				! modify SYS$SYSROOT?
$	then					! yes,
$	 define/sys/ex/tran=(term,conc) sys$sysroot 'f$tr("sys$sysroot")','p1':,sys$common:
$	else
$	 call	lnmtop sys$share	'p1':[syslib]
$	 call	lnmtop sys$library	'p1':[syslib]
$	 call	lnmtop sys$message	'p1':[sysmsg]
$	endif
$	call	install_newimg 'p1':[sysexe]
$	call	install_newimg 'p1':[syslib]
$	call	install_newimg 'p1':[sysmsg]
$	call	lnmcre sysuaf	'p1':[sysexe]sysuaf.dat
$	call	lnmcre rightslist	'p1':[sysexe]rightslist.dat
$	call	lnmcre vcs$ifex	'p1':[sysexe]vcs$ifex.exe
$	call	lnmcre vcs$iodl	'p1':[sysexe]vcs$iodl.exe
$! restart security_server process to switch rightslist.dat
$	p8	=f$sea(f$pa("rightslist","sys$system:.dat"))
$	if ""	.nes. p8
$	then
$	 if	f$getd(p1,"fulldevnam") .eqs. f$getd(p8,"fulldevnam") then -
$	 call	restart_secure_server
$	endif
$! @@@@@@@@@@@@@@@@@@@@@@ (end of site specific portion) @@@@@@@@@@@@@@@@@@@@@@@
$! delete files of decram product
$!!!	gosub	purge_decram_puroduct
$! termination
$90:	sts	=$status
$fine:	p8	='f$ve(0)
$	set	noon
$	clo/nol	dri
$	if ""	.nes. f$sea(tpf+".*") then delete 'tpf'.*;*
$	p8	=f$setprv(savprv)
$	set mes	'savmsg
$	exit	sts .or. (f$ve(savvfy,savvfy/2)*0)
$	exit
$er908:	sts	=%x908	! ss$_nosuchpgm
$	goto	fine
$er114:	sts	=%x114	! ss$_insfarg
$	goto	fine
$er014:	sts	=%x14	! ss$_badparam
$	goto	fine
$er8f0:	sts	=2288	! ss$_nonlocal
$	goto	fine
$er228:	sts	=%x228	! ss$_timeout
$	goto	fine
$! mount volume on remote device and install files
$install_from_remote:
$	if.not.	f$getd(p1,"mnt") then @sys$manager:dg$startup 'p1' 'volnam'/'lognam'/
$	if ""	.eqs. f$sea(p1+":[000000]sysmgr.dir") then goto 51
$120:	p8	=f$cvt(f$fil(p1+":[000000]sysmgr.dir","edt"))
$	if	"9999-12-31" .eqs. f$ex(0,10,p8) then goto 80
$	p8	=f$st(f$ex(0,4,p8)-1000)+f$ex(4,18,p8)
$	p7	=f$cvt()
$	p6	=(f$ex(11,2,p8)*3600)+(f$ex(14,2,p8)*60)+f$ex(17,2,p8)
$	p5	=(f$ex(11,2,p7)*3600)+(f$ex(14,2,p7)*60)+f$ex(17,2,p7) - p6
$	if	0.gt.p5 .and. f$ex(0,10,p7).gts.f$ex(0,10,p8) then p5=24*3600+p5
$	if 60	.le. p5 then goto 52
$	wait	0:0:2
$	goto	120
$! calicurate total required volume size
$dsiz:	p8	=(filsiz+filcnt+31)/32*32
$	say	hdr,"I-VOLSIZ, ''p8'=((''filsiz'+''filcnt')+31)/32*32 blocks needed for ''filcnt' files"
$	sts	=p8*2+1		! store required volume size in $status<1:31>
$	del/sym/g filsiz
$	del/sym/g filcnt
$	goto	fine
$!+
$!	entry	p1=source directory specification
$!		p2=destination directory specification
$!		p3=list of image file specification
$!-
$copfil:subr
$	set	on
$	on	error then exit
$	on	severe_error then exit
$	p7	=f$ex(f$le(p1)-1,1,p1)
$	if	">".nes.p7 .and. "]".nes.p7 .and. ":".nes.p7 then p1=p1+":"
$	p7	=f$ex(f$le(p2)-1,1,p2)
$	if	">".nes.p7 .and. "]".nes.p7 .and. ":".nes.p7 then p2=p2+":"
$	if	calsiz then goto 50
$!======
$! copy image file to target directory
$!======
$12:	p7	=f$el(p8,",",p3)
$	if ","	.eqs. p7 then exit
$	p8	=1+p8
$	if ""	.eqs. p7 then goto 12
$! add default file type (.EXE)
$	if	alpha32 then if "" .nes. f$tr(p7+"_TV") then p7=f$tr(p7+"_TV")
$	if ""	.nes. f$tr(p7) then p7=f$tr(p7)
$	p5	=""
$14:	p6	=p7
$	if	f$loc("]",p6) .lt. f$le(p6) then p6=f$ex(f$loc("]",p6)+1,99,p6)
$	if	f$loc("]",p6) .lt. f$le(p6) then p6=f$ex(f$loc("]",p6)+1,99,p6)
$	if	f$loc(">",p6) .lt. f$le(p6) then p6=f$ex(f$loc(">",p6)+1,99,p6)
$	if	f$loc(">",p6) .lt. f$le(p6) then p6=f$ex(f$loc(">",p6)+1,99,p6)
$	if	f$loc(":",p6) .lt. f$le(p6) then p6=f$ex(f$loc(":",p6)+1,99,p6)
$	if	"".nes.f$tr(f$el(0,".",p6)) .and. p5.nes.f$el(0,".",p6)
$	then
$	 p5	=f$el(0,".",p6)
$	 p7	=f$tr(p5)
$	 goto	14
$	endif
$	if	f$loc(".",p6) .ge. f$le(p6) then p7=p7+".EXE"
$	p6	=p2+f$pa(p7,,,"name")+f$pa(p7,,,"type")
$	if	f$loc(":",p7) .ge. f$le(p7) then p7=p1+p7
$! remove previous moved image
$!	p7=source file specification
$!	p6=distination file specification
$	if ""	.nes. f$sea(p6)
$	then
$	 p5	=f$getd(p6,"freeblocks")
$	 if	.not. f$fil(p6,"known") then delete 'p6';*
$	 if p5	.le. f$getd(p6,"freeblocks") then goto 12
$	endif
$! move file to ramdisk
$	copy	'p7' 'p2'
$	sts	=$status
$	if.not.	sts then backup/ignore=interlock 'p7' 'p2'
$!!!	if.not.	$status then exit
$	goto	12
$!======
$! calicurate total required volume size
$!======
$50:	p8	=f$in("''filsiz'")
$	p7	=f$in("''filcnt'")
$52:	p5	=f$el(p6,",",p3)
$	if ","	.nes. p5
$	then
$	 p6	=1+p6
$	 if	alpha32 then if "" .nes. f$tr(p5+"_TV") then p5=p5+"_TV"
$	 p5	=f$el(0,";",f$pa(p5,"''p1'.exe"))
$	 p4	=0
$54:	 p4	=1+p4
$	 f'p4'	=f$sea(p5)
$	 if ""	.nes. f'p4'
$	 then
$	  if 1	.ge. p4 then goto 54
$	  p2	=p4-1
$	  if	f'p2' .nes. f'p4' then goto 54
$	 endif
$	 if 1	.ge. p4 then goto 57
$56:	 p4	=p4-1
$	 if 0	.ge. p4 then goto 52
$	 p2	=f$el(0,";",f'p4')
$	 say	hdr,f$fa("I-FILSIZ, !4UL blk for !AS",f$fil(p2,"eof"),p2)
$	 p8	=p8+f$fil(p2,"eof")
$	 p7	=p7+1
$	 goto	56
$57:	 say	hdr,"E-NOSUCHFILE, ''p5' not exists"
$	endif
$	filsiz	==p8
$	filcnt	==p7
$	ends
$!+
$!	entry	p1=directory specification that image to be installed
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$install_newimg:
$	subr
$	p1	=f$pa(p1,,,"device")+f$pa(p1,,,"directory")
$! gather files in the directory of psuedo disk
$12:	p7	=f$sea("''p1'*.*")
$	if ""	.nes. p7
$	then
$	 if p6	.eqs. p7 then goto 14
$	 p8	=p8+","+f$pa(p7,,,"name")
$	 p6	=p7
$	 goto	12
$14:	endif
$	if ""	.eqs. p8 then exit
$! extract install-command line from sys$manager:vmsimages.dat
$	set mes	/nof/nos/noi/not
$	if ""	.nes. f$sea(tpf+".*") then delete 'tpf'.*;*
$	search/match=or/out='tpf'.tmp sys$manager:vmsimages.dat 'f$ex(1,999,p8)'
$	sts	=$status
$	set mes	'savmsg
$	p8	=p8+","
$! reinstall images
$	if 1	.ne. sts then goto 38
$	ope/r	dri 'tpf'.tmp
$32:	rea/er=90/en=37 dri rcd
$	rcd	=f$ed(f$el(0,"!",rcd),"trim,collapse")
$	p7	=f$el(0,"/",rcd)
$	if ""	.eqs. p7 then goto 32
$!	add default file type (.EXE)
$	p6	=""
$34:	p5	=0
$	if	f$loc("]",f$ex(p5,99,p7)) .lt. f$le(f$ex(p5,99,p7)) then p5=1+p5+f$loc("]",f$ex(p5,99,p7))
$	if	f$loc("]",f$ex(p5,99,p7)) .lt. f$le(f$ex(p5,99,p7)) then p5=1+p5+f$loc("]",f$ex(p5,99,p7))
$	if	f$loc(">",f$ex(p5,99,p7)) .lt. f$le(f$ex(p5,99,p7)) then p5=1+p5+f$loc(">",f$ex(p5,99,p7))
$	if	f$loc(">",f$ex(p5,99,p7)) .lt. f$le(f$ex(p5,99,p7)) then p5=1+p5+f$loc(">",f$ex(p5,99,p7))
$	if	f$loc(":",f$ex(p5,99,p7)) .lt. f$le(f$ex(p5,99,p7)) then p5=1+p5+f$loc(":",f$ex(p5,99,p7))
$	p5	=f$ed(f$ex(p5,99,p7),"upcase")
$	if ""	.eqs. p6 then p6=f$el(0,".",p5)
$	if ""	.nes. f$tr(f$el(0,".",p5))
$	then
$	 p7	=f$tr(f$el(0,".",p5))
$	 goto	34
$	endif
$	if	f$loc(".",p5) .ge. f$le(p5) then p7=p7+".exe"
$	if ""	.eqs. f$sea(p7) then goto 32
$!	install the image with new directory specification
$	if ""	.nes. f$tr(p6) then p7=p6
$	if	f$file(p7,"known")
$	then	instll rep 'p7' 'f$ex(f$loc("/",rcd),999,rcd)'
$	else	instll add 'p7' 'f$ex(f$loc("/",rcd),999,rcd)'
$	endif
$!	remove name of processed image from list
$	p6	=","+p6+","
$	if	f$loc(p6,p8) .lt. f$le(p8) then -
$	 p8	=f$ex(0,f$loc(p6,p8),p8)+f$ex(f$loc(p6,p8)+f$le(p6)-1,999,p8)
$	goto	32
$37:	close	dri
$38:	call	care_mthrtl "''p8'"
$	sts	=$status/2
$	if 0	.lt. sts
$	then
$	 p7	=sts+1+f$loc(",",f$ex(sts+1,999,p8))
$	 p8	=f$ex(0,sts,p8)+f$ex(p7,999,p8)
$	endif
$! warning message since some files could not reinstalled
$	if ","	.eqs. f$ex(0,1,p8) then p8=f$ex(1,999,p8)
$	if ","	.eqs. f$ex(f$le(p8)-1,1,p8) then p8=f$ex(0,f$le(p8)-1,p8)
$41:	if	f$loc(",,",p8) .lt. f$le(p8)
$	then
$	 p8	=f$ex(0,f$loc(",,",p8),p8)+f$ex($loc(",,",p8)+1,999,p8)
$	 goto	41
$	endif
$	if ""	.eqs. p8 then goto 90
$	define/user/nolog sys$output 'tpf'.tmp
$	instll	list
$	deas	sys$output
$	set mes	/nof/nos/noi/not
$	search/match=or/out='tpf'.tmp 'tpf'.tmp;-1 'p8'
$	if 1	.ne. $status then goto 90
$	purge	'tpf'.tmp /keep=1
$	p7	=0
$42:	p6	=f$el(p7,",",p8)
$	if ","	.nes. p6
$	then
$	 p7	=1+p7
$	 if ""	.eqs. p6 then goto 42
$	 search/out=_nl: 'tpf'.tmp 'p6'
$	 if 1	.eq. $status then -
$	  say	hdr,"W-REINSTALL, image ''p6' should be reinstalled"
$	 goto	42
$	endif
$! termination
$90:	sts	=$status
$	set	mes 'savmsg
$	clo/nol	dri
$	if ""	.nes. f$sea(tpf+".*") then delete 'tpf'.*;*
$	ends
$!	entry	p1=list of filename that not found in vmsimages.dat
$!	return	none
$!	destroy	none
$!	calling	call
$care_mthrtl:
$	subr
$	p7	=f$loc(","+f$pa("MTHRTL",,,"name")+",",p1)
$	if p7	.ge. f$le(p1) then exit 1
$	p6	=f$el(0,",",f$ex(p7+1,999,p1))
$	p6	=f$el(0,";",f$pa(p6,"SYS$SHARE:.EXE"))
$	if	f$file(p6,"known")
$	then	instll replace 'p6' /open/header/share
$	else	instll add 'p6' /open/header/share
$	endif
$	exit	p7*2+1
$	ends
$!+
$!	entry	p1=device name that image to be deinstalled
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$install_orgimg:
$	subr
$	p1	=f$ed(f$el(0,":",p1),"upcase,collapse")
$	if.not.	f$getd(p1,"exists") then exit %x10000910
$	if.not.	f$getd(p1,"mnt") then exit
$! gather files on ramdisk
$	show	device/file/out='tpf'.tmp 'p1':
$	clo/nol	dri
$	ope/r	dri 'tpf'.tmp
$	p8	=0
$11:	p8	=1+p8
$	f'p8'	=""
$12:	rea/er=90/en=17 dri rcd
$	if	f$loc("[",rcd).ge.f$le(rcd) .or. f$loc("]",rcd).ge.f$le(rcd) then goto 12
$	p7	=f$el(0,";",f$ex(f$loc("[",rcd),99,rcd))
$	if p7	.eqs. "[000000]INDEXF.SYS" then goto 12
$	f'p8'	=f'p8'+","+f$pa(p7,,,"name")
$	if 160	.gt. f$le(f'p8') then goto 12
$	goto	11
$17:	clo	dri
$	if ""	.nes. f'p8' then p8=1+p8
$! remove the directory from system logical name
$	call	lnmend sys$library	'p1':[syslib]
$	call	lnmend sys$share	'p1':[syslib]
$	call	lnmend sys$system	'p1':[sysexe]
$	call	lnmend sys$message	'p1':[sysmsg]
$! reinstall images from sys$sysdevice:
$31:	p8	=p8-1
$	if 0	.ge. p8 then goto 40
$	p7	=f'p8'
$	set mes	/nof/nos/noi/not
$	if ""	.nes. f$sea(tpf+".*") then delete 'tpf'.*;*
$	search/match=or/out='tpf'.tmp sys$manager:vmsimages.dat 'f$ex(1,999,p7)'
$	sts	=$status
$	set mes	'savmsg
$	p7	=p7+","
$	if 1	.ne. sts then goto 36
$	ope/r	dri 'tpf'.tmp
$32:	rea/er=90/en=35 dri rcd
$	rcd	=f$ed(f$el(0,"!",rcd),"trim,collapse")
$	p6	=f$el(0,"/",rcd)
$	if ""	.eqs. p6 then goto 32
$	p5	=0
$	if	f$loc("]",f$ex(p5,99,p6)) .lt. f$le(f$ex(p5,99,p6)) then p5=1+p5+f$loc("]",f$ex(p5,99,p6))
$	if	f$loc("]",f$ex(p5,99,p6)) .lt. f$le(f$ex(p5,99,p6)) then p5=1+p5+f$loc("]",f$ex(p5,99,p6))
$	if	f$loc(">",f$ex(p5,99,p6)) .lt. f$le(f$ex(p5,99,p6)) then p5=1+p5+f$loc(">",f$ex(p5,99,p6))
$	if	f$loc(">",f$ex(p5,99,p6)) .lt. f$le(f$ex(p5,99,p6)) then p5=1+p5+f$loc(">",f$ex(p5,99,p6))
$	if	f$loc(".",f$ex(p5,99,p6)) .ge. f$le(f$ex(p5,99,p6)) then p6=p6+".exe"
$	if ""	.eqs. f$sea(p6) then goto 32
$	if	f$loc(".",p6) .ge. f$le(p6) then p6=p6+".exe"
$	if	f$file(p6,"known")
$	then	instll replace 'rcd'
$	else	instll add 'rcd'
$	endif
$	p6	=","+f$pa(p6,,,"name")+","
$	if	f$loc(p6,p7) .lt. f$le(p7) then -
$	 p7	=f$ex(0,f$loc(p6,p7),p7)+f$ex(f$loc(p6,p7)+f$le(p6)-1,999,p7)
$	goto	32
$35:	clo	dri
$	delete	'tpf'.*;*
$36:	call	care_mthrtl "''p7'"
$	goto	31
$! remove the directory from system logical name
$40:	call	lnmrem sys$library	'p1':[syslib]
$	call	lnmrem sys$share	'p1':[syslib]
$	call	lnmrem sys$system	'p1':[sysexe]
$	call	lnmrem sys$message	'p1':[sysmsg]
$! termination
$90:	sts	=$status
$	clo/nol	dri
$	if ""	.nes. f$sea(tpf+".*") then delete 'tpf'.*;*
$	ends
$!+
$! lnmtop - add directory spec. at top of the logical name
$!	entry	p1=logical name
$!		p2=new directory spec to add
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$lnmtop:subr
$	p2	=f$ed(p2,"upcase,collapse")
$	if ""	.nes. f$tr(p1)
$	then
$	 if	f$tr(p1,,,,,"concealed") then p5=p5+",concealed"
$	 if	f$tr(p1,,,,,"terminal") then p5=p5+",terminal"
$	 if ""	.nes. p5 then p5=p5 + "/translate=(" + f$ex(1,99,p5) +")"
$	 p5	="/table=" + f$tr(p1,,,,,"table_name") + "/" + f$tr(p1,,,,,"access_mode") + p5
$	else
$	 p5	="/system/exec"
$	endif
$12:	p7	=f$tr(p1,,p8)
$	if ""	.nes. p7
$	then
$	 p8	=1+p8
$	 if p7	.nes. p2 then p6=p6+","+p7
$	 goto	12
$	endif
$	define/nolog'p5' 'p1' 'p2''p6'
$	ends
$!+
$! lnmend - add directory spec. at end of the logical name
$!	entry	p1=logical name
$!		p2=new directory spec to add
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$lnmend:subr
$	p2	=f$ed(p2,"upcase,collapse")
$	if ""	.nes. f$tr(p1)
$	then
$	 if	f$tr(p1,,,,,"concealed") then p5=p5+",concealed"
$	 if	f$tr(p1,,,,,"terminal") then p5=p5+",terminal"
$	 if ""	.nes. p5 then p5=p5 + "/translate=(" + f$ex(1,99,p5) +")"
$	 p5	="/table=" + f$tr(p1,,,,,"table_name") + "/" + f$tr(p1,,,,,"access_mode") + p5
$	else
$	 p5	="/system/exec"
$	endif
$12:	p7	=f$tr(p1,,p8)
$	if ""	.nes. p7
$	then
$	 p8	=1+p8
$	 if p7	.eqs. p2
$	 then	p4=1
$	 else	p6=p6+","+p7
$	 endif
$	 goto	12
$	endif
$	if.not.	f$in(p4) then exit
$	p6	=f$ex(1,999,p6)
$	if ""	.nes. p6 then p2=p6+","+p2
$	define/nolog'p5' 'p1' 'p2'
$	ends
$!+
$! lnmrem - remove directory spec. from the logical name
$!	entry	p1=logical name
$!		p2=directory spec to remove
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$lnmrem:subr
$	p2	=f$ed(p2,"upcase,collapse")
$	if ""	.nes. f$tr(p1)
$	then
$	 if	f$tr(p1,,,,,"concealed") then p5=p5+",concealed"
$	 if	f$tr(p1,,,,,"terminal") then p5=p5+",terminal"
$	 if ""	.nes. p5 then p5=p5 + "/translate=(" + f$ex(1,99,p5) +")"
$	 p5	="/table=" + f$tr(p1,,,,,"table_name") + "/" + f$tr(p1,,,,,"access_mode") + p5
$	else
$	 p5	="/system/exec"
$	endif
$12:	p7	=f$tr(p1,,p8)
$	if ""	.nes. p7
$	then
$	 p8	=1+p8
$	 if p7	.nes. p2 then p6=p6+","+p7
$	 goto	12
$	endif
$	if ","	.eqs. f$ex(0,1,p6) then p6=f$ex(1,999,p6)
$	if ""	.nes. p6 then define/nolog'p5' 'p1' 'p6'
$	ends
$!+
$! lnmdel - deassign a logical name
$!	entry	p1=logical name
$!		p2=part of equivalent name of the logical name
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$lnmdel:subr
$	p8	=f$tr(p1)
$	if	f$loc(p2,p8) .ge. f$le(p8) then exit
$	deassign/'f$tr(p1,,,,,"access_mode")/table='f$tr(p1,,,,,"table_name") 'p1'
$	ends
$!+
$! lnmcre - create a executive_mode logical name with system wide
$!	entry	p1=logical name
$!		p2=file specification as equivalent of the logical name
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$lnmcre:subr
$	if	"".eqs.p1 .or. "".eqs.p2 then exit %x114
$	if ""	.eqs. f$sea(p2) then exit
$	p1	=f$ed(p1,"collapse")
$	p5	=f$ex(f$loc("/",p1),99,p1)
$	p1	=f$el(0,"/",p1)
$	if ""	.eqs. p5
$	then
$	 if ""	.nes. f$tr(p1)
$	 then
$	  if	f$tr(p1,,,,,"concealed") then p5=p5+",concealed"
$	  if	f$tr(p1,,,,,"terminal") then p5=p5+",terminal"
$	  if ""	.nes. p5 then p5=p5 + "/translate=(" + f$ex(1,99,p5) +")"
$	  p5	="/table=" + f$tr(p1,,,,,"table_name") + "/" + f$tr(p1,,,,,"access_mode") + p5
$	 else
$	  p5	="/system/exec"
$	 endif
$	endif
$	define/nolog'p5' 'p1' 'p2'
$	ends
$!+
$! purge decram product related files
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$restart_secure_server:
$	subr
$	set	noon
$	if	alpha32 then exit 1
$	secsrv$_servernotactive=%x6eec6fa
$! stop current security server process
$1$:	p7	=0
$2$:	p6	=""
$	p5	=f$context("PROCESS",p6,"PRCNAM","SECURITY_SERVER","EQL")
$	p5	=f$pid(p6)
$	if ""	.nes. p5
$	then
$	 set	security/server=exit
$!	 if	secsrv$_servernotactive .eq. $status then stop/id='p5'
$	 if	.not.$status then stop/id='p5'
$	 if 10	.lt. p7 then exit %x8e8
$	 p7	=1+p7
$	 wait	0:0:1
$	 goto	2$
$	endif
$! restart security server process
$	p7	=0
$	set	security/server=start
$4$:	if 10	.lt. p7 then exit %x8e8
$	wait	0:0:1
$	p7	=1+p7
$	p6	=""
$	p5	=f$context("PROCESS",p6,"PRCNAM","SECURITY_SERVER","EQL")
$	p5	=f$pid(p6)
$	if ""	.eqs. p5 then goto 4$
$! confirm security server process is real working
$	if ""	.eqs. f$tr("sys$node") then exit
$	p8	=1+p8
$	directory/output=nl: 0::
$	if	.not.$status .and. 2.gt.p8 then goto 1$
$	ends
$!+
$! purge decram product related files
$!	return	none
$!	destroy	none
$!	calling	call
$!-
$purge_decram_puroduct:
$	if ""	.nes. f$sea("sys$common:[sysmgr]decram$recover.dat") then delete sys$common:[sysmgr]decram$recover.dat;*
$	if ""	.nes. f$sea("sys$specific:[sysmgr]decram*.*")
$	then
$	 set	mes/nof/nos/noi/not
$	 rename	sys$specific:[sysmgr]decram*.*/exc=decram$recover.dat sys$common:[sysmgr]
$	 sts	=$status
$	 set	mes/f/s/i/t
$	 if 1	.eq. (sts.and.7)
$	 then
$	 purge	sys$sysroot:[sysmgr]decram*.*
$	 rename	sys$common:[sysmgr]decram*.* *.*;1
$	 endif
$	endif
$	if ""	.nes. f$sea("sys$specific:[sysexe]decram*.*")
$	then
$	 rename	sys$specific:[sysexe]decram*.* sys$common:[sysexe]
$	 purge	sys$sysroot:[sysexe]decram*.*
$	 rename	sys$common:[sysexe]decram*.* *.*;1
$	endif
$!	if ""	.nes. f$sea("sys$manager:decram$set*.*") then delete sys$manager:decram$set*.*;*
$!	if ""	.nes. f$sea("sys$system:decram$setram.*") then delete sys$manager:decram$setram.*;*
$!	if ""	.nes. f$sea("sys$system:decram$setshad.*") then delete sys$manager:decram$setshad.*;*
$	if ""	.nes. f$sea("sys$examples:decram*.*") then delete sys$examples:decram*.*;*
$	if ""	.nes. f$sea("sys$examples:ramdisk*.*") then delete sys$examples:ramdisk*.*;*
$	if ""	.nes. f$sea("sys$examples:scratchram*.*") then delete sys$examples:scratchram*.*;*
$	if ""	.nes. f$sea("sys$help:decram*.*") then delete sys$help:decram*.*;*
$	if ""	.nes. f$sea("sys$systest:decram*.*") then delete sys$systest:decram*.*;*
$	return
%%
$	exit	$status .or. (f$ve(savvfy,savvfy/2)*0)
$	endsub
$!==============================================================================
$! build source module
$create_src_utility:
$	subroutine
$	savvfy	='f$ve(0)
$	if ""	.nes. f$sea(p1) then delete 'p1';*
$	create	'p1'
$	deck/dollar=??
	.title	dg$setchr
	.ident	1R1-001
;**************************************************************************
;* NO WARRANTIES OF ANY NATURE ARE EXTENDED BY THE DOCUMENT.  Any product *
;* and related material disclosed herein  are only furnished pursuant and *
;* subject to the terms and conditions of a duly executed Program Product *
;* License  or  Agreement  to purchase  or  lease  equipment.   The  only *
;* warranties made by Digital Equipment Corporation, if any, with respect *
;* to  the  products  described in this  document  are set forth  in such *
;* License  or Agreement.  DIGITAL  cannot accept  any financial or other *
;* responsibility that  may be the result of your use of the  information *
;* in this  document  or software material,  including  direct, indirect, *
;* special, or consequential dameges.                                     *
;* You should be very careful to ensure that  the use of this information *
;* and/or software material complies with the laws, rules and regurations *
;* of the jurisdictions with respect to which it is used.                 *
;* The information contained herein is subject to change without notice.  *
;* Revisions may be issued to advise of such change and/or additions.     *
;**************************************************************************
;
; facility:
;	DECram - psuedo disk within main-storage
;
; description:
;	force enable/disable mscp-served device characteristics of ram_disk
;	or enable/disable extended feature of DECram for shadowing operation.
;
; invoke image:
;	dcl command format;
;	 $ dg$setchr = "$" + f$search("dg$setchr.exe")
;	 $ dg$setchr 'device'/qualifier [, device[/qualifier] ]
;	   or
;	 $ mcr dg$setchr 'device'/qualifier [, device[/qualifier] ]
;	qualifier:
;	 /served - enable as mscp served disk (available for clusterwide)
;	  dev$m_noclu cleared and dev$m_clu applied.
;	 /noserved - disable as mscp served disk
;	  dev$m_clu cleared and dev$m_noclu applied.
;	 /shadow - enable DECram extended feature for shadowing member
;	  dev$m_mscp applied and device type change to dt$_generic_du.
;	 /noshadow - disnable DECram extended feature for shadowing volume
;	  dev$m_mscp cleared and device type change to dt$_ram_disk.
;	 /size=volsiz - set volume size
;	 /device='symbol' - list all devices related to specified device name
;	 /exists=nodnam - confirm that device registered at remote node
;	 /mounted='symbol' - list node names which mount the device
;	 /vmsnode='symbol' - list all active vms nodes in the cluster
;	examples:
;	 $ dg$setchr mda0/size=4096
;	 $ dg$setchr mda0/noserved/noshadow
;	 $ dg$setchr mda1/noserved/noshadow,mda1000/shadow,mda1001
;	 $ dg$setchr sys$manager:decram$recover.dat/flush_database 
;	 $ dg$setchr mda1/mounted='dcl_symbol_name'
;	 $ dg$setchr mda1/vmsnode='dcl_symbol_name'
;	 $ dg$setchr *md*/device='dcl_symbol_name'
;	 $ dg$setchr mda1/exists="vax001,vax002"
;
	.page
	.sbttl	subsystem common definition
;===============================================================================
;*                                                                             *
;*      subsystem common definition                                            *
;*                                                                             *
;===============================================================================
	.default	displacement,word
	decramon=1			; enable decram message interpreter
	shdinfon=1			; enable informational message
	mntnodes=1			; generate volume mounted node list
;;;	.page
	.sbttl	external symbol definition
;===============================================================================
;*                                                                             *
;*      symbol definition                                                      *
;*                                                                             *
;===============================================================================
;
; call external macro
;
	exec_version
	call_jsb_entry
	parmdef
	.if gt	alpha32
	;$aidef			; argument information register (R25) definition
	 $intstkdef		; interrupt/exception frame
	 $chfctxdef		; fixed exception context area
	 $libicbdef		; procedure invocation context block (lib$...)
	;$lkdef			; procedure linkage section
	 $pdscdef		; call frame (alpha)
	 $psigdef		; procedure signature information block
	;$rasedef		; function return signature code definition
	.iff
	 $sfdef			; call frame (vax)
	.endc
	$ccbdef
	$chfdef			; exception argument block
	$clubdef
	$csbdef
	$dcdef
	$ddbdef
	$devdef
	$dscdef
	$dvidef
	$dvsdef			; $device_scan system service
	$dyndef
	$iodef
	$lckdef
	$libclidef
	$lkidef
	$pcbdef
	$sbdef
	$ssdef
	$stsdef
	$syidef
	$ucbdef
	$fabdef
	$namdef
	$rabdef
	$rmsdef
	$xabfhcdef
	char$c_ht=9
	char$c_sp=32
	cli$_abkeyw=^x<038010>
	cli$_valreq=^x<038150>
	.page
	.sbttl	d-bank
;===============================================================================
;*                                                                             *
;*      data bank                                                              *
;*                                                                             *
;===============================================================================
; define record layout of sys$manager:decram$recover.dat
	.save
	.psect	$abs$,abs
	.restore
	.page
	.sbttl	i-bank
;===============================================================================
;*                                                                             *
;*      instruction bank                                                       *
;*                                                                             *
;===============================================================================
	$banki	gbl782
	.enable	local_block
	.=<.+3>/4*4
begin:	.call_entry	max_args=3,home_args=TRUE,-
			input=<>,output=<>,preserve=<R2,R3,R4,R5,R6>
	movab	-256(sp),sp		; sp=command buffer
;=======
; get command line
;=======
	pushab	(sp)			; dsc$a_pointer
	ashl	#7,#1,-(sp)		; dsc$w_length=128
	pushaw	dsc$w_length(sp)	; param-3:result length return
	pushl	#0			; param-2:no prompt required
	pushaq	4*2(sp)			; param-1:result string buffer
	calls	#3,g^lib$get_foreign
	blbc	R0,90$
; xlate command line to uppercase
	pushaq	4*0(sp)
	pushaq	4*1(sp)
	calls	#2,g^str$upcase
	popr	#^m<R2,R3>
; replace tab character to space
	movq	R2,R0
34$:	locc	s^#char$c_ht,R0,(R1)
	beql	40$
	movb	s^#char$c_sp,(R1)
	brb	34$
;=======
; service the device
;=======
40$:	skpc	#char$c_sp,R2,(R3)	; R0=dsc$w_length , R1=dsc$a_pointer
	beql	47$			; abend if no device specified
	pushl	#0			; param-3:field number
;;;	pushab	(R1)			; param-2:buffer of device list
	pushr	#^m<R0,R1>		; param-1:length of devuce list
	pushl	#3			; param-k:
	movq	s^#ss$_normal,R2	; R3=default qualifier mask
42$:	callg	(sp),point_field_by_comma
	tstl	R0			; is there  device in list?
	beql	48$			; no more...
;;;	pushl	R3			; param-3:default qualifier mask
;;;	pushab	(R1)			; param-2:buffer of device name
	pushr	#^m<R0,R1,R3>		; param-1:length of device bname
	calls	#3,b^service_device
	blbc	R0,90$
	movq	R0,R2			; R3=last qualifier mask
	incl	parm_3(sp)		; increment device field index
	brb	42$
47$:	movzwl	#ss$_insfarg,R2		; yes, no device list presented...
48$:	movl	R2,R0			; ss$_normal
;=======
; termination
;=======
90$:	blbc	R0,91$
	blbs	b^lclsts,91$
	movzwl	b^lclsts,R0
91$:	ret
	$bankd_w gbl782
lclsts:	.word	ss$_normal		; assume requested unit is local device
	.dsabl	local_block
;+
;	entry	parm_1=length of device name
;		parm_2=buffer of device name
;		parm_3=function bit mask
;	return	R0=completion code
;		R1=previous qualifier bitmask
;	destroy	R0-R1
;	calling	call
;-
	$banki	gbl782
service_device:
	.call_entry	max_args=3,home_args=TRUE,-
			input=<>,output=<R1>,preserve=<R2,R3,R4,R5,R6>
	pushl	R1			; save R1
	pushaw	parm_1(ap)		; param-2:destination
	pushaq	parm_1(ap)		; param-1:source
	calls	#2,g^str$upcase
	blbc	R0,7$
; extarct device name from command line
	.if gt	alpha32
	 movl	parm_1(ap),R0
	 movl	parm_2(ap),R1
	.iff
	 movq	parm_1(ap),R0
	.endc
	skpc	#char$c_sp,R0,(R1)	; R0=dsc$w_length , R1=dsc$a_pointer
	movq	R0,R4
	locc	#^a"/",R0,(R1)		; qualifier specified?
	pushr	#^m<R0,R1>		; save remain string length and buffer
	subl	R0,R4
	locc	#char$c_sp,R4,(R5)	; R5=buffer of device name
	subl	R0,R4			; R4=length of device name
; get requested qualifiers
;;;	popl	R1			; R1=buffer of qualifiers
	popr	#^m<R0,R1>		; R0=length of qualifiers
	bsbw	getfnc			; R2/R3=descriptor of qualifier value
	blbc	R0,7$
	movl	R1,R6			; R6=qualifier bit mask
	bneq	1$
	movl	parm_3(ap),R6		; default qualifier present?
	beql	9$			; no, give up
1$:	movl	R6,(sp)			; as return R1
; service each qualifer for the device
	pushr	#^m<R2,R3>		; descriptor of qualifier value
	movl	sp,R3			; R3=descriptor of qualifier value
2$:	ffs	#0,#31,R6,R1
	beql	7$
	bbcc	R1,R6,3$
3$:;	pushab	(R5)			; param-4:buffer of device name
;;;	pushl	R4			; param-3:length of device name
;;;	pushl	R3			; param-2:qualifier value
	pushr	#^m<R1,R3,R4,R5>	; param-1:qualifier index
	calls	#4,b^srvdev
	blbs	R0,2$
; termination
;	cmpw	#ss$_devreqerr,R0
;	bneq	7$
;	incl	R0
;	brb	2$
7$:	popr	#^m<R1>			; reload R1
	ret
9$:	movzwl	#ss$_badattrib,R0
;;;	movzwl	#ss$_insfarg,R0
	brb	7$
;+
;	entry	parm_1=qualifier index
;		parm_2=descriptor of qualifier value string
;		parm_3=length of device name
;		parm_4=buffer of device name
;-
	$banki	gbl782
srvdev:	.call_entry	max_args=4,home_args=TRUE,-
			input=<>,output=<R0,R1>,preserve=<R2,R3,R4,R5>
	caseb	parm_1(ap),#1,s^#<3$-1$>/2-1
1$:	.word	f_serv-1$		; 1=served
	.word	f_serv-1$		; 2=noserved
	.word	f_shad-1$		; 3=shadow
	.word	f_shad-1$		; 4=noshadow
	.word	f_size-1$		; 5=size
	.if gt	mntnodes
	 .word	f_mnod-1$		; 6=node name list that volume mounted
	 .word	f_node-1$		; 7=node name list in cluster
	 .word	f_unit-1$		; 8=existant device list
	 .word	f_dvst-1$		; 9=confirm device registered at node
	.endc
3$:	movzwl	#ss$_badattrib,R0
	ret
;=======
; service /SHADOW,/NOSHADOW qualifier -set device type for shadowing
;	parm_1=qualifier index (=3)
;	parm_2=descriptor of dcl symbol to save node names
;	parm_3=length of device name
;	parm_4=buffer of device name
;=======
	.enable	local_block
f_shad:	clrq	-(sp)
;;;	pushl	#0			; param-5:nullarg
	clrq	-(sp)			; param-4:
;;;	pushl	#0			; param-3:
	pushaw	4*3(sp)			; param-2:chan
	pushaq	parm_3(ap)		; param-1:devnam
	calls	#5,g^sys$assign
	blbc	R0,7$
	popr	#^m<R2>			; R2=channel number
; confirm that device is local device
	pushl	R2			; param-1:channel number
	calls	#1,confirm_localdev
	blbc	R0,7$
; informational message
	.if gt	shdinfon
	 blbc	parm_1(ap),2$		; /shadow qualifier?  no,jump
	 pushl	R2			; param-1:channel number
	 calls	#1,ucb_from_channel
	 blbc	R0,7$
	 pushl	R1			; param-1:ucb
	 calls	#1,chk_hbs_environment
2$:	.endc
; update characteristics
	clrq	-(sp)			; sractch for iosb
	pushl	#<dt$_ram_disk@8>!1	; parameter for noshadow
	blbc	parm_1(ap),4$		; /shadow qualifier?
	movb	s^#dt$_generic_du,1(sp)	; yes,
4$:;	pushl	#0			; param-12:p6
	clrq	-(sp)			; param-11:p5
;;;	pushl	#0			; param-10:p4
	clrq	-(sp)			; param-9:p3
	pushl	#0			; param-8:p2
	pushaq	4*5(sp)			; param-7:p1
;;;	pushl	#0			; param-6:astprm
	clrq	-(sp)			; param-5:asradr
	pushaq	4*9(sp)			; param-4:iosb
	pushl	#io$_setchar		; param-3:func
	pushl	R2			; param-2:chan
	pushl	#0			; param-1:efn
	calls	#12+1,g^sys$qiow
	blbc	R0,5$
	movzwl	(sp),R0
	blbs	R0,7$
5$:	.if gt	decramon;;;;;;;;;;;;;;;;;
	 cmpw	#ss$_illiofunc,R0	; request to MDA1000 thru MDA1999? 
	 bneq	7$			; yes, maybe
	 pushl	R2			; param-1:chan
	 calls	#1,b^10$
	 movw	R0,(sp)			; return completion code in iosb
	.endc	;;;;;;;;;;;;;;;;;;;;;;;;;
7$:	brw	r2dsgn			; R2=channel number
;+
; 10$ - analyze failed completion code of DECram 2.0 for operator
;       check unit number of target device is 1000 thru 1999
;	entry	parm_1=channel number
;-
	.if gt	decramon;;;;;;;;;;;;;;;;;
10$:	.call_entry	max_args=1,home_args=TRUE,-
			input=<R0>,output=<R0>,scratch=<>,preserve=<>
	pushr	#^m<R0,R1>		; save R0,R1
;;;	pushl	#0			; unit number return here
	clrq	-(sp)			; unit characteristics return here
;;;	pushl	#0			;
	clrq	-(sp)
	pushal	4*3(sp)
	pushl	#<dvi$_unit@16>!4	;
	pushl	#0
	pushal	4*5(sp)
	pushl	#<dvi$_devchar@16>!4	;
;;;	pushl	#0			; param-8:nullarg
	clrq	-(sp)			; param-7:astprm
;;;	pushl	#0			; param-6:astadr
	clrq	-(sp)			; param-5:iosb
	pushal	4*4(sp)			; param-4:itmlst
	pushl	#0			; param-3:devnam
	pushl	parm_1(ap)		; param-2:chan
	pushl	#0			; param-1:efn
	calls	#8+7,g^sys$getdviw
	blbc	R0,17$			; R0=device characteristic
	popr	#^m<R0,R1>		; R1=unit number
	cmpw	#1000,R1
	bgtru	11$
	cmpw	#1999,R1
	bgequ	13$
11$:	putasc	b^19$
	movzwl	#ss$_devreqerr,(sp)
	brb	17$
13$:	bbc	#dev$v_mnt,R0,17$	; volume mounted?
	movzwl	#ss$_devmount,(sp)
17$:	popr	#^m<R0,R1>
	ret
	$bankd_r gbl782
19$:	.ascic	"%DECRAM-F-DEVREQERR, shadow qualifier allowed only unit 1000-1999"
	.endc	;;;;;;;;;;;;;;;;;;;;;;;;;
	.dsabl	local_block
;=======
; service /SERVED,/NOSERVED qualifier
;	parm_1=qualifier index (1)
;	parm_2=descriptor of dcl symbol to save node names
;	parm_3=length of device name
;	parm_4=buffer of device name
;=======
	.enable	local_block
	$banki	gbl782
; get ucb address of taregt device (mda0)
f_serv:	clrq	-(sp)
;;;	pushl	#0			; param-5:nullarg
	clrq	-(sp)			; param-4:
;;;	pushl	#0			; param-3:
	pushaw	4*3(sp)			; param-2:chan
	pushaq	parm_3(ap)		; param-1:devnam
	calls	#5,g^sys$assign
	blbc	R0,3$
	popr	#^m<R2>			; R2=channel
; confirm that device is local device
	pushl	R2			; param-1:channel number
	calls	#1,confirm_localdev
	blbc	R0,3$
; adjust device characteristics
	pushl	R2			; param-1:
	calls	#1,ucb_from_channel
	blbc	R0,3$
	pushl	parm_1(ap)		; param-2:enable/disable flag
	pushl	R1			; param-1:ucb
	pushl	#2			; param-k:
	pushab	(sp)			; arglst
	pushab	b^10$			; routin
	calls	#2+3,g^sys$cmkrnl	; R1=previous contents of ucb$l_devchar2
; termination
3$:	brw	r2dsgn			; R2=channel number
;+
; 10$ - adjust device characteristics (ucb$l_devchar2) to served by mscp
;	entry	parm_1=address of ucb
;		parm_2=enable/disable flag (bit0=1,enable)
;	return	R0=completion code
;	destroy	R0
;	calling	call (cmkrnl)
;-
10$:	.call_entry	max_args=2,home_args=TRUE,-
			input=<>,output=<>,scratch=<>,preserve=<R1,R2,R3,R4>
;;;	movab	contingency,sf$a_handler(fp)
	movl	parm_1(ap),R2		; R2=ucb
	blbc	parm_2(ap),16$		; "set device/served" request?  no,jump
; set device characteristics as "set device/served"
	bicl	#dev$m_noclu,ucb$l_devchar2(R2)
	bisl	#dev$m_clu,ucb$l_devchar2(R2)
	movl	ucb$l_ddb(R2),R0	; R0=ddb
	tstl	ddb$l_allocls(R0)	; allocation class sepecified?
	bneq	11$			; yes, bypass
	movl	g^clu$gl_allocls,ddb$l_allocls(R0)
; set media-id of ram disk to "DG DG01"
11$:	tstl	ucb$l_media_id(R2)	; media id already set?
	bneq	14$			; yes, skip
	.if gt	alpha32
	 subl	#8,sp
	 movw	ddb$t_name_str(R0),0(sp); put two chars as device ident
	.iff
	 movq	ddb$t_name_str(R0),-(sp); put two chars as device ident
	.endc
;;;	movl	#^a/RAM/,2(sp)		; put three chars as media ident
;;;	movl	#^a/DM /,2(sp)		; put three chars as media ident
	movw	0(sp),3(sp)		; put two chars as device ident
	movb	#^a/ /,2(sp)
	movab	(sp),R3			; R3=buffer of source string
	clrl	R4
	movl	#5,R0			; R0=length of source string (always 5)
12$:	ashl	#5,R1,R1		; erase five lsb of result storage
	subb3	#^a/@/,(R3)+,R4		; pickup a char source buffer
	bicb	#^x<E0>,R4		; extract only five lsb
	bisl	R4,R1			; merge to previous character
	sobgtr	R0,12$
	ashl	#7,R1,R1		; clear seven least-significant-bits
	bisl3	#1,R1,ucb$l_media_id(R2);
; termination
14$:	movl	#ss$_normal,r0
	ret
; set device characteristics as "set device/noserved"
16$:	bicl	#dev$m_clu,ucb$l_devchar2(R2)
	bisl	#dev$m_noclu,ucb$l_devchar2(R2)
	brb	14$
	.dsabl	local_block
;=======
; service /SIZE qualifier - set volume size (total volume capacity)
;	parm_1=qualifier index (5)
;	parm_2=value string descriptor of last valued qualifier
;	parm_3=length of device name
;	parm_4=buffer of device name
;========
f_size:	pushal	-(sp)			; param-2:address of result storage
	pushl	parm_2(ap)		; param-1:descriptor of binary string
	calls	#2,g^ots$cvt_tu_l	; xlate qualifier value to binary
	popr	#^m<R3>			; R3=volume size in block
	blbc	R0,7$
; assign the device
	clrq	-(sp)
;;;	pushl	#0			; param-5:nullarg
	clrq	-(sp)			; param-4:mbxnam
;;;	pushl	#0			; param-3:acmode
	pushaw	4*3(sp)			; param-2:chan
	pushaq	parm_3(ap)		; param-1:devnam
	calls	#5,g^sys$assign
	popr	#^m<R2>			; R2=channel number
	blbc	R0,7$
; confirm that device is local device
	pushl	R2			; param-1:channel number
	calls	#1,confirm_localdev
	blbc	R0,7$
; set volume valid
	clrq	-(sp)			; p5,p6
	clrq	-(sp)			; p3,p4
	clrq	-(sp)			; p1,p2
;;;	pushl	#0			; astprm
	clrq	-(sp)			; astadr
	pushl	#0			; iosb
	pushl	s^#io$_packack		; func
	pushl	R2			; chan
	pushl	#0			; efn
	calls	#12,g^sys$qiow
	blbc	R0,7$
; set volume size
	clrq	-(sp)			; p6
;;;	pushl	#0			; p5
	clrq	-(sp)			; p4
;;;	pushl	#0			; p3
	pushl	#0			; p2
	pushl	R3			; p1, volume size in block
;;;	pushl	#0			; astprm
	clrq	-(sp)			; astadr
	pushl	#0			; iosb
	pushl	s^#io$_format		; func
	pushl	R2			; chan
	pushl	#0			; efn
	calls	#12,g^sys$qiow
; termination
7$:;;;	brb	r2dsgn			;
r2dsgn:	pushr	#^m<R0,R1>		;
	$cancel_s chan=R2		;
	$dassgn_s chan=R2		;
	popr	#^m<R0,R1>		;
	ret
;=======
; service /EXISTS qualifier - confirm that device registered at remote node
;	entry	parm_1=qualifier index (=9)
;		parm_2=descriptor of nodename list
;		parm_3=length of device name
;		parm_4=buffer of device name
;	return	R0=completion code (bit0:sts, 31-2=ucb$l_sts)
;=======
	.if gt	mntnodes;;;;;;;;;;;;;;;;; generate volume mounted node
	.enable	local_block
	scdr_k_dev=2			; sense data index (ucb contents of device)
	$bankd_r gbl782
1$:	.ascii	/SCA0/			; must 4 char
	$banki	gbl782
f_dvst:	movab	-280(fp),sp		; sp=i/o buffer
; remove leading and trailing brackets from nodename list
	movl	parm_2(ap),R2
	.if gt	alpha32
	 movzwl	dsc$w_length(R2),R2
	 movl	dsc$a_pointer(R2),R3
	.iff
	 movq	dsc$w_length(R2),R2
	.endc
	cmpb	#^a/"/,(R3)
	bneq	2$
	incl	R3
	subl	#1+1,R2			; ignore leading and trailing brackets
; assign scs communication server "sca0"
2$:	pushab	1$			; dsc$a_pointer
	pushl	s^#f_dvst-1$		; dsc$w_length
	pushl	#0			; param-5:nulllarg
;;;	pushl	#0			; param-4:mbxnam
	clrq	-(sp)			; param-3:acmode
	pushaw	4*5(sp)			; param-2:chan
	pushaq	4*4(sp)			; param-1:devnam
	calls	#5+2,g^sys$assign
	popr	#^m<R4>			; R4=channel number
	cmpw	#ss$_nosuchdev,R0
	bneq	3$
	movzwl	#ss$_noobjsrv,R0
3$:	blbc	R0,7$
;
; get device characteristicas of the device at remote node
;	R2=length of nodename list
;	R3=buffer of nodename list
;	R4=channel to SCA0:
;	sp=i/o buffer
;
; put target device name in i/o buffer
	mcoml	#0,R5			; init save storage for device status
4$:	.if gt	alpha32
	 movl	parm_3(ap),R0
	 movl	parm_4(ap),R1
	 movb	R0,0+<4*4>(sp)
	 movl	(R1)+,01+<4*4>(sp)
	 movl	(R1)+,05+<4*4>(sp)
	 movl	(R1)+,09+<4*4>(sp)
	 movl	(R1)+,13+<4*4>(sp)
	.iff
	 movq	parm_3(ap),R0
	 movb	R0,0+<4*4>(sp)
	 movq	(R1)+,1+<4*4>(sp)
	 movq	(R1)+,9+<4*4>(sp)
	.endc
; build descriptor of node name
	locc	#^a/,/,R2,(R3)
	subl	R0,R2
	.if gt	alpha32
	 movl	R2,4*0(sp)		; put nodename descriptor
	 movl	R3,4*1(sp)
	.iff
	 movq	R2,4*0(sp)
	.endc
	movq	R0,R2			; R2,R3=descriptor of remain node list
; get ucb address from remote node
;	4*4(sp)=i/o buffer
;	3*4(sp)=iosb
;	2*4(sp)=iosb
;	1*4(sp)=pointer to node name
;	0*4(sp)=length of node name string
	movl	s^#scdr_k_dev,R0	; R0=sense data type (ucb contents of device)
	.iif gt	alpha32, movl sp,R1	; R1=parameter table
	bsbb	10$
	blbc	R0,7$			; check i/o status
;
;	0*4(sp)=descriptor of nodename
;	1*4(sp)=descriptor of nodename
;	2*4(sp)=iosb
;	3*4(sp)=iosb
;	4*4(sp)=i/o buffer - zero (contents of 'peek' address)
;	5*4(sp)=i/o buffer - ucb address
;	6*4(sp)=i/o buffer - contents of ucb
;
	ashl	#-16,R0,R0
	mcoml	ucb$l_sts+<4*6>(sp),R1
	cmpw	#ucb$l_sts+4,R0		; "ucb$l_sts" copied from remote node?
	blequ	6$			; yes,
	movl	5*4(sp),R0		; R0=address of ucb at remote node
	movab	ucb$l_sts(R0),R0	; R0=system va at remote node
	.iif gt	alpha32, movl sp,R1	; R1=parameter table
	bsbb	10$
	blbc	R0,7$
	movzwl	R1,R0			; check auxiliary status for 'peek' data
	blbc	R0,7$
	mcoml	4*4(sp),R1
6$:	bicl	R1,R5			; save ucb$l_sts
	incl	R3			; skip field separate (comma) char
	sobgtr	R2,4$			; try next device
; termination
7$:	pushr	#^m<R0,R1>
	$cancel_s chan=R4
	$dassgn_s chan=R4		; free channel
	popr	#^m<R0,R1>
	blbc	R0,9$			; successfully completed?
	ashl	#1,R5,R0		; yes, save ucb$l_sts in R0
	incl	R0			; ss$_normal
9$:	ret
;+
; 10$ - sense data from remote node
;	entry	R0=sense data type
;		R1=parameter table (alpha vms)
;		R4=channel number
;		5*4(sp)=4*4(R1)=i/o buffer
;		4*4(sp)=3*4(R1)=iosb
;		3*4(sp)=2*4(R1)=iosb
;		2*4(sp)=1*4(R1)=buffer to node name string
;		1*4(sp)=0*4(R1)=length of node name string
;		0*4(sp)=caller
;	return	R0
;	destroy	R0-R1
;	calling	jsb
;-
10$:	.jsb_entry input=<R0,R1,R4>,output=<>,scratch=<R1>,preserve=<>
	.if gt	alpha32
	 pushab	4*2(R1)		; save address of iosb
;;;	 pushl	#0		; p6
	 clrq	-(sp)		; p5
	 pushl	R0		; p4, sense data index (ucb contents of device)
	 pushab	0*4(R1)		; p3, descriptor of nodename
	 movzbl	#255,-(sp)	; p2,
	 pushab	4*4(R1)		; p1, i/o buffer
;;;	 pushl	#0		; param-6:astarg
	 clrq	-(sp)		; param-5:astadr
	 pushab	4*2(R1)		; param-4:iosb
	 pushl	s^#io$_sensemode; param-3:func
	 pushl	R4		; param-2:chan
	 pushl	#0		; param-1:efn
	 calls	#12,g^sys$qiow
	 popr	#^m<R1>		; R1=address of iosb
	 blbc	R0,11$
	 movl	(R1)+,R0	; load iosb contents
	 movl	(R1)+,R1
	.iff
;;;	 pushl	#0		; p6
	 clrq	-(sp)		; p5
	 pushl	R0		; p4, sense data index (ucb contents of device)
	 pushaq	4*4(sp)		; p3, descriptor of nodename
	 movzbl	#255,-(sp)	; p2,
	 pushab	4*10(sp)	; p1, i/o buffer
;;;	 pushl	#0		; param-6:astarg
	 clrq	-(sp)		; param-5:astadr
	 pushaq	4*11(sp)	; param-4:iosb
	 pushl	s^#io$_sensemode; param-3:func
	 pushl	R4		; param-2:chan
	 pushl	#0		; param-1:efn
	 calls	#12,g^sys$qiow
	 blbc	R0,11$
	 movq	4*3(sp),R0	; load iosb contents
	.endc
11$:	rsb
	.dsabl	local_block
	.endc	;;;;;;;;;;;;;;;;;;;;;;;;;
;=======
; service /DEVICE qualifier - list all existant device
;	parm_1=qualifier index (=8)
;	parm_2=descriptor of dcl symbol to save node names
;	parm_3=length of device name (wildcard included)
;	parm_4=buffer of device name
;========
	.enable	local_block
	.if gt	mntnodes;;;;;;;;;;;;;;;;; generate volume mounted node
f_unit:	ashl	#11,#1,R0		; R0=2048
	subl	R0,sp
	pushab	(sp)			; dsc$a_pointer
	pushl	R0			; dsc$w_length
	pushaq	(sp)			; param-2:descriptor of result buffer
	pushaq	parm_3(ap)		; param-1:descriptor of source device
	calls	#2+1,b^2$		; R1=length of rest string
	brw	24$
2$:	.call_entry	max_args=2,home_args=TRUE,-
			input=<>,output=<R1>,preserve=<R2,R3,R4,R5,R6,R7,R8>
	.if gt	alpha32
	 movl	parm_1(ap),R4
	 movl	parm_2(ap),R5
	.iff
	 movq	parm_1(ap),R4
	.endc
	movl	dsc$a_pointer(R5),R2
; scan all registered devices with the match-string
	pushl	s^#dc$_disk		; search criteria (device class)
;;;	pushl	#0
	clrq	-(sp)
	pushal	4*2(sp)
	pushl	#<dvs$_devclass@16>!4	; item list (search criteria)
	clrq	-(sp)			; context
3$:	pushab	(R2)			; dsc$a_pointer
	pushl	#63			; dsc$w_length
	pushaq	4*2(sp)			; param-5:contxt
	pushl	#0 ;pushal 4*5(sp)	; param-4:itmlst
	pushaq	(R4)			; param-3:search_devnam
	pushaw	4*3(sp)			; patam-2:retlen
	pushl	(sp)			; param-1:return_devnam
	calls	#5,g^sys$device_scan
	popr	#^m<R2,R3>
	blbc	R0,7$
	movb	#^a/,/,(R3)		; put a delimiter to separate unit name
; remove prefixed local host name from device name string
	.if gt	1;;;;;;;;;;;;;;;;;;;;;;;;
	 cmpb	#^a/$/,1(R3)		; device name with alocation class?
	 beql	6$			; yes, bypass
	 locc	#^a/$/,R2,(R3)		; host name prefixed?
	 beql	6$			; no, bypass
	 subl3	R0,R2,R6		; R6=length of host name
	 movab	g^scs$gb_nodename,R7
	 movab	1(R3),R8
	 decl	R6
4$:	 cmpb	(R7)+,(R8)+		; local device?
	 bneq	6$			; no,
	 sobgtr	R6,4$
	 addl3	R0,R3,R2
	 cmpb	(R1)+,(R3)+		; neglect "$" character
	 decl	R0			; decrement length for "$" character
5$:	 movb	(R1)+,(R3)+
	 sobgtr	R0,5$
	 sobgtr	R2,3$			; always jump
	.endc	;;;;;;;;;;;;;;;;;;;;;;;;;
; update result buffer pointer
6$:	addl	R3,R2
	sobgtr	R2,3$			; always jump
; scan terminated
7$:	incl	dsc$a_pointer(R5)	;
	subl3	dsc$a_pointer(R5),R3,R1	; R1=length of result string
	bgeq	8$
	incl	R1
8$:	cmpw	#ss$_nomoredev,R0	;
	bneq	9$			;
	incl	R0			;
9$:	ret
;=======
; service /VMSNODE qualifier - list all active vms nodes in cluster
;	parm_1=qualifier index (=7)
;	parm_2=descriptor of dcl symbol to save node names
;	parm_3=length of device name (not used)
;	parm_4=buffer of device name (not used)
;========
max_mntnod=64
;+
;	entry	parm_1=buffer to store node names
;	return	R1=length of node name list
;-
11$:	.call_entry	max_args=1,home_args=TRUE,-
			input=<>,output=<R1>,scratch=<>,preserve=<R2,R3,R4>
;;;	movab	contingency,sf$a_handler(fp)
	movl	parm_1(ap),R1
	movaq	g^scs$gq_config,R2	; listhead of known system chain
	movl	(R2),R3			; R3=sb of local node
	movl	g^clu$gl_club,R0	; this is cluster node
	beql	13$			; no,
	bbc	#club$v_cluster,club$l_flags(R0),13$ ; jump if not in cluster
12$:	cmpw	#^a/VM/,sb$t_swtype(R3)	; vms node?
	bneq	16$			; no, bypass if uda or hsc
	movl	sb$l_csb(R3),R0		; point to cluster-system-block
	bgeq	16$
	bbc	#csb$v_member,csb$l_status(R0),16$ ; node available?
13$:	movab	sb$t_nodename(R3),R4	; point to node name
	movzbl	(R4)+,R0		; yes,
14$:	movb	(R4)+,(R1)+
	sobgtr	R0,14$
	movb	#^a/,/,(R1)+
16$:	movl	sb$l_flink(R3),R3
	bgeq	18$
	cmpl	R2,R3
	bneq	12$
18$:	movl	#ss$_normal,R0
	subl	parm_1(ap),R1
	beql	19$
	decl	R1
19$:	ret
;
;	parm_1=qualifier index (6)
;	parm_2=descriptor of dcl symbol to save node names
;	parm_3=length of device name
;	parm_4=buffer of device name
;
f_node:	moval	-max_mntnod*8(sp),sp
	pushab	(sp)			; param-1:buffer to store node names
	pushl	#1			; param-k:
	pushab	(sp)			; arglst
	pushab	b^11$			; routin
	calls	#2+1,g^sys$cmkrnl
24$:	blbc	R0,29$
; set nodename list in the dcl symbol
	cmpw	#255,R1			; valid string length for dcl symbol?
	bgequ	25$			; yes, continue
	movzbl	i^#255,R1		; truncate it
	movzwl	i^#ss$_bufferovf&^x0fffe,R0
25$:;;;	pushab	(sp)			; dsc$a_pointer
;;;	pushl	R1			; dsc$w_length
	pushr	#^m<R0,R1>		; save completion code
	pushl	s^#lib$k_cli_local_sym	;
	pushal	4*0(sp)			; param-3=address of table indicator
	pushaq	4*3(sp)			; param-2=descriptor of value
	pushl	parm_2(ap)		; param-1=descriptor of symbol
	calls	#3,g^lib$set_symbol
	blbs	4(sp),27$
	movl	4(sp),R0
27$:	ret
29$:	cmpw	#ss$_nopriv,R0
	bneq	27$
	movzwl	#ss$_nocmkrnl,R0
	brb	27$
;=======
; service /MOUNTED qualifier - list all nodes which mount volume on the unit
;	parm_1=qualifier index (=6)
;	parm_2=descriptor of dcl symbol to save node names
;	parm_3=length of device name
;	parm_4=buffer of device name
;========
f_mnod:	moval	-max_mntnod*<4*3>(sp),sp
	pushal	(sp)			; param-2:longword array to store csid
	pushaq	parm_3(ap)		; param-1:descriptor of device name
	calls	#2,mounted_csid
	blbc	R0,27$
	cmpw	#ss$_vcclosed!1,R0	; is this cluster member?
	bneq	38$			; yes,
	bbs	#dev$v_mnt,R1,f_node	; volume mounted?
	clrl	R1			; no,
38$:	tstl	R1			; node which mount volume exists?
	beql	24$			; no,
	pushab	max_mntnod*4(sp)	; param-3:buffer to store node names
	pushal	4(sp)			; param-2:csid longword array
	pushl	R1			; param-1:number of csid
	pushl	#3			; param-k:
	pushab	(sp)			; arglst
	pushab	b^40$			; routin
	calls	#2+3,g^sys$cmkrnl
	brb	24$
;+
; 40$ - list node name of specified csid
;	entry	parm_1=number of csid
;		parm_2=csid array
;		parm_3=buffer to store node names
;	return	R1=length of node name list
;	destroy	R0-R1
;	calling	call (cmkrnl)
;-
40$:	.call_entry	max_args=3,home_args=TRUE,-
			input=<>,output=<R1>,scratch=<>,preserve=<R2,R3,R4,R5>
;;;	movab	contingency,sf$a_handler(fp)
	.if gt	alpha32
	 movl	parm_1(ap),R1		; R1=number of csid stored
	 movl	parm_2(ap),R2		; R2=longword array csid stored
	.iff
	 movq	parm_1(ap),R1		; R1=number of csid stored
	.endc
	movl	parm_3(ap),R3		; R3=result buffer
	movl	g^clu$gl_clusvec,R4	; R4=cluster vector
	movl	g^clu$gl_club,R0	; this is cluster node
	beql	41$			; no,
	bbs	#club$v_cluster,club$l_flags(R0),44$ ; jump if in cluster
41$:	sobgeq	R1,49$			; any csid listed?
	brb	45$			; no, normal exit
42$:	movl	(R2)+,R5		; retrieve csid
	beql	49$			; exit with ss$_badparam
;;;	lock	LOCKNAME=SCS,-		; Lock SCS database
;;;		PRESERVE=NO		; Don't preserve R0
	movzwl	R5,R0			; get NIX (node Index) from CSID
	cmpw	R0,g^clu$gw_maxindex	; is NIX in valid range?
	bgequ	47$			; no, abend
	movl	(R4)[R0],R0		; get CSB address
	bgeq	47$			; jump if unused vector
	cmpl	R5,csb$l_csid(R0)	; get the CSID
	bneq	47$
	movl	csb$l_sb(R0),R5
	bgeq	47$
;;;	unlock	LOCKNAME=SCS,-		; Unlock SCS database
;;;		NEWIPL=#0,-		; Drop IPL to touch argument list
;;;		PRESERVE=NO		; Don't preserve R0
	movab	sb$t_nodename(R5),R5
	movzbl	(R5)+,R0
43$:	movb	(R5)+,(R3)+
	sobgtr	R0,43$
	movb	#^a/,/,(R3)+
44$:	sobgeq	R1,42$
45$:	movl	#ss$_normal,R0
46$:	subl	parm_3(ap),R3		; R3=result buffer
	beql	48$
	decl	R3
48$:	movl	R3,R1			; R1=length of node name list
	ret
47$:;;;	unlock	LOCKNAME=SCS,-		; Unlock SCS database
;;;		NEWIPL=#0,-		; Drop IPL to touch argument list
;;;		PRESERVE=NO		; Don't preserve R0
49$:	movzwl	#ss$_nosuchnode,R0
	brb	46$
	.endc	;;;;;;;;;;;;;;;;;;;;;;;;;
	.dsabl	local_block
;+
; mounted_csid - list node csid which mounted the volume
;	entry	parm_1=descriptor of device name
;		parm_2=address of longword array to store csid
;	return	R0=completion code
;		R1=number of csid (R0=ss$_normal)  or
;		   device characteristics (R0=ss$_vcclosed!1)
;	destroy	R0-R1
;	calling	call
;-
	.if gt	mntnodes;;;;;;;;;;;;;;;;; generate volume mounted node
	.save
	.psect	$abs$,abs
	.=0
x_l_nods:	.blkl	1	; number of cluster node
x_l_csid:	.blkl	1	; csdi of local node
x_l_dchr:	.blkl	1	; ucb$l_devchar of device
x_q_rsnm:	.blkq	1	; descriptor of lock resource name
		.blkb	20	; lock resource name buffer
x_w_flag:	.blkw	1	;
		x_v_remmnt=2	;  mounted as remote shadowing
		x_v_remshd=3	;  shadow mounted by remote node
		x_v_remacc=4	;  accessed by remote node
		x_v_psuedo=5	;  not mounted by local node
		x_v_mountd=6	;  mounted as remote shadowing
		x_v_allocd=7	;  allocated by remote node
x_b_stat:	.blkb	1	; volume condition
				;  0=remote_access
				;  1=remote_shadow_member
				;  2=remote_mount
		.blkb	1	; filler
x_l_mntk:	.blkl	1	; volume mount count in the cluster
x_l_lsts:	.blkl	1	; scratch for $enq completion code
x_l_lkid:	.blkl	1	; scratch for lock id of enq (lck$k_nlmode)
x_q_valb:	.blkq	1	; scratch for valblk of enq (lck$k_nlmode)
		d_v_notfirst_mnt=0;mounted by remote node
		d_v_shadow_mbr=9;  remote shadow member
x_b_lkib:	.blkb	lki$k_length*max_mntnod
x_k_size:	.blkb	0	; length of structure
	.restore

	$banki	gbl782
mounted_csid:
	.call_entry	max_args=2,home_args=TRUE,-
			input=<>,output=<R1>,scratch=<>,preserve=<R2,R3,R4,R5>
	movab	-x_k_size(sp),sp	;
	pushaq	-(sp)			; 20 bytes scratch
	pushaq	-(sp)			; dsc$a_pointer
;;;	pushl	#0			; dsc$w_length
	clrq	-(sp)			; ucb$l_sts
	pushl	#0
	pushaw	4*2(sp)
	pushab	4*6(sp)
	pushl	#<dvi$_fulldevnam@16>!16
	pushl	#0
	pushal	4*5(sp)
	pushl	#<dvi$_devchar@16>!4
;;;	pushl	#0			; param-8:nullarg
	clrq	-(sp)			; param-7:astprm
;;;	pushl	#0			; param-6:astadr
	clrq	-(sp)			; param-5:iosb
	pushal	4*4(sp)			; param-4:itmlst
	pushl	parm_1(ap)		; param-3:devnam
;;;	pushl	#0			; param-2:chan
	clrq	-(sp)			; param-1:efn
	calls	#8+7,g^sys$getdviw
	blbs	R0,24$
	cmpw	#ss$_nosuchdev,R0
	bneq	25$
;	4*2(sp)=pointer of device name
;	4*1(sp)=length of device name
;	4*0(sp)=devchar
	movab	4*4(sp),R2
	.if gt	alpha32
	 movl	parm_1(ap),R1
	 movzwl	dsc$w_length(R1),R0
	 movl	dsc$a_pointer(R1),R1
	.iff
	 movq	@parm_1(ap),R0
	.endc
	pushab	(R2)			; beginning of buffer
	movzwl	R0,R0
	cmpb	#^a/_/,(R1)		; prefixed by "_" character?
	beql	21$			; yes, skip
	movb	#^a/_/,(R2)+
21$:	movb	(R1)+,(R2)+
	sobgtr	R0,21$
	cmpb	#^a/:/,-1(R2)		; surfixed by ":" character?
	beql	22$			; yes, skip
	movb	#^a/:/,(R2)+
22$:	subl3	(sp)+,R2,4*1(sp)
24$:	addl	#4,4*1(sp)		; length of lock resource name
	movl	#^a/SYS$/,4*3(sp)	; buffer of lock resource name
;	4*3(sp)=lock resource name buffer
;	4*2(sp)=pointer of lock resource name
;	4*1(sp)=length of lock resource name
;	4*0(sp)=devchar
; get cluster node information
;;;	pushl	#0			; csid of local node
	clrq	-(sp)			; number of node
;;;	pushl	#0
	clrq	-(sp)
	pushab	4*3(sp)
	pushl	#<syi$_node_csid@16>!4
	pushl	#0
	pushal	4*5(sp)
	pushl	#<syi$_cluster_nodes@16>!4
	pushl	#0			; param-7:astprm
;;;	pushl	#0			; param-6:astadr
	clrq	-(sp)			; param-5:iosb
	pushal	4*3(sp)			; param-4:itmlst
	pushl	#0			; param-3:nodename
;;;	pushl	#0			; param-2:csid
	clrq	-(sp)			; param-1:efn
	calls	#7+7,g^sys$getsyiw
25$:	blbc	R0,27$
;	4*4(sp)=pointer of lock resource name for the device
;	4*3(sp)=length of lock resource name for the device
;	4*2(sp)=devchar
;	4*1(sp)=csid of local node
;	4*0(sp)=number of cluster node
	tstl	4*0(sp)			; is this cluster member?
	bneq	26$			; yes,
	movl	4*2(sp),R1		; R1=device characteristics
	movzwl	#ss$_vcclosed!1,R0
	ret
; get lock information of the device
26$:	movab	(sp),R2			; save information pointer
	pushal	x_b_lkib(sp)		; param-3:buffer of lock information
	pushl	#lki$k_length*max_mntnod; param-2:length of lock information
	pushab	(R2)			; param-1:local control buffer
	pushl	#3			; param-k:
	pushal	(sp)			; arglst
	pushab	70$			; routin
	calls	#2+3,g^sys$cmkrnl	;
	popr	#^m<R3>			; R3=buffer of lock information
27$:	blbc	R0,39$
	divl3	s^#lki$k_length,R1,R4	; R4=number of lock information block
	movzbl	R4,R4
; evalute lock information
	movl	parm_2(ap),R1		; R1=address of remote csid array
	brb	38$
	assume	0 eq lck$k_nlmode
31$:	tstb	lki$b_grmode(R3)	; accessed by this node?
	beql	37$			; yes, bypass
;	cmpl	x_l_csid(R2),-
;		lki$l_remsysid(R3)		; local node information?
;	beql	37$				; yes, skip
	bisb	#1@x_v_remacc,x_w_flag(R2)	; assume access by remote node
	bbs	#dev$v_mnt,x_l_dchr(R2),33$	; local mount?
	bisb	#1@x_v_psuedo,x_w_flag(R2)	; no, local node is psuedo unit
	movb	#0,x_b_stat(R2)			; state="remote_access"
33$:	bbc	#d_v_shadow_mbr,x_q_valb(R2),34$; shadowed by remote node?
	bisb	#1@x_v_remshd,x_w_flag(R2)	; accessed as remote shadowing
	bbs	#dev$v_mnt,x_l_dchr(R2),34$	; local mount?
	bisb	#1@x_v_psuedo,x_w_flag(R2)	; no, local node is psuedo unit
	movb	#1,x_b_stat(R2)			; state="remote_shadow_member"
	assume	0 eq d_v_notfirst_mnt
34$:	blbc	x_q_valb(R2),35$		; mounted by remote node?
	bisb	#1@x_v_remmnt,x_w_flag(R2)	; yes, mounted by remote node
	bisb	#1@x_v_mountd,x_w_flag(R2)	; volume mounted
	incl	x_l_mntk(R2)
	bbs	#dev$v_mnt,x_l_dchr(R2),35$	; local mount?
	bisb	#1@x_v_psuedo,x_w_flag(R2)	; no, local node is psuedo unit
	movb	#2,x_b_stat(R2)			; state="remote_mount"
35$:	cmpb	#lck$k_exmode,lki$b_grmode(R3)	; exclusive access?
	bneq	36$				; no,
	bisb	#1@x_v_allocd,x_w_flag(R2)	; allocated by remote node
36$:	movl	lki$l_remsysid(R3),(R1)+	; csid of remote node
37$:	addl	s^#lki$k_length,R3
38$:	sobgeq	R4,31$
	movl	s^#ss$_normal,R0
	subl	parm_2(ap),R1
	ashl	#-2,R1,R1			; R1=number of csid
; termination
39$:	ret
;+
; 70$ - get entire lock information on the resource
;	entry	parm_1=pointer of internal control buffer
;		parm-2=length of lock information buffer
;		parm-3=buffer of lock information buffer
;	return	R0=completion code
;		R1=length of lock information in byte
;	destroy	R0-R1
;	calling	call (cmkrnl)
;-
lck$k_flags=lck$m_noqueue!lck$m_valblk!lck$m_syncsts!lck$m_system!lck$m_expedite
70$:	.call_entry	max_args=3,home_args=TRUE,-
			input=<>,output=<R1>,scratch=<>,preserve=<R2,R3>
;;;	movab	contingency,sf$a_handler(fp)
	subl	#60,sp
;	4*9(sp)=iosb
;	4*0(sp)=lksb
	movl	parm_1(ap),R2
	moval	(sp),R3
; obtain lock
;;;	pushl	#0			; param-11:nullarg
	clrq	-(sp)			; param-10:acmode
;;;	pushl	#0			; param-9:blkast
	clrq	-(sp)			; param-8:astprm
;;;	pushl	#0			; param-7:astadr
	clrq	-(sp)			; param-6:parid
	pushaq	x_q_rsnm(R2)		; param-5:resnam
	pushl	#lck$k_flags		; param-4:flags
	pushab	4*0(R3)			; param-3:lksb
	pushl	#lck$k_nlmode		; param-2:lkmode
	pushl	#0			; param-1:efn
	calls	#11,g^sys$enqw
	blbs	R0,72$
	movl	4*0(R3),R0
72$:	movl	R0,x_l_lsts(R2)		; pass $enq status
	movl	4*1(R3),x_l_lkid(R2)	; pass lock ident code
	.if gt	alpha32
	 movl	4*2(R3),x_q_valb+0(R2)	; pass lock value block
	 movl	4*3(R3),x_q_valb+4(R2)
	.iff
	 movq	4*2(R3),x_q_valb(R2)
	.endc
	cmpw	#ss$_valnotvalid,R0
	beql	74$
	blbc	R0,79$
; get entire lock information on the resource
74$:	movl	parm_2(ap),R0
;;;	pushl	#0			; length of lock information return
	clrq	-(sp)
	pushaw	4*1(sp)
	pushl	parm_3(ap)
	pushab	<lki$_locks@16>(R0)
;;;	pushl	#0			; param-7:nullarg
	clrq	-(sp)			; param-6:astprm
	pushl	#0			; param-5:astadr
	pushaq	4*9(R3)			; param-4:iosb
	pushal	4*4(sp)			; param-3:itmlst
	pushal	4*1(R3)			; param-2:lkiadr
	pushl	#0			; param-1:efn
	calls	#7+4,g^sys$getlki
	popr	#^m<R1>			; R1=length of lock information
	blbc	R0,77$
	movl	4*9(R3),R0
;;;	blbc	R0,77$
; free lock and exit
77$:	pushr	#^m<R0,R1>		; save completion code
	pushl	#0			; param-4:flags
;;;	pushl	#0			; param-3:acmode
	clrq	-(sp)			; param-2:value block
	pushl	4*1(R3)			; param-1:lkid
	calls	#4,g^sys$deq
	blbc	(sp),78$
	movl	R0,(sp)
78$:	popr	#^m<R0,R1>
79$:	ret
	.endc	;gt mntnodes;;;;;;;;;;;;;
	.page
	.sbttl	chk_hbs_environment - confirm environment
;+==============================================================================
; chk_hbs_environment - confirm environment for host_based_shadowing
;	entry	parm_1=ucb address of target ramdisk
;	return	none
;	destroy	R0
;	calling	call
;-
	.if gt	shdinfon
	.enable	local_block
	$banki	gbl782
chk_hbs_environment:
	.call_entry	max_args=1,home_args=TRUE,-
			input=<>,output=<>,scratch=<>,preserve=<R1,R2>
	$cmkrnl_s routin=b^10$,arglst=(ap)
	blbc	R0,7$
	movl	R1,R2
1$:	ffs	#0,#32,R2,R0
	beql	4$
	bbcc	R0,R2,2$
2$:	.if gt	alpha32
	 bsbb	20$
	 brb	1$
	.iff
	 pushl	R0		; param-1:message ident
	 pushab	1$		; return point
	 brb	20$
	.endc
4$:	movl	s^#ss$_normal,R0
7$:	ret
;+
; 10$ - retrieve shadowing system conditions
;	entry	parm_1=ucb address of target ramdisk
;	return	R1=condition bits
;		   bit0=1, hbs is disabled
;		   bit1=1, shadow-copy operation disabled
;		   bit2=1, shadow-copy is busy
;		   bit3=1, not cluster accessable
;	calling	call (cmkrnl)
;-
10$:	.call_entry	max_args=1,home_args=TRUE,-
			input=<>,output=<R1>,scratch=<>,preserve=<>
;	movab	contingency,sf$a_handler(fp)
	clrl	R1			;
; confirm host-based-shadowing capability
	bbs	#1,g^exe$gl_shadowing,11$
	bisl	#1@0,R1
11$:	movl	g^exe$gl_shadow_max_copy,R0
	bneq	12$			; copies allowed here?
	bisl	#1@1,R1			; no,
	brb	14$
12$:	cmpl	g^exe$gl_hbs_cip,R0	; too many copies activities on node?
	blssu	14$			; no, ok...
	bisl	s^#1@2,R1		; yes, mark it
; check device status for shadowing
14$:	movl	g^clu$gl_club,R0	; this is cluster node
	beql	16$			; no, ok...
	bbc	#club$v_cluster,club$l_flags(R0),16$ ; jump if not in cluster
	movl	parm_1(ap),R0
;;;	bbs	#dev$v_srv,ucb$l_devchar2(R0),16$
	bbc	#dev$v_clu,ucb$l_devchar2(R0),15$
	bbc	#dev$v_noclu,ucb$l_devchar2(R0),16$
15$:	bisl	s^#1@3,R1		; yes, mark it
16$:	movl	#ss$_normal,R0
	ret
;	MOVL	UCB$L_SHAD(R5),R2	; Get the SHAD
;	ASSUME	SHAD$V_COPYING LE 7	; Assume for byte reference.
;	ASSUME	SHAD$V_MERGING LE 7	; Assume for byte reference.
;	BITW	#<SHAD$M_COPYING!-	; Do we have any
;		  SHAD$M_MERGING!-	;  full, merge, or mini-merge
;		  SHAD$M_MINIMRG>,-	;
;		SHAD$W_STATUS(R2)	;  copies still in progress ?
;+
; 20$ - dispaly warning message
;	entry	0(sp)=caller
;		4(sp)=message ident
;	return	none
;	destroy	R0-R1
;	calling	jsb
;-
20$:	.jsb_entry	input=<R0>,output=<>,scratch=<>,preserve=<R2>
	movab	b^29$,R1
	.if gt	alpha32
	 tstl	R0
	 beql	22$
21$:	 movzbl	(R1)+,R2
	 addl	R2,R1
	 sobgtr	R0,21$
22$:	 putasc	(R1)
	 rsb
	.iff
	 tstl	4(sp)
	 beql	22$
21$:	 movzbl	(R1)+,R0
	 addl	R0,R1
	 sobgtr	4(sp),21$
22$:	 movl	R1,4(sp)
	 brw	output_asc
	.endc
	$bankd_r gbl782
29$:	.ascic	"%DGSETCHR-W-NOHBS, volume shadowing disabled, maintain SHADOWING"
	.ascic	"%DGSETCHR-W-NOCOPY, shadow-copy operation disabled, maintain SHADOW_MAX_COPY"
	.ascic	"%DGSETCHR-I-TIGHT, many shadow-coping exist, consider SHADOW_MAX_COPY"
	.ascic	"%DGSETCHR-I-LOCALDEV, device not cluster accessable"
	.dsabl	local_block
	.endc	;gt shdinfon
	.page
	.sbttl	subroutines
	.sbttl	___confirm_localdev - check that device is local
;+==============================================================================
; confirm_localdev - check that device is local
;	entry	parm_1=channel number
;	return	R0=completion code
;	destroy	R0
;	calling	call
;-
	$banki	gbl782
confirm_localdev:
	.call_entry	max_args=1,home_args=TRUE,-
			input=<>,output=<>,scratch=<>,preserve=<R1,R2,R3>
; confirm host name
	pushaq	-(sp)			; 16 bytes scratch
	pushal	-(sp)
;;;	pushl	#0			; host name length return here
	clrq	-(sp)
	pushaw	4*1(sp)
	pushab	4*4(sp)
	pushl	#<dvi$_host_name@16>!16
;;;	pushl	#0			; param-8:nullarg
	clrq	-(sp)			; param-7:astprm
;;;	pushl	#0			; param-6:astadr
	clrq	-(sp)			; param-5:iosb
	pushal	4*4(sp)			; param-4:itmlst
	pushl	#0
	pushl	parm_1(ap)		; param-2:chan
	pushl	#0			; param-1:efn
	calls	#8+4,g^sys$getdviw
	blbc	R0,7$
	movab	g^scs$gb_nodename,R3
	locc	#^a/ /,#8,(R3)
	subl3	R3,R1,R2
	popr	#^m<R0,R1>
	cmpw	R0,R2
	beql	6$
4$:	movzwl	#ss$_nonlocal,lclsts	; memory nonlocal device consisted...
	movl	#ss$_normal,R0
	ret
5$:	cmpb	(R1)+,(R3)+
	bneq	4$
6$:	sobgeq	R0,5$
7$:	ret
	.page
	.sbttl	___getfnc - identify requested function 
;+==============================================================================
; getfnc - identify requested function 
;	entry	R0=string length of qualifiers
;		R1=string buffer of qualifiers
;	return	R1=qualifier bit mask
;		R2=length value string of valued qualifer
;		R3=buffer value string of valued qualifer
;	destroy	R0-R3
;	calling	jsb
;
	.enable	local_block
	$banki	gbl782
getfnc:	.jsb_entry input=<R0,R1>,output=<R0,R1,R2,R3>,scratch=<>,preserve=<>
	pushr	#^m<R2,R3,R4,R5,R6,R7,R8,R9>
	clrl	R5
	cmpb	#^a"/",(R1)
	bneq	1$
	incl	R1
	decl	R0
	brb	1$
0$:	incl	R0			; ss$_normal
	brw	8$
;========
; extract a qualifer from command line
;========
1$:	pushl	#0			; param-3:field number
;;;	pushab	(R1)			; param-2:buffer of device list
	pushr	#^m<R0,R1>		; param-1:length of devuce list
	pushl	#3			; param-k:
2$:	callg	(sp),point_field_by_slash
	tstl	R0			; valid string length?
	beql	0$			; no,
	movq	R0,R2
	locc	#^a/ /,R0,(R1)		; R3=buffer of qualifier
	subl	R0,R2			; R2=length of quliafier
;========
; validate qualifier
;	R2=length of qualifer string from command line
;	R3=buffer of qualifer string from command line
;========
	movab	10$,R1			; R1=template function table
	clrl	R8
3$:	incl	R8
	movzbl	(R1)+,R0		; function template more?
	beql	6$			; no, illegal qualifier
	movzbl	(R1)+,R9		; R9=required miminum length
	decl	R0
	movl	R1,R4			;
	addl	R0,R1			; point to next template
; comapre qualifer with template string
	movq	R2,R6			; R6,R7=decriptor of presented qualifer
	cmpb	#^a/=/,-1(R1)		; valued qualifier?
	bneq	4$			; no, skip
	decl	R0
	pushr	#^m<R0,R1>		; save registers
	locc	#^a/=/,R6,(R7)
	subl	R0,R6			; length of valued qualifier name
	popr	#^m<R0,R1>		; reload registers
4$:	cmpw	R6,R0			; template shorter than function string?
	bgtru	3$			; yes, try next template
5$:	cmpb	(R7)+,(R4)+
	bneq	3$
	sobgtr	R6,5$
; check that minimum qualifier length presented
	cmpl	R2,R9			; minimum qualifier length presented?
	blssu	7$			; no, error
; mark in qualifer presented mask
	ashl	R8,#1,R8
	bisl	R8,R5			; mark qualifier index
	incl	parm_3(sp)		; increment qualifer field index
; check that value of qualifer presented
	cmpb	#^a/=/,-1(R1)		; valued required qualifier?
	bneq	2$			; no, skip
	cmpb	#^a/=/,(R7)+		; value present?
	bneq	9$			; no, process next qualifier
	addl3	R3,R2,R6		; R7=buffer of value string
	subl	R7,R6			; R6=length of value string
	beql	9$
; save qualifier value to pass caller
	.if gt	alpha32
	 movl	R6,4*4(sp)		; move to saved R2 storage
	 movl	R7,4*5(sp)		; move to saved R3 storage
	.iff
	 movq	R6,4*4(sp)		; move to saved R2/R3 storage
	.endc
	brw	2$
;========
; termination
;========
6$:	movzwl	#ss$_illiofunc,R0	; end of template
	brb	8$
7$:	movl	#cli$_abkeyw,R0
	brb	8$
9$:	movl	#cli$_valreq,R0
8$:	addl	#4*4,sp			; flush stack
	movl	R5,R1			; qualifier bit mask
	popr	#^m<R2,R3,R4,R5,R6,R7,R8,R9>
	rsb
	$bankd_r gbl782
10$:	.ascic	<2>/SERVED/		; func=1
	.ascic	<4>/NOSERVED/		; func=2
	.ascic	<2>/SHADOW/		; func=3
	.ascic	<4>/NOSHADOW/		; func=4
	.ascic	<2>/SIZE=/		; func=5, volume size in block
	.if gt	mntnodes
	 .ascic	<1>/MOUNTED=/		; func=6, node list volume mounted
	 .ascic	<1>/VMSNODE=/		; func=7, vms node list in cluster
	 .ascic	<1>/DEVICE=/		; func=8, existant device names
	 .ascic	<1>/EXISTS=/		; func=9, confirm device on remote node
	.endc
	.ascic	//
	.dsabl	local_block
	.page
	.sbttl	___point_field_by_backslash
;+==============================================================================
; point_field_by_backslash
;	point to prompt string in the record buffer
;	entry	param-1:record length
;		param-2:record buffer
;		param-3:field number for prompt (0 to n)
;	return	R0=prompt length
;		R1=prompt buffer (if zero, it means reached end of buffer)
;	destroy	R0,R1
;-
	.enable	local_block
	$banki	gbl782
point_field_by_slash:
	.call_entry	max_args=3,home_args=TRUE,-
			input=<>,output=<R1>,preserve=<R2,R3,R4,R5,R6,R7,R8>
	movb	#^a"/",R5
	brb	12$
point_field_by_comma:
	.call_entry	max_args=3,home_args=TRUE,-
			input=<>,output=<R1>,preserve=<R2,R3,R4,R5,R6,R7,R8>
	movb	#^a/,/,R5
12$:	.if gt	alpha32
	 movl	parm_1(ap),R2
	 movl	parm_2(ap),R3
	.iff
	 movq	parm_1(ap),R2
	.endc
; ignore characters after <!> character
	locc	#^a/!/,R2,(R3)		;
	beql	15$			;
14$:	cmpl	#2,R0			;
	bgtr	15$			;
	cmpb	(R1)+,(R1)+		; single "!" character?
	bneq	15$			; yes, continue
	subl	#2,R0			; no, never neglect paired "!" character
	locc	#^a/!/,R0,(R1)		;
	bneq	14$			;
15$:	subl	R0,R2			; any significant length?
	beql	91$			; no,
; point a field which separated by character in R5
20$:	mcoml	#0,R4			; init field index.
21$:	incl	R4			; increment field index
	movl	R3,R8			;
22$:	locc	#^a/"/,R2,(R3)		; point to explicit string
	movq	R0,R6			;
	locc	R5,R2,(R3)		; point to field delmitter
;;;	beql	28$			; it found?
	cmpw	R6,R0			; explicit string?
	bleq	28$			; no, continue
	movq	R6,R0			;
	decl	R0			; string more exists?
	beql	92$			; no, exit
	cmpb	(R1)+,(R1)		; paired /"/ character?
	beql	27$			; yes, point to next single /"/ char
; point to singel /"/ character
25$:	locc	#^a/"/,R0,(R1)		; explicit string delmitter found?
	beql	93$			; no, illegal format (not paired /"/)
	decl	R0			; string more exists?
	beql	92$			; no, illegal format - (no paired /"/)
	cmpb	(R1)+,(R1)		; paired /"/ character?
	bneq	26$			;
	incl	R1			; yes, point to next single /"/ char
	sobgtr	R0,25$			; string more exists?
	brb	93$			; no, illegal format - (no paired /"/)
26$:	movq	R0,R2			;
	brb	22$			;
27$:	movab	1(R1),R3		; point to next field
	subl3	#1,R0,R2		; compute remain string length
	bgtr	22$			;
	brb	92$			; no, illegal format - (no paired /"/)
; a field pointed
28$:	cmpl	R4,parm_3(ap)		; match to requested field number?
	beql	94$			; yes, request completes.
	movab	1(R1),R3		; point to next field
	subl3	#1,R0,R2		; compute remain string length
	bgtr	21$			;
; all fields processed
;	 r2=field length
;	 R3=field buffer
91$:	clrq	R0			; say no field extracted
	ret				;
92$:	incl	R1			;
93$:	cmpl	R4,parm_3(ap)		; match to requested field number?
	bneq	91$			; no, no field exists.
94$:	subl3	R8,R1,R0		; compute length of field
	movl	R8,R1			;
	ret				;
	.dsabl	local_block

;;;	.page
	.sbttl	___ucb_from_channel - retrieve ucb address of specified channel
;+==============================================================================
; ucb_from_channel - retrieve ucb address of specified channel
;	entry	parm_1=channel number
;	return	R0=completion code
;		R1=original ucb address
;	destroy	R0-R1
;	calling	call
;-
	$banki	gbl782
ucb_from_channel:
	.call_entry	max_args=1,home_args=TRUE,output=<R1>,preserve=<>
	.if gt	alpha32
;;;	 movl	parm_1(ap),R0		; channel number
	 evax_subq sp,#4,sp
	 evax_or   sp,#0,R17		; param-2:address of ccb return
;;;	 evax_or   R0,#0,R16		; param-1:channel number
	 jsb	g^ioc$chan_to_ccb
	 blbc	R0,3$
	 movl	(sp),R1			; R1=ccb
	.iff
	 movzwl	parm_1(ap),R1		; Retrieve input parameters
	 bicw	#<ccb$k_length-1>,R1	;
	 beql	1$			; invalid channel number
	.iif gt	alpha32, cmpl R1,@#ctl$gl_chindx
	.iif le alpha32, cmpw R1,@#ctl$gw_chindx
	 bgtru	1$			; invalid channel number
	.iif gt	alpha32, movl g^ctl$gl_ccbbase_bogus,R0
	.iif le	alpha32, movl g^ctl$gl_ccbbase,R0
	 mnegl	R1,R1			; convert to channel index
	 movab	(R0)[R1],R1		; point to corresponding CCB
	 movl	#ss$_normal,R0		;
	.endc
	movl	ccb$l_ucb(R1),R1	; get ucb
	bgeq	1$			; ucb must in system space
	ret				;
1$:	movzwl	#ss$_ivchan,R0		;
3$:	ret
	.page
	.sbttl	___output_asc - dispaly message on sys$output
;+==============================================================================
; output_asc - dispaly message on sys$output
;	entry	0(sp)=caller
;		4(sp)=address of text (counted ascii)
;	return	none
;	destroy	R0-R1
;	calling	jsb
;-
	$banki	gbl782
output_asc:
	.jsb_entry	max_args=0,input=<R0>,output=<>,scratch=<>,preserve=<>
	.if gt	alpha32
	 addl3	#1,R0,-(sp)
	 movzbl	(R0),-(sp)
	.iff
	 movl	4(sp),R1
	 movzbl	(R1)+,R0
	 pushr	#^m<R0,R1>
	.endc
	pushaq	(sp)
	calls	#1,g^lib$put_output
	addl	#4*2,sp
	.iif le	alpha32, movl (sp)+,(sp)
	rsb
	.page
	.sbttl	contingency - local contingency handler for local routines
;+==============================================================================
; contingency - local contingency handler for local routines
;	entry	parm_1:buffer address
;		parm_2:buffer length
;	return	R0=completion code
;	destroy	R0,R1
;	caloing	call
;-
	$banki	gbl782
contingency:
	.call_entry max_args=2,home_args=TRUE,preserve=<>
; save signal block/call mechanism block
;	movl	chf$l_sigarglst(AP),R0
;	.if gt	alpha32
;	 movl	(R0)+,svsig+<4*0>
;	 movl	(R0)+,svsig+<4*1>
;	 movl	(R0)+,svsig+<4*2>
;	 movl	(R0)+,svsig+<4*3>
;	 movl	(R0)+,svsig+<4*4>
;	 movl	(R0)+,svsig+<4*5>
;	 movl	chf$l_mcharglst(AP),R0
;	 movl	chf$ih_mch_savr0(R0),svmch+<4*0>
;	 movl	chf$ih_mch_savr1(R0),svmch+<4*1>
;	.iff
;	 movq	(R0)+,svsig+<8*0>
;	 movq	(R0)+,svsig+<8*1>
;	 movq	(R0)+,svsig+<8*2>
;	 movl	chf$l_mcharglst(AP),R0
;	 movl	chf$l_mch_savr0(R0),svmch+<4*0>
;	 movl	chf$l_mch_savr1(R0),svmch+<4*1>
;	.endc
; handle
	movl	chf$l_sigarglst(AP),R0	; reload exception as completion status
	bitw	#sts$m_fac_no/65536,chf$l_sig_name+2(R0)
	bneq	6$ ;4$			; this is not signal from system
	.if gt	alpha32
	 movl	chf$l_sig_arg1(R0),R1	; get fault param-1
	 movl	chf$l_sig_name(R0),R0	; get fault status
	.iff
	 assume	chf$l_sig_arg1 eq chf$l_sig_name+4
	 movq	chf$l_sig_name(R0),R0	; get fault status
	.endc
	cmpw	#ss$_ssfail,R0		;
	beql	6$
	.if le	alpha32
	 movab	b^3$,sf$l_save_pc(FP)	; point to procedure caller
3$:	 ret				; return to caller
	.endc
; we not handle the signal since it is not ss$ and/or rms$
4$:	movzwl	#ss$_resignal,R0	; pass to next handler
	ret
6$:	movzwl	#ss$_continue,R0	; restart at exception pc
	ret
	$bankd_w gbl782
;svsig:	.blkl	6
;svmch:	.blkl	2			; contents of register R0,R1

	.end	begin
??
$	exit	$status .or. (f$ve(savvfy,savvfy/2)*0)
$	endsubroutine
$!==============================================================================
$! build source module
$create_src_driver:
$	subr
$	savvfy	='f$ve(0)
$	if ""	.nes. f$sea(p1) then delete 'p1';*
$	create	'p1'
$	deck	/dollar=??
	.title	dgdriver - fast pseudo disk i/o driver
	.ident	'3.1'
;**************************************************************************
;* NO WARRANTIES OF ANY NATURE ARE EXTENDED BY THE DOCUMENT.  Any product *
;* and related material disclosed herein  are only furnished pursuant and *
;* subject to the terms and conditions of a duly executed Program Product *
;* License  or  Agreement  to purchase  or  lease  equipment.   The  only *
;* warranties made by Digital Equipment Corporation, if any, with respect *
;* to  the  products  described in this  document  are set forth  in such *
;* License  or Agreement.  DIGITAL  cannot accept  any financial or other *
;* responsibility that  may be the result of your use of the  information *
;* in this  document  or software material,  including  direct, indirect, *
;* special, or consequential dameges.                                     *
;* You should be very careful to ensure that  the use of this information *
;* and/or software material complies with the laws, rules and regurations *
;* of the jurisdictions with respect to which it is used.                 *
;* The information contained herein is subject to change without notice.  *
;* Revisions may be issued to advise of such change and/or additions.     *
;**************************************************************************
;
; FACILITY:
;	VAX/VMS Fast Pseudo Disk Device Driver
;
; ABSTRACT:
;	This version is a hack from the original PDDRIVER supplied with VMS.
;	The major advantage of this version is the move by page I/O (sic) to
;	memory.
;	the driver allocates pages from nonpaged pool to use for the disk.  the
;	program dg$setchr tells the driver how much memory (in pages) to allocate
;	for the disk.
;	This module contains the tables and routines necessary to emulate
;	device driver processing of a real disk drive using memory resident
;	data instead. For compatability with utilties which wish to know disk
;	geometry information, the pseudo-disk appears to have two sector per
;	track and half as many tracks (and cylinders) as there are blocks on
;	the disk.
;	assembly and link instructions.
;	 $ macro dgdriver
;	 $ link/share dgdriver + sys$input:/opt
;	 base=0
;	 $ copy dgdriver.exe sys$common:[sys$ldr]
;
;	initilize and mount examples:
;	 $ mcr  sysman io connect dga0/noadapter
;	 $ init ="initialize/nohighwater/index=beginning"
;	 $ init/size=4096 dga0 volume0		(vms 6.0 and up)
;	 $!mcr  dg$setchr dga0/size=64		(for vms 5.5-2 and earlier)
;	 $!init dga0 volume0			(for vms 5.5-2 and earlier)
;	 $
;	 $ mcr  dg$setchr dga0/served/shadow
;	 $ mount/noassist/system dsa0/shadow=($1$dga0,$3$dga0) volume0
;	 $ dismount  dsa0
;	 $ if   f$getdvi("dga0","shdw_member") then exit
;	 $ mcr  dg$setchr dga0/noshadow
;	 $ mount/noassist/nocache/override=(ident,shdw_membership) dga0
;
; AUTHOR:
;	Jay Olson,	Creation Date:	26-Oct-1984
;
; MODIFIED BY:
;	29-May-1986	norm lastovica, ken blaylock
;		use movc3 to move one page at a time rather than one
;		byte at a time.  replaces IOC$MOVFRUSER and
;		IOC$MOVTOUSER calls with DG$... version of the
;		routines.
;	29-may-1986	njl/kgb
;		check for last byte moved prior to calling ioc$filspt.
;		corrects system crashing problem due to accessing
;		invalid pte's.
;	10-Nov-1988	njl (version 2.1-0)
;		make things multiples of 32 blocks to allow for bigger
;		device sizes.  round device size requests to the next
;		multiple of 32 blocks.
;	6-apr-1989	KAPUNA::WHITE (version 2.1-1)
;		the MOV routines would calc an incorrect bytecount 
;		for R7 if less than one page of data was requested.
;		added a check for this case.
;	18-oct-1993	fssg (v3.0)
;		Add codes to support host based volume shadowing capability
;		with OpenVMS 6.0 IFT.
;		development memo:
;		 - to shadow, ucb$l_cddb must be set.
;		 - to shadow with mscp served disk, dev$m_mscp (dev$l_devchar)
;		   and device type (dt$_generic_du) must evaluated.
;		 - "initialize/size" allowed if the device type is dt$_ram_disk.
;		1) In IO_PACKACK, set the LCL_VALID bit in the UCB
;		   if the PACKACK completes successfully for the system
;		   disk. This is required for host-based shadowing booting.
;		2) Add host-based-shadowing support. a)force errors on a set
;		   of blocks (force_error) and b)erase a set of blocks (IO_DSE).
;		3) Change all references of EXE$GL_SYSUCB to SYS$AR_BOOTUCB
;		   since it is no longer the same for shadowing.
;		4) Add shadowed booting support.  Synchronize with DSA
;		   class driver by checking for different SYS$AR_BOOTUCB
;		   from EXE$GL_SYSUCB.
;		5) Add CRESHAD and REMSHAD FDT routines.
;	12-dec-1993	fssg (v3.1)
;		ported to Alpha VMS 2.0 EFT2
;-
	.page
;
; assembler directions
;
	.default displacement,word
	shdon=1				; enable host based volume shadoing
	dseon=1				; enable security erase i/o function
	sipon=0				; software implemented performance mon
	mpon=1				; software instrumentation package
	diagon=0			; enable alnaternate disk address spec.
	.iif ne	shdon, shdon=1
	.iif ne	dseon, dseon=1
	.iif ne	sipon, sipon=1
	.iif ne	diagon, diagon=1
	shdcddb=shdon			; alloc cddb required by shdriver 
	shdfe=0	;shdon			; force error (revectoring) handling
	shdlocal=shdcddb		; allowed even if non cluster operation
	.page
	.sbttl	symbol definitions
;
; external symbols
;
	exec_version
	call_jsb_entry
	$arbdef
	$cddbdef
	$clubdef			; Define Cluster Block
	$crbdef				; Define channel request block
	$dcdef				; Define device classes
	$ddbdef				; Define device data block
	$devdef				; Define device characteristics
	$dptdef				; Define driver prologue table
	$dyndef				; Define dynamic data structures
	.if gt	alpha32
	 $fdtargdef			; calling parameters for fdt routine
	 $fdt_contextdef
	.endc
	$idbdef				; Define interrupt data block
	$iodef				; Define i/o function codes
	$ipldef				; Define interrupt priority levels
	$irpdef				; Define i/o request packet
	.if le	alpha32
	 irp$l_func=irp$w_func
	 irp$l_sts=irp$w_sts
	.endc
	$mscpdef
	$prdef				; Define processor registers
	$prvdef				; process privilege code
	$ptedef				; Page table entry definitions
	.iif le	alpha32, pte$c_bytes_per_pte=4
	$rsndef				; resource wait code
	$splcoddef			; Define spinlock codes
	$ssdef				; Define system status codes
	$ucbdef				; Define ucb offsets
	$vadef
	.if gt	alpha32
	 va$m_byte=va$m_bytes_per_pagelet ; 511
	 va$v_byte=va$v_bytes_per_pagelet ; 0
	 va$s_byte=va$s_bytes_per_pagelet ; 9
	.endc
	$vecdef				; Define interrupt vector block
	.if le	alpha32
	 p1=4*0				; qio call parameter-1 offset
	 p2=4*1				; qio call parameter-2 offset
	 p3=4*2				; qio call parameter-3 offset
	.endc
;
; local symbols
;
	dg_fipl		=8		; fork ipl
	dg_secsiz	=512		; size of a block (512 bytes/sector)
	dg_trksiz	=32		; size of a track (32 sector/head)
	dg_cylsiz	=1		; size of a cylinder (1 track/cylinder)
; 
; Macro Procedures
;
	.macro	check_diskaddr err=?,buf=R1,knt=R2,lbn=R3
	.show	expansions
	 movl	irp$l_bcnt(R3),knt	; get number of bytes to move
	.iif gt	shdfe, ashl #-9,buf,lbn	; save block number
	 movab	-1(knt)[buf],R0		; compute highest byte offset to move
	 assume	dg_secsiz eq 512
	 ashl	#-9,R0,R0		; convert byte offset to block number
	 addl	ucb$l_dg_membuf(R5),buf	; add to base of in-memory buffer
	 cmpl	ucb$l_maxblock(R5),R0	; disk address within volume size?
	 blequ	err			; no, abend
	.noshow	expansions
	.endm
	.if gt	alpha32
	$OFFDEF	STARTARG, <irp,ucb >
	$OFFDEF	CTRLARG, <idb,ddb,crb >
	$OFFDEF	UNITARG, <idb,ucb>
	.endc
	.macro	$driver_entry max_args=6,home_args=TRUE,input=<>,output=<>,scratch=<>,preserve=<>
	.if gt	alpha32
	.call_entry %extract(0,8,<max_args>)=MAX_ARGS,%extract(0,8,<home_args>)=HOME_ARGS,%extract(0,8,<input>)=<INPUT>,%extract(0,8,<output>)=<OUTPUT>,%extract(0,8,<scratch>)=<SCRATCH>,%extract(0,8,<preserve>)=<PRESERVE>
	.endc
	.endm
	.if le	alpha32
	 .macro	driver_code		; define code program section
	 .endm
	 .macro	driver_data		; define data program section
	 .endm
;	 .macro	.symbol_alignment bound
;	 .endm
	 .macro	call_finishioc do_ret=Y	; immidiate i/o request end in fdt rtn
	  jmp	g^exe$finishioc
	 .endm
	 .macro	call_qiodrvpkt do_ret=Y	; queue request on unit
	  jmp	g^exe$qiodrvpkt
	 .endm
	 .macro	call_abortio do_ret=YES	; abort i/o request in fdt routine
	  jmp	g^exe$abortio
	 .endm
	 .macro	$driver_fdt_entry
	 .endm
	 .macro	$driver_ctrlinit_entry
	 .endm
	 .macro	$driver_unitinit_entry
	 .endm
	 .macro	$driver_start_entry
	 .endm
	.endc
;
; UCB extention (offsets which follow the standard ucb fields)
;
	.symbol_alignment long
	$DEFINI	UCB				; start of UCB definitions
	.=ucb$k_lcl_disk_length			; for local disk device
;;;	.iif gt	shdon, .=ucb$k_du_disk_length	; for du generic device
	.iif gt	shdon, .=ucb$k_mscp_disk_length	; for shadowing disk device
 $DEF	ucb$l_dg_memsiz	.blkl	1		; length of in-memory buffer
 $DEF	ucb$l_dg_membuf	.blkl	1		; address of in-memory buffer
	.if gt	shdfe
 $DEF	ucb$l_dg_fetbl	.blkl	1		; forced-error flag bit table
	.endc
	.if gt	alpha32
 $DEF	ucb$b_dg_fex	.blkb	1		; temp to store i/o func code
 $DEF	ucb$b_dg_fill	.blkb	3		; this field destroyed...
	.endc
 $DEF	ucb$k_dg_lngth	.blkl	0		; length of ucb
	$DEFEND	UCB				; End of UCB definitons
	.if gt	shdon
	 assume	ucb$l_dg_memsiz gt ucb$l_shad
	.endc
	.page
	.sbttl	dpt definition and initialize ucb,ddb,crb
;
; DPT - driver prologue table
; The DPT describes driver parameters and I/O database fields that are to
; be initialized during driver loading and reloading.
;
	.if gt	alpha32
	 DPTAB	STEP=2,-
		ADAPTER=NULL,-			; no real device
		MAXUNITS=2000,-			; only two thousand units allowed
		SMP=YES,-			; SMP modified
		FLAGS=<DPT$M_SVP>,-		; system page table entry required
		UCBSIZE=ucb$k_dg_lngth,-	; length of UCB
		NAME=DGDRIVER			; driver name
	.iff
	 DPTAB	END=DG_END,-			; label at end of driver
		ADAPTER=NULL,-			; no real device
		MAXUNITS=2000,-			; only two thousand units allowed
		UNLOAD=DG_UNLOAD,-		; clean-up routine when unloading
		SMP=YES,-			; SMP modified
		FLAGS=<DPT$M_SVP>,-		; system page table entry required
		UCBSIZE=ucb$k_dg_lngth,-	; length of UCB
		NAME=DGDRIVER			; driver name
	.endc
	DPT_STORE INIT				; start control block init values
	DPT_STORE DDB,DDB$L_ACPD,L,<^A\F11\>	; default ACP name
	DPT_STORE DDB,DDB$L_ACPD+3,B,<DDB$K_PACK> ; ACP class
;v4	DPT_STORE DDB,DDB$L_ACPD+3,B,<DDB$K_CART>
;v4	DPT_STORE UCB,UCB$B_FIPL,B,<dg_fipl>	; fork IPL
	DPT_STORE UCB,UCB$B_FLCK,B,SPL$C_IOLOCK8; fork IPL spin lock
	DPT_STORE UCB,UCB$B_DIPL,B,21		; device IPL (not used)
	DPT_STORE UCB,UCB$L_DEVCHAR,L,-		; device characteristics
			<DEV$M_FOD-		; files oriented
			!DEV$M_DIR-		; directory structured
			!DEV$M_AVL-		; available
			!DEV$M_SHR-		; shareable
			!DEV$M_IDV-		; input device
			!DEV$M_ODV-		; output device
			!DEV$M_RND>		; random access
	DPT_STORE UCB,UCB$L_DEVCHAR2,L,-
			<DEV$M_NLT-		; no bad block infor on last track
			!DEV$M_NNM>		; prefix name with "node$"
	DPT_STORE UCB,UCB$B_DEVCLASS,B,<DC$_DISK>   ; device class
	DPT_STORE UCB,UCB$B_DEVTYPE,B,<DT$_RAM_DISK>; device type
	DPT_STORE UCB,UCB$W_DEVBUFSIZ,W,<dg_secsiz> ; default buffer size
	DPT_STORE UCB,UCB$B_SECTORS,B,<dg_trksiz> ; number of sectors per track
	DPT_STORE UCB,UCB$B_TRACKS,B,<dg_cylsiz>; number of tracks per cylinder
	.if gt	alpha32
	DPT_STORE UCB,UCB$L_DEVSTS,L,<UCB$M_NOCNVRT>; inhibit log to phy conv in FDT
	.iff
	DPT_STORE UCB,UCB$W_DEVSTS,W,<UCB$M_NOCNVRT>; inhibit log to phy conv in FDT
	.endc
	DPT_STORE UCB,UCB$L_MEDIA_ID,L,<^x21c87001> ; media ident "DG DG01"
	DPT_STORE UCB,UCB$L_MAXBCNT,L,<65536-512>

	DPT_STORE REINIT			; start control block re-init values
	.if gt	alpha32
	DPT_STORE CRB,CRB$B_FLCK,B,SPL$C_IOLOCK8; fork IPL spin lock
;;;	DPT_STORE_ISR CRB$L_INTD, dg_int	; interrupt service routine
	.iff
	DPT_STORE DDB,DDB$L_DDT,D,DG$DDT	; DDT address
	DPT_STORE CRB,CRB$B_FLCK,B,SPL$C_IOLOCK8; fork IPL spin lock
;;;	DPT_STORE CRB,CRB$L_INTD+VEC$L_ISR,-	; interrupt service routine
;;;				D,dg_int
	DPT_STORE CRB,CRB$L_INTD+VEC$L_INITIAL,-; controller init address
				D,dg_ctrl_init
	DPT_STORE CRB,CRB$L_INTD+VEC$L_UNITINIT,-; unit init address
				D,dg_unit_init
	.endc
	DPT_STORE END				; end of initialization table
	.page
;
; DDT - driver dispatch table
; The DDT lists entry points for driver subroutines which are called by
; the operating system.
;
	.if gt	alpha32
	 DDTAB	DEVNAM=DG,-			; Name of device
		START=dg_startio,-		; Start I/O routine
		FUNCTB=dg_fuchtable,-		; Function decision table
		CTRLINIT=dg_ctrl_init,-
		UNITINIT=dg_unit_init
	.iff
	 DDTAB	DEVNAM=DG,-			; Name of device
		START=dg_startio,-		; Start I/O routine
		UNSOLIC=0,-			; Unsolicited interrupt
		FUNCTB=dg_fuchtable,-		; Function decision table
		CANCEL=0,-			; Cancel=NO-OP for files device
		DIAGBF=0,-			; No diagnostic buffer
		REGDMP=0,-			; Can't dump any registers
		ERLGBF=0			; No error logging
	.endc
;
; FDT - function dispatch table
; The FDT lists valid function codes, specifies which codes are buffered,
; and designates subroutines to perform preprocessing for particular
; functions.
;
	.symbol_alignment quad
	driver_data
	.if gt	alpha32
	fdt_ini	dg_fuchtable
	fdt_buf	<-
		UNLOAD,-			;  unload
		PACKACK,-			;  pack acknowledge
		AVAILABLE,-			;  available
		SENSECHAR,-			;  sense characteristics
		SENSEMODE,-			;  sense mode
		FORMAT,-			;  format (set size)
		ACCESS,-			;  access file/find directory entry
		ACPCONTROL,-			;  ACP control function
		CREATE,-			;  create file and/or directory entry
		DEACCESS,-			;  deaccess file
		DELETE,-			;  delete file and/or directory entry
		MODIFY,-			;  modify file attributes
		MOUNT,-				;  mount volume
		SETCHAR,-			;  prepare for shadowing
		DSE>
	fdt_act	ACP_STD$READBLK,<-		; read functions
		READLBLK,-			;  read logical block
		READPBLK,-			;  read physical block
		READVBLK>			;  read virtual block
	.if gt	shdon;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	fdt_act FDT_SHAD_WCHECK,<-		;  check write to shadow set mbr
		WRITELBLK,-			;  write LOGICAL Block
		WRITEPBLK,-			;  write Physical Block
		WRITEVBLK,-			;  write VIRTUAL Block
		WRITECHECK>
;	fdt_act FDT_CRESHAD,<CRESHAD>		;  create a shadow set virtual unit
	fdt_act FDT_REMSHAD,<REMSHAD,CRESHAD>	;  remove a shadow set member
	fdt_act	FDT_SETCHAR,<SETCHAR>		; set characteristics
	.iff
	fdt_act	ACP_STD$WRITEBLK,<-		; write functions
		WRITELBLK,-			;  write logical block
		WRITEPBLK,-			;  write physical block
		WRITEVBLK-			;  write virtual block
		WRITECHECK>			;
	.endc	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	fdt_act	ACP_STD$ACCESS,<-		; acp functions
		ACCESS,-			; acceess file/find directory entry
		CREATE>				; create file and/or directory entry
	fdt_act	ACP_STD$DEACCESS,<DEACCESS>	; deaccess file
	fdt_act	ACP_STD$MODIFY,<-
		ACPCONTROL,-			; ACP control function
		DELETE,-			; delete file and/or directory entry
		MODIFY>				; modify file attributes
	fdt_act	ACP_STD$MOUNT,<MOUNT>		; mount volume
	fdt_act	EXE_STD$LCLDSKVALID,<-		;
		UNLOAD,-			;  unload volume
		AVAILABLE,-			;  unit available
		PACKACK>			;  pack acknowledge
	fdt_act	EXE_STD$ONEPARM,<-		; one parameter function
		FORMAT>				;  format (set size)
	fdt_act	EXE_STD$SENSEMODE,<-		;
		SENSECHAR,-			;  sense characteristics
		SENSEMODE>			;  sense mode
	.iif gt	dseon, fdt_act FDT_DSE,<DSE>	; data security erase
	.iff	;gt alpha32
dg_fuchtable:
	FUNCTAB	,<-				; legal functions
		UNLOAD,-			;  unload
		PACKACK,-			;  pack acknowledge
		AVAILABLE,-			;  available
		SENSECHAR,-			;  sense characteristics
		SENSEMODE,-			;  sense mode
		FORMAT,-			;  format (set size)
		READPBLK,-			;  read physical block
		WRITEPBLK,-			;  write physical block
		READLBLK,-			;  read logical block
		WRITELBLK,-			;  write logical block
		READVBLK,-			;  read virtual block
		WRITEVBLK,-			;  write virtual block
		WRITECHECK,-			;  write virtual block
		ACCESS,-			;  access file/find directory entry
		ACPCONTROL,-			;  ACP control function
		CREATE,-			;  create file and/or directory entry
		DEACCESS,-			;  deaccess file
		DELETE,-			;  delete file and/or directory entry
		MODIFY,-			;  modify file attributes
		MOUNT-				;  mount volume
		CRESHAD,-			;  create a shadow set virtual unit
		REMSHAD,-			;  remove a shadow set member
		SETCHAR,-			;  shadowing preparation
		DSE>
	FUNCTAB	,<-				; buffered functions
		UNLOAD,-			;  unload
		PACKACK,-			;  pack acknowledge
		AVAILABLE,-			;  available
		SENSECHAR,-			;  sense characteristics
		SENSEMODE,-			;  sense mode
		FORMAT,-			;  format (set size)
		ACCESS,-			;  access file/find directory entry
		ACPCONTROL,-			;  ACP control function
		CREATE,-			;  create file and/or directory entry
		DEACCESS,-			;  deaccess file
		DELETE,-			;  delete file and/or directory entry
		MODIFY,-			;  modify file attributes
		MOUNT,-				;  mount volume
		SETCHAR,-			;  prepare for shadowing
		DSE>
	FUNCTAB	+ACP$READBLK,<-			; handlers
		READLBLK,-			;  read logical block
		READPBLK,-			;  read physical block
		READVBLK>			;  read virtual block
	.if gt	shdon;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	FUNCTAB FDT_SHAD_WCHECK,<-		;  check write to shadow set mbr
		WRITELBLK,-			;  write LOGICAL Block
		WRITEPBLK,-			;  write Physical Block
		WRITEVBLK,-			;  write VIRTUAL Block
		WRITECHECK>
;	FUNCTAB FDT_CRESHAD,<CRESHAD>		;  create a shadow set virtual unit
	FUNCTAB FDT_REMSHAD,<REMSHAD,CRESHAD>	;  remove a shadow set member
	FUNCTAB	FDT_SETCHAR,<SETCHAR>		; set characteristics
	.endc
	.if le	<shdon-alpha32>
	FUNCTAB	+ACP$WRITEBLK,<-		;  write functions
		WRITELBLK,-			;  write logical block
		WRITEPBLK,-			;  write physical block
		WRITEVBLK-			;  write virtual block
		WRITECHECK>			;
	.endc	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	FUNCTAB	+ACP$ACCESS,<-			;
		ACCESS,-			; acceess file/find directory entry
		CREATE>				; create file and/or directory entry
	FUNCTAB	+ACP$DEACCESS,<DEACCESS>	; deaccess file
	FUNCTAB	+ACP$MODIFY,<-			;
		ACPCONTROL,-			; ACP control function
		DELETE,-			; delete file and/or directory entry
		MODIFY>				; modify file attributes
	FUNCTAB	+ACP$MOUNT,<MOUNT>		; mount volume
	FUNCTAB	+EXE$LCLDSKVALID,<-		;
		UNLOAD,-			;  unload volume
		AVAILABLE,-			;  unit available
		PACKACK>			;  pack acknowledge
	FUNCTAB	+EXE$ZEROPARM,<-		; no parameter function
		UNLOAD,-			;  unload volume
		AVAILABLE,-			;  unit available
		PACKACK>			;  pack acknowledge
	FUNCTAB	+EXE$ONEPARM,<-			; one parameter function
		FORMAT>				;  format (set size)
	FUNCTAB	+EXE$SENSEMODE,<-		;
		SENSECHAR,-			;  sense characteristics
		SENSEMODE>			;  sense mode
	.iif gt	dseon, FUNCTAB FDT_DSE,<DSE>	; data security erase
	.endc	;gt alpha32
	.page
	.sbttl	driver initilization routines
	.sbttl	___dg_unload - driver unloading routine
;+==============================================================================
; dg_unload - driver unloading routine
; This routine is provided for compatibiltiy with other device drivers
; but does nothing.
; The operating system calls this routine when unloading the driver.
;
;	entry	R4=csr (vax) or idb (alpha)
;		R5=idb
;	destroy	all general registers (R0 - R15) are preserved.
;-
	driver_code
	.if gt	alpha32
	;i/o driver unloading not supported by AlphaVMS 2.0
	.iff
dg_unload:
	 movzwl	#ss$_devactive,R0
	 rsb				; return, driver cannot be unloaded
	.endc
;;;	.page
	.sbttl	___dg_ctrl_init - controller initialization routine
;+==============================================================================
; dg_ctrl_init - controller initialization routine
; This routine is provided for compatibiltiy with other device drivers
; but does nothing.
; The operating system calls this routine:
;	- during driver loading or reloading
;	- during recovery from power failure
;	entry	R4=csr (not used)
;		R5=idb (not used)
;		R6=ddb
;		R8=crb
;	destroy	R0-R1
;-
	driver_code
dg_ctrl_init:
	$driver_entry max_args=4,home_args=TRUE,preserve=<R2,R5,R6,R8>
;	$driver_ctrlinit_entry preserve=<R2,R5,R6,R8>,fetch=NO
	.if gt	alpha32
	 assume	ctrlarg$_idb eq 4*1
	 assume	ctrlarg$_ddb eq 4*2
	 assume	ctrlarg$_crb eq 4*3
	 movq	ctrlarg$_idb(ap),R5
;;;	 movl	ctrlarg$_ddb(ap),R6
	 movl	ctrlarg$_crb(ap),R8
	.iff
	 clrl	idb$l_csr(R5)		; We don't have a csr
	.endc
; disable i/o function from supported function mask in fdt.
	assume	11 eq io$_writepblk
	assume	12 eq io$_readpblk
	assume	21 eq io$_dse
	assume	26 eq io$_setchar
	.if le	alpha32
	.iif lt	dseon+shdon-2, movab dg_fuchtable,R1
	.iif le	dseon, bicb #<1@io$_dse>@-16,2(R1)
	.iif le	shdon, bicb #<1@io$_setchar>@-24,3(R1)
	.endc
; allocate cddb for shadowing operation
; cddb pointed from ucb$l_cddb is just required by t6.1 shdriver (at routine,
; shsb$find_read-ucb) even if both mscp and scsi in ucb$l_devchar2 are cleared.
	.if gt	shdcddb
	 movb	#spl$c_scs,crb$b_flck(R8)
	 .if le	shdlocal
	  tstl	g^clu$gl_club		; cluster operation?
	  bneq	3$			; yes, continue
	  assume io$_creshad eq 13	; disable shadowing i/o function
	  assume io$_remshad eq 16
	  bicw	#<<1@io$_creshad>!<1@io$_remshad>>@-8,dg_fuchtable+1
	  brb	4$			;
3$:	 .endc
	 tstl	crb$l_auxstruc(R8)	; already allocated?
	 blss	4$			; yes, skip
	 movzwl	#cddb$k_length,R1	; allocate a cddb from expool
	 jsb	g^exe$alononpaged
	 blbc	R0,7$
	 pushr	#^m<R1,R2,R3,R4,R5>	; clear it
	 movc5	#0,(sp),#0,R1,(R2)
	 popr	#^m<R1,R2,R3,R4,R5>
	 movw	R1,cddb$w_size(R2)
	 assume	cddb$b_subtype eq cddb$b_type+1
	 movw	#<dyn$c_cd_cddb@8>!dyn$c_classdrv,cddb$b_type(R2)
	 movl	g^clu$gl_allocls,cddb$l_allocls(R2)
	 movl	R8,cddb$l_crb(R2)	; set crb pointer
	 movl	R6,cddb$l_ddb(R2)	; set ddb pointer
	 movl	R2,crb$l_auxstruc(R8)	; set cddb address in crb
4$:	.endc
; return to sysgen utility
	movl	s^#ss$_normal,R0
	.iif gt	alpha32, ret		; return to executive
	.iif le	alpha32, rsb
7$:	.iif gt	shdcddb, bug_check INSFPOOL,FATAL	;INCONSTATE,FATAL
	.page
	.sbttl	___dg_unit_init - unit initialization routine
;+==============================================================================
; dg_unit_init - unit initialization routine
; This routine sets the pseudo disk unit online by setting the online bit
; in the status word of the UCB. If this device is the system disk, the
; size and address of the in-memory buffer have been stored by SYSBOOT in
; the last two longwords of the driver and these values are moved into the UCB.
; The operating system calls this routine:
;	- during driver loading (but not reloading)
;	- during recovery from power failure
;	entry	R3=0 (vax, normally primary csr) or idb (alpha)
;		R4=0 (vax, normally secondary csr) or idb (alpha)
;		R5=ucb
;	return	none
;	destroy	R0-R1
;	effect	the unit is set online
;-
	driver_code
pwrfail:bicw	#ucb$m_power,ucb$l_sts(R5); clear power failure bit
	.iif gt	alpha32, ret		; return to executive
	.iif le	alpha32, rsb
dg_unit_init:
	$driver_entry max_args=2,home_args=TRUE,preserve=<R4,R5>
;	$driver_unitinit_entry preserve=<R4,R5>,fetch=NO
	.if gt	alpha32
	 assume	unitarg$_idb eq 4*1
	 assume	unitarg$_ucb eq 4*2
	 movq	unitarg$_idb(ap),R4
;;;	 movl	unitarg$_ucb(ap),R5
	.endc
	bbs	#ucb$v_power,ucb$l_sts(R5),pwrfail
; set appropriate device characteristics for usage
	cmpw	#1000,ucb$w_unit(R5)	; automatic mscp served unit?
	blequ	0$			; yes,
	assume	22 eq dev$v_noclu	; no, diasble "$set dev/served" command
	bisb	#<dev$m_noclu@-16>,ucb$l_devchar2+2(R5)
	brb	1$
	assume	dev$v_clu eq 0
	assume	24 eq dev$v_scsi
0$:	bisl	#dev$m_clu,ucb$l_devchar2(R5)
; set unit online
	assume	ucb$v_online eq 4
1$:	bisl	#ucb$m_online,ucb$l_sts(R5)
; setup UCB CDDB field (required by shdriver - routine,shsb$find_read-ucb)
	.if gt	shdcddb
	 movl	ucb$l_crb(R5),R0
	 movl	crb$l_auxstruc(R0),ucb$l_cddb(R5)
	.endc
; set up a dummy MAXBLOCK value to allow vms6.0 initialize utility
; (vms 6.1-5vh initialize utility abend with devide fault)
;	tstl	ucb$l_dg_membuf(R5)	; already initialized?
;	bneq	4$			; yes, bypass
	tstl	ucb$l_maxblock(R5)	; already initialized?
	bneq	4$			; yes,
	movl	#1,ucb$l_maxblock(R5)
; set up internal buffer (in-memory buffer as a disk volume)
4$:	cmpl	g^sys$ar_bootucb,R5	; is this the system disk?
	bneq	7$			; no, skip
	moval	bootbf,R1		; SYSBOOT put some stuff at the end
	addl	#7,R1			;                    quadword align it
	bicl	#7,R1			; point to last quadword
	.if gt	shdfe
	 pushr	#^m<R3,R4,R5>		; save registsers
	 movq	0(R1),R0		; R0=buffer of disk-volume buffer
;;;	 movl	4(R1),R1		; R1=length of volume buffer in byte
	 movl	R0,ucb$l_dg_membuf(R5)
	 assume	dg_secsiz eq 512
	 ashl	#-9,R1,R2		; R2=physical volume size in block
	 ashl	#-12,R2,R3		; R3=max pbn/4096bits(8bits*512) for RCT
	 bitw	#<8*512>-1,R2
	 beql	5$
	 incl	R3
5$:	 subl3	R3,R2,ucb$l_maxblock(R5); set max logical block
	 assume	dg_secsiz eq 512
	 ashl	#9,ucb$l_maxblock(R5),R2; R2=logical volume size in byte
	 addl3	R0,R2,ucb$l_dg_fetbl(R5); save forced-error table address
	 subl	R2,R1			; R1=length of forced-error table
	 movc5	#0,(sp),#0,R1,(R0)[R2]	; clear forced-error table
	 popr	#^m<R3,R4,R5>		; restore registsers
	.iff	;gt shdfe
	 movl	(R1)+,ucb$l_dg_membuf(R5); set up address of volume buffer
	 assume	dg_secsiz eq 512
	 ashl	#-9,(R1),ucb$l_maxblock(R5)
	.endc	;gt shdfe
;
; Check for host based shadowed system disk.  If so, fork and wait until
; the controller init routine of SHDRIVER completes its execution.
;
	blbc	g^exe$gl_shadow_sys_disk,7$
6$:	cmpl	g^sys$ar_bootucb,-	; is the system disk pointer updated?
		g^exe$gl_sysucb		;
	beql	8$			; no, wait for system initialization
7$:	movl	s^#ss$_normal,R0	; yes, continue
	.iif gt	alpha32, ret		; return to executive
	.iif le	alpha32, rsb
8$:	.if gt	alpha32
	 fork_wait routine=9$,continue=7$,environment=CALL
9$:	 fork_routine environment=CALL,fetch=YES
	.iff
	 fork_wait			; fork and wait (R3-R5 preserved)
	.endc
	brb	6$			; try again
	.page
	.sbttl	fdt routines
	.sbttl	___fdt_creshad - CRESHAD fdt routine
	.sbttl	___fdt_remshad - REMSHAD fdt routine
;+==============================================================================
; fdt_creshad - CRESHAD fdt routine
; fdt_remshad - REMSHAD fdt routine
; Dispatch CRESHAD and REMSHAD requests to shadowing driver.
;	entry	R3=irp
;		R4=pcb
;		R5=ucb
;		R6=ccb
;		R7=i/o function code
;		p1=irp (alpha)
;		p2=pcb (alpha)
;		p3=ucb (alpha)
;		p4=ccb (alpha)
;	destroy	R0-R2,R9-R11
;-
	.enable	local_block
	.if gt	shdon
	driver_code
;fdt_creshad:
fdt_remshad:
	$driver_entry max_args=4,home_args=TRUE,preserve=<R3,R5>
;	$driver_fdt_entry preserve=<R3,R5>,fetch=NO
	.if gt	alpha32
	 movl	g^exe$gl_hbs_ptr,R0	; shdriver active?
	 bgeq	0$			; no,
	 callg	(ap),(R0)
	 ret
	.iff
	 movl	g^exe$gl_hbs_ptr,R0	; shdriver active?
	 bgeq	0$			; no,
	 jmp	(R0)			; jump to shadow dispatcher
	.endc
0$:	.if gt	alpha32
	 assume	fdtarg$_irp eq 4*1
	 assume	fdtarg$_pcb eq 4*2
	 assume	fdtarg$_ucb eq 4*3
	 assume	fdtarg$_ccb eq 4*4
	 movl	fdtarg$_irp(ap),R3	; setup to call exe_std$finishio
	 movl	fdtarg$_ucb(ap),R5	; setup to call exe_std$finishio
	.endc
	movzwl	#ss$_nosuchpgm,R0	; reboot with "shadowing=2" sg parameter
	brb	7$
	.endc	;gt shdon

;;;	.page
	.sbttl	___fdt_shad_wcheck - check rd/wrt to shadow mbr for privilege
;+==============================================================================
; fdt_shad_wcheck - check read/write to shadow mbr for privilege
; Allow only processes with SYSPRV privilege to perform WRITES to
; Host Based Shadowing shadow set members.
;	entry	R3=irp
;		R4=pcb
;		R5=ucb
;		R6=ccb
;		R7=i/o function code (vax)
;	return	R0=completion code
;		ss$_illiofunc - I/O directed to shadow set member by a process
;		                that doesn't have sys priv.
;	destroy	R0-R2,R9-R11
;-
	.if gt	shdon
	driver_code
fdt_shad_wcheck:
	$driver_entry max_args=4,home_args=TRUE,preserve=<R3,R5>
;	$driver_fdt_entry preserve=<R3,R5>,fetch=NO
	.if gt	alpha32
	 movl	fdtarg$_irp(ap),R3	;
	 movl	fdtarg$_ucb(ap),R5	;
	.endc
;;;	bbs	#dev$v_ssm,ucb$l_devchar2(R5),1$
	bbc	#dev$v_shd,-		;
		ucb$l_devchar2(R5),2$	; this device is a shadow set member?
1$:	movl	irp$l_arb(R3),R0	; yes,
	beql	5$			; If ARB absent, exit
	bbc	#prv$v_sysprv,arb$q_priv(R0),5$
2$:	.if gt	alpha32			; pass to second fdt routine (acp$write)
	 callg	(ap),g^acp_std$writeblk	; continue FDT processing
	 ret
	.iff
	 jmp	g^acp$writeblk		; continue FDT processing
	.endc
5$:	movzwl	#ss$_nosysprv,R0	; set error status
7$:	call_finishioc do_ret=YES	; complete I/O request
	.endc	;gt shdon
	.dsabl	local_block
;;;	.page
	.sbttl	___fdt_dse - DSE function fdt routine
;+==============================================================================
; fdt_dse - DSE fdt routine
;	entry	R3=irp
;		R4=pcb
;		R5=ucb
;		R6=ccb
;		R7=i/o function code
;		p1(ap)=address of buffer that contains 32-bits erase pattern
;		p2(ap)=byte count
;		p3(ap)=starting lbn
;	return	R0=completion code
;	destroy	R0-R2,R9-R11
;-
fdt_dse:$driver_entry max_args=4,home_args=TRUE,preserve=<R3,R5>
;	$driver_fdt_entry preserve=<R3,R5>,fetch=NO
	.if gt	dseon
	.if gt	alpha32			;
	 movl	fdtarg$_irp(ap),R3	;
	 movl	fdtarg$_ucb(ap),R5	;
	 assume	irp$l_qio_p3 eq irp$l_qio_p2+4
	 movq	irp$l_qio_p2(R3),R0	;
;;;	 movl	irp$l_qio_p3(R3),R1	;
	.iff				;
	 movq	p2(ap),R0		;
	.endc				;
	assume	512 eq dg_secsiz	;
	movab	dg_secsiz-1(R0),R0	; round up xfer count to multiple block
	bicw	#dg_secsiz-1,R0		;
	movl	R1,irp$l_media(R3)	;
	movl	R0,irp$l_bcnt(R3)	;
	beql	2$			;
	call_qiodrvpkt do_ret=NO	; queue request on unit (R3=irp,R5=ucb)
	.iif gt	alpha32, brb 8$		;
2$:	incl	R0			; ss$_normal
7$:	call_finishioc do_ret=NO	; complete i/o request (R3=irp,R5=ucb)
8$:	.iif gt	alpha32, ret		;
	.iff	;gt dseon		;
	.if gt	alpha32
	 movzwl	#ss$_illiofunc,R0
	 call_abortio do_ret=YES	; complete i/o request (R3=irp,R5=ucb)
	.endc
	.endc	;gt dseon

;;;	.page
	.sbttl	___fdt_setchar - SETCHAR fdt routine (prepare for shadowing)
;+==============================================================================
; fdt_setchar - SETCHAR fdt routine (prepare for shadowing)
;	entry	R3=irp
;		R4=pcb
;		R5=ucb
;		R6=ccb
;		R7=i/o function code (vax)
;		p1(ap)=address of parameter longword stored
;		p2(ap)=byte count (not used)
;	return	R0=completion code
;	destroy	R0-R2,R9-R11
;-
	driver_code
fdt_setchar:
	$driver_entry max_args=4,home_args=TRUE,preserve=<R3,R5>
;	$driver_fdt_entry preserve=<R3,R5>,fetch=NO
	.if gt	shdon
	.if gt	alpha32			;
	 movl	fdtarg$_irp(ap),R3	;
	 movl	fdtarg$_ucb(ap),R5	;
	 assume	irp$l_qio_p2 eq irp$l_qio_p1+4
	 movq	irp$l_qio_p1(R3),R0	;
;;;	 movl	irp$l_qio_p2(R3),R1	;
	.iff				;
	 movq	p1(ap),R0		;
	.endc				;
	 movl	R1,irp$l_bcnt(R3)	;
	 movl	(R0),irp$l_media(R3)	;
	 call_qiodrvpkt do_ret=YES	;
	.iff
	.if gt	alpha32
	 movzwl	#ss$_illiofunc,R0
	 call_abortio do_ret=YES	; complete i/o request (R3=irp,R5=ucb)
	.endc
	.endc	;gt shdon;;;;;;;;;;;;;;;;
	.page
	.sbttl	dg_startio - start i/o operation
;+==============================================================================
; dg_startio - start i/o operation
; start i/o operation. since no real device in involved, the pseudo i/o
; operation is done completely in this routine.  unfortunately, that may
; involve substantial periods of time spent at high (fork) IPL.
;	entry	R3=IRP address (i/o request packet)
;		R5=UCB address (unit control block)
;		irp$l_bcnt(=ucb$l_bcnt)     =xfer count
;		irp$l_boff(=ucb$l_boff)     =offset in page of direct i/o
;		irp$l_svapte(=ucb$l_svapte) =va of pte that map user i/o buffer
;		irp$l_media                 =r/w lbn
;	return	R0=First I/O status longword: status code & bytes xfered
;		R1=Second I/O status longword: 0 for disks
;	destroy	all registers except R0-R4 are preserved
;	effect	the I/O function is executed
;-
	.enable	local_block
	driver_code
dg_startio:
	$driver_entry max_args=2,home_args=TRUE,preserve=<R2,R3,R4,R5>
;	$driver_start_entry preserve=<R2,R3,R4,R5>,fetch=NO
	.if gt	alpha32
	 assume	startarg$_irp eq 4*1
	 assume	startarg$_ucb eq 4*2
	 movl	startarg$_irp(ap),R3
	 movl	startarg$_ucb(ap),R5
	 extzv	#irp$v_fcode,-			; extract I/O function code
		#irp$s_fcode,irp$l_func(R3),R1
	 movl	irp$l_func(R3),ucb$l_func(R5) 	; save function code
	 movl	R1,ucb$b_dg_fex(R5)		; save function dispatch index
	.iff
	 extzv	#irp$v_fcode,-			; extract I/O function code
		#irp$s_fcode,irp$w_func(R3),R1
	 movw	irp$w_func(R3),ucb$w_func(R5) 	; save function code
	 movb	R1,ucb$b_fex(R5)		; save function dispatch index
	.endc
;++	bbs	#irp$v_physio,irp$l_sts(R3),2$	; continue if physical i/o
;++	bbc	#ucb$v_valid,ucb$l_sts(R5),5$	; jump if volume not valid
2$:	dispatch R1,TYPE=B,<-			; Dispatch to proper function
		<io$_nop,	okexit>,-	;  0,
		<io$_unload,	io_unl>,-	;  1, UNLOAD Function
		<io$_seek,	okexit>,-	;  2, SEEK Function (unsupported)
		<io$_recal,	okexit>,-	;  3, RECALIBRATE (unsupported)
		<io$_drvclr,	okexit>,-	;  4, DRVCLR (unsupported)
		<io$_release,	okexit>,-	;  5, RELEASE PORT (unsupported)
		<io$_offset,	ilexit>,-	;  6, OFFSET HEADS (unsupported)
		<io$_retcenter,	ilexit>,-	;  7, RETURN TO CENTER (unsupported)
		<io$_packack,	io_packack>,-	;  8, PACK ACKNOWLEDGE
		<io$_search,	okexit>,-	;  9, SEARCH (unsupported)
		<io$_writecheck,io_read>,-	; 10,
		<io$_writepblk,	io_write>,-	; 11,
		<io$_readpblk,	io_read>,-	; 12,
		<io$_writehead,	ilexit>,-	; 13, WRITEHEAD / CRESHAD
		<io$_readhead,	ilexit>,-	; 14, READHEAD
		<15,		ilexit>-	; 15,
		<io$_remshad,	ilexit>-	; 16,
		<io$_available,	io_avail>-	; 17,
		<io$_setprfpath,ilexit>-	; 18,
		<io$_display,	ilexit>-	; 19,
		<20,		ilexit>-	; 20,
		<io$_dse,	io_dse>-	; 21,
-;		<io$_format,	io_format>-	; 30,
		>
ilexit:	cmpb	#io$_format,R1		; media preparation?
	beql	io_format		; yes,
	.if gt	shdon
	 cmpb	#io$_setchar,R1		; shadowing preparation?
	 bneq	4$			; no, continue
	 brw	io_setchar		; yes,
4$:	.endc
	movzbl	#ss$_illiofunc,R0	; otherwise, not supported
;	brb	iodone
;5$:	movzwl	#ss$_volinv,R0		; Set volume invalid status
	brb	iodone			; And exit
; operaton completion
okexit:	movl	s^#ss$_normal,R0	; assume normal completion status
ioexit:	ashl	#16,irp$l_bcnt(R3),R1	; ...merge in the byte count
	bisl	R1,R0
iodone:	clrl	R1
	tstw	R0;;;;;;;;;;;;;;;;;;;;;;; if R0=0, process will hung in
	beql	9$;;;;;;;;;;;;;;;;;;;;;;;  implicits $synch service
	.if gt	alpha32			; complete request
;;;	 pushl	R5			; param-3:ucb
;;;	 pushl	R1			; param-2:iost2
	 pushr	#^m<R0,R1,R5>		; param-1:iost1
	 calls	#3,g^ioc_std$reqcom	; complete i/o request and
	 ret				;     start next request in wait queue
	.iff
	 reqcom
	.endc
9$:	bpt	;;;;;;;;;;;;;;;;;;;;;;;;;
	.dsabl	local_block

;;;	.page
	.sbttl	___io_packack - service PACK ACKNOWLEDGE function
;+==============================================================================
; io_packack - service PACK ACKNOWLEDGE function
; Mark the volume valid by setting UCB$V_VALID in UCB$L_STS.  IO$_PACKACK
; must be the first function issued to the pseudo disk after the driver
; has been loaded.
;	entry	R3=IRP address (I/O request packet)
;		R5=UCB address (unit control block)
;
io_packack:
	bbcc	#dev$v_swl,ucb$l_devchar(R5),1$
1$:	bbss	#ucb$v_lcl_valid,ucb$l_sts(R5),2$
	incb	ucb$b_onlcnt(R5)
	assume	ucb$v_valid ge 8
2$:	.iif gt	alpha32, bisl #ucb$m_valid,ucb$l_sts(R5)
	.iif le	alpha32, bisb #<ucb$m_valid@-8>,ucb$l_sts+1(R5)
	brb	okexit

;;;	.page
	.sbttl	___io_unl - service UNLOAD function
	.sbttl	___io_avail - service AVAILABLE function
;+==============================================================================
; UNLOAD AND AVAILABLE FUNCTIONS
; Mark the volume invalid by clearing UCB$V_VALID in UCB$L_STS.  since
; the disk can't be spun down, these two functions are identical.
;	entry	R3=irp
;		R5=ucb
;-
io_avail:
io_unl:	assume	ucb$v_valid ge 8
2$:	bicb	#<ucb$m_valid@-8>,ucb$l_sts+1(R5)
	brb	okexit
	.dsabl	local_block
	.page
	.sbttl	___io_format - service FORMAT function (set volume size)
;+==============================================================================
; io_format - service FORMAT function (set volume size)
; Deallocate memory associated with current pseudo disk (all data is
; lost), allocate enough memory for the new size and set relevant
; parameters.
;	entry	R3=irp
;		R5=ucb
;		irp$l_media - parameter longword (new size of disk)
;-
	.enable	local_block
1$:	brw	iodone			; abnormal completion
io_format:
	movzbl	#ss$_devmount,R0	; can't IO$_FORMAT while mounted!
	tstl	ucb$l_vcb(R5)		; device mounted by anybody?
	bneq	1$			; yes, error
	assume	ucb$v_valid ge 8
	bicb	#<ucb$m_valid@-8>,ucb$l_sts+1(R5) ; clear software volume valid
	bbcc	#ucb$v_lcl_valid,ucb$l_sts(R5),3$
	decb	ucb$b_onlcnt(R5)
; free allocated internal buffer (in memory buffer as a disk-volume)
3$:	movl	ucb$l_dg_membuf(R5),R0	; any data currently in use?
	beql	4$			; Branch if nothing to deallocate
	movl	ucb$l_dg_memsiz(R5),R1	; length of volume buffer in byte
	beql	4$			; branch if nothing to deallocate
	pushl	R3			; save R3 across call
	assume	dg_fipl eq ipl$_synch	; at proper IPL?
	jsb	g^exe$deanonpgdsiz	; deallocate pool (r0=buffer,r1=size)
	popr	#^m<R3>			; restore pointer to IRP
; allocate new in-memory buffer as a disk volume
	assume	dg_trksiz eq 32		;
4$:	addl	#dg_trksiz-1,irp$l_media(R3) ; round up to next multiple of
	bicl	#dg_trksiz-1,irp$l_media(R3) ;                        32 pages.
	assume	512 eq dg_secsiz
	ashl	#9,irp$l_media(R3),R1	; number of bytes to allocate
	beql	7$			; branch if nothing to allocate
;
; caliculate physical volume size in byte
; physical volume size = (logical volume size) + (length of forced error table)
; forced error size =(logical volume size) / (512bytes/8bit)
;
	.if gt	shdfe
	 assume	512 eq dg_secsiz
	 assume	dg_trksiz eq 32
;;;	 ashl	#-9,R1,R2		; R2=number of logical block (max lbn)
;;;	 ashl	#-3,R2,R2		; sp=max lbn/8bits
	 ashl	#-<9+3>,R1,R2		; R2=forced-error table size in byte
	 addl	R2,R1			; R1=physical volume size in byte
	.endc	;gt shdfe
	jsb	g^exe$alononpaged	; allocate memory
	blbc	R0,1$			; exit if error
	assume	ucb$l_dg_membuf eq ucb$l_dg_memsiz+4
	movq	R1,ucb$l_dg_memsiz(R5)	; length of volume buffer in byte
;;;	movl	R2,ucb$l_dg_membuf(R5)	; save pointer to disk volume buffer
; initialize forced-error flag bit table
	.if gt	shdfe
	 pushr	#^m<R2,R3,R4,R5>	; save registers
	 assume	512 eq dg_secsiz
	 ashl	#9,irp$l_media(R3),R0	; R0=logical volume size in byte
	 subl	R0,R1			; R1=length of forced-error table
	 addl3	R0,R2,ucb$l_dg_fetbl(R5); save forced-error flag bit table
	 pushl	R0			; save logical volume size in byte
	 movc5	#0,(sp),#0,R1,(R2)[R0]	; clear forced-error flag bit table
	 popr	#^m<R1,R2,R3,R4,R5>	;       (it means no revetoring occured)
	.endc
; set characteristics (volume size and cylinder)
	assume	512 eq dg_secsiz
	ashl	#-9,R1,R1		; R1=number of logical block (max lbn)
	movl	R1,ucb$l_maxblock(R5)	; R1=sectors/logical volume
	divl	s^#dg_trksiz,R1		; R1=tracks/logical volume
	assume	dg_cylsiz eq 1		; (1 tracks/cylinder)
;;;	divl	s^#dg_trksiz,R1		; R1=cylinders/logical volume
6$:	movw	R1,ucb$w_cylinders(R5) 	; adjust storage size in cylinders
	brw	okexit
7$:	clrl	ucb$l_dg_membuf(R5)	; mark as not used
;;;	clrl	ucb$l_maxblock(R5)	; set volume size to zero
	movl	#1,ucb$l_maxblock(R5)	; set up a dummy value to allow vms 6.1
	brb	6$			; 5vh initialize utility (devide fault)
	.dsabl	local_block
	.page
	.sbttl	___io_setchar - service SETCHAR function (shadowing preparation)
;+==============================================================================
; io_setchar - service SETCHAR function (shadowing preparation)
; reset device characteristic (dev$m_mscp) and device type.
;	entry	R3=irp
;		R5=ucb
;		irp$l_media - parameter longword
;		(bit07-00:always one , bit15-08:device type)
;-
	.if gt	shdon
io_setchar:
	movzwl	irp$l_media(R3),R1	;
	movzwl	#ss$_badattrib,R0	; assume error
	cmpb	#1,R1
	bneq	3$
	ashl	#-8,R1,R1		; R1=device type
	movzwl	#ss$_devmount,R0	; assume error
	bbs	#dev$v_mnt,ucb$l_devchar(R5),3$
	movzwl	#ss$_devalloc,R0	; assume error
	bbs	#dev$v_all,ucb$l_devchar(R5),3$
;;;	movzwl	#ss$_devreqerr,R0	; assume error
;;;	cmpw	#1000,ucb$w_unit(R5)	; unit 0-999?
;;;	bgtru	3$			; yes, error
	movl	s^#ss$_normal,R0	; set completion code
	movb	R1,ucb$b_devtype(R5)	; update device type
	assume	58 eq dt$_ram_disk
	assume	35 eq dt$_generic_du
;;;	blbc	R1,2$			; shadowing preparation?  no,jump
	cmpb	#dt$_generic_du,R1
	bneq	2$
	bisl	#dev$m_mscp,ucb$l_devchar2(R5) ; yes,
	brb	3$
2$:	bicl	#dev$m_mscp,ucb$l_devchar2(R5)
3$:	brw	iodone			; i/o completion
	.endc	;gt shdon
	.page
	.sbttl	___io_read - move data to the user's buffer
	.sbttl	___io_write - move data from the user's buffer
;+==============================================================================
; io_read - move data to the user's buffer
; io_write - move data from the user's buffer
;	Because the ACP FDT routines call QIODRVPKT, it is necessary for the
;	actual transfer of data from the in-memory pseudo disk to/from the
;	user's buffer to be done here rather than in FDT routines.
;	Since we are no longer in process context, the data is transfered by
;	MOVE_FROM_USER or MOVE_TO_USER, which double map the user buffer
;	using information in UCB$L_SVAPTE.
;	If physical I/O, the specified cylinder, track, and sector are
;	converted to a byte offset from the start of the in-memory buffer.
;	(Note: unlike many real disks, no skew and interleave factors are
;	involved). For logical I/O, the byte offset is also calculated, albeit
;	in a different manner. Having obtained the byte offset by some means,
;	the data is moved from/to the user's buffer.
;	entry	R3=irp
;		R5=ucb
;		irp$l_media=LBN if logio, sector and cylinder if phyio
;		irp$l_bcnt=xfer byte count
;	return	R0=completion code
;	destroy	R2,R4
;-
	.enable	local_block
	.if gt	diagon
;
; convert disk sector address to block address for diagnostics
;
	 irp$b_secadr=irp$l_media+0	; sector number
	 irp$b_trkadr=irp$l_media+1	; track (head) number
	 irp$w_cyladr=irp$l_media+2	; cylinder number
	 assume	ucb$b_sectors+1 eq ucb$b_tracks
	 assume	ucb$b_sectors+2 eq ucb$w_cylinders
0$:	 bbc	#io$v_diagnostic,irp$l_func(R3),5$
	 cmpb	irp$b_secadr(R3),ucb$b_sectors(R5)
	 bgequ	iaddrxt
	 cmpb	irp$b_trkadr(R3),ucb$b_tracks(R5)
	 bgequ	iaddrxt
	 cmpw	irp$w_cyladr(R3),ucb$w_cylinders(R5)
	 bgequ	iaddrxt
; convert cylinder, track, and sector to byte offsets
;	Byte offset = Sector size * ((Sectors per track) * Track + Sector)
	 movzwl	irp$w_cyladr(R3),R1	; get cylinder number
	 assume	dg_cylsiz eq 1		; (1 tracks/cylinder)
	 assume	dg_trksiz eq 32		; (32 sectors/track)
	 ashl	#5,R1,R1		; convert cylinder to sectors
	 addw	irp$b_secadr(R3),R1	;
	 assume	512 eq dg_secsiz
	 ashl	#9,R1,R1		; convert sectors to byte offset
	 brb	6$
	.endc	;gt diagon
	.if gt	shdon-diagon
4$:	 bbc	#io$v_mscpmodifs,irp$l_func(R3),5$
	 brw	force_error		; force error the lbn
	.endc
iaddrxt:movzwl	#ss$_ivaddr,R0
	brw	iodone
;
; write i/o processing
;
io_write:
	.if eq	<shdon*2>-diagon-1
	 bbc	#irp$v_physio,irp$l_sts(R3),5$
	 bbc	#io$v_mscpmodifs,irp$l_func(R3),0$
	 brw	force_error		; force error the lbn
	.endc
	.iif gt	shdon-diagon, bbs #irp$v_physio,irp$l_sts(R3),4$
;
; read i/o processing
;
io_read:.iif gt	diagon, bbs #irp$v_physio,irp$l_sts(R3),0$
5$:	assume	512 eq dg_secsiz	
	ashl	#9,irp$l_media(R3),R1	; convert start lbn to byte offset
;
; both writelblk and writevblk are odd values, so if the lsb is set, we're
; doing a write;otherwise it is a read.
;
6$:	.if gt	shdfe
	 pushr	#^m<R3,R6,R7,R8,R9,R10,R11>
	 pushl	s^#ss$_normal		; assume normal completion
	 movl	ucb$l_dg_fetbl(R5),R10	; R10=forced error flag table
	.iff				;
	 pushr	#^m<R3,R6,R7,R8,R9>	; save registers
	.endc
	check_diskaddr err=17$,buf=R1,knt=R6,lbn=R11
	.if gt	alpha32
	 pushl	R5			; param-1:ucb
	 calls	#1,g^ioc_std$initbufwind; setup window into buffer (r0=buf va)
	 bicl3	#^c<<1@13>-1>,R0,R7	; get the end of the first page
	 ashl	#13,#1,R8		; make R8 a constant 8192 to save space
	.iff
	 jsb	g^ioc$initbufwind	; setup window into buffer (r0=buf va)
	 bicl3	#^c<va$m_byte>,R0,R7	; get the end of the first page
	 ashl	#va$s_byte,#1,R8	; make R8 a constant 512 to save space
	.endc
	movl	R5,R9			; save R5 (also destroyed via MOVC)
	subl3	R7,R8,R7		; determine the first page byte count
	.iif gt	alpha32, cmpl #io$_readpblk,ucb$b_dg_fex(R5)
	.iif le	alpha32, cmpb s^#io$_readpblk,ucb$b_fex(R5)
	blequ	20$			; for read i/o
;;;	brb	10$			; for write i/o
	.dsabl	local_block
;
;	R1=address of internal volume buffer for the starting block-number
;	R3=irp (not used)
;	R5=ucb
;	R6=number of bytes to be moved
;	R7=number of bytes can be moved on first time
;	R8=constant (512)
;	R9=ucb
;	R10=forced error flag table
;	R11=starting block number
;	4*0(sp)=completion code (ss$_normal)
;	4*1(sp)=saved r3
;	4*2(sp)=saved r6
;	4*3(sp)=saved r7
;	4*4(sp)=saved r8
;	4*5(sp)=saved r9
;	4*6(sp)=saved r10
;	4*7(sp)=saved r11
;
; 10$ - move_from_user, block transfer from user buffer as write i/o data
; this routine is called by an i/o driver to move a string from a user
; buffer to an internal buffer as a disk-volume.
;
10$:	movl	R1,R3			; save voolume-buffer address
	cmpl	R6,R7			; are requested bytes less than page ?
	bgtru	12$			; is bytcnt less than bytes on page?
11$:	movl	R6,R7			; yes just move requested bytes
12$:	movc3	R7,(R0),(R3)	 	; move data from user
	.iif gt	shdfe, bbs R11,(R10),15$; forced-error block?
13$:	.iif le	alpha32, movl R9,R5	; restore R5 (UCB pointer)
	subl	R7,R6			; decrement the byte count remaining
	bleq	14$			; if zero, all move done
	addl	#pte$c_bytes_per_pte,ucb$l_svapte(R9) ; point to next spte
	.if gt	alpha32
	 pushl	R9			; param-1:ucb
	 calls	#1,g^ioc_std$filspt	;
	.iff
	 jsb	g^ioc$filspt		; fill in the spt (R0=vritual address)
	.endc
	.iif gt	shdfe, incl R11		; increment block number
	movl	R8,R7			; preinit a full page move (512 bytes)
	cmpl	R8,R6			; is the count remaining more than 512
	blequ	12$			; yes, move just one page
	brb	11$			; no, count is the remaining size
; termination
14$:	.iif gt	alpha32, movl R9,R5	; restore R5 (UCB pointer)
	.if gt	shdfe
	 popr	#^m<R0,R3,R6,R7,R8,R9,R10,R11>
	 brw	ioexit
15$:	 bbsc	R11,(R10),13$		; clear forced-error flag
17$:	 popr	#^m<R0,R3,R6,R7,R8,R9,R10,R11>
	 brw	iaddrxt			;
	.iff
	 popr	#^m<R3,R6,R7,R8,R9>	;
	 brw	okexit			;
17$:	 popr	#^m<R3,R6,R7,R8,R9>	;
	 brw	iaddrxt			;
	.endc
;
; 20$ - move_to_user, block transfer to user buffer as read i/o data
; this routine is called by an i/o driver to move a string from an
; internal disk-volume buffer to a user buffer. 
;
20$:	cmpl	R6,R7			; are requested bytes less than page ?
	bgtru	22$			; is bytcnt less than bytes on page?
21$:	movl	R6,R7			; yes just move requested bytes
22$:	movc3	R7,(R1),(R0)		; move data from to user's buffer
	.iif gt	shdfe, bbs R11,(R10),25$; forced-error block?
23$:	.iif le	alpha32, movl R9,R5	; restore R5 (UCB pointer)
	subl	R7,R6			; decrement the byte count remaining
	bleq	14$			; if zero, all move done
	addl	#pte$c_bytes_per_pte,ucb$l_svapte(R9) ; point to next spte
	.if gt	alpha32
	 movl	R1,R2			; save source buffer address
	 pushl	R9			; param-1:ucb
	 calls	#1,g^ioc_std$filspt	;
	 movl	R2,R1			; restore R1
	.iff
	 jsb	g^ioc$filspt		; fill in the spt (R0=vritual address)
	.endc
	.iif gt	shdfe, incl R11		; increment block number
	movl	R8,R7			; preinit byte cnt for a full page move
	cmpl	R8,R6			; is the count remaining more than 512?
	blequ	22$			; yes, move just one page (512 bytes)
	brb	21$			; no, make the count the remaining cnt
25$:	.iif gt	shdfe, movzwl #ss$_forcederror,(sp) ; mark the force error
	.iif gt	shdfe, brb 23$		; join to main stream
	.page
	.sbttl	___io_dse - security data erase (io$_dse) service routine
;+==============================================================================
; io_dse - security data erase (io$_dse) service routine
;	entry	R3=irp
;		R5=ucb
;		irp$l_media=LBN if logio, sector and cylinder if phyio
;		irp$l_bcnt=xfer byte count
;	return	R0=completion code
;	destroy	R2,R4
;-
io_dse:	.if gt	dseon
	pushr	#^m<R3,R5,R6,R7,R8>
	assume	512 eq dg_secsiz
	ashl	#9,irp$l_media(R3),R4	; convert start lbn to byte offset
	check_diskaddr err=9$,buf=R4,knt=R6,lbn=R2
;
;	R2=starting block number
;	R4=address in disk-volume buffer for the starting LBN
;	R6=number of bytes to be cleared
;
; clear forced error flag
	.if gt	shdfe
	 assume	512 eq dg_secsiz
	 ashl	#-9,R6,R0		; block count to be cleared
	 movl	ucb$l_dg_fetbl(R5),R1	; R1=forced error flag table
2$:	 bbsc	R2,(R1),3$		; clear forced-error flag
3$:	 incl	R2			; increment block number
	 sobgtr	R0,2$
	.endc
; erase the block
	movl	R4,R3			; put output pointer where movc updates
	movzwl	#65536-512,R8		; R8=constant 65024
4$:	movl	R6,R7
	cmpl	R6,R8			; are requested bytes less than page ?
	blssu	5$			; is bytcnt less than bytes on page?
	movl	R8,R7			; yes just move requested bytes
5$:	movc5	#0,(R3),#0,R7,(R3)
	subl	R7,R6
	bgtr	4$
	popr	#^m<R3,R5,R6,R7,R8>
	brw	okexit
9$:	popr	#^m<R3,R5,R6,R7,R8>
	brw	iaddrxt
	.endc	;gt dseon
	.page
	.sbttl	subroutines
	.sbttl	___force_error - service force a LBN request from shadow server
;+==============================================================================
; force_error - service force a LBN request from shadow server
; This routine is used to generate unrecoverable ECC errors on a set of
; logical blocks. It is used by shadowing code when the master copy of a
; particular block has gone bad and the "forced error" bit for this block
; must be set for all members of the shadow set. Since ramdisk doesn't support
; the forced error bit, the alternative is simply to generate an unrecoverable
; ECC error, so all subsequent reads to this block generate an error.
; The ECC error is generated by performing a read long, inverting every byte
; in the block, and performing a write long.
;	entry	R3=irp
;		R5=ucb
;		irp$l_media=starting physical-block-number
;	return	R0=completion code
;	destroy	R0-R2
;	calling	jmp
;-
force_error:
	.if gt	shdfe
	movl	irp$l_media(R3),R0	; R0=starting physical block number
	clrl	R1			; R1=processed byte count
	movl	ucb$l_dg_fetbl(R5),R2	; R2=forced-error flag table
;;;	bgeq	7$
	bbc	#mscp$v_md_error,-	; exit if the MD_ERROR bit not set
		irp$l_media+6(R3),7$	; this bit must be set to force an error
	bbc	#dev$v_swl,-		; exit if device is software
		ucb$l_devchar(R5),4$	;        write locked. Can't support HBS
; The device is write-locked and therefore can not accept the commands
; necessary to cause an uncorrectable ECC error.
	movzwl	#ss$_writlck,R0		; set write-locked status
	brb	5$
2$:	bbss	R0,(R2),3$		; mark as forced-error-flag
3$:	incl	R0			; next lbn to force error
	movab	dg_secsiz(R1),R1	; update accumulated byte count
4$:	cmpl	irp$l_bcnt(R3),R1	;
	bgtru	2$
	movl	s^#ss$_normal,R0
5$:;;;	movl	R1,R1			; get accumulated transfer count
	brw	iodone			; complete the QIO
; The check to determine if the device supports host-based shadowing has
; not yet been made. Therefore, we can attempt to for an error at this time.
7$:	movzwl	#ss$_unsupported,R0	; set unsupported status
	brb	5$
	.iff	;gt shdfe
	 .if gt	shdon
	 movzwl	#ss$_unsupported,R0
	 brw	iodone
	 .endc
	.endc	;gt shdfe
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
bootbf:	.jsb_entry
	movl	b^4(R0),R0		; 8 bytes filled in by SYSBOOT
	movl	b^4(R0),R0		; last location in driver
dg_end:

	.end
??
$	exit	$status .or. (f$ve(savvfy,savvfy/2)*0)
$	endsubroutine
$!==============================================================================