PDP-10 Archive: cms/sources/reclog.bli from DEC_CMS-20_V1.0

Trailing-Edge - PDP-10 Archives - DEC_CMS-20_V1.0_SRC - cms/sources/reclog.bli

There are no other files named reclog.bli in the archive.

%TITLE 'reclog - recognize log and nolog qualifiers'
MODULE reclog (IDENT = '001',
	       %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 contains routines to implement the /LOG and /NOLOG qualifiers
!
! ENVIRONMENT:
!   VAX/VMS, DS-20
!
! AUTHOR: Sue Millar, CREATION DATE: June, 1981
!
! MODIFIED BY:
!
!--
!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
	labrev,			! See if this is a legal abbreviation
	reclog;			! Recognize and process the log and nolog qualifiers

!
! INCLUDE FILES:
!
%if %bliss(bliss32) %then
    library 'sys$library:starlet';
%else
    require 'jsys:';
%fi
    library 'XPORT:';
    require 'BLISSX:';
    require 'SCONFG:';
    require 'COMUSR:';
    require 'LANGME:';

!
! MACROS:
!
!
! EQUATED SYMBOLS:
bind
    log_spelling = lit('/LOG') : desc_block,
    nolog_spelling = lit('/NOLOG') : desc_block ;
!
!
! OWN STORAGE:
!
    global
	f_log_set : initial (true) ;		! TRUE if /LOG (default)
						! FALSE if /NOLOG
!
 
! EXTERNAL REFERENCES:
    external routine
	bug,					! Report a bug
	codspl,					! Get the spelling of a qualifier
	ers,					! Report a user error
	nxtlex;					! Get the next lexeme

    external
	gratab : gratab_vector ;

    external literal
	s_invqual,				!lexeme is incorrect or misplaced
	s_lexambig;				!lexeme is ambiguous
!

%SBTTL 'reclog - recognize and process /log and /nolog'
GLOBAL ROUTINE reclog ( a_user_string, a_found_log,
			 first_com_qual_x, last_com_qual_x,
			 first_par_qual_x, last_par_qual_x) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine recognizes the /LOG qualifier (or its negative /NOLOG )
!	and sets the global flag f_log_set accordingly. 
!
! FORMAL PARAMETERS:
!
!	a_user_string : address of a descriptor of the remaining users command
!			string, with no leading blanks or tabs. If this string
!			begins with /LOG or /NOLOG , the descriptor will be advances
!			over the qualifier by calling NXTLEX. If it does not begin
!			with the /log or /nolog qualifier, the descriptor is not changed.
!	a_found_log :   Address of a fullword that will be set to true if the /log
!			or /nolog qualifiers is found, false otherwise.
! IMPLICIT INPUTS:
!
!	
!
! IMPLICIT OUTPUTS:
!
!	
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
!	FALSE if the user made a mistake , TRUE if there were no mistakes,
!	whether or not a /log or /nolog qualifier was found.
!
! SIDE EFFECTS:
!
!	The parse tree for the command line is NOT updated to include this
!	qualifier. Only the global symbol f_log_set is updated. The user
! 	string is updated only if one of the qualifiers is found.
!
!--

    BEGIN			!RECLOG

    bind
	user_string = .a_user_string : desc_block,
	found_log = .a_found_log ;
    own
	possible_match :desc_block;
    local
	lexeme : desc_block,		! Lexeme obtained from NXTLEX
	first_qual_x,
	last_qual_x,	
	p_slash,			! pointer to slash
	qual_code,
	save_len,			! Save the user string
	save_ptr ;

    
!Initialize 
    found_log = false;

! Save the user's input in case the qualifiers aren't found
    save_ptr = .user_string[desc_ptr];
    save_len = .user_string[desc_len] ;

! Advance past the lexemes
! Eat up the slash but remember where it was
    if not nxtlex(user_string, k_normal_lex, k_null, lexeme)
    then
	bug(lit('NXTLEX missed slash for RECLOG'));

    p_slash = .lexeme[desc_ptr];

! Obtain the qualifier name
    if not nxtlex(user_string, k_normal_lex, lit('qualifier'), lexeme)
    then
	return false;
! Let the descriptor denote the slash followed by the name
    lexeme[desc_ptr] = ch$plus(.lexeme[desc_ptr], -1);
    lexeme[desc_len] = .lexeme[desc_len] + 1 ;

! Make sure the slash is right in front of the name
    if ch$diff(.lexeme[desc_ptr], .p_slash) gtr 0
    then
	begin				! Switch the space and the slash
	ch$wchar(%c' ', .p_slash);
	ch$wchar(%c'/', .lexeme[desc_ptr]);
	end ;


! Eliminate if qualifier is longer than /NOLOG (remember the slash!)
! and reset the user's input

    if (.lexeme[desc_len] gtr .nolog_spelling[desc_len] + 1)
    then
	begin	
	user_string[desc_len] = .save_len;
	user_string[desc_ptr] = .save_ptr;
	return true;
	end;
! Initialize the descriptor
    $str_desc_init (descriptor = possible_match,
		    string = (0,k_null)) ;

! Find an unambiguous match
    incr n from 1 to 2 do
	begin
	! Examine both command and parameter qualifiers
	if .n eql 1 then
	    begin		! Command qualifiers
    	    first_qual_x = .first_com_qual_x;
	    last_qual_x = .last_com_qual_x ;
	    end
	else
	    begin		! Parameter qualifiers
    	    first_qual_x = .first_par_qual_x;
	    last_qual_x = .last_par_qual_x ;
	    end;
	
        incr i from .first_qual_x to .last_qual_x do

	begin 				! Examine a qualifier
	if labrev(lexeme,codspl(.gratab[.i]), possible_match )
	then
	    qual_code = .gratab[.i] ;
	end ;				! Examine a qualifier
	
    end ; 				! Examine both command and parameter qualifers

    ! Report invalid qualifier
    if .possible_match[desc_len] eql 0
    then
	begin		! Can't find it
	ers(s_invqual,cat(lexeme,' is incorrect, or perhaps misplaced'));
	return false;
	end;

    ! Report ambiguity
    if not ch$fail(ch$find_ch(.possible_match[desc_len],.possible_match[desc_ptr], %c' '))
    then
	begin
	ers(s_lexambig,cat(lexeme, ' could mean: ',possible_match)) ;
	return false;
	end;


! See if we have the qualifier - if we don't, reset the user string
! and return

    if  (.qual_code neq k_log_qual)
    and
	(.qual_code neq k_nolog_qual)
    then
	begin			! We don't have a qualifer
				! So return original user's input
	user_string[desc_len] = .save_len;
	user_string[desc_ptr] = .save_ptr;
   	return true 
	end;

! Now we know we have either /log or /nolog
! We must advance the pointer and set the flags

    found_log = true ;
     
    if .qual_code eql k_log_qual
    then
	f_log_set = true 		! /LOG was specified
    else
        f_log_set = false ;		! /NOLOG was specified

    ! Everything is fine -- return normally

	true

    END;			! end of routine RECLOG

routine labrev(user_str,com_str,match_str) =

!++
!
! Functional Description:
!	This routine examines a string to see if it is an abbreviation for
!	for a CMS keyword. If there are multiple keywords that match the
!	abbreviation, these keywords are concatenated into a single string
!	using a series of calls on the routine 'labrev'.  The blank is used 
!       as a delimiter between each of the keywords.
!
!	Restrictions:	This routine can handle a series of calls to it
! 			for only one abbreviation at one time.
!  				
! Formal Parameters:
!
!	user_str:	address of descriptor for abbreviated keyword. The only
!			time that the string represented by user_str may change
!			is when the match_str has zero length on input.  This
!			is the means by which this routine detects that a new
!			abbreviation is being provided.
!	com_str:	address of descriptor for formal keyword.  The string
!			represented by com_str must not contain any blanks.
! 	match_str:	address of dynamic descriptor of concatenated matching
! 			keyword(s) except when a new abbreviation is being
! 			provided to the routine or when no prior match has
!                       occurred.  When these exceptions occur, this argument
!                       on the call to this routine should be the address of a
!                       descriptor with zero length.
!
! Implicit Inputs:
!
!	None
!
! Implicit Outputs:
!
!	None
!
! Routine Value:
! Completion Codes:
!
!	if a match occurs: routine value = true
! 	if no match:       routine value = false
!
! Side Effects:
!    None.
!
!--
        begin


	own
	    first_match: initial(false),  ! flag:
					  ! 	true = match on previous call
					  !	       (set on first match)
					  !    false = no match on previous 
					  !   	       call


	    abbrev_str : $str_descriptor(class = dynamic) ;
					  ! Save user's input

	map
	    user_str   : ref desc_block ,
	    com_str    : ref desc_block ,
	    match_str  : ref desc_block;


    ! validate if same abbrev or a new one is being submitted
    if not (.first_match)
    then
	begin   ! start no match yet
	if (.match_str[desc_len] neq 0)
	then
            ! match string must be 0 length if no prior match
	    bug(cat(('Attempt to submit a non-zero length descriptor '),
	        ('of match string without a prior match to the '),
                ('routine LABREV.  Non-zero string is '),
		  .match_str)) ;
	end     ! end no match yet
    else
	begin    ! start first_match set
	! abbrev is allowed to change if 0 length match_str
	if (.match_str[desc_len] eql 0)
	then
	    first_match = false
	else
       	    begin    ! start illegal abbrev change
            !+
            ! 	determine if the abbreviation was the same as submitted on
            !	a previous call
            !-

            if (ch$compare(len_comma_ptr(.user_str),
        	len_comma_ptr(abbrev_str)) neq 0)
 	    then
                bug(cat(('Attempt to replace '),abbrev_str,(' with '),
			.user_str,(' in call to routine LABREV'))) ;
					! exit from routine
	    end ;    ! end illegal abbrev change
	end ;    ! end first match set

    !+
    !   eliminate cases where the abbreviation is longer than keyword
    !-
    if (.user_str[desc_len] gtr .com_str[desc_len])
    then
	return FALSE ;    ! exit from routine

    ! compare strings using length of user_str as com_str length
    if (ch$compare(len_comma_ptr(.user_str),.user_str[desc_len],
                       .com_str[desc_ptr]) neq 0)
    then
        return FALSE ;     ! exit from routine here

    if not (.first_match)
    then
        begin    ! start first match segment

        !+
        !	the first match has occurred:
        !	1. the first match flag is set
        !  	2. the desc for match_str is pointed to the keyword desc
        !	3.  the value of true is returned
        !-

        first_match = TRUE ;
        $str_desc_init(descriptor = abbrev_str,
			class = dynamic,
		           string = (.user_str[desc_len], 
				    .user_str[desc_ptr])) ;
							! save abbrev
        ch$move(.user_str[desc_len], .user_str[desc_ptr], .abbrev_str[str$a_pointer]);

	! set output arguments
        $str_desc_init(descriptor = .match_str,
		        string = (.com_str[desc_len], 
		    	.com_str[desc_ptr])) ;

        end      ! end first match segment

    else


        !+
        !	second and subsequent matches
        !
        !	1. append the concatenated string
        ! 	2. build concatented string in work area in the following
        !          order: match_str,blank,com_str.
        !-
	begin

! The following could be done in one statement using a dynamic string 
! descriptor for match_str and the XPORT functions $STR_APPEND and
! $STR_CONCAT. Unfortunately, there appears to be a bug in XPORT
! when this method is attempted.

	    local
		concat_desc : desc_block,	! To build new string
		st,				! Return status
		work_ptr;			! 
		
	 $str_desc_init (descriptor = concat_desc,
		         string = (sum_of_lens(.com_str,lit(' '),.match_str),
							k_null)) ;

	! Get space for string
	st = $xpo_get_mem(characters = .concat_desc[desc_len],
			  result = concat_desc[desc_ptr]);
	! Write original string
        work_ptr = ch$move(len_comma_ptr(.match_str),.concat_desc[desc_ptr]) ;

        ch$wchar_a(%c' ',work_ptr) ;    ! write blank
        ch$move(len_comma_ptr(.com_str),.work_ptr) ;	! Write new match

        match_str[desc_len] = .concat_desc[desc_len] ;     ! set output
        match_str[desc_ptr] = .concat_desc[desc_ptr] ;     ! arguments

	end ;
   TRUE
   end ;

END				! End of module
ELUDOM