ポインターと API を使用してユーザー・スペースにアクセスする

次の例は、ポインターを使用してユーザー・スペースにアクセスし、レコードのチェーンを作成する方法を示します。

POINTA は、ユーザー・スペース中の得意先の名前 (CUSTOMER NAME) と所在地 (CUSTOMER ADDRESS) を読み取ってから、 情報をリスト表示するプログラムです。 このプログラムでは、POINTACU というファイルに得意先情報が入っているものとしています。

得意先アドレス・フィールドは可変長フィールドであり、長いアドレスが可能です。

図 82. ポインターを使用してユーザー・スペースにアクセスする例 - DDS
 ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8
      A* THIS IS THE CUSTOMER INFORMATION FILE  - POINTACUST
      A
      A
      A          R FSCUST                    TEXT('CUSTOMER MASTER RECORD')
      A            FS_CUST_NO     8S00       TEXT('CUSTOMER NUMBER')
      A                                      ALIAS(FS_CUST_NUMBER)
      A            FS_CUST_NM    20          TEXT('CUSTOMER NAME')
      A                                      ALIAS(FS_CUST_NAME)
      A            FS_CUST_AD   100          TEXT('CUSTOMER ADDRESS')
      A                                      ALIAS(FS_CUST_ADDRESS)
      A                                      VARLEN
