Trailing-Edge
-
PDP-10 Archives
-
BB-H138F-BM_1988
-
7-sources/diudmp.bli
There are 4 other files named diudmp.bli in the archive. Click here to see a list.
%TITLE 'Routines To Dump Transform / FQN Data Structures'
MODULE DIUDMP(
IDENT='253'
%BLISS32 (,
ADDRESSING_MODE(EXTERNAL=GENERAL,NONEXTERNAL=LONG_RELATIVE)
)
%BLISS36 (,
ENTRY (dmpdim, dmpfqn, dmptrs, dmptrd, dmptra)
)
) =
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
!
! ABSTRACT: Routines to dump out the transform and dims and FQN data
! structures using $FAO_PUT macro.
!
! AUTHOR: Sandy Clemens, Creation Date: 25-Oct-84
!
! EDIT HISTORY:
!
! 3 Clean up copyright notice. Change LIBRARY 'DIUMSG'
! to 'DIU'. Remove copying things to 'tmp' LOCAL variable
! since it wasn't being used anyway.
! Sandy Clemens 14-Jun-85
!
! 14 Add transform execution code and conversion warnings report
! code. FILES: DIUETR.BLI (NEW), DIUCSR.BLI (NEW), DIUDMP.BLI,
! DIUABO.B36, INTFAC.BLI, DIUTLB.BLI.
! Sandy Clemens 15-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: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
!*****************************************************************
! D I U $ D U M P _ D I M S
!*****************************************************************
GLOBAL ROUTINE DIU$DUMP_DIMS (dimlst, depth) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
! Routine used to dump out the dims list, node by node.
! Used mainly for debugging.
!
! FORMAL PARAMETERS
!
! dimlst Address of the first node in the dims list.
!
! depth Used for indentation (for $FAO_PUT macro).
!
! IMPLICIT PARAMETERS
!
! None
!
! ROUTINE VALUE
!
! None
!--
BEGIN
MAP dimlst : REF dims;
LOCAL status : INITIAL (0),
tmp : INITIAL (0);
IF .dimlst EQL 0
THEN $FAO_PUT (.depth, 'Empty')
ELSE DO BEGIN
%IF %BLISS(BLISS32)
%THEN
$FAO_PUT (.depth, 'DIMS node at address: !XL', .dimlst);
%FI
%IF %BLISS(BLISS36)
%THEN
$FAO_PUT (.depth, 'DIMS node at address: !OL', .dimlst);
%FI
tmp = .dimlst [dims$b_id];
IF .tmp EQL DIU$K_DIMSNODE
THEN $FAO_PUT (.depth, 'DIMS$B_ID: DIU$K_DIMSNODE')
ELSE $FAO_PUT (.depth, 'DIMS$B_ID: ***UNKNOWN***');
$FAO_PUT (.depth, 'DIMS$B_DIMENSIONS_CNT: !SL',
.dimlst [dims$b_dimensions_cnt]);
$FAO_PUT (.depth, 'DIMS$L_TOT_CELLS: !SL', .dimlst [dims$l_tot_cells]);
%IF %BLISS(BLISS32)
%THEN
$FAO_PUT (.depth, 'DIMS$A_LIST: !XL', .dimlst [dims$a_list]);
$FAO_PUT (.depth, 'DIMS$A_PREVIOUS: !XL', .dimlst [dims$a_previous]);
$FAO_PUT (.depth, 'DIMS$A_NEXT: !XL', .dimlst [dims$a_next]);
%FI
%IF %BLISS(BLISS36)
%THEN
$FAO_PUT (.depth, 'DIMS$A_LIST: !OL', .dimlst [dims$a_list]);
$FAO_PUT (.depth, 'DIMS$A_PREVIOUS: !OL', .dimlst [dims$a_previous]);
$FAO_PUT (.depth, 'DIMS$A_NEXT: !OL', .dimlst [dims$a_next]);
%FI
$FAO_PUT (.depth, ' '); ! CRLF for prettier format...
dimlst = .dimlst [dims$a_next]
END
UNTIL .dimlst EQL 0;
END; ! end of routine
!*****************************************************************
! D I U $ D U M P _ F Q N
!*****************************************************************
GLOBAL ROUTINE DIU$DUMP_FQN (fqn, depth) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
! Routine to dump out the fqn stringlist, node by node,
! and the name strings. Used mainly for debugging.
!
! FORMAL PARAMETERS
!
! fqn Root address of the fqn list.
!
! depth Used for indentation (for $FAO_PUT macro).
!
! IMPLICIT PARAMETERS
!
! None
!
! ROUTINE VALUE
!
! None
!--
BEGIN
MAP fqn : REF crx_stringlist;
LOCAL status : INITIAL (0),
tmp : INITIAL (0);
IF .fqn EQL 0
THEN $FAO_PUT (.depth, 'Empty')
ELSE DO BEGIN
$FAO_PUT (.depth, 'FQN node is: ');
%IF %BLISS(BLISS32)
%THEN
$FAO_PUT (.depth, 'CRS$A_PREVIOUS: !XL', .fqn [CRS$A_PREVIOUS]);
$FAO_PUT (.depth, 'CRS$A_NEXT: !XL', .fqn [CRS$A_NEXT]);
%FI
%IF %BLISS(BLISS36)
%THEN
$FAO_PUT (.depth, 'CRS$A_PREVIOUS: !OL', .fqn [CRS$A_PREVIOUS]);
$FAO_PUT (.depth, 'CRS$A_NEXT: !OL', .fqn [CRS$A_NEXT]);
%FI
tmp = .fqn [CRS$B_ID];
IF .tmp EQL CRX$K_STRINGLIST
THEN $FAO_PUT (.depth, 'CRS$B_ID: CRX$K_STRINGLIST')
ELSE $FAO_PUT (.depth, 'CRS$B_ID: ***UNKNOWN***');
$FAO_PUT (.depth, 'FQN NAME : !AD',
.fqn [CRS$W_STRING_LENGTH],
(.fqn [CRS$A_STRING]));
$FAO_PUT (.depth, ' '); ! for prettier format
fqn = .fqn [CRS$A_NEXT]
END
UNTIL .fqn EQL 0;
END;
!*****************************************************************
! D I U $ D M P _ M E M B E R _ N A M E
!*****************************************************************
ROUTINE DIU$DMP_MEMBER_NAME (member, depth) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
! Routine to show the name of a member block referred to by a
! transform node.
!
! FORMAL PARAMETERS
!
! member The addresss of the member block.
!
! depth Used for indentation (for $FAO_PUT macro).
!
! IMPLICIT PARAMETERS
!
! None
!
! ROUTINE VALUE
!
! None
!
!--
BEGIN
MAP member : REF crx_member;
LOCAL status : INITIAL (0);
IF .member EQL 0
THEN $FAO_PUT (.depth, 'Member name: * EMPTY *')
ELSE $FAO_PUT (.depth, 'Member name: !AD', .member [CRM$B_NAME_LENGTH],
ch$ptr (member [CRM$T_NAME]));
END;
!*****************************************************************
! D I U $ D M P _ T R A _ S R C
!*****************************************************************
GLOBAL ROUTINE DIU$DMP_TRA_SRC (trans, depth) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
! Routine to dump out the source portion of the transform
! structure. Used mainly for debugging.
!
! FORMAL PARAMETERS
!
! trans Address of the first node in the transform list.
!
! depth Used for indentation (for $FAO_PUT macro).
!
! IMPLICIT PARAMETERS
!
! None
!
! ROUTINE VALUE
!
! None
!--
BEGIN
MAP trans : REF transform_str;
LOCAL status : INITIAL(0),
tmp : INITIAL (0);
! make sure TRA_ID is correctly set to DIU$K_TRANSFORM
tmp = .trans [tra_id];
IF .tmp NEQ DIU$K_TRANSFORM
THEN $FAO_PUT (.depth, 'TRA_ID : ***UNKNOWN***');
%IF %BLISS(BLISS32)
%THEN
$FAO_PUT (.depth, 'TRA_SRC_ADDR : !XL', .trans [tra_src_addr]);
%FI
%IF %BLISS(BLISS36)
%THEN
$FAO_PUT (.depth, 'TRA_SRC_ADDR : !OL', .trans [tra_src_addr]);
%FI
! display member name
DIU$DMP_MEMBER_NAME (.trans [tra_src_addr], .depth);
! dump source FQN stringlist
%IF %BLISS (BLISS32)
%THEN
$FAO_PUT (.depth, 'FQN for source at !XL is: ', .trans [tra_src_nam]);
%FI
%IF %BLISS (BLISS36)
%THEN
$FAO_PUT (.depth, 'FQN for source at !OL is: ', .trans [tra_src_nam]);
%FI
DIU$DUMP_FQN (.trans [tra_src_nam], .depth+1);
! dump source DIMS structure
%IF %BLISS (BLISS32)
%THEN
$FAO_PUT (.depth, 'DIMS for source at !XL is: ', .trans [tra_src_dims]);
%FI
%IF %BLISS (BLISS36)
%THEN
$FAO_PUT (.depth, 'DIMS for source at !OL is: ', .trans [tra_src_dims]);
%FI
DIU$DUMP_DIMS (.trans [tra_src_dims], .depth+1);
%IF %BLISS(BLISS32)
%THEN
$FAO_PUT (.depth, 'TRA_SRC$V_UNIT : !XL', .trans [tra_src$v_unit]);
%FI
%IF %BLISS(BLISS36)
%THEN
$FAO_PUT (.depth, 'TRA_SRC$V_UNIT : !OL', .trans [tra_src$v_unit]);
%FI
$FAO_PUT (.depth, 'TRA_SRC$V_LENGTH : !ZL', .trans [tra_src$v_length]);
$FAO_PUT (.depth, 'TRA_SRC$V_SCALE : !ZL', .trans [tra_src$v_scale]);
$FAO_PUT (.depth, 'TRA_SRC$V_OFFSET : !ZL', .trans [tra_src$v_offset]);
! data type fields
$FAO_PUT (.depth, 'TRA_SRC$V_TYPE : !ZL', .trans [tra_src$v_type]);
depth = .depth + 1;
$FAO_PUT (.depth, 'TRA_SRC$V_DT_TYPE : !ZL', .trans [tra_src$v_dt_type]);
$FAO_PUT (.depth, 'TRA_SRC$V_DT_CLASS : !ZL', .trans [tra_src$v_dt_class]);
depth = .depth - 1;
$FAO_PUT (.depth, 'TRA_SRC$V_ALIGN : !ZL', .trans [tra_src$v_align]);
$FAO_PUT (.depth, 'TRA_SRC$V_SYS_ORIG : !ZL', .trans [tra_src$v_sys_orig]);
END; ! end of routine DIU$DMP_TRA_SRC
!*****************************************************************
! D I U $ D M P _ T R A _ D S T
!*****************************************************************
GLOBAL ROUTINE DIU$DMP_TRA_DST (trans, depth) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
! Routine to dump out the destination portion of the transform
! structure. Used mainly for debugging.
!
! FORMAL PARAMETERS
!
! trans Address of the first node in the transform list.
!
! depth Used for indentation (for $FAO_PUT macro).
!
! IMPLICIT PARAMETERS
!
! None
!
! ROUTINE VALUE
!
! None
!--
BEGIN
MAP trans : REF transform_str;
LOCAL status : INITIAL(0),
tmp : INITIAL (0);
! make sure TRA_ID is correctly set to DIU$K_TRANSFORM
tmp = .trans [tra_id];
IF .tmp NEQ DIU$K_TRANSFORM
THEN $FAO_PUT (.depth, 'TRA_ID : ***UNKNOWN***');
%IF %BLISS(BLISS32)
%THEN
$FAO_PUT (.depth, 'TRA_DST_ADDR : !XL', .trans [tra_dst_addr]);
%FI
%IF %BLISS(BLISS36)
%THEN
$FAO_PUT (.depth, 'TRA_DST_ADDR : !OL', .trans [tra_dst_addr]);
%FI
! display member name
DIU$DMP_MEMBER_NAME (.trans [tra_dst_addr], .depth);
! dump destination FQN stringlist
%IF %BLISS (BLISS32)
%THEN
$FAO_PUT (.depth, 'FQN for destination at !XL is: ', .trans [tra_dst_nam]);
%FI
%IF %BLISS (BLISS36)
%THEN
$FAO_PUT (.depth, 'FQN for destination at !OL is: ', .trans [tra_dst_nam]);
%FI
DIU$DUMP_FQN (.trans [tra_dst_nam], .depth+1);
! dump destination DIMS structure
%IF %BLISS (BLISS32)
%THEN
$FAO_PUT (.depth, 'DIMS for destination at !XL is: ', .trans [tra_dst_dims]);
%FI
%IF %BLISS (BLISS36)
%THEN
$FAO_PUT (.depth, 'DIMS for destination at !OL is: ', .trans [tra_dst_dims]);
%FI
DIU$DUMP_DIMS (.trans [tra_dst_dims], .depth+1);
%IF %BLISS(BLISS32)
%THEN
$FAO_PUT (.depth, 'TRA_DST$V_UNIT : !XL', .trans [tra_dst$v_unit]);
%FI
%IF %BLISS(BLISS36)
%THEN
$FAO_PUT (.depth, 'TRA_DST$V_UNIT : !OL', .trans [tra_dst$v_unit]);
%FI
$FAO_PUT (.depth, 'TRA_DST$V_LENGTH] : !ZL', .trans [tra_dst$v_length]);
$FAO_PUT (.depth, 'TRA_DST$V_SCALE] : !ZL', .trans [tra_dst$v_scale]);
$FAO_PUT (.depth, 'TRA_DST$V_OFFSET : !ZL', .trans [tra_dst$v_offset]);
! data type fields
$FAO_PUT (.depth, 'TRA_DST$V_TYPE : !ZL', .trans [tra_dst$v_type]);
depth = .depth + 1;
$FAO_PUT (.depth, 'TRA_DST$V_DT_TYPE : !ZL', .trans [tra_dst$v_dt_type]);
$FAO_PUT (.depth, 'TRA_DST$V_DT_CLASS : !ZL', .trans [tra_dst$v_dt_class]);
depth = .depth - 1;
$FAO_PUT (.depth, 'TRA_DST$V_ALIGN : !ZL', .trans [tra_dst$v_align]);
$FAO_PUT (.depth, 'TRA_DST$V_SYS_ORIG : !ZL', .trans [tra_dst$v_sys_orig]);
END; ! end of routine DIU$DMP_TRA_DST
!*****************************************************************
! D I U $ D U M P _ T R A N S F O R M
!*****************************************************************
GLOBAL ROUTINE DIU$DUMP_TRANSFORM (trans) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
! Routine to dump out the entire transform structure,
! node by node. Used mainly for debugging.
!
!
! NOTE
!
! Due to a BLISS-36 bug, this routine had to be split up so
! that it would compile. The compiler kept running out of
! dynamic memory... So the routine was split into the two
! routines DIU$DMP_TRA_SRC and DIU$DMP_TRA_DST.
!
!
! FORMAL PARAMETERS
!
! trans Address of the first node in the transform list.
!
! IMPLICIT PARAMETERS
!
! None
!
! ROUTINE VALUE
!
! None
!--
BEGIN
MAP trans : REF transform_str;
LOCAL status : INITIAL(0);
LOCAL depth : INITIAL (0),
tmp : INITIAL (0);
IF .trans EQL 0 ! Transform is empty if the address is 0.
THEN BEGIN
! Tell the user that the transform is empty
$FAO_PUT (1, '** Empty **');
END
ELSE
DO BEGIN
depth = 0;
$FAO_PUT (.depth, ' '); ! blank line
$FAO_PUT (.depth, ' '); ! blank line
$FAO_PUT (.depth, 'Transform node is as follows: ');
tmp = .trans [tra_id];
! make sure TRA_ID is correctly set to DIU$K_TRANSFORM
IF .tmp EQL DIU$K_TRANSFORM
THEN $FAO_PUT (.depth, 'TRA_ID : DIU$K_TRANSFORM')
ELSE $FAO_PUT (.depth, 'TRA_ID : ***UNKNOWN***');
! Call DIU$DMP_TRA_SRC to dump the source portion of the
! transform structure.
DIU$DMP_TRA_SRC (.trans, .depth);
! Call DIU$DMP_TRA_SRC to dump the destination portion of
! the transform structure.
DIU$DMP_TRA_DST (.trans, .depth);
%IF %BLISS (BLISS32)
%THEN
$FAO_PUT (.depth, 'TRA_WORST : !XL', .trans [tra_worst]);
$FAO_PUT (.depth, 'TRA_OPCODE : !XL', .trans [tra_opcode]);
$FAO_PUT (.depth, 'TRA_NEXT : !XL', .trans [tra_next]);
%FI
%IF %BLISS (BLISS36)
%THEN
$FAO_PUT (.depth, 'TRA_WORST : !OL', .trans [tra_worst]);
$FAO_PUT (.depth, 'TRA_OPCODE : !OL', .trans [tra_opcode]);
$FAO_PUT (.depth, 'TRA_NEXT : !OL', .trans [tra_next]);
%FI
! next node...
trans = .trans [tra_next];
END ! end of DO loop
UNTIL .trans EQL 0; ! Stop when there are no more transform nodes
END;
END
ELUDOM