The following shows the sample batch program after processing by the PL/I compiler. The original code is further expanded and includes the following:
For details on the expanded code generated by the DML precompiler, see Call Formats.
PL/I OPTIMIZING COMPILER /*RETRIEVAL*/ PAGE 2
SOURCE LISTING
STMT LEV NT
/*RETRIEVAL*/
/*DMLIST*/
/*NO_ACTIVITY_LOG*/
/*SCHEMA_COMMENTS*/
1 0 DEPTRPT: PROC OPTIONS (MAIN) REORDER;
/* DECLARE SUBSCHEMA AND MODE */
/*
DCL (EMPSS01 SUBSCHEMA, EMPSCHM SCHEMA VERSION 100)
MODE (BATCH) DEBUG;
*/
/* REQUIRED DECLARATIVES */
2 1 0 DCL IDMS ENTRY OPTIONS(INTER,ASM);
3 1 0 DCL ABORT ENTRY OPTIONS(INTER,ASM);
4 1 0 DCL ADDR BUILTIN;
/* CONSTANTS */
5 1 0 DCL DEPT_HEADER CHAR (11) INIT ('DEPT REPORT');
6 1 0 DCL 1 HEAD_LINE,
5 HEAD_DEPT_ID CHAR (9) INIT ('DEPT ID '),
5 HEAD_EMP_ID CHAR (8) INIT ('EMP ID '),
5 HEAD_LNAME CHAR (17) INIT ('LAST NAME '),
5 HEAD_FNAME CHAR (10) INIT ('FIRST NAME');
7 1 0 DCL PRTHEAD CHAR (44) DEFINED HEAD_LINE;
/* LOGICAL CONSTANTS */
8 1 0 DCL YES BIT(1) INIT ('1'B);
9 1 0 DCL NO BIT(1) INIT ('0'B);
10 1 0 DCL EOF BIT(1) INIT ('0'B);
11 1 0 DCL 1 PROGRAM_FLAGS,
5 DB_END_OF_SET BIT(1) INIT ('0'B);
/* FILE DECLARATIONS */
12 1 0 DCL INFILE FILE RECORD INPUT ENV (F BLKSIZE(80));
13 1 0 DCL OUTFILE FILE RECORD OUTPUT ENV (F RECSIZE(133) CTLASA );
14 1 0 DCL SYSPRINT FILE PRINT;
/* THE FOLLOWING RECORDS ARE DEFINED THROUGH IDD. */
/* THE DML PRECOMPILER AUTOMATICALLY CONVERTS HYPHENS */
/* TO UNDERSCORES. */
/*
INCLUDE IDMS (DEPT-IN-REC);
15 1 0 DECLARE 1 DEPT_IN_REC,
2 DEPT_ID_IN PICTURE '(4)9',
2 DEPT_FILLER CHARACTER (76);
/*
INCLUDE IDMS (PRT-OUT-REC);
*/
16 1 0 DECLARE 1 PRT_OUT_REC,
2 DEPT_ID_OUT CHARACTER (4),
2 PRT_FILL_5 CHARACTER (5) INITIAL (' '),
2 EMP_ID_OUT CHARACTER (4),
2 PRT_FILL_4 CHARACTER (4) INITIAL (' '),
2 EMP_LNAME_OUT CHARACTER (15),
2 PRT_FILL_2 CHARACTER (2) INITIAL (' '),
2 EMP_FNAME_OUT CHARACTER (10);
/* REDEFINE PRT_OUT_REC */
17 1 0 DCL PRTREC CHAR (44) DEFINED PRT_OUT_REC;
18 1 0 DCL 1 PRINT_AREA,
5 CC CHAR (1),
5 PRINT_LINE CHAR (132);
19 1 0 DCL 1 SPACES CHAR (132) INIT ( (132) ' ');
/* POSSIBLE VALUES FOR CC */
20 1 0 DCL 1 CONTROL_CHARACTERS,
5 NEW_PAGE CHAR (1) INIT ('1'),
5 SINGLE_SPACE CHAR (1) INIT (' '),
5 DOUBLE_SPACE CHAR (1) INIT ('0'),
5 TRIPLE_SPACE CHAR (1) INIT ('-'),
5 OVERPRINT CHAR (1) INIT ('+');
/*
INCLUDE IDMS (SUBSCHEMA_CTRL);
*
21 DECLARE 1 SUBSCHEMA_CTRL,
3 PROGRAM CHARACTER (8) INITIAL (' ') ,
3 ERROR_STATUS CHARACTER (4) INITIAL ('1400') ,
3 DBKEY FIXED BINARY (31),
3 RECORD_NAME CHARACTER (16) INITIAL (' ') ,
3 AREA_NAME CHARACTER (16) INITIAL (' ') ,
3 ERROR_SET CHARACTER (16) INITIAL (' ') ,
3 ERROR_RECORD CHARACTER (16) INITIAL (' ') ,
3 ERROR_AREA CHARACTER (16) INITIAL (' ') ,
3 IDBMSCOM_AREA CHARACTER (100) INITIAL (LOW(100)) ,
3 DIRECT_DBKEY FIXED BINARY (31),
3 DATABASE_STATUS,
5 DBSTATMENT_CODE CHARACTER (2),
5 DBSTATUS_CODE CHARACTER (5),
3 FILLER0001 CHARACTER (1),
3 RECORD_OCCUR FIXED BINARY (31),
3 DML_SEQUENCE FIXED BINARY (31);
22 DECLARE 1 RIDBMSCOM BASED(ADDR(SUBSCHEMA_CTRL.IDBMSCOM_AREA)),
3 PAGE_INFO,
5 PAGE_INFO_GROUP FIXED BINARY (15),
5 PAGE_INFO_DBK_FORMAT FIXED BINARY (15),
3 SSC_IDMS_STATUS_WRK,
5 SSC_IN01_REQ_WK,
7 SSC_IN01_REQ_CODE FIXED BINARY (31),
7 SSC_IN01_REQ_RETURN FIXED BINARY (31),
5 SSC_STATUS_LINE,
7 SSC_STATUS_LABEL CHARACTER (16),
7 SSC_STATUS_VALUE CHARACTER (12),
3 FILLER0002 CHARACTER (60);
23 DECLARE 1 IDBMSCOM (100) BASED(ADDR(SUBSCHEMA_CTRL.IDBMSCOM_AREA))
CHARACTER (1);
24 DECLARE 1 AREA_RNAME BASED(ADDR(SUBSCHEMA_CTRL.AREA_NAME)),
3 SSC_DNO CHARACTER (8),
3 SSC_DNA CHARACTER (8);
25 DECLARE 1 RRECORD_NAME BASED(ADDR(SUBSCHEMA_CTRL.RECORD_NAME)),
3 SSC_NODN CHARACTER (8),
3 SSC_DBN CHARACTER (8);
26 1 0 DECLARE 1 SUBSCHEMA_CTRL,
3 PROGRAM CHARACTER (8) INITIAL (' '),
3 ERROR_STATUS CHARACTER (4) INITIAL ('1400'),
3 DBKEY FIXED BINARY (31),
3 RECORD_NAME CHARACTER (16) INITIAL (' '),
3 AREA_NAME CHARACTER (16) INITIAL (' '),
3 ERROR_SET CHARACTER (16) INITIAL (' '),
3 ERROR_RECORD CHARACTER (16) INITIAL (' '),
3 ERROR_AREA CHARACTER (16) INITIAL (' '),
3 IDBMSCOM_AREA,
5 IDBMSCOM (100) CHARACTER (1),
3 DIRECT_DBKEY FIXED BINARY (31),
3 DATABASE_STATUS,
5 DBSTATMENT_CODE CHARACTER (2),
5 DBSTATUS_CODE CHARACTER (5),
3 FILLER0001 CHARACTER (1),
3 RECORD_OCCUR FIXED BINARY (31),
3 DML_SEQUENCE FIXED BINARY (31);
27 1 0 DECLARE 1 AREA_RNAME BASED(ADDR(SUBSCHEMA_CTRL.AREA_NAME)),
3 SSC_DNO CHARACTER (8),
3 SSC_DNA CHARACTER (8);
28 1 0 DECLARE 1 RRECORD_NAME BASED(ADDR(SUBSCHEMA_CTRL.RECORD_NAME)),
3 SSC_NODN CHARACTER (8),
3 SSC_DBN CHARACTER (8);
/*
INCLUDE IDMS (DEPARTMENT);
*/
28 1 0 DECLARE 1 DEPARTMENT,
2 DEPT_ID_0410 PICTURE '(4)9',
2 DEPT_NAME_0410 CHARACTER (45),
2 DEPT_HEAD_ID_0410 PICTURE '(4)9',
2 FILLER0002 CHARACTER (3);
/*
INCLUDE IDMS (EMPLOYEE);
*/
30 1 0 DECLARE 1 EMPLOYEE,
2 EMP_ID_0415 PICTURE '(4)9',
2 EMP_NAME_0415,
3 EMP_FIRST_NAME_0415 CHARACTER (10),
3 EMP_LAST_NAME_0415 CHARACTER (15),
2 EMP_ADDRESS_0415,
3 EMP_STREET_0415 CHARACTER (20),
3 EMP_CITY_0415 CHARACTER (15),
3 EMP_STATE_0415 CHARACTER (2),
3 EMP_ZIP_0415,
4 EMP_ZIP_FIRST_FIVE_0415 CHARACTER (5),
4 EMP_ZIP_LAST_FOUR_0415 CHARACTER (4),
2 EMP_PHONE_0415 PICTURE '(10)9',
2 STATUS_0415 CHARACTER (2),
2 SS_NUMBER_0415 PICTURE '(9)9',
2 START_DATE_0415,
3 START_YEAR_0415 PICTURE '(2)9',
3 START_MONTH_0415 PICTURE '(2)9',
3 START_DAY_0415 PICTURE '(2)9',
2 TERMINATION_DATE_0415,
3 TERMINATION_YEAR_0415 PICTURE '(2)9',
3 TERMINATION_MONTH_0415 PICTURE '(2)9',
3 TERMINATION_DAY_0415 PICTURE '(2)9',
2 BIRTH_DATE_0415,
3 BIRTH_YEAR_0415 PICTURE '(2)9',
3 BIRTH_MONTH_0415 PICTURE '(2)9',
3 BIRTH_DAY_0415 PICTURE '(2)9',
2 FILLER0003 CHARACTER (2),
2 FILLER0004 CHARACTER (4);
/***********************************************************/
/* PROCESSING FOLLOWS */
/* OPEN THE FILES */
/* INFILE ── INPUT */
/* OUTFILE ── OUTPUT */
/* SYSPRINT ── USED BY IDMS_STATUS */
31 1 0 OPEN FILE (INFILE);
32 1 0 OPEN FILE (OUTFILE);
33 1 0 OPEN FILE (SYSPRINT);
34 1 0 ON ENDFILE (INFILE) EOF = YES;
/* BIND RUN UNIT AND RECORDS EXPLICITLY */
/*
BIND RUN_UNIT DMLP0001
NODENAME ('')
DBNAME ('');
*/
35 1 0 /* IDMS PL/I DML EXPANSION */ DO;
36 1 1 DML_SEQUENCE=1;
37 1 1 SSC_NODN='';
38 1 1 SSC_DBN='';
39 1 1 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (59)
,SUBSCHEMA_CTRL
,'EMPSS01 '
40 1 1 ); END;
41 1 0 CALL IDMS_STATUS;
/*
BIND RECORD (EMPLOYEE); DMLP0002
*/
42 1 0 /* IDMS PL/I DML EXPANSION */ DO;
43 1 1 DML_SEQUENCE=2;
44 1 1 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (48)
,'EMPLOYEE '
,EMPLOYEE
45 1 1 ); END;
46 1 0 CALL IDMS_STATUS;
/*
BIND RECORD (DEPARTMENT); DMLP0003
*/
47 1 0 /* IDMS PL/I DML EXPANSION */ DO;
48 1 1 DML_SEQUENCE=3;
49 1 1 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (48)
,'DEPARTMENT '
,DEPARTMENT
50 1 1 ); END;
51 1 0 CALL IDMS_STATUS;
/*
READY; DMLP0004
*/
52 1 0 /* IDMS PL/I DML EXPANSION */ DO;
53 1 1 DML_SEQUENCE=4;
54 1 1 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (37)
55 1 1 ); END;
56 1 0 CALL IDMS_STATUS;
57 1 0 READ FILE (INFILE) INTO (DEPT_IN_REC);
58 1 0 DO WHILE ( EOF);
59 1 1 DB_END_OF_SET = NO;
60 1 1 DEPT_ID_0410 = DEPT_ID_IN;
/*
OBTAIN CALC RECORD (DEPARTMENT); DMLP0005
*/
61 1 1 /* IDMS PL/I DML EXPANSION */ DO;
62 1 2 DML_SEQUENCE=5;
63 1 2 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (32)
,'DEPARTMENT '
,IDBMSCOM (43)
64 1 2 ); END;
/* 0326 MEANS */
/* DEPT NOT FOUND */
65 1 1 IF ERROR_STATUS = '0326' THEN CALL NO_DEPT;
66 1 1 ELSE
DO;
/*
IF SET (DEPT_EMPLOYEE) EMPTY DMLP0006
*/
67 1 2 /* IDMS PL/I DML EXPANSION */ DO;
68 1 3 DML_SEQUENCE=6;
69 1 3 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (64)
,'DEPT-EMPLOYEE '
70 1 3 ); END;
71 1 2 IF ERROR_STATUS='0000'
THEN CALL NO_EMP;
72 1 2 ELSE
CALL NEW_DEPT;
73 1 2 DO UNTIL (DB_END_OF_SET);
/*
OBTAIN NEXT RECORD (EMPLOYEE) DMLP0007
SET (DEPT_EMPLOYEE);
*/
74 1 3 /* IDMS PL/I DML EXPANSION */ DO;
75 1 4 DML_SEQUENCE=7;
76 1 4 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (10)
,'EMPLOYEE '
,'DEPT-EMPLOYEE '
,IDBMSCOM (43)
77 1 4 ); END;
78 1 3 IF ERROR_STATUS = '0307' THEN
DB_END_OF_SET = YES;
79 1 3 ELSE
CALL IDMS_STATUS;
80 1 3 IF DB_END_OF_SET THEN
DO;
/* MOVE FIELDS TO */
/* OUTPUT RECORD */
81 1 4 DEPT_ID_OUT = DEPT_ID_0410;
82 1 4 EMP_ID_OUT = EMP_ID_0415;
83 1 4 EMP_LNAME_OUT = EMP_LAST_NAME_0415;
84 1 4 EMP_FNAME_OUT = EMP_FIRST_NAME_0415;
85 1 4 CC = DOUBLE_SPACE;
86 1 4 PRINT_LINE = SPACES;
87 1 4 PRINT_LINE = PRTREC;
88 1 4 CALL PRINT_A_LINE;
89 1 4 END; /* END PRINTING DO */
90 1 3 END; /* END DO UNTIL */
91 1 2 END; /* END 0326 ELSE DO */
92 1 1 READ FILE (INFILE) INTO (DEPT_IN_REC);
93 1 1 END; /* END DO WHILE EOF */
94 1 0 CALL END_PROCESSING;
95 1 0 NEW_DEPT: PROC;
96 2 0 PRINT_LINE = SPACES; /* NEW PAGE FOR EACH */
97 2 0 CC = NEW_PAGE; /* DEPARTMENT */
98 2 0 PRINT_LINE = DEPT_HEADER;
99 2 0 CALL PRINT_A_LINE;
100 2 0 PRINT_LINE = SPACES;
101 2 0 CC = DOUBLE_SPACE;
102 2 0 PRINT_LINE = DEPT_ID_0410;
103 2 0 CALL PRINT_A_LINE;
104 2 0 PRINT_LINE = SPACES;
105 2 0 CC = DOUBLE_SPACE;
106 2 0 PRINT_LINE = PRTHEAD;
107 2 0 CALL PRINT_A_LINE;
108 2 0 END NEW_DEPT;
109 1 0 NO_DEPT: PROC;
110 2 0 PRINT_LINE = SPACES;
111 2 0 CC = NEW_PAGE;
112 2 0 PRINT_LINE = DEPT_ID_IN;
113 2 0 CALL PRINT_A_LINE;
114 2 0 PRINT_LINE = SPACES;
115 2 0 CC = DOUBLE_SPACE;
116 2 0 PRINT_LINE = '** DEPARTMENT SPECIFIED ABOVE NOT FOUND **';
117 2 0 CALL PRINT_A_LINE;
118 2 0 END NO_DEPT;
119 1 0 NO_EMP: PROC;
120 2 0 PRINT_LINE = SPACES;
121 2 0 CC = NEW_PAGE;
122 2 0 PRINT_LINE = DEPT_ID_IN;
123 2 0 CALL PRINT_A_LINE;
124 2 0 PRINT_LINE = SPACES;
125 2 0 CC = DOUBLE_SPACE;
126 2 0 PRINT_LINE = DEPT_ID_0410;
127 2 0 CALL PRINT_A_LINE;
128 2 0 PRINT_LINE = SPACES;
129 2 0 CC = DOUBLE_SPACE;
130 2 0 PRINT_LINE = '** DEPARTMENT SPECIFIED IS EMPTY ***';
131 2 0 CALL PRINT_A_LINE;
132 2 0 END NO_EMP;
133 1 0 END_PROCESSING: PROC;
/*
FINISH; DMLP0008
*/
134 2 0 /* IDMS PL/I DML EXPANSION */ DO;
135 2 1 DML_SEQUENCE=8;
136 2 1 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (2)
137 2 1 ); END;
138 2 0 CLOSE FILE (INFILE);
139 2 0 CLOSE FILE (OUTFILE);
140 2 0 CLOSE FILE (SYSPRINT);
141 2 0 END END_PROCESSING;
142 1 0 PRINT_A_LINE: PROC;
143 2 0 WRITE FILE (OUTFILE) FROM (PRINT_AREA);
144 2 0 END PRINT_A_LINE;
INCLUDE IDMS (IDMS_STATUS);
*/
145 1 0 IDMS_STATUS: PROC;
/* THE IDMS_STATUS PROCEDURE IS CALLED BY THE USER AFTER */
/* EACH IDMS COMMAND HAS BEEN ISSUED AND CHECKS HAVE BEEN */
/* MADE FOR ANY EXPECTED NON-ZERO ERROR_STATUS CONDITIONS. */
/* IT DETECTS A NON-ZERO ERROR_STATUS AND ABNORMALLY */
/* TERMINATES THE PROGRAM ACCORDINGLY. */
146 2 0 DECLARE IDMSIN1 ENTRY OPTIONS(INTER,ASSEMBLER);
147 2 0 IF ERROR_STATUS='0000' THEN GOTO END_STATUS;
148 2 0 PUT SKIP EDIT ('PROGRAM NAME ──────', PROGRAM,
'ERROR STATUS ──────', ERROR_STATUS,
'ERROR RECORD ──────', ERROR_RECORD,
'ERROR SET ─────────', ERROR_SET,
'ERROR AREA ────────', ERROR_AREA,
'LAST GOOD RECORD ──', RECORD_NAME,
'LAST GOOD AREA ────', AREA_NAME)
(A(19),X(5),A(8),SKIP,A(19),X(5),A(4),
5(SKIP,A(19),X(5),A(16)));
149 2 0 SSC_IN01_REQ_CODE = 39;
150 2 0 SSC_IN01_REQ_RETURN = 0;
151 2 0 SSC_STATUS_LABEL = ' ';
152 2 0 DO UNTIL (SSC_IN01_REQ_RETURN > 0);
153 2 1 CALL IDMSIN1 (IDBMSCOM(41),
SSC_IN01_REQ_WK,
SUBSCHEMA_CTRL,
IDBMSCOM(1),
DML_SEQUENCE,
SSC_STATUS_LINE);
154 2 1 IF SSC_IN01_REQ_RETURN > 4 THEN
PUT SKIP EDIT ('DML SEQUENCE ------', DML_SEQUENCE)
(A(19),X(5),F(10));
156 2 1 ELSE
PUT SKIP EDIT (SSC_STATUS_LABEL, '---',
SSC_STATUS_VALUE)
(A(16),A(3),X(5),A(12));
158 2 1 END;
/*
ROLLBACK;
*/
159 2 0 /* IDMS PL/I DML EXPANSION */ DO;
160 2 1 DML_SEQUENCE=9;
161 2 1 CALL IDMS (SUBSCHEMA_CTRL
,IDBMSCOM (67)
162 2 1 ); END;
163 2 0 CALL ABORT;
164 2 0 END_STATUS: END;
165 1 0 END DEPTRPT;
|
Copyright © 2014 CA.
All rights reserved.
|
|