図 83. ポインターを使用してユーザー・スペースにアクセスする例
 5722WDS V5R4M0  060210 LN  IBM ILE COBOL                 CBLGUIDE/POINTA          ISERIES1   06/02/15 13:43:25        ページ    2
                                     ソ ー ス
  STMT PL SEQNO  -A 1 B..+....2....+....3....+....4....+....5....+....6....+....7..IDENTFCN  S コピー名   変更日付
           000100 PROCESS varchar   1 
     1     000200 ID DIVISION.
           000300* このプログラムは、可変長レコードをユーザー・スペース
           000400*  に読み取ります。次に、ディスプレイ装置にレコードを
           000500*  表示します。
     2     000600 PROGRAM-ID. pointa.
     3     000700 ENVIRONMENT DIVISION.
     4     000800 CONFIGURATION SECTION.
     5     000900 SPECIAL-NAMES. CONSOLE IS CRT,
     7     001000                CRT STATUS IS ws-crt-status.   2 
     8     001100 INPUT-OUTPUT SECTION.
     9     001200 FILE-CONTROL.
    10     001300     SELECT cust-file ASSIGN TO DATABASE-pointacu
    12     001400            ORGANIZATION IS SEQUENTIAL
    13     001500            FILE STATUS IS ws-file-status.
    14     001600 DATA DIVISION.
    15     001700 FILE SECTION.
    16     001800 FD  cust-file.
    17     001900 01  fs-cust-record.
           002000* 下線をダッシュに変更し、別名を使用して、
           002100*  フィールド名にコピーします。
           002200 COPY DDR-ALL-FORMATS-I OF pointacu.
    18    +000001       05  POINTACU-RECORD PIC X(130).                                        <-ALL-FMTS
          +000002*    I-O FORMAT:FSCUST     FROM FILE POINTACU   OF LIBRARY CBLGUIDE           <-ALL-FMTS
          +000003*                          CUSTOMER MASTER RECORD                             <-ALL-FMTS
    19    +000004       05  FSCUST        REDEFINES POINTACU-RECORD.                           <-ALL-FMTS
    20    +000005           06 FS-CUST-NUMBER        PIC S9(8).                                <-ALL-FMTS
          +000006*                  CUSTOMER NUMBER                                            <-ALL-FMTS
    21    +000007           06 FS-CUST-NAME          PIC X(20).                                <-ALL-FMTS
          +000008*                  CUSTOMER NAME                                              <-ALL-FMTS
    22    +000009           06 FS-CUST-ADDRESS.   3                                            <-ALL-FMTS
          +000010*                  (可変長フィールド)                                         <-ALL-FMTS
    23    +000011                49 FS-CUST-ADDRESS-LENGTH                                     <-ALL-FMTS
          +000012                                    PIC S9(4) COMP-4.                         <-ALL-FMTS
    24    +000013                49 FS-CUST-ADDRESS-DATA                                       <-ALL-FMTS
          +000014                                    PIC X(100).                               <-ALL-FMTS
          +000015*                  CUSTOMER ADDRESS                                           <-ALL-FMTS
    25     002300 WORKING-STORAGE SECTION.
    26     002400 01  ws-file-status.
    27     002500     05 ws-file-status-1 PIC X.
    28     002600        88  ws-file-stat-good   VALUE "0".
    29     002700        88  ws-file-stat-at-end VALUE "1".
    30     002800     05 ws-file-status-2 PIC X.
    31     002900 01  ws-crt-status.   4 
    32     003000     05 ws-status-1           PIC 9(2).
    33     003100        88 ws-status-1-ok       VALUE 0.
    34     003200        88 ws-status-1-func-key VALUE 1.
    35     003300        88 ws-status-1-error    VALUE 9.
    36     003400     05 ws-status-2           PIC 9(2).
    37     003500        88 ws-func-03           VALUE 3.
    38     003600        88 ws-func-07           VALUE 7.
    39     003700        88 ws-func-08           VALUE 8.
    40     003800     05 ws-status-3           PIC 9(2).
 5722WDS V5R4M0  060210 LN  IBM ILE COBOL                CBLGUIDE/POINTA          ISERIES1   06/02/15 13:43:25        ページ    3
  STMT PL SEQNO  -A 1 B..+....2....+....3....+....4....+....5....+....6....+....7..IDENTFCN  S コピー名   変更日付
    41     003900 01  ws-params.   5 
    42     004000     05  ws-space-ptr         POINTER.   6 
    43     004100     05  ws-space.
    44     004200       10  ws-space-name      PIC X(10) VALUE "MYSPACE".
    45     004300       10  ws-space-lib       PIC X(10) VALUE "QTEMP".
    46     004400     05  ws-attr              PIC X(10) VALUE "PF".
    47     004500     05  ws-init-size         PIC S9(5) VALUE 32000 BINARY.
    48     004600     05  ws-init-char         PIC X     VALUE SPACE.
    49     004700     05  ws-auth              PIC X(10) VALUE "*ALL".
    50     004800     05  ws-text              PIC X(50) VALUE
           004900                              "Customer Information Records".
    51     005000     05  ws-replace           PIC X(10) VALUE "*YES".
    52     005100     05  ws-err-data.   7 
    53     005200         10 ws-input-l        PIC S9(6) BINARY VALUE 16.
    54     005300         10 ws-output-l       PIC S9(6) BINARY.
    55     005400         10 ws-exception-id   PIC X(7).
    56     005500         10 ws-reserved       PIC X(1).
           005600
    57     005700 77  ws-accept-data           PIC X   VALUE SPACE.
    58     005800   88 ws-acc-blank             VALUE SPACE.
    59     005900   88 ws-acc-create-space      VALUE "Y", "y".
    60     006000   88 ws-acc-use-prv-space     VALUE "N", "n".
    61     006100   88 ws-acc-delete-space      VALUE "Y", "y".
    62     006200   88 ws-acc-save-space        VALUE "N", "n".
           006300
    63     006400 77  ws-prog-indicator        PIC X   VALUE "G".
    64     006500   88  ws-prog-continue        VALUE "G".
    65     006600   88  ws-prog-end             VALUE "C".
    66     006700   88  ws-prog-loop            VALUE "L".
           006800
    67     006900 77  ws-line                  PIC 99.
           007000* エラー・メッセージ行
    68     007100 77  ws-error-msg             PIC X(50) VALUE SPACES.
           007200* それ以上のアドレス情報標識
    69     007300 77  ws-plus                  PIC X.
           007400* 表示するアドレス情報の長さ
    70     007500 77  ws-temp-size             PIC 9(2).
           007600
    71     007700 77  ws-current-rec           PIC S9(4) VALUE 1.
    72     007800 77  ws-old-rec               PIC S9(4) VALUE 1.
    73     007900 77  ws-old-space-ptr         POINTER.
           008000* 表示する最大行数
    74     008100 77  ws-displayed-lines       PIC S99 VALUE 20.
           008200* レコードの表示を開始する行
    75     008300 77  ws-start-line            PIC S99 VALUE 5.
           008400* スペースに新しいレコードを作成するための変数
    76     008500 77  ws-addr-inc              PIC S9(4) PACKED-DECIMAL.
    77     008600 77  ws-temp                  PIC S9(4) PACKED-DECIMAL.
    78     008700 77  ws-temp-2                PIC S9(4) PACKED-DECIMAL.
           008800* 直前のレコードへのポインター
    79     008900 77  ws-cust-prev-ptr         POINTER VALUE NULL.
    80     009000 LINKAGE SECTION.
    81     009100 01 ls-header-record.   8 
    82     009200    05  ls-hdr-cust-ptr             USAGE POINTER.
           009300* FROM ファイルから読み取るレコードの数
 5722WDS V5R4M0  060210 LN  IBM ILE COBOL                 CBLGUIDE/POINTA          ISERIES1   06/02/15 13:43:25        ページ    4
  STMT PL SEQNO  -A 1 B..+....2....+....3....+....4....+....5....+....6....+....7..IDENTFCN  S コピー名   変更日付
    83     009400    05  ls-record-counter           PIC S9(3) BINARY.
    84     009500    05  FILLER                      PIC X(14).   9 
    85     009600 01 ls-user-space.   10 
    86     009700     05  ls-customer-rec.
           009800* 直前の得意先レコードへのポインター
    87     009900         10 ls-cust-prev-ptr        USAGE POINTER.
    88     010000         10 ls-cust-rec-length      PIC S9(4) BINARY.
    89     010100         10 ls-cust-name            PIC X(20).
    90     010200         10 ls-cust-number          PIC S9(8).
           010300* 次レコードが 16 バイト境界になることを確実にするための、
           010400*  充てん文字を含めた、このレコードの全長
    91     010500         10 ls-cust-address-length  PIC S9(4) BINARY.
    92     010600     05  ls-cust-address-data       PIC X(116).
           010700
           010800* ls-user-space のサイズは実際に必要であるより 16 だけ大きい。
           010900* これにより、次レコードの開始アドレスが、
           011000* 宣言されたサイズを超えずに確立されるようになる。
           011100* サイズは、ポインター調整を可能にするため 16 だけ大きい。
           011200
    93     011300 PROCEDURE DIVISION.
           011400* PROC... DIV に "USING" 項目が必要でないことに注意。
    94     011500 DECLARATIVES.
           011600 cust-file-para SECTION.
           011700     USE AFTER ERROR PROCEDURE ON cust-file.
           011800 cust-file-para-2.
    95     011900     MOVE "Error XX on file pointacu" TO ws-error-msg.
    96     012000     MOVE ws-file-status TO ws-error-msg(7:2).
           012100 END DECLARATIVES.
           012200
           012300 main-program section.
           012400 mainline.
           012500* 入力データが訂正されるまで、初期画面の読み取りを続ける。
    97     012600     SET ws-prog-loop TO TRUE.
    98     012700     PERFORM initial-display THRU read-initial-display
           012800         UNTIL NOT ws-prog-loop.
           012900* プログラムを続行し、得意先情報域を作成したい
           013000* 場合は、スペースに、得意先ファイルからのレコード
           013100* を充てんする。
    99     013200     IF ws-prog-continue AND
           013300        ws-acc-create-space THEN
   100     013400       PERFORM read-customer-file
   101     013500       MOVE 1 TO ws-current-rec
           013600* ポインターをヘッダー・レコードに設定
   102     013700       SET ADDRESS OF ls-header-record TO ws-space-ptr
           013800* 最初の得意先レコードをスペースに設定
   103     013900       SET ADDRESS OF ls-user-space TO ls-hdr-cust-ptr
           014000     END-IF.
   104     014100     IF ws-prog-continue THEN
   105     014200       PERFORM main-loop UNTIL ws-prog-end
           014300     END-IF.
           014400 end-program.
   106     014500     PERFORM clean-up.
   107     014600     STOP RUN.
           014700
           014800 initial-display.   11 
 5722WDS V5R4M0  060210 LN  IBM ILE COBOL                 CBLGUIDE/POINTA          ISERIES1   06/02/15 13:43:25        ページ    5
  STMT PL SEQNO  -A 1 B..+....2....+....3....+....4....+....5....+....6....+....7..IDENTFCN  S コピー名   変更日付
   108     014900     DISPLAY "Create Customer Information Area" AT 0118 WITH
           015000                BLANK SCREEN REVERSE-VIDEO
           015100             "Create customer information area (Y/N)=>   <="
           015200                AT 1015
           015300             "F3=Exit" AT 2202.
   109     015400     IF ws-error-msg NOT = SPACES THEN
   110     015500       DISPLAY ws-error-msg at 2302 with beep highlight
   111     015600       MOVE SPACES TO ws-error-msg
           015700     END-IF.
           015800
           015800
   112     016000     ACCEPT ws-accept-data AT 1056 WITH REVERSE-VIDEO
           016100       ON EXCEPTION
   113     016200         IF ws-status-1-func-key THEN
   114     016300           IF ws-func-03 THEN
   115     016400             SET ws-prog-end TO TRUE
           016500           ELSE
   116     016600             MOVE "Invalid Function Key" TO ws-error-msg
           016700           END-IF
           016800         ELSE
   117     016900           MOVE "Unknown Error" TO ws-error-msg
           017000         END-IF
           017100       NOT ON EXCEPTION
   118     017200         IF ws-acc-create-space THEN
   119     017300           PERFORM create-space THRU set-space-ptrs
   120     017400           SET ws-prog-continue TO TRUE
           017500         ELSE
   121     017600           IF ws-acc-use-prv-space THEN
   122     017700             PERFORM get-space
   123     017800             IF ws-space-ptr = NULL
   124     017900               MOVE "No Customer Information Area" TO ws-error-msg
           018000             ELSE
   125     018100               PERFORM set-space-ptrs
   126     018200               SET ws-prog-continue TO TRUE
           018300             END-IF
           018400           ELSE
   127     018500             MOVE "Invalid Character Entered" TO ws-error-msg
           018600           END-IF
           018700         END-IF
           018800     END-ACCEPT.
           018900
           019000 create-space.
   128     019100     CALL "QUSCRTUS" USING ws-space, ws-attr, ws-init-size,   13 
           019200                           ws-init-char, ws-auth, ws-text,
           019300                           ws-replace, ws-err-data.
           019400
           019500* スペースを作成する際のエラーの検査をここで追加できる。
           019600
           019700 get-space.
   129     019800     CALL "QUSPTRUS" USING ws-space, ws-space-ptr, ws-err-data.   14 
           019900
           020000 set-space-ptrs.
           020100* スペースの先頭にヘッダー・レコードを設定
   130     020200     SET ADDRESS OF ls-header-record   15 
           020300         ADDRESS OF ls-user-space   16 
 5722WDS V5R4M0  060210 LN  IBM ILE COBOL                 CBLGUIDE/POINTA          ISERIES1   06/02/15 13:43:25        ページ    6
  STMT PL SEQNO  -A 1 B..+....2....+....3....+....4....+....5....+....6....+....7..IDENTFCN  S コピー名   変更日付
           020400         TO ws-space-ptr.
           020500* ヘッダー・レコードの後の最初の得意先レコードを設定
   131     020600     SET ADDRESS OF ls-user-space TO   17 
           020700         ADDRESS OF ls-user-space(LENGTH OF ls-header-record   18 
           020800                                  + 1:1).
           020900* 最初のレコードへのポインターをヘッダー・レコードに保管
   132     021000     SET ls-hdr-cust-ptr TO ADDRESS OF ls-user-space.
           021100
           021200 delete-space.
   133     021300     CALL "QUSDLTUS" USING ws-space, ws-err-data.   19 
           021400
           021500 read-customer-file.
           021600* 得意先ファイルから全レコードを読み取り、スペースに移動
   134     021700     OPEN INPUT cust-file.
   135     021800     IF ws-file-stat-good THEN
   136     021900       READ cust-file AT END CONTINUE
           022000       END-READ
   138     022100       PERFORM VARYING ls-record-counter FROM 1 BY 1
           022200             UNTIL not ws-file-stat-good
   139     022300         SET  ls-cust-prev-ptr  TO ws-cust-prev-ptr
           022400*  ファイルからの情報をスペースに移動
   140     022500         MOVE fs-cust-name      TO ls-cust-name
   141     022600         MOVE fs-cust-number    TO ls-cust-number
   142     022700         MOVE fs-cust-address-length  TO ls-cust-address-length
   143     022800         MOVE fs-cust-address-data(1:fs-cust-address-length)
           022900              TO ls-cust-address-data(1:ls-cust-address-length)
           023000*  現行レコードへのポインターを保管
   144     023100         SET  ws-cust-prev-ptr  TO ADDRESS OF ls-user-space
           023200*  次レコードが 16 バイト境界になるよう確認
   145     023300         ADD LENGTH OF ls-customer-rec   20 
           023400             ls-cust-address-length TO 1 GIVING ws-addr-inc
   146     023500         DIVIDE ws-addr-inc BY 16 GIVING ws-temp
           023600             REMAINDER ws-temp-2
   147     023700         SUBTRACT ws-temp-2 FROM 16 GIVING ws-temp
           023800*  合計レコード長をユーザー・スペースに保管
   148     023900         ADD ws-addr-inc TO ws-temp GIVING ls-cust-rec-length
   149     024000         SET ADDRESS OF ls-user-space
           024100          TO ADDRESS OF ls-user-space(ls-cust-rec-length + 1:1)
           024200*  ファイルから次レコードを読み取る           024100          TO ADDRESS OF ls-user-space(ls-cust-rec-length + 1:1)
   150     024300         READ cust-file AT END CONTINUE
           024400         END-READ
           024500       END-PERFORM
           024600*  ループの終わりでは、実際よりも 1 つだけレコード
           024700*  が多い
   152     024800       SUBTRACT 1 FROM ls-record-counter
           024900     END-IF.
   153     025000     CLOSE cust-file.
           025100
           025200 main-loop.   21 
           025300* F3 が入力されるまで、ディスプレイにレコードを表示する   153     025000     CLOSE cust-file.
   154     025400     DISPLAY "Customer Information" AT 0124 WITH
           025500                BLANK SCREEN REVERSE-VIDEO
           025600             "Cust     Customer Name        Customer"
           025700                AT 0305
           025800             " Address"
 5722WDS V5R4M0  060210 LN  IBM ILE COBOL                 CBLGUIDE/POINTA          ISERIES1   06/02/15 13:43:25        ページ    7
  STMT PL SEQNO  -A 1 B..+....2....+....3....+....4....+....5....+....6....+....7..IDENTFCN  S コピー名   変更日付
           025900             "Number"   AT 0405
           026000             "F3=Exit" AT 2202.
           026100* 保留中のエラーがあれば、ディスプレイに表示する
   155     026200     IF ws-error-msg NOT = SPACES THEN
   156     026300       DISPLAY ws-error-msg at 2302 with beep highlight
   157     026400       MOVE SPACES TO ws-error-msg
           026500     END-IF.
           026600* リストの中央であれば、F7 をディスプレイに表示する
   158     026700     IF ws-current-rec > 1 THEN   22 
   159     026800       DISPLAY "F7=Back" AT 2240
           026900     END-IF.
           027000* 現行レコードを保管
   160     027100     MOVE ws-current-rec TO ws-old-rec.
   161     027200     SET  ws-old-space-ptr TO ADDRESS OF ls-user-space.   23 
           027300* 各レコードをディスプレイに移動
   162     027400     PERFORM VARYING ws-line FROM  ws-start-line BY 1
           027500         UNTIL ws-line > ws-displayed-lines or
           027600               ws-current-rec > ls-record-counter
           027700* アドレスが表示幅より大きければ、"+" を表示する
   163     027800         IF ls-cust-address-length > 40 THEN
   164     027900           MOVE "+" TO ws-plus
   165     028000           MOVE 40 TO ws-temp-size
           028100         ELSE
   166     028200           MOVE ls-cust-address-length TO ws-temp-size
   167     028300           MOVE SPACE TO ws-plus
           028400         END-IF
   168     028500         DISPLAY ls-cust-number at line ws-line column 5
           028600                 ls-cust-name ls-cust-address-data with
           028700                   size ws-temp-size ws-plus at line
           028800                   ws-line column 78
           028900* 次レコードをスペースに読み取る
   169     029000         ADD 1 TO ws-current-rec
   170     029100         SET ADDRESS OF ls-user-space
           029200          TO ADDRESS OF ls-user-space
           029300            (ls-cust-rec-length + 1:1)
           029400     END-PERFORM.
           029500* 順方向に進むことができれば、F8 をディスプレイに表示する
   171     029600     IF ws-current-rec < ls-record-counter THEN   22 
   172     029700       DISPLAY "F8=Forward" AT 2250
           029800     END-IF.
           029900* 続行か、終了か、または次レコードか前レコード
           030000* を読み取るかを調べる。
   173     030100     SET ws-acc-blank to TRUE.
   174     030200     ACCEPT ws-accept-data WITH SECURE   24 
           030300       ON EXCEPTION
   175     030400         IF ws-status-1-func-key THEN
   176     030500           IF ws-func-03 THEN
   177     030600             SET ws-prog-end TO TRUE
           030700           ELSE
   178     030800            IF ws-func-07 THEN
   179     030900             PERFORM back-screen
           031000            ELSE
   180     031100            IF ws-func-08 THEN
   181     031200             PERFORM forward-screen
           031300            ELSE
 5722WDS V5R4M0  060210 LN  IBM ILE COBOL                 CBLGUIDE/POINTA          ISERIES1   06/02/15 13:43:25        ページ    8
  STMT PL SEQNO  -A 1 B..+....2....+....3....+....4....+....5....+....6....+....7..IDENTFCN  S コピー名   変更日付
   182     031400             MOVE "Invalid Function Key" TO ws-error-msg
   183     031500             MOVE ws-old-rec TO ws-current-rec
   184     031600             SET ADDRESS OF ls-user-space TO ws-old-space-ptr
           031700            END-IF
           031800           END-IF
           031900         ELSE
   185     032000           MOVE "Unknown Error" TO ws-error-msg
   186     032100           MOVE ws-old-rec TO ws-current-rec
   187     032200           SET ADDRESS OF ls-user-space TO ws-old-space-ptr
           032300         END-IF
           032400       NOT ON EXCEPTION
   188     032500         MOVE ws-old-rec TO ws-current-rec
   189     032600         SET ADDRESS OF ls-user-space TO ws-old-space-ptr
           032700     END-ACCEPT.
           032800
           032900 clean-up.
           033000* プログラムに対する終結処理を実行。
           033100* 入力データが訂正されるまで、初期画面の読み取りを続ける。
   190     033200     SET ws-prog-loop to TRUE.
   191     033300     SET ws-acc-blank to TRUE.
   192     033400     PERFORM final-display THRU read-final-display   25 
           033500         UNTIL NOT ws-prog-loop.
           033600
           033700 final-display.
   193     033800     DISPLAY "Delete Customer Information Area" AT 0118 WITH   26 
           033900                BLANK SCREEN REVERSE-VIDEO
           034000             "Delete customer information area (Y/N)=>   <="
           034100                AT 1015
           034200             "F3=Exit" AT 2202.
   194     034300     IF ws-error-msg NOT = SPACES THEN
   195     034400       DISPLAY ws-error-msg at 2302 with beep highlight
   196     034500       MOVE SPACES TO ws-error-msg
           034600     END-IF.
           034700
           034800 read-final-display.
   197     034900     ACCEPT ws-accept-data AT 1056 WITH REVERSE-VIDEO
           035000       ON EXCEPTION
   198     035100         IF ws-status-1-func-key THEN
   199     035200           IF ws-func-03 THEN
   200     035300             SET ws-prog-end TO TRUE
           035400           ELSE
   201     035500             MOVE "Invalid Function Key" TO ws-error-msg
           035600           END-IF
           035700         ELSE
   202     035800           MOVE "Unknown Error" TO ws-error-msg
           035900         END-IF
           036000       NOT ON EXCEPTION
   203     036100         IF ws-acc-delete-space THEN
   204     036200           PERFORM delete-space
   205     036300           SET ws-prog-continue TO TRUE
           036400         ELSE
   206     036500           IF ws-acc-save-space THEN
   207     036600             SET ws-prog-continue TO TRUE
           036700           ELSE
   208     036800             MOVE "Invalid Character Entered" TO ws-error-msg
 5722WDS V5R4M0  060210 LN  IBM ILE COBOL                 CBLGUIDE/POINTA          ISERIES1   06/02/15 13:43:25        ページ    9
  STMT PL SEQNO  -A 1 B..+....2....+....3....+....4....+....5....+....6....+....7..IDENTFCN  S コピー名   変更日付
           036900           END-IF
           037000         END-IF
           037100     END-ACCEPT.
           037200
           037300 back-screen.   27 
   209     037400     IF ws-old-rec <= 1 THEN
   210     037500       MOVE "Top of customer records" TO ws-error-msg
   211     037600       MOVE ws-old-rec TO ws-current-rec   28 
   212     037700       SET ADDRESS OF ls-user-space TO ws-old-space-ptr
           037800     ELSE
   213     037900       MOVE ws-old-rec TO ws-current-rec   28 
   214     038000       SET ADDRESS OF ls-user-space TO ws-old-space-ptr
   215     038100       PERFORM VARYING ws-line FROM ws-start-line BY 1
           038200         UNTIL ws-line > ws-displayed-lines or
           038300               ws-current-rec <= 1
           038400* 一度に 1 レコードずつ逆方向に移動
   216     038500         SET ws-cust-prev-ptr TO ls-cust-prev-ptr   29 
   217     038600         SET ADDRESS OF ls-user-space TO ws-cust-prev-ptr
   218     038700         SUBTRACT 1 FROM ws-current-rec
           038800       END-PERFORM
           038900     END-IF.
           039000
           039100 forward-screen.   30 
           039200* 現行レコードが最大レコード数以上であれば、
           039300* 最大レコード数に達した旨のエラーを印刷する。
   219     039400     IF ws-current-rec >= ls-record-counter
   220     039500       MOVE "No more customer records" TO ws-error-msg
   221     039600       MOVE ws-old-rec TO ws-current-rec
   222     039700       SET ADDRESS OF ls-user-space TO ws-old-space-ptr
           039800     ELSE
   223     039900       MOVE ws-current-rec TO ws-old-rec
   224     040000       SET ws-old-space-ptr TO ADDRESS OF ls-user-space
           040100     END-IF.
           040200
                           * * * * *   ソ ー ス 仕 様 の 終 わ り   * * * * *
 2 
