ILE RPG で関数ポインタ

同じ名前の関数に、状況に応じて違うふるまいをさせることができます。

たとえば↓のような、ファイル名をわたして CLRPFM をやってくれる/RGZPFM をやってくれるサブプロシージャが入っているサービスプログラムがあるとしましょう。

どちらも引数はファイル名だけになっていますので、メインプログラムには共通のいわばダミーのような関数を定義し、同じソースのままで、状況に応じて CLRPFM をやってもらったり RGZPFM をやってもらったりすることが可能です。

オブジェクト指向で、クラスによって同じシグニチャのメソッドの処理内容が変わることと似てますね。
実際、ある処理だけを部品的に入れ替えしてるようなイメージで、他の処理は完全に共通化できるような場合にはたいへん有用な機能だと思います。

     H NOMAIN                                                                                       
      * グローバル定義                                                                                     
     D PSDS           SDS                                                                           
     D   CPFMSG                       7a   OVERLAY(PSDS:40)                                         
      *                                                                                             
     D QCMDEXC         PR                  EXTPGM('QCMDEXC')                                        
     D  cmdString                  1000    CONST                                                    
     D                                     Options(*varsize)                                        
     D  cmdLen                       15p 5 CONST                                                    
      * 呼び出しプロシージャ定義                                                                                
     D CLRPFM          PR                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      *                                                                                             
     D RGZPFM          PR                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      *                                                                                             
      * プロシージャ(CLRPFM)処理内容                                                                                
     P CLRPFM          B                   export                                                   
     D CLRPFM          PI                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      *                                                                                             
     D cmdstr          S           1024a                                                            
      *                                                                                             
      /free                                                                                         
               cmdstr = 'CLRPFM FILE(' + %trimR(file) + ')';                                        
                                                                                                    
               monitor;                                                                             
                    QCMDEXC(cmdstr:%len(cmdstr));                                                   
               on-error;                                                                            
                    if (CPFMSG <> *BLANKS);                                                         
                     select ;                                                                       
                     when (CPFMSG = 'CPF3142');                                                     
                       dsply 'NOT EXIST';                                                           
                     when (CPFMSG = 'CPF3156');                                                     
                       dsply 'IN USE';                                                              
                     other;                                                                         
                       dsply ('error ' + CPFMSG);                                                   
                     endsl;                                                                         
                     endif;                                                                         
                endmon;                                                                             
                                                                                                    
      /end-free                                                                                     
     P CLRPFM          E                                                                            
      *                                                                                             
      * プロシージャ(RGZPFM)処理内容                                                                                
     P RGZPFM          B                   export                                                   
     D RGZPFM          PI                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
     D cmdstr          S           1024a                                                            
      /free                                                                                         
               cmdstr = 'RGZPFM FILE(' + %trimR(file) + ')';                                        
                                                                                                    
               monitor;                                                                             
                    QCMDEXC(cmdstr:%len(cmdstr));                                                   
               on-error;                                                                            
                    if (CPFMSG <> *BLANKS);                                                         
                     select ;                                                                       
                     when (CPFMSG = 'CPF2991');                                                     
                       dsply 'NOT EXIST';                                                           
                     when (CPFMSG = 'CPF3135');                                                     
                       dsply 'IN USE';                                                              
                     other;                                                                         
                       dsply ('error ' + CPFMSG);                                                   
                     endsl;                                                                         
                     endif;                                                                         
                endmon;                                                                             
                                                                                                    
      /end-free                                                                                     
     P RGZPFM          E

↑は、以下のように、まず最初にモジュールを作成し、サービスプログラムとしてコンパイルします。

CRTRPGMOD MODULE(APITEST/COMMANDS) SRCFILE(APITEST/QRPGLESRC)
CRTSRVPGM SRVPGM(APITEST/COMMANDS) MODULE(APITEST/COMMANDS) EXPORT(*ALL)

そのサービスプログラムを利用して、条件に応じて処理を変更できるようにするやりかたのサンプルを書いてみました。


関数ポインタの使い方

サービスプログラム側にあるプロシージャのポインタを取得して実行させるわけですから、同じシグニチャのサブプロシージャ定義が必要になります。通常は /COPY を使うと思いますが、わかりやすくするためにここでは定義しています。

     D CLRPFM          PR                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      *                                                                                             
     D RGZPFM          PR                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)      

ProcessFile というプロシージャにファイル名を引数としてわたして実行すると、条件に応じて↑のどちらかのサブプロシージャが実行される、というようになっています。

     D processFp       S               *   Procptr                                                  
      *                                                                                             
     D ProcessFile     PR                  extproc(processFP)                                       
     D  file                         10a

