Google
 

Trailing-Edge - PDP-10 Archives - BB-H138F-BM_1988 - 7-sources/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