.MCALL	.MODULE
.MODULE	INDSU2,VERSION=18,COMMENT=<Subroutines #2> GLOBAL=.ISU2

; Copyright (c) 1998 by Mentec, Inc., Nashua, NH.
; All rights reserved
;
; This software is furnished under a license for use only on a
; single computer system and  may  be  copied  only  with  the
; inclusion of the above copyright notice.  This software,  or
; any other copies thereof, may not be provided  or  otherwise
; made available to any other person except for  use  on  such
; system and to one who agrees to these license  terms.  Title
; to  and  ownership of the software shall at all times remain
; in Mentec, Inc.
;
; The information in this document is subject to change without
; notice and should not be construed as a commitment by Digital
; Equipment Corporation, or Mentec, Inc.
;
; Digital and Mentec  assume  no  responsibility for the use or
; reliability of its software on equipment which is not supplied
; by Digital  or Mentec,  and listed  in the  Software  Product
; Description.
.ENABL	GBL,LC

	.SBTTL	Macro definitions and local data

;+
;System macro calls.
;-

	.MCALL	.PRINT, .DSTAT, .FETCH, .LOOKUP, .GVAL
	.MCALL	.HERR, .SERR, .CLOSE, .SETTOP
	.MCALL	FDBDF$, DEFIN$, FERDF$, RT5DF$

FDBDF$				;Define FDB offsets.
DEFIN$				;Definitions for IND files
FERDF$				;Define file service error codes
RT5DF$				;Define RT specific

	.PSECT	INDSU2

	.NLIST	BEX

	.GLOBL	VOLFLG,DVSTAT,DVINFO

ENAB:	.ASCIZ	/ENABLE DATA/
DISA:	.ASCIZ	/DISABLE DATA/
	.EVEN

	.LIST	BEX

	.SBTTL	DSPLY routine

;+
;DSPLY
;Displays a command string.  All command strings are preceeded by
;an exclamation mark (!)
;-

DSPLY::	JSR	R2,$SAVVR	;Save and volatile registers
	MOV	#CMDBUF,R1	;Get pointer to start of command buffer
	MOVB	#<EXCLAM>,-(R1)	;Prefix with !
	MOV	CMDBL,R2	;Get command buffer length
	INC	R2		;Increment count for !
	MOVB	R2,PRFLAG	;Make non-zero set trailing <CR/LF>.
	CALL	TRCMSG		;Don't care if quiet is on
	MOV	@SP,LINDS	;Make non-zero so we don't enter again for
				;same command line
	RETURN
	.SBTTL	Print message routines

;+
;PRMSG2
;Advance a line print message text.
;
;Input:  R1 -> Message text buffer
;	 R2 =  Count of characters to print
;
;Output: <CR><LF>text (trailing <CR><LF> if specified in PRFLAG)
;
;Modified registers:  R0, R1, R2
;-

	.ENABL	LSB

PRMSG2::SAVE	<R2>			;Save the character count
	MOV	#TERM,R0		;R0 -> at terminal I/O buffer.
	MOV	R0,R2			;R2 -> start of same buffer.
	MOVB	#<CR>,(R2)+		;Insert a carriage return,
	MOVB	#<LF>,(R2)+		;Insert a line feed.
	BR	PRTCOM			;Branch to common print code...

;+
;PRMSG1
;Print . plus a string of text.
;
;Input:  R1 -> message buffer pointer.
;	 R2 =  number of characters to print.
;
;Output: <CR><LF>.TEXT (optional trailing <CR><LF> if PRFLAG bit set.
;
;Modified registers R0, R1, R2
;-

PRMSG1::CMPB	@R1,#<SEMIC>	;Comment?
	BEQ	TRCMSG		;Print the line
	BIT	#<PREFIX>,.LIFLG;Prefix enabled?
	BNE	1$		;Branch if yes
	CMPB	-1(R1),#<SEMIC>	;Possible semicolon? (Pointer adjusted if
				;prefix disabled)
	BEQ	TRCMSG		;Branch if comment
1$:	BIT	#<QUIET>,.LIFLG	;Quiet enabled?
	BNE	3$		;Yes, don't display the string