CRT STATUS IS は、拡張 ACCEPT ステートメントの終了後に状況値を入れる場所のデータ名を指定します。 この例では、STATUS キー値を使用して、押されたファンクション・キーを判別します。
 3 
fs-cust-address は可変長フィールドです。 ここで FILLER 以外の意味がある名前を参照するには、 1  のように、CRTCBLMOD コマンドまたは CRTBNDCBL コマンドの CVTOPT パラメーターに *VARCHAR を指定するか、 または PROCESS ステートメントに VARCHAR を指定してください。 可変長フィールドの詳細については SAA データ・タイプを使用したデータ項目の宣言を参照してください。
 4 
 2  で言及されている CRT STATUS は、ここで定義されます。
 5 
ws-params 構造には、API を呼び出してユーザー・スペースにアクセスする際に使用するパラメーターが入れられます。
 6 
ws-space-ptr は、API QUSPTRUS で設定されるポインター・データ項目を定義します。 これはユーザー・スペースの先頭を指し、LINKAGE SECTION の中で項目のアドレスを設定するために使用します。
 7 
ws-err-data は、ユーザー・スペース API のエラー・パラメーターの構造です。 ws-input-l はゼロですが、これによってすべての例外はプログラムに通知され、 エラー・コード・パラメーターでは渡されないことに注意してください。 エラー・コード・パラメーターの詳細については、 Web サイト http://www.ibm.com/eserver/iseries/infocenter にある iSeries Information Center の 「プログラミング」カテゴリーの中の『CL および API』セクションを参照してください。
 8 