%PADDR でプロシージャのポインタアドレスを取得し、procptr として定義したポインタ変数に格納します。
そして、そのポインタ変数を extproc として定義したプロシージャを実行すると、実際には %PADDR で引数にとったプロシージャが実行される、という仕組みになっています。

               processFp = %PADDR(RGZPFM);                                                     
                                                                                                    
               ProcessFile(file);     

extproc で指定されたプロシージャは D 仕様書での PR の定義はありますが、P 仕様書での実際の定義はありません。実体がないから、ですね。

プログラム全文

↓が全文になります。

     D ProcPtr         PR                                                                           
     D  AC                            1a   CONST                                                    
     D  file                         10a   CONST                                                    
      *                                                                                             
     D ProcPtr         PI                                                                           
     D  pAC                           1a   CONST                                                    
     D  pFile                        10a   CONST                                                    
      *                                                                                             
      * 呼び出しプロシージャ定義                                                                                
     D CLRPFM          PR                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      *                                                                                             
     D RGZPFM          PR                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      *                                                                                             
      * メインルーチン用定義                                                                                  
     D ProcessFile     PR                  extproc(processFP)                                       
     D  file                         10a                                                            
      *                                                                                             
     D processFp       S               *   Procptr                                                  
      *                                                                                             
     D ActionCode      S              1a                                                            
     D file            S             10a                                                            
      *                                                                                             
      /free                                                                                         
                                                                                                    
               ActionCode = pAC;                                                                    
               file = %trimR(pFile);                                                                
                                                                                                    
               select;                                                                              
                 When ActionCode='C';                                                               
                    processFp = %PADDR(CLRPFM);                                                     
                 When ActionCode='R';                                                               
                    processFp = %PADDR(RGZPFM);                                                     
               endSl;                                                                               
                                                                                                    
               ProcessFile(file);                                                                   
                                                                                                    
               *inLR = *on ;                                                                        
                    return ;                                                                        
                                                                                                    
      /end-free

CRTRPGMOD コマンドでモジュールを作成し、

CRTRPGMOD MODULE(APITEST/PROCPTR) SRCFILE(APITEST/QRPGLESRC)

一番最初に紹介したサービスプログラムとともにプログラムにします。

CRTPGM PGM(APITEST/PROCPTEST) MODULE(APITEST/PROCPTR) BNDSRVPGM(APITEST/COMMANDS)

だいたいこんなかんじです。

サービスプログラムを使わない場合

また、以下のようにひとつの大きなソースで書くことも可能です。人工的かつ冗長なので、まぁ、一応載せておくだけですが ......

CRTBNDRPG PGM(APITEST/PROCPTR) SRCFILE(APITEST/QRPGLESRC)
     H DFTACTGRP(*NO)                                                                               
      *                                                                                             
     D ProcPtest       PR                                                                           
     D  AC                            1a   CONST                                                    
     D  file                         10a   CONST                                                    
      *                                                                                             
     D ProcPtest       PI                                                                           
     D  pAC                           1a   CONST                                                    
     D  pFile                        10a   CONST                                                    
      *                                                                                             
      * グローバル定義                                                                                     
     D PSDS           SDS                                                                           
     D   CPFMSG                       7a   OVERLAY(PSDS:40)                                         
      *                                                                                             
     D QCMDEXC         PR                  EXTPGM('QCMDEXC')                                        
     D  cmdString                  1000    CONST                                                    
     D                                     Options(*varsize)                                        
     D  cmdLen                       15p 5 CONST                                                    
      *                                                                                             
      * 呼び出しプロシージャ定義                                                                                
     D CLRPFM          PR                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      *                                                                                             
     D RGZPFM          PR                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      *                                                                                             
      * メインルーチン用定義                                                                                  
     D ProcessFile     PR                  ExtProc(processFp)                                       
     D  file                         10a                                                            
     D processFp       S               *   Procptr                                                  
      *                                                                                             
     D ActionCode      S              1a                                                            
     D file            S             10a                                                            
      *                                                                                             
      /free                                                                                         
                                                                                                    
          ActionCode = pAC;                                                                         
          file = %trimR(pFile);                                                                     
                                                                                                    
          select;                                                                                   
            When ActionCode='C';                                                                    
               processFp = %PADDR(CLRPFM);                                                          
            When ActionCode='R';                                                                    
               processFp = %PADDR(RGZPFM);                                                          
          endSl;                                                                                    
                                                                                                    
          ProcessFile(file);                                                                        
                                                                                                    
          *inLR = *on ;                                                                         
          return ;                                                                              
                                                                                                    
      /end-free                                                                                     
      *                                                                                             
      * ローカルプロシージャ定義                                                                                
     P CLRPFM          B                                                                            
     D CLRPFM          PI                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      * ローカル変数定義                                                                                     
     D cmdstr          S           1024a                                                            
      /free                                                                                         
          cmdstr = 'CLRPFM FILE(' + %trimR(file) + ')';                                             
                                                                                                    
          monitor;                                                                                  
               QCMDEXC(cmdstr:%len(cmdstr));                                                        
          on-error;                                                                                 
               if (CPFMSG <> *BLANKS);                                                              
                select ;                                                                            
                when (CPFMSG = 'CPF3142');                                                          
                  dsply 'NOT EXIST';                                                                
                when (CPFMSG = 'CPF3156');                                                          
                  dsply 'IN USE';                                                                   
                other;                                                                              
                  dsply ('error ' + CPFMSG);                                                        
                endsl;                                                                              
                endif;                                                                              
          endmon;                                                                                   
                                                                                                    
      /end-free                                                                                     
      *                                                                                             
      * ローカルプロシージャ定義                                                                                
     P CLRPFM          E                                                                            
      *                                                                                             
     P RGZPFM          B                                                                            
     D RGZPFM          PI                                                                           
     D  file                         10a   CONST                                                    
     D                                     Options(*varsize)                                        
      * ローカル変数定義                                                                                     
     D cmdstr          S           1024a                                                            
      /free                                                                                         
          cmdstr = 'RGZPFM FILE(' + %trimR(file) + ')';                                             
                                                                                                    
          monitor;                                                                                  
               QCMDEXC(cmdstr:%len(cmdstr));                                                        
          on-error;                                                                                 
               if (CPFMSG <> *BLANKS);                                                              
                select ;                                                                            
                when (CPFMSG = 'CPF2991');                                                          
                  dsply 'NOT EXIST';                                                                
                when (CPFMSG = 'CPF3135');                                                          
                  dsply 'IN USE';                                                                   
                other;                                                                              
                  dsply ('error ' + CPFMSG);                                                        
                endsl;                                                                              
                endif;                                                                              
          endmon;                                                                                   
                                                                                                    
      /end-free                                                                                     
     P RGZPFM          E

