MODULE help_help (
		LANGUAGE (BLISS32),
		ADDRESSING_MODE(EXTERNAL=GENERAL,
				NONEXTERNAL=LONG_RELATIVE),
		IDENT = 'V04-000',
		MAIN = HELP$START
		) =
BEGIN

!
!****************************************************************************
!*									    *
!*  COPYRIGHT (c) 1978, 1980, 1982, 1984 BY				    *
!*  DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS.		    *
!*  ALL RIGHTS RESERVED.						    *
!* 									    *
!*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED   *
!*  ONLY IN  ACCORDANCE WITH  THE  TERMS  OF  SUCH  LICENSE  AND 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.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE IS  HEREBY   *
!*  TRANSFERRED.							    *
!* 									    *
!*  THE INFORMATION IN THIS SOFTWARE IS  SUBJECT TO CHANGE WITHOUT NOTICE   *
!*  AND  SHOULD  NOT  BE  CONSTRUED AS  A COMMITMENT BY DIGITAL EQUIPMENT   *
!*  CORPORATION.							    *
!* 									    *
!*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE  OR  RELIABILITY OF ITS   *
!*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
!* 									    *
!*									    *
!****************************************************************************

!++
!
! FACILITY:  DCL $HELP command
!
! ABSTRACT:
!
!	The DCL HELP command provides on-line information retrieval.
!
! ENVIRONMENT:
!
!	VAX native, user mode.
!
!--
!
!
! AUTHOR:  Peter George,	 CREATION DATE:  1-May-1981
!
! MODIFIED BY:
!
!	V03-006	MCN0177		Maria del C. Nasr	11-Jul-1984
!		Make /NOOUTPUT suppress all output.  Allow prompting
!		with /[NO]OUTPUT qualifier only if explicitly specified.
!
!	V03-005	PCG0017		Peter George		11-Apr-1984
!		Modify defaulting of output stream, processing
!		of /USERLIBRARY, and signalling of errors returned
!		by LBR$OUTPUT_HELP.
!
!	V03-004	PCG0016		Peter George		12-Oct-1983
!		Abort on write errors.
!
!	V03-003	PCG0015		Peter George		15-Sep-1983
!		Change page break prompt.
!
!	V03-002	PCG0014		Peter George		15-Dec-1982
!		Use CLI$INTERFACE routines for parsing.
!		Clean up some code.
!		Fix HELP/PAGE in command procedures.
!
!	V03-001	PCG0013		Peter George		01-Jul-1982
!		Add /LIBLIST and /INSTRUCTION qualifiers.
!--

LIBRARY
    'SYS$LIBRARY:STARLET';

REQUIRE
    'HELPDEF';

!
! Declare static strings
!
MACRO
    SD[A] =
	BIND %NAME('SD_',A) = $descriptor(a)%;

SD(
	'KEYWORDS',
	'PROMPT',
	'PAGE',
	'OUTPUT',
	'LIBRARY',
	'LIBLIST',
	'INSTRUCTIONS',
	'USERLIBRARY',
	'ALL',
	'NONE',
	'PROCESS',
	'GROUP',
	'SYSTEM',
	);

BIND
    pagebrk_prompt = $DESCRIPTOR ('Press RETURN to continue ... '),
    sysinput = $DESCRIPTOR ('SYS$INPUT') : $BBLOCK;

EXTERNAL ROUTINE
    lib$get_input,		! Get a line from SYS$INPUT
    scr$erase_page,		! Clear screen
    lbr$output_help,		! Get help text
    cli$get_value,		! Get entity value
    cli$present;		! Is entity present

EXTERNAL
    lbr$gl_rmsstv : ADDRESSING_MODE(GENERAL);	! RMS STV from librarian

FORWARD ROUTINE
    get_input,					! Get a line of input text
    print_help_line,				! Driver to call help output routines
    put_page_break,				! Put a page break
    put_output,					! Put a line of output text to the screen
    find_file_info,				! Determine characteristics of SYS$OUPUT
    open_sysinput,				! Open SYS$INPUT
    open_sysoutput,				! Open SYS$OUTPUT
    clean_up,					! Deassign, disconnect, close all open files
    make_upper_case;				! Upper case a string
    
