Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

module ioserv (	! Input and output service functions
		ident = '1',
		%if
		    %bliss(bliss32)
		%then
		    language(bliss32),
		    addressing_mode(external=long_relative,
				    nonexternal=long_relative)
		%else
		    language(bliss36)
		%fi
		) =
begin

!
!			  COPYRIGHT (C) 1982 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:  CMS Library Processor
!
! Abstract:
!
!	This module provides miscellaneous input and output service functions.
!
! Environment:
!
! Author:  Earl Van Horn	Creation Date:  March 5, 1980
!
!--

!
! Table of Contents:
!
forward routine
    filter,		! Detect noise characters.
    find_next_words,	! Breaks a string into terminal lines.
    writes,		! Write a multi-line string to any stream.
    twidth: novalue,	! Return width of terminal, default value or from SWIDTH
    swidth,		! Set term width used by other routines in module
    yes ;		! Get a yes or no answer.

!
! Include Files:
!

library 'XPORT:' ;

%if %bliss(bliss32) %then
	LIBRARY 'sys$library:starlet';
%else
	REQUIRE 'jsys:';
%fi

require 'BLISSX:' ;
require 'condit:';

!
! Macros:
!

!
! Equated Symbols:
!
literal
    k_max_terminal_width = 150 ;	! Buffer size for terminal lines.

!
! Own Storage:
!

own
    terminal_width : initial(80) ;	! Number of chars. in terminal line.

!
! External References:
!

external literal
	s_enteryn,		!enter YES or NO
	s_meansno,		!means NO
	s_speccherr;		!char was not a graphic,space, or horiz tab

external routine
    ask,			! Ask the user a question and get the answer.
    bug : novalue,		! Report a bug.
    ers,			! Report a user mistake.
    fresad : novalue,		! Free string allocated by ASK.
    maksad,			! Allocate a string and descriptor.
    sysmsg ;			! Output to the terminal.

global routine filter(a_string) =

!++
! Functional Description:
!
!	This routine scans the supplied string for a character that
!	is neither a graphic, nor a space, nor a horizontal tab.
!	If there are any, it informs the user and returns FALSE.
!	An empty string is considered good.
!
! Formal Parameters:
!
!	a_string:	Address of a descriptor for the string to be scanned.
!
! Implicit Inputs:
!
!	None
!
! Implicit Outputs:
!
!	None
!
! Routine Value:
! Completion Codes:
!
!	TRUE if the user made no mistakes, otherwise FALSE.
!
! Side Effects:
!
!	None
!
!--

    begin	! FILTER
    bind
	string = .a_string : desc_block ;

    local
	p_this ;		! Character pointer to current character.

    p_this = .string[desc_ptr] ;
    incr i from 1 to .string[desc_len] do
	begin	! Test one character and advance to the next.

	selectone ch$rchar(.p_this) of
	    set		! Test one character

	    [9, 32 to 127]:
		;	! OK.

	    [otherwise]:
		begin	! Illegal
		ers(s_speccherr,lit(
		 'A character was not a graphic, space, or horizontal tab')) ;
		return false ;
		end ;	! Illegal

	    tes ;	! Test one character.

	p_this = ch$plus(.p_this, 1) ;
	end ;	! Test one character and advance to the next.

    true
    end ;	! FILTER

global routine find_next_words(a_raw_string, max_len, a_next_segment) =