実行例

実行例です。

qsort

C の標準関数でソートを行うための関数である qsort でも、実際に比較を行うための関数は関数ポインタを引数としてわたすような仕様になっています。

ちょうど「Sort Arrays in both Ascending and Descending Order」に例があり、実行してみたのでついでに載せておきます。解説は←のサイトに行ってみてください。

     H DFTACTGRP(*NO) BNDDIR('QC2LE')                                                               
                                                                                                    
     D qsortTest       PR                                                                           
     D    action                      2                                                             
                                                                                                    
     D qsortTest       PI                                                                           
     D    action                      2                                                             
                                                                                                    
     D QSORT           PR                  ExtProc('qsort')                                         
     D   base                              likeds(PhoneNo_t) dim(300)                               
     D   numToSort                   10I 0 value                                                    
     D   sizeElem                    10I 0 value                                                    
     D   compare                       *   procptr value                                            
                                                                                                    
     D AscendExt       PR            10I 0                                                          
     D    Elem1                            likeds(PhoneNo_t)                                        
     D    Elem2                            likeds(PhoneNo_t)                                        
                                                                                                    
     D DescendExt      PR            10I 0                                                          
     D    Elem1                            likeds(PhoneNo_t)                                        
     D    Elem2                            likeds(PhoneNo_t)                                        
                                                                                                    
     D DescendName     PR            10I 0                                                          
     D    Elem1                            likeds(PhoneNo_t)                                        
     D    Elem2                            likeds(PhoneNo_t)                                        
                                                                                                    
     D NameWithinExt   PR            10I 0                                                          
     D    Elem1                            likeds(PhoneNo_t)                                        
     D    Elem2                            likeds(PhoneNo_t)                                        
                                                                                                    
     D PhoneNo_t       ds                  qualified                                                
     D   Ext                          4A                                                            
     D                                1A                                                            
     D   Empl                        30A                                                            
                                                                                                    
     D List            ds                  likeds(PhoneNo_t)                                        
     D                                     dim(300)                                                 
                                                                                                    
     D x               s             10I 0                                                          
     D total           s             10I 0                                                          
                                                                                                    
      /free                                                                                         
                                                                                                    
         // **********************************                                                      
         //   Load some values into array                                                           
         // **********************************                                                      
                                                                                                    
         x = 1;                                                                                     
         List(x).Ext  = '6292';                                                                     
         List(x).Empl = 'Klement, Scott';                                                           
                                                                                                    
         x = x + 1;                                                                                 
         List(x).Ext  = '6291';                                                                     
         List(x).Empl = 'Bizub, James';                                                             
                                                                                                    
         x = x + 1;                                                                                 
         List(x).Ext  = '6280';                                                                     
         List(x).Empl = 'Lewis, Doug';                                                              
                                                                                                    
         x = x + 1;                                                                                 
         List(x).Ext  = '6230';                                                                     
         List(x).Empl = 'Klement, Anna';                                                            
                                                                                                    
         x = x + 1;                                                                                 
         List(x).Ext  = '6209';                                                                     
         List(x).Empl = 'Michuda, Mike';                                                            
                                                                                                    
         x = x + 1;                                                                                 
         List(x).Ext  = '6272';                                                                     
         List(x).Empl = 'Vogl, Jackie';                                                             
                                                                                                    
         x = x + 1;                                                                                 
         List(x).Ext  = '6272';                                                                     
         List(x).Empl = 'Dobs, Marion';                                                             
                                                                                                    
         x = x + 1;                                                                                 
         List(x).Ext  = '6272';                                                                     
         List(x).Empl = 'Mahan, Stacy';                                                             
                                                                                                    
         total = x;                                                                                 
                                                                                                    
         // **********************************                                                      
         //   Run QSORT.  QSORT calls my                                                            
         //   "Compare" subprocedure to                                                             
         //   compare each element                                                                  
         // **********************************                                                      
                                                                                                    
         select;                                                                                    
         when action = 'A';                                                                         
           qsort(List: Total: %size(PhoneNo_t): %paddr(AscendExt));                                 
           dsply 'Sorted by Extension - Ascend';                                                    
         when action = 'D';                                                                         
           qsort(List: Total: %size(PhoneNo_t): %paddr(DescendExt));                                
           dsply 'Sorted by Extension - Descend';                                                   
         when action = 'DN';                                                                        
           qsort(List: Total: %size(PhoneNo_t): %paddr(DescendName));                               
           dsply 'Sorted by Extension - DescendName';                                               
         when action = 'NE';                                                                        
           qsort(List: Total: %size(PhoneNo_t): %paddr(NameWithinExt));                             
           dsply 'Sorted by Extension - NameWithinExt';                                             
         other;                                                                                     
           dsply 'No such Option!!';                                                                
           *inlr = *on;                                                                             
           return;                                                                                  
         endsl;                                                                                     
                                                                                                    
         for x = 1 to total;                                                                        
            dsply List(x);                                                                          
         endfor;                                                                                    
                                                                                                    
         *inlr = *on;                                                                               
                                                                                                    
      /end-free                                                                                     
                                                                                                    
     P AscendExt       B                                                                            
     D AscendExt       PI            10I 0                                                          
     D    Elem1                            likeds(PhoneNo_t)                                        
     D    Elem2                            likeds(PhoneNo_t)                                        
      /free                                                                                         
           select;                                                                                  
           when Elem1.Ext < Elem2.Ext;                                                              
              return -1;                                                                            
           when Elem1.Ext > Elem2.Ext;                                                              
              return 1;                                                                             
           other;                                                                                   
              return 0;                                                                             
           endsl;                                                                                   
      /end-free                                                                                     
     P                 E                                                                            
                                                                                                    
     P DescendExt      B                                                                            
     D DescendExt      PI            10I 0                                                          
     D    Elem1                            likeds(PhoneNo_t)                                        
     D    Elem2                            likeds(PhoneNo_t)                                        
      /free                                                                                         
           select;                                                                                  
           when Elem1.Ext < Elem2.Ext;                                                              
              return 1;                                                                             
           when Elem1.Ext > Elem2.Ext;                                                              
              return -1;                                                                            
           other;                                                                                   
              return 0;                                                                             
           endsl;                                                                                   
      /end-free                                                                                     
     P                 E                                                                            
                                                                                                    
     P DescendName     B                                                                            
     D DescendName     PI            10I 0                                                          
     D    Elem1                            likeds(PhoneNo_t)                                        
     D    Elem2                            likeds(PhoneNo_t)                                        
      /free                                                                                         
           select;                                                                                  
           when Elem1.Empl < Elem2.Empl;                                                            
              return 1;                                                                             
           when Elem1.Empl > Elem2.Empl;                                                            
              return -1;                                                                            
           other;                                                                                   
              return 0;                                                                             
           endsl;                                                                                   
      /end-free                                                                                     
     P                 E                                                                            
                                                                                                    
     P NameWithinExt   B                                                                            
     D NameWithinExt   PI            10I 0                                                          
     D    Elem1                            likeds(PhoneNo_t)                                        
     D    Elem2                            likeds(PhoneNo_t)                                        
      /free                                                                                         
           select;                                                                                  
           when Elem1.Ext < Elem2.Ext;                                                              
              return -1;                                                                            
           when Elem1.Ext > Elem2.Ext;                                                              
              return 1;                                                                             
           when Elem1.Empl < Elem2.Empl;                                                            
              return 1;                                                                             
           when Elem1.Empl > Elem2.Empl;                                                            
              return -1;                                                                            
           other;                                                                                   
              return 0;                                                                             
           endsl;                                                                                   
      /end-free                                                                                     
     P                 E

[Top Pageに戻る]

Ads by TOK2