.TITLE	FD - Force a deallocation on another device
	.LIBRARY	/SYS$LIBRARY:LIB.MLB/		; I'm lazy

; This program will prompt for a device name, determine the allocator of
; the device, and force on him/her/it a deallocation of the device.
; The forced deallocate is done via a kernel-mode AST.

; The deallocate will fail if either of the following holds:
; (a) The owner of the device is in SUSPended state,
; (b) The owner of the device has active channels to the device.
;
; Case (a) fails since ASTs cannot be delivered to suspended processes.
; Case (b) falls out of the $DALLOC system service.  Enthusiastic hackers
;          who are annoyed at this restriction can modify the code to
;	   deassign open channels first, but this is a risky undertaking.

; JCH 29-May-1984

; Assembly instructions:
;	$ MACRO FD

; Link instructions:
;	$ LINK  FD,SYS$SYSTEM:SYS.STB/SELECT

; Execution instructions:
;	$ SET PROCESS/PRIVELEGE=CMKRNL
;	$ RUN FD	
;		(Foreign command interface also supported)

	$ACBDEF
	$DVIDEF
	$DYNDEF
	$IRPDEF
	$PCBDEF

.IIF NDF,PCB$L_EPID,PCB$L_EPID=PCB$L_PID	; V3/V4 compatability

	.ENTRY		FD,^M<>
GETDEV:	PUSHAW		DEVNAM		; Length
	PUSHAQ		PROMPT		; Prompt string
	PUSHAQ		DEVNAM		; Answer
	CALLS		#3,G^LIB$GET_FOREIGN
	BLBS		R0,GETPID	; Now we know the device
	RET				; Error, return
GETPID:	$GETDVI_S	DEVNAM=DEVNAM,ITMLST=ITMLST
	BLBS		R0,GOTPID	; Now we know the PID of the owner
	RET				; Error, return

GOTPID:	TSTL		PID		; Zero?
	BNEQ		DOIT		; No, there's an owner
	PUSHAQ		NOBODY		; Zero PID <==> No owner
	CALLS		#1,G^LIB$PUT_OUTPUT
	RET

DOIT:	$CMKRNL_S	ROUTIN=BUTLER,ARGLST=PARMS
	RET				; All done

; The following procedure is copied to nonpaged pool and executed
; as kernel-mode code in the context of the target process.  Much
; of the code is inspired by RSE.MAR.

	.ENTRY	DEALLOCATE,^M<>		; AST routine to deallocate device
	MOVAL	DEVNAM+8,DEVNAM+4	; PIC-ify (us having been moved)
	$DALLOC_S	DEVNAM=DEVNAM	; Deallocate at the highest mode
	RET				; Clean up and exit AST
DEVNAM:	.ASCID		/                                          /
DEALLOCATE_END:

; End of special code

	.ENTRY	BUTLER,^M<R2,R3,R4,R5>
A_ASTD=  04	; Address of AST routine descriptor
A_PID=   08	; Address of PID
	CMPB	(AP),#2			; Enough args?
	BGEQ	2$			; Yes, OK
	MOVZWL	#SS$_INSFARG,R0		; No, error
	RET
2$:	MOVL	@A_PID(AP),R4		; Get the PID
	BSBW	FIXR4			; Convert E/I PID to PCB address
	BBS	#PCB$V_DELPEN,PCB$L_STS(R4),10$ ;  Marked for delete ?

; First part -- allocate NP pool for AST control block.

	MOVZWL	#ACB$C_LENGTH,R1	; Set size required
	JSB	@#EXE$ALONONPAGED	; Allocate a block
	BLBS	R0,20$			; BR if allocate went OK
10$:	BRW	99$			; Chain them branches!
20$:	MOVB	#DYN$C_ACB,ACB$B_TYPE(R2); Set type of structure
	MOVW	R1,ACB$W_SIZE(R2)	;  and size of structure
	CLRL	ACB$L_ASTPRM(R2)	; No ASTPRM
30$:	CLRB	ACB$B_RMOD(R2)			; Must be Kernel mode
	MOVL	PCB$L_PID(R4),ACB$L_PID(R2)	; Set PID for AST
	MOVL	R2,R4			; Save ACB for later

