Google
 

Trailing-Edge - PDP-10 Archives - tops20-v7-ft-dist1-clock - 7-sources/diumat.bli
There are 4 other files named diumat.bli in the archive. Click here to see a list.
%TITLE 'Make a Single Move Matching Transform from Two (Source) Transforms'
MODULE DIUMAT(
       IDENT='253'
       %BLISS32 (,
                 ADDRESSING_MODE(EXTERNAL=GENERAL,NONEXTERNAL=LONG_RELATIVE)
                 )
       %BLISS36 (,
                 ENTRY (chkdms, chkfqn, chkmat, mattra)
                )
                       ) = 
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:	Routines to generate a single default move_matching
!		or move_others_matching transform structure, given
!		two (source) transforms.
!
! AUTHOR:	Sandy Clemens, Creation Date:  25-Oct-84
!
! EDIT HISTORY:
!
!  253  Change libraries to new names.
!       Gregory A. Scott 1-Jul-86
!
!  236  Change library of DIXLIB to DIUDIX.
!       Sandy Clemens  19-Jun-86
!
!       3	Clean up copyright notices.  Change LIBRARY 'DIUMSG'
!		to 'DIU'.  Clean up condition handling.
!		Sandy Clemens	14-Jun-85
!--
!********************************************************************
!           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:DIUMSG';	! DIU MESSAGE Literals
%FI

%IF %BLISS (BLISS36)
%THEN
     LIBRARY 'BLI:XPORT';               ! XPORT definitions
     LIBRARY 'FAOPUT';                  ! Defines $FAO_PUT macro
     LIBRARY 'FAO';
     LIBRARY 'DIU';
%FI

UNDECLARE %QUOTE $DESCRIPTOR;
LIBRARY 'DIUCRX';                       ! CRX data structures
UNDECLARE %QUOTE $DESCRIPTOR;
LIBRARY 'DIUTLB';			! DIU Transform structure
UNDECLARE %QUOTE $DESCRIPTOR;
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
!******************************************************************
!                     L I T E R A L S
!******************************************************************

LITERAL
       no_match = 1,
       yes_match = 2;
!******************************************************************
!                     C H E C K _ D I M S
!******************************************************************
GLOBAL ROUTINE CHECK_DIMS (src_dims, dst_dims) =
BEGIN
!++
! FUNCTIONAL DESCRIPTOIN
!
!	This routine checks two entire dims lists to see if they
!	can be moved using Move-Matching.
!
! FORMAL PARAMETERS
!
!	src_dims	The root address of the source dims list.
!
!	dst_dims	The root address of the destination dims list.
!
! IMPLICIT PARAMETERS
!
!	None.
!
! ROUTINE VALUE
!
!	Match_flg, set to 1 if the dims don't match, otherwise,
!	set to zero.
!++

LOCAL sdims : REF dims,
      ddims : REF dims,
      count,
      src_dimension : REF crx_dimension,
      dst_dimension : REF crx_dimension,
      match_flg : INITIAL (yes_match),
      done : INITIAL (0),
      status : INITIAL (0);

sdims = .src_dims;
ddims = .dst_dims;

