Example - the preprox.cbl Program

$set ans85
      ****************************************************************
      * Copyright Micro Focus Limited 1986-94. All Rights Reserved.  *
      * This demonstration program is provided for use by users of   *
      * Micro Focus products and may be used, modified and           *
      * distributed as part of your application provided that you    *
      * properly acknowledge the copyright of Micro Focus in this    *
      * material.                                                    *
      ****************************************************************


      /*****************************************************************
      *                                                                *
      *  Beginning of the example Integrated Pre-Processor             *
      *                                                                *
      ******************************************************************

       identification division.
           program-id.    integrated-preprocessor2.
           author.        Micro Focus.
           date-written.  8 August 1986.
           date-compiled. 8 August 1986.
           security.      Copyright protection.

       environment division.
           configuration section.
           source-computer. ibm-pc.
           object-computer. ibm-pc.

       special-names.
           command-line is cmd-line.

       select main-file assign main-file-name
            organization line sequential
            status is file-stat.

       select copy-file assign copy-file-name
           organization line sequential
           status is file-stat.

       select trace-file assign "trace.cbl"
            organization line sequential
            status is file-stat.

       select console-file assign ":CO:"
           organization line sequential
           status is file-stat.

       select dir-file assign dir-file-name
           organization line sequential
           status is file-stat.

       file section.

       fd main-file.
       01  main-rec.
          02 filler pic x(80).

       fd copy-file.
       01  copy-rec.
          02 filler pic x(80).

       fd trace-file.
       01  trace-rec.
          02 filler pic x(80).

       fd console-file.
       01  console-rec.
          02 filler pic x(80).

       fd dir-file.
       01  dir-rec.
          02 filler pic x(80).
      /
       working-storage section.

       01  file-stat.
           02 stat-1           pic 9.
           02 stat-2           pic 9.

       77  token-pos           pic 9(2)    comp-x.
       77  unfinished-action   pic 9(2)    comp-x.
       77  separate-verbs      pic 9(2)   comp-x.
       77  copy-file-active    pic 9(2)    comp-x.
       77  input-empty         pic 9(2)    comp-x.
       77  output-ready        pic 9(2)    comp-x.
       77  input-to-return     pic 9(2)    comp-x.
       77  edit-active         pic 9(2)    comp-x.
       77  edit-to-return      pic 9(2)    comp-x.
       77  overflow-active     pic 9(2)    comp-x.
       77  prep-active         pic 9(2)    comp-x.

       77  token               pic 9(2)    comp-x.
       77  token-delimit       pic 9(2)    comp-x.
       77  char                pic 9(2)    comp-x.
       77  pp                  pic 9(2)    comp-x.
       77  temp                pic 9(2)    comp-x.
       77  temp-2              pic 9(2)    comp-x.
       77  temp-X              pic X.
       77  error-message-text  pic x(40)   value
                                     "Pre-Processor Syntax in error".

       01  input-buffer.
           02  input-byte          pic 9(2)    comp-x      occurs 80.
           02  input-layout redefines input-byte.
               03  filler          pic x(6).
               03  in-col-7        pic 9(2)    comp-x.
               03  filler          pic x(65).
               03  in-col-73       pic 9(2)    comp-x.
               03  filler          pic x(7).
       01  input-flags.
           02  in-col-5            pic 9(2)    comp-x.
           02  in-col-6            pic 9(2)    comp-x.
       77  input-count             pic 9(2)    comp-x.

       01  output-buffer.
           02  output-byte         pic 9(2)    comp-x      occurs 80.
           02  output-layout redefines output-byte.
               03   filler         pic x(6).
               03   out-col-7-80   pic x(74).
       01  output-flags.
           02  out-col-5           pic 9(2)    comp-x.
           02  out-col-6           pic 9(2)    comp-x.
       77  output-count            pic 9(2)    comp-x.

       01  overflow-buffer.
           02  overflow-byte       pic 9(2)    comp-x      occurs 80.
           02  overflow-msg redefines overflow-byte.
               03  msg-number      pic x(7).
               03  filler          pic x(73).
       01  overflow-flags.
           02  over-col-5          pic 9(2)    comp-x.
           02  over-col-6          pic 9(2)    comp-x.
       77  overflow-count          pic 9(2)    comp-x.

       01  cmdline                 pic x(80).

       01  next-prep               pic x(8).

       01  lex-buffer.
           02  lex-byte            pic 9(2)    comp-x      occurs 80.
           02  lex-layout redefines lex-byte.
               03  lex-1-30        pic X(30).
               03  filler          pic X(50).
       77  lex-count               pic 9(2)    comp-x.
       77  saved-lex-1-30          pic x(30).
      /
       78  do-copy                                value  1.
       78  do-error                               value  2.

       78  val-A                                  value  H"41".
       78  val-Z                                  value  H"5A".
       78  val-a-lc                               value  H"61".
       78  val-z-lc                               value  H"7A".
       78  val-lc-to-UC                           value  H"20".
       78  val-zero                               value  H"30".
       78  val-nine                               value  H"39".
       78  val-space                              value  H"20".
       78  val-file-slash                         VALUE  H"5C".

       78  val-eor                                value  H"FF".
       78  val-eoc                                value  H"FE".
       78  val-eof                                value  H"FD".
       78  val-eol                                value  H"7F".
       78  val-period                             value  H"2E".
       78  val-plus                               value  H"2B".
       78  val-minus                              value  H"2D".
       78  val-quote                              value  H"22".
       78  val-apostrophe                         value  H"27".
       78  val-mult                               value  H"2A".
       78  val-asterisk                           value  H"2A".
       78  val-div                                value  H"2F".
       78  val-slash                              value  H"2F".
       78  val-lbkt                               value  H"28".
       78  val-rbkt                               value  H"29".
       78  val-equal                              value  H"3D".
       78  val-gt                                 value  H"3E".
       78  val-lt                                 value  H"3C".
       78  val-semi                               value  H"3B".
       78  val-comma                              value  H"2C".

       78  tok-word                               value  1.
       78  tok-numb                               value  2.
       78  tok-eor                                value  3.
       78  tok-eoc                                value  4.
       78  tok-eof                                value  5.
       78  tok-period                             value  6.
       78  tok-plus                               value  7.
       78  tok-minus                              value  8.
       78  tok-an-lit                             value  9.
       78  tok-mult                               value  10.
       78  tok-div                                value  11.
       78  tok-lbkt                               value  12.
       78  tok-rbkt                               value  13.
       78  tok-equal                              value  14.
       78  tok-gt                                 value  15.
       78  tok-lt                                 value  16.
       78  tok-ge                                 value  17.
       78  tok-le                                 value  18.
       78  tok-error                              value  19.

       78  val-false                              value  0.
       78  val-true                               value  1.

       78  sound-beep                             value X"E5".
       78  keybd-read                             value X"83".

      /*****************************************************************
      *                                                                *
      * when trace-flag = val-true then TRACE.CBL is created as a trace*
      * file, to contain a copy of buffer for every return from the    *
      * pre-processor to the compiler ... a useful debugging aide.     *
      *                                                                *
      ******************************************************************


       77  trace-flag              pic 9(2)    comp-x  value val-false.

       linkage section.

       01  mode-flag               pic 9(2)    comp-x.
       01  buffer                  pic x(80).
       01  response.
           03  response-status     pic 9(2)    comp-x.
           03  response-code-1     pic 9(4)    comp-x.
           03  filler redefines response-code-1.
               05  filler          pic x.
               05  resp-main       pic 9(2)    comp-x.
           03  response-code-2     pic 9(4)    comp-x.
           03  filler redefines response-code-2.
               05  filler          pic x.
               05  resp-more       pic 9(2)    comp-x.


      /*****************************************************************
      *                                                                *
      * Procedure Division.                                            *
      *                                                                *
      ******************************************************************

       procedure division using mode-flag, buffer, response.

       start-para section.
           move 0 to response-status
           if mode-flag = 0
               move val-false to prep-active
               accept input-buffer from cmd-line
               if input-buffer not = spaces
                   perform analyse-command-line
               else
                   perform open-main-file
               end-if
               move val-true  to input-empty
               move val-false to copy-file-active
               move val-false to output-ready
               move val-false to input-to-return
               move val-false to edit-active
               move val-false to edit-to-return
               move val-false to overflow-active
               move val-false to separate-verbs
               move 7 to output-count
               move 12 to overflow-count
               move 0 to unfinished-action
               open output console-file
           else
               perform preprocess until output-ready = val-true
               if input-to-return = val-true
                   move input-buffer to buffer
                   move 0 to response-code-1
                   move 0 to response-code-2
                   move in-col-5 to resp-more
                   move in-col-6 to resp-main
                   move val-false to input-to-return
                   move edit-to-return to output-ready
               else
                   if edit-to-return = val-true
                       move output-buffer to buffer
                       move 0 to response-code-1
                       move 0 to response-code-2
                       move out-col-5 to resp-more
                       move out-col-6 to resp-main
                       move spaces to output-buffer
                       move spaces to output-flags
                       move 7 to output-count
                       move overflow-active to output-ready
                       move overflow-active to edit-to-return
                       if overflow-active = val-true
                           move overflow-buffer to output-buffer
                           move overflow-flags to output-flags
                           move overflow-count  to output-count
                           move spaces to overflow-buffer
                           move spaces to overflow-flags
                           move 12 to overflow-count
                           move val-false to overflow-active
                       end-if
                   end-if
               end-if
           perform trace-record
           end-if.
       start-x.
           exit program.


      /*****************************************************************
      *                                                                *
      * open, close and main and copy source code files                *
      *                                                                *
      ******************************************************************

       open-main-file section.
           move buffer to main-file-name.
           open input main-file.
           if stat-1 not = 0
               move 255 to response-status
           else
               if trace-flag = val-true
                   open output trace-file
                   if stat-1 not = 0
                       move 255 to response-status
                   end-if
               end-if
           end-if.

       close-main-file section.
           close main-file console-file
           if trace-flag = val-true
               close trace-file
           end-if
           move 0 to in-col-6
           move val-true to output-ready.

       trace-record section.
           if trace-flag = val-true
               move buffer to trace-rec
               write trace-rec
           end-if.

      /*****************************************************************
      *                                                                *
      *    routine to process copy verb                                *
      *    if the copy file is on two lines then set flag & get        *
      *    name of the copy file next time through.                    *
      *    otherwise get the name of copy file and open it.            *
      *                                                                *
      ******************************************************************

       open-copy-file section.
           move 3 to in-col-6
           move input-count to in-col-5
           subtract 5 from in-col-5
           perform read-token
           evaluate token
               when tok-word
               when tok-an-lit
                   move lex-1-30 to copy-file-name
                   open input copy-file
                   if stat-1 not = 0
                       move 255 to response-status
                   else
                       move val-true to copy-file-active
                   end-if
               when tok-eor
                   move do-copy to unfinished-action
               when other
                   move 255 to response-status
           end-evaluate
           move val-true to output-ready
           move val-true to input-empty.

       continue-copy-file section.
           perform open-copy-file
           move 0 to in-col-5
           move 4 to in-col-6.

       close-copy-file section.
           close copy-file
           move val-false to copy-file-active
           move spaces to input-buffer
           move val-true to input-empty
           move 128 to in-col-6
           move val-true to output-ready.

      /*****************************************************************
      *                                                                *
      * read main and copy source code files                           *
      *                                                                *
      ******************************************************************

       read-record section.
           move spaces to input-flags
           if copy-file-active = val-false
               if prep-active = val-true
                   move spaces to input-buffer
                   move 0 to resp-more
                   move 0 to resp-main
                   call next-prep using mode-flag input-buffer response
                   move resp-more to in-col-5
                   move resp-main to in-col-6
               else
                   read main-file
                       at end
                           move spaces to input-buffer
                           move val-eof to in-col-73
                       not at end
                           move main-rec to input-buffer
                           move val-eor to in-col-73
               end-if
           else
               read copy-file
                   at end
                       move spaces to input-buffer
                       move val-eoc to in-col-73
                   not at end
                       move copy-rec to input-buffer
                       move val-eor to in-col-73
           end-if
            evaluate in-col-6
               when 0 move spaces to input-buffer
                      move spaces to input-flags
                      move val-eof to in-col-73
                      move val-space to char
      *for the moment we'll not change modified lines
               when 1 move val-eor to char
               when 2 move val-eor to char
               when 3 move val-eor to char
               when 4 move val-eor to char
               when 5 move val-eor to char
               when 6 move val-eor to char
               when 128 move val-eor to char
               when other
                   if in-col-7 = val-asterisk or in-col-7 = val-slash
                       move val-eor to char
                   else
                       move val-space to char
                   end-if
           end-evaluate
           move 8 to input-count
           if prep-active = val-false
               move val-space to in-col-6
           end-if
           move val-false to input-empty.
           move val-true to input-to-return.

      ******************************************************************
      *                                                                *
      *  RDCH        read a character from the input record            *
      *                                                                *
      ******************************************************************

       rdch section.
           move input-byte (input-count) to char.
           add 1 to input-count.

       ppch section.
           move input-byte (input-count) to pp.

       lexch section.
           move char to lex-byte (lex-count).
           add 1 to lex-count.


      /*****************************************************************
      *                                                                *
      *  EDIT-SETUP      prepare to output an edited record            *
      *                                                                *
      ******************************************************************

       edit-setup section.
           if separate-verbs = val-false
               if edit-active = val-false
                   move input-count to temp
                   subtract lex-count from temp
                   perform until output-count = temp
                       move input-byte (output-count) to
                                              output-byte (output-count)
                       add 1 to output-count
                   end-perform
               end-if
           else
               perform until output-count = 12
                   move val-space to output-byte(output-count)
                   add 1 to output-count
               end-perform
               move val-false to separate-verbs
           end-if
           move val-true to edit-active.

       move-token section.
           move lex-count to temp
           add output-count to temp
           if token = tok-an-lit
              subtract 1 from lex-count
              if input-count not =  74
                  add 1 to temp
              end-if
           end-if.
           if temp > 72
               move val-true to overflow-active
               move 0         to over-col-5
               move out-col-6 to over-col-6
           end-if
           move 1 to temp
           perform move-delimit
           if overflow-active = val-false
               perform until temp > lex-count
                   move lex-byte (temp) to output-byte (output-count)
                   add 1 to temp
                   add 1 to output-count
               end-perform
           else
               perform until temp > lex-count
                   move lex-byte(temp) to overflow-byte (overflow-count)
                   add 1 to temp
                   add 1 to overflow-count
               end-perform
           end-if
           perform move-delimit.

       move-delimit section.
           if token = tok-an-lit
               if overflow-active = val-false
                   move token-delimit to output-byte (output-count)
                   add 1 to output-count
               else
                   move token-delimit to overflow-byte (overflow-count)
                   add 1 to overflow-count
               end-if
           end-if.

      /*****************************************************************
      *                                                                *
      *  READ-TOKEN  -  main lexical analysis subroutine               *
      *                                                                *
      *                 input : char     = next character from input   *
      *                                                                *
      *                 result: token    = lexical token type          *
      *                         LEX-1-30 = lexical symbol string       *
      *                                                                *
      ******************************************************************

       read-token section.
           move 1 to lex-count.
           move spaces to lex-1-30.
       rt-loop.
           perform rdch
               until char not = val-space
           move input-count to token-pos
           subtract 1 from token-pos
           evaluate char
               when val-A thru val-Z
                   perform rt-word
               when val-a-lc thru val-z-lc
                   subtract val-lc-to-uc from char
                   perform rt-word
               when val-zero thru val-nine
                   perform rt-numb
               when val-eor
                   move tok-eor to token
               when val-period
                   move tok-period to token
                   perform rt-numb-query
               when val-plus
                   move tok-plus to token
                   perform rt-numb-query
               when val-minus
                   move tok-minus to token
                   perform rt-numb-query
               when val-quote
               when val-apostrophe
                   perform rt-lit
               when val-mult
                   move tok-mult to token
                   perform rdch
               when val-div
                   move tok-div  to token
                   perform rdch
               when val-lbkt
                   move tok-lbkt to token
                   perform rdch
               when val-rbkt
                   move tok-rbkt to token
                   perform rdch
               when val-equal
                   move tok-equal to token
                   perform rdch
               when val-gt
                   move tok-gt to token
                   perform rt-compare
               when val-lt
                   move tok-lt to token
                   perform rt-compare
               when val-semi
               when val-comma
                   perform rdch
                   go to rt-loop
               when val-eoc
                   move tok-eoc to token
               when val-eof
                   move tok-eof to token
               when val-file-slash
                   perform rt-word
               when val-eol
                   continue
               when other
                   move tok-error to token
                   display "Preprocessor error: unrecognised token"
           end-evaluate.
      *
      /*****************************************************************
      *                                                                *
      *  RT-WORD       read a word.  leaves CHAR = next character      *
      *                                                                *
      ******************************************************************

       rt-word section.
           move tok-word to token.
       rt-word-l.
           perform lexch.
           perform rdch.
           evaluate char
               when val-A thru val-Z
               when val-zero thru val-nine
               when val-minus
               WHEN val-file-slash
                   go to rt-word-l
               when val-a-lc thru val-z-lc
                   subtract val-lc-to-uc from char
                   go to rt-word-l
           end-evaluate.


      ******************************************************************
      *                                                                *
      *  RT-NUMB       read a number. leaves CHAR = next character     *
      *                                                                *
      ******************************************************************

       rt-numb section.
           move tok-numb to token.
       rt-numb-l.
           perform lexch.
           perform rdch.
           evaluate char
               when val-zero thru val-nine
                   go to rt-numb-l
               when val-period
                   perform ppch
                   if pp >= val-zero and pp <= val-nine
                       go to rt-numb-l
                   end-if
           end-evaluate.

       rt-numb-query section.
           perform lexch.
           perform rdch.
           evaluate char
               when val-zero thru val-nine
               perform rt-numb
           end-evaluate.

      /*****************************************************************
      *                                                                *
      *  RT-LIT        read alphanumeric literal. leaves CHAR = next ch*
      *                eliminates lead & trail quote/apostrophe        *
      *                                                                *
      ******************************************************************

       rt-lit section.
           move char to token-delimit.
           move tok-an-lit to token.
       rt-lit-l.
           perform rdch
           evaluate char
               when val-quote
               when val-apostrophe
                   if char = token-delimit
                       perform rdch
                   else
                       perform lexch
                       go to rt-lit-l
                   end-if
               when val-eor
                   move val-eor to char
               when other
                   perform lexch
                   go to rt-lit-l
           end-evaluate.


      ******************************************************************
      *                                                                *
      *  RT-COMPARE    read a comparator symbol ( <= >= ). leaves CHAR=*
      *                                                                *
      ******************************************************************

       rt-compare section.
           perform lexch.
           perform rdch.
           if char = val-equal
               if token = tok-gt then move tok-ge to token
                                 else move tok-le to token
               end-if
               perform lexch
               perform rdch
           end-if.
       rt-compare-x.
           exit.


      /*****************************************************************
      *                                                                *
      * PREPROCESS      the main program                               *
      *                                                                *
      ******************************************************************

       preprocess section.
           if input-empty = val-true
               perform read-record
           end-if
           if unfinished-action not = 0
               perform tidy-up
           else
               if separate-verbs = val-false
                   perform read-token
               else
                   move tok-word to token
                   move saved-lex-1-30 to lex-1-30
                   move val-false to edit-active
               end-if
               evaluate token
                   when tok-word
                       evaluate lex-1-30
                           when "PRINT"
                               perform print-routine
                           when other
                               if edit-active = val-true
                                   perform move-token
                               end-if
                       end-evaluate
                   when tok-eor
                       if edit-active = val-true
                           move val-true to edit-to-return
                           move val-false to edit-active
                       end-if
                       move val-true to output-ready
                       move val-true to input-empty
                   when tok-eof
                       perform close-main-file
                   when tok-eoc
                       perform close-copy-file
                   when tok-error
                       move 255 to response-status
                       move val-true to output-ready
                   when other
                       if edit-active = val-true
                           perform move-token
                       end-if
               end-evaluate
           end-if.


      /*****************************************************************
      *                                                                *
      * routines to tidy-up the various pre-processor tasks            *
      *                                                                *
      ******************************************************************

       tidy-up section.
           move unfinished-action to temp
           move 0 to unfinished-action
           evaluate temp
               when do-copy
                   perform continue-copy-file
               when do-error
                   perform continue-error-routine
               when other
                   display "TIDY-UP: ENTRY - BUT NOT ACTIVE !"
                   move 255 to response-status
           end-evaluate.


      /*****************************************************************
      *                                                                *
      *    routine to process PRINT verb                               *
      *                                                                *
      ******************************************************************


       print-routine section.
           if edit-active = val-true
               move val-true to output-ready
               move val-true to edit-to-return
               move lex-1-30 to saved-lex-1-30
               move val-true to separate-verbs
           else
               perform edit-setup
               move "DISPLAY " to lex-1-30
               move 8 to lex-count
               move 2 to  in-col-6
               move 1 to out-col-6
               move token-pos to out-col-5
               perform move-token
           end-if.

      ******************************************************************
      *                                                                *
      * this routine will insert a warning into the list file.         *
      * the warning must have the format of a comment line.            *
      *                                                                *
      ******************************************************************

        warn-routine section.
           move 0 to out-col-5
           move 5 to out-col-6
           move "* EXAMPLE WARNING MESSAGE" to out-col-7-80
           move val-true to edit-to-return.




      /*****************************************************************
      *                                                                *
      * This routine can signal the compiler to switch into the editor.*
      * at the point in the source code where the pre-processor finds  *
      * an error.                                                      *
      * Note: all open source files are closed before switching to the *
      * editor.  Also, note that a record is passed back to the compiler
      * to flush out a buffered listing record in the compiler, BEFORE *
      * entering the interactive Y/N sequence.  The flush record ..... *
      * "* ... warning ... etc" appears on the user screen AFTER the   *
      * interactive sequence, if the user choses to continue, as the   *
      * compiler treats the warning message as another buffered record.*
      *                                                                *
      ******************************************************************

        error-routine section.
           move 0 to out-col-5
           move 5 to out-col-6
           move "*  WARNING .... PRE-PROCESSOR ERROR" to out-col-7-80
           move val-true to output-ready
           move val-true to input-to-return
      * make a comment so the checker doesn't object to it
           move val-asterisk to in-col-7
           move val-true to edit-to-return
           move val-false to overflow-active
           move spaces to overflow-buffer
           move 12 to overflow-count
           move do-error to unfinished-action.


        continue-error-routine section.
           move "**nnn-S" to msg-number
           perform varying temp from 8 by 1 until temp = input-count
               move val-asterisk to overflow-byte ( temp )
           end-perform
           write console-rec from overflow-buffer
           write console-rec from error-message-text
           write console-rec from "CONTINUE CHECKING PROGRAM ?   Yes/No"
           call sound-beep
           call keybd-read using temp-X
           if temp-X = 'N' or temp-X = 'n'
               display error-message-text upon cmd-line
               move 6 to in-col-6
               close main-file
               close copy-file
           else
               move 7 to in-col-6
               move 2 to in-col-5
           end-if
           move spaces to input-buffer
           move val-true to input-empty
           move val-true to output-ready
           move val-true to input-to-return
           move val-false to edit-to-return.

      /*****************************************************************
       analyse-command-line section.
           move 1 to input-count.
       analyse-again.
           perform read-token
               evaluate lex-1-30
                   when "PREPROCESS"
                     move val-true to prep-active
      *write to command line
                     perform read-token
                     perform read-token
                     move input-count to temp
                     add 1 to temp
                     subtract temp from 80 giving temp-2
                     move input-buffer(temp:temp-2) to cmdline
                     display cmdline upon cmd-line
      *call next preprocessor
                     move lex-1-30(1:8) to next-prep
                     call next-prep using mode-flag buffer response
                 when "DIRECTIVES"
                     perform read-directives
                     move 1 to input-count
                     perform read-token
                     go to analyse-again
                 when spaces
                     perform open-main-file
                 when other
                   move tok-error to token
                   display "PREPROC ERROR: UNRECOGNISED PARAMETER"
                 end-evaluate.


      /*****************************************************************
       read-directives section.
           perform read-token
           move input-count to temp-2
           perform read-token
           move lex-1-30 to dir-file-name
           subtract temp-2 from input-count giving temp
           add 1 to temp
           perform read-token
           move lex-1-30 to dir-file-name(temp:1)
           add 1 to temp
           perform read-token
           move lex-1-30 to dir-file-name(temp:3)

               open input dir-file
               if stat-1 not = 0
                   move tok-error to token
                   display "PREPROC ERROR: INVALID DIRECTIVES FILE"
               else
                   read dir-file
      *only allowing a one line file at present
                   move dir-rec to input-buffer
                   close dir-file.

      ******************************************************************
      *                                                                *
      * End of example Integrated Pre-Processor                        *
      *                                                                *
      ******************************************************************