Google
 

Trailing-Edge - PDP-10 Archives - BB-H138F-BM_1988 - 7-sources/diucsr.b36
There are 4 other files named diucsr.b36 in the archive. Click here to see a list.
%TITLE 'Write Conversion Statistics Report'
MODULE DIUCSR (IDENT = '253',
               ENTRY (DIU$CSR)
               ) =
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 process the DIU transform structure for
!               data conversion / transformation.  These routines
!               extract the appropriate information out of each
!               transform node and perform the data conversion
!               specified by that information.  The data conversion
!               is performed by the DIL data conversion routines.
!
! AUTHOR:	Sandy Clemens, Creation Date:  26-Jun-85
! EDIT HISTORY:
!
!  253  Change CRX library to DIUCRX.
!       Gregory A. Scott 1-Jul-86
!
!  240  Change name to DIU$CSR - something that makes sense for output in DDT.
!       Use the DIXTAB that is in DIUERR rather than having another copy here.
!       Gregory A. Scott 19-Jun-86
!
!  236  Change library of DIXLIB to DIUDIX.
!       Sandy Clemens  19-Jun-86
!
!  235	Add DIUCSR.B36: Rewrite from DIUCSR.BLI to reflect changes in DIU
!       and remove TOPS-10 and VMS conditionals.
!	Sandy Clemens  18-Jun-86
!--
%SBTTL 'Libraries and Literals'

LIBRARY 'DIUTLB';
LIBRARY 'DIUCRX';
LIBRARY 'BLI:XPORT';                    ! XPORT definitions
LIBRARY 'DIU';                          ! DIU TOPS-20 MESSAGE definitions
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 definitions

LITERAL header_typ = 1,                 ! literals used to identify different
        field_head_typ = 2,             ! types of things which can be written
        msg_typ = 3,                    ! to the terminal or log file for the
        end_typ = 4;                    ! conversion statistics report

EXTERNAL ROUTINE LJ$UTXT,
                 FAOL,
                 SINGLE_FQN_NAME;

EXTERNAL dixtab : DIU_ERROR_TABLE(),    ! DIX error table
         interactive,                   ! TRUE if interactive
         tty : $XPO_IOB();              ! Terminal IOB
%SBTTL'Routine WRITE_LINE -- write a line to the user log file'
ROUTINE WRITE_LINE (type, p_descr, dix_cond, num_errs) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
!       This routine writes either a report header, field header, "end of
!       report" message, or report entry for the conversion statistics report.
!       
! FORMAL PARAMETERS
!
!       type         integer (literal) identifying the type of entry
!                    to be written
!
!       p_descr      the message to be written
!
!       dix_cond     an error condition if this is a report entry with
!                    an associated condition value
!
!       num_errs     the number of times the error occurred (if this is
!                    a report entry with an associated error condition)
!
! ROUTINE VALUE
!
!       NONE
!--
BEGIN

LOCAL descr : REF $STR_DESCRIPTOR(CLASS = DYNAMIC),
      strng : $STR_DESCRIPTOR(),
      outlen : INITIAL (512),           ! for FAOL call
      outbuf : $STR_DESCRIPTOR (CLASS = DYNAMIC_BOUNDED, STRING = (0, 0));

$STR_DESC_INIT (DESCRIPTOR = strng, CLASS = DYNAMIC);

SELECTONE .type OF
SET

[header_typ] :                          ! write the report header

$STR_COPY (TARGET = strng,
           STRING = %STRING ('| Conversion statistics',
                                 %CHAR (13, 10)));

[field_head_typ] :                      ! write field header

BEGIN
descr = .p_descr;
$STR_COPY (TARGET = strng,
           STRING = $STR_CONCAT ('|',
                                 %CHAR (13, 10),        ! CRLF
                                 '|  Field ',
                                 .descr,
                                 %CHAR (13, 10)));
END;


[msg_typ] :                             ! write a report entry w/ condition
                                        ! message and count of occurrences
BEGIN
INCR indx FROM 0 TO dix_max_cond DO
     IF .dixtab [.indx, DIU$G_ERRTAB_CODE] EQL .dix_cond
     THEN BEGIN
          ! make string w/dix error in it
          $STR_COPY (STRING = $STR_CONCAT ('|        ',
                                           dixtab [.indx, DIU$T_ERRTAB_TEXT],
                                           ' occurred !SL time!%S',
                                           %CHAR (13, 10)
                                           ),
                     TARGET = strng);

          $XPO_GET_MEM (CHARACTERS = .outlen, DESC = outbuf, FILL = %C' ');
          FAOL (strng, outlen, outbuf, num_errs);      ! let faol fill string
          $STR_COPY (STRING = outbuf, TARGET = strng);
          $XPO_FREE_MEM (STRING = outbuf);
          END;
END;


[end_typ] :                             ! write "end of report" message

$STR_COPY (TARGET = strng,
           STRING = %STRING('|', %CHAR(13,10), '| End conversion statistics'));

TES;

