旧 PL/I コンパイラーによって課せられた、フェッチされたモジュールの制限は、 ほぼすべて除去されました。 したがって、FETCH されたモジュールは次のことが行えます。
しかし、フェッチの対象である Enterprise PL/I モジュールに対するいくつかの 制限があります。 それらは次のとおりです。
NORENT WRITABLE コードは逐次使用可能です。そのため、FFETCHABLE 定数を示すために使用されるポインターは、 すべての NORENT WRITABLE ルーチンのプロローグ・コードで、ゼロにリセットされます。 これによって、コードが正しい PL/I セマンティクスも提供しながら逐次再使用可能になることが保証されますが、 NORENT WRITABLE コードにおいて TITLE を指定した FETCH の使用に制限が課されます。 この制限によって、FETCH A TITLE('B') を行ったルーチンでは、終了して再入した場合、 CALL A ステートメントを実行する前に FETCH A TITLE('B') を再実行する必要があります (そうしなければ、CALL の実行前に暗黙の (TITLE のない) A の FETCH が実行されます)。
これらの制限を説明するために、コンパイラー・ユーザー出口 を考えてみます。 EXIT コンパイル時オプションを指定すると、コンパイラーは IBMUEXIT とい う名前の Enterprise PL/I モジュールをフェッチして呼び出します。
まず、RENT オプションを指定してコンパイラー・ユーザー出口を コンパイルする必要があるので注意してください。 コンパイラーは、このユーザー出口が DLL であることを前提としているからです。
上の項目 1 により、このルーチンに関するコンパイラーの PROCEDURE ステートメント は次のようになります。
ibmuexit:
proc ( addr_Userexit_Interface_Block,
addr_Request_Area )
options( fetchable );
dcl addr_Userexit_Interface_Block pointer byvalue;
dcl addr_Request_Area pointer byvalue;
上の項目 3 により、ユーザー出口を DLL にリンクするときに、 リンカー・オプション DYNAM=DLL を指定する必要があります。 DLL は、PDSE または一時データ・セットのどちらかにリンクする 必要があります (一次データ・セットにリンクする場合は、DSNTYPE=LIBRARY を SYSLMOD DD ステートメントに指定する必要があります)。
ユーザー出口のコンパイル、リンク、および呼び出しを行うため の JCL ステートメントはすべて、図 16 の JCL に示されています。 下記のサンプル・コードでは、フェッチされたユーザー出口は 構造体を指す 2 つの BYVALUE ポインターを受け取らず、代わりに 2 つの構造体 BYADDR を 受け取ります。これが上のコード抜粋との大きな相違です。 この変更を有効にするために、コードではその PROCEDURE ステートメントの それぞれに OPTIONS(NODESCRIPTOR) を指定しています。
//*
//*********************************************************************
//* compile the user exit
//*********************************************************************
//PLIEXIT EXEC PGM=IBMZPLI,
// REGION=256K
//STEPLIB DD DSN=IBMZ.V3R8M0.SIBMZCMP,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSLIN DD DSN=&&LOADSET,DISP=(MOD,PASS),UNIT=SYSSQ,
// SPACE=(CYL,(3,1))
//SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,
// SPACE=(1024,(200,50),,CONTIG,ROUND),DCB=BLKSIZE=1024
//SYSIN DD *
*Process or('|') not('!');
*Process limits(extname(31));
/********************************************************************/
/* */
/* NAME - IBMUEXIT.PLI */
/* */
/* DESCRIPTION */
/* User-exit sample program. */
/* */
/* Licensed Materials - Property of IBM */
/* 5639-A83, 5639-A24 (C) Copyright IBM Corp. 1992,2008. */
/* All Rights Reserved. */
/* US Government Users Restricted Rights-- Use, duplication or */
/* disclosure restricted by GSA ADP Schedule Contract with */
/* IBM Corp. */
/* */
/* DISCLAIMER OF WARRANTIES */
/* The following "enclosed" code is sample code created by IBM */
/* Corporation. This sample code is not part of any standard */
/* IBM product and is provided to you solely for the purpose of */
/* assisting you in the development of your applications. The */
/* code is provided "AS IS", without warranty of any kind. */
/* IBM shall not be liable for any damages arising out of your */
/* use of the sample code, even if IBM has been advised of the */
/* possibility of such damages. */
/* */
/********************************************************************/
/********************************************************************/
/* */
/* During initialization, IBMUEXIT is called. It reads */
/* information about the messages being screened from a text */
/* file and stores the information in a hash table. IBMUEXIT */
/* also sets up the entry points for the message filter service */
/* and termination service. */
/* */
/* For each message generated by the compiler, the compiler */
/* calls the message filter registered by IBMUEXIT. The filter */
/* looks the message up in the hash table previously created. */
/* */
/* The termination service is called at the end of the compile */
/* but does nothing. It could be enhanced to generates reports */
/* or do other cleanup work. */
/* */
/********************************************************************/
pack: package exports(*);
Dcl
1 Uex_UIB native Based( null() ),
2 Uex_UIB_Length fixed bin(31),
2 Uex_UIB_Exit_token pointer, /* for user exit's use*/
2 Uex_UIB_User_char_str pointer, /* to exit option str */
2 Uex_UIB_User_char_len fixed bin(31),
2 Uex_UIB_Filename_str pointer, /* to source filename */
2 Uex_UIB_Filename_len fixed bin(31),
2 Uex_UIB_return_code fixed bin(31), /* set by exit procs */
2 Uex_UIB_reason_code fixed bin(31), /* set by exit procs */
2 Uex_UIB_Exit_Routs, /* exit entries setat
initialization */
3 ( Uex_UIB_Termination,
Uex_UIB_Message_Filter, /* call for each msg */
*, *, *, * )
limited entry (
*, /* to Uex_UIB */
* /* to a request area */
);
/*******************************************************************/
/* */
/* Request Area for Initialization exit */
/* */
/*******************************************************************/
Dcl 1 Uex_ISA native based( null() ),
2 Uex_ISA_Length fixed bin(31);
/*******************************************************************/
/* */
/* Request Area for Message_Filter exit */
/* */
/*******************************************************************/
Dcl 1 Uex_MFA native based( null() ),
2 Uex_MFA_Length fixed bin(31),
2 Uex_MFA_Facility_Id char(3),
2 * char(1),
2 Uex_MFA_Message_no fixed bin(31),
2 Uex_MFA_Severity fixed bin(15),
2 Uex_MFA_New_Severity fixed bin(15); /* set by exit proc */
/*******************************************************************/
/* */
/* Request Area for Terminate exit */
/* */
/*******************************************************************/
Dcl 1 Uex_TSA native based( null() ),
2 Uex_TSA_Length fixed bin(31);
/*******************************************************************/
/* */
/* Severity Codes */
/* */
/*******************************************************************/
dcl uex_Severity_Normal fixed bin(15) value(0);
dcl uex_Severity_Warning fixed bin(15) value(4);
dcl uex_Severity_Error fixed bin(15) value(8);
dcl uex_Severity_Severe fixed bin(15) value(12);
dcl uex_Severity_Unrecoverable fixed bin(15) value(16);
/*******************************************************************/
/* */
/* Return Codes */
/* */
/*******************************************************************/
dcl uex_Return_Normal fixed bin(15) value(0);
dcl uex_Return_Warning fixed bin(15) value(4);
dcl uex_Return_Error fixed bin(15) value(8);
dcl uex_Return_Severe fixed bin(15) value(12);
dcl uex_Return_Unrecoverable fixed bin(15) value(16);
/*******************************************************************/
/* */
/* Reason Codes */
/* */
/*******************************************************************/
dcl uex_Reason_Output fixed bin(15) value(0);
dcl uex_Reason_Suppress fixed bin(15) value(1);
dcl hashsize fixed bin(15) value(97);
dcl hashtable(0:hashsize-1) ptr init((hashsize) null());
dcl 1 message_item native based,
2 message_Info,
3 facid char(3),
3 msgno fixed bin(31),
3 newsev fixed bin(15),
3 reason fixed bin(31),
2 link pointer;
ibmuexit: proc ( ue, ia )
options( fetchable nodescriptor );
dcl 1 ue like uex_Uib byaddr;
dcl 1 ia like uex_Isa byaddr;
dcl sysuexit file stream input env(recsize(80));
dcl p pointer;
dcl bucket fixed bin(31);
dcl based_Chars char(8) based;
dcl title_Str char(8) var;
ue.uex_Uib_Message_Filter = message_Filter;
ue.uex_Uib_Termination = exitterm;
on undefinedfile(sysuexit)
begin;
put edit ('** User exit unable to open exit file ')
(A) skip;
put skip;
signal error;
end;
if ue.uex_Uib_User_Char_Len = 0 then
do;
open file(sysuexit);
end;
else
do;
title_Str
= substr( ue.uex_Uib_User_Char_Str->based_Chars,
1, ue.uex_Uib_User_Char_Len );
open file(sysuexit) title(title_Str);
end;
on error, endfile(sysuexit)
goto done;
allocate message_item set(p);
/***************************************************************/
/* */
/* Skip header lines and read first data line */
/* */
/***************************************************************/
get file(sysuexit) list(p->message_info) skip(3);
do loop;
/*************************************************************/
/* */
/* Put message information in hash table */
/* */
/*************************************************************/
bucket = mod(p->msgno, hashsize);
p->link = hashtable(bucket);
hashtable(bucket) = p;
/*************************************************************/
/* */
/* Read next data line */
/* */
/*************************************************************/
allocate message_item set(p);
get file(sysuexit) skip;
get file(sysuexit) list(p->message_info);
end;
/***************************************************************/
/* */
/* Clean up */
/* */
/***************************************************************/
done:
free p->message_Item;
close file(sysuexit);
end;
message_Filter:
proc ( ue, mf )
options( nodescriptor );
dcl 1 ue like uex_Uib byaddr;
dcl 1 mf like uex_Mfa byaddr;
dcl p pointer;
dcl bucket fixed bin(15);
on error snap system;
ue.uex_Uib_Reason_Code = uex_Reason_Output;
ue.uex_Uib_Return_Code = 0;
mf.uex_Mfa_New_Severity = mf.uex_Mfa_Severity;
/***************************************************************/
/* */
/* Calculate bucket for error message */
/* */
/***************************************************************/
bucket = mod(mf.uex_Mfa_Message_No, hashsize);
/***************************************************************/
/* */
/* Search bucket for error message */
/* */
/***************************************************************/
do p = hashtable(bucket) repeat (p->link) while(p!=null())
until (p->msgno = mf.uex_Mfa_Message_No &
p->facid = mf.Uex_Mfa_Facility_Id);
end;
if p = null() then;
else
do;
/***********************************************************/
/* */
/* Filter error based on information in has table */
/* */
/***********************************************************/
ue.uex_Uib_Reason_Code = p->reason;
if p->newsev < 0 then;
else
mf.uex_Mfa_New_Severity = p->newsev;
end;
end;
exitterm:
proc ( ue, ta )
options( nodescriptor );
dcl 1 ue like uex_Uib byaddr;
dcl 1 ta like uex_Tsa byaddr;
ue.uex_Uib_return_Code = 0;
ue.uex_Uib_reason_Code = 0;
end;
end pack;
//*********************************************************************
//* link the user exit
//*********************************************************************
//LKEDEXIT EXEC PGM=IEWL,PARM='XREF,LIST,LET,DYNAM=DLL',
// COND=(9,LT,PLIEXIT),REGION=5000K
//SYSLIB DD DSN=CEE.SCEELKED,DISP=SHR
//SYSLMOD DD DSN=&&EXITLIB(IBMUEXIT),DISP=(NEW,PASS),UNIT=SYSDA,
// SPACE=(TRK,(7,1,1)),DSNTYPE=LIBRARY
//SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(CYL,(3,1)),
// DCB=BLKSIZE=1024
//SYSPRINT DD SYSOUT=X
//SYSDEFSD DD DUMMY
//SYSLIN DD DSN=&&LOADSET,DISP=SHR
// DD DDNAME=SYSIN
//LKED.SYSIN DD *
ENTRY IBMUEXIT
//*********************************************************************
//* compile main
//*********************************************************************
//PLI EXEC PGM=IBMZPLI,PARM='F(I),EXIT',
// REGION=256K
//STEPLIB DD DSN=&&EXITLIB,DISP=SHR
// DD DSN=IBMZ.V3R8M0.SIBMZCMP,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSLIN DD DSN=&&LOADSET2,DISP=(MOD,PASS),UNIT=SYSSQ,
// SPACE=(CYL,(3,1))
//SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,
// SPACE=(1024,(200,50),,CONTIG,ROUND),DCB=BLKSIZE=1024
//SYSIN DD *
*process;
MainFet: Proc Options(Main);
/* the exit will suppress the message for the next dcl */
dcl one_byte_integer fixed bin(7);
End ;
//*
//SYSUEXIT DD *
Fac Id Msg No Severity Suppress Comment
+--------+--------+----------+----------+-------------------------------
'IBM' 1042 -1 1 String spans multiple lines
'IBM' 1044 -1 1 FIXED BIN 7 mapped to 1 byte