17.10 - PL/IのINMODルーチンの生成 - FastExport

Teradata® FastExportリファレンス

Product
FastExport
Release Number
17.10
Release Date
2021年6月
Content Type
プログラミング リファレンス
Publication ID
B035-2410-061K-JPN
Language
日本語 (日本)

以下はPL/IのINMODルーチンのコンパイルおよび連係編集の一例です。

//MXM049A  JOB (22150000),'MXM',MSGCLASS=A,NOTIFY=MXM
//STEP1  EXEC PGM=IEV90,REGION=1024K,
//             PARM='OBJ,NODECK,XREF(FULL)'
//SYSLIB   DD   DSN=SYS1.MACLIB,DISP=SHR
//         DD   DSN=SYS1.AMODGEN,DISP=SHR
//SYSPRINT DD   SYSOUT=A
//SYSTERM  DD   SYSOUT=*
//SYSUT1   DD   UNIT=VIO,SPACE=(CYL,(9,5))
//SYSUT2   DD   UNIT=VIO,SPACE=(CYL,(9,5))
//SYSUT3   DD   UNIT=VIO,SPACE=(CYL,(9,5))
//SYSLIN   DD   DSN=&&PLIA,DISP=(,PASS),UNIT=SCR,
//  SPACE=(CYL,(1,1)),DCB=(RECFM=FB,LRECL=80,BLKSIZE=3200)
//SYSIN    DD   *
         TITLE 'DYNAMN'
