Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/string.bli
There are no other files named string.bli in the archive.
module string ( ! General purpose string 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:
!
! Provides general purpose string handling functions.
!
! Environment: Transportable
!
! Author: Earl Van Horn Creation Date: April, 1979
!
! Modified By:
!
! , : Version
! 01 -
!--
!
! Table of Contents:
!
forward routine
endquo , ! finds length and pointer to quoted substring
findps, ! finds occurences of '#' followed by a given character
fresad : novalue, ! Frees a block allocated by MAKSAD.
maksad ; ! Allocates and initializes a string and its descriptor.
!
! Include Files:
!
%if %bliss(bliss32)
%then library 'sys$library:starlet';
%else require 'jsys:';
%fi
library 'XPORT:' ;
require 'BLISSX:' ;
!
! Macros:
!
!
! Equated Symbols:
!
! Definition of the SAD block, which is allocated by MAKSAD.
!
! In addition to fields for a string and its descriptor, this block
! contains the number of units in the block, for use in freeing
! the block.
!
$field
sad_fields =
set
sad_units = [$short_integer], ! Number of units in
! the entire block,
! including this one.
sub_descriptor(name=sad_desc), ! Descriptor of the string
! allocated in this block. The
! value returned by MAKSAD is
! the address of SAD_DESC in the
! allocated block.
sad_string = [$sub_block(0)] ! Start of string.
tes ;
literal
k_sad_head_units = $field_set_units,! Number of units in the
! SAD block, not counting those
! that store the string.
k_sad_desc_off = %upval ; ! To compute address of a SAD,
! given the address of the descriptor
! within it.
!
! Own Storage:
!
!
! External References:
EXTERNAL LITERAL
s_notalpha, !FINPS called with non-alphabetic char
s_ilaftlb; !has illegal char following # sign
EXTERNAL ROUTINE
ers ; ! Report user error
!
GLOBAL ROUTINE endquo(len,a_ptr) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will scan a string to find a quoted substring.
! It is assumed that the presence of the first quote mark represents
! the start of the quoted string and that two quoted strings are
! not adjacent to each other without at least one intervening
! delimiting character other than a quote mark.
!
! FORMAL PARAMETERS:
!
! len length of string to be scanned.
!
! a_ptr Address of pointer to start of string to be scanned.
! This pointer will be updated by this routine if the
! quoted string does not start on the first character
! of the string being scanned.
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! Length of string is returned and a_ptr is updated if quoted string
! does not start at first character of string.
! -1 = failure in processing.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
own
f_1st_quo:initial(false) ; ! first quote encounted
local
f_odd_quo, ! set on odd and clr on even quote
f_success, ! set when end of quoted string found
l_tmp, ! temp pointer and length
p_tmp, !
p_quo, ! pointer to first quote
retval ; ! value return by this routine
! initialize variables
f_odd_quo = false ;
f_success = false ;
f_1st_quo = false ;
l_tmp = .len ;
p_tmp = ..a_ptr ;
until
.l_tmp eql 0
do
begin ! read a character loop
local
char ;
char = ch$rchar_a(p_tmp) ;
l_tmp = .l_tmp - 1 ;
if
not .f_1st_quo
then
begin ! first quote found
if
.char eql %c'"'
then
begin ! start quoted string
p_quo = ch$plus(.p_tmp,-1) ;
f_odd_quo = true ;
f_1st_quo = true ;
end ; ! start quoted string
end ! first quote found
else
begin ! look for ending quote
if
.char eql %c'"'
then
begin ! quote processing
! toggle odd-even flag
if
.f_odd_quo
then
f_odd_quo = false
else
f_odd_quo = true ;
! if even,check for following quote
if
not .f_odd_quo
then
begin ! even quote
if
((ch$rchar(.p_tmp) neq %c'"') and (.l_tmp gtr 0)) or
(.l_tmp eql 0)
then
begin ! end of quoted string
retval = ch$diff(.p_tmp,.p_quo) ;
f_success = true ;
exitloop ;
end ; ! end of quoted string
end ; ! even quote
end ; ! quote processing
end ; ! looking for ending quote
end ; ! read character loop
if
.f_success and (.a_ptr neq .p_quo)
then
.a_ptr = .p_quo ;
if
not .f_success
then
retval = -1;
.retval
END; ! end of routine endquo
GLOBAL ROUTINE findps( len_string, ptr_string, char, a_num_found) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine searches a given string for an occurence of
! '#' followed by the given character of another '#'.
! The string is checked for validity - false will be returned
! for a string with unmatched '#' or an invalid character
! following the '#'.
!
!
! FORMAL PARAMETERS:
!
! len_string: fullword containing the length of the string to be checked
! ptr_string: fullword containing a pointer to the string to be checked
! char: fullword containing the allowable character after
! the '#', right justified.
! a_num_found: address of a fullword where the number of occurrences
! of '#' followed by char will be placed. If the string is invalid
! this fullword is undefined.
!
! IMPLICIT INPUTS:
!
! none
!
! IMPLICIT OUTPUTS:
!
! none
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE - the string is valid
! FALSE - the string contains a # not followed by char or another #,
! or the string contains an unmatched #
!
! SIDE EFFECTS:
!
! none
!
!--
BEGIN
bind
num_found = .a_num_found ;
local
alt_char, ! opposite character -small or capital
t_len, ! length of string
t_ptr, ! pointer to string
f_pound ; ! toggle flag for '#'
! Initialize everything
t_len = .len_string ;
t_ptr = .ptr_string ;
num_found = 0 ;
f_pound = true ;
!if string length is zero, return --
if
t_len eql 0
then
return true ;
! Find alternate character
alt_char = (selectone .char of
set
[%x'41' to %x'5a']: .char + %x'20' ;
[%x'61' to %x'7a']: .char - %x'20' ;
[otherwise] : %c' ' ;
tes) ;
! Check that alternate character is not a blank - if it is the passed
! character was not a letter.
if .alt_char eql %c' '
then
ers(s_notalpha,lit('Non-alphabetic character found after "#"')) ;
! loop to find occurrences of '#'
until .t_len eql 0
do
begin
local
this_char ; !current character
this_char = ch$rchar_a(t_ptr) ;
t_len = .t_len - 1 ;
if .this_char eql %c'#'
then ! found a pound sign
begin
local
next_char ; ! character after the pound sign
f_pound = false ; !odd pound sign
if .t_len eql 1
then !odd pound sign at end of string
begin
ers(s_ilaftlb,cat('Illegal character following "#" in ',
(.len_string,.ptr_string))) ;
return false ;
end ;
next_char = ch$rchar_a (t_ptr) ;
t_len = .t_len - 1 ;
if (.next_char eql .char) or
(.next_char eql .alt_char)
then !found pound sign follwed by legal char
begin
f_pound = true ; !toggle flag back to ok
num_found = .num_found + 1 ;
end
else !look for '##' occurence
if .next_char eql %c'#'
then !found '##' occurence
f_pound = true
else
begin
ers(s_ilaftlb,cat('Illegal character following "#" in ',
(.len_string, .ptr_string))) ;
return false ; ! found '#' followed by illegal char
end ;
end;
end ;
if .f_pound
then
return true !legal string
else
return false ; ! bad string
END; ! end of routine findps
global routine fresad(a_sad_desc) : novalue =
!++
! Functional Description:
!
! FRESAD frees the storage allocated by MAKSAD. The storage is
! identified by passing to FRESAD the address returned by MAKSAD.
!
! Formal Parameters:
!
! a_sad_desc : Address of the descriptor in the SAD block
! to be freed.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! Storage is returned to the system, by calling $XPO_FREE_MEM.
!
!--
begin ! FRESAD
bind
sad = .a_sad_desc - k_sad_desc_off
: block field(sad_fields) ;
$xpo_free_mem(binary_data = (.sad[sad_units], sad, units)) ;
end ; ! FRESAD
global routine maksad(num_chars) =
!++
! Functional Description:
!
! Allocate space for a string of length NUM_CHARS and for a descriptor
! of that string. Initialize the descriptor to denote the string.
! Return the address of the descriptor. The allocated space may be
! freed by calling FRESAD.
!
! Formal Parameters:
!
! num_chars: The length of the string to be allocated.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value: The address of the descriptor
! Completion Codes:
!
! None
!
! Side Effects:
!
! A block is allocated in the system's free storage
! using $XPO_GET_MEM.
!
!--
begin ! MAKSAD
local
r_sad : ref block field(sad_fields),
! Address of allocated sad.
units_needed ; ! Number of units to allocate.
units_needed = k_sad_head_units + units_for_chars(.num_chars) ;
$xpo_get_mem(units = .units_needed, result = r_sad) ;
r_sad[sad_units] = .units_needed ;
$str_desc_init(descriptor = r_sad[sad_desc],
string = (.num_chars, ch$ptr(r_sad[sad_string]))) ;
r_sad[sad_desc] ! Return the address of the sad descriptor.
end ; ! MAKSAD
end ! Module STRING
eludom