!
! Write the text
!
IF .interactive
THEN $XPO_PUT (IOB = tty, STRING = strng)	! Write message to terminal
ELSE LJ$UTXT(strng);                    ! Write to LOG file
END;                                    ! end of routine WRITE_LINE
%SBTTL 'DIU$CSR -- Conversion Statistics Report'
GLOBAL ROUTINE DIU$CSR (p_trans) =
!++
! FUNCTIONAL DESCRIPTION
!
!       This routine writes a data conversion statistics report to the user log
!       file or the terminal after data conversion has been completed.
!       
! FORMAL PARAMETERS
!
!       p_trans    address of the transform node which contains the FFDs for
!                  which the conversion error occurred
!
! ROUTINE VALUE
!
!       FALSE if we had any errors
!       TRUE if there were no errors
!
!--
BEGIN

LOCAL trans : REF transform_str,
      src_nam : $STR_DESCRIPTOR(),
      dst_nam : $STR_DESCRIPTOR(),
      header_flag : INITIAL (0),
      text : $STR_DESCRIPTOR();

trans = .p_trans;

$STR_DESC_INIT (DESCRIPTOR = text, CLASS = DYNAMIC, STRING = (0, 0));

IF .trans NEQ 0
THEN DO BEGIN
     IF .trans [tra_worst] NEQ 0        ! if there are errors for this field
     THEN                               ! then tell the user...
         BEGIN
         ! make single strings for the names of each field
         SINGLE_FQN_NAME (.trans [tra_src_addr], src_nam);
         SINGLE_FQN_NAME (.trans [tra_dst_addr], dst_nam);

         IF .header_flag EQL 0          ! if header hasn't been written yet,
         THEN BEGIN                     ! then write it...
              WRITE_LINE (header_typ, 0, 0, 0);
              header_flag = 1;
              END;

         $STR_COPY (TARGET = text,      ! always write the field name header
                    STRING =            ! if there are any errors...
                        $STR_CONCAT (src_nam, ' to ', dst_nam));
         WRITE_LINE (field_head_typ, text, 0, 0);

         !
         ! Errors are stored in the transform structure based on the
         ! data class of the conversion (either fixed-point data,
         ! floating-point or string)...
         !
         CASE .trans [tra_src$v_dt_class] FROM 1 TO dix$k_max_class OF
         SET
         [dt_string] :

             BEGIN

             IF .trans [tra_str_rounded] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_ROUNDED,
                                  .trans [tra_str_rounded]);

             IF .trans [tra_str_unimp] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_UNIMP,
                                  .trans [tra_str_unimp]);

             IF .trans [tra_str_graphic] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_GRAPHIC,
                                  .trans [tra_str_graphic]);

             IF .trans [tra_str_fmtlost] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_FMTLOST,
                                  .trans [tra_str_fmtlost]);

             IF .trans [tra_str_nonprint] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_NONPRINT,
                                  .trans [tra_str_nonprint]);

             IF .trans [tra_str_trunc] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_TRUNC,
                                  .trans [tra_str_trunc]);

             IF .trans [tra_str_invalchar] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_INVALCHAR,
                                  .trans [tra_str_invalchar]);
             END;

         [dt_fbin, dt_dnum, dt_pdec] :

             BEGIN

             IF .trans [tra_fix_rounded] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_ROUNDED,
                                  .trans [tra_fix_rounded]);

             IF .trans [tra_fix_unimp] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_UNIMP,
                                  .trans [tra_fix_unimp]);

             IF .trans [tra_fix_toobig] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_TOOBIG,
                                  .trans [tra_fix_toobig]);

             IF .trans [tra_fix_impossible] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_IMPOSSIBLE,
                                  .trans [tra_fix_impossible]);

             IF .trans [tra_fix_unsigned] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_UNSIGNED,
                                  .trans [tra_fix_unsigned]);

             IF .trans [tra_fix_invdnumchr] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_INVDNUMCHR,
                                  .trans [tra_fix_invdnumchr]);

             IF .trans [tra_fix_invdnumsgn] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_INVDNUMSGN,
                                  .trans [tra_fix_invdnumsgn]);

             IF .trans [tra_fix_invpddgt] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_INVPDDGT,
                                  .trans [tra_fix_invpddgt]);

             IF .trans [tra_fix_invpdsgn] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_INVPDSGN,
                                  .trans [tra_fix_invpdsgn]);
             END;

         [dt_fp] :

             BEGIN

             IF .trans [tra_fp_rounded] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_ROUNDED,
                                  .trans [tra_fp_rounded]);

             IF .trans [tra_fp_unimp] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_UNIMP,
                                  .trans [tra_fp_unimp]);

             IF .trans [tra_fp_toobig] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_TOOBIG,
                                  .trans [tra_fp_toobig]);

             IF .trans [tra_fp_unnorm] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_UNNORM,
                                  .trans [tra_fp_unnorm]);

             IF .trans [tra_fp_impossible] NEQ 0
             THEN WRITE_LINE (msg_typ, 0, DIX$_IMPOSSIBLE,
                                  .trans [tra_fp_impossible]);
             END;

         TES;

         END;

         trans = .trans [tra_next];     ! look at next transform node

         END

     UNTIL .trans EQL 0;                ! until there are no more!

IF .header_flag                              ! if we had any errors
THEN WRITE_LINE (end_typ, 0, 0, 0);     ! write the 'end' message

IF .header_flag                         ! if we had any errors
THEN FALSE                              ! return false
ELSE TRUE                               ! return true

END;

END
ELUDOM