ユーザー・スペース中に定義される最初のデータ構造 (ls-header-record)。
 9 
FILLER は、Is-header-record の長さは 16 バイトの倍数にすることによってポインター位置合わせを維持するのに使用されています。
 10 
ユーザー・スペース中に定義される 2 番目のデータ構造 (ls-user-space)。
 11 
initial-display によって、「Create Customer Information Area」画面が表示されます。
 12 
read-initial-display は最初の表示画面を読み取って、 ユーザーが継続を選択したかそれともプログラム終了を選択したかを判別します。 実行キーを押してプログラムを継続すると、プログラムは ws-accept-data を調べて、 得意先情報域 (Customer Information Area) を作成するのかどうかを調べます。
 13 
QUSCRTUS はユーザー・スペースを作成するために使用する API です。
 14 
QUSPTRUS は、ユーザー・スペースの先頭へのポインターを戻すために使用する API です。
 15 
最初のデータ構造 (ls-header-record) をユーザー・スペースの先頭にマッピングします。
 16 
2 番目のデータ構造 (ls-user-space) をユーザー・スペースの先頭にマッピングします。
 17 
ADDRESS OF 特殊レジスターを使用します。
 18 
ADDRESS OF が参照変更されているので、ADDRESS OF 特殊レジスターではなく ADDRESS OF を使用します。
 19 