EXTERNAL LITERAL
    cli$_present,				! Entity is present
    cli$_defaulted,				! Entity is present by default
    cli$_negated,				! Entity is explicitly negated
    lbr$_endtopic;				! Status telling lbr$output_help to abort
						! help on a particular topic

LITERAL
    true = 1,					! Truthness
    false = 0;					! Falsity

OWN
    sysinchan,					! Channel assigned to SYS$INPUT
    sysoutrab  : $BBLOCK [rab$c_bln],		! RAB for output to SYS$OUTPUT
    sysout_name : $BBLOCK [dsc$c_s_bln],	! String descriptor for result name
    sysoutdesc : $BBLOCK [dsc$c_s_bln],		! String descriptor for output file name
    outputdesc : $BBLOCK [dsc$c_s_bln],		! Local descriptor for prompt response
    outputbuf : $BBLOCK [hlp$c_pagesize],	! Buffer for prompt
    current_height : INITIAL (0),		! Number of lines currently output
    list_height,				! Number of lines on a page
    help_flags : $BBLOCK [4];			! Control flags


GLOBAL ROUTINE help$start (arglist) =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine is called by CLI when the HELP command is entered.
!	The keys are parsed and the librarian is called to extract the
!	help from the help library.
!
! INPUTS:
!
!	User's command line.
!
! OUTPUTS:
!
!	The requested help text is displayed on the current SYS$OUTPUT:
!
! ROUTINE VALUE:
!
!	Always true.
!
!--

LOCAL
    getcmd_desc : $BBLOCK [dsc$c_s_bln],			! Command descriptor
    libraryname : $BBLOCK [dsc$c_s_bln],			! String descriptor for library name
    library_addr,						! Address of library desc
    list_width,							! Number of chars per line
    listingfab  : $BBLOCK [fab$c_bln],				! FAB for output to listing
    sysoutfab : $BBLOCK [fab$c_bln],				! FAB for output to terminal
    sysoutnam  : $BBLOCK [nam$c_bln],				! NAM block for SYS$OUTPUT
    status;

! Get help keys and uppercase them
! 
CH$FILL (0, dsc$c_s_bln, getcmd_desc);
getcmd_desc [dsc$b_class] = dsc$k_class_d;
CLI$GET_VALUE (sd_keywords, getcmd_desc);
make_upper_case (getcmd_desc, .getcmd_desc [dsc$a_pointer]);

! Get output file.
!
CH$FILL (0, dsc$c_s_bln, sysoutdesc);				! Init output descriptor
IF CLI$PRESENT (sd_output)					! If /OUTPUT
THEN 								! Then get output file
    BEGIN
    sysoutdesc [dsc$b_class] = dsc$k_class_d;
    CLI$GET_VALUE (sd_output, sysoutdesc)	
    END
ELSE
    ! /NOOUTPUT was specified, so suppress all output
    !
    BEGIN
    sysoutdesc [dsc$w_length] = %CHARCOUNT('NL:');
    sysoutdesc [dsc$a_pointer] = UPLIT BYTE ('NL:');
    END;

! Get library file.
!
IF CLI$PRESENT (sd_library)					! If /LIBRARY
THEN 								! Then get library name
    BEGIN
    CH$FILL (0, dsc$c_s_bln, libraryname);
    libraryname [dsc$b_class] = dsc$k_class_d;
    CLI$GET_VALUE (sd_library, libraryname);
    library_addr = libraryname;
    END
ELSE library_addr = 0;						! Else Use null arg in call

!
! Initialize all flags.  Set prompt flag off if /OUTPUT or /NOOUTPUT qualifier
! is present, and prompt set by default. 
!
help_flags = 0;
IF ((CLI$PRESENT (sd_output) EQL CLI$_PRESENT
     OR CLI$PRESENT (sd_output) EQL CLI$_NEGATED)
   AND (CLI$PRESENT (sd_prompt) EQL CLI$_DEFAULTED))
THEN
    help_flags [hlp$v_prompt] = false
ELSE
    help_flags [hlp$v_prompt] = CLI$PRESENT (sd_prompt);

!
! Parse /USERLIBRARY
!
help_flags = .help_flags AND NOT hlp$m_process 			! By default don't search any tables
	       AND NOT hlp$m_group AND NOT hlp$m_system;		!