!++
! Functional Description:
!
!	This routine identifies successive segments of a given raw string of
!	arbitrary length.  Each segment contains as many whole words as will
!	fit in a given maximum length, where words are separated by blanks.
!	Leading and trailing blanks are omitted from each segment.  A segment
!	ends at the end of a word, unless the first word in the segment is
!	longer than the maximum length.
!
!	Each segment is identified by storing into a descriptor provided by
!	the caller.  On the first call for a given raw string, the descriptor
!	to be used for the first segment should have a zero length.
!
!	Successive calls with the same raw string identify successive
!	segments, provided the descriptor to be used for the next segment
!	identifies the previous segment.
!
!	The routine returns TRUE when it identifies the last segment of
!	the raw string, and otherwise returns FALSE.
!
!	In this version of the routine, tabs are treated the same as any
!	non-space character.
!
! Formal Parameters:
!
!	a_raw_string :	Address of a descriptor of a string to be segmented.
!	max_len:	Maximum number of characters allowed in a segment.
!	a_next_segment:	Address of a descriptor having several functions.
!			When the routine is called the first time for a given
!			raw string, the descriptor must have a zero length.
!			When the routine returns, the descriptor denotes the
!			next segment identified.  When the routine is called
!			to identify additional segments, the descriptor must
!			contain the same information as that output by the
!			previous call.
!
! Implicit Inputs:
!
!	None
!
! Implicit Outputs:
!
!	None
!
! Routine Value:
! Completion Codes:
!
!	TRUE if the last segment is identified, else FALSE.
!
! Side Effects:
!
!	None
!
!--

    begin	! FIND_NEXT_WORDS
    bind
	raw_string = .a_raw_string : desc_block,
	next_segment = .a_next_segment : desc_block ;
    local
	num_blanks,		! Number of leading blanks in the new segment.
	remaining_len ;		! Number of chars. remaining in the raw string,
				! starting with the first of this segment.

    ! Set the tentative pointer to the new segment.
    if .next_segment[desc_len] eql 0
    then
	next_segment[desc_ptr] = .raw_string[desc_ptr]
    else
	next_segment[desc_ptr] = ch$plus(.next_segment[desc_ptr],
					 .next_segment[desc_len]) ;

    ! Compute and check the number of characters remaining.
    remaining_len = .raw_string[desc_len] -
		      ch$diff(.next_segment[desc_ptr], .raw_string[desc_ptr]) ;
    if .remaining_len lss 0
    then
	bug(lit('Bad argument to FIND_NEXT_WORDS')) ;

    ! Skip leading blanks in the new segment.
    num_blanks = 0 ;
    while .num_blanks lss .remaining_len do
	begin   ! Look for non-blank.
	if ch$rchar(ch$plus(.next_segment[desc_ptr], .num_blanks)) neq %c' '
	then
	    exitloop ;
	num_blanks = .num_blanks + 1 ;
	end ;	! Look for non-blank.
    if .num_blanks gtr 0
    then
	begin	! Found leading blanks.
	next_segment[desc_ptr] = ch$plus(.next_segment[desc_ptr], .num_blanks);
	remaining_len = .remaining_len - .num_blanks ;
	end ;	! Found leading blanks.

    ! Check for a call after the final segment.
    if .raw_string[desc_len] gtr 0 and .remaining_len eql 0
    then
	bug(lit('FIND_NEXT_WORDS was called too often')) ;

    ! Set the tentative length of the new segment.
    next_segment[desc_len] = .remaining_len ;

    ! See if more than one segment remains.
    if .next_segment[desc_len] gtr .max_len
    then
	begin	! Break before closest space
	local
	    p_break ;	! Char. pointer to space that will follow the segment.

	p_break = ch$plus(.next_segment[desc_ptr], .max_len) ;
	while ch$rchar(.p_break) neq %c' ' do
	    begin	! Back up for space
	    if ch$diff(.p_break, .next_segment[desc_ptr]) gtr 0
	    then
		p_break = ch$plus(.p_break, -1)
	    else
		begin	! No space found
		next_segment[desc_len] = .max_len ;	! Tough
		return false ;
		end ;	! No space found
	    end ;	! Back up for space
	next_segment[desc_len] =
		ch$diff(.p_break, .next_segment[desc_ptr]) ;
	end ;	! Break before closest space

    ! Omit trailing blanks.
    while .next_segment[desc_len] gtr 0 do
	begin	! Back up for non-space
	if ch$rchar(
		ch$plus(.next_segment[desc_ptr], .next_segment[desc_len] - 1))
		neq %c' '
	then
	    exitloop
	else
	    next_segment[desc_len] = .next_segment[desc_len] - 1 ;
	end ;	! Back up for non-space

    ! Finally, determine if this is the last segment.
	begin	! Look for more non-blank characters.
	local
	    extra_len ;		! Num. chars. still in raw string

	! The following statement is parenthesized like A = (B - C) - D
	! to avoid a compiler bug.
	extra_len = (.raw_string[desc_len]
		- ch$diff(.next_segment[desc_ptr], .raw_string[desc_ptr]))
		- .next_segment[desc_len] ;
	if .extra_len lss 0
	then
	    bug(lit('FIND_NEXT_WORDS found too much')) ;

	! Compute the value for the routine to return.
	if .extra_len eql 0
	then
	    true
	else
	    ch$fail(ch$find_not_ch(.extra_len,
		    ch$plus(.next_segment[desc_ptr], .next_segment[desc_len]),
		    %c' '))
	end	! Look for more non-blank characters
    end ;	! FIND_NEXT_WORDS