QUSDLTUS はユーザー・スペースを削除するために使用する API です。
 20 
この後にある 4 つの算術ステートメントは、各レコードの全長を計算し、 各レコードの長さが必ず 16 バイトの倍数になるようにします。
 21 
main-loop は、「Customer Information」画面を表示します。
 22 
これらのステートメントは、プログラムがファンクション・キー F7 および F8 を表示する必要があるかどうかを判別するためのものです。
 23 
画面上の最初の得意先レコードへのポインターを保管します。
 24 
この ACCEPT ステートメントは、「Customer Information」画面からの入力を待ちます。 押されるファンクション・キーに基づいて、 該当する段落を呼び出して次のレコード集合 (forward-screen) または直前のレコード集合 (back-screen) を表示するか、 または F3 が押された場合はルーチンを終了するための標識を設定します。
 25 
終結ルーチンは、該当するキーが押されるまで、「Delete Customer Information Area」画面を表示します。
 26 
このステートメントは、「Delete Customer Information Area」画面を表示します。
 27 
各レコードには、直前の得意先レコードを指すポインターが入れられます。 ADDRESS OF 特殊レジスターは、現行の得意先レコードを指します。 ADDRESS OF 特殊レジスターを変更すると、現行の得意先レコードが変更されます。

back-screen は、現行のレコード・ポインターを一度に 1 レコードずつ逆方向に移動します。 29  これは、現行の得意先レコード (ADDRESS OF) を指すポインターに直前の得意先レコードへのポインターを移動することによって行います。 一度に 1 レコードずつ逆方向に移動する前に、 まずプログラムは現行の得意先レコードを現在表示されている最初のレコードに設定します。 28 

 30 
