Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/sysops.bli
There are no other files named sysops.bli in the archive.
module sysops ( ! Miscellaneous interfaces to the host system.
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: STEP Library Processor
!
! Abstract:
!
! This file defines miscellaneous routines whose implementations
! are host dependent.
!
! Environment: VAX/VMS, DS-20, TOPS-10
!
! Author: Earl Van Horn Creation Date: January 16, 1980
!
!--
!
! Table of Contents:
!
forward routine
%if %bliss(bliss36) %then
%if %switches(tops20) %then
lib$put_output, ! Simulate routine of same name on VMS,
%fi ! write line to tty without XPORT.
%fi
exits : novalue, ! Silently terminate image execution.
sysmes ; ! Return descriptor to status message.
!
! Include Files:
!
%if %bliss(bliss32) %then
library 'SYS$LIBRARY:STARLET' ;
undeclare %quote $descriptor ; ! Conflict with XPORT
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
require 'JSYS:';
%else
require 'UUO:';
%fi
%fi
library 'XPORT:' ;
require 'BLISSX:' ;
%if %bliss(bliss32) %then
require 'CONDIT:' ;
%fi
!
! Macros:
!
!
! Equated Symbols:
!
!
! Own Storage:
!
!
! External References:
!
external routine
%if %bliss(bliss36) %then
%if %switches(tops20) %then
cvtdes, ! convert ASCIZ string to desc format(STROPS)
%fi
%fi
bug; ! print bug message(TERMIO)
global routine exits(status) : novalue =
!++
! Functional Description:
!
! This routine terminates execution of the current image. No message
! is issued (except under TOPS-10).
!
! Formal Parameters:
!
! STATUS Status value to be returned as the completion code
! for the current image.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! None
!
!--
begin ! EXITS
%if %bliss(bliss32) %then
local
silent_status : $sts_fullword ; ! Status with inhibit-message bit on.
silent_status = .status ;
silent_status[sts$v_inhib_msg] = 1 ;
$exit(code = .silent_status) ;
! This code should never execute.
signal_stop(.status) ;
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
haltf()
%else
UUO(0,RESET(0));
UUO(0,EXIT(1));
%fi
%fi
end ; ! EXITS
%if %bliss(bliss36) %then
GLOBAL ROUTINE LIB$PUT_OUTPUT (d_message) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is compiled only on Tops-10 and Tops-20 systems and
! duplicates the functionality of STARLET's LIB$PUT_OUTPUT. It
! prints a message without going through XPORT.
!
! FORMAL PARAMETERS:
!
! d_message a descriptor describing string to be printed
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! true
!
! SIDE EFFECTS:
!
!--
BEGIN
MAP
d_message : ref $str_descriptor();
LITERAL
max_len = 150;
LOCAL
temp_ptr,
mess_buf : vector[ch$allocation(max_len+3)];
temp_ptr = ch$move (minu(max_len,.d_message[str$h_length]),
.d_message[str$a_pointer],
ch$ptr(mess_buf) );
temp_ptr = ch$move (3,
ch$ptr(uplit(%char(13, 10, 00))),
.temp_ptr );
%if tops20 %then
PSOUT (mess_buf);
%fi
%if tops10 %then
UUO (0, OUTSTR(mess_buf));
%fi
return true;
END; !(of routine LIB$PUT_OUTPUT)
%fi
global routine sysmes(status, a_buffer) =
!++
! Functional Description:
!
! This routine obtains the message associated with a system status code,
! and returns the address of a descriptor for it. If there is no
! message associated with the code, or if the code is not a valid system
! status code, a message with the hexadecimal(VAX) or the octal
! (-20) code value is returned.
!
! NB: TOPS-10 has no facilities for converting status codes to
! strings. Thus, a message with the octal (-10) code value is
! ALWAYS returned.
! The caller supplies a descriptor of a buffer in which the message
! is to be placed. The routine places the message in the buffer,
! adjusts the length field of the descriptor, and returns the address of
! the same descriptor.
!
! Formal Parameters:
!
! status: Status code whose message is to be returned.
! a_buffer: Address of a descriptor of the buffer into which the
! message is to be placed. The buffer can be any length,
! but the message produced by this routine will not be
! longer than 256 characters.
!
! The length of the descriptor will be changed to the
! length of the actual message, and the address of the
! descriptor is returned.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! The same descriptor address that was passed to the routine.
!
! Side Effects:
!
! None
!
!--
begin ! SYSMES
bind
buffer = .a_buffer : desc_block ;
literal
%if %bliss(bliss32) %then
text = 1, ! flag for text only returned from $GETMSG
%fi
k_max_message_chars = 256 ; ! VMS limit on size of message.
local
code, ! Status returned by system services
! called by this routine.
%if %bliss(bliss32) %then
message_chars : word ; ! number of characters in the message
%fi
%if %bliss(bliss36) %then
ernum : block[1],
ptr: block[1],
stgcnt : block[1] ;
%fi
%if %bliss(bliss32) %then
! Get the message text and length.
code = $getmsg(msgid = .status, msglen = message_chars,
bufadr = buffer, flags = text) ;
! Make sure we have a message.
if not (.code eql ss$_normal or .code eql ss$_bufferovf)
then
begin ! Compose hex message.
code = $fao(lit('Status code in hex: !XL'),
message_chars, buffer, .status) ;
if not (.code eql ss$_normal or .code eql ss$_bufferovf)
then
signal_stop(.status, .code) ;
end ; ! Compose hex message.
! Adjust the message descriptor and return its address.
buffer[desc_len] = min(.message_chars, k_max_message_chars) ;
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
!Put the handle and error value together
ernum[lh]=$fhslf ;
ernum[rh]=.status;
!Set maximum error message length
stgcnt[lh]=-k_max_message_chars;
stgcnt[rh]=0;
! set up pointer
ptr = .buffer[desc_ptr] ;
!Get the message text and length.
code=erstr(.ptr,.ernum,.stgcnt);
!Make sure we have a message
if
.code eql 0
then
begin ! +1 return -> bad error code
! fix length to 34 characters
if
.buffer[desc_len] lss 34
then
bug(lit('Not enough room in output buffer area (sysmes)'))
else
buffer[desc_len] = 34 ;
! generate octal message
$str_copy(string=$str_concat('Status code in octal: ',
$str_ascii(.status,base8,length=12)),
target= (.buffer[desc_len],.buffer[desc_ptr])) ;
return true ;
end; ! +1 return -> bad error code
if
.code eql 1
then
bug(lit('invalid designation designator or string size out of bounds')) ;
if
.code neq 2
then
bug(lit('Invalid return from ERSTR JSYS 11 call!')) ;
! update descriptor
if
not cvtdes(.ptr,buffer)
then
bug(lit('Illegal ASCIZ string(SYSMES)')) ;
%else
! fix length to 34 characters
if
.buffer[desc_len] lss 34
then
bug(lit('Not enough room in output buffer area (sysmes)'))
else
buffer[desc_len] = 34 ;
! generate octal message
$str_copy(string=$str_concat('Status code in octal: ',
$str_ascii(.status,base8,length=12)),
target= (.buffer[desc_len],.buffer[desc_ptr])) ;
return true ;
%fi
%fi
! return address of descriptor
buffer
end ; ! SYSMES
end ! Module SYSOPS
eludom