global routine writes(a_iob, a_string) =

!++
! Functional Description:
!
!	This routine writes a string to the output stream denoted by the
!	IOB supplied.  If the string will not fit on a terminal line,
!	it is broken into several lines, at spaces if possible, and the
!	extra lines are indented one more space than the number of leading
!	spaces in the first.
!
!	Excessive indentation is handled in a reasonable way:
!	If the number of leading spaces in the first line is more than
!	half a screen width, the number of leading spaces is assumed to
!	be the given number modulo half a screen width.
!
!	The string descriptor address supplied as argument is returned as
!	the value of the routine.
!
! Formal Parameters:
!
!	a_iob :		Address of the iob to use for writing
!	a_string:	Address of a descriptor for the string to write
!
! Implicit Inputs:
!
!	The own variable TERMINAL_WIDTH declared in this module.
!
! Implicit Outputs:
!
!	None
!
! Routine Value:
! Completion Codes:
!
!	The string descriptor address passed in as argument
!
! Side Effects:
!
!	Information is written into the output stream denoted by the IOB.
!
!--

    begin	! WRITES
    bind
	iob = .a_iob,
	string = .a_string: desc_block ;

    local
	first_line,			! Means this line is the first.
	indentation,			! Number of leading blanks in a line.
	last_line,			! Means this line is the last.
	line : vector[ch$allocation(k_max_terminal_width)], ! One output line.
	seg : desc_block ;		! Denotes the portion of the string
					! to be output next.

    ! Determine the indentation of this message.
    indentation = 0 ;
    while .indentation lss .string[desc_len] do
	begin	! Look for non-blank.
	if ch$rchar(ch$plus(.string[desc_ptr], .indentation)) neq %c' '
	then
	    exitloop ;
	indentation = .indentation + 1 ;
	end ;	! Look for non-blank.

    ! Handle excessive indentation in a reasonable way.
    if .indentation gtr .terminal_width/2
    then
	indentation = .indentation mod (.terminal_width/2) ;

    ! Tell FIND_NEXT_WORDS to start at the beginning of the string.
    $str_desc_init(descriptor = seg, string = (0, k_null)) ;

    ! Output the lines.
    first_line = true ;
    do
	begin	! Write one line
	last_line = find_next_words(string,
				.terminal_width - .indentation, seg) ;
	ch$fill(%c' ', .indentation, ch$ptr(line)) ;
	ch$move(len_comma_ptr(seg), ch$ptr(line, .indentation)) ;
	$step_put(iob = iob,
		string = (.indentation + .seg[desc_len], ch$ptr(line))) ;
	if .first_line and not .last_line
	then
	    begin	! Prepare for more lines.
	    first_line = false ;
	    indentation = .indentation + 1 ;
	    end ;	! Prepare for more lines.
	end	! Write one line
    until .last_line ;

    string
    end ;	! WRITES

GLOBAL ROUTINE twidth (a_width):novalue =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine returns the width of the terminal when called
!
! FORMAL PARAMETERS:
!
!	a_width		Address of place to store the width of the terminal.
!
! IMPLICIT INPUTS:
!
!	None.
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
!	None
!
! SIDE EFFECTS:
!
!	None.
!
!--

    BEGIN
    
    .a_width = .terminal_width ;
    
    END;			! end of routine %(/*routine-name*/)%