; Second, allocate nonpaged pool and copy routine therein.  We provide
; a "jacket" routine to make the right things happen, and it goes in
; front of the target routine.

	MOVL	A_ASTD(AP),R5		; Address of descriptor
	MOVZWL	(R5),R1			; Size of block to allocate
	ADDL	#12+OH_SIZE,R1		; Plus overhead for jacket
	JSB	@#EXE$ALONONPAGED	; Allocate it
	BLBC	R0,88$			; Can't, back off and exit
	PUSHR	#^M<R2,R3,R4,R5>	; Save regs over MOVC
	MOVC3	#OH_SIZE,JACKET,12(R2)	; Copy AST jacket code, update R3
	MOVL	A_ASTD(AP),R5		; Get back descriptor
	MOVC3	(R5),@4(R5),(R3)	; Copy the target code to NPP
	POPR	#^M<R2,R3,R4,R5>	; Get regs back
	ADDW3	#12+OH_SIZE,(R5),IRP$W_SIZE(R2)	; Insert size....
	MOVB	#DYN$C_LOADCODE,ACB$B_TYPE(R2)	; Call it loaded code
	MOVAL	12(R2),ACB$L_AST(R4)	; Set AST address in ACB
	MOVL	R4,R5			; Set address of ACB
	CLRL	R2			; Null priority increment
	JSB	@#SCH$QAST		; Queue AST for process
	CVTBL	#1,R0			; Success!
	RET				; Done, return

; Error path if AST code can't be copied to NPP.  Must deallocate AST blk.

88$:	PUSHL	R0			; Save error code
	MOVL	R2,R0			; Address in R0
	JSB	@#EXE$DEANONPAGED	; Call it
	POPL	R0			; Restore error code
;	BRB	99$			; And return R0/ error code

;  Error path if nonpaged pool allocation fails or process is delpend

99$:	RET				; Return, R0/ error code

; Routine to take IPID or EPID in R4 and convert to PCB address.
; Destroys R0-R2, returns PCB address in R4 (thus destroying PID).

FIXR4:	MOVL	R4,R0			; Save PID
	MOVZWL	G^SGN$GW_MAXPRCCT,R1	; Process count
	MOVL	G^SCH$GL_PCBVEC,R2	; Address
	DECL	R1			; Skip system
10$:	MOVL	(R2)[R1],R4		; Next PCB
	CMPL	R0,PCB$L_PID(R4)	; IPID match?
	BEQL	20$			; Yes, done
	CMPL	R0,PCB$L_EPID(R4)	; (V4 only) EPID match?
	BNEQ	30$			; No, try looking elsewhere
20$:	RSB				; With PCB address in R4
30$:	SOBGTR	R1,10$			; Loop over all processes
	MOVZWL	#SS$_NONEXPR,R0		; "Nonexistent process"
	RET				; Exit K-mode

JACKET:	.WORD	0		; Jacket routine to call user routine
	CALLS	#0,B^CALLER	; Call user-supplied routine
	PUSHL	#^X04500198	; Stick a CVTBL #1,R0 / RET on the stack
	PUSHAB	(SP)		; Point to it
	MOVAL	JACKET-12,R0	; Block to deallocate
	JMP	@#EXE$DEANONPAGED;Deallocate block and exit AST, R0/1
CALLER:				; Customer code ends up here in NPP
OH_SIZE=.-JACKET

PARMS:	.LONG	 2	; 2 arguments
	.ADDRESS ASTD	; AST routine descriptor:  length (bytes) and
			;  address of entry mask of code to execute
	.ADDRESS PID 	; EPID or IPID of process who will execute the code

PROMPT:	.ASCID		/Device: /
NOBODY:	.ASCID		/Not currently allocated/
ITMLST:	.WORD		4,DVI$_PID
	.ADDRESS	PID
	.BLKL		1
	.LONG		0
ASTD:	.LONG		DEALLOCATE_END-DEALLOCATE
	.ADDRESS	DEALLOCATE
PID:	.BLKL		1
	.END	FD