DO BEGIN
   !++
   ! If both dims passed are set to 0, then we are done so EXITLOOP.
   ! If one dims EQL 0 and the other NEQ 0 then set match_flg to
   ! no_match & EXITLOOP.  If both dims are NEQ 0 then see if their
   ! respective dimensions_cnts are equal.  If not, then set match_flg
   ! to no_match & EXITLOOP.
   !--

   IF (.sdims EQL 0 AND .ddims EQL 0)
   THEN EXITLOOP                        ! these match & we're finished
   ELSE
        IF (.sdims EQL 0 AND .ddims NEQ 0) OR
           (.sdims NEQ 0 AND .ddims EQL 0)
        THEN (match_flg = no_match; EXITLOOP)   ! these don't match
        ELSE
            ! if both dims address are non-zero, then make sure the
            ! addresses really point at dims nodes...
            IF (.sdims [dims$b_id] NEQ DIU$K_DIMSNODE) OR
              (.ddims [dims$b_id] NEQ DIU$K_DIMSNODE)
            THEN
                SIGNAL (DIU$_BUG)
            ELSE
                ! if the 2 dims nodes have different dimension counts,
                ! then the structures don't "match" (can't be moved by
                ! move matching)...
                IF .sdims [dims$b_dimensions_cnt] NEQ
                    .ddims [dims$b_dimensions_cnt]
                THEN (match_flg = no_match; EXITLOOP);

   !++
   ! If not DONE, then examine the list of crx dimension nodes and see
   ! if the upper & lower bounds are set correctly for a move-matching
   ! situation, that is, the source bounds are within the destination
   ! bounds!
   !--

   src_dimension = .sdims [dims$a_list];        ! get addressibility via REFs
   dst_dimension = .ddims [dims$a_list];
   count = 0;					! Initialize count of dimensions

   WHILE NOT .done DO
         BEGIN

         ! check crx dimension node ids
         IF (.src_dimension [CRD$B_ID] NEQ CRX$K_DIMENSION) OR
            (.dst_dimension [CRD$B_ID] NEQ CRX$K_DIMENSION)
         THEN
             SIGNAL (DIU$_BUG);

         IF (.src_dimension [crd$l_lower_bound] LSS     ! check bounds
             .dst_dimension [crd$l_lower_bound])
           OR
            (.src_dimension [crd$l_upper_bound] GTR
             .dst_dimension [crd$l_upper_bound])
         THEN BEGIN
              match_flg = no_match;     ! these don't match
              done = 1;
              END
         ELSE BEGIN                     ! get next crx dimension nodes
              src_dimension = .src_dimension [crd$a_next];
              dst_dimension = .dst_dimension [crd$a_next];
              END;

         !++
         ! Keep a count of the number of CRX dimension nodes we have
         ! processed.  We know that the dimension count is the same
         ! for the source and destination because we checked above!
         !--
         count = .count + 1;
         IF .count EQL .sdims [dims$b_dimensions_cnt]
         THEN done = 1;
         END;

   sdims = .sdims [dims$a_next];        ! process next DIMS nodes
   ddims = .ddims [dims$a_next];
   IF (.sdims NEQ 0) OR (.ddims NEQ 0)  ! if we aren't really done
     AND (.match_flg EQL yes_match)
   THEN done = 0;                       ! then note it!

   END

UNTIL .done;

.match_flg                              ! return match_flg (set to yes_match
                                        ! or no_match)...

END;
!******************************************************************
!                     C H E C K _ F Q N S
!******************************************************************
GLOBAL ROUTINE CHECK_FQNS (src_fqn, dst_fqn) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine checks two entire fqns to see if their
!	names match.
!
! FORMAL PARAMETERS
!
!	src_fqn		The root address of the source fqn stringlist.
!
!	dst_fqn		The root address of the destination fqn stringlist.
!
! IMPLICIT PARAMETERS
!
!	None.
!
! ROUTINE VALUE
!
!	Match_flg, set to 1 if the names don't match, otherwise,
!	set to zero.
!++

LOCAL	sfqn : REF crx_stringlist,
	dfqn : REF crx_stringlist,
	match_flg : INITIAL (yes_match),
	done : INITIAL (0);

sfqn = .src_fqn;
dfqn = .dst_fqn;

! This destination name has already been used, so it can't match now.
IF .dfqn EQL 0 THEN RETURN no_match;

DO BEGIN
   ! if source & destination names are the same
   IF $STR_EQL (STRING1 = (.sfqn [CRS$W_STRING_LENGTH],
                           (.sfqn [CRS$A_STRING])),
                STRING2 = (.dfqn [CRS$W_STRING_LENGTH], 
                           (.dfqn [CRS$A_STRING])))
      THEN BEGIN
           ! if either field has sub-fields and the other doesn't then
           ! this is not a match...
	   sfqn = .sfqn [CRS$A_NEXT];
	   dfqn = .dfqn [CRS$A_NEXT];
	   IF (.sfqn EQL 0 AND .dfqn NEQ 0) OR (.sfqn NEQ 0 AND .dfqn EQL 0)
	      THEN                      ! this is not a match; stop processing
                  (match_flg = no_match; done = 1)
	      ELSE                      ! if both names complete, we're done
                  (IF .sfqn EQL 0 AND .dfqn EQL 0
		   THEN done = 1)
	   END
      ELSE BEGIN                        ! if the names aren't equal
	   match_flg = no_match;        ! then this is not a match
	   done = 1                     ! and we can stop processing
	   END
   END
UNTIL .done;