IF CLI$PRESENT (sd_userlibrary)					! If /USERLIBRARY is specified
THEN 
    BEGIN
    IF CLI$PRESENT (sd_all)					! If ALL 
    THEN help_flags = .help_flags OR hlp$m_process OR 		! Then search all tables
			hlp$m_group OR hlp$m_system;		!
    IF CLI$PRESENT (sd_none)					! If NONE 
    THEN help_flags = .help_flags AND NOT hlp$m_process 	! Then don't search any tables
		       AND NOT hlp$m_group AND NOT hlp$m_system;!
    IF CLI$PRESENT (sd_process)					! If PROCESS
    THEN help_flags [hlp$v_process] = true;			! Then search it
    IF CLI$PRESENT (sd_group)					! If GROUP
    THEN help_flags [hlp$v_group] = true;			! Then search it
    IF CLI$PRESENT (sd_system)					! If SYSTEM
    THEN help_flags [hlp$v_system] = true;			! Then search it
    END;

!
! Get other flags
!
help_flags [hlp$v_page] = CLI$PRESENT (sd_page);		! Set paging flag
help_flags [hlp$v_help] = CLI$PRESENT (sd_instructions);	! Set instructions flag
help_flags [hlp$v_liblist] = CLI$PRESENT (sd_liblist);		! Set default library list flag

!
! Get and set output device characteristics.
!
open_sysoutput (sysoutfab, sysoutnam);				! Open SYS$OUTPUT
find_file_info (sysoutfab, list_width);				! Get characteristics of output
current_height = .list_height - 3;				! Don't generate page break prompt yet
outputdesc [dsc$w_length] = 0;					! Init prompt command descriptor
outputdesc [dsc$a_pointer] = outputbuf;				!

!
! Open SYS$INPUT if prompting or paging in effect
!
IF .help_flags [hlp$v_prompt] OR .help_flags [hlp$v_page]	! If prompting or pating
   THEN open_sysinput ();					! Then open SYS$INPUT

!
! Call lbr$output_help to do all the real work.
!
status = lbr$output_help (print_help_line, list_width,		! Call LBR$OUTPUT_HELP
	    getcmd_desc, .library_addr, help_flags, get_input);	!

clean_up (sysoutfab);						! Close all the files that have been opened

RETURN .status;
END;								! Of help$start

ROUTINE get_input (get_str, prompt_str, out_len) =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine prompts the user and gets a line of text from SYS$INPUT.
!
! INPUTS:
!
!	get_str =	address of the string descriptor to receive the input string
!
!	prompt_str =	address of the descriptor for the prompt string
!
!	out_len	=	address of a longword to receive the length of the input string
!
! OUTPUTS:
!
!	get_str : as described above
!
! ROUTINE VALUE:
!
!	The status of the QIO.
!
!--

MAP
    get_str : REF $BBLOCK,
    prompt_str : REF $BBLOCK;

LOCAL
    iosb : VECTOR [2],						! I/O status block
    term_char : VECTOR [4],					! QIO input termination characters
    status;							! Local status

!
! If paging is in effect, always generate a page break after a prompt.
!
current_height = .list_height - 3;				! Generate page break with next help text

!
! If an answer for this prompt already exists, then skip the prompt and
! use it.
!
IF (.outputdesc [dsc$w_length] NEQ 0) 				! If old response is around
   THEN BEGIN							! Then use it
	get_str [dsc$w_length] = .outputdesc [dsc$w_length];	! Copy it
	CH$MOVE (.outputdesc [dsc$w_length], 			!
		.outputdesc [dsc$a_pointer], 			!
		.get_str [dsc$a_pointer]);			!
	outputdesc [dsc$w_length] = 0;				! Clear old descriptor
	RETURN true;						! Return success
	END;							!

!
! If SYS$INPUT is not a terminal, then use LIB$GET_INPUT.  Otherwise,
! do QIO's to solicit input.
!
IF .help_flags [hlp$v_notterm]					! Is SYS$INPUT a terminal?
   THEN IF (status = lib$get_input (.get_str,.prompt_str,.out_len)) ! No, use LIB$GET_INPUT
		OR (.status EQL RMS$_EOF)			!
	   THEN RETURN .status					! Return success or EOF
	   ELSE SIGNAL_STOP (.status);				! Stop if error

