.ntype	__,R31			;  set EVAX nonzero if R31 is a register
.if eq <__ & ^xF0> - ^x50
EVAX = 1
.iff
;EVAX = 0
.endc
	.if	df,evax
evax = 1
alpha=1
bigpage=1
addressbits=32
;					;... EVAX=1 -> Step1
.iif ndf WCB$W_NMAP, evax=2		;... EVAX=2 -> Step2 (ndf as of T2.0)
.iif ndf WCB$W_NMAP, step2=1		;... EVAX=2 -> Step2 (ndf as of T2.0)
	.endc
	.TITLE	JGCtl	;control JFdriver (fragmentation avoider driver)
	.IDENT	'V001'
; By Glenn C. Everhart
; Released for public use.
; axp step 2 (64 bit capable) version
;
; FACILITY:
; 
;
;   This program takes a command of form
;jgctl/flags jgan: otherdisk:
;  where JGAn: refers to a local unit of JGdriver, which is an intercept
; driver furnished to provide extended error retry for a VMS device (usually
; a disk, but any device can be used). Note that this code is directed at
; disks primarily or at other similar devices where the UCB does NOT
; GET DELETED. 
;   The intercept driver will cause erroneous read or write operations on
; its target device to be (invisibly) retried up to a settable number of
; times (8 as it currently stands...this is assembled into jgdriver) in
; the event of error. Its use is otherwise invisible to users and it operates
; by intercepting driver start_io and using the IRP$L_PID hook to get
; access to the IRP after I/O but before the user app sees it.
;
; The AXP version of JGdriver just uses the IRP space from IRP$Q_QIO_P3
; on through IRP$Q_QIO_P5 (in VMS 7.0 and up) for storage of information
; about how many times (if at all) the IRP has been retried, and some bits
; of extra information needed to finish it up. Since this information should
; by start-io time have been fully encoded into the IRP it is expected this
; will not cause problems.
;
; The VAX version uses the IRP$L_KEYDESC field (so long as this is not
; already in use) to point to a small block it allocates from pool to
; hold this information, because there is not room for it in the VAX IRP.
;
; Operation otherwise is the same. At start-io, for r/w,the intercept code looks
; for a magic number in its data storage and if it finds it, assumes that
; it has already set the IRP up. If it does not find it, it sets it up
; and sets the IRP field IRP$L_PID to cause I/O post to go to a routine
; within the intercept driver on completion. It then calls the original
; start-io and returns. (If the operation is not read or write, it just
; calls the original start-io without touching the IRP.)
;
; The completion code examines the I/O status about to be returned to
; the user. If the low bit is 1 (success) it just uses com$post to
; postprocess the IRP (since the driver has already called REQCOM)
; If the low bit is 0, it decrements the error retry count it has and
; requeues (via insioqc) the I/O (from fork level!) to the intercepted
; driver again. If the retry count is exhausted it just cleans up and
; calls com$post (actually, for axp, the step2 replacement) to return
; the final status to the user.
;
; This operation has proven handy for some types of disk storage where
; the retry operation of the native drivers has been inadequate. In
; particular, the VAX DKdriver is not as careful as it might be to retry
; potentially retriable operations, so that using this intercept provides
; an invisible yet highly effective way of ensuring that an error is
; repeatable before the user code sees it. Where timing or other transient
; conditions cause problems, this gives a large advantage. On optical media
; it has been dramatic on VAX. The Alpha DKdriver is more careful, but even
; there, this driver will ensure that errors due to timeouts under heavy
; load are retried before being returned. Since this approach requires NO
; driver code changes it is attractive; it can be applied for those disks
; needing it, and not applied for others. The intercept is device unit
; specific, unlike one which might patch a class driver in memory or
; something of that sort. Units not intercepted operate EXACTLY as before.
;
; The intercept here is one published by Glenn Everhart in 1992 as a
; candidate standard. It works by replacing the victim DDT with its own
; and allows the intercept to be removed completely with a single store
; of a longword. It further allows the intercept to be intercepted, and
; interception and removal can occur in any order. The reason for
; proposing this scheme was precisely that interception and removal become
; order independent, so that any third parties using the intercept can
; freely use it without risk of crashes due to pool reuse, as occurs where
; the interception code is not standardized and an entry is intercepted by
; intercept A, then intercept B, and then intercept A is removed. If
; this scheme is used, removal of intercept A results in the chain being
; reconstituted so that intercept B no longer relies on intercept A's
; presence. (In passing, it should be noted that switching has always been
; on fairly idle systems, so there may be some cache invalidation needed
; to perform such switches safely during load. Setup is done in "safe order"
; though, and this intercept is expected to be used where normally it is
; not needed to remove it.)
;
; Note: define VMS$V5 to build for Version 5.x of VMS.
VMS$V5=1
;
; 
; AUTHOR:
; 
; G. EVERHART
;
; 04-Aug-1989	D. HITTNER	Cleaned up definitions, added messages
; 29-Aug-1989   G. Everhart	Added more flexible device geometry selection
;--
	.PAGE
	.SBTTL	EXTERNAL AND LOCAL DEFINITIONS

	.LIBRARY /SYS$SHARE:LIB/