.match_flg			! return match_flg (if set to 1, no match
				! was found, else match was found
END;
!******************************************************************
!                    C H E C K _ M A T C H
!******************************************************************
GLOBAL ROUTINE CHECK_MATCH (src_fqn, dst_fqn, src_dims, dst_dims) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine checks DIMS lists and FQN stringlist for two
!       fields to see if they can be moved using move-matching or
!       move-others-matching.
!
! FORMAL PARAMETERS
!
!	src_fqn		The root address of the source fqn stringlist.
!
!	dst_fqn		The root address of the destination fqn stringlist.
!
!	src_dims	The root address of the source dims list.
!
!	dst_dims	The root address of the destination dims list.
!
! IMPLICIT PARAMETERS
!
!	None.
!
! ROUTINE VALUE
!
!	Match_flg, set to 1 if the dims don't match, otherwise,
!	set to zero.
!++

LOCAL match_flg : INITIAL (yes_match);

match_flg = check_fqns (.src_fqn, .dst_fqn);
IF .match_flg EQL yes_match
THEN match_flg = check_dims (.src_dims, .dst_dims);

.match_flg                              ! return match_flg, which is set to
                                        ! either "yes_match" or "no_match"
END;
!******************************************************************
!                 D I U $ M A T C H _ T R A N S
!******************************************************************
GLOBAL ROUTINE DIU$MATCH_TRANS (src_trans, dst_trans) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will traverse the transform lists and search for
!	matching names.  When matching names are found, the dst_trans
!	information will be copied into the destination fields in the
!	src_trans structure, provided that the dimension information
!       (found in the dims structure attached to the transforms) is
!       valid for a move-matching or move-others-matching situation.
!
! FORMAL PARAMETERS
!
!	src_trans	The root address of the source (final) transform
!			structure.
!
!	dst_trans	The root address of the destination transform
!			structure.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	DIU$_NORMAL     Normal successful completion
!
!++

LOCAL	strans : REF transform_str,
	dtrans : REF transform_str,
	match : INITIAL (0),
        status : INITIAL (0);

strans = .src_trans;

IF .strans [tra_id] NEQ DIU$K_TRANSFORM
   THEN SIGNAL (DIU$_BUG);

DO BEGIN

   dtrans = .dst_trans;

   IF .dtrans [tra_id] NEQ DIU$K_TRANSFORM
	THEN SIGNAL (DIU$_BUG);

   DO BEGIN
      match = check_match (.strans [tra_src_nam], .dtrans [tra_src_nam],
                           .strans [tra_src_dims], .dtrans [tra_src_dims]);
      IF .match EQL yes_match
         THEN BEGIN
              !++
	      ! The transforms fully qualified names match, so
	      ! copy the dtrans fields into the dst fields of
	      ! the strans structure...  If a copy is done, zero
              ! out the DIMS and FQN structure addresses in the
              ! dtrans field so that when we delete the dest trans
              ! structure later we don't also lose these structures!
              ! If a move is done, set the destination member field
              ! CRM$V_FACILITY_USE_2 to TRUE so that later we'll 
              ! be able to read through the dst record descr. tree
              ! and know that something was moved into this field!
              !--
              LOCAL dst_member : REF crx_member;
              dst_member = .dtrans [tra_src_addr];
              dst_member [CRM$V_FACILITY_USE_2] = TRUE;
	      strans [tra_dst_addr] = .dtrans [tra_src_addr];
	      strans [tra_dst_nam] = .dtrans [tra_src_nam];
              dtrans [tra_src_nam] = 0;
	      strans [tra_dst$v_length] = .dtrans [tra_src$v_length];
	      strans [tra_dst$v_scale] = .dtrans [tra_src$v_scale];
	      strans [tra_dst$v_type] = .dtrans [tra_src$v_type];
	      strans [tra_dst$v_sys_orig] = .dtrans [tra_src$v_sys_orig];
              strans [tra_dst_dims] = .dtrans [tra_src_dims];
              dtrans [tra_src_dims] = 0;
	      dtrans = 0;               ! set to zero to show we have a match
	      END
	 ELSE
	      dtrans = .dtrans [tra_next]
      END
   UNTIL .dtrans EQL 0;		! Until no more dst_trans nodes to be
				! processed, or we found a match...

   strans = .strans [tra_next]

   END

UNTIL .strans EQL 0;                    ! Until there are no more src transform
                                        ! nodes to be processed...

DIU$_NORMAL                             ! Return normal status

END;

END
ELUDOM