Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/blissx.req
There are no other files named blissx.req in the archive.
! BLISSX.REQ -- Some general purpose extensions to the BLISS language
!
! 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 file contains macros and other declarations expected to
! be useful throughout the CMS system. These include some
! standard abbreviations like TRUE and FALSE, and some facilities
! for string concatenation and other string operations.
!
! Environment: Transportable
!
! Author: Earl Van Horn Creation Date: April, 1979
!
!--
! This file assumes that the declaration
!
! LIBRARY 'XPORT:' ;
!
! or equivalent has already appeared in the program.
! These abbreviations improve readability or evolvability.
!
literal
true = (0 eql 0),
false = (0 neq 0) ;
macro
repeat = while true do % ;
literal
k_null = xpo$k_failure ; ! XPORT compatible constant for
! both the null address and the
! null character pointer.
!+
! These literals are designed to simipify the generation of machine
! dependent in-line code. The use of TOPS10 and TOPS20 only require
! one level of %if-%then-%fi instead of two levels necessary when
! using %switches directly.
!-
%if %bliss(bliss32) %then
LITERAL ! expand this if VMS
VaxVms = true,
Tops10 = false,
Tops20 = false;
%fi
%if %bliss(bliss36) %then
LITERAL ! expand this if TOPS-10 or TOPS-20
VaxVms = false,
Tops10 = %Switches(tops10),
Tops20 = %Switches(tops20);
%fi
! The IN_RANGE and OUT_RANGE Macros
!
! These macros generate code to do standard in-range and out-range
! checking but allow the BLISS code to be more readable.
macro
In_Range (value, low, high) = ((value) GEQ (low) and (value) LEQ (high)) %,
Out_Range(value, low, high) = ((value) LSS (low) and (value) GTR (high)) %;
! The UNITS_FOR_CHARS Macro
!
! This macro produces an expression for the number of addressable units
! needed to store a given number of characters.
!
macro
units_for_chars(n) =
%bliss32(n) %bliss16(n) %bliss36(ch$allocation(n))
% ;
! The SUB_DESCRIPTOR Macro
!
! This macro is an extension of the XPORT facility for defining transportable
! data structures. When used in a $FIELD declaration, it generates field
! definitions for an XPORT fixed or dynamic descriptor (but not for a bounded
! descriptor). The descriptor may appear anywhere in a data block, but the
! macro aligns it to start with an addressable unit.
!
! The macro should be called in an XPORT $FIELD declaration, as an item listed
! between SET and TES. For example, suppose one wants to define a data block
! called NODE that contains a descriptor, a usage count, a type code, and the
! link addresses for a two-way list. The block might be declared as follows:
!
! $FIELD
! NODE_FIELDS =
! SET
! NODE_NEXT = [$ADDRESS],
! NODE_PREV = [$ADDRESS],
! SUB_DESCRIPTOR(NAME = NODE_SPELL),
! NODE_USAGE = [$SHORT_INTEGER],
! NODE_TYPE = [$BYTE]
! TES ;
!
! The argument of SUB_DESCRIPTOR is the name of the descriptor. This name will
! be declared by the macro as a field of length zero at the beginning of the
! descriptor. The name must consist of 27 or fewer characters, because the
! macro declares the other field names of the descriptor by appending the
! four-character suffixes listed in the macro. For instance, in the above
! example the name NODE_SPELL is a zero length field at the start of the
! descriptor, and the name NODE_SPELL_LEN is the length field of the descriptor.
!
! The descriptor can be initialized by $XPO_DESC_INIT. It is typically
! used for strings, but also can be used for binary data. The _PTR field should
! be used when the descriptor denotes a character string, and the _ADR field
! should be used when the descriptor denotes binary data.
!
keywordmacro
sub_descriptor(name) =
name = [$descriptor(fixed)], ! XPORT fixed descriptor
%name(name, '_len') = [$sub_field(name, str$h_length)], ! Length
%name(name, '_typ') = [$sub_field(name, str$b_dtype)], ! Data type
%name(name, '_cls') = [$sub_field(name, str$b_class)], ! Class
%name(name, '_ptr') = [$sub_field(name, str$a_pointer)],! Char. ptr.
%name(name, '_adr') = [$sub_field(name, xpo$a_address)] ! Address
% ;
! The DESC_BLOCK Macro
!
! This macro generates the BLISS attributes for an XPORT compatible
! descriptor of the kind defined by the SUB_DESCRIPTOR macro.
!
! The DESC_BLOCK macro may appear in an OWN, GLOBAL, LOCAL, MAP, or
! BIND declaration.
!
macro
desc_block =
block[k_desc_fullwords] field(desc_fields)
% ;
! These are declarations used in the DESC_BLOCK macro.
!
$field
desc_fields =
set
sub_descriptor(name=desc) ! Declares desc_len, desc_ptr, etc.
tes ;
literal
k_desc_fullwords = $field_set_size, ! Fullwords in a descriptor block.
k_desc_units = $field_set_units ; ! Addressable units in a desc. block.
! The LIT Macro
!
! This macro generates a UPLIT for the descriptor of a character
! string literal.
!
macro
lit(c) =
uplit(%charcount(c)
%bliss32(or str$k_dtype_t ^ 16 or str$k_class_f ^ 24)
%bliss36(or str$k_dtype_t ^ 18 or str$k_class_f ^ 27)
%bliss16( , str$k_dtype_t or str$k_class_f ^ 8)
, ch$ptr(uplit(c)))
% ;
! The CAT Macro
!
! This macro concatenates strings. It generates an expression whose value is
! the address of a descriptor of the concatenated string. It allocates and
! initializes both the descriptor and the string.
!
! The string is the concatenation of the strings defined by the arguments,
! in the order given. There may be any number of arguments, but there
! must be at least one. Each argument can be one of the string definition
! forms recognized by XPORT:
!
! address-of-descriptor
! quoted-string
! ( quoted-string )
! ( number-of-characters , character-pointer )
!
! The string and descriptor remain allocated unless explicitly freed by
! calling the external routine FRESAD.
!
macro
cat [] =
%if %null(check_str_info(%remaining))
%then
begin ! cat
local
a_desc ; ! Address of descriptor of concatenation
external routine
maksad ; ! Allocates & initializes string & descriptor
a_desc = maksad(sum_of_lens(%remaining)) ;
ch$copy(len_comma_ptr(%remaining), 0, len_comma_ptr(.a_desc)) ;
.a_desc
end !cat
%fi
% ;
! The SCAT Macro
! This macro performs the same function as the CAT macro. It differs
! internally, in that it reuses the same memory over and over again,
! if possible. It is designed for instances in which the same
! SCAT statement is performed over and over, and the results of the previous
! instance are no longer needed in any way. For instance,
! it would be APPROPRIATE to use this for strings that are output
! immediately. It would be INAPPROPRIATE in a loop whose purpose
! is to build an array of descriptors.
macro
scat [] =
%if %null(check_str_info(%remaining))
%then
begin !scat
literal init=100;
own
first : initial(true),
desc1 : $str_descriptor(class=DYNAMIC_BOUNDED,
string=(0,0)),
cur_len : initial(init),
cur_total,
out_desc : desc_block;
!if first time, get initial memory allocation
if .first
then
begin
first = false;
$xpo_get_mem(characters=init,descriptor=desc1);
end;
!how long is this string?
cur_total = sum_of_lens(%remaining);
!is current space enough to accomodate this string?
if .cur_total gtr .cur_len
then
begin !get more space
$xpo_free_mem(string=desc1);
$xpo_get_mem(characters=.cur_total,descriptor=desc1);
cur_len = .cur_total;
end; !get more space
!now copy string, and update length.
ch$copy(len_comma_ptr(%remaining),0,.cur_total,
.desc1[str$a_pointer]);
desc1[str$h_length] = .cur_total;
!now point to it with a SAY-compatible descriptor (non-bounded)
$str_desc_init(descriptor=out_desc,
string=(.desc1[str$h_length],.desc1[str$a_pointer]));
!return address of descriptor
out_desc
end ! scat
%fi
% ;
! The LEN_COMMA_PTR Macro
!
! This macro generates a list of the form
!
! length , character-pointer , length , character-pointer ...
!
! Each argument of the macro results in one "length , pointer" pair, and the
! pairs occur in the same order as the corresponding arguments. Each pair
! describes a string defined by the corresponding argument, which can be
! one of the four XPORT string forms. There may be any number of arguments,
! but there must be at least one.
macro
len_comma_ptr(s) [] =
%if %identical((s), (%remove(s)))
%then %if %isstring(s)
%then %charcount(s) , ch$ptr(uplit(s))
%else .block[s, desc_len] , .block[s, desc_ptr]
%fi
%else %if num_params(%remove(s)) eql 1 and %isstring(%remove(s))
%then %charcount(%remove(s)) , ch$ptr(uplit(%remove(s)))
%else %if num_params(%remove(s)) eql 2
%then %remove(s)
%else %error('LEN_COMMA_PTR has the bad argument ', s)
%fi
%fi
%fi
%if not %null(%remaining)
%then , len_comma_ptr(%remaining)
%fi
% ;
! The CHECK_STR_INFO Macro
!
! This macro checks that each of its arguments is one of the three XPORT
! forms for string information. The user is told about each argument
! that is recognized as invalid. Null is returned if and only if all
! arguments are valid.
!
macro
check_str_info(s) [] =
%if not %identical((s), (%remove(s)))
%then %if num_params(%remove(s)) gtr 2
%then %errormacro('The string information ', s,
' must not have more than two items.')
%count ! Return something non-null.
%fi
%fi
check_str_info(%remaining)
% ;
! The SUM_OF_LENS Macro
!
! This macro computes the sum of the lengths of a list of strings, i.e.,
! it generates an expression whose value is that sum. Each argument
! can be one of the three XPORT string forms.
!
macro
sum_of_lens(s) [] =
%if %count eql 0
%then ( ! Insert an opening parenthesis.
%fi
%if %identical((s), (%remove(s)))
%then %if %isstring(s)
%then %charcount(s) ! If s is quoted-string
%else .block[s, desc_len] ! If s is a descriptor address
%fi
%else %if num_params(%remove(s)) eql 1 and %isstring(%remove(s))
%then %charcount(%remove(s)) ! If s is ( quoted-string )
%else %if num_params(%remove(s)) eql 2
%then first_param(%remove(s)) ! If s has len and ptr
%else %error('SUM_OF_LENS has the bad argument ', s)
%fi
%fi
%fi
%if not %null(%remaining)
%then + sum_of_lens(%remaining)
%else ) ! Insert a closing parenthesis.
%fi
% ;
! These macros are used in the above macros.
!
macro
first_param(a) [] = a %,
num_params [] = %length % ;
! The following macros are used to allow CMS to intercept the various
! XPORT calls and let it do special processing if needed.
!
! WARNING: These macros must be called with at least one argument,
! otherwise they expand to NULL!
! The $STEP_CLOSE macro
!
! This macro allows $XPO_CLOSE calls to be intercepted by the FILE$CLOSE
! routine for special processing.
!
macro
$step_close [] =
begin
macro xpo$close = file$close %quote % ;
$xpo_close (%remaining)
end % ;
! The $STEP_GET macro
!
! This macro allows $XPO_GET calls to be intercepted by the FILE$GET
! routine for special processing.
!
macro
$step_get [] =
begin
macro xpo$get = file$get %quote % ;
$xpo_get (%remaining)
end % ;
! The $STEP_OPEN macro
!
! This macro allows $XPO_OPEN calls to be intercepted by the FILE$OPEN
! routine for special processing.
!
macro
$step_open [] =
begin
macro xpo$open = file$open %quote % ;
$xpo_open (%remaining)
end % ;
! The $STEP_PUT macro
!
! This macro allows $XPO_PUT calls to be intercepted by the FILE$PUT
! routine for special processing.
!
macro
$step_put [] =
begin
macro xpo$put = file$put %quote % ;
$xpo_put (%remaining)
end % ;
! The $STEP_RENAME macro
!
! This macro allows $XPO_RENAME calls to be intercepted by the FILE$RENAME
! routine for special processing.
!
macro
$step_rename [] =
begin
macro xpo$rename = file$rename %quote % ;
$xpo_rename (%remaining)
end % ;
! The $STEP_DELETE macro
!
! This macro allows $XPO_DELETE calls to be intercepted by the FILE$DELETE
! routine for special processing.
!
macro
$step_delete [] =
begin
macro xpo$delete = file$delete %quote % ;
$xpo_delete (%remaining)
end % ;
! The $CMS_OPEN macro
!
! This macro allows $XPO_OPEN calls to be intercepted by the IO$OPEN
! routine to avoid special processing.
!
macro
$cms_open [] =
begin
macro xpo$open = io$open %quote % ;
$xpo_open (%remaining)
end % ;
! The $CMS_CLOSE macro
!
! This macro allows $XPO_CLOSE calls to be intercepted by the CMS$CLOSE
! to avoid special processing.
!
macro
$cms_close [] =
begin
macro xpo$close = io$close %quote % ;
$xpo_close (%remaining)
end % ;
! The $CMS_GET macro
!
! This macro allows $XPO_GET calls to be intercepted by the CMS$GET
! to avoid special processing.
!
macro
$cms_get [] =
begin
macro xpo$get = io$get %quote % ;
$xpo_get (%remaining)
end % ;
! The $CMS_PUT macro
!
! This macro allows $XPO_PUT calls to be intercepted by the CMS$PUT
! to avoid special processing.
!
macro
$cms_put [] =
begin
macro xpo$put = io$put %quote % ;
$xpo_put (%remaining)
end % ;
! The following macros declares all the control blocks
! and buffers needed to allow CMS use RMS or JSYS calls
! for faster IO while faking XPORT to minimise too much
! radical change.
! The $IO_BLOCK macro
! declares varous blocks and buffers to allow full IO.
Macro
$io_block(name) =
%if
VaxVms
%then
%name(name,'_buf') : VECTOR[ch$allocation(512)],
%name(name,'_nam_buf') : VECTOR[ch$allocation(nam$c_maxrss)],
%name(name,'_nam') : $NAM(RSS=nam$c_maxrss,
RSA=ch$ptr(%name(name,'_nam_buf'))),
%name(name,'_fab') : $FAB(NAM=ch$ptr(%name(name,'_nam')),
FOP=SQO, ORG=SEQ, RFM=VAR),
%name(name,'_rab') : $RAB(FAB=ch$ptr(%name(name,'_fab')),
RBF=ch$ptr(%name(name,'_buf')), RSZ=512,
UBF=ch$ptr(%name(name,'_buf')), USZ=512,
MBC=10, ROP=<RAH,WBH,LOC,PMT>),
%name(name,'_iob') : $XPO_IOB() PRESET([iob$a_rms_fab] = ch$ptr(%name(name,'_fab')),
[iob$a_rms_rab] = ch$ptr(%name(name,'_rab')),
[iob$h_length] = iob$k_length)
%else
%name(name,'_iob') : $XPO_IOB()
PRESET([$sub_field(iob$t_resultant,str$a_pointer)] = 0,
[$sub_field(iob$t_resultant,str$h_length)] = 0,
[$sub_field(iob$t_resultant,str$b_class)] = str$k_class_d,
[$sub_field(iob$t_resultant,str$b_dtype)] = str$k_dtype_t,
[iob$h_length] = iob$k_length)
%fi
% ;
! The $IO_BLOCK_DECL macro
! declares varous blocks and buffers to allow full IO used for local declaraations
Macro
$io_block_decl(name) =
%if
VaxVms
%then
%name(name,'_nam_buf') : VECTOR[ch$allocation(nam$c_maxrss)],
%name(name,'_nam') : $NAM(),
%name(name,'_fab') : $FAB(),
%name(name,'_rab') : $RAB(),
%name(name,'_buf') : VECTOR[ch$allocation(512)],
%fi
%name(name,'_iob') : $XPO_IOB() % ;
! The $IO_BLOCK_INIT macro
! declares varous blocks and buffers to allow full IO.
Macro
$io_block_init(name) =
BEGIN
%if
VaxVms
%then
$NAM_INIT(NAM = ch$ptr(%name(name,'_nam')),
RSA=ch$ptr(%name(name,'_nam_buf')), RSS=nam$c_maxrss);
$FAB_INIT(FAB = %name(name,'_fab'),
NAM=ch$ptr(%name(name,'_nam')),
FOP=SQO, ORG=SEQ, RFM=VAR);
$RAB_INIT(RAB=%name(name,'_rab'),
FAB=ch$ptr(%name(name,'_fab')),
RBF=ch$ptr(%name(name,'_buf')),RSZ=512,
UBF=ch$ptr(%name(name,'_buf')),USZ=512,
MBC=10,ROP=<RAH,WBH,LOC,PMT>);
$XPO_IOB_INIT(IOB = %name(name,'_iob'));
%name(name,'_iob')[iob$a_rms_fab] = ch$ptr(%name(name,'_fab'));
%name(name,'_iob')[iob$a_rms_rab] = ch$ptr(%name(name,'_rab'));
%else
$XPO_IOB_INIT(IOB = %name(name,'_iob'));
$str_desc_init(DESCRIPTOR = %name(name,'_iob')[iob$t_resultant],
STRING = (0,0),CLASS=dynamic);
%fi
END %;
! The $OC_BLOCK macro
! declares various locks and buffers to allow only opens
! and closes of the desired file.
Macro
$oc_block(name) =
%if
VaxVms
%then
%name(name,'_nam_buf') : VECTOR[ch$allocation(nam$c_maxrss)],
%name(name,'_nam') : $NAM(RSS=nam$c_maxrss,
RSA=ch$ptr(%name(name,'_nam_buf'))),
%name(name,'_fab') : $FAB(NAM=ch$ptr(%name(name,'_nam')),FOP=SQO,
ORG=SEQ,RFM=VAR),
%name(name,'_iob') : $XPO_IOB() PRESET([iob$a_rms_fab] = ch$ptr(%name(name,'_fab')))
%else
%name(name,'_iob') : $XPO_IOB()
PRESET([$sub_field(iob$t_resultant,str$a_pointer)] =0,
[$sub_field(iob$t_resultant,str$h_length)] = 0,
[$sub_field(iob$t_resultant,str$b_class)] = str$k_class_d,
[$sub_field(iob$t_resultant,str$b_dtype)] = str$k_dtype_t,
[iob$h_length] = iob$k_length)
%fi
% ;
! The $OC_BLOCK_decl macro
! declares varous blocks and buffers to allow full IO used for local declaraations
Macro
$oc_block_decl(name) =
%if
VaxVms
%then
%name(name,'_nam_buf') : VECTOR[ch$allocation(nam$c_maxrss)],
%name(name,'_nam') : $NAM(),
%name(name,'_fab') : $FAB(),
%fi
%name(name,'_iob') : $XPO_IOB() % ;
! The $oc_BLOCK_INIT macro
! declares varous blocks and buffers to allow full IO.
Macro
$oc_block_init(name) =
%if
VaxVms
%then
BEGIN
$NAM_INIT(NAM = ch$ptr(%name(name,'_nam')),
RSA=ch$ptr(%name(name,'_nam_buf')),RSS=nam$c_maxrss);
$FAB_INIT(FAB = %name(name,'_fab'),
NAM=ch$ptr(%name(name,'_nam')),
FOP=SQO, ORG=SEQ, RFM=VAR);
$XPO_IOB_INIT(IOB = %name(name,'_iob'));
%name(name,'_iob')[iob$a_rms_fab] = ch$ptr(%name(name,'_fab'));
END
%else
$XPO_IOB_INIT(IOB = %name(name,'_iob'));
$str_desc_init(DESCRIPTOR = %name(name,'_iob')[iob$t_resultant],
STRING = (0,0),CLASS=dynamic);
%fi
% ;
! Follows are a set of transportable return codes to replace the xport set.
Macro
declare_return_code(cms_code, vax_code, twenty_code) =
LITERAL
cms_code =
%if
%bliss(bliss32)
%then
vax_code
%else
twenty_code
%fi %;
declare_return_code(step$_eof, rms$_eof, xpo$_end_file);
declare_return_code(step$_normal, rms$_normal, xpo$_normal);
declare_return_code(step$_created, rms$_created, xpo$_created);
declare_return_code(step$_no_file, rms$_fnf, gjfx24 ^ 3);
declare_return_code(step$_file_lock, rms$_flk, opnx9 ^ 3);
declare_return_code(step$_no_access, rms$_prv, gjfx35 ^ 3);
declare_return_code(step$_no_space, ss$_exdiskquota, iox11 ^ 3);
! BLISSX.REQ -- LAST LINE