; 
; EXTERNAL SYMBOLS
; 

	$dyndef
	$ADPDEF				;DEFINE ADAPTER CONTROL BLOCK
	$ATRDEF
	$CRBDEF				;DEFINE CHANNEL REQUEST BLOCK
	$DCDEF				;DEFINE DEVICE CLASS
	$DDBDEF				;DEFINE DEVICE DATA BLOCK
	$ddtdef				;define driver dispatch tbl
	$DEVDEF				;DEFINE DEVICE CHARACTERISTICS
	$DPTDEF				;DEFINE DRIVER PROLOGUE TABLE
	$DVIDEF				;Symbols for $GETDVI service.
	$EMBDEF				;DEFINE ERROR MESSAGE BUFFER
	$FABDEF
	$FATDEF
	$FIBDEF				;Symbols for file information block.
	$IDBDEF				;DEFINE INTERRUPT DATA BLOCK
	$IODEF				;DEFINE I/O FUNCTION CODES
	$IRPDEF				;DEFINE I/O REQUEST PACKET
	$NAMDEF
	$PRDEF				;DEFINE PROCESSOR REGISTERS
	$RMSDEF
	$SBDEF
	$SCSDEF
	$SSDEF				;DEFINE SYSTEM STATUS CODES
	$STSDEF				;Symbols for returned status.
	$TPADEF				;Symbols for LIB$TPARSE calls.
	$UCBDEF				;DEFINE UNIT CONTROL BLOCK
	$VECDEF				;DEFINE INTERRUPT VECTOR BLOCK
	$XABDEF

; 
; UCB OFFSETS WHICH FOLLOW THE STANDARD UCB FIELDS
; DEFINE THESE SO WE KNOW WHERE IN THE UCB TO ACCESS. WE MUST
; SET THE ONLINE BIT OR CLEAR IT, AND ALSO SET
; UCB$HUCB (HOST UCB ADDRESS), UCB$HFSZ (HOST FILE SIZE),
; AND UCB$HLBN (HOST LOGICAL BLOCK NUMBER OF FILE START)
;

	.if	ndf,evax
	$DEFINI	UCB			;START OF UCB DEFINITIONS