forward-screenws-old-space-ptr (表示画面上の最初のレコードを指している) を、 現行レコード (表示されている最後のレコードの後) を指すように設定します。

ユーザー・スペースは常に 16 バイト境界で始まるので、ここに示されている方法では、すべてのレコードが必ず位置合わせされます。 また、レコードのチェーンの作成に ls-cust-rec-length も使用されます。

POINTA を実行すると、次の画面が表示されます。

 CMDSTR                          開始コマンド 

次の1つを選んでください。

   コマンド 
      1. DNS QUERY の開始                                           NSLOOKUP                                          NSLOOKUP
      2. QSH の開始                                                 QSH
      3. RPC BIND プログラム・デーモンの開始                        RPCBIND

      6. エージェント・サービスの開始                              STRAGTSRV
      7. 拡張印刷機能開始                                          STRAPF
      8. BRM を使用したアーカイブ開始                               STRARCBRM
      9. ASP バランス化開始                                         STRASPBAL

     11. BRM を使用したバックアップ開始                             STRBKUBRM
     12. COBOL デバッグ開始                                         STRCBLDBG
     13. CGU 開始                                                   STRCGU
                                                                       続く ...
 選択またはコマンド 
 ===> CALL POINTA

 F3= 終了   F4= プロンプト   F9=コマンドの複写   F12= 取り消し
 F16= メジャー・メニュー
 (C) COPYRIGHT IBM CORP. 1980, 2005.

                   Create Customer Information Area



               Create customer information area (Y/N)=> y <=











