home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / viscobv6.zip / vac22os2 / ibmcobol / samples / sdu / iwzzss1.cbl < prev    next >
Text File  |  1997-03-14  |  17KB  |  319 lines
  1.       **********************************************************
  2.       *  PRODUCT   = Data Description and Conversion for OS/2
  3.       *
  4.       *  SOURCE FILE NAME = IWZZSS1.CBL
  5.       *
  6.       *  DESCRIPTIVE NAME = ADL Declaration Translator and CPB sample
  7.       *
  8.       *  FUNCTION = This sample program calls the parse function of the
  9.       *              ADL declaration translator to compile ADL source
  10.       *              text IWZZSS1.ADL into the appropriate ADL declare
  11.       *              and plan spaces, calls the generate function of
  12.       *              the ADL declaration translator to reproduce the
  13.       *              ADL source file IWZZSS1.GEN. The parse function's
  14.       *              output is also used to call the conversion plan
  15.       *              builder to create conversion plans from the encoded
  16.       *              descriptions.
  17.       *              The conversion plan space generated as the output
  18.       *              of the conversion plan builder is stored in the  
  19.       *              file IWZZSS1F.
  20.       *
  21.       **********************************************************
  22.         IDENTIFICATION DIVISION.
  23.         PROGRAM-ID. IWZZSS1.
  24.         ENVIRONMENT DIVISION.
  25.         CONFIGURATION SECTION.
  26.         SOURCE-COMPUTER. IBM-PS2.
  27.         OBJECT-COMPUTER. IBM-PS2.
  28.         INPUT-OUTPUT SECTION.
  29.         FILE-CONTROL.
  30.              SELECT Sample-SPC ASSIGN TO IWZZSS1F
  31.                                       ORGANIZATION IS SEQUENTIAL.
  32.         DATA DIVISION.
  33.         FILE SECTION.
  34.         FD   Sample-SPC
  35.               RECORDING MODE IS F
  36.               RECORD CONTAINS 5000 CHARACTERS.
  37.         01    CnvPlnSpc  PICTURE X(5000).
  38.         WORKING-STORAGE SECTION.
  39.       **********************************************************
  40.       *  Work areas and values specific to this sample program
  41.       **********************************************************
  42.         77     BUFLEN-ADLDCLSPC  PICTURE 9(6) USAGE IS BINARY
  43.                                  VALUE IS 64000.
  44.         77     BUFLEN-ADLPLNSPC  PICTURE 9(6) USAGE IS BINARY 
  45.                                  VALUE IS 64000.
  46.         77     BUFLEN-CNVPLNSPC  PICTURE 9(6) USAGE IS BINARY
  47.                                  VALUE IS 5000.
  48.         77     UserAdlPlnSpcNull  PICTURE 9(6) USAGE IS BINARY 
  49.                                   VALUE IS 0.
  50.         77     AdlDclSpc  PICTURE X(64000).
  51.         77     AdlPlnSpc  PICTURE X(64000).
  52.       **********************************************************
  53.       *  Return codes and ADL exception codes
  54.       **********************************************************
  55.         77     PRS-NO-ERROR  PICTURE 9(2) USAGE BINARY VALUE IS 0.
  56.         77     GEN-NO-ERROR  PICTURE 9(2) USAGE BINARY VALUE IS 0.
  57.         77     CPB-NO-ERROR  PICTURE 9(2) USAGE BINARY VALUE IS 0.
  58.         77     CPB-ADL-EXCEPTION-SEV2  PICTURE 9(6)
  59.                                           USAGE IS BINARY VALUE is 2.
  60.         77     CPB-ADL-EXCEPTION-SEV3  PICTURE 9(6)
  61.                                           USAGE IS BINARY VALUE IS 18.
  62.       **********************************************************
  63.       *  Parameters for FMTPRS, FMTGEN and FMTCRCP
  64.       **********************************************************
  65.         77     DclXlrId        PICTURE X(8).
  66.         77     ADLDECLTRANSLATOR  PICTURE X(8)
  67.                                     VALUE IS X"2B12000301886D01".
  68.         77     ParameterCCSID      PICTURE 9(6) USAGE IS BINARY
  69.                                    VALUE IS 0.
  70.         77     SrcFilNamLength     PICTURE  9(6) USAGE IS BINARY.
  71.         77     SrcFilNam           PICTURE  X(255).
  72.         77     SrcFilCCSID         PICTURE  9(6) USAGE IS BINARY
  73.                                    VALUE IS 0.
  74.         77     DclXlrOptLength     PICTURE  9(6) USAGE IS BINARY.
  75.         77     DclXlrOpt           PICTURE  X(255).
  76.         77     LstOptLength       PICTURE  9(6) USAGE IS BINARY.
  77.         77     LstOpt              PICTURE  X(255).
  78.         77     LstFilNamLength    PICTURE  9(6) USAGE IS BINARY.
  79.         77     LstFilNam           PICTURE  X(255).
  80.         77     ADLDclSpcCCSID      PICTURE  9(6)  USAGE IS BINARY
  81.                                    VALUE IS 0.
  82.         77     ADLDclSpcLength   PICTURE  9(6) USAGE IS BINARY.
  83.         77     ADLPlnSpcLength   PICTURE  9(6) USAGE IS BINARY.
  84.         77     ADLSpcCCSID      PICTURE 9(6) USAGE IS BINARY
  85.                                 VALUE IS 0.
  86.         77     LstFilCCSID         PICTURE 9(6) USAGE IS BINARY
  87.                                    VALUE IS 0.
  88.         77     AdlDclSpcCount   PICTURE 9(6) USAGE IS BINARY.
  89.         77     UserAdlPlnSpcCount   PICTURE  9(6) USAGE IS BINARY.
  90.         77     DefaultAdlPlnSpcCount  PICTURE  9(6) USAGE IS BINARY.
  91.         77     CnvPlnSpcLength   PICTURE 9(6) USAGE IS BINARY.
  92.         77     FlagList      PICTURE 9(6) USAGE IS BINARY.
  93.         01     AdlDclSpcList.
  94.             05 AdlDclSpcptr   USAGE IS POINTER OCCURS 32 TIMES.
  95.         01     UserAdlPlnSpcList.
  96.             05 UserAdlPlnSpcPtr   USAGE IS POINTER OCCURS 32 TIMES.
  97.         01     DefaultAdlPlnSpcList.
  98.             05 DefaultAdlPlnSpcPtr  USAGE IS POINTER OCCURS 32 TIMES.
  99.         01     Cnstkn.  
  100.             05 CnstknLength  PICTURE 9(6) USAGE IS BINARY.
  101.             05 CnstknClass   PICTURE 9(2) USAGE IS BINARY.
  102.             05 CnstknValue   PICTURE X(16).
  103.         01     FeedBack.
  104.             05 Condition-ID.
  105.                 10 MsgSev  PICTURE 9(2) USAGE IS BINARY.
  106.                 10 MsgNo    PICTURE 9(2) USAGE IS BINARY.
  107.             05 Case-Severity-Control  PICTURE X.
  108.             05 Facility-ID  PICTURE X(3).
  109.             05 I-S-Info.
  110.                 10 AdlExId  PICTURE 9(6) USAGE IS BINARY.
  111.                 10 AdlCommAreaPtr REDEFINES AdlExId USAGE IS POINTER.
  112.                 10 User-ExitCtokPtr  REDEFINES AdlExId USAGE IS POINTER.
  113.       **********************************************************
  114.       *  ADL Communication Area
  115.       **********************************************************
  116.         01     AdlCommArea.
  117.             05 AdlCALength  PICTURE 9(6) USAGE IS BINARY.
  118.             05 ExId  PICTURE 9(6) USAGE IS BINARY.
  119.             05 SevCod  PICTURE 9(2) USAGE IS BINARY.
  120.             05 PlanId.
  121.                 10  PreLength  PICTURE 9(2) USAGE IS BINARY.
  122.                 10  CharData  PICTURE X(255).
  123.             05 PlanStmt  PICTURE 9(6) USAGE IS BINARY.
  124.             05 InpErrDta.
  125.                 10  PreLength  PICTURE 9(2) USAGE IS BINARY.
  126.                 10  CharData  PICTURE X(255).
  127.             05 SrcFldID.
  128.                 10  PreLength  PICTURE 9(2) USAGE IS BINARY.
  129.                 10  CharData  PICTURE X(255).
  130.             05 TrgFldId.
  131.                 10  PreLength  PICTURE 9(2) USAGE IS BINARY.
  132.                 10  CharData  PICTURE X(255).
  133.         PROCEDURE DIVISION.
  134.       **********************************************************
  135.       *  Call PARSE function of ADL Declaration Translator for
  136.       *  ADL source text to get ADLDCLSPC and ADLPLNSPC.
  137.       *  Translator id is set to ADL.
  138.       *  Note: Currently all CCSIDs should be zero
  139.       **********************************************************
  140.              MOVE ADLDECLTRANSLATOR TO DclXlrId.
  141.              MOVE 11 TO SrcFilNamLength.
  142.              MOVE "IWZZSS1.ADL" TO SrcFilNam.
  143.              MOVE 8 TO DclXlrOptLength.
  144.              MOVE "AUTOSKIP" TO DclXlrOpt.
  145.              MOVE 4 TO LstOptLength.
  146.              MOVE "LIST" TO LstOpt.
  147.              MOVE 12 TO LstFilNamLength.
  148.              MOVE "IWZZSS1P.LST" TO LstFilNam.
  149.              MOVE BUFLEN-ADLDCLSPC TO ADLDclSpcLength.
  150.              MOVE BUFLEN-ADLPLNSPC TO ADLPlnSpcLength.
  151.              CALL "FMTPRS" USING
  152.                                   BY REFERENCE DclXlrId
  153.                                   BY VALUE     ParameterCCSID
  154.                                   BY VALUE     SrcFilNamLength
  155.                                   BY REFERENCE SrcFilNam
  156.                                   BY VALUE     SrcFilCCSID
  157.                                   BY VALUE     DclXlrOptLength
  158.                                   BY REFERENCE DclXlrOpt
  159.                                   BY VALUE     LstOptLength
  160.                                   BY REFERENCE LstOpt
  161.                                   BY VALUE     LstFilNamLength
  162.                                   BY REFERENCE LstFilNam
  163.                                   BY VALUE     ADLDclSpcLength
  164.                                   BY REFERENCE AdlDclSpc
  165.                                   BY VALUE     ADLDclSpcCCSID
  166.                                   BY REFERENCE Cnstkn
  167.                                   BY VALUE     ADLPlnSpcLength
  168.                                   BY REFERENCE AdlPlnSpc
  169.                                   BY REFERENCE FeedBack.
  170.       **********************************************************
  171.       *  Check the Condition Token
  172.       **********************************************************
  173.              IF MsgNo OF Condition-ID IN FeedBack NOT = PRS-NO-ERROR
  174.              THEN
  175.                   DISPLAY "Error in PARSE function"
  176.                   DISPLAY
  177.                    "The Condition Token has the following contents:"
  178.                   DISPLAY "Message Severity "
  179.                           MsgSev OF Condition-ID IN FeedBack
  180.                           " Number "
  181.                           MsgNo OF Condition-ID IN FeedBack
  182.                   DISPLAY "Case+Severity+Control "
  183.                           Case-Severity-Control IN FeedBack
  184.                   DISPLAY "Facility ID "
  185.                           Facility-ID OF FeedBack
  186.                   DISPLAY "Instance Specific "
  187.                           AdlExId OF FeedBack 
  188.                   STOP RUN
  189.              END-IF.
  190.       **********************************************************
  191.       *  Call GENERATE function of ADL Declaration Translator for
  192.       *  ADLDCLSPC to get ADL Source test.
  193.       *  This call is not necessary to create a conversion plan. 
  194.       *  It is mainly done for debugging of the PARSE function.
  195.       *  Translator id is set to ADL.
  196.       *  Note: Currently all CCSIDs should be zero.
  197.       **********************************************************
  198.              MOVE 11 to SrcFilNamLength.
  199.              MOVE "IWZZSS1.GEN" TO SrcFilNam.
  200.              MOVE 0 to DclXlrOptLength.
  201.              MOVE 12 TO LstOptLength.
  202.              MOVE "LIST FLAG(I)" to LstOpt.
  203.              MOVE 12 to LstFilNamLength.
  204.              MOVE "IWZZSS1G.LST" TO LstFilNam.
  205.              CALL "FMTGEN" USING
  206.                                   BY REFERENCE DclXlrId
  207.                                   BY VALUE     ParameterCCSID
  208.                                   BY VALUE     DclXlrOptLength
  209.                                   BY REFERENCE DclXlrOpt
  210.                                   BY REFERENCE AdlDclSpc
  211.                                   BY VALUE AdlSpcCCSID
  212.                                   BY VALUE SrcFilNamLength
  213.                                   BY REFERENCE SrcFilNam
  214.                                   BY VALUE     SrcFilCCSID
  215.                                   BY VALUE     LstOptLength
  216.                                   BY REFERENCE LstOpt
  217.                                   BY VALUE     LstFilNamLength
  218.                                   BY REFERENCE LstFilNam
  219.                                   BY VALUE     LstFilCCSID
  220.                                   BY REFERENCE FeedBack.
  221.       **********************************************************
  222.       *  Check the Condition Token
  223.       **********************************************************
  224.              IF MsgNo OF Condition-ID IN FeedBack NOT = GEN-NO-ERROR
  225.              THEN
  226.                   DISPLAY "Error in GENERATE function"
  227.                   DISPLAY
  228.                    "The Condition Token has the following contents:"
  229.                   DISPLAY "Message Severity "
  230.                           MsgSev OF Condition-ID IN FeedBack
  231.                           " Number "
  232.                           MsgNo OF Condition-ID IN FeedBack
  233.                   DISPLAY "Case+Severity+Control "
  234.                           Case-Severity-Control IN FeedBack
  235.                   DISPLAY "Facility ID      "
  236.                           Facility-ID OF FeedBack
  237.                   DISPLAY "Instance Specific "
  238.                           AdlExId OF FeedBack 
  239.                   STOP RUN
  240.              END-IF.
  241.       **********************************************************
  242.       *  Call Conversion Plan Builder
  243.       *  Note: If UserAdlPlnSpcCount (third parameter) is not zero,
  244.       *        then the fourth parameter must be replaced with
  245.       *             BY REFERENCE UserAdlPlnSpcList
  246.       *        and addresses of user defined plan spaces must be
  247.       *        entered into the list.
  248.       **********************************************************
  249.              MOVE 1 TO AdlDclSpcCount.
  250.              SET AdlDclSpcPtr(1) TO ADDRESS OF AdlDclSpc.
  251.              MOVE 0 TO UserAdlPlnSpcCount.
  252.              MOVE 1 TO DefaultAdlPlnSpcCount.
  253.              SET DefaultAdlPlnSpcPtr(1) TO ADDRESS OF AdlPlnSpc.
  254.              MOVE BUFLEN-CNVPLNSPC TO CnvPlnSpcLength.
  255.              MOVE 0 TO FlagList.
  256.              SET AdlCommAreaPtr TO ADDRESS OF AdlCommArea.
  257.              CALL "FMTCRCP" USING
  258.                                   BY VALUE     AdlDclSpcCount
  259.                                   BY REFERENCE AdlDclSpcList
  260.                                   BY VALUE     UserAdlPlnSpcCount
  261.                                   BY VALUE     UserAdlPlnSpcNull
  262.                                   BY VALUE     DefaultAdlPlnSpcCount
  263.                                   BY REFERENCE DefaultAdlPlnSpcList
  264.                                   BY VALUE     CnvPlnSpcLength
  265.                                   BY REFERENCE CnvPlnSpc
  266.                                   BY VALUE     FlagList
  267.                                   BY REFERENCE FeedBack.
  268.       **********************************************************
  269.       *  Check the Condition Token
  270.       *  Note: The Case-Severity-Control field is further divided into
  271.       *        three sub-fields. You may want to display it in hex.
  272.       **********************************************************
  273.              IF MsgNo OF Condition-ID IN FeedBack NOT = CPB-NO-ERROR
  274.              THEN
  275.                   DISPLAY "Error in Conversion Plan Builder"
  276.                   DISPLAY
  277.                    "The Condition Token has the following contents:"
  278.                   DISPLAY "Message Severity "
  279.                           MsgSev OF Condition-ID IN FeedBack
  280.                           " Number "
  281.                           MsgNo OF Condition-ID IN FeedBack
  282.                   DISPLAY "Case+Severity+Control "
  283.                           Case-Severity-Control IN FeedBack
  284.                   DISPLAY "Facility ID "
  285.                           Facility-ID OF FeedBack
  286.       **********************************************************
  287.       *  Check whether an ADL exception occurred. If so, the ADL
  288.       *  communication area is displayed.
  289.       **********************************************************
  290.                   IF MsgNo OF Condition-ID = CPB-ADL-EXCEPTION-SEV2  OR
  291.                      MsgNo OF Condition-ID = CPB-ADL-EXCEPTION-SEV3
  292.                  THEN
  293.                      DISPLAY
  294.                       "The ADL communication area has the following
  295.       -                            " contents:"
  296.                      DISPLAY "ADL exception: " ExId OF AdlCommArea
  297.                      DISPLAY "Severity of ADL exception: " 
  298.                              SevCod OF AdlCommArea
  299.                      DISPLAY "Name of processed plan: " 
  300.                              CharData OF PlanId OF AdlCommArea
  301.                      DISPLAY "Number of processed PLAN statement: "
  302.                              PlanStmt OF AdlCommArea
  303.                      DISPLAY "Source identifier of processed assignment
  304.       -                             " statement: "
  305.                              CharData OF SrcFldId OF AdlCommArea
  306.                      DISPLAY "Target identifier of processed assignment
  307.       -                             " statement: "
  308.                              CharData OF TrgFldId OF AdlCommArea
  309.                      STOP RUN
  310.                   END-IF 
  311.              ELSE
  312.       ********************************************************** 
  313.       *  Write conversion plan space into file.
  314.       **********************************************************
  315.                 OPEN OUTPUT Sample-SPC
  316.                 WRITE  CnvPlnSpc
  317.                 CLOSE SAMPLE-SPC.
  318.              STOP RUN.
  319.