!
! Initialize input termination characters.
! Use usual set plus '?'.
!
term_char [0] = 8;						! Size of terminator mask
term_char [1] = term_char [2];					! Address of terminator mask
term_char [2] = %X'FFFFE0FF';					! Quadword terminator mask
term_char [3] = %X'80000000';					!

!
! Do QIO and wait for completion.
!
IF NOT (status = $QIOW (CHAN = .sysinchan,			! Input channel
			IOSB = iosb,				! I/O status block
			FUNC = IO$_READVBLK OR IO$_READPROMPT,	! QIO type is read with prompt
			P1 = .get_str [dsc$a_pointer],		! Input buffer
			P2 = hlp$c_pagesize,			! Size of buffer
			P4 = term_char,				! Terminator mask
			P5 = .prompt_str [dsc$a_pointer],	! Prompt string address
			P6 = .prompt_str [dsc$w_length]))	! Prompt string length
   THEN SIGNAL_STOP (.status);					! Stop if error

get_str [dsc$w_length] = .(iosb[0])<16,16> + 1;			! Return length of get string

RETURN .status;							! Return QIO status
END;

ROUTINE print_help_line (linedesc) =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
!	Driver for the two output routines in this module.
!	Calls put_page_brk and put_output.
!
! INPUTS:
!
!	linedesc =	address of string descriptor for the line of help
!			text to be output
!
! OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	Status returned by put_page_break
!
!--

IF NOT put_page_break ()					! Put a page break 
   THEN	RETURN LBR$_ENDTOPIC;					! Then terminate listing
put_output (.linedesc);						! Output help to terminal

RETURN true;
END;

ROUTINE put_page_break =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
!	If output is going to a video terminal, and paging is enabled, 
!	then a page break is forced if the screen is full of help text.
!
! INPUTS:
!
!	None.
!
! OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	False, if user responds with a '?' to a conditional page break.
!	True, otherwise.
!
!--

LOCAL
    status,							! Local status longword
    prompt_desc : $BBLOCK [dsc$c_s_bln];			! Descriptor for page break prompt

IF .help_flags [hlp$v_page] 					! If paging enabled
THEN IF (.current_height LSS .list_height - 4) 			! Then if not three or less lines left on the page
     THEN current_height = .current_height + 1			! Then simply increment the line count
     ELSE BEGIN							! Else clear the screen
	  IF (.current_height EQL .list_height - 4)		! And if in the middle of some help information
	  THEN BEGIN						! Then output a page break prompt

		outputdesc [dsc$w_length] = 1;			! Init blank string
		outputbuf [0,0,8,0] = 10;			!
		put_output (outputdesc);			! Output a blank line

		outputdesc [dsc$w_length] = 0;			! Init input string
		status = get_input (outputdesc, 		! Issue page break prompt
				pagebrk_prompt, outputdesc);	!
		IF .status EQL RMS$_EOF				! If EOF was detected
		   THEN $EXIT();				! Then exit help now

		SELECTONE (CH$RCHAR (.outputdesc[dsc$a_pointer] ! Test termination character
		   + .outputdesc [dsc$w_length] - 1)) OF SET	!

		[%X'1A']:					! If CTRL/Z 
		$EXIT();					! Then exit help now

		[%C'?']:					! If ?
		RETURN false;					! Simply continue

		[OTHERWISE]:					! Anything else
		IF .outputdesc [dsc$w_length] EQL 1		! If no text
		THEN outputdesc[dsc$w_length] = 0		! Then simply continue
		ELSE BEGIN					! Use text as next command
		     outputdesc [dsc$w_length] = 		!
			.outputdesc [dsc$w_length] - 1;		!
		     RETURN false;				!
		     END;					!

		TES;
		END;

	  scr$erase_page (1,1);					! Clear screen
	  current_height = 1;					! Reset line count
	  END;							!

RETURN true;
END;

ROUTINE put_output (linedesc) =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
!	Put a line of help text to SYS$OUTPUT.
!
! INPUTS:
!
!	linedesc =	address of string descriptor for the line of help
!			text to be output
!
! OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	Always true.
!
!--

