以下は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)