F3=Exit

                      Customer Information
  Cust     Customer Name        Customer  Address
  Number
  00000001 Bakery Unlimited     30 Bake Way, North York
  00000002 Window World         150 Eglinton Ave E., North York, Ontario
  00000003 Jons Clothes         101 Park St, North Bay, Ontario, Canada
  00000004 Pizza World          254 Main Street, Toronto, Ontario          +
  00000005 Marv's Auto Body     9 George St, Peterborough, Ontario, Cana   +
  00000006 Jack's Snacks        23 North St, Timmins, Ontario, Canada
  00000007 Video World          14 Robson St, Vancouver, B.C, Canada
  00000008 Pat's Daycare        8 Kingston Rd, Pickering, Ontario, Canad   +
  00000009 Mary's Pies          3 Front St, Toronto, Ontario, Canada
  00000010 Carol's Fashions     19 Spark St, Ottawa, Ontario, Canada
  00000011 Grey Optical         5 Lundy's Lane, Niagara Falls, Ont. Cana   +
  00000012 Fred's Forage        33 Dufferin St, Toronto, Ontario, Canada   +
  00000013 Dave's Trucking      15 Water St, Guelph, Ontario, Canada
  00000014 Doug's Music         101 Queen St. Toronto, Ontario, Canada     +
  00000015 Anytime Copiers      300 Warden Ave, Scarborough, Ontario, Ca   +
  00000016 Rosa's Ribs          440 Avenue Rd, Toronto, Ontario, Canada