;.=UCB$W_BCR+2				;BEGIN DEFINITIONS AT END OF UCB
.=UCB$K_LCL_DISK_LENGTH	;v4 def end of ucb
; USE THESE FIELDS TO HOLD OUR LOCAL DATA FOR VIRT DISK.
; Add our stuff at the end to ensure we don't mess some fields up that some
; areas of VMS may want.
; Leave thisfield first so we can know all diskswill have it at the
; same offset.
$def	ucb$l_oldfdt	.blkl	1	;fdt tbl of prior fdt chain
;
; Add other fields here if desired.
;
$def	ucb$l_ctlflgs	.blkl	1		;flags to control modes
$def	ucb$l_cbtctr	.blkl	1		;how many extents
$def	ucb$l_cbtini	.blkl	1		;init for counter
; preceding 2 fields allow specifying of contig-best-try extents
; on every Nth extend, not every one. This should still help keep
; file extensions from preferentially picking up chaff
$def	ucb$JGcontfil	.blkb	80
;
$DEF	ucb$l_minxt	.blkl	1		;min. extent
$def	ucb$l_maxxt	.blkl	1		;max extent
$def	ucb$l_frac	.blkl	1		;fraction to extend by
$def	ucb$l_slop	.blkl	1		;slop blocks to leave free
; DDT intercept fields
; following must be contiguous.
$def    ucb$s_ppdbgn            ;add any more prepended stuff after this
$def    ucb$l_uniqid    .blkl   1       ;driver-unique ID, gets filled in
                                        ; by DPT address for easy following
                                        ; by SDA
$def    ucb$l_intcddt   .blkl   1       ; Our interceptor's DDT address if
                                        ; we are intercepted
$def    ucb$l_prevddt   .blkl   1       ; previous DDT address
$def    ucb$l_icsign    .blkl   1       ; unique pattern that identifies
                                        ; this as a DDT intercept block
; NOTE: Jon Pinkley suggests that the DDT size should be encoded in part of this
; unique ID so that incompatible future versions will be guarded against.
$def    ucb$s_ppdend
$def    ucb$a_vicddt    .blkb   ddt$k_length
                                        ; space for victim's DDT
			.blkl	4	;safety
$def	ucb$l_backlk	.blkl	1	;backlink to victim ucb
; Make the "unique magic number" depend on the DDT length, and on the
; length of the prepended material. If anything new is added, be sure that
; this magic number value changes.
magic=^xF024F000 + ddt$k_length + <256*<ucb$s_ppdend-ucb$s_ppdbgn-16>>
p.magic=^xF024F000 + ddt$k_length + <256*<ucb$s_ppdend-ucb$s_ppdbgn-16>>
				;an ACE is there or not.
$DEF	UCB$L_JG_HOST_DESCR	.BLKL	2	;host dvc desc.
;
; Set FDT table start mask for each unit by keeping it here.
; We need just enough to get back to user's FDTs.
$def	ucb$l_fdtlgl	.blkl	2	;legal fcn msks
$def	ucb$l_fdtbuf	.blkl	2	;buffered fcn msks
$def	ucb$l_fdtmfy	.blkl	3	;modify fcn
$def	ucb$l_fdtbak	.blkl	3	;"go back" fcn
$def	ucb$l_vict	.blkl	1	;victim ucb for checking
; The following lets us steal start-io and add error retries
$def	ucb$l_omedia	.blkl	1	;storage of orig. irp$l_media
$def	ucb$l_ppid	.blkl	1	;store for irp$l_pid contents
$def	ucb$l_retries	.blkl	1	;counter for i/o retries
$def	ucb$l_hstartio	.blkl	1	;host driver start-io loc.
$def	ucb$l_hstucb	.blkl	1	;host ucb (quick ref)
$DEF	UCB$K_JG_LEN	.BLKW	1	;LENGTH OF UCB
;UCB$K_JG_LEN=.				;LENGTH OF UCB

	$DEFEND	UCB			;END OF UCB DEFINITONS
	.iff ;evax
	$fdt_contextdef
	$fdtdef
	$DEFINI	UCB			;START OF UCB DEFINITIONS

