Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/termnl.bli
There are no other files named termnl.bli in the archive.
module termnl ( ! Terminal input and output functions
ident = '1',
%if
%bliss(bliss32)
%then
language(bliss32),
addressing_mode(external=long_relative,
nonexternal=long_relative)
%else
language(bliss36)
%fi
) =
begin
!
! COPYRIGHT (C) 1979, 1980 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! 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: STEP Library Processor
!
! Abstract:
!
! This module provides functions to open the terminal for input, output,
!
! Environment:
!
! Author: Earl Van Horn Creation Date: April, 1979
!
!--
!
! Table of Contents:
!
forward routine
ask, ! Prompt and read line from the terminal input stream.
set_term_width, ! Get term width from system and pass on to IOSERV
interm : novalue, ! Initialize terminal operations.
say, ! Write a string to the normal terminal output stream.
saylp : novalue, ! Same as SAY, but takes length and pointer.
sayslo: novalue, ! same as SAYLP except output as single line.
setout; ! redirect the output to a file.
!
! Include Files:
!
%if %bliss(bliss32) %then
library 'sys$library:starlet';
%fi
library 'XPORT:' ;
require 'HOSUSR:' ;
require 'TERUSR:' ;
%if %bliss(bliss36) %then
require 'jsys:';
%fi
require 'BLISSX:' ;
!
! Macros:
!
!
! Equated Symbols:
!
!
! Own Storage:
!
own
$io_block(err), ! User's error output stream.
errors_to_out_iob, ! TRUE means error messages will be written to
! OUT_IOB as well as ERR_IOB. FALSE means
! error messages will not go to OUT_IOB.
$io_block(in), ! User's input stream
$io_block(out) ; ! User's regular output stream
!
! External References:
!
external
f_as_setout; ! Set to tell the Roll back mechanism that
! a show output file is being opened for append
! so that the restore address may be saved
! on a later put operation (ROLBCK)
external literal
s_eofmark, !Command canceled due to end-of-file mark
s_redirfail; !cannot be redirected
external routine
bugsts,
badxpo,
bug,
bugiob,
ers, ! exit image after printing message
filter, ! Checks for illegal input characters.
fresad, ! Frees the block allocated by MAKSAD.
localf, ! Report error if spec. involves network.
maksad, ! Allocates string and descriptor.
writes, ! Output a multi-line message.
batrun, ! Determine if this is a batch job
swidth, ! Set terminal width for module IOSERV
xfstat ; ! checks the returned status of an xport call.
global routine ask(a_prompt) =
!++
! Functional Description:
!
! ASK issues a prompt consisting of the caller's prompt string,
! if any, followed by ": ". It then reads from the terminal input
! stream, and checks the input line for non-printing characters
! other than space and horizontal tab. If there are such characters,
! the user is informed of the problem and prompted again. When
! acceptable input has been obtained, ASK returns the address of
! a descriptor of the input line.
!
! On VAX/VMS a final hyphen, followed only by spaces and tabs, means
! that the line is to be continued. The hyphen and any following
! spaces and tabs are omitted, and the user is prompted for more input.
!
! The string and descriptor allocated by ASK may be freed by
! calling FRESAD.
!
! The caller's prompt string must be no longer than 78 characters.
!
! The first time a CTRL-Z is returned by the GET operation this
! routine will return a string of length zero. If ASK is called
! again, the image is terminated with the info message S_EOFMARK.
! This allows remarks to be optional, but terminates if any other
! prompted field is not specified.
!
! Formal Parameters:
!
! a_prompt : Address of a descriptor of the prompt string.
! If this parameter is K_NULL, or the descriptor has
! a zero length field, the default prompt will be issued.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value: Address of a descriptor of the input line.
! Completion Codes:
!
! None
!
! Side Effects:
!
! The character string that was read and a descriptor to it are allocated
! by calling MAKSAD.
!
!--
begin ! ASK
bind
prompt = .a_prompt : desc_block ;
literal
k_prompt_max = 80 ; ! Maximum number of chars in the prompt.
own
EOF_Seen : initial(false); ! true if user (or system) typed an EOF
! This stops infinite loops waiting
! for input after an ^Z. (QAR 116)
local
need_input, ! Need to read more from user.
omitted_chars, ! Number of characters to be omitted
! when continuing to next line.
prompt_buf : vector[ch$allocation(k_prompt_max)], ! Storage for prompt.
prompt_len, ! Actual number of chars in the prompt.
r_input : ref desc_block ; ! Descriptor for input obtained.
if .EOF_seen
then ! prevent infinite GET loop after ^Z
ers(s_eofmark, ! follow VMS convention and exit
lit('Command canceled due to end-of-file mark'));
if prompt eql k_null
then
begin ! Use default prompt.
prompt_len = 13 ;
ch$copy(len_comma_ptr((': ')), 0,
.prompt_len, ch$ptr(prompt_buf)) ;
end ! Use default prompt.
else
begin ! Use user prompt.
local
fill;
!Compute how the prompt is to be filled
if
.prompt[desc_len] geq 12
then
fill=1
else
fill=12-.prompt[desc_len];
prompt_len=.prompt[desc_len]+.fill+1;
if .prompt_len gtr k_prompt_max
then
bug(cat(('The prompt supplied to ASK exceeded 78 characters'))) ;
ch$copy(len_comma_ptr(prompt),
len_comma_ptr((':')),
.fill,ch$ptr(uplit(' ')),
0, .prompt_len, ch$ptr(prompt_buf)) ;
end ; ! Use user prompt.
r_input = k_null ; ! Initialize.
need_input = true ; ! Initialize.
while .need_input do
begin ! Get a line.
$step_get(iob = in_iob, prompt = (.prompt_len, ch$ptr(prompt_buf))) ;
if .in_iob[iob$g_comp_code] eql step$_eof
then
begin
EOF_seen = true; ! set flag after ^Z
! it only affects next call to ASK
! *** KLUDGE *** VMS XPORT forgets to set length to zero after
! putting CTRL-Z in first position of buffer.
in_iob[iob$h_string] = 0;
end;
if not filter(in_iob[iob$t_string])
then
say(lit('Please retype the last line'))
else
begin ! Allocate, copy, and test for continuation.
if .r_input eql k_null or not %bliss(bliss32) ! Compiler will omit
! ELSE clause except
! for VMS.
then
begin ! First segment.
! Allocate space for the first input line.
r_input = maksad(.in_iob[iob$h_string]) ;
! Copy the input into the allocated space.
ch$copy(len_comma_ptr(in_iob[iob$t_string]), 0,
len_comma_ptr(.r_input)) ;
end ! First segment.
else
begin ! Continuation segment.
local
r_partial : ref desc_block ; ! To input so far.
! Hold on to the partial input string.
r_partial = .r_input ;
! Allocate space for the extended input.
r_input = maksad(.r_partial[desc_len] - .omitted_chars +
.in_iob[iob$h_string]) ;
! Concatenate the input so far with the new input.
ch$copy(.r_partial[desc_len] - .omitted_chars,
.r_partial[desc_ptr],
len_comma_ptr(in_iob[iob$t_string]),
0, len_comma_ptr(.r_input)) ;
! Free the space that held the previous input.
fresad(.r_partial) ;
end ; ! Continuation segment.
%if not %bliss(bliss32)
%then
need_input = false ; ! Continuations only on VMS.
%else
! Look for continuation character.
omitted_chars = 0 ; ! Initialize.
decr i from .r_input[desc_len] to 1 do
selectone ch$rchar(ch$plus(.r_input[desc_ptr], .i - 1)) of
set ! Examine one character.
[%c' ', 9]: ! Space or tab.
; ! Continue looking.
[%c'-']:
begin ! Found continuation.
omitted_chars = .r_input[desc_len] - .i + 1 ;
exitloop ;
end ; ! Found continuation.
[otherwise]:
exitloop ; ! Found no continuation.
tes ; ! Examine one character.
if .omitted_chars eql 0
then
need_input = false
else
begin ! Set continuation prompt.
ch$copy(len_comma_ptr(':_'), 0, 2, ch$ptr(prompt_buf)) ;
prompt_len = 2 ;
end ; ! Set continuation prompt.
%fi
end ; ! Allocate, copy, and test for continuation.
end ; ! Get a line.
.r_input
end ; ! ASK
global routine set_term_width =
!++
! Functional Description:
!
! Determine what line width should be used when reporting long
! messages to the user. This width is pass to routines in module
! IOSERV via call to SWIDTH.
!
! For BATCH jobs, the width is set assuming the output is going to
! a printer.
!
! For INTERACTIVE jobs, the controling terminal's width is used
! even if output is redirected to a file. It is assumed that
! that the user will want to look at it on his/her terminal.
!
! Formal Parameters:
!
! None
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! The OWN TERMINAL_WIDTH in module IOSERV is changed.
!
!--
begin
own
width; ! save terminal width
%if Tops20 %then
begin
!+
! Use the MTOPR jsys to get the width of the primary output device.
! The primary-output-desinator, $PRIOU, is used because it seems
! that XPORT does not use JFNs to reference the terminal.
! This works for both interactive and batch jobs, because batch jobs
! are run with a psuedo-terminal input/output device.
!-
! this jsys has no error return, pray that it works
mtopr ($PriOu, $morlw, 0; width);
! pass width to module IOSERV
swidth(.width); ! ignore error returns for now
end;
%fi
!
! enable this section of code after version 1 is out the door
!
%if VaxVms and FALSE %then !****** SECTION COMMENTED OUT ******
begin
!+
! Use the $GETDEV system service to get the width of the terminal
! associated with SYS$OUTPUT.
!-
own
buf : block[8,1],
DevNam_Desc : $str_descriptor(string = 'SYS$OUTPUT:'),
CS_Desc : $str_descriptor(string = (8,buf));
local
RetStatus; ! hold return status from $GETDEV
RetStatus = $GetDev (DevNam = DevNam_Desc,
PriBuf = CS_Desc);
if .RetStatus
then
begin
if .buf[dib$b_DevClass] eql DC$_Term
then
width = .buf[dib$W_DevBufSiz]
else
width = 132;
end
else
bugsts(.RetStatus,
cat('$GETDEV can not get device characteristics for SYS$OUTPUT:'));
! pass width to module IOSERV
swidth(.width); ! ignore error returns for now
end;
%fi
true
end; !(of routine set_term_width)
global routine interm : novalue =
!++
! Functional Description:
!
! Initialize terminal operations by opening files, etc.
! This routine performs no operation when called the second and
! subsequent times.
!
! Formal Parameters:
!
! None
!
! Implicit Inputs:
!
! The internal own variable, INTERM_CALLED.
!
! Implicit Outputs:
!
! The following own segments internal to this module are initialized:
!
! IN_IOB, OUT_IOB, ERR_IOB, ERRORS_TO_OUT_IOB
!
! The internal own variable, INTERM_CALLED, is set to TRUE.
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! Terminal input, error, and normal output streams are opened.
!
!--
begin ! INTERM
local
status;
own
interm_called : initial(false) ; ! Means INTERM was called.
if not .interm_called
then
begin ! Initialize.
interm_called = true ;
if
not (status=$step_open(iob = in_iob, file_spec = $xpo_input,
failure=0))
then
bugiob(in_iob,lit('Cannot open standard input')) ;
if
not (status=$step_open(iob = out_iob, file_spec = $xpo_output,
options = output,failure=0))
then
bugiob(out_iob,lit('Cannot open standard output')) ;
errors_to_out_iob = false ;
if
not (status=$step_open(iob = err_iob, file_spec = $xpo_error,
options = output,failure=0))
then
bugiob(err_iob,lit('Cannot open standard error output')) ;
set_term_width();
end ; ! Initialize.
end ; ! INTERM
global routine say(a_string) =
!++
! Functional Description:
!
! SAY writes a string to the normal terminal output stream.
! On successive calls, each string will begin a new line.
!
! The string descriptor address passed as argument is returned
! as the value of the routine.
!
! Formal Parameters:
!
! a_string : Address of descriptor of string to be written.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value: The same address that was passed in as argument
! Completion Codes:
!
! None
!
! Side Effects:
!
! The string supplied is written to the normal terminal output stream.
!
!--
begin ! SAY
writes(out_iob,.a_string)
end ; ! SAY
global routine saylp(num_chars, p_string) : novalue =
!++
! Functional Description:
!
! SAYLP performs the same function as SAY, i.e., it
! writes a string to the normal terminal output stream.
!
! The differences are that it takes a length and character pointer
! as parameters instead of the address of a descriptor, and it does
! not return a value.
!
! Formal Parameters:
!
! num_chars : Number of characters to be written.
! p_string : Character pointer to the first character of the string.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! The string supplied is written to the normal terminal output stream.
!
!--
begin ! SAYLP
local
string : desc_block ; ! Descriptor of string to write.
$str_desc_init(descriptor = string, string = (.num_chars, .p_string)) ;
writes(out_iob,string)
end ; ! SAYLP
global routine sayslo(num_chars, p_string) : novalue =
!++
! Functional Description:
!
! SAYSLO performs the same function as SAY, i.e., it
! writes a string to the normal terminal output stream,
! but performs no multiline output with identation as with
! SAYLP. That is to say the input is put out as a single line
!
! The differences are that it takes a length and character pointer
! as parameters instead of the address of a descriptor, and it does
! not return a value.
!
! Formal Parameters:
!
! num_chars : Number of characters to be written.
! p_string : Character pointer to the first character of the string.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! The string supplied is written to the normal terminal output stream.
!
!--
begin ! SAYSLO
local
string : desc_block ; ! Descriptor of string to write.
$str_desc_init(descriptor = string, string = (.num_chars, .p_string)) ;
$step_put(iob=out_iob,string=string) ;
end ; ! SAYSLO
GLOBAL ROUTINE SETOUT(OPTION,A_FILE_SPEC,A_DEFAULT) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine redirects the output from the terminal to
! a file or vice versa depending on the call parameters.
! It primary use will be in handling the output and append
! qualifiers.
!
! FORMAL PARAMETERS:
!
! option This indicates the action to be performed on
! this call to the routine. The actions currently
! are:
!
! k_say_create open the file
! k_say_append append the file
! k_say_close close the file
!
! The definitions of option are located in the
! file TERUSR.REQ.
!
! a_file_spec Address of descriptor denoting filename.
!
! a_default Address of descriptor denoting default filename.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! The variable ERRORS_TO_OUT_IOB, declared OWN in this module, is set
! to TRUE if the option is K_SAY_CREATE or K_SAY_APPEND and the action
! is successful. Otherwise it is set to false.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE = requested action successful.
! FALSE = requested action failed because of a user mistake, which has
! been reported.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
BIND
FILE=.A_FILE_SPEC: DESC_BLOCK ,
DEFAULT_FILE =.A_DEFAULT : DESC_BLOCK ;
LOCAL
STATUS ; ! xport returned status
! Prevent network activity in this release.
if .option neq k_say_close
then
if not localf(len_comma_ptr(file))
then
return false ;
! Prevent error messages from going to OUT_IOB while it is being changed.
errors_to_out_iob = false ;
! close current output
STATUS=$STEP_CLOSE(IOB=OUT_IOB,
FAILURE=xpo$io_failure) ;
if (.STATUS NEQ step$_normal)
then
begin
if xfstat(s_redirfail,out_iob, lit('The output cannot be redirected'))
then
! invalid file spec
return false
else
! not related to file spec
bugiob(out_iob, lit('SETOUT could not close the old file')) ;
end ;
! select action to be performed
SELECTONE .OPTION OF
SET
[K_SAY_CREATE]:
STATUS=$STEP_OPEN(IOB=OUT_IOB,
FILE_SPEC=FILE,
DEFAULT=DEFAULT_FILE,
OPTIONS=OUTPUT,
FAILURE=0) ;
[K_SAY_APPEND]:
begin ! open for append
!+
! let roll back mechanism know that this is an output data
! file opened for append for restore address can be saved
!-
f_as_setout = true ;
STATUS=$STEP_OPEN(IOB=OUT_IOB,
FILE_SPEC=FILE,
DEFAULT=DEFAULT_FILE,
OPTIONS=APPEND,
FAILURE=0) ;
! reset flag
f_as_setout = false ;
end; ! open for append
[K_SAY_CLOSE]:
STATUS=$STEP_OPEN(IOB=OUT_IOB,
FILE_SPEC=$XPO_OUTPUT,
OPTIONS=OUTPUT,
FAILURE=0) ;
[OTHERWISE]:
BUG(LIT('Invalid option to SETOUT')) ;
TES ;
if NOT ((.STATUS EQL step$_normal)
OR (.STATUS EQL step$_CREATED))
then
begin
if xfstat(s_redirfail,out_iob,lit('The output cannot be redirected'))
then
! invalid file spec
begin
local
status;
! make sure output iob is open to terminal
if
(status=$step_open(iob=out_iob,
file_spec=$xpo_output,
options=output,failure=0)) neq step$_created
then
badxpo(.status,lit('Cannot open standard output')) ;
return false ;
end
else
! not related to file spec
bugiob(out_iob, lit('SETOUT could not open the new file')) ;
end ;
! If a file has been opened, direct errors to it in addition to the usual
! destinations for errors.
if .option eql k_say_create or .option eql k_say_append
then
errors_to_out_iob = true ;
TRUE
END;
end ! Module TERMIO
eludom