GLOBAL ROUTINE swidth (width) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine sets the width of the terminal.
!
! FORMAL PARAMETERS:
!
!	width		Value to be set
!
! IMPLICIT INPUTS:
!
!	None.
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
!	true  - width in-range and accepted
!	false - width out-of-range and ignored
!
! SIDE EFFECTS:
!
!	Affects operation of WRITES
!
!--

    BEGIN
    
    if (.width lss 40) or (.width gtr k_max_terminal_width)
    then
	return false;

    terminal_width = .width;
    return true;
    END;			! end of routine swidth

global routine yes(a_prompt) =

!++
! Functional Description:
!
!	YES issues the prompt supplied followed by a question mark, and
!	insists on a yes or no answer.  Upper and lower case are equivalent,
!	and the answer may be abbreviated.   An answer with no printing
!	graphics is interpreted as an answer of no, and the user is so
!	informed.  If the response is not valid, the user is prompted again.
!
!	If no prompt is supplied, a default prompt is issued.
!
! Formal Parameters:
!
!	a_prompt :	! Address of a descriptor for the prompt.  If the
!			! address is K_NULL or the descriptor contains a zero
!			! length, a default prompt is issued.
!
! Implicit Inputs:
!
!	None
!
! Implicit Outputs:
!
!	None
!
! Routine Value:  TRUE if the answer was yes, otherwise FALSE
! Completion Codes:
!
!	None
!
! Side Effects:
!
!	The terminal input and normal output streams are read and written.
!
!--

    begin	! YES
    bind
	prompt = .a_prompt : desc_block ;

    local
	r_query : ref desc_block,	! Prompt followed by question mark.
	r_response : ref desc_block,	! Address of descriptor of response.
	answer,				! +1 means yes.
					!  0 means undetermined.
					! -1 means no.
	c,				! Character being examined.
	p,				! Pointer to character being examined.
	p_guts,				! Pointer to first letter.
	guts_len ;			! Number of characters between first and last
					! letters, inclusive.

    ! Put a question mark on the prompt, even if it is empty.
    if prompt eql k_null
    then
	r_query = lit('?')
    else
	begin	! Append a question mark.
	r_query = maksad(.prompt[desc_len] + 12) ;
	ch$copy(len_comma_ptr(prompt), len_comma_ptr('?  [Y/N] (N)'), 0,
		len_comma_ptr(.r_query)) ;
	end ;	! Append a question mark.

    answer = 0 ;			! Initialize
    while .answer eql 0 do
	begin	! ask and test

	r_response = ask(.r_query) ;

	p_guts = k_null ;			! Initialize.
	guts_len = 0 ;			! Initialize.
	p = .r_response[desc_ptr] ;	! Initialize.

	! Launder the input.
	incr i from 1 to .r_response[desc_len] do
	    begin	! Examine one character
	    c = ch$rchar(.p) ;

	    if .c geq %c'A' and .c leq %c'Z'
	    then
		begin	! Convert to lower case
		c = .c + %c'a' - %c'A' ;
		ch$wchar(.c, .p) ;
		end ;	! Convert to lower case

	    if .c neq 9 and .c neq 32	! Neither space nor tab.
	    then
		begin	! Note first and last letters
		if .p_guts eql k_null
		then
		    p_guts = .p ;
		guts_len = .guts_len + 1 ;
		end ;	! Note first and last letters

	    p = ch$plus(.p, 1) ;
	    end ;	! Examine one character

	! See if we have an answer.
	if .guts_len eql 0
	then
	    begin	! Default.
	    sysmsg(s_meansno,lit('Your response means NO'),0) ;
	    answer = -1 ;
	    end		! Default.
	else if not
	    ch$fail(ch$find_sub(len_comma_ptr(lit('no')), .guts_len, .p_guts))
	then
	    answer = -1
	else if not
	    ch$fail(ch$find_sub(len_comma_ptr(lit('yes')), .guts_len, .p_guts))
	then
	    answer = +1
	else
	    sysmsg(s_enteryn,lit('Type YES or NO'),0) ;

	! Get rid of the block allocated by ASK.
	fresad(.r_response) ;

	end ;	! Ask and test

    ! Free the query block if it was allocated.
    if prompt neq k_null
    then
	fresad(.r_query) ;

    .answer eql +1
    end ;	! YES

end				! Module IOSERV
eludom