;.=UCB$W_BCR+2				;BEGIN DEFINITIONS AT END OF UCB
.=UCB$K_LCL_DISK_LENGTH	;v4 def end of ucb
; USE THESE FIELDS TO HOLD OUR LOCAL DATA FOR VIRT DISK.
; Add our stuff at the end to ensure we don't mess some fields up that some
; areas of VMS may want.
; Leave thisfield first so we can know all diskswill have it at the
; same offset.
;
;
$def	ucb$l_hucbs	.blkl	1	;host ucb table
;
; Add other fields here if desired.
;
$def	ucb$l_ctlflgs	.blkl	1		;flags to control modes
;
$def	ucb$l_cbtctr	.blkl	1		;How many extends done
$def	ucb$l_cbtini	.blkl	1		;init for counter
; preceding 2 fields allow specifying of contig-best-try extents
; on every Nth extend, not every one. This should still help keep
; file extensions from preferentially picking up chaff
; The following lets us remember what the original stolen device is
; so we can prevent double bashes...
$def	ucb$JGcontfil	.blkb	80
$def	ucb$l_asten	.blkl	1		;ast enable mask store
;
; DDT intercept fields
; following must be contiguous.
$def    ucb$s_ppdbgn            ;add any more prepended stuff after this
$def    ucb$l_uniqid    .blkl   1       ;driver-unique ID, gets filled in
                                        ; by DPT address for easy following
                                        ; by SDA
$def    ucb$l_intcddt   .blkl   1       ; Our interceptor's DDT address if
                                        ; we are intercepted
$def    ucb$l_prevddt   .blkl   1       ; previous DDT address
$def    ucb$l_icsign    .blkl   1       ; unique pattern that identifies
                                        ; this as a DDT intercept block
; NOTE: Jon Pinkley suggests that the DDT size should be encoded in part of this
; unique ID so that incompatible future versions will be guarded against.
$def    ucb$s_ppdend
$def    ucb$a_vicddt    .blkb   ddt$k_length
                                        ; space for victim's DDT
			.blkl	4	;safety
$def	ucb$l_backlk	.blkl	1	;backlink to victim ucb
; Make the "unique magic number" depend on the DDT length, and on the
; length of the prepended material. If anything new is added, be sure that
; this magic number value changes.
magic=^xF013F000 + ddt$k_length + <256*<ucb$s_ppdend-ucb$s_ppdbgn-16>>
p.magic=^xF013F000 + ddt$k_length + <256*<ucb$s_ppdend-ucb$s_ppdbgn-16>>
$DEF	UCB$L_JG_HOST_DESCR	.BLKL	2	;host dvc desc.
;
; Store copy of victim FDT table here for step 2 Alpha driver.
; assumes FDT table is 64+2 longs long
;
; This layout is much easier to deal with than the VAX or STEP1 one...
; fdt$k_length should be 68 longwords for the 64bit case, 66 longs for
; vms 6.1. The code even for 6.1 copied an extra quadword to be certain
; it got everything, so it actually requires no mods for 64 bit FDTs.
; It is essential that the complete FDT and DDT get copied. which
; symbolic use of length symbols will now assure.
$def	ucb$l_myfdt	.blkl	<<FDT$K_LENGTH/4>+4>;user FDT tbl copy + slop for safety
$def	ucb$l_oldfdt	.blkl	1	;fdt tbl of prior fdt chain
$def	ucb$l_vict	.blkl	1	;victim ucb, for unmung check
$def	ucb$l_mungd	.blkl	1	;munged flag, 1 if numg'd
; The following lets us steal start-io and add error retries
$def    ucb$l_omedia    .blkl   1       ;storage of orig. irp$l_media
$def    ucb$l_ppid      .blkl   1       ;store for irp$l_pid contents
$def    ucb$l_retries   .blkl   1       ;counter for i/o retries
$def    ucb$l_hstartio  .blkl   1       ;host driver start-io loc.
$def    ucb$l_hstucb    .blkl   1       ;host ucb (quick ref)
;
$DEF	UCB$K_JG_LEN	.BLKW	1	;LENGTH OF UCB
;UCB$K_JG_LEN=.				;LENGTH OF UCB

	$DEFEND	UCB			;END OF UCB DEFINITONS
	.endc
; TO SET ONLINE:
;	BISW	#UCB$M_ONLINE,UCB$W_STS(R5)  ;SET UCB STATUS ONLINE