MAP
    linedesc : REF $BBLOCK;

LOCAL
    linebuf : $BBLOCK [hlp$c_pagesize],
    status;

sysoutrab [rab$w_rsz] = 0;
sysoutrab [rab$l_rbf] = linebuf;

IF .linedesc [dsc$w_length] NEQ 0
   THEN BEGIN
	CH$MOVE (.linedesc [dsc$w_length], .linedesc [dsc$a_pointer], linebuf);
	sysoutrab [rab$w_rsz] = .linedesc [dsc$w_length];
	END;

IF NOT (status = $PUT (RAB = sysoutrab))
   THEN SIGNAL_STOP ( (shr$_writeerr OR hlp$c_facility OR sts$k_error),
	1, sysout_name, .status, .sysoutrab [rab$l_stv]);

RETURN true;
END;						!Of put_output

ROUTINE find_file_info (fab, listwidth) =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
!	Determine the file characteristics, i.e., page height and line width,
!	of the file specified by the input fab.  Also, check to see if device
!	is suitable for page breaks.
!
! INPUTS:
!
!	fab =		address of FAB for file of interest
!
!	listwidth =	address of longword to contain line width
!
! OUTPUTS:
!
!	listwidth : as described above.  
!	Also implicitly:  list_height and help_flags.
!
! ROUTINE VALUE:
!
!	Always true.
!
!--

MAP
    fab : REF $BBLOCK;

BIND
    namblk = .fab [fab$l_nam] : $BBLOCK;	! NAM block associated with input FAB

MACRO
    ddp$b_pagelen = 3,0,8,0%;			! *** Hardwired page length offset ***

LITERAL 
    getdvilen = 4*12 + 4;

LOCAL
    getdvidesc : $BBLOCK [getdvilen],
    devnamdesc : $BBLOCK [dsc$c_s_bln],
    devbufsiz,
    devclass,
    devdepend : $BBLOCK [4],
    devtype;

.listwidth = hlp$c_liswidth;					! Assume default width of 80

devnamdesc [dsc$w_length] = .namblk [nam$b_dev];		! Get the device name
devnamdesc [dsc$a_pointer] = .namblk [nam$l_dev];		!

!
! Do a $GETDVI to get the parameters of interest.
!
CH$FILL (0, getdvilen, getdvidesc);				! Init the $GETDVI buffer

getdvidesc [0,0,16,0] = 4;					! Get the device class
getdvidesc [2,0,16,0] = dvi$_devclass;				!
getdvidesc [4,0,32,0] = devclass;				!
getdvidesc [8,0,32,0] = getdvidesc [0,0,16,0];			!

getdvidesc [12,0,16,0] = 4;					! Get the device dependent chars
getdvidesc [14,0,16,0] = dvi$_devdepend;			!
getdvidesc [16,0,32,0] = devdepend;				!
getdvidesc [20,0,32,0] = getdvidesc [12,0,16,0];		!

getdvidesc [24,0,16,0] = 4;					! Get the device type
getdvidesc [26,0,16,0] = dvi$_devtype;				!
getdvidesc [28,0,32,0] = devtype;				!
getdvidesc [32,0,32,0] = getdvidesc [24,0,16,0];		!

getdvidesc [36,0,16,0] = 4;					! Get the device buffer size
getdvidesc [38,0,16,0] = dvi$_devbufsiz;			!
getdvidesc [40,0,32,0] = devbufsiz;				!
getdvidesc [44,0,32,0] = getdvidesc [36,0,16,0];		!

IF (.fab [fab$l_dev] AND dev$m_spl) NEQ 0			! If output device is spooled
   THEN BEGIN							! Then use the secondary device
	getdvidesc [2,0,16,0] = dvi$_devclass OR dvi$c_secondary;
	getdvidesc [14,0,16,0] = dvi$_devdepend OR dvi$c_secondary;
	getdvidesc [26,0,16,0] = dvi$_devtype OR dvi$c_secondary;
	getdvidesc [38,0,16,0] = dvi$_devbufsiz OR dvi$c_secondary;
	END;

