home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l360 / 3.ddi / CALC.@BL / CALC.CBL
Encoding:
Text File  |  1991-04-17  |  8.5 KB  |  176 lines
  1.       $SET WARNING(3) NOOSVS ANS85 mf
  2.        SPECIAL-NAMES.
  3.            crt status is key-status.
  4.        WORKING-STORAGE SECTION.
  5.        78  Return-key                      value X"3030".
  6.        78  Equals-key                      value X"333D".
  7.        01  key-status.
  8.            03  key-type                    pic x.
  9.                88  function-key            value "1".
  10.                88  data-key                value "3".
  11.            03  key-code-1                  pic 99  comp-x.
  12.            03  key-code-1-x redefines
  13.                key-code-1                  pic x.
  14.                88  Operator-entered        value "*" "-" "/" "+".
  15.                88  CLear-key               value "C" "c".
  16.            03  key-code-2                  pic x.
  17.        01  redefines key-status.
  18.            03                              pic xx.
  19.                88  escape-key-pressed      value X"3100".
  20.       * Answer needed "=" or <CR>
  21.                88  answer-needed           value Return-key Equals-key.
  22.            03                              pic x.
  23.        01  set-bit-pairs                   pic 99  comp-x  value 1.
  24.        01  data-key-control.
  25.            03  data-key-setting            pic 99  comp-x.
  26.                88  key-is-disabled                         value zero.
  27.                88  act-as-a-function-key   value 1.
  28.                88  character-into-field    value 2.
  29.            03                              pic x  value "3".
  30.            03  first-data-key              pic x.
  31.            03  number-of-data-keys         pic 99  comp-x  value 1.
  32.        01  user-key-control.
  33.            03  User-key-setting            pic 99  comp-x  value 1.
  34.            03                              pic x           value "1".
  35.            03  first-user-key              pic 99  comp-x  value 0.
  36.            03  number-of-keys              pic 99  comp-x  value 1.
  37.        78  No-of-data-keys                 value 7.
  38.        01  keys-to-enable                  pic x(no-of-data-keys)
  39.            value "/*-+Cc=".
  40.        01  redefines keys-to-enable.
  41.            03  key-to-enable occurs no-of-data-keys times
  42.                indexed by key-enable-index pic x.
  43.        01  Entered-Value                   PIC S9(11)V9(7) BINARY.
  44.        01  Saved-Value                     PIC S9(11)V9(7) BINARY.
  45.        01  saved-operator                  pic x.
  46.        01  is-there-a-key-waiting          pic x   comp-x.
  47.            88  no-key-waiting              value zero.
  48.            88  key-waiting                 value 1 thru 255.
  49.        01                                  pic 99  comp-x.
  50.            88  calculation-ok              value zero.
  51.            88  numeric-overflow            value 1.
  52.        SCREEN SECTION.
  53.        01  Calculator-screen.
  54.            05  BLANK SCREEN.
  55.            05  LINE 1  COL 1 VALUE "╔══════════════════════════╗".
  56.            05  LINE 2  COL 1 VALUE "║ ╔══════════════════════╗ ║".
  57.            05  LINE 3  COL 1 VALUE "║ ║                      ║ ║".
  58.            05  LINE 4  COL 1 VALUE "║ ╚══════════════════════╝ ║".
  59.            05  LINE 5  COL 1 VALUE "║   ┌───┐┌───┐┌───┐┌───┐   ║".
  60.            05  LINE 6  COL 1 VALUE "║   │   ││   ││   ││   │   ║".
  61.            05  LINE 7  COL 1 VALUE "║   └───┘└───┘└───┘└───┘   ║".
  62.            05  LINE 8  COL 1 VALUE "║   ┌───┐┌───┐┌───┐┌───┐   ║".
  63.            05  LINE 9  COL 1 VALUE "║   │   ││   ││   ││   │   ║".
  64.            05  LINE 10 COL 1 VALUE "║   └───┘└───┘└───┘│   │   ║".
  65.            05  LINE 11 COL 1 VALUE "║   ┌───┐┌───┐┌───┐│   │   ║".
  66.            05  LINE 12 COL 1 VALUE "║   │   ││   ││   ││   │   ║".
  67.            05  LINE 13 COL 1 VALUE "║   └───┘└───┘└───┘└───┘   ║".
  68.            05  LINE 14 COL 1 VALUE "║   ┌───┐┌───┐┌───┐┌───┐   ║".
  69.            05  LINE 15 COL 1 VALUE "║   │   ││   ││   ││   │   ║".
  70.            05  LINE 16 COL 1 VALUE "║   └───┘└───┘└───┘│   │   ║".
  71.            05  LINE 17 COL 1 VALUE "║   ┌────────┐┌───┐│   │   ║".
  72.            05  LINE 18 COL 1 VALUE "║   │        ││   ││   │   ║".
  73.            05  LINE 19 COL 1 VALUE "║   └────────┘└───┘└───┘   ║".
  74.            05  LINE 20 COL 1 VALUE "╚══════════════════════════╝".
  75.            05 HIGHLIGHT.
  76.                10  entry-field.
  77.                    15  LINE 3  COL 5 PIC -(11)9.9(7)
  78.                        USING Entered-Value PROMPT spaces.
  79.                10 LINE 6  COL 7  VALUE "C".
  80.                10         COL 12 VALUE "/".
  81.                10         COL 17 VALUE "*".
  82.                10         COL 22 VALUE "-".
  83.                10 LINE 9  COL 7  VALUE "7".
  84.                10         COL 12 VALUE "8".
  85.                10         COL 17 VALUE "9".
  86.                10 LINE 10 COL 22 VALUE "+".
  87.                10 LINE 12 COL 7  VALUE "4".
  88.                10         COL 12 VALUE "8".
  89.                10         COL 17 VALUE "6".
  90.                10 LINE 15 COL 7  VALUE "1".
  91.                10         COL 12 VALUE "2".
  92.                10         COL 17 VALUE "3".
  93.                10 LINE 16 COL 22 VALUE "=".
  94.                10 LINE 18 COL 9  VALUE "0".
  95.                10         COL 17 VALUE ".".
  96.        PROCEDURE DIVISION.
  97.        main-1.
  98.            perform initialization-routines
  99.            DISPLAY Calculator-screen
  100.            perform with test after until escape-key-pressed
  101.                if operator-entered or numeric-overflow
  102.       *    Position the cursor at the first integer position of the
  103.       *    entry field which waiting for a character to be pressed
  104.                    if numeric-overflow
  105.                        display low-values at 0321
  106.                    else
  107.                        display low-values at 0316
  108.                    end-if
  109.       *    Leave the previous value in th field until a value is
  110.       *    entered
  111.                    set no-key-waiting to true
  112.                    perform with test after until key-waiting
  113.                        call X"D9" using is-there-a-key-waiting
  114.                    end-perform
  115.                    move zero to entered-value
  116.                end-if
  117.                display Entry-field
  118.                ACCEPT Calculator-screen
  119.                if data-key or answer-needed
  120.                    perform data-key-terminated-accept
  121.                end-if
  122.            end-perform
  123.            exit program
  124.            STOP RUN.
  125.        data-key-terminated-accept.
  126.            evaluate true
  127.                when Operator-entered
  128.                    if saved-operator not = spaces
  129.                        perform calculate-answer
  130.       *    Display current intermediate result  whilst waiting for next
  131.       *    keystoke which will require the field to be cleared
  132.                        display Entry-field
  133.                    end-if
  134.                    move key-code-1-x to saved-operator
  135.                    move entered-value to saved-value
  136.                when CLear-key
  137.                    move zero to entered-value saved-value
  138.                    move spaces to saved-operator
  139.                when answer-needed
  140.                    perform calculate-answer
  141.                    move spaces to saved-operator
  142.            end-evaluate.
  143.        calculate-answer.
  144.            set calculation-ok to true
  145.            evaluate saved-operator
  146.                when "*"
  147.                    compute entered-value = saved-value * entered-value
  148.                        on size error perform size-error-action
  149.                when "-"
  150.                    compute entered-value = saved-value - entered-value
  151.                        on size error perform size-error-action
  152.                when "+"
  153.                    compute entered-value = saved-value + entered-value
  154.                        on size error perform size-error-action
  155.                when "/"
  156.                    compute entered-value = saved-value / entered-value
  157.                        on size error perform size-error-action
  158.            end-evaluate.
  159.        size-error-action.
  160.            move zero to entered-value saved-value
  161.            move spaces to saved-operator
  162.            display "Numeric Overflow    " at 0305 with highlight
  163.            set numeric-overflow to true.
  164.        initialization-routines.
  165.       *    activate "*" "/" "-" "+" "C" "c" and "="
  166.       *    to terminate an accept.
  167.            set act-as-a-function-key to true
  168.            perform varying key-enable-index from 1 by 1
  169.                    until key-enable-index > No-of-data-keys
  170.                move key-to-enable(key-enable-index) to first-data-key
  171.                call X"AF" using set-bit-pairs data-key-control
  172.            end-perform
  173.            move zero to entered-value saved-value
  174.       *    Enable function key zero - The Escape key.
  175.            call X"AF" using set-bit-pairs user-key-control.
  176.