; Macro to check return status of system calls.
;
	.MACRO	ON_ERR	THERE,?HERE
	BLBS	R0,HERE
	BRW	THERE
HERE:	.ENDM	ON_ERR

;
;
;
	.PSECT	ADVDD_DATA,RD,WRT,NOEXE,LONG

;
; KERNEL ARG LIST
K_ARG:
	.LONG	2			;2 ARGS: HOST-DVC NAME, VD DVC NAME
	.ADDRESS	DEV_BUF_DESC
	.ADDRESS	VDV_BUF_DESC
;	.ADDRESS	DDFNM
;	.ADDRESS	VDFNM
DEFAULT_DEVICE:
	.ASCID	/SYS$DISK/

	.ALIGN LONG
iosb:	.long	0,0
IOSTATUS: .BLKQ 1
BUFG:	.long	1		;bash flag
	.long	1000		;
DEV_BUF:			; Buffer to hold device name.
	.BLKB	40
DEV_BUF_SIZ = . - DEV_BUF
busz=.-bufg
DEV_BUF_DESC:			; Descriptor pointing to device name.
	.LONG	 DEV_BUF_SIZ
	.ADDRESS DEV_BUF

PID:				; Owner of device (if any).
	.BLKL	1

DEV_ITEM_LIST:			; Device list for $GETDVI.
	.WORD	 DEV_BUF_SIZ	; Make sure we a have a physical device name.
	.WORD	 DVI$_DEVNAM
	.ADDRESS DEV_BUF
	.ADDRESS DEV_BUF_DESC
	.WORD	 4		; See if someone has this device allocated.
	.WORD	 DVI$_PID
	.ADDRESS PID
	.LONG	 0
	.WORD	 4
	.WORD	 DVI$_DEVCLASS	; Check for a terminal.
	.ADDRESS DEV_CLASS
	.LONG	 0
	.LONG	 0		; End if item list.

DEV_CLASS:
	.LONG	1
;**
vbufg:	.long	2	;deassign bash flag. Deassign victim dvc, not JG: dvc.
	.long	1000
VDV_BUF:			; Buffer to hold VDVice name.
	.BLKB	40
VDV_BUF_SIZ = . - VDV_BUF
vbusz=.-vbufg
VDV_BUF_DESC:			; Descriptor pointing to VDVice name.
	.LONG	 VDV_BUF_SIZ
	.ADDRESS VDV_BUF

VPID:				; Owner of VDVice (if any).
	.BLKL	1

VDV_ITEM_LIST:			; VDVice list for $GETDVI.
	.WORD	 VDV_BUF_SIZ	; Make sure we a have a physical device name.
	.WORD	 DVI$_DEVNAM
	.ADDRESS VDV_BUF
	.ADDRESS VDV_BUF_DESC
	.WORD	 4		; See if someone has this device allocated.
	.WORD	 DVI$_PID
	.ADDRESS VPID
	.LONG	 0
	.WORD	 4
	.WORD	 DVI$_DEVCLASS	; Check for a terminal.
	.ADDRESS VDV_CLASS
	.LONG	 0
	.LONG	 0		; End if item list.

VDV_CLASS:
	.LONG	1
;**
DEFNAM:

WRK:	.BLKL	1	;SCRATCH INTEGER
; DESCRIPTOR FOR VDn: "FILENAME"
	.ALIGN LONG
VDFNM:	.WORD	 255.	;LENGTH
VDFTP:	.BYTE	DSC$K_DTYPE_T	;TEXT TYPE
	.BYTE	1	; STATIC STRING
	.ADDRESS	VDFNMD
VDFNMD:	.BLKB	256.	; DATA AREA
	.align long
wrkstr:	.word	20	;length
	.byte	dsc$k_dtype_t	;text
	.byte	1	;static
	.address	wrkdat
wrkdat:	.blkb	20
	.byte	0,0,0,0	;safety
