Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/t20src/diutut.bli
There are 4 other files named diutut.bli in the archive. Click here to see a list.
%TITLE 'Utility Routines For Transforms'
MODULE DIUTUT(
%BLISS32 (IDENT = 'DIU V1.0',
ADDRESSING_MODE(EXTERNAL=GENERAL,NONEXTERNAL=LONG_RELATIVE)
)
%BLISS36 (IDENT='253',
ENTRY (dixerr, sngnam)
)
) =
BEGIN
!++
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1986.
! ALL RIGHTS RESERVED.
!
! 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 THAT IS NOT SUPPLIED BY DIGITAL.
!
! FACILITY: DIU Data Interchange Utility V01-000
!
! ABSTRACT: Utility routines for DIU.
!
! AUTHOR: Sandy Clemens, Creation Date: 25-Oct-84
!
! EDIT HISTORY:
!
! 3 Clean up copyright notices. Change LIBRARY 'DIUMSG'
! to 'DIU'. Clean up condition handling.
! Sandy Clemens 14-Jun-85
!
! 10 Make default transform generation code use the DIU top level
! condition handler rather than DIU$TRANS_HANDLER.
! Sandy Clemens 20-Jun-85
!
! 11 Delete error table structures. Don't need that in this
! module any more.
! Sandy Clemens 26-Jun-85
!
! 20 Remove TTY external reference from DIUTUT. It's not needed
! and will not compile on the VAX. Also change $FAO_PUT of
! error message to a SIGNAL of DIU$_BUG.
! Sandy Clemens 17-Jul-85
!
! 22 Made routine SINGLE_FQN_NAME get the entire field name string
! out of the record description tree (not just the partial name
! from the transform).
! Sandy Clemens 18-Jul-85
!
! 23 Remove DIU$CDD_EXTRACT from DIUTUT module and put it
! into INTFAC. It's only part of INTFAC, not DIU. FILES:
! INTFAC.BLI,DIUTUT.BLI, DIUTLB.BLI.
! Sandy Clemens 18-Jul-85
!
! 236 Change library of DIXLIB to DIUDIX.
! Sandy Clemens 19-Jun-86
!
! 253 Change libraries to new names.
! Gregory A. Scott 1-Jul-86
!--
!********************************************************************
! L I B R A R Y A N D R E Q U I R E F I L E S
!********************************************************************
%IF %BLISS (BLISS32)
%THEN
LIBRARY 'SYS$LIBRARY:XPORT'; ! XPORT definitions
UNDECLARE %QUOTE $STRING;
LIBRARY 'SYS$LIBRARY:STARLET'; ! VMS System Services
LIBRARY 'DIU$SOURCE_LIB:DIUVMS'; ! DIU VMS Specifics
LIBRARY 'DIU$SOURCE_LIB:DIU'; ! DIU VMS specifics
LIBRARY 'DIU$SOURCE_LIB:DIUMSG'; ! DIU MESSAGE Literals
%FI
%IF %BLISS (BLISS36)
%THEN
LIBRARY 'BLI:XPORT'; ! XPORT definitions
LIBRARY 'FAOPUT'; ! Defines $FAO_PUT macro
LIBRARY 'FAO';
LIBRARY 'DIU';
LIBRARY 'DIUACTION';
%FI
%IF %BLISS (BLISS32)
%THEN
UNDECLARE %QUOTE $DESCRIPTOR;
%FI
LIBRARY 'DIUCRX'; ! CRX data structures
%IF %BLISS (BLISS32)
%THEN
UNDECLARE %QUOTE $DESCRIPTOR;
%FI
LIBRARY 'DIUTLB'; ! DIU Transform structure
%IF %BLISS (BLISS32)
%THEN
UNDECLARE %QUOTE $DESCRIPTOR;
%FI
UNDECLARE %QUOTE STS$K_SEVERE, %QUOTE STS$K_ERROR, %QUOTE STS$K_WARNING,
%QUOTE STS$K_SUCCESS, %QUOTE SS$_NORMAL, %QUOTE STS$K_INFO;
LIBRARY 'DIUDIX'; ! DIX/DIL specific things
LIBRARY 'DIUMLB'; ! DIU Mapping routines library
%IF %BLISS (BLISS32)
%THEN
UNDECLARE %QUOTE $DESCRIPTOR;
%FI
!++
! Define MACRO diu$unwind_cond so that we have one common name for
! unwind condition...
!--
%IF %BLISS (BLISS36)
%THEN
EXTERNAL LITERAL ss$unw;
MACRO diu$unwind_cond = ss$unw %;
%FI
%IF %BLISS (BLISS32)
%THEN
MACRO diu$unwind_cond = ss$_unwind %;
%FI
EXTERNAL ROUTINE free_stringlist;
!******************************************************************
! S I N G L E _ F Q N _ N A M E
!******************************************************************
GLOBAL ROUTINE SINGLE_FQN_NAME (
memb, ! (addr) field for which we want
! the complete fqn
str ! (addr) str descr to write new name to
) : NOVALUE =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
! This routine takes a member node address and walks the entire
! record description tree in order to make a single, complete,
! fully qualified name which is written into the string
! descriptor passed. Between each name segement a "." is
! inserted. That is, if the stringlist has three nodes, each
! with the string "A" stored as the name, this routine would
! return the address of a string which looks like this: "A.A.A"
!
!--
LOCAL
status : INITIAL (0), ! for $FAO_PUT
fqn_loc : REF crx_stringlist,
nam_str : REF $STR_DESCRIPTOR (CLASS = DYNAMIC),
cur_mem : REF crx_member,
pre_mem : REF crx_member,
fqn_head : REF crx_stringlist;
cur_mem = .memb; ! get addressibility via REFs
nam_str = .str;
fqn_head = 0; ! initialize to zero (null pointer!)
$STR_DESC_INIT (DESCRIPTOR = .nam_str, ! initialize local string descriptor
CLASS = DYNAMIC,
STRING = (0, 0)
);
! First, make the new stringlist
WHILE (.cur_mem [CRM$B_ID] NEQ CRX$K_RECORD) DO
BEGIN
!
! Add current field name to fqn stringlist
!
$XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, ! get memory for new
RESULT = fqn_loc, FILL = 0); ! stringlist node
fqn_loc [CRS$B_ID] = CRX$K_STRINGLIST; ! initialize id
! If this is the 1st field name then don't need to do anything,
! otherwise prepend it to the stringlist we're building...
IF .fqn_head EQL 0
THEN fqn_head = .fqn_loc
ELSE BEGIN
fqn_head [CRS$A_PREVIOUS] = .fqn_loc;
fqn_loc [CRS$A_NEXT] = .fqn_head;
fqn_head = .fqn_loc;
END;
! copy member name string length into new stringlist node
fqn_loc [CRS$W_STRING_LENGTH] = .cur_mem [CRM$B_NAME_LENGTH];
! get memory for new string
$XPO_GET_MEM (CHARACTERS = .fqn_loc [CRS$W_STRING_LENGTH],
RESULT = fqn_loc [CRS$A_STRING]);
! copy field's name into new stringlist
CH$MOVE (.fqn_loc [CRS$W_STRING_LENGTH], CH$PTR (cur_mem [CRM$T_NAME]),
.fqn_loc [CRS$A_STRING]);
! read backward up thru the record description tree looking
! for parent field...
pre_mem = .cur_mem [CRM$A_PREVIOUS];
WHILE TRUE DO
SELECTONE .pre_mem [CRM$B_ID] OF
SET
[CRX$K_MEMBER] : ! member parent
IF .pre_mem [CRM$A_CHILDREN] EQL .cur_mem
THEN EXITLOOP
ELSE BEGIN
cur_mem = .pre_mem;
pre_mem = .pre_mem [CRM$A_PREVIOUS];
END;
[CRX$K_OVERLAY] : ! overlay node
BEGIN
LOCAL pre_overlay : REF crx_overlay;
cur_mem = .pre_mem; ! go upward looking for member parent
pre_overlay = .pre_overlay [CRO$A_PREVIOUS];
pre_mem = .pre_overlay;
END;
[CRX$K_RECORD] : ! record node
EXITLOOP; ! exit because we're at the top!
TES;
cur_mem = .pre_mem; ! loop back...
END; ! end of while crx node is not
! crx$k_record loop...
!
! now make the fqn stringlist into a single string...
!
IF (.fqn_loc EQL 0) OR (.fqn_loc [CRS$W_STRING_LENGTH] EQL 0)
THEN ! if the name is empty
SIGNAL (DIU$_BUG) ! this should NEVER happen...
ELSE
DO BEGIN
! append the name to the final "long" name
$STR_APPEND (STRING = (.fqn_loc [CRS$W_STRING_LENGTH],
.fqn_loc [CRS$A_STRING]),
TARGET = .nam_str);
! between each name, put a ".", BUT not after the final name
IF .fqn_loc [CRS$A_NEXT] NEQ 0
THEN $STR_APPEND (STRING = '.',
TARGET = .nam_str);
! get next name section
fqn_loc = .fqn_loc [CRS$A_NEXT];
END
UNTIL .fqn_loc EQL 0;
free_stringlist (.fqn_head); ! release memory used by temp
! stringlist structure...
END; ! end routine single_fqn_name
!******************************************************************
! D I U $ D I X E R R _ H A N D L E R
!******************************************************************
GLOBAL ROUTINE DIU$DIXERR_HANDLER (sig : REF VECTOR,
mech : REF VECTOR,
enbl : REF VECTOR) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
! This is the condition handler for SIGNALs generated by the
! calls to DIX$$DES_BY_DET (in routine DIU$MAKE_FFDS).
!
! FORMAL PARAMETERS
!
! sig SIGNAL vector
!
! mech mechanism vector
!
! enbl enable vector
!
! ROUTINE VALUE
!
! That of the condition code in the signal vector.
!--
BIND
cond = sig [1] : condition_value,
return_value = mech [ %BLISS36 (1) %BLISS32 (3)],
error_temp = .enbl [1] : condition_value;
IF .cond NEQ diu$unwind_cond ! if not unwinding
THEN BEGIN
error_temp = .cond; ! save condition value
SETUNWIND() ! initiate unwind
END
ELSE BEGIN
return_value = .error_temp ! return condition value saved earlier
END
END;
END
ELUDOM