TRCMSG:	SAVE	<R2>		;Save character count on stack.
	MOV	#TERM,R2	;Point to buffer to sstore string for display
	MOV	R2,R0		;R0 -> start of string display buffer
	BIT	#<PRIDOT>,.LIFLG ;Print a dot?
	BEQ	PRTCOM		;No
	MOVB	#<DOT>,(R2)+	;Store dot as first char of string
PRTCOM:	DEC	@SP		;All bytes moved??
	BLT	2$		;Yes
	MOVB	(R1)+,(R2)+	;Copy a character.
	BR	PRTCOM		;Check for more.

2$:	TST	(SP)+		;Clean up stack before returning
	CLRB	(R2)+		;Insert null character (implies CR/LF)
	TSTB	PRFLAG		;Trailing <CR><LF> desired?
	BNE	TIIO		;Yes
	MOVB	#<200>,-(R2)	;Insert <200> byte (no CR/LF)

;+
;TIIO - Print the message and clean up
;
; Input: R0 -> The message buffer
;	  The buffer must end in one of the following characters:
;		0 (null) means return the carriage after printing the string
;		200 means no carriage return
;
; Output:The message is printed
;
; R0 is modified
;-

TIIO:	CLRB	PRFLAG		;Reset PRFLAG
	.PRINT			;Print contents of message buffer
3$:	BIC	#<PRIDOT>,.LIFLG ;Clear flag - must be reset
	CLC			;Clear C-bit for success
	RETURN			;Return to caller

	.DSABL	LSB
	.SBTTL	PRSYM  - Parse symbol

;+
;PRSYM
;Parse symbol name from command, search symbol table for it, if found
;use it, if not found make entry in table.  If errors are found exit
;directly to error routine.
;
;Input:  R0 -> command buffer
;	 SYMTP = Symbol type with bit 0 cleared
;
;Output: R0 -> updated beyond symbol
;	 R5 -> symbol table entry address
;-

	.ENABL	LSB

PRSYM::	CALL	GTSYM		;Get symbol
	BCC	1$		;Branch if no error
	TRAP	ERSYN		;Syntax error

1$:	TSTB	SPCSYM		;Trying to redefine special symbol?
	BEQ	2$		;Branch if no
	TRAP	ERRES		;Error redefining special symbol

2$:	CALL	SRSYM		;Search symbol table for symbol
	BCS	4$		;Symbol was not found