;
; DESCRIPTOR FOR NODE$FWAN: DEVICE NAME
	.ALIGN LONG
DDFNM:	.WORD	 255.	;LENGTH
DDFTP:	.BYTE	DSC$K_DTYPE_T	;TEXT TYPE
	.BYTE	1	; STATIC STRING
DDFNA:	.ADDRESS	DDFNMD
DDFNMD:	.BLKB	256.	; DATA AREA
DDCHN:	.LONG	0
VDCHN:	.LONG	0	;CHANNEL HOLDERS
P1DSC:	.ASCID	/UNIT/
P2DSC:	.ASCID	/FNAM/
deads:	.ascid	/DEASSIGN/	;deassign JG: from disk (turn off)
verds:	.ascid	/VERIFY/	;retry errors on r/w
	.EVEN
; UCB data area
verfg:	.long	0
deafg:	.long	0
HSTUCB:	.LONG	0	;SERVED UCB ADDRESS
VDUCB: .LONG 0		;LOCAL FW/FQ/FD UCB ADDRESS
;
;
ERROR:	.LONG	2
MESS:	.LONG	SS$_ABORT
	.LONG	0

	.PSECT	ADVDD_CODE,RD,NOWRT,EXE,LONG
	.ENTRY	ADVDD,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11>
	clrl	deafg	;not deassign
	pushab	deads
	calls	#1,g^cli$present
	cmpl	r0,#cli$_present	;there?
	bneq	100$
	incl	deafg
100$:
	clrl	verfg
	pushab	verds		;/verify?
	calls	#1,g^cli$present
	cmpl	r0,#cli$_present	;there?
	bneq	1001$
	incl	verfg
1001$:

	PUSHAB	WRK		;PUSH LONGWORD ADDR FOR RETLENGTH
	PUSHAB	VDFNM		;ADDRESS OF DESCRIPTOR TO RETURN
	PUSHAB	P1DSC		; GET P1 (FDn: UNIT)
	CALLS	#3,G^CLI$GET_VALUE	;GET VALUE OF NAME TO VDFNM
	ON_ERR	ADVDD_EXIT
;	tstl	deafg		;/deas? no need for 2nd file
;	bneq	40$
	PUSHAB	WRK			; GET 2ND FILE (served unit)
	PUSHAB	DDFNM			; & ITS DESCRIPTOR
	PUSHAB	P2DSC			; & PARAMETER NAME 'P2'
	CALLS	#3,G^CLI$GET_VALUE	; GET FNM
	ON_ERR	ADVDD_EXIT
	$ASSIGN_S -			; Get a channel to the 
		DEVNAM=DDFNM,-		; device for host file
		CHAN=DDCHN
	ON_ERR	ADVDD_EXIT
; LET ERRORS BY FOR THIS SINCE WE GET OUR INFO VIA OPEN ANYWAY SO
; CHANNEL REALLY DOESN'T HAVE TO BE THERE.
; Get the physical device name, and see if this device has an owner.
; (We must do this so we can get the host UCB address)
	$GETDVI_S -
		CHAN=ddchn,-		; Command line has device name.
		ITMLST=DEV_ITEM_LIST
	BLBS	R0,40$
	BRW	advdd_EXIT
40$:
290$:
; MUST HAVE ASSIGNMENT TO VD: UNIT IN ANY CASE.
	$ASSIGN_S -
		DEVNAM=VDFNM,-		; GET CHANNEL FOR VDn:
		CHAN=VDCHN
	ON_ERR	ADVDD_EXIT		; SKIP OUT IF ERROR
	$GETDVI_S -
		CHAN=vdchn,-		; Command line has device name.
		ITMLST=VDV_ITEM_LIST
	BLBS	R0,140$
	BRW	advdd_EXIT
140$:
; Here do the real work in kernel mode, having now the device
; descriptions and channels to the devces even!
	tstl	deafg		;if /deas, do $qio, then knl work
	bneq	307$
	$CMKRNL_S -
		ROUTIN=BASHUCB,ARGLST=K_ARG
	CMPL	R0,#SS$_NORMAL				;Any errors?
	BEQL	300$					;No, skip error routine
	MOVL	R0,MESS					;Move error to message