F3=Exit                                         F8=Forward

                      Customer Information
  Cust     Customer Name        Customer  Address
  Number
  00000017 Picture It           33 Kingston Rd, Ajax, Ontario, Canada
  00000018 Paula's Flowers      144 Pape Ave, Toronto, Ontario, Canada
  00000019 Mom's Diapers        101 Ford St, Toronto, Ontario, Canada
  00000020 Chez Francois        1202 Rue Ste Anne, Montreal, PQ, Canada
  00000021 Vetements de Louise  892 Rue Sherbrooke, Montreal E, PQ, Cana   +
  00000022 Good Eats            355 Lake St, Port Hope, Ontario, Canada







F3=Exit                               F7=Back

                      Customer Information
  Cust     Customer Name        Customer  Address
  Number
  00000001 Bakery Unlimited     30 Bake Way, North York
  00000002 Window World         150 Eglinton Ave E., North York, Ontario
  00000003 Jons Clothes         101 Park St, North Bay, Ontario, Canada
  00000004 Pizza World          254 Main Street, Toronto, Ontario          +
  00000005 Marv's Auto Body     9 George St, Peterborough, Ontario, Cana   +
  00000006 Jack's Snacks        23 North St, Timmins, Ontario, Canada
  00000007 Video World          14 Robson St, Vancouver, B.C, Canada
  00000008 Pat's Daycare        8 Kingston Rd, Pickering, Ontario, Canad   +
  00000009 Mary's Pies          3 Front St, Toronto, Ontario, Canada
  00000010 Carol's Fashions     19 Spark St, Ottawa, Ontario, Canada
  00000011 Grey Optical         5 Lundy's Lane, Niagara Falls, Ont. Cana   +
  00000012 Fred's Forage        33 Dufferin St, Toronto, Ontario, Canada   +
  00000013 Dave's Trucking      15 Water St, Guelph, Ontario, Canada
  00000014 Doug's Music         101 Queen St. Toronto, Ontario, Canada     +
  00000015 Anytime Copiers      300 Warden Ave, Scarborough, Ontario, Ca   +
  00000016 Rosa's Ribs          440 Avenue Rd, Toronto, Ontario, Canada
F3=Exit                                         F8=Forward

                        Delete Customer Information Area



                   Delete customer information area (Y/N)=> y <=











F3=Exit

 CMDSTR                          開始コマンド

 次の1つを選んでください。

   コマンド
      1. DNS QUERY の開始                                           NSLOOKUP
      2. QSH の開始                                                 QSH
      3. RPC BIND プログラム・デーモンの開始                        RPCBIND

      6. エージェント・サービスの開始                              STRAGTSRV
      7. 拡張印刷機能開始                                          STRAPF
      8. BRM を使用したアーカイブ開始                               STRARCBRM
      9. ASP バランス化開始                                         STRASPBAL

     11. BRM を使用したバックアップ開始                             STRBKUBRM
     12. COBOL デバッグ開始                                         STRCBLDBG
     13. CGU 開始                                                   STRCGU
                                                                       続く ...
 選択またはコマンド
 ===> ENDCPYSCN

 F3= 終了   F4= プロンプト   F9=コマンドの複写   F12= 取り消し
 F16= メジャー・メニュー
 (C) COPYRIGHT IBM CORP. 1980, 2005.