;+
;At this point we know that a symbol of the given name has been found.  If it
;is a local symbol and we are within a BEGIN/END block see if the symbol is
;outside the current block.  (Note that when searching for a local symbol in
;the search begins at SYMND and continues upward to LSYME.  CONTXT+6 contains
;the start of the local symbol table before the .BEGIN directive.) If the
;symbol entry is within the current block, between SYMND and CONTXT+6, update
;the symbol.  If the symbol is outside, this means that the symbol has not
;been defined within the current block and should be created.  This causes a
;multiple entry for a given symbol.  The characteristics (ie. the symbol
;type do not have to match.  If that symbol is referenced again within the
;current block the newly created symbol will be found first.  Upon leaving the
;.END block (.END) the table pointers are reset erasing the latest symbol
;entry.
;-

	TSTB	GLOBS		;Are we updating a global symbol?
	BNE	3$		;Yes, do normal process
	TSTB	BLOCK		;Are we in a BEGIN/END block?
	BEQ	3$		;No, in first level
	CMP	R5,CONTXT+6	;Was the symbol found in the current block?
	BHIS	4$		;No, create a new entry
3$:	MOVB	SETYP(R5),-(SP)	;Get the symbol type
	BIC	#<1>,@SP	;Strip low bit for type
	CMPB	SYMTP,(SP)+	;Match?
	BEQ	11$		;Branch if yes
	TRAP	ERRED		;Error redefining symbol


;+
;Local symbol.
;-

4$:	MOV	#SEVAL,R2	;Assume symbol type is string or logical
	CMPB	SYMTP,#<NUM>	;Numeric?
	BNE	5$		;Branch if yes
	ADD	#<2>,R2		;Value length = 2 for numeric
5$:	TSTB	GLOBS		;Global symbol?
	BNE	7$		;Branch if yes
6$:	MOV	SYMND,R5	;Get start of local symbol table
	SUB	R2,R5		;Expand it downwards
	CMP	R5,SYMFR	;Overflowed into global symbol table?
	BLO	8$		;Branch if yes - symbol table overflow
	MOV	R5,SYMND	;Set new end of global tableop
	BR	10$

;+
;Global symbol.
;-

7$:	MOV	SYMFR,R5	;Get end of global symbol table
	MOV	R5,R4		;Copy its address and enter symbol there
	ADD	R2,R4		;Point to free area
	CMP	R4,SYMND	;Any space left?
	BLO	9$		;Branch if yes
8$:	TRAP	ERSOV		;Symbol table overflow

;+
;Slot found
;-

9$:	MOV	R4,SYMFR	;Set address of next free slot
10$:	MOV	CRNTS,@R5	;Store symbol name
	MOV	CRNTS+2,2(R5)	;Second word
	MOVB	SYMTP,SETYP(R5) ;Store symbol type (bit 0 may have to be set
				;later for logical and numeric symbols)
	SUB	#SEVAL,R2	;Subtract fixed part of SYMTAB entry
	MOVB	R2,SELEN(R5)	;Store length of value field (may have to be
				;modified later for string symbols)
	BEQ	11$		;Branch if string or logical symbol
	CLR	SEVAL(R5)	;Initialize numeric symbol to 0
11$:	RETURN

	.DSABL	LSB

	.SBTTL	GDFDB - Get data file FDB

;+
;GDFDB
;Get data file program request block (pseudo FDB).  There are four descriptor
;blocks, one for each data file that can be open.  These blocks are linked
;together in a contiguous data block in the data overlay.  The channel
;number is the same number as the number following the '#' in the .DATA
;directive.
;
; Input:  R0 -> Command string just after a .OPEN, .CLOSE, .DATA, or a
;		.ENABLE DATA directive.  To file number field of the form
;			<SPACE>#<FILE NUMBER>
;		Where <FILE NUMBER> is in the range (0,NDATF-1).
;
; Output:	If legal file number found:
;		R0 -> After file number
;		R5 = Address of corresponding FDB
;		C-bit is clear
;		Z-bit is clear If file open
;		Z-bit set if file closed
;
;		If no file number specified:
;		R0 Unchanged
;		R5 -> FDB for data file #0
;		C-bit and Z bit are the same as above
;
;		If illegal file number found:
;		C-bit is set
;
; Registers altered: R0, R5
;-

	.ENABL	LSB
GDFDB::	SAVE	<R0>
	MOV	#DATDN,R5	;Get start of data file FDB area
	CALL	$GNBLK		;Get next non-blank
	BCS	4$		;Branch if end of line
	CMPB	R2,#<LB>	;Was a file number specified?
	BNE	4$		;Branch if no
	MOVB	(R0)+,R2	;Get file number in R2
	SUB	#<'0>,R2	;Convert to binary
	BEQ	2$		;Branch if zero
	CMP	#<NDATF-1>,R2	;In range?
	BLO	5$		;Branch with c-bit set if not
1$:	ADD	#F$SIZE,R5	;Point to next FDB
	DEC	R2		;Decreamnet File number
	BGT	1$		;Loop until pointing at correct FDB
2$:	MOV	@SP,R2		;Get the start of the buffer
3$:	MOVB	(R0)+,(R2)+	;Shift characters down in the buffer
	CMP	R0,CMDBE	;Reached end of buffer?
	BLOS	3$		;Branch if no
	SUB	#3,CMDBE	;Adjust end of buffer pointer
4$:	RESTORE	<R0>
	TSTB	F$FLGS(R5)	;Test if open and clear c-bit.
	RETURN

5$:	RESTORE	<R0>
	RETURN
	.DSABL	LSB
	.SBTTL	FLAB - Find lable

;+
;FLAB
;Find label in direct access label table
;
;Input:  LABL	Label in ASCII
;
;Output: R1,R2	Label in RAD50
;
;	 If the label is found in the direct access label table:
;		C-bit is clear
;		Z-bit set if the entry is first in the table
;		Z-bit clear if entry is not the first in the table
;	 R4 -> entry
;	 R5 -> Next younger entry, or 0 if entry is first in table
;
;	 If not found:
;		C-bit is set
;		Z-bit cleared
;	 R4 -> Oldest entry in table
;	 R5 -> Second oldest entry
;
;Modified registers: R0, R1, R2, R4, R5
;-

	.ENABL	LSB

FLAB::	MOV	#LABL,R0	;Point to label to search
	CALL	CAT5		;Convert to 2 words of RAD50 (in R1, R2)
	BCS	6$		;Something is wrong - give error
	CMPB	@R0,#<DOT>	;If dot
	BEQ	6$		;Branch do to syntax error
	MOV	LABTP,R4	;Get start of FIFO queue
	CLR	R5		;Initialize trailing pointer
1$:	CMP	2(R4),R1	;Match?
	BNE	2$		;Branch if not
	CMP	4(R4),R2	;Second word match?
	BEQ	4$		;Branch if there is a match
2$:	TST	@R4		;End of queue?
	BEQ	3$		;Branch if yes
	MOV	R4,R5		;Save previous entry address
	MOV	@R4,R4		;Get next label entry
	BR	1$		;Loop back

3$:	SEC			;Set C-bit to show label not found
	CLZ			;Clear Z-bit
	BR	5$

4$:	TST	R5		;Set or clear Z-bit, clear C-bit
5$:	RETURN

6$:	TST	(SP)+		;Clean up before error
SYNERR:	TRAP	ERSYN		;Syntax error

	.DSABL	LSB

	.SBTTL CLRLBT - Clear out label table

;+
;CLRLBT
;Clear direct label table
;
;Modified registers: R1
;-

	.ENABL	LSB

CLRLBT::MOV	#LABT,R1	;Get start of table
	MOV	R1,LABTP	;Set pointer
1$:	MOV	R1,@R1
	ADD	#<12.>,(R1)+	;Make pointer to next element
	CLR	(R1)+		;Clear label name
	CLR	(R1)+		;Both words
	ADD	#<6>,R1		;Skip over position context
	CMP	R1,#LABTE	;End of table?
	BLO	1$		;Branch if no
	CLR	-12.(R1)	;Clear pointer in last entry
	RETURN

	.DSABL	LSB
	.SBTTL	KEYWD - Scan line for directive

;+
;KEYWD
;Determine if current line contains a BEGIN or END so that scan routine can
;be smart and not jump into or out of a nested block.
;-

	.ENABL	LSB

KEYWD::	SAVE	<R0,R2,R3>
	CMPB	(R0)+,#<DOT>	;A directive or label?
	BNE	7$		;Branch if no
	CMPB	@R0,#<SEMIC>	;Is this an internal comment (to be ignored)?
	BEQ	7$		;Branch if yes
	BITB	#DATASW,BLKFLG	;Scanning enabled data?
	BEQ	1$		;Branch if no
	MOV	#DISA,R2	;Point to disable data string
	MOV	R0,R3		;Copy buffer pointer
	CALL	CMPAR		;Is this a disable data?
	BCS	7$		;Branch if no
	BICB	#DATASW,BLKFLG	;Yes, clear flag
	BR	7$		;Return

1$:	MOVB	(R0)+,R2	;Get next character
	BEQ	2$		;Branch if end of line
	CMPB	R2,#<COLON>	;Is this a label?
	BEQ	3$		;Branch if yes
	CMPB	R2,#<SPA>	;Delimiter?
	BEQ	2$		;Branch if yes
	CMPB	R2,#<HT>
	BNE	1$		;Branch if no

;+
;At his point it has been determined that we have a directive.  Not a label.
;-

2$:	MOV	4(SP),R0	;Restore pointer for compare
	TSTB	(R0)+		;Point past .
	BR	4$

3$:	MOV	R1,SCR		;Save keyword pointer
	CALL	$GNBLK		;Get next non-blank
	BCS	7$		;If C-bit set, end of line (no keyword)
	CMPB	R2,#<DOT>	;Is it a directive?
	BNE	7$		;Branch if no
	MOV	SCR,R1		;Restore keyword pointer
4$:	MOV	#ENAB,R2	;Point to enable data string
	MOV	R0,R3		;Copy buffer pointer
	CALL	CMPAR		;Is this one?
	BCS	5$		;Branch if no
	BISB	#DATASW,BLKFLG	;Signify now scanning data
	BR	7$		;Return

5$:	MOVB	(R0)+,R3	;Pick up next character
	CMPB	R3,#<'A+40>	;Possible lowercase character?
	BLT	6$		;Branch if no
	CMPB	R3,#<'Z+40>	;Check upper limit	
	BICB	#40,R3		;Convert uppercase
6$:	CMPB	R3,(R1)+	;Same character?
	BNE	7$		;Branch if no
	TSTB	@R1		;End of keyword?
	BNE	5$		;Branch if no
	TST	(PC)+		;Branch around for success
7$:	SEC			;Set C-bit for return
8$:	RESTORE <R3,R2,R0>
	RETURN

	.DSABL	LSB
	.SBTTL	GLAB - Get label from command line

;+
;GLAB
;Get label from command line.
;-

	.ENABL	LSB

GLAB::	CALL	$GNBLK		;Get next non-blank
	BCS	4$		;Branch if error
	TST	R1		;Blank seen?
	BEQ	4$		;Branch if no -error
	DEC	R0		;Back up to first non-blank
GLAB1::	MOV	#LABL,R3	;Get address of search argument
1$:	CMPB	@R0,#<SPA>	;Space or EOL?
	BLOS	2$		;Branch if yes
	CMPB	@R0,#<COLON>	;Is next character a colon?
	BEQ	2$		;Terminate the scan if yes
	MOVB	(R0)+,(R3)+	;Store next character
	CMP	R3,#LBLND	;Have we scanned 6 characters?
	BLO	1$		;Branch for more if not
2$:	CMP	R3,#LABL	;Have we scanned any characters?
	BEQ	4$		;Branch if no - error
3$:	CMP	R3,#LBLND	;End of label?
	BEQ	5$		;Branch if yes
	CLRB	(R3)+		;Zero out rest of label
	BR	3$		;Branch till done

4$:	SEC			;Set C-bit for error
5$:	RETURN

	.DSABL	LSB
	.SBTTL	Label processor

;+
;Label processing
;-

	.ENABL	LSB

LABEL::	CALL	GLAB1		;Get label from command buffer
	BCS	SYNERR		;Branch if syntax error
	CMPB	(R0)+,#<COLON>	;Followed by colon?
	BNE	SYNERR		;Branch if no - syntax error
	CALL	$GNBLK		;See if more in command line
	BCC	2$		;Branch if more
	CALL	FLAB		;See if already marked as direct access label
	BEQ	1$		;Branch if first entry in table
	MOV	@R4,@R5		;Move entry pointed to by R4
	MOV	LABTP,@R4	;Get beginning of table
	MOV	R4,LABTP	;STORE IT AWAY
	BCC	1$		;Branch if entry is found
	TST	(R4)+		;Else store label information
	MOV	R1,(R4)+	;Store label name
	MOV	R2,(R4)+	;
	MOV	#GCML,R0	;Get command file FDB
	CALL	.MARK		;Get position context
	MOV	R1,(R4)+	; and store it
	MOV	R2,(R4)+	;
	MOV	R3,(R4)+	;
1$:	JMP	INDRD		;Read in next line

2$:	DEC	R0		;Back up pointer
	JMP	INTST		;Go process rest of command

	.DSABL	LSB
.SBTTL	GDSTAT - Get device status

;+
;GDSTAT
;Get device status.  Used in .VOL and .TESTDEVICE in INDUTL.MAC.
;First it gets the device name from the command string.  If it is
;an invalid device name a syntax error is generated.  Valid device
;names are 3 characters long.  It can be either a physical or logical
;name.  The colon following the name is optional but nothing should
;the name or colon.  Once it has been determined that the name is 
;valid it is converted to RAD50.  Then a DSTATUS is done to store
;the device status in DVINFO.  It is left up the the calling routine
;to handle the error processing.  In otherwords, immediately after the
;DSTATUS we return to the calling routine.
;
; Input:
;	  R0 -> command string (beyond the directive)
;
; Call:	  CALL	GDSTAT		;Get device status
;
; Output: R1 -> WRKFDB work file descriptor block (1st word is channel)
;	  R2 -> Device DBLK in FDB
;	  DVINFO = 4 words of device status
;	  C-bit clear device was found in tables
;	  C-bit set if device is not found in tables (DVINFO has no status)
;-

	.ENABL	LSB

GDSTAT::CLR	DVSTAT		;Start off new
	CALL	$GNBLK		;Get next non-blank character
	BCS	SYNER		;Syntax error
	TST	R1		;Were there any blanks?
	BEQ	SYNER		;Branch if no
	DEC	R0		;To start of supposed device name
	CALL	CAT5		;Convert to RAD50
	BCS	SYNER		;Something is wrong - give error
	TSTB	@R0		;End of line?
	BEQ	10$		;Branch if syntax is ok
	CMPB	#<COLON>,(R0)+	;Was colon specified with the device name?
	BNE	SYNER		;Branch if no
	TSTB	@R0		;Yes, now is it the end of the line?
	BNE	SYNER		;Branch for syntax error
10$:	CLRB	SPFIR+SEVAL	;Start out without errors
	MOV	#WRKFDB,R2	;Point to special VOLID FDB
	MOV	R1,F$DNAM(R2)	;Store the device name
	MOV	R2,R1		;R1 becomes pointer to FDB
	TST	(R2)+		;R2 -> device name for DSTATUS

	.DSTAT	#DVINFO,R2	;Get device status
	BCS	40$			; Return error if no device
; Determine whether device is a magtape

	MOV	DVINFO,R0
	BIC	#^C<MTBITS>,R0		; Isolate bits that indicate Magtape
	CMP	R0,#MTDEVC		; Is that what it is?
	BNE	15$			; If not, it's not a magtape.
	BIS	#<TAPEFG>,DVSTAT	; Declare it a magtape

; Check to see if device is (T)MSCP

15$:	.GVAL	#EMTBLK,#<SYSGEN>	; get SYSGEN features word
	BIT	#<RTEM$>,R0		; RTEM?
	BNE	30$			; Yes, handlers are only emulated
	CMPB	DVINFO,#<MUDEV>		; MU?
	BEQ	20$			; Yes.  That's TMSCP
	CMPB	DVINFO,#<DUDEV>		; DU?
	BNE	30$			; No - Branch if not MSCP.
20$:	BIS	#<MSCPFG>,DVSTAT	; It is MSCP
30$:	CLC				; Indicate DEVICE VALID
40$:	RETURN

SYNER:	TRAP	ERSYN			; Syntax error

	.DSABL	LSB
	.SBTTL	GDSTA1 - Get Device Status part II (IGTDUS)

;+
;GDSTA1
;Get DU status to differentiate between NSD and OFL
;
; Input:  Nothing is passed to this routine.
; Output: Carry is clear if device really exists and set if it doesn't.
;
; Call:	CALL	GDSTA1
;-

	.ENABL	LSB

GDSTA1::CALL	GETDUS		;This is a call to bring the UT1 overlay in
10$:	CALLR	REGET		;Reload INDUTL overlay and return to caller
				; therein

; Get LD status.  Called from INDUTL overlay, transfers control to INDUT2
; to routine LDSTAT, then back again.

LDSTAR::CALL	LDSTAT		;This is a call to bring the UT2 overlay in
	BR	10$		;Reload INDUTL and return to caller

	.DSABL	LSB
	.SBTTL	GETHDL - Get handler in core if not resident
;+
;GETHDL
; Get handler in core if not resident.  Called by VOL and TESTDV in INDUTL.
; Gets top of memory.  If the handler is not resident, FETCHes it.
; If the LOKFLG bit is set in DVSTAT, does a Non-File-Structured LOOKUP.
;
; Input:	R1 = address of FDB (1st entry is channel)
;		R2 = address of device DBLK
;		PRGEND end of IND
;		DVINFO DSTATUS information block
;
; Call:	BIS	#LOKFLG,DVSTAT
;	CALL	GETHDL			; Get handler in core and do LOOKUP
;-

	.ENABL	LSB

GETHDL::MOV	R4,-(SP)
	MOV	#DVSTAT,R4		; Economize with R4.
	CLR	F$ERR(R1)		; Assume no errors
	BIC	#<FCHFLG!LOAFLG>,@R4	; Assume handler NOT FETCHED/LOADED
	.SERR				; trap FETCH and LOOKUP errors
	TST	DVINFO+4		; Is handler resident?
	BNE	10$			; Branch if yes

; Check for room above IND for a FETCH operation.  Given enough space,
; .FETCH the handler.

	MOV	PRGEND,R0		; Get address of first available space
	ADD	DVINFO+2,R0		; Add size of handler to be FETCHed
	MOV	R0,-(SP)		; New upper limit
	.SETTOP
	CMP	R0,(SP)+		; Do we have the room?
	BLO	110$			; No, give error

	.FETCH	PRGEND,#WRKFDB+F$DNAM	; FETCH the handler into memory
	BCS	110$			; not fetchable
	BIS	#<FCHFLG>,@R4		; Declare it FETCHED
	BR	20$

; At this point we have a valid device.  Perform a non-file structured LOOKUP.
; The sequence number = #0 is used to rewind tape devices.

10$:	BIS	#<LOAFLG>,@R4		; Handler was loaded
20$:	BIT	#<LOKFLG>,@R4		; Want a LOOKUP?
	BEQ	40$			; Skip it if not.

				.ASSUME  F$CHAN EQ 0	; F$CHAN(R1)
	.LOOKUP	#EMTBLK,@R1,R2,#0	; Do LOOKUP
	BCS	60$			; Branch if a LOOKUP error occurred
	BIS	#<ONLFLG>,@R4		; Device is ONLINE
30$:	CLR	VOLFLG			; Don't need it on no more from .VOL
40$:	.HERR				; Make monitor handle serious errors
	MOV	(SP)+,R4		; Thanks, Mr. R4!
	MOV	R1,R0			; Let R0 -> FDB on return
	RETURN				; This is the ONLY return for GETHDL.
;	......
;+
; LOOKUP error.  Set error code in FDB before processing an error.
;-

60$:	CMPB	@#ERRBYT,#2		; non-shareable, already allocated?
	BEQ	70$			; Branch if yes
	CMPB	@#ERRBYT,#-2		; Is this device owned by another job?
	BEQ	65$			; Branch if so.
	CALL	RER			; Declare READ_ERROR
	BR	80$			; Get name and leave.

65$:	BIT	#<FCHFLG>,@R4		; Fetched?
	BNE	70$			; Yes, no special checks - it exists.
	TST	DVINFO+4		; Handler loaded?
	BEQ	80$			; No, and it's not fetched either
70$:	BIS	#<ATTFLG>,@R4		; Indicate device attached elsewhere

80$:	TST	VOLFLG			; Did we come from .VOL in INDTES?
	BNE	30$			; Yes, just return and get error there
	CALL	INDDEV			; Go find physical device name
	BCC	90$			; Any more errors?  Branch if not.
	CALL	RER			; Declare READ_ERROR
90$:	CALL	REGET			; Reload INDUTL, return to caller
	BR	30$			; no error because attached elsewhere
;	......

; FETCH error

110$:	MOV	#<IE.NOS>,F$ERR(R1)	; No space for handler error code
	MOVB	F$ERR(R1),SPFIR+SEVAL	; Store error code in special symbol
	BR	80$
;	......

; Set the READ_ERROR condition, and NOT_ONLINE

RER:	MOV	#<IE.RER>,F$ERR(R1)	; Device read error
	BIC	#<ONLFLG>,@R4		; Device is NOT online
	RETURN
;	......

	.DSABL	LSB

	.END