;;;	BRW	300$
301$:
; ERROR RETURN ... CLOSE FAB & LEAVE
	$PUTMSG_S	MSGVEC=ERROR			;Pump out error message
; deassign logic
307$:	movl	#2,bufg	;unmung fcn
	$qiow_s chan=vdchn,efn=#4,func=#<io$_format+128>,iosb=iosb,-
	p1=bufg,p2=#busz
; after unbashing the current host, take the JG unit offline
;	$CMKRNL_S -
;		ROUTIN=BASHUCB,ARGLST=K_ARG
	$DASSGN_S CHAN=VDCHN
	ret
300$:
; Since that worked OK, send the format function to the JG unit to
; finish bashing the host disk.
	movl	#1,bufg		;set to bash device
	$qiow_s chan=vdchn,efn=#4,func=#<io$_format+128>,iosb=iosb,-
	p1=bufg,p2=#busz
; BE SURE WE DON'T LEAVE THE CHANNELS ASSIGNED TO THE DEVICES
; EITHER...
303$:	$DASSGN_S CHAN=VDCHN
	$DASSGN_S CHAN=DDCHN			;CLEAN UP I/O CHANNELS
	RET
advdd_exit:
	RET

; BASHUCB - AREA TO MESS UP UCB WITH OUR FILE DATA
; BEWARE BEWARE BEWARE
;  runs in KERNEL mode ... HAS to be right.
;  Saves lots of registers so they're free...
	.ENTRY	BASHUCB,^M<R2,R3,R4,R5,R6,R7,R8,r9,r10,r11>
; TAKEN LOOSELY FROM ZERO.MAR
	.if	ndf,vms$v5
	MOVL	G^SCH$GL_CURPCB,R4	;;; NEED OUR PCB
	.iff
	MOVL	G^CTL$GL_PCB,R4		;;; NEED OUR PCB (VMS V5)
	.endc
	clrl	hstucb
	JSB	G^SCH$IOLOCKW		;;; LOCK I/O DATABASE
	tstl	deafg	;/deas needs no 2nd assign
	bneq	90$
	MOVL	4(AP),R1		;;; ADDRESS DVC NAME DESCRIPTORS (target)
	JSB	G^IOC$SEARCHDEV		;;; GET UCB ADDRESS INTO R1 for tgt
	BLBS	R0,660$
	BRW	BSH_XIT
660$:
;
80$:
	MOVL	R1,HSTUCB		;;; SAVE HOST UCB ADDRESS
	movl	r1,r11			;use r11 for target UCB
	BEQL	166$			;;; ... BUT ZERO UCB ADDRESS LOOKS BAAAAD
90$:
	MOVL	8(AP),R1		;;; ADDRESS VDn NAME DESCRIPTORS
	JSB	G^IOC$SEARCHDEV		;;; GET UCB ADDRESS INTO R1
	BLBS	R0,160$
	BRW	BSH_XIT
160$:
	movl	r1,vducb		;;; store vd ucb
	movl	r1,r5			;use r5 for local ucb (JG dvc)
	beql	166$			;fail if no ucb...
