Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/lognam.bli
There are no other files named lognam.bli in the archive.
module lognam ( ! Logical name operations
ident = '1',
%if
%bliss(bliss32)
%then
language(bliss32),
addressing_mode(external=general,
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:
!
! Operations on logical names.
!
! Environment: VAX/VMS, DS-20, TOPS-10
!
! Author: Earl Van Horn Creation Date: May 1980
!
!--
!
! Table of Contents:
!
forward routine
crelog : novalue, ! Create a logical name.
dellog , ! Delete a logical name.
trnlog; ! Translate a logical name.
!
! Include Files:
!
%if %bliss(bliss32) %then
library 'SYS$LIBRARY:STARLET' ;
undeclare %quote $descriptor ; ! Conflict with XPORT
%else
require 'jsys:';
%fi
library 'XPORT:' ;
require 'BLISSX:' ;
require 'SCONFG:' ;
!
! Macros:
!
%if %bliss(bliss32) %then
! The following fields should be defined in STARLET.REQ .
! They are fields in the CLI request block for the logical name services.
macro
cli_q_name = 4,0,0,0 %, ! Address of descriptor of logical name.
cli_q_value = 12,0,0,0 % ; ! Address of descriptor of logical name value.
%fi
!
! Equated Symbols:
!
%if %bliss(bliss36) %then
%if %switches(tops20) %then
%else
%error('DS-10 code not yet implemented');
%fi
%fi
!
! Own Storage:
!
%if %bliss(bliss36) %then
%if %switches(tops20) %then
%else
%error('DS-10 code not yet implemented');
%fi
%fi
!
! External References:
!
external routine
bug : novalue, ! Report a bug.
ers, ! error
%if %bliss(bliss36) %then
%if %switches(tops20) %then
bugsts : novalue, ! Report a bug involving a system status code.
cvtas0, ! convert desc string to ASCIZ(STROPS)
cvtdes, ! convert ASCIZ string to desc format(STROPS)
freas0, ! free dynamic memory used by ASCIZ string(STROPS)
%fi
%fi
%if %bliss(bliss32) %then
lib$set_logical, ! set/create supervisor-mode logical name
lib$delete_logical, ! delete supervisor-mode logical name
bugsts : novalue, ! Report a bug involving a system status code.
%fi
say; ! testing purposes only
EXTERNAL LITERAL
s_libnamlim;
global routine crelog(a_name, a_value) : novalue =
!++
! Functional Description:
!
! This routine creates a process logical name that will continue to
! exist after the current image exits. Any previous value for this
! logical name is superseded.
!
! NB: TOPS-10 has no facilities for logical names.
! STEP10 will allow a "logical name" to be defined only
! for LIB (a macro defined in SCONFG.req).
!
! Any trailing colon in the name is ignored. However, the value
! to be defined for the name is accepted without change.
!
! No case conversion is performed.
!
! Formal Parameters:
!
! A_NAME: Address of a descriptor of the logical name to be
! defined. Any trailing colon is ignored.
! A_VALUE: Address of a descriptor of the value to be given to
! the logical name. Any previous value is superseded.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! The logical name is defined.
!
!--
begin ! CRELOG
bind
name = .a_name : desc_block,
value = .a_value : desc_block ;
own
p_name, ! pointer for ASCIZ string name
p_value ; ! pointer for ASCIZ string value
local
%if %bliss(bliss32) %then
d_name_no_colon : desc_block,
%fi
colon, ! One means the name ends with a colon,
! zero means not.
status ; ! Status code from a system service.
! Make sure a name was supplied.
if .name[desc_len] eql 0
then
bug(lit('CRELOG was given a zero length name')) ;
!+
! make sure the logical name translation is not too long
!-
IF
.value[desc_len] GTR %if VaxVms %then 63 %fi
%if Tops20 %then 39 %fi
THEN
ers(s_libnamlim,cat('The directory specification, ',
value,', cannot be longer than ',
%if VaxVms %then '63' %fi
%if Tops20 %then '39' %fi,' characters'));
! Eliminate any trailing colon from the name.
if ch$rchar(ch$plus(.name[desc_ptr], .name[desc_len] - 1)) eql %c':'
then
colon = 1
else
colon = 0 ;
%if %bliss(bliss32) %then
$str_desc_init(descriptor = d_name_no_colon,
string = (.name[desc_len] - .colon, .name[desc_ptr])) ;
status = lib$set_logical (d_name_no_colon, value);
if not .status
then
bugsts(.status, cat('CRELOG could not define ', name)) ;
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
! Check for trailing colon
name[desc_len] = .name[desc_len] - .colon ;
!Make the string ASCIZ
cvtas0(name,p_name) ;
cvtas0(value,p_value) ;
!Define the logical name.
if
crlnm($clnjb,.p_name,.p_value;status) neq 1
then
begin
freas0(.p_name) ;
freas0(.p_value) ;
bugsts(.status, cat('CRELOG could not define ', name)) ;
end ;
! free memory used by ASCIZ string
freas0(.p_name) ;
freas0(.p_value) ;
%else
begin
register
R;
local
tmpcorString: block[tmpcorStringSize];
! check if name=LIB; if not, it's considered a bug
if ch$neq(.name[desc_len], .name[desc_ptr],
%CHARCOUNT(LIB), ch$ptr(uplit(LIB)) ) then
bug(lit('CRELOG only defines logical names for LIB'));
! store 'value~~~...~~~LOG' in tmpcorString
ch$fill(tmpcorFillChar,tmpcorStringLength,ch$ptr(tmpcorString));
ch$move(.value[desc_len],.value[desc_ptr],ch$ptr(tmpcorString));
ch$move(%CHARCOUNT(LIB), ch$ptr(uplit(LIB)),
ch$plus(ch$ptr(uplit(LIB)), tmpcorStringLength-%CHARCOUNT(LIB)));
! store tmpcorStrng in th S$L "file"
tmpcorBlock[1,rhw] = tmpcorString - 1;
R<LH> = $TCRWF;
R<RH> = tmpcorBlock;
if UUO(1,TMPCOR(R)) neq 1 then
bug(lit('TMPCOR UUO does not work -- not enough room'));
end;
%fi
%fi
end ; ! CRELOG
global routine dellog(a_name) =
!++
! Functional Description:
!
! This routine deletes a process logical name. Any trailing colon
! in the name is ignored. The returned value indicates whether
! a deletion actually occurred.
!
! NB: TOPS-10 has no facilities for logical names.
! STEP10 returns false unless a_name is the same as
! was last written to the TMPCOR file by crelog.
!
! Formal Parameters:
!
! A_NAME: Address of a descriptor of the process logical
! name to be deleted. Any trailing colon is ignored.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! TRUE means the name did have a value, and that the name was
! successfully deleted. FALSE means that the name did not have
! a value to be deleted, i.e., that no such logical name is defined.
!
! Side Effects:
!
! The logical name is deleted.
!
!--
begin ! DELLOG
bind
name = .a_name : desc_block ;
own
p_name ; ! pointer to ASCIZ string
local
d_name_no_colon : ! descriptor for name with colon
$str_descriptor(), ! removed
colon, ! One means the name ends with a colon,
! zero means not.
status ; ! Status code from a system service.
! Make sure a name was supplied.
if .name[desc_len] eql 0
then
bug(lit('DELLOG was given a zero length name')) ;
! Eliminate any trailing colon from the name.
if ch$rchar(ch$plus(.name[desc_ptr], .name[desc_len] - 1)) eql %c':'
then
colon = 1
else
colon = 0 ;
!remove colon from name
$str_desc_init (descriptor = d_name_no_colon,
string = (.name[desc_len]-.colon, .name[desc_ptr]));
%if %bliss(bliss32) %then
! Call the CLI to delete the logical name.
status = lib$delete_logical (d_name_no_colon);
if not .status
then
begin ! Problem.
if .status eql ss$_nolognam
then
return false ;
bugsts(.status, cat('DELLOG could not delete ', name)) ;
end ; ! Problem.
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
!make string ASCIZ
cvtas0(d_name_no_colon,p_name) ;
if
crlnm($clnj1,.p_name;status) neq 1
then
begin ! Problem.
freas0(.p_name) ;
if .status eql crlnx1
then
return false ;
bugsts(.status, cat('DELLOG could not delete ', name)) ;
end ; ! Problem.
! free up memory used by ASCIZ string
freas0(.p_name) ;
%else
begin
register
R;
local
tmpcorString: block[tmpcorStringSize];
! read in the TMPCOR "file"
tmpcorBlock[1,rhw] = tmpcorString - 1;
R<LH> = $TCRRF;
R<RH> = tmpcorBlock;
if UUO(1,TMPCOR(R)) neq 1 then
return false; ! TMPCOR "file" does not exist
if .R neq tmpcorStringSize then
return false; ! "file" size wrong
! check if name is the same as in the "file"
if ch$neq(.name[desc_len], .name[desc_ptr],
tmpcorStringLength-%CHARCOUNT(LIB), ch$ptr(tmpcorString),
tmpcorFillChar) then
return false; ! name was not in the "file"
! delete the TMPCOR "file"
R<LH> = $TCRDF;
R<RH> = tmpcorBlock;
if UUO(1,TMPCOR(R)) neq 1 then
bug(lit('TMPCOR UUO does not work'));
end;
%fi
%fi
true
end ; ! DELLOG
GLOBAL ROUTINE trnlog (a_name, a_buffer) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine uses the system call to translate a logical name.
! The translation is placed in a user-supplied buffer. Standard host conventions
! are followed. If the input string ends in a colon, the colon is stripped before
! the call to the operating system(monitor).The routine returns TRUE if a
! successful logical translation occurs. The routine will return FALSE if :
!
! 1) the input string has a leading '_' character in the case of
! VAX or (ESC or CTRL/F) in the case of DS-20. The string placed
! in the output buffer is equivalent to the input string with the
! the leading character removed.
! 2) the input string has no logical translation. In this case, the
! output buffer contains the input string.
!
! NB: TOPS-10 has no facilities for logical names.
! If a_name is LOG (macro defined in SCONFG.req), then
! STEP10 will "translate" a_name to the string in TMPCOR
! (if there is one).
!
! FORMAL PARAMETERS:
!
! a_name : address of descriptor of the logical name to be translated
! ******* bug; not treated as READONLY *************
! a_buffer : address of descriptor where the resultant string is to be placed
!
! IMPLICIT INPUTS:
!
! none
!
! IMPLICIT OUTPUTS:
!
! none
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE if a successful tranlation occurs, FALSE otherwise.
!
! SIDE EFFECTS:
!
! none
!
!--
BEGIN ! routine TRNLOG
macro
esc = %char(27) % ,
ctrlf = %char(06) % ;
BIND
name = .a_name : desc_block,
buffer = .a_buffer : desc_block ;
OWN
%if VaxVms %then
len : word , ! length of logical name returned by $TRNLOG
%fi
%if Tops20 %then
p_name, ! pointer to ASCIZ string for name
u_ptr, ! updated pointer from jsys call
%fi
colon, ! presence of colon
status ; ! return status of $TRNLOG
! Check to see if output buffer is big enough
IF
.buffer[desc_len] LSS log_nam_value_size
THEN
bug(cat('logical name output buffer too small module lognam; routine trnlog')) ;
! Check for trailing colon - if it's there get rid of it
IF
CH$RCHAR (CH$PLUS (.name[desc_ptr], .name[desc_len] - 1)) EQL %C':'
THEN
colon = 1
else
colon = 0 ;
name[desc_len] = .name[desc_len] - .colon ;
%if %bliss(bliss32) %then
! Call $TRNLOG to get logical translation of input
status = $TRNLOG (LOGNAM = name,
RSLBUF = buffer,
RSLLEN = len) ;
! Check possible returns of call
! Check for no translation
IF
.status EQL SS$_NOTRAN
THEN
RETURN false ;
! Check for invalid input logical name
IF
.status EQL SS$_IVLOGNAM
THEN
BEGIN
bugsts ( .status, cat('invalid logical name in call to $TRNLOG, routine trnlog, module lognam')) ;
return false ;
END ;
! Check for other possible error codes (access violation or result buffer overflow
IF
NOT .status
THEN
BEGIN
bugsts( .status, cat('bad call to $TRNLOG routine trnlog, module lognam')) ;
return false ;
END ;
!
! Call must have been successful so return true
!
buffer[desc_len] = .len ;
RETURN true ;
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
! examine first character for ESC or CTRL/F
if
ch$rchar(.name[desc_ptr]) eql %c esc or ! ESC
ch$rchar(.name[desc_ptr]) eql %c ctrlf ! CTRL/F
then
begin ! do not perform the translation
local
len,
ptr ;
! readjust length to get back colon if it was there
name[desc_len] = .name[desc_len] + .colon ;
len = .name[desc_len] - 1 ;
ptr = ch$plus(.name[desc_ptr],1) ;
! copy to output
$str_copy(string=(.len,.ptr),target=buffer) ;
! return with no further processing
return false ;
end ; ! do not perform translation
!Make it ASCIZ
cvtas0(name,p_name) ;
!Get logical translation of input
if
lnmst($lnsjb,.p_name,.buffer[desc_ptr];status,u_ptr) neq 1
then
begin ! error return
! now check for system logical names
if
lnmst($lnssy,.p_name,.buffer[desc_ptr];status,u_ptr) neq 1
then
begin ! not translate
! free ASCIZ memory
freas0(.p_name) ;
! Check possible returns of call
! Check for no translation
IF
.status EQL lnstx1
THEN
begin
! readjust length to get back colon if it was there
name[desc_len] = .name[desc_len] + .colon ;
! force output to input length
buffer[desc_len] = .name[desc_len] ;
! copy input to output unchanged
$str_desc_init ( descriptor = buffer,
string = (.name[desc_len], .name[desc_ptr] )) ;
RETURN false ;
end ;
! Check for other possible error codes (access violation or result buffer overflow
IF
NOT .status
THEN
BEGIN
bugsts( .status, cat('bad call to lnmst JSYS 504 routine trnlog, module lognam')) ;
return false ;
END ;
end ; ! no translate
END; ! error return
! find length of string written
buffer[desc_len] = ch$diff(.u_ptr, .buffer[desc_ptr]);
! free memory
freas0(.p_name) ;
! readjust length to get back colon if it was there
name[desc_len] = .name[desc_len] + .colon ;
! Call must have been successful so return true
return true ;
%else
begin
macro noTranslation =
begin
buffer[desc_len] = .name[desc_len];
ch$move(.name[desc_len], .name[desc_ptr], .buffer[desc_ptr]);
return false;
end; % ;
register
R;
local
len, ptr, ! length and pointer to string in TMPCOR
tmpcorString: block[tmpcorStringSize];
! check if name=LIB; if not, there's no translation
if ch$neq(.name[desc_len]+colon, .name[desc_ptr],
%CHARCOUNT(LIB), ch$ptr(uplit(LIB)) ) then
noTranslation
! read in the TMPCOR "file"
tmpcorBlock[1,rhw] = tmpcorString - 1;
R<LH> = $TCRRF;
R<RH> = tmpcorBlock;
if UUO(1,TMPCOR(R)) neq 1 then
noTranslation ! TMPCOR "file" does not exist
if .R neq tmpcorStringSize then
noTranslation ! "file" size wrong
! check if "file" was written by crelog
ptr = ch$find_ch(tmpcorStringLength,
ch$ptr(tmpcorString), tmpcorFillChar);
if ch$fail(.ptr) then
noTranslation
len = ch$diff(.ptr, ch$ptr(tmpcorString));
ptr = ch$find_not_ch(tmpcorStringLength-len,
ptr, tmpcorFillChar);
if ch$fail(.ptr) then
noTranslation
if ch$neq(%CHARCOUNT(LIB), ch$ptr(uplit(LIB)),
ch$diff(ch$plus(ch$ptr(tmpcorString),tmpcorStringLength),.ptr),
.ptr) then
noTranslation
! everything is OK
buffer[desc_len] = len;
ch$move(len, ch$ptr(tmpcorString), .buffer[desc_ptr]);
end;
return true;
%fi
%fi
END;
end ! Module LOGNAM
eludom