IF $GETDVI (DEVNAM = devnamdesc, ITMLST = getdvidesc)		! Get the device characteristics
   THEN BEGIN							!
	.listwidth = MINU (.devbufsiz, hlp$c_maxwidth);		! Get the listing width
	list_height = .devdepend [ddp$b_pagelen];		! Get the listing height
	IF ((.devclass NEQ dc$_term) OR				! If output device is not a terminal
		(NOT .devdepend [tt$v_scope]) OR		! Or output device is not a video terminal
		(.devtype EQL dt$_ttyunkn)) 			! Or terminal type is unknown
	   THEN help_flags = .help_flags AND NOT hlp$m_page;	! Then do not generate page breaks
	END;							!

RETURN true;		
END;								!Of find_file_info

ROUTINE open_sysinput =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
! 	Open SYS$INPUT.
!
! INPUTS:
!
!	None.
!
! OUTPUTS:
!
!	sysinchan =	longword containing channel assigned to SYS$INPUT
!
! ROUTINE VALUE:
!
!	Always true.
!
!--

LOCAL
    devinfobuf : $BBLOCK [dib$k_length],		! DIB buffer
    devinfodesc : $BBLOCK [dsc$c_s_bln],		! DIB desc
    sysinstring1 : VECTOR [nam$c_maxrss, BYTE],		! Space for SYS$INPUT resultant string
    sysinstring2 : VECTOR [nam$c_maxrss, BYTE],		! Space for SYS$INPUT resultant string
    sysindesc : $BBLOCK [dsc$c_s_bln], 			! String descriptor for SYS$INPUT
    sysinname : $BBLOCK [dsc$c_s_bln],			! String descriptor for resultant name
    status;

sysindesc [dsc$w_length] = .sysinput [dsc$w_length];	! Init input desc
sysindesc [dsc$a_pointer] = .sysinput [dsc$a_pointer];

sysinname [dsc$w_length] = nam$c_maxrss;		! Init output desc
sysinname [dsc$a_pointer] = sysinstring2;

WHILE (status = $TRNLOG (LOGNAM = sysindesc,		! Recursively translate input desc
		RSLLEN = sysinname [dsc$w_length],
		RSLBUF = sysinname))
DO BEGIN

   IF (.status EQL SS$_NOTRAN) 				! Stop when not translatable
      THEN EXITLOOP
      ELSE IF NOT .status				! Signal any errors
	      THEN SIGNAL_STOP (.status);

   IF CH$RCHAR (.sysinname [dsc$a_pointer]) EQL %X'1B'
      THEN BEGIN
	   sysinname [dsc$w_length] = .sysinname [dsc$w_length] - 4;
	   sysinname [dsc$a_pointer] = .sysinname [dsc$a_pointer] + 4;
	   END;
   sysindesc [dsc$w_length] = .sysinname [dsc$w_length];  ! New input desc
   sysindesc [dsc$a_pointer] = .sysinname [dsc$a_pointer];
   sysinname [dsc$w_length] = nam$c_maxrss;		  ! New output desc
   sysinname [dsc$a_pointer] = 
	(IF .sysinname [dsc$a_pointer] EQL sysinstring1
	    THEN sysinstring2
	    ELSE sysinstring1);
   END;

IF NOT (status = $ASSIGN (DEVNAM = sysinname, CHAN = sysinchan))
   THEN SIGNAL_STOP (.status);

devinfodesc [dsc$w_length] = dib$k_length;
devinfodesc [dsc$a_pointer] = devinfobuf;
IF $GETCHN (CHAN = .sysinchan, SCDBUF = devinfodesc)
   THEN IF (.devinfobuf [dib$b_devclass] NEQ dc$_term)
	   THEN BEGIN
		$DASSGN (CHAN = .sysinchan);
		help_flags [hlp$v_notterm] = true;
		END;

RETURN true;
END;

ROUTINE open_sysoutput (sysoutfab, sysoutnam)  =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
! 	Open SYS$OUTPUT.
!
! INPUTS:
!
!	sysoutfab =	address of FAB for SYS$OUTPUT
!
!	sysoutnam = 	address of NAM block for SYS$OUTPUT
!
! OUTPUTS:
!
!	sysoutfab, sysoutrab, sysout_name : updated as expected.
!
! ROUTINE VALUE:
!
!	Always true.
!
!--

