Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/lexica.bli
There are 27 other files named lexica.bli in the archive. Click here to see a list.
module lexica ( ! Lexical functions of the STEP language processor
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 contains routines for recognizing and processing
! lexemes of the CMS command language.
!
! Environment: Transportable
!
! Author: Earl Van Horn Creation Date: April, 1979
!
!--
!
! Table of Contents:
!
forward routine
abbrev, ! Checks abbreviation for a match with a
! keyword.
errchr, ! Reports an erroneous character.
nxtlex, ! Identifies next lexeme in the command string.
peekch ; ! Peek ahead to the next character.
!
! Include Files:
!
%if %bliss(bliss32) %then
library 'sys$library:starlet';
%else
require 'jsys:';
%fi
library 'XPORT:' ;
require 'BLISSX:' ;
require 'LANGME:' ; ! Declarations internal to the language
! processor.
!
! Macros:
!
!
! Equated Symbols:
!
!
! Own Storage:
!
!
! External References:
!
external literal
s_ilchar,
s_missing,
s_nostrtstr, !description may not start w/string
s_quotenot;
external routine
bug, ! Reports a bug.
ers, ! Reports a user mistake.
zalloc ;
global routine abbrev(user_str,com_str,match_str,zone_id) =
!++
!
! 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 'abbrev'. 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 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.
!
! zone_id: address of zone identifier, in which strings will be
! allocated as described under side effects.
!
! 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:
!
! All allocations occur in the zone specified on the call and it is
! assumed that the zone is not freed for subsequent calls on the same
! abbreviation. Allocations occur for the 2nd and subsequent matches,
! and when a new abbreviation is given.
!
!--
begin
own
first_match: initial(false), ! flag:
! true = match on previous call
! (set on first match)
! false = no match on previous
! call
abbrev_desc: desc_block ; ! retain current abbrev
local
work_ptr : , ! work area used as a ptr to next
! character position
concat_desc: desc_block ; ! desc of work area where concatenated
! string is built
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 ABBREV. 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_desc)) neq 0)
then
bug(cat(('Attempt to replace '),abbrev_desc,(' with '),
.user_str,(' in call to routine ABBREV'))) ;
! 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 abbrevation is saved in the zone
! 3. the desc for match_str is pointed to the keyword desc
! 4 the value of true is returned
!-
first_match = TRUE ;
$str_desc_init(descriptor = abbrev_desc,
string = (.user_str[desc_len],
ch$ptr(zalloc((units_for_chars(
.user_str[desc_len])),.zone_id)))) ;
! save abbrev
ch$move(len_comma_ptr(.user_str),.abbrev_desc[desc_ptr]) ;
match_str[desc_len] = .com_str[desc_len] ; ! set output
match_str[desc_ptr] = .com_str[desc_ptr] ; ! arguments
end ! end first match segment
else
begin ! start 2nd+ match segment
!+
! second and subsequent matches
!
! 1. allocate space in zone for an area to build the
! concatentated string.
! 2. build concatented string in work area in the following
! order: match_str,blank,com_str.
! 3. set match_str to point to concatented string.
!-
$str_desc_init(descriptor = concat_desc,
string = (sum_of_lens(.com_str,lit(' '),.match_str),
k_null)) ;
concat_desc[desc_ptr] = ch$ptr(zalloc((units_for_chars(
.concat_desc[desc_len])),.zone_id)) ;
! allocate space
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) ;
match_str[desc_len] = .concat_desc[desc_len] ; ! set output
match_str[desc_ptr] = .concat_desc[desc_ptr] ; ! arguments
end ; ! end 2nd+ match segment
TRUE
end ;
global routine errchr(p_bad_char, a_string, a_description) =
!++
! Functional Description:
!
! This routine calls ERR to output an error message saying that
! the given character is not allowed in the given string, which
! must satisfy the given description. For example:
!
! The file-spec "A&B" may not contain "&".
!
! A special message is output in case the given string consists only
! of the erroneous character.
!
! Formal Parameters:
!
! p_bad_char : Character pointer to the bad character. This pointer
! must point into the given string.
! a_string : Address of a descriptor of the string in which the
! erroneous character appears.
! a_description : Address of a descriptor of a string explaining what
! the given string is supposed to be.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! The address of a descriptor for the message output. The descriptor
! and the string to which it points may be freed by calling FRESAD.
!
! Side Effects:
!
! A string and descriptor for the message is allocated, and the
! message is output to the terminal error stream.
!
!--
begin ! ERRCHR
bind
string = .a_string : desc_block,
description = .a_description : desc_block ;
! Check the arguments for consistency.
if .string[desc_len] eql 0
then
bug(lit('ERRCHR was given an empty string')) ;
if not
(ch$diff(.p_bad_char, .string[desc_ptr]) geq 0
and ch$diff(.p_bad_char,
ch$plus(.string[desc_ptr], .string[desc_len])) lss 0)
then
bug(cat('The character given to ERRCHR was not within ',
string)) ;
! Now report the error.
if .string[desc_len] eql 1
then
ers(s_nostrtstr,cat(description, ' may not begin with ''',
string,'''' ))
else
begin ! More than one character.
if .p_bad_char eql .string[desc_ptr]
then
ers(s_ilchar,cat(description,' ', string,' may not begin with ''',
(1, .p_bad_char), ''''))
else
ers(s_ilchar,cat(description,' ',string,' may not contain ''',
(1, .p_bad_char), ''''))
end ! More than one character.
end ; ! ERRCHR
global routine nxtlex(a_user_string, lexical_rule, a_description,
a_lexeme) =
!++
! Functional Description:
!
! This routine obtains the next lexeme of the user string. The lexeme
! is not copied. Instead, the lexeme descriptor supplied as parameter
! is made to denote the lexeme as it sits in the user string itself.
! However, the user string descriptor is updated to exclude the lexeme
! and any spaces and tabs before and after it, i.e., the descriptor
! is made to denote the remaining, unanalyzed portion of the user string.
!
! Three kinds of lexemes can be recognized: normal lexemes, file
! specifications, and quoted strings. Except in quoted strings, the
! lexeme delivered does not contain spaces or tabs, and each letter
! delivered in a lexeme is converted to upper case. Case
! conversion is performed in the string that was passed in as
! user string, and is done only on the lexeme delivered by
! this call; the rest of the user string remains untouched.
!
! If a quoted string is the last item in the user string, and it does
! not end with a quotation mark, the closing quotation mark is inserted
! into the character position one beyond the end of the user string,
! and the lexeme descriptor is made to include this quotation mark.
! Thus the user string buffer must be at least one character position
! longer than the user string.
!
! The required lexeme must be present in the user string.
! PEEKCH may be used to determine if the next character is one of a
! given set, assuming there are no leading spaces or tabs in the user
! string. This is the case if the user string and its descriptor
! were most recently processed by NXTLEX.
!
! If the lexeme is present and correctly formed, TRUE is returned.
! The caller may supply a description of the required lexeme.
! If a description is supplied, it is used to report a missing or
! erroneous lexeme, and FALSE is returned. If a description is not
! supplied, a missing or erroneous lexeme is reported as a bug, and
! the routine does not return.
!
! Formal Parameters:
!
! a_user_string: Address of a descriptor of the portion of the user's
! input string that has not yet been processed. The
! descriptor will be modified so that it denotes the
! portion of the string following the next lexeme and
! following any spaces and tabs after the lexeme.
!
! The buffer pointed to by this descriptor must have
! at least one character position beyond the last
! character denoted by the descriptor. If the last
! lexeme is a quotation without a closing quotation
! mark, a quotation mark is stored in this extra
! position.
! lexical_rule: Integer code indicating the kind of lexeme to be
! recognized. The codes are defined in LANGME.REQ.
! a_description: Adddress of a descriptor for a noun phrase describing
! the lexeme required. This phrase is used in an error
! message if the required lexeme is missing or erroneous.
! If this address is K_NULL, a missing or erroneous
! lexeme is reported as a bug, and the routine does not
! return.
! a_lexeme: Address of a descriptor that will be initialized to
! denote the next lexeme in the user string. If
! the last lexeme in the user string is a quotation
! without a closing quotation mark, this descriptor
! is extended to include a quotation mark inserted
! into the user string buffer at one character position
! beyond the user string.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! TRUE if the user made no mistakes, otherwise FALSE. See the
! explanation of A_DESCRIPTION, above.
!
! Side Effects:
!
! None
!
!--
begin ! NXTLEX
bind
user_string = .a_user_string : desc_block,
description = .a_description : desc_block,
lexeme = .a_lexeme : desc_block ;
local
a_explanation, ! Address of descriptor of phrase describing
! the required lexeme.
bad_character, ! Means an invalid character was found.
closing, ! Number of characters added after the
! user string. At present, only an omitted
! closing quotation mark is added, so this
! variable can only be 0 or 1.
num_quotes, ! Number of quotation marks found in a
! quoted string.
p_lexeme, ! Character pointer to the start of the lexeme.
! K_NULL means lexeme has not been found yet.
p_rest, ! Character pointer to the postion one beyond
! the end of the lexeme as found in the user
! string, i.e., not including any closing
! quotation mark provided by NXTLEX.
! K_NULL means the end of the lexeme has not
! been found yet.
p_this ; ! Character pointer to the current character
! being examined.
OWN
f_file_spec:initial(false); !has a file spec been found and hence
!is a comma allowed
! Initialize.
bad_character = false ;
closing = 0 ;
num_quotes = 0 ;
p_this = .user_string[desc_ptr] ;
p_lexeme = k_null ;
p_rest = k_null ;
if
if description eql k_null
then true
else (.description[desc_len] eql 0)
then
a_explanation = lit('lexeme')
else
a_explanation = description ;
! Find the lexeme.
while .p_rest eql k_null and ch$diff(.p_this, .user_string[desc_ptr])
lss .user_string[desc_len] do
begin ! Examine one character and advance to the next.
if .lexical_rule eql k_normal_lex or .lexical_rule eql k_file_spec_lex
then
begin ! Non-quotation needed.
selectone ch$rchar(.p_this) of
set ! Examine one character of non-quotation.
[%c'a' to %c'z']: ! Convert to upper case.
begin ! Convert.
ch$wchar(ch$rchar(.p_this) + (%c'A' - %c'a'), .p_this) ;
if .p_lexeme eql k_null
then
begin
if .lexical_rule eql k_file_spec_lex
then
f_file_spec = true;
p_lexeme = .p_this ; ! Start the current lexeme.
end;
end ; ! Convert.
[%c'A' to %c'Z', %c'0' to %c'9',
%c'$', %c'_', %c'-', %c'.', %c'*', %c'+']:
if .p_lexeme eql k_null
then
begin
if .lexical_rule eql k_file_spec_lex
then
f_file_spec = true;
p_lexeme = .p_this ; ! Start the current lexeme.
end;
[%c'<', %c'>', %c'[', %c']', %c';']: ! Only file specs.
if .lexical_rule eql k_file_spec_lex
then
begin ! File specification character.
if .p_lexeme eql k_null
then
begin
p_lexeme = .p_this ; ! Start the current lexeme.
f_file_spec = true;
end;
end ! File specification character.
else
bad_character = true ;
[%c'/' %bliss32(, %c'=')]: ! Special char.
if .p_lexeme eql k_null
then
begin ! Special lexeme.
p_lexeme = .p_this ; ! Start the lexeme.
p_rest = ch$plus(.p_this, 1) ; ! And end it.
end ! Special lexeme.
else
p_rest = .p_this ; ! End the current lexeme.
[%c':']: ! Ordinary in file specs, otherwise special.
if .lexical_rule eql k_file_spec_lex
then
begin ! Colon in file specification.
if .p_lexeme eql k_null
then
begin
p_lexeme = .p_this ; ! Start the current lexeme.
f_file_spec = true;
end;
end ! Colon in file specification.
else
begin ! Colon as a normal lexeme.
if .p_lexeme eql k_null
then
begin ! Special colon.
p_lexeme = .p_this ; ! Start lexeme.
p_rest = ch$plus(.p_this, 1) ; ! And end it.
end ! Special colon.
else
p_rest = .p_this ; ! End the current lexeme.
end ; ! Colon as a normal lexeme.
[%c' ', 9]: ! Space or tab
if .p_lexeme neq k_null
then
p_rest = .p_this ; ! End the current lexeme.
[%c',']: ! Comma for file specs only
if .lexical_rule eql k_file_spec_lex
then
begin
if .p_lexeme neq k_null
then
begin
p_rest = .p_this; ! And end the lexeme.
end
else
begin
if .f_file_spec
then
f_file_spec = false
else
exitloop;
end;
end
else
bad_character = true;
[%c'"']:
if .p_lexeme eql k_null
then
bad_character = true ! Unwanted quotation.
else
p_rest = .p_this ; ! End the current lexeme.
[otherwise]:
bad_character = true ;
tes ; ! Examine one character of non-quotation.
end ! Non-quotation needed.
else if .lexical_rule eql k_quotation_lex
then
begin ! Quotation needed.
selectone ch$rchar(.p_this) of
set ! Examine one character of quotation.
[%c'"']:
if .p_lexeme eql k_null
then
begin ! First quote.
num_quotes = 1 ;
p_lexeme = .p_this ;
end ! First quote.
else
num_quotes = .num_quotes + 1 ;
[otherwise]:
if .p_lexeme eql k_null
then
begin ! Missing first quote.
ers(s_quotenot,cat(.a_explanation, ' beginning with "',
(1, .p_this), '" must be a quoted string')) ;
if description eql k_null
then
bug(lit('See above message')) ;
return false ; ! Not executed if BUG called.
end ! Missing first quote.
else
begin ! See if quotation should be ended.
if ch$rchar(ch$plus(.p_this, -1)) eql %c'"'
and .num_quotes mod 2 eql 0
then
p_rest = .p_this ; ! Previous character was the
! closing quotation mark.
end ; ! See if quotation should be ended.
tes ; ! Examine one character of quotation.
end ! Quotation needed.
else
bug(cat('Invalid lexical rule when processing ',
user_string)) ;
if .bad_character
then
begin ! Bad character.
local
bad_lexeme : desc_block ; ! Descriptor of lexeme in
! process.
if .p_lexeme eql k_null
then
$str_desc_init(descriptor = bad_lexeme, string = (1, .p_this))
else
$str_desc_init(descriptor = bad_lexeme,
string = (ch$diff(.p_this, .p_lexeme) + 1, .p_lexeme)) ;
errchr(.p_this, bad_lexeme, .a_explanation) ;
if description eql k_null
then
bug(lit('See above message')) ;
return false ; ! Not executed if BUG called.
end ; ! Bad character.
! Advance to the next character.
p_this = ch$plus(.p_this, 1) ;
end ; ! Examine one character and advance to the next.
! Report a missing lexeme.
if .p_lexeme eql k_null
then
begin ! Missing lexeme.
if description eql k_null
then
bug(cat('Lexeme not found in ', user_string)) ;
ers(s_missing,cat('Please supply ', .a_explanation)) ;
return false ;
end ; ! Missing lexeme.
! End of input ends the lexeme, even a quoted string.
if .p_rest eql k_null
then
begin ! End of input.
! Mark the user string as empty.
p_rest = .p_this ;
! Extend an unclosed quotation.
if .num_quotes mod 2 neq 0
then
begin ! Last item is an unclosed quotation.
! Store a quotation mark just after the user string.
ch$wchar(%c'"', .p_this) ;
! Have the lexeme be extended when the descriptor is set.
closing = 1 ;
end ; ! Last item is an unclosed quotation.
end ; ! End of input.
! Set the lexeme descriptor.
$str_desc_init(descriptor = lexeme,
string = (ch$diff(.p_rest, .p_lexeme) + .closing, .p_lexeme)) ;
! Skip over spaces and tabs following the lexeme.
while
if ch$diff(.p_rest, .user_string[desc_ptr])
lss .user_string[desc_len]
then
ch$rchar(.p_rest) eql %c' ' or ch$rchar(.p_rest) eql 9
else
false
do
p_rest = ch$plus(.p_rest, 1) ;
! The rest has been found.
! The order of these statements is important !
user_string[desc_len] = .user_string[desc_len]
- ch$diff(.p_rest, .user_string[desc_ptr]) ;
user_string[desc_ptr] = .p_rest ;
true
end ; ! NXTLEX
global routine peekch(a_user_string, a_char_set) =
!++
! Functional Description:
!
! This routine tests whether the first character in the user string
! is one of a given set of characters. If so, TRUE is returned,
! otherwise FALSE is returned. FALSE is also returned if the user
! string is empty.
!
! Formal Parameters:
!
! a_user_string: Address of a descriptor for the user string, whose
! first character is to be examined.
! a_char_set: Address of a descriptor for a string whose characters
! are those to be looked for in user string.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! TRUE means the first character of the user string belongs to the set.
! FALSE means that the first character does not belong to the set, or
! that the user string is empty.
!
! Side Effects:
!
! None
!
!--
begin ! PEEKCH
bind
user_string = .a_user_string : desc_block,
char_set = .a_char_set : desc_block ;
if .user_string[desc_len] gtr 0
then
not ch$fail(ch$find_ch(len_comma_ptr(char_set),
ch$rchar(.user_string[desc_ptr])))
else
false
end ; ! PEEKCH
end ! Module LEXICA
eludom