DYNAMN   CSECT
         EXTRN PLISTART
         B     START-*(,R15)            BRANCH AROUND CONSTANTS
         DC    AL1(L'PLIAFLAG)          LENGTH OF CONSTANTS
PLIAFLAG DC    C'ASSEMBLED AT &SYSTIME ON &SYSDATE.. PLIA'
         DC    C' COPYRIGHT (C) 2014 TERADATA CORPORATION,'
         DC    C' ALL RIGHTS RESERVED.'
*================================================================
*   ENTRY POINT
*================================================================
START    SAVE  (14,12)
         LR    R12,R15            -> PROGRAM ENTRY POINT
         USING DYNAMN,R12
*
         LA    R10,SAVAREA
         ST    R10,8(R13)         FORWARD CHAIN
         ST    R13,4(R10)         BACK CHAIN
         LR    R13,R10
*
         LR    R4,R1              SAVE PARM LIST ADDRESS
         L     R3,0(,R1)          -> COMMAND WORD
         L     R3,0(,R3)          COMMAND WORD
         CH    R3,=H'0'           INITIAL CALL?
         BE    DO_INIT            YES , DO INITIAL CODE
         CH    R3,=H'6'           INITIAL CALL?
         BE    DO_INIT            YES , DO INITIAL CODE
         CH    R3,=H'2'           INITIAL CALL?
         BNE   DO_CALL            NO, JUST GO CALL PROGRAM
*================================================================
*   SETUP PL/I ENVIRONMENT
*================================================================
DO_INIT  DS    0H
*
*        WTO   'PRIOR TO INIT REQUEST'
*
         MVC   PRP_REQUEST,INIT   INDICATE THE INIT REQUEST
*
         LA    R1,EXEC_ADDR       GET THE PARM ADDR LIST
         ST    R1,EPL_EXEC_OPTS   SAVE IN EPL
*
         LA    R1,PARM_EPL        R1 --> POINTER --> REQUEST LIST
         L     R15,PSTART         PL/I ENTRY ADDR
         BALR  R14,R15            INVOKE PL/I
*
*        WTO   'AFTER INIT REQUEST'
*================================================================
*   CALL "OPTIONS( MAIN )" INMOD
*================================================================
DO_CALL  DS    0H
*
*        WTO   'PRIOR TO CALL REQUEST'
*
         MVC   PRP_REQUEST,CALL   INDICATE THE CALL REQUEST
*
         ST    R4,EPL_PROG_PARMS  SAVE PARM ADDR IN EPL
         LA    R1,PARM_EPL        R1 --> POINTER --> REQUEST LIST
         L     R15,PSTART         PL/I ENTRY ADDR
         BALR  R14,R15            INVOKE PL/I
*
         CH    R3,=H'5'           FINAL CALL?
         BNE   DO_RTN             NO, JUST RETURN TO CALLER
*================================================================
*   TERMINATE THE PL/I ENVIRONMENT
*================================================================
DO_TERM  DS    0H
*
         ST    R15,RETCODE        SAVE PL/I RETURN CODE
*
*        WTO   'PRIOR TO TERM REQUEST'
*
         MVC   PRP_REQUEST,TERM   INDICATE A TERM COMMAND
*
         LA    R1,0               NO PARM LIST IS PRESENT
         ST    R1,EPL_PROG_PARMS  SAVE IN EPL
*
         LA    R1,PARM_EPL        R1 --> POINTER --> REQUEST LIST
         L     R15,PSTART         PL/I ENTRY ADDR
         BALR  R14,R15            INVOKE PL/I
*
*        WTO   'AFTER TERM REQUEST'
*================================================================
*   RETURN TO CALLER
*================================================================
DO_RTN   DS    0H
*
         L     R13,SAVAREA+4
         L     R14,12(R13)
         L     R15,RETCODE
         LM    R0,R12,20(R13)
         BR    R14                RETURN TO YOUR CALLER
         EJECT
         EJECT
*================================================================
*   CONSTANTS AND WORKAREAS
*================================================================
SAVAREA  DS    20F
RETCODE  DC    F'0'
PARM_EPL DC    A(X'80000000'+IBMBZPRP)      PARAMETER ADDR LIST
PSTART   DC    A(PLISTART)
*================================================================
*   REQUEST STRINGS ALLOWED IN THE INTERFACE
*================================================================
INIT     DC    CL8'INIT'          INITIALIZE THE PROGRAM ENVIR
CALL     DC    CL8'CALL'          INVOKE THE APPL - LEAVE ENVIR UP
TERM     DC    CL8'TERM'          TERMINATE ENVIRONMENT
EXEC     DC    CL8'EXECUTE'       INIT, CALL, TERM - ALL IN ONE
*================================================================
*   PARAMETER LIST PASSED BY A PRE-INITIALIZED PROGRAM
*   ADDRESSED BY REG 1 = A(A(IBMBZPRP))
*   SEE IBMBZEPL DSECT.
*================================================================
IBMBZPRP             DS  0F
PRP_LENGTH           DC  H'16'    LEN OF THIS PRP PASSED (16)
PRP_ZERO             DC  H'0'     MUST BE ZERO
PRP_REQUEST          DC  CL8' '   'INIT' - INITIALIZE PL/I
*                                 'CALL' - INVOKE APPLICATION
*                                 'TERM' - TERMINATE PL/I
*                                 'EXECUTE' - INIT, CALL, TERM
*
PRP_EPL_PTR          DC  A(IBMBZEPL)   A(EPL) - EXTENDED PARM LIST
*================================================================
*   PARAMETER LIST FOR THE PRE-INITIALIZED PROGRAM
*================================================================
IBMBZEPL             DS  0F
EPL_LENGTH           DC  A(EPL_SIZE)   LENGTH OF THIS EPL PASSED
EPL_TOKEN1           DC  F'0'          FIRST ENV TOKEN
EPL_TOKEN2           DC  F'0'          SECOND ENV TOKEN
EPL_PROG_PARMS       DC  F'0'          A(PARM ADDRESS LIST) ...
EPL_EXEC_OPTS        DC  A(EXEC_ADDR)  A(EXECUTION TIME OPTNS) ...
EPL_ALTMAIN          DC  F'0'          A(ALTERNATE MAIN)
EPL_SERVICE_VEC      DC  A(IBMBZSRV)   A(SERVICE ROUTINES VECTOR)
EPL_SIZE             EQU *-IBMBZEPL    THE SIZE OF THIS BLOCK
*================================================================
*   SERVICE ROUTINE VECTOR
*================================================================
IBMBZSRV             DS  0F
SRV_SLOTS            DC  F'2'          COUNT OF SLOTS DEFINED
SRV_USERWORD         DC  A(SRV_UA)     USER WORD
SRV_WORKAREA         DC  A(SRV_WA)     A(WORKAREA)
SRV_LOAD             DC  F'0'          A(LOAD ROUTINE)
SRV_DELETE           DC  F'0'          A(DELETE ROUTINE)
SRV_GETSTOR          DC  F'0'          A(GET STORAGE ROUTINE)
SRV_FREESTOR         DC  F'0'          A(FREE STORAGE ROUTINE)
SRV_EXCEP_RTR        DC  F'0'          A(EXCEPTION ROUTER SERVICE)
SRV_ATTN_RTR         DC  F'0'          A(ATTENTION ROUTER SERVICE)
SRV_MSG_RTR          DC  F'0'          A(MESSAGE ROUTER SERVICE)
SRV_END              DS  0F
*================================================================
*   SERVICE ROUTINE USERAREA
*================================================================
SRV_UA               DS  8F
*================================================================
*   SERVICE ROUTINE WORKAREA
*================================================================
SRV_WA               DS  0D
                     DC  F'256'   LENGTH OF WORKAREA
                     DS  63F      ACTUAL WORKAREA
*================================================================
*   EXECUTION TIME PARAMETERS
*================================================================
EXEC_ADDR DC    A(X'80000000'+EXEC_LEN)
EXEC_LEN  DC    AL2(EXEC_OLEN)
EXEC_OPTS DC    C'NATLANG(ENU),NOSTAE'
EXEC_OLEN EQU   *-EXEC_OPTS
*
     LTORG
R0       EQU   0
R1       EQU   1
R2       EQU   2
R3       EQU   3
R4       EQU   4
R5       EQU   5
R6       EQU   6
R7       EQU   7
R8       EQU   8
R9       EQU   9
R10      EQU   10
R11      EQU   11
R12      EQU   12
R13      EQU   13
R14      EQU   14
R15      EQU   15
         END
//*
//STEP2    EXEC IEL1CL
//PLI.SYSPRINT  DD SYSOUT=*
//PLI.SYSIN     DD *
 INMDPL2: PROCEDURE (X,Y) OPTIONS (MAIN);
  DCL X FIXED, Y FIXED;
  DCL 1 PARM_LIST ALIGNED BASED(P),
        10 STATUS       FIXED BINARY (31,0),
        10 RLENGTH      FIXED BINARY (31,0),
        10 BUFFER       CHAR(80);
  DCL 1 PARM_PARM2 ALIGNED BASED(Q),
        10 SEQ          FIXED BINARY (31,0),
        10 LEN          FIXED BINARY (15,0),
        10 PARAMETER    CHAR(80);
  DCL COUNT STATIC FIXED BINARY (31,0),
      INSROWS STATIC FIXED BINARY (31,0),
      REJROWS STATIC FIXED BINARY (31,0);
  DCL I, NOTMATCH FIXED BINARY (31,0);
  DCL ADDR BUILTIN, SUBSTR BUILTIN;
  DCL P POINTER, Q POINTER;
  DCL SYSPRINT FILE OUTPUT;                                                                        

  P = ADDR(X);
  Q = ADDR(Y);                                                                                    

  OPEN FILE(SYSPRINT);
  PUT SKIP LIST('### INSIDE PL/I INMOD ROUTINE...');
  PUT SKIP LIST('STATUS =');
  PUT LIST(P->STATUS);
  PUT SKIP LIST('LENGTH =');
  PUT LIST(P->RLENGTH);
  PUT SKIP LIST('BUFFER =');
  PUT LIST(SUBSTR(P->BUFFER,1,30));
  PUT SKIP LIST('SEQ =');
  PUT LIST(Q->SEQ);
  PUT SKIP LIST('PARM =');
  PUT LIST(SUBSTR(Q->PARAMETER,1,Q->LEN));                                                         

  SELECT (P->STATUS);                                                                              
    WHEN (6) DO; /* INITIALIZE */
                 COUNT = 0;
                 REJROWS = 0;
                 INSROWS = 0;
                 P->STATUS = 0;
             END;

                                                                                 
    WHEN (7) DO; /* PROCESS */
                 COUNT = COUNT + 1;
                 NOTMATCH = 0;
                 P->STATUS = 0;
                 DO I = 1 TO Q -> LEN;
                    IF SUBSTR(P->BUFFER,I,1) ^= SUBSTR(Q->PARAMETER,I,1)
                       THEN DO;
                          NOTMATCH= 1;
                          LEAVE;
                       END;
                 END;
                 IF NOTMATCH = 1
                    THEN DO;
                       PUT SKIP LIST('------> REJECTED <------');
                       REJROWS = REJROWS + 1;
                       P->RLENGTH = 0;
                    END;
                 ELSE
                    DO;
                       PUT SKIP LIST('------> ACCEPTED <------');
                       INSROWS = INSROWS + 1;
                    END;
             END;
    WHEN (5) DO; /* FINALIZE */
                 P->STATUS = 0;
             END;
    OTHERWISE DO;
                 PUT SKIP LIST ('UNKNOWN CODE...');
                 P->STATUS = 99;
             END;
  END;                                                                                             
  PUT SKIP LIST('STATUS =');
  PUT LIST(P->STATUS);
  PUT SKIP LIST('LENGTH =');
  PUT LIST(P->RLENGTH);
  PUT SKIP LIST('TOTAL =');
  PUT LIST(COUNT);
  PUT SKIP LIST('INSERTS =');
  PUT LIST(INSROWS);
  PUT SKIP LIST('REJROWS =');
  PUT LIST(REJROWS);
  PUT SKIP LIST('---------------------------------------------------');
  CLOSE FILE(SYSPRINT);                                                                           

 END INMDPL2;
//LKED.SYSPRINT DD SYSOUT=*
//LKED.PLIA     DD DISP=(OLD,DELETE),DSN=&&PLIA
//LKED.SYSIN    DD *
  INCLUDE PLIA
  ENTRY DYNAMN
  NAME INMDPL2(R)