MAP
    sysoutfab : REF $BBLOCK,
    sysoutnam : REF $BBLOCK;

LOCAL
    sysoutstring : VECTOR [nam$c_maxrss, BYTE],			! Space for SYS$OUTPUT resultant filename
    status;

$NAM_INIT (	NAM = .sysoutnam,
		ESS = nam$c_maxrss,
		ESA = sysoutstring,
		RSS = nam$c_maxrss,
		RSA = sysoutstring);

$FAB_INIT (	FAB = .sysoutfab,
		FNS = .sysoutdesc [dsc$w_length],
		FNA = .sysoutdesc [dsc$a_pointer],
		DNM = 'SYS$DISK:HELP.LIS',
		RAT = CR,
		FAC = PUT,
		NAM = .sysoutnam );

$RAB_INIT (	RAB = sysoutrab,
		FAB = .sysoutfab );

IF NOT (status = $CREATE (FAB = .sysoutfab))
   THEN BEGIN
	sysout_name [dsc$w_length] = .sysoutnam [nam$b_esl];
	sysout_name [dsc$a_pointer] = .sysoutnam [nam$l_esa];
	SIGNAL_STOP ( (shr$_openout OR hlp$c_facility OR sts$k_error),
			1, sysout_name, .status, .lbr$gl_rmsstv );
	END;

sysout_name [dsc$w_length] = .sysoutnam [nam$b_rsl];
sysout_name [dsc$a_pointer] = .sysoutnam [nam$l_rsa];

IF NOT (status = $CONNECT (RAB = sysoutrab))
   THEN SIGNAL_STOP ( (shr$_openout OR hlp$c_facility OR sts$k_error),
			1, sysout_name, .status, .sysoutrab [rab$l_stv] );

RETURN true;
END;

ROUTINE clean_up (sysoutfab) =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
! 	Deassign SYS$INPUT if assigned and disconnect and close output file.
!
! INPUTS:
!
!	sysoutfab =	address of FAB for SYS$OUTPUT
!
! OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	Always true.
!
!--

MAP
    sysoutfab : REF $BBLOCK;

LOCAL
    status;

IF (.help_flags [hlp$v_prompt] OR .help_flags [hlp$v_page])
   AND NOT .help_flags [hlp$v_notterm]
   THEN IF NOT (status = $DASSGN (CHAN = .sysinchan))
		THEN SIGNAL (.status);

IF NOT (status = $DISCONNECT (RAB = sysoutrab))
   THEN SIGNAL ( (shr$_closeout OR hlp$c_facility OR sts$k_warning),
	1, sysout_name, .status, .sysoutrab [rab$l_stv]);

IF NOT (status = $CLOSE (FAB = .sysoutfab))
   THEN SIGNAL ( (shr$_closeout OR hlp$c_facility OR sts$k_warning),
	1, sysout_name, .status, .sysoutrab [rab$l_stv]);

RETURN true;
END;

%SBTTL 'Routine make_upper_case';
ROUTINE make_upper_case (idesc, oname) =
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
! 	Upper case the name described by string descriptor idesc and
! 	put the name at location oname.
!
! INPUTS:
!
!	idesc = 	address of string descriptor for input text string
!
!	oname = 	address of buffer to contain uppercase output string
!
! OUTPUTS:
!
!	oname : as described above
!
! ROUTINE VALUE:
!
!	Always true.
!
!--

MAP
    idesc : REF $BBLOCK,
    oname : REF VECTOR[,BYTE];

BIND
    namlen = idesc[dsc$w_length] : WORD,
    iname = idesc[dsc$a_pointer] : REF VECTOR[,BYTE];

IF .namlen GTRU 0						! If non-empty string
   THEN INCRU i FROM 0 TO .namlen-1				! Then for each character

DO IF .iname[.i] GEQU %ASCII'a'					! Convert character to uppercase and copy
      AND .iname[.i] LEQU %ASCII'z'
      THEN oname[.i] = .iname[.i] - (%ASCII'a' - %ASCII'A')
      ELSE IF .iname[.i] EQL 9
	      THEN oname[.i] = 32
	      ELSE oname[.i] = .iname[.i];

RETURN true

END;								!Of make_upper_case

END								!Of module
ELUDOM