; BUGGER THE UCB
; ASSUMES FILE LBN AND SIZE ALREADY RECORDED
; ALSO ASSUMES THAT ZERO LBN OR SIZE MEANS THIS ENTRY NEVER CALLED.
; (REALLY ONLY WORRY ABOUT ZERO SIZE; IF WE OVERMAP A REAL DEVICE
; THEN ZERO INITIAL LBN COULD BE OK.)
;
; CHECK REF COUNT FIRST... ONLY CAN GET AWAY WITH THIS ON DEVICE
; NOBODY'S USING...
; .. fake this since device may have count messed by advd somehow
; but will be allocated if mounted.
; ... for now ...
554$:
	brb	164$	;(it doersn't matter ifthe local disk is in
			; use...we don't bother it.)
166$:	brw	165$
164$:
; check that both UCBs are disk devices at least!
; We can't be sure all the device characteristics will be the
; same for the local device and the MSCP served remote one (and
; in fact they are not all alike!) but at least they had better
; both be disks or this function is not even approximately
; correct and will probably be quickly fatal to the system.
	tstl	deafg	;/deas? r11 invalid.
	beql	1164$
; for deassign, must set JG offline so it can be turned on again
; but just do all work here & scram.
	cmpl	ucb$l_icsign(r5),#magic	;got right magic no.?
	bneq	1176$		;if not then not JGdriver
; clear online & valid on JG dvc for next time
	.if	df,evax
	bicl	#ucb$m_online,ucb$l_sts(r5)	;set JG unit online
	bicl	#ucb$m_valid,ucb$l_sts(r5)	; & valid
	.iff
	bicw	#ucb$m_online,ucb$w_sts(r5)	;set JG unit online
	bicw	#ucb$m_valid,ucb$w_sts(r5)	; & valid
	.endc
1166$:	movl	#1,r0
	brw	bsh_xit		;unlock & leave
1176$:	movl	#ss$_drverr,r0
	brw	bsh_xit
1164$:
; be sure target is a disk for now, to ensure the target UCB doesn't go
; away. Expand this list later if we want to protect tape, or other
; weird stuff.
	cmpb	ucb$b_devclass(r11),#dc$_disk
	bneq	1176$			;if not disk exit now.
; besure intercept driver is one of ours
	cmpl	ucb$l_icsign(r5),#magic	;got right magic no.?
	bneq	1176$		;if not then not JGdriver
; Be sure the JG unit is not online yet. If it is, someone else will
; be using its UCB so we don't want to screw this up.
	.if	df,evax
	bitl	#ucb$m_online,ucb$l_sts(r5)	;set JG unit online
	bneq	166$
	.iff
	bitw	#ucb$m_online,ucb$w_sts(r5)	;set JG unit online
	bneq	166$
	.endc
; Looks like we're gonna do the assign. Store backpointer for driver to
; check before unmung.
	movl	r11,ucb$l_vict(r5)		;store ucb of victim in JG ucb
; Now get on with the tricky part, replacing the DDT. Do this
; at device IPL so we have reasonable certainty nobody will mess with
; these structures until we get them all put into proper order.
; The DDT structure is 64 bytes long, so grab a block of pool of 64 bytes
; size and copy the existing DDT into it.
; (it is possible to save the old address if the conditional is used)
	.if	df,evax
	bisl	#ucb$m_online,ucb$l_sts(r5)	;set JG unit online
	bisl	#ucb$m_valid,ucb$l_sts(r5)	; & valid
	.iff
	bisw	#ucb$m_online,ucb$w_sts(r5)	;set JG unit online
	bisw	#ucb$m_valid,ucb$w_sts(r5)	; & valid
	.endc
; no need to copy geometry actually
;	movl	ucb$l_maxblock(r11),ucb$l_maxblock(r5)	;copy geom for luck
;	movw	ucb$w_cylinders(r11),ucb$w_cylinders(r5)
;	movb	ucb$b_sectors(r11),ucb$b_sectors(r5)
;	movb	ucb$b_tracks(r11),ucb$b_tracks(r5)
	clrl	ucb$l_ctlflgs(r5); set NOT to retry at first
	tstl	verfg		;/verify?
	beql	61$		;if not branch
	bisl	#^x100000,ucb$l_ctlflgs(r5)	;say to retry errors
61$:
1000$:
165$:
	MOVL	#SS$_NORMAL,R0
BSH_XIT:
	PUSHL	R0
	JSB	G^SCH$IOUNLOCK		;;; UNLOCK I/O DATABASE (DROP IPL)
	POPL	R0			;;; REMEMBER R0
	RET	;;; BACK TO USER MODE NOW
vms$v5=1
	.END ADVDD