GnuCOBOL FAQ ¶

GnuCOBOL 4 with XFD, and C++ versions are available for testing

Dedicated to the living memory of Roger While (1950-2015)

Any organization interested in reproducing the COBOL standard and
specifications in whole or in part, using ideas from this document as the basis
for an instruction manual or for any other purpose, is free to do so.  However,
all such organizations are requested to reproduce the following acknowledgment
paragraphs in their entirety as part of the preface to any such publication:

COBOL is an industry language and is not the property of any company or group
of companies, or of any organization or group of organizations.

No warranty, expressed or implied, is made by any contributor or by the CODASYL
COBOL Committee as to the accuracy and functioning of the programming system
and language.  Moreover, no responsibility is assumed by any contributor, or by
the committee, in connection therewith.

The authors and copyright holders of the copyrighted materials used herein

    FLOW-MATIC (trademark of Sperry Rand Corporation), Programming for the UNIVAC
    (R) I and II, Data Automation Systems copyrighted 1958, 1959, by Sperry Rand
    Corporation; IBM Commercial Translator Form No. F28-8013, copyrighted 1959 by
    IBM; FACT, DSI 27A5260-2760, copyrighted 1960 by Minneapolis-Honeywell

have specifically authorized the use of this material, in whole or in part, in
the COBOL specifications.  Such authorization extends to the reproduction and
use of COBOL specifications in programming manuals or similar publications.

Any organization using a short passage from this document, such as in a book
review, is requested to mention "COBOL" in acknowledgment of the source.

identification division.
program-id. motto.
data division.
working-storage section.

1, computer                                                   . 2
   programming value is "Highly rewarding".


2, GnuCOBOL REDEFINES programming                         pic xx.
                                                        procedure
                                                        division.
3. display GnuCOBOL.

prompt$ cobc -xj -free motto.cob
Hi

On June 17th, 2015, the legal transfer of all components of the GnuCOBOL
source code tree, from all authors, to the Free Software Foundation, was
announced as official.  The rights to copy the GnuCOBOL project source
codes are now in the care, and capable hands, of the FSF.

You are allowed to write GnuCOBOL programs that use the libcob run time
library however you like.  Closed, proprietary, commercial use is allowed as
part of the LGPL user freedoms.  You can ship GnuCOBOL generated programs in
binary form as you wish, (with exceptions; mentioned below).

Modifications to the compiler itself, if ever distributed, need to
provide access to source code and be licensed under the GNU GPL.

Modifications to the run time library code, if distributed to others,
should also provide access to the source code of the library changes,
and be licensed under the LGPL, but other redistribution models are
allowed.

This ensures that no one is allowed to provide people with access to a
compiler that they can't change, rebuild, and redistribute freely.

If modified sources are personal, or never distributed outside an
organization, there is no burden to release the source of a custom
compiler.  The main intents of the GPL are to ensure end user freedoms.
And the LGPL code to be usable, as given, in closed run-time systems.

I think.  I am not a lawyer.

Please note: this applies to default GnuCOBOL binary builds.

Any version of the compiler that is configured to use Berkeley DB
beyond version 1.85 must abide by the Oracle license, and sources of the
COBOL programs that use libdb must be shipped with any binaries. There are
alternatives to libdb, but deep down, GnuCOBOL encourages free software.

GnuCOBOL, by default is built with libdb for ISAM operations.  Be aware of
the implications, call Oracle, or build in something like the VBISAM engine.

yum install open-cobol

If you don't know already: GC translates COBOL to C and compiles it using a
C compiler. For Win8 I'd use VS2012 or higher (Express Versions work fine).
After installing it go to the downloads area and grab the first "official"
nightly build direct from svn: ... link above

it's quite easy to build GnuCOBOL 2.0 on your own: checkout 2.0-branch,
download the win_prerequisites from sourceforge download area, unpack it to
build_windows, open the VS solution you need (maybe changing defaults.h to
match your path) and click compile.

Do NOT post code to a website if you need to keep it private
Do NOT post code to a website if you have no rights to copy

CALL "cfunction" USING BY REFERENCE ADDRESS OF VAR-IN-LINKAGE-SECTION.

MOVE FUNCTION COMPANY-RULE39(SALES-RECORD) TO BONUS

DISPLAY
    FUNCTION UPPER-CASE(
        FUNCTION SUBSTITUTE(
            "This is the orginal string.";
            "original"; "new"; "string"; "text"
        )
    )

THIS IS THE NEW TEXT.

The OC project would not have been where it is today without the
significant/enormous help from many-many persons. The THANKS
file does not even do justice to this.

$ make check

$ TESTSUITEFLAGS='--jobs=4' make check

00:24.86 elapsed 300%CPU

01:24.72 elapsed 100%CPU

AT_SETUP([RETURN-CODE nested])
AT_KEYWORDS([returncode])

AT_DATA([prog.cob], [
       IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog.
       PROCEDURE        DIVISION.
           MOVE 1 TO RETURN-CODE.
           IF RETURN-CODE NOT = 1
              DISPLAY RETURN-CODE NO ADVANCING
              END-DISPLAY
           END-IF.
           CALL "mod1"
           END-CALL.
           IF RETURN-CODE NOT = 2
              DISPLAY RETURN-CODE NO ADVANCING
              END-DISPLAY
           END-IF.
           MOVE ZERO TO RETURN-CODE.
           STOP RUN.
       PROGRAM-ID.      mod1.
       PROCEDURE        DIVISION.
           IF RETURN-CODE NOT = 1
              DISPLAY RETURN-CODE NO ADVANCING
              END-DISPLAY
           END-IF.
           MOVE 2 TO RETURN-CODE.
           EXIT PROGRAM.
       END PROGRAM mod1.
       END PROGRAM prog.
])

AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([./prog], [0], [], [])

AT_CLEANUP

tests/cobol85/README

Test Modules
------------

Core tests:

  NC - COBOL nucleus tests
  SM - COPY sentence tests
  IC - CALL sentence tests

File I-O tests:

  SQ - Sequential file I-O tests
  RL - Relative file I-O tests
  IX - Indexed file I-O tests
  ST - SORT sentence tests
  SG - Segment tests

Advanced facilities:

  RW - REPORT SECTION tests
  IF - Intrinsic Function tests
  SG - Segment tests
  DB - Debugging facilities tests
  OB - Obsolete facilities tests

------ Directory Information -------   --- Total Tests Information ---
Module Programs Executed Error Crash   Pass Fail Deleted Inspect Total
------ -------- -------- ----- -----  ----- ---- ------- ------- -----
NC           95       95     0     0   4371    0       4      26  4401
SM           17       17     0     0    293    0       2       1   296
IC           25       25     0     0    247    0       4       0   251
SQ           85       85     0     0    521    0       0      89   610
RL           35       35     0     0   1830    0       5       0  1835
IX           42       42     0     0    510    0       1       0   511
ST           40       40     0     0    289    0       0       0   289
SG           13       13     0     0    313    0       0       0   313
OB            7        7     0     0     34    0       0       0    34
IF           45       45     0     0    735    0       0       0   735
RW            6        6     0     0     42    0       0       0    42
DB           14       14     0     0    404    0       4      27   435
------ -------- -------- ----- -----  ----- ---- ------- ------- -----
Total       424      424     0     0   9589    0      20     143  9752

Advanced facilities:

  CM - COMMUNICATION SECTION tests

DB - Debugging facilities tests
OB - Obsolete facilities tests

Input-Output Section.
 File-Control.
    Select InFile  Assign to
         "C:\expon180.1e6".
    Select OutFile  Assign to
         "C:\TELCO.TXT"
                 Line
                 Sequential.

$ echo 'N' | time ./telco
Enter 'N' to skip calculations:
0.46user 1.08system 0:01.61elapsed 96%CPU (0avgtext+0avgdata 0maxresident)k
0inputs+134776outputs (0major+345minor)pagefaults 0swaps

$ echo '' | time ./telco
Enter 'N' to skip calculations:
11.37user 1.41system 0:12.95elapsed 98%CPU (0avgtext+0avgdata 0maxresident)k
24inputs+134776outputs (0major+360minor)pagefaults 0swaps

$ tail TELCO.TXT
    35    D  |         0.31         0.02         0.01 |         0.34
   193    D  |         1.73         0.11         0.05 |         1.89
   792    L  |         1.03         0.06              |         1.09
   661    D  |         5.91         0.39         0.20 |         6.50
    44    L  |         0.06         0.00              |         0.06
   262    L  |         0.34         0.02              |         0.36
-------------+----------------------------------------+-------------
   Totals:   |   922,067.11    57,628.30    25,042.17 | 1,004,737.58
  Start-Time:09:37:23.93
    End-Time:09:37:36.83

$ tail TELCO.TXT
     35    D  |         0.31         0.02         0.01 |         0.34
    193    D  |         1.73         0.11         0.05 |         1.89
    792    L  |         1.03         0.06              |         1.09
    661    D  |         5.91         0.39         0.20 |         6.50
     44    L  |         0.06         0.00              |         0.06
    262    L  |         0.34         0.02              |         0.36
 -------------+----------------------------------------+-------------
    Totals:   |   922,067.11    57,628.30    25,042.17 | 1,004,737.58
   Start-Time:21:40:48.52
     End-Time:21:40:51.92

COBOL
bench
mark
      *> 
      *> By William Klein, used with permission
      *>
       Identification Division.
        Program-ID. TELCO.
       Environment Division.
       Input-Output Section.
        File-Control.
           Select InFile  Assign to
                "C:\expon180.1e6".
      *>        "C:\TELCO.TEST".
           Select OutFile  Assign to
                "C:\TELCO.TXT"
                        Line
                        Sequential.
       Data Division.
        File Section.
       FD  InFile.
       01  InRec                Pic S9(15)      Packed-Decimal.
       01  InRec2.
           05                   Pic  X(7).
           05                   Pic S9(1)       Packed-Decimal.
             88  Premimum-Rate                  Value 1 3 5 7 9.
       FD  OutFile.
       01  OutRec               Pic X(70).
       Working-Storage Section.
       01  Misc.
           05                   Pic  X          Value "N".
             88  EOF                            Value "Y".
           05  Do-Calc          Pic  X          Value "Y".
             88  No-Calc                        Value "N".
           05.
               10  Start-Time   Pic X(21).
               10  End-Time     Pic X(21).
       01  Misc-Num.
           05  Price-Dec5       Pic S9(05)V9(06).
           05  Redefines Price-Dec5.
               10               Pic X(3).
               10               Pic S9(05).
                 88  Even-Round
                                Value 05000 25000 45000 65000 85000.
           05  Running-Totals.
               10  Price-Tot   Pic S9(07)V99    Binary.
               10  BTax-Tot    Pic S9(07)v99    Binary.
               10  DTax-Tot    Pic S9(07)V99    Binary  Value Zero.
               10  Output-Tot  Pic S9(07)V99    Binary.
           05  Temp-Num.
               10  Temp-Price   Pic S9(05)V99   Binary.
               10  Temp-Btax    Pic S9(05)V99   Binary.
               10  Temp-DTax    Pic S9(05)V99   Binary.
       01  WS-Output.
           05  Header-1         Pic X(70)       Value
               "  Time  Rate |        Price         Btax         Dtax |
      -        "      Output".
           05  Header-2         Pic X(70)       Value
               "-------------+----------------------------------------+-
      -        "------------".
           05  Detail-Line.
               10               Pic X(01)       Value Space.
               10  Time-Out     Pic zzzz9.
               10               Pic X(04)       Value Space.
               10  Rate-Out     Pic X.
               10               Pic X(04)       Value "  | ".
               10  Price-Out    Pic z,zzz,zz9.99.
               10               Pic X(01)       Value Spaces.
               10  Btax-Out     Pic z,zzz,zZ9.99.
               10               Pic X(01)       Value Spaces.
               10  Dtax-Out     Pic Z,zzz,zz9.99        Blank When Zero.
               10               Pic X(03)       Value " | ".
               10  Output-Out   Pic z,zzz,zZ9.99.
       Procedure Division.
        Mainline.
           Perform Init
           Perform Until EOF
               Read  InFile
                   At End
                       Set EOF  to True
                   Not At End
                       If No-Calc
                           Continue
                       Else
                           Perform  Calc-Para
                       End-If
                       Write OutRec from Detail-Line
               End-Read
           End-Perform
           Perform WindUp
           Stop Run
                .
       Calc-Para.
           Move InRec   to Time-Out
           If Premimum-Rate
               Move "D"         To Rate-Out
               Compute Temp-Price Rounded Price-Out Rounded Price-Dec5
                        = InRec * +0.00894
               Compute Temp-DTax DTax-Out
                        = Temp-Price * 0.0341
               Add Temp-Dtax to DTax-Tot
           Else
               Move "L"         To Rate-Out
               Compute Temp-Price Rounded Price-Out Rounded Price-Dec5
                        = InRec * +0.00130
               Move Zero to DTax-Out Temp-DTax
           End-If
           If Even-Round
               Subtract .01 from Temp-Price
               Move Temp-Price to Price-Out
           End-If
           Compute Temp-Btax BTax-Out
                        = Temp-Price * 0.0675
           Compute Output-Out
                        = Temp-Price + Temp-Btax + Temp-Dtax
           Add Temp-BTax        To Btax-Tot
           Add Temp-Price       to Price-Tot
           Compute Output-Tot
                        = Output-Tot + Function NumVal (Output-Out (1:))
               .
       Init.
           Open Input  InFile
                Output OutFile
           Write OutRec from Header-1
           Write OutRec from Header-2
           Display "Enter 'N' to skip calculations:" Upon Console
           Accept Do-Calc From Console
           Move Function Current-Date   To Start-Time
                .
       WindUp.
           Move Function Current-Date to End-Time
           Write OutRec         from Header-2
           Move Price-Tot       to Price-Out
           Move Btax-Tot        to Btax-Out
           Move Dtax-Tot        to Dtax-Out
           Move Output-Tot      to Output-Out
           Move "   Totals:"    to Detail-Line (1:12)
           Write OutRec         from Detail-Line
           Move Spaces          to OutRec
           String       "  Start-Time:"         Delimited by Size
                        Start-Time (9:2)        Delimited by Size
                        ":"                     Delimited by size
                        Start-Time (11:2)       Delimited by size
                        ":"                     Delimited by size
                        Start-Time (13:2)       Delimited by size
                        "."                     Delimited by size
                        Start-Time (15:2)       Delimited by size
                into OutRec
           Write OutRec
           Move Spaces          to OutRec
           String       "    End-Time:"         Delimited by Size
                        End-Time (9:2)          Delimited by Size
                        ":"                     Delimited by size
                        End-Time (11:2)         Delimited by size
                        ":"                     Delimited by size
                        End-Time (13:2)         Delimited by size
                        "."                     Delimited by size
                        End-Time (15:2)         Delimited by size
                into OutRec
           Write OutRec
           Close InFile
                 OutFile
                .

Update
      *>
      *> By Roger While, used with permission
      *>
       IDENTIFICATION DIVISION.
       PROGRAM-ID. telco5.
       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT INFILE   ASSIGN TO
                "expon180.1e6"
                .
           SELECT OUTFILE  ASSIGN TO
                "TELCO.TXT"
                LINE SEQUENTIAL
                .
       DATA DIVISION.
       FILE SECTION.
       FD  INFILE.
       01  INREC            PIC S9(15)      PACKED-DECIMAL.
       01  INREC2.
           05               PIC  X(7).
           05               PIC  X.
             88  PREMIMUM-RATE
                    VALUES X"1C" X"3C" X"5C" X"7C" X"9C".
       FD  OUTFILE.
       01  OUTREC           PIC X(70).
       WORKING-STORAGE SECTION.
       01  DO-CALC          PIC X            VALUE "Y".
           88  NO-CALC                       VALUE "N".

       01  START-TIME       PIC X(21).
       01  END-TIME         PIC X(21).

       01  PRICE-TOT        PIC S9(07)V99    COMP-5.
       01  BTAX-TOT         PIC S9(07)V99    COMP-5.
       01  DTAX-TOT         PIC S9(07)V99    COMP-5.
       01  OUTPUT-TOT       PIC S9(07)V99    COMP-5.

       01  TEMP-PRICE       PIC S9(07)V99    COMP-5.
       01  TEMP-BTAX        PIC S9(07)V99    COMP-5.
       01  TEMP-DTAX        PIC S9(07)V99    COMP-5.

       01  HEADER-1         PIC X(70)       VALUE
           "  Time  Rate |        Price         Btax         Dtax | "
           &   "      Output".
       01  HEADER-2         PIC X(70)       VALUE
           "-------------+----------------------------------------+-"
           &   "------------".
       01  DETAIL-LINE.
           10               PIC X(01)         VALUE SPACE.
           10  NUMB-OUT     PIC ZZZZ9.
           10               PIC X(04)         VALUE SPACE.
           10  RATE-OUT     PIC X.
           10               PIC X(04)         VALUE "  | ".
           10  PRICE-OUT    PIC Z,ZZZ,ZZ9.99.
           10               PIC X(01)         VALUE SPACES.
           10  BTAX-OUT     PIC Z,ZZZ,ZZ9.99.
           10               PIC X(01)         VALUE SPACES.
           10  DTAX-OUT     PIC Z,ZZZ,ZZ9.99  BLANK WHEN ZERO.
           10               PIC X(03)         VALUE " | ".
           10  OUTPUT-OUT   PIC Z,ZZZ,ZZ9.99.
       PROCEDURE DIVISION.
       MAINLINE.
           OPEN INPUT  INFILE
                OUTPUT OUTFILE
           WRITE OUTREC FROM HEADER-1
           END-WRITE
           WRITE OUTREC FROM HEADER-2
           END-WRITE
           DISPLAY "Enter 'N' to skip calculations:" UPON CONSOLE
           END-DISPLAY
           ACCEPT DO-CALC FROM CONSOLE
           END-ACCEPT
       *>  Start timer
           MOVE FUNCTION CURRENT-DATE   TO START-TIME
       *>  Start loop
       *>  PERFORM UNTIL EXIT, changed to 0 = 1 for older compilers
           PERFORM UNTIL 0 = 1
               READ  INFILE AT END
                     EXIT PERFORM
               END-READ
               IF NOT NO-CALC
                   MOVE INREC   TO NUMB-OUT
                   IF PREMIMUM-RATE
                       MOVE "D"         TO RATE-OUT
                       COMPUTE TEMP-PRICE ROUNDED MODE NEAREST-EVEN
                                = INREC * 0.00894
                       END-COMPUTE
                       COMPUTE TEMP-DTAX
                                = TEMP-PRICE * 0.0341
                       END-COMPUTE
                       ADD TEMP-DTAX TO DTAX-TOT
                       END-ADD
                       MOVE TEMP-DTAX TO DTAX-OUT
                   ELSE
                       MOVE "L"         TO RATE-OUT
                       COMPUTE TEMP-PRICE ROUNDED MODE NEAREST-EVEN
                                = INREC * 0.00130
                       END-COMPUTE
                       MOVE ZERO TO TEMP-DTAX
                       MOVE ZERO TO DTAX-OUT
                   END-IF
                   MOVE TEMP-PRICE TO PRICE-OUT
                   COMPUTE TEMP-BTAX BTAX-OUT
                                = TEMP-PRICE * 0.0675
                   END-COMPUTE
                   ADD TEMP-PRICE TEMP-BTAX TEMP-DTAX TO OUTPUT-TOT
                   END-ADD
                   ADD TEMP-PRICE TEMP-BTAX TEMP-DTAX GIVING OUTPUT-OUT
                   END-ADD
                   ADD TEMP-BTAX        TO BTAX-TOT
                   END-ADD
                   ADD TEMP-PRICE       TO PRICE-TOT
                   END-ADD
               END-IF
               WRITE OUTREC FROM DETAIL-LINE
               END-WRITE
           END-PERFORM
       *>  End loop
       *>  End timer
           MOVE FUNCTION CURRENT-DATE TO END-TIME
           WRITE OUTREC         FROM HEADER-2
           END-WRITE
           MOVE PRICE-TOT       TO PRICE-OUT
           MOVE BTAX-TOT        TO BTAX-OUT
           MOVE DTAX-TOT        TO DTAX-OUT
           MOVE OUTPUT-TOT      TO OUTPUT-OUT
           MOVE "   Totals:"    TO DETAIL-LINE (1:12)
           WRITE OUTREC         FROM DETAIL-LINE
           END-WRITE
           MOVE SPACES          TO OUTREC
           STRING       "  Start-Time:"         DELIMITED BY SIZE
                        START-TIME (9:2)        DELIMITED BY SIZE
                        ":"                     DELIMITED BY SIZE
                        START-TIME (11:2)       DELIMITED BY SIZE
                        ":"                     DELIMITED BY SIZE
                        START-TIME (13:2)       DELIMITED BY SIZE
                        "."                     DELIMITED BY SIZE
                        START-TIME (15:2)       DELIMITED BY SIZE
                INTO OUTREC
           END-STRING
           WRITE OUTREC
           END-WRITE
           MOVE SPACES          TO OUTREC
           STRING       "    End-Time:"         DELIMITED BY SIZE
                        END-TIME (9:2)          DELIMITED BY SIZE
                        ":"                     DELIMITED BY SIZE
                        END-TIME (11:2)         DELIMITED BY SIZE
                        ":"                     DELIMITED BY SIZE
                        END-TIME (13:2)         DELIMITED BY SIZE
                        "."                     DELIMITED BY SIZE
                        END-TIME (15:2)         DELIMITED BY SIZE
                INTO OUTREC
           END-STRING
           WRITE OUTREC
           END-WRITE
           CLOSE INFILE
                 OUTFILE
           STOP RUN
           .

# Sample make rule for using FastCGI with GnuCOBOL
.RECIPEPREFIX = >

program: program.cob
> cobc -x -C program.cob
> sed -i 's/<stdio.h/<fcgi_stdio.h/' program.c
> LD_RUN_PATH=. cobc -x program.c -lfcgi

*> FastCGI from COBOL sample
*>   fastcgi-accept is a binary-long
*>   carriage-return is x"0d" and newline is x"0a"
 procedure division.

 call "FCGI_Accept" returning fastcgi-accept
     on exception
         display
             "FCGI_Accept call error, link with -lfcgi"
         end-display
 end-call

 perform until fastcgi-accept is less than zero

*> Always send out the Content-type before any other IO
     display "Content-type: text/html" carriage-return newline
     end-display

     display "<html><body>" end-display
     display
         "<h3>FastCGI environment with GnuCOBOL</h3>"
     end-display

     ... rest of CGI handling ...

     call "FCGI_Accept" returning fastcgi-accept
         on exception
             move -1 to fastcgi-accept
     end-call

 end-perform

call STATIC "FCGI_Accept" returning fastcgi-accept

cobc -x program.cob -A '--include fcgi_stdio.h' -lfcgi

cobweb
GTK+
       *> test basic windowing
        procedure division.
        move new-window("cobweb-gtk", width-hint, height-hint)
          to gtk-window-data
        move new-box(gtk-window, HORIZONTAL, spacing, homogeneous)
          to gtk-box-data
        move new-image(gtk-box, "blue66.png") to gtk-image-data
        move new-label(gtk-box, "And? ") to gtk-label-data
        move new-entry(gtk-box, "cobweb-entry-activated")
          to gtk-entry-data
        move new-button(gtk-box, "Expedite", "cobweb-button-clicked")
          to gtk-button-data
        move new-vte(gtk-box, vte-cols, vte-rows) to gtk-vte-data
        move new-spinner(gtk-box) to gtk-spinner-data

        move gtk-go(gtk-window) to extraneous
        goback.

prompt$ cd gnucobol-source-dir/branches/gnu-cobol-builtin-script
prompt$ ./configure --with-tcl
prompt$ make; make check && sudo make install

move function tcl-unrestricted("source tkgui.tcl") to tcl-result

tkwait window .

broadwayd :1 &
BROADWAY_DISPLAY=:1 GDK_BACKEND=broadway ./cobweb-periodic

OpenCobolIDE 4.6.2 now includes this new build of GnuCOBOL:
https://launchpad.net/cobcide/4.0/4.6.2
(mirror: https://github.com/OpenCobolIDE/OpenCobolIDE/releases/tag/4.6.2)

For the past week I have been using OpenCobolIDE to do all my GnuCOBOL
development. Being able to see your compile time errors while editing your
source is something I missed after I left the HPe3000 world.

Had a problem after corrupting the recent file list. Think it might have
happened when I deleted a file, outside of OpenCobolIDE, when it was
up-and-running.

I fired off an email to Colin Duquesnoy (the main author) about my problem,
went to bed (it was nearly 1 o'clock in the morning), and found a reply in my
inbox 1st thing the next morning. Was back up and coding by 8 o'clock.

Impressed by the product and the support response (a 7 hour turnaround for
FREE!!).

Would recommend it to anybody.

Incidentally, OC has been (and still is) used in production
environments since 2005.
(This includes projects that I personally worked on plus other
  projects reported to me; these worldwide)

The OC project would not have been where it is today without the
significant/enormous help from many-many persons. The THANKS
file does not even do justice to this.

GnuCOBOL viability

For those concerned about the viability of OpenCOBOL in a production
environment, I offer our situation as an example.

We started loading OpenCOBOL to a Debian (Etch) Parisc box in mid March. With
some valuable help from this forum we were up and running in a few days.

We then explored the CGI capabilities and moved our home-brewed CGI handler
(written in HP3000 Cobol) over. We ended up changing only a few lines.

As Marcr's post indicates, we found a MySql wrapper and made some minor
changes to it.

Starting the second week in April we were in full development of new systems
for commercial use.

Please accept our congratulations to the community and our gratitude for the
help from the forum.

jimc

For our part, the answer is yes.

You may want to read an earlier thread about this. Search on OpenCOBOL
viability.

Having worked with Cobol since the 1960's, my mindset is that no
conversion is automatic.

In our case we are not converting from a specific dialect like MF,
but instead are either writing entirely new systems or are changing
features (making them web based for example) in older systems.

There are some identified failures in OpenCOBOL execution that have
been discussed in this forum. We have found them to be inconsequential
and simply work around them. Then again I do not remember working with
a bug-free compiler.

Our environment is Debian Linux, OpenCOBOL 1.1, MySQL, ISAM (the one
provided with the 1.1 prerelease), HTML (via CGI) and a new PreProcessor
to relieve the tedium of writing SQL statements.

If you have some "nay sayers" in your organization and would like some
support I will be happy to speak with them.

jimc

As part of an initial study of COBOL compilers for finding an alternative to
that of Micro Focus, OpenCobol was selected to develop a model for the
compilation of a public accounting package (1.5 million lines).

The model had to validate this choice, including with the use of sequential
indexed files, with OpenCobol version 0.33 and small adjustments to the COBOL
code (mainly using reserved keywords and keywords not implemented).

After the functional qualification of this model, the software is in production
since July, 2011 under Linux RedHat Enterprise Linux 4 Advanced Server 32-bit
virtualized environment VMWARE ESX – 4 GB of RAM - processor dual AMD Opteron
6176 (tm).

The software package is deployed for 650 users whose 150 connected
simultaneously, at the peaks of activity and in comparison with the previous
platform on AIX 4.3 and Micro Focus, performance gain is in a report, at best,
1-10 (batch of exploitation of entrustment), at worst, 1 to 4 (batch of
recalculation).

With the rise of the package version, a functional validation is in progress
since September 2011 with OpenCobol version 1.1 under Linux RedHat Enterprise
Linux 5 Advanced Server 64-bit and dual Quad-Core AMD Opteron 8356 (tm)
processor. No loss of performance related to the new version of OpenCobol (but
related to the package of 10% to 20% loss) after campaign in the two
environments.

If you wish you can also add the fact that the Account package ACAS has
also been migrated over to GOC and is used in productions for various
users. There is at least one more Accounting system called APAC that
has been migrated over from Micro Focus in the last year or so

I have also migrated both Mainframe Cobol applications to GOC running on
Unix, Linux & Sun variants based systems for companies and governments
in the UK and elsewhere including countries where English is not the
spoken language (but luckily the programming is generally in English or
similar) including languages which is written right to left.

Again luckily I did not have to convert/migrate the manuals.

As a guess I would say that over 2 million code lines have been migrated
at this time where the target compiler has been v1.1 and more lately
v2.0/v2.1.

It is done. We used open Cobol to migrate old archive-Data from Z/os to
Unix/linux.  At the end of the year we stop working on Z/OS because all our
Data and Software is migrated to SAP and Linux/Unix. But there were many old
archive-Data files wich coudn't migrated to SAP. So our solution was to use
OpenCobol to do the Job. We also could do it with our IBM-Cobol-Compiler but
there is one problem. When the Z/OS is gone, you have no chance to repair any
mistake. So wie transferred all our archive-Data in binary sequential format to
Linux. Then, some open-Cobol-Programs convertet them from EBDCIC to ASCII -
cvs-Format. This was my idear because this is a format that every database and
so on can read and understand. So we use OpenCobol-Programs for converting and
formatting and may be siron, web oracle or what else to bring the data to the
enduser. The old data were sequential tape-files and VSAM-KSDS and the binary
files for trnansfer were createt by the sort-utility. The only thing was, to
remember to use binary mode for then transfer to linux and to keep the
record-information (PL/1 Copybooks, Cobol-Copies, SIRON-GENATS) also on the
linux-side. So the big trucks can come at the end of the year and carry away
the about 30 years so loved IBM Mainfraime. But i have my ownd S/370, the
machine i began my IT-Carrier. It is running under Hercules with MVS 3.8 and i
love it. As a hobby i wrote a Fullscreen-controled Horse-Management-System with
ifox00 (assembler) and Cobol68. I wrote some assembler-routines to bring the
dynamic call also to cobol 68 and it works so fine....
Real computing is a IBM Mainfraime. I love the real System-Console and so on...
When you ever worked with such a machine you know what it really means..
Mouting tapes, inserting paper in a line-printer, starting jobs with real
cards, all that i have done and it was the most fun with this old machines and
technics.

So since 1977 I've gone from FORTRAN, to Assembler, to PL/I, to Business
BASIC, to MS-COBOL, to Power Basic, to GnuCOBOL. At each language change my
code generators have gained more features -- so now my non-OOP Power Basic
is generating OOP GnuCOBOL. The application specs have essentially remained
unchanged for 30 years, but the code looks a lot more sexy, now that I'm
back with COBOL. :-)

By the way, COBJAPI just keeps getting better. A simple event loop
integrates nicely with our GnuCOBOL classes, especially now that we seem to
have overcome some issues with ENTRY and CALL. ;-)

Rod

...
this is amazing what you can do with this compiler and now that java GUI
can be invoked using COBJAPI i feel so great.

I want to thank everyone for your help in getting me started in GnuCOBOL.
I was able to develop my first two COBOL programs from scratch. I used
several FUNCTIONs, built several multidimensional arrays, and called a C
program to return several values back to my program. These were the first
COBOL programs I've developed from scratch. I've done minor COBOL
maintenance in the past. We successfully implemented my two programs for
an ADP to Construction Management System interface at a company with over
20,000 employees. The project was a huge success and my team will use
these two programs as models for future development.

Thank you and Thank you again!!!

Mmmm... to me the tutuorialspoint stuff is pretty shoddy. To imply that
you need Hercules to run COBOL is... let's say, quaint. On top of that
they seem to imply that a Hercules user would use z/OS. z/OS is a
licensed product, and IBM will not, full-stop and no questions, license
it for Hercules.

I think I've yet to see a page from there that I didn't dislike, because
it will confuse, mislead or plain lie to a new user of COBOL, through
omission and commission.

I think the Cork stuff is orders of magnitude more useful to someone
starting out with COBOL.

I do not think tutorialspoint should be linked-to from the GnuCOBOL
Project.  We can obviously discuss this further, If necessary, I can
come up with an "oh, no, I don't like the look of that" for, say, each
of 20 pages.

If the program you are working on is copyrighted by the Free Software
Foundation, then when someone else sends you a piece of code to add to the
program, we need legal papers to use it—just as we asked you to sign papers
initially. Each person who makes a nontrivial contribution to a program must
sign some sort of legal papers in order for us to have clear title to the
program; the main author alone is not enough.

So, before adding in any contributions from other people, please tell us, so we
can arrange to get the papers. Then wait until we tell you that we have
received the signed papers, before you actually use the contribution.

This applies both before you release the program and afterward. If you receive
diffs to fix a bug, and they make significant changes, we need legal papers for
that change.

This also applies to comments and documentation files. For copyright law,
comments and code are just text. Copyright applies to all kinds of text, so we
need legal papers for all kinds.

Entries MUST be L/GPL. That's Lesser General Public License and/or General
Public Licence.

Authors MUST be willing to hand copyright over to the FSF.

COBOL source modules MUST compile warning/error free, with options

1. -W
2. with any of the standard "-std=" options.
3. with either option -fixed(default) or -free
4. Any/all combination of above

Further these COBOL modules MUST execute correctly however they have been
compiled (-std=).

Should work. Preferable they compile warning free with -Wall (not have to).
Reference format doesn't matter. If it doesn't work with some configurations
(or better: need a specific configuration) this has to be documented.

Hi folks!

We're starting to translate upcoming versions into different
languages. The necessary code changes for OC 2.0 were already done.
Now we need translators.

Before posting every stuff here I want to gather the translators
here. Who is able and willing to translate the strings (currently 667)
into what language(s)
[or has somebody who does this]?

From the last discussions I remember people wanting to do this for
French, Italian, Spanish, German but I don't remember who exactly said
that he/she will help. We already have a Japanese translation, but
that needs an heavy update.

...

GnuCOBOL 2.0 includes support for English, Spanish and Japanese
messages, errors and warnings.  Source portable object .po files
are nearly complete for Dutch, French and German.  Italian can't
be too far off.

$ apt-get source open-cobol

As an example; here is a SourceForge message with a code block.  Blank line
before the tildes counts, otherwise it isn't seen as a code block paragraph.
Sadly, spaces in a visually blank line can confuse the start of paragraph
detection.  If it looks like highlighting should be working, and isn't,
backspace over the preceding line, just in case.

~~~~~~
::cobol
 SAMPLE
       * Next big thing
        IDENTIFICATION DIVISION.
        PROGRAM-ID. big-thing-42.
        PROCEDURE DIVISION.
        DISPLAY "ok, what now?"
        GOBACK.
~~~~~~
then more message, (and the message part doesn't need the blank line after
the closing tildes, as the closers inform the markup of what's what).

~~~~~~
::cobolfree
    PERFORM 3 TIMES
        DISPLAY "Yeah, that!"
    END-PERFORM
~~~~~~

and more message, which can have a preceding blank line.

Otherwise, to get the forge to highlight code, indent the block by four
spaces.  The tildes can be more convient for COBOL listings though,
as it can save moving text around, inside the browser edit widget.

SAMPLE
      * Next big thing
       IDENTIFICATION DIVISION.
       PROGRAM-ID. big-thing-42.
       PROCEDURE DIVISION.
       DISPLAY "ok, what now?"
       GOBACK.

PERFORM 3 TIMES
    DISPLAY "Yeah, that!"
END-PERFORM

identification division.
program-id. freeze.

data division.
working-storage section.
01 hell                   pic 9.
   88 hell-freezes-over value 1.

procedure division.
perform jumps thru flaming-hoops until hell-freezes-over.
stop run.

jumps.
flaming-hoops.
divide 1 by 0 giving hell.

*> ********************************************************
*>  frogSort, called for help with 10-94, request for count
*>  The Weinersmith Fly By Frog Sort, weiner sort for short
*> ********************************************************
 identification division.
 program-id. frogsort.
 data division.
 working-storage section.
 01 opinion          usage binary-long.
 01 shared-value     pic 99.
    88 fair          value 1.
 01 caveman-count    pic x(12) value "[-]+++++++++".
 01 spacer           pic x(10) value spaces.

 linkage section.
 01 jars.
    05 flies        pic 9 occurs 21 times.

*> ********************************************************
 procedure division using jars.
 start-here.
 move function length(jars) to shared-value
 display "Grog sort jars.  frogSort"
 display "http://www.smbc-comics.com/?id=2831"
 .

 forkanother.
     call "fork" returning opinion end-call
     if opinion is zero then
         subtract 1 from shared-value
         if not fair then go forkanother.
 .

 call "sleep" using by value flies(shared-value) end-call
 display
     "Jar: " function char(shared-value + 65) " reporting "
     caveman-count(1 : flies(shared-value) + 3) " flies,"
     spacer(1 : 10 - flies(shared-value))
     "that would be " flies(shared-value) " to you, futureman."
 call "wait" using by value 0

 stop run returning 107.
 end program frogsort.

prompt$ ./cbrainrun
10-12 Welcome to cbrain v0.42
cb: 1094
cb: help
Grog sort jars.  frogSort
http://www.smbc-comics.com/?id=2831
Jar: U reporting [-] flies,          that would be 0 to you, futureman.
Jar: K reporting [-] flies,          that would be 0 to you, futureman.
Jar: A reporting [-] flies,          that would be 0 to you, futureman.
Jar: L reporting [-]+ flies,         that would be 1 to you, futureman.
Jar: B reporting [-]+ flies,         that would be 1 to you, futureman.
Jar: M reporting [-]++ flies,        that would be 2 to you, futureman.
Jar: C reporting [-]++ flies,        that would be 2 to you, futureman.
Jar: N reporting [-]+++ flies,       that would be 3 to you, futureman.
Jar: D reporting [-]+++ flies,       that would be 3 to you, futureman.
Jar: O reporting [-]++++ flies,      that would be 4 to you, futureman.
Jar: E reporting [-]++++ flies,      that would be 4 to you, futureman.
Jar: P reporting [-]+++++ flies,     that would be 5 to you, futureman.
Jar: F reporting [-]+++++ flies,     that would be 5 to you, futureman.
Jar: Q reporting [-]++++++ flies,    that would be 6 to you, futureman.
Jar: G reporting [-]++++++ flies,    that would be 6 to you, futureman.
Jar: R reporting [-]+++++++ flies,   that would be 7 to you, futureman.
Jar: H reporting [-]+++++++ flies,   that would be 7 to you, futureman.
Jar: S reporting [-]++++++++ flies,  that would be 8 to you, futureman.
Jar: I reporting [-]++++++++ flies,  that would be 8 to you, futureman.
Jar: T reporting [-]+++++++++ flies, that would be 9 to you, futureman.
Jar: J reporting [-]+++++++++ flies, that would be 9 to you, futureman.

 program-id. one.
 procedure division. add
 1 to return-code.

*btiffin*

springing into life
soaking sun, drinking summer
falling to winter

0[5-7-5 in cbrain]

 72 . 65
. 73 . 75 .
 85 . 42

There are several references to "COBOL 85" and these are often
distinguished from "Intrinsic Functions".

The official (but really obscure) term that should be used is "Amended
Third Standard COBOL". The "clearer" (and IMHO better) term that should
be used is something like

 - "'85 Standard COBOL with its amendments"

By 1991 (actually 1993 for ISO rather than ANSI) there was no such thing
as "just '85 Standard COBOL". The only recognized Standard was the
"base" document (X3.23-1985) ALONG with its two amendments
 - Intrinsic Functions Module Amendment
 - Corrections Amendment

An interesting related fact is that the "Intrinsic Functions Module" was
OPTIONAL in the ANSI and ISO COBOL Standards but was REQUIRED (at the
HIGH level) for FIPS COBOL. As the "certification tests" were aimed at
getting US government contracts, most vendors (who were still doing
certification) actually treated Intrinsic Functions required not
optional for "High-level" certification. (They were NOT included in the
FIPS intermediate certification process).

Bottom-Line:
 Although some intrinsic functions were added in the '02 Standard (and
more are included in the draft revision), it is not proper (in my
opinion) to distinguish between supporting the '85 Standard and
supporting intrinsic functions.

P.S. The corrections amendment did make some technical changes but all
of these were included in the '02 Standard. Therefore, hopefully, what
it did won't impact OpenCOBOL much.

$ tar xvf gnucobol-2.2tar.gz
$ cd gnucobol-2.2
$ ./configure
$ make
$ make check
$ sudo make install
$ sudo ldconfig

$ svn checkout svn://svn.code.sf.net/p/gnucobol/code/trunk gnucobol
$ cd gnucobol/

$ build_aux/bootstrap

$ mkdir build
$ cd build
$ ../configure --help   # to see any options you may want to tweak
$ ../configure          # note the .. up directory, while in build/

$ make
$ make check

$ make check-all

$ sudo make install
$ sudo ldconfig

$ type cobc
$ cobc --version

$ tar xvf gnucobol-2.2.tar.gz
$ cd gnucobol-2.2
$ ./configure
$ make
$ make check     # (or make checkall)
$ sudo make install
$ sudo ldconfig

$ tar xvf gnu-cobol-3.0-rc-1.tar.gz
$ cd gnucobol-3.0
$ ./configure
$ make
$ make check
$ make test
$ sudo make install
$ sudo ldconfig

$ ./occurlrefresh

$ svn checkout svn://svn.code.sf.net/p/gnucobol/code/branches/reportwriter \
  gnu-cobol-rw
$ cd gnu-cobol-rw/

$ mkdir reportwriter
$ wget -N -e robots=off -r -np -nH --cut-dirs =5 \
  http://svn.code.sf.net/p/gnucobol/code/branches/reportwriter
$ chmod 775 configure tests/testsuite
$ touch cobc/*pars*.c* cobc/pplex.c* cobc/scanner.c* cobc/*.hpp tests/testsuite

$ build_aux/bootstrap

$ mkdir build
$ cd build
$ ../configure --help   # to see any options you may want to tweak
$ ../configure          # note the .. up directory, while in build/

$ make
$ make check
$ sudo make install
$ sudo ldconfig

$ cd tests/cobol85
$ wget http://www.itl.nist.gov/div897/ctg/suites/newcob.val.Z
$ uncompress newcob.val.Z
$ make test

$ wget http://sourceforge.net/projects/gnucobol/files/gnu-cobol/3.0/gnucobol-3.0-rc1.tar.gz
$ tar xvf gnucobol-3.0.tar.gz
$ cd gnu-cobol-3.0
$ ./configure
$ make
$ make check
$ sudo make install
$ sudo ldconfig

wget -N -e robots=off -r -np -nH --cut-dirs =5 \
    http://svn.code.sf.net/p/gnucobol/code/branches/gnu-cobol-2.0

wget -N -e robots=off -r -np -nH --cut-dirs =5 \
    http://svn.code.sf.net/p/gnucobol/code/branches/reportwriter

wget -N -e robots=off -r -np -nH --cut-dirs =5 \
    http://svn.code.sf.net/p/gnucobol/code/branches/gnu-cobol-cpp

wget -N -e robots=off -r -np -nH --cut-dirs =5 \
    http://svn.code.sf.net/p/gnucobol/code/branches/gnu-cobol-builtin-script

$ apt-get install open-cobol (old version now)

$ apt install gnucobol

export COB_LD_FLAGS+='-Wl, --no-as-needed'

cobc -Q "-Wl, --no-as-needed"

$ yum install open-cobol (old version)

$ sudo dnf install gnucobol

I worked with Realia COBOL 4.2 for OS/2 and DOS back in the early 1990's.
It was an excellent compiler, but too expensive for me to buy for personal
use.  Unlike Microfocus COBOL, there were no license fees for executables
you created using Realia COBOL. CA (formerly Computer Associates) bought
Realia, and I don't think CA-Realia COBOL is available any more.

Two days was just for me to fumble around with building the GnuCOBOL 2.0
from source, while writing a manual (still unfinished) on how to do it. My
end goal is to create an installer for the GnuCOBOL 2.0 (like I did for
GnuCOBOL 1.1) so you can run a setup.exe for it like any other windows
application. But if GC 2.0 will be included in a future release of
OpenCOBOLIDE that would be even better.

I have a working version of GnuCOBOL 2.0 (r624 from 10JUL2015) built with
MinGW, if you would like to try it, but it's a 52 megabyte zip file with
no documentation or installer. You can download it from here:

http://www.arnoldtrembley.com/GC20base.zip

Create a folder named something like c:\GnuCOBOL or C:\GC20 and unzip the
contents into it while preserving the directory structure. Read the CMD
files for an idea of how to setup the environment variables. Several
months ago I tested it with OpenCOBOLIDE, and I was able to compile a
small COBOL program.

Good Job Arnold. This is what I need.

Just downloaded, unpacked and it works out of the box !  1 minute for
installation.  After that I configured preferences in OCIDE and all works
fine.  Thanks a lot.

I suggest to store this zip file or something similar into the sourceforge
site.

On Mac OS X 10.5.x/10.6.x, I have successfully managed to compile and install
OpenCOBOL 1.0.0 (including libdb linking), and am now happily compiling
production systems with it. It's not *entirely* straightforward, as it involves
installing GMP via MacPorts -- the *only way* that GMP will install properly
because of some eccentricities in Apple's Xcode development tools (particularly
with relation to c99 in gcc), unless you are willing to patch things by hand.
In addition, the earlier BerkeleyDB versions (the 4.x.x ones available via
MacPorts) cause some strange ioctl errors at runtime under Mac OS X Leopard and
Snow Leopard when attempting certain types of ORGANIZATION IS INDEXED
operations; precisely what conditions causes this I am yet to fully ascertain.
The upshot of it is that in order to compile and run a complete OpenCOBOL 1.0.0
installation on Leopard and Snow Leopard, one has to 1) install GMP via
MacPorts; but 2) compile and install a recent version of BerkeleyDB natively.

Probably at some point, I'm going to package this into a pretty-pretty
precompiled .app and .dmg along with a rudimentary Cocoa compiler interface.
Until then, however -- my COBOL on Mac comrades! -- please do the following:

-- INSTALLATION STEPS (Tested on both 10.5.x and 10.6.x) --
1) Download an appropriate MacPorts distribution for your OS:
<http://distfiles.macports.org/MacPorts/>
If you want to use the installer:
* For 10.5.x: MacPorts-1.8.0-10.5-Leopard.dmg
* For 10.6.x: MacPorts-1.8.0-10.6-SnowLeopard.dmg
From source, MacPorts-1.8.0.tar.gz is confirmed to work on both versions.
NB: Make sure PATH is properly set by install in your active user's ~/.profile.
2) Update MacPorts: sudo port -d selfupdate
3) Install GMP with MacPorts: sudo port install gmp
4) Download the Oracle Berkeley DB 5.0.21 (or later) .tar.gz source:
<http://www.oracle.com/technology/products/berkeley-db/db/index.html>
5) Untar, cd to the Berkeley DB source folder, then:
cd /build_unix
6) Do the following to configure, make and install Berkeley DB:
../dist/configure
make
sudo make install
7) Download and untar OpenCOBOL 1.0.0, cd to directory
8) Run ./configure, setting CPPFLAGS and LDFLAGS as below (CHANGING ANY
VERSION-SPECIFIC PATHS TO WHAT YOU JUST INSTALLED) as follows:

./configure
CPPFLAGS="-I/opt/local/var/macports/software/gmp/5.0.1_0/opt/local/include/
-I/usr/local/BerkeleyDB.5.0/include/"
LDFLAGS="-L/opt/local/var/macports/software/gmp/5.0.1_0/opt/local/lib
-L/usr/local/BerkeleyDB.5.0/lib/"

9) Make and install:
make
sudo make install
10) Et voila! Try exiting the directory and invoking cobc.

-- YOU SHOULD THEN BE ABLE TO DO SOMETHING LIKE THIS: --

phrygia.ganymede-labs.com:bottles ganymede$ sw_vers
ProductName: Mac OS X
ProductVersion: 10.5.6
BuildVersion: 9G55
phrygia.ganymede-labs.com:bottles ganymede$ cobc -V
cobc (OpenCOBOL) 1.0.0
Copyright (C) 2001-2007 Keisuke Nishida
Copyright (C) 2007 Roger While
phrygia.ganymede-labs.com:bottles ganymede$ cobc -v -x bottles.cbl
preprocessing bottles.cbl into
/var/folders/KI/KI15WC0KGMmvvO980RztgU+++TI/-Tmp-//cob75450_0.cob translating
/var/folders/KI/KI15WC0KGMmvvO980RztgU+++TI/-Tmp-//cob75450_0.cob into
/var/folders/KI/KI15WC0KGMmvvO980RztgU+++TI/-Tmp-//cob75450_0.c
  gcc -pipe -c -I/usr/local/include
-I/opt/local/var/macports/software/gmp/5.0.1_0/opt/local/include/
-I/usr/local/BerkeleyDB.5.0/include/ -I/usr/local/include -O2 -Wno-unused
-fsigned-char -Wno-pointer-sign -o
/var/folders/KI/KI15WC0KGMmvvO980RztgU+++TI/-Tmp-//cob75450_0.o
/var/folders/KI/KI15WC0KGMmvvO980RztgU+++TI/-Tmp-//cob75450_0.c gcc -pipe
-L/opt/local/var/macports/software/gmp/5.0.1_0/opt/local/lib
-L/usr/local/BerkeleyDB.5.0/lib/ -o bottles
/var/folders/KI/KI15WC0KGMmvvO980RztgU+++TI/-Tmp-//cob75450_0.o
-L/opt/local/var/macports/software/gmp/5.0.1_0/opt/local/lib
-L/usr/local/BerkeleyDB.5.0/lib/ -L/usr/local/lib -lcob -lm -lgmp
-L/usr/local/lib -lintl -liconv -lc -R/usr/local/lib -lncurses -ldb


With lots of sloppy LINKAGE SECTION kisses,
-- Ganymede

I tried brew install gnu-cobol --universal but that just installs the
64 bit version. I would prefer to compile from source: which means
installing 32 bit versions of libdb and gmp.  brew install gmp --32-bit
will install a 32 bit version of gmp, but this option does not affect the
installation of libdb.

I compiled db-6.1.26 with CFLAGS=-m32 and installed it, and then built
GnuCOBOL with: ./configure CFLAGS=-m32
CPPFLAGS=-I/usr/local/BerkeleyDB.6.1/include/
LDFLAGS=-L/usr/local/BerkeleyDB.6.1/lib/

This works!

1) brew install gmp@4
2) export LDFLAGS='-L/usr/local/opt/gmp@4/lib'
3) export CPPFLAGS='-I/usr/local/opt/gmp@4/include'
4) ./configure

One update:

export LDFLAGS='-L/usr/local/opt/gmp@4/lib -L/usr/local/opt/berkeley-db/lib'
export CPPFLAGS='-I/usr/local/opt/gmp@4/include -I/usr/local/opt/berkeley-db/include'
./configure

Just to document this a little further as I've got this install down pat and
repeated many times - to do an install of Opencobol-1.1 on a newly installed
Centos-6.6:

After installing a "Basic Server" Centos-6.6 from CD 1 of 2…

Login to your CentOS Box, and su to root

install dependencies 1 of 2
yum install gmp gmp-devel libtool ncurses ncurses-devel ncurses-libs make

install dependencies 2 of 2
yum install libdbi libdbi-devel libtool-ltdl libtool-ltdl-devel db4 db4-devel

Obtain gmp-5.1.3.tar; ./configure; make; make check; make install

Download open-cobol 1.1.tar.gz; you can use wget
yum install wget
wget http://downloads.sourceforge.net/project/open-cobol/
Copy to say /usr/local and decompress and extract

cd /usr/local/open-cobol-1.1

Build and install with ./configure; make; make check; make install

$ wget http://sourceforge.net/projects/gnucobol/files/gnu-cobol/1.1/gnu-cobol-1.1.tar.gz
 ...
$ cd ...gnu-cobol-1.1
 ...

Hi Guys

I have installed GnuCOBOL on Minix 3. I just wanted to report about it and
leave a some instructions if someone is interested later.

I think that these instructions will help with BSD installs as Minix heavily
borrows from NetBSD.

But first off, why Minix?

Minix was just a toy when Linus studied it but it has gone through revisions.
Minix 3 aims to be a high reliability embedded OS.

It is highly compartmentalized and a failure in a driver should not bring it
down. Also there is a reincarnation server that will try to revive drivers
that have failed.

Drivers are in userland.

It's much smaller then Linux.

However it has a very small user base. You can't just assume that things have
been tested, there isn't enough of a community to get the coverage and things
need to be well tested without relying on the herd for protection.

Here is how things went:

I installed gmp 5.1.3 and VBISAM both with configure prefix="/usr"

vbisam needed chmod +x install-sh

I renamed doc/cbrunt.tex to hide it and I touched to create an empty
cbrunt.tex file

I installed texi2html 1.82 I am not sure it helped with anything

I installed help2man-1.44.1

I installed bison and flex Fromm the minix repo(which is really mostly
untested NetBSD packages)

I installed autoconf 2.69 and automake 1.15 both with prefix="/usr"

autoconf failed at test 503 with make check but I installed it anyways.

I installed GnuCOBOL with configure --with-vbisam

692 test ran, 4 failed, 2 were expected fails.

The two unexpected fails were:
COB_PRE_LOAD with entry points
First read on empty sequential file.

I don't think Minix has shared objects and I didn't need libtool

the compiler was clang.

`configure' configures GnuCOBOL 1.1 to adapt to many kinds of systems.

Usage: ./configure [OPTION]... [VAR=VALUE]...

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.

Configuration:
  -h, --help              display this help and exit
      --help=short        display options specific to this package
      --help=recursive    display the short help of all the included packages
  -V, --version           display version information and exit
  ---quiet, --silent   do not print `checking...' messages
      --cache-file=FILE   cache test results in FILE [disabled]
  -C, --config-cache      alias for `--cache-file=config.cache'
  -n, --no-create         do not create output files
      --srcdir=DIR        find the sources in DIR [configure dir or `..']

Installation directories:
  --prefix=PREFIX         install architecture-independent files in PREFIX
                          [/usr/local]
  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
                          [PREFIX]

By default, `make install' will install all the files in
`/usr/local/bin', `/usr/local/lib' etc.  You can specify
an installation prefix other than `/usr/local' using `--prefix',
for instance `--prefix=$HOME'.

For better control, use the options below.

Fine tuning of the installation directories:
  --bindir=DIR           user executables [EPREFIX/bin]
  --sbindir=DIR          system admin executables [EPREFIX/sbin]
  --libexecdir=DIR       program executables [EPREFIX/libexec]
  --datadir=DIR          read-only architecture-independent data [PREFIX/share]
  --sysconfdir=DIR       read-only single-machine data [PREFIX/etc]
  --sharedstatedir=DIR   modifiable architecture-independent data [PREFIX/com]
  --localstatedir=DIR    modifiable single-machine data [PREFIX/var]
  --libdir=DIR           object code libraries [EPREFIX/lib]
  --includedir=DIR       C header files [PREFIX/include]
  --oldincludedir=DIR    C header files for non-gcc [/usr/include]
  --infodir=DIR          info documentation [PREFIX/info]
  --mandir=DIR           man documentation [PREFIX/man]

Program names:
  --program-prefix=PREFIX            prepend PREFIX to installed program names
  --program-suffix=SUFFIX            append SUFFIX to installed program names
  --program-transform-name=PROGRAM   run sed PROGRAM on installed program names

System types:
  --build=BUILD     configure for building on BUILD [guessed]
  --host=HOST       cross-compile to build programs to run on HOST [BUILD]

Optional Features:
  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]
  --enable-maintainer-mode  enable make rules and dependencies not useful
                          (and sometimes confusing) to the casual installer
  --disable-dependency-tracking  speeds up one-time build
  --enable-dependency-tracking   do not reject slow dependency extractors
  --enable-experimental   (GnuCOBOL) enable experimental code (Developers only!)
  --enable-param-check    (GnuCOBOL) enable CALL parameter checking
  --enable-shared[=PKGS]
                          build shared libraries [default=yes]
  --enable-static[=PKGS]
                          build static libraries [default=yes]
  --enable-fast-install[=PKGS]
                          optimize for fast installation [default=yes]
  --disable-libtool-lock  avoid locking (might break parallel builds)
  --disable-rpath         do not hardcode runtime library paths
  --disable-nls           do not use Native Language Support

Optional Packages:
  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
  --with-cc=<cc>          (GnuCOBOL) specify the C compiler used by cobc
  --with-seqra-extfh      (GnuCOBOL) Use external SEQ/RAN file handler
  --with-cisam            (GnuCOBOL) Use CISAM for ISAM I/O
  --with-disam            (GnuCOBOL) Use DISAM for ISAM I/O
  --with-vbisam           (GnuCOBOL) Use VBISAM for ISAM I/O
  --with-index-extfh      (GnuCOBOL) Use external ISAM file handler
  --with-db1              (GnuCOBOL) use Berkeley DB 1.85 (libdb-1.85)
  --with-db               (GnuCOBOL) use Berkeley DB 3.0 or later (libdb)(default)
  --with-lfs64            (GnuCOBOL) use large file system for file I/O (default)
  --with-dl               (GnuCOBOL) use system dynamic loader (default)
  --with-patch-level      (GnuCOBOL) define a patch level (default 0)
  --with-varse         (GnuCOBOL) define variable sequential format (default 0)
  --with-gnu-ld           assume the C compiler uses GNU ld [default=no]
  --with-pic              try to use only PIC/non-PIC objects [default=use
                          both]
  --with-tags[=TAGS]
                          include additional configurations [automatic]
  --with-gnu-ld           assume the C compiler uses GNU ld default=no
  --with-libiconv-prefix[=DIR]  search for libiconv in DIR/include and DIR/lib
  --without-libiconv-prefix     don't search for libiconv in includedir and libdir
  --with-libintl-prefix[=DIR]  search for libintl in DIR/include and DIR/lib
  --without-libintl-prefix     don't search for libintl in includedir and libdir

Some influential environment variables:
  CC          C compiler command
  CFLAGS      C compiler flags
  LDFLAGS     linker flags, e.g. -L<lib dir> if you have libraries in a
              nonstandard directory <lib dir>
  CPPFLAGS    C/C++ preprocessor flags, e.g. -I<include dir> if you have
              headers in a nonstandard directory <include dir>
  CPP         C preprocessor
  CXXCPP      C++ preprocessor

Use these variables to override the choices made by 'configure' or to help
it to find libraries and programs with nonstandard names/locations.

Report bugs to <open-cobol-list@lists.sourceforge.net>.

000100* HELLO.COB GnuCOBOL FAQ example
000200 IDENTIFICATION DIVISION.
000300 PROGRAM-ID. hello.
000400 PROCEDURE DIVISION.
000500     DISPLAY "Hello, world".
000600     STOP RUN.

$ cobc -E hello.cob

# 1 "hello.cob"

IDENTIFICATION DIVISION.
PROGRAM-ID. hello.
PROCEDURE DIVISION.
 DISPLAY "Hello, world".
 STOP RUN.

$ cobc -C hello.cob

/* Generated by            cobc 1.1.0 */
/* Generated from          hello.cob */
/* Generated at            Oct 04 2008 00:19:36 EDT */
/* GnuCOBOL build date    Oct 01 2008 22:15:19 */
/* GnuCOBOL package date  Oct 01 2008 16:31:26 CEST */
/* Compile command         cobc -C hello.cob */

/* PROGRAM-ID : hello */

static unsigned char b_5[4] __attribute__((aligned));        /* COB-CRT-STATUS */
static unsigned char b_1[4] __attribute__((aligned));        /* RETURN-CODE */
static unsigned char b_2[4] __attribute__((aligned));        /* SORT-RETURN */
static unsigned char b_3[4] __attribute__((aligned));        /* NUMBER-OF-CALL-PARAMETERS */

/* attributes */
static cob_field_attr a_1        = {16, 4, 0, 0, NULL};
static cob_field_attr a_2        = {33, 0, 0, 0, NULL};

/* fields */
static cob_field f_5        = {4, b_5, &a_1};        /* COB-CRT-STATUS */

/* constants */
static cob_field c_1        = {12, (unsigned char *)"Hello, world", &a_2};

/* ---------------------------------------------- */

/* Generated by            cobc 1.1.0 */
/* Generated from          hello.cob */
/* Generated at            Oct 04 2008 00:19:36 EDT */
/* GnuCOBOL build date    Oct 01 2008 22:15:19 */
/* GnuCOBOL package date  Oct 01 2008 16:31:26 CEST */
/* Compile command         cobc -C hello.cob */

#define  __USE_STRING_INLINES 1
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include <libcob.h>

#define COB_SOURCE_FILE                "hello.cob"
#define COB_PACKAGE_VERSION        "1.1"
#define COB_PATCH_LEVEL                0

/* function prototypes */
static int hello_ (const int);

int hello (void);


/* functions */

int
hello ()
{
  return hello_ (0);
}

/* end functions */

static int
hello_ (const int entry)
{

#include "hello.c.h"  /* local variables */

  static int initialized = 0;
  static cob_field *cob_user_parameters[COB_MAX_FIELD_PARAMS];
  static cob_module module = { NULL, NULL, &f_5, NULL, cob_user_parameters, 0, '.',
                               '$', ',', 1, 1, 1, 0};


  /* perform frame stack */
  int frame_index;
  struct frame {
    int  perform_through;
    void *return_address;
  } frame_stack[255];

  /* Start of function code */

  if (unlikely(entry < 0)) {
    if (!initialized) {
        return 0;
    }
    initialized = 0;
    return 0;
  }

  module.next = cob_current_module;
  cob_current_module = &module;

  if (unlikely(initialized == 0))
    {
      if (!cob_initialized) {
        cob_fatal_error (COB_FERROR_INITIALIZED);
      }
      cob_check_version (COB_SOURCE_FILE, COB_PACKAGE_VERSION, COB_PATCH_LEVEL);
      if (module.next)
        cob_set_cancel ((const char *)"hello", (void *)hello, (void *)hello_);
      (*(int *) (b_1)) = 0;
      (*(int *) (b_2)) = 0;
      (*(int *) (b_3)) = 0;
      memset (b_5, 48, 4);


      initialized = 1;
    }

  /* initialize frame stack */
  frame_index = 0;
  frame_stack[0].perform_through = -1;

  /* initialize number of call params */
  (*(int *) (b_3))   = cob_call_params;
  cob_save_call_params = cob_call_params;

  goto l_2;

  /* PROCEDURE DIVISION */


  /* hello: */

  l_2:;

  /* MAIN SECTION: */

  /* MAIN PARAGRAPH: */

  /* hello.cob:5: DISPLAY */
  {
    cob_new_display (0, 1, 1, &c_1);
  }
  /* hello.cob:6: STOP */
  {
    cob_stop_run ((*(int *) (b_1)));
  }

  cob_current_module = cob_current_module->next;
  return (*(int *) (b_1));

}

/* end function stuff */

$ cobc -S hello.cob

    .file        "cob9141_0.c"
    .text
.globl hello
    .type        hello, @function
hello:
    pushl        %ebp
    movl        %esp, %ebp
    subl        $8, %esp
    movl        $0, (%esp)
    call        hello_
    leave
    ret
    .size        hello, .-hello
    .data
    .align 4
    .type        module.5786, @object
    .size        module.5786, 28
module.5786:
    .long        0
    .long        0
    .long        f_5.5782
    .long        0
    .long        cob_user_parameters.5785
    .byte        0
    .byte        46
    .byte        36
    .byte        44
    .byte        1
    .byte        1
    .byte        1
    .byte        0
    .local        cob_user_parameters.5785
    .comm        cob_user_parameters.5785,256,32
    .local        initialized.5784
    .comm        initialized.5784,4,4
    .section        .rodata
.LC0:
    .string        "Hello, world"
    .data
    .align 4
    .type        c_1.5783, @object
    .size        c_1.5783, 12
c_1.5783:
    .long        12
    .long        .LC0
    .long        a_2.5781
    .align 4
    .type        f_5.5782, @object
    .size        f_5.5782, 12
f_5.5782:
    .long        4
    .long        b_5.5776
    .long        a_1.5780
    .align 4
    .type        a_2.5781, @object
    .size        a_2.5781, 8
a_2.5781:
    .byte        33
    .byte        0
    .byte        0
    .byte        0
    .long        0
    .align 4
    .type        a_1.5780, @object
    .size        a_1.5780, 8
a_1.5780:
    .byte        16
    .byte        4
    .byte        0
    .byte        0
    .long        0
    .local        b_3.5779
    .comm        b_3.5779,4,16
    .local        b_2.5778
    .comm        b_2.5778,4,16
    .local        b_1.5777
    .comm        b_1.5777,4,16
    .local        b_5.5776
    .comm        b_5.5776,4,16
    .section        .rodata
.LC1:
    .string        "1.1"
.LC2:
    .string        "hello.cob"
.LC3:
    .string        "hello"
    .text
    .type        hello_, @function
hello_:
    pushl        %ebp
    movl        %esp, %ebp
    subl        $2072, %esp
    movl        8(%ebp), %eax
    shrl        $31, %eax
    testl        %eax, %eax
    je        .L4
    movl        initialized.5784, %eax
    testl        %eax, %eax
    jne        .L5
    movl        $0, -2052(%ebp)
    jmp        .L6
.L5:
    movl        $0, initialized.5784
    movl        $0, -2052(%ebp)
    jmp        .L6
.L4:
    movl        cob_current_module, %eax
    movl        %eax, module.5786
    movl        $module.5786, cob_current_module
    movl        initialized.5784, %eax
    testl        %eax, %eax
    sete        %al
    movzbl        %al, %eax
    testl        %eax, %eax
    je        .L7
    movl        cob_initialized, %eax
    testl        %eax, %eax
    jne        .L8
    movl        $0, (%esp)
    call        cob_fatal_error
.L8:
    movl        $0, 8(%esp)
    movl        $.LC1, 4(%esp)
    movl        $.LC2, (%esp)
    call        cob_check_version
    movl        module.5786, %eax
    testl        %eax, %eax
    je        .L9
    movl        $hello_, 8(%esp)
    movl        $hello, 4(%esp)
    movl        $.LC3, (%esp)
    call        cob_set_cancel
.L9:
    movl        $b_1.5777, %eax
    movl        $0, (%eax)
    movl        $b_2.5778, %eax
    movl        $0, (%eax)
    movl        $b_3.5779, %eax
    movl        $0, (%eax)
    movl        $4, 8(%esp)
    movl        $48, 4(%esp)
    movl        $b_5.5776, (%esp)
    call        memset
    movl        $1, initialized.5784
.L7:
    movl        $0, -4(%ebp)
    movl        $-1, -2044(%ebp)
    movl        $b_3.5779, %edx
    movl        cob_call_params, %eax
    movl        %eax, (%edx)
    movl        cob_call_params, %eax
    movl        %eax, cob_save_call_params
.L10:
    movl        $c_1.5783, 12(%esp)
    movl        $1, 8(%esp)
    movl        $1, 4(%esp)
    movl        $0, (%esp)
    call        cob_new_display
    movl        $b_1.5777, %eax
    movl        (%eax), %eax
    movl        %eax, (%esp)
    call        cob_stop_run
.L6:
    movl        -2052(%ebp), %eax
    leave
    ret
    .size        hello_, .-hello_
    .ident        "GCC: (Debian 4.3.1-9) 4.3.1"
    .section        .note.GNU-stack,"",@progbits

$ cobc -c hello.cob

$ cobc -m hello.cob
$ cobc hello.cob

$ cobc -b hello.cob

$ cobc -b hello.cob support.c

$ cobc -m hello.cob support.c

$ cobcrun hello
Hello, world

$ cobc -x hello.cob

$ ./hello
Hello, world

$ cobc -xj hello.cob
Hello, world

#!/usr/local/bin/cobc -xj
000100* HELLO.COB GnuCOBOL FAQ example
000200 IDENTIFICATION DIVISION.
000300 PROGRAM-ID. hello.
000400 PROCEDURE DIVISION.
000500     DISPLAY "Hello, world".
000600     STOP RUN.

$ ./hello-cobol.sh
Hello, world

-rwxrwxr-x. 1 btiffin btiffin  9730 Apr 22 00:25 hello
-rw-rw-r--. 1 btiffin btiffin  2253 Apr 22 00:26 hello.c
-rw-rw-r--. 1 btiffin btiffin   835 Apr 22 00:26 hello.c.h
-rw-rw-r--. 1 btiffin btiffin   391 Apr 22 00:26 hello.c.l.h
-rw-rw-r--. 1 btiffin btiffin   181 Apr 22 00:24 hello.cob
-rw-rw-r--. 1 btiffin btiffin  3288 Apr 22 00:24 hello.o
-rw-rw-r--. 1 btiffin btiffin  2577 Apr 22 00:26 hello.s
-rwxrwxr-x. 1 btiffin btiffin  9334 Apr 22 00:27 hello.so

$ cobc -x hello.cob
$ ./hello
Hello, world

$ cobc hello.cob
$ cobcrun hello
Hello, world

# build up a library, lots of subprograms in a single DSO
cobc -b multiprog.cob program??.cob

# run program06 in library multiprog, with a single argc/argv string
cobcrun -M multiprog program06 "command line argument"

# equivalent to cobcrun multiprog, without -M, if CWD is ~/cobol/multiprog
cobcrun -M /home/me/cobol/multiprog multiprog

# sample in a job control scenario
# exit code 0 is ok, 1 to 9 and the catch-all are problems,
#     30 thru 89 are special case codes that start program30, ..., program89
cobcrun -M /home/me/cobol/multiprog program27 "program27-inputfilename.dat" \
"program27-outputfilename.rpt"
case $? in
            0) echo "program27 complete" ;;
        [1-9]) echo "program27 fell over with status $?" ;;
   [3-8][0-9]) cobcrun -M /home/me/cobol/multiprog program$? "for say, state taxes"
            *) echo "batch job fell over with status $?" ;;
esac

$ cob-config
Usage: cob-config [OPTIONS]
Options:
        [--prefix[=DIR]]
        [--exec-prefix[=DIR]]
        [--version]
        [--libs]
        [--cflags]
$ cob-config --libs
-L/usr/local/lib -lcob -lm -lgmp -lncurses -ldb
$ cob-config --cflags
-I/usr/local/include

$ cobc -V
cobc (GnuCOBOL) 1.1.0
Copyright (C) 2001-2008 Keisuke Nishida / Roger While
Built    Oct 29 2008 16:32:02
Packaged Oct 28 2008 19:05:45 CET

$ cobc --help
Usage: cobc [options] file...

Options:
  --help                Display this message
  --version, -V         Display compiler version
  -v                    Display the programs invoked by the compiler
  -x                    Build an executable program
  -m                    Build a dynamically loadable module (default)
  -std=<dialect>        Compile for a specific dialect :
                          cobol2002   Cobol 2002
                          cobol85     Cobol 85
                          ibm         IBM Compatible
                          mvs         MVS Compatible
                          bs2000      BS2000 Compatible
                          mf          Micro Focus Compatible
                          default     When not specified
                        See config/default.conf and config/*.conf
  -free                 Use free source format
  -fixed                Use fixed source format (default)
  -O, -O2, -Os          Enable optimization
  -g                    Produce debugging information in the output
  -debug                Enable all run-time error checking
  -o <file>             Place the output into <file>
  -b                    Combine all input files into a single
                        dynamically loadable module
  -E                    Preprocess only; do not compile, assemble or link
  -C                    Translation only; convert COBOL to C
  -S                    Compile only; output assembly file
  -c                    Compile and assemble, but do not link
  -t <file>             Generate and place a program listing into <file>
  -I <directory>        Add <directory> to copy/include search path
  -L <directory>        Add <directory> to library search path
  -l <lib>              Link the library <lib>
  -D <define>           Pass <define> to the C compiler
  -conf=<file>          User defined dialect configuration - See -std=
  --list-reserved       Display reserved words
  --list-intrinsics     Display intrinsic functions
  --list-mnemonics      Display mnemonic names
  -save-temps(=<dir>)   Save intermediate files (default current directory)
  -MT <target>          Set target file used in dependency list
  -MF <file>            Place dependency list into <file>
  -ext <extension>      Add default file extension

  -W                    Enable ALL warnings
  -Wall                 Enable all warnings except as noted below
  -Wobsolete            Warn if obsolete features are used
  -Warchaic             Warn if archaic features are used
  -Wredefinition        Warn incompatible redefinition of data items
  -Wconstant            Warn inconsistent constant
  -Wparentheses         Warn lack of parentheses around AND within OR
  -Wstrict-typing       Warn type mismatch strictly
  -Wimplicit-define     Warn implicitly defined data items
  -Wcall-params         Warn non 01/77 items for CALL params (NOT set with -Wall)
  -Wcolumn-overflow     Warn text after column 72, FIXED format (NOT set with -Wall)
  -Wterminator          Warn lack of scope terminator END-XXX (NOT set with -Wall)
  -Wtruncate            Warn possible field truncation (NOT set with -Wall)
  -Wlinkage             Warn dangling LINKAGE items (NOT set with -Wall)
  -Wunreachable         Warn unreachable statements (NOT set with -Wall)

  -ftrace               Generate trace code (Executed SECTION/PARAGRAPH)
  -ftraceall            Generate trace code (Executed SECTION/PARAGRAPH/STATEMENTS)
  -fsyntax-only         Syntax error checking only; don't emit any output
  -fdebugging-line      Enable debugging lines ('D' in indicator column)
  -fsource-location     Generate source location code (Turned on by -debug or -g)
  -fimplicit-init       Do automatic initialization of the Cobol runtime system
  -fsign-ascii          Numeric display sign ASCII (Default on ASCII machines)
  -fsign-ebcdic         Numeric display sign EBCDIC (Default on EBCDIC machines)
  -fstack-check         PERFORM stack checking (Turned on by -debug or -g)
  -ffold-copy-lower     Fold COPY subject to lower case (Default no transformation)
  -ffold-copy-upper     Fold COPY subject to upper case (Default no transformation)
  -fnotrunc             Do not truncate binary fields according to PICTURE
  -ffunctions-all       Allow use of intrinsic functions without FUNCTION keyword
  -fmfcomment           '*' or '/' in column 1 treated as comment (FIXED only)
  -fnull-param          Pass extra NULL terminating pointers on CALL statements

GnuCOBOL compiler for most COBOL dialects with lots of extensions

Usage: cobc [options]... file...

Options:
  -h, -help             display this help and exit
  -V, -version          display compiler version and exit
  -i, -info             display compiler information (build/environment)
  -v, -verbose          display compiler version and the commands
                        invoked by the compiler
  -vv, -verbose=2       like -v but additional pass verbose option
                        to assembler/compiler
  -vvv, -verbose=3      like -vv but additional pass verbose option
                        to linker
  -q, -brief            reduced displays, commands invoked not shown
  -###                 like -v but commands not executed
  -x                    build an executable program
  -m                    build a dynamically loadable module (default)
  -j [<args>], -job[=<args>]    run program after build, passing <args>
  -std=<dialect>        warnings/features for a specific dialect
                        <dialect> can be one of:
                        cobol2014, cobol2002, cobol85, default,
                        ibm, mvs, bs2000, mf, acu;
                        see configuration files in directory config
  -F, -free             use free source format
  -fixed                use fixed source format (default)
  -O, -O2, -Os          enable optimization
  -g                    enable C compiler debug / stack check / trace
  -d, -debug            enable all run-time error checking
  -o <file>             place the output into <file>
  -b                    combine all input files into a single
                        dynamically loadable module
  -E                    preprocess only; do not compile or link
  -C                    translation only; convert COBOL to C
  -S                    compile only; output assembly file
  -c                    compile and assemble, but do not link
  -T <file>             generate and place a wide program listing
  into <file>
  -t <file>             generate and place a program listing into <file>
  --tlines=<lines>      specify lines per page in listing, default = 55
  --no-symbols          specify no symbols in listing
  -P[=<dir or file>]    generate preprocessed program listing (.lst)
  -Xref                 generate cross reference through 'cobxref'
                        (V. Coen's 'cobxref' must be in path)
  -I <directory>        add <directory> to copy/include search path
  -L <directory>        add <directory> to library search path
  -l <lib>              link the library <lib>
  -A <options>          add <options> to the C compile phase
  -Q <options>          add <options> to the C link phase
  -D <define>           define <define> for COBOL compilation
  -K <entry>            generate CALL to <entry> as static
  -conf=<file>          user-defined dialect configuration; see -std
  -list-reserved        display reserved words
  -list-intrinsics      display intrinsic functions
  -list-mnemonics       display mnemonic names
  -list-system          display system routines
  -save-temps[=<dir>]   save intermediate files
                        - default: current directory
  -ext <extension>      add file extension for resolving COPY

  -W                    enable all warnings
  -Wall                 enable most warnings (all except as noted below)
  -Wno-<warning>        disable warning enabled by -W or -Wall
  -Wno-unfinished       don't warn if unfinished features are used
                        - ALWAYS active
  -Wobsolete            warn if obsolete features are used
  -Warchaic             warn if archaic features are used
  -Wredefinition        warn incompatible redefinition of data items
  -Wconstant            warn inconsistent constant
  -Woverlap             warn overlapping MOVE items
  -Wpossible-overlap    warn MOVE items that may overlap depending on variables
                        - NOT set with -Wall
  -Wparentheses         warn lack of parentheses around AND within OR
  -Wstrict-typing       warn type mismatch strictly
  -Wimplicit-define     warn implicitly defined data items
  -Wcorresponding       warn CORRESPONDING with no matching items
  -Winitial-value       warn Initial VALUE clause ignored
  -Wprototypes          warn missing FUNCTION prototypes/definitions
  -Wcall-params         warn non 01/77 items for CALL params
                        - NOT set with -Wall
  -Wcolumn-overflow     warn text after program-text area, FIXED format
                        - NOT set with -Wall
  -Wterminator          warn lack of scope terminator END-XXX
                        - NOT set with -Wall
  -Wtruncate            warn possible field truncation
                        - NOT set with -Wall
  -Wlinkage             warn dangling LINKAGE items
                        - NOT set with -Wall
  -Wunreachable         warn unreachable statements
                        - NOT set with -Wall

  -fsign=[ASCII|EBCDIC] define display sign representation
                        - default: machine native
  -ffold-copy=[UPPER|LOWER]     fold COPY subject to value
                        - default: no transformation
  -ffold-call=[UPPER|LOWER]     fold PROGRAM-ID, CALL, CANCEL subject to value
                        - default: no transformation
  -fdefaultbyte=0..255  initialize fields without VALUE to decimal value
                        - default: initialize to picture
  -fintrinsics=[ALL|intrinsic function name(,name,...)] intrinsics to be used without FUNCTION keyword
  -ftrace               generate trace code
                        - executed SECTION/PARAGRAPH
  -ftraceall            generate trace code
                        - executed SECTION/PARAGRAPH/STATEMENTS
                        - turned on by -debug
  -fsyntax-only         syntax error checking only; don't emit any output
  -fdebugging-line      enable debugging lines
                        - 'D' in indicator column or floating >>D
  -fsource-location     generate source location code
                        - turned on by -debug/-g/-ftraceall
  -fimplicit-init       automatic initialization of the COBOL runtime system
  -fstack-check         PERFORM stack checking
                        - turned on by -debug or -g
  -fsyntax-extension    allow syntax extensions
                        - e.g. switch name SW1, etc.
  -fwrite-after         use AFTER 1 for WRITE of LINE SEQUENTIAL
                        - default: BEFORE 1
  -fmfcomment           '*' or '/' in column 1 treated as comment
                        - FIXED format only
  -facucomment          '$' in indicator area treated as '*',
                        '|' treated as floating comment
  -fnotrunc             allow numeric field overflow
                        - non-ANSI behaviour
  -fodoslide            adjust items following OCCURS DEPENDING
                        - requires implicit/explicit relaxed syntax
  -fsingle-quote        use a single quote (apostrophe) for QUOTE
                        - default: double quote
  -frecursive-check     check recursive program call
  -foptional-file       treat all files as OPTIONAL
                        - unless NOT OPTIONAL specified

  -ftab-width=1..12     set number of spaces that are asumed for tabs
  -ftext-column=72..255 set right margin for source (fixed format only)
  -fpic-length=<number> maximum number of characters allowed in the character-string
  -fword-length=1..61   maximum word-length for COBOL words / Programmer defined words
  -fliteral-length=<number>     maximum literal size in general
  -fnumeric-literal-length=1..38        maximum numeric literal size
  -fassign-clause=<value>       set way of interpreting ASSIGN
  -fbinary-size=<value> binary byte size - defines the allocated bytes according to PIC
  -fbinary-byteorder=<value>    binary byte order
  -ffilename-mapping    resolve file names at run time using environment variables.
  -fpretty-display      alternate formatting of numeric fields
  -fbinary-truncate     numeric truncation according to ANSI
  -fcomplex-odo         allow complex OCCURS DEPENDING ON
  -findirect-redefines  allow REDEFINES to other than last equal level number
  -flarger-redefines-ok allow larger REDEFINES items
  -frelax-syntax-checks allow certain syntax variations (e.g. REDEFINES position)
  -fperform-osvs        exit point of any currently executing perform is recognized if reached
  -fsticky-linkage      linkage-section items remain allocated between invocations
  -frelax-level-hierarchy       allow non-matching level numbers
  -fhostsign            allow hexadecimal value 'F' for NUMERIC test of signed PACKED DECIMAL field
  -faccept-update       set WITH UPDATE clause as default for ACCEPT dest-item, instead of WITH NO UPDATE
  -faccept-auto         set WITH AUTO clause as default for ACCEPT dest-item, instead of WITH TAB
  -fconsole-is-crt      assume CONSOLE IS CRT if not set otherwise
  -fprogram-name-redefinition   program names don't lead to a reserved identifier
  -fno-echo-means-secure        NO-ECHO hides input with asterisks like SECURE
  -fcomment-paragraphs=<support>        comment paragraphs in IDENTIFICATION DIVISION (AUTHOR, DATE-WRITTEN, ...)
  -fmemory-size-clause=<support>        MEMORY-SIZE clause
  -fmultiple-file-tape-clause=<support> MULTIPLE-FILE-TAPE clause
  -flabel-records-clause=<support>      LABEL-RECORDS clause
  -fvalue-of-clause=<support>   VALUE-OF clause
  -fdata-records-clause=<support>       DATA-RECORDS clause
  -ftop-level-occurs-clause=<support>   OCCURS clause on top-level
  -fsynchronized-clause=<support>       SYNCHRONIZED clause
  -fgoto-statement-without-name=<support>       GOTO statement without name
  -fstop-literal-statement=<support>    STOP-LITERAL statement
  -fdebugging-line=<support>    DEBUGGING MODE and indicator 'D'
  -fuse-for-debugging=<support> USE FOR DEBUGGING
  -fpadding-character-clause=<support>  PADDING CHARACTER clause
  -fnext-sentence-phrase=<support>      NEXT SENTENCE phrase
  -feject-statement=<support>   EJECT statement
  -fentry-statement=<support>   ENTRY statement
  -fmove-noninteger-to-alphanumeric=<support>   move noninteger to alphanumeric
  -fodo-without-to=<support>    OCCURS DEPENDING ON without to
  -fsection-segments=<support>  section segments
  -falter-statement=<support>   ALTER statement
  -fcall-overflow=<support>     OVERFLOW clause for CALL
  -fnumeric-boolean=<support>   boolean literals (B'1010')
  -fhexadecimal-boolean=<support>       hexadecimal-boolean literals (BX'A')
  -fnational-literals=<support> national literals (N'UTF-16 string')
  -fhexadecimal-national-literals=<support>     hexadecimal-national literals (NX'265E')
  -facucobol-literals=<support> ACUCOBOL-GT literals (#B #O #H #X)
  -fword-continuation=<support> continuation of COBOL words
  -fnot-exception-before-exception=<support>    NOT ON EXCEPTION before ON EXCEPTION
  -faccept-display-extensions=<support> extensions to ACCEPT and DISPLAY
  -frenames-uncommon-levels=<support>   RENAMES of 01-, 66- and 77-level items
  -fprogram-prototypes=<support>        CALL/CANCEL with program-prototype-name
  -freference-out-of-declaratives=<support>     references to sections not in DECLARATIVES from within DECLARATIVES
        where <support> is one of the following:
        'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
        'unconformable'
  -fnot-reserved=<word> word to be taken out of the reserved words list
  -freserved=<word>     word to be added to reserved words list
  -freserved=<word>:<alias>     word to be added to reserved words list as alias


Report bugs to: bug-gnucobol@gnu.org
or (preferably) use the issue tracker via the home page.
GnuCOBOL home page: <http://www.gnu.org/software/gnucobol/>
General help using GNU software: <http://www.gnu.org/gethelp/>

prompt$ cobc --info
cobc (GnuCOBOL) 2.0.0
Copyright (C) 2016 Free Software Foundation, Inc.
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software; see the source for copying conditions.  There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Written by Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward
Hart
Built     Jun 15 2016 07:38:33
Packaged  Oct 25 2015 21:40:28 UTC
C version "5.2.1 20151010"

build information
build environment        : x86_64-pc-linux-gnu
CC                       : gcc
CPPFLAGS                 :
CFLAGS                   : -g -O0 -pipe -fsigned-char -Wall
                           -Wwrite-strings -Wmissing-prototypes
                           -Wno-format-y2k
LD                       : /usr/bin/ld -m elf_x86_64
LDFLAGS                  : -Wl,-z,relro,-z,now,-O1

GnuCOBOL information
COB_CC                   : gcc
COB_CFLAGS               : -I/usr/local/include -pipe
COB_LDFLAGS              :
  env: COB_LDFLAGS       : -Wl,--no-as-needed
COB_LIBS                 : -L/usr/local/lib -lcob -lm -lvbisam -lgmp
                           -lncurses -ldl
COB_CONFIG_DIR           : /usr/local/share/gnu-cobol/config
COB_COPY_DIR             : /usr/local/share/gnu-cobol/copy
COB_MSG_FORMAT           : GCC
COB_MODULE_EXT           : so
COB_EXEEXT               :
64bit-mode               : yes
BINARY-C-LONG            : 8 bytes
Extended screen I/O      : ncurses
Variable format          : 0
Sequential handler       : Internal
ISAM handler             : VBISAM

prompt$ cobc --help
GnuCOBOL compiler for most COBOL dialects with lots of extensions

usage: cobc [options]... file...

options:
  -h, -help             display this help and exit
  -V, -version          display compiler version and exit
  -i, -info             display compiler information (build/environment)
  -v, -verbose          display the commands invoked by the compiler
  -vv                   display compiler version and the commands
                        invoked by the compiler
  -x                    build an executable program
  -m                    build a dynamically loadable module (default)
  -j(=<args>), -job(=<args>) run job, with optional arguments passed to program/module
  -std=<dialect>        warnings/features for a specific dialect
                        <dialect> can be one of:
                        cobol2014, cobol2002, cobol85, default,
                        ibm, mvs, bs2000, mf, acu;
                        see configuration files in directory config
  -F, -free             use free source format
  -fixed                use fixed source format (default)
  -O, -O2, -Os          enable optimization
  -g                    enable C compiler debug / stack check / trace
  -d, -debug            enable all run-time error checking
  -o <file>             place the output into <file>
  -b                    combine all input files into a single
                        dynamically loadable module
  -E                    preprocess only; do not compile or link
  -C                    translation only; convert COBOL to C
  -S                    compile only; output assembly file
  -c                    compile and assemble, but do not link
  -P(=<dir or file>)    generate preprocessed program listing (.lst)
  -Xref                 generate cross reference through 'cobxref'
                        (V. Coen's 'cobxref' must be in path)
  -I <directory>        add <directory> to copy/include search path
  -L <directory>        add <directory> to library search path
  -l <lib>              link the library <lib>
  -A <options>          add <options> to the C compile phase
  -Q <options>          add <options> to the C link phase
  -D <define>           define <define> for COBOL compilation
  -K <entry>            generate CALL to <entry> as static
  -conf=<file>          user defined dialect configuration - See -std=
  -cb_conf=<tag:value>  override configuration entry
  -list-reserved        display reserved words
  -list-intrinsics      display intrinsic functions
  -list-mnemonics       display mnemonic names
  -list-system          display system routines
  -save-temps(=<dir>)   save intermediate files
                        - default: current directory
  -ext <extension>      add default file extension

  -W                    enable ALL warnings
  -Wall                 enable all warnings except as noted below
  -Wno-<feature>        disable warning enabled by -W or -Wall
  -Wobsolete            warn if obsolete features are used
  -Warchaic             warn if archaic features are used
  -Wredefinition        warn incompatible redefinition of data items
  -Wconstant            warn inconsistent constant
  -Woverlap             warn overlapping MOVE items
  -Wparentheses         warn lack of parentheses around AND within OR
  -Wstrict-typing       warn type mismatch strictly
  -Wimplicit-define     warn implicitly defined data items
  -Wcorresponding       warn CORRESPONDING with no matching items
  -Wexternal-value      warn EXTERNAL item with VALUE clause
  -Wprototypes          warn missing FUNCTION prototypes/definitions
  -Wcall-params         warn non 01/77 items for CALL params
                        - NOT set with -Wall
  -Wcolumn-overflow     warn text after program-text area, FIXED format
                        - NOT set with -Wall
  -Wterminator          warn lack of scope terminator END-XXX
                        - NOT set with -Wall
  -Wtruncate            warn possible field truncation
                        - NOT set with -Wall
  -Wlinkage             warn dangling LINKAGE items
                        - NOT set with -Wall
  -Wunreachable         warn unreachable statements
                        - NOT set with -Wall

  -fsign=<value>        define display sign representation
                        - ASCII or EBCDIC (default: machine native)
  -ffold-copy=<value>   fold COPY subject to value
                        - UPPER or LOWER (default: no transformation)
  -ffold-call=<value>   fold PROGRAM-ID, CALL, CANCEL subject to value
                        - UPPER or LOWER (default: no transformation)
  -fdefaultbyte=<value> initialize fields without VALUE to decimal value
                        - 0 to 255 (default: initialize to picture)
  -fintrinsics=<value>  intrinsics to be used without FUNCTION keyword
                        - ALL or intrinsic function name(,name,...)
  -ftrace               generate trace code
                        - executed SECTION/PARAGRAPH
  -ftraceall            generate trace code
                        - executed SECTION/PARAGRAPH/STATEMENTS
                        - turned on by -debug
  -fsyntax-only         syntax error checking only; don't emit any output
  -fdebugging-line      enable debugging lines
                        - 'D' in indicator column or floating >>D
  -fsource-location     generate source location code
                        - turned on by -debug/-g/-ftraceall
  -fimplicit-init       automatic initialization of the COBOL runtime system
  -fstack-check         PERFORM stack checking
                        - turned on by -debug or -g
  -fsyntax-extension    allow syntax extensions
                        - eg. switch name SW1, etc.
  -fwrite-after         use AFTER 1 for WRITE of LINE SEQUENTIAL
                        - default: BEFORE 1
  -fmfcomment           '*' or '/' in column 1 treated as comment
                        - FIXED format only
  -facucomment          '$' in indicator area treated as '*',
                        '|' treated as floating comment
  -fnotrunc             allow numeric field overflow
                        - non-ANSI behaviour
  -fodoslide            adjust items following OCCURS DEPENDING
                        - requires implicit/explicit relaxed syntax
  -fsingle-quote        use a single quote (apostrophe) for QUOTE
                        - default: double quote
  -frecursive-check     check recursive program call
  -frelax-syntax        relax syntax checking
                        - eg. REDEFINES position
  -foptional-file       treat all files as OPTIONAL
                        - unless NOT OPTIONAL specified


Report bugs to: bug-gnucobol@gnu.org or
use the preferred issue tracker via home page.
GnuCOBOL home page: <http://www.gnu.org/software/gnucobol/>
General help using GNU software: <http://www.gnu.org/gethelp/>

prompt$ cobc --info
cobc (GnuCOBOL) 3.0-dev.0
Copyright (C) 2018 Free Software Foundation, Inc.
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software; see the source for copying conditions.  There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Written by Keisuke Nishida, Roger While,
           Ron Norman, Simon Sobisch, Edward Hart
Built     Jun 14 2018 03:13:41
Packaged  Sep 30 2017 10:21:38 UTC
C version "6.3.1 20161221 (Red Hat 6.3.1-1)"

build information
build environment        : x86_64-pc-linux-gnu
CC                       : gcc
C version                : "6.3.1 20161221 (Red Hat 6.3.1-1)"
CPPFLAGS                 :
CFLAGS                   : -O2 -pipe -finline-functions -fsigned-char
                           -Wall -Wwrite-strings -Wmissing-prototypes
                           -Wno-format-y2k -U_FORTIFY_SOURCE
LD                       : /usr/bin/ld -m elf_x86_64
LDFLAGS                  : -Wl,-z,relro,-z,now,-O1

GnuCOBOL information
COB_CC                   : gcc
COB_CFLAGS               : -I/usr/local/include -Wno-unused
                           -fsigned-char -Wno-pointer-sign -pipe
  env: COB_CFLAGS        : -I/home/btiffin/clean/trunk
                           -I/home/btiffin/clean/trunk/libcob
                           -I/usr/local/include -Wno-unused
                           -fsigned-char -Wno-pointer-sign -pipe
COB_LDFLAGS              :
  env: COB_LDFLAGS       : -L/home/btiffin/clean/trunk/libcob/.libs
COB_LIBS                 : -L/usr/local/lib -lcob -lm -lvbisam -lgmp
                           -lncursesw -ldl
  env: COB_LIBS          : -L/home/btiffin/clean/trunk/libcob/.libs
                           -lcob -lm -lvbisam -lgmp -lncursesw -ldl
COB_CONFIG_DIR           : /usr/local/share/gnucobol/config
  env: COB_CONFIG_DIR    : /home/btiffin/clean/trunk/config
COB_COPY_DIR             : /usr/local/share/gnucobol/copy
  env: COB_COPY_DIR      : /home/btiffin/clean/trunk/copy
COB_MSG_FORMAT           : GCC
COB_OBJECT_EXT           : o
COB_MODULE_EXT           : so
COB_EXE_EXT              :
64bit-mode               : yes
BINARY-C-LONG            : 8 bytes
extended screen I/O      : ncursesw
variable format          : 0
sequential handler       : built-in
ISAM handler             : VBISAM
mathematical library     : GMP

prompt$ cobc --help
GnuCOBOL compiler for most COBOL dialects with lots of extensions

Usage: cobc [options]... file...

Options:
  -h, -help             display this help and exit
  -V, -version          display compiler version and exit
  -i, -info             display compiler information (build/environment)
                        and exit
  -v, -verbose          display compiler version and the commands
                        invoked by the compiler
  -vv, -verbose=2       like -v but additional pass verbose option
                        to assembler/compiler
  -vvv, -verbose=3      like -vv but additional pass verbose option
                        to linker
  -q, -brief            reduced displays, commands invoked not shown
  -###                  like -v but commands not executed
  -x                    build an executable program
  -m                    build a dynamically loadable module (default)
  -j [<args>], -job[=<args>]    run program after build, passing <args>
  -std=<dialect>        warnings/features for a specific dialect
                        <dialect> can be one of:
                        default, cobol2014, cobol2002, cobol85, xopen,
                        ibm-strict, ibm, mvs-strict, mvs,
                        mf-strict, mf, bs2000-strict, bs2000,
                        acu-strict, acu, rm-strict, rm;
                        see configuration files in directory config
  -F, -free             use free source format
  -fixed                use fixed source format (default)
  -O, -O2, -O3, -Os     enable optimization
  -O0                   disable optimization
  -g                    enable C compiler debug / stack check / trace
  -d, -debug            enable all run-time error checking
  -o <file>             place the output into <file>
  -b                    combine all input files into a single
                        dynamically loadable module
  -E                    preprocess only; do not compile or link
  -C                    translation only; convert COBOL to C
  -S                    compile only; output assembly file
  -c                    compile and assemble, but do not link
  -T <file>             generate and place a wide program listing into <file>
  -t <file>             generate and place a program listing into <file>
  --tlines=<lines>      specify lines per page in listing, default = 55
  -P[=<dir or file>]    generate preprocessed program listing (.lst)
  -Xref                 specify cross reference in listing
  -I <directory>        add <directory> to copy/include search path
  -L <directory>        add <directory> to library search path
  -l <lib>              link the library <lib>
  -A <options>          add <options> to the C compile phase
  -Q <options>          add <options> to the C link phase
  -D <define>           define <define> for COBOL compilation
  -K <entry>            generate CALL to <entry> as static
  -conf=<file>          user-defined dialect configuration; see -std
  -list-reserved        display reserved words
  -list-intrinsics      display intrinsic functions
  -list-mnemonics       display mnemonic names
  -list-system          display system routines
  -save-temps[=<dir>]   save intermediate files
                        * default: current directory
  -ext <extension>      add file extension for resolving COPY

Warning options:
  -W                    enable all warnings
  -Wall                 enable most warnings (all except as noted below)
  -Wno-<warning>        disable warning enabled by -W or -Wall
  -Wno-unfinished       do not warn if unfinished features are used
                        * ALWAYS active
  -Wno-pending          do not warn if pending features are mentioned
                        * ALWAYS active
  -Wobsolete            warn if obsolete features are used
  -Warchaic             warn if archaic features are used
  -Wredefinition        warn about incompatible redefinition of data items
  -Wtruncate            warn about field truncation from constant assignments
  -Wpossible-truncate   warn about possible field truncation
                        * NOT set with -Wall
  -Woverlap             warn about overlapping MOVE of items
  -Wpossible-overlap    warn about MOVE of items that may overlap depending on variables
                        * NOT set with -Wall
  -Wparentheses         warn about lack of parentheses around AND within OR
  -Wstrict-typing       warn strictly about type mismatch
  -Wimplicit-define     warn about implicitly defined data items
  -Wcorresponding       warn about CORRESPONDING with no matching items
  -Winitial-value       warn if initial VALUE clause is ignored
  -Wprototypes          warn about missing FUNCTION prototypes/definitions
  -Warithmetic-osvs     warn if arithmetic expression precision has changed
  -Wcall-params         warn about non 01/77 items for CALL parameters
                        * NOT set with -Wall
  -Wconstant-expression  warn about expressions that always resolve to true/false
  -Wcolumn-overflow     warn about text after program-text area, FIXED format
                        * NOT set with -Wall
  -Wterminator          warn about lack of scope terminator END-XXX
                        * NOT set with -Wall
  -Wlinkage             warn about dangling LINKAGE items
                        * NOT set with -Wall
  -Wunreachable         warn about likely unreachable statements
                        * NOT set with -Wall
  -Wno-dialect          do not warn about dialect specific issues
                        * ALWAYS active
  -Wothers              do not warn about different issues
                        * ALWAYS active
  -Werror               treat all warnings as errors
  -Werror=<warning>     treat specified <warning> as error

Compiler options:
  -fsign=[ASCII|EBCDIC] define display sign representation
                        * default: machine native
  -ffold-copy=[UPPER|LOWER]     fold COPY subject to value
                        * default: no transformation
  -ffold-call=[UPPER|LOWER]     fold PROGRAM-ID, CALL, CANCEL subject to value
                        * default: no transformation
  -fdefaultbyte=<value> initialize fields without VALUE to value
                        * decimal 0..255 or any quoted character
                        * default: initialize to picture
  -fmax-errors=<number> maximum number of errors to report before
                        compilation is aborted
                        * default: 100
  -fdump=<scope>        dump data fields on abort, <scope> may be
                        a combination of: ALL, WS, LS, RD, FD, SC
  -fintrinsics=[ALL|intrinsic function name(,name,...)]
                        intrinsics to be used without FUNCTION keyword

  -fno-recursive_check  disable check of recursive program call;
                        effectively compiling as RECURSIVE program
  -ftrace               generate trace code
                        * scope: executed SECTION/PARAGRAPH
  -ftraceall            generate trace code
                        * scope: executed SECTION/PARAGRAPH/STATEMENTS
                        * turned on by -debug
  -fsyntax-only         syntax error checking only; don't emit any output
  -fdebugging-line      enable debugging lines
                        * 'D' in indicator column or floating >>D
  -fsource-location     generate source location code
                        * turned on by -debug/-g/-ftraceall
  -fimplicit-init       automatic initialization of the COBOL runtime system
  -fstack-check         PERFORM stack checking
                        * turned on by -debug or -g
  -fwrite-after         use AFTER 1 for WRITE of LINE SEQUENTIAL
                        * default: BEFORE 1
  -fmfcomment           '*' or '/' in column 1 treated as comment
                        * FIXED format only
  -facucomment          '$' in indicator area treated as '*',
                        '|' treated as floating comment
  -fnotrunc             allow numeric field overflow
                        * non-ANSI behaviour
  -fodoslide            adjust items following OCCURS DEPENDING
                        * implies -fcomplex-odo
  -fsingle-quote        use a single quote (apostrophe) for QUOTE
                        * default: double quote
  -foptional-file       treat all files as OPTIONAL
                        * unless NOT OPTIONAL specified
  -fno-theader           suppress all headers and output of compilation
                         options from listing while keeping page breaks
  -fno-tsource           suppress source from listing
  -fno-tmessages         suppress warning and error summary from listing
  -ftsymbols             specify symbols in listing

Compiler dialect configuration options:
  -freserved-words=<value>      use of complete/fixed reserved words
  -ftab-width=1..12      set number of spaces that are asumed for tabs
  -ftext-column=72..255  set right margin for source (fixed format only)
  -fpic-length=<number>  maximum number of characters allowed in the PICTURE character-string
  -fword-length=1..61    maximum word-length for COBOL (= programmer defined) words
  -fliteral-length=<number>     maximum literal size in general
  -fnumeric-literal-length=1..38        maximum numeric literal size
  -fassign-clause=<value>       set way of interpreting ASSIGN
  -fbinary-size=<value>  binary byte size - defines the allocated bytes according to PIC
  -fbinary-byteorder=<value>    binary byte order
  -fscreen-section-rules=<value>        which compiler's rules to apply to SCREEN SECTION item clauses
  -ffilename-mapping     resolve file names at run time using environment variables.
  -fpretty-display       alternate formatting of numeric fields
  -fbinary-truncate      numeric truncation according to ANSI
  -fcomplex-odo          allow complex OCCURS DEPENDING ON
  -findirect-redefines   allow REDEFINES to other than last equal level number
  -flarger-redefines-ok  allow larger REDEFINES items
  -frelax-syntax-checks  allow certain syntax variations (e.g. REDEFINES position)
  -frelax-level-hierarchy       allow non-matching level numbers
  -fselect-working       require ASSIGN USING items to be in WORKING-STORAGE
  -fsticky-linkage       LINKAGE-SECTION items remain allocated between invocations
  -fmove-ibm             MOVE operates as on IBM (left to right, byte by byte)
  -fperform-osvs         exit point of any currently executing perform is recognized if reached
  -farithmetic-osvs      limit precision in intermediate results to precision of final result (less accurate)
  -fconstant-folding     evaluate constant expressions at compile time
  -fhostsign             allow hexadecimal value 'F' for NUMERIC test of signed PACKED DECIMAL field
  -fprogram-name-redefinition   program names don't lead to a reserved identifier
  -faccept-update        set WITH UPDATE clause as default for ACCEPT dest-item, instead of WITH NO UPDATE
  -faccept-auto          set WITH AUTO clause as default for ACCEPT dest-item, instead of WITH TAB
  -fconsole-is-crt       assume CONSOLE IS CRT if not set otherwise
  -fno-echo-means-secure        NO-ECHO hides input with asterisks like SECURE
  -fline-col-zero-default       assume the first item in a field DISPLAY goes at LINE 0 COL 0, not LINE 1 COL 1
  -fdisplay-special-fig-consts  special behaviour of DISPLAY SPACE/ALL X'01'/ALL X'02'/ALL X'07'
  -fbinary-comp-1        COMP-1 is a 16-bit signed integer
  -fmove-non-numeric-lit-to-numeric-is-zero     imply zero in move of non-numeric literal to numeric items
  -fcomment-paragraphs=<support>        comment paragraphs in IDENTIFICATION DIVISION (AUTHOR, DATE-WRITTEN, ...)
  -fmemory-size-clause=<support>        MEMORY-SIZE clause
  -fmultiple-file-tape-clause=<support> MULTIPLE-FILE-TAPE clause
  -flabel-records-clause=<support>      LABEL-RECORDS clause
  -fvalue-of-clause=<support>   VALUE-OF clause
  -fdata-records-clause=<support>       DATA-RECORDS clause
  -ftop-level-occurs-clause=<support>   OCCURS clause on top-level
  -fsynchronized-clause=<support>       SYNCHRONIZED clause
  -fgoto-statement-without-name=<support>       GOTO statement without name
  -fstop-literal-statement=<support>    STOP-literal statement
  -fstop-identifier-statement=<support> STOP-identifier statement
  -fdebugging-mode=<support>    DEBUGGING MODE and debugging indicator
  -fuse-for-debugging=<support> USE FOR DEBUGGING
  -fpadding-character-clause=<support>  PADDING CHARACTER clause
  -fnext-sentence-phrase=<support>      NEXT SENTENCE phrase
  -flisting-statements=<support>        listing-directive statements EJECT, SKIP1, SKIP2, SKIP3
  -ftitle-statement=<support>   listing-directive statement TITLE
  -fentry-statement=<support>   ENTRY statement
  -fmove-noninteger-to-alphanumeric=<support>   move noninteger to alphanumeric
  -fmove-figurative-constant-to-numeric=<support>       move figurative constants to numeric
  -fmove-figurative-space-to-numeric=<support>  move figurative constant SPACE to numeric
  -fmove-figurative-quote-to-numeric=<support>  move figurative constant QUOTE to numeric
  -fodo-without-to=<support>    OCCURS DEPENDING ON without to
  -fsection-segments=<support>  section segments
  -falter-statement=<support>   ALTER statement
  -fcall-overflow=<support>     OVERFLOW clause for CALL
  -fnumeric-boolean=<support>   boolean literals (B'1010')
  -fhexadecimal-boolean=<support>       hexadecimal-boolean literals (BX'A')
  -fnational-literals=<support> national literals (N'UTF-16 string')
  -fhexadecimal-national-literals=<support>     hexadecimal-national literals (NX'265E')
  -facu-literals=<support>      ACUCOBOL-GT literals (#B #O #H #X)
  -fword-continuation=<support> continuation of COBOL words
  -fnot-exception-before-exception=<support>    NOT ON EXCEPTION before ON EXCEPTION
  -faccept-display-extensions=<support> extensions to ACCEPT and DISPLAY
  -frenames-uncommon-levels=<support>   RENAMES of 01-, 66- and 77-level items
  -fsymbolic-constant=<support> constants defined in SPECIAL-NAMES
  -fconstant-78=<support>       constant with level 78 item (note: has left to right precedence in expressions)
  -fconstant-01=<support>       constant with level 01 CONSTANT AS/FROM item
  -fperform-varying-without-by=<support>        PERFORM VARYING without BY phrase (implies BY 1)
  -fprogram-prototypes=<support>        CALL/CANCEL with program-prototype-name
  -freference-out-of-declaratives=<support>     references to sections not in DECLARATIVES from within DECLARATIVES
  -fnumeric-value-for-edited-item=<support>     numeric literals in VALUE clause of numeric-edited items
  -fincorrect-conf-sec-order=<support>  incorrect order of CONFIGURATION SECTION paragraphs
  -fdefine-constant-directive=<support> allow >> DEFINE CONSTANT var AS literal
  -ffree-redefines-position=<support>   REDEFINES clause not following entry-name in definition
  -frecord-delimiter=<support>  RECORD DELIMITER clause
  -fsequential-delimiters=<support>     BINARY-SEQUENTIAL and LINE-SEQUENTIAL phrases in RECORD DELIMITER
  -frecord-delim-with-fixed-recs=<support>      RECORD DELIMITER clause on file with fixed-length records
  -fmissing-statement=<support> missing statement (e.g. empty IF / PERFORM)
  -fzero-length-literals=<support>      zero-length literals, e.g. '' and ""
        where <support> is one of the following:
        'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', 'unconformable'
  -fnot-reserved=<word>  word to be taken out of the reserved words list
  -freserved=<word>      word to be added to reserved words list
  -freserved=<word>:<alias>     word to be added to reserved words list as alias
  -fnot-register=<word>  special register to disable
  -fregister=<word>      special register to enable


Report bugs to: bug-gnucobol@gnu.org
or (preferably) use the issue tracker via the home page.
GnuCOBOL home page: <http://www.gnu.org/software/gnucobol/>
General help using GNU software: <http://www.gnu.org/gethelp/>

cobc -xjgv -debug -A '-Wa\,--defsym,DEBUG=1' cpuid.cob vendor.s brand.s negate.s

Command line:   cobc -xjgv -debug -A -Wa\,--defsym,DEBUG=1 cpuid.cob vendor.s brand.s negate.s
Preprocessing:  cpuid.cob -> cpuid.i
Return status:  0
Parsing:        cpuid.i (cpuid.cob)
Return status:  0
Translating:    cpuid.i -> cpuid.c (cpuid.cob)
Executing:      gcc -std=gnu99 -c -I/usr/local/include -pipe -Wno-unused
                -fsigned-char -Wno-pointer-sign -g -Wa\,--defsym,DEBUG=1 -o
                "/tmp/cob8643_0.o" "cpuid.c"
Return status:  0
Executing:      gcc -std=gnu99 -c -I/usr/local/include -pipe -Wno-unused
                -fsigned-char -Wno-pointer-sign -g -Wa\,--defsym,DEBUG=1 -fPIC
                -DPIC -o "/tmp/cob8643_1.o" "vendor.s"
Return status:  0
Executing:      gcc -std=gnu99 -c -I/usr/local/include -pipe -Wno-unused
                -fsigned-char -Wno-pointer-sign -g -Wa\,--defsym,DEBUG=1 -fPIC
                -DPIC -o "brand.o" "brand.s"
Return status:  0
Executing:      gcc -std=gnu99 -c -I/usr/local/include -pipe -Wno-unused
                -fsigned-char -Wno-pointer-sign -g -Wa\,--defsym,DEBUG=1 -fPIC
                -DPIC -o "negate.o" "negate.s"
Return status:  0
Executing:      gcc -std=gnu99 -Wl,--export-dynamic -o "cpuid"
                "/tmp/cob8643_0.o" "/tmp/cob8643_1.o" "brand.o" "negate.o"
                -L/usr/local/lib -lcob -lm -lvbisam -lgmp -lncursesw -ldl
Return status:  0

Executing:      ./cpuid
Vendor: AuthenticAMD, with highest CPUID function: 13
CPUID normal maximum  : 00000000000000000013
Processor Brand string: AMD A10-5700 APU with Radeon(tm) HD Graphics
Number: 7fffffe2, Address: 0x6031e0
Number: 8000001e, Address: 0x6031e0
CPUID extended maximum: 00000000002147483678, 0x8000001E
Return status:  0

.ifdef DEBUG
# prep the printf call, args are rdi, rsi, rdx and rax
    movq    $msg, %rdi
    movl    %edx, %esi
    movq    8(%rsp), %rdx
    xorb    %al,%al
    call    printf
.endif

Number: 7fffffe2, Address: 0x6031e0
Number: 8000001e, Address: 0x6031e0

DISPLAY B#101                        *> base 2 numeric literal
DISPLAY O#1777777777777777777777     *> base 8 numeric literal
DISPLAY X#ffffffffffffffff           *> base 16 numeric literal
DISPLAY H#ffffffffffffffff           *> base 16 numeric literal


DISPLAY B"000001010"                 *> numeric as base 2
DISPLAY BX"00001010"                 *> string literal in base 2
DISPLAY H"DECAFBAD"                  *> numeric as base 16

DISPLAY N"ABCDE"                     *> 16bit character National
DISPLAY NX"20304050"                 *> 16bit National in base 16

DISPLAY L"ABCDE"                     *> L String literal??

DISPLAY "ABC" & "DEF"                *> string literal concatenation
DISPLAY X"0a00"                      *> string as base 16 pairs
   MOVE Z"C-string" TO add-zero-byte *> nul byte suffix literal

In the following order -
CPY, CBL, COB, cpy, cbl, cob and finally with no extension.

User specified extensions (in the order as per command line) are inspected
PRIOR to the above defaults.

ie. They take precedence.

The standard extensions for copybooks are (in the given order):

    no extension
    CPY
    CBL
    COB
    cpy
    cbl
    cob

Given

    COBCPY=/globdir1:../globdir2

and a command line with

    "-I/mydir1 -I ../mydir2 -e myext"

and the standard installation path for COB_COPY_DIR

    /usr/local/share/gnu-cobol/config

with the statement "COPY mybook." The following files are checked, in the
following order (relative to current file)

    mybook
    mybook.myext
    mybook.CPY
    mybook.CBL
    mybook.COB
    mybook with lowercase standard extensions (cpy, cbl, cob)
    /mydir1/mybook
    /mydir1/mybook.myext
    /mydir1/mybook.CPY
    /mydir1/mybook.CBL
    /mydir1/mybook with other standard extensions
    ../mydir2/mybook
    ../mydir2/mybook.myext
    ../mydir2/mybook.CPY
    ../mydir2/mybook.CBL
    ../mydir2/mybook with other standard extensions
    /globdir1/mybook
    /globdir1/mybook.myext
    /globdir1/mybook.CPY
    /globdir1/mybook.CBL
    /globdir1/mybook with other standard extensions
    ../globdir2/mybook
    ../globdir2/mybook.myext
    ../globdir2/mybook.CPY
    ../globdir2/mybook.CBL
    ../globdir2/mybook with other standard extensions
    /usr/local/share/gnu-cobol/copy/mybook
    /usr/local/share/gnu-cobol/copy/mybook.myext
    /usr/local/share/gnu-cobol/copy/mybook.CPY
    /usr/local/share/gnu-cobol/copy/mybook.CBL
    /usr/local/share/gnu-cobol/copy/mybook with other standard extensions

If all these 64 files are not found you'll see

    myprog.cob:line: Error: mybook: file not found

# COBOL compiler configuration                                        -*- sh -*-

# Value: any string
name: "GnuCOBOL"

# Value: int
tab-width: 8
text-column: 72

# Value: `cobol2002', `mf', `ibm'
#
assign-clause: mf

# If yes, file names are resolved at run time using environment variables.
# For example, given ASSIGN TO "DATAFILE", the actual file name will be
#  1. the value of environment variable `DD_DATAFILE' or
#  2. the value of environment variable `dd_DATAFILE' or
#  3. the value of environment variable `DATAFILE' or
#  4. the literal "DATAFILE"
# If no, the value of the assign clause is the file name.
#
# Value: `yes', `no'
filename-mapping: yes

# Value: `yes', `no'
pretty-display: yes

# Value: `yes', `no'
auto-initialize: yes

# Value: `yes', `no'
complex-odo: no

# Value: `yes', `no'
indirect-redefines: no

# Value:         signed  unsigned  bytes
#                ------  --------  -----
# `2-4-8'        1 -  4                2
#                5 -  9                4
#               10 - 18                8
#
# `1-2-4-8'      1 -  2                1
#                3 -  4                2
#                5 -  9                4
#               10 - 18                8
#
# `1--8'         1 -  2    1 -  2      1
#                3 -  4    3 -  4      2
#                5 -  6    5 -  7      3
#                7 -  9    8 -  9      4
#               10 - 11   10 - 12      5
#               12 - 14   13 - 14      6
#               15 - 16   15 - 16      7
#               17 - 18   17 - 18      8
binary-size: 1-2-4-8

# Value: `yes', `no'
binary-truncate: yes

# Value: `native', `big-endian'
binary-byteorder: big-endian

# Value: `yes', `no'
larger-redefines-ok: no

# Value: `yes', `no'
relaxed-syntax-check: no

# Perform type OSVS - If yes, the exit point of any currently executing perform
# is recognized if reached.
# Value: `yes', `no'
perform-osvs: no

# If yes, non-parameter linkage-section items remain allocated
# between invocations.
# Value: `yes', `no'
sticky-linkage: no

# If yes, allow non-matching level numbers
# Value: `yes', `no'
relax-level-hierarchy: no

# not-reserved:
# Value: Word to be taken out of the reserved words list
# (case independent)

# Dialect features
# Value: `ok', `archaic', `obsolete', `skip', `ignore', `unconformable'
author-paragraph:                        obsolete
memory-size-clause:                        obsolete
multiple-file-tape-clause:                obsolete
label-records-clause:                obsolete
value-of-clause:                        obsolete
data-records-clause:                obsolete
top-level-occurs-clause:                skip
synchronized-clause:                ok
goto-statement-without-name:        obsolete
stop-literal-statement:                obsolete
debugging-line:                        obsolete
padding-character-clause:                obsolete
next-sentence-phrase:                archaic
eject-statement:                        skip
entry-statement:                        obsolete
move-noninteger-to-alphanumeric:    error
odo-without-to:                        ok

# GnuCOBOL compiler configuration
#
# Copyright (C) 2001,2002,2003,2004,2005,2006,2007 Keisuke Nishida
# Copyright (C) 2007-2012 Roger While
#
# This file is part of GnuCOBOL.
#
# The GnuCOBOL compiler is free software: you can redistribute it
# and/or modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# GnuCOBOL is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GnuCOBOL.  If not, see <http://www.gnu.org/licenses/>.


# Value: any string
name: "GnuCOBOL"

# Value: enum
standard-define                 0
#        CB_STD_OC = 0,
#        CB_STD_MF,
#        CB_STD_IBM,
#        CB_STD_MVS,
#        CB_STD_BS2000,
#        CB_STD_85,
#        CB_STD_2002

# Value: int
tab-width:                      8
text-column:                    72

# Value: 'mf', 'ibm'
#
assign-clause:                  mf

# If yes, file names are resolved at run time using
# environment variables.
# For example, given ASSIGN TO "DATAFILE", the file name will be
#  1. the value of environment variable 'DD_DATAFILE' or
#  2. the value of environment variable 'dd_DATAFILE' or
#  3. the value of environment variable 'DATAFILE' or
#  4. the literal "DATAFILE"
# If no, the value of the assign clause is the file name.
#
filename-mapping:               yes

# Alternate formatting of numeric fields
pretty-display:                 yes

# Allow complex OCCURS DEPENDING ON
complex-odo:                    no

# Allow REDEFINES to other than last equal level number
indirect-redefines:             no

# Binary byte size - defines the allocated bytes according to PIC
# Value:         signed  unsigned  bytes
#                ------  --------  -----
# '2-4-8'        1 -  4    same        2
#                5 -  9    same        4
#               10 - 18    same        8
#
# '1-2-4-8'      1 -  2    same        1
#                3 -  4    same        2
#                5 -  9    same        4
#               10 - 18    same        8
#
# '1--8'         1 -  2    1 -  2      1
#                3 -  4    3 -  4      2
#                5 -  6    5 -  7      3
#                7 -  9    8 -  9      4
#               10 - 11   10 - 12      5
#               12 - 14   13 - 14      6
#               15 - 16   15 - 16      7
#               17 - 18   17 - 18      8
#
binary-size:                    1-2-4-8

# Numeric truncation according to ANSI
binary-truncate:                yes

# Binary byte order
# Value: 'native', 'big-endian'
binary-byteorder:               big-endian

# Allow larger REDEFINES items
larger-redefines-ok:            no

# Allow certain syntax variations (eg. REDEFINES position)
relaxed-syntax-check:           no

# Perform type OSVS - If yes, the exit point of any currently
# executing perform is recognized if reached.
perform-osvs:                   no

# If yes, linkage-section items remain allocated
# between invocations.
sticky-linkage:                 no

# If yes, allow non-matching level numbers
relax-level-hierarchy:          no

# If yes, allow reserved words from the 85 standard
cobol85-reserved:               no

# Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field
hostsign:                       no

# not-reserved:
# Value: Word to be taken out of the reserved words list
# (case independent)
# Words that are in the (proposed) standard but may conflict

# Dialect features
# Value: 'ok', 'archaic', 'obsolete', 'skip', 'ignore', 'unconformable'

alter-statement:                        obsolete
author-paragraph:                       obsolete
data-records-clause:                    obsolete
debugging-line:                         obsolete
eject-statement:                        skip
entry-statement:                        obsolete
goto-statement-without-name:            obsolete
label-records-clause:                   obsolete
memory-size-clause:                     obsolete
move-noninteger-to-alphanumeric:        error
multiple-file-tape-clause:              obsolete
next-sentence-phrase:                   archaic
odo-without-to:                         ok
padding-character-clause:               obsolete
section-segments:                       ignore
stop-literal-statement:                 obsolete
synchronized-clause:                    ok
top-level-occurs-clause:                ok
value-of-clause:                        obsolete

$ diff -u config/default.conf config/ibm.conf

--- config/default.conf 2014-02-21 14:29:56.154806798 -0500
+++ config/ibm.conf     2014-02-21 14:29:56.159806822 -0500
@@ -20,10 +20,10 @@


 # Value: any string
-name: "GnuCOBOL"
+name: "IBM COBOL"

 # Value: enum
-standard-define                        0
+standard-define                        2
 #        CB_STD_OC = 0,
 #        CB_STD_MF,
 #        CB_STD_IBM,
@@ -38,7 +38,7 @@

 # Value: 'mf', 'ibm'
 #
-assign-clause:                 mf
+assign-clause:                 ibm

 # If yes, file names are resolved at run time using
 # environment variables.
@@ -52,13 +52,13 @@
 filename-mapping:              yes

 # Alternate formatting of numeric fields
-pretty-display:                        yes
+pretty-display:                        no

 # Allow complex OCCURS DEPENDING ON
-complex-odo:                   no
+complex-odo:                   yes

 # Allow REDEFINES to other than last equal level number
-indirect-redefines:            no
+indirect-redefines:            yes

 # Binary byte size - defines the allocated bytes according to PIC
 # Value:         signed  unsigned  bytes
@@ -81,10 +81,10 @@
 #               15 - 16   15 - 16      7
 #               17 - 18   17 - 18      8
 #
-binary-size:                   1-2-4-8
+binary-size:                   2-4-8

 # Numeric truncation according to ANSI
-binary-truncate:               yes
+binary-truncate:               no

 # Binary byte order
 # Value: 'native', 'big-endian'
@@ -98,20 +98,20 @@

 # Perform type OSVS - If yes, the exit point of any currently
 # executing perform is recognized if reached.
-perform-osvs:                  no
+perform-osvs:                  yes

 # If yes, linkage-section items remain allocated
 # between invocations.
-sticky-linkage:                        no
+sticky-linkage:                        yes

 # If yes, allow non-matching level numbers
-relax-level-hierarchy:         no
+relax-level-hierarchy:         yes

 # If yes, allow reserved words from the 85 standard
 cobol85-reserved:              no

 # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field
-hostsign:                      no
+hostsign:                      yes

 # not-reserved:
 # Value: Word to be taken out of the reserved words list
@@ -125,8 +125,8 @@
 author-paragraph:                      obsolete
 data-records-clause:                   obsolete
 debugging-line:                                obsolete
-eject-statement:                       skip
-entry-statement:                       obsolete
+eject-statement:                       ok
+entry-statement:                       ok
 goto-statement-without-name:           obsolete
 label-records-clause:                  obsolete
 memory-size-clause:                    obsolete
@@ -138,5 +138,5 @@
 section-segments:                      ignore
 stop-literal-statement:                        obsolete
 synchronized-clause:                   ok
-top-level-occurs-clause:               ok
+top-level-occurs-clause:               skip
 value-of-clause:                       obsolete

# Makefile for the GnuCOBOL FAQ
# Brian Tiffin, Modified: 2015-11-14/06:58-0500
# Dedicated to the public domain, all rights waived
.RECIPEPREFIX = >

# default options, note that -g will leave intermediate files
COBCOPTS = -W -g -debug

# filenames to cleanup
COBCCLEAN = $*.c $*.s $*.i $*.c.h $*.c.l* $*.so $*.html $*

# Simple GnuCOBOL rules.  Customize to taste,
# create an executable
%: %.cob
> cobc $(COBCOPTS) -x $^ -o $@

# create an executable, and run it
%.run: %.cob
> cobc $(COBCOPTS) -xj $^ -o $@

# create an executable, and mark date-compiled
#%.mark: %.cob
#> sed -i 's#date-compiled\..*$$#date-compiled\. '\
#"$$(date +%Y-%m-%d/%H:%M%z)"'\.#' $^
#> cobc $(COBCOPTS) -x $^ -o $@

# create a dynamic module
%.so: %.cob
> cobc $(COBCOPTS) -m $^ -o $@

# create a linkable object
%.o: %.cob
> cobc $(COBCOPTS) -c $^ -o $@

# generate C code
%.c: %.cob
> cobc $(COBCOPTS) -C $^

# generate assembly
%.s: %.cob
> cobc $(COBCOPTS) -S $^

# generate intermediates in tmps
%.i: %.cob
> [ -d tmps ] || mkdir tmps
> cobc $(COBCOPTS) --save-temps=tmps -c $^

# create an executable; if errors, call vim in quickfix
%.q: %.cob
> cobc $(COBCOPTS) -x $^ 2>errors.err || vi -q

# make binary; capture warnings, call vim quickfix
%.qw: %.cob
> cobc $(COBCOPTS) -x $^ 2>errors.err ; vi -q

# run ocdoc to get documentation
%.ocdoc: %.cob
> ./ocdoc $^ $*.rst $*.html $*.css

# run rst2html
%.html: %.cob
> sed ':loop;/!rst.marker!/{d};N;b loop' $^ | sed '$$d' \
    | sed 's/:SAMPLE:/$*/' | rst2html >$*.html

# run cobxref
%.lst: %.cob
> cobc $(COBCOPTS) -Xref $^

# run cobolmac, .cbl to .cob
%.mac: %.cbl
> cobolmac <$^ >$*.cob

# clean up -g files, with interactive prompting, just in case
%.clean: %.cob
> @echo "Remove: " $(COBCCLEAN)
> @(read -p "Are you sure? " -r; \
    if [[ $$REPLY =~ ^[Yy]$$ ]]; then rm $(COBCCLEAN) ; fi)

# tectonics for occurlrefresh
occurlrefresh: occurl.c occurlsym.cpy occurlrefresh.cbl
> cobc -x $(COBCOPTS) occurlrefresh.cbl occurl.c -lcurl

prompt$ make program       # for executables
prompt$ make program.run   # compile and run
prompt$ make program.mark  # change date-compiled and compile
prompt$ make program.o     # for object files
prompt$ make program.so    # for shared library
prompt$ make program.q     # compile and call vi in quickfix mode
prompt$ make program.clean # clean up cobc generated files
prompt$ make program.html  # generate documentation

$ make occurlrefresh

" Auto load COBOL template
autocmd BufNewFile  *.cob      0r ~/lang/cobol/header.cob
autocmd BufNewFile  *.cbl      0r ~/lang/cobol/header.cob

GCobol >>SOURCE FORMAT IS FREE
REPLACE ==:SAMPLE:== BY ==program-name==.
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* project/:SAMPLE:
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20150405  Modified:
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or greater)
      *> PURPOSE
      *>   :SAMPLE: program.
      *> TECTONICS
      *>   cobc -x -g -debug :SAMPLE:.cob
      *> ***************************************************************
       identification division.
       program-id. :SAMPLE:.
       author.
       date-compiled.
       date-written.
       installation.
       remarks.
       security.

       environment division.
       configuration section.
       source-computer.
       object-computer.
       special-names.
       repository.
           function all intrinsic.

       input-output section.
       file-control.
       i-o-control.

       data division.
       file section.

       working-storage section.

       local-storage section.
       linkage section.
       report section.
       screen section.

      *> ***************************************************************
       procedure division.

       goback.
      *> ***************************************************************

      *> informational warnings and abends
       soft-exception.
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .

       end program :SAMPLE:.
      *> ***************************************************************
      *>****
>>ELSE

!rst-marker!
========
:SAMPLE:
========

.. contents::

Introduction
------------

Usage
-----

    prompt$ ./:SAMPLE:

Source
------

.. include::  :SAMPLE:.cob
   :code: cobolfree
   :end-before: !rst-marker
>>END-IF

" Auto update modified time stamp
"    Modified: must occur in the first 32 lines,
"    32 chars of data before Modified: tag remembered
"    modify strftime to suit
function! LastModified()
    if &modified
        let save_cursor = getpos(".")
        let n = min([32, line("$")])
        keepjumps exe '1,' . n . 's#^\(.\{,32}Modified:\).*#\1'
            \ . strftime(" %Y-%m-%d/%H:%M%z") . '#e'
        keepjumps exe '1,' . n . 's#^\(.\{,32}@modified \).*#\1'
            \ . strftime("%Y-%m-%d/%H:%M%z") . '#e'
        keepjumps exe '1,' . n . 's#^\(.\{,32}author.\)$#\1'
            \ . ' YOUR NAME HERE.' . '#e'
        keepjumps exe '1,' . n . 's#^\(.\{,32}date-written.\).*#\1'
            \ . strftime(" %Y-%m-%d/%H:%M%z") . '.' . '#e'
        call histdel('search', -1)
        call setpos('.', save_cursor)
    endif
endfunction
au BufWritePre * call LastModified()

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* ===========
      *><*
      *><* ===========
      *><* :Author:
      *><* :Date:
      *><* :Purpose:
      *><* :Tectonics: cobc
      *> ***************************************************************
       identification division.
       program-id. .

       environment division.
       configuration section.
       source-computer. posix.
       object-computer.

       special-names.

       repository.
           function all intrinsic.

       input-output section.
       file-control.
      *>   select
      *>   assign to
      *>   organization is
      *>   .

       data division.
       file section.
      *>fd .
      *>    01 .

       working-storage section.
       local-storage section.
       linkage section.
       screen section.

      *> ***************************************************************
       procedure division.

       goback.
       end program .
      *><*
      *><* Last Update: dd-Mmm-yyyy

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:
      *> Date:
      *> Purpose:
      *> Tectonics: cobc -x -g head-full.cob
      *>            COB_SET_DEBUG=Y ./head-full
      *> ***************************************************************
  id   identification division.
       program-id. sample.

 site  environment division.
       configuration section.
       source-computer. posix with debugging mode.
       object-computer. posix.

       special-names.

       repository.
           function all intrinsic.

       input-output section.
       file-control.
           select standard-in
           assign to keyboard
           organization is line sequential
           status is stdin-file-status
           .

           select standard-out
           assign to display
           organization is line sequential
           status is stdout-file-status
           .

 data  data division.
 file  file section.
       fd standard-in.
           01 stdin-line       pic x(32768).
       fd standard-out.
           01 stdout-line      pic x(32768).

store  working-storage section.
       01 stdin-file-status.
          05 stdin-status      pic 99.
          05 stdin-substatus   pic 99.

       01 stdout-file-status.
          05 stdout-status     pic 99.
          05 stdout-substatus  pic 99.

       01 countdown            pic 99.
       01 display-count        pic z9.
       01 joke-limiter         pic x     value low-value.
          88 refrain                     value high-value.

       local-storage section.
       linkage section.
       report section.
       screen section.

      *> ***************************************************************
 code  procedure division.
 decl  declaratives.

       helpful-debug section.
           use for debugging on cleanse.
       cleanse-debug.
           display
               "DEBUG: cleansing input: " trim(stdin-line trailing)
               upon syserr
       .

       bark-on-stdin-errors section.
           use after standard error on standard-in.
       bark-stdin.
           display
               "Something bad happened on KEYBOARD" upon syserr
       .

       bark-on-stdout-errors section.
           use after standard error on standard-out.
       bark-stdout.
           display
               "Something bad happened on DISPLAY" upon syserr
       .

       end declaratives.

 main  mainline section.

      *> Turn on statement tracer lines <*
       ready trace

       open input standard-in
       if stdin-status greater than 10
           perform soft-exception
       end-if

       open output standard-out
       if stdout-status greater than 10
           perform soft-exception
       end-if

      *> Turn off statement tracer lines <*
       reset trace

       perform until stdin-status greater than 9
           move "What is your command? " to stdout-line
           write stdout-line end-write
           if stdout-status greater than 10
               perform soft-exception
           end-if

           read standard-in
               at end
                   exit perform
           end-read
           if stdin-status greater than 10
               perform soft-exception
           end-if

           perform cleanse

           evaluate stdin-line also true
               when "help"         also any
                   display "We all want a little help"
                   display "help, quit or exit exit"
               when "quit"         also any
                   display
                       "I know you want to quit, but I'm being"
                       " unfriendly; type 'exit', you user you"
               when "exit"         also refrain
                   display "fine, leaving now"
                   exit perform
               when "exit"         also any
                   display "Ha!  No quit for you"
                   display
                       "Wasting your time for "
                   end-display
                   perform varying countdown from 10 by -1
                       until countdown equal zero
                       move countdown to display-count
                       display
                           display-count "... " with no advancing
                       call
                           "fflush" using NULL
                           on exception continue
                       end-call
                       call "C$SLEEP" using 1 end-call
                   end-perform
                   display "keep trying"
                   set refrain to true
               when other
                   display "try 'help'"
           end-evaluate
       end-perform

 done  goback.

      *> ***************************************************************
 aide  helper section.

      *> rudimentary changes to stdin, show off a few functions <*
       cleanse.
           move trim(substitute(lower-case(stdin-line),
               "'", space, '"', space))
             to stdin-line
       .

 warn  soft-exception.
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

 fail  hard-exception.
         perform soft-exception
         stop run returning 127
       .

 unit  end program sample.

GCobol >>SOURCE FORMAT IS FIXED
      ******************************************************************
      * Author:
      * Date:
      * Purpose:
      * Tectonics: cobc
      ******************************************************************
       IDENTIFICATION DIVISION.
       PROGRAM-ID. .

       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT
           ASSIGN TO
           ORGANIZATION IS
           .

       DATA DIVISION.
       FILE SECTION.
       FD .
           01 .

       WORKING-STORAGE SECTION.

       LOCAL-STORAGE SECTION.

       LINKAGE SECTION.

       SCREEN SECTION.

      ******************************************************************
       PROCEDURE DIVISION.

       GOBACK.
       END PROGRAM .

>>SOURCE FORMAT IS FREE

*> **  >>SOURCE FORMAT IS FREE
*> *********************************************************************
*> Author:
*> Date:
*> Purpose:
*> Tectonics: cobc -free
*> *********************************************************************
identification division.
program-id. .

environment division.
configuration section.

input-output section.
file-control.
    select
        assign to
        organization is
    .

data division.
file section.
fd .
    01 .

working-storage section.

local-storage section.

linkage section.

screen section.

procedure division.

goback.
end program .

$ python
Python 2.7.5 (default, Nov 12 2013, 16:18:42)
[GCC 4.8.2 20131017 (Red Hat 4.8.2-1)] on linux2
Type "help", "copyright", "credits" or "license" for more information.
>>> exit
Use exit() or Ctrl-D (i.e. EOF) to exit
>>>

$ cobc -x -g head-full.cob
$ COB_SET_DEBUG=Y ./head-full
Source :    'head-full.cob'
Program-Id: sample           Statement: OPEN                   Line: 93
Program-Id: sample           Statement: IF                     Line: 94
Program-Id: sample           Statement: OPEN                   Line: 98
Program-Id: sample           Statement: IF                     Line: 99
Program-Id: sample           Statement: RESET TRACE            Line: 103
What is your command?

DEBUG: cleansing input: quit
I know you want to quit, but I'm being unfriendly; type 'exit', you user you
What is your command?

DEBUG: cleansing input: 'exit'
Ha!  No quit for you
Wasting your time for
10...  9...  8...  7...  6...  5...  4...  3...  2...  1... keep trying
What is your command?

DEBUG: cleansing input: "EXIT"
fine, leaving now

$ cat datafile | filter
$ filter <inputfile >outputfile

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* ===========
      *><* filter
      *><* ===========
      *><* :Author:    Brian Tiffin
      *><* :Date:      20090207
      *><* :Purpose:   Standard IO filters
      *><* :Tectonics: cobc -x filter.cob
      *> ***************************************************************
       identification division.
       program-id. filter.

       environment division.
       configuration section.

       input-output section.
       file-control.
           select standard-input assign to keyboard.
           select standard-output assign to display.

       data division.
       file section.
       fd standard-input.
           01 stdin-record     pic x(32768).
       fd standard-output.
           01 stdout-record    pic x(32768).

       working-storage section.
       01  file-status         pic x  value space.
           88 end-of-file             value high-value
              when set to false is          low-value.

      *> ***************************************************************
       procedure division.
       main section.
       00-main.

       perform 01-open

       perform 01-read

       perform
            until end-of-file
                perform 01-transform
                perform 01-write
                perform 01-read
       end-perform
       .

       00-leave.
       perform 01-close
       .

       goback.
      *> end main

       support section.
       01-open.
       open input standard-input
       open output standard-output
       .

       01-read.
       read standard-input
            at end set end-of-file to true
       end-read
       .

      *> All changes here
       01-transform.
       move stdin-record to stdout-record
       .
      *>

       01-write.
       write stdout-record end-write
       .

       01-close.
           close standard-input
           close standard-output
       .

       end program filter.
      *><*
      *><* Last Update: dd-Mmm-yyyy

*> POSIX stream IO mix and match with GnuCOBOL
 01 result           usage binary-long.

 01 stdin            usage pointer.
 01 errno-address    usage pointer.
 01 errno            usage binary-long based.

 01 buffer           pic x(80).
 01 got              usage pointer.

*> POSIX timezone information
 01 tzname           usage pointer.
 01 tznames          usage pointer based.
    05 tzs           usage pointer occurs 2 times.
 01 timezone         usage binary-c-long.
 01 daylight         usage binary-long.


 call "CBL_GC_HOSTED" stdin "stdin"
 call "CBL_GC_HOSTED" errno-address "errno"
 set address of errno to errno-address

 call "fgets" using buffer by value 80 stdin returning got
 if got equal null then
     display "stdin error: " errno upon syserr
     move 0 to err
 end-if

 set environment "TZ" to "PST8PDT"
 call "tzset" returning omitted
 call "CBL_GC_HOSTED" tzname "tzname" returning result
 if result equal zero and tzname not equal null then
     set address of tznames to tzname
     if tzs(1) not equal null then
         call "printf" using
             by content "first tzname: %s" & x"0a00"
             by value tzs(1)
     end-if
 end-if

$ ./cobprog | lp
$ ./yearend | lp -d $PRESIDENTSPRINTER

CALL "SYSTEM"
    USING "lp os-specific-path-to-file"
    RETURNING status
END-CALL

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian
      *> Date:      10-Aug-2009
      *> Purpose:   CUPS quick print
      *> Tectonics: cobc -lcups -x cupscob.cob
      *> ***************************************************************
       identification division.
       program-id. cupscob.

       data division.
       working-storage section.
       01 result      usage binary-long.
       01 cupsError   usage binary-long.
       01 msgPointer  usage pointer.
       01 msgBuffer   pic   x(1024) based.
       01 msgDisplay  pic   x(132).

      *> ***************************************************************
       procedure division.
       call "cupsPrintFile"
         using
           "cupsQueue" & x"00"
           "filename.prn" & x"00"
           "GnuCOBOL CUPS interface" & x"00"
           by value 0
           by reference NULL
         returning result
       end-call

       if result equals zero
           call "cupsLastError" returning cupsError
           display "Err: " cupsError

           call "cupsLastErrorString" returning msgPointer
           set address of msgBuffer to msgPointer
           string
               msgBuffer delimited by x"00"
             into msgDisplay
           end-string
           display function trim(msgDisplay)
       else
           display "Job: " result
       end-if

       goback.
       end program cupscob.

$ apt-get install cups cups-pdf

call "cupsPrintFile"
    using
        "PDFer"       & x"00"
        "cupscob.cob" & x"00"
        "cupscob.pdf" & x"00"
        by value 0
        by reference NULL
    returning result
end-call

Check if your particular distro has cups-pdf in
its repository. (eg. Using Yast with Suse).
If yes, install from there.
If no, use one of the RPM finders on the web to find
a version for your distro.
eg. www.rpmfind.com

The installation of cups-pdf should automatically set
up a dummy printer with the name "cups-pdf".
So you do not actually need to define a class.
You can print directly to "cups-pdf".
(Check defined printers with eg. "lpstat -t")

The output file location is dependent on the cups-pdf
configuration file normally located at /etc/cups/cups-pdf.conf.
So, eg. on my box the location is defined thus -
Out ${HOME}/Documents/PDFs

call "cupsPrintFile"              *> requires -lcups
    using
        "cups-pdf"    & x"00"         *> printer class
        "cupscob.cob" & x"00"         *> input filename
        "cupscob.pdf" & x"00"         *> title
        by value 0                    *> num_options
        by reference NULL             *> options struct <*
    returning result
    on exception
        display "hint: use -lcups for cupsPrintFile"
end-call

GCobol IDENTIFICATION DIVISION.
       PROGRAM-ID. PRTCBL.
      *AUTHOR. J C CURREY.
      ************************************************************
      *      PRINTS A COBOL SOURCE FILE WITH IT'S COPY BOOKS     *
      *                                                          *
      *   VERSION 001--ORIGINAL VERSION                          *
      *                 3/26/2009--J C CURREY                    *
      *                                                          *
      *           002--ADDS .CPY (CAPS) IF .cpy FAILS TO FIND    *
      *                  FILE AND EXPANDS INPUT TO 132 CHARACTERS*
      *                 4/09/2009--J C CURREY                    *
      *                                                          *
      *           003--ADDS NOLIST AND LIST SUPPORT (NOTE NOT    *
      *                  SUPPORTED BY OPENCOBOL COMPILER)        *
      *                  **NOLIST IN COL 7-14 TURNS OFF LISTING  *
      *                  **LIST IN COL 7-12 TURNS ON LISTING     *
      *                 4/22/2009--J C CURREY                    *
      *                                                          *
      *           004--ADDS SUPPORT FOR /testing-set-1/copybooks *
      *                Copybooks are searched for first in the   *
      *                local directory and if not found, then in *
      *                /testing-set-1/copybooks                  *
      *                 5/7/2009--J C CURREY                     *
      *                                                          *
      *           005--CORRECTS MISSING LINE ISSUE ON PAGE BREAKS*
      *                IN THE COPY FILE PRINTING SECTION.        *
      *                1285451--SANDY DOSS                       *
      *                06/19/2009--JEREMY MONTOYA                *
      *                                                          *
      *           006--USES EXTERNAL PCL CODE FILE TO INSERT PCL *
      *                CODE INTO PRINT FILE FOR FORMATTING.      *
      *                1330505--JIM CURREY                       *
      *                12/14/2009--PETE MCTHOMPSON               *
      ************************************************************
       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
121409     SELECT FORMAT-FILE ASSIGN TO WS-NAME-FORMAT-FILE
121409       ORGANIZATION IS LINE SEQUENTIAL.
           SELECT PRINT-FILE ASSIGN TO WS-NAME-PRINT-FILE
             ORGANIZATION IS LINE SEQUENTIAL.
           SELECT INPUT-FILE ASSIGN TO WS-NAME-INPUT-FILE
             ORGANIZATION IS LINE SEQUENTIAL
             FILE STATUS IS WS-INPUT-FILE-STATUS.
           SELECT COPY-FILE ASSIGN TO WS-NAME-COPY-FILE
             ORGANIZATION IS LINE SEQUENTIAL
             FILE STATUS IS WS-COPY-FILE-STATUS.
       DATA DIVISION.
       FILE SECTION.
      *
       FD  PRINT-FILE.
121409 01  FORMAT-LINE                         PIC X(140).
       01  PRINT-LINE.
           05  OR-LINE-NUMBER                  PIC Z(6).
           05  OR-FILLER-1                     PIC XX.
           05  OR-TEXT                         PIC X(132).
121409*
121409 FD  FORMAT-FILE.
121409 01  FORMAT-RECORD                       PIC X(140).
      *
       FD  INPUT-FILE.
       01  INPUT-RECORD.
           05  IR-BUFFER                       PIC X(132).

       FD  COPY-FILE.
       01  COPY-RECORD.
           05  CR-BUFFER                       PIC X(132).
      **NOLIST
      * THIS IS ANOTHER LINE
      **LIST
      *
       WORKING-STORAGE SECTION.
      ****************************************************
      *   CONSTANTS, COUNTERS AND WORK AREAS             *
      ****************************************************
       01  WS-NAME-PROGRAM                     PIC X(12) VALUE
121409                                            "prtcbl   006".
       01  WS-NO-PARAGRAPH                     PIC S9(4) COMP.
       01  WS-I                                PIC S9(4) COMP.
       01  WS-J                                PIC S9(4) COMP.
       01  WS-K                                PIC S9(4) COMP.
       01  WS-NAME-PRINT-FILE                  PIC X(64) VALUE SPACES.
       01  WS-NAME-INPUT-FILE                  PIC X(64) VALUE SPACES.
       01  WS-INPUT-FILE-STATUS                PIC XX VALUE "00".
050709 01  WS-NAME-COPY-FILE                   PIC X(128) VALUE SPACES.
050709 01  WS-HOLD-NAME-COPY-FILE              PIC X(128) VALUE SPACES.
121409 01  WS-NAME-FORMAT-FILE                 PIC X(128) VALUE SPACES.
       01  WS-COPY-FILE-STATUS                 PIC XX VALUE "00".
       01  WS-LINE-PRINTER-NAME                PIC X(16) VALUE SPACES.
       01  WS-LINE-NUMBER                      PIC S9(6) COMP
                                                    VALUE ZERO.
       01  WS-PAGE-LINE-COUNTER                PIC S9(4) COMP
                                                    VALUE 999.
       01  WS-PAGE-NUMBER                      PIC S9(4) COMP
                                                    VALUE ZERO.
       01  WS-PRINT-COMMAND                    PIC X(128).
      *
       01  WS-ESCAPE-CHARACTER                 PIC X VALUE X"1B".
      *
       01  WS-HEADING-LINE                     PIC X(132).
       01  WS-CURRENT-DATE                     PIC X(21).
       01  WS-ED4S                             PIC ZZZZ-.
042209 01  WS-SWITCH-PRINT                     PIC X VALUE SPACE.
      ****************************************************************
      *                PROCEDURE DIVISION                            *
      ****************************************************************
       PROCEDURE DIVISION.
       0000-MAIN SECTION.
           PERFORM 1000-INITIALIZATION THRU 1990-EXIT.
           PERFORM 2000-PROCESS THRU 2990-EXIT.
           PERFORM 9000-END-OF-PROGRAM THRU 9990-EXIT.
           STOP RUN.
      ****************************************************************
      *               INITIALIZATION                                 *
      ****************************************************************
       1000-INITIALIZATION.
           MOVE 1000 TO WS-NO-PARAGRAPH.
           DISPLAY "I) ", WS-NAME-PROGRAM, " BEGINNING AT--"
             FUNCTION CURRENT-DATE.
       1002-GET-INPUT-FILE.
           DISPLAY "A) ENTER INPUT-FILE NAME " WITH NO ADVANCING.
           ACCEPT WS-NAME-INPUT-FILE.
           OPEN INPUT INPUT-FILE.
           IF WS-INPUT-FILE-STATUS IS EQUAL TO 35
             DISPLAY "W) INPUT FILE NOT FOUND"
             GO TO 1002-GET-INPUT-FILE.
           DISPLAY "A) ENTER PRINT-FILE (WORK FILE) NAME "
             WITH NO ADVANCING.
           ACCEPT WS-NAME-PRINT-FILE.
           DISPLAY "A) ENTER PRINTER NAME " WITH NO ADVANCING.
           ACCEPT WS-LINE-PRINTER-NAME.
           OPEN OUTPUT PRINT-FILE.
121409     MOVE "laserjet_113D.txt" TO WS-NAME-FORMAT-FILE.
121409     OPEN INPUT FORMAT-FILE.
121409 1010-OUTPUT-PCL-CODES.
121409     READ FORMAT-FILE NEXT RECORD AT END GO TO 1020-FORMAT-EOF.
121409     MOVE FORMAT-RECORD TO FORMAT-LINE.
121409     WRITE FORMAT-LINE.
121409     GO TO 1010-OUTPUT-PCL-CODES.
121409 1020-FORMAT-EOF.
121409     CLOSE FORMAT-FILE.
       1990-EXIT.
           EXIT.
      **************************************************************
      *                 DETAIL SECTION                             *
      **************************************************************
       2000-PROCESS.
           MOVE 2000 TO WS-NO-PARAGRAPH.
           READ INPUT-FILE NEXT RECORD AT END GO TO 2990-EXIT.
           ADD 1 TO WS-LINE-NUMBER.
           IF WS-PAGE-LINE-COUNTER IS GREATER THAN 112
             PERFORM 2800-HEADINGS THRU 2890-EXIT.
           MOVE WS-LINE-NUMBER TO OR-LINE-NUMBER.
           MOVE SPACES TO OR-FILLER-1.
           MOVE INPUT-RECORD TO OR-TEXT.
042209     IF IR-BUFFER (7:6) IS EQUAL TO "**LIST"
042209       MOVE "Y" TO WS-SWITCH-PRINT.
042209     IF WS-SWITCH-PRINT IS EQUAL TO "N"
042209       THEN NEXT SENTENCE
042209       ELSE WRITE PRINT-LINE
042209            ADD 1 TO WS-PAGE-LINE-COUNTER.
042209      IF IR-BUFFER (7:8) IS EQUAL TO "**NOLIST"
042209       MOVE "N" TO WS-SWITCH-PRINT.
           IF IR-BUFFER (7:1) IS EQUAL TO "*" GO TO 2000-PROCESS.
           MOVE 1 TO WS-I.
       2010-COMPARE-LOOP.
           IF IR-BUFFER (WS-I:2) IS EQUAL TO "*>" GO TO 2090-ENDER.
           IF IR-BUFFER (WS-I:6) IS EQUAL TO " COPY " GO TO 2020-COPY.
           ADD 1 TO WS-I.
           IF WS-I IS LESS THAN 73 GO TO 2010-COMPARE-LOOP.
           GO TO 2000-PROCESS.
       2020-COPY.
           SUBTRACT 1 FROM WS-LINE-NUMBER.
           ADD 6 TO WS-I.
           MOVE 1 TO WS-J.
           MOVE SPACES TO WS-NAME-COPY-FILE.
       2022-MOVE-LOOP.
           IF IR-BUFFER (WS-I:1) IS EQUAL TO SPACE
             GO TO 2030-OPEN-COPYFILE.
           IF IR-BUFFER (WS-I:1) IS EQUAL TO "."
             MOVE ".cpy" to WS-NAME-COPY-FILE (WS-J:4)
               GO TO 2030-OPEN-COPYFILE.
           MOVE IR-BUFFER (WS-I:1) TO WS-NAME-COPY-FILE (WS-J:1).
           ADD 1 TO WS-I, WS-J.
           IF WS-I IS GREATER THAN 73
             OR WS-J IS GREATER THAN 64
               THEN MOVE "**PROBLEM WITH.COPY STATEMENT ABOVE**"
                      TO OR-TEXT
                    WRITE PRINT-LINE
                    ADD 1 TO WS-PAGE-LINE-COUNTER
                    GO TO 2000-PROCESS.
           GO TO 2022-MOVE-LOOP.
       2030-OPEN-COPYFILE.
           OPEN INPUT COPY-FILE.
           IF WS-COPY-FILE-STATUS IS NOT EQUAL TO "00"
040909       MOVE ".CPY" TO WS-NAME-COPY-FILE (WS-J:4)
040909       OPEN INPUT COPY-FILE
040909       IF WS-COPY-FILE-STATUS IS NOT EQUAL TO "00"
050709         MOVE WS-NAME-COPY-FILE TO WS-HOLD-NAME-COPY-FILE
050709         STRING "/testing-set-1/copybooks/"
050709           WS-HOLD-NAME-COPY-FILE
050709             INTO WS-NAME-COPY-FILE
      *     DISPLAY "D) AT.COPY FILE OPEN NAME=\", WS-NAME-COPY-FILE, "\"
050709         OPEN INPUT COPY-FILE
050709           IF WS-COPY-FILE-STATUS IS NOT EQUAL TO "00"
050709             ADD 25 TO WS-J
050709             MOVE ".cpy" TO WS-NAME-COPY-FILE (WS-J:4)
      *     DISPLAY "D) AT.COPY FILE OPEN NAME=\", WS-NAME-COPY-FILE, "\"
050709             OPEN INPUT COPY-FILE
050709             IF WS-COPY-FILE-STATUS IS NOT EQUAL TO "00"
050709               MOVE "***COPY FILE ABOVE NOT FOUND***" TO OR-TEXT
050709               WRITE PRINT-LINE
050709               ADD 1 TO WS-LINE-NUMBER
050709               ADD 1 TO WS-PAGE-LINE-COUNTER
050709               GO TO 2000-PROCESS
050709             END-IF
050709           END-IF
040909       END-IF
040909     END-IF.
       2032-PRINT-LOOP.
           READ COPY-FILE NEXT RECORD AT END GO TO 2039-EOF.
           ADD 1 TO WS-LINE-NUMBER.
061909*    MOVE WS-LINE-NUMBER TO OR-LINE-NUMBER.
061909*    MOVE SPACES TO OR-FILLER-1.
061909*    MOVE COPY-RECORD TO OR-TEXT.
           IF WS-PAGE-LINE-COUNTER IS GREATER THAN 112
             PERFORM 2800-HEADINGS THRU 2890-EXIT.
061909     MOVE WS-LINE-NUMBER TO OR-LINE-NUMBER.
061909     MOVE SPACES TO OR-FILLER-1.
061909     MOVE COPY-RECORD TO OR-TEXT.
042209     IF CR-BUFFER (7:6) IS EQUAL TO "**LIST"
042209       MOVE "Y" TO WS-SWITCH-PRINT.
042209     IF WS-SWITCH-PRINT IS EQUAL TO "N"
042209       THEN NEXT SENTENCE
042209       ELSE WRITE PRINT-LINE
042209            ADD 1 TO WS-PAGE-LINE-COUNTER.
042209      IF CR-BUFFER (7:8) IS EQUAL TO "**NOLIST"
042209       MOVE "N" TO WS-SWITCH-PRINT.
           GO TO 2032-PRINT-LOOP.
       2039-EOF.
           CLOSE COPY-FILE.
042209     MOVE "Y" TO WS-SWITCH-PRINT.
       2090-ENDER.
           GO TO 2000-PROCESS.
      *
      *    PAGE HEADINGS
      *
       2800-HEADINGS.
           INITIALIZE PRINT-LINE.
           ADD 1 TO WS-PAGE-NUMBER.
           MOVE FUNCTION CURRENT-DATE TO WS-CURRENT-DATE.
           MOVE WS-NAME-INPUT-FILE TO PRINT-LINE.
           MOVE WS-PAGE-NUMBER TO WS-ED4S.
           MOVE "PAGE" TO PRINT-LINE (66:4).
           MOVE WS-ED4S TO PRINT-LINE (71:4).
           MOVE WS-CURRENT-DATE (5:2) TO PRINT-LINE (80:2).
           MOVE "/" TO PRINT-LINE (82:1).
           MOVE WS-CURRENT-DATE (7:2) TO PRINT-LINE (83:2).
           MOVE "/" TO PRINT-LINE (85:1).
           MOVE WS-CURRENT-DATE (1:4) TO PRINT-LINE (86:4).
           MOVE WS-CURRENT-DATE (9:2) TO PRINT-LINE (92:2).
           MOVE ":" TO PRINT-LINE (94:1).
           MOVE WS-CURRENT-DATE (11:2) TO PRINT-LINE (95:2).
           MOVE ":" TO PRINT-LINE (97:1).
           MOVE WS-CURRENT-DATE (13:2) TO PRINT-LINE (98:2).
           IF WS-PAGE-NUMBER IS EQUAL TO 1
             THEN WRITE PRINT-LINE
             ELSE WRITE PRINT-LINE AFTER ADVANCING PAGE.
           INITIALIZE PRINT-LINE.
           WRITE PRINT-LINE.
           MOVE 4 TO WS-PAGE-LINE-COUNTER.
       2890-EXIT.
           EXIT.
      *
      *    END OF JOB
      *
       2990-EXIT.
           EXIT.
      ****************************************************************
      *             TERMINATION                                      *
      ****************************************************************
       9000-END-OF-PROGRAM.
           MOVE 9000 TO WS-NO-PARAGRAPH.
           CLOSE INPUT-FILE.
           CLOSE PRINT-FILE.
121409*    STRING "lp -d " DELIMITED BY SIZE,
121409*      WS-LINE-PRINTER-NAME DELIMITED BY SIZE,
121409*      "-o sides=two-sided-long-edge " DELIMITED BY SIZE,
121409*      "-o lpi=11 -o cpi=18 -o page-left=34 " DELIMITED BY SIZE,
121409*      WS-NAME-PRINT-FILE DELIMITED BY SIZE
121409*        INTO WS-PRINT-COMMAND.
           STRING "lp -d " DELIMITED BY SIZE,
             WS-LINE-PRINTER-NAME DELIMITED BY SIZE,
             "-o raw " DELIMITED BY SIZE,
             WS-NAME-PRINT-FILE DELIMITED BY SIZE
               INTO WS-PRINT-COMMAND.
           CALL "SYSTEM" USING WS-PRINT-COMMAND.
           DISPLAY "I) " WS-NAME-PROGRAM " COMPLETED NORMALLY AT--"
               FUNCTION CURRENT-DATE.
       9990-EXIT.
           EXIT.

CALL "SYSTEM"
    USING
        "nohup whatever 0</dev/null 1>mystdout 2>mystderr &"
    RETURNING result
END-CALL

EXPORT LD_RUN_PATH=mylibdir
./configure ; make ; make install

LD_RUN_PATH=mylibdir cobc -x nextbigthing.cob

tar xvf open-cobol-1.1.tar.gz
cd open-cobol-1.1
./configure
make
make check
sudo make install
sudo ldconfig

I mentioned in the past the preferred way of doing
a configure/build ie. Out-of-source-tree build.

eg.
We have OC 2.0 in /home/open-cobol-2.0

We want to test -
OC with BDB
OC with vbisam
OC without db (ISAM)

mkdir /home/oc20110710bdb
cd /home/oc20110710bdb
/home/open-cobol-2.0/configure --enable-debug
make
make check
cd tests
cd cobol85
# <Get newcob.val - per README>
make test

mkdir /home/oc20110710vbisam
cd /home/oc20110710vbisam
/home/open-cobol-2.0/configure --enable-debug --with-vbisam
make
make check
cd tests
cd cobol85
# <Get newcob.val - per README>
make test

mkdir /home/oc20110710nodb
cd /home/oc20110710nodb
/home/open-cobol-2.0/configure --enable-debug --without-db
make
make check
cd tests
cd cobol85
# <Get newcob.val - per README>
make test

For the last example both the OC and ANSI85 tests have been adjusted
to cater for lack of ISAM functionality.

To set your current environment to compile/execute from any of the above
(ie. without doing a "make install" from any directory), then
either "source" or execute as part of current environment
(with . ) the following files from the build directory -
tests/atconfig
tests/atlocal

(Note in that order)

So eg.
. /home/oc20110710vbisam/tests/atconfig
. /home/oc20110710vbisam/tests/atlocal

will set compiler/runtime to this environment in the current shell.

Note that both the OC tests and the ANSI85 tests do this internally
(Fairly obvious otherwise we would not be testing the right thing).

Of course, from any of the above example directories you can do
a final "make install".

# multiple versions of GnuCOBOL, when built from source
# ### UPDATE source PATHNAMES to match local installation ###
use-cobol () {
    local ROOTPATH="$HOME"/builds
    case "$1" in
    2\.0 | 2)
         source "$ROOTPATH"/branches/gnu-cobol-2.0/tests/atconfig
         source "$ROOTPATH"/branches/gnu-cobol-2.0/tests/atlocal
         ;;
    reportwriter | rw)
         source "$ROOTPATH"/branches/reportwriter/tests/atconfig
         source "$ROOTPATH"/branches/reportwriter/tests/atlocal
         ;;
    cpp | c\+\+)
         source "$ROOTPATH"/branches/gnu-cobol-cpp/tests/atconfig
         source "$ROOTPATH"/branches/gnu-cobol-cpp/tests/atlocal
         ;;
    fileiorewrite )
         source "$ROOTPATH"/branches/fileiorewrite/tests/atconfig
         source "$ROOTPATH"/branches/fileiorewrite/tests/atlocal
         ;;
    release | gnucobol)
         source "$ROOTPATH"/trunk/gnu-cobol/tests/atconfig
         source "$ROOTPATH"/trunk/gnu-cobol/tests/atlocal
         ;;
    *)
         echo "Use use-cobol 2 rw cpp fileiorewrite or release"
         ;;
    esac
}

prompt$ use-cobol 2.0
prompt$ use-cobol reportwriter
prompt$ use-cobol c++

prompt$ use-cobol simon
prompt$ use-cobol ron
prompt$ use-cobol sergey
prompt$ use-cobol joe
prompt$ use-cobol experiment

program-id. helloat.
DISPLAY "Hello, world" LINE 5 COLUMN 5
goback.

$ infocmp | head -2

# Reconstructed via infocmp from file: /home/btiffin/.terminfo/x/xterm-256color
xterm-256color|xterm with 256 colors,

[btiffin@localhost junk]$ sudo infocmp | head -2
# Reconstructed via infocmp from file: /usr/share/terminfo/x/xterm-256color
xterm-256color|xterm with 256 colors,

$ infocmp >xterm.terminfo
$ vi xterm.terminfo
$ # get rid of smcup= and rmcup= upto and including the comma
$ tic xterm.terminfo

...
rin=\E[%p1%dT, rmacs=\E(B, rmam=\E[?7l, rmcup=\E[?1049l,
rmir=\E[4l, rmkx=\E[?1l\E>, rmm=\E[?1034l, rmso=\E[27m,
rmul=\E[24m, rs1=\Ec, rs2=\E[!p\E[?3;4l\E[4l\E>, sc=\E7,
setab=\E[4%p1%dm, setaf=\E[3%p1%dm,
setb=\E[4%?%p1%{1}%=%t4%e%p1%{3}%=%t6%e%p1%{4}%=%t1%e%p1%{6}%=%t3%e%p1%d%;m,
setf=\E[3%?%p1%{1}%=%t4%e%p1%{3}%=%t6%e%p1%{4}%=%t1%e%p1%{6}%=%t3%e%p1%d%;m,
sgr=%?%p9%t\E(0%e\E(B%;\E[0%?%p6%t;1%;%?%p2%t;4%;%?%p1%p3%|%t;7%;%?%p4%t;5%;%?%p7%t;8%;m,
sgr0=\E(B\E[m, smacs=\E(0, smam=\E[?7h, smcup=\E[?1049h,
...

...
rin=\E[%p1%dT, rmacs=\E(B, rmam=\E[?7l,
rmir=\E[4l, rmkx=\E[?1l\E>, rmm=\E[?1034l, rmso=\E[27m,
rmul=\E[24m, rs1=\Ec, rs2=\E[!p\E[?3;4l\E[4l\E>, sc=\E7,
setab=\E[4%p1%dm, setaf=\E[3%p1%dm,
setb=\E[4%?%p1%{1}%=%t4%e%p1%{3}%=%t6%e%p1%{4}%=%t1%e%p1%{6}%=%t3%e%p1%d%;m,
setf=\E[3%?%p1%{1}%=%t4%e%p1%{3}%=%t6%e%p1%{4}%=%t1%e%p1%{6}%=%t3%e%p1%d%;m,
sgr=%?%p9%t\E(0%e\E(B%;\E[0%?%p6%t;1%;%?%p2%t;4%;%?%p1%p3%|%t;7%;%?%p4%t;5%;%?%p7%t;8%;m,
sgr0=\E(B\E[m, smacs=\E(0, smam=\E[?7h,
...

identification division.
program-id. helloscreen.
procedure division.
display "Hello, world" at 0212
display "Goodbye, smcup/rmcup" at 0313
goback.
end program helloscreen.

[btiffin@home forum]$ ./helloscreen

       Hello, world
        Goodbye, smcup/rmcup
[btiffin@home forum]$

/* Buffer size definitions */

#define COB_MINI_BUFF           256
#define COB_SMALL_BUFF          1024
#define COB_NORMAL_BUFF         2048
#define COB_FILE_BUFF           4096
#define COB_MEDIUM_BUFF         8192
#define COB_LARGE_BUFF          16384
#define COB_MINI_MAX            (COB_MINI_BUFF - 1)
#define COB_SMALL_MAX           (COB_SMALL_BUFF - 1)
#define COB_NORMAL_MAX          (COB_NORMAL_BUFF - 1)
#define COB_FILE_MAX            (COB_FILE_BUFF - 1)
#define COB_MEDIUM_MAX          (COB_MEDIUM_BUFF - 1)
#define COB_LARGE_MAX           (COB_LARGE_BUFF - 1)

/* Perform stack size */
#define COB_STACK_SIZE          255

/* Maximum size of file records */
#define MAX_FD_RECORD           65535

/* Maximum number of parameters */
#define COB_MAX_FIELD_PARAMS    36

/* Maximum number of field digits */
#define COB_MAX_DIGITS          38

/* Max digits in binary field */
#define COB_MAX_BINARY          39

/* Maximum number of cob_decimal structures */
#define COB_MAX_DEC_STRUCT      32

/* Maximum group and single field size */
#define COB_MAX_FIELD_SIZE      268435456

...

    none of the values below: don't do extra synch - the system (and
additional for indexed files the library used) decide when the buffer
should be written to the file (in general keys are stored more often and
if locking is active more is done) - it is guaranteed to be done on
CLOSE... --> this is the standard and is normally completely fine.

    Y or y: after all file-changes (WRITE, REWRITE, DELETE) do an extra
synch of the indexed files via the library, all other files will receive
an fflush()/)

    P or p: additional send fsync() to all files to be physically written
to disk and wait until this is finished (real slow)

    false values: don't do extra synch - the system (and additional for
indexed files the library used) decide when the buffer should be written
to the file (in general keys are stored more often and if locking is
active more is done) - it is guaranteed to be done on CLOSE... --> this is
the standard and is normally completely fine.

    true values or P: after all sucessful file commands nearly identical
to the P option of GnuCOBOL 1.1: if fdatasync() is available use this
(force data write and wait for it but don't force writing of metadata like
last access/write stamps), otherwise use fsync

prompt$ cobcrun -r

GnuCOBOL 2.0-rc3.0 runtime configuration
 via  /usr/local/share/gnucobol/config/runtime.cfg

 CALL configuration
    : COB_LOAD_CASE         : not set
    : COB_PHYSICAL_CANCEL   : false (default)
    : COB_PRE_LOAD          : not set
    : COB_LIBRARY_PATH      : not set

 File I/O configuration
    : COB_FILE_PATH         : not set
    : COB_VARSEQ_FORMAT     : 0 (default)
    : COB_LS_FIXED          : false (default)
    : COB_LS_NULLS          : false (default)
    : COB_SORT_CHUNK        : 256 KB (default)
    : COB_SORT_MEMORY       : 128 MB (default)
    : COB_SYNC              : false (default)

 Screen I/O configuration
    : COB_BELL              : BEEP (default)
    : COB_REDIRECT_DISPLAY  : false (default)
    : COB_SCREEN_ESC        : false (default)
    : COB_SCREEN_EXCEPTIONS : false (default)
    : COB_INSERT_MODE       : false (default)
    : COB_TIMEOUT_SCALE     : 0 (1000) (default)
    : COB_LEGACY            : false (default)
    : COB_EXIT_WAIT         : true (default)
    : COB_EXIT_MSG          : 'end of program, please press a key to exit'
(default)

 Miscellaneous
    : COB_DISABLE_WARNINGS  : false (default)
    : COB_ENV_MANGLE        : false (default)
    : COB_SET_TRACE         : false (default)
    : COB_TRACE_FILE        : not set

 System configuration
 env: USERNAME              : 'btiffin' (set by LOGNAME)
 env: LANG                  : 'en_CA.UTF-8'
    : OSTYPE                : not set
 env: TERM                  : 'xterm'
    : LC_CTYPE              : C
    : LC_NUMERIC            : C
    : LC_COLLATE            : en_CA.UTF-8
    : LC_MESSAGES           : en_CA.UTF-8
    : LC_MONETARY           : en_CA.UTF-8
    : LC_TIME               : en_CA.UTF-8

# GnuCOBOL runtime configuration
#
# Copyright (C) 2015, 2016 Free Software Foundation, Inc.
# Written by Simon Sobisch, Ron Norman
#
# This file is part of the GnuCOBOL runtime.
#
# The GnuCOBOL runtime is free software: you can redistribute it
# and/or modify it under the terms of the GNU Lesser General Public License
# as published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# GnuCOBOL is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with GnuCOBOL.  If not, see <http://www.gnu.org/licenses/>.


#
## General instructions
#

# The initial runtime.cfg file is found in the  $COB_CONFIG_DIR/config
# (  COB_CONFIG_DIR  defaults to  installdir/gnucobol  ).
# The environment variable  COB_RUNTIME_CONFIG  may define a different runtime
# configuration file to read.

# If settings are included in the runtime environment file multiple times
# then the last setting value is used, no warning occurs.

# Settings via environment variables always take precedence over settings
# that are given in runtime configuration files. And the environment is
# checked after completing processing of the runtime configuration file(s)

# All values set to string variables or environment variables are checked
# for  ${envvar}  and replacement is done at the time of the setting.

# Any environment variable may be set with the directive  setenv  .
# Example:  setenv COB_LIBARAY_PATH ${LD_LIBRARY_PATH}

# Any environment variable may be unset with the directive  unsetenv
# (one var per line).
# Example:  unsetenv COB_LIBRARY_PATH

# Runtime configuration files can include other files with the directive
# include.
# Example:  include my-runtime-configuration-file

# To include another configuration file only if it is present use the directive
# includeif.
# You can also use  ${envvar}  inside this.
# Example:  includeif ${HOME}/mygc.cfg

# If you want to reset a parameter to its default value use:
#    reset parametername

# Most runtime variables have boolean values, some are switches, some have
# string values, integer values and some are size values.
# The boolean values will be evaluated as following:
#   to true:          1, Y, ON, YES, TRUE  (no matter of case)
#   to false:         0, N, OFF
# A 'size' value is an integer optionally followed by K, M, or G for kilo, mega
# or giga.

# For convenience a parameter in the runtime.cfg file may be defined by using
# either the environment variable name or the parameter name.
# In most cases the environment variable name is the parameter name (in upper
# case) with the prefix  COB_  .

#
## General environment
#

# Environment name:  COB_DISABLE_WARNINGS
#   Parameter name:  disable_warnings
#          Purpose:  turn off runtime warning messages
#             Type:  boolean
#          Default:  false
#          Example:  DISABLE_WARNINGS  TRUE

# Environment name:  COB_ENV_MANGLE
#   Parameter name:  env_mangle
#          Purpose:  names checked in the environment would get non alphanumeric
#                    change to '_'
#             Type:  boolean
#          Default:  false
#          Example:  ENV_MANGLE  TRUE

# Environment name:  COB_SET_TRACE
#   Parameter name:  set_trace
#          Purpose:  to enable to COBOL trace feature
#             Type:  boolean
#          Default:  false
#          Example:  SET_TRACE  TRUE

# Environment name:  COB_TRACE_FILE
#   Parameter name:  trace_file
#          Purpose:  to define where COBOL trace output should go
#             Type:  string
#          Default:  stderr
#          Example:  TRACE_FILE  ${HOME}/mytrace.log

#
## Call environment
#

# Environment name:  COB_LIBRARY_PATH
#   Parameter name:  library_path
#          Purpose:  paths for dynamically-loadable modules
#             Type:  string
#             Note:  the default paths .:/installpath/extras are always
#                    added to the given paths
#          Example:  LIBRARY_PATH    /opt/myapp/test:/opt/myapp/production

# Environment name:  COB_PRE_LOAD
#   Parameter name:  pre_load
#          Purpose:  modules that are loaded during startup, can be used
#                    to CALL COBOL programs or C functions that are part
#                    of a module library
#             Type:  string
#             Note:  the modules listed should NOT include extensions, the
#                    runtime will use the right ones on the various platforms,
#                    COB_LIBRARY_PATH is used to locate the modules
#          Example:  PRE_LOAD      COBOL_function_library:external_c_library

# Environment name:  COB_LOAD_CASE
#   Parameter name:  load_case
#          Purpose:  resolve ALL called program names to UPPER or LOWER case
#             Type:  Only use  UPPER  or  LOWER
#          Default:  if not set program names in CALL are case sensitive
#          Example:  LOAD_CASE  UPPER

# Environment name:  COB_PHYSICAL_CANCEL
#   Parameter name:  physical_cancel
#          Purpose:  physically unload a dynamically-loadable module on CANCEL,
#                    this frees some RAM and allows the change of modules during
#                    run-time but needs more time to resolve CALLs (both to
#                    active and not-active programs)
#            Alias:  default_cancel_mode, LOGICAL_CANCELS (0 = yes)
#             Type:  boolean (evaluated for true only)
#          Default:  false
#          Example:  PHYSICAL_CANCEL  TRUE

#
## File I/O
#

# Environment name:  COB_VARSEQ_FORMAT
#   Parameter name:  varseq_format
#          Purpose:  declare format used for variable length sequential files
#                    - different types and lengths precede each record
#                    - 'length' is the data length & does not include the prefix
#             Type:  0   means 2 byte record length (big-endian) + 2 NULs
#                    1   means 4 byte record length (big-endian)
#                    2   means 4 byte record length (local machine int)
#                    3   means 2 byte record length (big-endian)
#          Default:  0
#          Example:  VARSEQ_FORMAT 1

# Environment name:  COB_FILE_PATH
#   Parameter name:  file_path
#          Purpose:  define default location where data files are stored
#             Type:  file path directory
#          Default:  .  (current directory)
#          Example:  FILE_PATH ${HOME}/mydata

# Environment name:  COB_LS_FIXED
#   Parameter name:  ls_fixed
#          Purpose:  Defines if LINE SEQUENTIAL files should be fixed length
#                    (or variable, by removing trailing spaces)
#            Alias:  STRIP_TRAILING_SPACES  (0 = yes)
#             Type:  boolean
#          Default:  false
#          Example:  LS_FIXED TRUE

# Environment name:  COB_LS_NULLS
#   Parameter name:  ls_nulls
#          Purpose:  Defines for LINE SEQUENTIAL files what to do with data
#                    which is not DISPLAY type.  This could happen if a LINE
#                    SEQUENTIAL record has COMP data fields in it.
#             Type:  boolean
#          Default:  false
#             Note:  The TRUE setting will handle files that contain COMP data
#                    in a similar manner to the method used by Micro Focus COBOL
#          Example:  LS_NULL = TRUE

# Environment name:  COB_SYNC
#   Parameter name:  sync
#          Purpose:  Should the file be synced to disk after each write/update
#             Type:  boolean
#          Default:  false
#          Example:  SYNC: TRUE

# Environment name:  COB_SORT_MEMORY
#   Parameter name:  sort_memory
#          Purpose:  Defines how much RAM to assign for sorting data
#             Type:  size  but must be more than 1M
#          Default:  128M
#          Example:  SORT_MEMORY 64M

# Environment name:  COB_SORT_CHUNK
#   Parameter name:  sort_chunk
#          Purpose:  Defines how much RAM to assign for sorting data in chunks
#             Type:  size  but must be within 128K and 16M
#          Default:  256K
#          Example:  SORT_CHUNK 1M

#
## Screen I/O
#

# Environment name:  COB_BELL
#   Parameter name:  bell
#          Purpose:  Defines how a request for the screen to beep is handled
#             Type:  FLASH, SPEAKER, FALSE, BEEP
#          Default:  BEEP
#          Example:  BELL SPEAKER

# Environment name:  COB_REDIRECT_DISPLAY
#   Parameter name:  redirect_display
#          Purpose:  Defines if DISPLAY output should be sent to 'stderr'
#             Type:  boolean
#          Default:  false
#          Example:  redirect_display Yes

# Environment name:  COB_SCREEN_ESC
#   Parameter name:  screen_esc
#          Purpose:  Enable handling of ESC key during ACCEPT
#             Type:  boolean
#          Default:  false
#             Note:  is only evaluated if COB_SCREEN_EXCEPTIONS is active
#          Example:  screen_esc Yes

# Environment name:  COB_SCREEN_EXCEPTIONS
#   Parameter name:  screen_exceptions
#          Purpose:  enable exceptions for function keys during ACCEPT
#             Type:  boolean
#          Default:  false
#          Example:  screen_exceptions Yes

# Environment name:  COB_TIMEOUT_SCALE
#   Parameter name:  timeout_scale
#          Purpose:  specify translation in milliseconds for ACCEPT clauses
#                    BEFORE TIME value / AFTER TIMEOUT
#             Type:  integer
#                    0 means 1000 (Micro Focus COBOL compatible), 1 means 100
#                    (ACUCOBOL compatible), 2 means 10, 3 means 1
#          Default:  0
#          Example:  timeout_scale 3

# Environment name:  COB_INSERT_MODE
#   Parameter name:  insert_mode
#          Purpose:  specify default insert mode for ACCEPT; 0=off, 1=on
#             Type:  boolean
#          Default:  false
#          Example:  insert_mode Y

# Environment name:  COB_LEGACY
#   Parameter name:  legacy
#          Purpose:  keep behaviour of former runtime versions, currently only
#                    for setting screen attributes for non input fields
#             Type:  boolean
#          Default:  not set
#          Example:  legacy true

# Environment name:  COB_EXIT_WAIT
#   Parameter name:  exit_wait
#          Purpose:  to wait on main program exit if an extended screenio
#                    DISPLAY was issued without an ACCEPT following
#             Type:  boolean
#          Default:  true
#          Example:  COB_EXIT_WAIT off

# Environment name:  COB_EXIT_MSG
#   Parameter name:  exit_msg
#          Purpose:  string to display if COB_EXIT_WAIT is processed, set to ''
#                    if no actual display but an ACCEPT should be done
#             Type:  string
#          Default:  'end of program, please press a key to exit' (localized)
#          Example:  COB_EXIT_MSG ''

# Note: If you want to slightly speed up a program's startup time, remove all
#       of the comments from the actual real file that is processed

105a106,114
> # Environment name:  COB_CURRENT_DATE
> #   Parameter name:  current_date
> #          Purpose:  specify an alternate Date/Time to be returned to ACCEPT
clauses
> #                    This is used for testing purposes
> #            Alias:  COB_DATE
> #             Type:  Numeric string in format YYYYDDMMHH24MISS
> #          Default:  The operating system date is use
> #          Example:  COB_CURRENT_DATE "2016/03/16 16:40:52"
>
159a169,171
> #                    b32 means 4 byte record length (big-endian)
> #                    l32 means 4 byte record length (little-endian)
> #                    mf  means Micro Focus default
162a175,201
> # Environment name:  COB_VARREL_FORMAT
> #   Parameter name:  varrel_format
> #          Purpose:  declare format to be used for variable length relative
> #                    files (different types and lengths preceding each
record)
> #             Type:  0   means local machine 'size_t'
> #                    b32 means 4 byte record length (big-endian)
> #                    l32 means 4 byte record length (little-endian)
> #                    b64 means 8 byte record length (big-endian)
> #                    l64 means 8 byte record length (little-endian)
> #                    mf  means Micro Focus default
> #                    gc  means GnuCOBOL default (local 'size_t')
> #          Default:  0
> #          Example:  VARREL_FORMAT B32
>
> # Environment name:  COB_FIXREL_FORMAT
> #   Parameter name:  fixrel_format
> #          Purpose:  declare format to be used for fixed length relative
> #                    files (different types and lengths preceding each
record)
> #             Type:  b32 means 4 byte record length (big-endian)
> #                    l32 means 4 byte record length (little-endian)
> #                    b64 means 8 byte record length (big-endian)
> #                    l64 means 8 byte record length (little-endian)
> #                    mf  means Micro Focus default
> #                    gc  means GnuCOBOL default (local 'size_t')
> #          Default:  gc  fixed size with no record length prefix
> #          Example:  FIXREL_FORMAT B32
>
188c227,247
< #          Example:  LS_NULL = TRUE
---
> #          Example:  LS_NULLS = TRUE
>
> # Environment name:  COB_LS_VALIDATE
> #   Parameter name:  ls_validate
> #          Purpose:  Defines for LINE SEQUENTIAL files that the data should
be
> #                    validated. If any record has non-DISPLAY characters
then
> #                    an error status of 30 is returned
> #             Type:  boolean
> #          Default:  true
> #             Note:  The TRUE setting does data validation
> #                    The FALSE setting lets non-DISPLAY characters be
written
> #                    If LS_NULLS is set, then LS_VALIDATE is not checked
> #          Example:  LS_VALIDATE = FALSE
>
> # Environment name:  COB_MF_FILES
> #   Parameter name:  mf_files
> #          Purpose:  Declares that all files in the program should follow
> #                    Micro Focus format
> #             Type:  boolean
> #          Default:  false
> #          Example:  MF_FILES = TRUE
253,259d311
<
< # Environment name:  COB_INSERT_MODE
< #   Parameter name:  insert_mode
< #          Purpose:  specify default insert mode for ACCEPT; 0=off, 1=on
< #             Type:  boolean
< #          Default:  false
< #          Example:  insert_mode Y

FD infile
    RECORD IS VARYING IN SIZE FROM 1 TO 65535 CHARACTERS
    DEPENDING ON infile-record-length.
01 infile-record.
   05 infile-data      PIC X OCCURS FROM 1 TO 65535 TIMES
                       DEPENDING ON infile-record-length.

FD infile RECORD VARYING DEPENDING ON infile-record-length.

export COB_LDFLAGS='-Wl, --no-as-needed'

-I <directory>        Add <directory> to copy/include search path
-L <directory>        Add <directory> to library search path
-l <lib>              Link the library <lib>
-A <options>          Add <options> to the C compile phase
-Q <options>          Add <options> to the C link phase
-K <entry>            Generate CALL to <entry> as static

libcob: Cannot find module 'gtk_init'

here following my env variables:

set path=..\bin\;..\runtime_acu;%path%;

:: needed at compile time (serve OLDNAMES.LIB prelevata da
s:\std\wip\generator\include e messa in
s:\std\wip\maw\gnu\gnu_cobol_2.0\mylib\
include=..\include
LIB=..\lib;
PKG_CONFIG_PATH=..\lib\pkgconfig
set COB_LDFLAGS=-Wl,--no-as-needed
(I find out similar issue on linux solved with this)
set COB_LIBS= ..\lib\gtk\*.lib
set COB_LIBRARY_PATH=..\bin;..\runtime_acu;..\lib;.
set COB_CONFIG_DIR=..\config
set COB_PRE_LOAD=..\bin\libgtk-3-0.dll;..\bin\libgdk-3-0.dll;
..\bin\libgobject-2.0-0.dll;
..\bin\libpango-1.0-0.dll;..\bin\libglib-2.0-0.dll;
..\bin\libgdk_pixbuf-2.0-0.dll; acu_io_bridge.dll;..\runtime_acu\wrun32.dll

Finally I found out the issue!!!!!

All the values in my set script were separated by ;(semi colon standard
windows) , but mingw want them separated by : (colon standard linux).  I
changed all the ; to : (specially in cob_preload and cob_library_path)
and it worked.

Hope this can be usefull for somenone else.

cheers
Ivan

prompt$ time cobc -x anagrams.cob

real    0m0.115s
user    0m0.088s
sys     0m0.020s

prompt$ time ./anagrams
2016-04-28T05:16:17.999194355, 000018977 seconds past midnight
25104 words, most anagrams: 05
abel      [abel, able, bale, bela, elba]
acert     [caret, carte, cater, crate, trace]
aegln     [angel, angle, galen, glean, lange]
aeglr     [alger, glare, lager, large, regal]
aeln      [elan, lane, lean, lena, neal]
eilv      [evil, levi, live, veil, vile]
2016-04-28T05:16:18.034565633, 000018978 seconds past midnight

real    0m0.042s
user    0m0.032s
sys     0m0.008s

prompt$ cobc -x -Q '-pg' anagrams.cob
prompt$ ./anagrams
2016-04-28T05:13:01.894518641, 000018781 seconds past midnight
25104 words, most anagrams: 05
abel      [abel, able, bale, bela, elba]
acert     [caret, carte, cater, crate, trace]
aegln     [angel, angle, galen, glean, lange]
aeglr     [alger, glare, lager, large, regal]
aeln      [elan, lane, lean, lena, neal]
eilv      [evil, levi, live, veil, vile]
2016-04-28T05:13:01.933875670, 000018781 seconds past midnight

prompt$ ls -larct
-rwxrwxr-x  1 username groupname  20024 Apr 28 05:05 anagrams
-rw-rw-r--  1 username groupname   2797 Apr 28 05:05 gmon.out

prompt$ gprof anagrams
Flat profile:

Each sample counts as 0.01 seconds.
 no time accumulated

  %   cumulative   self              self     total
 time   seconds   seconds    calls  Ts/call  Ts/call  name
  0.00      0.00     0.00        1     0.00     0.00  anagrams
  0.00      0.00     0.00        1     0.00     0.00  anagrams_

prompt$ perf record ./anagrams
2016-04-28T05:23:07.574207248, 000019387 seconds past midnight
25104 words, most anagrams: 05
abel      [abel, able, bale, bela, elba]
acert     [caret, carte, cater, crate, trace]
aegln     [angel, angle, galen, glean, lange]
aeglr     [alger, glare, lager, large, regal]
aeln      [elan, lane, lean, lena, neal]
eilv      [evil, levi, live, veil, vile]
2016-04-28T05:23:07.610477929, 000019387 seconds past midnight
[ perf record: Woken up 1 times to write data ]
[ perf record: Captured and wrote 0.008 MB perf.data (176 samples) ]

prompt$ perf report --stdio | cat
Warning:
Kernel address maps (/proc/{kallsyms,modules}) were restricted.

# Total Lost Samples: 0
#
# Samples: 176  of event 'cycles'
# Event count (approx.): 127807808
#
# Overhead  Command   Shared Object     Symbol
# ........  ........  ................  ...................................
#
    33.08%  anagrams  libcob.so.4.0.0   [.] sort_compare
    14.03%  anagrams  libc-2.21.so      [.] msort_with_tmp.part.0
     7.27%  anagrams  libc-2.21.so      [.] _IO_getc
     6.57%  anagrams  libc-2.21.so      [.] __memcpy_sse2
     5.31%  anagrams  libc-2.21.so      [.] __GI___mempcpy
     4.79%  anagrams  anagrams          [.] anagrams_
     2.30%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     2.25%  anagrams  libcob.so.4.0.0   [.] cob_move
     1.99%  anagrams  libc-2.21.so      [.] __GI___qsort_r
     1.99%  anagrams  libc-2.21.so      [.] _int_free
     1.95%  anagrams  libc-2.21.so      [.] __memcmp_sse4_1
     1.32%  anagrams  libcob.so.4.0.0   [.] cob_decimal_get_field
     1.14%  anagrams  libc-2.21.so      [.] __libc_calloc
     1.13%  anagrams  libcob.so.4.0.0   [.] cob_read_next
     1.10%  anagrams  libc-2.21.so      [.] __memmove_ssse3
     0.66%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.66%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.66%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.66%  anagrams  libcob.so.4.0.0   [.] cob_set_exception
     0.66%  anagrams  libgmp.so.10.2.0  [.] __gmpn_add_n
     0.66%  anagrams  libcob.so.4.0.0   [.] _IO_getc@plt
     0.66%  anagrams  libcob.so.4.0.0   [.] __gmpz_set_ui@plt
     0.66%  anagrams  libgmp.so.10.2.0  [.] __gmpz_sizeinbase
     0.66%  anagrams  libcob.so.4.0.0   [.] cob_intr_formatted_current_date
     0.64%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.64%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.54%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.52%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.51%  anagrams  ld-2.21.so        [.] _dl_map_object
     0.50%  anagrams  libcob.so.4.0.0   [.] lineseq_read
     0.50%  anagrams  ld-2.21.so        [.] strcmp
     0.49%  anagrams  libcob.so.4.0.0   [.] cob_malloc
     0.49%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.48%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.48%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.45%  anagrams  libc-2.21.so      [.] __memset_sse2
     0.43%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.42%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.41%  anagrams  libc-2.21.so      [.] memchr
     0.27%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.05%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx
     0.01%  anagrams  [unknown]         [k] 0xffffffffxxxxxxxx

  15. Disclaimer of Warranty.

  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. Limitation of Liability.

  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.

01 user-pointer USAGE POINTER.

MOVE user-function(user-data) TO user-pointer

01 user-record.
   05 user-pointer USAGE POINTER.

MOVE user-function(user-data) to user-record

#include <stdio.h>

int
main(int argc, char** argv)
{
    char c;
    c = 127;
    printf("%d\n", c);
    c += 1;
    printf("%d\n", c);
    c += 1;
    printf("%d\n", c);
    return 0;
}

prompt$ gcc chars.c
prompt$ ./a.out
127
-128
-127

*>GCOB
       identification division.
       program-id. statically.

       procedure division.
       display "statically linked"

       goback.
       end program statically.

prompt$ cobc -x -v -save-temp statically.cob
cobc (GnuCOBOL) 2.0-rc3.0
Built     Feb 24 2017 13:48:33  Packaged  Nov 05 2016 15:27:33 UTC
C version "5.4.0 20160609"
loading standard configuration file 'default.conf'
command line:   cobc -x -v -save-temp statically.cob
preprocessing:  statically.cob -> statically.i
return status:  0
parsing:        statically.i (statically.cob)
return status:  0
translating:    statically.i -> statically.c (statically.cob)
executing:      gcc -c -I/usr/local/include -Wno-unused -fsigned-char
                -Wno-pointer-sign -pipe -o "statically.o" "statically.c"
return status:  0
executing:      gcc -Wl,--export-dynamic -o "statically" "statically.o"
                -Wl,--no-as-needed -L/usr/local/lib -lcob -lm
                -lvbisam -lgmp -lncurses -ldl
return status:  0

# Creating a static libcob executable
.RECIPEPREFIX = >

statically: statically.cob
> cobc -save-temp -x statically.cob
> gcc -c -I/usr/local/include -Wno-unused -fsigned-char \
      -Wno-pointer-sign -pipe -g -o "statically.o" "statically.c"
> gcc -o "statically" "statically.o" -Wl,--no-as-needed \
      -L/usr/local/lib -Wl,-Bstatic -lcob -lvbisam \
      -Wl,-Bdynamic -lm -lgmp -lncurses -ldl

prompt$ make -B statically
cobc -save-temp -x statically.cob
gcc -c -I/usr/local/include -Wno-unused -fsigned-char \
    -Wno-pointer-sign -pipe -g -o "statically.o" "statically.c"
gcc -o "statically" "statically.o" -Wl,--no-as-needed \
    -L/usr/local/lib -Wl,-Bstatic -lcob -lvbisam \
    -Wl,-Bdynamic -lm -lgmp -lncurses -ldl

prompt$ ls -go statically
-rwxrwxr-x 1 969264 Feb 24 17:50 statically

prompt$ ldd statically
        linux-vdso.so.1 =>  (0x00obfuscated)
        libm.so.6 => /lib/x86_64-linux-gnu/libm.so.6 (0x00obfuscated)
        libgmp.so.16 => /usr/local/lib/libgmp.so.16 (0x00obfuscated)
        libncurses.so.5 => /lib/x86_64-linux-gnu/libncurses.so.5 (0x00obfuscated)
        libtinfo.so.5 => /lib/x86_64-linux-gnu/libtinfo.so.5 (0x00obfuscated)
        libdl.so.2 => /lib/x86_64-linux-gnu/libdl.so.2 (0x00obfuscated)
        libc.so.6 => /lib/x86_64-linux-gnu/libc.so.6 (0x00obfuscated)
        /lib64/ld-linux-x86-64.so.2 (0x00obfuscated)

prompt$ cobc -x statically.cob
prompt$ ls -go statically
-rwxrwxr-x 1 13408 Feb 24 17:52 statically

prompt$ ldd statically
        linux-vdso.so.1 =>  (0x00obfuscated)
        libcob.so.4 => /usr/local/lib/libcob.so.4 (0x00obfuscated)
        libm.so.6 => /lib/x86_64-linux-gnu/libm.so.6 (0x00obfuscated)
        libvbisam.so.1 => /usr/local/lib/libvbisam.so.1 (0x00obfuscated)
        libgmp.so.16 => /usr/local/lib/libgmp.so.16 (0x00obfuscated)
        libncurses.so.5 => /lib/x86_64-linux-gnu/libncurses.so.5 (0x00obfuscated)
        libtinfo.so.5 => /lib/x86_64-linux-gnu/libtinfo.so.5 (0x00obfuscated)
        libdl.so.2 => /lib/x86_64-linux-gnu/libdl.so.2 (0x00obfuscated)
        libc.so.6 => /lib/x86_64-linux-gnu/libc.so.6 (0x00obfuscated)
        /lib64/ld-linux-x86-64.so.2 (0x00obfuscated)

prompt$ cobc -x statically.cob
prompt$ ./statically
statically linked

prompt$ make -B statically
prompt$ ./statically
statically linked

*>GCOB
       identification division.
       program-id. statically.

       procedure division.
       display "static linking of libcob"
       call "SYSTEM" using "ls -go statically"
       goback.
       end program statically.

prompt$ make -B statically
cobc -save-temp -x statically.cob
gcc -c -I/usr/local/include -Wno-unused -fsigned-char \
    -Wno-pointer-sign -pipe -g -o "statically.o" "statically.c"
gcc -o "statically" "statically.o" -Wl,--no-as-needed \
    -L/usr/local/lib -Wl,-Bstatic -lcob -lvbisam \
    -Wl,-Bdynamic -lm -lgmp -lncurses -ldl

prompt$ ./statically
static linking of libcob
-rwxrwxr-x 1 969312 Feb 24 18:05 statically

prompt$ cobc -xj statically.cob
static linking of libcob
-rwxrwxr-x 1 13480 Feb 24 18:06 statically

       >>SOURCE FORMAT IS FREE
IDENTIFICATION DIVISION.
program-id. GCACCEPT9.
*>
***********************************************************************************
*> GnuCOBOL
*> Purpose:    SHOWS HOW TO ACCEPT & CHECK A NUMBER WITH DCIMALS & SIGN FROM A
FILED ON SCREEN
*> Tectonics:  cobc -x GCACCEPT.COB  (use GnuCOBOL 2.0 or greater)
*> Usage:      GCACCEPT
*> Author:     Eugenio Di Lorenzo - Italia (DILO)
*> License:    Copyright 2017 E.Di Lorenzo - GNU Lesser General Public License, LGPL, 3.0 (or greater)
*> Version:    1.0 2017.03.01
*> Changelog:  1.0 first release.
*>
***********************************************************************************
ENVIRONMENT DIVISION.
Configuration Section.
 SPECIAL-NAMES.
   CRT STATUS IS wKeyPressed
   Decimal-Point is Comma.

DATA DIVISION.
WORKING-STORAGE SECTION.
78  K-ESCAPE      VALUE 2005.

01 black   constant as 0.
01 blue    constant as 1.
01 green   constant as 2.
01 cyan    constant as 3.
01 red     constant as 4.
01 magenta constant as 5.
01 yellow  constant as 6.
01 white   constant as 7.
01 pro         pic X value  '_'.
01 wKeyPressed pic 9999.

01 wRetCode    PIC 9999.

*>
***************************************************************************************
*> HOW IT WORKS:
*>
***************************************************************************************
*> Field9 is your numeric field you have to accept and next you can store for example in a file
*> in this example it is PIC S9(7)V99 = 9 bytes, 7 integers & 2 decimals signed
*> FieldX is the field you have to use in the ACCEPT statement
*> in this example it is 11 bytes = 9 digits + the sign (+ or -) + the comma
*> FieldZ is a working filed to display the number on screen after the ACCEPT (11 bytes)
*> it is same length than FieldX but it is edited

01 Field9   PIC S9(7)V99. *> this is the numeric field (example to be stored in a file)
01 FieldX   PIC X(11).
01 FieldZ   PIC -(7)9,99. *> max edited number is -9999999,99 (11 chars)


*> **************************************************************
*>           P R O C E D U R E   D I V I S I O N
*> **************************************************************
PROCEDURE DIVISION.
  *> sets in order to detect the PgUp, PgDn, PrtSc(screen print), Esc keys,
  set environment 'COB_SCREEN_EXCEPTIONS' TO 'Y'.
  set environment 'COB_SCREEN_ESC'        TO 'Y'.

  display 'GnuCOBOL - HOW TO MANAGE NUMERIC DATA ON SCREEN'
                                     at 0205 with  Background-Color white Foreground-Color blue reverse-video
  display '-----------------------------------------------'
                                     at 0305 with  Background-Color white Foreground-Color blue reverse-video
  display 'Type an amount .....:'    at 0505 with  Background-Color white Foreground-Color blue reverse-video
  display 'signed with 2 decimals'   at 0540 with  Background-Color white Foreground-Color blue reverse-video
  display '12345678901'              at 0627 with  Background-Color white Foreground-Color blue reverse-video
  display '(decimal point is comma)' at 0640 with  Background-Color white Foreground-Color blue reverse-video
  display 'ESC = EXIT'               at 2305 with  Background-Color white Foreground-Color blue reverse-video
  .
Accept-Field.
  accept FieldX at 0527 with  Background-Color blue Foreground-Color cyan
         update prompt character is pro auto-skip reverse-video

  if wKeyPressed = K-ESCAPE go to End-Program end-if

*> INTRINSIC FUNCTION: TEST-NUMVAL(STRING)
*> --------------------------------------
*> tests the given string for conformance to the rules used by intrinsic FUNCTION NUMVAL.
*> Returns 0 if the value conforms, a character position of the first non conforming character,
*> or the length of the field plus one for other cases such as all spaces.
*> example: you can type +123,44 (is ok) ; -145,,23 (is ko) ; 123- (is ok) etc
  move function test-numval(FieldX) to wRetCode
  display  'RetCode.............:' at 1305 with  Background-Color white Foreground-Color blue reverse-video
  display  wRetCode   at 1334 with  Background-Color white Foreground-Color blue reverse-video

  display ' '
        at 1505 with  Background-Color white Foreground-Color black reverse-video

  if wRetCode > length of FieldX
     *> the field is empty ! program move zero to the field
     move zero to FieldX

     move function numval(FieldX) to Field9 FieldZ
     *> following statement is used to display the amount on screen after the ACCEPT
     move FieldZ to FieldX
     display FieldX                             at 0527 with  Background-Color white Foreground-Color blue reverse-video

     display 'correct format number '           at 1505 with  Background-Color white Foreground-Color green reverse-video
     display '=> empty field ! forced to ZERO.' at 1520 with  Background-Color red   Foreground-Color green reverse-video
     display 'Edited Number.......:'                  at 0905 with Background-Color white Foreground-Color blue reverse-video
     display  FieldZ                                  at 0927 with Background-Color white Foreground-Color blue reverse-video
     display 'Number in memory....:'                  at 1105 with Background-Color white Foreground-Color blue reverse-video
     display  Field9                                  at 1129 with Background-Color white Foreground-Color blue reverse-video
     display 'PIC S9(7)V99 = 9 bytes, 7 int & 2 dec.' at 1140 with Background-Color white Foreground-Color blue reverse-video
  else
     *> field is not empty
     if wRetCode not = ZERO
        *> field is not correct
        display 'incorrect format number '            at 1505 with Background-Color white Foreground-Color red reverse-video
        display '- 1st wrong character at position: ' at 1529 with Background-Color white Foreground-Color red reverse-video
        display wRetCode                              at 1564 with Background-Color white Foreground-Color red reverse-video
     else
        *> field is correct

        move function numval(FieldX) to Field9 FieldZ
        *> following statement is used to display the amount on screen after the ACCEPT
        move FieldZ to FieldX
        display FieldX                             at 0527 with Background-Color white Foreground-Color blue reverse-video

        display 'correct format number '                 at 1505 with Background-Color white Foreground-Color green reverse-video
        display 'Edited Number.......:'                  at 0905 with Background-Color white Foreground-Color blue reverse-video
        display  FieldZ                                  at 0927 with Background-Color white Foreground-Color blue reverse-video
        display 'Number in memory....:'                  at 1105 with Background-Color white Foreground-Color blue reverse-video
        display  Field9                                  at 1129 with Background-Color white Foreground-Color blue reverse-video
        display 'PIC S9(7)V99 = 9 bytes, 7 int & 2 dec.' at 1140 with Background-Color white Foreground-Color blue reverse-video

      end-if
  end-if

 go Accept-Field
 .
End-Program.
 goback.

*>
*****************************************************************************************************************************
*> HOW TO MANAGE A SIGE NUMERIC FIELD ON SCREEN (short form whitout demo statements)
*>
*****************************************************************************************************************************
*>  display 'Type an amount .....:'  at 0505 with  Background-Color white Foreground-Color blue reverse-video
*>  .
*>Accept-Field.
*>  accept FieldX at 0527 with  Background-Color blue Foreground-Color cyan
*>         update prompt character is pro auto-skip reverse-video
*>  if function test-numval(FieldX) > length of FieldX
*>     move zero to FieldX
*>     move function numval(FieldX) to Field9 FieldZ
*>     move FieldZ to FieldX
*>     display FieldX  at 0527 with Background-Color white Foreground-Color blue reverse-video
*>  else
*>     if function test-numval(FieldX) not = ZERO
*>        display 'incorrect format number ' at 1505 with  Background-Color white Foreground-Color red reverse-video
*>        go to Accept-Field
*>       else
*>        move function numval(FieldX) to Field9 FieldZ
*>        move FieldZ to FieldX
*>        display FieldX at 0527 with Background-Color white Foreground-Color blue reverse-video
*>      end-if
*>  end-if

field(offset : length)

01 some-field PIC x(10) VALUE "abcdefghij".

...

DISPLAY some-field
DISPLAY some-field(1:5)
DISPLAY some-field(6:5)
DISPLAY some-field(8:)

abcdefghij
abcde
fghij
hij

table-field(current-index)(offset : length)

table-field OF account-group(current-index)(offset IN accounts : len)

DISPLAY some-field( 1 + 2 + 3 : 4 + 5 * 6 / 4 )

DISPLAY some-field( (1 + 2) * 3 : 4 + 5 * 6 / 4 )

DISPLAY some-field(
           base-offset + current-offset : function length(subject-field))

DISPLAY some-field(1:a-3)
DISPLAY some-fielf(1:a - 3)

DISPLAY some-field(1 : a-3 + 4 + b - 3)

01 some-field PIC x(8).
01 mod-len USAGE BINARY-LONG value 10.

...
DISPLAY some-field(1 : mod-len)

libcob: refmod.cob: 33: length of 'some-field' out of bounds: 10

DISPLAY some-field(1 : 10)

prompt$ cobc -x refmod.cob
refmod.cob: in paragraph 'sample-main':
refmod.cob: 33: error: length of 'some-field' out of bounds: 10

http colon slash slash
www dot dubner dot com slash symas slash repos slash cblgdb-2.3.tar.gz

prompt$ make -B
COBCDEVEL=1 COBCDNOCLEAN=2 COBCDFLAGS=--free COBCDXM=-x ../../cobcd rtest.cbl

prompt$ ./rtest
entering: rtest
Addition result: (should be 4.44): +04.44
Subtraction result: (should be 1.23) +01.23
ABCDEFGHIJKLMNOPQRSTUVWXYZ

prompt$ gdb -q rtest
Reading symbols from rtest...done.
registering CPrint (Usage is "print  <COBOL identifier>") [Version 2.3]
registering CWatch (Usage is "cwatch <COBOL identifier>")

(gdb) start
Temporary breakpoint 1 at 0x40111b: file rtest.cbl, line 3.
Starting program: /home/btiffin/inst/cblgdb-2.3/samples/ref_test_1/rtest

[Thread debugging using libthread_db enabled]
Using host libthread_db library "/lib64/libthread_db.so.1".

Temporary breakpoint 1, 0x000000000040111b in main (argc=0, argv=0x7fffffffdc50) at rtest.cbl:3
3       PROCEDURE DIVISION.

(gdb) step
0x00007ffff7b8a4d0 in cob_module_global_enter () from /usr/local/lib/libcob.so.4

(gdb)
Single stepping until exit from function cob_module_global_enter,
which has no line number information.
RTEST_ (entry=0) at rtest.cbl:4
4       DISPLAY "entering: rtest".

(gdb)
entering: rtest
5       CALL 'ADD-SUB'.

(gdb)
0x000000000040159b in ADD__SUB () at rtest.cbl:32
32      ADDITION.

(gdb)
0x00007ffff7b8a4d0 in cob_module_global_enter () from /usr/local/lib/libcob.so.4

(gdb)
Single stepping until exit from function cob_module_global_enter,
which has no line number information.
0x00007ffff74f3a70 in memset_ifunc () from /lib64/libc.so.6

(gdb)
Single stepping until exit from function memset_ifunc,
which has no line number information.
0x00007ffff750ccb0 in __memset_sse2_unaligned () from /lib64/libc.so.6

(gdb)
Single stepping until exit from function __memset_sse2_unaligned,
which has no line number information.
ADD__SUB_ (entry=0) at rtest.cbl:33
33      MOVE 1.23 TO WS-ADDEND-1.

(gdb) print ws-addend-1
"0000"

(gdb) step
34      MOVE 3.21 TO WS-ADDEND-2.

(gdb) print ws-addend-1
"0123"

(gdb) step
35      CALL 'ADD-THEM' USING WS-FOR-ADD.

(gdb) print ws-addend-2
"0321"

(gdb) step
0x0000000000401ed0 in ADD__THEM (b_41=0x7fffffffdc50 "\001") at rtest.cbl:65
65      DoTheAddition.

(gdb)
0x00007ffff7b8a4d0 in cob_module_global_enter () from /usr/local/lib/libcob.so.4

(gdb)
Single stepping until exit from function cob_module_global_enter,
which has no line number information.
ADD__THEM_ (entry=0, b_41=0x606160 <b_16> "000001230321") at rtest.cbl:66
66          MOVE LK-PARAM-1 TO LS-Accumulator.

(gdb)
67          ADD  LK-PARAM-2 TO LS-Accumulator.
(gdb)
68          MOVE LS-Accumulator TO LK-RESULT.
(gdb)
69          GOBACK.
(gdb)
ADD__SUB_ (entry=0) at rtest.cbl:36
36      DISPLAY 'Addition result: (should be 4.44): ' WITH NO ADVANCING.

(gdb) print *
  1 : 01 WS-FOR-ADD/ADD-SUB [W-S] : "044401230321"
  2 : 02 WS-SUM/WS-FOR-ADD/ADD-SUB [W-S] : +04.44
  3 : 02 WS-ADDEND-1/WS-FOR-ADD/ADD-SUB [W-S] : "0123"
  4 : 02 WS-ADDEND-2/WS-FOR-ADD/ADD-SUB [W-S] : "0321"
  5 : 01 WS-FOR-SUBTRACT/ADD-SUB [W-S] : "000000000000"
  6 : 02 WS-DIFFERENCE/WS-FOR-SUBTRACT/ADD-SUB [W-S] : +00.00
  7 : 02 WS-MINUEND/WS-FOR-SUBTRACT/ADD-SUB [W-S] : "0000"
  8 : 02 WS-SUBTRAHEND/WS-FOR-SUBTRACT/ADD-SUB [W-S] : "0000"
  9 : 01 TESTER/ADD-SUB [W-S] : "000000000000000000"
 10 : 02 TESTER-02/TESTER/ADD-SUB [W-S] : "000000000000000000"
 11 : 10 TEST-1/TESTER-02/TESTER/ADD-SUB [W-S] : "000000000"
 12 : 20 BOB/TEST-1/TESTER-02/TESTER/ADD-SUB [W-S] : "000000000"
 13 : 20 BOB/TEST-2/TESTER-02/TESTER/ADD-SUB [W-S] : "000000000"
 14 : 10 TEST-2/TESTER-02/TESTER/ADD-SUB [W-S] : "000000000"
 15 : 66 BILL/ADD-SUB [W-S] : "000000000"
 16 : 01 LS-ALPHABET/ADD-SUB [L-S] : "                          "

(gdb) cont
Continuing.
Addition result: (should be 4.44): +04.44
Subtraction result: (should be 1.23) +01.23
ABCDEFGHIJKLMNOPQRSTUVWXYZ
[Inferior 1 (process 2683) exited normally]
(gdb)

MOVE FUNCTION NEW-WINDOW(640, 480) TO window-structure

01 window-width USAGE BINARY-LONG.

MOVE 640 to window-width
MOVE FUNCTION NEW-WINDOW(window-width...

MOVE FUNCTION NEW-WINDOW(FUNCTION NUMVAL(640), FUNCTION NUMVAL(480))
  TO window-structure

MOVE NEW-WINDOW(NUMVAL(640), NUMVAL(480)) TO window-structure

01 extraneous pic x.
MOVE cool-effect("fireworks") TO extraneous

IDENTIFICATION DIVISION.
FUNCTION-ID. udf-sample.

DATA DIVISION.
LINKAGE SECTION.
01 data-value   PIC S9(9).
01 data-binary  USAGE BINARY-LONG.
01 data-decimal PIC 9 ANY NUMERIC.   *> caller sets width
01 data-fixed   PIC X(16).
01 data-buffer  PIC X ANY LENGTH.    *> caller sets width
01 return-value.
   05 binary-result USAGE BINARY-LONG.
   05 decimal-result PIC S9(9).

PROCEDURE DIVISION USING
    data-value data-binary data-decimal data-fixed data-buffer
    RETURNING return-value.

DISPLAY "value: " data-value " binary: " data-binary
        " decimal: " data-decimal
DISPLAY "fixed: " data-fixed
DISPLAY "buffer length: " FUNCTION LENGTH(data-buffer)
DISPLAY "buffer: "  FUNCTION TRIM(data-buffer)

MOVE FUNCTION LENGTH TO binary-result decimal-result
GOBACK.
END FUNCTION udf-sample.

IDENTIFICATION DIVISION.
PROGRAM-ID. use-udf.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
    FUNCTION udf-sample
    FUNCTION ALL INTRINSIC.

DATA DIVISION.
WORKING-STORAGE SECTION.
01 udf-value   PIC S9(9).
01 udf-binary  USAGE BINARY-LONG.
01 udf-decimal PIC 9(9).
01 udf-fixed   PIC X(16).
01 udf-buffer  PIC X(80).
01 udf-return.
   05 binary-result USAGE BINARY-LONG.
   05 decimal-result PIC S9(9).

PROCEDURE DIVISION USING
    udf-value udf-binary udf-decimal udf-fixed udf-buffer
    RETURNING udf-return.

MOVE FUNCTION udf-sample TO udf-return

GOBACK.
END PROGRAM use-udf.

prompt$ cobc -xj use-udf.cob udf-sample.cob

Options:
  -i  cmdfile    Read commands from this file
  -p  progid     Define PROGRAM-ID
  -k, -keep      Keep the generated COBOL code
  -D  env=val    Define environment variable
  -h, -help      display this help and exit
  -V, -version   display version and exit

INPUT
OUTPUT
SKIP=
COPY=
GEN
RUN
SKIPIF[condition]
COBC[opts]
PROGRAMID=name
QUIT / EXIT
HELP

Options:
  -C x           character 'x' indicates ignore
  -e STR         string STR is ignored
  -n STR         string STR is ignored; alpha chars are DIGITS in testfile
  -f STR         STR is date/time pattern; date/time in testfile must be
                     close to modification time of testfile
  -T STR         STR is date/time pattern; date/time in testfile must be
                     close to current time of day
  -v STR         STR is date/time pattern; verify date/time in testfile
  -I STR         if STR is on line of referencefile, ignore complete line
  -x secs        seconds of difference allowed in time compare; default: 300
  -w             ignore all spaces
  -U             Keep trailing spaces (remove underscore)
  -h, -help      display this help and exit
  -V, -version   display version and exit
  referencefile  base text file (reference case) to compare with
        -T,current time
        -v,verify time
        -f,'testfile' time
        -e,just ignore
  testfile       text file created by the test case to be compared

    DDD MMM dd HH:MM:SS YYYY
    MMM DD YYYY HH:MI:SS
    MMM DD YYYY HH-MI-SS
    MMM DD YYYY HH:MM:SS
    YYYY/MM/DD HH:MI:SS
    YYYY/MM/DD
    HH:MM:SS
    HH:MI:SS
    YY/MM/DD
     V.R.P
    HH:MM
    HH:MI
    YYYY
     dd
    MMM
    DDD
along with day and month names (in English)

Strings can be set with ``-I``, that if found will cause the line to
be ignored for comparison.

ACCEPT variable FROM CONSOLE.

ACCEPT variable FROM ENVIRONMENT "path".
ACCEPT variable FROM COMMAND-LINE.

ACCEPT variable FROM ARGUMENT-NUMBER
ACCEPT variable FROM ARGUMENT-VALUE

ACCEPT variable AT 0101.
ACCEPT screen-variable.

ACCEPT today FROM DATE.
ACCEPT today FROM DATE YYYYMMDD.
ACCEPT thetime FROM TIME.

ACCEPT theday FROM DAY.
ACCEPT theday FROM DAY YYYYDDD.

ACCEPT weekday FROM DAY-OF-WEEK.

ACCEPT thekey FROM ESCAPE KEY.

ACCEPT username FROM USER NAME.

ACCEPT exception-stat FROM EXCEPTION STATUS.

ACCEPT some-data FROM device-name.

ACCEPT OMITTED.   *> Waits for a keystroke that includes terminator.

ACCEPT datafield
    ON EXCEPTION
        display "datafield got EOF, not changed"
END-ACCEPT

ACCEPT exception-pic9-4 FROM EXCEPTION-STATUS

COMPUTE delicate-value ROUNDED MODE IS PROHIBITED
          = interest-by-loop - interest-by-new-formula
    ON SIZE ERROR
        DISPLAY
            "Rats.  Call the boss, the new formula fell over"
            UPON SYSERR
END-COMPUTE

ACCEPT unexpected-rounding  FROM EXCEPTION-STATUS
IF unexpected-rounding NOT EQUAL "0000" THEN
    DISPLAY
        "Rats. Unexpected rounding. Code " unexpected-rounding
        UPON SYSERR
END-IF

SELECT filename
    ASSIGN TO "filename.dat"
    ACCESS MODE IS RANDOM
    RELATIVE KEY IS keyfield.

ADD 1 TO cobol

ADD 1 TO cobol GIVING GnuCOBOL

ADD
    a b c d f g h i j k l m n o p q r s t u v w x y z
    GIVING total-of
    ON SIZE ERROR
        PERFORM log-problem
    NOT ON SIZE ERROR
        PERFORM graph-result
END-ADD

ADD 1 TO GnuCOBOL

ADD 1 TO GnuCOBOL GIVING NewCOBOL

ADD 1 GnuCOBOL GIVING NewCOBOL

*> Modified: 2016-05-18/19:10-0400
 COPY sample-template REPLACING
 ==:DATABOOK:== BY
 ==

 01 data-group.
    05 top-group.
       10 field-a        pic 9(5) value 1.
       10 field-b        pic 9(5) value 2.
       10 inner-group.
          15 field-c     pic 9(5) value 3.
       10 field-d        pic 9(5) value 4.
    05 field-e           pic 9(5) value 5.
    05 field-f           pic x(3) value "006".
    05 field-g           pic x(3) value "abc".

 01 other-group.
    05 top-group.
       10 field-c        pic 9(5).
       10 field-b        usage binary-long.
       10 field-a        usage float-short.
    05 field-d           pic s9(5).
    05 field-z           pic s9(5).
    05 field-f           pic 9(3).
    05 field-g           pic 9(3).

 ==
 ==:CODEBOOK:== BY
 ==

 add corresponding data-group to other-group
 display "field-a: " field-a of other-group
 display "field-b: " field-b of other-group
 display "field-c: " field-c of other-group
 display "field-d: " field-d of other-group
 display "field-z: " field-z of other-group
 display "field-f: " field-f of other-group
 display "field-g: " field-g of other-group

 ==
 .

prompt$ cobc -xj add-sample.cob
field-a: 1
field-b: +0000000002
field-c: 00000
field-d: +00000
field-z: +00000
field-f: 006
field-g: 123

SET pointer-variable TO ADDRESS OF linkage-store

SET ADDRESS OF based-var TO pointer-from-c

SET prog-pointer TO ADDRESS OF PROGRAM "entry-point"

CALL "program" RETURNING ADDRESS OF linkage-or-based-var

DISPLAY "Legend: " WITH NO ADVANCING
WRITE printrecord AFTER ADVANCING PAGE
WRITE printrecord BEFORE ADVANCING 3 LINES

SELECT printseq
    ASSIGN TO LINE ADVANCING FILE "printer-file"

PERFORM
    WITH TEST AFTER
    VARYING variable FROM 1 BY 1
    UNTIL variable > 10
        AFTER inner FROM 1 BY 1
        UNTIL inner > 4
             DISPLAY variable ", " inner
END-PERFORM.

PERFORM
    VARYING variable FROM 1 BY 1
    UNTIL variable > 10
        AFTER inner FROM 1 BY 1
        UNTIL inner > 4
            DISPLAY variable ", " inner
END-PERFORM

INSPECT variable REPLACING "/" BY ":" AFTER INITIAL SPACE

WRITE title-record AFTER ADVANCING PAGE
WRITE record-name AFTER ADVANCING 2 LINES

procedure division.
declaratives.
handlers section.
use after standard error procedure on input.
    display "Error during read" upon syserr
    exit
.
end declaratives.

INSPECT variable REPLACING ALL "123" WITH "456".

MOVE ALL QUOTES TO var.

COMPUTE biggest = FUNCTION MAX(table-field(ALL))

01 pointer-var         usage POINTER.
01 character-field     pic x(80) BASED value "Sample".

ALLOCATE 1024 characters returning pointer-var
ALLOCATE character-field
ALLOCATE character-field INITIALIZED RETURNING pointer-var

* Set up for a mixed case SORT COLLATING SEQUENCE IS
 ENVIRONMENT DIVISION.
 CONFIGURATION SECTION.
 SPECIAL-NAMES.
     ALPHABET mixed IS "AaBbCcDdEeFfGgHhIiJjKkLlMm" &
                       "NnOoPpQqRrSsTtUuVvWwXxYyZz".

 DATA DIVISION.
 01 accounts.
    05 tables-data OCCURS 1 TO 1000 TIMES
           DEPENDING ON total-accounts
           ASCENDING KEY account-key
           INDEXED BY account-index.


 SORT table-data
     ON DESCENDING KEY account-key
     COLLATING SEQUENCE IS mixed.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
ALPHABET ALPHA IS ASCII.
ALPHABET BETA IS EBCDIC.

PROCEDURE DIVISION.
INSPECT variable CONVERTING ALPHA TO BETA

IF variable IS ALPHABETIC
    DISPLAY "alphabetic"
END-IF

IF variable IS ALPHABETIC-LOWER
    DISPLAY "alphabetic-lower"
END-IF

DISPLAY variable "alphabetic-upper " WITH NO ADVANCING
IF variable IS ALPHABETIC-UPPER
    DISPLAY "true A-Z, and nothing but A to Z"
ELSE
    DISPLAY "false A-Z, something else in here"
END-IF

INITIALIZE data-record REPLACING ALPHANUMERIC BY literal-value

INITIALIZE data-record
    REPLACING ALPHANUMERIC-EDITED BY identifier-1

EVALUATE variable ALSO second-var ALSO statuate-42
    WHEN "A"      ALSO 1 THRU 5   ALSO ANY         PERFORM first-case
    WHEN "A"      ALSO 6          ALSO 1 THRU 8    PERFORM second-case
    WHEN "A"      ALSO 6          ALSO 9           PERFORM special-case
    WHEN "A"      ALSO 7 THRU 9   ALSO ANY         PERFORM third-case
    WHEN OTHER                                     PERFORM invalid-case
END-EVALUATE

 identification division.
 program-id. altering.
 author. Brian Tiffin.
 date-written. 2015-10-28/06:36-0400.
 remarks. Demonstrate ALTER.

 procedure division.
 main section.

*> And now for some altering.
 contrived.
 ALTER story TO PROCEED TO beginning
 GO TO story
 .

*> Jump to a part of the story
 story.
 GO.
 .

*> the first part
 beginning.
 ALTER story TO PROCEED to middle
 DISPLAY "This is the start of a changing story"
 GO TO story
 .

*> the middle bit
 middle.
 ALTER story TO PROCEED to ending
 DISPLAY "The story progresses"
 GO TO story
 .

*> the climatic finish
 ending.
 DISPLAY "The story ends, happily ever after"
 .

*> fall through to the exit
 exit program.

prompt$ cobc -xj -debug altering.cob
This is the start of a changing story
The story progresses
The story ends, happily ever after

prompt$ COB_SET_TRACE=Y ./altering
Source:     'altering.cob'
Program-Id: altering         Entry:     altering               Line: 8
Program-Id: altering         Section:   main                   Line: 8
Program-Id: altering         Paragraph: contrived              Line: 11
Program-Id: altering         Statement: ALTER                  Line: 12
Program-Id: altering         Statement: GO TO                  Line: 13
Program-Id: altering         Paragraph: story                  Line: 17
Program-Id: altering         Paragraph: beginning              Line: 22
Program-Id: altering         Statement: ALTER                  Line: 23
Program-Id: altering         Statement: DISPLAY                Line: 24
This is the start of a changing story
Program-Id: altering         Statement: GO TO                  Line: 25
Program-Id: altering         Paragraph: story                  Line: 17
Program-Id: altering         Paragraph: middle                 Line: 29
Program-Id: altering         Statement: ALTER                  Line: 30
Program-Id: altering         Statement: DISPLAY                Line: 31
The story progresses
Program-Id: altering         Statement: GO TO                  Line: 32
Program-Id: altering         Paragraph: story                  Line: 17
Program-Id: altering         Paragraph: ending                 Line: 36
Program-Id: altering         Statement: DISPLAY                Line: 37
The story ends, happily ever after
Program-Id: altering         Statement: EXIT PROGRAM           Line: 41
Program-Id: altering         Exit:      altering
prompt$

By the time I started, an ALTERed GO TO was already anathema. Not only
where I worked, but people who'd come from other sites, and the computer
press.

In itself, it is not a bad thing, but it seems in most of its uses, it was
done badly. It was used to (attempt to) implement business-logic, in large
programs.

Large programs of the time already suffered from being largely
"fall-through" (lack of use of PERFORM). Ordinary GO TO and DEPENDING ON
were already used, often badly or tortuously (a GO TO solely to jump over
a few conditions, a DEPENDING ON relating to a transaction-type, flying
off to one of 70 paragraphs, almost all of which (but you could be sure,
not all) would GO TO the top of that processing again to read another
record.

You make that worse by using ALTER just because you can.

The common complaint with ALTER is  that it obscures the flow of the
program for analysis, and it obscures you when something takes a dive at
2am and you're looking at a core-dump and wondering what was the current
value of the ALTERered GOs.

The latter argument is a bit fake, because the generated pseudo-assembler
shows you where the current barch-to address is stored. It may be valid for
other compilers.

The classic actual presumed OK use of ALTER is for performance. A branch
is faster than any test-and-branch. The more tests you can avoid (since
they can no longer ever be true, different from the "jump over" GO TO) the
faster the program runs.

An implementation of "PERFORM" using ALTERed GO TOs would be faster than an
actual PEFORM (in IBM Mainframe COBOLs) because you don't have to cater for
fall-through/GO TO/PERFORM potentially affecting the same label.

(As an aside I implemented "PERFORM" with GOTO &name in IBM's VS/Script
GML, because it didn't have anything for "perform" and having it made it
about 90% simpler to write a particular system specification).

I don't know what the original intent of ALTER was.

ALTER can be used safely. But it can't be used safely because no-one
believes it can be used safely. Reality vs Myth, score one for Myth.

If COBOL didn't have PERFORM...

    ALTER PERFORM-IT TO PROCEED TO A
    ALTER RETURN-TO TO PROCEED TO NEXT-PARA
    GO TO PERFORM-IT
    .
NEXT-PARA.
    ALTER PERFORM-IT TO PROCEED TO B
    ALTER RETURN-TO TO PROCEED TO WERE-DONE
    GO TO PERFORM-IT
    .
WERE-DONE.
    DISPLAY the-counter
    GOBACK
    .
A.
    ADD 1 TO the-counter
    GO TO RETURN-TO
    .
B.
    ADD 2 TO the-counter
    GO TO RETURN-TO
    .
PERFORM-IT.
    GO TO
    .
RETURN-TO.
    GO TO
    .

    ALTER RETURN-TO TO PROCEED TO NEXT-PARA
    GO TO A
    .
NEXT-PARA.
    ALTER RETURN-TO TO PROCEED TO WERE-DONE
    GO TO B
    .
WERE-DONE.
    DISPLAY the-counter
    GOBACK
    .
A.
    ADD 1 TO the-counter
    GO TO RETURN-TO
    .
B.
    ADD 2 TO the-counter
    GO TO RETURN-TO
    .
RETURN-TO.
    GO TO
    .

On an IBM Mainframe and prior to the greatly-improved optimisation
with their COBOL II compilers, that would avoid a whole heap of code
generated "after" the end of the paragraph, which determines whether a
PERFORM was active, so a return is needed, otherwise glibbly dribbling
on.

Of course applied piecemeal to reuse different pieces of code from
different points in the business-logic (multiple exits from the
paragraphs, effectively, even though only one exit, they are multiple
because they are to multiple potential locations) then you start to see
the torture that can ensue. "If I put an ALTER there, and another one
there, then I don't need to change anything else". Making a piece of
code into a PERFORMed paragraph or SECTION when it is originally in a
fall-through program takes a little more to do.

Obviously, if you don't start out with a fall-though program in the
first place, it is different. Reusing a piece of code doesn't have to
become opaque.

The only-24-hours-in-a-day part of "performance" were much more serious
with much slower machines.

Remember also that the big fall-through program is on 12,000 punched
cards. "Restructuring" is more than trivial effort. You're being paid to
make the small change, not paid to take three days to do it and two
weeks to test it, even if the program is a bit nicer afterwards (no way
at all to rewrite the whole program).

I was lucky and never had to use punched cards, but I worked with a lot
of people who did, and they made me fully aware of the many problems.

Access via terminal to programs stored on disk probably had a greater
impact on structured programming than we can imagine today.

> Remember also that the big fall-through program is on 12,000 punched
> cards. "Restructuring" is more than trivial effort.

Missing option to restructure the program because of punchcard - this is
the best explanation for "why did someone ever wanted to use ALTER"
ever!

BTW: I'm one of the "this COBOL program needs a restructure"
programmers. Not "just because" but "because it's very likely that
someone [possibly I myself] needs to change the program again - if I
took 2 hours to understand the program logic this time I'll invest 2
other hours to make sure this won't happen again, restructure it, change
the comments to actually match the logic, ..".  And restructuring old
sources is sometimes the best option to deeply understand their logic,
enabling you to find the bug / place where to add the feature missing.
If you're in a hurry: keep the changed version for later when you have
the time to test it and just copy the necessary changes into the
original version for now.

I'm thankfull for having the sources on disk and multiline editors with
syntax highlighting, options to copy-and-paste, search [and replace],
... It's a wonderful time for programmers!

SELECT file
    ASSIGN TO filename
    ACCESS MODE IS RANDOM
    RECORD KEY IS key-field
    ALTERNATE KEY IS alt-key WITH DUPLICATES.

IF field = "A" AND num = 3
    DISPLAY "got A3"
END-IF

IF NOT (a NOT > b AND c AND NOT d)
   code
END-IF

IF NOT (((a NOT > b) AND (a NOT > c)) AND (NOT (a NOT > d)))
    code
END-IF

EVALUATE  TRUE  ALSO  TRUE
    WHEN a > 3  ALSO  ANY      *> b can be any value **
        PERFORM a-4-b-any
    WHEN a = 3  ALSO  b = 1
        PERFORM a-3-b-1
END-EVALUATE

01 cond-1   PIC X.
   88 first-truth   VALUES ARE "A" "B" "C".
   88 second-truth  VALUES ARE "X" "Y" "Z".

I-O-CONTROL.
    SAME RECORD AREA FOR file1, file2.

SAME RECORD AREAS

ACCEPT command-line-argument-count FROM ARGUMENT-NUMBER

DISPLAY 2 UPON ARGUMENT-NUMBER
ACCEPT indexed-command-line-argument FROM ARGUMENT-VALUE

       >>source format is free
*>*****************************************************************
*> Author:    jrls (John Ellis)
*> Date:      Nov-2008
*> Purpose:   command line processing
*>*****************************************************************
identification division.
program-id. cmdline.
data division.
*>
working-storage section.
*>******************************************
01 argv                 pic x(100) value spaces.
   88 recv                         value "-r", "--recv".
   88 email                        value "-e", "--email".
   88 delivered                    value "-d", "--delivered".
01 cmdstatus            pic x    value spaces.
   88 lastcmd                    value "l".
01 reptinfo.
   05 rept-recv         pic x(30) value spaces.
   05 rept-howsent      pic x(10) value spaces.
*>
procedure division.
 0000-start.
*>
    perform until lastcmd
         move low-values        to argv
         accept argv            from argument-value
         if argv > low-values
            perform 0100-process-arguments
         else
            move "l"            to cmdstatus
         end-if
    end-perform
    display reptinfo.
    stop run.
*>
 0100-process-arguments.
*>
     evaluate true
         when recv
            if rept-recv = spaces
               accept rept-recv from argument-value
            else
               display "duplicate " argv
            end-if
         when email
            move "email"        to rept-howsent
         when delivered
            move "delivered"    to rept-howsent
         when other display "invalid switch: " argv
     end-evaluate.

./cmdline --recv "john ellis" -e -f
invalid switch: -f
john ellis                    email

PROGRAM-ID. program-name AS literal.

01 const-id AS 123.
01 str-const AS "abc".

01 shared-data pic x(4) is external AS "newname".

01 CLUBTABLE.
   05 MEMBER-DATA OCCURS 1 TO 7000000000 TIMES
        DEPENDING ON PEOPLE
        ASCENDING KEY IS HOURS-DONATED.

sort clubtable ASCENDING key hours-donated

SPECIAL-NAMES.
ALPHABET ALPHA IS ASCII.
ALPHABET BETA IS EBCDIC.

PROCEDURE DIVISION.
INSPECT variable CONVERTING ALPHA TO BETA

SELECT input-file
ASSIGN TO "filename.ext"

SELECT input-file
ASSIGN USING DYNAMIC identifier

SELECT input-file
ASSIGN TO EXTERNAL identifier

# If yes, file names are resolved at run time using
#   environment variables.
# For example, given ASSIGN TO "DATAFILE", the actual
#   file name will be
#  1. the value of environment variable 'DD_DATAFILE' or
#  2. the value of environment variable 'dd_DATAFILE' or
#  3. the value of environment variable 'DATAFILE' or
#  4. the literal "DATAFILE"
# If no, the value of the assign clause is the file name.
#
# Value: 'yes', 'no'
filename-mapping: yes

$ export DD_DATAFILE='/tmp/opencobol.dat'
$ ./myprog

$ export DD_DATAFILE='/tmp/other.dat'
$ ./myprog

ASSIGN TO name

*> Display at line 1, column 4 <*
 DISPLAY "Name:" AT 0104
*> Accept starting at line 1, column 10 for length of field <*
 ACCEPT name-var AT 0110

SET screen-name ATTRIBUTE BLINK OFF

GCobol IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog.
       ENVIRONMENT      DIVISION.
       CONFIGURATION    SECTION.
       DATA             DIVISION.
       WORKING-STORAGE  SECTION.
       01  X               PIC 9 VALUE 0.
       01  AWAY-FROM-ZERO  PIC 9 VALUE 0.
       PROCEDURE        DIVISION.
           COMPUTE X ROUNDED MODE AWAY-FROM-ZERO
                   AWAY-FROM-ZERO = 1.1
           DISPLAY X ", " AWAY-FROM-ZERO NO ADVANCING
           STOP RUN.

2, 1

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20110626
      *> Purpose:   Demonstrate alternative for B-OR
      *> Tectonics: cobc -x bits.cob
      *> ***************************************************************
       identification division.
       program-id. bits.

       data division.
       working-storage section.
       01 s1 pic 999 usage comp-5.
       01 t2 pic 999 usage comp-5.
       01 len   pic 9.
       01 result usage binary-long.

      *> ***************************************************************
       procedure division.
       move 2 to s1
       move 4 to t2
       move 1 to len

      *> CBL_OR takes source, target and length value  2 OR 4 is 6.   **
       call "CBL_OR" using s1 t2 by value len returning result end-call
       display s1 space t2 space len space result

       goback.
       end program bits.

$ cobc -x bits.cob
$ ./bits
002 006 1 +0000000000

05 BLANK SCREEN BACKGROUND-COLOR 7 FOREGROUND-COLOR 0.

01 based-var PIC X(80) BASED.

GCobol*-----------------------------------------------------------------
       IDENTIFICATION DIVISION.
       PROGRAM-ID. 'MEMALL'.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SPECIAL-NAMES. DECIMAL-POINT IS COMMA.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
       DATA DIVISION.
       FILE SECTION.
      *
       WORKING-STORAGE SECTION.
      *
       77  mychar      pic x.
       01  REC-TEST BASED.
           03 REC-TEST-PART1 PIC X(5500000).
           03 REC-TEST-PART2 PIC X(0100000).
           03 REC-TEST-PART3 PIC X(1200000).
           03 REC-TEST-PART4 PIC X(1200000).
           03 REC-TEST-PART5 PIC X(1700000).
      *-----------------------------------------------------------------
       LINKAGE SECTION.
      *-----------------------------------------------------------------
       PROCEDURE DIVISION.
       declaratives.
       end declaratives.
      *-----------------------------------------------------------------
       main section.
       00.
           FREE ADDRESS OF REC-TEST
           display 'MEMALL loaded and REC-TEST FREEd before ALLOCATE'
           accept   mychar
      *
           IF ADDRESS OF REC-TEST = NULL
              display 'REC-TEST was not allocated before'
           ELSE
              display 'REC-TEST was allocated before'
           END-IF
           accept  mychar
      *
           ALLOCATE  REC-TEST
           move all '9' to REC-TEST
           display 'REC-TEST allocated and filled with '
                REC-TEST (1:9)
           accept  mychar
      *
           IF ADDRESS OF REC-TEST = NULL
              display 'REC-TEST was not allocated before'
              ALLOCATE  REC-TEST
              display 'REC-TEST allocated again, filled with '
                   REC-TEST (1:9)
           ELSE
              display 'REC-TEST was allocated before'
           END-IF
           accept  mychar
      *
      *
           FREE ADDRESS OF REC-TEST
           display 'REC-TEST FREEd'
           accept  mychar
      *
           stop run
      *
           continue.
       ex. exit program.
      *-----------------------------------------------------------------
      *--- End of program MEMALL ---------------------------------------

DISPLAY "Beeeeep" LINE 3 COLUMN 1 WITH BEEP END-DISPLAY.

MOVE 1 TO counter
PERFORM WITH TEST BEFORE
    UNTIL counter IS GREATER THAN OR EQUAL TO limiter
        CALL "subprogram" USING counter RETURNING result END-CALL
        MOVE result TO answers(counter)
        ADD 1 TO counter END-ADD
END-PERFORM

WRITE record-name
    BEFORE ADVANCING some-number LINES

INSPECT character-var TALLYING
   the-count FOR ALL "tests" BEFORE "prefix"

USE BEFORE REPORTING
 ...

DISPLAY "Beeeeep" LINE 3 COLUMN 1 WITH BELL END-DISPLAY.

01 result PIC S9(8) USAGE BINARY VALUE -1234.

BINARY-LONG SIGNED    -2147483648 [-2**31] < n < 2147483648 [2**31]
BINARY-LONG UNSIGNED                    0 <= n < 4294967296 [2**32]

GCobol >>SOURCE FORMAT IS FREE
       identification division.
       program-id. comp32.

       environment division.
       configuration section.
       repository. function all intrinsic.

       data division.
       working-storage section.
       01 comp32               PIC S9(9) USAGE COMP-5.
       01 comp34               PIC S9(10) USAGE COMP-5.

       procedure division.
       display "comp32 s9(9)  usage comp-5 length: "
           function length(comp32) " and "
           function byte-length(comp32) " byte-length"

       display "comp34 s9(10) usage comp-5 length: "
           function length(comp34) " and "
           function byte-length(comp34) " byte-length"
       display space

       perform varying tally from 1 by 1 until tally > 3
           evaluate tally
               when 1 display "2 ** 29 ok"
               when 2 display "2 ** 30 DISPLAY IS TRUNCATED FOR comp32"
               when 3 display "2 ** 31 size error detected for comp32"
           end-evaluate

           compute comp32 = 2 ** (28 + tally)
               on size error perform soft-exception
               not on size error
                   display "comp32 = 2 ** (28 + " tally ") =  " comp32
           end-compute

           compute comp34 = 2 ** (28 + tally)
               on size error perform soft-exception
               not on size error
                   display "comp34 = 2 ** (28 + " tally ") = " comp34
           end-compute
           display space
       end-perform
       goback.
      *> ***************************************************************

      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
         display space upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .

       end program comp32.

prompt$ cobc -xj -debug comp32.cob
comp32 s9(9)  usage comp-5 length: 000000004 and 000000004 byte-length
comp34 s9(10) usage comp-5 length: 000000008 and 000000008 byte-length

2 ** 29 ok
comp32 = 2 ** (28 + 00001) =  +536870912
comp34 = 2 ** (28 + 00001) = +0536870912

2 ** 30 DISPLAY IS TRUNCATED FOR comp32
comp32 = 2 ** (28 + 00002) =  +073741824
comp34 = 2 ** (28 + 00002) = +1073741824

2 ** 31 size error detected for comp32

--Exception Report--
Time of exception:   2016013107083456-0500
Module:              comp32
Module-path:         /home/btiffin/lang/cobol/forum/comp32
Module-source:       comp32.cob
Exception-file:      00
Exception-status:    EC-SIZE-OVERFLOW
Exception-location:  comp32; ; 31
Exception-statement: COMPUTE

comp34 = 2 ** (28 + 00003) = +2147483648

05 BLANK SCREEN BACKGROUND-COLOR 7 FOREGROUND-COLOR 0.

FD file-name
  BLOCK CONTAINS 1 TO n RECORDS

FD  mini-report
      linage is 16 lines
          with footing at 15
          lines at top 2
          lines at bottom 2.

PERFORM the-procedure
    VARYING step-counter FROM 1 BY step-size
    UNTIL step-counter > counter-limit

CALL "function"
    ON EXCEPTION
        DISPLAY "error: exception calling function"
    NOT ON EXCEPTION
        DISPLAY "Working as intended"
END-CALL

CALL "function"
    ON EXCEPTION
        DISPLAY "error calling function" END-DISPLAY
    NOT ON EXCEPTION
        DISPLAY "Working as intended" END-DISPLAY
END-CALL

CALL "function"
    ON EXCEPTION
        DISPLAY "error: exception calling function"
            NOT ON EXCEPTION
                DISPLAY "Working as intended"
END-CALL

GCobol*>>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20110701
      *> Purpose:   Try C library formatted printing, and CALL exception
      *> Tectonics: cobc -x callon.cob
      *>        or  cobc -x callon.cob CBL_OC_DUMP.cob
      *> ***************************************************************
       identification division.
       program-id. callon.

       data division.
       working-storage section.
       01 result      usage binary-long.

       01 pie         usage float-short.
       01 stuff       pic x(12) value 'abcdefghijkl'.

      *> ***************************************************************
       procedure division.
       move 3.141592654 to pie

      *> Get a dump of the memory at pie, but don't stop if not linked
       call "CBL_OC_DUMP" using pie 4 on exception continue end-call
       display "Continues even if external function not available"

      *> Call C's printf, abort if not available
       call static "printf" using
           "float-short: %10.8f" & x"0a00"
           by value pie
           returning result
       end-call
       display pie space length of pie space result
       display "static functions rarely, if ever, trigger on exception"

      *> Get a dump of the memory used by stuff, don't stop if no link
       call "CBL_OC_DUMP" using stuff 12 on exception continue end-call
       display "Continues even if external function not available"

      *> Get a dump of the memory used by stuff, abort if not linked <*
       call "CBL_OC_DUMP" using stuff 12 end-call
       display "Will abend without DUMP, this might not be displayed"

       goback.
       end program callon.

$ cobc -x callon.cob
$ ./callon
Continues even if external function not available
float-short: 3.14159274
static functions rarely, if ever, trigger on exception
3.1415927 4 +0000000024
Continues even if external function not available
libcob: Cannot find module 'CBL_OC_DUMP'
$ cobc -x callon.cob CBL_OC_DUMP.cob
$ ./callon

Offset  HEX-- -- -- -5 -- -- -- -- 10 -- -- -- -- 15 --   CHARS----1----5-
000000  db 0f 49 40                                       ..I@............
Continues even if external function not available

float-short: 3.14159274
3.1415927 4 +0000000024
static functions rarely, if ever, trigger on exception

Offset  HEX-- -- -- -5 -- -- -- -- 10 -- -- -- -- 15 --   CHARS----1----5-
000000  61 62 63 64 65 66 67 68 69 6a 6b 6c               abcdefghijkl....
Continues even if external function not available

Offset  HEX-- -- -- -5 -- -- -- -- 10 -- -- -- -- 15 --   CHARS----1----5-
000000  61 62 63 64 65 66 67 68 69 6a 6b 6c               abcdefghijkl....
Will abend without DUMP, this might not be displayed

CALL STATIC "puts" USING a-zstring END-CALL

GCOBOL identification division.
       program-id. chained.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 str                  pic x(80).

       procedure division chaining str.
       display "In chained with :" trim(str) ":"

       accept str from command-line
       display "COMMAND-LINE    :" trim(str) ":"

       goback.
       end program chained.

prompt$ cobc -x -j='"this is a test"' chained.cob
In chained with :this is a test:
COMMAND-LINE    :this is a test:

GCOBOL identification division.
       program-id. caller.

       data division.
       working-storage section.

       procedure division.

       display "new COMMAND-LINE argument value" upon command-line
       call "chained" using "** this is NOT passed by chaining **"

       goback.
       end program caller.

prompt$ cobc -x caller.cob chained.cob
prompt$ ./caller "this is the original argv"
In chained with :this is the original argv:
COMMAND-LINE    :new COMMAND-LINE argument value:

PADDING CHARACTER IS

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20101031
      *> Purpose:   Try out SYMBOLIC CHARACTERS
      *> Tectonics: cobc -x figurative.cob
      *> Rave:      GnuCOBOL is stone cold cool
      *> ***************************************************************
       identification division.
       program-id. figurative.

       environment division.
       configuration section.
       special-names.
           symbolic characters TAB is 10
                               LF  is 11
                               CMA is 45.

       data division.
       working-storage section.
       01 a-comma pic x(1) value ",".
       01 lots-of-commas pic x(20).

      *> ***************************************************************
       procedure division.
       display
           "thing" TAB "tabbed thing" LF
           "and" TAB "another tabbed thing" LF
           "other" CMA " things"

       move a-comma to lots-of-commas
       display "MOVE a-comma : " lots-of-commas

       move CMA to lots-of-commas
       display "MOVE symbolic: " lots-of-commas

       goback.
       end program figurative.

$ cobc -x figuratives.cob
$ ./figuratives
thing   tabbed thing
and     another tabbed thing
other, things
MOVE a-comma : ,
MOVE symbolic: ,,,,,,,,,,,,,,,,,,,,

INSPECT str TALLYING TALLY FOR CHARACTERS BEFORE INITIAL ','

INSPECT str REPLACING CHARACTERS BY '*' AFTER INITIAL ':'

FD file-name
   BLOCK CONTAINS integer-1 TO integer-2 CHARACTERS
   RECORD IS VARYING IN SIZE FROM integer-5 TO integer-6 CHARACTERS
      DEPENDING ON identifier-1.

ALLOCATE 100 * cell-size CHARACTERS RETURNING heap-pointer

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
CLASS octals IS '0' THRU '7'.

CLASS host-class IS 'A' THROUGH 'Z'
                    'a' THROUGH 'z'
                    '0' THROUGH '9'
                    '-', '.'.

...

PROCEDURE DIVISION.
IF user-value IS NOT octals
    DISPLAY "Sorry, not a valid octal number"
ELSE
    DISPLAY user-value
END-IF

IF network-host IS NOT host-class
    DISPLAY "Invalid (pre international domain name standard) host"
END-IF

CLOSE input-file

CRT STATUS IS user-field

OBJECT-COMPUTER. name.
  PROGRAM COLLATING SEQUENCE IS alphabet-1.

DISPLAY var-1 LINE 1 COLUMN 23

DISPLAY "Text" AT 0203
DISPLAY "Text" AT 002101 WITH REVERSE-VIDEO

DECIMAL POINT IS COMMA

ACCEPT the-args FROM COMMAND-LINE END-ACCEPT

PROGRAM-ID. CBL_OC_PROGRAM IS COMMON PROGRAM.

>>IF ENDIAN = "BIG"
big end code
>>END-IF

>>IF ENDIAN = "LITTLE"
little end code
>>END-IF

*> Modified: 2016-04-30/01:52-0400
 COPY sample-template REPLACING
 ==:DATABOOK:== BY
 ==

 01 from-x     pic x(4) comp-x value "WXYZ".

 ==
 ==:CODEBOOK:== BY
 ==

 display from-x
 add 1 to from-x
 display from-x

 ==
 .

$ cobc -xj compx-sample.cob
sample-template.cob: 12: Warning: Numeric value is expected
465407834
465407835

OCDUMP 77  byline                pic 999    usage comp-5.

       TEST-ENDIAN SECTION.
       00.
      *    Number-bytes are shuffled in Big-Little endian
           move 128 to byline
           set address of byte to address of byline
           if function ord(byte) > 0
              set  is-big-endian-yes to true
           else
              set  is-big-endian-no  to true
           end-if
      *
           continue.
       ex. exit.

COMPUTE circular-area = radius ** 2 * FUNCTION PI END-COMPUTE

GCobol*> ***************************************************************
       identification division.
       program-id. computing.

       data division.
       working-storage section.
       01 answer pic s9(8).
       01 var    pic s9(8).

      *> ***************************************************************
       procedure division.
       compute answer = 3*var-1 end-compute

       goback.
       end program computing.

$ cobc -x computing.cob
computing.cob:18: Error: 'var-1' is not defined

GCobol*> ***************************************************************
       identification division.
       program-id. computing.

       data division.
       working-storage section.
       01 answer pic s9(8).
       01 var    pic s9(8).
       01 var-1  pic s9(8).

      *> ***************************************************************
       procedure division.
       compute answer = 3*var-1 end-compute

       goback.
       end program computing.

$ cobc -x computing.cob

GCobol*> ***************************************************************
       identification division.
       program-id. computing.

       data division.
       working-storage section.
       01 answer pic s9(8).
       01 var    pic s9(8).
       01 var-1  pic s9(8).

      *> ***************************************************************
       procedure division.
       compute
           answer = 3 * var - 1
           on size error
               display "Problem, call the ghost busters"
           not on size error
               display "All good, answer is within range"
       end-compute

       goback.
       end program computing.

COMPUTE
    total ROUNDED MODE NEAREST-AWAY-FROM-ZERO =
      total - amount * rate / time-span
END-COMPUTE

01 enumerated-value CONSTANT AS 500.
01 some-string      CONSTANT AS "immutable value".

FD a-file RECORD CONTAINS 80 CHARACTERS.

CALL "subprog" USING BY CONTENT alpha-var.

if action-flag = "C" or "R" or "U" or "D"
    continue
else
    display "invalid action-code"
end-if

call "CBL_OC_DUMP" using cstruct ON EXCEPTION CONTINUE end-call

INSPECT X CONVERTING "012345678" TO "999999999".

*> Repository default data names
 01 gtk-window-record.
    05 gtk-window       usage pointer.
    05 gwr-pointer      usage pointer.
    05 gwr-number       usage binary-long.
*> ...

*> Include some data
 data division.
 working-storage section.

 01 important-field pic x.

 COPY cobweb-gtk-data-preamble.

 01 more-working-store pic xx.

 procedure division.

 COPY cobweb-gtk-preamble.

 move new-button(new-box(new-window("Put up a GUI"),
     "An OK button", "cobweb-gtk-clicked"))
   to extraneous

 goback.
 end program sample.

01 :tag:-record.
   05 :tag:-keyfield           PIC X(8).
   05 :tag:-description        PIC X(32).
   05 :tag:-itemlist           PIC X(8) OCCURS subitems TIMES.

identification division.
program-id. contrived.

data division.
working-storage section.

COPY copybook REPLACING ==:tag:== BY ==ws==   subitems BY 16.
COPY copybook REPLACING ==:tag:== BY ==old==  subitems BY 0.

procedure division.
move "abcdefgh" to ws-keyfield old-keyfield

PERFORM read-next-partnumber

if ws-keyfield equal old-keyfield
    display "lookup didn't change key " ws-keyfield
else
    display "new key " ws-keyfield " was " old-keyfield
end-if

goback.

read-next-partnumber.
move "hgfedcba" to ws-keyfield
.

end program contrived.

01 bin-record.
   05 first-will usage binary-short.
   05 second-will usage binary-long.
   05 this-wont-move usage binary-long.
   05 third-will usage binary-short.
01 num-record.
   05 first-will pic 999.
   05 second-will pic s9(9).
   05 third-will pic 999.
   05 this-doesnt-match pic s9(9).

move corresponding bin-record to num-record
display
    first-will in num-record
    second-will in num-record
    third-will in num-record

UNSTRING Input-Address
    DELIMITED BY "," OR "/"
    INTO
        Street-Address DELIMITER D1 COUNT C1
        Apt-Number DELIMITER D2 COUNT C2
        City DELIMITER D3 COUNT C3
        State DELIMITER D4 COUNT C4
        Zip-Code DELIMITER D5 COUNT C5
END-UNSTRING

SPECIAL-NAMES.
    CONSOLE IS CRT
    CRT STATUS is identifier-1.

SPECIAL-NAMES.
    CURRENCY SIGN IS literal-1.

SPECIAL-NAMES.
    CURSOR IS identifier-2.

 identification division.
 program-id. dates.

 data division.
 working-storage section.
 01 date-2nd
    03 date-yy   pic 9(2).
    03 date-mm   pic 9(2).
    03 date-dd   pic 9(2).
 01 date-3rd
    03 date-yyyy pic 9(4).
    03 date-mm   pic 9(2).
    03 date-dd   pic 9(2).

 procedure division.
 accept date-2nd from date end-accept

*> Just before the 3rd millennium, programmers admitted     <*
*>   that 2 digit year storage was a bad idea and ambiguous <*
 accept date-3rd from date yyyymmdd end-accept

 display date-2nd space date-3rd

 goback.
 end program dates.

./dates
110701 20110701

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      2011182 (July 01)
      *> Purpose:   Accept from day in Julian form
      *> Tectonics: cobc -x days.cob
      *> ***************************************************************
       identification division.
       program-id. days.

       data division.
       working-storage section.
       01 julian-2nd.
          03 julian-yy   pic 9(2).
          03 julian-days pic 9(3).
       01 julian-3rd.
          03 julian-yyyy pic 9(4).
          03 julian-days pic 9(3).

       procedure division.
       accept julian-2nd from day end-accept

      *> Just before the 3rd millennium, programmers admitted     <*
      *> that 2 digit year storage was a bad idea and ambiguous   <*
       accept julian-3rd from day yyyyddd end-accept

       display julian-2nd space julian-3rd

       goback.
       end program days.

$ make days
cobc -W -x days.cob -o days
$ ./days
11182 2011182

accept the-day from day-of-week

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER mine
  WITH DEBUGGING MODE.

PROCEDURE DIVISION.
DECLARATIVES.
decl-debug section.
  USE FOR DEBUGGING ON ALL PROCEDURES
decl-paragraph.
  DISPLAY "Why is this happening to me?"
END DECLARATIVES.

IDENTIFICATION DIVISION.
PROGRAM-ID. 'virgule'.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
DECIMAL-POINT IS COMMA.

procedure division.
declaratives.
handle-errors section.
    use after standard error procedure on filename-1.
handle-error.
    display "Something bad happened with " filename-1
.
helpful-debug section.
    use for debugging on main-file.
help-me.
    display "Just touched " main-file
.
end declaratives.

DELETE filename-1 RECORD
  INVALID KEY
    DISPLAY "no delete"
  NOT INVALID KEY
    DISPLAY "record removed"
END-DELETE

DELETE FILE
    filename-1 filename-2 filename-3
END-DELETE

identification division.
program-id. delfile.

environment division.
input-output section.
file-control.
select testing-file assign to "testing.tt"
    status is file-status.

data division.
working-storage section.
01 file-status pic xx.

procedure division.
open input testing-file
display "open status  : " file-status

delete file testing-file
display "delete status: " file-status

close testing-file
display "close status : " file-status

>>IF DELETE DEFINED
    delete file testing-file
    display "delete status: " file-status
>>END-IF

goback.
end program delfile.

prompt$ echo -n >testing.tt
prompt$ cobc -xj delfile.cob
open status  : 00
delete status: 41
close status : 00

prompt$ ls testing.tt
testing.tt

prompt$ cobc -DDELETE -xj delfile.cob
open status  : 00
delete status: 41
close status : 00
delete status: 00

prompt$ ls testing.tt
ls: cannot access 'testing.tt': No such file or directory

prompt$ cobc -xj delfile.cob
open status  : 35
delete status: 00
close status : 42

prompt$ ls testing.tt
ls: cannot access 'testing.tt': No such file or directory

STRING null-terminated
    DELIMITED BY LOW-VALUE
    INTO no-zero
END-STRING

UNSTRING Expand-Code-Rec
    DELIMITED BY ". " OR " "
    INTO SPI-Current-Token
    DELIMITER IN Delim
    WITH POINTER Src-Ptr
END-UNSTRING

01 TABLE-DATA.
   05 TABLE-ELEMENTS
       OCCURS 1 TO 100 TIMES DEPENDING ON crowd-size
       INDEXED BY cursor-var.
     10 field-1 PIC X.

GO TO para-1 para-2 para-3 DEPENDING ON jump-number

ASSIGN TO DISK USING dataname

DISPLAY "First value: " a-variable " and another string"

DISPLAY "1" 23 "4"

DISPLAY "ENVNAME" UPON ENVIRONMENT-NAME
DISPLAY "COBOL value" UPON ENVIRONMENT-VALUE
     ON EXCEPTION stop run
     NOT ON EXCEPTION continue
END-DISPLAY
CALL "SYSTEM" USING "echo $ENVNAME"

$ ENVNAME="parent shell value"
$ ./disps
COBOL value
$ echo $ENVNAME
parent shell value

DIVIDE dividend BY divisor GIVING answer ROUNDED REMAINDER r
    ON SIZE ERROR
        PERFORM log-division-error
        SET division-error TO TRUE
    NOT ON SIZE ERROR
        SET division-error TO FALSE
END-DIVIDE

SET ind-1 DOWN BY 2

SET ptr-1 DOWN BY 8

SCROLL DOWN 5 LINES

SELECT filename
  ALTERNATE RECORD KEY IS altkey WITH DUPLICATES

SORT filename ON DESCENDING KEY keyfield
  WITH DUPLICATES IN ORDER
  USING sort-in GIVING sort-out.

SELECT filename
  ORGANIZATION IS RELATIVE
  ACCESS MODE IS DYNAMIC

SPECIAL-NAMES.
ALPHABET ALPHA IS NATIVE.
ALPHABET BETA IS EBCDIC.

PROCEDURE DIVISION.
INSPECT variable CONVERTING ALPHA TO BETA

IF AGE IS ZERO
   DISPLAY "Cigar time"
ELSE
   DISPLAY "What is it with kids anyway?"
END-IF

01 form-record.
   02 first-field PIC xxx
      USING identifier-1
      ERASE EOL.

USE AFTER STANDARD ERROR PROCEDURE ON filename-1

STOP RUN WITH ERROR STATUS stat-var.

ACCEPT identifier FROM ESCAPE KEY END-ACCEPT

*> evaluate variables and an expression
EVALUATE a ALSO b ALSO TRUE
    WHEN 1 ALSO 1 THRU 9 ALSO c EQUAL 1 PERFORM all-life
    WHEN 2 ALSO 1 THRU 9 ALSO c EQUAL 2 PERFORM life
    WHEN 3 THRU 9 ALSO 1 ALSO c EQUAL 9 PERFORM disability
    WHEN OTHER PERFORM invalid
END-EVALUATE

*> evaluate on arbitrary expressions
EVALUATE TRUE
    WHEN d = 1
        PERFORM d-is-one
    WHEN d > 1
        PERFORM d-greater-one
    WHEN OTHER
        PERFORM d-zero-or-negative
END-EVALUATE

EVALUATE the-day
    WHEN "MONDAY"
        PERFORM week-start-report
    WHEN "FRIDAY"
        PERFORM weeks-end-report
        PERFORM prepare-for-weekend
    WHEN OTHER
        PERFORM daily-report
END-EVALUATE

*> evaluate on false
EVALUATE FALSE
    WHEN d = 1
        PERFORM d-not-one
    WHEN OTHER
        PERFORM d-is-one
END-EVALUATE

CALL "CBL_OC_DUMP" ON EXCEPTION CONTINUE END-CALL

PROCEDURE DIVISION EXTERN USING BY VALUE A

77 shared-var PIC S9(4) IS EXTERNAL AS 'shared_var'.

      *> ********************************************************
      *> Callback event handlers
      *> ********************************************************

       REPLACE ==FIELDSIZE== BY ==80==.

id     identification division.
       program-id. cobweb-button-clicked.

       environment division.
       configuration section.
       repository.
           function entry-get-text
           function all intrinsic.

       data division.
       working-storage section.
       01 gtk-entry-data                               external.
          05 gtk-entry         usage pointer.
       01 the-text-entry       pic x(FIELDSIZE).

       linkage section.
       01 gtk-widget           usage pointer.
       01 gtk-window           usage pointer.

       procedure division using by value gtk-widget gtk-window.

       move entry-get-text(gtk-entry) to the-text-entry
       display trim(the-text-entry) " (via button)"

done   goback.
       end program cobweb-button-clicked.

01 gtk-box-data.
   05 gtk-box           usage pointer.
01 gtk-label-data.
   05 gtk-label         usage pointer.
01 gtk-entry-data                        external.
   05 gtk-entry         usage pointer.
01 gtk-button-data.
   05 gtk-button        usage pointer.

01 record-1      pic 9.
   88 conditional-1 values 1,2,3 when set to false is 0.

set conditional-1 to true
display record-1

set conditional-1 to false
display record-1

if conditional-1
    display "BAD"
end-if

$ ./conditionals
1
0

evaluate false
    when 1 equal 1
        display "Not displayed, as 1 equal 1 is true"
    when 1 equal 2
        display "This displays because 1 equal 2 is false"
    when other
        display "the truest case, nothing is false"
end-evaluate

FD filename-sample
   RECORD IS VARYING IN SIZE FROM 1 TO 32768 CHARACTERS
     DEPENDING ON record-size-sample.

data division.
FILE section.
fd cobol-file-selector.
01 cobol-io-buffer        pic x(132).

environment division.
input-output section.
file-control.
   select optional data-file assign to file-name
       organization is line sequential
       FILE STATUS is data-file-status.
   select mini-report assign to "mini-report".

procedure division.
declaratives.

error-handling section.
    USE AFTER EXCEPTION FILE filename-maybe.
error-handler.
    display "Exception on filename"
.
end declaratives.

DELETE FILE file-selector-1 file-selector-2

01  status-code                pic x(2) value spaces.
    88  SUCCESS                    value '00'.
    88  SUCCESS_DUPLICATE          value '02'.
    88  SUCCESS_INCOMPLETE         value '04'.
    88  SUCCESS_OPTIONAL           value '05'.
    88  SUCCESS_NO_UNIT            value '07'.
    88  END_OF_FILE                value '10'.
    88  OUT_OF_KEY_RANGE           value '14'.
    88  KEY_INVALID                value '21'.
    88  KEY_EXISTS                 value '22'.
    88  KEY_NOT_EXISTS             value '23'.
    88  PERMANENT_ERROR            value '30'.
    88  INCONSISTENT_FILENAME      value '31'.
    88  BOUNDARY_VIOLATION         value '34'.
    88  NOT_EXISTS                 value '35'.
    88  PERMISSION_DENIED          value '37'.
    88  CLOSED_WITH_LOCK           value '38'.
    88  CONFLICT_ATTRIBUTE         value '39'.
    88  ALREADY_OPEN               value '41'.
    88  NOT_OPEN                   value '42'.
    88  READ_NOT_DONE              value '43'.
    88  RECORD_OVERFLOW            value '44'.
    88  READ_ERROR                 value '46'.
    88  INPUT_DENIED               value '47'.
    88  OUTPUT_DENIED              value '48'.
    88  I_O_DENIED                 value '49'.
    88  RECORD_LOCKED              value '51'.
    88  END_OF_PAGE                value '52'.
    88  I_O_LINAGE                 value '57'.
    88  FILE_SHARING               value '61'.
    88  NOT_AVAILABLE              value '91'.

GCOBOL >> SOURCE FORMAT IS FREE
identification division.
program-id. checkfilestatus.

data division.
working-storage section.
01  status-message pic x(72).
01  display-message pic x(72) value spaces.

linkage section.
01  file-name pic x(64).
01  file-status pic x(2).

procedure division using file-name file-status.
start-checkfilestatus.
    if file-status = '00' or '10'
        goback
    end-if
    evaluate file-status
    when 00 move 'SUCCESS.' TO status-message
    when 02 move 'SUCCESS DUPLICATE.' TO status-message
    when 04 move 'SUCCESS INCOMPLETE.' TO status-message
    when 05 move 'SUCCESS OPTIONAL.' TO status-message
    when 07 move 'SUCCESS NO UNIT.' TO status-message
    when 10 move 'END OF FILE.' TO status-message
    when 14 move 'OUT OF KEY RANGE.' TO status-message
    when 21 move 'KEY INVALID.' TO status-message
    when 22 move 'KEY EXISTS.' TO status-message
    when 23 move 'KEY NOT EXISTS.' TO status-message
    when 30 move 'PERMANENT ERROR.' TO status-message
    when 31 move 'INCONSISTENT FILENAME.' TO status-message
    when 34 move 'BOUNDARY VIOLATION.' TO status-message
    when 35 move 'FILE NOT FOUND.' TO status-message
    when 37 move 'PERMISSION DENIED.' TO status-message
    when 38 move 'CLOSED WITH LOCK.' TO status-message
    when 39 move 'CONFLICT ATTRIBUTE.' TO status-message
    when 41 move 'ALREADY OPEN.' TO status-message
    when 42 move 'NOT OPEN.' TO status-message
    when 43 move 'READ NOT DONE.' TO status-message
    when 44 move 'RECORD OVERFLOW.' TO status-message
    when 46 move 'READ ERROR.' TO status-message
    when 47 move 'INPUT DENIED.' TO status-message
    when 48 move 'OUTPUT DENIED.' TO status-message
    when 49 move 'I/O DENIED.' TO status-message
    when 51 move 'RECORD LOCKED.' TO status-message
    when 52 move 'END-OF-PAGE.' TO status-message
    when 57 move 'I/O LINAGE.' TO status-message
    when 61 move 'FILE SHARING FAILURE.' TO status-message
    when 91 move 'FILE NOT AVAILABLE.' TO status-message
    end-evaluate
    string 'ERROR ' delimited by size
        file-name delimited by space
        space delimited by size
        status-message delimited by '.'
        into display-message
    end-string
    display display-message end-display
    stop run
    .
end program checkfilestatus.

environment division.
input-output section.
FILE-CONTROL.
  select optional data-file assign to file-name
      organization is line sequential
      file status is data-file-status.

  select mini-report assign to "mini-report".

VALUE OF FILE-ID IS file-ids in summary-array

environment division.
input-output section.
file-control.
    select cobol-file-selector
    assign to disk
    organization            indexed
    access mode             dynamic
    record key              fd-key-field
    file status             file-status-field.

data division.
file section.
fd cobol-file-selector label record standard
    VALUE OF FILE-ID is "actual-filename.dat".

01 the-record.
   05 first-field  pic x(10).
   05 filler       pic x(35) value "this space intentionally left blank".
   04 third-field  pic x(10).

01 the-record.
    05 first-field  pic x(10).
    05              pic x(35) value "this space intentionally left blank".
    05 third-field  pic x(10).

01 the-record.
    05 first-field  pic x(10).
    05                        value "this space intentionally left blank".
    05 third-field  pic x(10).

CONTROLS ARE FINAL, datafield-1, datafield-2

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-19/20:56-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 ieee-754-16          usage float-decimal-16.

       ==
       ==:CODEBOOK:== BY
       ==

       compute ieee-754-16 = 2 ** 32
       perform 32 times
           display ieee-754-16
           divide ieee-754-16 by 4 giving ieee-754-16
       end-perform

       ==
       .

prompt$ ./float-decimal-16-sample.cob
4294967296E0
1073741824E0
268435456E0
67108864E0
16777216E0
4194304E0
1048576E0
262144E0
65536E0
16384E0
4096E0
1024E0
256E0
64E0
16E0
4E0
1E0
25E-2
625E-4
15625E-6
390625E-8
9765625E-10
244140625E-12
6103515625E-14
152587890625E-16
38146972656E-16
9536743164E-16
2384185791E-16
596046447E-16
149011611E-16
37252902E-16
9313225E-16

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-19/21:42-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 ieee-754-34          usage float-decimal-34.
       01 as-dotnines          pic v9(34).
       01 as-nines             pic z(20).

       ==
       ==:CODEBOOK:== BY
       ==

       compute ieee-754-34 = 2 ** 64
       perform 64 times
           if ieee-754-34 less than 1.0 then
               move ieee-754-34 to as-dotnines
               display ieee-754-34 ", " as-dotnines
           else
               move ieee-754-34 to as-nines
               display ieee-754-34 ", " as-nines
           end-if
           divide ieee-754-34 by 4 giving ieee-754-34
       end-perform

       ==
       .

$ ./float-decimal-34-sample.cob
18446744073709551616E0, 18446744073709551616
4611686018427387904E0,  4611686018427387904
1152921504606846976E0,  1152921504606846976
288230376151711744E0,   288230376151711744
72057594037927936E0,    72057594037927936
18014398509481984E0,    18014398509481984
4503599627370496E0,     4503599627370496
1125899906842624E0,     1125899906842624
281474976710656E0,      281474976710656
70368744177664E0,       70368744177664
17592186044416E0,       17592186044416
4398046511104E0,        4398046511104
1099511627776E0,        1099511627776
274877906944E0,         274877906944
68719476736E0,          68719476736
17179869184E0,          17179869184
4294967296E0,           4294967296
1073741824E0,           1073741824
268435456E0,            268435456
67108864E0,             67108864
16777216E0,             16777216
4194304E0,              4194304
1048576E0,              1048576
262144E0,               262144
65536E0,                65536
16384E0,                16384
4096E0,                 4096
1024E0,                 1024
256E0,                  256
64E0,                   64
16E0,                   16
4E0,                    4
1E0,                    1
25E-2, 0.2500000000000000000000000000000000
625E-4, 0.0625000000000000000000000000000000
15625E-6, 0.0156250000000000000000000000000000
390625E-8, 0.0039062500000000000000000000000000
9765625E-10, 0.0009765625000000000000000000000000
244140625E-12, 0.0002441406250000000000000000000000
6103515625E-14, 0.0000610351562500000000000000000000
152587890625E-16, 0.0000152587890625000000000000000000
3814697265625E-18, 0.0000038146972656250000000000000000
95367431640625E-20, 0.0000009536743164062500000000000000
2384185791015625E-22, 0.0000002384185791015625000000000000
59604644775390625E-24, 0.0000000596046447753906250000000000
1490116119384765625E-26, 0.0000000149011611938476562500000000
37252902984619140625E-28, 0.0000000037252902984619140625000000
931322574615478515625E-30, 0.0000000009313225746154785156250000
23283064365386962890625E-32, 0.0000000002328306436538696289062500
582076609134674072265625E-34, 0.0000000000582076609134674072265625
145519152283668518066406E-34, 0.0000000000145519152283668518066406
36379788070917129516601E-34, 0.0000000000036379788070917129516601
909494701772928237915E-33, 0.0000000000009094947017729282379150
2273736754432320594787E-34, 0.0000000000002273736754432320594787
568434188608080148696E-34, 0.0000000000000568434188608080148696
142108547152020037174E-34, 0.0000000000000142108547152020037174
35527136788005009293E-34, 0.0000000000000035527136788005009293
8881784197001252323E-34, 0.0000000000000008881784197001252323
222044604925031308E-33, 0.0000000000000002220446049250313080
55511151231257827E-33, 0.0000000000000000555111512312578270
138777878078144567E-34, 0.0000000000000000138777878078144567
34694469519536141E-34, 0.0000000000000000034694469519536141
8673617379884035E-34, 0.0000000000000000008673617379884035
2168404344971008E-34, 0.0000000000000000002168404344971008

2 ** 128 as D-34  = 3402823669209384634633746074317682E5

2 ** 126 as 9(38) = 85070591730234615865843651857942050000
 as numeric-edit  = 85,070,591,730,234,615,865,843,651,857,942,050,000

identification division.
program-id. threes.

data division.
working-storage section.
01 fshort usage float-short.
01 flong  usage float-long.
01 fpic   pic   9v9(35).

procedure division.
compute fshort = 1 / 3
display "(1/3) as short " fshort
compute flong = 1 / 3
display "(1/3) as long  " flong
compute fpic = 1 / 6
display "(1/6) as pic   " fpic
compute fpic rounded = 1 / 6
display "(1/6) rounded  " fpic
goback.

end program threes.

$ ./threes
(1/3) as short 0.333333343267440796
(1/3) as long  0.333333333333333315
(1/6) as pic   0.16666666666666666666666666666666666
(1/6) rounded  0.16666666666666666666666666666666667

FD  mini-report
      linage is 16 lines
          with footing at 13
          lines at top 2
          lines at bottom 2.

...

write report-line from report-line-data
    at end-of-page
        write report-line from running-summary end-write

        if more-detail-records then
            add 1 to page-count
            write report-line from report-header
                after advancing page
            end-write
        end-if
end-write

identification division.
program-id. foreverloop.

data division.
working-storage section.
01 cobol   pic 9 value 0.
01 c       pic 9 value 1.
01 fortran pic 9 value 2.

procedure division.

perform forever
    add 1 to cobol
    display "cobol at " cobol

    if cobol greater than fortran
        exit perform
    end-if

    if cobol greater than c
        exit perform cycle
    end-if

    display "cobol still creeping up on c"
end-perform

display "cobol surpassed c and fortran"

goback.
end program foreverloop.

$ cobc -free -x foreverloop.cob
$ ./foreverloop
cobol at 1
cobol still creeping up on c
cobol at 2
cobol at 3
cobol surpassed c and fortran

123456 >>SOURCE FORMAT IS FIXED

>>SOURCE FORMAT IS FREE

 01 var PIC X(1024) BASED.

 ALLOCATE var
 CALL "buffer-thing" USING BY REFERENCE var END-CALL
 MOVE var TO working-store
 FREE var

ACCEPT var FROM ENVIRONMENT "path"
    ON EXCEPTION
        DISPLAY "No path" END-DISPLAY
    NOT ON EXCEPTION
        DISPLAY var END-DISPLAY
END-ACCEPT

PERFORM VARYING loop-index FROM 1 BY 1 UNTIL loop-index > loop-value
    SUBTRACT transaction-value(loop-index) FROM balance
END-PERFORM

ACCEPT var FROM ENVIRONMENT "path"
    ON EXCEPTION
        DISPLAY "No path"
    NOT ON EXCEPTION
        DISPLAY var
END-ACCEPT

ACCEPT var FROM ENVIRONMENT "path"
    ON EXCEPTION
        DISPLAY "No path"
            NOT ON EXCEPTION
                DISPLAY var
END-ACCEPT

DISPLAY FUNCTION TRIM("   trim off leading spaces" LEADING).

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
READ  *> Date:      20131211
URL   *> Purpose:   Read a web resource into working store
SAMPLE*> Credits:   Curl project sample getinmemory.c
      *> License:   GPL 3.0+
      *> Tectonics: cobc -lcurl -x curlit.cob
      *> ***************************************************************
       identification division.
       program-id. curlit.

       environment division.
       configuration section.
       repository.
           function read-url
           function all intrinsic.

       data division.
       working-storage section.

       copy "gccurlsym.cpy".

       01 web-page             pic x(16777216).
       01 curl-status          usage binary-long.

       01 gnucobolcgi          pic x(69)
            value "http://opencobol.add1tocobol.com/gnucobolcgi/" &
                  "gnucobol.cgi?query=thing".

      *> ***************************************************************
       procedure division.

      *>
      *> Read a web resource, or query into fixed ram.
      *>   Caller is in charge of sizing the buffer,
      *>     (or getting trickier with the write callback)
      *> Pass URL and working-storage variable,
      *>   get back libcURL error code or 0 for success

       move read-url("https://google.com", web-page) to curl-status

      *>
      *> Now tesing the result, relying on the gccurlsym
      *>   GnuCOBOL Curl Symbol copy book

       if curl-status not equal zero then
           display
               curl-status " "
               CURLEMSG(curl-status) upon syserr
       end-if

      *>
      *> And display the page (suitable for piping to w3m if .html)

       display trim(web-page trailing) with no advancing

      *> FUNCTION-ID can be used pretty much anywhere a sending field
      *> is expected, so it doesn't have to be a move, and the request
      *> isn't limited to just page resources, query lines will work too

       initialize web-page
       compute curl-status = read-url(gnucobolcgi, web-page) end-compute
       if curl-status not equal zero then
           display
               curl-status " "
               CURLEMSG(curl-status) upon syserr
       else
           display trim(web-page trailing) with no advancing
       end-if

      *>
      *> or if it's unreliable, but worthy information, skip the check
      *>    one line networking

       move spaces to web-page
       move read-url("https://en.wikipedia.org/wiki/GNU_Cobol", web-page)
         to curl-status
       display trim(web-page trailing) with no advancing

       move spaces to web-page
       move read-url(
               "http://sourceforge.net/rest/p/gnucobol/", web-page)
         to curl-status
       display trim(web-page trailing) with no advancing

      *>
      *> libcurl can report on many error conditions

       move spaces to web-page
       move read-url("http://notfoundsite.moc", web-page)
         to curl-status
       perform check

       move read-url("http://peoplecards.ca", web-page)
         to curl-status
       display trim(web-page trailing) with no advancing

       goback.
      *> ***************************************************************

       check.
       if curl-status not equal zero then
           display
               curl-status " "
               CURLEMSG(curl-status) upon syserr
       end-if.

       end program curlit.
      *> ***************************************************************
      *> ***************************************************************


      *>
      *> The function hiding all the curl details
      *>
      *> Purpose:   Call libcURL and read into memory
      *> ***************************************************************
       identification division.
       function-id. read-url.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       copy "gccurlsym.cpy".

       01 curl-handle          usage pointer.
       01 callback-handle      usage procedure-pointer.
       01 memory-block.
          05 memory-address    usage pointer sync.
          05 memory-size       usage binary-long sync.
          05 running-total     usage binary-long sync.
       01 curl-result          usage binary-long.

       linkage section.
       01 url                  pic x any length.
       01 buffer               pic x any length.
       01 curl-status          usage binary-long.

      *> ***************************************************************
       procedure division using url buffer returning curl-status.
       display "Read: " url upon syserr

      *> initialize libcurl, hint at missing library if need be
       call "curl_global_init" using by value CURL_GLOBAL_ALL
           on exception
               display
                   "need libcurl, link with -lcurl" upon syserr
               stop run returning 1
       end-call

      *> initialize handle
       call "curl_easy_init" returning curl-handle end-call
       if curl-handle equal NULL then
           display "no curl handle" upon syserr
           stop run returning 1
       end-if

      *> Set the URL
       call "curl_easy_setopt" using
           by value curl-handle
           by value CURLOPT_URL
           by reference concatenate(trim(url trailing), x"00")
       end-call

      *> follow all redirects
       call "curl_easy_setopt" using
           by value curl-handle
           by value CURLOPT_FOLLOWLOCATION
           by value 1
       end-call

      *> set the call back to write to memory
       set callback-handle to address of entry "curl-write-callback"
       call "curl_easy_setopt" using
           by value curl-handle
           by value CURLOPT_WRITEFUNCTION
           by value callback-handle
       end-call

      *> set the curl handle data handling structure
       set memory-address to address of buffer
       move length(buffer) to memory-size
       move 1 to running-total

       call "curl_easy_setopt" using
           by value curl-handle
           by value CURLOPT_WRITEDATA
           by value address of memory-block
       end-call

      *> some servers demand an agent
       call "curl_easy_setopt" using
           by value curl-handle
           by value CURLOPT_USERAGENT
           by reference concatenate("libcurl-agent/1.0", x"00")
       end-call

      *> let curl do all the hard work
       call "curl_easy_perform" using
           by value curl-handle
           returning curl-result
       end-call

      *> the call back will handle filling ram, return the result code
       move curl-result to curl-status
       goback.
       end function read-url.

      *> ***************************************************************
      *> ***************************************************************

curl  *> Supporting callback
call  *> Purpose:   libcURL write callback
back  *> ***************************************************************
       identification division.
       program-id. curl-write-callback.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 real-size            usage binary-long.

      *> libcURL will pass a pointer to this structure in the callback
       01 memory-block         based.
          05 memory-address    usage pointer sync.
          05 memory-size       usage binary-long sync.
          05 running-total     usage binary-long sync.

       01 content-buffer       pic x(65536) based.
       01 web-space            pic x(16777216) based.
       01 left-over            usage binary-long.

       linkage section.
       01 contents             usage pointer.
       01 element-size         usage binary-long.
       01 element-count        usage binary-long.
       01 memory-structure     usage pointer.

      *> ***************************************************************
       procedure division
           using
              by value contents
              by value element-size
              by value element-count
              by value memory-structure
          returning real-size.

       set address of memory-block to memory-structure
       compute real-size = element-size * element-count end-compute

      *> Fence off the end of buffer
       compute
           left-over = memory-size - running-total
       end-compute
       if left-over > 0 and < real-size then
           move left-over to real-size
       end-if

      *> if there is more buffer, and data not zero length
       if (left-over > 0) and (real-size > 1) then
           set address of content-buffer to contents
           set address of web-space to memory-address

           move content-buffer(1:real-size)
             to web-space(running-total:real-size)

           add real-size to running-total
       end-if

      *> That if should have an else that raises a size exception <*

       goback.
       end program curl-write-callback.

GNU   *> manifest constants for libcurl
Cobol *> Usage: COPY occurlsym  inside data division
      *>  Taken from include/curl/curl.h 2013-12-19

curl  *> Functional enums
       01 CURL_MAX_HTTP_HEADER CONSTANT AS     102400.

       78 CURL_GLOBAL_ALL                      VALUE 3.

       78 CURLOPT_FOLLOWLOCATION               VALUE 52.
       78 CURLOPT_WRITEDATA                    VALUE 10001.
       78 CURLOPT_URL                          VALUE 10002.
       78 CURLOPT_USERAGENT                    VALUE 10018.
       78 CURLOPT_WRITEFUNCTION                VALUE 20011.

      *> Result codes
       78 CURLE_OK                             VALUE 0.
      *> Error codes
       78 CURLE_UNSUPPORTED_PROTOCOL           VALUE 1.
       78 CURLE_FAILED_INIT                    VALUE 2.
       78 CURLE_URL_MALFORMAT                  VALUE 3.
       78 CURLE_OBSOLETE4                      VALUE 4.
       78 CURLE_COULDNT_RESOLVE_PROXY          VALUE 5.
       78 CURLE_COULDNT_RESOLVE_HOST           VALUE 6.
       78 CURLE_COULDNT_CONNECT                VALUE 7.
       78 CURLE_FTP_WEIRD_SERVER_REPLY         VALUE 8.
       78 CURLE_REMOTE_ACCESS_DENIED           VALUE 9.
       78 CURLE_OBSOLETE10                     VALUE 10.
       78 CURLE_FTP_WEIRD_PASS_REPLY           VALUE 11.
       78 CURLE_OBSOLETE12                     VALUE 12.
       78 CURLE_FTP_WEIRD_PASV_REPLY           VALUE 13.
       78 CURLE_FTP_WEIRD_227_FORMAT           VALUE 14.
       78 CURLE_FTP_CANT_GET_HOST              VALUE 15.
       78 CURLE_OBSOLETE16                     VALUE 16.
       78 CURLE_FTP_COULDNT_SET_TYPE           VALUE 17.
       78 CURLE_PARTIAL_FILE                   VALUE 18.
       78 CURLE_FTP_COULDNT_RETR_FILE          VALUE 19.
       78 CURLE_OBSOLETE20                     VALUE 20.
       78 CURLE_QUOTE_ERROR                    VALUE 21.
       78 CURLE_HTTP_RETURNED_ERROR            VALUE 22.
       78 CURLE_WRITE_ERROR                    VALUE 23.
       78 CURLE_OBSOLETE24                     VALUE 24.
       78 CURLE_UPLOAD_FAILED                  VALUE 25.
       78 CURLE_READ_ERROR                     VALUE 26.
       78 CURLE_OUT_OF_MEMORY                  VALUE 27.
       78 CURLE_OPERATION_TIMEDOUT             VALUE 28.
       78 CURLE_OBSOLETE29                     VALUE 29.
       78 CURLE_FTP_PORT_FAILED                VALUE 30.
       78 CURLE_FTP_COULDNT_USE_REST           VALUE 31.
       78 CURLE_OBSOLETE32                     VALUE 32.
       78 CURLE_RANGE_ERROR                    VALUE 33.
       78 CURLE_HTTP_POST_ERROR                VALUE 34.
       78 CURLE_SSL_CONNECT_ERROR              VALUE 35.
       78 CURLE_BAD_DOWNLOAD_RESUME            VALUE 36.
       78 CURLE_FILE_COULDNT_READ_FILE         VALUE 37.
       78 CURLE_LDAP_CANNOT_BIND               VALUE 38.
       78 CURLE_LDAP_SEARCH_FAILED             VALUE 39.
       78 CURLE_OBSOLETE40                     VALUE 40.
       78 CURLE_FUNCTION_NOT_FOUND             VALUE 41.
       78 CURLE_ABORTED_BY_CALLBACK            VALUE 42.
       78 CURLE_BAD_FUNCTION_ARGUMENT          VALUE 43.
       78 CURLE_OBSOLETE44                     VALUE 44.
       78 CURLE_INTERFACE_FAILED               VALUE 45.
       78 CURLE_OBSOLETE46                     VALUE 46.
       78 CURLE_TOO_MANY_REDIRECTS             VALUE 47.
       78 CURLE_UNKNOWN_TELNET_OPTION          VALUE 48.
       78 CURLE_TELNET_OPTION_SYNTAX           VALUE 49.
       78 CURLE_OBSOLETE50                     VALUE 50.
       78 CURLE_PEER_FAILED_VERIFICATION       VALUE 51.
       78 CURLE_GOT_NOTHING                    VALUE 52.
       78 CURLE_SSL_ENGINE_NOTFOUND            VALUE 53.
       78 CURLE_SSL_ENGINE_SETFAILED           VALUE 54.
       78 CURLE_SEND_ERROR                     VALUE 55.
       78 CURLE_RECV_ERROR                     VALUE 56.
       78 CURLE_OBSOLETE57                     VALUE 57.
       78 CURLE_SSL_CERTPROBLEM                VALUE 58.
       78 CURLE_SSL_CIPHER                     VALUE 59.
       78 CURLE_SSL_CACERT                     VALUE 60.
       78 CURLE_BAD_CONTENT_ENCODING           VALUE 61.
       78 CURLE_LDAP_INVALID_URL               VALUE 62.
       78 CURLE_FILESIZE_EXCEEDED              VALUE 63.
       78 CURLE_USE_SSL_FAILED                 VALUE 64.
       78 CURLE_SEND_FAIL_REWIND               VALUE 65.
       78 CURLE_SSL_ENGINE_INITFAILED          VALUE 66.
       78 CURLE_LOGIN_DENIED                   VALUE 67.
       78 CURLE_TFTP_NOTFOUND                  VALUE 68.
       78 CURLE_TFTP_PERM                      VALUE 69.
       78 CURLE_REMOTE_DISK_FULL               VALUE 70.
       78 CURLE_TFTP_ILLEGAL                   VALUE 71.
       78 CURLE_TFTP_UNKNOWNID                 VALUE 72.
       78 CURLE_REMOTE_FILE_EXISTS             VALUE 73.
       78 CURLE_TFTP_NOSUCHUSER                VALUE 74.
       78 CURLE_CONV_FAILED                    VALUE 75.
       78 CURLE_CONV_REQD                      VALUE 76.
       78 CURLE_SSL_CACERT_BADFILE             VALUE 77.
       78 CURLE_REMOTE_FILE_NOT_FOUND          VALUE 78.
       78 CURLE_SSH                            VALUE 79.
       78 CURLE_SSL_SHUTDOWN_FAILED            VALUE 80.
       78 CURLE_AGAIN                          VALUE 81.

      *> Error strings
       01 LIBCURL_ERRORS.
          02 CURLEVALUES.
             03 FILLER PIC X(30) VALUE "CURLE_UNSUPPORTED_PROTOCOL    ".
             03 FILLER PIC X(30) VALUE "CURLE_FAILED_INIT             ".
             03 FILLER PIC X(30) VALUE "CURLE_URL_MALFORMAT           ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE4               ".
             03 FILLER PIC X(30) VALUE "CURLE_COULDNT_RESOLVE_PROXY   ".
             03 FILLER PIC X(30) VALUE "CURLE_COULDNT_RESOLVE_HOST    ".
             03 FILLER PIC X(30) VALUE "CURLE_COULDNT_CONNECT         ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_WEIRD_SERVER_REPLY  ".
             03 FILLER PIC X(30) VALUE "CURLE_REMOTE_ACCESS_DENIED    ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE10              ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_WEIRD_PASS_REPLY    ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE12              ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_WEIRD_PASV_REPLY    ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_WEIRD_227_FORMAT    ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_CANT_GET_HOST       ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE16              ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_COULDNT_SET_TYPE    ".
             03 FILLER PIC X(30) VALUE "CURLE_PARTIAL_FILE            ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_COULDNT_RETR_FILE   ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE20              ".
             03 FILLER PIC X(30) VALUE "CURLE_QUOTE_ERROR             ".
             03 FILLER PIC X(30) VALUE "CURLE_HTTP_RETURNED_ERROR     ".
             03 FILLER PIC X(30) VALUE "CURLE_WRITE_ERROR             ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE24              ".
             03 FILLER PIC X(30) VALUE "CURLE_UPLOAD_FAILED           ".
             03 FILLER PIC X(30) VALUE "CURLE_READ_ERROR              ".
             03 FILLER PIC X(30) VALUE "CURLE_OUT_OF_MEMORY           ".
             03 FILLER PIC X(30) VALUE "CURLE_OPERATION_TIMEDOUT      ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE29              ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_PORT_FAILED         ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_COULDNT_USE_REST    ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE32              ".
             03 FILLER PIC X(30) VALUE "CURLE_RANGE_ERROR             ".
             03 FILLER PIC X(30) VALUE "CURLE_HTTP_POST_ERROR         ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CONNECT_ERROR       ".
             03 FILLER PIC X(30) VALUE "CURLE_BAD_DOWNLOAD_RESUME     ".
             03 FILLER PIC X(30) VALUE "CURLE_FILE_COULDNT_READ_FILE  ".
             03 FILLER PIC X(30) VALUE "CURLE_LDAP_CANNOT_BIND        ".
             03 FILLER PIC X(30) VALUE "CURLE_LDAP_SEARCH_FAILED      ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE40              ".
             03 FILLER PIC X(30) VALUE "CURLE_FUNCTION_NOT_FOUND      ".
             03 FILLER PIC X(30) VALUE "CURLE_ABORTED_BY_CALLBACK     ".
             03 FILLER PIC X(30) VALUE "CURLE_BAD_FUNCTION_ARGUMENT   ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE44              ".
             03 FILLER PIC X(30) VALUE "CURLE_INTERFACE_FAILED        ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE46              ".
             03 FILLER PIC X(30) VALUE "CURLE_TOO_MANY_REDIRECTS      ".
             03 FILLER PIC X(30) VALUE "CURLE_UNKNOWN_TELNET_OPTION   ".
             03 FILLER PIC X(30) VALUE "CURLE_TELNET_OPTION_SYNTAX    ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE50              ".
             03 FILLER PIC X(30) VALUE "CURLE_PEER_FAILED_VERIFICATION".
             03 FILLER PIC X(30) VALUE "CURLE_GOT_NOTHING             ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_ENGINE_NOTFOUND     ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_ENGINE_SETFAILED    ".
             03 FILLER PIC X(30) VALUE "CURLE_SEND_ERROR              ".
             03 FILLER PIC X(30) VALUE "CURLE_RECV_ERROR              ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE57              ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CERTPROBLEM         ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CIPHER              ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CACERT              ".
             03 FILLER PIC X(30) VALUE "CURLE_BAD_CONTENT_ENCODING    ".
             03 FILLER PIC X(30) VALUE "CURLE_LDAP_INVALID_URL        ".
             03 FILLER PIC X(30) VALUE "CURLE_FILESIZE_EXCEEDED       ".
             03 FILLER PIC X(30) VALUE "CURLE_USE_SSL_FAILED          ".
             03 FILLER PIC X(30) VALUE "CURLE_SEND_FAIL_REWIND        ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_ENGINE_INITFAILED   ".
             03 FILLER PIC X(30) VALUE "CURLE_LOGIN_DENIED            ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_NOTFOUND           ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_PERM               ".
             03 FILLER PIC X(30) VALUE "CURLE_REMOTE_DISK_FULL        ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_ILLEGAL            ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_UNKNOWNID          ".
             03 FILLER PIC X(30) VALUE "CURLE_REMOTE_FILE_EXISTS      ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_NOSUCHUSER         ".
             03 FILLER PIC X(30) VALUE "CURLE_CONV_FAILED             ".
             03 FILLER PIC X(30) VALUE "CURLE_CONV_REQD               ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CACERT_BADFILE      ".
             03 FILLER PIC X(30) VALUE "CURLE_REMOTE_FILE_NOT_FOUND   ".
             03 FILLER PIC X(30) VALUE "CURLE_SSH                     ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_SHUTDOWN_FAILED     ".
             03 FILLER PIC X(30) VALUE "CURLE_AGAIN                   ".
       01 FILLER REDEFINES LIBCURL_ERRORS.
          02 CURLEMSG OCCURS 81 TIMES PIC X(30).

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Date:      20131005
Wrap  *> Purpose:   Wrap CALL in FUNCTION
CALL  *> Tectonics: cobc -x call-wrap.cob
in UDF*> ***************************************************************
       identification division.
       program-id. call-wrap.

       environment division.
       configuration section.
       repository.
           function all intrinsic
           function f.

       data division.
       working-storage section.
       01 a                    pic s9(9) value 2.

      *> ***************************************************************
       procedure division.

      *> These are just tests
       display "a is                   : " a

       perform 4 times
           move f("square", a) to a
           display 'f("square", a) is      : ' a
       end-perform

       display 'f("square-root", a) is : ' f("square-root", a)

       goback.
       end program call-wrap.
      *> ***************************************************************

      *> ***************************************************************
      *>  functional call wrapper
      *>
       identification division.
       function-id. f.

       data division.
       linkage section.
       01 call-name            pic x any length.
       01 argument-integer     pic s9(9).
       01 argument-result      pic s9(9).

       procedure division
           using call-name argument-integer returning argument-result.

      *> Need RAISE support added in, should get on that
       call call-name
           using argument-integer returning argument-result
           on exception
               continue
       end-call

       goback.
       end function f.
      *> ***************************************************************

      *> ***************************************************************
      *>  this is a made up example CALL target, square an int
       identification division.
       program-id. square.

       data division.
       working-storage section.
       01 the-square           pic s9(9).

       linkage section.
       01 input-integer        pic s9(9).
       01 output-integer       pic s9(9).

       procedure division using input-integer returning output-integer.

       set address of output-integer to address of the-square
       compute
           output-integer = input-integer * input-integer
       end-compute

       goback.
       end program square.
      *> ***************************************************************

      *> ***************************************************************
      *>  another made up example, this one has for fun data conversions
       identification division.
       program-id. square-root.

       data division.
       working-storage section.
       01 the-root             pic s9(9).
       01 the-float            usage float-short.

       linkage section.
       01 input-integer        pic s9(9).
       01 output-integer       pic s9(9).

       procedure division using input-integer returning output-integer.

      *> move the integer to a float for libc sqrt
       compute the-float = input-integer end-compute

       call static "sqrt" using
           by value the-float
           returning the-float
       end-call

      *> back to integer for the return <*
       set address of output-integer to address of the-root
       compute output-integer = the-float end-compute

       goback.
       end program square-root.

$ cobc -x -g -debug -W call-wrap.cob
$ ./call-wrap
a is                   : +000000002
f("square", a) is      : +000000004
f("square", a) is      : +000000016
f("square", a) is      : +000000256
f("square", a) is      : +000065536
f("square-root", a) is : +000000256

ADD 1 TO cobol GIVING GnuCOBOL.

* Main program
 IDENTIFICATION   DIVISION.
 PROGRAM-ID.      main-global.

 DATA             DIVISION.
 WORKING-STORAGE SECTION.
 01 built-on      PIC xxxx/xx/xxBxx/xx/xxBxxxxxxx GLOBAL.
 01 shared-value  PIC x(32)                       GLOBAL.
 01 newline       PIC x VALUE x"0a"               GLOBAL.

 PROCEDURE        DIVISION.
     DISPLAY "Enter main-global   - " WITH NO ADVANCING
     MOVE FUNCTION WHEN-COMPILED TO built-on
     INSPECT built-on REPLACING
         ALL "/" BY ":" AFTER INITIAL SPACE
         ALL " " BY "." AFTER INITIAL SPACE
         ALL "/" BY "-"
       FIRST " " BY "/"
     DISPLAY "Built on " built-on

     MOVE FUNCTION MODULE-ID TO shared-value
     DISPLAY "shared-value is :" FUNCTION TRIM(shared-value) ":"
     CALL "nested-global"
     DISPLAY "Back in main-global"
     DISPLAY "shared-value is :" FUNCTION TRIM(shared-value) ":"

     STOP RUN.

* Nested program, accesses GLOBAL data from Main
 IDENTIFICATION   DIVISION.
 PROGRAM-ID.      nested-global.

 PROCEDURE        DIVISION.
     DISPLAY newline "Enter nested-global - Built on " built-on

     DISPLAY
         "Caller    " FUNCTION MODULE-CALLER-ID       newline
         "Date      " FUNCTION MODULE-DATE            newline
         "Formatted " FUNCTION MODULE-FORMATTED-DATE  newline
         "Id        " FUNCTION MODULE-ID              newline
         "Path      " FUNCTION MODULE-PATH            newline
         "Source    " FUNCTION MODULE-SOURCE          newline
         "Time      " FUNCTION MODULE-TIME            newline

     MOVE FUNCTION MODULE-ID TO shared-value
     EXIT PROGRAM.

 END PROGRAM nested-global.
 END PROGRAM main-global.

prompt$ cobc -xj main-global.cob
Enter main-global   - Built on 2015-10-27/23:32:46.00-0400
shared-value is :main-global:

Enter nested-global - Built on 2015-10-27/23:32:46.00-0400
Caller    main-global
Date      20151027
Formatted Oct 27 2015 23:32:46
Id        nested-global
Path      /home/btiffin/lang/cobol/faq/main-global
Source    main-global.cob
Time      233246

Back in main-global
shared-value is :nested-global:

GO.

GO paragraph.

*> A contrivance of spaghetti
 identification division.
 program-id. going.
 author. Brian Tiffin.
 date-written. 2015-10-28/21:56-0400.
 remarks. Demonstrate GO, qualified GO, computed GO, and ALTER.

 data division.
 working-storage section.
 01 province             pic 9 value 2.

*> ************************************************************
 procedure division.
 main section.

*> First a simple GO TO.
 GO TO jumpover
 DISPLAY "This is never seen"
 .

*> target of the first GO
 jumpover.
 DISPLAY "In jumpover"
 DISPLAY space
 .

*> And now a fall through into some sections

*> Branches to, and within sections
*> The first part of section-a is an unlabelled paragraph
 section-a section.
 GO TO paragraph-x
 DISPLAY "This is never seen"
 .

*> There are three paragraph-x labels
 paragraph-x.
 DISPLAY "In paragraph-x of section-a"

*> Now a jump to a section
 GO TO section-b
 DISPLAY "This is never seen"
 .

*> this section is jumped to from section-a
 section-b section.
 paragraph-x.
 DISPLAY "In paragraph-x of section-b"

*> And now, a true spaghetti dance, with back branching
 GO TO paragraph-z
 .

 paragraph-y.
 DISPLAY "back branch to paragraph-y of section-b"

*> qualified GO TO of paragraph within a section.
 GO TO paragraph-x OF section-c
 .

 paragraph-z.
 DISPLAY "In paragraph-z of section-b"
 GO TO paragraph-y
 .

*> c-section
 section-c section.
 paragraph-one.
 DISPLAY "This is never seen"
 .

*> there are three paragraph-x labels, each in different sections
 paragraph-x.
 DISPLAY "In paragraph-x of section-c"
 DISPLAY space
 .

*> Fall through into a computed GO example

*> Now a computed GO DEPENDING within an unlabelled paragraph.
 computed-go section.
 DISPLAY "motto, depending on province: " province
 GO TO quebec, ontario, manitoba DEPENDING ON province
 .

*> I remember / That born under the lily / I grow under the rose.
 quebec.
 DISPLAY "Je me souviens / "
 DISPLAY "Que né sous le lys / "
 DISPLAY "Je croîs sous la rose."
 GO home
 .

 *> Loyal she began. Loyal she remains.
 ontario.
 DISPLAY "Ut incepit Fidelis sic permanet."
 GO home
 .

*> Glorious and free
 manitoba.
 DISPLAY "Gloriosus et liber."
 GO home
 .

*> And now for some altering.
 home.
 DISPLAY space

 ALTER story TO PROCEED TO beginning
 GO TO story
 .

*> Jump to a part of the story
 story.
 GO.
 .

*> the first part
 beginning.
 ALTER story TO PROCEED to middle
 DISPLAY "This is the start of a changing story"
 GO TO story
 .

*> the middle bit
 middle.
 ALTER story TO PROCEED to ending
 DISPLAY "The story progresses"
 GO TO story
 .

*> the climatic finish
 ending.
 DISPLAY "The story ends, happily ever after"
 .

*> fall through to the exit
 EXIT PROGRAM.

$ cobc -xj going.cob
In jumpover

In paragraph-x of section-a
In paragraph-x of section-b
In paragraph-z of section-b
back branch to paragraph-y of section-b
In paragraph-x of section-c

motto, depending on province: 2
Ut incepit Fidelis sic permanet.

This is the start of a changing story
The story progresses
The story ends, happily ever after

*> Simple GO TO
 IDENTIFICATION DIVISION.
 PROGRAM-ID. going-paragraph.
 AUTHOR. Brian Tiffin.
 DATE-WRITTEN. 2015-10-28/22:10-0400.
 REMARKS. Demonstrate GO.

 PROCEDURE DIVISION.
 main section.
 entry-point.

*> A simple GO TO.
 GO TO jumpover
 DISPLAY "This is never seen"
 .

*> target of the GO
 jumpover.
 DISPLAY "In jumpover"
 .

*> fall through to the exit
 EXIT PROGRAM.

*> GO section and to qualified paragraph labels
 IDENTIFICATION DIVISION.
 PROGRAM-ID. going-section.
 AUTHOR. Brian Tiffin.
 DATE-WRITTEN. 2015-10-28/22:10-0400.
 REMARKS. Demonstrate section and qualified GO

 PROCEDURE DIVISION.
 main section.
 entry-point.

 GO TO section-a
 DISPLAY "This is never seen"
 .

*> Branches to, and within sections
*> The first part of section-a is an unlabelled paragraph
 section-a section.

 GO TO paragraph-x
 DISPLAY "This is never seen"
 .

*> There are three paragraph-x labels
 paragraph-x.
 DISPLAY "In paragraph-x of section-a"

*> Now a jump to another section
 GO TO section-b
 DISPLAY "This is never seen"
 .

*> this section is jumped to from section-a
 section-b section.
 paragraph-x.
 DISPLAY "In paragraph-x of section-b"

*> And now, a little spaghettia dance, with back branching
 GO TO paragraph-z
 .

 paragraph-y.
 DISPLAY "back branch to paragraph-y of section-b"

*> qualified GO TO of paragraph within a section.
 GO TO paragraph-x OF section-c
 .

 paragraph-z.
 DISPLAY "In paragraph-z of section-b"
 GO TO paragraph-y
 .

*> c-section
 section-c section.
 paragraph-one.
 DISPLAY "This is never seen"
 .

*> there are three paragraph-x labels, each in different sections
 paragraph-x.
 DISPLAY "In paragraph-x of section-c"
 .

*> fall through to the exit
 EXIT PROGRAM.

prompt$ cobc -xj going-section.cob
In paragraph-x of section-a
In paragraph-x of section-b
In paragraph-z of section-b
back branch to paragraph-y of section-b
In paragraph-x of section-c

A SECTION.
   If not-needed-no-more
       GO TO X
   end-if
...
X.
    EXIT.
B SECTION.
   If not-needed-no-more
       GO TO X
   end-if
...
X.
    EXIT.

In both those cases within a SECTION, the GO TO
paragraph-existing-within-SECTION is implicitly qualified as
GO TO X OF A and GO TO X OF B.

The point of using X is that of the old Copy/Paste with GO TO. If you
religiously "number" all the exits uniquely, when a SECTION is copied
and pasted (by someone else, of course) and the closing paragraph is
renamed but one of the GO TOs using it is not... pickle ensures.

On the other hand, if all the exits-from-SECTION-paragraphs are named
the same, the implicit qualification "saves" you.

You can, of course, explicitly qualify a GO TO. However, why would you
ever need or want to do that?

*> A computed GO TO
 IDENTIFICATION DIVISION.
 PROGRAM-ID. going-computed.
 AUTHOR. Brian Tiffin.
 DATE-WRITTEN. 2015-10-28/22:10-0400.
 REMARKS. Demonstrate computed GO.

 DATA DIVISION.
 WORKING-STORAGE SECTION.
 01 province             pic 9 value 2.

*> ************************************************************
 PROCEDURE DIVISION.
 main section.

*> Now a computed GO DEPENDING
 DISPLAY "motto, depending on province: " province
 GO TO quebec, ontario, manitoba DEPENDING ON province
 .

*> I remember / That born under the lily / I grow under the rose.
 quebec.
 DISPLAY "Je me souviens / "
 DISPLAY "Que né sous le lys / "
 DISPLAY "Je croîs sous la rose."
 GO home
 .

 *> Loyal she began. Loyal she remains.
 ontario.
 DISPLAY "Ut incepit Fidelis sic permanet."
 GO home
 .

*> Glorious and free
 manitoba.
 DISPLAY "Gloriosus et liber."
 GO home
 .

*> And out
 home.
 EXIT PROGRAM.

prompt$ cobc -xj going-computed.cob
motto, depending on province: 2
Ut incepit Fidelis sic permanet.

IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 JUMP-ENTRY    PIC 9  VALUE 6.
   88 EXT-MODUS  VALUES 3, 4.
LINKAGE SECTION.
PROCEDURE DIVISION.
    GO TO ENTRY 'STMT05'.
MAIN.
    GO TO ENTRY 'STMT01'
                'STMT02'
                'STMT03'
                'STMT04'
                'STMT05'
    DEPENDING ON JUMP-ENTRY
    DISPLAY 'NOT JUMPED'
    GOBACK.
ENTRY FOR GO TO 'STMT01'
    DISPLAY 'STMT01'
ENTRY FOR GO TO 'STMT02'
    PERFORM 3 TIMES
ENTRY FOR GO TO 'STMT03'
       DISPLAY 'STMT03'
ENTRY FOR GO TO 'STMT04'  DISPLAY 'STMT04'
       IF EXT-MODUS EXIT PERFORM END-IF
    END-PERFORM
ENTRY FOR GO TO 'STMT05'
    DISPLAY 'STMT05'
    SUBTRACT 1 FROM JUMP-ENTRY
    GO TO MAIN.

small '05!ab1! c1! d'

bcd

GOBACK.

ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
I-O-CONTROL.
    SAME RECORD AREA FOR filename-1 filename-2.

IDENTIFICATION DIVISION.
PROGRAM-ID. sample.

IF A = 1 OR 2
    MOVE 1 TO B
END-IF

IF (A = 1) OR (A = 2)
    MOVE 1 TO B
END-IF

READ infile WITH IGNORE LOCK

READ filename-1 INTO identifer-1 IGNORING LOCK END-READ

MOVE "abc" TO field IN the-record IN the-structure

01 cursor-var USAGE INDEX.

SET cursor-var UP BY 1.

environment division.
input-output section.
file-control.
   select optional indexing
   assign to "indexing.dat"
   organization is indexed
   access mode is dynamic
   record key is keyfield of indexing-record
   alternate record key is splitkey of indexing-record
       with duplicates
   .

01 TABLE-DATA.
   05 TABLE-ELEMENTS
       OCCURS 1 TO 100 TIMES DEPENDING ON crowd-size
       INDEXED BY cursor-var.
     10 field-1 PIC X.

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20111226
      *> Purpose:   Small sample of INITIAL procedure division clause
      *> Tectonics: cobc -x -w -g -debug initialclause.cob
      *> ***************************************************************
       identification division.
       program-id. initialclause.

      *> -*********-*********-*********-*********-*********-*********-**
       procedure division.
       call "with-initial" end-call
       call "without-initial" end-call
       call "with-initial" end-call
       call "without-initial" end-call
       call "without-initial" end-call
       goback.
       end program initialclause.


      *> -*********-*********-*********-*********-*********-*********-**
      *> -*********-*********-*********-*********-*********-*********-**
       identification division.
       program-id. with-initial is initial.

       data division.
       working-storage section.
       01 the-value pic 99 value 42.

      *> -*********-*********-*********-*********-*********-*********-**
       procedure division.
       display "Inside with-initial with   : " the-value
       multiply the-value by 2 giving the-value
           on size error
               display "size overflow"
       end-multiply
       goback.
       end program with-initial.


      *> -*********-*********-*********-*********-*********-*********-**
      *> -*********-*********-*********-*********-*********-*********-**
       identification division.
       program-id. without-initial.

       data division.
       working-storage section.
       01 the-value pic 99 value 42.

      *> -*********-*********-*********-*********-*********-*********-**
       procedure division.
       display "Inside without-initial with: " the-value
       multiply the-value by 2 giving the-value
           on size error
               display "size overflow"
       end-multiply
       goback.
       end program without-initial.

[btiffin@home cobol]$ ./initialclause
Inside with-initial with   : 42
Inside without-initial with: 42
Inside with-initial with   : 42
Inside without-initial with: 84
size overflow
Inside without-initial with: 84
size overflow

GCobol*-----------------------------------------------------------------
       IDENTIFICATION DIVISION.
       PROGRAM-ID. 'INITTEST'.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SPECIAL-NAMES. DECIMAL-POINT IS COMMA.
       INPUT-OUTPUT SECTION.
       DATA DIVISION.
      *
       WORKING-STORAGE SECTION.
      *
       77  mychar      pic x.
       77  mynumeric   pic 9.
       01  REC-TEST BASED.
           03 REC-TEST-PART1 PIC X(10) value all '9'.
           03 REC-TEST-PART2 PIC X(10) value all 'A'.
       01  fillertest.
           03 fillertest-1 PIC 9(10) value 2222222222.
           03 filler       PIC X     value '|'.
           03 fillertest-2 PIC X(10) value all 'A'.
           03 filler       PIC 9(03) value 111.
           03 filler       PIC X     value '.'.
      *-----------------------------------------------------------------
       LINKAGE SECTION.
      *-----------------------------------------------------------------
       PROCEDURE DIVISION.
      *-----------------------------------------------------------------
       Main section.
       00.
      *
           display 'fillertest '
                   'on start:'
           end-display
           display fillertest
           end-display
           accept  mychar
      *
           initialize fillertest
           display 'fillertest '
                   'after initialize:'
           end-display
           display fillertest
           end-display
           accept  mychar
      *
           initialize fillertest replacing numeric by 9
           display 'fillertest '
                   'after initialize replacing numeric by 9:'
           end-display
           display fillertest
           end-display
           accept  mychar
      *
           initialize fillertest replacing alphanumeric by 'X'
           display 'fillertest '
                   'after initialize replacing alphanumeric by "X":'
           end-display
           display fillertest
           end-display
           accept  mychar
      *
           initialize fillertest replacing alphanumeric by all 'X'
           display 'fillertest '
                   'after initialize replacing alphanumeric by all "X":'
           end-display
           display fillertest
           end-display
           accept  mychar
      *
           initialize fillertest with filler
           display 'fillertest '
                   'after initialize with filler:'
           end-display
           display fillertest
           end-display
           accept  mychar
      *
           initialize fillertest all to value
           display 'fillertest '
                   'after initialize all to value:'
           end-display
           display fillertest
           end-display
           accept  mychar
      *
           ALLOCATE  REC-TEST
           display 'REC-TEST after allocating:'
           end-display
           display REC-TEST
           end-display
           accept  mychar
      *
           initialize REC-TEST all to value
           display 'REC-TEST after initalize all to value:'
           end-display
           display REC-TEST
           end-display
           accept  mychar
      *
           stop run
      *
           continue.
       ex. exit program.
      *-----------------------------------------------------------------
      *--- End of program INITTEST -------------------------------------

fillertest on start:
2222222222|AAAAAAAAAA111.
fillertest after initialize:
0000000000|          111.
fillertest after initialize replacing numeric by 9:
0000000009|          111.
fillertest after initialize replacing alphanumeric by "X":
0000000009|X         111.
fillertest after initialize replacing alphanumeric by all "X":
0000000009|XXXXXXXXXX111.
fillertest after initialize with filler:
0000000000           000
fillertest after initialize all to value:
2222222222|AAAAAAAAAA111.
REC-TEST after allocating:

REC-TEST after initalize all to value:
9999999999AAAAAAAAAA

77 based-var   PIC X(9) BASED VALUE "ALLOCATED".
77 pointer-var USAGE POINTER.

ALLOCATE based-var
DISPLAY ":" based-var ":"
FREE based-var
ALLOCATE based-var INITIALIZED RETURNING pointer-var
DISPLAY ":" based-var ":"

:         :
:ALLOCATED:

OPEN INPUT datafile

procedure division.
sort sort-work
    on descending key work-rec
    collating sequence is mixed
    input procedure is sort-transform
    output procedure is output-uppercase.

display sort-return
goback.

environment division.
input-output section.
file-control.
    select htmlfile
    assign to filename
    organization is record sequential.

GCobol identification division.
       program-id. inspecting.

       data division.
       working-storage section.
       01  ORIGINAL            pic XXXX/XX/XXBXX/XX/XXXXXXX/XX.
       01  DATEREC             pic XXXX/XX/XXBXX/XX/XXXXXXX/XX.

       procedure division.

       move function when-compiled to DATEREC ORIGINAL

       INSPECT DATEREC REPLACING ALL "/" BY ":" AFTER INITIAL SPACE

       display "Formatted function WHEN-COMPILED " ORIGINAL
       display " after INSPECT REPLACING         " DATEREC

       goback.
       end program inspecting.

Formatted function WHEN-COMPILED 2010/03/25 23/05/0900-04/00
 after INSPECT REPLACING         2010/03/25 23:05:0900-04:00

ocular*> Printable characters
      *> tectonics: cobc -xjd printables.cob | cat -v
       identification division.
       program-id. printables.

       environment division.
       configuration section.
       special-names.
           alphabet all-codes is 01 thru 256.

       repository.
           function all intrinsic.

       data division.
       working-storage section.
      *> maybe-printable is pretty much equivalent to all-codes alphabet
       01 maybe-printable constant as
             x"000102030405060708090A0B0C0D0E0F" &
             x"101112131415161718191A1B1C1D1E1F" &
             x"202122232425262728292A2B2C2D2E2F" &
             x"303132333435363738393A3B3C3D3E3F" &
             x"404142434445464748494A4B4C4D4E4F" &
             x"505152535455565758595A5B5C5D5E5F" &
             x"606162636465666768696A6B6C6D6E6F" &
             x"707172737475767778797A7B7C7D7E7F" &
             x"808182838485868788898A8B8C8D8E8F" &
             x"909192939495969798999A9B9C9D9E9F" &
             x"A0A1A2A3A4A5A6A7A8A9AAABACADAEAF" &
             x"B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF" &
             x"C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF" &
             x"D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF" &
             x"E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF" &
             x"F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF".

      *> convert to spaces
       01 printable constant as
       >>IF CHARSET = "EBCDIC"
             x"40404040404040404040404040404040" &
             x"40404040404040404040404040404040" &
             x"40404040404040404040404040404040" &
             x"40404040404040404040404040404040" &
             x"404142434445464748494A4B4C4D4E4F" &
             x"505152535455565758595A5B5C5D5E5F" &
             x"606162636465666768696A6B6C6D6E6F" &
             x"707172737475767778797A7B7C7D7E7F" &
             x"808182838485868788898A8B8C8D8E8F" &
             x"909192939495969798999A9B9C9D9E9F" &
             x"A0A1A2A3A4A5A6A7A8A9AAABACADAEAF" &
             x"B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF" &
             x"C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF" &
             x"D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF" &
             x"E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF" &
             x"F0F1F2F3F4F5F6F7F8F9FAFBFCFDFE40" &
       >>ELSE
             x"20202020202020202020202020202020" &
             x"20202020202020202020202020202020" &
             x"202122232425262728292A2B2C2D2E2F" &
             x"303132333435363738393A3B3C3D3E3F" &
             x"404142434445464748494A4B4C4D4E4F" &
             x"505152535455565758595A5B5C5D5E5F" &
             x"606162636465666768696A6B6C6D6E6F" &
             x"707172737475767778797A7B7C7D7E20" &
             x"20202020202020202020202020202020" &
             x"20202020202020202020202020202020" &
             x"20202020202020202020202020202020" &
             x"20202020202020202020202020202020" &
             x"20202020202020202020202020202020" &
             x"20202020202020202020202020202020" &
             x"20202020202020202020202020202020" &
             x"20202020202020202020202020202020".
       >>END-IF

      *> convert to periods
       01 dotted constant as
       >>IF CHARSET = "EBCDIC"
             x"7D7D7D7D7D7D7D7D7D7D7D7D7D7D7D7D" &
             x"7D7D7D7D7D7D7D7D7D7D7D7D7D7D7D7D" &
             x"7D7D7D7D7D7D7D7D7D7D7D7D7D7D7D7D" &
             x"7D7D7D7D7D7D7D7D7D7D7D7D7D7D7D7D" &
             x"404142434445464748494A4B4C4D4E4F" &
             x"505152535455565758595A5B5C5D5E5F" &
             x"606162636465666768696A6B6C6D6E6F" &
             x"707172737475767778797A7B7C7D7E7F" &
             x"808182838485868788898A8B8C8D8E8F" &
             x"909192939495969798999A9B9C9D9E9F" &
             x"A0A1A2A3A4A5A6A7A8A9AAABACADAEAF" &
             x"B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF" &
             x"C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF" &
             x"D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF" &
             x"E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF" &
             x"F0F1F2F3F4F5F6F7F8F9FAFBFCFDFE7D" &
       >>ELSE
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"202122232425262728292A2B2C2D2E2F" &
             x"303132333435363738393A3B3C3D3E3F" &
             x"404142434445464748494A4B4C4D4E4F" &
             x"505152535455565758595A5B5C5D5E5F" &
             x"606162636465666768696A6B6C6D6E6F" &
             x"707172737475767778797A7B7C7D7E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E" &
             x"2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E".
       >>END-IF

       01 testing.
          05 value x"00010203" & " abcd " & x"0d0a" & x"8899EEFF".

       procedure division.
       sample-main.

      *> First using the two working-storage character fields
       display testing
       inspect testing converting maybe-printable to printable
       display ":" testing ":"
       display space

      *> Second using an ALPHABET and the replacement character field
       initialize testing with filler all to value
       display testing
       inspect testing converting all-codes to printable
       display ":" testing ":"
       display space

      *> third using the ALPHABET and the dotted replacement
       initialize testing with filler all to value
       display testing
       inspect testing converting all-codes to dotted
       display ":" testing ":"

       goback.
       end program printables.

prompt$ cobc -xjd printables.cob | cat -v
^@^A^B^C abcd ^M
M-^HM-^YM-nM-^?
:     abcd       :

^@^A^B^C abcd ^M
M-^HM-^YM-nM-^?
:     abcd       :

^@^A^B^C abcd ^M
M-^HM-^YM-nM-^?
:.... abcd ......:

DIVIDE A INTO B GIVING C.

READ filespec RECORD INTO record-space

CALL "subprogram" RETURNING INTO result

STRING source-field DELIMITED BY LOW-VALUE ... INTO destination-field

UNSTRING source-field DELIMITED BY "," INTO dest-field-1 ...

environment division.
configuration section.
repository.
    function all intrinsic.

move trim("  abc") to dest
move function trim("  abc") to dest

READ filename-1
    INVALID KEY
        DISPLAY "Bad key" END-DISPLAY
    NOT INVALID KEY
        DISPLAY "Good read" END-DISPLAY
END-READ

77 str1 pic x(40) justified right.

READ WITH KEPT LOCK

- RELATIVE KEY IS
- ALTERNATE RECORD KEY IS
- NOT INVALID KEY
- SORT filename ON DESCENDING KEY keyfield
- START indexing KEY IS LESS THAN keyfield

file-control.
    select cgi-in
    assign to keyboard.

START filename-1 LAST
    INVALID KEY
        MOVE ZERO TO record-count
        >>D DISPLAY "No last record for " filename-1
END-START

$ export LC_MESSAGES=es_ES
$ cobc -x fdfgffd.cob
cobc: fdfgffd.cob: No existe el fichero o el directorio

DISPLAY FUNCTION TRIM(var-1 LEADING)

INSPECT FUNCTION REVERSE(TEST-CASE)
    TALLYING B-COUNT
    FOR LEADING ' '.
DISPLAY B-COUNT.

INSPECT X REPLACING LEADING ZEROS BY SPACES.

COPY "copy.inc"
    REPLACING LEADING ==TEST== BY ==FIRST==
              LEADING ==NORM== BY ==SECOND==.

IF requested LESS THAN OR EQUAL TO balance
    PERFORM transfer
ELSE
    PERFORM reject
END-IF

COBOL *****************************************************************
      * Example of LINAGE File Descriptor
      * Author: Brian Tiffin
      * Date:   10-July-2008
      * Tectonics: $ cocb -x linage.cob
      *            $ ./linage <filename ["linage.cob"]>
      *            $ cat -n mini-report
      *****************************************************************
       IDENTIFICATION DIVISION.
       PROGRAM-ID. linage-demo.

       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           select optional data-file assign to file-name
               organization is line sequential
               file status is data-file-status.
           select mini-report assign to "mini-report".

       DATA DIVISION.
       FILE SECTION.
       FD  data-file.
       01  data-record.
           88 endofdata        value high-values.
           02 data-line        pic x(80).
       FD  mini-report
           linage is 16 lines
               with footing at 15
               lines at top 2
               lines at bottom 2.
       01  report-line         pic x(80).

       WORKING-STORAGE SECTION.
       01  command-arguments   pic x(1024).
       01  file-name           pic x(160).
       01  data-file-status    pic xx.
       01  lc                  pic 99.
       01  report-line-blank.
           02 filler           pic x(18) value all "*".
           02 filler           pic x(05) value spaces.
           02 filler           pic x(34)
               VALUE "THIS PAGE INTENTIONALLY LEFT BLANK".
           02 filler           pic x(05) value spaces.
           02 filler           pic x(18) value all "*".
       01  report-line-data.
           02 body-tag         pic 9(6).
           02 line-3           pic x(74).
       01  report-line-header.
           02 filler           pic x(6) VALUE "PAGE: ".
           02 page-no          pic 9999.
           02 filler           pic x(24).
           02 filler           pic x(5) VALUE " LC: ".
           02 header-tag       pic 9(6).
           02 filler           pic x(23).
           02 filler           pic x(6) VALUE "DATE: ".
           02 page-date        pic x(6).

       01  page-count          pic 9999.

       PROCEDURE DIVISION.

       accept command-arguments from command-line end-accept.
       string
           command-arguments delimited by space
           into file-name
       end-string.
       if file-name equal spaces
           move "linage.cob" to file-name
       end-if.

       open input data-file.
       read data-file
           at end
               display "File: " function trim(file-name) " open error"
               go to early-exit
       end-read.

       open output mini-report.

       write report-line
           from report-line-blank
       end-write.

       move 1 to page-count.
       accept page-date from date end-accept.
       move page-count to page-no.
       write report-line
           from report-line-header
           after advancing page
       end-write.

       perform readwrite-loop until endofdata.

       display
           "Normal termination, file name: "
           function trim(file-name)
           " ending status: "
           data-file-status
       close mini-report.

      * Goto considered harmful?  Bah!  :)
       early-exit.
       close data-file.
       exit program.
       stop run.

      ****************************************************************
       readwrite-loop.
       move data-record to report-line-data
       move linage-counter to body-tag
       write report-line from report-line-data
           end-of-page
               add 1 to page-count end-add
               move page-count to page-no
               move linage-counter to header-tag
               write report-line from report-line-header
                   after advancing page
               end-write
       end-write
       read data-file
           at end set endofdata to true
       end-read
       .

      *****************************************************************
      * Commentary
      * LINAGE is set at a 20 line logical page
      *  16 body lines
      *   2 top lines
      *   A footer line at 15 (inside the body count)
      *   2 bottom lines
      * Build with:
      * $ cobc -x -Wall -Wtruncate linage.cob
      * Evaluate with:
      * $ ./linage
      * This will read in linage.cob and produce a useless mini-report
      * $ cat -n mini-report
      *****************************************************************
       END PROGRAM linage-demo.

$ ./linage except.cob

******************     THIS PAGE INTENTIONALLY LEFT BLANK     ******************


















PAGE: 0001                         LC: 000000                       DATE: 090206
000001 IDENTIFICATION DIVISION.
000002 PROGRAM-ID. MINIPROG.
000003 ENVIRONMENT DIVISION.
000004 CONFIGURATION SECTION.
000005 SOURCE-COMPUTER. LINUX.
000006 OBJECT-COMPUTER. LINUX.
000007 SPECIAL-NAMES.
000008 INPUT-OUTPUT SECTION.
000009 FILE-CONTROL.
000010 SELECT PRINTFILE ASSIGN TO "XXRXWXX"
000011 FILE STATUS RXWSTAT.
000012 DATA DIVISION.
000013 FILE SECTION.
000014 FD PRINTFILE.





PAGE: 0002                         LC: 000015                       DATE: 090206
000001 01 PRINTREC PIC X(132).
000002 WORKING-STORAGE SECTION.
000003 01 RXWSTAT PIC XX.
000004 01 str     pic x(4).
000005 PROCEDURE DIVISION.
000006 A00-MAIN SECTION.
000007 001-MAIN-PROCEDURE.
000008 OPEN INPUT PRINTFILE.
000009 DISPLAY "File Status: " RXWSTAT.
000010 DISPLAY "EXCEPTION-FILE: " FUNCTION EXCEPTION-FILE.
000011 DISPLAY "Return Length: "
000012 FUNCTION LENGTH (FUNCTION EXCEPTION-FILE).
000013 DISPLAY "EXCEPTION-STATUS: " FUNCTION EXCEPTION-STATUS.
000014 DISPLAY "EXCEPTION-STATEMENT: " FUNCTION EXCEPTION-STATEMENT.





PAGE: 0003                         LC: 000015                       DATE: 090206
000001 STRING "TOOLONG" DELIMITED SIZE INTO RXWSTAT.
000002 DISPLAY "EXCEPTION-STATUS: " FUNCTION EXCEPTION-STATUS.
000003 DISPLAY "EXCEPTION-STATEMENT: " FUNCTION EXCEPTION-STATEMENT.
000004 DISPLAY "EXCEPTION-LOCATION: " FUNCTION EXCEPTION-LOCATION.
000005 STOP RUN.

FD testfile
    RECORD IS VARYING IN SIZE FROM 0 TO 132 CHARACTERS
    DEPENDING ON actual.

ACCEPT identifier LINE NUMBER 10 POSITION NUMBER 20.

DISPLAY "Text" AT 0203
DISPLAY "Text" AT 002101 WITH REVERSE-VIDEO

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
    LOCALE spanish IS 'ES_es'.

SELECT filename-1 ASSIGN TO 'master.dat' LOCK MODE IS MANUAL.

MOVE LOW-VALUE TO alphanumeric-1.

IF alphabetic-1 EQUALS LOW-VALUE
    DISPLAY "Failed validation"
END-IF.

MOVE LOW-VALUES TO alphanumeric-1.

SCREEN SECTION.
01 example.
    05 FILLER
        LINE 1 COLUMN 10
        VALUE IS "Example:"
        LOWLIGHT.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
OBJECT-COMPUTER.
MEMORY SIZE IS 8 CHARACTERS.

MERGE sort-file
    ON DESCENDING KEY key-field-1
    WITH DUPLICATES IN ORDER
    COLLATING SEQUENCE IS user-alphabet
    USING filename-1 filename-2
    GIVING filename-3

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140610
      *> Purpose:   Demonstrate a merge pass
      *> Tectonics: cobc -x gnucobol-merge-sample.cob
      *> ***************************************************************
       identification division.
       program-id. gnucobol-merge-sample.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

files  input-output section.
       file-control.
           select master-file
               assign to "master-sample.dat"
               organization is line sequential.

           select eastern-transaction-file
               assign to "east-transact-sample.dat"
               organization is line sequential.

           select western-transaction-file
               assign to "west-transact-sample.dat"
               organization is line sequential.

           select merged-transactions
               assign to "merged-transactions.dat"
               organization is line sequential.

           select working-merge
               assign to "merge.tmp".

data   data division.
       file section.
       fd master-file.
          01 master-record     pic x(64).

       fd eastern-transaction-file.
          01 transact-rec      pic x(64).

       fd western-transaction-file.
          01 transact-rec      pic x(64).

       fd merged-transactions.
          01 new-rec           pic x(64).

       sd working-merge.
          01 merge-rec.
             02 master-key     pic 9(8).
             02 filler         pic x.
             02 action         pic xxx.
             02 filler         PIC x(52).

      *> ***************************************************************
      *> not much code
      *>     trick.  DEP, CHQ, BAL are action keywords.  They sort
      *>     descending as DEP, CHQ, BAL, so main can do all deposits,
      *>     then all withdrawals, then balance reports, for each id.
      *> ***************************************************************
code   procedure division.
       merge working-merge
           on ascending key master-key
              descending key action
           using eastern-transaction-file,
                 western-transaction-file,
                 master-file
           giving merged-transactions
done   goback.
       end program gnucobol-merge-sample.

11111111 BAL            critical corporate data
22222222 BAL            even more critical
33333333 BAL            big account this one
44444444 BAL            a smaller, but no less important account

11111111 CHQ 0001111.11 withdrawal from account one
33333333 DEP 0333333.33 third of a million in, pocket change
33333333 CHQ 0000333.33 payroll
33333333 CHQ 0000333.33 payroll
33333333 CHQ 0000333.33 payroll
55555555 DEP 0000555.55 deposit to new record five
55555555 CHQ 0000055.55 withdrawal from account five

11111111 CHQ 0001111.11 withdrawal from account one
44444444 DEP 0000044.44 deposit to account four
66666666 BAL            balance request for account six

$ cobc -x gnucobol-merge-sample.cob  -g -debug
$ COB_SET_TRACE=YES ./gnucobol-merge-sample
Source:     'gnucobol-merge-sample.cob'
Program-Id: gnucobol-merge-sample Entry:     gnucobol-merge-sample  Line: 64
Program-Id: gnucobol-merge-sample Section:   (None)                 Line: 64
Program-Id: gnucobol-merge-sample Paragraph: (None)                 Line: 64
Program-Id: gnucobol-merge-sample Statement: MERGE                  Line: 64
Program-Id: gnucobol-merge-sample Statement: GOBACK                 Line: 70
Program-Id: gnucobol-merge-sample Exit:      gnucobol-merge-sample

$ cat merged-transactions.dat
11111111 CHQ 0001111.11 withdrawal from account one
11111111 CHQ 0001111.11 withdrawal from account one
11111111 BAL            critical corporate data
22222222 BAL            even more critical
33333333 DEP 0333333.33 third of a million in, pocket change
33333333 CHQ 0000333.33 payroll
33333333 CHQ 0000333.33 payroll
33333333 CHQ 0000333.33 payroll
33333333 BAL            big account this one
44444444 DEP 0000044.44 deposit to account four
44444444 BAL            a smaller, but no less important account
55555555 DEP 0000555.55 deposit to new record five
55555555 CHQ 0000055.55 withdrawal from account five
66666666 BAL            balance request for account six

05 some-field pic x(16)
    line number is plus 1
    column number is minus 8

01 alphanum-3              PIC XXX.
01 num2                    PIC 99.

MOVE "ABCDEFG" TO xvar3
DISPLAY xvar3

MOVE 12345 TO num2
DISPLAY num2

ABC
45

MOVE CORRESPONDING ident-1 TO ident-2

LOCK MODE IS MANUAL WITH LOCK ON MULTIPLE RECORDS.

MULTIPLY var-1 BY var-2 GIVING var-3
    ON SIZE ERROR
        SET invalid-result TO TRUE
END-MULTIPLY

ACCEPT username FROM USER NAME.

IF a IS NEGATIVE
    SET in-the-red TO TRUE
END-IF

READ index-sequential-file NEXT RECORD INTO ident-1

IF condition-1
    NEXT SENTENCE
ELSE
    PERFORM do-something.

CLOSE filename-1 WITH NO REWIND

READ file-1 WITH NO LOCK

DISPLAY field-1 WITH NO ADVANCING

STOP RUN WITH NORMAL STATUS status-val

IF NOT production
    CALL "test-thing"
        NOT ON EXCEPTION
            DISPLAY "Linkage to thing, OK, called"
    END-CALL
END-IF

CALL "func" RETURNING NOTHING

SET ADDRESS OF based-var TO NULL

IF ptr EQUAL NULL
    DISPLAY "ptr not valid"
END-IF

CALL "thing" RETURNING NULL END-CALL

CALL "thing" RETURNING OMITTED END-CALL

MOVE CONCATENATE(TRIM(cbl-string TRAILING) NULL) TO c-string

MOVE CONCATENATE(TRIM(cbl-string TRAILING) LOW-VALUE) TO c-string

CALL "c-function" USING NULL

CALL "c-function" USING BY VALUE NULL

MOVE ALL NULLS TO var-space

05 some-field pic x(16) LINE NUMBER 5.

if NUMERIC '20140101' then
    display 'only numbers'
end-if

if NUMERIC '2014010a' then
    display 'only numbers'
end-if

*> Tectonics: cobc -xj any-numeric-sample.cob
 identification division.
 program-id. any-numeric.
 author. Brian Tiffin.
 date-written. 2015-12-15/01:08-0500.
 date-modified. 2015-12-15/22:45-0500.
 date-compiled.
 installation. Requires GnuCOBOL 2 or greater.
 remarks. Demonstrate ANY NUMERIC in linkage items.

 environment division.
 configuration section.
 repository.
     function variant-size
     function all intrinsic.

 data division.
 working-storage section.
 01 the-first-number   pic 9(5)  value 42.
 01 the-second-number  pic 9(30) value 42.
 01 the-third-number   pic 99    value 42.
 01 what-size          usage binary-long.

 procedure division.

 move variant-size(the-first-number) to what-size
 perform show-result

 move variant-size(the-second-number) to what-size
 perform show-result

 move variant-size(the-third-number) to what-size
 perform show-result

 goback.

 show-result.
 display "Length  : " what-size
 .

 end program any-numeric.
*> ***************************************************************

 identification division.
 function-id. variant-size.

 data division.
 linkage section.
 01 a-number           pic 9 any numeric.
 01 what-size          usage binary-long.

 procedure division using a-number returning what-size.

 display "Received: " a-number
 move function length(a-number) to what-size

 goback.
 end function variant-size.

prompt$ cobc -xj any-numeric-sample.cob
Received: 00042
Length  : +0000000005
Received: 000000000000000000000000000042
Length  : +0000000030
Received: 42
Length  : +0000000002

INITIALIZE data-record REPLACING NUMERIC-EDITED BY literal-value

GCobol identification division.
       program-id. runtime-computer.

       environment division.
       configuration section.
       object-computer.
           memory size is 8 characters
           program collating sequence is bigiron-alphabet
           segment-limit is 64
           character classificiation is spanish-locale.
       special-names.
           alphabet bigiron-alphabet is ebcdic
           symbolic characters BS  is  9
                               TAB is 10
                               LF  is 11
                           NEWLINE is 11
                               CMA is 45
           locale spanish-locale is "es_ES".
       repository.
           function all intrinsic.

01 days-in-week.
   05 day-name  pic x(9) occurs 7 times.
   05 day-names redefines day-name.
      10 value "Sunday   ".
      10 value "Monday   ".
      10 value "Tuesday  ".
      10 value "Wednesday".
      10 value "Thursday ".
      10 value "Friday   ".
      10 value "Saturday ".

01 main-table.
   05 main-record occurs 1 to 366 times depending on the-day-in-year.
      10 main-field pic x occurs from 1 to 132 times depending on the-len.

...

display trim(day-name(weekday)) ":"
move data-size-from-read to the-len
display main-record(what-day)

MOVE "abc" TO the-field OF the-record IN the-structure

environment division.
configuration section.
repository.
    function all intrinsic

01 some-field         pic x(80).
01 some-len           constant as LENGTH OF some-field.
01 other-field        pic x(some-len).

DISPLAY LENGTH OF other-field
DISPLAY LENGTH(other-field)

SPECIAL-NAMES.
    SWITCH-1 IS mainframe
        ON STATUS IS bigiron
        OFF STATUS IS pc

...

SET mainframe TO OFF

CALL "thing" USING
    BY REFERENCE string-var
    BY VALUE number-var
    BY REFERENCE OMITTED
    GIVING NULL
END-CALL

...

PROGRAM-ID. thing.
DATA DIVISION.
WORKING-STORAGE SECTION.
77 default-float usage float-long.

LINKAGE-SECTION.
77 string-var pic x(80).
77 number-var pic 9(8).
77 float-var usage float-long.

PROCEDURE DIVISION
    USING
        BY REFERENCE OPTIONAL string-var
        BY VALUE number-var
        BY REFERENCE OPTIONAL float-var
    RETURNING OMITTED.

IF float-var IS OMITTED
    SET ADDRESS OF float-var TO ADDRESS OF default-float
END-IF

DISPLAY "Tap Enter to continue"
ACCEPT OMITTED

SPECIAL-NAMES.
    SWITCH-1 IS mainframe
        ON STATUS IS bigiron
        OFF STATUS IS pc

...

>>DEFINE IS-BIG PARAMETER
>>IF IS-BIG IS DEFINED

SET mainframe TO ON

>>END-IF

USE FOR DEBUGGING ON ALL PROCEDURES

ADD 1 TO wafer-thin-mint
    ON SIZE ERROR
        SET get-a-bucket TO TRUE
END-ADD

table
       01 wordlist             based.
          05 word-table occurs 0 to maxwords times
              depending ON wordcount
              descending key is wordstr
              indexed by wl-index.
             10 wordstr        pic x(20).
             10 wordline       usage binary-long.

SELECT file-name-1
  ASSIGN TO "actual-name"
  SHARING WITH READ ONLY

OPEN INPUT SHARING WITH ALL OTHER infile
OPEN EXTEND SHARING WITH NO OTHER myfile

ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
    SELECT OPTIONAL nofile ASSIGN TO "file.not"
           ORGANIZATION IS LINE SEQUENTIAL.

...

DATA DIVISION.
LINKAGE SECTION.
77 arg PIC 99.

PROCEDURE DIVISION USING OPTIONAL arg

OPEN INPUT nofile
CLOSE nofile

IF arg IS OMITTED OR NOT NUMERIC
    MOVE 0 TO RETURN-CODE
ELSE
    MOVE arg TO RETURN-CODE
END-IF
GOBACK.

IDENTIFICATION DIVISION.
PROGRAM-ID. sample.

OPTIONS.
    ENTRY-CONVENTION IS EXTERN
    DEFAULT ROUNDED MODE IS NEAREST-EVEN.

IF A EQUAL 1 OR 2 OR 3 OR 5
    DISPLAY "FORE!"
END-IF

MOVE 1 to A
IF A NOT EQUAL 1 OR 2
    DISPLAY "NOT 1 OR 2 (unexpected?)"
END-IF

sort sort-work
    ascending key work-rec with duplicates in order
    using  sort-in
    giving sort-out.

GCobol*> Here be dragons <*
       EVALUATE TRUE
           WHEN a IS 1
               PERFORM paragraph-1
           WHEN OTHER
               ALTER paragraph-1 TO paragraph-2
               PERFORM paragraph-3
       END-EVALUATE

sort sort-work
    on descending key work-rec
    collating sequence is mixed
    input procedure is sort-transform
    output procedure is output-uppercase.

GCobol >>SOURCE FORMAT IS FIXED

       IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog.
       DATA             DIVISION.
       WORKING-STORAGE  SECTION.
       01 G-1.
         02 X-1         PIC 9(1) VALUE 1                 PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-2.
         02 X-2         PIC 9(2) VALUE 12                PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-3.
         02 X-3         PIC 9(3) VALUE 123               PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-4.
         02 X-4         PIC 9(4) VALUE 1234              PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-5.
         02 X-5         PIC 9(5) VALUE 12345             PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-6.
         02 X-6         PIC 9(6) VALUE 123456            PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-7.
         02 X-7         PIC 9(7) VALUE 1234567           PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-8.
         02 X-8         PIC 9(8) VALUE 12345678          PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-9.
         02 X-9         PIC 9(9) VALUE 123456789         PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-10.
         02 X-10        PIC 9(10) VALUE 1234567890       PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-11.
         02 X-11        PIC 9(11) VALUE 12345678901      PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-12.
         02 X-12        PIC 9(12) VALUE 123456789012     PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-13.
         02 X-13        PIC 9(13) VALUE 1234567890123    PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-14.
         02 X-14        PIC 9(14) VALUE 12345678901234   PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-15.
         02 X-15        PIC 9(15) VALUE 123456789012345  PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-16.
         02 X-16        PIC 9(16) VALUE 1234567890123456 PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-17.
         02 X-17        PIC 9(17) VALUE 12345678901234567
                                                         PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-18.
         02 X-18        PIC 9(18) VALUE 123456789012345678
                                                         PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S1.
         02 X-S1        PIC S9(1) VALUE -1               PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S2.
         02 X-S2        PIC S9(2) VALUE -12              PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S3.
         02 X-S3        PIC S9(3) VALUE -123             PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S4.
         02 X-S4        PIC S9(4) VALUE -1234            PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S5.
         02 X-S5        PIC S9(5) VALUE -12345           PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S6.
         02 X-S6        PIC S9(6) VALUE -123456          PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S7.
         02 X-S7        PIC S9(7) VALUE -1234567         PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S8.
         02 X-S8        PIC S9(8) VALUE -12345678        PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S9.
         02 X-S9        PIC S9(9) VALUE -123456789       PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S10.
         02 X-S10       PIC S9(10) VALUE -1234567890     PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S11.
         02 X-S11       PIC S9(11) VALUE -12345678901    PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S12.
         02 X-S12       PIC S9(12) VALUE -123456789012   PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S13.
         02 X-S13       PIC S9(13) VALUE -1234567890123  PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S14.
         02 X-S14       PIC S9(14) VALUE -12345678901234 PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S15.
         02 X-S15       PIC S9(15) VALUE -123456789012345
                                                         PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S16.
         02 X-S16       PIC S9(16) VALUE -1234567890123456
                                                         PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S17.
         02 X-S17       PIC S9(17) VALUE -12345678901234567
                                                         PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.
       01 G-S18.
         02 X-S18       PIC S9(18) VALUE -123456789012345678
                                                         PACKED-DECIMAL.
         02 FILLER      PIC X(18) VALUE SPACE.

       PROCEDURE        DIVISION.
      *>   Dump all values <*
           DISPLAY
               "PACKED-DECIMAL, 1, 12, 123,"
           END-DISPLAY
           DISPLAY
               " ..., 123456789012345678"
           END-DISPLAY
           CALL "dump" USING G-1 END-CALL.
           CALL "dump" USING G-2 END-CALL.
           CALL "dump" USING G-3 END-CALL.
           CALL "dump" USING G-4 END-CALL.
           CALL "dump" USING G-5 END-CALL.
           CALL "dump" USING G-6 END-CALL.
           CALL "dump" USING G-7 END-CALL.
           CALL "dump" USING G-8 END-CALL.
           CALL "dump" USING G-9 END-CALL.
           CALL "dump" USING G-10 END-CALL.
           CALL "dump" USING G-11 END-CALL.
           CALL "dump" USING G-12 END-CALL.
           CALL "dump" USING G-13 END-CALL.
           CALL "dump" USING G-14 END-CALL.
           CALL "dump" USING G-15 END-CALL.
           CALL "dump" USING G-16 END-CALL.
           CALL "dump" USING G-17 END-CALL.
           CALL "dump" USING G-18 END-CALL.

           DISPLAY SPACE END-DISPLAY
           DISPLAY
               "PACKED-DECIMAL, -1, -12, -123,"
           END-DISPLAY
           DISPLAY
               " ..., -123456789012345678"
           END-DISPLAY
           CALL "dump" USING G-S1 END-CALL.
           CALL "dump" USING G-S2 END-CALL.
           CALL "dump" USING G-S3 END-CALL.
           CALL "dump" USING G-S4 END-CALL.
           CALL "dump" USING G-S5 END-CALL.
           CALL "dump" USING G-S6 END-CALL.
           CALL "dump" USING G-S7 END-CALL.
           CALL "dump" USING G-S8 END-CALL.
           CALL "dump" USING G-S9 END-CALL.
           CALL "dump" USING G-S10 END-CALL.
           CALL "dump" USING G-S11 END-CALL.
           CALL "dump" USING G-S12 END-CALL.
           CALL "dump" USING G-S13 END-CALL.
           CALL "dump" USING G-S14 END-CALL.
           CALL "dump" USING G-S15 END-CALL.
           CALL "dump" USING G-S16 END-CALL.
           CALL "dump" USING G-S17 END-CALL.
           CALL "dump" USING G-S18 END-CALL.

           DISPLAY SPACE END-DISPLAY.
           DISPLAY
               "PACKED-DECIMAL, 1, 12, 123,"
           END-DISPLAY.
           DISPLAY
               " ..., 123456789012345678"
               " after subfield INITIALIZE"
           END-DISPLAY.
           INITIALIZE X-1 ALL TO VALUE.
           CALL "dump" USING G-1 END-CALL.
           INITIALIZE X-2 ALL TO VALUE.
           CALL "dump" USING G-2 END-CALL.
           INITIALIZE X-3 ALL TO VALUE.
           CALL "dump" USING G-3 END-CALL.
           INITIALIZE X-4 ALL TO VALUE.
           CALL "dump" USING G-4 END-CALL.
           INITIALIZE X-5 ALL TO VALUE.
           CALL "dump" USING G-5 END-CALL.
           INITIALIZE X-6 ALL TO VALUE.
           CALL "dump" USING G-6 END-CALL.
           INITIALIZE X-7 ALL TO VALUE.
           CALL "dump" USING G-7 END-CALL.
           INITIALIZE X-8 ALL TO VALUE.
           CALL "dump" USING G-8 END-CALL.
           INITIALIZE X-9 ALL TO VALUE.
           CALL "dump" USING G-9 END-CALL.
           INITIALIZE X-10 ALL TO VALUE.
           CALL "dump" USING G-10 END-CALL.
           INITIALIZE X-11 ALL TO VALUE.
           CALL "dump" USING G-11 END-CALL.
           INITIALIZE X-12 ALL TO VALUE.
           CALL "dump" USING G-12 END-CALL.
           INITIALIZE X-13 ALL TO VALUE.
           CALL "dump" USING G-13 END-CALL.
           INITIALIZE X-14 ALL TO VALUE.
           CALL "dump" USING G-14 END-CALL.
           INITIALIZE X-15 ALL TO VALUE.
           CALL "dump" USING G-15 END-CALL.
           INITIALIZE X-16 ALL TO VALUE.
           CALL "dump" USING G-16 END-CALL.
           INITIALIZE X-17 ALL TO VALUE.
           CALL "dump" USING G-17 END-CALL.
           INITIALIZE X-18 ALL TO VALUE.
           CALL "dump" USING G-18 END-CALL.

           DISPLAY SPACE END-DISPLAY.
           DISPLAY
               "PACKED-DECIMAL, -1, -12, -123,"
           END-DISPLAY.
           DISPLAY
               " ..., -123456789012345678"
               " after subfield INITIALIZE"
           END-DISPLAY.
           INITIALIZE X-S1 ALL TO VALUE.
           CALL "dump" USING G-S1 END-CALL.
           INITIALIZE X-S2 ALL TO VALUE.
           CALL "dump" USING G-S2 END-CALL.
           INITIALIZE X-S3 ALL TO VALUE.
           CALL "dump" USING G-S3 END-CALL.
           INITIALIZE X-S4 ALL TO VALUE.
           CALL "dump" USING G-S4 END-CALL.
           INITIALIZE X-S5 ALL TO VALUE.
           CALL "dump" USING G-S5 END-CALL.
           INITIALIZE X-S6 ALL TO VALUE.
           CALL "dump" USING G-S6 END-CALL.
           INITIALIZE X-S7 ALL TO VALUE.
           CALL "dump" USING G-S7 END-CALL.
           INITIALIZE X-S8 ALL TO VALUE.
           CALL "dump" USING G-S8 END-CALL.
           INITIALIZE X-S9 ALL TO VALUE.
           CALL "dump" USING G-S9 END-CALL.
           INITIALIZE X-S10 ALL TO VALUE.
           CALL "dump" USING G-S10 END-CALL.
           INITIALIZE X-S11 ALL TO VALUE.
           CALL "dump" USING G-S11 END-CALL.
           INITIALIZE X-S12 ALL TO VALUE.
           CALL "dump" USING G-S12 END-CALL.
           INITIALIZE X-S13 ALL TO VALUE.
           CALL "dump" USING G-S13 END-CALL.
           INITIALIZE X-S14 ALL TO VALUE.
           CALL "dump" USING G-S14 END-CALL.
           INITIALIZE X-S15 ALL TO VALUE.
           CALL "dump" USING G-S15 END-CALL.
           INITIALIZE X-S16 ALL TO VALUE.
           CALL "dump" USING G-S16 END-CALL.
           INITIALIZE X-S17 ALL TO VALUE.
           CALL "dump" USING G-S17 END-CALL.
           INITIALIZE X-S18 ALL TO VALUE.
           CALL "dump" USING G-S18 END-CALL.

           DISPLAY SPACE END-DISPLAY.
           DISPLAY
               "PACKED-DECIMAL, 1, 12, 123,"
           END-DISPLAY.
           DISPLAY
               " ..., 123456789012345678"
               " after subfield ZERO"
           END-DISPLAY.
           MOVE ZERO TO X-1.
           CALL "dump" USING G-1 END-CALL.
           MOVE ZERO TO X-2.
           CALL "dump" USING G-2 END-CALL.
           MOVE ZERO TO X-3.
           CALL "dump" USING G-3 END-CALL.
           MOVE ZERO TO X-4.
           CALL "dump" USING G-4 END-CALL.
           MOVE ZERO TO X-5.
           CALL "dump" USING G-5 END-CALL.
           MOVE ZERO TO X-6.
           CALL "dump" USING G-6 END-CALL.
           MOVE ZERO TO X-7.
           CALL "dump" USING G-7 END-CALL.
           MOVE ZERO TO X-8.
           CALL "dump" USING G-8 END-CALL.
           MOVE ZERO TO X-9.
           CALL "dump" USING G-9 END-CALL.
           MOVE ZERO TO X-10.
           CALL "dump" USING G-10 END-CALL.
           MOVE ZERO TO X-11.
           CALL "dump" USING G-11 END-CALL.
           MOVE ZERO TO X-12.
           CALL "dump" USING G-12 END-CALL.
           MOVE ZERO TO X-13.
           CALL "dump" USING G-13 END-CALL.
           MOVE ZERO TO X-14.
           CALL "dump" USING G-14 END-CALL.
           MOVE ZERO TO X-15.
           CALL "dump" USING G-15 END-CALL.
           MOVE ZERO TO X-16.
           CALL "dump" USING G-16 END-CALL.
           MOVE ZERO TO X-17.
           CALL "dump" USING G-17 END-CALL.
           MOVE ZERO TO X-18.
           CALL "dump" USING G-18 END-CALL.

           DISPLAY SPACE END-DISPLAY.
           DISPLAY
               "PACKED-DECIMAL, -1, -12, -123,"
           END-DISPLAY.
           DISPLAY
               " ..., -123456789012345678"
               " after subfield ZERO"
           END-DISPLAY.
           MOVE ZERO TO X-S1.
           CALL "dump" USING G-S1 END-CALL.
           MOVE ZERO TO X-S2.
           CALL "dump" USING G-S2 END-CALL.
           MOVE ZERO TO X-S3.
           CALL "dump" USING G-S3 END-CALL.
           MOVE ZERO TO X-S4.
           CALL "dump" USING G-S4 END-CALL.
           MOVE ZERO TO X-S5.
           CALL "dump" USING G-S5 END-CALL.
           MOVE ZERO TO X-S6.
           CALL "dump" USING G-S6 END-CALL.
           MOVE ZERO TO X-S7.
           CALL "dump" USING G-S7 END-CALL.
           MOVE ZERO TO X-S8.
           CALL "dump" USING G-S8 END-CALL.
           MOVE ZERO TO X-S9.
           CALL "dump" USING G-S9 END-CALL.
           MOVE ZERO TO X-S10.
           CALL "dump" USING G-S10 END-CALL.
           MOVE ZERO TO X-S11.
           CALL "dump" USING G-S11 END-CALL.
           MOVE ZERO TO X-S12.
           CALL "dump" USING G-S12 END-CALL.
           MOVE ZERO TO X-S13.
           CALL "dump" USING G-S13 END-CALL.
           MOVE ZERO TO X-S14.
           CALL "dump" USING G-S14 END-CALL.
           MOVE ZERO TO X-S15.
           CALL "dump" USING G-S15 END-CALL.
           MOVE ZERO TO X-S16.
           CALL "dump" USING G-S16 END-CALL.
           MOVE ZERO TO X-S17.
           CALL "dump" USING G-S17 END-CALL.
           MOVE ZERO TO X-S18.
           CALL "dump" USING G-S18 END-CALL.
           STOP RUN.

#include <stdio.h>
#ifdef  __INTEL_COMPILER
#pragma warning ( disable : 1419 )
#endif
int dump (unsigned char *data);
int dump (unsigned char *data)
{
  int i;
  for (i = 0; i < 10; i++)
    printf ("%02x", data[i]);
  puts ("");
  return 0;
}
/**/

$ cobc -x packed-decimal.cob dump.c
$ ./packed-decimal
PACKED-DECIMAL, 1, 12, 123,
 ..., 123456789012345678
1f202020202020202020
012f2020202020202020
123f2020202020202020
01234f20202020202020
12345f20202020202020
0123456f202020202020
1234567f202020202020
012345678f2020202020
123456789f2020202020
01234567890f20202020
12345678901f20202020
0123456789012f202020
1234567890123f202020
012345678901234f2020
123456789012345f2020
01234567890123456f20
12345678901234567f20
0123456789012345678f

PACKED-DECIMAL, -1, -12, -123,
 ..., -123456789012345678
1d202020202020202020
012d2020202020202020
123d2020202020202020
01234d20202020202020
12345d20202020202020
0123456d202020202020
1234567d202020202020
012345678d2020202020
123456789d2020202020
01234567890d20202020
12345678901d20202020
0123456789012d202020
1234567890123d202020
012345678901234d2020
123456789012345d2020
01234567890123456d20
12345678901234567d20
0123456789012345678d

PACKED-DECIMAL, 1, 12, 123,
 ..., 123456789012345678 after subfield INITIALIZE
1f202020202020202020
012f2020202020202020
123f2020202020202020
01234f20202020202020
12345f20202020202020
0123456f202020202020
1234567f202020202020
012345678f2020202020
123456789f2020202020
01234567890f20202020
12345678901f20202020
0123456789012f202020
1234567890123f202020
012345678901234f2020
123456789012345f2020
01234567890123456f20
12345678901234567f20
0123456789012345678f

PACKED-DECIMAL, -1, -12, -123,
 ..., -123456789012345678 after subfield INITIALIZE
1d202020202020202020
012d2020202020202020
123d2020202020202020
01234d20202020202020
12345d20202020202020
0123456d202020202020
1234567d202020202020
012345678d2020202020
123456789d2020202020
01234567890d20202020
12345678901d20202020
0123456789012d202020
1234567890123d202020
012345678901234d2020
123456789012345d2020
01234567890123456d20
12345678901234567d20
0123456789012345678d

PACKED-DECIMAL, 1, 12, 123,
 ..., 123456789012345678 after subfield ZERO
0f202020202020202020
000f2020202020202020
000f2020202020202020
00000f20202020202020
00000f20202020202020
0000000f202020202020
0000000f202020202020
000000000f2020202020
000000000f2020202020
00000000000f20202020
00000000000f20202020
0000000000000f202020
0000000000000f202020
000000000000000f2020
000000000000000f2020
00000000000000000f20
00000000000000000f20
0000000000000000000f

PACKED-DECIMAL, -1, -12, -123,
 ..., -123456789012345678 after subfield ZERO
0c202020202020202020
000c2020202020202020
000c2020202020202020
00000c20202020202020
00000c20202020202020
0000000c202020202020
0000000c202020202020
000000000c2020202020
000000000c2020202020
00000000000c20202020
00000000000c20202020
0000000000000c202020
0000000000000c202020
000000000000000c2020
000000000000000c2020
00000000000000000c20
00000000000000000c20
0000000000000000000c

ORGANIZATION IS LINE SEQUENTIAL PADDING CHARACTER IS '*'

WRITE theline AFTER ADVANCING PAGE

PAGE LIMITS ARE 66 LINES 132 COLUMNS
    HEADING iS 4 FIRST DETAIL IS 6
    LAST CONTROL HEADING IS 58
    LAST DETAIL IS 60
    FOOTING IS 62

NAMED-PARAGRAPH.
    PERFORM FOREVER
        IF solution
            EXIT PARAGRAPH
        END-IF
        PERFORM solve-the-puzzle.
    END-PERFORM.

beginning.
    PERFORM FOREVER
        PERFORM miracles
    END-PERFORM
    GOBACK.

miracles.
    DISPLAY wonders

+, -, A, B, N, X, Z, "*", 'CR', 'DB', E, S, V, ".", ",", P, currency symbol

A    A character position for ALPHABETIC or SPACE
B    A blank insertion
E    Marks the start of an exponent for floating point values
N    A NATIONAL character position
P    An assumed decimal scaling postion
S    An indicator of the presence of an operational sign
V    An indicator of the location of an assumed decimcal point
X    A character position for any character
Z    A leading numeric character, space when zero
9    A character position for digits
0    A zero insertion
/    A slash insertion
,    A comma insertion
.    An editing symbol for decimal point alignment, and a period insertion
+    A sign control symbol
-    A sign control symbol
CR   A sign control pair, displayed when value negative
DB   A sign control pair, displayed when value negative
*    A cheque protection symbol, leading zeroes replaced by asterisk

Symbols are case insensitive.  CR, cr, Cr, cR are equivalent for example.

PICTURE clauses can also contain a valid currency picture, (default is
dollar sign) defined in the configuration section, special-names
paragraph. For example:

CURRENCY SIGN IS "CAD" PICTURE SYMBOL "c"
CURRENCY SIGN IS "CLP" PICTURE SYMBOL "C"

Currency sign picture symbols are case sensitive.  Currency picture
symbols are limited in that they cannot override the other predefined
symbols or some COBOL syntax symbols.

*>>source format is free
*> ********************************************************************
*> Author:    jrls (John Ellis)
*> Date:      Oct-2008
*> Purpose:   formated output examples using pic strings.
*> ********************************************************************

identification division.
program-id. picstring.
data division.
working-storage section.
*><*

01  header.
    05  filler          pic xxx  value "ln".
    05  filler          pic x(11) value "    disp1".
    05  filler          pic x(11) value "    disp2".
    05  filler          pic x(11) value "    disp3".
    05  filler          pic x(11) value "    disp4".
    05  filler          pic x(12) value "    disp5".
    05  filler          pic x(9)  value "   an1".
    05  filler          pic x(14) value "      phone".
    05  filler          pic x(10) value "   date".
*><*
01  headerLines         pic x(90) value all "-".
*><*
01  displayformats.
    05  linenum         pic 99  value 1.
    05  disp1           pic zzz,zz9.99 value zero.
    05  filler          pic x value spaces.
    05  disp2           pic $zz,zz9.99 value zero.
    05  filler          pic x value spaces.
    05  disp3           pic ---,--9.99 value zero.
    05  filler          pic x value spaces.
    05  disp4           pic $-z,zz9.99 value zero.
    05  filler          pic x value spaces.
    05  disp5           pic -zz,zz9.zz- blank  zero value zero.
    05  filler          pic x value spaces.
*><*an1 is actually a string field because of the embedded blanks,
*><* thus you put value spaces.
    05  an1             pic 99b99b99    value spaces.
    05  filler          pic x value spaces.
    05  phone           pic bxxxbxxxbxxxx value spaces.
    05  filler          pic x value spaces.
    05  dispdate        pic 99/99/9999  value zero.
*><*

procedure division.
0000-start.
*><*
    display headerLines.
    display header.
    display headerLines.
*><****************************************************
    move 220.22         to disp1,
                           disp2.
    move -220.22        to disp3,
                           disp4,
                           disp5.

    inspect disp5 replacing first "-" by "(",
                            first "-" by ")".

    move 10122008       to dispdate.
*><****************************************************
*><*Please note the results of moving 'abcd' to an1.
*><*an1 will show up as 00 00 00 because alpha data was
*><*moved into instead of numeric data.
*><*
*><*The phone field will display " abc def ghij" because
*><*'b' in the pic string.
*><****************************************************
    move "abcd"         to an1.
    move "abcdefghij"   to phone.

    display displayformats.

    add 1               to linenum.
    move zero           to disp4,
                           disp5.
*><****************************************************
*><*Here after moving data to an1 and phone, I use the
*><*inspect statement to replace the blanks.
*><****************************************************
    move "123456"       to an1.
    move "5555551234"   to phone.

    inspect an1 replacing all " " by "-".

    inspect phone replacing first " " by "(",
                            first " " by ")",
                            first " " by "-".

    display displayformats.

    inspect phone converting "23456789" to "adgjmptw".
    display phone.

    perform 0010-endProgram.
*><*
0010-endProgram.
    stop run.
*><*

-------------------------------------------------------------------------------------
ln     disp1     disp2    disp3      disp4     disp5      an1         phone      date
-------------------------------------------------------------------------------------
01    220.22   $220.22  -220.22   $-220.22   (220.22) 00 00 00  abc def ghij 10/12/2008
02    220.22   $220.22  -220.22     $ 0.00            12-34-56 (555)555-1234 10/12/2008
(jjj)jjj-1adg

01 show-value     PIC zzz,zzz,999.

move 1 to show-value
display ":" show-value ":"

move 123 to show-value
display ":" show-value ":"

move 123456 to show-value
display ":" show-value ":"

move 123456789 to show-value
display ":" show-value ":"

:        001:
:        123:
:    123,456:
:123,456,789:

01 show-value     PIC ***,***,999.

:********001:
:********123:
:****123,456:
:123,456,789:

01 show-value     PIC $$$,$$$,$$9.

:         $1:
:       $123:
:   $123,456:
:$23,456,789:

01 show-value     PIC $$$$,$$$,$$9.99.

move 123456789.50 to show-value
display ":" show-value ":"

:          $1.50:
:        $123.50:
:    $123,456.50:
:$123,456,789.50:

01 big-value pic $$$$,$$$,$$$,$$$,$$$,$$$,$$$,$$$,$$$,$$$,$$9.99.

:                                          $1.50:
:                                        $123.50:
:                                    $123,456.50:
:                                $123,456,789.50:
:                          $1,550,057,000,000.00:

01 form-1 AUTO.
   05 LINE 01 COLUMN 01 VALUE "Form!".
   05 LINE PLUS 3 COLUMN 01 VALUE value-4.
   05 LINE PLUS 3 COLUMN 10 VALUE value-5.

01  c-handle        USAGE IS POINTER.

CALL "open-lib" RETURNING c-handle
    ON EXCEPTION
        DISPLAY "Can't link open-lib"
        STOP RUN RETURNING 1
END-CALL
IF c-handle EQUAL NULL
    DISPLAY "Can't open-lib"
    STOP RUN RETURNING 1
END-IF

CALL "use-lib" USING BY VALUE c-handle BY CONTENT "Hello" & x"00"
CALL "close-lib" USING BY VALUE c-handle

*> Interfacing with the C ABI includes a little bit of voodoo.
*> Pass a REFERENCE or use RETURNING if C sets the value. Use
*>   VALUE when you want C to have its view of the pointer, not
*>   the REFERENCE address of the COBOL POINTER.  So most inits
*>   are BY REFERENCE (or RETURNING) and most usage, including
*>   rundown of C ABI tools, is usually USING BY VALUE.
*>

data   01 perl-pointer usage pointer.
       01 perl-char    pic x based.
       01 next-char    pic x based.

code   set address of perl-char to perl-pointer
       perform until perl-char equal x"00"
           set perl-pointer up by 1
           set address of next-char to perl-pointer

           if next-char not equal x"00" then
               display perl-char with no advancing
           else
               display perl-char
           end-if

           set address of perl-char to perl-pointer
       end-perform

MULTIPLE FILE TAPE CONTAINS file-1 POSITION 1 file-2 POSITION 80

IF amount IS POSITIVE
    DISPLAY "Not broke yet"
END-IF

05 field PIC X(16) PRESENT WHEN sum > 0.

READ file-1 PREVIOUS RECORD

SPECIAL-NAMES.
    PRINTER IS myprint

DISPLAY "test" UPON PRINTER

export COBPRINTER='cat >>printfile.txt'

export COB_DISPLAY_FILE='printfile.txt'

01 callback-handler USAGE PROCEDURE-POINTER.

SET callback-handler TO ENTRY "react-to-click"
CALL "register-event" USING
    BY VALUE object-handle
    BY CONTENT z"onclick"
    BY VALUE callback-handler
END-CALL

USE FOR DEBUGGING ON ALL PROCEDURES

ALTER paragraph-1 TO PROCEED TO paragraph-x

EXIT PROGRAM.

77 callback USAGE PROGRAM-POINTER.
...
SET callback TO ENTRY a-program-id
CALL callback
    on exception "no linkage to callback" upon syserr
END-CALL

COMPUTE var ROUNDED MODE IS PROHIBITED = 1.1 END-COMPUTE

ACCEPT unexpected-rounding FROM EXCEPTION STATUS END-ACCEPT

GCobol
       identification division.
       program-id. SAMPLE.

       data division.
       working-storage section.
       01 unexpected-round   pic 9(4).
       01 delicate-value     pic 99v99.

       procedure division.

      *> No SIZE conditional, will set an exception status
       compute
           delicate-value rounded mode is prohibited = 1.177
       accept unexpected-round from exception status
       display delicate-value ", " unexpected-round

      *> SIZE conditional, but rounding allowed, no exception raised
       compute
           delicate-value rounded = 1.177
           on size error
               display "size error: " with no advancing
       end-compute
       accept unexpected-round from exception status
       display delicate-value ", " unexpected-round

      *> SIZE conditional, but allowed with assumed
      *>  ROUNDED MODE IS NEAREST-AWAY-FROM-ZERO
       compute
           delicate-value = 1.175 + 1.946
           on size error
               display "size error: " with no advancing
       end-compute
       accept unexpected-round from exception status
       display delicate-value ", " unexpected-round

      *> trigger a SIZE conditional, set the exception code
       compute
           delicate-value rounded mode is prohibited = 1.175 + 1.946
           on size error
               display "size error: " with no advancing
       end-compute
       accept unexpected-round from exception status
       display delicate-value ", " unexpected-round

       goback.
       end program SAMPLE.

01.17, 4101
01.18, 0000
03.12, 0000
size error: 03.12, 4101

PROMPT IS ':'

ACCEPT variable-1
   LINE <line> COLUMN <column>
   WITH
      AUTO-SKIP | AUTO
      [PROTECTED] SIZE [IS] variable-2 | literal-2
END-ACCEPT

DISPLAY QUOTE 123 QUOTE

"123"

01 var PICTURE X(4).

MOVE ALL QUOTES TO var
DISPLAY var

""""

DATA DIVISION.
REPORT SECTION.
RD report-1
    PAGE LIMIT IS 66 LINES.

READ infile PREVIOUS RECORD INTO back-record
   AT END
       SET attop TO TRUE
   NOT AT END
       PERFORM cursor-calculator
END-READ

identification division.
program-id. tracing.

data division.
working-storage section.
01 indicator pic 9.

procedure division.
move 1 to indicator
READY TRACE
perform until indicator > 5
    display "traced line: " indicator
    add 1 to indicator
end-perform
RESET TRACE
display "not traced"
goback.
end program tracing.

prompt$ cobc -x tracing.cob
prompt$ ./tracing
traced line: 1
traced line: 2
traced line: 3
traced line: 4
traced line: 5
not traced

prompt$ cobc -x -debug tracing.cob
prompt$ ./tracing
Source :    'tracing.cob'
Program-Id: tracing          Statement: PERFORM                Line: 11
Program-Id: tracing          Statement: DISPLAY                Line: 12
traced line: 1
Program-Id: tracing          Statement: ADD                    Line: 13
Program-Id: tracing          Statement: DISPLAY                Line: 12
traced line: 2
Program-Id: tracing          Statement: ADD                    Line: 13
Program-Id: tracing          Statement: DISPLAY                Line: 12
traced line: 3
Program-Id: tracing          Statement: ADD                    Line: 13
Program-Id: tracing          Statement: DISPLAY                Line: 12
traced line: 4
Program-Id: tracing          Statement: ADD                    Line: 13
Program-Id: tracing          Statement: DISPLAY                Line: 12
traced line: 5
Program-Id: tracing          Statement: ADD                    Line: 13
Program-Id: tracing          Statement: RESET TRACE            Line: 15
not traced

FD file
    RECORD IS VARYING IN SIZE FROM 1 TO 80 CHARACTERS
        DEPENDING ON size-field

SELECT file
    ASSIGN TO filename
    ACCESS MODE IS RANDOM
    RECORD KEY IS key-field
    ALTERNATE KEY IS alt-key WITH DUPLICATES.

READ infile NEXT RECORD INTO display-rec END-READ

FD file
    RECORD IS VARYING IN SIZE FROM 1 TO 80 CHARACTERS
        DEPENDING ON size-field
    RECORDING MODE IS F.

UNLOCK file-1s RECORDS

PROGRAM-ID nextbigthing IS RECURSIVE.

IDENTIFICATION   DIVISION.
PROGRAM-ID.      prog.
DATA             DIVISION.
WORKING-STORAGE  SECTION.
01 ALONE         PIC X.
01 G             REDEFINES ALONE.
  02 A           PIC X.
  02 B           REDEFINES A PIC 9.
PROCEDURE        DIVISION.
    STOP RUN.

CLOSE file REEL FOR REMOVAL

BY REFERENCE
BY CONTENT
BY VALUE

USE FOR DEBUGGING ON ALL REFERENCES TO some-field.

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20110806
      *> Purpose:   RELATIVE file organization
      *> Tectonics: cobc -g -debug -W -x relatives.cob
      *> ***************************************************************
       identification division.
       program-id. relatives.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       input-output section.
       file-control.
           select optional relatives
               assign to "relatives.dat"
               file status is filestatus
               organization is relative
               access mode is dynamic
               relative key is nicknum.

       data division.
       file section.
       fd relatives.
          01 person.
             05 firstname      pic x(48).
             05 lastname       pic x(64).
             05 relationship   pic x(32).

       working-storage section.
       77 filestatus pic 9(2).
          88 ineof value 1 when set to false is 0.

       77 satisfaction pic 9.
          88 satisfied value 1 when set to false is 0.

       77 nicknum   pic 9(2).

       77 title-line pic x(34).
          88 writing-names value "Adding, Overwriting.  00 to finish".
          88 reading-names value "Which record?         00 to quit".
       77 problem   pic x(80).

       screen section.
       01 detail-screen.
          05           line 1 column 1  from title-line erase eos.
          05           line 2 column 1  value "Record: ".
          05 pic 9(2)  line 2 column 16 using nicknum.
          05           line 3 column 1  value "First name: ".
          05 pic x(48) line 3 column 16 using firstname.
          05           line 4 column 1  value "Last name: ".
          05 pic x(64) line 4 column 16 using lastname.
          05           line 5 column 1  value "Relation: ".
          05 pic x(32) line 5 column 16 using relationship.
          05 pic x(80) line 6 column 1  from problem.

       01 show-screen.
          05           line 1 column 1  from title-line erase eos.
          05           line 2 column 1  value "Record: ".
          05 pic 9(2)  line 2 column 16 using nicknum.
          05           line 3 column 1  value "First name: ".
          05 pic x(48) line 3 column 16 from firstname.
          05           line 4 column 1  value "Last name: ".
          05 pic x(64) line 4 column 16 from lastname.
          05           line 5 column 1  value "Relation: ".
          05 pic x(32) line 5 column 16 from relationship.
          05 pic x(80) line 6 column 1  from problem.

      *> -*********-*********-*********-*********-*********-*********-**
       procedure division.
       beginning.

      *> Open the file and find the highest record number
      *> which is a sequential read operation after START
           open input relatives

           move 99 to nicknum
           start relatives key is less than or equal to nicknum
               invalid key
                   move concatenate('NO START' space filestatus)
                     to problem
                   move 00 to nicknum
               not invalid key
                   read relatives next end-read
           end-start

      *> Close and open for i-o
           close relatives
           open i-o relatives

      *> Prompt for numbers and names to add until 00
           set writing-names to true
           set satisfied to false
           perform fill-file through fill-file-end
               until satisfied

           close relatives

      *> Prompt for numbers to view names of until 00
           open input relatives

           set reading-names to true
           set satisfied to false
           perform record-request through record-request-end
               until satisfied

           perform close-shop
       .
       ending.
           goback.

      *> get some user data to add
       fill-file.
           display detail-screen.
           accept detail-screen.
           move spaces to problem
           if nicknum equal 0
               set satisfied to true
               go to fill-file-end
           end-if.
       .
       write-file.
           write person
               invalid key
                   move concatenate("overwriting: " nicknum) to problem
                   rewrite person
                       invalid key
                           move concatenate(
                               exception-location() space nicknum
                               space filestatus)
                           to problem
                   end-rewrite
           end-write.
           display detail-screen

       .
       fill-file-end.
       .

      *> get keys to display
       record-request.
           display show-screen
           accept show-screen
           move spaces to problem
           if nicknum equals 0
               set satisfied to true
               go to record-request-end
           end-if
       .

      *> The magic of relative record number reads
       read-relation.
           read relatives
               invalid key
                   move exception-location() to problem
               not invalid key
                   move spaces to problem
           end-read
           display show-screen
       .

       record-request-end.
       .

      *> get out <*
       close-shop.
           close relatives.
           goback.
       .
       end program relatives.

Adding, Overwriting.  00 to finish
Record:        04
First name:    Brad____________________________________________
Last name:     Tiffin__________________________________________________________
Relation:      brother_________________________

Which record?         00 to quit
Record:        03
First name:    Brian
Last name:     Tiffin
Relation:

RELEASE record-1 FROM identifier-1

DIVIDE
    hex-val BY 16 GIVING left-nibble REMAINDER right-nibble
END-DIVIDE

CLOSE filename-1 REEL FOR REMOVAL

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20110606
      *> Purpose:   Demonstration of 66-level datanames
      *> Tectonics: cobc
      *> ***************************************************************
       identification division.
       program-id. sixtysix.

       data division.
       working-storage section.
       01 master.
          05 field-1 pic s9(9).
          05 field-2 pic x(16).
          05 field-3 pic x(4).
          05 field-4 pic s9(9).
       66 sixtysix renames field-2.
       66 group-66 renames field-2 through field-4.

      *> ***************************************************************
       procedure division.
       move -66 to field-1
       move "sixtysix" to field-2
       move "ABCD" to field-3
       multiply field-1 by -1 giving field-4
       display "master  : " master
       display "field-1 : " field-1
       display "sixtysix: " sixtysix
       display "group-66: " group-66

       goback.
       end program sixtysix.

$ ./sixtysix
master  : 00000006vsixtysix        ABCD000000066
field-1 : -000000066
sixtysix: sixtysix
group-66: sixtysix        ABCD000000066

REPLACE ==MARKER== BY ==DISPLAY "REPLACE EXAMPLE" END-DISPLAY==.
identification division.
program-id. prog.

procedure division.
MARKER
goback.
end program prog.

# 1 "replacing.cob"

 identification division.
 program-id. prog.

 procedure division.
 DISPLAY "REPLACE EXAMPLE" END-DISPLAY
 goback.
 end program prog.

REPLACE OFF.
REPLACE LAST OFF.
REPLACE ALSO ==partial-text== BY ==partial-replacement==.

COPY "copy.inc"
    REPLACING LEADING  ==TEST== BY ==FIRST==
              TRAILING ==NORM== BY ==SECOND==.

000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. RWEX06.
000300 AUTHOR. JAY MOSELEY.
000400 DATE-WRITTEN. APRIL, 2008.
000410* ************************************************************* *
000412* * MODIFICATIONS:                                              *
000414* * CORRECT PARAGRAPH NAME AND GO TO CODING ERRORS.             *
000416* ************************************************************* *
000500 DATE-COMPILED.
000600
000700* ************************************************************* *
000800* REPORT WRITER EXAMPLE #6.                                     *
000900* ************************************************************* *
001000
001100 ENVIRONMENT DIVISION.
001200 CONFIGURATION SECTION.
001300 SOURCE-COMPUTER. IBM-370.
001400 OBJECT-COMPUTER. IBM-370.
001500
001600 INPUT-OUTPUT SECTION.
001700 FILE-CONTROL.
001800
001900     SELECT PAYROLL-REGISTER-DATA
002000         ASSIGN TO EXTERNAL DATAIN
002005                   ORGANIZATION IS LINE SEQUENTIAL.
002100
002200     SELECT REPORT-FILE
002300         ASSIGN TO EXTERNAL LINE ADVANCING SYSPRINT.
002400
002500 DATA DIVISION.
002600 FILE SECTION.
002700
002800 FD  PAYROLL-REGISTER-DATA
002900     LABEL RECORDS ARE OMITTED
003000     BLOCK CONTAINS 0 RECORDS
003100     RECORD CONTAINS 80 CHARACTERS
003200     DATA RECORD IS PAYROLL-REGISTER-RECORD.
003300
003400 01  PAYROLL-REGISTER-RECORD.
003500     03  PRR-DEPARTMENT-NUMBER   PIC 9(02).
003600     03  FILLER                  PIC X(01).
003700     03  PRR-EMPLOYEE-KEY.
003800         05  PRR-EMPLOYEE-NO     PIC 9(04).
003900         05  FILLER              PIC X(01).
004000         05  PRR-GENDER          PIC X(01).
004100         05  FILLER              PIC X(01).
004200         05  PRR-EMPLOYEE-NAME   PIC X(20).
004300     03  FILLER                  PIC X(01).
004400     03  PRR-PAY-DATE            PIC 9(08).
004500     03  FILLER                  REDEFINES PRR-PAY-DATE.
004600         05  PRR-PAY-DATE-YEAR   PIC 9(04).
004700         05  PRR-PAY-DATE-MONTH  PIC 9(02).
004800         05  PRR-PAY-DATE-DAY    PIC 9(02).
004900     03  FILLER                  PIC X(01).
005000     03  PRR-GROSS-PAY           PIC 9(04)V99.
005100     03  FILLER                  PIC X(01).
005200     03  PRR-FICA-WH             PIC 9(03)V99.
005300     03  FILLER                  PIC X(01).
005400     03  PRR-FED-WH              PIC 9(03)V99.
005500     03  FILLER                  PIC X(01).
005600     03  PRR-MISC-DED            PIC 9(03)V99.
005700     03  FILLER                  PIC X(01).
005800     03  PRR-NET-PAY             PIC 9(04)V99.
005900     03  FILLER                  PIC X(09).
006000
006100 FD  REPORT-FILE
006200     LABEL RECORDS ARE OMITTED
006300     REPORT IS QUARTERLY-PAY-REGISTER.
006400
006500 WORKING-STORAGE SECTION.
006600 77  END-OF-FILE-SWITCH          PIC X(1)    VALUE 'N'.
006700     88  END-OF-FILE                         VALUE 'Y'.
006800
006900 01  WS-EMPLOYEE-KEY.
007000     03  WS-EMPLOYEE-NUMBER      PIC 9(04).
007100     03  FILLER                  PIC X(03).
007200     03  WS-EMPLOYEE-NAME        PIC X(20).
007300
007400 01  WS-PERCENTS-COMPUTED.
007500     03  WPC-DEPT                OCCURS 6 TIMES
007600                                 INDEXED BY WPCD-IX.
007700         05  WPC-PERCENT         OCCURS 5 TIMES
007800                                 INDEXED BY WPCC-IX
007900                                 PIC 9(3)V99.
008000
008100 01  DEPARTMENT-TABLE.
008200     03  FILLER PIC X(17) VALUE '01MANAGEMENT     '.
008300     03  FILLER PIC X(50) VALUE ZEROS.
008400     03  FILLER PIC X(17) VALUE '05ADMINISTRATIVE '.
008500     03  FILLER PIC X(50) VALUE ZEROS.
008600     03  FILLER PIC X(17) VALUE '10SKILLED NURSING'.
008700     03  FILLER PIC X(50) VALUE ZEROS.
008800     03  FILLER PIC X(17) VALUE '15PATIENT SUPPORT'.
008900     03  FILLER PIC X(50) VALUE ZEROS.
009000     03  FILLER PIC X(17) VALUE '20HOUSEKEEPING   '.
009100     03  FILLER PIC X(50) VALUE ZEROS.
009200     03  FILLER PIC X(17) VALUE '25MAINTENANCE    '.
009300     03  FILLER PIC X(50) VALUE ZEROS.
009400 01  FILLER REDEFINES DEPARTMENT-TABLE.
009500     03  DEPARTMENT-ENTRY      OCCURS 6 TIMES
009600                               INDEXED BY DE-IX.
009700         05  DE-NUMBER         PIC 9(02).
009800         05  DE-NAME           PIC X(15).
009900         05  DE-GROSS          PIC 9(08)V99.
010000         05  DE-FICA           PIC 9(08)V99.
010100         05  DE-FWT            PIC 9(08)V99.
010200         05  DE-MISC           PIC 9(08)V99.
010300         05  DE-NET            PIC 9(08)V99.
010400
010500 REPORT SECTION.
010600 RD  QUARTERLY-PAY-REGISTER
010700     CONTROLS ARE FINAL, PRR-DEPARTMENT-NUMBER,
010800         PRR-EMPLOYEE-KEY
010900     PAGE LIMIT IS 66 LINES
011000     HEADING 1
011100     FIRST DETAIL 7
011200     LAST DETAIL 60.
011300
011400 01  TYPE PAGE HEADING.
011500     02  LINE 1.
011600         03  COLUMN 39   PIC X(13) VALUE 'C E N T U R Y'.
011700         03  COLUMN 55   PIC X(13) VALUE 'M E D I C A L'.
011800         03  COLUMN 71   PIC X(11) VALUE 'C E N T E R'.
011900     02  LINE 2.
012000         03  COLUMN 35   PIC X(17) VALUE 'Q U A R T E R L Y'.
012100         03  COLUMN 55   PIC X(13) VALUE 'P A Y R O L L'.
012200         03  COLUMN 71   PIC X(15) VALUE 'R E G I S T E R'.
012300         03  COLUMN 111  PIC X(04) VALUE 'PAGE'.
012400         03  COLUMN 116  PIC ZZZZ9 SOURCE PAGE-COUNTER.
012500     02  LINE 4.
012600         03  COLUMN 06   PIC X(28) VALUE
012700             '--------- EMPLOYEE ---------'.
012800         03  COLUMN 40   PIC X(05) VALUE 'GROSS'.
012900         03  COLUMN 54   PIC X(04) VALUE 'FICA'.
013000         03  COLUMN 66   PIC X(07) VALUE 'FED W/H'.
013100         03  COLUMN 80   PIC X(05) VALUE 'MISC.'.
013200         03  COLUMN 95   PIC X(03) VALUE 'NET'.
013300     02  LINE 5.
013400         03  COLUMN 07   PIC X(02) VALUE 'NO'.
013500         03  COLUMN 22   PIC X(04) VALUE 'NAME'.
013600         03  COLUMN 41   PIC X(03) VALUE 'PAY'.
013700         03  COLUMN 55   PIC X(03) VALUE 'TAX'.
013800         03  COLUMN 68   PIC X(03) VALUE 'TAX'.
013900         03  COLUMN 79   PIC X(07) VALUE 'DEDUCT.'.
014000         03  COLUMN 95   PIC X(03) VALUE 'PAY'.
014100
014200 01  DEPT-HEAD TYPE CONTROL HEADING PRR-DEPARTMENT-NUMBER
014300     NEXT GROUP PLUS 1.
014400     02  LINE PLUS 1.
014500         03 COLUMN 01    PIC X(18) VALUE
014600            'DEPARTMENT NUMBER:'.
014700         03  COLUMN 21   PIC 9(02) SOURCE PRR-DEPARTMENT-NUMBER.
014800         03  COLUMN 24   PIC X(15) SOURCE DE-NAME (DE-IX).
014900
015000 01  EMPLOYEE-DETAIL TYPE DETAIL.
015100     02  LINE PLUS 1.
015200         03  COLUMN 01   PIC X(27) SOURCE PRR-EMPLOYEE-KEY.
015300         03  COLUMN 50   PIC 9(04).99 SOURCE PRR-GROSS-PAY.
015400         03  COLUMN 60   PIC 9(03).99 SOURCE PRR-FICA-WH.
015500         03  COLUMN 70   PIC 9(03).99 SOURCE PRR-FED-WH.
015600         03  COLUMN 80   PIC 9(03).99 SOURCE PRR-MISC-DED.
015700         03  COLUMN 90   PIC 9(04).99 SOURCE PRR-NET-PAY.
015800
015900 01  EMPL-FOOT TYPE CONTROL FOOTING PRR-EMPLOYEE-KEY.
016000     02  LINE PLUS 1.
016100         03  COLUMN 06   PIC ZZZ9  SOURCE WS-EMPLOYEE-NUMBER.
016200         03  COLUMN 14   PIC X(20) SOURCE WS-EMPLOYEE-NAME.
016300         03  COLUMN 38   PIC $$,$$9.99 SUM PRR-GROSS-PAY.
016400         03  COLUMN 53   PIC $$$9.99 SUM PRR-FICA-WH.
016500         03  COLUMN 66   PIC $$$9.99 SUM PRR-FED-WH.
016600         03  COLUMN 79   PIC $$$9.99 SUM PRR-MISC-DED.
016700         03  COLUMN 92   PIC $$,$$9.99 SUM PRR-NET-PAY.
016800
016900 01  DEPT-FOOT TYPE CONTROL FOOTING PRR-DEPARTMENT-NUMBER
017000     NEXT GROUP PLUS 2.
017100     02  LINE PLUS 2.
017200         03  COLUMN 14   PIC X(20) VALUE
017300             'DEPARTMENT TOTALS'.
017400         03  DEPT-FOOT-GROSS       COLUMN 38   PIC $$,$$9.99
017500                                   SUM PRR-GROSS-PAY.
017600         03  COLUMN 48   PIC X         VALUE '*'.
017700         03  DEPT-FOOT-FICA        COLUMN 53   PIC $$$9.99
017800                                   SUM PRR-FICA-WH.
017900         03  COLUMN 61   PIC X         VALUE '*'.
018000         03  DEPT-FOOT-FWT         COLUMN 66   PIC $$$9.99
018100                                   SUM PRR-FED-WH.
018200         03  COLUMN 74   PIC X         VALUE '*'.
018300         03  DEPT-FOOT-MISC        COLUMN 79   PIC $$$9.99
018400                                   SUM PRR-MISC-DED.
018500         03  COLUMN 87   PIC X         VALUE '*'.
018600         03  DEPT-FOOT-NET         COLUMN 92   PIC $$,$$9.99
018700                                   SUM PRR-NET-PAY.
018800         03  COLUMN 102  PIC X         VALUE '*'.
018900
019000 01  COMP-FOOT TYPE CONTROL FOOTING FINAL.
019100     02  LINE PLUS 2.
019200         03  COLUMN 14   PIC X(20) VALUE
019300             'COMPANY TOTALS'.
019400         03  CO-GROSS    COLUMN 37   PIC $$$,$$9.99
019500                         SUM PRR-GROSS-PAY.
019600         03  COLUMN 48   PIC XX        VALUE '**'.
019700         03  CO-FICA     COLUMN 51   PIC $$,$$9.99
019800                         SUM PRR-FICA-WH.
019900         03  COLUMN 61   PIC XX        VALUE '**'.
020000         03  CO-FWT      COLUMN 64   PIC $$,$$9.99
020100                         SUM PRR-FED-WH.
020200         03  COLUMN 74   PIC XX        VALUE '**'.
020300         03  CO-MISC     COLUMN 77   PIC $$,$$9.99
020400                         SUM PRR-MISC-DED.
020500         03  COLUMN 87   PIC XX        VALUE '**'.
020600         03  CO-NET      COLUMN 91   PIC $$$,$$9.99
020700                         SUM PRR-NET-PAY.
020800         03  COLUMN 102  PIC XX        VALUE '**'.
020900
021000 01  REPORT-FOOT TYPE REPORT FOOTING.
021100     02  LINE 1.
021200         03  COLUMN 39   PIC X(13) VALUE 'C e n t u r y'.
021300         03  COLUMN 55   PIC X(13) VALUE 'M e d i c a l'.
021400         03  COLUMN 71   PIC X(11) VALUE 'C e n t e r'.
021500     02  LINE 2.
021600         03  COLUMN 35   PIC X(17) VALUE 'Q u a r t e r l y'.
021700         03  COLUMN 55   PIC X(13) VALUE 'P a y r o l l'.
021800         03  COLUMN 71   PIC X(15) VALUE 'R e g i s t e r'.
021900         03  COLUMN 111  PIC X(04) VALUE 'PAGE'.
022000         03  COLUMN 116  PIC ZZZZ9 SOURCE PAGE-COUNTER.
022100     02  LINE 4.
022200         03  COLUMN 40   PIC X(05) VALUE 'GROSS'.
022300         03  COLUMN 58   PIC X(04) VALUE 'FICA'.
022400         03  COLUMN 74   PIC X(07) VALUE 'FED W/H'.
022500         03  COLUMN 92   PIC X(05) VALUE 'MISC.'.
022600         03  COLUMN 111  PIC X(03) VALUE 'NET'.
022700     02  LINE 5.
022800         03  COLUMN 41   PIC X(03) VALUE 'PAY'.
022900         03  COLUMN 59   PIC X(03) VALUE 'TAX'.
023000         03  COLUMN 76   PIC X(03) VALUE 'TAX'.
023100         03  COLUMN 91   PIC X(07) VALUE 'DEDUCT.'.
023200         03  COLUMN 111  PIC X(03) VALUE 'PAY'.
023300
023400     02  LINE PLUS 2.
023500         03  COLUMN 05   PIC X(29) VALUE
023600             '* * * DEPARTMENT TOTALS * * *'.
023700     02  LINE PLUS 2.
023800         03  COLUMN 05   PIC 9(02) SOURCE DE-NUMBER (1).
023900         03  COLUMN 08   PIC X(15) SOURCE DE-NAME (1).
024000         03  COLUMN 38   PIC $$,$$9.99 SOURCE DE-GROSS (1).
024100         03  COLUMN 48   PIC ZZ9 SOURCE WPC-PERCENT (1 1).
024200         03  COLUMN 51   PIC X VALUE '%'.
024300         03  COLUMN 57   PIC $$$9.99   SOURCE DE-FICA (1).
024400         03  COLUMN 65   PIC ZZ9 SOURCE WPC-PERCENT (1 2).
024500         03  COLUMN 68   PIC X VALUE '%'.
024600         03  COLUMN 74   PIC $$$9.99   SOURCE DE-FWT (1).
024700         03  COLUMN 82   PIC ZZ9 SOURCE WPC-PERCENT (1 3).
024800         03  COLUMN 85   PIC X VALUE '%'.
024900         03  COLUMN 91   PIC $$$9.99   SOURCE DE-MISC (1).
025000         03  COLUMN 99   PIC ZZ9 SOURCE WPC-PERCENT (1 4).
025100         03  COLUMN 102  PIC X VALUE '%'.
025200         03  COLUMN 108  PIC $$,$$9.99 SOURCE DE-NET (1).
025300         03  COLUMN 118  PIC ZZ9 SOURCE WPC-PERCENT (1 5).
025400         03  COLUMN 121  PIC X VALUE '%'.
025500     02  LINE PLUS 2.
025600         03  COLUMN 05   PIC 9(02) SOURCE DE-NUMBER (2).
025700         03  COLUMN 08   PIC X(15) SOURCE DE-NAME (2).
025800         03  COLUMN 38   PIC $$,$$9.99 SOURCE DE-GROSS (2).
025900         03  COLUMN 48   PIC ZZ9 SOURCE WPC-PERCENT (2 1).
026000         03  COLUMN 51   PIC X VALUE '%'.
026100         03  COLUMN 57   PIC $$$9.99   SOURCE DE-FICA (2).
026200         03  COLUMN 65   PIC ZZ9 SOURCE WPC-PERCENT (2 2).
026300         03  COLUMN 68   PIC X VALUE '%'.
026400         03  COLUMN 74   PIC $$$9.99   SOURCE DE-FWT (2).
026500         03  COLUMN 82   PIC ZZ9 SOURCE WPC-PERCENT (2 3).
026600         03  COLUMN 85   PIC X VALUE '%'.
026700         03  COLUMN 91   PIC $$$9.99   SOURCE DE-MISC (2).
026800         03  COLUMN 99   PIC ZZ9 SOURCE WPC-PERCENT (2 4).
026900         03  COLUMN 102  PIC X VALUE '%'.
027000         03  COLUMN 108  PIC $$,$$9.99 SOURCE DE-NET (2).
027100         03  COLUMN 118  PIC ZZ9 SOURCE WPC-PERCENT (2 5).
027200         03  COLUMN 121  PIC X VALUE '%'.
027300     02  LINE PLUS 2.
027400         03  COLUMN 05   PIC 9(02) SOURCE DE-NUMBER (3).
027500         03  COLUMN 08   PIC X(15) SOURCE DE-NAME (3).
027600         03  COLUMN 38   PIC $$,$$9.99 SOURCE DE-GROSS (3).
027700         03  COLUMN 48   PIC ZZ9 SOURCE WPC-PERCENT (3 1).
027800         03  COLUMN 51   PIC X VALUE '%'.
027900         03  COLUMN 57   PIC $$$9.99   SOURCE DE-FICA (3).
028000         03  COLUMN 65   PIC ZZ9 SOURCE WPC-PERCENT (3 2).
028100         03  COLUMN 68   PIC X VALUE '%'.
028200         03  COLUMN 74   PIC $$$9.99   SOURCE DE-FWT (3).
028300         03  COLUMN 82   PIC ZZ9 SOURCE WPC-PERCENT (3 3).
028400         03  COLUMN 85   PIC X VALUE '%'.
028500         03  COLUMN 91   PIC $$$9.99   SOURCE DE-MISC (3).
028600         03  COLUMN 99   PIC ZZ9 SOURCE WPC-PERCENT (3 4).
028700         03  COLUMN 102  PIC X VALUE '%'.
028800         03  COLUMN 108  PIC $$,$$9.99 SOURCE DE-NET (3).
028900         03  COLUMN 118  PIC ZZ9 SOURCE WPC-PERCENT (3 5).
029000         03  COLUMN 121  PIC X VALUE '%'.
029100     02  LINE PLUS 2.
029200         03  COLUMN 05   PIC 9(02) SOURCE DE-NUMBER (4).
029300         03  COLUMN 08   PIC X(15) SOURCE DE-NAME (4).
029400         03  COLUMN 38   PIC $$,$$9.99 SOURCE DE-GROSS (4).
029500         03  COLUMN 48   PIC ZZ9 SOURCE WPC-PERCENT (4 1).
029600         03  COLUMN 51   PIC X VALUE '%'.
029700         03  COLUMN 57   PIC $$$9.99   SOURCE DE-FICA (4).
029800         03  COLUMN 65   PIC ZZ9 SOURCE WPC-PERCENT (4 2).
029900         03  COLUMN 68   PIC X VALUE '%'.
030000         03  COLUMN 74   PIC $$$9.99   SOURCE DE-FWT (4).
030100         03  COLUMN 82   PIC ZZ9 SOURCE WPC-PERCENT (4 3).
030200         03  COLUMN 85   PIC X VALUE '%'.
030300         03  COLUMN 91   PIC $$$9.99   SOURCE DE-MISC (4).
030400         03  COLUMN 99   PIC ZZ9 SOURCE WPC-PERCENT (4 4).
030500         03  COLUMN 102  PIC X VALUE '%'.
030600         03  COLUMN 108  PIC $$,$$9.99 SOURCE DE-NET (4).
030700         03  COLUMN 118  PIC ZZ9 SOURCE WPC-PERCENT (4 5).
030800         03  COLUMN 121  PIC X VALUE '%'.
030900     02  LINE PLUS 2.
031000         03  COLUMN 05   PIC 9(02) SOURCE DE-NUMBER (5).
031100         03  COLUMN 08   PIC X(15) SOURCE DE-NAME (5).
031200         03  COLUMN 38   PIC $$,$$9.99 SOURCE DE-GROSS (5).
031300         03  COLUMN 48   PIC ZZ9 SOURCE WPC-PERCENT (5 1).
031400         03  COLUMN 51   PIC X VALUE '%'.
031500         03  COLUMN 57   PIC $$$9.99   SOURCE DE-FICA (5).
031600         03  COLUMN 65   PIC ZZ9 SOURCE WPC-PERCENT (5 2).
031700         03  COLUMN 68   PIC X VALUE '%'.
031800         03  COLUMN 74   PIC $$$9.99   SOURCE DE-FWT (5).
031900         03  COLUMN 82   PIC ZZ9 SOURCE WPC-PERCENT (5 3).
032000         03  COLUMN 85   PIC X VALUE '%'.
032100         03  COLUMN 91   PIC $$$9.99   SOURCE DE-MISC (5).
032200         03  COLUMN 99   PIC ZZ9 SOURCE WPC-PERCENT (5 4).
032300         03  COLUMN 102  PIC X VALUE '%'.
032400         03  COLUMN 108  PIC $$,$$9.99 SOURCE DE-NET (5).
032500         03  COLUMN 118  PIC ZZ9 SOURCE WPC-PERCENT (5 5).
032600         03  COLUMN 121  PIC X VALUE '%'.
032700     02  LINE PLUS 2.
032800         03  COLUMN 05   PIC 9(02) SOURCE DE-NUMBER (6).
032900         03  COLUMN 08   PIC X(15) SOURCE DE-NAME (6).
033000         03  COLUMN 38   PIC $$,$$9.99 SOURCE DE-GROSS (6).
033100         03  COLUMN 48   PIC ZZ9 SOURCE WPC-PERCENT (6 1).
033200         03  COLUMN 51   PIC X VALUE '%'.
033300         03  COLUMN 57   PIC $$$9.99   SOURCE DE-FICA (6).
033400         03  COLUMN 65   PIC ZZ9 SOURCE WPC-PERCENT (6 2).
033500         03  COLUMN 68   PIC X VALUE '%'.
033600         03  COLUMN 74   PIC $$$9.99   SOURCE DE-FWT (6).
033700         03  COLUMN 82   PIC ZZ9 SOURCE WPC-PERCENT (6 3).
033800         03  COLUMN 85   PIC X VALUE '%'.
033900         03  COLUMN 91   PIC $$$9.99   SOURCE DE-MISC (6).
034000         03  COLUMN 99   PIC ZZ9 SOURCE WPC-PERCENT (6 4).
034100         03  COLUMN 102  PIC X VALUE '%'.
034200         03  COLUMN 108  PIC $$,$$9.99 SOURCE DE-NET (6).
034300         03  COLUMN 118  PIC ZZ9 SOURCE WPC-PERCENT (6 5).
034400         03  COLUMN 121  PIC X VALUE '%'.
034500     02  LINE PLUS 2.
034600         03  COLUMN 37   PIC $$$,$$9.99 SOURCE CO-GROSS.
034700         03  COLUMN 48   PIC X(5) VALUE '100%'.
034800         03  COLUMN 55   PIC $$,$$9.99  SOURCE CO-FICA.
034900         03  COLUMN 65   PIC X(5) VALUE '100%'.
035000         03  COLUMN 72   PIC $$,$$9.99  SOURCE CO-FWT.
035100         03  COLUMN 82   PIC X(5) VALUE '100%'.
035200         03  COLUMN 89   PIC $$,$$9.99  SOURCE CO-MISC.
035300         03  COLUMN 99   PIC X(5) VALUE '100%'.
035400         03  COLUMN 107  PIC $$$,$$9.99 SOURCE CO-NET.
035500         03  COLUMN 118  PIC X(5) VALUE '100%'.
035600
035700 PROCEDURE DIVISION.
035800
035900 DECLARATIVES.
036000
036100 DEPT-HEAD-USE SECTION. USE BEFORE REPORTING DEPT-HEAD.
036200 DEPT-HEAD-PROC.
036300     SET DE-IX TO +1.
036400     SEARCH DEPARTMENT-ENTRY
036500         WHEN DE-NUMBER (DE-IX) = PRR-DEPARTMENT-NUMBER
036600             MOVE ZEROS TO DE-GROSS (DE-IX), DE-FICA (DE-IX),
036700                           DE-FWT (DE-IX), DE-MISC (DE-IX),
036800                           DE-NET (DE-IX).
036900
037000 DEPT-HEAD-EXIT.
037100     EXIT.
037200
037300 EMPL-FOOT-USE SECTION. USE BEFORE REPORTING EMPL-FOOT.
037400 EMPL-FOOT-PROC.
037500     MOVE PRR-EMPLOYEE-KEY TO WS-EMPLOYEE-KEY.
037600
037700 EMPL-FOOT-EXIT.
037800     EXIT.
037900
038000 DEPT-FOOT-USE SECTION. USE BEFORE REPORTING DEPT-FOOT.
038100 DEPT-FOOT-PROC.
038200     MOVE DEPT-FOOT-GROSS TO DE-GROSS (DE-IX).
038300     MOVE DEPT-FOOT-FICA TO DE-FICA (DE-IX).
038400     MOVE DEPT-FOOT-FWT TO DE-FWT (DE-IX).
038500     MOVE DEPT-FOOT-MISC TO DE-MISC (DE-IX).
038600     MOVE DEPT-FOOT-NET TO DE-NET (DE-IX).
      *     SUPPRESS PRINTING.
038700
038800 DEPT-FOOT-EXIT.
038900     EXIT.
039000
039100 COMP-FOOT-USE SECTION. USE BEFORE REPORTING COMP-FOOT.
039200 COMP-FOOT-PROC.
039300     PERFORM COMP-FOOT-CALC
039400         VARYING WPCD-IX FROM +1 BY +1
039500         UNTIL WPCD-IX > +6.
039600     GO TO COMP-FOOT-EXIT.
039700
039800 COMP-FOOT-CALC.
039900     SET DE-IX TO WPCD-IX.
040000     SET WPCC-IX TO +1.
040100     COMPUTE WPC-PERCENT (WPCD-IX WPCC-IX) ROUNDED =
040200         ((DE-GROSS (DE-IX) / CO-GROSS) * 100) + .5.
040300     SET WPCC-IX TO +2.
040400     COMPUTE WPC-PERCENT (WPCD-IX WPCC-IX) ROUNDED =
040500         ((DE-FICA (DE-IX) / CO-FICA) * 100) + .5.
040600     SET WPCC-IX TO +3.
040700     COMPUTE WPC-PERCENT (WPCD-IX WPCC-IX) ROUNDED =
040800         ((DE-FWT (DE-IX) / CO-FWT) * 100) + .5.
040900     SET WPCC-IX TO +4.
041000     COMPUTE WPC-PERCENT (WPCD-IX WPCC-IX) ROUNDED =
041100         ((DE-MISC (DE-IX) / CO-MISC) * 100) + .5.
041200     SET WPCC-IX TO +5.
041300     COMPUTE WPC-PERCENT (WPCD-IX WPCC-IX) ROUNDED =
041400         ((DE-NET (DE-IX) / CO-NET) * 100) + .5.
041500
041600 COMP-FOOT-EXIT.
041700     EXIT.
041800
041900 END DECLARATIVES.
042000
042100 000-INITIATE.
042200
042300     OPEN INPUT PAYROLL-REGISTER-DATA,
042400          OUTPUT REPORT-FILE.
042500
042600     INITIATE QUARTERLY-PAY-REGISTER.
042700
042800     READ PAYROLL-REGISTER-DATA
042900         AT END
043000             MOVE 'Y' TO END-OF-FILE-SWITCH.
043200
043300     PERFORM 100-PROCESS-PAYROLL-DATA THRU 199-EXIT
043400         UNTIL END-OF-FILE.
043500
043600 000-TERMINATE.
043700     TERMINATE QUARTERLY-PAY-REGISTER.
043800
043900     CLOSE PAYROLL-REGISTER-DATA,
044000           REPORT-FILE.
044100
044200     STOP RUN.
044300
044400 100-PROCESS-PAYROLL-DATA.
044500     GENERATE QUARTERLY-PAY-REGISTER.
044600     READ PAYROLL-REGISTER-DATA
044700         AT END
044800             MOVE 'Y' TO END-OF-FILE-SWITCH.
045000
045100 199-EXIT.
045200     EXIT.
045300

$ cobc -x rwex06.cob
# example has SELECTs for DATAIN and SYSPRINT
export DD_DATAIN=./ex06data.txt
export DD_SYSPRINT=./ex06report.txt
./rwex06
cat ex06report.txt


                                        C E N T U R Y   M E D I C A L   C E N T E R
                                    Q U A R T E R L Y   P A Y R O L L   R E G I S T E R                         PAGE     1

       --------- EMPLOYEE ---------      GROSS         FICA        FED W/H       MISC.          NET
        NO             NAME               PAY           TAX          TAX        DEDUCT.         PAY

  DEPARTMENT NUMBER:  01 MANAGEMENT

       6622    GAVIN SHAFER            $1,040.00       $60.84      $134.48        $4.75        $839.93
       7078    VERA ALSTON             $1,800.00      $105.30      $138.24        $3.75      $1,552.71
       8093    GRADY KAISER            $2,300.00      $134.57      $247.53        $6.50      $1,911.43

               DEPARTMENT TOTALS       $5,140.00 *    $300.71 *    $520.25 *     $15.00 *    $4,304.07 *


  DEPARTMENT NUMBER:  05 ADMINISTRATIVE

       1720    PAULINE WINSTON           $680.00       $39.79      $290.36        $3.50        $526.37
       2116    HERMAN COX                $610.00       $35.69       $76.52        $7.25        $490.55
       6925    ADOLF TRUJILLO            $625.00       $36.55      $118.95        $4.00        $465.50

               DEPARTMENT TOTALS       $1,915.00 *    $112.03 *    $485.83 *     $14.75 *    $1,482.42 *


  DEPARTMENT NUMBER:  10 SKILLED NURSING

       1504    TIFFANY KEIR            $1,740.00      $101.82      $187.74        $1.75      $1,448.69
       6640    ALEXANDER CATHEY        $1,950.00      $114.06      $371.10        $7.25      $1,457.59
       9465    STEVE HUGHES            $1,475.00       $86.30      $239.40        $3.00      $1,146.30

               DEPARTMENT TOTALS       $5,165.00 *    $302.18 *    $798.24 *     $12.00 *    $4,052.58 *


  DEPARTMENT NUMBER:  15 PATIENT SUPPORT

       2903    KAYLA VERBECK             $840.00       $49.14      $136.32        $5.25        $649.29
       5196    CLAIRE KELLAR             $886.00       $51.82      $102.80        $6.75        $724.63

               DEPARTMENT TOTALS       $1,726.00 *    $100.96 *    $239.12 *     $12.00 *    $1,373.92 *


  DEPARTMENT NUMBER:  20 HOUSEKEEPING

       5190    MARYANN GLAZENER          $540.00       $31.62       $69.84        $3.50        $435.10
       6580    CAROLINE TROMBETTA        $480.00       $28.08       $51.78        $2.75        $396.39
       9507    ADRIANA CHANGAZI          $498.00       $29.16       $80.82        $6.75        $381.27

               DEPARTMENT TOTALS       $1,518.00 *     $88.86 *    $202.44 *     $13.00 *    $1,212.76 *


  DEPARTMENT NUMBER:  25 MAINTENANCE

        428    MELVIN BEHRENS            $468.00       $27.36       $50.52        $5.00        $385.12
       2003    BALDWIN SIMONSEN          $670.00       $39.22      $113.46        $4.75        $512.57
       6491    LEO TILLEY                $606.00       $35.46       $46.56        $3.50        $520.48

               DEPARTMENT TOTALS       $1,744.00 *    $102.04 *    $210.54 *     $13.25 *    $1,418.17 *

               COMPANY TOTALS         $17,208.00 ** $1,006.78 ** $2,456.42 **    $80.00 **  $13,843.92 **








                                        C e n t u r y   M e d i c a l   C e n t e r
                                    Q u a r t e r l y   P a y r o l l   R e g i s t e r                         PAGE     2

                                         GROSS             FICA            FED W/H           MISC.              NET
                                          PAY               TAX              TAX            DEDUCT.             PAY

      * * * DEPARTMENT TOTALS * * *

      01 MANAGEMENT                    $5,140.00  30%     $300.71  30%     $520.25  21%      $15.00  19%     $4,304.07  31%

      05 ADMINISTRATIVE                $1,915.00  11%     $112.03  11%     $485.83  20%      $14.75  18%     $1,482.42  11%

      10 SKILLED NURSING               $5,165.00  30%     $302.18  30%     $798.24  33%      $12.00  15%     $4,052.58  29%

      15 PATIENT SUPPORT               $1,726.00  10%     $100.96  10%     $239.12  10%      $12.00  15%     $1,373.92  10%

      20 HOUSEKEEPING                  $1,518.00   9%      $88.86   9%     $202.44   8%      $13.00  16%     $1,212.76   9%

      25 MAINTENANCE                   $1,744.00  10%     $102.04  10%     $210.54   9%      $13.25  17%     $1,418.17  10%

                                      $17,208.00 100%   $1,006.78 100%   $2,456.42 100%      $80.00 100%    $13,843.92 100%

 
GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20110213
      *> Purpose:   Demonstrate an intrinsic function shortcut
      *> Tectonics: cobc -x functionall.cob
      *> ***************************************************************
       identification division.
       program-id. functionall.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

      *> ***************************************************************
       procedure division.
       display function pi space function e
       display pi space e

       goback.
       end program functionall.

$ cobc -x functionall.cob
$ ./functionall
3.1415926535897932384626433832795029 2.7182818284590452353602874713526625
3.1415926535897932384626433832795029 2.7182818284590452353602874713526625

$ cobc -x functionall.cob
functionall.cob:19: Error: 'pi' undefined
functionall.cob:19: Error: 'e' undefined

$ cobcrun cobweb-gtk

*> cobweb-gtk UDF repository follows
 repository.
     function new-builder
     function new-window
     function new-scrolled-window
     function new-box
     function new-frame
     function new-image
     function new-label
     function new-entry
     function new-button
     function new-checkbutton
     function new-spinner
     function new-vte
     function new-textview
     function rundown-signals
     function signal-attach
     function builder-signal-attach
     function builder-get-object
     function show-widget
     function hide-widget
     function set-sensitive-widget
     function entry-get-text
     function entry-set-text
     function textview-get-text
     function textview-set-text
     function gtk-go
     function all intrinsic.

SUM OF identifier-1 RESET ON FINAL

NEXT GROUP IS NEXT PAGE WITH RESET

READY TRACE
display "statement trace"
RESET TRACE

Program-Id: tracing          Statement: DISPLAY                Line: 12
statement trace

01 result PIC S9(8).

CALL "libfunc" RETURNING result END-CALL

PROCEDURE DIVISION USING thing RETURNING otherthing

close tax-file with no rewind

write person
    invalid key
        move concatenate("overwriting: " nicknum) to problem
        rewrite person
            invalid key
                move concatenate(
                    exception-location() space nicknum
                    space filestatus)
                to problem
        end-rewrite
end-write.

GCOBOL >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* =================
      *><* rewriting example
      *><* =================
      *><* :Author:    Brian Tiffin
      *><* :Date:      17-Feb-2009, 29-Apr-2016
      *><* :Purpose:   Demonstrate SEQUENTIAL REWRITE
      *><* :Copyright: Dedicated to the public domain
      *><* :Tectonics:
      *><*    cobc -xj rewriting.cob
      *><*    dd if=rewriting.dat cbs=53 conv=unblock status=none
      *> ***************************************************************
       identification division.
       program-id. rewriting-test.

       environment division.
       configuration section.

       input-output section.
       file-control.
          select rewriting
          assign to "rewriting.dat"
          status is rewriting-status
          organization is sequential
          access mode is sequential
          .

       data division.
       file section.
       fd rewriting.
       01 rewriting-record     pic x(44).

       working-storage section.
       01 rewriting-status.
          03 high-status       pic xx.
             88 rewriting-ok   values '00' thru '09'.

       01 record-stat pic x.
          88 no-more-records value low-value false high-value.

       01 data-line.
          05 value
             "The first two data lines will be overwritten".

       01 redata-line.
          05 value
             "I'm a big fan of COBOL and GnuCOBOL features".

      *> ***************************************************************
       procedure division.

      *> Populate a sample database, create or overwrite
       display "WRITE four records" end-display
       perform populate-sample

      *> open the data file again, for input and output
       open i-o rewriting
       perform rewriting-check

       display "REWRITE the first two records" end-display
       perform rewrite-a-record
       perform rewrite-a-record

      *> and with that we are done with rewriting sample
       close rewriting

       goback.
      *> ***************************************************************

      *><* read next sequential paragraph
       read-next-record.
           read rewriting next record
               at end set no-more-records to true
           end-read
           display "Read: "rewriting-record end-display
           perform rewriting-check
       .

      *><* Write paragraph
       write-rewriting-record.
           write rewriting-record end-write
           perform rewriting-check
       .

       rewrite-rewriting-record.
           rewrite rewriting-record end-rewrite
           perform rewriting-check
       .

      *><* file status quick check.  For this sample, keep running
       rewriting-check.
           if not rewriting-ok then
               display
                   "file io problem: " rewriting-status upon syserr
               end-display
           end-if
       .

      *><* demonstrate a record rewrite
       rewrite-a-record.
           perform read-next-record
           if no-more-records then
               display "no record to rewrite" upon syserr end-display
           else
               move redata-line to rewriting-record
               perform rewrite-rewriting-record
           end-if
       .

      *><* populate a sample file
       populate-sample.
           open output rewriting
           perform rewriting-check

           move data-line to rewriting-record
           perform 4 times
               perform write-rewriting-record
           end-perform

      *> close sample file, as the rewrite demo needs a different mode
           close rewriting
           perform rewriting-check
       .

       end program rewriting-test.
      *><*
      *><* Last Update: 20160429

prompt$ cobc -xj rewriting.cob
WRITE four records
REWRITE the first two records
Read: The first two data lines will be overwritten
Read: The first two data lines will be overwritten

prompt$ dd if=rewriting.dat cbs=44 conv=unblock status=none
I'm a big fan of COBOL and GnuCOBOL features
I'm a big fan of COBOL and GnuCOBOL features
The first two data lines will be overwritten
The first two data lines will be overwritten

COMPUTE total-value ROUNDED = 1.0 / 6.0

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/rounding
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20151018   Modified:  2015-10-18/14:40-0400
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU General Public License, GPL, 3.0 (or greater)
      *> PURPOSE
      *>   ROUNDED MODE examples
      *> TECTONICS
      *>   cobc -x rounding.cob -g -debug
      *> ***************************************************************
       identification division.
       program-id. rounding.
       author. Brian Tiffin.
       date-written. 2015-10-18/14:40-0400.
       remarks. Exercise the various ROUNDED MODE options.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 samples.
          05 filler occurs 10 times.
             10 val       pic s9v99.

       01 results.
          05 filler occurs 7 times.
             10 mode-name pic x(22).
             10 filler occurs 10 times.
                15 res    pic s9.

       01 prohibit-bad    pic s9v999 value 2.499.
       01 prohibit-good   pic s9v99 value 2.49.
       01 no-round        pic s9v99.

       01 value-index     pic 99.
       01 mode-index      pic 9.

      *> ***************************************************************
       procedure division.
       move +2.49 to val(1)
       move -2.49 to val(2)
       move +2.50 to val(3)
       move -2.50 to val(4)
       move +3.49 to val(5)
       move -3.49 to val(6)
       move +3.50 to val(7)
       move -3.50 to val(8)
       move +3.51 to val(9)
       move -3.51 to val(10)

       move "away-from-zero" to mode-name(1)
       move "nearest-away-from-zero" to mode-name(2)
       move "nearest-even" to mode-name(3)
       move "nearest-toward-zero" to mode-name(4)
       move "toward-greater" to mode-name(5)
       move "toward-lesser" to mode-name(6)
       move "truncation" to mode-name(7)

       perform varying value-index from 1 by 1 until value-index > 10
           add val(value-index) zero giving res(1, value-index)
               rounded mode away-from-zero
           add val(value-index) zero giving res(2, value-index)
               rounded mode nearest-away-from-zero
           add val(value-index) zero giving res(3, value-index)
               rounded mode nearest-even
           add val(value-index) zero giving res(4, value-index)
               rounded mode nearest-toward-zero
           add val(value-index) zero giving res(5, value-index)
               rounded mode toward-greater
           add val(value-index) zero giving res(6, value-index)
               rounded mode toward-lesser
           add val(value-index) zero giving res(7, value-index)
               rounded mode truncation
       end-perform
       display "                      " with no advancing
       perform varying value-index from 1 by 1 until value-index > 9
           display val(value-index) " " with no advancing
       end-perform
       display val(10)

       perform varying mode-index from 1 by 1 until mode-index > 7
           display mode-name(mode-index) with no advancing
           perform varying value-index from 1 by 1 until value-index > 10
               display "  " res(mode-index, value-index) "  "
                   with no advancing
           end-perform
           evaluate true
               when mode-index = 2
                   display "default ROUNDED"
               when mode-index = 3
                   display "Banker's rounding"
               when mode-index = 7
                   display "no ROUNDED given"
               when other
                   display space
           end-evaluate
       end-perform
       .

      *> fall through to this labelled paragraph
       prohibited-rounding.
       display space
       display "PROHIBITED example"
       display "------------------"
       display "Attempt to ADD " prohibit-bad
               " ZERO GIVING an s9v99 ROUNDED MODE PROHIBITED"
       add prohibit-bad zero giving no-round rounded mode prohibited
           on size error
               perform soft-exception
           not on size error
               display prohibit-bad ", " no-round
       end-add

       display space
       display "Attempt to ADD " prohibit-good
               " ZERO GIVING an s9v99 ROUNDED MODE PROHIBITED"
       add prohibit-good zero giving no-round rounded mode prohibited
           on size error
               perform soft-exception
           not on size error
               display prohibit-good ", " no-round
       end-add

       goback.
      *> ***************************************************************

      *> informational warnings and abends
       soft-exception.
         display "Module:              " module-id upon syserr
         display "Module Path:         " module-path upon syserr
         display "Module Source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
         perform soft-exception
         stop run returning 127
       .

       end program rounding.
      *> ***************************************************************
      *>****

>>ELSE
==============
rounding usage
==============

./rounding

Introduction
------------

Displays an example of the various ROUNDED MODE clauses supported by
GnuCOBOL.

Source
------

.. code-include::  rounding.cob
   :language: cobol
>>END-IF

prompt$ cobc -x rounding.cob -g -debug
prompt$ ./rounding


                        +2.49 -2.49 +2.50 -2.50 +3.49 -3.49 +3.50 -3.50 +3.51 -3.51
  away-from-zero          +3    -3    +3    -3    +4    -4    +4    -4    +4    -4
  nearest-away-from-zero  +2    -2    +3    -3    +3    -3    +4    -4    +4    -4  default ROUNDED
  nearest-even            +2    -2    +2    -2    +3    -3    +4    -4    +4    -4  Banker's rounding
  nearest-toward-zero     +2    -2    +2    -2    +3    -3    +3    -3    +4    -4
  toward-greater          +3    -2    +3    -2    +4    -3    +4    -3    +4    -3
  toward-lesser           +2    -3    +2    -3    +3    -4    +3    -4    +3    -4
  truncation              +2    -2    +2    -2    +3    -3    +3    -3    +3    -3  no ROUNDED given

  PROHIBITED example
  ------------------
  Attempt to ADD +2.499 ZERO GIVING an s9v99 ROUNDED MODE PROHIBITED
  Module:              rounding
  Module Path:         /home/btiffin/lang/cobol/forum/rounding
  Module Source:       rounding.cob
  Exception-file:      00
  Exception-status:    EC-SIZE-TRUNCATION
  Exception-location:  rounding; prohibited-rounding; 106
  Exception-statement: ADD

  Attempt to ADD +2.49 ZERO GIVING an s9v99 ROUNDED MODE PROHIBITED
  +2.49, +2.49


STOP RUN RETURNING 1

GCobol >>SOURCE FORMAT IS FIXED
      *> ************************************************************ <*
      *> Author:    Brian Tiffin
      *> Date:      20110701
      *> Purpose:   Play with 2.0 screen section
      *> Tectonics: cobc -x screening.cob
      *> ************************************************************ <*
       identification division.
       program-id. screening.

       data division.
       working-storage section.
       01 some-data pic s9(9).

       screen section.
       01 detail-screen.
          03 line 1 column 1 value "title line".
          03 line 2 column 1 value "field: ".
          03 line 2 column 16 using some-data.

      *> ************************************************************ <*
       procedure division.
       accept detail-screen end-accept
       goback.

       end program screening.

SCROLL UP 8
SCROLL DOWN 4

SD sort-file-1
    RECORD CONTAINS 80 CHARACTERS.

ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
    SELECT OPTIONAL fileresource
        ASSIGN TO external-name
        FILE STATUS IS identifier
        COLLATING SEQUENCE IS alphabet-name
        LOCK MODE IS MANUAL WITH LOCK ON MULTIPLE RECORDS
        RECORD DELIMITER IS STANDARD
        RESERVE num AREA
        SHARING WITH NO OTHER
        ORGANIZATION IS INDEXED
            ACCESS MODE IS DYNAMIC
            RECORD KEY IS key-field
            ALTERNATE RECORD KEY IS key-field-2 WITH DUPLICATES
            ALTERNATE RECORD KEY IS key-field-3
            ALTERNATE RECORD KEY IS splitkey
                SOURCE IS first-part OF indexing-record
                          last-part OF indexing-record
                WITH DUPLICATES.

SELECT myfile ASSIGN TO "name.txt".

100-entry.
    MOVE data-field TO formatted-field
    IF sub-field IS GREATER THAN 10 THEN
        PERFORM DO-STUFF
    ELSE
        NEXT SENTENCE
    END-IF
    DISPLAY "Still the first sentence".   *> Note the period

    DISPLAY "NEXT SENTENCE would jump to here"
.

77 field-1 PICTURE S9(8) SIGN IS TRAILING SEPARATE.

dd if=inputfile.dat cbs=80 conv=unblock status=none

dd if=textfile.txt of=output.dat cbs=80 conv=block status=none

ORGANIZATION IS SEQUENTIAL
ACCESS MODE IS SEQUENTIAL

*> GnuCOBOL variable length sequential read/write, contrived
*> tectonics: cobc -xjd varseq-sample.cob
 identification division.
 program-id. varseq-sample.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 input-output section.
 file-control.
     select optional varseq assign to varseq-name
     organization is sequential
     file status is varseq-stat.

 data division.
 file section.
 fd varseq
     record is varying in size
     from 0 to 36 depending on varseq-size.
 01 varseq-record.
    05 pic x occurs 0 to 36 depending on varseq-size.

 working-storage section.
 01 varseq-name.
    05 value "varseq.dat".
 01 varseq-stat          pic xx.
    88 varseq-ok             value "00".
    88 varseq-eof            value "10".
 01 varseq-size          pic 99.

*> a semi realistic record type, trigger is "CUSTINFO"
 01 varseq-master.
    05 record-marker     pic x(8).
    05 cust-total        pic s9(8)v99 usage comp-5.
    05 cust-hint         pic x(16).

*> different fillers for the 1 to 36 byte samples
 01 fake-data-1.
    05 value "0123456789abcdefghijklmnopqrstuvwxyz".
 01 fake-data-2.
    05 value "zyxwvutsrqponmlkjihgfedcba9876543210".
 01 fake-data-3.
    05 value "##################------------------".
 01 fake-data-4.
    05 value "==================++++++++++++++++++".

*> 5 different fake data sources, every fifth is type CUSTINFO
 01 random-integer pic 99.
 01 random-float   usage float-long.

 procedure division.
 varseq-sample.

*> fill the file with fake data, different lengths
 perform populate-varseq

*> now read through the fake data
 perform scan-varseq

 goback.
*> *********************************************************

 populate-varseq.
*> fill in some semi-realistic customer data
*>   "CUSTINFO" determines this special record type
 move "CUSTINFO" to record-marker
 move 1234.56 to cust-total
 move "Likes dogs, golf" to cust-hint

 open output varseq
 if not varseq-ok then
     display "error opening " varseq-name " for write "
              varseq-stat upon syserr
 end-if

*> contrived loop to fill in 0 to 36 byte records
*>  every random fifth, write out the semi-realistic customer
*>      each time customer data is written, double the total
 perform varying tally from 0 by 1 until tally > 36
     move tally to varseq-size
     compute random-float = random() * 5.0
     compute random-integer = random-float + 1.0
     if varseq-size greater than 0 then
         evaluate random-integer
             when 1
                 move fake-data-1(1:varseq-size) to varseq-record
             when 2
                 move fake-data-2(1:varseq-size) to varseq-record
             when 3
                 move fake-data-3(1:varseq-size) to varseq-record
             when 4
                 move fake-data-4(1:varseq-size) to varseq-record
             when 5
                 move length(varseq-master) to varseq-size
                 move varseq-master to varseq-record
                 add cust-total to cust-total
         end-evaluate
     end-if
     write varseq-record
     if not varseq-ok then
         display "error writing " varseq-name
                 "at " tally " with " varseq-stat
            upon syserr
     end-if
 end-perform
*> write out one more zero length record
 move 0 to varseq-size
 write varseq-record
 if not varseq-ok then
     display "error writing " varseq-name
             "at 0 with " varseq-stat
        upon syserr
 end-if

*> close the made up data, report any anomalies
 close varseq
 if not varseq-ok then
     display "error closing write " varseq-name upon syserr
 end-if
 .

*> do a read pass, if the first eight bytes are the magic key
*> treat data as the semi-real customer info
*> total should double on each display of the dog lovin golfer
*> a real application would likely have a varseq-recordtype field
*> instead of just looking for "CUSTINFO" as a magic key
 scan-varseq.

 open input varseq
 if not varseq-ok then
     display "error opening " varseq-name " for read "
              varseq-stat upon syserr
     *> just bail if open fails
     exit paragraph
 end-if

 perform until varseq-eof
     read varseq
     if varseq-ok then
         display "read " varseq-size " bytes " with no advancing
         if varseq-record(1:8) equal "CUSTINFO" then
             move varseq-record to varseq-master
             display "Customer info: " cust-total ", " cust-hint
         else
             display trim(varseq-record)
         end-if
     else
         if not varseq-eof then
             display "error reading " varseq-name upon syserr
         end-if
     end-if
 end-perform

*> close the read pass, report any anomalies
 close varseq
 if not varseq-ok and not varseq-eof then
     display "error closing read " varseq-name upon syserr
 end-if
 .

 end program varseq-sample.

prompt$ cobc -xjd varseq-sample.cob
read 00 bytes
read 01 bytes z
read 02 bytes ==
read 03 bytes ===
read 32 bytes Customer info: +00001234.56, Likes dogs, golf
read 05 bytes 01234
read 06 bytes zyxwvu
read 07 bytes =======
read 08 bytes zyxwvuts
read 09 bytes #########
read 10 bytes ##########
read 11 bytes ===========
read 12 bytes zyxwvutsrqpo
read 13 bytes #############
read 32 bytes Customer info: +00002469.12, Likes dogs, golf
read 32 bytes Customer info: +00004938.24, Likes dogs, golf
read 16 bytes ================
read 17 bytes =================
read 18 bytes 0123456789abcdefgh
read 19 bytes ==================+
read 20 bytes 0123456789abcdefghij
read 21 bytes zyxwvutsrqponmlkjihgf
read 22 bytes 0123456789abcdefghijkl
read 32 bytes Customer info: +00009876.48, Likes dogs, golf
read 24 bytes 0123456789abcdefghijklmn
read 25 bytes ##################-------
read 26 bytes 0123456789abcdefghijklmnop
read 27 bytes 0123456789abcdefghijklmnopq
read 32 bytes Customer info: +00019752.96, Likes dogs, golf
read 29 bytes zyxwvutsrqponmlkjihgfedcba987
read 30 bytes ##################------------
read 32 bytes Customer info: +00039505.92, Likes dogs, golf
read 32 bytes ==================++++++++++++++
read 33 bytes zyxwvutsrqponmlkjihgfedcba9876543
read 34 bytes ==================++++++++++++++++
read 35 bytes ##################-----------------
read 36 bytes ##################------------------
read 00 bytes

01 field-1 pic 99.
   88 cond-1 value 42.

MOVE 0 TO field-1
DISPLAY field-1
SET cond-1 TO TRUE
DISPLAY field-1

77 field-1 PICTURE S9(8) SIGN IS TRAILING SEPARATE.

CALL "c-function" USING
    BY VALUE UNSIGNED SIZE IS 2 short-field
    RETURNING new-value
END-CALL

ADD 1 TO gnucobol
    ON SIZE ERROR
        SET erroneous TO TRUE
    NOT ON SIZE ERROR
        DISPLAY "ADDING 1 TO COBOL"
END-ADD

STRING
   field-1        DELIMITED BY SIZE
   " slash/slash" DELIMITED BY "/"
   field-2        DELIMTTED BY SIZE
   INTO response-field
   ON OVERFLOW
      DISPLAY "response truncated" UPON SYSERR
END-STRING

MEMORY SIZE IS integer-1 WORDS

GCobol* GnuCOBOL SORT verb example using standard in and standard out
       identification division.
       program-id. sorting.

       environment division.
       input-output section.
       file-control.
           select sort-in
               assign keyboard
               organization line sequential.
           select sort-out
               assign display
               organization line sequential.
           select sort-work
               assign "sortwork".

       data division.
       file section.
       fd sort-in.
          01 in-rec        pic x(255).
       fd sort-out.
          01 out-rec       pic x(255).
       sd sort-work.
          01 work-rec      pic x(255).

       procedure division.
       sort sort-work
           ascending key work-rec
           using  sort-in
           giving sort-out.

       goback.
       exit program.
       end program sorting.

GCobol >>SOURCE FORMAT IS FIXED
      ******************************************************************
      * Author:    Brian Tiffin
      * Date:      02-Sep-2008
      * Purpose:   A GnuCOBOL SORT verb example
      * Tectonics: cobc -x sorting.cob
      *     ./sorting <input >output
      *   or simply
      *     ./sorting
      *   for keyboard and screen demos
      ******************************************************************
       identification division.
       program-id. sorting.

       environment division.
       configuration section.
      * This sets up a sort order lower then upper except for A and a
       special-names.
           alphabet mixed is " AabBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTu
      -"UvVwWxXyYzZ0123456789".

       input-output section.
       file-control.
           select sort-in
               assign keyboard
               organization is line sequential.
           select sort-out
               assign display
               organization is line sequential.
           select sort-work
               assign "sortwork".

       data division.
       file section.
       fd sort-in.
          01 in-rec        pic x(255).
       fd sort-out.
          01 out-rec       pic x(255).
       sd sort-work.
          01 work-rec      pic x(255).

       working-storage section.
       01 loop-flag        pic x value low-value.

       procedure division.
       sort sort-work
           on descending key work-rec
           collating sequence is mixed
           input procedure is sort-transform
           output procedure is output-uppercase.

       display sort-return.
       goback.

      ******************************************************************
       sort-transform.
       move low-value to loop-flag
       open input sort-in
       read sort-in
           at end move high-value to loop-flag
       end-read
       perform
           until loop-flag = high-value
               move FUNCTION LOWER-CASE(in-rec) to work-rec
               release work-rec
               read sort-in
                   at end move high-value to loop-flag
               end-read
       end-perform
       close sort-in
       .

      ******************************************************************
       output-uppercase.
       move low-value to loop-flag
       open output sort-out
       return sort-work
           at end move high-value to loop-flag
       end-return
       perform
           until loop-flag = high-value
               move FUNCTION UPPER-CASE(work-rec) to out-rec
               write out-rec end-write
               return sort-work
                   at end move high-value to loop-flag
               end-return
       end-perform
       close sort-out
       .

       exit program.
       end program sorting.

table define

    01  nbr-of-columns  pic 9(4) value zero.
    01  tcindex2        usage is index.
    01  dbtables.
        03  tables-columns  occurs 1 to 1000 times
                depending on nbr-of-columns
                ascending key tcTable, tcColumn
                            indexed by tcindex.
        05  tcTable     pic x(64)   value spaces.
        05  tcColumn    pic x(64)   value spaces.
            05  tcAlias pic x(10)   value spaces.
        05  tcOrder pic 9(4)    value zero.
            05  tcType  pic x(10)   value spaces.
            05  tcMaxLen    pic 9(4)    value zero.
    *><*
    01  aliasName.
        05          pic x value "t".
        05 anVal        pic 9(3)    value zero.

     01 showdata.
        05  sdTable     pic x(17) value spaces.
        05  sdColumn    pic x(17) value spaces.
        05  sdType      pic x(10) value spaces.
        05  sdOrder     pic zzzzz-.
        05  sdMaxLen    pic zzzzz.

table load

   perform varying rows from 1 by 1
       until rows > dbNumRows
       call "dbNextRow"     using by value dbResult,
                                  by reference ColumnBuff,
                                  by reference CbuffDesc
            returning dbResult
       add 1            to nbr-of-columns
       set tcindex          up by 1
       move cbTable         to tcTable(tcindex)
       move cbColumn        to tcColumn(tcindex)
       move cbType          to tcType(tcindex)
       move cbOrder         to tcOrder(tcindex)
       move cbMaxLen        to tcMaxLen(tcindex)
       if nbr-of-columns = 1
          add 1         to anVal
       else
          set tcindex2      to tcindex
          set tcindex2      down by 1
          if cbTable <> tcTable(tcindex2)
             add 1          to anVal
          end-if
       end-if
       move aliasName       to tcAlias(tcindex)
   end-perform.


table sort

    sort tables-columns ascending key tcTable, tcColumn.

display table

    perform varying tcindex from 1 by 1
        until tcindex > nbr-of-columns
        move tcTable(tcindex)       to sdTable
        move tcColumn(tcindex)      to sdColumn
        move tcOrder(tcindex)       to sdOrder
        move tcType(tcindex)        to sdType
        move tcMaxLen(tcindex)      to sdMaxLen
        display showdata
    end-perform.

MOVE CORRESPONDING cbRecord to table-columns(tcindex)
...
MOVE CORRESPONDING table-columns(tcindex) to showdata

SORT
    WITH DUPLICATES

SORT
    WITH DUPLICATES IN ORDER

SAME SORT-MERGE AREA FOR filename-1.

>>SOURCE FORMAT IS FIXED
>>SOURCE FORMAT IS FREE

GCobol >>SOURCE FORMAT IS what-it-is-fixed-being-boxey-but-nice

e_e    >>source free

SELECT ...
    RECORD KEY IS newkey-name SOURCE is dname-a dname-f dname-c

011400 01  TYPE PAGE HEADING.
011500     02  LINE 1.
011600         03  COLUMN 39   PIC X(13) VALUE 'C E N T U R Y'.
011700         03  COLUMN 55   PIC X(13) VALUE 'M E D I C A L'.
011800         03  COLUMN 71   PIC X(11) VALUE 'C E N T E R'.
011900     02  LINE 2.
012000         03  COLUMN 35   PIC X(17) VALUE 'Q U A R T E R L Y'.
012100         03  COLUMN 55   PIC X(13) VALUE 'P A Y R O L L'.
012200         03  COLUMN 71   PIC X(15) VALUE 'R E G I S T E R'.
012300         03  COLUMN 111  PIC X(04) VALUE 'PAGE'.
012400         03  COLUMN 116  PIC ZZZZ9 source PAGE-COUNTER.

start indexing
   key is less than
       keyfield of indexing-record
   invalid key
       display "bad start: " keyfield of indexing-record
       set no-more-records to true
   not invalid key
       read indexing previous record
           at end set no-more-records to true
       end-read
end-start

KEY IS GREATER THAN
KEY IS >
KEY IS LESS THAN
KEY IS <
KEY IS EQUAL TO
KEY IS =

KEY IS NOT GREATER THAN
KEY IS NOT >
KEY IS NOT LESS THAN
KEY IS NOT <
KEY IS NOT EQUAL TO
KEY IS NOT =

KEY IS <>
KEY IS GREATER THAN OR EQUAL TO
KEY IS >=
KEY IS LESS THAN OR EQUAL TO
KEY IS <=

CALL STATIC "puts" USING a-zstring RETURNING out-count END-CALL

CALL STDCALL "CreateWindowEx" USING ...

STOP RUN RETURNING 5.

01 var PICTURE X(5).

STRING
   "abc" DELIMITED BY "b"
   "def" DELIMITED BY SIZE
   "ghi" DELIMITED BY "z"
   INTO var
   ON OVERFLOW
       DISPLAY "var is full at" SPACE LENGTH OF var
END-STRING

DISPLAY var

var is full at 5
adefg

SUBTRACT a b c FROM d ROUNDED END-SUBTRACT

SUBTRACT a FROM b GIVING c
    ON SIZE ERROR
        SET math-error TO TRUE
    NOT ON SIZE ERROR
        SET math-error TO FALSE
END-SUBTRACT

SUBTRACT CORRESPONDING record-a FROM record-b ROUNDED
    ON SIZE ERROR
        SET something-wrong TO TRUE
END-SUBTRACT

03  COLUMN 38   PIC $$,$$9.99 SUM PRR-GROSS-PAY.

CURRENCY SIGN IS "&" PICTURE SYMBOL IS 'literal'

SPECIAL-NAMES.
    SYMBOLIC CHARACTERS NUL IS 1
                        SOH IS 2
                        BEL IS 8
                        TAB IS 9.

SPECIAL-NAMES.
    SYMBOLIC CHARACTERS    NUL SOH BEL TAB
                    ARE      1   2   8   9.

01 infile.
   03 slice    occurs 1 to 64 times depending on slices.
      05 lone-char   pic x   synchronized.
      05 stext usage pointer synchronized.
      05 val   float-long    synchronized.
      05 ftext usage pointer synchronized.

CHARACTER CLASSIFICATION IS SYSTEM-DEFAULT

GLOBAL PIC 9(5) USAGE BINARY VALUE ZERO

IDENTIFICATION   DIVISION.
PROGRAM-ID.      callee.
PROCEDURE        DIVISION.
    ADD 1 TO TALLY END-ADD
    CALL "nested" END-CALL
    STOP RUN.

IDENTIFICATION   DIVISION.
PROGRAM-ID.      nested.
PROCEDURE        DIVISION.
    DISPLAY tally END-DISPLAY
    STOP RUN.
END PROGRAM      nested.

INSPECT record-1 TALLYING ident-1 FOR LEADING "0"

perform
    with test after
    varying x from 1 by xstep
    until x >= function e
        if x > function e
            move function e to x-value
        else
            move x to x-value
        end-if
        compute recip = 1 / x end-compute
        move recip to y-value
        write outrec end-write
end-perform

IF A GREATER THAN 10
    DISPLAY "A > 10"
END-IF

IF A > 10 THEN
   DISPLAY "A GREATER THAN 10"
ELSE
   DISPLAY "A LESS THAN OR EQUAL TO 10"
END-IF

PERFORM 100-open-files THROUGH 100-files-end

01 testing-field pic 9.
   88 first-half   values 0 thru 4
   88 second-half  values 5 thru 9.

evaluate testing-field
    when 0 thru 7
        display "0 thru 7"
    when first-half
        display "first half"
end-evaluate

PERFORM first-paragraph THRU last-paragraph.

01 current-time.
   05 ct-hours      pic 99.
   05 ct-minutes    pic 99.
   05 ct-seconds    pic 99.
   05 ct-hundredths pic 99.

ACCEPT current-time FROM TIME

01 squeeze usage index value 10.
01 accordian.
   05 pleat occurs 1 to 10 times depending on sqeeze pic x.

PERFORM 5 TIMES
    DISPLAY "DERP"
END-PERFORM

ADD 1 TO cobol GIVING GnuCOBOL
    ON SIZE ERROR
        DISPLAY "Potential exceeds expectations"
END-ADD

FD  mini-report
    linage is 16 lines
        with footing at 15
        lines at top 2
        lines at bottom 2.

READY TRACE
display "traced output, showing source line"
RESET TRACE

move "ABBCCCBBA" to data-to-change
TRANSFORM data-to-change FROM "ABC" TO "XYZ"
display data-to-change

XYYZZZYYX

01 field-1 pic x.
   88 cond-1 values 'a','b','c'.

move 'b' to field-1
SET cond-1 TO TRUE

EVALUATE TRUE
    WHEN field-1 equal 'a'
        display field-1
    WHEN field-1 equal 'b' or 'c'
        display "internal fail setting cond-1 true"
END-EVALUATE

a

EVALUATE FALSE
    WHEN 0 equal 1
        display "Yes, that is, false"
END-EVALUATE

sample identification division.
       program-id. unbound.

       environment division.
       configuration section.
       special-names.
       repository.
           function all intrinsic.

       data             division.
       working-storage section.
       01 n                pic 9(03).
       01 p                usage pointer.

       linkage section.
      *> unbound tables need to be in linkage
       01 a-table.
          03 rows occurs 0 to unbounded times depending on n.
             05 col1       pic x.
             05 filler     pic x value '-'.
             05 col2       pic xxx.
             05 filler     pic x value ':'.
             05 col3       pic x(16).

       procedure division.
      *> 123 is just an arbitrary limit
       display "How many entries (1-123)? " with no advancing
       accept n
       display space
       if n < 1 or > 123 then move 1 to n end-if

      *> show the user requested table length
       display n " entries gives " length(a-table) " table bytes"
       end-display

       allocate function length(a-table) characters
           initialized to all '?' returning p
       set address of a-table to p

      *> Show the first record as question marks
       display rows(1)

      *> Show the last record with some data
       initialize rows(n) with filler all to value then to default
       move "A" to col1(n)
       move "BCD" to col2(n)
       move "Some data" to col3(n)
       display rows(n)
       goback.
       end program unbound.

prompt$ cobc -xj unbound.cob -debug
How many entries (1-123)? 27

027 entries gives 000000594 table bytes
??????????????????????
A-BCD:Some data

CLOSE file-1 UNIT WITH NO REWIND

UNLOCK filename-1 RECORDS

UNSTRING Input-Address
    DELIMITED BY "," OR "/"
    INTO
        Street-Address DELIMITER D1 COUNT C1
        Apt-Number DELIMITER D2 COUNT C2
        City DELIMITER D3 COUNT C3
        State DELIMITER D4 COUNT C4
        Zip-Code DELIMITER D5 COUNT C5
    WITH POINTER ptr-1
    ON OVERFLOW
        SET more-fields TO TRUE
END-UNSTRING

PERFORM VARYING ident-1 FROM 1 BY 1 UNTIL ident-1 > 10
    CALL "thing" USING BY VALUE ident-1 END-CALL
END-PERFORM

SET ptr-1 UP BY 4
SET ind-1 UP BY 1

display "Warning: read length truncated" upon syserr

display "This is going to be cool" UPON PRINTER

prompt$ export COBPRINTER='cat >>prt.log'

prompt$ export COB_DISPLAY_PRINTER='prt.log'

CHARACTER CLASSIFICATION IS USER-DEFAULT

01 important-data    pic x(6) value "secret".

01 vip-status-test   pic x(3).
   88 vip            value  "you".
   88 guest          values "him", "her".

call "subprogram" using by value 42 end-call

01 testing-field               PIC 9.
   88 status-ok                value 0.
   88 status-warning           values 1,2,4,5.
   88 status-golook            value 3.
   88 status-error             values 6 thru 8.
   88 status-run-for-the-hills value 9.

PERFORM VARYING loop-counter FROM 1 BY 1 UNTIL loop-counter > 10
    DISPLAY loop-counter
END-PERFORM

FD infile
   RECORD IS VARYING IN SIZE FROM 1 TO 65535 CHARACTERS
   DEPENDING ON infile-record-length.
01 infile-record.
   05 infile-data      PIC X OCCURS 1 TO 65535 TIMES
                       DEPENDING ON infile-record-length.

FD infile RECORD VARYING DEPENDING ON infile-record-length.

READ infile NEXT RECORD WITH WAIT END-READ

EVALUATE TRUE
    WHEN A = 10
        DISPLAY "A = 10"
    WHEN A = 15
        PERFORM A-IS-15
    WHEN B IS EQUAL 6
        PERFORM B-IS-6
    WHEN C IS GREATER THAN 5
        DISPLAY "C > 5"
    WHEN OTHER
        DISPLAY "Default imperative"
 END-EVALUATE

identification division.
program-id. when-compiled-sample.
date-written. 2015-10-28/00:17-0400.

procedure division.
display when-compiled

stop run.

prompt$ cobc -xj when-compiled-sample.cob
10/28/1500.20.10

identification division.
program-id. when-compiled-sample.
date-written. 2015-10-28/00:21-0400.

procedure division.
display when-compiled
display function when-compiled

stop run.

$ cobc -xj when-compiled-sample.cob
10/28/1500.21.29
2015102800212900-0400

identification division.
program-id. when-compiled-sample.
date-written. 2015-10-28/00:21-0400.

environment division.
configuration section.
repository.
    function all intrinsic.

procedure division.
display when-compiled
display function when-compiled

stop run.

prompt$ cobc -xj when-compiled-sample.cob
2015102800263700-0400
2015102800263700-0400

WRITE record-buff END-WRITE

WRITE indexed-record
    WITH LOCK
    ON INVALID KEY
        DISPLAY "Key exists, REWRITING..."
        PERFORM rewrite-key
END-WRITE
IF indexed-file-status NOT EQUAL ZERO THEN
    DISPLAY "Write problem: " indexed-file-status UPON SYSERR
    PERFORM evasive-manoeuvres
END-IF

WRITE record-name-1 AFTER ADVANCING PAGE

WRITE record-name-1 FROM header-record-1
    AFTER ADVANCING 2 LINES
    AT END-OF-PAGE
        PERFORM write-page-header
        PERFORM write-last-detail-reminder
END-WRITE

ACCEPT date-var FROM DAY YYYYDDD

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-09/19:38-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 date-var    pic 99999999.

       ==
       ==:CODEBOOK:== BY
       ==

       accept date-var from date
       display ":" date-var ":"

       accept date-var from date yyyymmdd
       display ":" date-var ":"

       ==
       .

$ ./yyyymmdd-sample.cob
:00151213:
:20151213:

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-13/00:28-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 amount pic s9(8)v99 value zero.

       ==
       ==:CODEBOOK:== BY
       ==

       if amount equal zero then
           display zero
       else
           display amount
       end-if

       ==
       .

prompt$ ./zero-sample.cob
0

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-09/19:38-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 amount pic s9(8)v99 value all zeroes.

       ==
       ==:CODEBOOK:== BY
       ==

       display amount

       ==
       .

prompt$ ./zeroes-sample.cob
+00000000.00

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-09/19:38-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 amount      pic s9(8)v99.
          88 zilch                 value zeros.
       01 show-amount pic $(8)9.99.

       ==
       ==:CODEBOOK:== BY
       ==

       move amount to show-amount
       if zilch then
           display " GOOSE EGGS "
       else
           display show-amount
       end-if

       ==
       .

prompt$ ./zeros-sample.cob
 GOOSE EGGS

#!/usr/local/bin/cobc -xj

       COPY template REPLACING
       ==:DATABOOK:== BY
       ==

       01 showing pic --9.99.
       01 absing  pic zz9.99.

       01 samples-table.
          05 sample-values.
             10 filler pic s99v99 value -42.42.
             10 filler pic s99v99 value -0.42.
             10 filler pic s99v99 value 42.42.
          05 filler redefines sample-values.
             10 sample pic s99v99 occurs 3 times indexed by lot.

       ==
       ==:CODEBOOK:== BY
       ==

       perform varying lot from 1 by 1 until lot > 3
           move sample(lot) to showing
           move abs(sample(lot)) to absing

           display "Abs of: " showing " is " absing
       end-perform

       ==
       .

$ ./abs-sample.cob
Abs of: -42.42 is  42.42
Abs of:  -0.42 is   0.42
Abs of:  42.42 is  42.42

#!/usr/local/bin/cobc -xj

       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 x            pic s9v99.
       01 degrees      pic s999v9.
       01 answer       pic s9v9(5).

       ==
       ==:CODEBOOK:== BY
       ==

       perform varying x from -1.0 by 0.25 until x > 1.0
           compute answer = acos(x)
           compute degrees rounded = answer * 180 / pi
           display "acos(" x ") ~= " answer " ~= " degrees "°"
       end-perform

       ==
       .

$ ./acos-sample.cob
acos(-1.00) ~= +3.14159 ~= +180.0°
acos(-0.75) ~= +2.41885 ~= +138.6°
acos(-0.50) ~= +2.09439 ~= +120.0°
acos(-0.25) ~= +1.82347 ~= +104.5°
acos(+0.00) ~= +1.57079 ~= +090.0°
acos(+0.25) ~= +1.31811 ~= +075.5°
acos(+0.50) ~= +1.04719 ~= +060.0°
acos(+0.75) ~= +0.72273 ~= +041.4°
acos(+1.00) ~= +0.00000 ~= +000.0°

WORKING-STORAGE SECTION.
77  INTEREST       PIC S9V9999 VALUE 0.08.
77  MONTHLY        PIC S9V9999 VALUE ZERO.
77  PERIODS        PIC 99      VALUE 36.
77  ANNUITY-VALUE  PIC S9V9999 VALUE ZERO.
PROCEDURE DIVISION.
   COMPUTE MONTHLY ROUNDED = INTEREST / 12
   COMPUTE ANNUITY-VALUE ROUNDED =
       FUNCTION ANNUITY (MONTHLY PERIODS)
   DISPLAY "Monthly rate: " MONTHLY
       " Periods: " PERIODS
       " Annuity ratio: " ANNUITY-VALUE
   END-DISPLAY.

Monthly rate: +0.0067 Periods: 36 Annuity ratio: +0.0314

#!/usr/local/bin/cobc -xj

       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 x            pic s9v99.
       01 degrees      pic s999v9.
       01 answer       pic s9v9(5).

       ==
       ==:CODEBOOK:== BY
       ==

       perform varying x from -1.0 by 0.25 until x > 1.0
           compute answer = asin(x)
           compute degrees rounded = answer * 180 / pi
           display "asin(" x ") ~= " answer " ~= " degrees "°"
       end-perform

       ==
       .

prompt$ ./asin-sample.cob
asin(-1.00) ~= -1.57079 ~= -090.0°
asin(-0.75) ~= -0.84806 ~= -048.6°
asin(-0.50) ~= -0.52359 ~= -030.0°
asin(-0.25) ~= -0.25268 ~= -014.5°
asin(+0.00) ~= +0.00000 ~= +000.0°
asin(+0.25) ~= +0.25268 ~= +014.5°
asin(+0.50) ~= +0.52359 ~= +030.0°
asin(+0.75) ~= +0.84806 ~= +048.6°
asin(+1.00) ~= +1.57079 ~= +090.0°

#!/usr/local/bin/cobc -xj

       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 answer       pic s9v9(5).
       01 degrees      pic s999v9.

       01 samples-table.
          05 sample-values.
             10 filler pic s9(2)v99 value -10.
             10 filler pic s9(2)v99 value -1.
             10 filler pic s9(2)v99 value -0.75.
             10 filler pic s9(2)v99 value -0.5.
             10 filler pic s9(2)v99 value -0.25.
             10 filler pic s9(2)v99 value 0.
             10 filler pic s9(2)v99 value +0.25.
             10 filler pic s9(2)v99 value +0.5.
             10 filler pic s9(2)v99 value +0.75.
             10 filler pic s9(2)v99 value +1.
             10 filler pic s9(2)v99 value +10.
          05 filler redefines sample-values.
             10 x      pic s9(2)v99 occurs 11 times indexed by lot.
       ==
       ==:CODEBOOK:== BY
       ==

       perform varying lot from 1 by 1 until lot > 11
           compute answer = atan(x(lot))
           compute degrees rounded = answer * 180 / pi
           display "atan(" x(lot) ") ~= " answer " ~= " degrees "°"
       end-perform

       ==
       .

      *> Plot with
      *> gnuplot
      *>   set term png 256,160
      *>   set grid ; set tics scale 0
      *>   set output "atan-sample.png"
      *>   plot "atan-numbers.txt" using 1:2  with lines notitle

prompt$ ./atan-sample.cob
atan(-10.00) ~= -1.47112 ~= -084.3°
atan(-01.00) ~= -0.78539 ~= -045.0°
atan(-00.75) ~= -0.64350 ~= -036.9°
atan(-00.50) ~= -0.46364 ~= -026.6°
atan(-00.25) ~= -0.24497 ~= -014.0°
atan(+00.00) ~= +0.00000 ~= +000.0°
atan(+00.25) ~= +0.24497 ~= +014.0°
atan(+00.50) ~= +0.46364 ~= +026.6°
atan(+00.75) ~= +0.64350 ~= +036.9°
atan(+01.00) ~= +0.78539 ~= +045.0°
atan(+10.00) ~= +1.47112 ~= +084.3°

prompt$ gnuplot
gnuplot> set term dumb
Terminal type set to 'dumb'
Options are 'feed  size 79, 24'
gnuplot> set grid ; set tics scale 0
gnuplot> plot "atan-numbers.txt" using 1:2  with lines notitle

 1.5 +----------------+-----------------+----------------+-------------****
     |                :                 :                :       ******   |
     |                :                 :                : ******         |
   1 +...............................................******...............+
     |                :                 :      ******    :                |
     |                :                 : *****          :                |
 0.5 +....................................*...............................+
     |                :                 :*               :                |
     |                :                 *                :                |
   0 +..................................*.................................+
     |                :                 *                :                |
     |                :                *:                :                |
     |                :               * :                :                |
-0.5 +................................*...................................+
     |                :          *****  :                :                |
     |                :    ******       :                :                |
  -1 +...............******...............................................+
     |         ****** :                 :                :                |
     |   ******       :                 :                :                |
-1.5 ****-------------+-----------------+----------------+----------------+
    -10              -5                 0                5                10

COBOL  >>SOURCE FORMAT IS FIXED
      ******************************************************************
      * Purpose:   demonstrate intrinsic FUNCTION BYTE-LENGTH
      ******************************************************************
       identification division.
       program-id. bytelength.

       data division.
       working-storage section.
       01 char-var           usage binary-char.
       01 short-var          usage binary-short.
       01 long-var           usage binary-long.
       01 double-var         usage binary-double.

       01 num1-var           pic 9.
       01 num4-var           pic 99v99.
       01 num9-var           pic s9(9).
       01 num18-var          pic s9(18).
       01 num18c-var         pic s9(18) usage comp.
       01 num18p-var         pic s9(18) usage comp-3.
       01 edit-var           pic $zzzz9.99.

       01 string-var         pic x(10) value "abc".

       01 newline            pic x value x'0a'.

       procedure division.
       display
           "num1-var   len = " function byte-length(num1-var) newline
           "num4-var   len = " function byte-length(num4-var) newline
           "num9-var   len = " function byte-length(num9-var) newline
           "num18-var  len = " function byte-length(num18-var) newline
           "num18c-var len = " function byte-length(num18c-var) newline
           "num18p-var len = " function byte-length(num18p-var) newline
           "edit-var   len = " function byte-length(edit-var) newline

           "12         len = " function byte-length(12) newline
           "12.12      len = " function byte-length(12.12) newline
           "1234567890.123 = " function
               byte-length(1234567890.123) newline

           "string-var len = " function byte-length(string-var) newline
           "trim string    = " function
               byte-length(function trim(string-var)) newline

           "char-var   len = " function byte-length(char-var) newline
           "short-var  len = " function byte-length(short-var) newline
           "long-var   len = " function byte-length(long-var) newline
           "double-var len = " function byte-length(double-var)

       end-display
       goback.
       exit program.

num1-var   len = 1
num4-var   len = 4
num9-var   len = 9
num18-var  len = 18
num18c-var len = 8
num18p-var len = 10
edit-var   len = 9
12         len = 2
12.12      len = 4
1234567890.123 = 13
string-var len = 10
trim string    = 00000003
char-var   len = 1
short-var  len = 2
long-var   len = 4
double-var len = 8

DISPLAY FUNCTION COMBINED-DATETIME(1; 1)

0000001.00001

MOVE "COBOL" TO stringvar
MOVE FUNCTION CONCATENATE("Gnu"; stringvar) TO goodsystem
DISPLAY goodsystem

01 ptr USAGE POINTER.
01 str PIC x(4) VALUE z"abc".

SET ptr TO ADDRESS OF str
DISPLAY FUNCTION CONTENT-LENGTH(ptr)

01 ptr USAGE POINTER.
01 str PIC x(7) VALUE z"abcdef".

SET ptr TO ADDRESS OF str
DISPLAY FUNCTION CONTENT-OF(ptr)
DISPLAY FUNCTION CONTENT-OF(ptr, 2)
DISPLAY FUNCTION CONTENT-OF(ptr)(3:3)

#!/usr/local/bin/cobc -xj

       COPY line-sequential-template REPLACING
       ==:INPUT-NAME:== BY =="no-input"==
       ==:OUTPUT-NAME:== BY =="cos-plot.gp"==

       ==:DATABOOK:== BY
       ==

       01 gnuplot.
          05 value
          'set terminal dumb ; set grid ; set tics scale 0 ; ' &
          'set title "FUNCTION COS" ; plot "-" using 1:2 with lines'.

       01 x            pic s9v99.
       01 domain       pic s9v99.
       01 degrees      pic s999v9.
       01 answer       pic s9(5)v9(5).

       01 output-data-line.
          05 x-out     pic -9.99.
          05           pic x value space.
          05 ans-out   pic -9(5).9(5).

       ==
       ==:CODEBOOK:== BY
       ==

       perform open-files

       move length(gnuplot) to output-actual
       move gnuplot to output-line
       perform write-output

       compute domain = pi * 3
       move length(output-data-line) to output-actual
       perform varying x from 0.0 by 0.25 until x > domain
           compute degrees rounded = x * 180 / pi
           move cos(x) to answer
           display "cos(" x ") ~= cos(" degrees "°) ~= " answer

           move x to x-out
           move answer to ans-out
           move output-data-line to output-line
           perform write-output
       end-perform

       perform close-files

       call "SYSTEM" using "gnuplot cos-plot.gp"

       perform delete-output
       ==
       .

prompt$ ./cos-sample.cob
cos(+0.00) ~= cos(+000.0°) ~= +00001.00000
cos(+0.25) ~= cos(+014.3°) ~= +00000.96891
cos(+0.50) ~= cos(+028.6°) ~= +00000.87758
cos(+0.75) ~= cos(+043.0°) ~= +00000.73168
cos(+1.00) ~= cos(+057.3°) ~= +00000.54030
cos(+1.25) ~= cos(+071.6°) ~= +00000.31532
cos(+1.50) ~= cos(+085.9°) ~= +00000.07073
cos(+1.75) ~= cos(+100.3°) ~= -00000.17824
cos(+2.00) ~= cos(+114.6°) ~= -00000.41614
cos(+2.25) ~= cos(+128.9°) ~= -00000.62817
cos(+2.50) ~= cos(+143.2°) ~= -00000.80114
cos(+2.75) ~= cos(+157.6°) ~= -00000.92430
cos(+3.00) ~= cos(+171.9°) ~= -00000.98999
cos(+3.25) ~= cos(+186.2°) ~= -00000.99412
cos(+3.50) ~= cos(+200.5°) ~= -00000.93645
cos(+3.75) ~= cos(+214.9°) ~= -00000.82055
cos(+4.00) ~= cos(+229.2°) ~= -00000.65364
cos(+4.25) ~= cos(+243.5°) ~= -00000.44608
cos(+4.50) ~= cos(+257.8°) ~= -00000.21079
cos(+4.75) ~= cos(+272.2°) ~= +00000.03760
cos(+5.00) ~= cos(+286.5°) ~= +00000.28366
cos(+5.25) ~= cos(+300.8°) ~= +00000.51208
cos(+5.50) ~= cos(+315.1°) ~= +00000.70866
cos(+5.75) ~= cos(+329.5°) ~= +00000.86119
cos(+6.00) ~= cos(+343.8°) ~= +00000.96017
cos(+6.25) ~= cos(+358.1°) ~= +00000.99944
cos(+6.50) ~= cos(+372.4°) ~= +00000.97658
cos(+6.75) ~= cos(+386.7°) ~= +00000.89300
cos(+7.00) ~= cos(+401.1°) ~= +00000.75390
cos(+7.25) ~= cos(+415.4°) ~= +00000.56792
cos(+7.50) ~= cos(+429.7°) ~= +00000.34663
cos(+7.75) ~= cos(+444.0°) ~= +00000.10379
cos(+8.00) ~= cos(+458.4°) ~= -00000.14550
cos(+8.25) ~= cos(+472.7°) ~= -00000.38574
cos(+8.50) ~= cos(+487.0°) ~= -00000.60201
cos(+8.75) ~= cos(+501.3°) ~= -00000.78084
cos(+9.00) ~= cos(+515.7°) ~= -00000.91113
cos(+9.25) ~= cos(+530.0°) ~= -00000.98476


                                  FUNCTION COS

    1 ***----+------+------+------+------+-----******-+------+------+------+
      |  **  :      :      :      :      :    *:     *"-" using 1:2 ****** |
  0.8 +....*.................................*........*....................+
      |     *:      :      :      :      : **  :      :*     :      :      |
  0.6 +......*............................*.............*..................+
  0.4 +.......*...........................*..............*.................+
      |      : *    :      :      :      *     :      :   *  :      :      |
  0.2 +.........*.......................*..................*...............+
      |      :  *   :      :      :     *:     :      :    * :      :      |
    0 +..........*.....................*....................*..............+
      |      :   *  :      :      :   *  :     :      :      *      :      |
 -0.2 +...........*..................*........................*............+
      |      :     *:      :      : *    :     :      :      : *    :      |
 -0.4 +.............*..............*............................*..........+
 -0.6 +..............*.............*.............................*.........+
      |      :      : *    :     **      :     :      :      :    * :      |
 -0.8 +................**......**.................................**.......+
      |      :      :    **: **   :      :     :      :      :      **     |
   -1 +------+------+------**-----+------+-----+------+------+------+-*----+
      0      1      2      3      4      5     6      7      8      9      10

GNU    >>SOURCE FORMAT IS FIXED
Cobol *>*************************************************
      *>****P* gcfaq/currency-symbol
      *> TECTONICS
      *>   cobc -x currency-symbol.cob
      *> SOURCE
       identification division.
       program-id. sample-currency-symbol.

       environment division.
       configuration section.
       special-names.
       currency sign is "&".   *> with picture symbol "@".
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 some-money              pic 9(5)9v99 value 4242.
       01 show-money              pic &zzzz9.99.

      *> ************************************************
       procedure division.
       display function currency-symbol

       move some-money to show-money
       display some-money
       display show-money

       goback.
       end program sample-currency-symbol.
      *>****

$ cobc -x currency-symbol.cob
$ ./currency-symbol

$
004242.00
 &4242.00

DISPLAY FUNCTION CURRENT-DATE.

2008080921243796-0400

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-09/03:48-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 showing pic zzz,zz9.
       01 dating  pic 9999/99/99.

       01 samples-table.
          05 sample-values.
             10 filler pic 9(6) value 1.
             10 filler pic 9(6) value 50000.
             10 filler pic 9(6) value 100000.
             10 filler pic 9(6) value 200000.
             10 filler pic 9(6) value 151550.
          05 filler redefines sample-values.
             10 sample pic 9(6) occurs 5 times indexed by lot.
       ==
       ==:CODEBOOK:== BY
       ==

       perform varying lot from 1 by 1 until lot > 5
           move sample(lot) to showing
           move date-of-integer(sample(lot)) to dating

           display "Day: " showing " is " dating
       end-perform

       ==
       .

prompt$ ./date-of-integer-sample
Day:       1 is 1601/01/01
Day:  50,000 is 1737/11/23
Day: 100,000 is 1874/10/16
Day: 200,000 is 2148/07/31
Day: 151,550 is 2015/12/06

DISPLAY FUNCTION DATE-TO-YYYYMMDD(000101)
DISPLAY FUNCTION DATE-TO-YYYYMMDD(500101)
DISPLAY FUNCTION DATE-TO-YYYYMMDD(610101)
DISPLAY FUNCTION DATE-TO-YYYYMMDD(990101)

DISPLAY FUNCTION DATE-TO-YYYYMMDD(990101, 50, 1900)
DISPLAY FUNCTION DATE-TO-YYYYMMDD(990101, -10, 1900)
DISPLAY FUNCTION DATE-TO-YYYYMMDD(990101, 50, 2000)
DISPLAY FUNCTION DATE-TO-YYYYMMDD(990101, 50, 2100)

20000101
20500101
19610101
19990101
18990101
17990101
19990101
20990101

DISPLAY FUNCTION DAY-OF-INTEGER(97336).
1867182

DISPLAY FUNCTION E

2.7182818284590452353602874713526625

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      29-May-2009, Modified 20110505 to add e tic mark
      *> Purpose:   Plot Euler's number (using integral of 1 over x)
      *> Tectonics: requires access to gnuplot. http://www.gnuplot.info
      *>            cobc -Wall -x ploteuler.cob
      *> OVERWRITES ocgenplot.gp, ocgpdata.txt and images/euler.png
      *> ***************************************************************
       identification division.
       program-id. ploteuler.

       environment division.
       input-output section.
       file-control.
           select scriptfile
               assign to "ocgenplot.gp"
               organization is line sequential.
           select outfile
               assign to "ocgpdata.txt"
               organization is line sequential.

       data division.
       file section.
       fd scriptfile.
          01 gnuplot-command pic x(82).

       fd outfile.
          01 outrec.
             03 x-value   pic -z9.999.
             03 filler    pic x.
             03 y-value   pic -z9.999.

       working-storage section.
       01 xstep   pic 9v99999.
       01 x       pic 9v99999.
       01 recip   pic 9v99999.

      *> The plot command is xrange 0:3, y 0:2 data col 1 for x 2 for y
       01 gpcmds  pic x(400) value is
           "set style fill solid 1.0;                         " &
           "set grid;                                         " &
           "set xtics add ('e' 2.718281);                     " &
           "plot [0:3] [0:2] 'ocgpdata.txt' using 1:2 \       " &
           " with filledcurves below x1  title '1/x';         " &
           "set terminal png;                                 " &
           "set output 'images/euler.png';                    " &
           "replot                                            ".
       01 line-cnt pic 999.
       01 gptable.
          05 gpcmd pic x(50) occurs 8 times.

       01 gplot   pic x(40) value is 'gnuplot -persist ocgenplot.gp'.
       01 result  pic s9(9).

      *> ***************************************************************
       procedure division.
       display function e

      *><* Create the script to plot the area of Euler's number
       open output scriptfile.
       move gpcmds to gptable
       perform varying line-cnt from 1 by 1 until line-cnt > 8
           move gpcmd(line-cnt) to gnuplot-command
           write gnuplot-command end-write
       end-perform
       close scriptfile

      *><* Create the reciprocal data
       open output outfile
       move spaces to outrec
       compute xstep = function e / 100 end-compute
       perform
           with test after
           varying x from 1 by xstep
           until x >= function e
               if x > function e
                   move function e to x-value
               else
                   move x to x-value
               end-if
               compute recip = 1 / x end-compute
               move recip to y-value
               write outrec end-write
       end-perform
       close outfile

      *><* Invoke gnuplot
       call "SYSTEM" using gplot returning result end-call
       if result not = 0
           display "Problem: " result
           stop run returning result
       end-if

       goback.
       end program ploteuler.

IDENTIFICATION DIVISION.
PROGRAM-ID. MINIPROG.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. LINUX.
OBJECT-COMPUTER. LINUX.
SPECIAL-NAMES.

INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT PRINTFILE ASSIGN TO "XXRXWXX"
FILE STATUS RXWSTAT.

DATA DIVISION.
FILE SECTION.
FD PRINTFILE.
01 PRINTREC PIC X(132).

WORKING-STORAGE SECTION.
01 RXWSTAT PIC XX.

PROCEDURE DIVISION.
A00-MAIN SECTION.
001-MAIN-PROCEDURE.
OPEN INPUT PRINTFILE.
DISPLAY "File Status: " RXWSTAT.
DISPLAY "EXCEPTION-FILE: " FUNCTION EXCEPTION-FILE.
DISPLAY "Return Length: "
    FUNCTION LENGTH (FUNCTION EXCEPTION-FILE).
DISPLAY "EXCEPTION-STATUS: " FUNCTION EXCEPTION-STATUS.
DISPLAY "EXCEPTION-STATEMENT: " FUNCTION EXCEPTION-STATEMENT.
STRING "TOOLONG" DELIMITED SIZE INTO RXWSTAT.
DISPLAY "EXCEPTION-STATUS: " FUNCTION EXCEPTION-STATUS.
DISPLAY "EXCEPTION-STATEMENT: " FUNCTION EXCEPTION-STATEMENT.
DISPLAY "EXCEPTION-LOCATION: " FUNCTION EXCEPTION-LOCATION.

STOP RUN.

File Status: 35
EXCEPTION-FILE: 35PRINTFILE
Return Length: 00000011
EXCEPTION-STATUS: EC-I-O-PERMANENT-ERROR
EXCEPTION-STATEMENT: OPEN
EXCEPTION-STATUS: EC-OVERFLOW-STRING
EXCEPTION-STATEMENT: STRING
EXCEPTION-LOCATION: MINIPROG; 001-MAIN-PROCEDURE OF A00-MAIN; 29

DISPLAY FUNCTION EXP(1)

2.718281828459045091

DISPLAY FUNCTION EXP10(1.0)
DISPLAY FUNCTION EXP10(1.2)
DISPLAY FUNCTION EXP10(10)

10.000000000000000000
15.848931924611132871
10000000000.000000000000000000

GCobol*> ***************************************************************
      *> Program to find range and domain of FUNCTION FACTORIAL
       identification division.
       program-id. fact.

       data division.
       working-storage section.
       01 ind pic 999.
       01 result pic 9(18).

      *> ***************************************************************
       procedure division.
       perform varying ind from 0 by 1 until ind > 20
           add zero to function factorial(ind) giving result
               on size error
                   display "overflow at " ind
           end-add
           display ind " = " function factorial(ind)
       end-perform

       goback.
       end program fact.

000 = 000000000000000001
001 = 000000000000000001
002 = 000000000000000002
003 = 000000000000000006
004 = 000000000000000024
005 = 000000000000000120
006 = 000000000000000720
007 = 000000000000005040
008 = 000000000000040320
009 = 000000000000362880
010 = 000000000003628800
011 = 000000000039916800
012 = 000000000479001600
013 = 000000006227020800
014 = 000000087178291200
015 = 000001307674368000
016 = 000020922789888000
017 = 000355687428096000
018 = 006402373705728000
019 = 121645100408832000
overflow at 020
020 = 432902008176640000

GCobol*> ***************************************************************
      *> Program to find range and domain of FUNCTION FACTORIAL
       identification division.
       program-id. fact.

       data division.
       working-storage section.
       01 ind                  pic 99.
       01 z-ind                pic z9.
       01 result               pic 9(18).
       01 pretty-result        pic z(17)9.

      *> ***************************************************************
       procedure division.
       perform varying ind from 0 by 1 until ind > 21
           add zero to function factorial(ind) giving result
               on size error
                   display
                       "overflow at " ind ", result undefined: "
                       function factorial(ind)
               not on size error
                   move ind to z-ind
                   move result to pretty-result
                   display "factorial(" z-ind ") = " pretty-result
           end-add
       end-perform

       goback.
       end program fact.

factorial( 0) =                  1
factorial( 1) =                  1
factorial( 2) =                  2
factorial( 3) =                  6
factorial( 4) =                 24
factorial( 5) =                120
factorial( 6) =                720
factorial( 7) =               5040
factorial( 8) =              40320
factorial( 9) =             362880
factorial(10) =            3628800
factorial(11) =           39916800
factorial(12) =          479001600
factorial(13) =         6227020800
factorial(14) =        87178291200
factorial(15) =      1307674368000
factorial(16) =     20922789888000
factorial(17) =    355687428096000
factorial(18) =   6402373705728000
factorial(19) = 121645100408832000
overflow at 20, result undefined, 432902008176640000
overflow at 21, result undefined, 197454024290336768

display formatted-current-date("YYYY-Www-D")
2015-W49-3

display formatted-current-date("YYYY-MM-DD")
2015-12-02

display formatted-current-date("YYYY-MM-DDThh:mm:ss+hh:mm")
2015-12-02T03:47:05-05:00

display formatted-current-date("YYYY-MM-DDThh:mm:ssZ")
2015-12-02T08:47:05Z

display formatted-current-date("YYYY-MM-DDThh:mm:ss+hh:mm")
2015-12-02T03:47:05000:00

display formatted-date("YYYY-MM-DD",
          integer-of-date(numval(current-date(1:8))))
display formatted-date("YYYY-Www-D",
          integer-of-date(numval(current-date(1:8))))

2015-12-02
2015-W49-3

Wednesday, February 15, 1995, at 05:14:27.812479168304 Eastern Standard Time

identification division.
program-id. formatted-time-sample.

environment division.
configuration section.
repository.
    function all intrinsic.

procedure division.
display current-date
display seconds-past-midnight
display formatted-time("hh:mm:ss", seconds-past-midnight)
display
  formatted-time("hh:mm:ss+hh:mm", seconds-past-midnight, -300)

goback.
end program formatted-time-sample.

prompt$ cobc -xj formatted-time-sample
201512012253247400000
000082404
22:53:24
22:53:24-05:00

DISPLAY FUNCTION FRACTION-PART(FUNCTION E)
DISPLAY FUNCTION FRACTION-PART(-1.5)
DISPLAY FUNCTION FRACTION-PART(-1.0)
DISPLAY FUNCTION FRACTION-PART(1)

+.718281828459045235
-.500000000000000000
+.000000000000000000
+.000000000000000000

GNU    >>SOURCE FORMAT IS FIXED
Cobol *>*************************************************
      *>****P* gcfaq/highest-algebraic
      *> TECTONICS
      *>   cobc -x highest-algebraic.cob
      *> SOURCE
       identification division.
       program-id. function-highest-algebraic.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 some-money              pic 9(5)9v99 value 4242.
       01 show-money              pic $zzzz9.99.
       01 some-pennies            pic v99 value 0.06.

       01 newline                 pic x value x"0a".

      *> ************************************************
       procedure division.
       move some-money to show-money

       display
           some-money " : " highest-algebraic(some-money) newline
           show-money " : " highest-algebraic(show-money) newline
           some-pennies " : " highest-algebraic(some-pennies)

       goback.
       end program function-highest-algebraic.

./highest-algebraic
004242.00 : 0999999.99
 $4242.00 : 0099999.99
.06 : 0000000.99

DISPLAY
    FUNCTION INTEGER (-3)      SPACE
    FUNCTION INTEGER (-3.141)
DISPLAY
    FUNCTION INTEGER (3)       SPACE
    FUNCTION INTEGER (3.141)
DISPLAY
    FUNCTION INTEGER (-0.3141) SPACE
    FUNCTION INTEGER (0.3141)  SPACE
    FUNCTION INTEGER (0)

-000000000000000003 -000000000000000004
+000000000000000003 +000000000000000003
-000000000000000001 +000000000000000000 +000000000000000000

display integer-of-formatted-date("YYYY-Www-D", "2014-W01-1")
150844

display integer-of-formatted-date("YYYY-MM-DD", "2013-12-30")
150844

display integer-of-formatted-date("YYYY-DDD", "2013-364")
150844

DISPLAY
    FUNCTION INTEGER-PART (-3)      SPACE
    FUNCTION INTEGER-PART (-3.141)
DISPLAY
    FUNCTION INTEGER-PART (3)       SPACE
    FUNCTION INTEGER-PART (3.141)
DISPLAY
    FUNCTION INTEGER-PART (-0.3141) SPACE
    FUNCTION INTEGER-PART (0.3141)  SPACE
    FUNCTION INTEGER-PART (0)

-000000000000000003 -000000000000000003
+000000000000000003 +000000000000000003
+000000000000000000 +000000000000000000 +000000000000000000

working storage.
01 nat     pic n(10).
01 cha     pic x(10).
01 bin     constant as h'ff'.

01 num     pic s9(8)v9(8).
01 form    pic $-z(7)9.9(8).

procedure division.
display
    function length(nat) space
    function length(cha) space
    function length(bin)
end-display
display
    function length(num) space
    function length(form)
end-display

20 10 3
16 19

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20120116
      *> Purpose:   Demonstrate locale functions
      *> Tectonics: cobc -x locales.cob
      *> ***************************************************************
       identification division.
       program-id. locales.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

      *> -*********-*********-*********-*********-*********-*********-**
       procedure division.

      *> Display cultural norm date and times as set in environment.
      *>   Google LC_ALL.
      *> 20120622 represents June 22 2012
      *> 141516 represents 2pm (14th hour), 15 minutes, 16 seconds
      *> 39600 represents 11 hours in seconds

       display locale-date(20120622)
       display locale-time(141516)
       display locale-time-from-seconds(39600)

       goback.
       end program locales.

[btiffin@home cobol]$ cobc -x locales.cob
[btiffin@home cobol]$ ./locales
06/22/2012
02:15:16 PM
11:00:00 AM

[btiffin@home cobol]$ export LANG='en_CA.utf8'
[btiffin@home cobol]$ ./locales
22/06/12
02:15:16 PM
11:00:00 AM

[btiffin@home cobol]$ export LANG=en_DK.utf8
[btiffin@home cobol]$ ./locales
2012-06-22
14:15:16
11:00:00

[btiffin@home cobol]$ LANG=en_HK.utf8 ./locales
Sunday, June 22, 2012
02:15:16 EST
11:00:00 EST

$ locs=( $(locale -a) )
$ for l in ${locs[@]}; do echo $l; LANG=$l ./locales; done

000100 >>SOURCE FORMAT IS FIXED
000200*> ***************************************************************
000300*> Author:    Brian Tiffin
000400*> Date:      20120116
000500*> Purpose:   Demonstrate locale function invalid arguments
000600*> Tectonics: cobc -x -g -debug locales.cob
000700*> ***************************************************************
000800 identification division.
000900 program-id. locales.
001000
001100 environment division.
001200 configuration section.
001300 repository.
001400     function all intrinsic.
001500
001600*> -*********-*********-*********-*********-*********-*********-**
001700 procedure division.
001800
001900*> Display cultural norm date and times as set in environment.
002000*>   Google LC_ALL.
002100*> 20120622 represents June 22 2012
002200*> 141516 represents 2pm (14th hour), 15 minutes, 16 seconds
002300*> 39600 represents 11 hours in seconds
002400
002500 display locale-date(20120622)
002600 display locale-time(141516)
002700 display locale-time-from-seconds(39600)
002800
002900*> invalid arguments are detected through EXCEPTION-STATUS
003000 display locale-date(20120699)
003100 DISPLAY "EXCEPTION-STATUS: " EXCEPTION-STATUS
003200 DISPLAY "EXCEPTION-STATEMENT: " EXCEPTION-STATEMENT
003300 DISPLAY "EXCEPTION-LOCATION: " EXCEPTION-LOCATION
003400
003500 display locale-time(941516)
003600 DISPLAY "EXCEPTION-STATUS: " EXCEPTION-STATUS
003700 DISPLAY "EXCEPTION-STATEMENT: " EXCEPTION-STATEMENT
003800 DISPLAY "EXCEPTION-LOCATION: " EXCEPTION-LOCATION
003900
004000 display locale-time-from-seconds(-39600)
004100
004200 goback.
004300 end program locales.

$ ./locales
06/22/2012
02:15:16 PM
11:00:00 AM

EXCEPTION-STATUS: EC-ARGUMENT-FUNCTION
EXCEPTION-STATEMENT: DISPLAY
EXCEPTION-LOCATION: locales; MAIN PARAGRAPH OF MAIN SECTION; 30

EXCEPTION-STATUS: EC-ARGUMENT-FUNCTION
EXCEPTION-STATEMENT: DISPLAY
EXCEPTION-LOCATION: locales; MAIN PARAGRAPH OF MAIN SECTION; 35
-11:00:00 AM

DISPLAY FUNCTION LOG(100)
DISPLAY FUNCTION LOG(FUNCTION E)

4.60517018598809137
000000001

DISPLAY FUNCTION LOG10(100)

000000002

DISPLAY FUNCTION MAX ( "def"; "abc"; )
DISPLAY FUNCTION MAX ( 123.1; 123.11; 123 )

def
123.11

DISPLAY FUNCTION MEAN( 1; 2; 3; 4; 5; 6; 7; 8; 9 )

+5.00000000000000000

DISPLAY FUNCTION MEDIAN( 1; 2; 3; 4; 5; 6; 7; 8; 9 )

5

DISPLAY FUNCTION MIDRANGE( 1; 2; 3; 4; 5; 6; 7; 8; 9 )

5.000000000000000000

DISPLAY FUNCTION MIN ( "def"; "abc";)
DISPLAY FUNCTION MIN ( 123.1; 123.11; 123 )

abc
123

DISPLAY FUNCTION MOD( 123; 23 )

+000000000000000008

GNU
COBOL
       IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog.
       ENVIRONMENT      DIVISION.
       DATA             DIVISION.
       WORKING-STORAGE SECTION.
       PROCEDURE        DIVISION.
           CALL "prog2"
           END-CALL.
           STOP RUN.
       END PROGRAM prog.

       IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog2.
       ENVIRONMENT      DIVISION.
       DATA             DIVISION.
       WORKING-STORAGE SECTION.
       01 newline       pic x value x"0a".

       PROCEDURE        DIVISION.
           DISPLAY
               FUNCTION MODULE-CALLER-ID           newline
               FUNCTION MODULE-DATE                newline
               FUNCTION MODULE-FORMATTED-DATE      newline
               FUNCTION MODULE-ID                  newline
               FUNCTION MODULE-PATH                newline
               FUNCTION MODULE-SOURCE              newline
               FUNCTION MODULE-TIME
           END-DISPLAY.
           EXIT PROGRAM.

prompt$ date
Thu Sep  4 04:01:32 EDT 2014

prompt$ cobc -xj module-dash.cob
prog
20140904
Sep 04 2014 04:01:34
prog2
/home/btiffin/lang/cobol/module-dash
module-dash.cob
040134

display 0 upon argument-number
accept progname from argument-value
display "argument-value zero :" progname ":"

      *>
      *> monetary-decimal-point.cob
      *> Tectonics: cobc -xj monetary-decimal-point.cob
      *>
       >>SOURCE FORMAT IS FIXED
       identification division.
       program-id. monetary-decimal-point.

       procedure division.
       demonstrate-intrinsic.

       display "FUNCTION MONETARY-DECIMAL-POINT is """
           function monetary-decimal-point """, character code "
           function ord(function monetary-decimal-point)
       end-display
       .

       goback.
       end program monetary-decimal-point.

prompt$ cobc -W -xj monetary-decimal-point.cob
FUNCTION MONETARY-DECIMAL-POINT is ".", character code 000000047

      *>
      *> monetary-thousands-separator.cob
      *> Tectonics: cobc -xj monetary-thousands-separator.cob
      *>
       >>SOURCE FORMAT IS FIXED
       identification division.
       program-id. monetary-thousands-separator.

       procedure division.
       demonstrate-intrinsic.

       display "FUNCTION MONETARY-THOUSANDS-SEPARATOR is """
           function monetary-thousands-separator """, character code "
           function ord(function monetary-thousands-separator)
       end-display
       .

       goback.
       end program monetary-thousands-separator.

prompt$ cobc -W -xj monetary-thousands-separator.cob
FUNCTION MONETARY-THOUSANDS-SEPARATOR is ",", character code 000000045

GCobol IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog.
       DATA             DIVISION.
       WORKING-STORAGE  SECTION.
       01  X   PIC   X(12) VALUE " -9876.1234 ".
       01  F   PIC   X(12) VALUE "B-9876.1234 ".
       PROCEDURE        DIVISION.
           DISPLAY FUNCTION NUMVAL ( X )
           DISPLAY FUNCTION NUMVAL ( F )
           STOP RUN.

-09876.1234
000000000

GCobol IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog.
       DATA             DIVISION.
       WORKING-STORAGE  SECTION.
       01  X   PIC   X(14) VALUE " % -9876.1234 ".
       PROCEDURE        DIVISION.
           DISPLAY FUNCTION NUMVAL-C ( X , "%" )
           END-DISPLAY.
           STOP RUN.

-09876.1234

GCobol IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog.
       DATA             DIVISION.
       WORKING-STORAGE  SECTION.
       01  X   PIC   X(12) VALUE " -0.1234E+4 ".
       PROCEDURE        DIVISION.
           DISPLAY FUNCTION NUMVAL-F ( X )
           END-DISPLAY.
           STOP RUN.

-000001234

DISPLAY FUNCTION ORD("J")

00000075

DISPLAY ORD-MAX( 9; 8; 7; 6; 5; 4; 3; 2; 1 )
DISPLAY ORD-MAX( 'abc'; 'def'; 'ghi' )

00000001
00000003

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20090531
      *> Purpose:   Demonstration of FUNCTION ORD-MIN and REPOSITORY
      *> Tectonics: cobc -x ordmin.cob
      *> ***************************************************************
       identification division.
       program-id. ordmin.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 posmin               pic 9(8).

      *> ***************************************************************
       procedure division.
       move ord-min ( 9; 8; 7; 6; 5; 4; 3; 2; 1; 2; 3; 4; 5 ) to posmin
       display posmin
       move ord-min ("abc"; "def"; "000"; "def"; "abc") to posmin
       display posmin
       goback.
       end program ordmin.

00000009
00000003

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20101030
      *> Purpose:   Demonstrate PI
      *> Tectonics: cobc -x pi-demo.cob
      *> ***************************************************************
       identification division.
       program-id. pi-demo.

       data division.
       working-storage section.
       01 args pic x(80).
       01 diameter pic 999 value 1.
       01 show-diameter pic zz9.
       01 circumference usage float-long.
       01 plural pic xx.
       01 plural-length pic 9 value 1.
       01 newline pic x value x'0a'.

      *> ***************************************************************
       procedure division.
       accept args from command-line end-accept
       if args not equal spaces
           move args to diameter
       end-if

       if diameter not equal 1
           move "s " to plural
           move 2 to plural-length
       else
           move "  " to plural
           move 1 to plural-length
       end-if
       move diameter to show-diameter

       display "FUNCTION PI is " function pi newline

       compute circumference = function pi * diameter
       display
           "A wheel, " show-diameter " metre" plural(1:plural-length)
           "wide will roll, very close to but only approximately, "
           newline circumference " metres in ONE full rotation."
           newline

       goback.
       end program pi-demo.

$ cobc -x pi-demo.cob && ./pi-demo && ./pi-demo 42
FUNCTION PI is 3.1415926535897932384626433832795029

A wheel,   1 metre wide will roll, very close to but only approximately,
3.14159265358979312 metres in ONE full rotation.

FUNCTION PI is 3.1415926535897932384626433832795029

A wheel,  42 metres wide will roll, very close to but only approximately,
131.946891450771318 metres in ONE full rotation.

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20101030
      *> Purpose:   Demo of PRESENT-VALUE
      *> Tectonics: cobc -x present-value-demo.cob
      *> ***************************************************************
       identification division.
       program-id. present-value-demo.

       data division.
       working-storage section.
       01 args pic x(80).
       01 newline pic x value x'0a'.
       01 rate pic s9v9999 value 0.7000.
       01 the-value pic s9(6)v99.

      *> ***************************************************************
       procedure division.
       accept args from command-line end-accept

       if args not equal to spaces
           move args to rate
       end-if

       compute the-value rounded =
           function present-value(rate; 1000, 1010, 1000, 1100)
       end-compute
       display
            "A discount rate of " rate " gives a PRESENT-VALUE of "
            the-value " given" newline
            "end-amounts of 1000, 1010, 1000 and 1100"

       compute the-value rounded =
           function present-value(rate; 1000, 1000, 1000, 1000)
       display
            "A discount rate of " rate " gives a PRESENT-VALUE of "
            the-value " given" newline
            "end-amounts of 1000, 1000, 1000 and 1000"

       goback.
       end program present-value-demo.

$ ./present-value-demo
A discount rate of +0.7000 gives a PRESENT-VALUE of +001272.96 given
end-amounts of 1000, 1010, 1000 and 1100
A discount rate of +0.7000 gives a PRESENT-VALUE of +001257.53 given
end-amounts of 1000, 1000, 1000 and 1000
$ ./present-value-demo 0.333
A discount rate of +0.3330 gives a PRESENT-VALUE of +002089.18 given
end-amounts of 1000, 1010, 1000 and 1100
A discount rate of +0.3330 gives a PRESENT-VALUE of +002051.88 given
end-amounts of 1000, 1000, 1000 and 1000
$ ./present-value-demo 0.935
A discount rate of +0.9350 gives a PRESENT-VALUE of +001003.03 given
end-amounts of 1000, 1010, 1000 and 1100
A discount rate of +0.9350 gives a PRESENT-VALUE of +000993.23 given
end-amounts of 1000, 1000, 1000 and 1000

./configure --with-python[=PYTHON]

- PYAPI-FINALIZE, finalize the Python instance
- PYAPI-REPORT, toggles printing of exception reports

display function python("result = 'abcde' * 3")

abcdeabcdeabcde

display python("result = _ * 3")(26:5)

abcde

move function python(
    "import sys; result = 'Args: %s and %s' % sys.argv[0] + sys.argv[1]"
    "first argument")
  to answer
display trim(answer)

Args: GnuCOBOL and first argument

COPY pyapi.

...

move python(PYAPI-FINALIZE) to extraneous
move python(PYAPI-REPORT) to extraneous
move python("result = _") to answer
display SCRIPT-RETURN-CODE
display FUNCTION EXCEPTION-STATUS
display ":" answer ":"

Traceback (most recent call last):
  File "<string>", line 1, in <module>
NameError: name '_' is not defined
1
EC-IMP-SCRIPT
::

"You got chocolate in my peanut butter!"
"You got peanut butter on my chocolate!"

"You got ketchup on my ice cream!"
"You got cake in my mustard!"

"Mmmm, pie."

DISPLAY FUNCTION RANDOM(1)
DISPLAY FUNCTION RANDOM(1)
DISPLAY FUNCTION RANDOM()

+00000000.1804289383
+00000000.1804289383
+000000000.846930886

*> Modified: 2016-06-14/00:51-0400
 COPY sample-template REPLACING
 ==:DATABOOK:== BY
 ==

 01 random-float         usage float-long.
 01 random-integer       pic 99.

 01 results.
    05 hits              pic 9(9) occurs 10 times.
 01 first-ten            pic 99.

 ==
 ==:CODEBOOK:== BY
 ==

*> compute random-float = random(0)
 perform 1000000 times
     compute random-float = random() * 10.0
     compute random-integer = random-float + 1.0
     if random-integer < 1 or > 10 then
         display "anomaly: " random-integer upon syserr
     end-if
     add 1 to hits(random-integer)
     if first-ten < 10 then
         display random-integer space with no advancing
         add 1 to first-ten
     end-if
 end-perform
 display "..."

 perform varying tally from 1 by 1 until tally > 10
     display tally ": " hits(tally)
 end-perform

 ==
 .

prompt$ cobc -xj random-sample.cob
09 04 08 08 10 02 04 08 03 06 ...
00001: 000100016
00002: 000099912
00003: 000099720
00004: 000100144
00005: 000100198
00006: 000100247
00007: 000099943
00008: 000099658
00009: 000100128
00010: 000100034

prompt$ ./random-sample
09 04 08 08 10 02 04 08 03 06 ...
00001: 000100016
00002: 000099912
00003: 000099720
00004: 000100144
00005: 000100198
00006: 000100247
00007: 000099943
00008: 000099658
00009: 000100128
00010: 000100034

GCOBOL identification division.

       program-id.             randomtest.

       environment division.

       configuration section.

       source-computer.

           cray-1
      *           with debugging mode
           .

       data division.

       working-storage section.

       01  answer-signed          pic S9(09).
       01  show-answer            pic z9999+.
       01  x                      pic s9.
       01  num-ran    pic v9(9) value zeroes.
       01  re-num-ran pic 9.9(9) value zeroes.
       01  seed       pic s9(9) binary.
       01  j          pic s9(9) binary value zeroes.
       01  datetime21 pic x(21).

       procedure division.

            move function current-date to datetime21
            move datetime21(8:9) to seed
      *     display 'seed=' seed
           compute num-ran = function random (seed)
      *    display 'num-ran = ' num-ran

           perform 10000000 times
               move num-ran to re-num-ran
               move re-num-ran(3:9) to seed
      *        display 're-num-ran = ' re-num-ran
      *        display 'seed = ' seed
               compute num-ran = function random ()
      *        display 'num-ran = ' num-ran
               display  num-ran
           end-perform

           stop run
           .

For a more secure seed: store the bytes 8-14 first in an alphanumeric
redefined variable, then move it with function REVERSE to another redefined
one, check which is greater, subtract the other one from it.  This was always
enough random for my cases.  If you want to run a casino take the result and
do a byte shift or some similar stuff of the result with the original value.

DISPLAY FUNCTION RANGE(1; 2; 3; 4; 5; 6; 7; 8; 9)

+000000000000000008

DISPLAY FUNCTION REM(123; 23)

+000000000000000008

DISPLAY FUNCTION REVERSE("abc")

cba

./configure --with-rexx

MOVE FUNCTION REXX("return ARG(1) * ARG(2)", 6, 7)
  TO answer

DISPLAY FUNCTION REXX("abc = xyz; return abc || zy")

COMPUTE answer = FUNCTION NUMVAL(FUNCTION REXX("return 6")) * 7

./configure --with-rexx

GCobol IDENTIFICATION   DIVISION.
       PROGRAM-ID.      prog.
       DATA             DIVISION.
       WORKING-STORAGE  SECTION.
       01  X   PIC      X(6)   VALUE "hhmmss".
       01  Y   PIC      9(8)   COMP-5.
       01  Z   PIC      X(6)   VALUE "010203".
       PROCEDURE        DIVISION.
           MOVE FUNCTION SECONDS-FROM-FORMATTED-TIME (X, Z) TO Y.
           IF Y NOT = 3723
                   DISPLAY Y
                   END-DISPLAY
           END-IF.
           STOP RUN.

identification division.
program-id. second-past-midnight-sample.

environment division.
configuration section.
repository.
    function all intrinsic.

procedure division.
display current-date
display seconds-past-midnight
display formatted-time("hh:mm:ss", seconds-past-midnight)

goback.
end program second-past-midnight-sample.

prompt$ cobc -xj seconds-past-midnight-sample.cob
201512012253247400000
000082404
22:53:2

#!/usr/local/bin/cobc -xj

       COPY line-sequential-template REPLACING
       ==:INPUT-NAME:== BY =="no-input"==
       ==:OUTPUT-NAME:== BY =="sin-plot.gp"==

       ==:DATABOOK:== BY
       ==

       01 gnuplot.
          05 value
          'set terminal dumb ; set grid ; set tics scale 0 ; ' &
          'set title "FUNCTION SIN" ; plot "-" using 1:2 with lines'.

       01 x            pic s9v99.
       01 domain       pic s9v99.
       01 degrees      pic s999v9.
       01 answer       pic s9(5)v9(5).

       01 output-data-line.
          05 x-out     pic -9.99.
          05           pic x value space.
          05 ans-out   pic -9(5).9(5).

       ==
       ==:CODEBOOK:== BY
       ==

       perform open-files

       move length(gnuplot) to output-actual
       move gnuplot to output-line
       perform write-output

       compute domain = pi * 3
       move length(output-data-line) to output-actual
       perform varying x from 0.0 by 0.25 until x > domain
           compute degrees rounded = x * 180 / pi
           move sin(x) to answer
           display "sin(" x ") ~= sin(" degrees "°) ~= " answer

           move x to x-out
           move answer to ans-out
           move output-data-line to output-line
           perform write-output
       end-perform

       perform close-files

       call "SYSTEM" using "gnuplot sin-plot.gp"

       perform delete-output
       ==
       .

$ ./sin-sample.cob
sin(+0.00) ~= sin(+000.0°) ~= +00000.00000
sin(+0.25) ~= sin(+014.3°) ~= +00000.24740
sin(+0.50) ~= sin(+028.6°) ~= +00000.47942
sin(+0.75) ~= sin(+043.0°) ~= +00000.68163
sin(+1.00) ~= sin(+057.3°) ~= +00000.84147
sin(+1.25) ~= sin(+071.6°) ~= +00000.94898
sin(+1.50) ~= sin(+085.9°) ~= +00000.99749
sin(+1.75) ~= sin(+100.3°) ~= +00000.98398
sin(+2.00) ~= sin(+114.6°) ~= +00000.90929
sin(+2.25) ~= sin(+128.9°) ~= +00000.77807
sin(+2.50) ~= sin(+143.2°) ~= +00000.59847
sin(+2.75) ~= sin(+157.6°) ~= +00000.38166
sin(+3.00) ~= sin(+171.9°) ~= +00000.14112
sin(+3.25) ~= sin(+186.2°) ~= -00000.10819
sin(+3.50) ~= sin(+200.5°) ~= -00000.35078
sin(+3.75) ~= sin(+214.9°) ~= -00000.57156
sin(+4.00) ~= sin(+229.2°) ~= -00000.75680
sin(+4.25) ~= sin(+243.5°) ~= -00000.89498
sin(+4.50) ~= sin(+257.8°) ~= -00000.97753
sin(+4.75) ~= sin(+272.2°) ~= -00000.99929
sin(+5.00) ~= sin(+286.5°) ~= -00000.95892
sin(+5.25) ~= sin(+300.8°) ~= -00000.85893
sin(+5.50) ~= sin(+315.1°) ~= -00000.70554
sin(+5.75) ~= sin(+329.5°) ~= -00000.50827
sin(+6.00) ~= sin(+343.8°) ~= -00000.27941
sin(+6.25) ~= sin(+358.1°) ~= -00000.03317
sin(+6.50) ~= sin(+372.4°) ~= +00000.21511
sin(+6.75) ~= sin(+386.7°) ~= +00000.45004
sin(+7.00) ~= sin(+401.1°) ~= +00000.65698
sin(+7.25) ~= sin(+415.4°) ~= +00000.82308
sin(+7.50) ~= sin(+429.7°) ~= +00000.93799
sin(+7.75) ~= sin(+444.0°) ~= +00000.99459
sin(+8.00) ~= sin(+458.4°) ~= +00000.98935
sin(+8.25) ~= sin(+472.7°) ~= +00000.92260
sin(+8.50) ~= sin(+487.0°) ~= +00000.79848
sin(+8.75) ~= sin(+501.3°) ~= +00000.62472
sin(+9.00) ~= sin(+515.7°) ~= +00000.41211
sin(+9.25) ~= sin(+530.0°) ~= +00000.17388


                                  FUNCTION SIN

    1 +------+******+------+------+------+-----+------+----****-----+------+
      |      *      **     :      :      :     :      "-" using 1:2 ****** |
  0.8 +.....*.........*................................**........*.........+
      |    * :      :  *   :      :      :     :      *      :    * :      |
  0.6 +...*............*..............................*............*.......+
  0.4 +..*..............*............................*..............*......+
      |  *   :      :    * :      :      :     :    * :      :      :*     |
  0.2 +.*.................*........................*..................*....+
      |*     :      :      *      :      :     :  *   :      :      :      |
    0 *.....................*....................*.........................+
      |      :      :      :*     :      :     :*     :      :      :      |
 -0.2 +......................*..................*..........................+
      |      :      :      :  *   :      :     *      :      :      :      |
 -0.4 +........................*...............*...........................+
 -0.6 +.........................*............**............................+
      |      :      :      :     *:      :  *  :      :      :      :      |
 -0.8 +...........................*........*...............................+
      |      :      :      :      :**    :*    :      :      :      :      |
   -1 +------+------+------+------+--*****-----+------+------+------+------+
      0      1      2      3      4      5     6      7      8      9      10

DISPLAY FUNCTION SQRT(-1)
CALL "perror" USING NULL RETURNING OMITTED
DISPLAY FUNCTION SQRT(2)

0.000000000000000000
Numerical argument out of domain
1.414213562373095145

DISPLAY
    FUNCTION STANDARD-DEVIATION(1 2 3 4 5 6 7 8 9 10) SPACE
    FUNCTION STANDARD-DEVIATION(1 2 3 4 5 6 7 8 9 100)

2.872281323269014308 28.605069480775604518

identification division.
program-id. stored-char-length-sample.

environment division.
configuration section.
repository.
    function all intrinsic.

data division.
working-storage section.
01 work-area pic x(20) value "default value".

procedure division.
display ":" work-area ": " stored-char-length(work-area)

move spaces to work-area
display ":" work-area ": " stored-char-length(work-area)

move "/usr/local/bin/" to work-area
display ":" work-area ": " stored-char-length(work-area)

inspect work-area(1:stored-char-length(work-area))
  replacing trailing "/" by " "
display ":" work-area ": " stored-char-length(work-area)

goback.
end program stored-char-length-sample.

prompt$ cobc -xj stored-char-length-sample.cob
:default value       : 000000013
:                    : 000000000
:/usr/local/bin/     : 000000015
:/usr/local/bin      : 000000014

DISPLAY
    FUNCTION SUBSTITUTE("this is a test",
        "this", "that",
        "is a", "was",
        "test", "very cool!")

that was very cool!

SUBSTITUTE(subject, lit-pat-1, repl-1 [, litl-pat-2, repl-2, ...])

MOVE FUNCTION SUBSTITUTE(subject, pat, repl)(2:4) TO xvar4

display substitute("ABCDEF-GHIJKL",
                   "abcdef-", "abc case ")

display substitute-case("ABCDEF-GHIJKL",
                        "abcdef-", "abc case ")

ABCDEF-GHIJKL
abc case GHIJKL

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-10/22:47-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 aggregate  pic s9(7).
       01 show-total pic -,---,--9.

       01 samples-table.
          05 sample-values.
             10 filler pic 9(6) value 1.
             10 filler pic 9(6) value 50000.
             10 filler pic 9(6) value 100000.
             10 filler pic 9(6) value 200000.
             10 filler pic 9(6) value 151550.
          05 filler redefines sample-values.
             10 s pic 9(6) occurs 5 times indexed by lot.
       ==
       ==:CODEBOOK:== BY
       ==

       move sum(s(1), s(2), s(3), s(4), s(5)) to aggregate show-total
       display show-total
       display aggregate

       move sum(-s(1), -s(2), -s(3), -s(4), -s(5)) to show-total
       display show-total

       ==
       .

prompt$ ./sum-sample.cob
  501,551
+0501551
 -501,551

#!/usr/local/bin/cobc -xj

       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 x            pic s9v99.
       01 domain       pic s9v9(5).
       01 degrees      pic s999v9.
       01 answer       pic s9(5)v9(5).

       ==
       ==:CODEBOOK:== BY
       ==

       perform varying x from -1.0 by 0.25 until x > 1.0
           compute domain = pi * x
           compute degrees rounded = domain * 180 / pi
           move tan(domain) to answer
           display "tan(" domain ") ~= tan(" degrees "°) ~= " answer
       end-perform

       ==
       .

prompt$ cobc -xj tan-sample.cob
tan(-3.14159) ~= tan(-180.0°) ~= +00000.00000
tan(-2.35619) ~= tan(-135.0°) ~= +00001.00000
tan(-1.57079) ~= tan(-090.0°) ~= -58057.91341
tan(-0.78539) ~= tan(-045.0°) ~= -00000.99998
tan(+0.00000) ~= tan(+000.0°) ~= +00000.00000
tan(+0.78539) ~= tan(+045.0°) ~= +00000.99998
tan(+1.57079) ~= tan(+090.0°) ~= +58057.91341
tan(+2.35619) ~= tan(+135.0°) ~= -00001.00000
tan(+3.14159) ~= tan(+180.0°) ~= +00000.00000

#!/usr/local/bin/cobc -xj

       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 result pic 9.

       01 sample-table.
          05 pic 9(8) value 0.
          05 pic 9(8) value 16000102.

          05 pic 9(8) value 16010101.
          05 pic 9(8) value 20151225.

          05 pic 9(8) value 20151325.
          05 pic 9(8) value 20151232.

          05 pic 9(8) value 20000229.
          05 pic 9(8) value 19000229.

       01 redefines sample-table.
          05 sample pic 9(8) occurs 8 times indexed by lot.

       ==
       ==:CODEBOOK:== BY
       ==

       perform varying lot from 1 by 1 until lot > 8
           move test-date-yyyymmdd(sample(lot)) to result
           display "test-date-yyyymmdd(" sample(lot) ") returns " result
              with no advancing
           if result greater than 0 then
               display " fail"
           else
               display " ok"
           end-if

       end-perform

       ==
       .

prompt$ ./test-date-sample.cob
test-date-yyyymmdd(00000000) returns 1 fail
test-date-yyyymmdd(16000102) returns 1 fail
test-date-yyyymmdd(16010101) returns 0 ok
test-date-yyyymmdd(20151225) returns 0 ok
test-date-yyyymmdd(20151325) returns 2 fail
test-date-yyyymmdd(20151232) returns 3 fail
test-date-yyyymmdd(20000229) returns 0 ok
test-date-yyyymmdd(19000229) returns 3 fail

#!/usr/local/bin/cobc -xj

       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 result pic 9.

       01 sample-table.
          05 pic 9(7) value 0.
          05 pic 9(7) value 1601000.

          05 pic 9(7) value 1601001.
          05 pic 9(7) value 2015350.

          05 pic 9(7) value 2000366.
          05 pic 9(7) value 1900366.

       01 redefines sample-table.
          05 sample pic 9(7) occurs 6 times indexed by lot.

       ==
       ==:CODEBOOK:== BY
       ==

       perform varying lot from 1 by 1 until lot > 6
           move test-day-yyyyddd(sample(lot)) to result
           display "test-day-yyyyddd(" sample(lot) ") returns " result
              with no advancing
           if result greater than 0 then
               display " fail"
           else
               display " ok"
           end-if

       end-perform

       ==
       .

prompt$ ./test-day-yyyyddd-sample.cob
test-day-yyyyddd(0000000) returns 1 fail
test-day-yyyyddd(1601000) returns 2 fail
test-day-yyyyddd(1601001) returns 0 ok
test-day-yyyyddd(2015350) returns 0 ok
test-day-yyyyddd(2000366) returns 0 ok
test-day-yyyyddd(1900366) returns 2 fail

display test-formatted-datetime("YYYYDDD", "1999001")
0
display test-formatted-datetime("YYYYDDD", "19A9001")
3
display test-formatted-datetime("hhmmss", "250101")
2
display test-formatted-datetime("hh:mm:ss+hh:mm", "232323-05:00")
0

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-10/23:34-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 lots constant as 7.
       01 samples-table.
          05 sample-values.
             10 value "$101.10 DB".
             10 value "$101.10 CR".
             10 value "$101.10 cr".
             10 value "#101010.10".
             10 value "#101.10 CR".
             10 value "-#10101.01".
             10 value "          ".
          05 filler redefines sample-values.
             10 sample pic x(10) occurs lots times indexed by lot.
       ==
       ==:CODEBOOK:== BY
       ==

       perform varying lot from 1 by 1 until lot > lots
           display "$: " sample(lot) " -> " test-numval-c(sample(lot))
           display "#: " sample(lot) " -> "
               test-numval-c(sample(lot), "#") with no advancing
           if test-numval-c(sample(lot), "#") equal 0 then
               display " = " numval-c(sample(lot), "#")
           else
               display space
           end-if
           display space

       end-perform

       ==
       .

prompt$ ./test-numval-c-sample.cob
$: $101.10 DB -> 000000000
#: $101.10 DB -> 000000001

$: $101.10 CR -> 000000000
#: $101.10 CR -> 000000001

$: $101.10 cr -> 000000009
#: $101.10 cr -> 000000001

$: #101010.10 -> 000000001
#: #101010.10 -> 000000000 = 00101010.1

$: #101.10 CR -> 000000001
#: #101.10 CR -> 000000000 = -00000101.1

$: -#10101.01 -> 000000002
#: -#10101.01 -> 000000000 = -0010101.01

$:            -> 000000011
#:            -> 000000011

#!/usr/local/bin/cobc -xj

      *> Modified: 2015-12-11/00:02-0500
       COPY sample-template REPLACING
       ==:DATABOOK:== BY
       ==

       01 lots constant as 5.
       01 samples-table.
          05 sample-values.
             10 value "101.99   ".
             10 value "101.99E01".
             10 value "101.99E+2".
             10 value "101.99E-2".
             10 value "          ".
          05 filler redefines sample-values.
             10 sample pic x(9) occurs lots times indexed by lot.

       ==
       ==:CODEBOOK:== BY
       ==

       perform varying lot from 1 by 1 until lot > lots
           display sample(lot) " -> " test-numval-f(sample(lot))
              with no advancing
           if test-numval-f(sample(lot)) equal 0 then
               display " = " numval-f(sample(lot))
           else
               display space
           end-if

       end-perform

       ==
       .

prompt$ ./test-numval-f-sample.cob
101.99    -> 000000000 = 0000101.99
101.99E01 -> 000000008
101.99E+2 -> 000000000 = 000010199
101.99E-2 -> 000000000 = 00001.0199
          -> 000000010

DISPLAY '"' FUNCTION TRIM("   abc   ") '"'
DISPLAY '"' FUNCTION TRIM("   abc   " LEADING) '"'
DISPLAY '"' FUNCTION TRIM("   abc   " TRAILING) '"'

"abc"
"abc   "
"   abc"

DISPLAY FUNCTION UPPER-CASE("# 123 abc DEF #")

# 123 ABC DEF #

DISPLAY FUNCTION VARIANCE(1 2 3 4 5 6 7 8 9 100)

+818.250000000000000

program-id. whenpart1. procedure division.
display "First part :" FUNCTION WHEN-COMPILED.

program-id. whenpart2. procedure division.
display "Second part:" FUNCTION WHEN-COMPILED.

program-id. whenshow. procedure division.
call "whenpart1" end-call.
call "whenpart2" end-call.
display "Main part  :" FUNCTION WHEN-COMPILED.

$ cobc -c whenpart1.cob && sleep 15 && cobc -c whenpart2.cob &&
> sleep 15 && cobc -x whenshow.cob whenpart1.o whenpart2.o
$ ./whenshow

First part :2008082721391500-0400
Second part:2008082721393000-0400
Main part  :2008082721394500-0400

01  ws-when-compiled PIC X(8)BX(8).
...
MOVE WHEN-COMPILED TO ws-when-compiled
DISPLAY "prognam " ws-when-compiled

01 built-on      PIC xxxx/xx/xxBxx/xx/xxBxxxxxxx GLOBAL.

...

    MOVE FUNCTION WHEN-COMPILED TO built-on
    INSPECT built-on REPLACING
        ALL "/" BY ":" AFTER INITIAL SPACE
        ALL " " BY "." AFTER INITIAL SPACE
        ALL "/" BY "-"
      FIRST " " BY "/"
    DISPLAY "Built on " built-on

Built on 2015-10-27/23:32:46.00-0400

Built on 2015102723324600-0400

01 built-on             pic xxxxBxxBxx/xxBxxBxxBxxxxxxx.
01 REDEFINES built-on.
   05  PIC x(4).
   05  bo-dash-1 PIC X.
   05  PIC x(2).
   05  bo-dash-2 PIC X.
   05  PIC x(2).
   05  pic x.
   05  PIC x(2).
   05  bo-colon-1 PIC X.
   05  PIC x(2).
   05  bo-colon-2 PIC X.
   05  PIC x(2).
   05  bo-dot PIC X.
   05  PIC x(7).
01 REDEFINES built-on.
   05  PIC x(4).
   05  PIC X.
       88  bo-setdash-1 value "-".
   05  PIC x(2).
   05  PIC X.
       88  bo-setdash-2 value "-".
   05  PIC x(2).
   05  pic x.
   05  PIC x(2).
   05  PIC X.
       88  bo-setcolon-1 value ":".
   05  PIC x(2).
   05  PIC X.
       88  bo-setcolon-2 value ":".
   05  PIC x(2).
   05  PIC X.
       88  bo-setdot value ".".
   05  PIC x(7).

   ....

move function when-compiled to built-on
move ":" to bo-colon-1 bo-colon-2
move "-" to bo-dash-1 bo-dash-2
move "." to bo-dot
DISPLAY built-on
move SPACE to built-on
set bo-setdash-1
       bo-setdash-2
       bo-setcolon-1
       bo-setcolon-2
       bo-setdot
    to true

Why, when this is typically only going to be done once per program? Because,
someone is going to see it, and do something similar to a date-stamp field
in a DB table with hundreds of millions of rows.

A couple of copybooks, however, and no-one would copy the code blindly
anyway. Blind-copiers don't look at copybook contents :-)

Just to clarify the use of FUNCTION.
(Applies to 0.33)
FUNCTION (generally speaking, there are exceptions) can
be used anywhere where a source item is valid.
It always results in a new temporary field.
This will have the desired characteristics dependant
on the parameters.
eg. FUNCTION MIN (x, y, z)
with x PIC 99
     y PIC 9(8) COMP
     z PIC 9(6)V99
will result in returning a field that has
at least 8 positions before the (implied) decimal
point and 2 after.

It does NOT ever change the contents of parameters
to the function.

FUNCTION's are nestable.
eg.

DISPLAY FUNCTION REVERSE (FUNCTION UPPER-CASE (myfield)).

be used anywhere where a source item is valid.

be used anywhere where a sending field is valid.

The standard only defines FUNCTION LENGTH.
The LENGTH OF phrase is an extension (from MF)

libcob/system.def

/* COB_SYSTEM_GEN (external name, number of parameters, internal name) */

COB_SYSTEM_GEN ("SYSTEM",               1, cob_sys_system)

COB_SYSTEM_GEN ("CBL_AND",              3, cob_sys_and)
COB_SYSTEM_GEN ("CBL_CHANGE_DIR",       1, cob_sys_change_dir)
COB_SYSTEM_GEN ("CBL_CHECK_FILE_EXIST", 2, cob_sys_check_file_exist)
COB_SYSTEM_GEN ("CBL_CLOSE_FILE",       1, cob_sys_close_file)
COB_SYSTEM_GEN ("CBL_COPY_FILE",        2, cob_sys_copy_file)
COB_SYSTEM_GEN ("CBL_CREATE_DIR",       1, cob_sys_create_dir)
COB_SYSTEM_GEN ("CBL_CREATE_FILE",      5, cob_sys_create_file)
COB_SYSTEM_GEN ("CBL_DELETE_DIR",       1, cob_sys_delete_dir)
COB_SYSTEM_GEN ("CBL_DELETE_FILE",      1, cob_sys_delete_file)
COB_SYSTEM_GEN ("CBL_EQ",               3, cob_sys_eq)
COB_SYSTEM_GEN ("CBL_ERROR_PROC",       2, cob_sys_error_proc)
COB_SYSTEM_GEN ("CBL_EXIT_PROC",        2, cob_sys_exit_proc)
COB_SYSTEM_GEN ("CBL_FLUSH_FILE",       1, cob_sys_flush_file)
COB_SYSTEM_GEN ("CBL_GET_CURRENT_DIR",  3, cob_sys_get_current_dir)
COB_SYSTEM_GEN ("CBL_GET_CSR_POS",      1, cob_sys_get_csr_pos)
COB_SYSTEM_GEN ("CBL_GET_SCR_SIZE",     2, cob_sys_get_scr_size)
COB_SYSTEM_GEN ("CBL_IMP",              3, cob_sys_imp)
COB_SYSTEM_GEN ("CBL_NIMP",             3, cob_sys_nimp)
COB_SYSTEM_GEN ("CBL_NOR",              3, cob_sys_nor)
COB_SYSTEM_GEN ("CBL_NOT",              2, cob_sys_not)
COB_SYSTEM_GEN ("CBL_OPEN_FILE",        5, cob_sys_open_file)
COB_SYSTEM_GEN ("CBL_OR",               3, cob_sys_or)
COB_SYSTEM_GEN ("CBL_PUT_SCR_POS",      1, cob_sys_put_scr_pos)
COB_SYSTEM_GEN ("CBL_READ_FILE",        5, cob_sys_read_file)
COB_SYSTEM_GEN ("CBL_READ_KBD_CHAR",    1, cob_sys_get_char)
COB_SYSTEM_GEN ("CBL_RENAME_FILE",      2, cob_sys_rename_file)
COB_SYSTEM_GEN ("CBL_TOLOWER",          2, cob_sys_tolower)
COB_SYSTEM_GEN ("CBL_TOUPPER",          2, cob_sys_toupper)
COB_SYSTEM_GEN ("CBL_WRITE_FILE",       5, cob_sys_write_file)
COB_SYSTEM_GEN ("CBL_XOR",              3, cob_sys_xor)

COB_SYSTEM_GEN ("CBL_READ_CHANNEL",     3, cob_sys_read_channel)
COB_SYSTEM_GEN ("CBL_WRITE_CHANNEL",    3, cob_sys_write_channel)

COB_SYSTEM_GEN ("CBL_GC_FORK",          0, cob_sys_fork)
COB_SYSTEM_GEN ("CBL_GC_GETOPT",        6, cob_sys_getopt_long_long)
COB_SYSTEM_GEN ("CBL_GC_HOSTED",        2, cob_sys_hosted)
COB_SYSTEM_GEN ("CBL_GC_NANOSLEEP",     1, cob_sys_oc_nanosleep)
COB_SYSTEM_GEN ("CBL_GC_WAITPID",       1, cob_sys_waitpid)
COB_SYSTEM_GEN ("CBL_OC_GETOPT",        6, cob_sys_getopt_long_long)
COB_SYSTEM_GEN ("CBL_OC_HOSTED",        2, cob_sys_hosted)
COB_SYSTEM_GEN ("CBL_OC_NANOSLEEP",     1, cob_sys_oc_nanosleep)

COB_SYSTEM_GEN ("C$CALLEDBY",           1, cob_sys_calledby)
COB_SYSTEM_GEN ("C$CHDIR",              2, cob_sys_chdir)
COB_SYSTEM_GEN ("C$COPY",               3, cob_sys_copyfile)
COB_SYSTEM_GEN ("C$DELETE",             2, cob_sys_file_delete)
COB_SYSTEM_GEN ("C$FILEINFO",           2, cob_sys_file_info)
COB_SYSTEM_GEN ("C$GETPID",             0, cob_sys_getpid)
COB_SYSTEM_GEN ("C$JUSTIFY",            1, cob_sys_justify)
COB_SYSTEM_GEN ("C$MAKEDIR",            1, cob_sys_mkdir)
COB_SYSTEM_GEN ("C$NARG",               1, cob_sys_return_args)
COB_SYSTEM_GEN ("C$PARAMSIZE",          1, cob_sys_parameter_size)
COB_SYSTEM_GEN ("C$PRINTABLE",          1, cob_sys_printable)
COB_SYSTEM_GEN ("C$SLEEP",              1, cob_sys_sleep)
COB_SYSTEM_GEN ("C$TOLOWER",            2, cob_sys_tolower)
COB_SYSTEM_GEN ("C$TOUPPER",            2, cob_sys_toupper)

COB_SYSTEM_GEN ("\x91",                 2, cob_sys_x91)
COB_SYSTEM_GEN ("\xE4",                 0, cob_sys_clear_screen)
COB_SYSTEM_GEN ("\xE5",                 0, cob_sys_sound_bell)
COB_SYSTEM_GEN ("\xF4",                 2, cob_sys_xf4)
COB_SYSTEM_GEN ("\xF5",                 2, cob_sys_xf5)

COB_SYSTEM_GEN ("CBL_OC_GETOPT",            6, cob_sys_getopt_long_long)
COB_SYSTEM_GEN ("CBL_OC_HOSTED",            2, cob_sys_hosted)
COB_SYSTEM_GEN ("CBL_OC_NANOSLEEP",         1, cob_sys_oc_nanosleep)

$ cobc --list-system

System routine                  Parameters

SYSTEM                          1
CBL_AND                         3
CBL_CHANGE_DIR                  1
CBL_CHECK_FILE_EXIST            2
CBL_CLOSE_FILE                  1
CBL_COPY_FILE                   2
CBL_CREATE_DIR                  1
CBL_CREATE_FILE                 5
CBL_DELETE_DIR                  1
CBL_DELETE_FILE                 1
CBL_EQ                          3
CBL_ERROR_PROC                  2
CBL_EXIT_PROC                   2
CBL_FLUSH_FILE                  1
CBL_GET_CURRENT_DIR             3
CBL_GET_SCR_POS                 1
CBL_GET_SCR_SIZE                2
CBL_IMP                         3
CBL_NIMP                        3
CBL_NOR                         3
CBL_NOT                         2
CBL_OPEN_FILE                   5
CBL_OR                          3
CBL_PUT_SCR_POS                 1
CBL_READ_FILE                   5
CBL_READ_KBD_CHAR               1
CBL_RENAME_FILE                 2
CBL_TOLOWER                     2
CBL_TOUPPER                     2
CBL_WRITE_FILE                  5
CBL_XOR                         3
CBL_READ_CHANNEL                3
CBL_WRITE_CHANNEL               3
CBL_GC_FORK                     0
CBL_GC_GETOPT                   6
CBL_GC_HOSTED                   2
CBL_GC_NANOSLEEP                1
CBL_GC_WAITPID                  1
CBL_OC_GETOPT                   6
CBL_OC_HOSTED                   2
CBL_OC_NANOSLEEP                1
C$CALLEDBY                      1
C$CHDIR                         2
C$COPY                          3
C$DELETE                        2
C$FILEINFO                      2
C$GETPID                        0
C$JUSTIFY                       1
C$MAKEDIR                       1
C$NARG                          1
C$PARAMSIZE                     1
C$PRINTABLE                     1
C$SLEEP                         1
C$TOLOWER                       2
C$TOUPPER                       2
X"91"                           2
X"E4"                           0
X"E5"                           0
X"F4"                           2
X"F5"                           2

GCobol >>SOURCE FORMAT IS FIXED
      *****************************************************************
      * GnuCOBOL demonstration
      * Author:  Brian Tiffin
      * Date:    26-Jun-2008
      * History:
      *     03-Jul-2008
      *     Updated to compile warning free according to standards
      * Purpose:
      *     CBL_ERROR_PROC and CBL_EXIT_PROC call example
      *     CBL_ERROR_PROC installs or removes run-time error procedures
      *     CBL_EXIT_PROC installs or removes exit handlers
      *     Also demonstrates the difference between Run time errors
      *     and raised exceptions.  Divide by zero is raises an
      *     exception, it does not cause a run time error.
      * NB:
      *     Please be advised that this example uses the functional
      *     but no longer standard ENTRY verb.  Compiling with -Wall
      *     will display a warning.  No warning will occur using
      *     -std=MF
      * Tectonics: cobc -x errorproc.cob
       identification division.
       program-id. error_exit_proc.

       data division.
       working-storage section.
      * entry point handlers are procedure addresses
       01  install-address   usage is procedure-pointer.
       01  install-flag      pic 9 comp-x value 0.
       01  status-code       pic s9(9) comp-5.

      * exit handler address and priority (prio is IGNORED with OC1.1)
       01  install-params.
           02 exit-addr      usage is procedure-pointer.
           02 handler-prio   pic 999 comp-x.

      * indexing variable for back scannning error message strings
       01  ind               pic s9(9) comp-5.

      * work variable to demonstrate raising exception, not RTE
       01  val               pic 9.

      * mocked up error procedure reentrancy control, global level
       01  once              pic 9 value 0.
           88 been-here            value 1.

      * mocked up non-reentrant value
       01  global-value      pic 99 value 99.

      * LOCAL-STORAGE SECTION comes into play for ERROR_PROCs that
      *   may themselves cause run-time errors, handling reentry.
       local-storage section.
       01  reenter-value     pic 99 value 11.

      * Linkage section for the error message argument passed to proc
      * By definition, error messages are 325 alphanumeric
       linkage section.
       01  err-msg           pic x(325).

      * example of GnuCOBOL error and exit procedures
       procedure division.

      * Demonstrate problem installing procedure
      * get address of WRONG handler.  NOTE: Invalid address
       set exit-addr to entry "nogo-proc".

      * flag: 0 to install, 1 to remove
       call "CBL_EXIT_PROC" using install-flag
                                  install-params
                            returning status-code
       end-call.
      * status-code 0 on success, in this case expect error.
       if status-code not = 0
           display
               "Intentional problem installing EXIT PROC"
               ", Status: " status-code
       end-if.

      * Demonstrate install of an exit handler
      * get address of exit handler
       set exit-addr to entry "exit-proc".

      * flag: 0 to install, 1 to remove
       call "CBL_EXIT_PROC" using install-flag
                                  install-params
                            returning status-code
       end-call.
      * status-code 0 on success.
       if status-code not = 0
           display
               "Problem installing EXIT PROC"
               ", Status: " status-code
           stop run
       end-if.

      * Demonstrate installation of an error procedure
      * get the procedure entry address
       set install-address to entry "err-proc".

      * install error procedure. install-flag 0 installs, 1 removes
       call "CBL_ERROR_PROC" using install-flag
                                   install-address
                             returning status-code
       end-call.
      * status-code is 0 on success.
       if status-code not = 0
           display "Error installing ERROR PROC"
           stop run
       end-if.

      * example of error that raises exception, not a run-time error
       divide 10 by 0 giving val end-divide.
      * val will be a junk value, use at own risk

       divide 10 by 0 giving val
           on size error display "DIVIDE BY ZERO Exception"
       end-divide.

      * intentional run-time error
       call "erroneous" end-call.           *> ** Intentional error **

      * won't get here.  RTS error handler will stop run
       display
           "procedure division, following run-time error"
       end-display.
       display
           "global-value: " global-value
           ", reenter-value: " reenter-value
       end-display.

       exit program.
      *****************************************************************

      *****************************************************************
      * Programmer controlled Exit Procedure:
       entry. "exit-proc".

       display
           "**Custom EXIT HANDLER (will pause 3 and 0.5 seconds)**"
       end-display.

      * sleep for 3 seconds
       call "C$SLEEP" using "3" end-call.
      * demonstrate nanosleep; argument in billionth's of seconds
      *   Note: also demonstrates GnuCOBOL's compile time
      *         string catenation using ampersand;
      *         500 million being one half second
       call "CBL_OC_NANOSLEEP" using "500" & "000000" end-call.

       exit program.

      *****************************************************************
      * Programmer controlled Error Procedure:
       entry "err-proc" using err-msg.

       display "**ENTER error procedure**".

      * These lines are to demonstrate local and working storage
       display
           "global-value: " global-value
           ", reenter-value: " reenter-value
       end-display.
      * As reenter-value is local-storage
      *  the 77 will NOT display on rentry, while the global 66 will
       move 66 to global-value.
       move 77 to reenter-value.

      * Process err-msg.
      * Determine Length of error message, looking for null terminator
       perform varying ind from 1 by 1
           until (err-msg(ind:1) = x"00") or (ind = length of err-msg)
               continue
       end-perform.
       display err-msg(1:ind).

      * demonstrate trapping an error caused in error-proc
       if not been-here then
           set been-here to true
           display "Cause error while inside error-proc"
           call "very-erroneous" end-call        *> Intentional error
       end-if.

      * In GnuCOBOL 1.1, the return-code is local and does
      *   not influence further error handlers
      *move 1 to return-code.
       move 0 to return-code.

       display "**error procedure EXIT**".

       exit program.
       end program err-proc.

$ cobc -x errorproc.cob
$ ./errorproc
Intentional problem installing EXIT PROC, Status: -000000001
DIVIDE BY ZERO Exception
**ENTER error procedure**
global-value: 99, reenter-value: 11
Cannot find module 'erroneous'
Cause error while inside error-proc
**ENTER error procedure**
global-value: 66, reenter-value: 11
Cannot find module 'very-erroneous'
**error procedure EXIT**
libcob: Cannot find module 'very-erroneous'
**Custom EXIT HANDLER (will pause 3 and 0.5 seconds)**

GCobol >>SOURCE FORMAT IS FIXED
      *****************************************************************
      * GnuCOBOL demonstration
      * Author:  Brian Tiffin
      * Date:    26-Jun-2008
      * History:
      *     03-Jul-2008
      *     Updated to compile warning free according to standards
      * Purpose:
      *     CBL_ERROR_PROC and CBL_EXIT_PROC call example
      *     CBL_ERROR_PROC installs or removes run-time error procedures
      *     CBL_EXIT_PROC installs or removes exit handlers
      *     Also demonstrates the difference between Run time errors
      *     and raised exceptions.  Divide by zero is raises an
      *     exception, it does not cause a run time error.
      * NB:
      *     Please be advised that this example uses the functional
      *     but no longer standard ENTRY verb.  Compiling with -Wall
      *     will display a warning.  No warning will occur using
      *     -std=MF
      * Tectonics: cobc -x errorproc.cob
       identification division.
       program-id. error_exit_proc.

       data division.
       working-storage section.
      * entry point handlers are procedure addresses
       01  install-address   usage is procedure-pointer.
       01  install-flag      pic 9 comp-x value 0.
       01  status-code       pic s9(9) comp-5.

      * exit handler address and priority (prio is IGNORED with OC1.1)
       01  install-params.
           02 exit-addr      usage is procedure-pointer.
           02 handler-prio   pic 999 comp-x.

      * indexing variable for back scannning error message strings
       01  ind               pic s9(9) comp-5.

      * work variable to demonstrate raising exception, not RTE
       01  val               pic 9.

      * mocked up error procedure reentrancy control, global level
       01  once              pic 9 value 0 external.
           88 been-here            value 1.

      * mocked up non-reentrant value
       01  global-value      pic 99 value 99 external.
       01 glob-addr usage pointer.

      * LOCAL-STORAGE SECTION comes into play for ERROR_PROCs that
      *   may themselves cause run-time errors, handling reentry.
       local-storage section.
       01  reenter-value     pic 99 value 11.

      * Linkage section for the error message argument passed to proc
      * By definition, error messages are 325 alphanumeric
      *linkage section.
      *01  err-msg           pic x(325).

      * example of GnuCOBOL error and exit procedures
       procedure division.
       set glob-addr to address of global-value
       display glob-addr

      * Demonstrate problem installing procedure
      * get address of WRONG handler.  NOTE: Invalid address
       set exit-addr to entry "nogo-proc".

      * flag: 0 to install, 1 to remove
       call "CBL_EXIT_PROC" using install-flag
                                  install-params
                            returning status-code
       end-call.
      * status-code 0 on success, in this case expect error.
       if status-code not = 0
           display
               "Intentional problem installing EXIT PROC"
               ", Status: " status-code
           end-display
       end-if.

      * Demonstrate install of an exit handler
      * get address of exit handler
       set exit-addr to entry "exit-proc".

      * flag: 0 to install, 1 to remove
       call "CBL_EXIT_PROC" using install-flag
                                  install-params
                            returning status-code
       end-call.
      * status-code 0 on success.
       if status-code not = 0
           display
               "Problem installing EXIT PROC"
               ", Status: " status-code
           end-display
           stop run
       end-if.

      * Demonstrate installation of an error procedure
      * get the procedure entry address
       set install-address to entry "err-proc".

      * install error procedure. install-flag 0 installs, 1 removes
       call "CBL_ERROR_PROC" using install-flag
                                   install-address
                             returning status-code
       end-call.
      * status-code is 0 on success.
       if status-code not = 0
           display "Error installing ERROR PROC" end-display
           stop run
       end-if.

      * example of error that raises exception, not a run-time error
       divide 10 by 0 giving val end-divide.
      * val will be a junk value, use at own risk

       divide 10 by 0 giving val
           on size error display "DIVIDE BY ZERO Exception" end-display
       end-divide.

      * intentional run-time error
       call "erroneous" end-call.           *> ** Intentional error **

      * won't get here.  RTS error handler will stop run
       display
           "procedure division, following run-time error"
       end-display.
       display
           "global-value: " global-value
           ", reenter-value: " reenter-value
       end-display.

       exit program.
       end program error_exit_proc.
      *****************************************************************

      *****************************************************************
      * Programmer controlled Exit Procedure:
       identification division.
       program-id. exit-proc.
       procedure division.

       display "**Custom EXIT HANDLER**" end-display.

      * sleep for 3 seconds
       display "Call C$SLEEP using 3" end-display.
       call "C$SLEEP" using "3" end-call.

      * demonstrate nanosleep; argument in billionth's of seconds
      *   Note: also demonstrates GnuCOBOL's compile time
      *         string catenation using ampersand;
      *         500 million being one half second
       display "Call CBL_OC_NANOSLEEP using 500,000,000" end-display.
       call "CBL_OC_NANOSLEEP" using "500" & "000000" end-call.

       exit program.
       end program exit-proc.

      *****************************************************************
      * Programmer controlled Error Procedure:
       identification division.
       program-id. err-proc.
       data division.
       working-storage section.
       01  global-value      pic 99 external.

       01  ind               pic s9(9) comp-5.
       01  once              pic 9 external.
           88 been-here            value 1.

      * LOCAL-STORAGE SECTION comes into play for ERROR_PROCs that
      *   may themselves cause run-time errors, handling reentry.
       local-storage section.
       01  reenter-value     pic 99 value 11.
       01 glob-addr usage pointer.

       linkage section.
       01  err-msg           pic x(325).

       procedure division using err-msg.
       set glob-addr to address of global-value
       display glob-addr end-display

       display "**ENTER error procedure**" end-display.

      * These lines are to demonstrate local and working storage
       display
           "global-value: " global-value
           ", reenter-value: " reenter-value
       end-display.
      * As reenter-value is local-storage
      *  the 77 will NOT display on rentry, while the global 66 will
       move 66 to global-value.
       move 77 to reenter-value.

      * Process err-msg.
      * Determine Length of error message, looking for null terminator
       perform varying ind from 1 by 1
           until (err-msg(ind:1) = x"00") or (ind = length of err-msg)
               continue
       end-perform.
       display err-msg(1:ind) end-display.

      * demonstrate trapping an error caused in error-proc
       if not been-here then
           set been-here to true
           display "Cause error while inside error-proc" end-display
           call "very-erroneous" end-call        *> Intentional error
       end-if.

      * In GnuCOBOL 1.1, the return-code is local and does
      *   not influence further error handlers
      *move 1 to return-code.
       move 0 to return-code.

       display "**error procedure EXIT**" end-display.

       exit program.
       end program err-proc.

Sample >>SOURCE FORMAT IS FIXED
      * Author:    Brian Tiffin
      * Date:      25-July-2008
      * Modified:  2015-07-29 07:41 EDT, Wednesday
      * License:   Copyright 2008,2015 Brian Tiffin
      *            Public domain sample.  Zero warranty.
      * Purpose:   Demonstrate GnuCOBOL byte stream files
      *            and SCREEN SECTION features
      * Tectonics: cobc -x streams.cob
       identification division.
       program-id. streams.

       environment division.
       configuration section.
       special-names.
           crt status is user-control.

       data division.
       working-storage section.
       78 READ-ONLY            value 1.
       78 WRITE-ONLY           value 2.
       78 READ-WRITE           value 3.

       01 filehandle           usage is pointer.
       01 filename             pic x(40).
       01 cfile                pic x(41).
       01 access-mode          usage binary-long.
       01 file-lock            pic x.
       01 device               pic x.
       01 result               usage binary-long.

       01 file-offset          pic 9(18) comp.
       01 read-length          pic 9(8)  comp.
       01 file-flags           binary-char.
       01 read-buffer          pic x(40).
       01 marquee              pic x(40).
       01 marquee-limit        pic 9(4).

       01 scr-result           pic 9(5).
       01 scr-file-offset      pic 9(5).
       01 scr-read-length      pic 9(5).
       01 scr-file-length      pic 9(6).
       01 scr-pass             pic x(5) value "Pre  ".

       01 user-control         pic 9(4).
       01 exit-message         pic x(10) value "CRT STATUS".

       screen section.
       01 file-screen.
          05 blank screen.
          05 line 1 column 25 value "GnuCOBOL byte stream files"
              foreground-color 2.
          05 line 3 column 10 value "Enter filename and marquee count."
              foreground-color 3.
          05 line 3 column 44 value "Any function key to exit"
              foreground-color 4.
          05 line 4 column 10 value "File:".
          05 line 4 column 19 using filename.
          05 line 5 column 10 value "limit:".
          05 line 5 column 19 using marquee-limit.
          05 line 5 column 30 value "<- limits marquee loop".
          05 line 7 column 19 from marquee reverse-video.
          05 line 9 column 10 from scr-pass.
          05 line 9 column 15 value "Result:".
          05 line 9 column 22 from scr-result.
          05 line 9 column 29 value "Length:".
          05 line 9 column 36 from scr-read-length.
          05 line 9 column 43 value "Offset:".
          05 line 9 column 50 from scr-file-offset.
          05 line 9 column 57 value "Total:".
          05 line 9 column 63 from scr-file-length.
          05 line 10 column 29 from exit-message.
          05 line 10 column 40 from user-control.

      ******************************************************************
       procedure division.

      * read screen with defaults
       move "streams.cob" to filename.
       move 64 to marquee-limit.
       accept file-screen end-accept.

      * tapping a function key will bail
       if user-control not = 0
           move "Bailing..." to exit-message
           display file-screen
           call "C$SLEEP" using "2"
           goback
       end-if.

      * open the file, name needs terminating null byte
       move READ-ONLY to access-mode.
       string filename delimited by space
              low-value delimited by size
              into cfile
       end-string.
       call "CBL_OPEN_FILE" using cfile
                                  access-mode
                                  file-lock
                                  device
                                  filehandle
                            returning result
       end-call.
       move result to scr-result

       display file-screen.

      * This section demonstrates the file-flags option
      * If 128 is in file-flags, CBL_READ_FILE will place
      * the actual file length into the file-offset field on
      * completion of the read.
       move result to scr-result
       move 0 to file-offset scr-file-offset.
       move 40 to read-length scr-read-length.
       move 128 to file-flags.

       call "CBL_READ_FILE" using filehandle
                                  file-offset
                                  read-length
                                  file-flags
                                  read-buffer
                            returning result.

       move "Post " to scr-pass
       move result to scr-result
       move file-offset to scr-file-offset
                           scr-file-length
       move read-length to scr-read-length

       display file-screen.

      * display a sliding marquee, one character every
      * 170 million, one billionth's of a second; about 5.9cps
       move 0 to file-flags.
       move 40 to read-length.
       perform varying file-offset from 0 by 1
           until (result not = 0)
              or (file-offset > marquee-limit)
               call "CBL_READ_FILE" using filehandle
                                          file-offset
                                          read-length
                                          file-flags
                                          read-buffer
                                    returning result
               end-call

               move read-buffer to marquee
               inspect marquee replacing all x"0d0a" by "  "
               inspect marquee replacing all x"0a" by space

               move file-offset to scr-file-offset
               move result to scr-result
               display file-screen

               call "CBL_OC_NANOSLEEP" using 170000000 end-call
       end-perform

       call "CBL_CLOSE_FILE" using filehandle
                             returning result.

       move "Leaving..." to exit-message.
       display file-screen.
       call "C$SLEEP" using "2" end-call.

       goback.
       exit program.

               GnuCOBOL byte stream files

Enter filename and marquee count. Any function key to exit
File:    streams.cob_____________________________
limit:   0064       <- limits marquee loop

               * Date:      25-July-2008        *

Post Result:00000  Length:00040  Offset:00064  Total:006207
                   Leaving... 0000



 System Calls v1.1.0 for OC v1.1  Author: Vincent B Coen  dated 12/01/2009

 COB_SYSTEM_GEN ("CBL_ERROR_PROC", 2, CBL_ERROR_PROC):        Register error proc in Linux??? needs checking Roger?
    call using      install-flag   pic x comp-x    Indicates operation to be performed
                                                   (0 = install error procedure)
                                                   (1 = un-install error procedure)
                    install-addrs  Usage procedure pointer  Create by 'set install-addr to entry entry-name'
                                                   (the address of error procedure to install or un-install)

 COB_SYSTEM_GEN ("CBL_EXIT_PROC", 2, CBL_EXIT_PROC)           Register closedown proc
    call using      install-flag   pic x comp-x    Indicate operation to be performed
                                                   (0 = install closedown proc. with default priority of 64)
                                                   (1 = un=install closedown proc.)
                                                   (2 = query priority of installed proc.)
                                                   (3 = install closedown proc. with given priority)
                    install-param  group item defined as:
                      install-addr  USAGE PROCEDURE POINTER (addr of closedown proc to install, uninstall or query)
                      install-prty  pic x comp-x    (when install-flag = 3, priority of proc. being installed 0 - 127)
       returning     status-code    (See section key).
    on exit           install-prty                  (when install-flag = 2, returns priority of selected proc.)

 COB_SYSTEM_GEN ("CBL_OPEN_FILE", 5, CBL_OPEN_FILE)           Open byte stream file
     call using     file-name      pic x(n)      space or null terminated
                    access-mode    pic x comp-5   (1 = read only, 2 = write only [deny must = 0]
                                                   3 = read / write)
                    deny-mode      pic x comp-5   (0 = deny both, 1 = deny write, 2 = deny read
                                                   3 = deny neither read nor write)
                    device         pic x comp-5   (must be zero)
                    file-handle    pic x(4)       (Returns a file handle for a successful open)
         returning  status-code    (See section key)

 COB_SYSTEM_GEN ("CBL_CREATE_FILE", 5, CBL_CREATE_FILE)       Create byte stream file
     call using     file-name      pic x(n)      (space or null terminated)
                    access-mode    pic x comp-x  (1 = read only)
                                                 (2 = write only (deny must be 0)
                                                 (3 = read / write)
                    deny-mode      pic x comp-x  (0 = deny both read & write exclusive)
                                                 (1 = deny write)
                                                 (2 = deny read)
                                                 (3 = deny neither read nor write)
                    device         pic x comp-x  (must be zero) (reserved for future use)
                    file-handle    pic x(4)      (Returns a file handle for a successful open)
          returning status-code     (See section key)

 COB_SYSTEM_GEN ("CBL_READ_FILE", 5, CBL_READ_FILE)           Read byte stream file
     call using  file-handle     pic x(4)         (File handke returned when file opened)
                 file-offset     pic x(8) comp-x  (offset in the file at which to read) (Max limit X"00FFFFFFFF") ??
                 byte-count      pic x(4) comp-x  (number of bytes to read. Poss limit x"00FFFF")
                 flags           pic x comp-x     (0 = standard read, 128 = current file size returned in the
                                                       file-offset field)
                 buffer          pic x(n)
      returning status-code     (See section key)
       on exit:  file-offset                      (Current file size on return if flags = 128 on entry)
                 buffer          pic x(n)         (Buffer into which bytes are read. IT IS YOUR RESPONSIBILITY
                                                   TO ENSURE THAT THE BUFFER IS LARGE ENOUGH TO HOLD ALL BYTES TO BE
                                                   READ)
      Remarks:                  See Introduction to Byte Stream Routines as well as example code taken
                                from old version of CobXref

 COB_SYSTEM_GEN ("CBL_WRITE_FILE", 5, CBL_WRITE_FILE)         Write byte stream file
     call using  file-handle     pic x(4)         (File handke returned when file opened)
                 file-offset     pic x(8) comp-x  (offset in the file at which to write) (Max limit X"00FFFFFFFF") ??
                 byte-count      pic x(4) comp-x  (number of bytes to write. Poss limit x"00FFFF")
                                                  Putting a value of zero here causes file to be trancated or extended
                                                  to the size specified in file-offset)
                 flags           pic x comp-x     (0 = standard write)
                 buffer          pic x(n)         (Buffer into which bytes are writen from)
      returning status-code     (See section key)

      Remarks:                  See Introduction to Byte Stream Routines as well as example code taken
                                from old version of CobXref

 COB_SYSTEM_GEN ("CBL_CLOSE_FILE", 1, CBL_CLOSE_FILE)         Close byte stream file
     call using file-handle       pic x(4)     on entry the file handle returned when file opened
          returning status-code   (see section key)

 COB_SYSTEM_GEN ("CBL_FLUSH_FILE", 1, CBL_FLUSH_FILE)         ??????????????
     call using   ???????         pic ????       No Idea

 COB_SYSTEM_GEN ("CBL_DELETE_FILE", 1, CBL_DELETE_FILE)       Delete File
     call using file-name         pic x(n)   file to delete terminated by space can contain path.
      returning status-code

 COB_SYSTEM_GEN ("CBL_COPY_FILE", 2, CBL_COPY_FILE)           Copy file
       call using file-name1     (pic x(n)       File to copy, can contain path terniated by space
                  file-name2     (pic x(n)       File name of new file, can contain path termiated by space.
                                                 For both, if no path current directory is assumed.
        returning status-code    (see section key)

 COB_SYSTEM_GEN ("CBL_CHECK_FILE_EXIST", 2, CBL_CHECK_FILE_EXIST)     Check if file exists & return details if it does
      Call using     file-name
                     file-details
        returning status-code

     file-name  pic x(n)
     file-details       Group item defined as:
        file-size        pic x(8) comp-x
      file-date
        day              pic x comp-x
        month            pic x comp-x
        year             pic xx comp-x

      file-time
        hours            pic x comp-x
        minutes          pic x comp-x
        seconds          pic x comp-x
        hundredths       pic x comp-x
      status-code    see section key

 On entry: file-name     The file to look for. name can contain path and is terminated by a space
                         If no path given current directory is assumed.
 On Exit:  file-size     Size if file in bytes
           file-date     Date the file was created
           file-time     Time file created

 COB_SYSTEM_GEN ("CBL_RENAME_FILE", 2, CBL_RENAME_FILE)        Rename file
     call using      old-file-name    pic x(n)     (file to rename can contain path terminated by space)
                     new-file-name    pic x(n)     (new file name  as above path must be same)
      returning status-code     (see section key)

 COB_SYSTEM_GEN ("CBL_GET_CURRENT_DIR", 3, CBL_GET_CURRENT_DIR) Get details of current directory
      call using      ???        pic x(n)  ???
                      ???        pic x(n)  ???
       returning  status-code (see section key)

 COB_SYSTEM_GEN ("CBL_CHANGE_DIR", 1, CBL_CHANGE_DIR)          Change current directory
      Call using     path-name   pic x(n) (relative or absolute terminated by x"00")
        returning  status-code (see section key)

 COB_SYSTEM_GEN ("CBL_CREATE_DIR", 1, CBL_CREATE_DIR)          Create directory
      Call using     path-name   pic x(n)  (relative or absolute path-name terminate by x"00")
        returning  status-code  (see section key)

 COB_SYSTEM_GEN ("CBL_DELETE_DIR", 1, CBL_DELETE_DIR)          Delete directory
      Call using path-name       pic x(n)  (relative or absolute name terminated by space or null [x"00"])
        returning status-code    (see section key)

 COB_SYSTEM_GEN ("CBL_AND", 3, CBL_AND)                        logical AND
      Call using  source      (Any data item)
                  target      (Any data item)
         by value length      (numeric literal or pic x(4) comp-5
        returning status-code  (see section key)

 COB_SYSTEM_GEN ("CBL_OR", 3, CBL_OR)                          logical OR
    call using    source      (Any data item)
                  target      (Any data item)
         by value length      (numeric literal or pic x(4) comp-5
        returning status-code  (see section key)

 COB_SYSTEM_GEN ("CBL_NOR", 3, CBL_NOR)                        Logial Not OR ?
      Call using  source      (Any data item)
                  target      (Any data item)
         by value length      (numeric literal or pic x(4) comp-5
        returning status-code  (see section key)

 COB_SYSTEM_GEN ("CBL_XOR", 3, CBL_XOR)                        logical eXclusive OR
      Call using  source      (Any data item)
                  target      (Any data item)
         by value length      (numeric literal or pic x(4) comp-5
        returning status-code  (see section key)


 COB_SYSTEM_GEN ("CBL_IMP", 3, CBL_IMP)                        Logical IMPlies
     call using source        Any data item
                target        Any data Item
           by value length    Nuneric literal or pic x(4) comp-5
      returning status-code    (see section key)

 COB_SYSTEM_GEN ("CBL_NIMP", 3, CBL_NIMP)                       Logical Not IMPlies
     call using source        Any data item
                target        Any data Item
           by value length    Nuneric literal or pic x(4) comp-5
      returning status-code    (see section key)

 COB_SYSTEM_GEN ("CBL_EQ", 3, CBL_EQ)                          Logical EQUIVALENCE between bits of both items
      Call using  source      (Any data item)
                  target      (Any data item)
         by value length      (numeric literal or pic x(4) comp-5
        returning status-code  (see section key)

 COB_SYSTEM_GEN ("CBL_NOT", 2, CBL_NOT)                        Logical NOT
    Call using target         Any data item
       by value length        numeric lit or pic x(4) comp-5

 COB_SYSTEM_GEN ("CBL_TOUPPER", 2, CBL_TOUPPER)                Convert a string to Upper case
     Call using    string      pic x(n)          (The string to convert)
         by value  length      pic x(4) comp-5   (Number of bytes to change)
        returning status-code  (see section key)

 COB_SYSTEM_GEN ("CBL_TOLOWER", 2, CBL_TOLOWER)                Convert a string to Lower case
     Call using    string      pic x(n)          (The string to convert)
         by value  length      pic x(4) comp-5   (Number of bytes to change)
        returning status-code  (see section key)

 COB_SYSTEM_GEN ("\364", 2, CBL_XF4)
 COB_SYSTEM_GEN ("\365", 2, CBL_XF5)
 COB_SYSTEM_GEN ("\221", 2, CBL_X91)
 COB_SYSTEM_GEN ("C$NARG", 1, cob_return_args)
 COB_SYSTEM_GEN ("C$PARAMSIZE", 1, cob_parameter_size)
 COB_SYSTEM_GEN ("C$MAKEDIR", 1, cob_acuw_mkdir)
 COB_SYSTEM_GEN ("C$CHDIR", 2, cob_acuw_chdir)
 COB_SYSTEM_GEN ("C$SLEEP", 1, cob_acuw_sleep)
 COB_SYSTEM_GEN ("C$COPY", 3, cob_acuw_copyfile)
 COB_SYSTEM_GEN ("C$FILEINFO", 2, cob_acuw_file_info)
 COB_SYSTEM_GEN ("C$DELETE", 2, cob_acuw_file_delete)

 COB_SYSTEM_GEN ("C$TOUPPER", 2, CBL_TOUPPER)                  Convert string to upper case
     see cbl_toupper  ???

 COB_SYSTEM_GEN ("C$TOLOWER", 2, CBL_TOLOWER)                  Convert string to lower case
     see cbl_tolower  ???
 COB_SYSTEM_GEN ("C$JUSTIFY", 1, cob_acuw_justify)
 COB_SYSTEM_GEN ("CBL_OC_NANOSLEEP", 1, CBL_OC_NANOSLEEP)

 Key:
   Option Returning clause will allow all routine to return a value showing result of the operation.
   Zero = success and nonzero failure. If this field is omitted the value should be returned in the
   special register RETURN-CODE..       Note that status-code must be capable of holding positive
                                        values from 0 to 65535 ie, pic xx comp-5.

 And a sample program too::

 Introduction to Byte Streaming Routines.

 The byte stream file routines enable you to read, write data files without the need to adhere to
 Cobol record definitions.

 For all of these routines, if the routine is successful the RETURN-CODE register is set to zero. If
 it fails, the RETURN-CODE register contains a file status value which indicates the failure. This
 file status  is always the standard ASNI '74 file status value. If no ANSI '74 file status is defined
 for the error, an extended error status is returned (9/nnn) where nnn is the runtime error number).
            MAYBE need to speak to Roger. <<<<<<<<<<<<<<<<<<<<


 An extract of a example of working Cobol code that shows usage of byte stream file handling


000100 Identification division.
000200 program-id.           cobxref.
...
...
104000 01  File-Handle-Tables.
104100     03  filler          occurs 0 to 99
104200                                    depending on Fht-Table-Size.
104300       05 Fht-File-Handle  pic x(4).
104400       05 Fht-File-OffSet  pic x(8)       comp-x  value zero.
104500       05 Fht-File-Size    pic x(8)       comp-x  value zero.
104600       05 Fht-Block-OffSet pic x(8)       comp-x  value zero.
104700       05 Fht-Byte-Count   pic x(4)       comp-x  value 4096.
104800       05 Fht-CopyRefNo2   pic 9(6)               value zero.
104900       05 Fht-Pointer      pic s9(5)      comp    value zero.
105000       05 Fht-Copy-Line-End pic s9(5)     comp    value zero.
105100       05 Fht-Copy-Words   pic s9(5)      comp    value zero.
105200       05 Fht-sw-Eof       pic 9                  value zero.
105300        88 Fht-Eof                                value 1.
105400       05 Fht-Current-Rec  pic x(160)             value spaces.
105500       05 Fht-File-Name    pic x(256).
105600       05 Fht-Buffer       pic x(4097).
105700       05 filler           pic x                  value x"FF".
105800 01  Fht-Table-Size        pic s9(5) comp value zero.
105900*
106000 01  Cbl-File-Fields.
106100     03  Cbl-File-name     pic x(256).
106200     03  Cbl-Access-Mode   pic x          comp-x  value 1.
106300     03  Cbl-Deny-Mode     pic x          comp-x  value 3.
106400     03  Cbl-Device        pic x          comp-x  value zero.
106500     03  Cbl-Flags         pic x          comp-x  value zero.
106600     03  Cbl-File-Handle   pic x(4)               value zero.
106700     03  Cbl-File-OffSet   pic x(8)       comp-x  value zero.
106800*
106900 01  Cbl-File-Details.
107000     03  Cbl-File-Size     pic x(8)       comp-x  value zero.
107100     03  Cbl-File-Date.
107200         05  Cbl-File-Day  pic x          comp-x  value zero.
107300         05  Cbl-File-Mth  pic x          comp-x  value zero.
107400         05  Cbl-File-Year pic x          comp-x  value zero.
107500     03  Cbl-File-time.
107600         05  Cbl-File-Hour pic x          comp-x  value zero.
107700         05  Cbl-File-Min  pic x          comp-x  value zero.
107800         05  Cbl-File-Sec  pic x          comp-x  value zero.
107900         05  Cbl-File-Hund pic x          comp-x  value zero.
...
...
      ********************************************************************
      *
      * zz300, zz400, zz500 & zz600 all relate to copy files/libraries
      *   via the COPY verb
      *  As it is hoped to only use the filename.i via Open-Cobol
      * then this lot can be killed off as well as all the other related
      * code.
      * NOTE that the COPY verb is implemented in a very basic way despite
      *  the fact that this code allows for 99 levels of COPY, eg, there is
      *  NO replacing so hopefully I can remove it all after primary testing
      *  When it is built into cobc
      *
356400 zz300-Open-File.
356500****************
356600* Open a Copy file using CBL-OPEN-File
356700*  filename is using Cbl-File-name
356800*
356900     move     zero to Return-Code.
357000     if       Fht-Table-Size > 99
357100              move 24 to Return-Code
357200              display Msg11
357300              go to zz300-Exit.
357400*
357500* set up New entry in File Table
357600*
357700     add      1 to Fht-Table-Size.
357800     move     Fht-Table-Size to e.
357900     move     zeroes to Fht-File-OffSet (e) Fht-File-Size (e)
358000                        Fht-File-Handle (e) Fht-Block-OffSet (e)
358100                        Fht-CopyRefNo2 (e)  Fht-sw-Eof (e)
358200                        Fht-Copy-Line-End (e) Fht-Copy-Words (e).
358300     move     4096 to   Fht-Byte-Count (e).
358400     move     spaces to Fht-Current-Rec (e).
358500     move     1      to Fht-pointer (e).
358600*
358700     perform  zz400-Check-File-Exists thru zz400-Exit.
358800     if       Return-Code not = zero
358900              subtract 1 from Fht-Table-Size
359000              go to zz300-Exit.
359100*
359200     move     Fht-Table-Size to e.
359300     move     Cbl-File-Size to Fht-File-Size (e).
359400     move     Cbl-File-name to Fht-File-Name (e).
359500     move     1    to Cbl-Access-Mode
359600                      Cbl-Deny-Mode.
359700     move     zero to Cbl-Device
359800                      Cbl-File-Handle.
359900     move     zero to Return-Code.
360000     call     "CBL_OPEN_FILE" using
360100              Cbl-File-name
360200              Cbl-Access-Mode
360300              Cbl-Deny-Mode
360400              Cbl-Device
360500              Cbl-File-Handle.
360600     if       Return-Code not = zero
360700              display Msg12 cbl-File-name
360800              display "       This should not happen here"
360900              subtract 1 from Fht-Table-Size
361000              go to zz300-exit.
361100*
361200     move     Cbl-File-Handle to Fht-File-Handle (e).
361300     add      1 to Copy-Depth.
361400     move     1 to sw-Copy.
361500     move     zero to Fht-CopyRefNo2 (e)
361600                      Return-Code.
362000 zz300-Exit.
362100     exit.
362200/
362300 zz400-Check-File-Exists.
362400*
362500* check for correct filename and extention taken from COPY verb
362600*
362700*  input : wsFoundNewWord2
362800* Output : Return-Code = 0  : Cbl-File-Details & Cbl-File-name
362900*          Return-Code = 25 : failed fn in wsFoundNewWord2
363000*
363100     move     zero to e.
363200     inspect  wsFoundNewWord2 tallying e for all ".".
363300     if       e not zero
363400              go to zz400-Try1.
363500     perform  varying a from 1 by 1 until Return-Code = zero
363600              move   1 to e
363700              move   spaces to Cbl-File-name
363800              string wsFoundNewWord2 delimited by space
363900                                    into Cbl-File-name pointer e
364000              string File-Ext (a) delimited by size
364100                                    into Cbl-File-name pointer e
364200              move   zero to Return-Code
364300              call   "CBL_CHECK_FILE_EXIST" using
364400                     Cbl-File-name
364500                     Cbl-File-Details
364600              end-call
364700              if   Return-Code not = zero
364800               and a = 7
364900                     exit perform
365000              end-if
365100     end-perform
365200     if       Return-Code not = zero
365300              display "zz400A Check File exist err=" Return-Code
365400              display Msg13 wsFoundNewWord2
365500              move 25 to Return-Code
365600              go to zz400-Exit.
365700* ok file now found
365900     go       to zz400-Exit.
366000*
366100 zz400-Try1.
366200     move     wsFoundNewWord2 to Cbl-File-name.
366300     move     zero to Return-Code.
366400     call     "CBL_CHECK_FILE_EXIST" using
366500              Cbl-File-name
366600              Cbl-File-Details.
366700     if       Return-Code not = zero
366800              move function lower-case (wsFoundNewWord2) to
366900                    Cbl-File-name
367000              go to zz400-Try2.
367100* ok file now found
367200     go       to zz400-exit.
367300*
367400 zz400-Try2.
367500     move     zero to Return-Code.
367600     call     "CBL_CHECK_FILE_EXIST" using
367700              Cbl-File-name
367800              Cbl-File-Details.
367900     if       Return-Code not = zero
368000              display "zz400C Check File exist err=" Return-Code
368100              display Msg13 wsFoundNewWord2 " or " Cbl-File-name
368200              move 25 to Return-Code
368300              go to zz400-Exit.
368400*
368500* ok file now found
368600*
368700 zz400-Exit.
368800     exit.
368900/
369000 zz500-Close-File.
369100     call     "CBL_CLOSE_FILE" using
369200              Fht-File-Handle (Fht-Table-Size).
369300     if       Return-Code not = zero
369400              display Msg14
369500                      Cbl-File-name.
369800     subtract 1 from Fht-Table-Size.
369900*
370000     if       Fht-Table-Size = zero
370100              move zero to sw-Copy.
370200     subtract 1 from Copy-Depth.
370300     move     zero to Return-Code.
370400     go       to zz500-Exit.
370500*
370600 zz500-Exit.
370700     exit.
370800/
370900 zz600-Read-File.
371000****************
371100* called using file-handle
371200*  returning   CopySourceRecin1  size 160 chars
371300* If buffer enpty read a block
371400*    and regardless, move record terminated by x"0a"
371500* to Fht-Current-Rec (Fht-Table-Size)
371600*
371700     if       Fht-Eof (Fht-Table-Size)
371800              perform zz500-Close-File
371900              go to zz600-Exit.
372000*
372100     if       Fht-File-OffSet (Fht-Table-Size) = zero
372200         and  Fht-Block-OffSet (Fht-Table-Size) = zero
372300              perform zz600-Read-A-Block
372400              go to zz600-Get-A-Record.
372500*
372600 zz600-Get-A-Record.
372700*******************
372800* Now to extract a record from buffer and if needed read a block
372900*         then extract
373000*
373100     move     spaces to Fht-Current-Rec (Fht-Table-Size).
373200     add      1 to Fht-Block-OffSet (Fht-Table-Size) giving g.
373300*
373400* note size is buffer size + 2
373500*
373600     unstring Fht-Buffer (Fht-Table-Size) (1:4097)
373700                delimited by x"0A" or x"FF"
373800                into         Fht-Current-Rec (Fht-Table-Size)
373900                delimiter    Word-Delimit3
374000                pointer      g.
374100*
374200* Get next Block of data ?
374300*
374400     if       Word-Delimit3 = x"FF"
374500          and g not < 4097
374600              add Fht-Block-OffSet (Fht-Table-Size)
374700                               to Fht-File-OffSet (Fht-Table-Size)
374800              perform zz600-Read-A-Block
374900              go to zz600-Get-A-Record.
375000* EOF?
375100     move     1 to Fht-Pointer (Fht-Table-Size).
375200     if       Word-Delimit3 = x"FF"
375300              move 1 to Fht-sw-Eof (Fht-Table-Size)
375400              go to zz600-Exit.
375500* Now so tidy up
375600     subtract 1 from g giving Fht-Block-OffSet (Fht-Table-Size).
375700     go       to zz600-exit.
375800*
375900 zz600-Read-A-Block.
      *******************
376000     move     all x"FF" to Fht-Buffer (Fht-Table-Size).
376100*     if       Fht-File-Size (Fht-Table-Size) < 4096 and not = zero
376200*              move Fht-File-Size (Fht-Table-Size)
376300*                             to Fht-Byte-Count (Fht-Table-Size).
376400     call     "CBL_READ_FILE" using
376500              Fht-File-Handle (Fht-Table-Size)
376600              Fht-File-OffSet (Fht-Table-Size)
376700              Fht-Byte-Count (Fht-Table-Size)
376800              Cbl-Flags
376900              Fht-Buffer (Fht-Table-Size).
377000     if       Return-Code not = zero
377100              display Msg15 Return-Code
377200              go to zz600-Exit.
377300* just in case all ff does not work
377400     move     x"FF" to Fht-Buffer (Fht-Table-Size) (4097:1).
377500     move     zero to Fht-Block-OffSet (Fht-Table-Size).
377600     subtract Fht-Byte-Count (Fht-Table-Size)
377700                            from Fht-File-Size (Fht-Table-Size).
377800 zz600-Exit.
377900     exit.

parent --> parent (same process id, fork() returns PID of child)
             |
           child1 (new process id, fork() returns 0)

parent --> parent
             |
           child1 --> child1
             .          |
             .        child2
           parent --> parent
                        |
                      child3

fork1 (p splits into p and c1)

fork2 (p splits into p and c2, c1 splits into c1 and c3)

fork3 (p splits into p and c4, c1 splits into c1 and c5,
       c2 splits in c2 and c6, c3 splits into c3 and c7)

if rpid < 0 then error occurred.

if rpid = 0 then "I'm the child", and that will usually exec a brand new
process space or jump to a completely separate part of the program. Don't
think this is a thread though, it is not, it is a separate copy of the
same program.

if rpid > 0 then "I'm the original", and I'll do my thing and eventually
wait on the child pid to ensure no orphan zombie reaping occurs.

      *>
      *> forking.cob, CBL_GC_FORK example
      *>
      *> Tectonics:
      *>   cobc -xj forking.cob
      *>
       identification division.
       program-id. forking.

       data division.
       working-storage section.
       01 return-pid           usage binary-long.
       01 wait-status          usage binary-long.

       01 copied-value         pic 9   value 7.

       procedure division.
       display "Forking"

      *> When the process forks, two processes will be running, at a
      *> point of execution of the "returning return-pid" part. 
       call "CBL_GC_FORK" returning return-pid

      *> all code from now on is being executed by two processes
      *> unless an error occurred and there is no child

      *> unlike fork(), GnuCOBOL uses -2 to mean not supported and
      *>                              -1 when fork() fails
       if return-pid < zero then
           display "forking error: " return-pid upon syserr
       else
           display "**Both processes evaluate this line ", return-pid
       end-if

       if return-pid equal zero then
      *> child will now branch off from the main control flow
           go to child-task
       end-if

      *> When the parent process exits, the child will be reaped as well
       display "This is still the original process: " return-pid
       display "Parent: copied value is: " copied-value
       add 1 to copied-value
       display "Parent: copied-value is now: " copied-value

      *> To ensure the child gets a chance to finish, waitpid is used
       call "CBL_GC_WAITPID" using return-pid returning wait-status
       display "Parent: status value from child: " wait-status
       display "Parent: copied-value is still: " copied-value
       display "Parent: leaves the building"
      *> libcob internals also set the parent return-code field
      *> during the call to CBL_GC_WAITPID (reset it to zero).
       move 0 to return-code
       goback.

      *> ********
      *> NOTE: this is not a thread, but is a separate process
      *>       evaluating an identical copy of the code as the parent
       child-task.
       display "    This is a new process space, a child"
       display "    Child: copied value is: " copied-value
       subtract 1 from copied-value
       display "    Child: copied-value is now: " copied-value

      *> exit the child process with a status value of 42
       display "    Child: leaves the building, setting return-code"
       move 42 to return-code
       goback.
       end program forking.

prompt$ cobc -xj forking.cob
Forking
**Both processes evaluate this line +0000005148
This is still the original process: +0000005148
Parent: copied value is: 7
Parent: copied-value is now: 8
**Both processes evaluate this line +0000000000
    This is a new process space, a child
    Child: copied value is: 7
    Child: copied-value is now: 6
    Child: leaves the building, setting return-code
Parent: status value from child: +0000000042
Parent: copied-value is still: 8
Parent: leaves the building

The CALL's X"F4", X"F5", X"91" are from MF.
You can find them in the online MF doc under
Library Routines.

F4/F5 are for packing/unpacking bits from/to bytes.
91 is a multi-use call. Implemented are the subfunctions
get/set cobol switches (11, 12) and get number of call params (16).

Roger

CALL X"F4" USING
               BYTE-VAR
               ARRAY-VAR
           RETURNING STATUS-VAR

CALL X"91" USING
               RESULT-VAR
               FUNCTION-NUM
               PARAMETER-VAR
           RETURNING STATUS-VAR

CALL "CBL_OC_NANOSLEEP" USING 500000000
                        RETURNING STATUS
END-CALL

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      01-Jul-2008
      *> Purpose:   Demonstrate the usage of GnuCOBOL call library
      *>            C$JUSTIFY, C$TOUPPER, C$TOLOWER
      *> Tectonics: Using OC1.1 post 02-Jul-2008, cobc -x -Wall
      *> History:   02-Jul-2008, updated to remove warnings
      *> ***************************************************************
       identification division.
       program-id. justify.

       environment division.
       configuration section.
       source-computer. IBMPC.
       object-computer. IBMPC.

       data division.
       WORKING-STORAGE section.
       01 source-str           pic x(80)
           value "    this is a test of the internal voice communication
      - " system".
       01 just-str             pic x(80).
       01 justification        pic x.
       01 result               pic s9(9) comp-5.

       procedure division.
       move source-str to just-str.

      *> Left justification
       move "L" to justification.
       perform demonstrate-justification.

      *> case change to upper, demonstrate LENGTH verb
       call "C$TOUPPER" using just-str
                        by value function length( just-str )
                        returning result
       end-call.

      *> Centre
       move "C" to justification.
       perform demonstrate-justification.

      *> case change to lower
       call "C$TOLOWER" using just-str
                            by value 80
                        returning result
       end-call.

      *> Right, default if no second argument
       call "C$JUSTIFY" using just-str
                        returning result
       end-call.
       move "R" to justification.
       perform show-justification.

       exit program.
       stop run.

      *> ***************************************************************
       demonstrate-justification.
       call "C$JUSTIFY" using just-str
                            justification
                        returning result
       end-call
       if result not equal 0 then
           display "Problem: " result
           stop run
       end-if
       perform show-justification
       .

      *> ***************************************************************
       show-justification.
       evaluate justification
           when "L"   display "Left justify"
           when "C"   display "Centred (in UPPERCASE)"
           when other display "Right justify"
       end-evaluate
       display "Source:    |" source-str "|"
       display "Justified: |" just-str "|"
       display space
       .


 $ ./justify
 Left justify
 Source:    |    this is a test of the internal voice communication system                   |
 Justified: |this is a test of the internal voice communication system                       |

 Centred (in UPPERCASE)
 Source:    |    this is a test of the internal voice communication system                   |
 Justified: |           THIS IS A TEST OF THE INTERNAL VOICE COMMUNICATION SYSTEM            |

 Right justify
 Source:    |    this is a test of the internal voice communication system                   |
 Justified: |                       this is a test of the internal voice communication system|


/* CB_PARSE_DEF (name, return value if true) */

CB_PARSE_DEF ("OPENCOBOL",              1U)
CB_PARSE_DEF ("GNUCOBOL",               1U)
CB_PARSE_DEF ("P64",                    sizeof (void *) > 4U)
CB_PARSE_DEF ("EXECUTABLE",             cb_flag_main != 0)
CB_PARSE_DEF ("MODULE",                 cb_flag_main == 0)
CB_PARSE_DEF ("TRUNC",                  cb_binary_truncate != 0)
CB_PARSE_DEF ("NOTRUNC",                cb_binary_truncate == 0)
CB_PARSE_DEF ("DEBUG",                  cobc_wants_debug != 0)
CB_PARSE_DEF ("STICKY-LINKAGE",         cb_sticky_linkage != 0)
CB_PARSE_DEF ("NOSTICKY-LINKAGE",       cb_sticky_linkage == 0)
CB_PARSE_DEF ("HOSTSIGNS",              cb_host_sign != 0)
CB_PARSE_DEF ("NOHOSTSIGNS",            cb_host_sign == 0)
CB_PARSE_DEF ("IBMCOMP",                cb_binary_size == CB_BINARY_SIZE_2_4_8)
CB_PARSE_DEF ("OCCOMP",                 cb_binary_size == CB_BINARY_SIZE_1_2_4_8)
CB_PARSE_DEF ("NOIBMCOMP",              cb_binary_size != CB_BINARY_SIZE_2_4_8)

CB_PARSE_DEF ("INTRINSIC-JVM",          1U)
CB_PARSE_DEF ("INTRINSIC-LUA",          1U)
CB_PARSE_DEF ("INTRINSIC-PYTHON",       1U)
CB_PARSE_DEF ("INTRINSIC-REXX",         1U)
CB_PARSE_DEF ("INTRINSIC-TCL",          1U)

>>IF P64 IS SET
    display "binary built assuming 8 byte pointers"
>>END-IF

>>IF OPENCOBOL IS SET
   display "free COBOL is pretty cool"
>>END-IF

>>IF INTRINSIC-TCL IS SET
    display tcl("expr {6 * 7}")
>>ELSE
    display "Intrinsic Tcl not available"
>>END-IF

>>IF ENDIAN = "BIG"
>>IF ENDIAN = "LITTLE"

>>IF CHARSET = "ASCII"
>>IF CHARSET = "EBCDIC"
>>IF CHARSET = "UNKNOWN"

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20131020
      *> License:   Public Domain
      *> Purpose:   Demonstrate GnuCOBOL conditional compile directives
      *> Tectonics: cobc -D PATHONE -x gnucobol-directives.cob
      *>   export GCOB_TESTVAR=42
      *>   cobc -D PATHTWO -x gnucobol-directives.cob
      *> ***************************************************************

       >>DEFINE internal-define 7

       identification division.
       program-id. gnucobol-directives.

       data division.
       working-storage section.
       01 working-var          pic x(32).

      *> ***************************************************************
       procedure division.

       >>IF PATHONE IS DEFINED
           move "First path conditional compile" to working-var
       >>ELSE
           >>IF PATHTWO IS DEFINED
               >>DEFINE internal-define AS 11 OVERRIDE
               move "Second path conditional compile" to working-var
           >>ELSE
               move "No PATHONE or PATHTWO symbols" to working-var
           >>END-IF
       >>END-IF

       display working-var

      *> Turns out that DEFINE directives don't nest in IF directive
       >>IF internal-define is > 10
           display "Hey, big define there"
       >>ELSE
           display "internal-define 10 or less, it won't be"
       >>END-IF

      *> This is how you pull conditional values from the environment
       >>DEFINE GCOB_TESTVAR PARAMETER
       >>IF GCOB_TESTVAR IS DEFINED
           display "Hey, cool, DEFINE with PARAMETER environment"
       >>END-IF

       >>IF GCOB_TESTVAR is > 10
           display "Nice.  PARAMETER and expressions"
       >>END-IF

       goback.
       end program gnucobol-directives.

$ unset GCOB_TESTVAR

$ cobc -E -D PATHONE gnucobol-directives.cob
$ cat gnucobol-directives.i | grep -v '^$'
#line 1 "gnucobol-directives.cob"

identification division.
program-id. gnucobol-directives.
data division.
working-storage section.
01 working-var pic x(32).
procedure division.
move "First path conditional compile" to working-var
display working-var
display "Hey, big define there"
goback.
end program gnucobol-directives.

$ GCOB_TESTVAR=42 cobc -E -D PATHTWO gnucobol-directives.cob
$ cat gnucobol-directives.i | grep -v '^$'
#line 1 "gnucobol-directives.cob"

identification division.
program-id. gnucobol-directives.
data division.
working-storage section.
01 working-var pic x(32).
procedure division.
move "Second path conditional compile" to working-var
display working-var
display "Hey, big define there"
display "Hey, cool, DEFINE with PARAMETER environment"
display "Nice.  PARAMETER and expressions"
goback.
end program gnucobol-directives.

Mnemonic names
SYSIN           Device name
SYSIPT          Device name
STDIN           Device name
SYSOUT          Device name
SYSLIST         Device name
SYSLST          Device name
STDOUT          Device name
PRINTER         Device name
SYSERR          Device name
STDERR          Device name
CONSOLE         Device name
C01             Feature name
C02 .. C12      Feature name
CSP             Feature name
FORMFEED        Feature name
CALL-CONVENTION Feature name
SWITCH-0        Switch name
SWITCH-1 .. 36  Switch name

Extended mnemonic names (with -fsyntax-extension)
SW0             Switch name
SW1 .. SW-36    Switch name

01 record-def.
   05 sub-group-1.
      10 field-a pic x.
      10 field-b pic x.
   05 sub-group-2.
      10 field-c pic x.
         15 sub-group-3.
            20 field-d pic x.
            20 field-e pic x.

01 record-def.
   25 sub-group-1.
      33 field-a pic x.
      33 field-b pic x.
   25 sub-group-2.
      44 field-c pic x.
         45 sub-group-3.
            46 field-d pic x.
            46 field-e pic x.

01 record-def.
   02 sub-group-1.
      03 field-a pic x.
      03 field-b pic x.
   02 sub-group-2.
      03 field-c pic x.
         04 sub-group-3.
            05 field-d pic x.
            05 field-e pic x.

data division.
working-storage section.
01 master.
   05 field-1 pic s9(9).
   05 field-2 pic x(16).
   05 field-3 pic x(4).
   05 field-4 pic s9(9).
66 sixtysix renames field-2.
66 group-66 renames field-2 through field-4.

01 cli-group
   05 cli-text     pic x(16).
      88 helping     values "help", "-help", "-h"
                     when set to false is "rude".
   05 cli-flags    usage binary-long.

set helping to true

set helping to false

move "rude" to cli-text

caveat amplificator, *developer beware*

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
CGI   *> Author:    Brian Tiffin, Francois Hiniger
      *> Date:      30-Aug-2008, 02-Oct-2013
      *> License:   Public Domain
      *> Purpose:   Display some GnuCOBOL CGI environment space
      *> Tectonics: cobc -x gnucobolcgi.cob
      *>  Move gnucobolcgi to the cgi-bin directory as gnucobol.cgi
      *>  browse http://localhost/cgi-bin/gnucobol.cgi
      *>      or http://localhost/gnucgiform.html
      *> ***************************************************************
       identification division.
       program-id. gnucobolcgi.

       environment division.
       input-output section.
       file-control.
           select webinput assign to KEYBOARD
           file status is in-status.

       data division.
       file section.
       fd webinput.
          01 chunk-of-post     pic x(1024).

       working-storage section.
       01 in-status            pic 9999.
       01 newline              pic x     value x'0a'.

       01 name-count           constant  as 25.
       01 name-index           pic 99    usage comp-5.
       01 value-string         pic x(256).
          88 IS-POST                     value 'POST'.
       01 environment-names.
          02 name-strings.
             03 filler         pic x(20) value 'DOCUMENT_ROOT'.
             03 filler         pic x(20) value 'GATEWAY_INTERFACE'.
             03 filler         pic x(20) value 'HTTP_ACCEPT'.
             03 filler         pic x(20) value 'HTTP_ACCEPT_CHARSET'.
             03 filler         pic x(20) value 'HTTP_ACCEPT_ENCODING'.
             03 filler         pic x(20) value 'HTTP_ACCEPT_LANGUAGE'.
             03 filler         pic x(20) value 'HTTP_CONNECTION'.
             03 filler         pic x(20) value 'HTTP_HOST'.
             03 filler         pic x(20) value 'HTTP_USER_AGENT'.
             03 filler         pic x(20) value 'LIB_PATH'.
             03 filler         pic x(20) value 'PATH'.
             03 filler         pic x(20) value 'QUERY_STRING'.
             03 filler         pic x(20) value 'REMOTE_ADDR'.
             03 filler         pic x(20) value 'REMOTE_PORT'.
             03 filler         pic x(20) value 'REQUEST_METHOD'.
             03 filler         pic x(20) value 'REQUEST_URI'.
             03 filler         pic x(20) value 'SCRIPT_FILENAME'.
             03 filler         pic x(20) value 'SCRIPT_NAME'.
             03 filler         pic x(20) value 'SERVER_ADDR'.
             03 filler         pic x(20) value 'SERVER_ADMIN'.
             03 filler         pic x(20) value 'SERVER_NAME'.
             03 filler         pic x(20) value 'SERVER_PORT'.
             03 filler         pic x(20) value 'SERVER_PROTOCOL'.
             03 filler         pic x(20) value 'SERVER_SIGNATURE'.
             03 filler         pic x(20) value 'SERVER_SOFTWARE'.
          02 filler redefines name-strings.
             03 name-string    pic x(20) occurs name-count times.
             88 IS-REQUEST-METHOD        value 'REQUEST_METHOD'.

      *> ***************************************************************
       procedure division.

      *> Always send out the Content-type before any other IO
       display
           "Content-type: text/html"
           newline
       end-display

       display
           "<html><head>"
           "<style>"
           "  table"
           "  { background-color:#e0ffff; border-collapse:collapse; }"
           "  table, th, td"
           "  { border: 1px solid black; }"
           "</style>"
           "</head><body>"
           newline
           "<h3>CGI environment with GnuCOBOL</h3>"
           newline "<p>"
           'To <a href="gnucgiform.html">GnuCOBOL CGI form</a>,'
           ' or <a href="gnuajaxform.html">GnuCOBOL AJAX form</a>'
           newline "</p><p>"
           "<i>All values of &lt;, &gt;, and &amp;"
           " replaced by space</i>"
           "</p><p><table>"
       end-display

      *> Display some of the known CGI environment values
       perform varying name-index from 1 by 1
           until name-index > name-count

               accept value-string from environment
                   name-string(name-index)
               end-accept

              *> cleanse any potential danger, thoughtlessly
               inspect value-string converting "<>&" to "   "

               display
                   "<tr><td>"
                   name-string(name-index)
                   ": </td><td>"
                   function trim (value-string trailing)
                   "</td></tr>"
               end-display

               *> Demonstration of POST handling
               if IS-REQUEST-METHOD(name-index) and IS-POST

                      *> open a channel to the POST data, KEYBOARD
                      *> read what's there, in a loop normally
                      *> and close. For real world, this would
                      *> have more intelligent defensive programming
                      *>   and likely fatter buffers

                      open input webinput
                      if in-status < 10 then
                          read webinput end-read
                          if in-status > 9 then
                              move spaces to chunk-of-post
                          end-if
                      end-if
                      close webinput

                      *> cleanse any potential danger, thoughtlessly
                      inspect chunk-of-post converting "<>&" to "   "

                      display
                          '<tr><td align="right">'
                          "First chunk of POST:&nbsp;"
                          "</td><td>" chunk-of-post(1:72) "</td></tr>"
                      end-display
               end-if
       end-perform

      *> end the table, and being free software, link to the source
       display
           "</table></p>"
           '<a href="gnucobolcgi.cob">GnuCOBOL CGI Source Code</a>'
           "</body></html>" end-display
       goback.

       end program gnucobolcgi.

<html><head><title>GnuCOBOL sample CGI form</title></head>
<body>
<h3>GnuCOBOL sample CGI form</h3>
<p>Welcome to <a href="http://savannah.gnu.org/projects/gnucobol">GnuCOBOL</a>, and
a small demonstration of CGI progamming.</p>
<form action="http://opencobol.add1tocobol.com/gnucobolcgi/gnucobol.cgi" method="post">
    <p>
    Text: <input type="text" name="text"><br>
    Pass: <input type="password" name="pass"><br>
    Checkbox: <input type="checkbox" name="checkbox"><br>
    <input type="radio" name="radio" value="ONE"> One<br>
    <input type="radio" name="radio" value="TWO"> Two<br>
    <input type="submit" value="Send"> <input type="reset">
    </p>
</form>
Pressing <b>Send</b> will cause a GnuCOBOL program to run on the server, with
the Common Gateway Interface results displayed in the browser.
</body>
</html>

As promised, here is the html for AJAX to use the cgenv.cgi example from the FAQ.
You need not change anything with the cobol code.

<html>
<head>
<title>Simple AJAX Example with GnuCOBOL</title>
<script language="Javascript">
function xmlhttpPost(strURL) {
    var xmlHttpReq = false;
    var self = this;
    // Mozilla/Safari
    if (window.XMLHttpRequest) {
        self.xmlHttpReq = new XMLHttpRequest();
    }
    // IE
    else if (window.ActiveXObject) {
        self.xmlHttpReq = new ActiveXObject("Microsoft.XMLHTTP");
    }
    self.xmlHttpReq.open('POST', strURL, true);
    self.xmlHttpReq.setRequestHeader('Content-Type',
        'application/x-www-form-urlencoded');
    self.xmlHttpReq.onreadystatechange = function() {
        if (self.xmlHttpReq.readyState == 4) {
            updatepage(self.xmlHttpReq.responseText);
        }
    }
    self.xmlHttpReq.send(getquerystring());
}

function getquerystring() {
    var form     = document.forms['f1'];
    var word = form.word.value;
    qstr = 'word=' + escape(word);  // NOTE: no '?' before querystring
    return qstr;
}

function updatepage(str){
    document.getElementById("result").innerHTML = str;
}
</script>
</head>
<body>
An asynchronous Javascript to GnuCOBOL example.<br>
Pressing <b>Go</b> will cause an AJAX call to the server,
and CGI results will appear below
<form name="f1">
  <p>word: <input name="word" type="text">
  <input value="Go" type="button" onclick='javascript:xmlhttpPost("gnucobol.cgi")'></p>
  <div id="result"></div>
</form>
</body>
</html>

<script type="text/javascript" src="/js/jquery.js"></script>

$.ajax({
    url: "/gnucobol-cobweb/gnucobol-sample/default.cgi",
        data: {
            report: "RWEX06"
        },
    success: function( data ) {
        $( "#gnucobol-sample" ).html( "<pre>" + data + "</pre>" );
    }
});

svn checkout svn://svn.code.sf.net/p/gnucobol/contrib/ gnucobol-contrib
cd gnucobol-contrib/trunk/samples/cgiform

CGI form and file upload example.

The program usage is described in the program header.

Files:

cgiform.cob            - CGI COBOL program
cgiform.html           - demo HTML form
cygwin_apache_start.sh - start apache under cygwin
cygwin_apache_stop.sh  - stop apache under cygwin
makefile               - compile the CGI COBOL program under cygwin
readme.txt             - this file

The CGI Program was tested in these environment:
- 64 bit windows, 64 bit cygwin, GnuCOBOL 2.0,
  apache web server under cygwin,
  Firefox 39.0.3.

This parses automatically GET, POST and POST with file upload requests. The
parsed information (field names, values, length) will be saved in an internal
table. After it you can get the values with the function COB2CGI-POST:

MOVE COB2CGI-POST(FIRSTNAME) TO FNAME

It's very easy to extend or change this program. Please search for these lines:

* begin user defined content *
* end user defined content *

Between these lines you can define your variables in WORKING-STORAGE section,
or you can write your HTML reply in COB2CGI-MAIN section, or you can write your
own sections.

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
       "http://www.w3.org/TR/html4/loose.dtd">
<html>
<head>
<title>CGI form test with post</title>
<meta http-equiv="content-type" content="text/html;charset=utf-8" />
<meta http-equiv="Content-Style-Type" content="text/css" />
</head>
<body>

<h2>CGI form test with post</h2>
<p>
<form action="/cgi-bin/cgiform" method="post" accept-charset="UTF-8">
  <table border="0" cellpadding="0" cellspacing="4">
    <tr>
      <td align="right">First name:</td>
      <td><input name="firstname" type="text" size="30" maxlength="30"></td>
    </tr>
    <tr>
      <td align="right">Last name:</td>
      <td><input name="lastname" type="text" size="30" maxlength="30"></textarea></td>
    </tr>
  </table>
  <br>
  <input type="submit" value="Send"> <input type="reset">
</form>
</p>

<h2>CGI file upload test</h2>

File upload uses enctype="multipart/form-data".
<br><br>

<p>
<form action="/cgi-bin/cgiform" method="post" accept-charset="UTF-8"
     enctype="multipart/form-data">

  <table border="0" cellpadding="0" cellspacing="4">
    <tr>
      <td align="right">First name:</td>
      <td><input name="firstname" type="text" size="30" maxlength="30"></td>
    </tr>
    <tr>
      <td align="right">Last name:</td>
      <td><input name="lastname" type="text" size="30" maxlength="30"></textarea></td>
    </tr>
    <tr>
      <td align="right">upload1:</td>
      <td><input type="file" name="upload1" /></td>
    </tr>
  </table>

<br>
<input type="submit" value="Upload form data" />

</form>
</p>

</body>
</html>

*>******************************************************************************
*>  cgiform is free software: you can redistribute it and/or modify it
*>  under the terms of the GNU General Public License as published by the Free
*>  Software Foundation, either version 3 of the License, or (at your option)
*>  any later version.
*>
*>  cgiform is distributed in the hope that it will be useful, but
*>  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
*>  or FITNESS FOR A PARTICULAR PURPOSE.
*>  See the GNU General Public License for more details.
*>
*>  You should have received a copy of the GNU General Public License along
*>  with cgiform.
*>  If not, see <http://www.gnu.org/licenses/>.
*>******************************************************************************

*>******************************************************************************
*> Program:      cgiform.cob
*>
*> Purpose:      CGI form and file upload example
*>
*> Author:       Laszlo Erdos - https://www.facebook.com/wortfee
*>
*> Date-Written: 2015.08.21
*>
*> Tectonics:    cobc -x -free cgiform.cob
*>
*>               Compile for Windows with this define "OS=WINDOWS"
*>               (GnuCOBOL with MS Visual Studio):
*>
*>               cobc -x -free cgiform.cob -D OS=WINDOWS
*>
*> Usage:        Compile this program and copy the runnable code to your web
*>               servers cgi-bin directory. Create a HTML file, and copy it in
*>               the htdocs directory. If you want to upload a file, you
*>               have to use enctype="multipart/form-data" in your HTML form.
*>
*>               This program processes every field in a HTML form, not only
*>               input type="file". The processed data will be written in an
*>               internal table: COB2CGI-TABLE. The field values will be saved
*>               in COB2CGI-DATA-VALUE variable. After the parsing you can get
*>               all values with the COB2CGI-POST function.
*>
*>               The uploaded files will be created in your cgi-bin directory.
*>               You can simply change this if you add a file path to the file
*>               at the function "CBL_CREATE_FILE".
*>
*>               The file type and content will be checked. For this demo
*>               only images (BMP, GIF, JPG, PNG, TIFF) are allowed. See the
*>               definition COB2CGI-CHECK-FILE-TYPE and the section
*>               COB2CGI-CHECK-FILE-DATA.
*>
*>               It's very easy to extend or change this program. Please search
*>               for these lines:
*>               ********* begin user defined content *********
*>               ********* end user defined content   *********
*>               Between these lines you can define your variables in
*>               WORKING-STORAGE section, or you can write your HTML reply in
*>               COB2CGI-MAIN section, or you can write your own section.
*>
*>******************************************************************************
*> Date       Change description
*> ========== ==================================================================
*> 2015.08.21 First version.
*>
*>******************************************************************************

 IDENTIFICATION DIVISION.
 PROGRAM-ID. cgiform.

 ENVIRONMENT DIVISION.
 CONFIGURATION SECTION.
 REPOSITORY.
    FUNCTION COB2CGI-POST
    FUNCTION COB2CGI-DECODE
    FUNCTION COB2CGI-ENV
    FUNCTION COB2CGI-NUM2HEX
    FUNCTION ALL INTRINSIC.

 DATA DIVISION.

 WORKING-STORAGE SECTION.
*> end of line char
 78 COB2CGI-LF                         VALUE X"0A".
 78 COB2CGI-CRLF                       VALUE X"0D0A".

*> flags
 01 COB2CGI-ERROR-FLAG                 PIC 9.
    88 V-COB2CGI-ERROR-NO              VALUE 0.
    88 V-COB2CGI-ERROR-YES             VALUE 1.
 01 COB2CGI-REQUEST-METHOD-FLAG        PIC 9.
    88 V-COB2CGI-REQUEST-METHOD-GET    VALUE 0.
    88 V-COB2CGI-REQUEST-METHOD-POST   VALUE 1.
 01 COB2CGI-MULTIPART-FLAG             PIC 9.
    88 V-COB2CGI-MULTIPART-NO          VALUE 0.
    88 V-COB2CGI-MULTIPART-YES         VALUE 1.
 01 COB2CGI-POST-FIELD-VALUE-FLAG      PIC 9.
    88 V-COB2CGI-POST-FIELD            VALUE 0.
    88 V-COB2CGI-POST-VALUE            VALUE 1.
 01 COB2CGI-EOF-FLAG                   PIC 9.
    88 V-COB2CGI-EOF-NO                VALUE 0.
    88 V-COB2CGI-EOF-YES               VALUE 1.

*> for environment variables
 01 COB2CGI-ENV-VALUE                  PIC X(256).

*> for GET data in query string
 78 COB2CGI-QUERY-STR-MAX-LEN          VALUE 65536.
 01 COB2CGI-QUERY-STR                  PIC X(COB2CGI-QUERY-STR-MAX-LEN)
                                             VALUE LOW-VALUE.
 01 COB2CGI-QUERY-STR-LEN              PIC 9(9) COMP.
 01 COB2CGI-QUERY-STR-IND              PIC 9(9) COMP.

*> for POST data together with UPLOAD file
 78 COB2CGI-CONTENT-MAX-LEN            VALUE 1000000.
 01 COB2CGI-CONTENT-LEN                PIC 9(9) COMP.

*> counts all received chars
 01 COB2CGI-CHAR-COUNT                 PIC S9(9) COMP.

*> for the C function getchar()
 01 COB2CGI-GETCHAR                    BINARY-INT.

*> !!!this is only for windows, GnuCOBOL with MS Visual Studio!!!
*> we have to switch stdin in binary mode
>>IF OS = "WINDOWS"
 01 COB2CGI-RET                        BINARY-INT.
*> file mode is binary (untranslated) x"8000"
 01 COB2CGI-MODE-BINARY                BINARY-INT VALUE 32768.
>>END-IF

*> character conversion
 01 COB2CGI-CHAR                       PIC X(1).
 01 COB2CGI-CHAR-R REDEFINES COB2CGI-CHAR PIC S9(2) COMP-5.

 01 COB2CGI-UTF8-STR                   PIC X(3).

*> max field length in the table
 78 COB2CGI-TAB-FIELD-MAX-LEN          VALUE 40.
*> max number of lines in the table
 78 COB2CGI-TAB-MAX-LINE               VALUE 1000.
 01 COB2CGI-TAB-IND                    PIC 9(9) COMP.
*> saved number of lines in the table
 01 COB2CGI-TAB-NR                     EXTERNAL PIC 9(9) COMP.
*> length of one COB2CGI-TAB-LINE = 161,
*> therefore the size of table = 161 * COB2CGI-TAB-MAX-LINE
 01 COB2CGI-TABLE-R                    EXTERNAL PIC X(161000).
 01 COB2CGI-TABLE REDEFINES COB2CGI-TABLE-R.
   02 COB2CGI-TAB.
     03 COB2CGI-TAB-LINE               OCCURS 1 TO COB2CGI-TAB-MAX-LINE TIMES.
       *> there are only the name of fields in the internal table,
       *> all values will be saved in the field COB2CGI-DATA-VALUE
       04 COB2CGI-TAB-FIELD            PIC X(40).
       04 COB2CGI-TAB-FIELD-LEN        PIC 9(9) COMP.
       04 COB2CGI-TAB-VALUE-PTR        PIC 9(9) COMP.
       04 COB2CGI-TAB-VALUE-LEN        PIC 9(9) COMP.
       04 COB2CGI-TAB-FILE-FLAG        PIC 9.
          88 V-COB2CGI-TAB-FILE-NO     VALUE 0.
          88 V-COB2CGI-TAB-FILE-YES    VALUE 1.
       04 COB2CGI-TAB-FILE-NAME        PIC X(60).
       04 COB2CGI-TAB-FILE-NAME-LEN    PIC 9(9) COMP.
       04 COB2CGI-TAB-FILE-TYPE        PIC X(40).
       04 COB2CGI-TAB-FILE-DATA-LEN    PIC 9(9) COMP.

*> max value length
 78 COB2CGI-DATA-VALUE-MAX-LEN         VALUE 500000.
*> we can save memory, if we use one field for all values
 01 COB2CGI-DATA-VALUE        EXTERNAL PIC X(COB2CGI-DATA-VALUE-MAX-LEN).

*> indices for cycles
 01 COB2CGI-IND-1                      PIC 9(9) COMP.
 01 COB2CGI-IND-2                      PIC 9(9) COMP.

*> for POST UPLOAD processing --------------------------------------------------

*> flags
 01 COB2CGI-EOL-FLAG                   PIC 9.
    88 V-COB2CGI-EOL-NO                VALUE 0.
    88 V-COB2CGI-EOL-YES               VALUE 1.
 01 COB2CGI-BOUNDARY-FLAG              PIC 9.
    88 V-COB2CGI-BOUNDARY-NO           VALUE 0.
    88 V-COB2CGI-BOUNDARY-YES          VALUE 1.
 01 COB2CGI-BOUNDARY-EOF-FLAG          PIC 9.
    88 V-COB2CGI-BOUNDARY-EOF-NO       VALUE 0.
    88 V-COB2CGI-BOUNDARY-EOF-YES      VALUE 1.
 01 COB2CGI-CONTENT-DISP-FLAG          PIC 9.
    88 V-COB2CGI-CONTENT-DISP-ERROR    VALUE 0.
    88 V-COB2CGI-CONTENT-DISP-FIELD    VALUE 1.
    88 V-COB2CGI-CONTENT-DISP-FILE     VALUE 2.
 01 COB2CGI-FIRST-LINE-FLAG            PIC 9.
    88 V-COB2CGI-FIRST-LINE-NO         VALUE 0.
    88 V-COB2CGI-FIRST-LINE-YES        VALUE 1.

*> boundary string in CONTENT_TYPE
*> example: "---------------------------5276231769132"
*> this boundary string splits the form fields and uploaded files
 01 COB2CGI-BOUNDARY                   PIC X(256).
 01 COB2CGI-BOUNDARY-LEN               PIC S9(9) COMP.
*> boundary string plus "--", this is the last boundary string
*> example: "---------------------------5276231769132--"
 01 COB2CGI-BOUNDARY-EOF               PIC X(256).

*> input buffer
 78 COB2CGI-INPUT-BUF-MAX-LEN          VALUE 1024.
 01 COB2CGI-INPUT-BUF                  PIC X(COB2CGI-INPUT-BUF-MAX-LEN).
 01 COB2CGI-INPUT-BUF-IND              PIC S9(09) COMP.
 01 COB2CGI-INPUT-BUF-SAVE             PIC X(COB2CGI-INPUT-BUF-MAX-LEN).
 01 COB2CGI-INPUT-BUF-SAVE-IND         PIC S9(09) COMP.

*> counter for COBOL inspect
 01 COB2CGI-INSPECT-COUNT              PIC S9(09) COMP.

*> max. uploaded file size
 78 COB2CGI-UPLOAD-FILE-MAX-SIZE       VALUE 300000.

*> check uploaded file type
 01 COB2CGI-CHECK-FILE-TYPE            PIC X(40).
    88 V-COB2CGI-FILE-TYPE-TXT         VALUE "text/plain".
    *> application
    88 V-COB2CGI-FILE-TYPE-EXE         VALUE "application/octet-stream".
    88 V-COB2CGI-FILE-TYPE-PDF         VALUE "application/pdf".
    88 V-COB2CGI-FILE-TYPE-ZIP         VALUE "application/zip".
    *> image
    88 V-COB2CGI-FILE-TYPE-BMP         VALUE "image/bmp".
    88 V-COB2CGI-FILE-TYPE-GIF         VALUE "image/gif".
    88 V-COB2CGI-FILE-TYPE-JPG         VALUE "image/jpeg".
    88 V-COB2CGI-FILE-TYPE-PNG         VALUE "image/png".
    88 V-COB2CGI-FILE-TYPE-TIF         VALUE "image/tiff".
    *> only images allowed
    88 V-COB2CGI-FILE-TYPE-ALLOWED     VALUE "image/bmp",  "image/gif"
                                             "image/jpeg", "image/png"
                                             "image/tiff".

*> temp file name
 01 COB2CGI-TMP-FILE-NAME              PIC X(COB2CGI-INPUT-BUF-MAX-LEN).
 01 COB2CGI-TMP-FILE-NAME-LEN          PIC 9(9) COMP.
 01 COB2CGI-TMP-FILE-PATH-LEN          PIC 9(9) COMP.

*> create and write the uploaded file
 01 COB2CGI-FILE-HANDLE                PIC X(4) USAGE COMP-X.
 01 COB2CGI-FILE-OFFSET                PIC X(8) USAGE COMP-X.
 01 COB2CGI-FILE-NBYTES                PIC X(4) USAGE COMP-X.
 01 COB2CGI-FILE-BUF                   PIC X(COB2CGI-INPUT-BUF-MAX-LEN).

*> ********* begin user defined content *********

 01 FIRSTNAME                 PIC X(40) VALUE "firstname".
 01 LASTNAME                  PIC X(40) VALUE "lastname".

 01 FNAME.
   02 LEN                     PIC 9(9) COMP.
   02 VAL                     PIC X(100).
 01 LNAME.
   02 LEN                     PIC 9(9) COMP.
   02 VAL                     PIC X(100).

*> ********* end user defined content   *********

 PROCEDURE DIVISION.

*>------------------------------------------------------------------------------
 COB2CGI-MAIN SECTION.
*>------------------------------------------------------------------------------

    *> Always send out the Content-type before any other IO
    DISPLAY "Content-Type: text/html; charset=utf-8"
            COB2CGI-LF
    END-DISPLAY

*>  Test cookie
*>  DISPLAY
*>     "Content-Type: text/html; charset=utf-8"
*>     "Set-Cookie: testcookie=first"
*>     "Set-Cookie: sessionToken=abc123; Expires=Wed, 19 Jun 2015 10:18:14 GMT"
*>     COB2CGI-LF
*>  END-DISPLAY

    PERFORM COB2CGI-PROCESS-DATA
    IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
    THEN
       GOBACK
    END-IF

*> ********* begin user defined content *********

    DISPLAY "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN""" END-DISPLAY
    DISPLAY "       ""http://www.w3.org/TR/html4/loose.dtd"">" END-DISPLAY
    DISPLAY "<html>" END-DISPLAY
    DISPLAY "<head>" END-DISPLAY
    DISPLAY "<title>Hello GnuCOBOL world!</title>" END-DISPLAY
    DISPLAY "<meta http-equiv=""content-type"" content=""text/html;charset=utf-8"" />" END-DISPLAY
    DISPLAY "<meta http-equiv=""Content-Style-Type"" content=""text/css"" />" END-DISPLAY
    DISPLAY "</head>" END-DISPLAY
    DISPLAY "<body>" END-DISPLAY

    MOVE COB2CGI-POST(FIRSTNAME) TO FNAME
    MOVE COB2CGI-POST(LASTNAME)  TO LNAME

    DISPLAY "<br><br>" END-DISPLAY
    DISPLAY "Hello GnuCOBOL world!" END-DISPLAY

    DISPLAY "<p>" END-DISPLAY
    DISPLAY "First name: " END-DISPLAY

    DISPLAY VAL OF FNAME(1:LEN OF FNAME) END-DISPLAY

    DISPLAY "<br>" END-DISPLAY
    DISPLAY "Last name : " END-DISPLAY

    DISPLAY VAL OF LNAME(1:LEN OF LNAME) END-DISPLAY

    DISPLAY "<br>" END-DISPLAY
    DISPLAY "</p>" END-DISPLAY
    DISPLAY "</body>" END-DISPLAY
    DISPLAY "</html>" END-DISPLAY

*> ********* end user defined content   *********

    GOBACK

    .
 COB2CGI-MAIN-EX.
    EXIT.

*> ********* begin user defined content *********

*> here you can write your own sections

*> ********* end user defined content   *********

*>------------------------------------------------------------------------------
 COB2CGI-PROCESS-DATA SECTION.
*>------------------------------------------------------------------------------

    SET V-COB2CGI-ERROR-NO OF COB2CGI-ERROR-FLAG TO TRUE

*> !!!this is only for windows, GnuCOBOL with MS Visual Studio!!!
*> we have to switch stdin in binary mode
>>IF OS = "WINDOWS"
    PERFORM COB2CGI-SET-BINARY-MODE
    IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
    THEN
       DISPLAY "<BR>Error in SET-BINARY-MODE <BR>" END-DISPLAY
       EXIT SECTION
    END-IF
>>END-IF

    *> check REQUEST_METHOD
    MOVE COB2CGI-ENV("REQUEST_METHOD")
      TO COB2CGI-ENV-VALUE

    IF  COB2CGI-ENV-VALUE NOT = "GET"
    AND COB2CGI-ENV-VALUE NOT = "POST"
    THEN
       DISPLAY "<BR>Error: wrong REQUEST_METHOD: " COB2CGI-ENV-VALUE " <BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    IF COB2CGI-ENV-VALUE = "GET"
    THEN
       SET V-COB2CGI-REQUEST-METHOD-GET  OF COB2CGI-REQUEST-METHOD-FLAG TO TRUE
       PERFORM COB2CGI-PROCESS-GET
       IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
       THEN
          DISPLAY "<BR>Error in PROCESS-GET <BR>" END-DISPLAY
          EXIT SECTION
       END-IF
    ELSE
       SET V-COB2CGI-REQUEST-METHOD-POST OF COB2CGI-REQUEST-METHOD-FLAG TO TRUE
       PERFORM COB2CGI-PROCESS-POST
       IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
       THEN
          DISPLAY "<BR>Error in PROCESS-POST <BR>" END-DISPLAY
          EXIT SECTION
       END-IF
    END-IF

    .
 COB2CGI-PROCESS-DATA-EX.
    EXIT.

*> !!!this is only for windows, GnuCOBOL with MS Visual Studio!!!
*> we have to switch stdin in binary mode
>>IF OS = "WINDOWS"
*>------------------------------------------------------------------------------
 COB2CGI-SET-BINARY-MODE SECTION.
*>------------------------------------------------------------------------------

    CALL STATIC "_setmode"
         USING BY VALUE 0
               BY VALUE COB2CGI-MODE-BINARY
         RETURNING COB2CGI-RET
    END-CALL

    *> if cannot set binary mode, then result = -1
    IF COB2CGI-RET = -1
    THEN
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       DISPLAY "Error: cannot set binary mode"
               "<BR>"
       END-DISPLAY
    END-IF

    .
 COB2CGI-SET-BINARY-MODE-EX.
    EXIT.
>>END-IF

*>------------------------------------------------------------------------------
 COB2CGI-PROCESS-GET SECTION.
*>------------------------------------------------------------------------------

    *> QUERY_STRING is the URL-encoded information
    *> that is sent with GET method request.
    MOVE COB2CGI-ENV("QUERY_STRING")
      TO COB2CGI-QUERY-STR
    MOVE FUNCTION STORED-CHAR-LENGTH(COB2CGI-ENV("QUERY_STRING"))
      TO COB2CGI-QUERY-STR-LEN

    *> no data
    IF COB2CGI-QUERY-STR-LEN = ZEROES
    THEN
       EXIT SECTION
    END-IF

    *> check QUERY_STRING data length
    IF COB2CGI-QUERY-STR-LEN > COB2CGI-QUERY-STR-MAX-LEN
    THEN
       DISPLAY "<BR>Error: QUERY_STRING length " COB2CGI-QUERY-STR-LEN
               " greater than " COB2CGI-QUERY-STR-MAX-LEN " max. length <BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    *> parse GET data
    PERFORM COB2CGI-PARSE-GET-POST
    IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
    THEN
       DISPLAY "<BR>Error in PARSE-GET-POST <BR>" END-DISPLAY
       EXIT SECTION
    END-IF

    .
 COB2CGI-PROCESS-GET-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-PROCESS-POST SECTION.
*>------------------------------------------------------------------------------

    *> check CONTENT_LENGTH
    MOVE COB2CGI-ENV("CONTENT_LENGTH")
      TO COB2CGI-ENV-VALUE

    MOVE NUMVAL(COB2CGI-ENV-VALUE)
      TO COB2CGI-CONTENT-LEN

    IF COB2CGI-CONTENT-LEN > COB2CGI-CONTENT-MAX-LEN
    THEN
       DISPLAY "<BR>Error: CONTENT_LENGTH " COB2CGI-CONTENT-LEN
               " greater than " COB2CGI-CONTENT-MAX-LEN " max. length <BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    *> no data
    IF COB2CGI-CONTENT-LEN = ZEROES
    THEN
       EXIT SECTION
    END-IF

    *> check CONTENT_TYPE
    MOVE COB2CGI-ENV("CONTENT_TYPE")
      TO COB2CGI-ENV-VALUE

    EVALUATE TRUE
       *> this is only a POST
       WHEN COB2CGI-ENV-VALUE(1:33) = "application/x-www-form-urlencoded"
          SET V-COB2CGI-MULTIPART-NO OF COB2CGI-MULTIPART-FLAG TO TRUE

          *> parse POST data
          PERFORM COB2CGI-PARSE-GET-POST
          IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
          THEN
             DISPLAY "<BR>Error in PARSE-GET-POST <BR>" END-DISPLAY
             EXIT SECTION
          END-IF

       *> this is a POST with file UPLOAD
       WHEN COB2CGI-ENV-VALUE(1:29) = "multipart/form-data; boundary"
          SET V-COB2CGI-MULTIPART-YES OF COB2CGI-MULTIPART-FLAG TO TRUE
          *> parse multipart POST data, save UPLOAD
          PERFORM COB2CGI-PARSE-UPLOAD
          IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
          THEN
             DISPLAY "<BR>Error in PARSE-UPLOAD <BR>" END-DISPLAY
             EXIT SECTION
          END-IF

       WHEN OTHER
          DISPLAY "<BR>Error: wrong CONTENT_TYPE: " COB2CGI-ENV-VALUE "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
          EXIT SECTION
    END-EVALUATE

    .
 COB2CGI-PROCESS-POST-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-PARSE-GET-POST SECTION.
*>------------------------------------------------------------------------------

    MOVE ZEROES TO COB2CGI-QUERY-STR-IND
    MOVE ZEROES TO COB2CGI-CHAR-COUNT
    MOVE ZEROES TO COB2CGI-GETCHAR
    SET V-COB2CGI-EOF-NO OF COB2CGI-EOF-FLAG TO TRUE

    *> field name comes first
    SET V-COB2CGI-POST-FIELD OF COB2CGI-POST-FIELD-VALUE-FLAG TO TRUE
    MOVE 1 TO COB2CGI-TAB-IND
    MOVE 1 TO COB2CGI-TAB-NR
    INITIALIZE COB2CGI-TAB-LINE(COB2CGI-TAB-IND)
    MOVE 1 TO COB2CGI-IND-1
    MOVE 1 TO COB2CGI-IND-2

    PERFORM UNTIL V-COB2CGI-EOF-YES   OF COB2CGI-EOF-FLAG
            OR    V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
       *> read next char from CGI input stream
       PERFORM COB2CGI-READ-NEXT-CHAR
       IF V-COB2CGI-EOF-YES OF COB2CGI-EOF-FLAG
       THEN
          EXIT PERFORM
       END-IF

       EVALUATE TRUE
          *> end of field name
          WHEN COB2CGI-CHAR = "="
             SET V-COB2CGI-POST-VALUE OF COB2CGI-POST-FIELD-VALUE-FLAG TO TRUE
             COMPUTE COB2CGI-TAB-FIELD-LEN(COB2CGI-TAB-IND)
                   = COB2CGI-IND-1 - 1
             END-COMPUTE
             MOVE 1 TO COB2CGI-IND-1
             MOVE COB2CGI-IND-2
               TO COB2CGI-TAB-VALUE-PTR(COB2CGI-TAB-IND)

          *> end of value, start a field name
          WHEN COB2CGI-CHAR = "&"
             SET V-COB2CGI-POST-FIELD OF COB2CGI-POST-FIELD-VALUE-FLAG TO TRUE
             IF COB2CGI-TAB-IND = 1
             THEN
                COMPUTE COB2CGI-TAB-VALUE-LEN(COB2CGI-TAB-IND)
                      = COB2CGI-IND-2 - 1
                END-COMPUTE
             ELSE
                COMPUTE COB2CGI-TAB-VALUE-LEN(COB2CGI-TAB-IND)
                      = COB2CGI-IND-2 - COB2CGI-TAB-VALUE-PTR(COB2CGI-TAB-IND)
                END-COMPUTE
             END-IF

             ADD 1 TO COB2CGI-TAB-IND
             ADD 1 TO COB2CGI-TAB-NR

             *> check table limit
             IF COB2CGI-TAB-IND > COB2CGI-TAB-MAX-LINE
             OR COB2CGI-TAB-NR  > COB2CGI-TAB-MAX-LINE
             THEN
                DISPLAY "<BR>Error: DATA-TAB-NR " COB2CGI-TAB-NR
                        " greater than " COB2CGI-TAB-MAX-LINE
                        " DATA-TAB-MAX-LINE <BR>"
                END-DISPLAY
                SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
                EXIT SECTION
             END-IF
             *> init next line in the table
             INITIALIZE COB2CGI-TAB-LINE(COB2CGI-TAB-IND)

          *> UTF8 special char in hexa code
          WHEN COB2CGI-CHAR = "%"
             MOVE COB2CGI-CHAR TO COB2CGI-UTF8-STR(1:1)
             *> read next char from CGI input stream
             PERFORM COB2CGI-READ-NEXT-CHAR
             IF V-COB2CGI-EOF-YES OF COB2CGI-EOF-FLAG
             THEN
                EXIT PERFORM
             END-IF
             MOVE COB2CGI-CHAR TO COB2CGI-UTF8-STR(2:1)

             *> read next char from CGI input stream
             PERFORM COB2CGI-READ-NEXT-CHAR
             IF V-COB2CGI-EOF-YES OF COB2CGI-EOF-FLAG
             THEN
                EXIT PERFORM
             END-IF
             MOVE COB2CGI-CHAR TO COB2CGI-UTF8-STR(3:1)

             *> convert UTF8 string
             MOVE COB2CGI-DECODE(COB2CGI-UTF8-STR)
               TO COB2CGI-DATA-VALUE(COB2CGI-IND-2:1)

             *> check value limit
             ADD 1 TO COB2CGI-IND-2
             IF COB2CGI-IND-2 > COB2CGI-DATA-VALUE-MAX-LEN
             THEN
                DISPLAY "<BR>Error: DATA-VALUE-LEN " COB2CGI-IND-2
                        " greater than " COB2CGI-DATA-VALUE-MAX-LEN
                        " DATA-VALUE-MAX-LEN <BR>"
                END-DISPLAY
                SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
                EXIT SECTION
             END-IF

          *> a SPACE char
          WHEN COB2CGI-CHAR = "+"
             MOVE SPACES
               TO COB2CGI-DATA-VALUE(COB2CGI-IND-2:1)

             *> check value limit
             ADD 1 TO COB2CGI-IND-2
             IF COB2CGI-IND-2 > COB2CGI-DATA-VALUE-MAX-LEN
             THEN
                DISPLAY "<BR>Error: DATA-VALUE-LEN " COB2CGI-IND-2
                        " greater than " COB2CGI-DATA-VALUE-MAX-LEN
                        " DATA-VALUE-MAX-LEN <BR>"
                END-DISPLAY
                SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
                EXIT SECTION
             END-IF

          *> other chars
          WHEN OTHER
             IF V-COB2CGI-POST-FIELD OF COB2CGI-POST-FIELD-VALUE-FLAG
             THEN
                MOVE COB2CGI-CHAR
                  TO COB2CGI-TAB-FIELD(COB2CGI-TAB-IND)
                                           (COB2CGI-IND-1:1)

                *> check field limit
                ADD 1 TO COB2CGI-IND-1
                IF COB2CGI-IND-1 > COB2CGI-TAB-FIELD-MAX-LEN
                THEN
                   DISPLAY "<BR>Error: FIELD-LEN " COB2CGI-IND-1
                           " greater than " COB2CGI-TAB-FIELD-MAX-LEN
                           " DATA-TAB-FIELD-MAX-LEN <BR>"
                   END-DISPLAY
                   SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
                   EXIT SECTION
                END-IF
             ELSE
                MOVE COB2CGI-CHAR
                  TO COB2CGI-DATA-VALUE(COB2CGI-IND-2:1)

                *> check value limit
                ADD 1 TO COB2CGI-IND-2
                IF COB2CGI-IND-2 > COB2CGI-DATA-VALUE-MAX-LEN
                THEN
                   DISPLAY "<BR>Error: DATA-VALUE-LEN " COB2CGI-IND-2
                           " greater than " COB2CGI-DATA-VALUE-MAX-LEN
                           " DATA-VALUE-MAX-LEN <BR>"
                   END-DISPLAY
                   SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
                   EXIT SECTION
                END-IF
             END-IF
       END-EVALUATE
    END-PERFORM

    IF COB2CGI-TAB-IND = 1
    THEN
       COMPUTE COB2CGI-TAB-VALUE-LEN(COB2CGI-TAB-IND)
             = COB2CGI-IND-2 - 1
       END-COMPUTE
    ELSE
       COMPUTE COB2CGI-TAB-VALUE-LEN(COB2CGI-TAB-IND)
             = COB2CGI-IND-2 - COB2CGI-TAB-VALUE-PTR(COB2CGI-TAB-IND)
       END-COMPUTE
    END-IF

    .
 COB2CGI-PARSE-GET-POST-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-READ-NEXT-CHAR SECTION.
*>------------------------------------------------------------------------------

    ADD 1 TO COB2CGI-CHAR-COUNT

    IF COB2CGI-CHAR-COUNT > COB2CGI-CONTENT-LEN + 1
    THEN
       DISPLAY "<BR>Error: CHAR-COUNT " COB2CGI-CHAR-COUNT
               " greater than " COB2CGI-CONTENT-LEN " CONTENT-LEN <BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    IF V-COB2CGI-REQUEST-METHOD-GET OF COB2CGI-REQUEST-METHOD-FLAG
    THEN
       *> data with GET
       ADD 1 TO COB2CGI-QUERY-STR-IND

       IF COB2CGI-QUERY-STR-IND > COB2CGI-QUERY-STR-MAX-LEN
       THEN
          DISPLAY "<BR>Error: QUERY-STR-IND " COB2CGI-QUERY-STR-IND
                  " greater than " COB2CGI-QUERY-STR-MAX-LEN
                  " QUERY-STR-MAX-LEN <BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
          EXIT SECTION
       END-IF

       IF COB2CGI-QUERY-STR-IND > COB2CGI-QUERY-STR-LEN
       THEN
          SET V-COB2CGI-EOF-YES OF COB2CGI-EOF-FLAG TO TRUE
          EXIT SECTION
       END-IF

       MOVE COB2CGI-QUERY-STR(COB2CGI-QUERY-STR-IND:1)
         TO COB2CGI-CHAR
    ELSE
       *> data with POST
       CALL STATIC "getchar" RETURNING COB2CGI-GETCHAR END-CALL

       IF COB2CGI-GETCHAR < ZEROES
       THEN
          SET V-COB2CGI-EOF-YES OF COB2CGI-EOF-FLAG TO TRUE
          EXIT SECTION
       END-IF

       MOVE COB2CGI-GETCHAR TO COB2CGI-CHAR-R
    END-IF

    *> !!!only for test!!!
    *> DISPLAY COB2CGI-CHAR WITH NO ADVANCING END-DISPLAY

    .
 COB2CGI-READ-NEXT-CHAR-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-PARSE-UPLOAD SECTION.
*>------------------------------------------------------------------------------

    PERFORM COB2CGI-UPL-GET-BOUNDARY
    IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
    THEN
       DISPLAY "<BR>Error in UPL-GET-BOUNDARY <BR>" END-DISPLAY
       EXIT SECTION
    END-IF

    *> !!!only for test, display boundary data!!!
    *> DISPLAY "BOUNDARY: " COB2CGI-BOUNDARY "<BR>" END-DISPLAY
    *> DISPLAY "BOUNDARY-LEN: " COB2CGI-BOUNDARY-LEN "<BR>" END-DISPLAY
    *> DISPLAY "BOUNDARY-EOF: " COB2CGI-BOUNDARY-EOF "<BR>" "<BR>"  END-DISPLAY

    PERFORM COB2CGI-UPL-READ-POST

    *> !!!only for test!!!
    *> success, if boundary EOF string found, without any error
    *> IF  V-COB2CGI-ERROR-NO OF COB2CGI-ERROR-FLAG
    *> AND V-COB2CGI-BOUNDARY-EOF-YES OF COB2CGI-BOUNDARY-EOF-FLAG
    *> THEN
    *>    DISPLAY "<BR>" "<BR>"
    *>            "BOUNDARY-EOF found, CGI post processed successfully"
    *>            "<BR>" "<BR>"
    *>    END-DISPLAY
    *> END-IF

    .
 COB2CGI-PARSE-UPLOAD-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-UPL-GET-BOUNDARY SECTION.
*>------------------------------------------------------------------------------

    IF COB2CGI-ENV-VALUE(1:30) = "multipart/form-data; boundary="
    THEN
       MOVE COB2CGI-ENV-VALUE(31:) TO COB2CGI-BOUNDARY
       MOVE FUNCTION STORED-CHAR-LENGTH(COB2CGI-BOUNDARY)
         TO COB2CGI-BOUNDARY-LEN

       MOVE SPACES TO COB2CGI-BOUNDARY-EOF
       STRING COB2CGI-BOUNDARY(1:COB2CGI-BOUNDARY-LEN)
              "--"
         INTO COB2CGI-BOUNDARY-EOF
       END-STRING
    ELSE
       DISPLAY "Error: can not find boundary string: "
               COB2CGI-ENV-VALUE
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    .
 COB2CGI-UPL-GET-BOUNDARY-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-UPL-READ-POST SECTION.
*>------------------------------------------------------------------------------

    MOVE ZEROES TO COB2CGI-CHAR-COUNT
    MOVE ZEROES TO COB2CGI-GETCHAR
    MOVE 1 TO COB2CGI-IND-2

    *> read a "boundary" line with EOL
    PERFORM COB2CGI-READ-NEXT-LINE
    IF V-COB2CGI-EOL-YES OF COB2CGI-EOL-FLAG
    THEN
       PERFORM COB2CGI-CHECK-BOUNDARY

       *> this must be a "boundary" line
       IF V-COB2CGI-BOUNDARY-NO OF COB2CGI-BOUNDARY-FLAG
       THEN
          DISPLAY "Error: boundary line not found"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
          EXIT SECTION
       END-IF
    ELSE
       DISPLAY "Error: end of line not found"
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    PERFORM UNTIL COB2CGI-CHAR-COUNT > COB2CGI-CONTENT-LEN
            OR    COB2CGI-GETCHAR < ZEROES
            OR    V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
            OR    V-COB2CGI-BOUNDARY-EOF-YES OF COB2CGI-BOUNDARY-EOF-FLAG

       *> read a "Content-Disposition" line with EOL
       PERFORM COB2CGI-READ-NEXT-LINE

       *> this must have an EOL
       IF V-COB2CGI-EOL-YES OF COB2CGI-EOL-FLAG
       THEN
          PERFORM COB2CGI-CHECK-CONTENT-DISP
          IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
          THEN
             EXIT SECTION
          END-IF

          *> this must be a "Content-Disposition" line
          EVALUATE TRUE
          WHEN V-COB2CGI-CONTENT-DISP-FIELD OF COB2CGI-CONTENT-DISP-FLAG
             *> read and save field value
             PERFORM COB2CGI-PARSE-FIELD-VALUE

          WHEN V-COB2CGI-CONTENT-DISP-FILE  OF COB2CGI-CONTENT-DISP-FLAG
             *> read and save the uploaded file
             PERFORM COB2CGI-PARSE-FILE-UPLOAD

          WHEN OTHER
             DISPLAY "Error: Content-Disposition not found"
                     "<BR>"
             END-DISPLAY
             SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
             EXIT SECTION
          END-EVALUATE
       ELSE
          DISPLAY "Error: end of line not found"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
          EXIT SECTION
       END-IF
    END-PERFORM

    .
 COB2CGI-UPL-READ-POST-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-READ-NEXT-LINE SECTION.
*>------------------------------------------------------------------------------

    MOVE ZEROES    TO COB2CGI-INPUT-BUF-IND
    MOVE LOW-VALUE TO COB2CGI-INPUT-BUF

    SET V-COB2CGI-EOL-NO OF COB2CGI-EOL-FLAG TO TRUE
    SET V-COB2CGI-EOF-NO OF COB2CGI-EOF-FLAG TO TRUE

    PERFORM UNTIL COB2CGI-CHAR-COUNT > COB2CGI-CONTENT-LEN
            OR    COB2CGI-INPUT-BUF-IND > COB2CGI-INPUT-BUF-MAX-LEN
            OR    COB2CGI-GETCHAR < ZEROES

       CALL STATIC "getchar" RETURNING COB2CGI-GETCHAR END-CALL

       IF COB2CGI-CHAR-COUNT > COB2CGI-CONTENT-LEN
       OR COB2CGI-GETCHAR < ZEROES
       THEN
          SET V-COB2CGI-EOF-YES OF COB2CGI-EOF-FLAG TO TRUE
          EXIT SECTION
       END-IF

       ADD 1 TO COB2CGI-CHAR-COUNT
       ADD 1 TO COB2CGI-INPUT-BUF-IND

       IF COB2CGI-INPUT-BUF-IND <= COB2CGI-INPUT-BUF-MAX-LEN
       THEN
          MOVE COB2CGI-GETCHAR TO COB2CGI-CHAR-R
          MOVE COB2CGI-CHAR    TO COB2CGI-INPUT-BUF(COB2CGI-INPUT-BUF-IND:1)

          *> !!!only for test!!!
          *> received chars
          *> DISPLAY COB2CGI-CHAR WITH NO ADVANCING END-DISPLAY
          *> received chars with num values
          *> DISPLAY "(" COB2CGI-GETCHAR ")" END-DISPLAY
          *> IF COB2CGI-GETCHAR = 10
          *> THEN
          *>    DISPLAY "<BR>" END-DISPLAY
          *> END-IF

          *> check end of line X"0A" or X"0D0A"
          IF COB2CGI-GETCHAR = 10
          OR COB2CGI-INPUT-BUF-IND = COB2CGI-INPUT-BUF-MAX-LEN
          THEN
             SET V-COB2CGI-EOL-YES OF COB2CGI-EOL-FLAG TO TRUE
             EXIT SECTION
          END-IF
       ELSE
          *> input buffer full
          EXIT SECTION
       END-IF
    END-PERFORM

    .
 COB2CGI-READ-NEXT-LINE-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-CHECK-BOUNDARY SECTION.
*>------------------------------------------------------------------------------

    SET V-COB2CGI-BOUNDARY-NO     OF COB2CGI-BOUNDARY-FLAG     TO TRUE
    SET V-COB2CGI-BOUNDARY-EOF-NO OF COB2CGI-BOUNDARY-EOF-FLAG TO TRUE

    *> search boundary string
    MOVE ZEROES TO COB2CGI-INSPECT-COUNT
    INSPECT COB2CGI-INPUT-BUF(1:COB2CGI-INPUT-BUF-IND)
       TALLYING COB2CGI-INSPECT-COUNT
       FOR ALL  COB2CGI-BOUNDARY(1:COB2CGI-BOUNDARY-LEN)

    IF COB2CGI-INSPECT-COUNT > ZEROES
    THEN
       SET V-COB2CGI-BOUNDARY-YES OF COB2CGI-BOUNDARY-FLAG TO TRUE

       *> search boundary EOF string
       MOVE ZEROES TO COB2CGI-INSPECT-COUNT
       INSPECT COB2CGI-INPUT-BUF(1:COB2CGI-INPUT-BUF-IND)
          TALLYING COB2CGI-INSPECT-COUNT
          FOR ALL  COB2CGI-BOUNDARY-EOF(1:COB2CGI-BOUNDARY-LEN + 2)

       IF COB2CGI-INSPECT-COUNT > ZEROES
       THEN
          SET V-COB2CGI-BOUNDARY-EOF-YES OF COB2CGI-BOUNDARY-EOF-FLAG TO TRUE
       END-IF
    END-IF

    .
 COB2CGI-CHECK-BOUNDARY-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-CHECK-CONTENT-DISP SECTION.
*>------------------------------------------------------------------------------

    SET V-COB2CGI-CONTENT-DISP-ERROR OF COB2CGI-CONTENT-DISP-FLAG TO TRUE

    IF COB2CGI-INPUT-BUF(1:38) NOT = "Content-Disposition: form-data; name="""
    THEN
       EXIT SECTION
    END-IF

    *> for every Content-Disposition there is a line in the internal table
    ADD 1 TO COB2CGI-TAB-IND
    MOVE COB2CGI-TAB-IND TO COB2CGI-TAB-NR

    IF COB2CGI-TAB-IND > COB2CGI-TAB-MAX-LINE
    THEN
       DISPLAY "Error: internal table full"
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    *> get length of field name
    MOVE ZEROES TO COB2CGI-INSPECT-COUNT
    INSPECT COB2CGI-INPUT-BUF(39:)
       TALLYING COB2CGI-INSPECT-COUNT
       FOR CHARACTERS BEFORE INITIAL """"

    *> save length of field name
    MOVE COB2CGI-INSPECT-COUNT
      TO COB2CGI-TAB-FIELD-LEN(COB2CGI-TAB-IND)

    *> save field name
    MOVE COB2CGI-INPUT-BUF(39:COB2CGI-INSPECT-COUNT)
      TO COB2CGI-TAB-FIELD(COB2CGI-TAB-IND)

    *> search number of fields
    MOVE ZEROES TO COB2CGI-INSPECT-COUNT
    INSPECT COB2CGI-INPUT-BUF(39:)
       TALLYING COB2CGI-INSPECT-COUNT
       FOR ALL """"

    *> this is only one field --> exit section
    IF COB2CGI-INSPECT-COUNT = 1
    THEN
       SET V-COB2CGI-CONTENT-DISP-FIELD OF COB2CGI-CONTENT-DISP-FLAG TO TRUE
       SET V-COB2CGI-TAB-FILE-NO OF COB2CGI-TAB-FILE-FLAG(COB2CGI-TAB-IND)
                                                                     TO TRUE
       EXIT SECTION
    END-IF

    *> search file name
    MOVE ZEROES TO COB2CGI-INSPECT-COUNT
    INSPECT COB2CGI-INPUT-BUF(39 + COB2CGI-TAB-FIELD-LEN(COB2CGI-TAB-IND):)
       TALLYING COB2CGI-INSPECT-COUNT
       FOR CHARACTERS BEFORE INITIAL "filename="""

    IF COB2CGI-INSPECT-COUNT = 3
    THEN
       SET V-COB2CGI-CONTENT-DISP-FILE OF COB2CGI-CONTENT-DISP-FLAG TO TRUE
       SET V-COB2CGI-TAB-FILE-YES OF COB2CGI-TAB-FILE-FLAG(COB2CGI-TAB-IND)
                                                                    TO TRUE

       *> get length of file name
       MOVE ZEROES TO COB2CGI-INSPECT-COUNT
       INSPECT COB2CGI-INPUT-BUF(39 + COB2CGI-TAB-FIELD-LEN(COB2CGI-TAB-IND)
                                    + 13:)
          TALLYING COB2CGI-INSPECT-COUNT
          FOR CHARACTERS BEFORE INITIAL """"

       *> save length of file name in temp
       MOVE COB2CGI-INSPECT-COUNT
         TO COB2CGI-TMP-FILE-NAME-LEN

       *> save file name in temp
       MOVE COB2CGI-INPUT-BUF(39 + COB2CGI-TAB-FIELD-LEN(COB2CGI-TAB-IND)
                                 + 13:COB2CGI-INSPECT-COUNT)
         TO COB2CGI-TMP-FILE-NAME

       *> Check file name. Internet Explorer sends a file name with full
       *> file path, but Firefox sends only a file name.
       MOVE ZEROES TO COB2CGI-INSPECT-COUNT
       INSPECT COB2CGI-TMP-FILE-NAME
          TALLYING COB2CGI-INSPECT-COUNT
          FOR ALL "\" "/"

       IF COB2CGI-INSPECT-COUNT = ZEROES
       THEN
          *> this is only a file name without file path
          *> save length of file name
          MOVE COB2CGI-TMP-FILE-NAME-LEN
            TO COB2CGI-TAB-FILE-NAME-LEN(COB2CGI-TAB-IND)
          *> save file name
          MOVE COB2CGI-TMP-FILE-NAME
            TO COB2CGI-TAB-FILE-NAME(COB2CGI-TAB-IND)
       ELSE
          *> this is a file name with full file path, get file name from it
          MOVE ZEROES TO COB2CGI-INSPECT-COUNT

          INSPECT FUNCTION REVERSE(COB2CGI-TMP-FILE-NAME)
             TALLYING COB2CGI-INSPECT-COUNT
             FOR CHARACTERS BEFORE INITIAL "\"
                            BEFORE INITIAL "/"

          COMPUTE COB2CGI-TMP-FILE-PATH-LEN
                = FUNCTION LENGTH(COB2CGI-TMP-FILE-NAME)
                - COB2CGI-INSPECT-COUNT + 1
          END-COMPUTE

          *> save length of file name
          COMPUTE COB2CGI-TAB-FILE-NAME-LEN(COB2CGI-TAB-IND)
                = COB2CGI-TMP-FILE-NAME-LEN
                - COB2CGI-TMP-FILE-PATH-LEN + 1
          END-COMPUTE

          *> save file name
          MOVE COB2CGI-TMP-FILE-NAME(COB2CGI-TMP-FILE-PATH-LEN:
                                     COB2CGI-TAB-FILE-NAME-LEN(COB2CGI-TAB-IND))
            TO COB2CGI-TAB-FILE-NAME(COB2CGI-TAB-IND)
       END-IF
    ELSE
       DISPLAY "Error: filename not found in Content-Disposition"
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    .
 COB2CGI-CHECK-CONTENT-DISP-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-PARSE-FIELD-VALUE SECTION.
*>------------------------------------------------------------------------------

    *> this must be an empty line
    PERFORM COB2CGI-READ-NEXT-LINE
    IF V-COB2CGI-EOL-NO OF COB2CGI-EOL-FLAG
    OR COB2CGI-INPUT-BUF(1:2) NOT = COB2CGI-CRLF
    THEN
       DISPLAY "Error: end of line not found"
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    *> init char counter
    MOVE ZEROES TO COB2CGI-IND-1

    SET V-COB2CGI-FIRST-LINE-YES OF COB2CGI-FIRST-LINE-FLAG TO TRUE
    MOVE SPACES TO COB2CGI-INPUT-BUF-SAVE
    MOVE ZEROES TO COB2CGI-INPUT-BUF-SAVE-IND

    *> set value pointer in the table
    MOVE COB2CGI-IND-2
      TO COB2CGI-TAB-VALUE-PTR(COB2CGI-TAB-IND)

    PERFORM TEST AFTER
      UNTIL V-COB2CGI-BOUNDARY-YES     OF COB2CGI-BOUNDARY-FLAG
      OR    V-COB2CGI-BOUNDARY-EOF-YES OF COB2CGI-BOUNDARY-EOF-FLAG

       *> read a line
       PERFORM COB2CGI-READ-NEXT-LINE
       IF V-COB2CGI-EOF-YES OF COB2CGI-EOF-FLAG
       THEN
          DISPLAY "Error: boundary line not found"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
          EXIT SECTION
       END-IF

       PERFORM COB2CGI-CHECK-BOUNDARY

       IF V-COB2CGI-BOUNDARY-YES     OF COB2CGI-BOUNDARY-FLAG
       OR V-COB2CGI-BOUNDARY-EOF-YES OF COB2CGI-BOUNDARY-EOF-FLAG
       THEN
          *> end of field reached
          *> write last line without CRLF
          IF COB2CGI-INPUT-BUF-SAVE-IND > 2
          THEN
             IF COB2CGI-IND-2 < COB2CGI-DATA-VALUE-MAX-LEN
             THEN
                MOVE COB2CGI-INPUT-BUF-SAVE(1:COB2CGI-INPUT-BUF-SAVE-IND - 2)
                  TO COB2CGI-DATA-VALUE(COB2CGI-IND-2:)
                COMPUTE COB2CGI-IND-1 = COB2CGI-IND-1
                                 + COB2CGI-INPUT-BUF-SAVE-IND - 2
                END-COMPUTE
                MOVE COB2CGI-IND-1
                  TO COB2CGI-TAB-VALUE-LEN(COB2CGI-TAB-IND)
                ADD COB2CGI-IND-1 TO COB2CGI-IND-2
             ELSE
                DISPLAY "Error: value is too long"
                        "<BR>"
                END-DISPLAY
                SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
                EXIT SECTION
             END-IF
          END-IF

          EXIT PERFORM
       ELSE
          IF V-COB2CGI-FIRST-LINE-NO OF COB2CGI-FIRST-LINE-FLAG
          THEN
             *> this was only a CRLF, we have to write it in the internal table
             IF COB2CGI-IND-2 < COB2CGI-DATA-VALUE-MAX-LEN
             THEN
                MOVE COB2CGI-INPUT-BUF-SAVE(1:COB2CGI-INPUT-BUF-SAVE-IND)
                  TO COB2CGI-DATA-VALUE(COB2CGI-IND-2:)
                ADD COB2CGI-INPUT-BUF-SAVE-IND TO COB2CGI-IND-1
                MOVE COB2CGI-IND-1
                  TO COB2CGI-TAB-VALUE-LEN(COB2CGI-TAB-IND)
                ADD COB2CGI-IND-1 TO COB2CGI-IND-2
             ELSE
                DISPLAY "Error: value is too long"
                        "<BR>"
                END-DISPLAY
                SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
                EXIT SECTION
             END-IF
          END-IF

          *> save line
          SET V-COB2CGI-FIRST-LINE-NO OF COB2CGI-FIRST-LINE-FLAG TO TRUE
          MOVE COB2CGI-INPUT-BUF     TO COB2CGI-INPUT-BUF-SAVE
          MOVE COB2CGI-INPUT-BUF-IND TO COB2CGI-INPUT-BUF-SAVE-IND
       END-IF
    END-PERFORM

    .
 COB2CGI-PARSE-FIELD-VALUE-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-PARSE-FILE-UPLOAD SECTION.
*>------------------------------------------------------------------------------

    *> this must be a Content-Type
    PERFORM COB2CGI-READ-NEXT-LINE
    IF V-COB2CGI-EOL-NO OF COB2CGI-EOL-FLAG
    OR COB2CGI-INPUT-BUF(1:14) NOT = "Content-Type: "
    THEN
       DISPLAY "Error: Content-Type not found"
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    *> save Content-Type as file type
    MOVE ZEROES TO COB2CGI-INSPECT-COUNT
    INSPECT COB2CGI-INPUT-BUF(15:)
       TALLYING COB2CGI-INSPECT-COUNT
       FOR CHARACTERS BEFORE INITIAL COB2CGI-CRLF
    MOVE COB2CGI-INPUT-BUF(15:COB2CGI-INSPECT-COUNT)
      TO COB2CGI-TAB-FILE-TYPE(COB2CGI-TAB-IND)

    *> if not empty file
    IF COB2CGI-TAB-FILE-NAME-LEN(COB2CGI-TAB-IND) NOT = ZEROES
    THEN
       *> check file type
       MOVE COB2CGI-TAB-FILE-TYPE(COB2CGI-TAB-IND) TO COB2CGI-CHECK-FILE-TYPE
       IF  NOT V-COB2CGI-FILE-TYPE-ALLOWED OF COB2CGI-CHECK-FILE-TYPE
       THEN
          DISPLAY "Error: File-Type not allowed"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
          EXIT SECTION
       END-IF
    END-IF

    *> this must be an empty line
    PERFORM COB2CGI-READ-NEXT-LINE
    IF V-COB2CGI-EOL-NO OF COB2CGI-EOL-FLAG
    OR COB2CGI-INPUT-BUF(1:2) NOT = COB2CGI-CRLF
    THEN
       DISPLAY "Error: end of line not found"
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    *> if not empty file
    IF COB2CGI-TAB-FILE-NAME-LEN(COB2CGI-TAB-IND) NOT = ZEROES
    THEN
       *> create uploaded file
       PERFORM COB2CGI-FILE-CREATE
       IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
       THEN
          EXIT SECTION
       END-IF
    END-IF

    *> init offset
    MOVE ZEROES TO COB2CGI-FILE-OFFSET

    SET V-COB2CGI-FIRST-LINE-YES OF COB2CGI-FIRST-LINE-FLAG TO TRUE
    MOVE SPACES TO COB2CGI-INPUT-BUF-SAVE
    MOVE ZEROES TO COB2CGI-INPUT-BUF-SAVE-IND

    PERFORM TEST AFTER
      UNTIL V-COB2CGI-BOUNDARY-YES     OF COB2CGI-BOUNDARY-FLAG
      OR    V-COB2CGI-BOUNDARY-EOF-YES OF COB2CGI-BOUNDARY-EOF-FLAG

       *> read a line
       PERFORM COB2CGI-READ-NEXT-LINE
       IF V-COB2CGI-EOF-YES OF COB2CGI-EOF-FLAG
       THEN
          DISPLAY "Error: boundary line not found"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
          EXIT PERFORM
       END-IF

       PERFORM COB2CGI-CHECK-BOUNDARY

       IF V-COB2CGI-BOUNDARY-YES     OF COB2CGI-BOUNDARY-FLAG
       OR V-COB2CGI-BOUNDARY-EOF-YES OF COB2CGI-BOUNDARY-EOF-FLAG
       THEN
          *> end of uploaded file reached
          *> write last line without CRLF
          IF COB2CGI-INPUT-BUF-SAVE-IND > 2
          THEN
             MOVE COB2CGI-INPUT-BUF-SAVE(1:COB2CGI-INPUT-BUF-SAVE-IND - 2)
               TO COB2CGI-FILE-BUF
             COMPUTE COB2CGI-FILE-NBYTES = COB2CGI-INPUT-BUF-SAVE-IND - 2
             END-COMPUTE

             PERFORM COB2CGI-FILE-WRITE
             IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
             THEN
                EXIT PERFORM
             END-IF
          END-IF

          EXIT PERFORM
       ELSE
          IF V-COB2CGI-FIRST-LINE-NO OF COB2CGI-FIRST-LINE-FLAG
          THEN
             *> this was only a CRLF, we have to write it in the file
             MOVE COB2CGI-INPUT-BUF-SAVE(1:COB2CGI-INPUT-BUF-SAVE-IND)
               TO COB2CGI-FILE-BUF
             MOVE COB2CGI-INPUT-BUF-SAVE-IND TO COB2CGI-FILE-NBYTES

             PERFORM COB2CGI-FILE-WRITE
             IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
             THEN
                EXIT PERFORM
             END-IF
          ELSE
             *> if not empty file
             IF COB2CGI-TAB-FILE-NAME-LEN(COB2CGI-TAB-IND) NOT = ZEROES
             THEN
                *> this is the first line, we can check here the file data
                PERFORM COB2CGI-CHECK-FILE-DATA
                IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
                THEN
                   EXIT PERFORM
                END-IF
             END-IF
          END-IF

          *> save line
          SET V-COB2CGI-FIRST-LINE-NO OF COB2CGI-FIRST-LINE-FLAG TO TRUE
          MOVE COB2CGI-INPUT-BUF     TO COB2CGI-INPUT-BUF-SAVE
          MOVE COB2CGI-INPUT-BUF-IND TO COB2CGI-INPUT-BUF-SAVE-IND
       END-IF
    END-PERFORM

    *> if not empty file
    IF COB2CGI-TAB-FILE-NAME-LEN(COB2CGI-TAB-IND) NOT = ZEROES
    THEN
       PERFORM COB2CGI-FILE-CLOSE
       IF V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG
       THEN
          EXIT SECTION
       END-IF
    END-IF

    .
 COB2CGI-PARSE-FILE-UPLOAD-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-CHECK-FILE-DATA SECTION.
*>------------------------------------------------------------------------------

    *> check uploaded file data
    EVALUATE TRUE
    WHEN V-COB2CGI-FILE-TYPE-BMP OF COB2CGI-CHECK-FILE-TYPE
       IF COB2CGI-INPUT-BUF(1:2) NOT = "BM"
       THEN
          DISPLAY "Error: Image content not BMP"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       END-IF

    WHEN V-COB2CGI-FILE-TYPE-GIF OF COB2CGI-CHECK-FILE-TYPE
       IF COB2CGI-INPUT-BUF(1:3) NOT = "GIF"
       THEN
          DISPLAY "Error: Image content not GIF"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       END-IF

    WHEN V-COB2CGI-FILE-TYPE-JPG OF COB2CGI-CHECK-FILE-TYPE
       IF  COB2CGI-INPUT-BUF(1:4) NOT = X"FFD8FFE0"
       AND COB2CGI-INPUT-BUF(1:4) NOT = X"FFD8FFE1"
       THEN
          DISPLAY "Error: Image content not JPG"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       END-IF

    WHEN V-COB2CGI-FILE-TYPE-PNG OF COB2CGI-CHECK-FILE-TYPE
       IF COB2CGI-INPUT-BUF(1:4) NOT = X"89504E47"
       THEN
          DISPLAY "Error: Image content not PNG"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       END-IF

    WHEN V-COB2CGI-FILE-TYPE-TIF OF COB2CGI-CHECK-FILE-TYPE
       IF  COB2CGI-INPUT-BUF(1:3) NOT = X"49492A"
       AND COB2CGI-INPUT-BUF(1:3) NOT = X"4D4D2A"
       THEN
          DISPLAY "Error: Image content not TIF"
                  "<BR>"
          END-DISPLAY
          SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       END-IF

    WHEN OTHER
       DISPLAY "Error: File-Type not allowed"
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
    END-EVALUATE

    .
 COB2CGI-CHECK-FILE-DATA-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-FILE-CREATE SECTION.
*>------------------------------------------------------------------------------

    CALL "CBL_CREATE_FILE"
         USING COB2CGI-TAB-FILE-NAME(COB2CGI-TAB-IND)
             , 2
             , 0
             , 0
             , COB2CGI-FILE-HANDLE
    END-CALL

    IF RETURN-CODE NOT = ZEROES
    THEN
       DISPLAY "Error: CBL_CREATE_FILE, "
               "FILE: " COB2CGI-TAB-FILE-NAME(COB2CGI-TAB-IND)
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
    END-IF

    .
 COB2CGI-FILE-CREATE-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-FILE-WRITE SECTION.
*>------------------------------------------------------------------------------

    CALL "CBL_WRITE_FILE"
         USING COB2CGI-FILE-HANDLE
       , COB2CGI-FILE-OFFSET
       , COB2CGI-FILE-NBYTES
       , 0
       , COB2CGI-FILE-BUF(1:COB2CGI-INPUT-BUF-IND)
    END-CALL

    IF RETURN-CODE NOT = ZEROES
    THEN
       DISPLAY "Error: CBL_WRITE_FILE, "
               "FILE: " COB2CGI-TAB-FILE-NAME(COB2CGI-TAB-IND)
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
    END-IF

    ADD  COB2CGI-FILE-NBYTES TO COB2CGI-FILE-OFFSET
    *> update uploaded file size
    MOVE COB2CGI-FILE-OFFSET TO COB2CGI-TAB-FILE-DATA-LEN(COB2CGI-TAB-IND)

    *> check max. allowed file size
    IF COB2CGI-UPLOAD-FILE-MAX-SIZE < COB2CGI-TAB-FILE-DATA-LEN(COB2CGI-TAB-IND)
    THEN
       DISPLAY "Error: " COB2CGI-TAB-FILE-NAME(COB2CGI-TAB-IND) " file size"
               " > " COB2CGI-UPLOAD-FILE-MAX-SIZE " max. allowed size" "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
       EXIT SECTION
    END-IF

    .
 COB2CGI-FILE-WRITE-EX.
    EXIT.

*>------------------------------------------------------------------------------
 COB2CGI-FILE-CLOSE SECTION.
*>------------------------------------------------------------------------------

    CALL "CBL_CLOSE_FILE"
         USING COB2CGI-FILE-HANDLE
    END-CALL

    IF RETURN-CODE NOT = ZEROES
    THEN
       DISPLAY "Error: CBL_CLOSE_FILE, "
               "FILE: " COB2CGI-TAB-FILE-NAME(COB2CGI-TAB-IND)
               "<BR>"
       END-DISPLAY
       SET V-COB2CGI-ERROR-YES OF COB2CGI-ERROR-FLAG TO TRUE
    END-IF

    .
 COB2CGI-FILE-CLOSE-EX.
    EXIT.

 END PROGRAM cgiform.

*>******************************************************************************
*>  COB2CGI-POST.cob is free software: you can redistribute it and/or
*>  modify it under the terms of the GNU Lesser General Public License as
*>  published by the Free Software Foundation, either version 3 of the License,
*>  or (at your option) any later version.
*>
*>  COB2CGI-POST.cob is distributed in the hope that it will be useful,
*>  but WITHOUT ANY WARRANTY; without even the implied warranty of
*>  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
*>  See the GNU Lesser General Public License for more details.
*>
*>  You should have received a copy of the GNU Lesser General Public License
*>  along with COB2CGI-POST.cob.
*>  If not, see <http://www.gnu.org/licenses/>.
*>******************************************************************************

*>******************************************************************************
*> Function:     COB2CGI-POST.cob
*>
*> Purpose:      Get saved cgi values
*>
*> Author:       Laszlo Erdos - https://www.facebook.com/wortfee
*>
*> Date-Written: 2015.08.21
*>
*> Usage:        To use this function, simply CALL it as follows:
*>               COB2CGI-POST(<cgi-field-name>)
*>               Fields in COB2CGI-POST linkage:
*>                 <cgi-field-name>  - input
*>                 <cgi-field-value> - output
*>******************************************************************************

 IDENTIFICATION DIVISION.
 FUNCTION-ID. COB2CGI-POST.
 AUTHOR.      Laszlo Erdos.

 ENVIRONMENT DIVISION.
 DATA DIVISION.
 WORKING-STORAGE SECTION.

*> there are only the name of fields in the internal table
 01 COB2CGI-TAB-IND                    PIC 9(9) COMP.
 78 COB2CGI-TAB-MAX-LINE               VALUE 1000.
 01 COB2CGI-TAB-NR            EXTERNAL PIC 9(9) COMP.
 01 COB2CGI-TABLE-R           EXTERNAL PIC X(161000).
 01 COB2CGI-TABLE REDEFINES COB2CGI-TABLE-R.
   02 COB2CGI-DATA-TAB.
     03 COB2CGI-TAB-LINE               OCCURS 1 TO COB2CGI-TAB-MAX-LINE TIMES.
       04 COB2CGI-TAB-FIELD            PIC X(40).
       04 COB2CGI-TAB-FIELD-LEN        PIC 9(9) COMP.
       04 COB2CGI-TAB-VALUE-PTR        PIC 9(9) COMP.
       04 COB2CGI-TAB-VALUE-LEN        PIC 9(9) COMP.
       04 COB2CGI-TAB-FILE-FLAG        PIC 9.
          88 V-COB2CGI-TAB-FILE-NO     VALUE 0.
          88 V-COB2CGI-TAB-FILE-YES    VALUE 1.
       04 COB2CGI-TAB-FILE-NAME        PIC X(60).
       04 COB2CGI-TAB-FILE-NAME-LEN    PIC 9(9) COMP.
       04 COB2CGI-TAB-FILE-TYPE        PIC X(40).
       04 COB2CGI-TAB-FILE-DATA-LEN    PIC 9(9) COMP.

*> we can save memory, if we use one field for all values
 01 COB2CGI-DATA-VALUE        EXTERNAL PIC X(500000).

 01 COB2CGI-IND-1                      PIC 9(9) COMP.

 LINKAGE SECTION.
 01 LNK-CGI-FIELD-NAME                 PIC X(40).
 01 LNK-CGI-FIELD-VALUE.
   02 LEN                              PIC 9(9) COMP.
   02 VAL                              PIC X(500000).

 PROCEDURE DIVISION USING     BY VALUE LNK-CGI-FIELD-NAME
                    RETURNING          LNK-CGI-FIELD-VALUE.

 COB2CGI-POST-MAIN SECTION.

    PERFORM VARYING COB2CGI-IND-1 FROM 1 BY 1
      UNTIL COB2CGI-IND-1 > COB2CGI-TAB-NR
      OR    COB2CGI-IND-1 > COB2CGI-TAB-MAX-LINE

       IF COB2CGI-TAB-FIELD(COB2CGI-IND-1) = LNK-CGI-FIELD-NAME
       THEN
          IF COB2CGI-TAB-VALUE-LEN(COB2CGI-IND-1) = ZEROES
          THEN
             MOVE ZEROES
               TO LEN OF LNK-CGI-FIELD-VALUE
             MOVE SPACES
               TO VAL OF LNK-CGI-FIELD-VALUE
          ELSE
             MOVE COB2CGI-TAB-VALUE-LEN(COB2CGI-IND-1)
               TO LEN OF LNK-CGI-FIELD-VALUE
             MOVE COB2CGI-DATA-VALUE
                  (COB2CGI-TAB-VALUE-PTR(COB2CGI-IND-1):
                   COB2CGI-TAB-VALUE-LEN(COB2CGI-IND-1))
               TO VAL OF LNK-CGI-FIELD-VALUE
          END-IF

          EXIT PERFORM
       END-IF
    END-PERFORM

    IF COB2CGI-IND-1 > COB2CGI-TAB-NR
    OR COB2CGI-IND-1 > COB2CGI-TAB-MAX-LINE
    THEN
       MOVE ZEROES
         TO LEN OF LNK-CGI-FIELD-VALUE
       MOVE SPACES
         TO VAL OF LNK-CGI-FIELD-VALUE
    END-IF

    GOBACK

    .
 COB2CGI-POST-MAIN-EX.
    EXIT.
 END FUNCTION COB2CGI-POST.

*>******************************************************************************
*>  COB2CGI-ENV.cob is free software: you can redistribute it and/or
*>  modify it under the terms of the GNU Lesser General Public License as
*>  published by the Free Software Foundation, either version 3 of the License,
*>  or (at your option) any later version.
*>
*>  COB2CGI-ENV.cob is distributed in the hope that it will be useful,
*>  but WITHOUT ANY WARRANTY; without even the implied warranty of
*>  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
*>  See the GNU Lesser General Public License for more details.
*>
*>  You should have received a copy of the GNU Lesser General Public License
*>  along with COB2CGI-ENV.cob.
*>  If not, see <http://www.gnu.org/licenses/>.
*>******************************************************************************

*>******************************************************************************
*> Function:     COB2CGI-ENV.cob
*>
*> Purpose:      Get cgi environment variables
*>
*> Author:       Laszlo Erdos - https://www.facebook.com/wortfee
*>
*> Date-Written: 2015.08.21
*>
*> Usage:        To use this function, simply CALL it as follows:
*>               COB2CGI-ENV(<env-name>)
*>               Fields in COB2CGI-ENV linkage:
*>                 <env-name>  - input
*>                 <env-value> - output
*>******************************************************************************

 IDENTIFICATION DIVISION.
 FUNCTION-ID. COB2CGI-ENV.
 AUTHOR.      Laszlo Erdos.

 ENVIRONMENT DIVISION.
 DATA DIVISION.
 WORKING-STORAGE SECTION.

 LINKAGE SECTION.
 01 LNK-ENV-NAME                       PIC X(256).
 01 LNK-ENV-VALUE                      PIC X(256).

 PROCEDURE DIVISION USING     BY VALUE LNK-ENV-NAME
                    RETURNING          LNK-ENV-VALUE.

 COB2CGI-ENV-MAIN SECTION.

    ACCEPT LNK-ENV-VALUE FROM ENVIRONMENT
           LNK-ENV-NAME
    END-ACCEPT

    GOBACK

    .
 COB2CGI-ENV-MAIN-EX.
    EXIT.
 END FUNCTION COB2CGI-ENV.

*>******************************************************************************
*>  COB2CGI-DECODE.cob is free software: you can redistribute it and/or
*>  modify it under the terms of the GNU Lesser General Public License as
*>  published by the Free Software Foundation, either version 3 of the License,
*>  or (at your option) any later version.
*>
*>  COB2CGI-DECODE.cob is distributed in the hope that it will be useful,
*>  but WITHOUT ANY WARRANTY; without even the implied warranty of
*>  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
*>  See the GNU Lesser General Public License for more details.
*>
*>  You should have received a copy of the GNU Lesser General Public License
*>  along with COB2CGI-DECODE.cob.
*>  If not, see <http://www.gnu.org/licenses/>.
*>******************************************************************************

*>******************************************************************************
*> Function:     COB2CGI-DECODE.cob
*>
*> Purpose:      Decode UTF-8 chars
*>
*> Author:       Laszlo Erdos - https://www.facebook.com/wortfee
*>
*> Date-Written: 2015.08.21
*>
*> Usage:        To use this function, simply CALL it as follows:
*>               COB2CGI-DECODE(<UTF8-string>)
*>               Fields in COB2CGI-DECODE linkage:
*>                 <UTF8-string>  - input
*>                 <UTF8-value>   - output
*>******************************************************************************

 IDENTIFICATION DIVISION.
 FUNCTION-ID. COB2CGI-DECODE.
 AUTHOR.      Laszlo Erdos.

 ENVIRONMENT DIVISION.
 DATA DIVISION.
 WORKING-STORAGE SECTION.

 01 WS-DECODE-TABLE.
   02 FILLER                           PIC X(4) VALUE "%00" & X"00".
   02 FILLER                           PIC X(4) VALUE "%01" & X"01".
   02 FILLER                           PIC X(4) VALUE "%02" & X"02".
   02 FILLER                           PIC X(4) VALUE "%03" & X"03".
   02 FILLER                           PIC X(4) VALUE "%04" & X"04".
   02 FILLER                           PIC X(4) VALUE "%05" & X"05".
   02 FILLER                           PIC X(4) VALUE "%06" & X"06".
   02 FILLER                           PIC X(4) VALUE "%07" & X"07".
   02 FILLER                           PIC X(4) VALUE "%08" & X"08".
   02 FILLER                           PIC X(4) VALUE "%09" & X"09".
   02 FILLER                           PIC X(4) VALUE "%0A" & X"0A".
   02 FILLER                           PIC X(4) VALUE "%0B" & X"0B".
   02 FILLER                           PIC X(4) VALUE "%0C" & X"0C".
   02 FILLER                           PIC X(4) VALUE "%0D" & X"0D".
   02 FILLER                           PIC X(4) VALUE "%0E" & X"0E".
   02 FILLER                           PIC X(4) VALUE "%0F" & X"0F".

   02 FILLER                           PIC X(4) VALUE "%10" & X"10".
   02 FILLER                           PIC X(4) VALUE "%11" & X"11".
   02 FILLER                           PIC X(4) VALUE "%12" & X"12".
   02 FILLER                           PIC X(4) VALUE "%13" & X"13".
   02 FILLER                           PIC X(4) VALUE "%14" & X"14".
   02 FILLER                           PIC X(4) VALUE "%15" & X"15".
   02 FILLER                           PIC X(4) VALUE "%16" & X"16".
   02 FILLER                           PIC X(4) VALUE "%17" & X"17".
   02 FILLER                           PIC X(4) VALUE "%18" & X"18".
   02 FILLER                           PIC X(4) VALUE "%19" & X"19".
   02 FILLER                           PIC X(4) VALUE "%1A" & X"1A".
   02 FILLER                           PIC X(4) VALUE "%1B" & X"1B".
   02 FILLER                           PIC X(4) VALUE "%1C" & X"1C".
   02 FILLER                           PIC X(4) VALUE "%1D" & X"1D".
   02 FILLER                           PIC X(4) VALUE "%1E" & X"1E".
   02 FILLER                           PIC X(4) VALUE "%1F" & X"1F".

   02 FILLER                           PIC X(4) VALUE "%20" & X"20".
   02 FILLER                           PIC X(4) VALUE "%21" & X"21".
   02 FILLER                           PIC X(4) VALUE "%22" & X"22".
   02 FILLER                           PIC X(4) VALUE "%23" & X"23".
   02 FILLER                           PIC X(4) VALUE "%24" & X"24".
   02 FILLER                           PIC X(4) VALUE "%25" & X"25".
   02 FILLER                           PIC X(4) VALUE "%26" & X"26".
   02 FILLER                           PIC X(4) VALUE "%27" & X"27".
   02 FILLER                           PIC X(4) VALUE "%28" & X"28".
   02 FILLER                           PIC X(4) VALUE "%29" & X"29".
   02 FILLER                           PIC X(4) VALUE "%2A" & X"2A".
   02 FILLER                           PIC X(4) VALUE "%2B" & X"2B".
   02 FILLER                           PIC X(4) VALUE "%2C" & X"2C".
   02 FILLER                           PIC X(4) VALUE "%2D" & X"2D".
   02 FILLER                           PIC X(4) VALUE "%2E" & X"2E".
   02 FILLER                           PIC X(4) VALUE "%2F" & X"2F".

   02 FILLER                           PIC X(4) VALUE "%30" & X"30".
   02 FILLER                           PIC X(4) VALUE "%31" & X"31".
   02 FILLER                           PIC X(4) VALUE "%32" & X"32".
   02 FILLER                           PIC X(4) VALUE "%33" & X"33".
   02 FILLER                           PIC X(4) VALUE "%34" & X"34".
   02 FILLER                           PIC X(4) VALUE "%35" & X"35".
   02 FILLER                           PIC X(4) VALUE "%36" & X"36".
   02 FILLER                           PIC X(4) VALUE "%37" & X"37".
   02 FILLER                           PIC X(4) VALUE "%38" & X"38".
   02 FILLER                           PIC X(4) VALUE "%39" & X"39".
   02 FILLER                           PIC X(4) VALUE "%3A" & X"3A".
   02 FILLER                           PIC X(4) VALUE "%3B" & X"3B".
   02 FILLER                           PIC X(4) VALUE "%3C" & X"3C".
   02 FILLER                           PIC X(4) VALUE "%3D" & X"3D".
   02 FILLER                           PIC X(4) VALUE "%3E" & X"3E".
   02 FILLER                           PIC X(4) VALUE "%3F" & X"3F".

   02 FILLER                           PIC X(4) VALUE "%40" & X"40".
   02 FILLER                           PIC X(4) VALUE "%41" & X"41".
   02 FILLER                           PIC X(4) VALUE "%42" & X"42".
   02 FILLER                           PIC X(4) VALUE "%43" & X"43".
   02 FILLER                           PIC X(4) VALUE "%44" & X"44".
   02 FILLER                           PIC X(4) VALUE "%45" & X"45".
   02 FILLER                           PIC X(4) VALUE "%46" & X"46".
   02 FILLER                           PIC X(4) VALUE "%47" & X"47".
   02 FILLER                           PIC X(4) VALUE "%48" & X"48".
   02 FILLER                           PIC X(4) VALUE "%49" & X"49".
   02 FILLER                           PIC X(4) VALUE "%4A" & X"4A".
   02 FILLER                           PIC X(4) VALUE "%4B" & X"4B".
   02 FILLER                           PIC X(4) VALUE "%4C" & X"4C".
   02 FILLER                           PIC X(4) VALUE "%4D" & X"4D".
   02 FILLER                           PIC X(4) VALUE "%4E" & X"4E".
   02 FILLER                           PIC X(4) VALUE "%4F" & X"4F".

   02 FILLER                           PIC X(4) VALUE "%50" & X"50".
   02 FILLER                           PIC X(4) VALUE "%51" & X"51".
   02 FILLER                           PIC X(4) VALUE "%52" & X"52".
   02 FILLER                           PIC X(4) VALUE "%53" & X"53".
   02 FILLER                           PIC X(4) VALUE "%54" & X"54".
   02 FILLER                           PIC X(4) VALUE "%55" & X"55".
   02 FILLER                           PIC X(4) VALUE "%56" & X"56".
   02 FILLER                           PIC X(4) VALUE "%57" & X"57".
   02 FILLER                           PIC X(4) VALUE "%58" & X"58".
   02 FILLER                           PIC X(4) VALUE "%59" & X"59".
   02 FILLER                           PIC X(4) VALUE "%5A" & X"5A".
   02 FILLER                           PIC X(4) VALUE "%5B" & X"5B".
   02 FILLER                           PIC X(4) VALUE "%5C" & X"5C".
   02 FILLER                           PIC X(4) VALUE "%5D" & X"5D".
   02 FILLER                           PIC X(4) VALUE "%5E" & X"5E".
   02 FILLER                           PIC X(4) VALUE "%5F" & X"5F".

   02 FILLER                           PIC X(4) VALUE "%60" & X"60".
   02 FILLER                           PIC X(4) VALUE "%61" & X"61".
   02 FILLER                           PIC X(4) VALUE "%62" & X"62".
   02 FILLER                           PIC X(4) VALUE "%63" & X"63".
   02 FILLER                           PIC X(4) VALUE "%64" & X"64".
   02 FILLER                           PIC X(4) VALUE "%65" & X"65".
   02 FILLER                           PIC X(4) VALUE "%66" & X"66".
   02 FILLER                           PIC X(4) VALUE "%67" & X"67".
   02 FILLER                           PIC X(4) VALUE "%68" & X"68".
   02 FILLER                           PIC X(4) VALUE "%69" & X"69".
   02 FILLER                           PIC X(4) VALUE "%6A" & X"6A".
   02 FILLER                           PIC X(4) VALUE "%6B" & X"6B".
   02 FILLER                           PIC X(4) VALUE "%6C" & X"6C".
   02 FILLER                           PIC X(4) VALUE "%6D" & X"6D".
   02 FILLER                           PIC X(4) VALUE "%6E" & X"6E".
   02 FILLER                           PIC X(4) VALUE "%6F" & X"6F".

   02 FILLER                           PIC X(4) VALUE "%70" & X"70".
   02 FILLER                           PIC X(4) VALUE "%71" & X"71".
   02 FILLER                           PIC X(4) VALUE "%72" & X"72".
   02 FILLER                           PIC X(4) VALUE "%73" & X"73".
   02 FILLER                           PIC X(4) VALUE "%74" & X"74".
   02 FILLER                           PIC X(4) VALUE "%75" & X"75".
   02 FILLER                           PIC X(4) VALUE "%76" & X"76".
   02 FILLER                           PIC X(4) VALUE "%77" & X"77".
   02 FILLER                           PIC X(4) VALUE "%78" & X"78".
   02 FILLER                           PIC X(4) VALUE "%79" & X"79".
   02 FILLER                           PIC X(4) VALUE "%7A" & X"7A".
   02 FILLER                           PIC X(4) VALUE "%7B" & X"7B".
   02 FILLER                           PIC X(4) VALUE "%7C" & X"7C".
   02 FILLER                           PIC X(4) VALUE "%7D" & X"7D".
   02 FILLER                           PIC X(4) VALUE "%7E" & X"7E".
   02 FILLER                           PIC X(4) VALUE "%7F" & X"7F".

   02 FILLER                           PIC X(4) VALUE "%80" & X"80".
   02 FILLER                           PIC X(4) VALUE "%81" & X"81".
   02 FILLER                           PIC X(4) VALUE "%82" & X"82".
   02 FILLER                           PIC X(4) VALUE "%83" & X"83".
   02 FILLER                           PIC X(4) VALUE "%84" & X"84".
   02 FILLER                           PIC X(4) VALUE "%85" & X"85".
   02 FILLER                           PIC X(4) VALUE "%86" & X"86".
   02 FILLER                           PIC X(4) VALUE "%87" & X"87".
   02 FILLER                           PIC X(4) VALUE "%88" & X"88".
   02 FILLER                           PIC X(4) VALUE "%89" & X"89".
   02 FILLER                           PIC X(4) VALUE "%8A" & X"8A".
   02 FILLER                           PIC X(4) VALUE "%8B" & X"8B".
   02 FILLER                           PIC X(4) VALUE "%8C" & X"8C".
   02 FILLER                           PIC X(4) VALUE "%8D" & X"8D".
   02 FILLER                           PIC X(4) VALUE "%8E" & X"8E".
   02 FILLER                           PIC X(4) VALUE "%8F" & X"8F".

   02 FILLER                           PIC X(4) VALUE "%90" & X"90".
   02 FILLER                           PIC X(4) VALUE "%91" & X"91".
   02 FILLER                           PIC X(4) VALUE "%92" & X"92".
   02 FILLER                           PIC X(4) VALUE "%93" & X"93".
   02 FILLER                           PIC X(4) VALUE "%94" & X"94".
   02 FILLER                           PIC X(4) VALUE "%95" & X"95".
   02 FILLER                           PIC X(4) VALUE "%96" & X"96".
   02 FILLER                           PIC X(4) VALUE "%97" & X"97".
   02 FILLER                           PIC X(4) VALUE "%98" & X"98".
   02 FILLER                           PIC X(4) VALUE "%99" & X"99".
   02 FILLER                           PIC X(4) VALUE "%9A" & X"9A".
   02 FILLER                           PIC X(4) VALUE "%9B" & X"9B".
   02 FILLER                           PIC X(4) VALUE "%9C" & X"9C".
   02 FILLER                           PIC X(4) VALUE "%9D" & X"9D".
   02 FILLER                           PIC X(4) VALUE "%9E" & X"9E".
   02 FILLER                           PIC X(4) VALUE "%9F" & X"9F".

   02 FILLER                           PIC X(4) VALUE "%A0" & X"A0".
   02 FILLER                           PIC X(4) VALUE "%A1" & X"A1".
   02 FILLER                           PIC X(4) VALUE "%A2" & X"A2".
   02 FILLER                           PIC X(4) VALUE "%A3" & X"A3".
   02 FILLER                           PIC X(4) VALUE "%A4" & X"A4".
   02 FILLER                           PIC X(4) VALUE "%A5" & X"A5".
   02 FILLER                           PIC X(4) VALUE "%A6" & X"A6".
   02 FILLER                           PIC X(4) VALUE "%A7" & X"A7".
   02 FILLER                           PIC X(4) VALUE "%A8" & X"A8".
   02 FILLER                           PIC X(4) VALUE "%A9" & X"A9".
   02 FILLER                           PIC X(4) VALUE "%AA" & X"AA".
   02 FILLER                           PIC X(4) VALUE "%AB" & X"AB".
   02 FILLER                           PIC X(4) VALUE "%AC" & X"AC".
   02 FILLER                           PIC X(4) VALUE "%AD" & X"AD".
   02 FILLER                           PIC X(4) VALUE "%AE" & X"AE".
   02 FILLER                           PIC X(4) VALUE "%AF" & X"AF".

   02 FILLER                           PIC X(4) VALUE "%B0" & X"B0".
   02 FILLER                           PIC X(4) VALUE "%B1" & X"B1".
   02 FILLER                           PIC X(4) VALUE "%B2" & X"B2".
   02 FILLER                           PIC X(4) VALUE "%B3" & X"B3".
   02 FILLER                           PIC X(4) VALUE "%B4" & X"B4".
   02 FILLER                           PIC X(4) VALUE "%B5" & X"B5".
   02 FILLER                           PIC X(4) VALUE "%B6" & X"B6".
   02 FILLER                           PIC X(4) VALUE "%B7" & X"B7".
   02 FILLER                           PIC X(4) VALUE "%B8" & X"B8".
   02 FILLER                           PIC X(4) VALUE "%B9" & X"B9".
   02 FILLER                           PIC X(4) VALUE "%BA" & X"BA".
   02 FILLER                           PIC X(4) VALUE "%BB" & X"BB".
   02 FILLER                           PIC X(4) VALUE "%BC" & X"BC".
   02 FILLER                           PIC X(4) VALUE "%BD" & X"BD".
   02 FILLER                           PIC X(4) VALUE "%BE" & X"BE".
   02 FILLER                           PIC X(4) VALUE "%BF" & X"BF".

   02 FILLER                           PIC X(4) VALUE "%C0" & X"C0".
   02 FILLER                           PIC X(4) VALUE "%C1" & X"C1".
   02 FILLER                           PIC X(4) VALUE "%C2" & X"C2".
   02 FILLER                           PIC X(4) VALUE "%C3" & X"C3".
   02 FILLER                           PIC X(4) VALUE "%C4" & X"C4".
   02 FILLER                           PIC X(4) VALUE "%C5" & X"C5".
   02 FILLER                           PIC X(4) VALUE "%C6" & X"C6".
   02 FILLER                           PIC X(4) VALUE "%C7" & X"C7".
   02 FILLER                           PIC X(4) VALUE "%C8" & X"C8".
   02 FILLER                           PIC X(4) VALUE "%C9" & X"C9".
   02 FILLER                           PIC X(4) VALUE "%CA" & X"CA".
   02 FILLER                           PIC X(4) VALUE "%CB" & X"CB".
   02 FILLER                           PIC X(4) VALUE "%CC" & X"CC".
   02 FILLER                           PIC X(4) VALUE "%CD" & X"CD".
   02 FILLER                           PIC X(4) VALUE "%CE" & X"CE".
   02 FILLER                           PIC X(4) VALUE "%CF" & X"CF".

   02 FILLER                           PIC X(4) VALUE "%D0" & X"D0".
   02 FILLER                           PIC X(4) VALUE "%D1" & X"D1".
   02 FILLER                           PIC X(4) VALUE "%D2" & X"D2".
   02 FILLER                           PIC X(4) VALUE "%D3" & X"D3".
   02 FILLER                           PIC X(4) VALUE "%D4" & X"D4".
   02 FILLER                           PIC X(4) VALUE "%D5" & X"D5".
   02 FILLER                           PIC X(4) VALUE "%D6" & X"D6".
   02 FILLER                           PIC X(4) VALUE "%D7" & X"D7".
   02 FILLER                           PIC X(4) VALUE "%D8" & X"D8".
   02 FILLER                           PIC X(4) VALUE "%D9" & X"D9".
   02 FILLER                           PIC X(4) VALUE "%DA" & X"DA".
   02 FILLER                           PIC X(4) VALUE "%DB" & X"DB".
   02 FILLER                           PIC X(4) VALUE "%DC" & X"DC".
   02 FILLER                           PIC X(4) VALUE "%DD" & X"DD".
   02 FILLER                           PIC X(4) VALUE "%DE" & X"DE".
   02 FILLER                           PIC X(4) VALUE "%DF" & X"DF".

   02 FILLER                           PIC X(4) VALUE "%E0" & X"E0".
   02 FILLER                           PIC X(4) VALUE "%E1" & X"E1".
   02 FILLER                           PIC X(4) VALUE "%E2" & X"E2".
   02 FILLER                           PIC X(4) VALUE "%E3" & X"E3".
   02 FILLER                           PIC X(4) VALUE "%E4" & X"E4".
   02 FILLER                           PIC X(4) VALUE "%E5" & X"E5".
   02 FILLER                           PIC X(4) VALUE "%E6" & X"E6".
   02 FILLER                           PIC X(4) VALUE "%E7" & X"E7".
   02 FILLER                           PIC X(4) VALUE "%E8" & X"E8".
   02 FILLER                           PIC X(4) VALUE "%E9" & X"E9".
   02 FILLER                           PIC X(4) VALUE "%EA" & X"EA".
   02 FILLER                           PIC X(4) VALUE "%EB" & X"EB".
   02 FILLER                           PIC X(4) VALUE "%EC" & X"EC".
   02 FILLER                           PIC X(4) VALUE "%ED" & X"ED".
   02 FILLER                           PIC X(4) VALUE "%EE" & X"EE".
   02 FILLER                           PIC X(4) VALUE "%EF" & X"EF".

   02 FILLER                           PIC X(4) VALUE "%F0" & X"F0".
   02 FILLER                           PIC X(4) VALUE "%F1" & X"F1".
   02 FILLER                           PIC X(4) VALUE "%F2" & X"F2".
   02 FILLER                           PIC X(4) VALUE "%F3" & X"F3".
   02 FILLER                           PIC X(4) VALUE "%F4" & X"F4".
   02 FILLER                           PIC X(4) VALUE "%F5" & X"F5".
   02 FILLER                           PIC X(4) VALUE "%F6" & X"F6".
   02 FILLER                           PIC X(4) VALUE "%F7" & X"F7".
   02 FILLER                           PIC X(4) VALUE "%F8" & X"F8".
   02 FILLER                           PIC X(4) VALUE "%F9" & X"F9".
   02 FILLER                           PIC X(4) VALUE "%FA" & X"FA".
   02 FILLER                           PIC X(4) VALUE "%FB" & X"FB".
   02 FILLER                           PIC X(4) VALUE "%FC" & X"FC".
   02 FILLER                           PIC X(4) VALUE "%FD" & X"FD".
   02 FILLER                           PIC X(4) VALUE "%FE" & X"FE".
   02 FILLER                           PIC X(4) VALUE "%FF" & X"FF".

 01 WS-DECODE-TAB REDEFINES WS-DECODE-TABLE.
   02 WS-DECODE-TAB-LINE               OCCURS 1 TO 256 TIMES
                                       ASCENDING KEY IS WS-DECODE-TAB-UTF8-STR
                                       INDEXED BY WS-DECODE-TAB-INDEX.
     03 WS-DECODE-TAB-UTF8-STR         PIC X(3).
     03 WS-DECODE-TAB-UTF8-VAL         PIC X(1).

 LINKAGE SECTION.
 01 LNK-UTF8-STR                       PIC X(3).
 01 LNK-UTF8-VAL                       PIC X(1).

 PROCEDURE DIVISION USING     BY VALUE LNK-UTF8-STR
                    RETURNING          LNK-UTF8-VAL.

 COB2CGI-DECODE-MAIN SECTION.

    SET WS-DECODE-TAB-INDEX TO 1
    SEARCH ALL WS-DECODE-TAB-LINE
       AT END
          *> not found --> gives space back
          MOVE X"20"
            TO LNK-UTF8-VAL

       WHEN WS-DECODE-TAB-UTF8-STR(WS-DECODE-TAB-INDEX) = LNK-UTF8-STR
          MOVE WS-DECODE-TAB-UTF8-VAL(WS-DECODE-TAB-INDEX)
            TO LNK-UTF8-VAL
    END-SEARCH

    GOBACK

    .
 COB2CGI-DECODE-MAIN-EX.
    EXIT.
 END FUNCTION COB2CGI-DECODE.

*>******************************************************************************
*>  COB2CGI-NUM2HEX.cob is free software: you can redistribute it and/or
*>  modify it under the terms of the GNU Lesser General Public License as
*>  published by the Free Software Foundation, either version 3 of the License,
*>  or (at your option) any later version.
*>
*>  COB2CGI-NUM2HEX.cob is distributed in the hope that it will be useful,
*>  but WITHOUT ANY WARRANTY; without even the implied warranty of
*>  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
*>  See the GNU Lesser General Public License for more details.
*>
*>  You should have received a copy of the GNU Lesser General Public License
*>  along with COB2CGI-NUM2HEX.cob.
*>  If not, see <http://www.gnu.org/licenses/>.
*>******************************************************************************

*>******************************************************************************
*> Function:     COB2CGI-NUM2HEX.cob
*>
*> Purpose:      Convert a number in hexa
*>
*> Author:       Laszlo Erdos - https://www.facebook.com/wortfee
*>
*> Date-Written: 2015.08.21
*>
*> Usage:        To use this function, simply CALL it as follows:
*>               COB2CGI-NUM2HEX(<number>)
*>               Fields in COB2CGI-NUM2HEX linkage:
*>                 <number>      - input
*>                 <hexa string> - output
*>******************************************************************************

 IDENTIFICATION DIVISION.
 FUNCTION-ID. COB2CGI-NUM2HEX.
 AUTHOR.      Laszlo Erdos.

 ENVIRONMENT DIVISION.
 DATA DIVISION.
 WORKING-STORAGE SECTION.

 01 COB2CGI-NUM2HEX-IN                     PIC 9(2) COMP-5.
 01 COB2CGI-NUM2HEX-OUT                    PIC X(2).
 01 COB2CGI-NUM2HEX-QUOTIENT               PIC 9(2) COMP-5.
 01 COB2CGI-NUM2HEX-REMAINDER              PIC 9(2) COMP-5.
 01 COB2CGI-HEX-CHAR                       PIC X(16)
                                           VALUE "0123456789ABCDEF".
 01 COB2CGI-IND-1                          PIC 9(2) COMP-5.

 LINKAGE SECTION.
 01 LNK-NUM-DATA                          PIC X(1).
 01 LNK-NUM-DATA-R REDEFINES LNK-NUM-DATA PIC 9(2) COMP-5.
 01 LNK-HEX-DATA                          PIC X(2).

 PROCEDURE DIVISION USING     BY VALUE LNK-NUM-DATA
                    RETURNING          LNK-HEX-DATA.

 COB2CGI-NUM2HEX-MAIN SECTION.

    INITIALIZE LNK-HEX-DATA

    MOVE LNK-NUM-DATA-R TO COB2CGI-NUM2HEX-IN

    INITIALIZE COB2CGI-NUM2HEX-OUT

    PERFORM VARYING COB2CGI-IND-1 FROM 2 BY -1
            UNTIL   COB2CGI-IND-1 < 1

       DIVIDE COB2CGI-NUM2HEX-IN BY 16
          GIVING    COB2CGI-NUM2HEX-QUOTIENT
          REMAINDER COB2CGI-NUM2HEX-REMAINDER
       END-DIVIDE

       ADD 1 TO COB2CGI-NUM2HEX-REMAINDER

       MOVE COB2CGI-HEX-CHAR(COB2CGI-NUM2HEX-REMAINDER:1)
         TO COB2CGI-NUM2HEX-OUT(COB2CGI-IND-1:1)

       MOVE COB2CGI-NUM2HEX-QUOTIENT
         TO COB2CGI-NUM2HEX-IN
    END-PERFORM

    MOVE COB2CGI-NUM2HEX-OUT  TO LNK-HEX-DATA

    GOBACK

    .
 COB2CGI-NUM2HEX-MAIN-EX.
    EXIT.
 END FUNCTION COB2CGI-NUM2HEX.

cgibin=/srv/www/cgi-bin
htdocs=/srv/www/htdocs

all:    cgiform.exe

# compile
cgiform.exe:    cgiform.cob
        cobc -x -free cgiform.cob -o cgiform.exe
        cp cgiform.exe $(cgibin)/cgiform
        cp cgiform.html $(htdocs)/cgiform.html

clean:
        rm cgiform.exe
        rm $(cgibin)/cgiform
        rm $(htdocs)/cgiform.html

# Before you start Apache, you have to install cygserver
# as a Windows Service. Check this file: /bin/cygserver-config.
#
# Important File Locations
# - httpd.conf:
# c:/cygwin/etc/apache2/httpd.conf
#
# - HTML files:
# c:/cygwin/srv/www/htdocs/index.html
#
# Verifying that Apache is running
# In a browser try the following URL.
# http://localhost
# You should be happy to see a page that says "It Works"
#
# Issues:
# - Installed as Service but doesn't start.
#
#   Check that you installed Cygwin for All Users.
#   Just run Cygwin's setup program again and click "All Users"
#   and you should be all set.

# Running Apache2
/usr/sbin/apachectl2 start

# Stop Apache2
/usr/sbin/apachectl2 stop

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* =====================
      *><* ocdoc.cob usage guide
      *><* =====================
      *><* .. sidebar:: Table of Contents
      *><*
      *><*     .. contents:: :local:
      *><*
      *><* :Author:    Brian Tiffin
      *><* :Date:      30-Sep-2008
      *><* :Rights:    Copyright (c) 2008, Brian Tiffin.
      *><*             GNU FDL License.
      *><* :Purpose:   Extract usage document lines from COBOL sources.
      *><*             Using GnuCOBOL 1.1pr.  GnuCOBOL is tasty.
      *><* :Tectonics: cobc -x ocdoc.cob
      *><* :Docgen:    $ ./ocdoc ocdoc.cob ocdoc.rst ocdoc.html skin.css
      *> ***************************************************************
      *><*
      *><* ------------
      *><* Command line
      *><* ------------
      *><* *ocdoc* runs in two forms.
      *><*
      *><* Without arguments, *ocdoc* will act as a pipe filter.
      *><* Reading from standard in and writing the extract to standard
      *><+  out.
      *><*
      *><* The *ocdoc* command also takes an input file, an extract
      *><+  filename, an optional result file (with optional
      *><+  stylesheet) and a verbosity option *-v* or a
      *><+  special *-fixed* flag (to force skipping sequence numbers).
      *><* If a result file is given, ocdoc will automatically
      *><* run an *rst2html* command using the SYSTEM service.
      *><*
      *><* Due to an overly simplistic argument handler, you can only
      *><+  turn on verbosity or -fixed when using all four filenames.
      *><*
      *><* Examples::
      *><*
      *><*   $ cat ocdoc.cob | ocdoc >ocdoc.rst
      *><*   $ ./ocdoc ocdoc.cob ocdoc.rst
      *><*   $ ./ocdoc ocdoc.cob ocdoc.rst
      *><+  ocdoc.html skin.css -fixed
      *><*   ...
      *><*   Input  : ocdoc.cob
      *><*   Output : ocdoc.rst
      *><*   Command: rst2html --stylesheet=skin.css
      *><+  ocdoc.rst ocdoc.html
      *><*
      *><* -----------------
      *><* What is extracted
      *><* -----------------
      *><* - Lines that begin with \*><\* *ignoring spaces*, are
      *><+  extracted.
      *><*
      *><* - Lines that begin with \*><+ are appended to the
      *><+  previous output line.  As lines are trimmed of trailing
      *><+  spaces, and *ocdoc* removes the space following the
      *><+  extract triggers, you may need two spaces after an
      *><+  ocdoc append.
      *><*
      *><* - Lines that begin with \*><[ begin a here document
      *><+  with lines that follow extracted as is.
      *><*
      *><* - Lines that begin with \*><] close a here document.
      *><+  Here document start and end lines are excluded from the
      *><+  extract.
      *><*
      *><* -----------
      *><* Source code
      *><* -----------
      *><* `Download ocdoc.cob
      *><+  <http://opencobol.add1tocobol.com/ocdoc.cob>`_
      *><* `See ocdocseq.cob
      *><+  <http://opencobol.add1tocobol.com/ocdocseq.html>`_
      *><*
      *><! This is not extracted. Reminder of how to include source
      *><! .. include:: ocdoc.cob
      *><!    :literal:
      *><*
      *><* -----------------------
      *><* identification division
      *><* -----------------------
      *><*
      *><* ::
      *><*
      *><[
       identification division.
       program-id. OCDOC.

       environment division.
       input-output section.
       file-control.
           select standard-input assign to KEYBOARD.
           select standard-output assign to DISPLAY.

           select source-input
           assign to source-name
           organization is line sequential
           .
           select doc-output
           assign to doc-name
           organization is line sequential
           .
      *><]
      *><*
      *><* -------------
      *><* data division
      *><* -------------
      *><*
      *><* ::
      *><*
      *><[
       data division.
       file section.
       fd standard-input.
          01 stdin-record      pic x(256).
       fd standard-output.
          01 stdout-record     pic x(256).

       fd source-input.
          01 source-record     pic x(256).
       fd doc-output.
          01 doc-record        pic x(256).

       working-storage section.
       01 arguments            pic x(256).
       01 source-name          pic x(256).
       01 doc-name             pic x(256).
       01 result-name          pic x(256).
       01 style-name           pic x(256).
       01 verbosity            pic x(9).
          88 verbose           values "-v" "--v" "-verbose" "--verbose".
          88 skipseqnum        values "-fix" "-fixed" "--fix" "--fixed".
       01 usagehelp            pic x(6).
          88 helping           values "-h" "--h" "-help" "--help".
       01 filter-flag          pic x value low-value.
          88 filtering         value high-value.

       01 line-count           usage binary-long.
       01 line-display         pic z(8)9.

      *><]
      *><*
      *><* Note the conditional test for end of here doc
      *><*
      *><* ::
      *><*
      *><[
       01 trimmed              pic x(256).
          88 herestart         value "*><[".
          88 hereend           value "*><]".

       01 hereflag             pic x value low-value.
          88 heredoc           value high-value.
          88 herenone          value low-value.

      *><]
      *><*
      *><* Note the here-record adds an ocdoc extract to lines that
      *><+  follow.
      *><*
      *><* ::
      *><*
      *><[
       01 here-record.
          02 filler            pic x(5) value "*><* ".
          02 here-data         pic x(251).

       01 seq-record.
          02 filler            pic x(7) value "       ".
          02 seq-data          pic x(249).

       01 doc-buffer           pic x(256).
       01 buffer-offset        pic 999 usage comp-5 value 1.
       01 buffer-flag          pic x value low-value.
          88 buffer-empty      value low-value.
          88 buffered-output   value high-value.

       01 counter              pic 999 usage comp-5.
       01 len-of-comment       pic 999 usage comp-5.

       01 first-part           pic x(8).
          88 special           values "*><*" "*><+".
          88 autodoc           value "*><*".
          88 autoappend        value "*><+".

       01 rst-command          pic x(256).
       01 result               usage binary-long.
      *><]
      *><*
      *><* ------------------
      *><* procedure division
      *><* ------------------
      *><*
      *><* ::
      *><*
      *><[
      *> ***************************************************************
       procedure division.

      *><]
      *><*
      *><* Accept command line arguments.  See if help requested.
      *><*
      *><* ::
      *><*
      *><[
       accept arguments from command-line end-accept

       move arguments to usagehelp
       if helping
           display
               "$ ./ocdoc source markover [output [skin [--fixed]]]"
           end-display
           display "$ ./ocdoc" end-display
           display
               "    without arguments extracts stdin to stdout"
           end-display
           goback
       end-if

      *><]
      *><*
      *><* Either run as filter or open given files.  Two filenames
      *><+  will generate an extract.  Three will run the extract
      *><+  through *rst2html* using an optional fourth filename
      *><+  as a stylesheet.
      *><*
      *><* ::
      *><*
      *><[
      *> Determine if this is running as a filter
       if arguments not equal spaces
           unstring arguments delimited by all spaces
               into source-name doc-name
                    result-name style-name
                    verbosity
           end-unstring

           open input source-input
           open output doc-output
       else
           set filtering to true

           open input standard-input
           open output standard-output
       end-if

      *><]
      *><*
      *><* Initialize the output buffer, and line count.
      *><*
      *><* ::
      *><*
      *><[
       set buffer-empty to true
       move 1 to buffer-offset
       move spaces to doc-record
       move 0 to line-count

      *><]
      *><*
      *><* The read is either from file or stdin.  Start with the
      *><+  first record.
      *><*
      *><* ::
      *><*
      *><[
      *> filtering requires different reader loop
       if filtering
           read standard-input
               at end move high-values to stdin-record
           end-read
           move stdin-record to source-record
       else
           read source-input
               at end move high-values to source-record
           end-read
       end-if

      *><]
      *><*
      *><* The main loop starts here, having done a pre-read to start
      *><+  things off.
      *><*
      *><* ::
      *><*
      *><[
       perform until source-record = high-values
           add 1 to line-count

      *><]
      *><*
      *><* Small wrinkle if processing fixed form with sequence numbers,
      *><+  as the heredoc end marker needs to be recognized
      *><+  but we still want the sequence numbers in the heredoc.
      *><*
      *><* So files processed --fixed play some data shuffling games.
      *><*
      *><* ::
      *><*
      *><[
           if skipseqnum
               if heredoc
                   move source-record(7 : 248) to trimmed
                   move source-record to seq-data
                   move seq-record to source-record
               else
                   move source-record(7 : 248) to source-record
                   move source-record to trimmed
               end-if
           else
               move function trim(source-record leading) to trimmed
           end-if

      *><]
      *><*
      *><* First to check for here doc start and end, setting flag
      *><+  if trimmed conditional the heredoc start or heredoc end
      *><+  strings.
      *><*
      *><* ::
      *><*
      *><[
           if herestart
               set heredoc to true
           end-if

           if hereend
               set herenone to true
           end-if

      *><]
      *><*
      *><* Inside the loop, we skip over heredoc entries.
      *><+  If it is normal, than check for heredoc and include
      *><+  source lines that follow, by prepending the extract tag
      *><*
      *><* ::
      *><*
      *><[
           if (not herestart) and (not hereend)
               if heredoc
                   move source-record to here-data
                   move here-record to trimmed
               end-if

      *><]
      *><*
      *><* Unstring the line, looking for special tags in the first
      *><+  part.
      *><*
      *><* ::
      *><*
      *><[
               unstring trimmed delimited by all spaces
                   into first-part
                       count in counter
               end-unstring

      *><]
      *><*
      *><* If special, we either buffer or append to buffer
      *><*
      *><* ::
      *><*
      *><[
               evaluate true when special
                   if autoappend and buffer-empty
                       move spaces to doc-record
                       move 1 to buffer-offset
                   end-if

                   if autodoc and buffered-output
                       if filtering
                           move doc-record to stdout-record
                           write stdout-record end-write
                       else
                           write doc-record end-write
                       end-if
                       if verbose
                           display
                               function trim(doc-record trailing)
                           end-display
                       end-if
                       move spaces to doc-record
                       set buffer-empty to true
                       move 1 to buffer-offset
                   end-if

      *><]
      *><*
      *><* Skip over where the tag was found plus an extra space.
      *><* Adding 2 skips over the assumed space after a special tag
      *><*
      *><* ::
      *><*
      *><[
                   add 2 to counter
                   compute len-of-comment =
                       function length(trimmed) - counter
                   end-compute

                   if len-of-comment > 0
                       move trimmed(counter : len-of-comment)
                           to doc-buffer
                   else
                       move spaces to doc-buffer
                   end-if

      *><]
      *><*
      *><* Buffer the line, either to position 1 or appending to last.
      *><*
      *><* ::
      *><*
      *><[
                   string
                       function trim(doc-buffer trailing)
                           delimited by size
                       into doc-record
                       with pointer buffer-offset
                       on overflow
                           move line-count to line-display
                           display
                               "*** truncation *** reading line "
                               line-display
                           end-display
                   end-string
                   set buffered-output to true
               end-evaluate
           end-if

      *><]
      *><*
      *><* Again, we either read the next record from file or stdin.
      *><*
      *><* ::
      *><*
      *><[
           if filtering
               read standard-input
                   at end move high-values to stdin-record
               end-read
               move stdin-record to source-record
           else
               read source-input
                   at end move high-values to source-record
               end-read
           end-if
       end-perform

      *><]
      *><*
      *><* We may or may not end up with buffered data
      *><*
      *><* ::
      *><*
      *><[
       if buffered-output
           set buffer-empty to true
           move 1 to buffer-offset
           if filtering
               move doc-record to stdout-record
               write stdout-record end-write
           else
               write doc-record end-write
           end-if
           if verbose
                display
                   function trim(doc-record trailing)
                end-display
           end-if
           move spaces to doc-record
       end-if

      *><]
      *><*
      *><* Close the GnuCOBOL files
      *><*
      *><* ::
      *><*
      *><[
       if filtering
           close standard-output
           close standard-input
       else
           close doc-output
           close source-input
       end-if

       if verbose
           display "Input  : " function trim(source-name) end-display
           display "Output : " function trim(doc-name) end-display
       end-if

      *><]
      *><*
      *><* If we have a result file, use the SYSTEM service to
      *><+  generate an HTML file, possibly with stylesheet.
      *><*
      *><* ::
      *><*
      *><[
      *> pass the extract through a markover, in this case ReST
       move spaces to rst-command
       if result-name not equal spaces
           if style-name equal spaces
               string
                   "rst2html " delimited by size
                   doc-name delimited by space
                   " " delimited by size
                   result-name delimited by space
                   into rst-command
               end-string
           else
               string
                   "rst2html --stylesheet=" delimited by size
                   style-name delimited by space
                   " " delimited by size
                   doc-name delimited by space
                   " " delimited by size
                   result-name delimited by space
                   into rst-command
               end-string
           end-if

           if verbose
               display
                   "Command: "
                   function trim(rst-command trailing)
               end-display
           end-if

           call "SYSTEM"
               using rst-command
               returning result
           end-call

           if result not equal zero
               display "HTML generate failed: " result end-display
           end-if
       end-if

      *><]
      *><*
      *><* And before you know it, we are done.
      *><*
      *><* ::
      *><*
      *><[
       goback.

       end program OCDOC.
      *><]
      *><*
      *><* Don't forget to visit http://opencobol.org
      *><*
      *><* Cheers
      *><*
      *><* *Last edit:* 03-Oct-2008

$ cobc -x ocdoc.cob
$ ./ocdoc ocdoc.cob ocdoc.rst ocdoc.html skin.css

GCobol >>SOURCE FORMAT IS FIXED
      *-----------------------------------------------------------------
      * Authors:   Brian Tiffin, Asger Kjelstrup, human
      * Date:      27-Jan-2010
      * Purpose:   Hex Dump display
      * Tectonics: cobc -c CBL_OC_DUMP.cob
      *     Usage: cobc -x program.cob -o CBL_OC_DUMP
      *            export OC_DUMP_EXT=1 for explanatory text on dumps
      *            (memory address and dump length)
      *            export OC_DUMP_EXT=Y for extended explanatory text
      *            (architecture   and endian-order)
      *-----------------------------------------------------------------
       identification division.
       program-id. CBL_OC_DUMP.
      *
       ENVIRONMENT      DIVISION.
       CONFIGURATION    SECTION.
      *
       data division.
       working-storage section.
       77  addr                             usage pointer.
       77  addr2addr                        usage pointer.
       77  counter               pic 999999 usage comp-5.
       77  byline                pic 999    usage comp-5.
       77  offset                pic 999999.
       01  some                  pic 999    usage comp-5.
           88 some-is-printable-iso88591
              values 32 thru 126, 160 thru 255.
           88 some-is-printable-ebcdic
              values 64, 65, 74 thru 80, 90 thru 97,
                     106 thru 111, 121 thru 127, 129 thru 137, 143,
                     145 thru 153, 159, 161 thru 169, 176,
                     186 thru 188, 192 thru 201, 208 thru 217, 224,
                     226 thru 233, 240 thru 249.
       77  high-var              pic 99     usage comp-5.
       77  low-var               pic 99     usage comp-5.
      *
       01  char-set              pic x(06).
           88 is-ascii           value 'ASCII'.
           88 is-ebdic           value 'EBCDIC'.
           88 is-unknown         value '?'.
       01  architecture          pic x(06).
           88 is-32-bit          value '32-bit'.
           88 is-64-bit          value '64-bit'.
       01  endian-order          pic x(10).
           88 is-big-endian-no   value 'Little-Big'.
           88 is-big-endian-yes  value 'Big-Little'.
      *
       77  hex-line              pic x(48).
       77  hex-line-pointer      pic 9(02) value 1.
      *
       77  show                  pic x(16).
       77  dots                  pic x value '.'.
       77  dump-dots             pic x.
      *
       77  hex-digit             pic x(16)  value '0123456789abcdef'.
       01  extended-infos        pic x.
           88 show-extended-infos      values '1', '2', 'Y', 'y'.
           88 show-very-extended-infos values '2', 'Y', 'y'.
      *
       77  len                   pic 999999 usage comp-5.
       77  len-display           pic 999999.
      *
       linkage section.
       01  buffer                pic x       any length.
       77  byte                  pic x.
      * ----------------------------------------------------------------
       procedure division using buffer.
      *
       MAIN SECTION.
       00.
           perform starting-address
      *
           perform varying counter from 0 by 16
                   until   counter  >=   len
              move counter to offset
              move spaces  to hex-line, show
              move '-'     to hex-line (24:01)
              move 1       to hex-line-pointer
              perform varying byline from 1 by 1
                      until   byline  >  16
                 if (counter + byline) > len
                    if byline < 9
                       move space to hex-line (24:01)
                    end-if
                    inspect show (byline:) replacing all spaces by dots
                    exit perform
                 else
                    move buffer (counter + byline : 1) to byte
                    perform calc-hex-value
                    if ((some-is-printable-iso88591 and is-ascii) or
                        (some-is-printable-ebcdic   and is-ebdic)   )
                       move byte to show (byline:1)
                    else
                       move dots to show (byline:1)
                    end-if
                 end-if
              end-perform
              display offset '  ' hex-line '  ' show
              end-display
           end-perform
           display ' '
           end-display
      *
           continue.
       ex. exit program.
      *-----------------------------------------------------------------
       CALC-HEX-VALUE SECTION.
       00.
           subtract 1 from function ord(byte) giving some
           end-subtract
           divide   some by 16 giving high-var remainder low-var
           end-divide
           string hex-digit (high-var + 1:1)
                  hex-digit (low-var  + 1:1)
                  space
                  delimited by size
                  into hex-line
                  with pointer hex-line-pointer
           end-string
      *
           continue.
       ex. exit.
      *-----------------------------------------------------------------
       STARTING-ADDRESS SECTION.
       00.
      * Get the length of the transmitted buffer
           CALL 'C$PARAMSIZE' USING 1
              GIVING len
           END-CALL
      * If wanted, change the dots to something different than points
           accept dump-dots from environment 'OC_DUMP_DOTS'
             not on exception
                 move dump-dots to dots
           end-accept
      *
           perform TEST-ASCII
           perform TEST-ENDIAN
           set addr      to address of buffer
           set addr2addr to address of addr
      *
           if len > 0
      * To show hex-address, reverse if Big-Little Endian
              if is-big-endian-yes
                 set addr2addr up   by LENGTH OF addr
                 set addr2addr down by 1
              end-if
              move 1 to hex-line-pointer
              perform varying byline from 1 by 1
                      until byline > LENGTH OF addr
                 set address of byte to addr2addr
                 perform calc-hex-value
                 if is-big-endian-yes
                    set addr2addr down by 1
                 else
                    set addr2addr up   by 1
                 end-if
              end-perform
           end-if
      *
      * Get and display characteristics and headline
           accept extended-infos from environment 'OC_DUMP_EXT'
           end-accept
           if show-extended-infos
              display ' '
              end-display
              if len > 0
                 end-display
                 display 'Dump of memory beginning at Hex-address: '
                          hex-line (1 : 3 * (byline - 1) )
                 end-display
              end-if
              move len to len-display
              display 'Length of memory dump is: ' len-display
              end-display
              if show-very-extended-infos
                 perform TEST-64bit
                 display 'Program runs in '
                         architecture ' architecture. '
                         'Char-set is '
                         function trim (char-set) '.'
                 end-display
                 display 'Byte order is ' endian-order
                         ' endian.'
                 end-display
              end-if
           end-if
      *
      * Do we have anything to dump?
           if len > 0
      * Ensure that the passed size is not too big
              if len > 999998
                 move 999998 to len, len-display
                 display 'Warning, only the first '
                         len-display  ' Bytes are shown!'
                 end-display
              end-if
              display ' '
              end-display
              display 'Offset  '
                      'HEX-- -- -- -5 -- -- -- -- 10 '
                      '-- -- -- -- 15 -- '
                      '  '
                      'CHARS----1----5-'
              end-display
           else
              display ' '
              end-display
              display 'Nothing to dump.'
              end-display
           end-if
      *
           continue.
       ex. exit.
      *-----------------------------------------------------------------
       TEST-ASCII SECTION.
      *Function: Discover if running Ascii or Ebcdic
       00.
           evaluate space
              when x'20'
                 set  is-ascii   to true
              when x'40'
                 set  is-ebdic   to true
              when other
                 set  is-unknown to true
           end-evaluate
      *
           continue.
       ex. exit.
      *-----------------------------------------------------------------
       TEST-64BIT SECTION.
      *Function: Discover if running 32/64 bit
       00.
      *    Longer pointers in 64-bit architecture
           if function length (addr) <= 4
              set  is-32-bit to true
           else
              set  is-64-bit to true
           end-if
      *
           continue.
       ex. exit.
      *-----------------------------------------------------------------
       TEST-ENDIAN SECTION.
       00.
      *    Number-bytes are shuffled in Big-Little endian
           move 128 to byline
           set address of byte to address of byline
           if function ord(byte) > 0
              set  is-big-endian-yes to true
           else
              set  is-big-endian-no  to true
           end-if
      *
           continue.
       ex. exit.
      *-----------------------------------------------------------------
       end program CBL_OC_DUMP.

Alpha literal Dump

Offs  HEX-- -- -- 5- -- -- -- -- 10 -- -- -- -- 15 -- CHARS----1----5-
0000  61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6f 70 71 abcdefghijklmopq
0016  72                                              r...............

Integer Dump: +0000000123

Offs  HEX-- -- -- 5- -- -- -- -- 10 -- -- -- -- 15 -- CHARS----1----5-
0000  7b 00 00 00                                     {...............

Numeric Literal Dump: 0

Dump of memory beginning at Hex-address: bf 80 fc e4
Program runs in 32-bit architecture. Char-set is ASCII .
Byte order is Big-Little endian.

Offs  HEX-- -- -- 5- -- -- -- -- 10 -- -- -- -- 15 -- CHARS----1----5-
0000  00                                              ................

GCobol >>SOURCE FORMAT IS FIXED
      *-----------------------------------------------------------------
      * Authors:   Brian Tiffin, Asger Kjelstrup, Simon Sobisch
      * Date:      19-Oct-2010
      * Purpose:   Hex Dump display
      * Tectonics: cobc -c CBL_OC_DUMP.cob
      *     Usage: export OC_DUMP_EXT=1 for explanatory text on dumps
      *            (memory address and dump length)
      *            export OC_DUMP_EXT=Y for extended explanatory text
      *            (architecture   and endian-order)
      *-----------------------------------------------------------------
       IDENTIFICATION DIVISION.
       PROGRAM-ID. CBL_OC_DUMP.
      *
       ENVIRONMENT      DIVISION.
       CONFIGURATION    SECTION.
      *
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       77  addr                             usage pointer.
       77  addr2addr                        usage pointer.
       77  counter               pic 999999 usage comp-5.
       77  byline                pic 999    usage comp-5.
       77  offset                pic 999999.
       01  some                  pic 999    usage comp-5.
           88 some-is-printable-iso88591
              values 32 thru 126, 160 thru 255.
           88 some-is-printable-ebcdic
              values 64, 65, 74 thru 80, 90 thru 97,
                     106 thru 111, 121 thru 127, 129 thru 137, 143,
                     145 thru 153, 159, 161 thru 169, 176,
                     186 thru 188, 192 thru 201, 208 thru 217, 224,
                     226 thru 233, 240 thru 249.
       77  high-var              pic 99     usage comp-5.
       77  low-var               pic 99     usage comp-5.
      *
       01  char-set              pic x(06).
           88 is-ascii           value 'ASCII'.
           88 is-ebdic           value 'EBCDIC'.
           88 is-unknown         value '?'.
       01  architecture          pic x(06).
           88 is-32-bit          value '32-bit'.
           88 is-64-bit          value '64-bit'.
       01  endian-order          pic x(10).
           88 is-big-endian-no   value 'Little-Big'.
           88 is-big-endian-yes  value 'Big-Little'.
      *
       77  hex-line              pic x(48).
       77  hex-line-pointer      pic 9(02) value 1.
      *
       77  show                  pic x(16).
       77  dots                  pic x value '.'.
       77  dump-dots             pic x.
      *
       77  hex-digit             pic x(16)  value '0123456789abcdef'.
       01  extended-infos        pic x.
           88 show-extended-infos      values '1', '2', 'Y', 'y'.
           88 show-very-extended-infos values '2', 'Y', 'y'.
      *
       77  len                   pic 999999 usage comp-5.
       77  len-display           pic 999999.
      *
       LINKAGE SECTION.
       01  buffer                pic x       any length.
       77  byte                  pic x.
      *-----------------------------------------------------------------
       PROCEDURE DIVISION USING buffer.
      *
      *MAIN SECTION.
      *00.
           perform starting-address
      *
           perform varying counter from 0 by 16
                   until   counter  >=   len
              move counter to offset
              move spaces  to hex-line, show
              move '-'     to hex-line (24:01)
              move 1       to hex-line-pointer
              perform varying byline from 1 by 1
                      until   byline  >  16
                 if (counter + byline) > len
                    if byline < 9
                       move space to hex-line (24:01)
                    end-if
                    inspect show (byline:) replacing all spaces by dots
                    exit perform
                 else
                    move buffer (counter + byline : 1) to byte
                    perform calc-hex-value
                    if ((some-is-printable-iso88591 and is-ascii) or
                        (some-is-printable-ebcdic   and is-ebdic)   )
                       move byte to show (byline:1)
                    else
                       move dots to show (byline:1)
                    end-if
                 end-if
              end-perform
              display offset '  ' hex-line '  ' show
                      upon SYSERR
              end-display
           end-perform
           display ' '
                   upon SYSERR
           end-display
      *
           exit program.
      *-----------------------------------------------------------------
       CALC-HEX-VALUE SECTION.
      *00.
           subtract 1 from function ord(byte) giving some
           end-subtract
           divide   some by 16 giving high-var remainder low-var
           end-divide
           string hex-digit (high-var + 1:1)
                  hex-digit (low-var  + 1:1)
                  space
                  delimited by size
                  into hex-line
                  with pointer hex-line-pointer
           end-string
      *
           exit section.
      *-----------------------------------------------------------------
       STARTING-ADDRESS SECTION.
      *00.
      * Get the length of the transmitted buffer
           CALL 'C$PARAMSIZE' USING 1
              GIVING len
           END-CALL
      * If wanted, change the dots to something different than points
           accept dump-dots from environment 'OC_DUMP_DOTS'
             not on exception
                 move dump-dots to dots
           end-accept
      *
           perform TEST-ASCII
           perform TEST-ENDIAN
           set addr      to address of buffer
           set addr2addr to address of addr
      *
           if len > 0
      * To show hex-address, reverse if Big-Little Endian
              if is-big-endian-yes
                 set addr2addr up   by LENGTH OF addr
                 set addr2addr down by 1
              end-if
              move 1 to hex-line-pointer
              perform varying byline from 1 by 1
                      until byline > LENGTH OF addr
                 set address of byte to addr2addr
                 perform calc-hex-value
                 if is-big-endian-yes
                    set addr2addr down by 1
                 else
                    set addr2addr up   by 1
                 end-if
              end-perform
           end-if
      *
      * Get and display characteristics and headline
           accept extended-infos from environment 'OC_DUMP_EXT'
           end-accept
           if show-extended-infos
              display ' '
                      upon SYSERR
              end-display
              if len > 0
                 display 'Dump of memory beginning at Hex-address: '
                          hex-line (1 : 3 * (byline - 1) )
                          upon SYSERR
                 end-display
              end-if
              move len to len-display
              display 'Length of memory dump is: ' len-display
                       upon SYSERR
              end-display
              if show-very-extended-infos
                 perform TEST-64bit
                 display 'Program runs in '
                         architecture ' architecture. '
                         'Char-set is '
                         function trim (char-set) '.'
                         upon SYSERR
                 end-display
                 display 'Byte order is ' endian-order
                         ' endian.'
                         upon SYSERR
                 end-display
              end-if
           end-if
      *
      * Do we have anything to dump?
           if len > 0
      * Ensure that the passed size is not too big
              if len > 999998
                 move 999998 to len, len-display
                 display 'Warning, only the first '
                         len-display  ' Bytes are shown!'
                         upon SYSERR
                 end-display
              end-if
              display ' '
                      upon SYSERR
              end-display
              display 'Offset  '
                      'HEX-- -- -- -5 -- -- -- -- 10 '
                      '-- -- -- -- 15 -- '
                      '  '
                      'CHARS----1----5-'
                      upon SYSERR
              end-display
           else
              display ' '
                      upon SYSERR
              end-display
              display 'Nothing to dump.'
                      upon SYSERR
              end-display
           end-if
      *
           exit section.
      *-----------------------------------------------------------------
       TEST-ASCII SECTION.
      *Function: Discover if running Ascii or Ebcdic
      *00.
           evaluate space
              when x'20'
                 set  is-ascii   to true
              when x'40'
                 set  is-ebdic   to true
              when other
                 set  is-unknown to true
           end-evaluate
      *
           exit section.
      *-----------------------------------------------------------------
       TEST-64BIT SECTION.
      *Function: Discover if running 32/64 bit
      *00.
      *    Longer pointers in 64-bit architecture
           if function length (addr) <= 4
              set  is-32-bit to true
           else
              set  is-64-bit to true
           end-if
      *
           exit section.
      *-----------------------------------------------------------------
       TEST-ENDIAN SECTION.
      *00.
      *    Number-bytes are shuffled in Big-Little endian
           move 128 to byline
           set  address of byte to address of byline
           if function ord(byte) > 0
              set  is-big-endian-yes to true
           else
              set  is-big-endian-no  to true
           end-if
      *
           exit section.
      *----------------------------------------------------------------*
       end program CBL_OC_DUMP.

******************************************************************
*  Open Cobol ESQL (Ocesql) Sample Program
*
*  INSERTTBL -- demonstrates CONNECT, DROP TABLE, CREATE TABLE,
*               INSERT rows, COMMIT, ROLLBACK, DISCONNECT
*
*  Copyright 2013 Tokyo System House Co., Ltd.
******************************************************************
 IDENTIFICATION              DIVISION.
******************************************************************
 PROGRAM-ID.                 INSERTTBL.
 AUTHOR.                     TSH.
 DATE-WRITTEN.               2013-06-28.

******************************************************************
 DATA                        DIVISION.
******************************************************************
 WORKING-STORAGE             SECTION.
 01  TEST-DATA.
                                 *>"---+++++++++++++++++++++----"
   03 FILLER       PIC X(28) VALUE "0001HOKKAI TARO         0400".
   03 FILLER       PIC X(28) VALUE "0002AOMORI JIRO         0350".
   03 FILLER       PIC X(28) VALUE "0003AKITA SABURO        0300".
   03 FILLER       PIC X(28) VALUE "0004IWATE SHIRO         025p".
   03 FILLER       PIC X(28) VALUE "0005MIYAGI GORO         020p".
   03 FILLER       PIC X(28) VALUE "0006FUKUSHIMA RIKURO    0150".
   03 FILLER       PIC X(28) VALUE "0007TOCHIGI SHICHIRO    010p".
   03 FILLER       PIC X(28) VALUE "0008IBARAKI HACHIRO     0050".
   03 FILLER       PIC X(28) VALUE "0009GUMMA KURO          020p".
   03 FILLER       PIC X(28) VALUE "0010SAITAMA JURO        0350".
 01  TEST-DATA-R   REDEFINES TEST-DATA.
   03  TEST-TBL    OCCURS  10.
     05  TEST-NO             PIC S9(04).
     05  TEST-NAME           PIC  X(20) .
     05  TEST-SALARY         PIC S9(04).
 01  IDX                     PIC  9(02).
 01  SYS-TIME                PIC  9(08).

 EXEC SQL BEGIN DECLARE SECTION END-EXEC.
 01  DBNAME                  PIC  X(30) VALUE SPACE.
 01  USERNAME                PIC  X(30) VALUE SPACE.
 01  PASSWD                  PIC  X(10) VALUE SPACE.
 01  EMP-REC-VARS.
   03  EMP-NO                PIC S9(04) VALUE ZERO.
   03  EMP-NAME              PIC  X(20) .
   03  EMP-SALARY            PIC S9(04) VALUE ZERO.
 EXEC SQL END DECLARE SECTION END-EXEC.

 EXEC SQL INCLUDE SQLCA END-EXEC.
******************************************************************
 PROCEDURE                   DIVISION.
******************************************************************
 MAIN-RTN.
     DISPLAY "*** INSERTTBL STARTED ***".

*    WHENEVER IS NOT YET SUPPORTED :(
*      EXEC SQL WHENEVER SQLERROR PERFORM ERROR-RTN END-EXEC.

*    CONNECT
     MOVE  "ocesql"          TO   DBNAME.
     MOVE  "postgres"        TO   USERNAME.
     MOVE  SPACES            TO   PASSWD.
     EXEC SQL
         CONNECT :USERNAME IDENTIFIED BY :PASSWD USING :DBNAME
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

*    DROP TABLE
     EXEC SQL
         DROP TABLE EMP
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN.

*    CREATE TABLE
     EXEC SQL
          CREATE TABLE EMP
          (
              EMP_NO     NUMERIC(4,0) NOT NULL,
              EMP_NAME   CHAR(20),
              EMP_SALARY NUMERIC(4,0),
              CONSTRAINT IEMP_0 PRIMARY KEY (EMP_NO)
          )
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

*    INSERT ROWS USING LITERAL
     EXEC SQL
          INSERT INTO EMP VALUES (46, 'KAGOSHIMA ROKURO', -320)
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN.

     EXEC SQL
          INSERT INTO EMP VALUES (47, 'OKINAWA SHICHIRO', 480)
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN.

*    INSERT ROWS USING HOST VARIABLE
     PERFORM VARYING IDX FROM 1 BY 1 UNTIL IDX > 10
        MOVE TEST-NO(IDX)     TO  EMP-NO
        MOVE TEST-NAME(IDX)   TO  EMP-NAME
        MOVE TEST-SALARY(IDX) TO  EMP-SALARY
        EXEC SQL
           INSERT INTO EMP VALUES
                  (:EMP-NO,:EMP-NAME,:EMP-SALARY)
        END-EXEC
        IF  SQLSTATE NOT = ZERO
            PERFORM ERROR-RTN
            EXIT PERFORM
        END-IF
     END-PERFORM.

*    COMMIT
     EXEC SQL COMMIT WORK END-EXEC.

*    DISCONNECT
     EXEC SQL
         DISCONNECT ALL
     END-EXEC.

*    END
     DISPLAY "*** INSERTTBL FINISHED ***".
     STOP RUN.

******************************************************************
 ERROR-RTN.
******************************************************************
     DISPLAY "*** SQL ERROR ***".
     DISPLAY "SQLSTATE: " SQLSTATE.
     EVALUATE SQLSTATE
        WHEN  "02000"
           DISPLAY "Record not found"
        WHEN  "08003"
        WHEN  "08001"
           DISPLAY "Connection falied"
        WHEN  SPACE
           DISPLAY "Undefined error"
        WHEN  OTHER
           DISPLAY "SQLCODE: "   SQLCODE
           DISPLAY "SQLERRMC: "  SQLERRMC
        *> TO RESTART TRANSACTION, DO ROLLBACK.
           EXEC SQL
               ROLLBACK
           END-EXEC
     END-EVALUATE.
******************************************************************

prompt$ ocesql INSERTTBL.cbl inserttbl.cob

      ******************************************************************
      *  Open Cobol ESQL (Ocesql) Sample Program
      *
      *  INSERTTBL -- demonstrates CONNECT, DROP TABLE, CREATE TABLE,
      *               INSERT rows, COMMIT, ROLLBACK, DISCONNECT
      *
      *  Copyright 2013 Tokyo System House Co., Ltd.
      ******************************************************************
       IDENTIFICATION              DIVISION.
      ******************************************************************
       PROGRAM-ID.                 INSERTTBL.
       AUTHOR.                     TSH.
       DATE-WRITTEN.               2013-06-28.

      ******************************************************************
       DATA                        DIVISION.
      ******************************************************************
       WORKING-STORAGE             SECTION.
       01  TEST-DATA.
                                       *>"---+++++++++++++++++++++----"
         03 FILLER       PIC X(28) VALUE "0001HOKKAI TARO         0400".
         03 FILLER       PIC X(28) VALUE "0002AOMORI JIRO         0350".
         03 FILLER       PIC X(28) VALUE "0003AKITA SABURO        0300".
         03 FILLER       PIC X(28) VALUE "0004IWATE SHIRO         025p".
         03 FILLER       PIC X(28) VALUE "0005MIYAGI GORO         020p".
         03 FILLER       PIC X(28) VALUE "0006FUKUSHIMA RIKURO    0150".
         03 FILLER       PIC X(28) VALUE "0007TOCHIGI SHICHIRO    010p".
         03 FILLER       PIC X(28) VALUE "0008IBARAKI HACHIRO     0050".
         03 FILLER       PIC X(28) VALUE "0009GUMMA KURO          020p".
         03 FILLER       PIC X(28) VALUE "0010SAITAMA JURO        0350".
       01  TEST-DATA-R   REDEFINES TEST-DATA.
         03  TEST-TBL    OCCURS  10.
           05  TEST-NO             PIC S9(04).
           05  TEST-NAME           PIC  X(20) .
           05  TEST-SALARY         PIC S9(04).
       01  IDX                     PIC  9(02).
       01  SYS-TIME                PIC  9(08).

OCESQL*EXEC SQL BEGIN DECLARE SECTION END-EXEC.
       01  DBNAME                  PIC  X(30) VALUE SPACE.
       01  USERNAME                PIC  X(30) VALUE SPACE.
       01  PASSWD                  PIC  X(10) VALUE SPACE.
       01  EMP-REC-VARS.
         03  EMP-NO                PIC S9(04) VALUE ZERO.
         03  EMP-NAME              PIC  X(20) .
         03  EMP-SALARY            PIC S9(04) VALUE ZERO.
OCESQL*EXEC SQL END DECLARE SECTION END-EXEC.

OCESQL*EXEC SQL INCLUDE SQLCA END-EXEC.
OCESQL     copy "sqlca.cbl".
      ******************************************************************
OCESQL*
OCESQL 01  SQ0001.
OCESQL     02  FILLER PIC X(014) VALUE "DROP TABLE EMP".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
OCESQL 01  SQ0002.
OCESQL     02  FILLER PIC X(135) VALUE "CREATE TABLE EMP ( EMP_NO NUME"
OCESQL  &  "RIC(4, 0) NOT NULL, EMP_NAME CHAR(20), EMP_SALARY NUMERIC("
OCESQL  &  "4, 0), CONSTRAINT IEMP_0 PRIMARY KEY (EMP_NO) )".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
OCESQL 01  SQ0003.
OCESQL     02  FILLER PIC X(053) VALUE "INSERT INTO EMP VALUES (46, 'K"
OCESQL  &  "AGOSHIMA ROKURO', -320)".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
OCESQL 01  SQ0004.
OCESQL     02  FILLER PIC X(052) VALUE "INSERT INTO EMP VALUES (47, 'O"
OCESQL  &  "KINAWA SHICHIRO', 480)".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
OCESQL 01  SQ0005.
OCESQL     02  FILLER PIC X(037) VALUE "INSERT INTO EMP VALUES ( $1, $"
OCESQL  &  "2, $3 )".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
OCESQL 01  SQ0006.
OCESQL     02  FILLER PIC X(014) VALUE "DISCONNECT ALL".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
       PROCEDURE                   DIVISION.
      ******************************************************************
       MAIN-RTN.
           DISPLAY "*** INSERTTBL STARTED ***".

      *    WHENEVER IS NOT YET SUPPORTED :(
      *      EXEC SQL WHENEVER SQLERROR PERFORM ERROR-RTN END-EXEC.

      *    CONNECT
           MOVE  "ocesql"          TO   DBNAME.
           MOVE  "postgres"        TO   USERNAME.
           MOVE  SPACES            TO   PASSWD.
OCESQL*    EXEC SQL
OCESQL*        CONNECT :USERNAME IDENTIFIED BY :PASSWD USING :DBNAME
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLConnect" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE USERNAME
OCESQL          BY VALUE 30
OCESQL          BY REFERENCE PASSWD
OCESQL          BY VALUE 10
OCESQL          BY REFERENCE DBNAME
OCESQL          BY VALUE 30
OCESQL     END-CALL.
           IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

      *    DROP TABLE
OCESQL*    EXEC SQL
OCESQL*        DROP TABLE EMP
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLExec" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE SQ0001
OCESQL     END-CALL.
           IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN.

      *    CREATE TABLE
OCESQL*    EXEC SQL
OCESQL*         CREATE TABLE EMP
OCESQL*         (
OCESQL*             EMP_NO     NUMERIC(4,0) NOT NULL,
OCESQL*             EMP_NAME   CHAR(20),
OCESQL*             EMP_SALARY NUMERIC(4,0),
OCESQL*             CONSTRAINT IEMP_0 PRIMARY KEY (EMP_NO)
OCESQL*         )
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLExec" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE SQ0002
OCESQL     END-CALL.
           IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

      *    INSERT ROWS USING LITERAL
OCESQL*    EXEC SQL
OCESQL*         INSERT INTO EMP VALUES (46, 'KAGOSHIMA ROKURO', -320)
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLExec" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE SQ0003
OCESQL     END-CALL.
           IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN.

OCESQL*    EXEC SQL
OCESQL*         INSERT INTO EMP VALUES (47, 'OKINAWA SHICHIRO', 480)
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLExec" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE SQ0004
OCESQL     END-CALL.
           IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN.

      *    INSERT ROWS USING HOST VARIABLE
           PERFORM VARYING IDX FROM 1 BY 1 UNTIL IDX > 10
              MOVE TEST-NO(IDX)     TO  EMP-NO
              MOVE TEST-NAME(IDX)   TO  EMP-NAME
              MOVE TEST-SALARY(IDX) TO  EMP-SALARY
OCESQL*       EXEC SQL
OCESQL*          INSERT INTO EMP VALUES
OCESQL*                 (:EMP-NO,:EMP-NAME,:EMP-SALARY)
OCESQL*       END-EXEC
OCESQL     CALL "OCESQLStartSQL"
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetSQLParams" USING
OCESQL          BY VALUE 3
OCESQL          BY VALUE 4
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-NO
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetSQLParams" USING
OCESQL          BY VALUE 16
OCESQL          BY VALUE 20
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-NAME
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetSQLParams" USING
OCESQL          BY VALUE 3
OCESQL          BY VALUE 4
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-SALARY
OCESQL     END-CALL
OCESQL     CALL "OCESQLExecParams" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE SQ0005
OCESQL          BY VALUE 3
OCESQL     END-CALL
OCESQL     CALL "OCESQLEndSQL"
OCESQL     END-CALL
              IF  SQLSTATE NOT = ZERO
                  PERFORM ERROR-RTN
                  EXIT PERFORM
              END-IF
           END-PERFORM.

      *    COMMIT
OCESQL*    EXEC SQL COMMIT WORK END-EXEC.
OCESQL     CALL "OCESQLStartSQL"
OCESQL     END-CALL
OCESQL     CALL "OCESQLExec" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "COMMIT" & x"00"
OCESQL     END-CALL
OCESQL     CALL "OCESQLEndSQL"
OCESQL     END-CALL.

      *    DISCONNECT
OCESQL*    EXEC SQL
OCESQL*        DISCONNECT ALL
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLDisconnect" USING
OCESQL          BY REFERENCE SQLCA
OCESQL     END-CALL.

      *    END
           DISPLAY "*** INSERTTBL FINISHED ***".
           STOP RUN.

      ******************************************************************
       ERROR-RTN.
      ******************************************************************
           DISPLAY "*** SQL ERROR ***".
           DISPLAY "SQLSTATE: " SQLSTATE.
           EVALUATE SQLSTATE
              WHEN  "02000"
                 DISPLAY "Record not found"
              WHEN  "08003"
              WHEN  "08001"
                 DISPLAY "Connection falied"
              WHEN  SPACE
                 DISPLAY "Undefined error"
              WHEN  OTHER
                 DISPLAY "SQLCODE: "   SQLCODE
                 DISPLAY "SQLERRMC: "  SQLERRMC
              *> TO RESTART TRANSACTION, DO ROLLBACK.
OCESQL*          EXEC SQL
OCESQL*              ROLLBACK
OCESQL*          END-EXEC
OCESQL     CALL "OCESQLStartSQL"
OCESQL     END-CALL
OCESQL     CALL "OCESQLExec" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "ROLLBACK" & x"00"
OCESQL     END-CALL
OCESQL     CALL "OCESQLEndSQL"
OCESQL     END-CALL
           END-EVALUATE.
      ******************************************************************

prompt$ cobc -x inserttbl.cob -locesql
prompt$ ./inserttbl
*** INSERTTBL STARTED ***
*** SQL ERROR ***
SQLSTATE: 01
SQLCODE: -0000000402
SQLERRMC:

prompt$ systemctl start postgresql

prompt$ ./inserttbl
*** INSERTTBL STARTED ***
*** SQL ERROR ***
SQLSTATE: 42P01
SQLCODE: -000000400
SQLERRMC: ERROR:  table "emp" does not exist

prompt$ ./inserttbl
*** INSERTTBL STARTED ***
*** INSERTTBL FINISHED ***

******************************************************************
*  Open Cobol ESQL (Ocesql) Sample Program
*
*  FETCHTBL --- demonstrates CONNECT, SELECT COUNT(*),
*               DECLARE cursor, FETCH cursor, COMMIT,
*               ROLLBACK, DISCONNECT
*
*  Copyright 2013 Tokyo System House Co., Ltd.
******************************************************************
 IDENTIFICATION              DIVISION.
******************************************************************
 PROGRAM-ID.                 FETCHTBL.
 AUTHOR.                     TSH.
 DATE-WRITTEN.               2013-06-28.

******************************************************************
 DATA                        DIVISION.
******************************************************************
 WORKING-STORAGE             SECTION.
 01  D-EMP-REC.
     05  D-EMP-NO            PIC  9(04).
     05  FILLER              PIC  X.
     05  D-EMP-NAME          PIC  X(20).
     05  FILLER              PIC  X.
     05  D-EMP-SALARY        PIC  --,--9.

 EXEC SQL BEGIN DECLARE SECTION END-EXEC.
 01  DBNAME                  PIC  X(30) VALUE SPACE.
 01  USERNAME                PIC  X(30) VALUE SPACE.
 01  PASSWD                  PIC  X(10) VALUE SPACE.
 01  EMP-REC-VARS.
     05  EMP-NO              PIC S9(04).
     05  EMP-NAME            PIC  X(20) .
     05  EMP-SALARY          PIC S9(04).
 01  EMP-CNT                 PIC  9(04).
 EXEC SQL END DECLARE SECTION END-EXEC.

 EXEC SQL INCLUDE SQLCA END-EXEC.
******************************************************************
 PROCEDURE                   DIVISION.
******************************************************************
 MAIN-RTN.
     DISPLAY "*** FETCHTBL STARTED ***".

*    WHENEVER IS NOT YET SUPPORTED :(
*      EXEC SQL WHENEVER SQLERROR PERFORM ERROR-RTN END-EXEC.

*    CONNECT
     MOVE  "ocesql"          TO   DBNAME.
     MOVE  "postgres"        TO   USERNAME.
     MOVE  SPACE             TO   PASSWD.
     EXEC SQL
         CONNECT :USERNAME IDENTIFIED BY :PASSWD USING :DBNAME
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

*    SELECT COUNT(*) INTO HOST-VARIABLE
     EXEC SQL
         SELECT COUNT(*) INTO :EMP-CNT FROM EMP
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN.
     DISPLAY "TOTAL RECORD: " EMP-CNT.

*    DECLARE CURSOR
     EXEC SQL
         DECLARE C1 CURSOR FOR
         SELECT EMP_NO, EMP_NAME, EMP_SALARY
                FROM EMP
                ORDER BY EMP_NO
     END-EXEC.
     EXEC SQL
         OPEN C1
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

*    FETCH
     DISPLAY "---- -------------------- ------".
     DISPLAY "NO   NAME                 SALARY".
     DISPLAY "---- -------------------- ------".
     EXEC SQL
         FETCH C1 INTO :EMP-NO, :EMP-NAME, :EMP-SALARY
     END-EXEC.
     PERFORM UNTIL SQLSTATE NOT = ZERO
        MOVE  EMP-NO        TO    D-EMP-NO
        MOVE  EMP-NAME      TO    D-EMP-NAME
        MOVE  EMP-SALARY    TO    D-EMP-SALARY
        DISPLAY D-EMP-REC
        EXEC SQL
            FETCH C1 INTO :EMP-NO, :EMP-NAME, :EMP-SALARY
        END-EXEC
     END-PERFORM.
     IF  SQLSTATE NOT = "02000" PERFORM ERROR-RTN STOP RUN.

*    CLOSE CURSOR
     EXEC SQL
         CLOSE C1
     END-EXEC.

*    COMMIT
     EXEC SQL
         COMMIT WORK
     END-EXEC.

*    DISCONNECT
     EXEC SQL
         DISCONNECT ALL
     END-EXEC.

*    END
     DISPLAY "*** FETCHTBL FINISHED ***".
     STOP RUN.

******************************************************************
 ERROR-RTN.
******************************************************************
     DISPLAY "*** SQL ERROR ***".
     DISPLAY "SQLSTATE: " SQLSTATE.
     EVALUATE SQLSTATE
        WHEN  "02000"
           DISPLAY "Record not found"
        WHEN  "08003"
        WHEN  "08001"
           DISPLAY "Connection falied"
        WHEN  SPACE
           DISPLAY "Undefined error"
        WHEN  OTHER
           DISPLAY "SQLCODE: "   SQLCODE
           DISPLAY "SQLERRMC: "  SQLERRMC
        *> TO RESTART TRANSACTION, DO ROLLBACK.
           EXEC SQL
               ROLLBACK
           END-EXEC
     END-EVALUATE.
******************************************************************

$ ocesql FETCHTBL.cbl fetchtbl.cob
precompile start: FETCHTBL.cbl
=======================================================
              LIST OF CALLED DB Library API
=======================================================
Generate:OCESQLConnect
Generate:OCESQLExecSelectIntoOne
Generate:OCESQLCursorDeclare
Generate:OCESQLCursorOpen
Generate:OCESQLCursorFetchOne
Generate:OCESQLCursorFetchOne
Generate:OCESQLCursorClose
Generate:COMMIT
Generate:OCESQLDisconnect
Generate:ROLLBACK
=======================================================

      ******************************************************************
      *  Open Cobol ESQL (Ocesql) Sample Program
      *
      *  FETCHTBL --- demonstrates CONNECT, SELECT COUNT(*),
      *               DECLARE cursor, FETCH cursor, COMMIT,
      *               ROLLBACK, DISCONNECT
      *
      *  Copyright 2013 Tokyo System House Co., Ltd.
      ******************************************************************
       IDENTIFICATION              DIVISION.
      ******************************************************************
       PROGRAM-ID.                 FETCHTBL.
       AUTHOR.                     TSH.
       DATE-WRITTEN.               2013-06-28.

      ******************************************************************
       DATA                        DIVISION.
      ******************************************************************
       WORKING-STORAGE             SECTION.
       01  D-EMP-REC.
           05  D-EMP-NO            PIC  9(04).
           05  FILLER              PIC  X.
           05  D-EMP-NAME          PIC  X(20).
           05  FILLER              PIC  X.
           05  D-EMP-SALARY        PIC  --,--9.

OCESQL*EXEC SQL BEGIN DECLARE SECTION END-EXEC.
       01  DBNAME                  PIC  X(30) VALUE SPACE.
       01  USERNAME                PIC  X(30) VALUE SPACE.
       01  PASSWD                  PIC  X(10) VALUE SPACE.
       01  EMP-REC-VARS.
           05  EMP-NO              PIC S9(04).
           05  EMP-NAME            PIC  X(20) .
           05  EMP-SALARY          PIC S9(04).
       01  EMP-CNT                 PIC  9(04).
OCESQL*EXEC SQL END DECLARE SECTION END-EXEC.

OCESQL*EXEC SQL INCLUDE SQLCA END-EXEC.
OCESQL     copy "sqlca.cbl".
      ******************************************************************
OCESQL*
OCESQL 01  SQ0001.
OCESQL     02  FILLER PIC X(026) VALUE "SELECT COUNT( * ) FROM EMP".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
OCESQL 01  SQ0002.
OCESQL     02  FILLER PIC X(060) VALUE "SELECT EMP_NO, EMP_NAME, EMP_S"
OCESQL  &  "ALARY FROM EMP ORDER BY EMP_NO".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
OCESQL 01  SQ0003.
OCESQL     02  FILLER PIC X(014) VALUE "DISCONNECT ALL".
OCESQL     02  FILLER PIC X(1) VALUE X"00".
OCESQL*
       PROCEDURE                   DIVISION.
      ******************************************************************
       MAIN-RTN.
           DISPLAY "*** FETCHTBL STARTED ***".

      *    WHENEVER IS NOT YET SUPPORTED :(
      *      EXEC SQL WHENEVER SQLERROR PERFORM ERROR-RTN END-EXEC.

      *    CONNECT
           MOVE  "ocesql"          TO   DBNAME.
           MOVE  "postgres"        TO   USERNAME.
           MOVE  SPACE             TO   PASSWD.
OCESQL*    EXEC SQL
OCESQL*        CONNECT :USERNAME IDENTIFIED BY :PASSWD USING :DBNAME
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLConnect" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE USERNAME
OCESQL          BY VALUE 30
OCESQL          BY REFERENCE PASSWD
OCESQL          BY VALUE 10
OCESQL          BY REFERENCE DBNAME
OCESQL          BY VALUE 30
OCESQL     END-CALL.
           IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

      *    SELECT COUNT(*) INTO HOST-VARIABLE
OCESQL*    EXEC SQL
OCESQL*        SELECT COUNT(*) INTO :EMP-CNT FROM EMP
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLStartSQL"
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetResultParams" USING
OCESQL          BY VALUE 1
OCESQL          BY VALUE 4
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-CNT
OCESQL     END-CALL
OCESQL     CALL "OCESQLExecSelectIntoOne" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE SQ0001
OCESQL          BY VALUE 0
OCESQL          BY VALUE 1
OCESQL     END-CALL
OCESQL     CALL "OCESQLEndSQL"
OCESQL     END-CALL.
           IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN.
           DISPLAY "TOTAL RECORD: " EMP-CNT.

      *    DECLARE CURSOR
OCESQL*    EXEC SQL
OCESQL*        DECLARE C1 CURSOR FOR
OCESQL*        SELECT EMP_NO, EMP_NAME, EMP_SALARY
OCESQL*               FROM EMP
OCESQL*               ORDER BY EMP_NO
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLCursorDeclare" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "FETCHTBL_C1" & x"00"
OCESQL          BY REFERENCE SQ0002
OCESQL     END-CALL.
OCESQL*    EXEC SQL
OCESQL*        OPEN C1
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLCursorOpen" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "FETCHTBL_C1" & x"00"
OCESQL     END-CALL.
           IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

      *    FETCH
           DISPLAY "---- -------------------- ------".
           DISPLAY "NO   NAME                 SALARY".
           DISPLAY "---- -------------------- ------".
OCESQL*    EXEC SQL
OCESQL*        FETCH C1 INTO :EMP-NO, :EMP-NAME, :EMP-SALARY
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLStartSQL"
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetResultParams" USING
OCESQL          BY VALUE 3
OCESQL          BY VALUE 4
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-NO
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetResultParams" USING
OCESQL          BY VALUE 16
OCESQL          BY VALUE 20
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-NAME
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetResultParams" USING
OCESQL          BY VALUE 3
OCESQL          BY VALUE 4
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-SALARY
OCESQL     END-CALL
OCESQL     CALL "OCESQLCursorFetchOne" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "FETCHTBL_C1" & x"00"
OCESQL     END-CALL
OCESQL     CALL "OCESQLEndSQL"
OCESQL     END-CALL.
           PERFORM UNTIL SQLSTATE NOT = ZERO
              MOVE  EMP-NO        TO    D-EMP-NO
              MOVE  EMP-NAME      TO    D-EMP-NAME
              MOVE  EMP-SALARY    TO    D-EMP-SALARY
              DISPLAY D-EMP-REC
OCESQL*       EXEC SQL
OCESQL*           FETCH C1 INTO :EMP-NO, :EMP-NAME, :EMP-SALARY
OCESQL*       END-EXEC
OCESQL     CALL "OCESQLStartSQL"
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetResultParams" USING
OCESQL          BY VALUE 3
OCESQL          BY VALUE 4
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-NO
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetResultParams" USING
OCESQL          BY VALUE 16
OCESQL          BY VALUE 20
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-NAME
OCESQL     END-CALL
OCESQL     CALL "OCESQLSetResultParams" USING
OCESQL          BY VALUE 3
OCESQL          BY VALUE 4
OCESQL          BY VALUE 0
OCESQL          BY REFERENCE EMP-SALARY
OCESQL     END-CALL
OCESQL     CALL "OCESQLCursorFetchOne" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "FETCHTBL_C1" & x"00"
OCESQL     END-CALL
OCESQL     CALL "OCESQLEndSQL"
OCESQL     END-CALL
           END-PERFORM.
           IF  SQLSTATE NOT = "02000" PERFORM ERROR-RTN STOP RUN.

      *    CLOSE CURSOR
OCESQL*    EXEC SQL
OCESQL*        CLOSE C1
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLCursorClose"  USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "FETCHTBL_C1" & x"00"
OCESQL     END-CALL
OCESQL    .

      *    COMMIT
OCESQL*    EXEC SQL
OCESQL*        COMMIT WORK
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLStartSQL"
OCESQL     END-CALL
OCESQL     CALL "OCESQLExec" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "COMMIT" & x"00"
OCESQL     END-CALL
OCESQL     CALL "OCESQLEndSQL"
OCESQL     END-CALL.

      *    DISCONNECT
OCESQL*    EXEC SQL
OCESQL*        DISCONNECT ALL
OCESQL*    END-EXEC.
OCESQL     CALL "OCESQLDisconnect" USING
OCESQL          BY REFERENCE SQLCA
OCESQL     END-CALL.

      *    END
           DISPLAY "*** FETCHTBL FINISHED ***".
           STOP RUN.

      ******************************************************************
       ERROR-RTN.
      ******************************************************************
           DISPLAY "*** SQL ERROR ***".
           DISPLAY "SQLSTATE: " SQLSTATE.
           EVALUATE SQLSTATE
              WHEN  "02000"
                 DISPLAY "Record not found"
              WHEN  "08003"
              WHEN  "08001"
                 DISPLAY "Connection falied"
              WHEN  SPACE
                 DISPLAY "Undefined error"
              WHEN  OTHER
                 DISPLAY "SQLCODE: "   SQLCODE
                 DISPLAY "SQLERRMC: "  SQLERRMC
              *> TO RESTART TRANSACTION, DO ROLLBACK.
OCESQL*          EXEC SQL
OCESQL*              ROLLBACK
OCESQL*          END-EXEC
OCESQL     CALL "OCESQLStartSQL"
OCESQL     END-CALL
OCESQL     CALL "OCESQLExec" USING
OCESQL          BY REFERENCE SQLCA
OCESQL          BY REFERENCE "ROLLBACK" & x"00"
OCESQL     END-CALL
OCESQL     CALL "OCESQLEndSQL"
OCESQL     END-CALL
           END-EVALUATE.
      ******************************************************************

prompt$ cobc -x fetchtbl.cob -locesql
prompt$ ./fetchtbl
*** FETCHTBL STARTED ***
TOTAL RECORD: 0012
---- -------------------- ------
NO   NAME                 SALARY
---- -------------------- ------
0001 HOKKAI TARO             400
0002 AOMORI JIRO             350
0003 AKITA SABURO            300
0004 IWATE SHIRO            -250
0005 MIYAGI GORO            -200
0006 FUKUSHIMA RIKURO        150
0007 TOCHIGI SHICHIRO       -100
0008 IBARAKI HACHIRO          50
0009 GUMMA KURO             -200
0010 SAITAMA JURO            350
0046 KAGOSHIMA ROKURO       -320
0047 OKINAWA SHICHIRO        480
*** FETCHTBL FINISHED ***

prompt$ ocesql

Open Cobol ESQL (Ocesql)
Version 1.0.0
June 28, 2013
Tokyo System House Co., Ltd. <opencobol@tsh-world.co.jp>

Usage: ocesql [--inc=include_dir] SOURCE [DESTFILE] [LOGFILE]

******************************************************************
*       SQLCA: SQL Communications Area for Ocesql                *
******************************************************************
 01  SQLCA GLOBAL.
     05  SQLCAID               PIC X(8).
     05  SQLCABC               PIC S9(9) COMP-5.
     05  SQLCODE               PIC S9(9) COMP-5.
     05  SQLERRM.
     49  SQLERRML              PIC S9(4) COMP-5.
     49  SQLERRMC              PIC X(70).
     05  SQLERRP               PIC X(8).               *> not used
     05  SQLERRD OCCURS 6 TIMES                        *> used only ERRD(3)
                               PIC S9(9) COMP-5.
     05  SQLWARN.                                      *> not used
         10 SQLWARN0           PIC X(1).
         10 SQLWARN1           PIC X(1).
         10 SQLWARN2           PIC X(1).
         10 SQLWARN3           PIC X(1).
         10 SQLWARN4           PIC X(1).
         10 SQLWARN5           PIC X(1).
         10 SQLWARN6           PIC X(1).
         10 SQLWARN7           PIC X(1).
     05  SQLSTATE              PIC X(5).
******************************************************************

01  SQLCA.
    03  SQLCAID         PIC X(8)          VALUE "SQLCA   ".
    03  SQLCABC         USAGE BINARY-LONG VALUE 136.
    03  SQLCODE         USAGE BINARY-LONG VALUE 0.
    03  SQLERRM.
        05  SQLERRML    USAGE BINARY-SHORT.
        05  SQLERRMC    PIC X(70).
    03  SQLERRP         PIC X(8).
    03  SQLERRD         USAGE BINARY-LONG OCCURS 6.
    03  SQLWARN.
        05  SQLWARN0    PIC X.
        05  SQLWARN1    PIC X.
        05  SQLWARN2    PIC X.
        05  SQLWARN3    PIC X.
        05  SQLWARN4    PIC X.
        05  SQLWARN5    PIC X.
        05  SQLWARN6    PIC X.
        05  SQLWARN7    PIC X.
        05  SQLWARN8    PIC X.
        05  SQLWARN9    PIC X.
        05  SQLWARN10   PIC X.
        05  SQLWARNA    REDEFINES SQLWARN10 PIC X.
    03  SQLSTATE        PIC X(5).
    03  FILLER          PIC X(21).

*    CONNECT
     MOVE  "ocesql@host:port"  TO   DBNAME.
     MOVE  "postgres"          TO   USERNAME.
     MOVE  SPACE               TO   PASSWD.
     EXEC SQL
         CONNECT :USERNAME IDENTIFIED BY :PASSWD USING :DBNAME
     END-EXEC.
     IF  SQLSTATE NOT = ZERO PERFORM ERROR-RTN STOP RUN.

Gnu   *>************************************************************************
COBOL *>  This file is part of DB2sample.
      *>
      *>  DB2MOD1.cob is free software: you can redistribute it and/or
      *>  modify it under the terms of the GNU Lesser General Public License as
      *>  published by the Free Software Foundation, either version 3 of the
      *>  License, or (at your option) any later version.
      *>
      *>  DB2MOD1.cob is distributed in the hope that it will be useful,
      *>  but WITHOUT ANY WARRANTY; without even the implied warranty of
      *>  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
      *>  See the GNU Lesser General Public License for more details.
      *>
      *>  You should have received a copy of the GNU Lesser General Public
      *>  License along with DB2MOD1.cob.
      *>  If not, see <http://www.gnu.org/licenses/>.
      *>************************************************************************

      *>************************************************************************
      *> Program:      DB2MOD1.sqb
      *>
      *> Purpose:      DB2 sample module
      *>
      *> Author:       Laszlo Erdos - https://www.facebook.com/wortfee
      *>
      *> Date-Written: 2015.12.24
      *>
      *> Tectonics:    DB2 precompile:
      *>               db2cmd -i -w -c db2 -tvf db2_precompile1.sql
      *>
      *>               Compile under cygwin:
      *>               cobc -m -std=mf DB2MOD1.cbl \
      *>               -I/cygdrive/c/IBM/SQLLIB/include/cobol_mf \
      *>               -L/cygdrive/c/IBM/SQLLIB/lib -ldb2api
      *>
      *> Usage:        To use this module, simply CALL it as follows:
      *>               CALL "DB2MOD1" USING LN-MOD
      *>
      *>               Implemented features:
      *>               - connect to DB2
      *>               - connect reset
      *>
      *>************************************************************************
      *> Date       Name / Change description
      *> ========== ============================================================
      *> 2015.12.24 Laszlo Erdos:
      *>            - first version.
      *>************************************************************************

       IDENTIFICATION DIVISION.
       PROGRAM-ID. DB2MOD1.

       ENVIRONMENT DIVISION.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
      *> linkage for DB2SQLMSG.cob
       COPY "LNSQLMSG.cpy".

      *> SQL communication area
       COPY "sqlca.cbl".

      *> SQL status
       01 WS-SQL-STATUS                PIC S9(9) COMP-5.
          88 SQL-STATUS-OK             VALUE    0.
          88 SQL-STATUS-NOT-FOUND      VALUE  100.
          88 SQL-STATUS-DUP            VALUE -803.

      *> SQL declare variables
       EXEC SQL BEGIN DECLARE SECTION END-EXEC.
      *> connect fields with variable length
       01 HV-DBALIAS.
          49 HV-DBALIAS-LEN            PIC S9(4) COMP-5.
          49 HV-DBALIAS-BUF            PIC X(9).
       01 HV-USERID.
          49 HV-USERID-LEN             PIC S9(4) COMP-5.
          49 HV-USERID-BUF             PIC X(20).
       01 HV-PSWD.
          49 HV-PSWD-LEN               PIC S9(4) COMP-5.
          49 HV-PSWD-BUF               PIC X(20).
       EXEC SQL END   DECLARE SECTION END-EXEC.

       LINKAGE SECTION.
       COPY "LNMOD1.cpy".

       PROCEDURE DIVISION USING LN-MOD.

      *>------------------------------------------------------------------------
       MAIN-DB2MOD1 SECTION.
      *>------------------------------------------------------------------------

          INITIALIZE LN-MSG

          EVALUATE TRUE
             WHEN V-LN-FNC-CONNECT
                PERFORM CONNECT

             WHEN V-LN-FNC-CONNECT-RESET
                PERFORM CONNECT-RESET

             WHEN OTHER
                MOVE "Wrong linkage function"
                  TO LN-MSG-1 OF LN-MOD
          END-EVALUATE

          GOBACK

          .
       MAIN-DB2MOD1-EX.
          EXIT.

      *>------------------------------------------------------------------------
       CONNECT SECTION.
      *>------------------------------------------------------------------------

          MOVE LN-DBALIAS OF LN-MOD TO HV-DBALIAS-BUF
          MOVE FUNCTION STORED-CHAR-LENGTH(HV-DBALIAS-BUF)
            TO HV-DBALIAS-LEN

          MOVE LN-USERID  OF LN-MOD TO HV-USERID-BUF
          MOVE FUNCTION STORED-CHAR-LENGTH(HV-USERID-BUF)
            TO HV-USERID-LEN

          MOVE LN-PSWD    OF LN-MOD TO HV-PSWD-BUF
          MOVE FUNCTION STORED-CHAR-LENGTH(HV-PSWD-BUF)
            TO HV-PSWD-LEN

          PERFORM SQL-CONNECT

          PERFORM COPY-SQL-MSG-IN-LINKAGE

          .
       CONNECT-EX.
          EXIT.

      *>------------------------------------------------------------------------
       CONNECT-RESET SECTION.
      *>------------------------------------------------------------------------

          PERFORM SQL-CONNECT-RESET

          PERFORM COPY-SQL-MSG-IN-LINKAGE

          .
       CONNECT-RESET-EX.
          EXIT.

      *>------------------------------------------------------------------------
       COPY-SQL-MSG-IN-LINKAGE SECTION.
      *>------------------------------------------------------------------------

      *>  get SQL message with DB2 functions: sqlgintp, sqlggstt
          CALL "DB2SQLMSG" USING SQLCA
                                 LN-SQLMSG
          END-CALL

          MOVE SQLCODE
            TO LN-SQLCODE              OF LN-MOD
          MOVE SQLSTATE
            TO LN-SQLSTATE             OF LN-MOD
          MOVE LN-MSG-1                OF LN-SQLMSG
            TO LN-MSG-1                OF LN-MOD
          MOVE LN-MSG-2                OF LN-SQLMSG
            TO LN-MSG-2                OF LN-MOD
          MOVE LN-MSG-3                OF LN-SQLMSG
            TO LN-MSG-3                OF LN-MOD
          MOVE LN-MSG-4                OF LN-SQLMSG
            TO LN-MSG-4                OF LN-MOD

          .
       COPY-SQL-MSG-IN-LINKAGE-EX.
          EXIT.

      *>------------------------------------------------------------------------
       SQL-CONNECT SECTION.
      *>------------------------------------------------------------------------

          EXEC SQL
               CONNECT TO    :HV-DBALIAS
                       USER  :HV-USERID
                       USING :HV-PSWD
          END-EXEC

          MOVE SQLCODE TO WS-SQL-STATUS

          .
       SQL-CONNECT-EX.
          EXIT.

      *>------------------------------------------------------------------------
       SQL-CONNECT-RESET SECTION.
      *>------------------------------------------------------------------------

          EXEC SQL
               CONNECT RESET
          END-EXEC

          MOVE SQLCODE TO WS-SQL-STATUS

          .
       SQL-CONNECT-RESET-EX.
          EXIT.

       END PROGRAM DB2MOD1.

DB2   *>************************************************************************
Sample*>  This file is part of DB2sample.
      *>
      *>  DB2TEST1.cob is free software: you can redistribute it and/or
      *>  modify it under the terms of the GNU Lesser General Public License as
      *>  published by the Free Software Foundation, either version 3 of the
      *>  License, or (at your option) any later version.
      *>
      *>  DB2TEST1.cob is distributed in the hope that it will be useful,
      *>  but WITHOUT ANY WARRANTY; without even the implied warranty of
      *>  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
      *>  See the GNU Lesser General Public License for more details.
      *>
      *>  You should have received a copy of the GNU Lesser General Public
      *>  License along with DB2TEST1.cob.
      *>  If not, see <http://www.gnu.org/licenses/>.
      *>************************************************************************

      *>************************************************************************
      *> Program:      DB2TEST1.cob
      *>
      *> Purpose:      Test program for the DB2 sample module
      *>
      *> Author:       Laszlo Erdos - https://www.facebook.com/wortfee
      *>
      *> Date-Written: 2015.12.24
      *>
      *> Tectonics:    cobc -x DB2TEST1.cob
      *>
      *> Usage:        This is a test program for the DB2 sample module. You
      *>               can call and test through a few simple screens the
      *>               code in the DB2 module.
      *>
      *>               Implemented features:
      *>               - connect to DB2
      *>               - connect reset
      *>
      *>************************************************************************
      *> Date       Name / Change description
      *> ========== ============================================================
      *> 2015.12.24 Laszlo Erdos:
      *>            - first version.
      *>************************************************************************

       IDENTIFICATION DIVISION.
       PROGRAM-ID. DB2TEST1.

       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SPECIAL-NAMES.
          CRT STATUS IS WS-FNC-KEY.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01 WS-FNC-KEY                   PIC 9(4).
          88 V-FNC-F1                  VALUE 1001.
          88 V-FNC-F2                  VALUE 1002.
          88 V-FNC-F9                  VALUE 1009.
          88 V-FNC-F10                 VALUE 1010.
       01 WS-ACCEPT-FNC-KEY            PIC X.

       01 WS-MSG.
         02 WS-SQLCODE                 PIC S9(10).
         02 WS-SQLSTATE                PIC X(5).
         02 WS-MSG-1                   PIC X(80).
         02 WS-MSG-2                   PIC X(80).
         02 WS-MSG-3                   PIC X(80).
         02 WS-MSG-4                   PIC X(80).

       01 WS-CONNECT.
         02 WS-DBALIAS                 PIC X(9).
         02 WS-USERID                  PIC X(20).
         02 WS-PSWD                    PIC X(20).

      *> linkage
       COPY "LNMOD1.cpy".

      *> colors
       COPY SCREENIO.

       SCREEN SECTION.
       01 HEADER-SCREEN.
          05 FILLER LINE 2 COLUMN 13
             VALUE "DB2 sample program, please select a function"
      *>     this deletes the screen
             BLANK SCREEN
             FOREGROUND-COLOR COB-COLOR-GREEN.

       01 MAIN-FUNCTION-SCREEN.
          05 FILLER LINE 4 COLUMN 5
             VALUE "F1 - Connect to DB2"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 5 COLUMN 5
             VALUE "F2 - Connect reset"
             FOREGROUND-COLOR COB-COLOR-GREEN.

          05 FILLER LINE 18 COLUMN 5
             VALUE "F9 - Exit"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER PIC X TO WS-ACCEPT-FNC-KEY SECURE
             LINE 18 COLUMN 79
             FOREGROUND-COLOR COB-COLOR-GREEN.

       01 MESSAGE-SCREEN.
      *> line 20
          05 FILLER LINE 20 COLUMN 1
             VALUE "SQLCODE: "
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER PIC -Z(9)9 FROM WS-SQLCODE OF WS-MSG
             LINE 20 COLUMN 10
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 20 COLUMN 30
             VALUE "SQLSTATE: "
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER PIC X(5) FROM WS-SQLSTATE OF WS-MSG
             LINE 20 COLUMN 40
             FOREGROUND-COLOR COB-COLOR-GREEN.
      *> line 21
          05 FILLER PIC X(80) FROM WS-MSG-1 OF WS-MSG
             LINE 21 COLUMN 1
             FOREGROUND-COLOR COB-COLOR-GREEN.
      *> line 22
          05 FILLER PIC X(80) FROM WS-MSG-2 OF WS-MSG
             LINE 22 COLUMN 1
             FOREGROUND-COLOR COB-COLOR-GREEN.
      *> line 23
          05 FILLER PIC X(80) FROM WS-MSG-3 OF WS-MSG
             LINE 23 COLUMN 1
             FOREGROUND-COLOR COB-COLOR-GREEN.
      *> line 24
          05 FILLER PIC X(80) FROM WS-MSG-4 OF WS-MSG
             LINE 24 COLUMN 1
             FOREGROUND-COLOR COB-COLOR-GREEN.

       01 CONNECT-SCREEN.
          05 FILLER LINE 4 COLUMN 1
             VALUE "DBALIAS:"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER PIC X(9) TO WS-DBALIAS
             LINE 4 COLUMN 10
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 4 COLUMN 50
             VALUE "eg.: testdb"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 5 COLUMN 1
             VALUE "USERID:"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER PIC X(20) TO WS-USERID
             LINE 5 COLUMN 10
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 5 COLUMN 50
             VALUE "eg.: LASZLO.ERDOES"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 6 COLUMN 1
             VALUE "PSWD:"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER PIC X(20) TO WS-PSWD SECURE
             LINE 6 COLUMN 10
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 6 COLUMN 50
             VALUE "eg.: laszlopw"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 18 COLUMN 1
             VALUE "F1 - Connect to DB2"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER LINE 18 COLUMN 25
             VALUE "F10 - Back to main"
             FOREGROUND-COLOR COB-COLOR-GREEN.
          05 FILLER PIC X TO WS-ACCEPT-FNC-KEY SECURE
             LINE 18 COLUMN 79
             FOREGROUND-COLOR COB-COLOR-GREEN.


       PROCEDURE DIVISION.

      *>------------------------------------------------------------------------
       MAIN-DB2TEST1 SECTION.
      *>------------------------------------------------------------------------

          PERFORM FOREVER
             DISPLAY HEADER-SCREEN END-DISPLAY
             DISPLAY MAIN-FUNCTION-SCREEN END-DISPLAY
             DISPLAY MESSAGE-SCREEN END-DISPLAY
             ACCEPT MAIN-FUNCTION-SCREEN END-ACCEPT

      *>     init message
             INITIALIZE WS-MSG
             DISPLAY MESSAGE-SCREEN END-DISPLAY

             EVALUATE TRUE
                WHEN V-FNC-F1
                   PERFORM FNC-CONNECT-SCREEN

                WHEN V-FNC-F2
                   PERFORM FNC-CONNECT-RESET

                WHEN V-FNC-F9
                   EXIT PERFORM

                WHEN OTHER
                   MOVE "Please select a valid function key"
                     TO WS-MSG-1 OF WS-MSG
             END-EVALUATE
          END-PERFORM

          STOP RUN

          .
       MAIN-DB2TEST1-EX.
          EXIT.

      *>------------------------------------------------------------------------
       FNC-CONNECT-SCREEN SECTION.
      *>------------------------------------------------------------------------

          PERFORM FOREVER
             DISPLAY HEADER-SCREEN END-DISPLAY
             DISPLAY CONNECT-SCREEN END-DISPLAY
             DISPLAY MESSAGE-SCREEN END-DISPLAY
             ACCEPT CONNECT-SCREEN END-ACCEPT

      *>     init message
             INITIALIZE WS-MSG
             DISPLAY MESSAGE-SCREEN END-DISPLAY

             EVALUATE TRUE
                WHEN V-FNC-F1
                   PERFORM FNC-CONNECT

                WHEN V-FNC-F10
                   EXIT PERFORM

                WHEN OTHER
                   MOVE "Please select a valid function key"
                     TO WS-MSG-1 OF WS-MSG
             END-EVALUATE
          END-PERFORM

          .
       FNC-CONNECT-SCREEN-EX.
          EXIT.

      *>------------------------------------------------------------------------
       FNC-CONNECT SECTION.
      *>------------------------------------------------------------------------

          INITIALIZE LN-MOD
          INITIALIZE WS-MSG
          SET V-LN-FNC-CONNECT OF LN-MOD TO TRUE
          MOVE WS-CONNECT TO LN-CONNECT OF LN-MOD

          CALL "DB2MOD1" USING LN-MOD END-CALL

          PERFORM COPY-LN-MSG-IN-WS-MSG

          .
       FNC-CONNECT-EX.
          EXIT.

      *>------------------------------------------------------------------------
       FNC-CONNECT-RESET SECTION.
      *>------------------------------------------------------------------------

          INITIALIZE LN-MOD
          INITIALIZE WS-MSG
          SET V-LN-FNC-CONNECT-RESET OF LN-MOD TO TRUE

          CALL "DB2MOD1" USING LN-MOD END-CALL

          PERFORM COPY-LN-MSG-IN-WS-MSG

          .
       FNC-CONNECT-RESET-EX.
          EXIT.

      *>------------------------------------------------------------------------
       COPY-LN-MSG-IN-WS-MSG SECTION.
      *>------------------------------------------------------------------------

          MOVE LN-MSG                  OF LN-OUTPUT
            TO WS-MSG

          .
       COPY-LN-MSG-IN-WS-MSG-EX.
          EXIT.

       END PROGRAM DB2TEST1.

Hi

I had some trouble with Oracle procob 10.2 and OpenCobol 1.1 with std=mf.
For PIC S9(2) COMP, procob seems to use 2 bytes, and OpenCobol only one.
It doesn't work well. It comes from the parameter binary-size in the
mf.conf, which seems to tell to opencobol the larger of comp type
I modify to binary-size: 2-4-8 and it works (same as the mvs.conf)
Our application works with Micro Focus / Oracle, and micro Focus use 2 bytes,
like Oracle. Perhaps because we have the mvs toggle

Except for this thing, opencobol and oracle work like a charm,
on a debian 32bit.

Regards,
Angus

GCobol*> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20091129, 20140915
      *> Purpose:   PostgreSQL connection test, updated for clarity
      *> Tectonics: cobc -x -lpq pgcob.cob
      *> ***************************************************************
       identification division.
       program-id. pgcob.

       data division.
       working-storage section.
       01 pgconn usage pointer.
       01 pgres  usage pointer.
       01 resptr usage pointer.
       01 resstr pic x(80) based.
       01 result usage binary-long.
       01 answer pic x(80).

      *> ***************************************************************
       procedure division.
       display "Before connect:     " pgconn end-display

      *> connect to PostgreSQL
       call "PQconnectdb" using
           by reference "dbname = postgres" & x"00"
           returning pgconn
           on exception
               display
                   "Error: PQconnectdb link problem, try -lpq"
                   upon syserr
               end-display
bail           stop run returning 1
       end-call
       display "After connect:      " pgconn end-display

       if pgconn equal null then
           display "Error: PQconnectdb failure" upon syserr end-display
bail       stop run returning 1
       end-if

      *> request a connection status
       call "PQstatus" using by value pgconn returning result end-call
       if result equal 0 then
           move "OK" to answer
       else
           move "BAD" to answer
       end-if
       display
           "Status:             " result
           " CONNECTION_" function trim(answer)
       end-display

      *> sample call to get the connection name credentials
       call "PQuser" using by value pgconn returning resptr end-call

       if resptr not equal null then
           set address of resstr to resptr
           string resstr delimited by x"00" into answer end-string
       else
           move "PQuser returned null" to answer
       end-if
       display "User:               " function trim(answer) end-display

      *> Evaluate a query
       display " -- call PQexec --" end-display
       call "PQexec" using
           by value pgconn
           by reference "select version();" & x"00"
           returning pgres
       end-call
       display "PQexec return code: " pgres end-display

      *> Pull out a result. row 0, field 0
       if pgres not equal null then
           call "PQgetvalue" using
               by value pgres
               by value 0
               by value 0
               returning resptr
           end-call
           if resptr not equal null then
               set address of resstr to resptr
               string resstr delimited by x"00" into answer end-string
           else
               move "PQgetvalue returned null" to answer
           end-if
       else
           move "PQexec returned null" to answer
       end-if
       display "PostgreSQL version: " answer end-display

      *> close the PostgreSQL connection
       call "PQfinish" using by value pgconn returning omitted end-call
       set pgconn to NULL

       goback.
       end program pgcob.

$ cobc -x pgcob.cob
$ ./pgcob
Before connect:     0x0000000000000000
Error: PQconnectdb link problem, try -lpq

$ cobc -x -lpq pgcob.cob
$ ./pgcob
Before connect:     0x0000000000000000
After connect:      0x00000000020975d0
Status:             +0000000001 CONNECTION_BAD
User:               btiffin
 -- call PQexec --
PQexec return code: 0x0000000000000000
PostgreSQL version: PQexec returned null
After PQfinish:     0x00000000020975d0

$ sudo service postgresql start

$ ./pgcob
Before connect:     0x0000000000000000
After connect:      0x00000000007d25d0
Status:             +0000000000 CONNECTION_OK
User:               btiffin
 -- call PQexec --
PQexec return code: 0x00000000007d31e0
PostgreSQL version: PostgreSQL 9.2.8 on x86_64-redhat-linux-gnu,
                    compiled by gcc (GCC) 4.8.2 2013121
After PQfinish:     0x00000000007d25d0

GCobol*> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20091129
      *> Purpose:   PostgreSQL connection test
      *> Tectonics: cobc -x -lpq pgcob.cob
      *> ***************************************************************
       identification division.
       program-id. pgcob.

       data division.
       working-storage section.
       01 pgconn usage pointer.
       01 pgres  usage pointer.
       01 resptr usage pointer.
       01 resstr pic x(80) based.
       01 result usage binary-long.
       01 answer pic x(80).

      *> ***************************************************************
       procedure division.
       display "Before connect:" pgconn end-display

       call "PQconnectdb" using
           by reference "dbname = postgres" & x"00"
           returning pgconn
       end-call
       display "After connect: " pgconn end-display

       call "PQstatus" using by value pgconn returning result end-call
       display "Status:        " result end-display

       call "PQuser" using by value pgconn returning resptr end-call

       set address of resstr to resptr
       string resstr delimited by x"00" into answer end-string
       display "User:          " function trim(answer) end-display

       display "call PQexec" end-display
       call "PQexec" using
           by value pgconn
           by reference "select version();" & x"00"
           returning pgres
       end-call
       display pgres end-display

      *> Pull out a result. row 0, field 0 <*
       call "PQgetvalue" using
           by value pgres
           by value 0
           by value 0
           returning resptr
       end-call
       set address of resstr to resptr
       string resstr delimited by x"00" into answer end-string
       display "Version:       " answer end-display

       call "PQfinish" using by value pgconn returning omitted end-call
       display "After finish:  " pgconn end-display

       call "PQstatus" using by value pgconn returning result end-call
       display "Status:        " result end-display

      *> this will now return garbage, DON'T DO THIS <*
       call "PQuser" using by value pgconn returning resptr end-call
       set address of resstr to resptr
       string resstr delimited by x"00" into answer end-string
       display "User after:    " function trim(answer) end-display

       goback.
       end program pgcob.

$ cobc -x -lpq pgcob.cob
$ ./pgcob
Before connect:0x00000000
After connect: 0x086713e8
Status:        +0000000000
User:          brian
call PQexec
0x08671a28
Version:       PostgreSQL 8.3.7 on i486-pc-linux-gnu,
               compiled by GCC gcc-4.3.real (Debian 4.3.
After finish:  0x086713e8
Status:        +0000000001
User after:    PostgreSQL 8.3.7 on i486-pc-linux-gnu,
               compiled by GCC gcc-4.3.real (Debian 4.3.

sudo alien -iv oracle-instantclient12.1-basic-12.1.0.1.0-1.x86_64.rpm
sudo alien -iv oracle-instantclient12.1-devel-12.1.0.2.0-1.x86_64.rpm
sudo alien -iv oracle-instantclient12.1-odbc-12.1.0.2.0-1.x86_64.rpm
sudo alien -iv oracle-instantclient12.1-precomp-12.1.0.2.0-1.x86_64.rpm
sudo alien -iv oracle-instantclient12.1-sqlplus-12.1.0.2.0-1.x86_64.rpm

# Extensions when using Oracle with GnuCobol
export ORACLE_HOME=/usr/lib/oracle/12.1/client64
export LD_LIBRARY_PATH=$ORACLE_HOME/lib:$LD_LIBRARY_PATH
export PATH=$PATH:$ORACLE_HOME/bin

# Oracle-sid and tnsnames.ora
export ORACLE_SID=MYORADB
export TWO_TASK=$ORACLE_SID

mkdir -p $ORACLE_HOME/network/admin
cd $ORACLE_HOME/network/admin

cat tnsnames.ora
MYORADB =
  (DESCRIPTION =
    (ADDRESS_LIST =
      (ADDRESS = (PROTOCOL = TCP)(HOST = host-db.test.xxx.at)(PORT = 1521))
    )
    (CONNECT_DATA =
      (SERVER = DEDICATED)
      (SERVICE_NAME = MYORADB)
    )
  )

procob OraSimple.pco oname=OraSimple.cbl

Pro*COBOL: Release 12.1.0.2.0 - Production on Do Nov 19 15:45:05 2015

Copyright (c) 1982, 2014, Oracle and/or its affiliates.  All rights reserved.

System-Standardoptionswerte aus:
  /usr/oraClnt/product/client-12.1.0.2_64/precomp/admin/pcbcfg.cfg

ls -la OraS*
-rw-rw-rw-    1 rpreh    seucc         16300 Nov 19 15:45 OraSimple.cbl
-rw-rw-rw-    1 rpreh    seucc          9255 Nov 19 15:45 OraSimple.lis
-rw-rw-rw-    1 rpreh    seucc          1368 Nov 19 15:44 OraSimple.pco

===> take the OraSimple.cbl File and transfer it to you
GnuCobol environment.

cobc -v -x -std=mf -P -ftraceall -debug -g OraSimple.cbl
  $ORACLE_HOME/lib/cobsqlintf.o -L/usr/local/lib -lcob -L$ORACLE_HOME/lib
  -lclntsh

reinhard@reinhard-CELSIUS-W530:$

cobc -v -x -std=mf -P -ftraceall -debug -g OraSimple.cbl
  $ORACLE_HOME/lib/cobsqlintf.o -L/usr/local/lib -lcob -L$ORACLE_HOME/lib -lclntsh
Command Line:cobc -v -x -std=mf -P -ftraceall -debug -g -L/usr/local/lib -lcob
   -L/usr/lib/oracle/12.1/client64/lib -lclntsh OraSimple.cbl
   /usr/lib/oracle/12.1/client64/lib/cobsqlintf.o
Preprocessing:OraSimple.cbl -> OraSimple.i
Return status:0Parsing:OraSimple.i (OraSimple.cbl)
Return status:0Translating:OraSimple.i -> OraSimple.c (OraSimple.cbl)
Executing:gcc -std=gnu99 -c -I/usr/local/include -pipe -Wno-unused
        -fsigned-char -Wno-pointer-sign -g -o "/tmp/cob22892_0.o"
        "OraSimple.c"
Return status:0Executing:gcc -std=gnu99 -Wl,--export-dynamic -o "OraSimple"
        "/tmp/cob22892_0.o"
        "/usr/lib/oracle/12.1/client64/lib/cobsqlintf.o"
        -L/usr/local/lib -lcob -lm -lgmp -lncurses -ldb -ldl -l"cob"
        -l"clntsh" -L"/usr/local/lib"
        -L"/usr/lib/oracle/12.1/client64/lib"
Return status:0

export COB_SET_TRACE=YES
export COB_TRACE_FILE=./my_cobol_trace.log
export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH

./OraSimple

reinhard@reinhard-CELSIUS-W530:~/gnu-cobol-2.0/ta2$ ./OraSimple
sqlcode connect +0000000000
ename SMITH    empno 7369
ename ALLEN    empno 7499
ename WARD     empno 7521
ename JONES    empno 7566
ename MARTIN   empno 7654
ename BLAKE    empno 7698
ename CLARK    empno 7782
ename SCOTT    empno 7788
ename KING     empno 7839
ename TURNER   empno 7844
ename ADAMS    empno 7876
ename JAMES    empno 7900
ename FORD     empno 7902
ename MILLER   empno 7934
ename Hofer    empno 1530

move 'scott' to hv-userid.
move 'tiger' to hv-passwd.

scott/tiger@MYORADB

reinhard@reinhard-CELSIUS-W530:~/gnu-cobol-2.0/ta2$ lsb_release -a
No LSB modules are available.
Distributor ID:Ubuntu
Description:Ubuntu 14.04.3 LTS
Release:14.04
Codename:trusty

Oracle*> OraSimple

       identification division.
       program-id. OraSimple.
       data division.
       working-storage section.

               exec sql begin declare section end-exec.

       01 hvs.
               05 hv-userid pic x(5).
               05 hv-passwd pic x(5).
               05 hv-ename pic x(8).
               05 hv-empno pic x(8).

               exec sql end declare section end-exec.

               exec sql include sqlca end-exec.

       procedure division.
       a-main section.
               move 'scott' to hv-userid.
               move 'tiger' to hv-passwd.
               exec sql connect :hv-userid identified by :hv-passwd
               end-exec.
               display 'sqlcode connect ' sqlcode.
               exec sql declare c1 cursor for
                       select ename,empno from emp
               end-exec
               exec sql open c1
               end-exec
               exec sql fetch c1 into
                       :hv-ename,:hv-empno
               end-exec
               perform until sqlcode not = 0
                       display 'ename ' hv-ename ' empno ' hv-empno
                       exec sql fetch c1 into
                               :hv-ename,:hv-empno
                       end-exec
               end-perform.
               stop run.

Simpleodbc

A preprocessor and a compile-time library
implementing an odbc interface, together with a
test program and free and fixed format test scripts
demonstrating and documenting the interface.

This software was written and tested using cobc
(GNU Cobol) 2.0.0 built Jan 28 2015 22:41:38 and
unixODBC-2.3.2 running under Ubuntu 14.04,
VMWARE and Windows 8.1 on a Lenovo G70 laptop.

Primary testing used Postgres 9.3 and the psqlODBC
driver accessing an 8.5 million row AllCities
WorldCity table and a 220 row Country table.

This odbc interface is not like other COBOL odbc
interfaces and is not intended to support existing
COBOL odbc code or statements.

Features

The preprocessor, library and test program
are written in free format COBOL.

The preprocessor accepts free and fixed format
and single and double quoted COBOL programs.

A supplied test script executes the free version of
the software.

A second supplied test script creates and executes
a fixed format version of the software.

The following limits can be changed by changing
pictures, occurs values and associated limit
values in the preprocessor and the libraries:

    100 host variables
    5 active connections
    10 active statements per connection
    100 bound parameters per statement
    100 bound columns per statement
    unbound row length 16384
    sql statement length 1024

connections have autocommit off by default

autocommit for a connection can be turned
on and off programmatically

The preprocessor, in addition to the usual
two parameters for input and output,
accepts an OPTIONAL diagnostic third parameter
consisting of any of the following letters
in any case and in any order

    d - dump the host variable definition table
    p - dump procedure definitions
    s - dump source input scan values
    r - display run-time diagnostics

the display of run-time diagnostics may also
be turned on and on procedurally at run-time

Connections, transactions and statements may be
prefixed by OPTIONAL 'in <connection>' and
'as <statement>' clauses which name the connection
and the statement or transaction.  This is to
identify multiple connections and multiple statements
per connection.

Subparagraphs may use 'in current' and 'as current'
to use the parent 'in' and 'as' values.

If you don't use the OPTIONAL 'in' and 'as features,
the connections, transactions and statements
are named 'default' and need not be specified.

A (named) transaction may reference multiple connections
and (named) rollbacks and (named) commits will honor
this (named) transaction.

The test program demonstrates the following features:

    perform test-driver
    perform test-datasource
    perform test-disconnect

    perform test-connect
    perform test-connect-dsn
    perform test-table

    perform test-select0
        select count(*) from worldcities
        select count(*) as rowcount1 from worldcities
    perform test-select1
        as cursor3 in connection1
        select * from worldcities
        where countrycode = 'DE'
        and population > 1000000
    perform test-select2
        as cursor3 in connection1
        select
            countrycode
           ,cc2
           ,country
        from worldcities
        inner join country on
        ISO = countrycode
        where countrycode = :countrycode
        and population > :population
    perform test-load
        start transaction
        truncate or create country table
        load country table from a file
        commit
    perform test-select3
        as cursor3 in connection1
        select
            geonameid
           ,name
           ,asciiname
           ,alternatenames
           ,latitude
           ,longitude
           ,featureclass
           ,featurecode
           ,countrycode
           ,cc2
           ,admin1code
           ,admin2code
           ,admin3code
           ,admin4code
           ,population
           ,elevation
           ,timezone
           ,modificationdate
        from worldcities
        where countrycode = :countrycode
        and population > :population
    perform test-select4
        two active statements, same connection

        as cursor3 in connection1
        select * from worldcities
        where countrycode = 'DE'
        and population > 1000000

        as cursor4 in connection1
        select * from worldcities
        where countrycode = 'FR'
        and population > 1000000
    perform test-select5
        two statements, different connections

        select * from worldcities
        where countrycode = 'DE'
        and population > 1000000
        (note the use of defaults here)

        as cursor1 in connection1
        select * from worldcities
        where countrycode = 'FR'
        and population > 1000000
    perform test-delete
        start a transaction

        delete the country table
        rollback

        delete countrycode = 'US'
        rollback
    perform test-update
        create and update a table and row
        with various data types
    perform test-dynamic
        create and execute sql statements
        and bound parameters directly

Bugs and Obscurities

    copy and include statements in an exec sql/end-sql
    block must be on a separate line

    64-bit odbc doesn't handle BINARY-DOUBLE/bigint
    postgresql doesn't have comps99/tinyint

    bound unsigned comp data returns in byte-reverse order

The preprocessor assumes the input source
is valid COBOL.  It will abort on

    identical input and output files

    the source is neither fixed nor free

    the usual invalid source type in column 7

    a single source line generating more than 500 lines

    odbc copy/include file error

    an unexpected data division statement
    (something in EXECUTE SQL DECLARE . . .)

    an unexpected data division level number
    (something in EXECUTE SQL DECLARE . . .)

    . . . not implemented . . .
    (some USAGE(s) in EXECUTE SQL DECLARE . . .)

    number of host variables exceeds . . .

    number of sql lines exceeds . . .

The compile libary will abort on

    SODBCAllocEnv failure (I've never seen this)

The test program will abort on

    failure to perform check-return after executing
    a procedural statement

    use of bigint in test-update (I don't remember the
    error, so try it yourself)

The compile library will issue the following messages:

    SOCN01 (named) connection exceeds . . .

    SOFC01 (named) connection not found

    SOAA01 (named) statement exceeds . . .

    SOST01 invalid statement handle

these won't be aborts, but they're not a good sign.

Getting Started

1.  Download and install the current version of
GNU COBOL 2.0

2.  download unixodbc from unixodbc.com and extract
./configure make
sudo make install

3. If you are on Ubuntu you already have some
version of Postgresql installed.

4. apt-get update
apt-get install postgresql postgresql-contrib
sudo -i -u postgres
createuser --interactive
\q

5. Create Drivers
sudo find / -name odbcinst.ini.template
sudo odbcinst -i -d -f /usr/share/psqlodbc/odbcinst.ini.template

for example:

[PostgreSQL ANSI]
Description     = PostgreSQL ODBC driver (ANSI version)
Driver          = /usr/lib/x86_64-linux-gnu/odbc/psqlodbca.so
Setup           = libodbcpsqlS.so
Debug           = 0
CommLog         = 1

[PostgreSQL Unicode]
Description     = PostgreSQL ODBC driver (Unicode version)
Driver          = /usr/lib/x86_64-linux-gnu/odbc/psqlodbcw.so
Setup           = libodbcpsqlS.so
Debug           = 0
CommLog         = 1

6.  Create a simple dsn

sudo odbcinst -i -s -f simpledsn

where simpledsn is a file containing:

[PostgresqlSimpleDSN]
Description         = PostgreSQL Simple
Driver              = PostgreSQL ANSI
Trace               = No
TraceFile           = /tmp/psqlodbc.log
Database            = simpledb
Servername          = localhost
UserName            = simpleuser
Password            = simplepassword
Port                = 5432
ReadOnly            = No
RowVersioning       = No
ShowSystemTables    = No
ShowOidColumn       = No
FakeOidIndex        = No
ConnSettings        =


**************************************
**Note:
**  postgresql template0 is a database
**  odbc template is an ini text file
**************************************

7.  Create the Test Database
psql (from command line)
createdb -T template0 simpledb;
/q

8. Create the Test User
psql simpledb
createuser simpleuser with password simplepassword;
/q

9.  Get the test data

Download and unzip allCountries.txt from
http://download.geonames.org/export/dump/

Download and unzip countryInfo.txt from
http://download.geonames.org/export/dump/

Note: The SODBCTest.cbl program assumes the
countryInfo.txt file is in the the test directory.
If not, modify the country-file-name value in
SODBCTest.cbl.

10.  Load the test data

psql simpledb (command line)

drop table worldcities;

create table worldcities(
    geonameid int
   ,name varchar(200)
   ,asciiname varchar(200)
   ,alternatenames varchar(8000)
   ,latitude varchar(10)
   ,longitude varchar(10)
   ,featureclass char(1)
   ,featurecode char(10)
   ,countrycode char(2)
   ,cc2 varchar(60)
   ,admin1code varchar(60)
   ,admin2code varchar(80)
   ,admin3code varchar(20)
   ,admin4code varchar(20)
   ,population numeric
   ,elevation varchar(6)
   ,dem varchar(6)
   ,timezone varchar(40)
   ,modificationdate char(10)
);

The following will take a few minutes

\copy worldcities from '/home/<your account>/. . ./allCountries.txt';

The following will take a few minutes

create index worldcities01 on worldcities(countrycode);

grant all privileges on worldcities to simpleuser;

\q

Note: This copy loads latitude, longitude and elevation
as VARCHAR so the following functions will be useful:

psql simpledb (command line)

    DROP FUNCTION todecimal(text);
    CREATE OR REPLACE FUNCTION todecimal(x text) RETURNS DECIMAL AS $$
    BEGIN
        RETURN CAST(x AS DECIMAL);
    EXCEPTION WHEN others THEN
        RETURN NULL;
    END;
    $$ LANGUAGE plpgsql IMMUTABLE;

and

    DROP FUNCTION toint(text);
    CREATE OR REPLACE FUNCTION toint(x text) RETURNS INT AS $$
    BEGIN
        RETURN CAST(x AS INT);
    EXCEPTION WHEN others THEN
        RETURN NULL;
    END;
    $$ LANGUAGE plpgsql IMMUTABLE;

and then

    the following will take a few minutes

    create index worldcities03 on
worldcities(todecimal(latitude),todecimal(longitude));

\q

11. Run the tests

    chmod +x SODBCTest.sh
    chmod +x SODBCTestFixed.sh

    ./SODBTest.sh > SODBCTest.txt
    less SODBCTest.txt

    (the tests produce lots of output)

    ./SODBCTestFixed.sh > SODBCTestFixed.txt
    less SODBCTestFixed.txt

*> ** >>SOURCE FORMAT IS FREE
*>
*> Test program for CobolSQLite3 [an SQLite3 Interface for GnuCOBOL 2.x].
*>
*> Written by Robert W.Mills, September 2017.
*>
*> Tectonics:
*>
*>   Install the SQLite3 library (sqlite.org), if required.
*>   prompt$ cobc -x -fdebugging-line CobolSQLite3-test.cob
*>   prompt$ export COB_PRE_LOAD=CobolSQLite3
*>   prompt$ ./CobolSQLite3-test

identification division.

  program-id.                          CobolSQLite3-test.

environment division.

  configuration section.

    repository.
      copy "CobolSQLite3-CSR.cpy".
      function all intrinsic.

data division.

  working-storage section.

    copy "CobolSQLite3-WS.cpy".

    01  foo-column-number.
      05  fcn-line-no                  pic s9(04) comp value 1.
      05  fcn-line-text                pic s9(04) comp value 2.

    01  sql-statements.
      05  create-table-foo             pic x(080) value
            "create table foo(line_no int, line_text text);".
      05  commit-sql                   pic x(080) value "commit;".
      05  insert-into-foo-1            pic x(088) value
            "insert into foo (line_no, line_text) values (1, 'this is line 1');".
      05  insert-into-foo-2            pic x(080) value
            "insert into foo (line_no, line_text) values (2, 'this is line 2');".
      05  insert-into-foo-3            pic x(080) value
            "insert into foo (line_no, line_text) values (3, 'this is line 3');".
      05  select-from-foo              pic x(080) value
            "select * from foo;".

    01  foo-heading-1.
      05                               pic x(001) value spaces.
      05  fh-line-no                   pic x(007) value "Line No".
      05                               pic x(003) value spaces.
      05  fh-line-text                 pic x(060) value "Line Text".
      05                               pic x(001) value spaces.

    01  foo-heading-2.
      05                               pic x(001) value spaces.
      05                               pic x(007) value all "-".
      05                               pic x(003) value spaces.
      05                               pic x(060) value all "-".
      05                               pic x(001) value spaces.

    01  foo-detail.
      05                               pic x(004) value spaces.
      05  fd-line-no                   pic Z(3)9(1).
      05                               pic x(003) value spaces.
      05  fd-line-text                 pic x(060).
      05                               pic x(001) value spaces.

procedure division.

testsqlite3-mainline.

>>D display "- opening database" end-display

  move "test.sdb" to db-name
  move DBOPEN(db-name) to db-object

  if DBSTATUS <> ZERO then
    display "DBOPEN: ", DBERRMSG end-display
    goback
  end-if

>>D display "- creating table foo" end-display

  if DBSQL(db-object, create-table-foo) <> ZERO then
    display "DBSQL (create table): ", DBERRMSG end-display
    goback
  end-if

>>D display "- adding record(s) to table foo" end-display

  if DBSQL(db-object, insert-into-foo-1) <> ZERO then
    display "DBSQL (insert 1): ", DBERRMSG end-display
    goback
  end-if

  if DBSQL(db-object, insert-into-foo-2) <> ZERO then
    display "DBSQL (insert 2): ", DBERRMSG end-display
    goback
  end-if

  if DBSQL(db-object, insert-into-foo-3) <> ZERO then
    display "DBSQL (insert 3): ", DBERRMSG end-display
    goback
  end-if

>>D display "- selecting all records from foo" end-display

  move DBCOMPILE(db-object, select-from-foo) to sql-object

  if DBSTATUS <> ZERO then
    display "DBCOMPILE (select foo): ", DBERRMSG end-display
    goback
  end-if

  move DBEXECUTE(sql-object) to db-status

  evaluate true

    when database-row-available

      perform print-column-headings

      perform get-print-data
        until sql-statement-finished

      display space end-display
      display "-- End of Report --" end-display

    when sql-statement-finished
      continue

    when database-lock-failed
      display "DBEXECUTE: ", DBERRMSG end-display
      goback

    when other
      display "DBEXECUTE: ", DBERRMSG end-display
      goback

  end-evaluate

  if DBRELEASE(sql-object) <> ZERO then
    display "DBRELEASE: ", DBERRMSG end-display
  end-if

>>D display "- closing database" end-display

  if DBCLOSE(db-object) <> ZERO then
    display "DBCLOSE: ", DBERRMSG end-display
  end-if

  move zero to return-code
  goback
  .

print-column-headings.

  *> Print the column heading lines.

  display foo-heading-1 end-display
  display foo-heading-2 end-display
  .

get-print-data.

  *> Get the line-no and line-text values.

  move DBGETINT(sql-object, fcn-line-no) to fd-line-no
  move DBGETSTR(sql-object, fcn-line-text) to fd-line-text

  *> Print the detail line.

  display foo-detail end-display

  *> Get the next row.

  move DBEXECUTE(sql-object) to db-status
  .

end program CobolSQLite3-test.

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* ================
      *><* indexing example
      *><* ================
      *><* :Author:    Brian Tiffin
      *><* :Date:      17-Feb-2009, 28-Jan-2014
      *><* :Purpose:   Demonstrate Indexed IO routines and START
      *><* :Tectonics: cobc -x indexing.cob
      *> ***************************************************************
       identification division.
       program-id. indexing.

       environment division.
       configuration section.

       input-output section.
       file-control.
          select optional indexed-file
          assign to "indexed-file.dat"
          status is indexing-status
          organization is indexed
          access mode is dynamic
          record key is keyfield of indexing-record
          alternate record key is altkey of indexing-record
              with duplicates
          .

      *> ** GnuCOBOL only supports split keys **
      *> **    in the reportwriter branch     **
      *> **        see second listing         **

      *>
      *>  alternate record key is splitkey
      *>      source is first-part of indexing-record
      *>                last-part of indexing-record
      *>      with duplicates

       data division.
       file section.
       fd indexed-file.
       01 indexing-record.
          03 keyfield          pic x(8).
          03 filler            pic x.
          03 altkey.
             05 first-part     pic 99.
             05 middle-part    pic x.
             05 last-part      pic 99.
          03 filler            pic x.
          03 data-part         pic x(52).

       working-storage section.
       01 indexing-status.
          03 high-status-code  pic xx.
          03 high-status redefines high-status-code pic 99.
             88 indexing-ok              values 0 thru 10.
          03 low-status-code   pic xx.
          03 low-status redefines low-status-code pic 99.


       01 display-record.
          03 filler            pic x(4)  value spaces.
          03 keyfield          pic x(8).
          03 filler            pic xx    value spaces.
          03 altkey.
             05 first-part     pic 99.
             05 filler         pic x     value space.
             05 middle-part    pic x.
             05 filler         pic x     value space.
             05 last-part      pic 99.
          03 filler            pic xx    value ", ".
          03 data-part         pic x(52).

      *> control break
       01 oldkey               pic 99x99.

      *> read control fields
       01 duplicate-flag       pic x.
          88 no-more-duplicates          value high-value
             when set to false is              low-value.
       01 record-flag          pic x.
          88 no-more-records             value high-value
             when set to false is              low-value.

      *> ***************************************************************
       procedure division.

      *> Populate a sample database, create or overwrite keys
       perform populate-sample

      *> clear the record space for this example
       move spaces to indexing-record

      *> open the data file again
       open i-o indexed-file
       perform indexing-check

      *> bail if things are going wrong
       if not indexing-ok then
           display "error opening for read pass, stopping" upon syserr
           stop run returning 1
       end-if

      *> read all the duplicate 00b02 keys
       move 00 to first-part of indexing-record
       move "b" to middle-part of indexing-record
       move 02 to last-part of indexing-record

      *> using read key and then next key / last key compare
       set no-more-duplicates to false

       display "Read all 00b02 keys sequentially" end-display
       perform read-indexing-record
       perform read-next-record
           until no-more-duplicates
       display space end-display

      *> read by key of reference ... the cool stuff
       move 00 to first-part of indexing-record
       move "a" to middle-part of indexing-record
       move 02 to last-part of indexing-record
       set no-more-records to false

      *> using start and read next
       display "Read all alternate keys greater than 00a02" end-display
       perform start-at-key
       perform read-next-by-key
           until no-more-records
       display space end-display

      *> read by primary key of reference
       move "87654321" to keyfield of indexing-record
       set no-more-records to false

      *> using start and previous by key
       display
           "Read all primary keys less than "
           keyfield of indexing-record
       end-display
       perform start-prime-key
       perform read-previous-by-key
           until no-more-records
       display space end-display

      *> and with that we are done with indexing sample
       close indexed-file

       goback.
      *> ***************************************************************

      *> ***************************************************************
      *><* read by alternate key paragraph
       read-indexing-record.
           display "Reading: " altkey of indexing-record end-display
           read indexed-file key is altkey of indexing-record
               invalid key
                   display
                       "bad read key: " altkey of indexing-record
                       upon syserr
                   end-display
               set no-more-duplicates to true
           end-read
           perform indexing-check
       .

      *><* read next sequential paragraph
       read-next-record.
           move corresponding indexing-record to display-record
           display display-record end-display
           move altkey of indexing-record to oldkey

           read indexed-file next record
               at end set no-more-duplicates to true
               not at end
                   if oldkey not equal altkey of indexing-record
                       set no-more-duplicates to true
                   end-if
           end-read
           perform indexing-check
       .

      *><* start primary key of reference paragraph
       start-prime-key.
           display "Prime < " keyfield of indexing-record end-display
           start indexed-file
              key is less than
                  keyfield of indexing-record
              invalid key
                  display
                      "bad start: " keyfield of indexing-record
                      upon syserr
                  end-display
                  set no-more-records to true
              not invalid key
                  read indexed-file previous record
                      at end set no-more-records to true
                  end-read
           end-start
           perform indexing-check
       .

      *><* read previous by key of reference paragraph
       read-previous-by-key.
           move corresponding indexing-record to display-record
           display display-record end-display

           read indexed-file previous record
               at end set no-more-records to true
           end-read
           perform indexing-check
       .
      *><* start alternate key of reference paragraph
       start-at-key.
           display "Seeking >= " altkey of indexing-record end-display
           start indexed-file
              key is greater than or equal to
                  altkey of indexing-record
              invalid key
                  display
                      "bad start: " altkey of indexing-record
                      upon syserr
                  end-display
                  set no-more-records to true
              not invalid key
                  read indexed-file next record
                      at end set no-more-records to true
                  end-read
           end-start
           perform indexing-check
       .

      *><* read next by key of reference paragraph
       read-next-by-key.
           move corresponding indexing-record to display-record
           display display-record end-display

           read indexed-file next record
               at end set no-more-records to true
           end-read
           perform indexing-check
       .

      *><* populate a sample database
       populate-sample.

      *> Open optional index file for read write
           open i-o indexed-file
           perform indexing-check

           move "12345678 00a01 some 12345678 data" to indexing-record
           perform write-indexing-record
           move "87654321 00a01 some 87654321 data" to indexing-record
           perform write-indexing-record
           move "12348765 00a01 some 12348765 data" to indexing-record
           perform write-indexing-record
           move "87651234 00a01 some 87651234 data" to indexing-record
           perform write-indexing-record

           move "12345679 00b02 some 12345679 data" to indexing-record
           perform write-indexing-record
           move "97654321 00b02 some 97654321 data" to indexing-record
           perform write-indexing-record
           move "12349765 00b02 some 12349765 data" to indexing-record
           perform write-indexing-record
           move "97651234 00b02 some 97651234 data" to indexing-record
           perform write-indexing-record

           move "12345689 00c13 some 12345689 data" to indexing-record
           perform write-indexing-record
           move "98654321 00c13 some 98654321 data" to indexing-record
           perform write-indexing-record
           move "12349865 00c13 some 12349865 data" to indexing-record
           perform write-indexing-record
           move "98651234 00c13 some 98651234 data" to indexing-record
           perform write-indexing-record

      *> close it ... not necessary, but for the example we will
           close indexed-file
           perform indexing-check
       .

      *><* Write paragraph
       write-indexing-record.
           write indexing-record
               invalid key
                   display
                       "rewriting key: " keyfield of indexing-record
                       upon syserr
                   end-display
                   rewrite indexing-record
                       invalid key
                           display
                               "really bad key: "
                               keyfield of indexing-record
                               upon syserr
                           end-display
                   end-rewrite
           end-write
       .

      *><* file status quick check.  For this sample, keep running
       indexing-check.
           if not indexing-ok then
               display
                   "isam file io problem: " indexing-status
                   upon syserr
               end-display
           end-if
       .

       end program indexing.
      *><*
      *><* Last Update: 20140128

Read all 00b02 keys sequentially
Reading: 00b02
    12345679  00 b 02, some 12345679 data
    97654321  00 b 02, some 97654321 data
    12349765  00 b 02, some 12349765 data
    97651234  00 b 02, some 97651234 data

Read all alternate keys greater than 00a02
Seeking >= 00a02
    12345679  00 b 02, some 12345679 data
    97654321  00 b 02, some 97654321 data
    12349765  00 b 02, some 12349765 data
    97651234  00 b 02, some 97651234 data
    12345689  00 c 13, some 12345689 data
    98654321  00 c 13, some 98654321 data
    12349865  00 c 13, some 12349865 data
    98651234  00 c 13, some 98651234 data

Read all primary keys less than 87654321
Prime < 87654321
    87651234  00 a 01, some 87651234 data
    12349865  00 c 13, some 12349865 data
    12349765  00 b 02, some 12349765 data
    12348765  00 a 01, some 12348765 data
    12345689  00 c 13, some 12345689 data
    12345679  00 b 02, some 12345679 data
    12345678  00 a 01, some 12345678 data

rewriting key: 12345678
rewriting key: 87654321
rewriting key: 12348765
rewriting key: 87651234
rewriting key: 12345679
rewriting key: 97654321
rewriting key: 12349765
rewriting key: 97651234
rewriting key: 12345689
rewriting key: 98654321
rewriting key: 12349865
rewriting key: 98651234

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* =======================================
      *><* indexing example with split key support
      *><* =======================================
      *><* :Author:    Brian Tiffin
      *><* :Date:      17-Feb-2009, 28-Jan-2014
      *><* :Modified:  2015-05-28 22:38 EDT, Thursday
      *><* :Purpose:   Demonstrate Indexed IO routines and START
      *><* :Tectonics: cobc -x indexing.cob
      *> ***************************************************************
       identification division.
       program-id. indexing.

       environment division.
       configuration section.

       input-output section.
       file-control.
          select optional indexed-file
          assign to "indexed-file.dat"
          status is indexing-status
          organization is indexed
          access mode is dynamic
          record key is keyfield of indexing-record
          alternate record key is split-key
              source is first-part of indexing-record
                        last-part of indexing-record
              with duplicates
          .

       data division.
       file section.
       fd indexed-file.
       01 indexing-record.
          03 keyfield          pic x(8).
          03 filler            pic x.
          03 altkey.
             05 first-part     pic 99.
             05 middle-part    pic x.
             05 last-part      pic 99.
          03 filler            pic x.
          03 data-part         pic x(52).

       working-storage section.
       01 indexing-status.
          03 high-status       pic 99.
             88 indexing-ok              values 0 thru 10.
          03 low-status        pic 99.

       01 display-record.
          03 filler            pic x(4)  value spaces.
          03 keyfield          pic x(8).
          03 filler            pic xx    value spaces.
          03 altkey.
             05 first-part     pic 99.
             05 filler         pic x     value space.
             05 middle-part    pic x.
             05 filler         pic x     value space.
             05 last-part      pic 99.
          03 filler            pic xx    value ", ".
          03 data-part         pic x(52).

      *> alternate key control break, split-key is two pic 99 fields.
       01 oldkey               pic 9999.

      *> read control fields
       01 duplicate-flag       pic x.
          88 no-more-duplicates          value high-value
             when set to false is              low-value.
       01 record-flag          pic x.
          88 no-more-records             value high-value
             when set to false is              low-value.

      *> ***************************************************************
       procedure division.

      *> Populate a sample database, create or overwrite keys
       perform populate-sample

      *> clear the record space for this example
       move spaces to indexing-record

      *> open the data file again
       open i-o indexed-file
       perform indexing-check

      *> read all the duplicate 0002 keys
       move 00 to first-part of indexing-record
       move "b" to middle-part of indexing-record
       move 02 to last-part of indexing-record

      *> load key space
       move function concatenate(first-part of indexing-record,
           last-part of indexing-record)
          to split-key

      *> using read key and then next key / last key compare
       set no-more-duplicates to false

       display "Read all 00b02 keys sequentially" end-display
       perform read-indexing-record
       perform read-next-record
           until no-more-duplicates
       display space end-display

      *> read by key of reference ... the cool stuff
       move 00 to first-part of indexing-record
       move "a" to middle-part of indexing-record
       move 02 to last-part of indexing-record
       set no-more-records to false

      *> using start and read next
       display "Read all alternate keys greater than 0002" end-display
       perform start-at-key
       perform read-next-by-key
           until no-more-records
       display space end-display

      *> read by primary key of reference
       move "87654321" to keyfield of indexing-record
       set no-more-records to false

      *> using start and previous by key
       display
           "Read all primary keys less than "
           keyfield of indexing-record
       end-display
       perform start-prime-key
       perform read-previous-by-key
           until no-more-records
       display space end-display

      *> and with that we are done with indexing sample
       close indexed-file

       goback.
      *> ***************************************************************

      *> ***************************************************************
      *><* read by alternate key paragraph
       read-indexing-record.
           display
               "Reading: " split-key " from " altkey of indexing-record
           end-display
           read indexed-file key is split-key
               invalid key
                   display
                       "bad read key: " split-key
                       upon syserr
                   end-display
               set no-more-duplicates to true
           end-read
           perform indexing-check
       .

      *><* read next sequential paragraph
       read-next-record.
           move corresponding indexing-record to display-record
           display display-record end-display
           *> move altkey of indexing-record to oldkey
           move split-key to oldkey

           read indexed-file next record
               at end set no-more-duplicates to true
               not at end
                   move function concatenate(
                       first-part of indexing-record,
                       last-part of indexing-record)
                     to split-key
                   if oldkey not equal split-key
                       set no-more-duplicates to true
                   end-if
           end-read
           perform indexing-check
       .

      *><* start primary key of reference paragraph
       start-prime-key.
           display "Prime < " keyfield of indexing-record end-display
           start indexed-file
              key is less than
                  keyfield of indexing-record
              invalid key
                  display
                      "bad start: " keyfield of indexing-record
                      upon syserr
                  end-display
                  set no-more-records to true
              not invalid key
                  read indexed-file previous record
                      at end set no-more-records to true
                  end-read
           end-start
           perform indexing-check
       .

      *><* read previous by key of reference paragraph
       read-previous-by-key.
           move corresponding indexing-record to display-record
           display display-record end-display

           read indexed-file previous record
               at end set no-more-records to true
           end-read
           perform indexing-check
       .
      *><* start alternate key of reference paragraph
       start-at-key.
           display "Seeking >= " split-key end-display
           start indexed-file
              key is greater than or equal to
                  split-key
              invalid key
                  display
                      "bad start: " split-key
                      upon syserr
                  end-display
                  set no-more-records to true
              not invalid key
                  read indexed-file next record
                      at end set no-more-records to true
                  end-read
           end-start
           perform indexing-check
       .

      *><* read next by key of reference paragraph
       read-next-by-key.
           move corresponding indexing-record to display-record
           display display-record end-display

           read indexed-file next record
               at end set no-more-records to true
           end-read
           perform indexing-check
       .

      *><* populate a sample database
       populate-sample.

      *> Open optional index file for read write
           open i-o indexed-file
           perform indexing-check

           move "12345678 00a01 some 12345678 data" to indexing-record
           perform write-indexing-record
           move "87654321 00a01 some 87654321 data" to indexing-record
           perform write-indexing-record
           move "12348765 00a01 some 12348765 data" to indexing-record
           perform write-indexing-record
           move "87651234 00a01 some 87651234 data" to indexing-record
           perform write-indexing-record

           move "12345679 00b02 some 12345679 data" to indexing-record
           perform write-indexing-record
           move "97654321 00b02 some 97654321 data" to indexing-record
           perform write-indexing-record
           move "12349765 00b02 some 12349765 data" to indexing-record
           perform write-indexing-record
           move "97651234 00b02 some 97651234 data" to indexing-record
           perform write-indexing-record

           move "12345689 00c13 some 12345689 data" to indexing-record
           perform write-indexing-record
           move "98654321 00c13 some 98654321 data" to indexing-record
           perform write-indexing-record
           move "12349865 00c13 some 12349865 data" to indexing-record
           perform write-indexing-record
           move "98651234 00c13 some 98651234 data" to indexing-record
           perform write-indexing-record

      *> close it ... not necessary, but for the example we will
           close indexed-file
           perform indexing-check
       .

      *><* Write paragraph
       write-indexing-record.
           write indexing-record
               invalid key
                   display
                       "rewriting key: " keyfield of indexing-record
                       upon syserr
                   end-display
                   rewrite indexing-record
                       invalid key
                           display
                               "really bad key: "
                               keyfield of indexing-record
                               upon syserr
                           end-display
                   end-rewrite
           end-write
       .

      *><* file status quick check.  For this sample, keep running
       indexing-check.
           if not indexing-ok then
               display
                   "isam file io problem: " indexing-status
                   upon syserr
               end-display
           end-if
       .

       end program indexing.
      *><*
      *><* Last Update: 20150528

                            VBISAM - ISAM File handler
               http://sourceforge.net/projects/vbisam

VBISAM is a replacement for IBM's C-ISAM.
(Version 2 by Roger While)

All programs are distributed under either the GNU General Public
License or the GNU Lesser General Public License.
See COPYING and COPYING.LIB for details.

Authors:
* Trevor van Bremen <trev_vb@users.sourceforge.net> wrote
  VBISAM.
* Roger While <simrw@users.sourceforge.net> autoconf'd/libtoolized
  it. Also major code restructure.

Requirements
============

VBISAM only requires a working C development system.

Installation
============

See INSTALL for general installation instruction.  Typically,
this is done by the following commands:

    ./configure
    make
    make install

The default target for installed files is "/usr/local".

Other than the usual configure options (./configure --help)
there are the following specific VBISAM configure options:

  --with-cisamcompat    use VBISAM C-ISAM comatibility mode
  --with-lfs64          use large file system for file I/O (default)
  --with-debug          Enable debugging mode

To squeeze extra performance out of the code, you may want to
do for the install eg :
make install-strip


Development
===========

You need to install the following extra packages with specified
minumum version before hacking VBISAM configure/makefile files:

  o Autoconf 2.59
  o Automake 1.9.6
  o Libtool 1.5.24
  o m4 1.4

Run "autoreconf -ifv -I m4" to regenerate configure/makefile scripts.
You need to run autoreconf whenever you modify configure.ac
or Makefile.am.

$ cobc -b hello.cob goodbye.cob

$ cobc -x -lcurl showcurl.cob

$ cobc occurl.c
$ cobc occgi.c
$ cobc -x myprog.cob
$ export COB_PRE_LOAD=occurl:occgi
$ ./myprog

This relates to LINKAGE items that are NOT referred
to in the USING phrase of the PROCEDURE DIVISION.
It also only has relevance when the program is CALL'ed
from another prog.
This means that the addressability of these items must
be programmed (usually with SET ADDRESS) before reference.

Per default, the item loses its addressability on exit
from the program. This option causes the module to retain
the item's address between CALL invocations of the program.

/* GnuCOBOL access to POSIX Message Queues                  */
/* Author: Brian Tiffin                                     */
/* Date:   August, 2008                                     */
/* Build:  gcc -c ocmq.c                                    */
/* Usage:  cobc -x -lrt program.cob ocmq.o                  */

#include <fcntl.h>           /* For O_* constants */
#include <sys/stat.h>        /* For mode constants */
#include <errno.h>           /* Access to error values */
#include <mqueue.h>          /* The message queues */
#include <signal.h>          /* for notification */
#include <time.h>            /* for the timed versions */
#include <stdio.h>
#include <string.h>          /* For strerror */

#include <libcob.h>          /* for cob_resolve */

/* Forward declarations */
static void ocmq_handler(int, siginfo_t *, void *);
static void (*MQHANDLER)(int *mqid);

/* Return C runtime global errno */
int ERRORNUMBER() {
    return errno;
}

/* Load a COBOL field with an error string */
int ERRORSTRING(char *errbuff, int buflen) {
    void *temperr;

    temperr = strerror(errno);
    memcpy((void *)errbuff, temperr, buflen);
    return strlen(temperr);
}

/*

/* Open Message Queue */
int MQOPEN(char *mqname, int oflags) {
    mqd_t mqres;

    errno = 0;
    mqres = mq_open(mqname, oflags);
    return (int)mqres;
}

/* Creating a queue requires two extra arguments, permissions and attributes */
int MQCREATE(char *mqname, int oflags, int perms, char *mqattr) {
    mqd_t mqres;

    errno = 0;
    mqres = mq_open(mqname, oflags, (mode_t)perms, (struct mq_attr *)mqattr);
    return (int)mqres;
}

/* Get current queue attributes */
int MQGETATTR(int mqid, char *mqattr) {
    mqd_t mqres;

    errno = 0;
    mqres = mq_getattr((mqd_t)mqid, (struct mq_attr *)mqattr);
    return (int)mqres;
}

/* Set current queue attributes */
/*   only accepts mqflags of 0 or MQO-NONBLOCK once created */
int MQSETATTR(int mqid, char *mqattr, char *oldattr) {
    mqd_t mqres;

    errno = 0;
    mqres = mq_setattr((mqd_t)mqid, (struct mq_attr *)mqattr, (struct mq_attr *)oldattr);
    return (int)mqres;
}

/* Send a message to the queue */
int MQSEND(int mqid, char *message, int length, unsigned int mqprio) {
    mqd_t mqres;

    errno = 0;
    mqres = mq_send((mqd_t)mqid, message, (size_t)length, mqprio);
    return (int)mqres;
}

/* Read the highest priority message */
int MQRECEIVE(int mqid, char *msgbuf, int buflen, int *retprio) {
    ssize_t retlen;

    errno = 0;
    retlen = mq_receive((mqd_t)mqid, msgbuf, buflen, retprio);
    return (int)retlen;
}

/* Timeout send */
int MQTIMEDSEND(int mqid, char *message, int length,
                unsigned int mqprio, int secs, long nanos) {

    mqd_t mqres;
    struct timespec mqtimer;
    struct timeval curtime;

    /* Expect seconds and nanos to wait, not absolute.  Add the GnuCOBOL values */
    gettimeofday(&curtime, NULL);
    mqtimer.tv_sec = curtime.tv_sec + (time_t)secs;
    mqtimer.tv_nsec = nanos;

    errno = 0;
    mqres = mq_timedsend((mqd_t)mqid, message, (size_t)length, mqprio, &mqtimer);
    return (int)mqres;
}

/* Read the highest priority message */
int MQTIMEDRECEIVE(int mqid, char *msgbuf, int buflen,
                   int *retprio, int secs, long nanos) {
    ssize_t retlen;
    struct timespec mqtimer;

    struct timeval curtime;

    /* Expect seconds and nanos to wait, not absolute.  Add the GnuCOBOL values */
    gettimeofday(&curtime, NULL);
    mqtimer.tv_sec = curtime.tv_sec + (time_t)secs;
    mqtimer.tv_nsec = nanos;

    errno = 0;
    retlen = mq_timedreceive((mqd_t)mqid, msgbuf, buflen, retprio, &mqtimer);
    return (int)retlen;
}


/* Notify of new message written to queue */
int MQNOTIFY(int mqid, char *procedure) {
    struct sigevent ocsigevent;
    struct sigaction ocsigaction;

    /* Install signal handler for the notify signal - fill in a
     * sigaction structure and pass it to sigaction(). Because the
     * handler needs the siginfo structure as an argument, the
     * SA_SIGINFO flag is set in sa_flags.
     */
    ocsigaction.sa_sigaction = ocmq_handler;
    ocsigaction.sa_flags = SA_SIGINFO;
    sigemptyset(&ocsigaction.sa_mask);

    if (sigaction(SIGUSR1, &ocsigaction, NULL) == -1) {
        fprintf(stderr, "%s\n", "Error posting sigaction");
        return -1;
    }

    /* Set up notification: fill in a sigevent structure and pass it
     * to mq_notify(). The queue ID is passed as an argument to the
     * signal handler.
     */
    ocsigevent.sigev_signo      = SIGUSR1;
    ocsigevent.sigev_notify     = SIGEV_SIGNAL;
    ocsigevent.sigev_value.sival_int = (int)mqid;

    if (mq_notify((mqd_t)mqid, &ocsigevent) == -1) {
        fprintf(stderr, "%s\n", "Error posting notify");
        return -1;
    }
    return 0;
}

/* Close a queue */
int MQCLOSE(int mqid) {
    mqd_t mqres;

    errno = 0;
    mqres = mq_close((mqd_t)mqid);
    return (int)mqres;
}

/* Unlink a queue */
int MQUNLINK(char *mqname) {
    mqd_t mqres;

    errno = 0;
    mqres = mq_unlink(mqname);
    return (int)mqres;
}

/* The signal handling section */
/* signal number */
/* signal information */
/* context unused (required by posix) */
static void ocmq_handler(int sig, siginfo_t *pInfo, void *pSigContext) {
    struct sigevent ocnotify;
    mqd_t mqid;

    /* Get the ID of the message queue out of the siginfo structure.     */
    mqid = (mqd_t) pInfo->si_value.sival_int;

    /* The MQPROCESSOR is a hardcoded GnuCOBOL resolvable module name */
    /*   It must accept an mqd_t pointer  */
    cob_init(0, NULL);
    MQHANDLER = cob_resolve("MQPROCESSOR");
    if (MQHANDLER == NULL) {
        /* What to do here? */
        fprintf(stderr, "%s\n", "Error resolving MQPROCESSOR");
        return;
    }

    /* Request notification again; it resets each time a notification
     * signal goes out.
     */
    ocnotify.sigev_signo = pInfo->si_signo;
    ocnotify.sigev_value = pInfo->si_value;
    ocnotify.sigev_notify = SIGEV_SIGNAL;

    if (mq_notify(mqid, &ocnotify) == -1) {
        /* What to do here? */
        fprintf(stderr, "%s\n", "Error posting notify");
        return;
    }

    /* Call the cobol module with the message queue id */
    MQHANDLER(&mqid);
    return;
}
/**/

GCobol >>SOURCE FORMAT IS FIXED
      ******************************************************************
      * Author:    Brian Tiffin
      * Date:      August 2008
      * Purpose:   Demonstration of GnuCOBOL message queues
      * Tectonics: gcc -c ocmq.c
      *            cobc -Wall -x -lrt mqsample.cob ocmq.o
      ******************************************************************
       identification division.
       program-id. mqsample.

       data division.
       working-storage section.
      * Constants for the Open Flags
       01 MQO-RDONLY           constant as 0.
       01 MQO-WRONLY           constant as 1.
       01 MQO-RDWR             constant as 2.
       01 MQO-CREAT            constant as 64.
       01 MQO-EXCL             constant as 128.
       01 MQO-NONBLOCK         constant as 2048.
      * Constants for the protection/permission bits
       01 MQS-IREAD            constant as 256.
       01 MQS-IWRITE           constant as 128.

      * Need a better way of displaying newlines
       01 newline              pic x value x'0a'.

      * Message Queues return an ID, maps to int
       01 mqid                 usage binary-long.
       01 mqres                usage binary-long.
      * Queue names end up in an mqueue virtual filesystem on GNU/Linux
       01 mqname.
          02 name-display      pic x(5) value "/ocmq".
          02 filler            pic x value x'00'.
       01 mqopenflags          usage binary-long.
       01 mqpermissions        usage binary-long.

       01 default-message      pic x(20) value 'GnuCOBOL is awesome'.
       01 user-message         pic x(80).
       01 send-length          usage binary-long.

       01 urgent-message       pic x(20) value 'Urgent GnuCOBOL msg'.

      * Data members for access to C global errno and error strings
       01 errnumber            usage binary-long.
       01 errstr               pic x(256).
      * legend to use with the error reporting
       01 operation            pic x(7).

       01 loopy                pic 9.

      * Debian GNU/Linux defaults to Message Queue entry limit of 8K
       01 msgbuf               pic x(8192).
       01 msglen               usage binary-long value 8192.
      * Priorities range from 0 to 31 on many systems, can be more
       01 msgprio              usage binary-long.
      * MQ attributes.  See /usr/include/bits/mqueue.h
       01 mqattr.
          03 mqflags           usage binary-long.
          03 mqmaxmsg          usage binary-long.
          03 mqmsgsize         usage binary-long.
          03 mqcurmsqs         usage binary-long.
          03 filler            usage binary-long occurs 4 times.
       01 oldattr.
          03 mqflags           usage binary-long.
          03 mqmaxmsg          usage binary-long.
          03 mqmsgsize         usage binary-long.
          03 mqcurmsqs         usage binary-long.
          03 filler            usage binary-long occurs 4 times.

       procedure division.
      * The ocmq API support MQCREATE and MQOPEN.
      * This example uses non blocking, non exclusive create
      *   read/write by owner and default attributes
       compute
           mqopenflags = MQO-RDWR + MQO-CREAT + MQO-NONBLOCK
       end-compute.
       compute
           mqpermissions = MQS-IREAD + MQS-IWRITE
       end-compute.

      * Sample shows the two types of open, but only evaluates create
       if zero = zero
       call "MQCREATE" using mqname
                           by value mqopenflags
                           by value mqpermissions
                           by value 0
                       returning mqid
       end-call
       else
       call "MQOPEN" using mqname
                         by value mqopenflags
                     returning mqid
       end-call
       end-if.
       move "create" to operation.
       perform show-error.

      * Show the attributes after initial create
       perform show-attributes.

      * Register notification
       call "MQNOTIFY" using by value mqid
                       mqname
                       returning mqres
       end-call.
       move "notify" to operation.
       perform show-error.

      * Create a temporary queue, will be removed on close
      * call "MQUNLINK" using mqname
      *                returning mqres
      * end-call.
      * move "unlink" to operation.
      * perform show-error.

      * Use the command line arguments or a default message
       accept user-message from command-line end-accept.
       if user-message equal spaces
           move default-message to user-message
       end-if.
       move function length
           (function trim(user-message trailing))
           to send-length.

      * Queue up an urgent message (priority 31)
       call "MQSEND" using by value mqid
                           by reference urgent-message
                           by value 20
                           by value 31
       end-call.
       move "send-31" to operation.
       perform show-error.

      * Queue up a low priority message (1)
       call "MQSEND" using by value mqid
                           by reference user-message
                           by value send-length
                           by value 1
                     returning mqres
       end-call.
       move "send-1" to operation.
       perform show-error.

      * Queue up a middle priority message (16)
       inspect urgent-message
           replacing leading "Urgent" by "Middle".
       call "MQSEND" using by value mqid
                           by reference urgent-message
                           by value 20
                           by value 16
                     returning mqres
       end-call.
       move "send-16" to operation.
       perform show-error.

      * Redisplay the queue attributes
       perform show-attributes.

      * Pull highest priority message off queue
       call "MQRECEIVE" using by value mqid
                            by reference msgbuf
                            by value msglen
                            by reference msgprio
                        returning mqres
       end-call.
       display
           newline "receive len: " mqres " prio: " msgprio
       end-display.
       if mqres > 0
           display
               "priority 31 message: " msgbuf(1:mqres)
           end-display
       end-if.
       move "receive" to operation.
       perform show-error.

      * Pull the middling priority message off queue
       call "MQRECEIVE" using by value mqid
                            by reference msgbuf
                            by value msglen
                            by reference msgprio
                        returning mqres
       end-call.
       display
           newline "receive len: " mqres " prio: " msgprio
       end-display.
       if mqres > 0
           display
               "priority 16 message: " msgbuf(1:mqres)
           end-display
       end-if.
       move "receive" to operation.
       perform show-error.

      * ** INTENTIONAL ERROR msglen param too small **
      * Pull message off queue
       call "MQRECEIVE" using by value mqid
                            by reference msgbuf
                            by value 1024
                            by reference msgprio
                        returning mqres
       end-call.
       display
           newline "receive len: " mqres " prio: " msgprio
       end-display.
       if mqres > 0
           display
               "no message: " msgbuf(1:mqres)
           end-display
       end-if.
       move "receive" to operation.
       perform show-error.

      * Pull the low priority message off queue, in blocking mode
       move MQO-NONBLOCK to mqflags of mqattr.
       call "MQSETATTR" using by value mqid
                            by reference mqattr
                            by reference oldattr
                        returning mqres
       end-call
       move "setattr" to operation.
       perform show-error.
       perform show-attributes.

       call "MQRECEIVE" using by value mqid
                            by reference msgbuf
                            by value msglen
                            by reference msgprio
                        returning mqres
       end-call.
       display
           newline "receive len: " mqres " prio: " msgprio
       end-display.
       if mqres > 0
           display
               "priority 1 message: " msgbuf(1:mqres)
           end-display
       end-if.
       move "receive" to operation.
       perform show-error.

       perform varying loopy from 1 by 1
           until loopy > 5
               display "Sleeper call " loopy end-display
               call "CBL_OC_NANOSLEEP" using 50000000000
                                       returning mqres
               end-call
       end-perform.

      * Close the queue.  As it is set unlinked, it will be removed
       call "MQCLOSE" using by value mqid
                      returning mqres
       end-call.
       move "close" to operation.
       perform show-error.

      * Create a temporary queue, will be removed on close
       call "MQUNLINK" using mqname
                       returning mqres
       end-call.
       move "unlink" to operation.
       perform show-error.

       goback.

      ******************************************************************
      * Information display of the Message Queue attributes.
       show-attributes.
       call "MQGETATTR" using by value mqid
                            by reference mqattr
                        returning mqres
       end-call
       move "getattr" to operation.
       perform show-error.

      * Display the message queue attributes
       display
           name-display " attributes:"       newline
           "flags:    " mqflags   of mqattr  newline
           "max msg:  " mqmaxmsg  of mqattr  newline
           "mqs size: " mqmsgsize of mqattr  newline
           "cur msgs: " mqcurmsqs of mqattr
       end-display
       .

      * The C global errno error display paragraph
       show-error.
           call "ERRORNUMBER" returning mqres end-call
           if mqres > 0
               display
                   operation " errno: " mqres
               end-display
               call "ERRORSTRING" using errstr
                                      by value length errstr
                                  returning mqres end-call
               if mqres > 0
                   display
                       "     strerror: " errstr(1:mqres)
                   end-display
               end-if
           end-if
       .
       end program mqsample.

      ******************************************************************
      * Author:    Brian Tiffin
      * Date:      August 2008
      * Purpose:   Demonstration of GnuCOBOL message queue notification
      * Tectonics: gcc -c ocmq.c
      *            cobc -Wall -x -lrt mqsample.cob ocmq.o
      ******************************************************************
       identification division.
       program-id. MQSIGNAL.

       data division.
       working-storage section.
       01 msgbuf pic x(8192).
       01 msglen usage binary-long value 8192.
       01 msgprio usage binary-long.
       01 mqres  usage binary-long.

       linkage section.
       01 mqid usage binary-long.

       procedure division using mqid.

       display "in MQSIGNAL".
       display "In the COBOL procedure with " mqid end-display.
       perform
           with test after
           until mqres <= 0

           call "MQRECEIVE" using by value mqid
                                by reference msgbuf
                                by value msglen
                                by reference msgprio
                            returning mqres
           end-call
           display
               "receive len: " mqres " prio: " msgprio
           end-display
           if mqres > 0
               display
                   "priority 31 message: " msgbuf(1:mqres)
               end-display
           end-if
       end-perform.

       goback.
       end program MQSIGNAL.

GCOB  *>-<*
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      *>
      *> Date started: June 2017
      *> Modified: 2017-06-25/04:30-0400 btiffin
      *>+<*
      *>
      *> lua.cob, intrinsic Lua demo
      *> Tectonics: cobc -xj lua.cob
      *>
       >>SOURCE FORMAT IS FREE
       identification division.
       program-id. sample.

       REPLACE ==newline== BY ==& x'0a' &==.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       COPY luaapi.

       01 extraneous pic x.
       01 comparator pic 9(2).

       procedure division.
       sample-main.
      *> mandatory intro
       move lua("print 'Hello, world'") to extraneous

      *> ref mod
       display ":" lua("return 'abc'")(2:1) ":"

      *> persistent
       display ":" lua("return 'abc'") ":"
       display ":" lua("a = 'abcdef'; return a") ":"
       display ":" lua("return a") ":"

      *> non persistent across close
       display ":" lua(LUA-COMMAND-CLOSE) ": close"
       display ":" lua("return a") ": want empty"

      *> syntax error
       display ":" lua("text")(1:1) ": want error"
       display exception-status
       display script-return-code

       display ":" lua("n = 5") ": want empty"
       display ":" lua("5 , ") ": want error"
       display exception-status
       display script-return-code

      *> SUBJECT TO CHANGE *<
      *> multiple returns, top is resulting value
       display ":" lua("return 11,22,33,44") ":"

      *> request stack dump
       move lua(LUA-COMMAND-STACKDUMP) to extraneous

      *> get entry n from stack relative from top
      *>   (negative value "commands")
      *> needs to be a string, a raw value will be passed in the field
      *>   as sign trailing...
       display ":" lua("-2") ":"
       display ":" lua("-2") ":"

      *> request stack dump
       move lua(LUA-COMMAND-STACKDUMP) to extraneous

      *> script from file, this will eat a stack value assumed from file
       move lua("dofile('local.lua')") to extraneous
       display ":" extraneous ": file has no returns, still want to eat"

      *> request stack dump
       move lua(LUA-COMMAND-STACKDUMP) to extraneous

       display ":" lua("n = norm(3.4, 2.0); return twice(n)") ":"

      *> request stack dump
       move lua(LUA-COMMAND-STACKDUMP) to extraneous

      *> tables
       move lua(
           'function f(n) return n + 100 end' newline
           'g = 42' newline
           'a = { [f(4)] = g; "x", "y"; z = 1, f(1), [30] = 23; 45 }'
           newline
           'return a, "a table and string", 0')
         to extraneous
      *> don't expect error
       display exception-status
       display script-return-code

      *> will be an internal format
       move lua(LUA-COMMAND-STACKDUMP) to extraneous

      *> pop the string
       display ":" lua("-1") ":"

      *> will still be an internal format
       display ":" lua("-1") ":"

      *> Lua table constructors take some getting used to
       display ":" lua("return a[1]") ': expect the first "x", implicit'
       display ":" lua("return a[3]") ": from  f(1)"
       display ":" lua("return a[30]") ":"
       display ":" lua("return a[104]") ": from [f(4)]"
       display ":" lua("return a['z']") ": from z = 1"

      *> user input
       move lua(
           "-- defines a factorial function"                    newline
           "function fact (n)"                                  newline
           "  if n == 0 then"                                   newline
           "    return 1"                                       newline
           "  else"                                             newline
           "    return n * fact(n-1)"                           newline
           "  end"                                              newline
           "end"                                                newline
           " "                                                  newline
           'print("enter a number:")'                           newline
           'a = io.read("*number")        -- read a number'     newline
           'print("Factorial " .. a .. " is " .. fact(a))'      newline
           "return a")
         to comparator

      *> should be no cruft on the stack
       move lua(LUA-COMMAND-STACKDUMP) to extraneous

       goback.
       end program sample.

prompt$ cobc -xj lua-sample.cob
Hello, world
:b:
:abc:
:abcdef:
:abcdef:
:: close
:: want empty
:: want error
EC-IMP-SCRIPT
+00000000000000000002
:: want empty
:: want error
EC-IMP-SCRIPT
+00000000000000000002
:44:
Lua Stack Dump, 3 items
001: number : 11
002: number : 22
003: number : 33
:22:
:11:
Lua Stack Dump, 1 item
001: number : 33
:3: file has no returns, still want to eat
Lua Stack Dump, 0 items
:7.8892331693264:
Lua Stack Dump, 0 items

+00000000000000000000
Lua Stack Dump, 2 items
001: other  : table
002: string : 'a table and string'
:a table and string:
:table: 0x1bc7af0:
:x: expect the first "x", implicit
:101: from  f(1)
:23:
:42: from [f(4)]
:1: from z = 1
enter a number:
17
Factorial 17 is 355687428096000
Lua Stack Dump, 0 items

GCobol >>SOURCE FORMAT IS FIXED
      *><* ======================
      *><* GnuCOBOL Lua Interface
      *><* ======================
      *><*
      *><* .. sidebar:: Contents
      *><*
      *><*     .. contents::
      *><*         :local:
      *><*         :depth: 2
      *><*         :backlinks: entry
      *><*
      *><* :Author:    Brian Tiffin
      *><* :Date:      28-Oct-2008
      *><* :Purpose:   interface to Lua scripting
      *><* :Rights:    | Copyright 2008 Brian Tiffin
      *><*             | Licensed under the GNU General Public License
      *><*             | No warranty expressed or implied
      *><* :Tectonics: | cobc -c -I/usr/include/lua5.1/ oclua.c
      *><*             | cobc -x -llua5.1 luacaller.cob oclua.o
      *><*             | ./ocdoc luacaller.cob oclua.rst oclua.html ocfaq.css
      *><* :Requires:  lua5.1, liblua5.1, liblua5.1-dev
      *><* :Link:      http://www.lua.org
      *><* :Thanks to: The Lua team, Pontifical Catholic University
      *><*             of Rio de Janeiro in Brazil.
      *><*             http://www.lua.org/authors.html
      *><* :Sources:   | http://opencobol.add1tocobol.com/luacaller.cob
      *><*             | http://opencobol.add1tocobol.com/oclua.c
      *><*             | http://opencobol.add1tocobol.com/oclua.lua
      *><*             | http://opencobol.add1tocobol.com/oclua.rst
      *><*             | http://opencobol.add1tocobol.com/ocfaq.rss
      *><*
      *> ***************************************************************
       identification division.
       program-id. luacaller.

       data division.
       working-storage section.
       01 luastate             usage pointer.
       01 luascript            pic x(10) value 'oclua.lua' & x"00".
       01 luacommand           pic x(64).
       01 luaresult            pic x(32).
       01 lualength            usage binary-long.

       01 items                pic 9 usage computational-5.
       01 luastack.
          03 luaitem           pic x(32) occurs 5 times.
       01 depth                usage binary-long.

      *> **************************************************************
       procedure division.

       call "OCLUA_OPEN" returning luastate end-call

       move 'return "GnuCOBOL " .. 1.0 + 0.1' & x"00" to luacommand
       call "OCLUA_DOSTRING"
           using
               by value luastate
               by reference luacommand
               by reference luaresult
               by value function length(luaresult)
           returning depth
       end-call
       display
           "GnuCOBOL displays: " depth " |" luaresult "|"
       end-display

       call "OCLUA_DOFILE"
           using
               by value luastate
               by reference luascript
               by reference luaresult
               by value 32
           returning depth
       end-call
       display
           "GnuCOBOL displays: " depth " |" luaresult "|"
       end-display

       call "OCLUA_DOFILE"
           using
               by value luastate
               by reference luascript
               by reference luaresult
               by value 32
           returning depth
       end-call
       display
           "GnuCOBOL displays: " depth " |" luaresult "|"
       end-display

       call "OCLUA_DEPTH"
           using
               by value luastate
           returning depth
       end-call
       display "Lua depth: " depth end-display

       perform varying items from 1 by 1
           until items > depth
               call "OCLUA_GET"
                   using
                       by value luastate
                       by value items
                       by reference luaresult
                       by value 32
                   returning lualength
               end-call
               move luaresult to luaitem(items)
       end-perform

       perform varying items from 1 by 1
           until items > depth
               display
                   "Item " items ": " luaitem(items)
               end-display
       end-perform

       call "OCLUA_POP"
           using
               by value luastate
               by value depth
           returning depth
       end-call

       call "OCLUA_DEPTH"
           using
               by value luastate
           returning depth
       end-call

       display "Lua depth: " depth end-display

       call "OCLUA_CLOSE" using by value luastate end-call

       goback.
       end program luacaller.
      *> ***************************************************************
      *><* ++++++++
      *><* Overview
      *><* ++++++++
      *><* The GnuCOBOL Lua interface is defined at a very high level.
      *><*
      *><* The objective is to provide easy access to Lua through
      *><* script files or strings to be evaluated.
      *><*
      *><* Command strings and script file names passed to Lua MUST be
      *><* terminated with a null byte, as per C Language conventions.
      *><*
      *><* A Lua engine is started with a call to OCLUA_OPEN, which
      *><* returns a GnuCOBOL POINTER that is used to reference
      *><* the Lua state for all further calls.
      *><*
      *><* A Lua engine is run down with a call to OCLUA_CLOSE.
      *><*
      *><* .. Attention::
      *><*   Calls to Lua without a valid state will cause
      *><*   undefined behaviour and crash the application.
      *><*
      *><* Lua uses a stack and results of the Lua RETURN reserved
      *><* word are placed on this stack.  Multiple values can be
      *><* returned from Lua.
      *><*
      *><* The developer is responsible for stack overflow conditions
      *><* and the size of the stack (default 20 elements) is
      *><* controlled with OCLUA_STACK using an integer that
      *><* determines the numbers of slots to reserve.
      *><*
      *><* Requires package installs of:
      *><*
      *><* * lua5.1
      *><* * liblua5.1
      *><* * liblua5.1-dev
      *><*
      *><* ++++++++++++++++
      *><* GnuCOBOL Lua API
      *><* ++++++++++++++++
      *><* ----------
      *><* OCLUA_OPEN
      *><* ----------
      *><* Initialize the Lua engine.
      *><*
      *><* ::
      *><*
      *><*   01 luastate USAGE POINTER.
      *><*
      *><*   CALL "OCLUA_OPEN" RETURNING luastate END-CALL
      *><*
      *><* -----------
      *><* OCLUA_STACK
      *><* -----------
      *><* Check and possibly resize the Lua data stack.  Returns 0 if
      *><* Lua cannot expand the stack to the requested size.
      *><*
      *><* ::
      *><*
      *><*   01 elements USAGE BINARY-LONG VALUE 32.
      *><*   01 result   USAGE BINARY-LONG.
      *><*
      *><*   CALL "OCLUA_STACK"
      *><*       USING
      *><*           BY VALUE luastate
      *><*           BY VALUE elements
      *><*       RETURNING result
      *><*   END-CALL
      *><*
      *><* --------------
      *><* OCLUA_DOSTRING
      *><* --------------
      *><* Evaluate a null terminated alphanumeric field as a Lua program
      *><* producing any top of stack entry and returning the depth of
      *><* stack after evaluation.
      *><*
      *><* Takes a luastate, a null terminated command string,
      *><* a result field and length and returns an integer depth.
      *><*
      *><* .. Attention::
      *><*   The Lua stack is NOT popped while returning the top of stack entry.
      *><*
      *><* ::
      *><*
      *><*   01 luacommand pic x(64).
      *><*   01 luaresult  pic x(32).
      *><*   01 depth      usage binary-long.
      *><*
      *><*   move 'return "GnuCOBOL " .. 1.0 + 0.1' & x"00" to luacommand
      *><*   call "OCLUA_DOSTRING"
      *><*       using
      *><*           by value luastate
      *><*           by reference luacommand
      *><*           by reference luaresult
      *><*           by value function length(luaresult)
      *><*       returning depth
      *><*   end-call
      *><*   display
      *><*       "GnuCOBOL displays: " depth " |" luaresult "|"
      *><*   end-display
      *><*
      *><* Outputs::
      *><*
      *><*   GnuCOBOL displays: +0000000001 |GnuCOBOL 1.1                   ||
      *><*
      *><* ------------
      *><* OCLUA_DOFILE
      *><* ------------
      *><* Evaluate a script using a null terminated alphanumeric field
      *><* naming a Lua program source file, retrieving any top of
      *><* stack entry and returning the depth of stack after evaluation.
      *><*
      *><* Takes a luastate, a null terminated filename,
      *><* a result field and length and returns an integer depth.
      *><*
      *><* .. Attention::
      *><*   The Lua stack is NOT popped while returning the top of
      *><*   stack entry.
      *><*
      *><* ::
      *><*
      *><*   01 luascript  pic x(10) value 'oclua.lua' & x"00".
      *><*   01 luaresult  pic x(32).
      *><*
      *><*   call "OCLUA_DOFILE"
      *><*       using
      *><*           by value luastate
      *><*           by reference luascript
      *><*           by reference luaresult
      *><*           by value function length(luaresult)
      *><*       returning depth
      *><*   end-call
      *><*   display
      *><*       "GnuCOBOL displays: " depth " |" luaresult "|"
      *><*   end-display
      *><*
      *><* Given oclua.lua::
      *><*
      *><*   -- Start
      *><*   -- Script: oclua.lua
      *><*   print("Lua prints hello")
      *><*
      *><*   hello = "Hello GnuCOBOL from Lua"
      *><*   return math.pi, hello
      *><*   -- End
      *><*
      *><* Outputs::
      *><*
      *><*   Lua prints hello
      *><*   GnuCOBOL displays: +0000000002 |Hello GnuCOBOL from Lua        ||
      *><*
      *><* and on return from Lua, there is *math.pi* and the
      *><* Hello string remaining on the Lua state stack.
      *><*
      *><* -----------
      *><* OCLUA_DEPTH
      *><* -----------
      *><* Returns the current number of elements on the Lua stack.
      *><*
      *><* ::
      *><*
      *><*   call "OCLUA_DEPTH"
      *><*       using
      *><*           by value luastate
      *><*       returning depth
      *><*   end-call
      *><*   display "Lua depth: " depth end-display
      *><*
      *><* ---------
      *><* OCLUA_GET
      *><* ---------
      *><* Retrieves values from the Lua stack, returning the length
      *><* of the retrieved item.
      *><*
      *><* An example that populates and displays a GnuCOBOL table::
      *><*
      *><*   01 items                pic 9 usage computational-5.
      *><*   01 luastack.
      *><*      03 luaitem           pic x(32) occurs 5 times.
      *><*
      *><*   perform varying items from 1 by 1
      *><*       until items > depth
      *><*           call "OCLUA_GET"
      *><*               using
      *><*                   by value luastate
      *><*                   by value items
      *><*                   by reference luaresult
      *><*                   by value function length(luaresult)
      *><*               returning lualength
      *><*           end-call
      *><*           move luaresult to luaitem(items)
      *><*   end-perform
      *><*
      *><*   perform varying items from 1 by 1
      *><*       until items > depth
      *><*           display
      *><*              "Item " items ": " luaitem(items)
      *><*           end-display
      *><*   end-perform
      *><*
      *><* Lua numbers the indexes of stacked items from 1, first
      *><* item to n, last item (current top of stack). Negative
      *><* indexes may also be used as documented by Lua, -1 being
      *><* top of stack.
      *><*
      *><* Sample output::
      *><*
      *><*   Item 1: GnuCOBOL 1.1
      *><*   Item 2: 3.1415926535898
      *><*   Item 3: Hello GnuCOBOL from Lua
      *><*   Item 4: 3.1415926535898
      *><*   Item 5: Hello GnuCOBOL from Lua
      *><*
      *><* ---------
      *><* OCLUA_POP
      *><* ---------
      *><* Pops the given number of elements off of the Lua stack
      *><* returning the depth of the stack after the pop.
      *><*
      *><* Example that empties the Lua stack::
      *><*
      *><*   call "OCLUA_POP"
      *><*       using
      *><*           by value luastate
      *><*           by value depth
      *><*       returning depth
      *><*   end-call
      *><*
      *><* -----------
      *><* OCLUA_CLOSE
      *><* -----------
      *><* Close and free the Lua engine.
      *><*
      *><* .. Danger::
      *><*    Further calls to Lua are unpredictable and may well
      *><*    lead to a SIGSEGV crash.
      *><*
      *><* ::
      *><*
      *><*   call "OCLUA_CLOSE" using by value luastate end-call
      *><*

/* GnuCOBOL Lua interface */
/* tectonics: cobc -c -I/usr/include/lua5.1 oclua.c */

#include <stdlib.h>
#include <stdio.h>
#include <string.h>

/* Include the Lua API header files. */
#include <lua.h>
#include <lauxlib.h>
#include <lualib.h>

/* Open the Lua engine and load all the default libraries */
lua_State *OCLUA_OPEN() {
    lua_State *oclua_state;
    oclua_state = lua_open();
    luaL_openlibs(oclua_state);
    return oclua_state;
}

int OCLUA_DO(lua_State *L, int which, const char *string,
             unsigned char *cobol, int coblen) {
    int result;
    int stacked;
    const char *retstr;
    int retlen;

    memset(cobol, ' ', coblen);
    result = ((which == 0) ? luaL_dostring(L, string) : luaL_dofile(L, string));
    if (result == 1) {
        /* error condition */
        return -1;
    } else {
        stacked = lua_gettop(L);
        if (stacked > 0) {
            /* populate cobol field with top of stack */
            retstr = lua_tolstring(L, stacked, &retlen);
            memcpy(cobol, retstr, (coblen > retlen) ? retlen : coblen);
        }
        /* return number of items on the stack */
        return stacked;
    }
}

/* by filename */
int OCLUA_DOFILE(lua_State *L, const char *filename,
                 unsigned char *cobol, int coblen) {
    return OCLUA_DO(L, 1, filename, cobol, coblen);
}

/* by string */
int OCLUA_DOSTRING(lua_State *L, const char *string,
                   unsigned char *cobol, int coblen) {
    return OCLUA_DO(L, 0, string, cobol, coblen);
}

/* retrieve stack item as string */
int OCLUA_GET(lua_State *L, int element, unsigned char *cobol, int coblen) {
    const char *retstr;
    int retlen;

    /* populate cobol field with top of stack */
    memset(cobol, ' ', coblen);
    retstr = lua_tolstring(L, element, &retlen);
    if (retstr == NULL) {
        return -1;
    } else {
        memcpy(cobol, retstr, (coblen > retlen) ? retlen : coblen);
        return retlen;
    }
}

/* check the stack, resize if needed, returns false if stack can't grow */
int OCLUA_STACK(lua_State *L, int extra) {
    return lua_checkstack(L, extra);
}

/* depth of Lua stack */
int OCLUA_DEPTH(lua_State *L) {
    return lua_gettop(L);
}

/* pop elements off stack */
int OCLUA_POP(lua_State *L, int elements) {
    lua_pop(L, elements);
    return lua_gettop(L);
}

/* close the engine */
void OCLUA_CLOSE(lua_State *L) {
    lua_close(L);
}

/**/

-- Start
-- Script: oclua.lua
print("Lua prints hello")

hello = "Hello GnuCOBOL from Lua"
return math.pi, hello
-- End

/* GnuCOBOL with embedded spidermonkey javascript */
/*   cobc -c -I/usr/include/smjs ocjs.c
 *   cobc -x -lsmjs jscaller.cob
 *   some people found mozjs before smjs
 */
#include <stdio.h>
#include <string.h>

/* javascript api requires an environment type */
#define XP_UNIX

#if (defined(XP_WIN) || defined(XP_UNIX) || defined(XP_BEOS) || defined(XP_OS2))
#include "jsapi.h"
#else
#error "Must define one of XP_BEOS, XP_OS2, XP_WIN or XP_UNIX"
#endif

/* Error codes */
#define OCJS_ERROR_RUNTIME  -1
#define OCJS_ERROR_CONTEXT  -2
#define OCJS_ERROR_GLOBAL   -3
#define OCJS_ERROR_STANDARD -4
#define OCJS_ERROR_EVALUATE -5

/* GnuCOBOL main CALL interface */
/* javascript layer requires
 *   a runtime per process,
 *   a context per thread,
 *   a global object per context
 * and will initialize
 *   standard classes.
 */
static JSRuntime *rt;
static JSContext *cx;
static JSObject *global;
static JSClass global_class = {
    "global",0,
    JS_PropertyStub,JS_PropertyStub,JS_PropertyStub,JS_PropertyStub,
    JS_EnumerateStub,JS_ResolveStub,JS_ConvertStub,JS_FinalizeStub
};

/* Initialize the engine resources */
int ocjsInitialize(int rtsize, int cxsize) {
    JSBool ok;

    /* on zero sizes, pick reasonable values */
    if (rtsize == 0) { rtsize = 0x100000; }
    if (cxsize == 0) { cxsize = 0x1000; }

    /* Initialize a runtime space */
    rt = JS_NewRuntime(rtsize);
    if (rt == NULL) { return OCJS_ERROR_RUNTIME; }
    /* Attach a context */
    cx = JS_NewContext(rt, cxsize);
    if (cx == NULL) { return OCJS_ERROR_CONTEXT; }
    /* And a default global */
    global = JS_NewObject(cx, &global_class, NULL, NULL);
    if (global == NULL) { return OCJS_ERROR_GLOBAL; }
    /* Load standard classes */
    ok = JS_InitStandardClasses(cx, global);

    /* Return success or standard class load error */
    return (ok == JS_TRUE) ? 0 : OCJS_ERROR_STANDARD;
}

/* Evaluate script */
int ocjsEvaluate(char *script, char *result, int length) {
    jsval rval;
    JSString *str;
    int reslen = OCJS_ERROR_EVALUATE;

    JSBool ok;

    /* filename and line number, not reported */
    char *filename = NULL;
    int lineno = 0;

    /* clear the result field */
    memset(result, ' ', length);

    /* Evaluate javascript */
    ok = JS_EvaluateScript(cx, global, script, strlen(script),
                           filename, lineno, &rval);

    /* Convert js result to JSString form */
    if (ok == JS_TRUE) {
        str = JS_ValueToString(cx, rval);
        reslen = strlen(JS_GetStringBytes(str));
        if (length < reslen) { reslen = length; }
        /* convert down to char and move to OpenCOBOl result field */
        memcpy(result, JS_GetStringBytes(str), reslen);
    }
    return reslen;
}

/* Evaluate script from file */
int ocjsFromFile(char *filename, char *result, int length) {
    FILE *fin;
    int bufsize = 10240;
    char inbuf[bufsize];
    int reslen;

    fin = fopen(filename, "r");
    if (fin == NULL) { return OCJS_ERROR_EVALUATE; }
    //while (fread(inbuf, sizeof(char), bufsize, fin) > 0) {
    if (fread(inbuf, 1, bufsize, fin) > 0) {
        reslen = ocjsEvaluate(inbuf, result, length);
    }
    return reslen;
}

/* release js engine */
int ocjsRunDown() {
    if (cx != NULL) { JS_DestroyContext(cx); }
    if (rt != NULL) { JS_DestroyRuntime(rt); }
    JS_ShutDown();
    return 0;
}

/* Quick call; start engine, evaluate, release engine */
int ocjsString(char *script, char *result, int length) {
    int reslen;

    reslen = ocjsInitialize(0, 0);
    if (reslen < 0) { return reslen; }
    reslen = ocjsEvaluate(script, result, length);
    ocjsRunDown();
    return reslen;
}
/**/

GCobol >>SOURCE FORMAT IS FIXED
      *>****************************************************************
      *>Author:    Brian Tiffin
      *>Date:      11-Sep-2008
      *>Purpose:   Embed some javascript
      *>Tectonics: cobc -c -I/usr/include/smjs ocjs.c
      *>           cobc -x -l/smjs jscaller.cob ocjs.o
      *>****************************************************************
       identification division.
       program-id. jscaller.

       data division.

       working-storage section.
       78 ocjs-error-runtime  value -1.
       78 ocjs-error-context  value -2.
       78 ocjs-error-global   value -3.
       78 ocjs-error-standard value -4.
       78 ocjs-error-evaluate value -5.

       78 newline              value x"0a".
       01 source-data          pic x(40)
            value "----+----1----+-$56.78 90----3----+----4".
       01 result               pic s9(9).
       01 result-field         pic x(81).

       01 javascript           pic x(1024).
       01 safety-null          pic x value x"00".

      *>****************************************************************
      *><* Evaluate spidermonkey code, return the length of js result
       procedure division.

       display "js> " with no advancing end-display
       accept javascript end-accept
       call "ocjsString"
           using javascript
               result-field
               by value function length(result-field)
           returning result
       end-call
       display "GnuCOBOL result-field: " result-field end-display
       display "GnuCOBOL received    : " result newline end-display

      *><* Initialize the javascript engine
       call "ocjsInitialize"
           using by value 65536
               by value 1024
           returning result
       end-call
       if result less 0
           stop run returning result
       end-if

      *><* find (zero offest) dollar amount, space, number
       move spaces to javascript
       string
           "pat = /\$\d+\.\d+\s\d+/; "
           'a = "' delimited by size
           source-data delimited by size
           '"; ' delimited by size
           "a.search(pat); " delimited by size
           x"00" delimited by size
           into javascript
       end-string

       display
           "Script: " function trim(javascript, trailing)
       end-display

       call "ocjsEvaluate"
           using javascript
               result-field
               by value function length(result-field)
           returning result
       end-call
       display "GnuCOBOL result-field: " result-field end-display
       display "GnuCOBOL received    : " result newline end-display

      *><* values held in js engine across calls
       move spaces to javascript
       string
           'a;' delimited by size
           x"00" delimited by size
           into javascript
       end-string

       display
           "Script: " function trim(javascript, trailing)
       end-display

       call "ocjsEvaluate"
           using javascript
               result-field
               by value function length(result-field)
           returning result
       end-call
       display "GnuCOBOL result-field: " result-field end-display
       display "GnuCOBOL received    : " result newline end-display

      *><* erroneous script
       move spaces to javascript
       string
           'an error of some kind;' delimited by size
           x"00" delimited by size
           into javascript
       end-string

       display
           "Script: " function trim(javascript, trailing)
       end-display

       call "ocjsEvaluate"
           using javascript
               result-field
               by value function length(result-field)
           returning result
       end-call
       if result equal ocjs-error-evaluate
           display " *** script problem ***" end-display
       end-if
       display "GnuCOBOL result-field: " result-field end-display
       display "GnuCOBOL received    : " result newline end-display

      *><* script from file
       move spaces to javascript
       string
           'ocjsscript.js' delimited by size
           x"00" delimited by size
           into javascript
       end-string

       display
           "Script: " function trim(javascript, trailing)
       end-display

       call "ocjsFromFile"
           using javascript
               result-field
               by value function length(result-field)
           returning result
       end-call
       if result equal ocjs-error-evaluate
           display " *** script problem ***" end-display
       end-if
       display "GnuCOBOL result-field: " result-field end-display
       display "GnuCOBOL received    : " result newline end-display

      *><* Rundown the js engine
       call "ocjsRunDown" returning result

      *><* take first name last name, return last "," first
       move spaces to javascript
       string
           "re = /(\w+)\s(\w+)/; " delimited by size
           'str = "John Smith"; ' delimited by size
           'newstr = str.replace(re, "$2, $1"); ' delimited by size
           "newstr;" delimited by size
           x"00" delimited by size
           into javascript
       end-string

       display
           "Script: " function trim(javascript, trailing)
       end-display

       call "ocjsString"
           using javascript
               result-field
               by value function length(result-field)
           returning result
       end-call
       display "GnuCOBOL result-field: " result-field end-display
       display "GnuCOBOL received    : " result newline end-display

      *><* split a string using numbers return array (as js string form)
       move spaces to javascript
       string
           'myString = "Hello 1 word. Sentence number 2."; '
               delimited by size
           'splits = myString.split(/(\d)/); ' delimited by size
           'splits;'  delimited by size
           x"00" delimited by size
           into javascript
       end-string

       display
           "Script: " function trim(javascript, trailing)
       end-display

       call "ocjsString"
           using javascript
               result-field
               by value function length(result-field)
           returning result
       end-call
       display "GnuCOBOL result-field: " result-field end-display
       display "GnuCOBOL received    : " result newline end-display

      *><* Get javascript date
       move "new Date()" & x"00" to javascript

       display
           "Script: " function trim(javascript, trailing)
       end-display

       call "ocjsString"
           using javascript
               result-field
               by value function length(result-field)
           returning result
       end-call
       display "GnuCOBOL result-field: " result-field end-display
       display "GnuCOBOL received    : " result end-display

       goback.
       end program jscaller.

var x = 2
var y = 39
var z = "42"
// boths line evaluate to 42
eval("x + y + 1")
eval(z)

js> 123 * 456 + 789
GnuCOBOL result-field: 56877
GnuCOBOL received    : +000000005

Script: pat = /\$\d+\.\d+\s\d+/; a = "----+----1----+-$56.78 90----3----+----4"; a.search(pat);
GnuCOBOL result-field: 16
GnuCOBOL received    : +000000002

Script: a;
GnuCOBOL result-field: ----+----1----+-$56.78 90----3----+----4
GnuCOBOL received    : +000000040

Script: an error of some kind;
 *** script problem ***
GnuCOBOL result-field:
GnuCOBOL received    : -000000005

Script: re = /(\w+)\s(\w+)/; str = "John Smith";
        newstr = str.replace(re, "$2, $1"); newstr;
GnuCOBOL result-field: Smith, John
GnuCOBOL received    : +000000011

Script: myString = "Hello 1 word. Sentence number 2.";
        splits = myString.split(/(\d)/); splits;
GnuCOBOL result-field: Hello ,1, word. Sentence number ,2,.
GnuCOBOL received    : +000000036

Script: new Date()
GnuCOBOL result-field: Mon Sep 15 2008 04:16:06 GMT-0400 (EDT)
GnuCOBOL received    : +000000039

GCobol >>SOURCE FORMAT IS FREE

REPLACE ==:SAMPLE:== BY ==callseed==.
>>IF docpass NOT DEFINED

      *> ***************************************************************
      *>****p* project/:SAMPLE:
      *> Author:
      *>   Brian Tiffin
      *> Date:
      *>   20141204
      *> License:
      *>   GNU General Public License, GPL, 3.0 (or greater)
      *> Purpose:
      *>   Test out libseed JavaScriptCore hooks
      *> Tectonics:
      *>   cobc -x callseed.cob -g -debug -lseed-gtk3
      *> ***************************************************************
       identification division.
       program-id. :SAMPLE:.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 seed-engine          usage pointer.
       01 seed-engine-record based.
          05 seed-context      usage pointer.
          05 seed-global       usage pointer.
          05 seed-searchpath   usage pointer.
          05 seed-group        usage pointer.
       01 seed-script          usage pointer.
       01 seed-exception       usage pointer.
       01 seed-value           usage pointer.
       01 seed-object          usage pointer.

       01 cobol-pic9           pic s9(8).
       01 cobol-long           usage binary-long value 42.
       01 cobol-picx           pic x(17).

      *> ***************************************************************
       procedure division.

      *> Initialize libseed, bail if no engine can be created
       call "seed_init" using by reference 0 0
           returning seed-engine
           on exception
               display "no libseed" upon syserr
               stop run
       end-call
       if seed-engine equal null then
           display "no libseed engine" upon syserr
           stop run
       else
           set address of seed-engine-record to seed-engine
       end-if
       display
           ":init  : " seed-engine space seed-context space
           seed-global space seed-group upon syserr

      *> convert some values
       call "seed_value_from_int" using
           by value seed-context
           by value cobol-long
           by reference seed-exception
           returning seed-value
       end-call
       display
           ":long  : " seed-engine space seed-context space
           seed-exception space seed-value upon syserr

      *> load in a javascript file
       call "seed_script_new_from_file" using
           by value seed-context
           by content z"webkit.js"
           returning seed-script
       end-call
       display ":script: " seed-script upon syserr

      *> evaluate the script
       call "seed_evaluate" using
           by value seed-context
           by value seed-script
           by value seed-object
           returning seed-value
       end-call
       display ":webkit: " seed-script space seed-value upon syserr

      *> evaluate some strings of javascript

      *> javascript print
       call "seed_simple_evaluate" using
           by value seed-context
           by content concatenate('print("Hello, seed");', x"00")
           by reference seed-exception
           returning seed-value
       end-call
       display
           ":print : " seed-engine space seed-context
           space seed-exception space seed-value upon syserr

      *> empty GTK+ window with title
       call "seed_simple_evaluate" using
           by value seed-context
           by content concatenate(
               "Gtk = imports.gi.Gtk; ",
               "Gtk.init(null, null); ",
               "window = new Gtk.Window({ type: Gtk.WindowType.TOPLEVEL }); ",
               "window.signal.hide.connect(Gtk.main_quit); ",
               "window.set_default_size(250, 200); ",
               "window.set_title('Center'); ",
               "window.set_position(Gtk.WindowPosition.CENTER); ",
               "window.show(); ",
               "Gtk.main();", x"00")
           by reference seed-exception
           returning seed-value
       end-call
       display
           ":center: " seed-engine space seed-context
           space seed-exception space seed-value upon syserr

      *> GTK+ window with a button, and hover over tooltip
       call "seed_simple_evaluate" using
           by value seed-context
           by content concatenate(
               "Example = new GType({ ",
               "    parent: Gtk.Window.type, ",
               "    name: 'Example', ",
               "    init: function() ",
               "    { ",
               "        init_ui(this); ",
               "        function init_ui(w) { ",
               "            w.signal.hide.connect(Gtk.main_quit); ",
               "            w.set_default_size(250, 200); ",
               "            w.set_title('Tooltips'); ",
               "            w.set_position(Gtk.WindowPosition.CENTER);     ",
               "            var fix = new Gtk.Fixed(); ",
               "            var button = new Gtk.Button({ label: 'Button' }); ",
               "            button.set_size_request(80, 35);      ",
               "            button.set_tooltip_text('Button widget'); ",
               "            fix.put(button, 50, 50); ",
               "            w.add(fix); ",
               "            w.set_tooltip_text('Window widget');             ",
               "            w.show_all(); ",
               "        } ",
               "    }     ",
               "}); ",
               "var window = new Example(); ",
               "Gtk.main();", x"00")
           by reference seed-exception
           returning seed-value
       end-call
       display
           ":hover : " seed-engine space seed-context
           space seed-exception space seed-value upon syserr

      *> call libSOUP to read a web page
       call "seed_simple_evaluate" using
           by value seed-context
           by content concatenate(
               "Soup = imports.gi.Soup; ",
               "var session = new Soup.SessionSync(); ",
               "// Soup.URI is a struct. ",
               "var uri = new Soup.URI.c_new('http://www.google.com'); ",
               "var request = new Soup.Message({method:'GET', uri:uri}); ",
               "var status = session.send_message(request); ",
               'print("status");', x"00")
           by reference seed-exception
           returning seed-value
       end-call
       display
           ":soup  : " seed-engine space seed-context
           space seed-exception space seed-value upon syserr

       goback.
       end program :SAMPLE:.
      *> ***************************************************************
>>ELSE

==============
:SAMPLE: usage
==============

An example of using libseed to run JavaScriptCore (which is part of
WebKitGTK)

Introduction
------------

Call some libseed from GnuCOBOL

Building
--------

::

    cobc -x callseed.cob -g -debug -lseed-gtk3
    ./callseed

So far, this simple example

* converts some values between COBOL and Javascript
* creates a web browser from a script file, webkit.js
* evaluates a string to centre an empty window
* evaluates a string to show a hover over tooltip on a button
* evaluates a string to use libSOUP to read a web page


Source
------

.. code-include::  :SAMPLE:.cob
      :language: cobol
>>END-IF

$ cobc -x callseed.cob -lseed-gtk3
$ ./callseed
:init  : 0x00000000012da3a0 0x00007fe9303afb78 0x00007fe9303af970 0x00007fe970c25000
:long  : 0x00000000012da3a0 0x00007fe9303afb78 0x0000000000000000 0xffff00000000002a
:script: 0x00000000012dd380
:webkit: 0x00000000012dd380 0x000000000000000a
Hello, seed
:print : 0x00000000012da3a0 0x00007fe9303afb78 0x0000000000000000 0x000000000000000a
:center: 0x00000000012da3a0 0x00007fe9303afb78 0x0000000000000000 0x000000000000000a
:hover : 0x00000000012da3a0 0x00007fe9303afb78 0x0000000000000000 0x000000000000000a
:soup  : 0x00000000012da3a0 0x00007fe9303afb78 0x0000000000000000 0x00007fe9301f3170

GCobol >>SOURCE FORMAT IS FREE
      *> ***************************************************************
      *>****J* gnucobol/cobduk
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20161122  Modified: 2016-11-22/01:44-0500
      *> LICENSE
      *>   Copyright 2016 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or superior)
      *> PURPOSE
      *>   Integrate Duktape
      *> TECTONICS
      *>   cobc -x -g -debug cobduk.cob duktape.c
      *> ***************************************************************
       identification division.
       program-id. cobduk.
       author. Brian Tiffin.
       date-written. 2016-11-22/00:18-0500.
       date-modified. 2016-11-22/01:44-0500.
       installation. Needs Duktape 1.5.1
       remarks. Just add duktape.c
       security. Probably worth keeping an eye on the ECMAScripting.

       environment division.
       configuration section.
       source-computer. gnulinux.
       object-computer. gnulinux
           classification is canadian.

       special-names.
           locale canadian is "en_CA.UTF-8".

       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 duk-ctx usage pointer.
       01 duk-str usage pointer.
       01 based-str pic x(80) based.
       01 fixed-str pic x(80).

      *> ***************************************************************
       procedure division.
      *> Init Duktape
       call "duk_create_heap" using null null null null null
           returning duk-ctx
           on exception
               display "error: no duktape" upon syserr
               perform soft-exception
               goback
       end-call
       if duk-ctx equal null then
           display "duktape init failed" upon syserr
           goback
       end-if

      *> Evaluate a test hello
       call "duk_eval_raw" using
           by value duk-ctx
           by content z"print('Hello, world');"
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> Evaluate a custom Duktape JSON encode, no replace, 4 spaces
       call "duk_eval_raw" using
           by value duk-ctx
           by content z"print(Duktape.enc('jx', {foo: 123}, null, 4));"
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> Evaluate a more JSON Duktape JSON encode, no replace, 4 spaces
       call "duk_eval_raw" using
           by value duk-ctx
           by content z"print(Duktape.enc('jc', {foo: 123}, null, 4));"
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> decode some JSON, and print out a field
       call "duk_eval_raw" using
           by value duk-ctx
           by content "print(Duktape.dec('jx', " & z'"{foo:123}").foo);'
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> stringy some JSON, leave data on the Duktape stack
       call "duk_eval_raw" using
           by value duk-ctx
           by content
               z"var res = JSON.stringify({foo: 123}, null, 4); res;"
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> get the character data into COBOL, -1 is top of stack
       call "duk_get_string" using
           by value duk-ctx
           by value -1
           returning duk-str
       end-call
       if duk-str not equal null then
           set address of based-str to duk-str
           string based-str delimited by low-value into fixed-str
           display "COBOL view of JSON: " fixed-str
       else
           display "JSON conversion failed" upon syserr
       end-if

       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program cobduk.
      *> ***************************************************************

prompt$ cobc -x -g -j cobduk.cob duktape.c
Hello, world
{
    foo: 123
}
{
    "foo": 123
}
123
COBOL view of JSON: {
    "foo": 123
}

===============
Duktape license
===============

(http://opensource.org/licenses/MIT)

Copyright (c) 2013-2017 by Duktape authors (see AUTHORS.rst)

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20090215
      *> Purpose:   Demonstrate libguile Scheme interactions
      *> Tectonics: cobc -x -lguile callguile.cob
      *> ***************************************************************
       identification division.
       program-id. callguile.

       data division.
       working-storage section.
       01 tax-scm              usage pointer.
       01 shipping-scm         usage pointer.
       01 scm-string           usage pointer.
       01 radix-scm            usage pointer.

       01 subtotal             pic 999v99 value 80.00.
       01 subtotal-display     pic z(8)9.99.
       01 weight               pic 99v99  value 10.00.
       01 weight-display       pic Z9.99.
       01 breadth              pic 99v99  value 20.00.
       01 breadth-display      pic Z9.99.

       01 answer               pic x(80).
       01 len                  usage binary-long.

       01 tax                  pic 9(9)v9(2).
       01 tax-display          pic z(8)9.9(2).
       01 shipping             pic 9(9)v9(2).
       01 shipping-display     pic z(8)9.9(2).
       01 invoice-total        pic 9(9)v9(2).
       01 invoice-display      pic $(8)9.9(2).

      *> ***************************************************************
       procedure division.

       display "OC: initialize libguile" end-display
       call "scm_init_guile" end-call

       display "OC: load scheme code" end-display
       call "scm_c_primitive_load" using "script.scm" & x"00" end-call
       display "OC:" end-display

       display "OC: evaluate one of the defined functions" end-display
       call "scm_c_eval_string" using "(do-hello)" & x"00" end-call
       display "OC:" end-display

       display "OC: perform tax calculation" end-display
       move subtotal to subtotal-display
       move weight to weight-display
       move breadth to breadth-display
       call "scm_c_eval_string"
           using
               function concatenate(
                   "(compute-tax "; subtotal-display; ")"; x"00"
               )
           returning tax-scm
       end-call

       display "OC: perform shipping calculation" end-display
       display "OC: " function concatenate(
                          "(compute-shipping "; weight-display; " ";
                          breadth-display; ")"; x"00"
                      )
       end-display
       call "scm_c_eval_string"
           using
               function concatenate(
                   "(compute-shipping "; weight-display; " ";
                   breadth-display; ")"; x"00"
               )
           returning shipping-scm
       end-call

       display "OC: have guile build a scheme integer 10" end-display
       call "scm_from_int32"
           using by value size is 4 10 returning radix-scm
       end-call

       display "OC: have guile convert number, base 10" end-display
       call "scm_number_to_string"
           using
               by value tax-scm by value radix-scm
           returning scm-string
       end-call

       display "OC: get numeric string to COBOL" end-display
       call "scm_to_locale_stringbuf"
           using
               by value scm-string
               by reference answer
               by value 80
           returning len
       end-call
       display "OC: tax as string: " answer end-display
       move answer to tax

       call "scm_number_to_string"
           using
               by value shipping-scm by value radix-scm
           returning scm-string
       end-call

       call "scm_to_locale_stringbuf"
           using
               by value scm-string
               by reference answer
               by value 80
           returning len
       end-call
       display "OC: shipping as string: " answer end-display
       move answer to shipping

       compute invoice-total = subtotal + tax + shipping end-compute

       move subtotal to subtotal-display
       move tax to tax-display
       move shipping to shipping-display
       move invoice-total to invoice-display
       display "OC:" end-display
       display "OC: subtotal   " subtotal-display end-display
       display "OC: tax        " tax-display end-display
       display "OC: shipping   " shipping-display end-display
       display "OC: total:     " invoice-display end-display
       goback.
       end program callguile.

(define (do-hello)
  (begin
    (display "Welcome to Guile")
    (newline)))

(define (compute-tax subtotal)
  (* subtotal 0.0875))


(define (compute-shipping weight length)

  ;; For small, light packages, charge the minimum
  (if (and (< weight 20) (< length 5))
      0.95

      ;; Otherwise for long packages, charge a lot
      (if (> length 100)
          (+ 0.95 (* weight 0.1))

          ;; Otherwise, charge the usual
          (+ 0.95 (* weight 0.05)))))

(display "Loaded script.scm")(newline)

OC: initialize libguile
OC: load scheme code
Loaded script.scm
OC:
OC: evaluate one of the defined functions
Welcome to Guile
OC:
OC: perform tax calculation
OC: perform shipping calculation
OC: (compute-shipping 10.00 20.00)
OC: have guile build a scheme integer 10
OC: have guile convert number, base 10
OC: get numeric string to COBOL
OC: tax as string: 7.0
OC: shipping as string: 1.45
OC:
OC: subtotal          80.00
OC: tax                7.00
OC: shipping           1.45
OC: total:           $88.45

GCOBOL*>-<*
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      *>
      *> Date started: July 2017
      *> Modified: 2017-07-08/01:29-0400 btiffin
      *>+<*
      *>
      *> safetcl.cob, test Safe Tcl mode
      *> Tectonics: cobc -xj safetcl.cob
      *>
       >>SOURCE FORMAT IS FREE
       identification division.
       program-id. sample.

       REPLACE ==newline== BY ==& x'0a' &==.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       COPY tclapi.

      *> make extraneous large enough to hold a Tcl error message
       01 extraneous pic x(80).

       procedure division.
       sample-main.

      *> predefined in compiler for conditional compilation
       >>IF INTRINSIC-TCL IS SET

       display tcl-unrestricted("puts {Hello, world};" newline
                                "return Hello;")

      *> safe interp will have no stdio channels
       display tcl("puts {Test}")

      *> but will be able to compute expressions
       display tcl("expr {1 + 2}")

      *> Ensure master still has stdio
       display tcl-unrestricted("puts {Hello, world};" newline
                                "return Hello;")

      *> try some of the disabled commands
       display tcl-unrestricted("pwd")
       display tcl("pwd")
       display tcl("exit")

      *> manipulate the safe interpreter
       display tcl-unrestricted("interp slaves")

      *> allow pwd
       move tcl-unrestricted("interp expose SaferTcl pwd")
         to extraneous
       display tcl("pwd")

      *> disable pwd again
       move tcl-unrestricted(concatenate("interp hide "
                             TCL-SAFE-NAME " pwd")) to extraneous
       display tcl("pwd")

      *> run some Tk gui
       display tcl-unrestricted("source adclock.tcl")

      *> idiom to avoid inadvertently terminating a program on Tcl exit
       display tcl-unrestricted(
           "interp alias {} exit {} return"                      newline
           "puts {Tcl 'exit' normally causes full process exit}" newline
           "exit 1")
       display "GnuCOBOL still running"

       >>END-IF

       goback.
       end program sample.

prompt$ cobc -xj safetcl.cob
Hello, world
Hello
can not find channel named "stdout"
3
Hello, world
Hello
/home/btiffin/forge/gnucobol/extensions/demos
invalid command name "pwd"
invalid command name "exit"
SaferTcl
/home/btiffin/forge/gnucobol/extensions/demos
invalid command name "pwd"
Time is 06:46:05
Calling 'exit' normally causes process exit

GnuCOBOL still running

# Intrinsic Tcl example with Tk
package require Tk

proc every {ms body} {eval $body; after $ms [info level 0]}
proc drawhands w {
    $w delete hands
    set secSinceMidnight [expr { [clock seconds] - [clock scan 00:00:00] }]
    foreach divisor {60 3600 43200} length {45 40 30} width {1 3 7} {
        set angle [expr {$secSinceMidnight * 6.283185 / $divisor}]
        set x [expr {50 + $length * sin($angle)}]
        set y [expr {50 - $length * cos($angle)}]
        $w create line 50 50 $x $y -width $width -tags hands
    }
}
proc drawmarks w {
  set length1 46
  set length2 50
  foreach h {0 1 2 3 4 5 6 7 8 9 10 11} {
    set angle [expr {6.283185 / 12 * $h} ]
    set x1 [expr {50 + $length1 * sin($angle)}]
    set x2 [expr {50 + $length2 * sin($angle)}]
    set y1 [expr {50 - $length1 * cos($angle)}]
    set y2 [expr {50 - $length2 * cos($angle)}]
    $w create line $x1 $y1 $x2 $y2 -width 1
  }
}
proc toggle {w1 w2} {
    if [winfo ismapped $w2] {
        foreach {w2 w1} [list $w1 $w2] break ;# swap
    }
    pack forget $w1
    pack $w2
}
canvas .analog -width 100 -height 100 -bg white

drawmarks .analog
every 1000 {drawhands .analog}

label .digital -textvar ::time -font {Courier 24}
every 1000 {set ::time [clock format [clock sec] -format %H:%M:%S]}

pack .analog

bind . <1> {toggle .analog .digital}
bind . <Key> {
    destroy .
}
tkwait window .
return "Time is $::time"

GCobol IDENTIFICATION DIVISION.
       PROGRAM-ID.    tclgui.
       AUTHOR. Rildo Pragana.
      *> REMARKS.
      *>    Example tcl/tk GUI program for Cobol.
      *>
       ENVIRONMENT DIVISION.
       DATA DIVISION.
      *>
       WORKING-STORAGE SECTION.
       01 DATA-BLOCK.
          05 NAME           PIC X(40).
          05 W-ADDRESS      PIC X(50).
          05 PHONE          PIC X(15).
          05 END-PGM                PIC X.
                05 QUICK-RET      PIC X.
       01 SITE-INFO.
          05  TITLE       PIC X(20).
          05  URL         PIC X(50).
       77 GUI-01          PIC X(64) VALUE "formA.tcl".
       77 GUI-02          PIC X(64) VALUE "formB.tcl".
       77 END-OF-STRING   pic X value LOW-VALUES.
       77 T-SCRIPT                  PIC X(128).
       77 T-RESULT                  PIC X(80).
       01 dummy                  pic X value X"00".

       PROCEDURE DIVISION.

       CALL "initTcl"

      *> test for stcleval function
       string "expr 12 * 34" END-OF-STRING into T-SCRIPT
       call "stcleval" using T-SCRIPT T-RESULT
       display "eval by tcl: |" T-SCRIPT "| returned " T-RESULT

       MOVE "Your name here" to NAME
       MOVE "Your address" TO W-ADDRESS
       MOVE "Phone number" to PHONE
      *> this variable tells Cobol that the user required an exit
       MOVE "0" to END-PGM
       MOVE "1" to QUICK-RET
       MOVE "Afonso Pena" to NAME
      *> now we may have the script name as a variable, terminated by a space
       CALL "tcleval" USING DATA-BLOCK "./formA.tcl "
       MOVE "Deodoro da Fonseca" to NAME
       CALL "tcleval" USING DATA-BLOCK GUI-01
       MOVE "Rui Barbosa" to NAME
       CALL "tcleval" USING DATA-BLOCK GUI-01
       MOVE "Frei Caneca" to NAME
       CALL "tcleval" USING DATA-BLOCK GUI-01

       MOVE "0" to QUICK-RET
       MOVE "Your name here" to NAME.
       100-restart.
      *> call C wrapper, passing data block and size of data
       CALL "tcleval" USING DATA-BLOCK GUI-01

       DISPLAY "Returned data:"
       DISPLAY "NAME    [" NAME "]"
       DISPLAY "ADDRESS [" W-ADDRESS "]"
       DISPLAY "PHONE   [" PHONE "]"
      *> if not end of program required, loop
       if END-PGM = 0
           go to 100-restart.
      *> to start a new GUI (graphical interface), call this first
       call "newGui"
       MOVE "Title of the site" to TITLE
       MOVE "URL (http://..., ftp://..., etc)" to URL
      *> now we may draw other main window...
       CALL "tcleval" USING SITE-INFO GUI-02
       DISPLAY "Returned data:"
       DISPLAY "TITLE   [" TITLE "]"
       DISPLAY "URL     [" URL "]"

       STOP RUN.

#!/bin/sh
# the next line restarts using wish\
exec wish "$0" "$@"

if {![info exists vTcl(sourcing)]} {

    package require Tk
    switch $tcl_platform(platform) {
        windows {
            option add *Button.padY 0
        }
        default {
            option add *Scrollbar.width 10
            option add *Scrollbar.highlightThickness 0
            option add *Scrollbar.elementBorderWidth 2
            option add *Scrollbar.borderWidth 2
        }
    }

}

#############################################################################
# Visual Tcl v1.60 Project
#


#################################
# VTCL LIBRARY PROCEDURES
#

if {![info exists vTcl(sourcing)]} {
#############################################################################
## Library Procedure:  Window

proc ::Window {args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    global vTcl
    foreach {cmd name newname} [lrange $args 0 2] {}
    set rest    [lrange $args 3 end]
    if {$name == "" || $cmd == ""} { return }
    if {$newname == ""} { set newname $name }
    if {$name == "."} { wm withdraw $name; return }
    set exists [winfo exists $newname]
    switch $cmd {
        show {
            if {$exists} {
                wm deiconify $newname
            } elseif {[info procs vTclWindow$name] != ""} {
                eval "vTclWindow$name $newname $rest"
            }
            if {[winfo exists $newname] && [wm state $newname] == "normal"} {
                vTcl:FireEvent $newname <<Show>>
            }
        }
        hide    {
            if {$exists} {
                wm withdraw $newname
                vTcl:FireEvent $newname <<Hide>>
                return}
        }
        iconify { if $exists {wm iconify $newname; return} }
        destroy { if $exists {destroy $newname; return} }
    }
}
#############################################################################
## Library Procedure:  vTcl:DefineAlias

proc ::vTcl:DefineAlias {target alias widgetProc top_or_alias cmdalias} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    global widget
    set widget($alias) $target
    set widget(rev,$target) $alias
    if {$cmdalias} {
        interp alias {} $alias {} $widgetProc $target
    }
    if {$top_or_alias != ""} {
        set widget($top_or_alias,$alias) $target
        if {$cmdalias} {
            interp alias {} $top_or_alias.$alias {} $widgetProc $target
        }
    }
}
#############################################################################
## Library Procedure:  vTcl:DoCmdOption

proc ::vTcl:DoCmdOption {target cmd} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    ## menus are considered toplevel windows
    set parent $target
    while {[winfo class $parent] == "Menu"} {
        set parent [winfo parent $parent]
    }

    regsub -all {\%widget} $cmd $target cmd
    regsub -all {\%top} $cmd [winfo toplevel $parent] cmd

    uplevel #0 [list eval $cmd]
}
#############################################################################
## Library Procedure:  vTcl:FireEvent

proc ::vTcl:FireEvent {target event {params {}}} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    ## The window may have disappeared
    if {![winfo exists $target]} return
    ## Process each binding tag, looking for the event
    foreach bindtag [bindtags $target] {
        set tag_events [bind $bindtag]
        set stop_processing 0
        foreach tag_event $tag_events {
            if {$tag_event == $event} {
                set bind_code [bind $bindtag $tag_event]
                foreach rep "\{%W $target\} $params" {
                    regsub -all [lindex $rep 0] $bind_code [lindex $rep 1] bind_code
                }
                set result [catch {uplevel #0 $bind_code} errortext]
                if {$result == 3} {
                    ## break exception, stop processing
                    set stop_processing 1
                } elseif {$result != 0} {
                    bgerror $errortext
                }
                break
            }
        }
        if {$stop_processing} {break}
    }
}
#############################################################################
## Library Procedure:  vTcl:Toplevel:WidgetProc

proc ::vTcl:Toplevel:WidgetProc {w args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    if {[llength $args] == 0} {
        ## If no arguments, returns the path the alias points to
        return $w
    }
    set command [lindex $args 0]
    set args [lrange $args 1 end]
    switch -- [string tolower $command] {
        "setvar" {
            foreach {varname value} $args {}
            if {$value == ""} {
                return [set ::${w}::${varname}]
            } else {
                return [set ::${w}::${varname} $value]
            }
        }
        "hide" - "show" {
            Window [string tolower $command] $w
        }
        "showmodal" {
            ## modal dialog ends when window is destroyed
            Window show $w; raise $w
            grab $w; tkwait window $w; grab release $w
        }
        "startmodal" {
            ## ends when endmodal called
            Window show $w; raise $w
            set ::${w}::_modal 1
            grab $w; tkwait variable ::${w}::_modal; grab release $w
        }
        "endmodal" {
            ## ends modal dialog started with startmodal, argument is var name
            set ::${w}::_modal 0
            Window hide $w
        }
        default {
            uplevel $w $command $args
        }
    }
}
#############################################################################
## Library Procedure:  vTcl:WidgetProc

proc ::vTcl:WidgetProc {w args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    if {[llength $args] == 0} {
        ## If no arguments, returns the path the alias points to
        return $w
    }

    set command [lindex $args 0]
    set args [lrange $args 1 end]
    uplevel $w $command $args
}
#############################################################################
## Library Procedure:  vTcl:toplevel

proc ::vTcl:toplevel {args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    uplevel #0 eval toplevel $args
    set target [lindex $args 0]
    namespace eval ::$target {set _modal 0}
}
}


if {[info exists vTcl(sourcing)]} {

proc vTcl:project:info {} {
    set base .top43
    namespace eval ::widgets::$base {
        set set,origin 1
        set set,size 1
        set runvisible 1
    }
    namespace eval ::widgets::$base.lab44 {
        array set save {-disabledforeground 1 -font 1 -text 1}
    }
    namespace eval ::widgets::$base.cpd45 {
        array set save {-disabledforeground 1 -font 1 -text 1}
    }
    namespace eval ::widgets::$base.cpd46 {
        array set save {-disabledforeground 1 -font 1 -text 1}
    }
    namespace eval ::widgets::$base.che47 {
        array set save {-disabledforeground 1 -font 1 -text 1 -variable 1}
    }
    namespace eval ::widgets::$base.but48 {
        array set save {-command 1 -disabledforeground 1 -font 1 -text 1}
    }
    namespace eval ::widgets::$base.ent49 {
        array set save {-background 1 -insertbackground 1 -textvariable 1}
    }
    namespace eval ::widgets::$base.cpd50 {
        array set save {-background 1 -insertbackground 1 -textvariable 1}
    }
    namespace eval ::widgets::$base.cpd51 {
        array set save {-background 1 -insertbackground 1 -textvariable 1}
    }
    namespace eval ::widgets::$base.lis43 {
        array set save {-background 1 -listvariable 1}
    }
    namespace eval ::widgets::$base.lab45 {
        array set save {-disabledforeground 1 -font 1 -text 1}
    }
    namespace eval ::widgets::$base.but47 {
        array set save {-command 1 -disabledforeground 1 -text 1}
    }
    namespace eval ::widgets::$base.but51 {
        array set save {-command 1 -disabledforeground 1 -text 1}
    }
    set base .top47
    namespace eval ::widgets::$base {
        set set,origin 1
        set set,size 1
        set runvisible 1
    }
    namespace eval ::widgets::$base.ent48 {
        array set save {
            -background 1 -disabledforeground 1 -insertbackground 1 -textvariable 1
        }
    }
    namespace eval ::widgets::$base.but49 {
        array set save {-command 1 -disabledforeground 1 -text 1}
    }
    namespace eval ::widgets::$base.but50 {
        array set save {-command 1 -disabledforeground 1 -text 1}
    }
    namespace eval ::widgets_bindings {
        set tagslist _TopLevel
    }
    namespace eval ::vTcl::modules::main {
        set procs {
            init
            main
            cobol_update
        }
        set compounds {
        }
        set projectType single
    }
}
}

#################################
# USER DEFINED PROCEDURES
#
#############################################################################
## Procedure:  main

proc ::main {argc argv} {
global cobol_fields widget

set cobol_fields {
    name        40
    address     50
    phone       15
    endpgm      1
    quickret      1
}

global nomes_anteriores
if {![info exists nomes_anteriores]} {
        set nomes_anteriores {}
}

#bind all <Return> do_exit
}

proc ::cobol_preprocess {args} {
        global quickret
        if {$quickret} {
                do_exit
        }
}
#############################################################################
## Procedure:  cobol_update

proc ::cobol_update {} {
global widget
global nomes_anteriores name

#puts "tcl-TC LOG: lappend nomes_anteriores $name"
lappend nomes_anteriores $name
focus $widget(nome_entry)

}

#############################################################################
## Initialization Procedure:  init

proc ::init {argc argv} {

}

init $argc $argv

#################################
# VTCL GENERATED GUI PROCEDURES
#

proc vTclWindow. {base} {
    if {$base == ""} {
        set base .
    }
    ###################
    # CREATING WIDGETS
    ###################
    wm focusmodel $top passive
    wm geometry $top 1x1+0+0; update
    wm maxsize $top 1265 994
    wm minsize $top 1 1
    wm overrideredirect $top 0
    wm resizable $top 1 1
    wm withdraw $top
    wm title $top "vtcl.tcl"
    bindtags $top "$top Vtcl.tcl all"
    vTcl:FireEvent $top <<Create>>
    wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <<DeleteWindow>>"

    ###################
    # SETTING GEOMETRY
    ###################

    vTcl:FireEvent $base <<Ready>>
}

proc vTclWindow.top43 {base} {
    if {$base == ""} {
        set base .top43
    }
    if {[winfo exists $base]} {
        wm deiconify $base; return
    }
    set top $base
    ###################
    # CREATING WIDGETS
    ###################
    vTcl:toplevel $top -class Toplevel \
        -highlightcolor black
    wm focusmodel $top passive
    wm geometry $top 570x523+318+169; update
    wm maxsize $top 1265 994
    wm minsize $top 1 1
    wm overrideredirect $top 0
    wm resizable $top 1 1
    wm deiconify $top
    wm title $top "New Toplevel 1"
    vTcl:DefineAlias "$top" "Toplevel1" vTcl:Toplevel:WidgetProc "" 1
    bindtags $top "$top Toplevel all _TopLevel"
    vTcl:FireEvent $top <<Create>>
    wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <<DeleteWindow>>"

    label $top.lab44 \
        -disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Nome:
    vTcl:DefineAlias "$top.lab44" "Label1" vTcl:WidgetProc "Toplevel1" 1
    label $top.cpd45 \
        -disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Endereco:
    vTcl:DefineAlias "$top.cpd45" "Label2" vTcl:WidgetProc "Toplevel1" 1
    label $top.cpd46 \
        -disabledforeground #a1a4a1 -font {helvetica 18 bold} -text Telefone:
    vTcl:DefineAlias "$top.cpd46" "Label3" vTcl:WidgetProc "Toplevel1" 1
    checkbutton $top.che47 \
        -disabledforeground #a1a4a1 -font {helvetica 10} -text concluido \
        -variable endpgm
    vTcl:DefineAlias "$top.che47" "Checkbutton1" vTcl:WidgetProc "Toplevel1" 1
    button $top.but48 \
        -command do_exit -disabledforeground #a1a4a1 \
        -font {helvetica 10 bold} -text entra
    vTcl:DefineAlias "$top.but48" "Button1" vTcl:WidgetProc "Toplevel1" 1
    entry $top.ent49 \
        -background white -insertbackground black -textvariable name
    vTcl:DefineAlias "$top.ent49" "nome_entry" vTcl:WidgetProc "Toplevel1" 1
    entry $top.cpd50 \
        -background white -insertbackground black -textvariable address
    vTcl:DefineAlias "$top.cpd50" "Entry2" vTcl:WidgetProc "Toplevel1" 1
    entry $top.cpd51 \
        -background white -insertbackground black -textvariable phone
    vTcl:DefineAlias "$top.cpd51" "Entry3" vTcl:WidgetProc "Toplevel1" 1
    listbox $top.lis43 \
        -background white -listvariable nomes_anteriores
    vTcl:DefineAlias "$top.lis43" "Listbox1" vTcl:WidgetProc "Toplevel1" 1
    label $top.lab45 \
        -disabledforeground #a1a4a1 -font {verdana -11} \
        -text {nomes
anteriores}
    vTcl:DefineAlias "$top.lab45" "Label4" vTcl:WidgetProc "Toplevel1" 1
    button $top.but47 \
        -command {source /usr/bin/tkcon} -disabledforeground #a1a4a1 \
        -text tkcon
    vTcl:DefineAlias "$top.but47" "Button2" vTcl:WidgetProc "Toplevel1" 1
    button $top.but51 \
        -command {MinhaJanela show} -disabledforeground #a1a4a1 \
        -text {nome (aux)}
    vTcl:DefineAlias "$top.but51" "Button3" vTcl:WidgetProc "Toplevel1" 1
    ###################
    # SETTING GEOMETRY
    ###################
    place $top.lab44 \
        -x 25 -y 35 -anchor nw -bordermode ignore
    place $top.cpd45 \
        -x 25 -y 100 -anchor nw
    place $top.cpd46 \
        -x 25 -y 170 -anchor nw
    place $top.che47 \
        -x 30 -y 440 -anchor nw -bordermode ignore
    place $top.but48 \
        -x 205 -y 430 -anchor nw -bordermode ignore
    place $top.ent49 \
        -x 140 -y 40 -width 403 -height 27 -anchor nw -bordermode ignore
    place $top.cpd50 \
        -x 175 -y 100 -width 368 -height 27 -anchor nw
    place $top.cpd51 \
        -x 175 -y 175 -width 273 -height 27 -anchor nw
    place $top.lis43 \
        -x 155 -y 245 -width 383 -height 156 -anchor nw -bordermode ignore
    place $top.lab45 \
        -x 35 -y 250 -anchor nw -bordermode ignore
    place $top.but47 \
        -x 470 -y 430 -anchor nw -bordermode ignore
    place $top.but51 \
        -x 320 -y 430 -anchor nw -bordermode ignore

    vTcl:FireEvent $base <<Ready>>
}

proc vTclWindow.top47 {base} {
    if {$base == ""} {
        set base .top47
    }
    if {[winfo exists $base]} {
        wm deiconify $base; return
    }
    set top $base
    ###################
    # CREATING WIDGETS
    ###################
    vTcl:toplevel $top -class Toplevel \
        -highlightcolor black
    wm withdraw $top
    wm focusmodel $top passive
    wm geometry $top 433x150+169+728; update
    wm maxsize $top 1265 994
    wm minsize $top 1 1
    wm overrideredirect $top 0
    wm resizable $top 1 1
    wm title $top "New Toplevel 2"
    vTcl:DefineAlias "$top" "MinhaJanela" vTcl:Toplevel:WidgetProc "" 1
    bindtags $top "$top Toplevel all _TopLevel"
    vTcl:FireEvent $top <<Create>>
    wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <<DeleteWindow>>"

    entry $top.ent48 \
        -background white -disabledforeground #a1a4a1 -insertbackground black \
        -textvariable name1
    vTcl:DefineAlias "$top.ent48" "Entry1" vTcl:WidgetProc "MinhaJanela" 1
    button $top.but49 \
        -command {global name name1
set name $name1
MinhaJanela hide} \
        -disabledforeground #a1a4a1 -text ok
    vTcl:DefineAlias "$top.but49" "Button1" vTcl:WidgetProc "MinhaJanela" 1
    button $top.but50 \
        -command {MinhaJanela hide} -disabledforeground #a1a4a1 -text fechar
    vTcl:DefineAlias "$top.but50" "Button2" vTcl:WidgetProc "MinhaJanela" 1
    ###################
    # SETTING GEOMETRY
    ###################
    place $top.ent48 \
        -x 50 -y 30 -width 353 -height 27 -anchor nw -bordermode ignore
    place $top.but49 \
        -x 145 -y 90 -anchor nw -bordermode ignore
    place $top.but50 \
        -x 240 -y 90 -anchor nw -bordermode ignore

    vTcl:FireEvent $base <<Ready>>
}

#############################################################################
## Binding tag:  _TopLevel

bind "_TopLevel" <<Create>> {
    if {![info exists _topcount]} {set _topcount 0}; incr _topcount
}
bind "_TopLevel" <<DeleteWindow>> {
    if {[set ::%W::_modal]} {
                vTcl:Toplevel:WidgetProc %W endmodal
            } else {
                destroy %W; if {$_topcount == 0} {exit}
            }
}
bind "_TopLevel" <Destroy> {
    if {[winfo toplevel %W] == "%W"} {incr _topcount -1}
}

Window show .
Window show .top43
Window show .top47

main $argc $argv
## ** ##

#!/bin/sh
# the next line restarts using wish\
exec wish "$0" "$@"
# this script receives "data_block" with the (group) value
# of the cobol variable and returns "result"

## visual tcl leaves the main window iconified, so let's show it
wm deiconify .

###### put in this list varname, size pairs

set cobol_fields {
        title                 20
        url                         50
}

grid [label .msg -text \
        "Use <Tab> to navigate, <Return> (or click button) \n\
to return to main program."] -columnspan 2

grid \
        [label .lab1 -text "Title:"] \
        [entry .e1 -width 20 -textvariable title] -padx 5 -pady 5 -sticky nsw
grid \
        [label .lab2 -text "URL:"] \
        [entry .e2 -width 50 -textvariable url] -padx 5 -pady 5 -sticky nsw

grid [button .ready -text Enter -command do_exit] \
        -columnspan 2 -pady 20 -sticky ns

bind all <Return> do_exit
focus .e1

#trace add variable ::ready write show_variables


proc show_variables {args} {
        uplevel #0 {
                set exclude {^::(env|auto_index|tcl_.*|widget|tk_.*|auto_.*)$}
                puts "variables: -----------------------------------------"
                foreach v [info vars ::*] {
                        if {[regexp $exclude $v]} {
                                continue
                        }
                        if {[array exists $v]} {
                                puts "$v: [array get $v]"
                        } else {
                                puts "$v: [set $v]"
                        }
                }
        }
}

> "Falcon list comprehension called from GnuCOBOL"
sums = [].mfcomp( {x,y=> x+y}, .[1 2 3], .[4 5 6] )
return sums.describe()

$ ./callfalcon
argv[1]: falconscript.fal
Falcon list comprehension called from GnuCOBOL
VM Output: [ 5, 6, 7, 6, 7, 8, 7, 8, 9]
Intermediate: [ 5, 6, 7, 6, 7, 8, 7, 8, 9]
Falcon says: [ 5, 6, 7, 6, 7, 8, 7, 8, 9]

OCOBOL*>>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:
      *> Purpose:
      *> Tectonics: cobc -x callfalcon.cob ocfalcon.o
      *>            $(falcon-conf --libs-only-l) -lstdc++
      *> ***************************************************************
       identification division.
       program-id. callfalcon.

       data division.
       working-storage section.
       01 argc usage binary-long value 2.
       01 argv.
          03 pointers usage pointer occurs 2 times.
       01 mock.
          03 strings pic x(80) occurs 2 times.

       01 stat usage binary-long.
       01 result pic x(80).
       01 resmax usage binary-long value 80.
       01 display-string pic x(80).

      *> ***************************************************************
       procedure division.

      *> Setup an argc, argv thingy
       move "callfalcon" & x"00" to strings(1)
       move "falconscript.fal" &x"00" to strings(2)
       set pointers(1) to address of strings(1)
       set pointers(2) to address of strings(2)

       call "CBL_OC_FALCON" using
            by value argc
            by reference argv
            by reference result
            by value resmax
            returning stat
       end-call
       string
           result delimited by low-value into display-string
       end-string
       display "Falcon says: " display-string end-display

       goback.
       end program callfalcon.

/*
   MODIFIED BY btiffin to interface with OpenCOBOL

   FALCON - The Falcon Programming Language.
   FILE: falcon_embed_3.cpp

   Embedding samples
   Adding VM interaction - input parameters and output result

   VM can give the embedder program access to exported symbols.
   The items inside the VM can be inspected and changed.
   The core module exports three symbols that every kind embedder
   should fill: the scriptName, scriptPath and args global variables.

   When a script returns from a routine, or from the main code, the
   return value is left in the A register of the VM. This script
   will transform that item in a string and will report it
   as output.

   Compile with
      g++ $(falcon-conf --cflags-only-I) $(falcon-conf -L) \
         falcon_embed_3.cpp -o falcon_embed_3

   -------------------------------------------------------------------
   Author: Giancarlo Niccolai
   Begin: 2007-08-11 19:49:00

   -------------------------------------------------------------------
   (C) Copyright 2004: the FALCON developers (see list in AUTHORS file)

   See LICENSE file for licensing details.
*/

// Inclusion of the Falcon Engine
#include <falcon/engine.h>
#include <iostream>
#include <string.h>

class AppFalcon
{
public:
   AppFalcon();
   ~AppFalcon();
   const char* embed( const char *script_name, int argc, char **argv );
};

AppFalcon::AppFalcon()
{
   Falcon::Engine::Init();
}

AppFalcon::~AppFalcon()
{
   Falcon::Engine::Shutdown();
}

// This is the routine that embeds falcon
const char* AppFalcon::embed( const char *script_name, int argc, char **argv )
{
   // first of all, we need a module loader to load the script.
   // The parameter is the search path for where to search our module
   Falcon::ModuleLoader theLoader(".");

   // As we want to use standard Falcon installation,
   // tell the loader that is safe to search module in system path
   theLoader.addFalconPath();

   // Allow the script to load iteratively other resources it may need.
   Falcon::Runtime rt( &theLoader );
   rt.loadFile( script_name );

   // We are ready to go. Let's create our VM and link in minimal stuff
   Falcon::VMachineWrapper vm;

   vm->link( Falcon::core_module_init() );  // add the core module

   // try to link our module and its dependencies.
   // -- It may fail if there are some undefined symbols
   vm->link( &rt );

   // Now that we have linked everything, we can set the script name,
   // the script path and the arguments.

   Falcon::Item *scriptName = vm->findGlobalItem( "scriptName" );
   Falcon::Item *scriptPath = vm->findGlobalItem( "scriptPath" );
   Falcon::Item *args = vm->findGlobalItem( "args" );

   // get the topmost (and so, the main) module, just to set the correct name.
   const Falcon::Module *mainMod = vm->mainModule()->module();

   //items can directly be set to Core and Garbage object pointers.
   *scriptName = new Falcon::CoreString( mainMod->name() );
   *scriptPath = new Falcon::CoreString( script_name );

   // create the arguments.
   // It is correct to pass an empty array if we haven't any argument to pass.
   Falcon::CoreArray *argsArray = new Falcon::CoreArray;
   for( int i = 0; i < argc; i ++ )
   {
      argsArray->append( new Falcon::CoreString( argv[i] ) );
   }
   *args = argsArray;

   // end of parameters

   // we're ready to go. Still, we may fail if the script has not a main routine.
   vm->launch();

   // We should have now an output value. It is advisable to turn it
   // in a string before to show it.
   Falcon::String str_regA;
   vm->regA().toString( str_regA );

   // Falcon provides a nice helper to convert falcon strings into char * or wchar_t
   Falcon::AutoCString c_regA( str_regA );
   std::cout << "VM Output: " << c_regA.c_str() << std::endl;

   return c_regA.c_str();
}

extern "C" {
    int CBL_OC_FALCON(int argc, char* argv[], char* result, int resmax) {
       //====================================================
       // Falcon engine initialization.
       AppFalcon myApp;

       char *script_name;
       const char *intermediate;

       if ( argc < 2 ) {
          std::cout << "Please, provide a script name" << std::endl;
          return 0;
       }

       script_name = argv[1];
       std::cout << "argv[1]: " << script_name << std::endl;

       // now we also pass the arguments.
       try {
          intermediate = myApp.embed( script_name, argc - 2, argv + 2 );
          std::cout << "Intermediate: " << intermediate << std::endl;
          memcpy(result, intermediate, resmax);
          return 0;
       }
       catch( Falcon::Error* err )
       {
          // This time let's use a Falcon stream,
          // that knows how to handle Falcon strings.
          Falcon::Stream* stdErr = new Falcon::StdErrStream();
          stdErr->writeString( err->toString() );
          err->decref();
          delete stdErr;
          return 0;
       }
    }
}

> "Falcon called from OpenCOBOL"
return "42"

prompt$ g++ $(falcon-conf --cflags-only-I) $(falcon-conf -L) ocfalcon.cpp -c
prompt$ cobc -x callfalcon.cob ocfalcon.o $(falcon-conf --libs-only-l) -lstdc++
prompt$ ./callfalcon
argv[1]: falconscript.fal
Falcon called from OpenCOBOL
VM Output: 42
Intermediate: 42
Falcon says: 42

> "Falcon list comprehension called from OpenCOBOL"
sums = [].mfcomp( {x,y=> x+y}, .[1 2 3], .[4 5 6] )
return sums.describe()

prompt$ ./callfalcon
argv[1]: falconscript.fal
Falcon list comprehension called from OpenCOBOL
VM Output: [ 5, 6, 7, 6, 7, 8, 7, 8, 9]
Intermediate: [ 5, 6, 7, 6, 7, 8, 7, 8, 9]
Falcon says: [ 5, 6, 7, 6, 7, 8, 7, 8, 9]

saying = List("Have", "a", "nice", "day")

for elem in saying
   >> elem
   formiddle: >> " "
   forlast: > "!"
end

Have a nice day!

with Interfaces.C;
use Interfaces.C;
package HelloAda is

   procedure hello;
   procedure ingress(value : in INTEGER);
   function echo(message : in char_array) return integer;
   pragma export(C, hello);
   pragma export(C, ingress);
   pragma export(C, echo);

end HelloAda;

with Ada.Text_IO, Ada.Integer_Text_IO, Interfaces.C;
use  Ada.Text_IO, Ada.Integer_Text_IO, Interfaces.C;
package body HelloAda is

procedure hello is
begin
   Put_Line("Hello from Ada and GnuCOBOL");
   New_Line;
end hello;

procedure ingress(value : in integer) is
begin
   Put_Line("Passing integer to Ada from GnuCOBOL");
   Put("GnuCOBOL passed: ");
   Put(value);
   New_Line;
   New_Line;
end ingress;

function echo(message : in char_array) return integer is
begin
    Put(To_Ada(message, true));
    return To_Ada(message, true)'length;
end echo;

end HelloAda;

GCobol******************* adacaller.cob ********************************
       >>SOURCE FORMAT IS FIXED
      ******************************************************************
      * Author:    Brian Tiffin
      * Date:      08-Sep-2008
      * Purpose:   Demonstrate using Ada subprograms
      * Tectonics: gnatgcc -c helloada.adb
      *            gnatbind -n helloada
      *            gnatgcc -c b~helloada.abd
      *            cobc -x -lgnat caller.cob helloada.o b~helloada.o
      ******************************************************************
       identification division.
       program-id. caller.

       data division.
       working-storage section.
       01 ada-message      pic x(10) value "Ada echo" & x'0a' & x'00'.
       01 result           pic s9(9) value high-value.
      *****************************************************************
       procedure division.
       begin.
       call "adainit" end-call

       call "hello" end-call

       call "ingress" using by value 42 end-call

       call "echo" using
           by reference ada-message
           returning result
       end-call
       display "Ada return: " result end-display

       call "adafinal" end-call

       goback
       .
       end program caller.

gnatgcc -c helloada.adb
gnatbind -n helloada
gnatgcc -c b~helloada.adb
cobc -x -lgnat adacaller.cob helloada.o b~helloada.o

Hello from Ada and GnuCOBOL

Passing integer to Ada from GnuCOBOL
GnuCOBOL passed:          42

Ada echo
Ada return: +000000009

/* Call GnuCOBOL from Vala */

public class from.vala
{

    public static int main(string[] args)
    {
        stdout.printf("Result: %d\n", ochello());
        return 0;

    }
    [import()]
    public extern static int ochello();
}
/**/

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20101017
      *> Purpose:   Call ochello from Vala in a from.vala Class
      *> Tectonics:
      *>   cobc -fimplicit-init -C ochello.cob
      *>   valac callcobol.vala ochello.c -X -lcob
      *> ***************************************************************
       identification division.
       program-id. from_vala_ochello.

      *> ***************************************************************
       procedure division.
       display "Hello GnuCOBOL's World!" end-display
       move 42 to return-code
       goback.
       end program from_vala_ochello.

// Call GnuCOBOL program from Vala and show the return code on a button
using Gtk;

public class from.vala {
    public static int cobolcode;
    public static char[] valarray = new char[80];

    public static int main (string[] args) {

        Gtk.init (ref args);
        var time = new TimeoutSource(50);

        var window = new Window (WindowType.TOPLEVEL);
        window.title = "Invoke GnuCOBOL program";
        window.set_default_size (300, 50);
        window.position = WindowPosition.CENTER;
        window.destroy.connect (Gtk.main_quit);

        cobolcode = ochello();

        var button = new Button.with_label (cobolcode.to_string());
        button.clicked.connect (() => {
            button.label = "Thanks for all the fish!";
            stdout.printf("%d\n", fishy());
        });

        time.set_callback(() => {
            var t = Time.local(time_t());
            string fromvala = "From vala string type + time to_string:  "
                              + t.to_string();
            string fromcobol = "xxxx/xx/xxbxx/xx/xxxxxxx/xx";

            stdout.printf("Vala fromcobol string was   : %s\n", fromcobol);

            datey(fromvala, fromcobol);

            stdout.printf("Vala fromcobol string set to: %s\n", fromcobol);
            return true;
        });

        time.attach(null);

        window.add (button);
        window.show_all ();

        Gtk.main ();
        return 0;
    }

    [import()]
    public extern static int ochello();
    public extern static int fishy();
    public extern static int datey(string arg1, string arg2);
}

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20101017
      *> Purpose:   Call ochello from Vala in a from.vala Class
      *> Tectonics:
      *>   cobc -fimplicit-init -C ochellogui.cob
      *>   valac --pkg gtk+-2.0 callcobolgui.vala ochellogui.c -X -lcob
      *> ***************************************************************
       identification division.
       program-id. from_vala_ochello.
       procedure division.
       display "Hello GnuCOBOL's Wonderful World!" end-display
       move 42 to return-code
       goback.
       end program from_vala_ochello.

      *> ***************************************************************
      *> ***************************************************************

       program-id. from_vala_fishy.
       procedure division.
       display "We really do mean, thanks for all the fish!" end-display
       goback.
       end program from_vala_fishy.

      *> ***************************************************************
      *> ***************************************************************

       program-id. from_vala_datey.
       data division.
       working-storage section.
       01 editted-date pic xxxx/xx/xxbxx/xx/xxxxxxx/xx.

       linkage section.
       01 datafromvala pic x(60).
       01 datafromcobol pic x(27).

       procedure division using datafromvala datafromcobol.
       move function current-date to editted-date
       inspect editted-date replacing all "/" by ":" after initial space
       display editted-date end-display

       display datafromvala end-display

       move editted-date to datafromcobol
       goback.
       end program from_vala_datey.

$ ./callcobolgui
...
Vala fromcobol string was   : xxxx/xx/xxbxx/xx/xxxxxxx/xx
2010/10/17 18:19:5598-04:00
From vala string type + time to_string:  2010-10-17 18:19:55
Vala fromcobol string set to: 2010/10/17 18:19:5598-04:00
Vala fromcobol string was   : xxxx/xx/xxbxx/xx/xxxxxxx/xx
2010/10/17 18:19:5603-04:00
From vala string type + time to_string:  2010-10-17 18:19:56
Vala fromcobol string set to: 2010/10/17 18:19:5603-04:00
...

// Tectonics: valac -c piping.gs
[indent=4]
class wrapper : Object
    def static hellogenie() : int
        ret_stdout : string
        ret_stderr : string
        ret_status : int

        try
            Process.spawn_command_line_sync("ech 'ech?'", out ret_stdout,
                out ret_stderr, out ret_status)
        except ex : Error
            print("in catch")
            print(ex.message)

        print("stdout: %s", ret_stdout)
        print("stderr: %s", ret_stderr)
        print("status: %d", ret_status)

        try
            Process.spawn_command_line_sync("echo -n 'hey it works!'",
                out ret_stdout, out ret_stderr, out ret_status)
        except ex : Error
            print("in catch")
            print(ex.message)

        print("stdout: %s", ret_stdout)
        print("stderr: %s", ret_stderr)
        print("status: %d", ret_status)

        return 42

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* =========
      *><* callgenie
      *><* =========
      *><* :Author:    Brian Tiffin
      *><* :Date:      29-Sep-2010
      *><* :Purpose:   Demonstrate getting at Genie code
      *><* :Tectonics:
      *><*    valac -c piping.gs
      *><*    cobc -x callgenie.cob piping.vala.o
      *><*         -lglib-2.0 -lgobject-2.0
      *> ***************************************************************
       identification division.
       program-id. callgenie.

       data division.
       working-storage section.
       01 result usage binary-long.

      *> ***************************************************************
       procedure division.
       call "wrapper_hellogenie" returning result end-call
       display "Result from Genie: " result end-display
       .
       goback.
       end program callgenie.
      *><*
      *><* Last Update: 29-Sep-2010

[btiffin@home vala]$ ./callgenie
in catch
Failed to execute child process "ech" (No such file or directory)
stdout: (null)
stderr: (null)
status: 0
stdout: hey it works!
stderr:
status: 0
Result from Genie: +0000000042

// Tectonics: valac -c genieregex.gs
[indent=4]
class cbl.oc.genie : Object
    def static regexing(pattern : string, subject : string, out value : string,
                        out leng : int) : int
        print " "
        print "Pattern: %s", pattern
        print "Subject: %s", subject
        try
            var r = new Regex(pattern)
            var s = subject
            s = r.replace(s, s.length, 0, "COBOL")
            value = s
            leng = (int)s.length
        except ex : Error
            print ex.message
            value = subject
            leng = (int)subject.length
            return 1
        return 0

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* ================
      *><* Call Genie Regex
      *><* ================
      *><* :Author:    Brian Tiffin
      *><* :Date:      20101101
      *><* :Purpose:   Getting at Genie Regex code
      *><* :Tectonics: vala -c genieregex.gs
      *><*             cobc -x callgenieregex.cob genieregex.vala.o
      *><*                  -lglib-2.0 -lgobject-2.0
      *> ***************************************************************
       identification division.
       program-id. callgenieregex.

       data division.
       working-storage section.
       01 pattern pic x(80) value "Fortran|APL|Python" & x"00".
       01 subject pic x(80) value
           "GnuCOBOL, Fortran, Vala, Genie, Python, C, APL" & x"00".
       01 out-pointer usage pointer.
       01 out-length usage binary-long.
       01 middleman pic x(80) based.
       01 replacement pic x(80).
       01 result usage binary-long.

      *> ***************************************************************
       procedure division.
       call "cbl_oc_genie_regexing"
           using
               by reference pattern
               by reference subject
               by reference out-pointer
               by reference out-length
           returning result
       end-call
       display "Result from Genie: " result end-display

       set address of middleman to out-pointer
       move middleman(1:out-length) to replacement
       display "replacement now: " replacement end-display

       move "(red)" & x'00' to pattern
       move "The red car was going too fast" & x'00' to subject
       move 0 to out-length
       set out-pointer to null
       free middleman

       call "cbl_oc_genie_regexing"
           using
               by reference pattern
               by reference subject
               by reference out-pointer
               by reference out-length
           returning result
       end-call
       display "Result from Genie: " result end-display

       set address of middleman to out-pointer
       move middleman(1:out-length) to replacement
       display "replacement now: " replacement end-display

       move "[:digit:]" & x'00' to pattern
       move "The Regex fails" & x'00' to subject
       move 0 to out-length
       set out-pointer to null
       free middleman

       call "cbl_oc_genie_regexing"
           using
               by reference pattern
               by reference subject
               by reference out-pointer
               by reference out-length
           returning result
       end-call
       display "Result from Genie: " result end-display

       set address of middleman to out-pointer
       move middleman(1:out-length) to replacement
       display "replacement now: " replacement end-display
       goback.
       end program callgenieregex.

$ valac -g -v -c genieregex.gs
cc -g -c '/home/btiffin/lang/cobol/genieregex.vala.c' \
         -pthread -I/usr/include/glib-2.0 -I/usr/lib64/glib-2.0/include

$ cobc -g -debug -v -x callgenieregex.cob genieregex.vala.o -lgobject-2.0 -lglib-2.0
Preprocessing:  callgenieregex.cob to callgenieregex.i
Return status:  0
Parsing:        callgenieregex.i
Return status:  0
Translating:    callgenieregex.i to callgenieregex.c
Executing:      gcc -c -I/usr/local/include -pipe -g -Wno-unused -fsigned-char
                -Wno-pointer-sign -o "/tmp/cob3411_0.o" "callgenieregex.c"
Return status:  0
Executing:      gcc -Wl,--export-dynamic -o "callgenieregex"
                "/tmp/cob3411_0.o" "genieregex.vala.o" -L/usr/local/lib -lcob
                -lm -lgmp -lncurses -ldb -ldl -l"gobject-2.0" -l"glib-2.0"
Return status:  0

$ ./callgenieregex

Pattern: Fortran|APL|Python
Subject: GnuCOBOL, Fortran, Vala, Genie, Python, C, APL
Result from Genie: +0000000000
replacement now: GnuCOBOL, COBOL, Vala, Genie, COBOL, C, COBOL

Pattern: (red)
Subject: The red car was going too fast
Result from Genie: +0000000000
replacement now: The COBOL car was going too fast

Pattern: [:digit:]
Subject: The Regex fails
Error while compiling regular expression [:digit:] at char 0:
      POSIX named classes are supported only within a class
Result from Genie: +0000000001
replacement now: The Regex fails

$ apt-get install libslang2

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20090503
      *> Purpose:   Experimental S-Lang interface
      *> Tectonics: cobc -x slangkey.cob -lslang
      *> ***************************************************************
       identification division.
       program-id. slangkey.

       data division.
       working-storage section.
       01 thekey               usage binary-long unsigned.
       01 thekm                usage binary-long.
       01 result               usage binary-long.

      *> exit handler address and priority (prio is IGNORED with OC1.1)
       01 install-flag       pic 9 comp-x value 0.
       01  install-params.
           02 exit-addr      usage is procedure-pointer.
           02 handler-prio   pic 999 comp-x.

      *> ***************************************************************
       procedure division.

      *> Initialize low and high level S-Lang terminal routines
       call "SLtt_get_terminfo" end-call
       call "SLkp_init" returning result end-call
       if result equal -1
           display "problem intializing S-Lang tty" end-display
           stop run giving 1
       end-if

       call "SLang_init_tty" using
           by value -1     *> abort char
           by value -1     *> flow ctrl
           by value 0      *> output processing
         returning result
       end-call
       if result equal -1
           display "problem intializing S-Lang tty" end-display
           stop run giving 1
       else
           display "Keyboard in special mode" x"0d" end-display
       end-if

      *> install an exit handler to put terminal back
       set exit-addr to entry "tty-reset"
       call "CBL_EXIT_PROC" using
           install-flag
           install-params
           returning result
       end-call
       if result not equal zero
           display "error installing exit procedure" end-display
       end-if

      *> Not sure?  Have SLang handle ^C or let GnuCOBOL take over?
       call "SLang_set_abort_signal" using by value 0 end-call

      *> The demo.  Fetch a key, then fetch a keycode.  4 times.
      *>   SLang terminals display newline as newline.  Need explicit
      *>   CR to get a carriage return.  Hence the x"0d".
      *>   Plus, output is buffered until line terminators.
       display
           "Tap a normal key, then tap a 'special' key, ie F1, 4 times"
           x"0d"
       end-display
       perform 4 times
           call "SLang_getkey" returning thekey end-call
           display thekey space with no advancing end-display
           call "SLkp_getkey" returning thekm end-call
           display thekm x"0d" end-display
       end-perform

      *> Exit handler will take care of resetting terminal
       goback.
       end program slangkey.


      *> ***************************************************************
      *> Exit procedure to ensure terminal properly reset
      *> ***************************************************************
       identification division.
       program-id. tty-reset.

       call "SLang_reset_tty" end-call
       display "exit proc, reset the tty" end-display

       goback.
       end program tty-reset

Keyboard in special mode
Tap a normal key, then tap a 'special' key, ie F1, 4 times
0000000097 +0000000513
0000000001 +0000000002
0000000099 +0000065535
0000000003 +0000000003
exit proc, reset the tty

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20090505
      *> Purpose:   Experimental S-Lang interface
      *> Tectonics: cobc -x callslang.cob -lslang
      *> ***************************************************************
       identification division.
       program-id. callslang.

       data division.
       working-storage section.
       01 result               usage binary-long.
       01 cobol-integer        usage binary-long value 42.
       01 cobol-float          usage float-long value 0.0.
       01 sl-int-type          constant as 20.
       01 sl-double-type       constant as 27.
       01 read-write           constant as 0.

      *> ***************************************************************
       procedure division.

      *> Initialize S-Lang
       call "SLang_init_all" returning result
       if result equal -1
           display "Sorry, problem initializing SLang" end-display
       end-if

      *> Register "slint" variable
       call "SLadd_intrinsic_variable" using
           by reference "slint" & x"00"
           by reference cobol-integer
           by value sl-int-type
           by value read-write
           returning result
       end-call
       if result equal -1
           display "Could not register cobol-integer" end-display
       end-if

      *> Register "sldbl" variable
       call "SLadd_intrinsic_variable" using
           by reference "sldbl" & x"00"
           by reference cobol-float
           by value sl-double-type
           by value read-write
           returning result
       end-call
       if result equal -1
           display "Could not register cobol-float" end-display
       end-if

       call "SLang_load_string" using
           "sldbl = sum([0, 1, 2, 3, 4, 5, 6, 7, 8, 9]);" & x"00"
           returning result
       end-call
       if result equal -1
           display "Could not interpret sum intrinsic" end-display
       end-if
       display "S-Lang set cobol-float to " cobol-float end-display

       display "Next lines of output are S-Lang printf" end-display
       call "SLang_load_string" using
           '() = printf("slint (cobol-integer) = %d\n", slint);' & x"00"
           returning result
       end-call
       if result equal -1
           display "Could not interpret printf" end-display
       end-if

       add 1 to cobol-integer

       call "SLang_load_string" using
           '() = printf("slint after COBOL add = %d\n", slint);' & x"00"
           returning result
       end-call
       if result equal -1
           display "error with printf after cobol add" end-display
       end-if

      *> Let's get out of here and do the Dilbert Nerd Dance...Woohoo!
       goback.
       end program callslang.

S-Lang set cobol-float to 45.000000000000000000
Next lines of output are S-Lang printf
slint (cobol-integer) = 42
slint after COBOL add = 43

<?xml version="1.0"?>
<Custom>
  <Language>
    <Name>GnuCOBOL</Name>
    <Spec_Suffix>.cob</Spec_Suffix>
    <Extension>.cbl</Extension>
    <Extension>.cpy</Extension>

    <Keywords>^(identification|id|environment|data|procedure|division|</Keywords>
    <Keywords>program-id|author|</Keywords>
    <Keywords>configuration|source-computer|object-computer|</Keywords>
    <Keywords>special-names|repository|</Keywords>
    <Keywords>input-output|file-control|io-control|</Keywords>
    <Keywords>file|working-storage|local-storage|linkage|</Keywords>
    <Keywords>communication|report|screen|</Keywords>
    <Keywords>section|declaratives|</Keywords>
    <Keywords>end|</Keywords>
    <Keywords>perform|end-perform|until|times|varying|</Keywords>
    <Keywords>add|subtract|multiply|divide|compute|</Keywords>
    <Keywords>end-add|end-subtract|end-multiply|end-divide|end-compute|</Keywords>
    <Keywords>accept|display|read|write|rewrite|sort|</Keywords>
    <Keywords>end-accept|end-display|end-read|end-write|end-rewrite|</Keywords>
    <Keywords>move|evaluate|end-evaluate|if|end-if|when|</Keywords>
    <Keywords>(un)?string|end-(un)?string|call|end-call|</Keywords>
    <Keywords>goback|stop[\s]+run|</Keywords>
    <Keywords>filler|low-value[s]?|high-value[s]?|space[s]?|zero[es]?[s]?)\b</Keywords>

    <Context>
      <New_Line_Comment_Start>\*&gt;|[ ]{6}\*</New_Line_Comment_Start>
      <String_Delimiter>&quot;</String_Delimiter>
      <Constant_Character>&apos;</Constant_Character>
      <Can_Indent>True</Can_Indent>
      <Syntax_Highlighting>True</Syntax_Highlighting>
      <Case_Sensitive>False</Case_Sensitive>
    </Context>

    <Categories>
      <Category>
        <Name>procedure</Name>
        <Pattern>^[0-9a-z]+\.</Pattern>
        <Index>1</Index>
        <Icon>subprogram_xpm</Icon>
      </Category>
    </Categories>
  </Language>

  <alias name="program">
    <param name="pid">prog</param>
    <text>*&gt;OC&lt;*
      *&gt;&gt;SOURCE FORMAT IS FIXED
      *&gt; ***************************************************************
      *&gt; Author:    Brian Tiffin
      *&gt; Date:      %D
      *&gt; Purpose:   %_
      *&gt; Tectonics: make
      *&gt; ***************************************************************
       identification division.
       program-id %(pid).

       environment division.
       configuration section.
       special-names.
       repository.
       input-output section.

       data division.
       file section.
       working-storage section.
       local-storage section.
       linkage section.
       screen section.

       procedure division.
       declaratives.
       end declaratives.

       00-main.

       .
       00-finish.
       goback.
      *&gt; ***************************************************************

       end program %(pid).
    </text>
  </alias>

  <Language>
    <Name>Vala</Name>
    <Spec_Suffix>.vala</Spec_Suffix>

    <Keywords>^(bool|char|constpointer|double|float|size_t|ssize_t|string|</Keywords>
    <Keywords>unichar|void|int|int8|int16|int32|int64|long|short|</Keywords>
    <Keywords>uint|uint8|uint16|uint32|uint64|ulong|ushort|</Keywords>
    <Keywords>class|delegate|enum|errordomain|interface|namespace|struct|</Keywords>
    <Keywords>break|continue|do|for|foreach|return|while|</Keywords>
    <Keywords>else|if|switch|</Keywords>
    <Keywords>case|default|</Keywords>
    <Keywords>abstract|const|dynamic|ensures|extern|inline|internal|override|</Keywords>
    <Keywords>private|protected|public|requires|signal|static|virtual|</Keywords>
    <Keywords>volatile|weak|false|null|true|</Keywords>
    <Keywords>try|catch|finally|throw|</Keywords>
    <Keywords>as|base|construct|delete|get|in|is|lock|new|out|params|ref|</Keywords>
    <Keywords>sizeof|set|this|throws|typeof|using|value|var|yield|yields)\b</Keywords>

    <Context>
      <New_Line_Comment_Start>//</New_Line_Comment_Start>
      <Comment_Start>/*</Comment_Start>
      <Comment_End>*/</Comment_End>
      <String_Delimiter>&quot;</String_Delimiter>
      <Constant_Character>&apos;</Constant_Character>
      <Can_Indent>True</Can_Indent>
      <Syntax_Highlighting>True</Syntax_Highlighting>
      <Case_Sensitive>True</Case_Sensitive>
    </Context>

    <Categories>
      <Category>
        <Name>procedure</Name>
        <Pattern>^[0-9a-z]+\.</Pattern>
        <Index>1</Index>
        <Icon>subprogram_xpm</Icon>
      </Category>
    </Categories>
  </Language>

  <tool name="cobc" package="OpenCOBOL" index="opencobol">
    <language>OpenCOBOL</language>
    <initial-cmd-line>-m</initial-cmd-line>
      <switches lines="3" columns="2">
         <title line="1" column="1" >Code generation</title>
         <title line="1" column="2" >Run-time options</title>
         <title line="2" column="1" line-span="2" >Source forms and Warnings</title>
         <title line="3" column="1" line-span="0" />
         <title line="2" column="2" >Debugging</title>
         <title line="3" column="2" >Syntax</title>

         <radio>
            <radio-entry label="Build dynamic module (default)" switch="-m" />
            <radio-entry label="Build executable" switch="-x" />
            <radio-entry label="Build object file" switch="-c" />
            <radio-entry label="Preprocess only" switch="-E" />
            <radio-entry label="Translation only, COBOL to C" switch="-C" />
            <radio-entry label="Compile only, output assembly file" switch="-S" />
         </radio>
         <check label="Syntax checking only" switch="-fsyntax-only"
                tip="Syntax error checking only; no output emitted" />

         <combo label="Optimization" switch="-O" nodigit="1" noswitch="0"
                tip="Controls the optimization level">
            <combo-entry label="No optimization" value="0" />
            <combo-entry label="Simple optimization" value="1" />
            <combo-entry label="Some more optimization" value="s" />
            <combo-entry label="Full optimization" value="2" />
         </combo>

         <field label="Generate listing to " switch="-t" separator=" " as-file="true"
                tip="Generate a listing file to given filename" />
         <field label="Save generated files to " switch="-save-temps"
                separator="=" as-directory="true"
                tip="Save temporary files to given directory" />

         <radio line="2" column="1">
            <radio-entry label="Format FIXED" switch="-fixed"
                tip="Standards mandate default is fixed format source code" />
            <radio-entry label="Format FREE (FIXED is default)" switch="-free"
                tip="Assume free format source code" />
         </radio>
         <check label="MF comment (may lead to ambiguous source)"
                switch="-fmfcomment" line="2" column="1"
                tip="Allow * or / in column 1 as FIXED format line comment" />
         <check label="FUNCTION implied" switch="-ffunctions-all" line="2" column="1"
                tip="Allow use of intrinsic functions without FUNCTION keyword" />
         <check label="Fold Copy LOWER" switch="-ffold-copy-lower" line="2" column="1"
                tip="Fold COPY subject to lower case" />
         <check label="Fold Copy UPPER" switch="-ffold-copy-upper" line="2" column="1"
                tip="Fold COPY subject to upper case" />
         <check label="Full Warnings" switch="-W" line="2" column="1"
                tip="ALL possible warnings" />
         <popup label="Warnings" line="2" column="1">
            <check label="All (exceptions listed below)" switch="-Wall" />
            <check label="Obsolete" switch="-Wobsolete"
                   tip="Warn if obsolete features used" />
            <check label="Archaic" switch="-Warchaic"
                   tip="Warn if archaic features used" />
            <check label="Redefinition" switch="-Wredefinition"
                   tip="Warn of incompatible redefinition of data items" />
            <check label="Constant" switch="-Wconstant"
                   tip="Warn of inconsistent constant" />
            <check label="Parentheses" switch="-Wparentheses"
                   tip="Warn of lack of parentheses around AND within OR" />
            <check label="Strict typing" switch="-Wstrict-typing"
                   tip="Warn of type mismatch, strictly" />
            <check label="Implicit define" switch="-Wimplicit-define"
                   tip="Warn of implicitly defined data items" />
            <check label="Call params (Not set for All)" switch="-Wcall-params"
                   tip="Warn of non 01/77 items for CALL" />
            <check label="Column overflow (Not set for All)" switch="-Wcolumn-overflow"
                   tip="Warn for FIXED format text past column 72" />
            <check label="Terminator (Not set for All)" switch="-Wterminator"
                   tip="Warn when missing scope terminator (END-xxx)" />
            <check label="Truncate (Not set for All)" switch="-Wtruncate"
                   tip="Warn of possible field truncation" />
            <check label="Linkage (Not set for All)" switch="-Wlinkage"
                   tip="Warn of dangling LINKAGE items" />
            <check label="Unreachable (Not set for All)" switch="-Wunreachable"
                   tip="Warn of unreachable statements" />
         </popup>

         <check label="Internal run-time error checks" switch="-debug" column="2"
                tip="generate extra internal tests" />
         <check label="Implicit initialize" switch="-fimplicit-init" column="2"
                tip="Do automatic initialization of the Cobol runtime system" />
         <check label="No truncation" switch="-fnotrunc" column="2"
                tip="Do not truncate binary fields according to PICTURE" />
         <check label="Sign ASCII" switch="-fsign-ascii" column="2"
                tip="Numeric display sign ASCII (Default on ASCII machines)" />
         <check label="Sign EBCDIC" switch="-fsign-ebcdic" column="2"
                tip="Numeric display sign EBCDIC (Default on EBCDIC machines)" />
         <check label="Stack checking for PERFORM" switch="-fstack-check" column="2"
                tip="Generate code to verify the boundary of the stack" />
         <check label="Pass extra NULL" switch="-fnull-param" column="2"
                tip="Pass extra NULL terminating pointers on CALL statements" />

         <check label="Enable Debugging lines"
                switch="-fdebugging-line" line="2" column="2"
                tip="Enable column 7 debug lines and &gt;&gt;D compiler directive" />
         <check label="Object Debug Information" switch="-g" line="2" column="2"
                tip="Link level debug information" />
         <check label="Trace (SECTION/PARAGRAPH)" switch="-ftrace" line="2" column="2"
                tip="Enable output of trace statements for SECTION and PARAGRAPH" />
         <check label="Trace all (SECTION/PARAGRAPH/STATEMENT)"
                switch="-ftraceall" line="2" column="2"
                tip="Enable trace for SECTION, PARAGRAPH and STATEMENTS" />
         <check label="Source locations" switch="-fsource-location" line="2" column="2"
                tip="Generate source location code (Turned on by -debug or -g)" />

         <check label="COBOL2002" switch="-std=cobol2002" line="3" column="2"
                tip="Override the compiler's default, and configure for COBOL 2002" />
         <check label="COBOL 85" switch="-std=cobol85" line="3" column="2"
                tip="Override the compiler's default, and configure for COBOL 85" />
         <check label="Micro Focus" switch="-std=mf" line="3" column="2"
                tip="Override the compiler's default, and Micro Focus compatibility" />
      </switches>
  </tool>

  <action name="make">
    <external>make</external>
  </action>

  <action name="cobc">
    <external>cobc -x %f</external>
  </action>

  <action name="cobcrun">
    <external>cobcrun %p</external>
  </action>

  <action name="valac">
    <external>valac --pkg gtk+-2.0 %f</external>
  </action>

  <action name="gdb">
    <external>konsole --vt_sz 132x24 -e gdb ./%p</external>
  </action>

  <action name="cgdb">
    <external>konsole --vt_sz 132x24 -e cgdb ./%p</external>
  </action>

  <action name="cgdb...">
    <shell>MDI.input_dialog "Enter command arguments" "Args"</shell>
    <external>konsole --vt_sz 132x24 -e cgdb --args ./%p %1</external>
  </action>

  <action name="gdbtui">
    <external>konsole --vt_sz 132x24 -e gdbtui --args ./%p %1</external>
  </action>

  <action name="gdbtui...">
    <shell>MDI.input_dialog "Enter command arguments" "Args"</shell>
    <external>konsole --vt_sz 132x24 -e gdbtui --args ./%p %1</external>
  </action>

  <action name="DDD">
    <external>ddd ./%p</external>
  </action>

  <submenu after="Build">
    <title>OpenCOBOL</title>
    <menu action="make">
      <title>make</title>
    </menu>
    <menu action="cobc">
      <title>cobc</title>
    </menu>
    <menu action="cobcrun">
      <title>cobcrun</title>
    </menu>
    <menu action="valac">
      <title>valac</title>
    </menu>
    <menu><title /></menu>
    <menu action="gdb">
      <title>gdb</title>
    </menu>
    <menu action="cgdb">
      <title>cgdb</title>
    </menu>
    <menu action="cgdb...">
      <title>cgdb...</title>
    </menu>
    <menu action="gdbtui">
      <title>gdbtui</title>
    </menu>
    <menu action="gdbtui...">
      <title>gdbtui...</title>
    </menu>
    <menu action="DDD">
      <title>ddd</title>
    </menu>
  </submenu>
</Custom>

export ESCDELAY=100
./tui-program

SET ENVIRONMENT 'COB_SCREEN_EXCEPTIONS' TO 'Y'
SET ENVIRONMENT 'COB_SCREEN_ESC'        TO 'Y'

78  black                       value 0.
78  blue                        value 1.
78  green                       value 2.
78  cyan                        value 3.
78  red                         value 4.
78  magenta                     value 5.
78  brown                       value 6.
78  white                       value 7.

COPY screenio.

*>   Colors
 78  COB-COLOR-BLACK     VALUE 0.
 78  COB-COLOR-BLUE      VALUE 1.
 78  COB-COLOR-GREEN     VALUE 2.
 78  COB-COLOR-CYAN      VALUE 3.
 78  COB-COLOR-RED       VALUE 4.
 78  COB-COLOR-MAGENTA   VALUE 5.
 78  COB-COLOR-YELLOW    VALUE 6.
 78  COB-COLOR-WHITE     VALUE 7.

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
Color *> Author:    Brian Tiffin
      *> Date:      20131026
      *> License:   Public Domain
      *> Purpose:   Show the GnuCOBOL default colour palette
      *> Tectonics: cobc -x gnucobol-colours.cob
      *> ***************************************************************
       identification division.
       program-id. gnucobol-colours.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 black   constant as 0.
       01 blue    constant as 1.
       01 green   constant as 2.
       01 cyan    constant as 3.
       01 red     constant as 4.
       01 magenta constant as 5.
       01 brown   constant as 6.
       01 white   constant as 7.

       01 anykey            pic x.

       01 backing           pic 9.
       01 foreing           pic 9.
       01 l                 pic 99.
       01 c                 pic 99.

       screen section.
       01 gnu-cobol-colours.
          05 line  1 column 1 value "GnuCOBOL Colours".
          05 line  2 column 1 value "----------------".
          05 line  3 column 1
               value "default          highlight        "
                   & "lowlight         reverse-video    "
                   & "blink".
          05 line  4 column 1 value "Black   0" foreground-color black.
          05 line  5 column 1 value "Blue    1" foreground-color blue.
          05 line  6 column 1 value "Green   2" foreground-color green.
          05 line  7 column 1 value "Cyan    3" foreground-color cyan.
          05 line  8 column 1 value "Red     4" foreground-color red.
          05 line  9 column 1 value "Magenta 5"
                                         foreground-color magenta.
          05 line 10 column 1 value "Brown   6" foreground-color brown.
          05 line 11 column 1 value "White   7"
                                         foreground-color white
                                         background-color black.

          05 line  4 column plus 9   value "Black   0"
                               highlight foreground-color black
                                         background-color white.
          05 line  5 column minus 10 value "Blue    1"
                               highlight foreground-color blue.
          05 line  6 column minus 10 value "Green   2"
                               highlight foreground-color green.
          05 line  7 column minus 10 value "Cyan    3"
                               highlight foreground-color cyan.
          05 line  8 column minus 10 value "Red     4"
                               highlight foreground-color red.
          05 line  9 column minus 10 value "Magenta 5"
                               highlight foreground-color magenta.
          05 line 10 column minus 10 value "Brown   6"
                               highlight foreground-color brown.
          05 line 11 column minus 10 value "White   7"
                               highlight foreground-color white
                                         background-color black.

          05 line  4 column plus 9   value "Black   0"
                               lowlight  foreground-color black
                                         background-color white.
          05 line  5 column minus 10 value "Blue    1"
                               lowlight  foreground-color blue.
          05 line  6 column minus 10 value "Green   2"
                               lowlight  foreground-color green.
          05 line  7 column minus 10 value "Cyan    3"
                               lowlight  foreground-color cyan.
          05 line  8 column minus 10 value "Red     4"
                               lowlight  foreground-color red.
          05 line  9 column minus 10 value "Magenta 5"
                               lowlight  foreground-color magenta.
          05 line 10 column minus 10 value "Brown   6"
                               lowlight  foreground-color brown.
          05 line 11 column minus 10 value "White   7"
                               lowlight  foreground-color white
                                         background-color black.

          05 line  4 column plus 9   value "Black   0"
                          reverse-video  foreground-color black
                                         background-color white.
          05 line  5 column minus 10 value "Blue    1"
                          reverse-video  foreground-color blue.
          05 line  6 column minus 10 value "Green   2"
                          reverse-video  foreground-color green.
          05 line  7 column minus 10 value "Cyan    3"
                          reverse-video  foreground-color cyan.
          05 line  8 column minus 10 value "Red     4"
                          reverse-video  foreground-color red.
          05 line  9 column minus 10 value "Magenta 5"
                          reverse-video  foreground-color magenta.
          05 line 10 column minus 10 value "Brown   6"
                          reverse-video  foreground-color brown.
          05 line 11 column minus 10 value "White   7"
                          reverse-video  foreground-color white
                                         background-color black.

          05 line  4 column plus 9   value "Black   0"
                                  blink  foreground-color black
                                         background-color white.
          05 line  5 column minus 10 value "Blue    1"
                                  blink  foreground-color blue.
          05 line  6 column minus 10 value "Green   2"
                                  blink  foreground-color green.
          05 line  7 column minus 10 value "Cyan    3"
                                  blink  foreground-color cyan.
          05 line  8 column minus 10 value "Red     4"
                                  blink  foreground-color red.
          05 line  9 column minus 10 value "Magenta 5"
                                  blink  foreground-color magenta.
          05 line 10 column minus 10 value "Brown   6"
                                  blink  foreground-color brown.
          05 line 11 column minus 10 value "White   7"
                                  blink  foreground-color white
                                         background-color black.

          05 line plus 2 column 30 value "Enter to exit".
          05 column plus 2 using anykey.

      *> ***************************************************************
       procedure division.

      *> display a table of colour combinations
       perform varying backing from 0 by 1 until backing > 7
           perform varying foreing from 0 by 1 until foreing > 7
               compute l = backing + 15
               compute c = foreing * 10 + 2
               display
                   " colour " at line l column c
                   with background-color backing
                        foreground-color foreing
               end-display
           end-perform
       end-perform

      *> put up the form oriented screen section
       accept gnu-cobol-colours end-accept

       goback.
       end program gnucobol-colours.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
    CRT STATUS IS screen-status.

DATA DIVISION.
WORKING-STORAGE SECTION.
COPY screenio.
01 screen-status pic 9(4).

PROCEDURE DIVISION.
ACCEPT screen-sample.
IF screen-status = COB-SCR-F1
    ...

CobCurses is a package designed to allow Open-Cobol
programmers to create screens on open system platforms,
or those (like Windows) that can use PDCurses. Since
handcrafting screens is tedious work, this package
includes a "Screen Designer" utility.

All User Guides and Programmer Guide documentation can
be found on the source forge (see link at bottom).

==== RELEASE NOTES ====

A large number of internal changes were implemented in
this release, but first let's cover the user visible
improvements:

1. MENUS! Popup menus are now supported, and are available
 in sdesign with every Action field. In fact, any sdesign
 field that is marked with a diamond graphic, has the
 ability to popup a menu with F1 (or ^O).

2. To support menus, FUNCTION keys are now available in
 Action mode (though CONTROL-O is an alternate way
 of opening a menu). This included a new event
 callback NC-FKEY-EVENT.

3. GRAPHIC characters in the screen background. It is now
 possible using sdesign to draw alternate-charset
 graphics in your screen background. See the notes in
 the opening help screen for the "Paint" function.

4. TRACE facilities. CobCurses now includes an
 environment variable that can enable capturing of
 trace information to a file for debugging. A routine
 named NC_TRACE_MSG can also be used to add custom
 messages to the trace file.

INTERNAL CHANGES:

The main two major internal changes were:

1. The terminal support has been virtualized, so that
 the CobCurses routines deal with a "terminal"
 object (not curses routines). This will eventually
 lead to other possible windowing interfaces like
 perhaps graphic X Window or native Windows support.

 The other motivation for this was to allow CobCurses
 to have one consistent set of constants for colours,
 attributes and character sets. Previously, these
 values were different depending upon the platform
 and implementation of curses used.

2. Menu support has been provided independently of curses.
 This is important for portability since PDCurses and
 some platforms do not provide a curses menu library.
 This also guarantees that CobCurses menus will behave
 consistently on all platforms (and overcome menu paging
 bugs in ncurses).

PLANNED FOR THE NEXT RELEASE:

Please avoid writing much code that works with colour pairs.
In the next release, it is planned to hide the colour pair
value altogether by using a TDC (Terminal Drawing Context).
This TDC will tie together attributes and colours, and
perhaps other "drawing contexts" so that you won't have to
manage colour pairs (this will be transparent). This will
also pave the way for graphical interfaces where a selected
font and line styles etc. may also be supported.

NOTES:

HPUX users will need to link with ncurses,
instead of the native HPUX curses libraries. I didn't
have time to fully investigate this, but the native
include files define things like MENU and ITEM types
that conflict with the CobCurses defined ones.

====

The release is available for download here:

http://sourceforge.net/projects/cobcurses

prompt$ svn checkout svn://svn.code.sf.net/p/gnucobol/contrib/ gnucobol-contrib
prompt$ cd gnucobol-contrib/trunk/tools/cobxref
prompt$ ./comp-cobxref.sh

prompt$ cobc -Xref cobxref.cbl
prompt$ cat cobxref.lst



  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    1
  Symbols of Module: COBXREF (COBXREF)
  ------------------------------------

  Data Section (FILE)              Defn    Locations
  --------------------------------+---------------------------------------------------------------


  FS-REPLY                        000095F  000239 003373
  P-CONDITIONS                    000127F  002311
  P-VARIABLES                     000128F  002310
  PL-PROG-NAME                    000124F  002667 002670
  PRINT-FILENAME                  000090F  000241 003317 003421
  PRINTLINE                       000111F  001581 001582 001583 001584 002169 002176 002179 002263
                                           002271 002274 002359 002361 002404 002428 002437 002486
                                           002490 002492 002528 002531 002563 002573 002618 002628
                                           002641 002648 002651 002661 002674 002696 002707 002715
                                           002718 003113 003115 003141 003142 003143 003144 003156
                                           003157 003161 003162 003166 003167 003168 003169 003173
                                           003174 003176 003177 003178 003179 003183 003184 003185
                                           003186 003190 003191 003192 003196 003197 003198 003202
                                           003203 003204 003208 003209 003210 003211 003215 003216
                                           003217 003218 003420
  PRINTLINE2                      000126F  002309 002312 002333
  SDSORTKEY                       000145F  002109
  SKADATANAME                     000135F  001256 001258 002154 002160 002162 002180 002237 002244
                                           002254 002275 002367 002376 002378 002385 002392 002397
                                           002399 002405 002461 002478 002480 002493 002538 002550
                                           002559 002564 002602 002610 002623 002629 002749 002751
  SKAREFNO                        000138F  001260 002181 002189 002276 002284 002406 002419 002494
                                           002501 002539 002565 002630 002750 002752
  SKAWSORPD                       000136F  001253 002182 002247 002249 002255 002277 002377 002379
                                           002394 002400 002411 002469 002495 002554 002566 002624
                                           002632 002739 002753 003105
  SKAWSORPD2                      000137F  001254 002256 002380 002401 002410 002631 002740 003106
  SL-GEN-REFNO1                   000108F  002732
  SORT1TMP                        000097F  000249 003405
  SORTFILE                        000097F  000143 002108
  SORTRECORD                      000134F  001251 001262 002754 003420
  SOURCE-LIST                     000107F  002730 002734
  SOURCE-LISTING                  000090F  000106 001233 001281 001481 001570 001633 001657
  SOURCEFILENAME                  000093F  000240 003271 003278 003300 003303 003307 003313 003315
                                           003421
  SOURCEINPUT                     000093F  000130 001282 001482 001566 001633 001657 002775 003372
  SOURCEOUTPUT                    000109F  002731
  SOURCERECIN                     000131F  002731 002774 002778
  SUPP-FILE-1                     000087F  000247 001577 003399
  SUPP-FILE-2                     000084F  000248 001576 003402
  SUPPLEMENTAL-PART1-OUT          000087F  000101 000133 001245 001281 001481 001564 001566 001634
                                           001657 002110
  SUPPLEMENTAL-PART2-IN           000084F  000102 000140 002111 002137 002138 002147 002149 002217
                                           002218 002230 002233 002345 002346 002355 002357 002448
                                           002449 002456 002458 002514 002515 002524 002526 002587
                                           002588 002596 002599
  XRCOND                          000115F  002701 002703
  XRDATANAME                      000112F  002165 002180 002259 002275 002360 002405 002424 002482
                                           002493 002529 002564 002629 002649 002666 002669 002697
                                           002716
  XRDEFN                          000113F  002181 002276 002406 002494 002565 002630 002663 002698
  XRREFERENCE                     000118F  002189 002284 002419 002501

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    2
  Symbols of Module: COBXREF (COBXREF)
  ------------------------------------

  Data Section (FILE)              Defn    Locations
  --------------------------------+---------------------------------------------------------------


  XRTYPE                          000114F  002182 002277 002411 002413 002495 002566 002632 002634
                                           002672 002699

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    3
  Symbols of Module: COBXREF (COBXREF)
  ------------------------------------

  Data Section (WORKING-STORAGE)   Defn    Locations
  --------------------------------+---------------------------------------------------------------


  A                               000163W  001221 001222 001225 001226 001252 001253 001254 001256
                                           001258 001260 001261 001340 001350 001376 001394 001414
                                           001415 001419 001420 001447 001468 001498 001500 001523
                                           001535 001686 001687 001708 001733 001808 001809 001872
                                           001876 001919 001921 001921 001939 001983 001984 001985
                                           001986 001995 002017 002032 002033 002034 002036 002042
                                           002044 002046 002048 002054 002060 002061 002303 002307
                                           002308 002310 002311 002331 002662 002663 002664 002666
                                           002667 002669 002670 002693 002694 002695 002697 002698
                                           002699 002700 003039 003050 003051 003053 003058 003060
                                           003061 003067 003081 003084 003085 003300 003300 003302
  A1                              000164W  003458 003459 003460 003461
  A2                              000165W  003239 003240 003241 003244
  ADDITIONAL-RESERVED-WORDS       000559W  001141
  ADDITIONAL-RESERVED-WORDS-R     001141W  001204
  ALL-FUN-IDX                     000550W  003104 003107
  ALL-FUNCTIONS                   000550W  001214 003103
  ALL-REPORTS                     000185W  002128
  ARG-NUMBER                      000218W  003262 003263 003265
  ARG-VALS                        000411W  001240 003322
  ARG-VALUE                       000412W  003271 003326 003327 003330 003331 003337 003338 003343
                                           003344 003350 003351 003357 003358 003366 003367 003381
  B                               000166W  001986 001994 002000 002035 002036 002059 002060 002083
                                           002094 002095 002098 002664 002672 002693 002705 002714
                                           003039 003043 003044 003046 003046 003054 003064 003066
                                           003067 003302 003303 003303 003305 003306 003307 003308
  BUILD-NUMBER                    000220W  001641 001644 001650 001651 001656 001739 001742 001752
                                           001777 001784 001801 003225 003227 003230 003449
  C                               000167W  001939 001998 001999 003039 003053 003055 003068
  COBOL-WORD-SIZE                 000200W
  CON-TAB-BLOCKS                  001148W  002298 002326
  CON-TAB-COUNT                   001155W  001397 001399 001402 001403 001405 001406 001408 001743
                                           001753 001754 001756 001757 001759 001760 002295 002297
                                           002307 002325 003427
  CON-TAB-SIZE                    001148W  001154 001397 001398 001743 001744 001745 001746 001753
                                           003425
  CONDITION-TABLE                 001147W  003424
  CONDITIONS                      001150W  001403 001406 001757 001760 002310 002326
  CT-IN-USE-FLAG                  001152W  001408
  CURRENCY-SIGN                   000224W  001436 001438 002935
  CWS                             000201W  001235 001237 001306 001378 001403 001406 001656 001740
                                           001757 001760 002071 002071 002741 002743
  D                               000168W  001939 002004 002005 002808 002845 002846 002848 002856
                                           002857 003034 003034 003036 003044 003051
  DUMP-RESERVED-WORDS             000189W  001220
  E                               000169W  002926 002928 002944 002945 003060 003062
  END-PROG                        000207W  001279 001563 001568 001573 001579 001860 002768 002877
  ERROR-MESSAGES                  000389W
  F-POINTER                       000160W  001275 003102 003107 003428
  FOUNDFUNCTION                   000253W  003087 003089
  FS-REPLY                        000239W  003373
  FULL-SECTION-NAME               000424W  001415 003164

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    4
  Symbols of Module: COBXREF (COBXREF)
  ------------------------------------

  Data Section (WORKING-STORAGE)   Defn    Locations
  --------------------------------+---------------------------------------------------------------


  FUNCTION-TABLE                  000448W  000549
  FUNCTION-TABLE-R                000549W  001202
  FUNCTION-TABLE-SIZE             000553W  001203 001225
  GEN-REFNO1                      000219W  001624 001632 001656 001770 002726 002732 002750 002752
  GIT-BUILD-NO                    001165W  002700 003449
  GIT-ELEMENTS                    001158W  001856 002113
  GIT-HOLDWSORPD                  001163W  001253 001261 002664 002699 003451
  GIT-HOLDWSORPD2                 001164W  001254 003452
  GIT-IN-USE-FLAG                 001166W  002695 003447 003461
  GIT-PROG-NAME                   001161W  002667 002670 003450
  GIT-REFNO                       001162W  001260 002663 002698 003448
  GIT-TABLE-COUNT                 001169W  001250 001252 001855 002112 002204 002662 002688 002694
                                           003438 003439 003446 003447 003448 003449 003450 003451
                                           003452 003459
  GIT-TABLE-SIZE                  001158W  001168 003439 003440 003441 003442 003443
  GIT-WORD                        001160W  001256 001258 001856 002113 002666 002669 002697 003446
                                           003460
  GLOBAL-ACTIVE                   000213W  001779 001783 001800 001830
  GLOBAL-CURRENT-LEVEL            000252W  001611 001614 001645 001648 001769 003436
  GLOBAL-CURRENT-REFNO            000251W  001624 001770 003448
  GLOBAL-CURRENT-WORD             000250W  001623 001771 001831 003420 003446
  GLOBAL-ITEM-TABLE               001157W  001198
  GOTASECTION                     000230W  001553 001600 001603 001604 003235 003242 003253
  GOTENDPROGRAM                   000221W  003426
  GOTPICTURE                      000222W  002931 002953 003017 003018 003022
  H1-PAGE                         000301W  003139
  H1PROG-NAME                     000285W  001270
  H1PROGRAMID                     000299W  003117 003131
  HAD-END-PROG                    000210W  002765
  HAVE-NESTED                     000216W  001308 001313
  HD-D                            000364W  003122
  HD-DATE-TIME                    000366W  003131
  HD-HH                           000357W  003125
  HD-M                            000363W  003121
  HD-MM                           000358W  003126
  HD-SS                           000359W  003127
  HD-UU                           000360W  003128
  HD-Y                            000362W  003120
  HD2-D                           000367W  003122
  HD2-HH                          000373W  003125
  HD2-M                           000369W  003121
  HD2-MM                          000375W  003126
  HD2-SS                          000377W  003127
  HD2-UU                          000379W  003128
  HD2-Y                           000371W  003120
  HDDATE                          000361W  003118 003119
  HDR1                            000283W  003141 003142
  HDR10                           000341W  003196
  HDR11                           000344W  003208
  HDR11A-SORTED                   000346W  002299 002328
  HDR11B-SORTED                   000350W  002300 002327
  HDR12-HYPHENS                   000353W  003209

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    5
  Symbols of Module: COBXREF (COBXREF)
  ------------------------------------

  Data Section (WORKING-STORAGE)   Defn    Locations
  --------------------------------+---------------------------------------------------------------


  HDR2                            000303W  003215
  HDR3                            000307W  003167 003177 003184 003216
  HDR5-PROG-NAME                  000314W  003147 003152 003153
  HDR5-SYMBOLS                    000312W  003156
  HDR6-HYPHENS                    000321W  003153 003154
  HDR6-SYMBOLS                    000316W  003157
  HDR7-VARIABLE                   000325W  003163 003165 003175
  HDR7-WS                         000323W  003166 003176
  HDR8-HD                         000330W  002350 002432 002473
  HDR8-WS                         000329W  003183
  HDR9                            000335W  003190
  HDR9B                           000338W  003202
  HDTIME                          000356W  003123 003124
  HOLDFOUNDWORD                   000232W  001918 001921
  HOLDFOUNDWORD2                  000233W  002847 002848 002857 002858
  HOLDFOUNDWORD2-SIZE             000161W  002836 002844 002849 002856 002859
  HOLDFOUNDWORD2-TYPE             000162W  002837 002854
  HOLDID                          000255W  001235 001237 001239 001310 001312 001632 001656 003129
                                           003148 003450
  HOLDID-MODULE                   000256W  001239 001315 001317 003150
  HOLDWSORPD                      000225W  001473 001508 001538 001555 001559 001601 001646 001683
                                           001805 002739 002744 002755 002799 002818 003063 003236
                                           003241 003427 003451
  HOLDWSORPD2                     000226W  001474 001509 001539 001621 001911 001914 001920 001922
                                           002740 003245 003427 003452
  LINE-COUNT                      000153W  001585 002170 002171 002199 002264 002265 002313 002314
                                           002362 002429 002430 002447 002472 002474 002487 002530
                                           002572 002574 002617 002619 002640 002642 002650 002673
                                           002675 002706 002708 002717 002733 002735 003145 003158
                                           003170 003180 003187 003193 003199 003205 003212 003219
  LINE-END                        000157W  002804 002857 003044
  LIST-SOURCE                     000187W  001271 002729
  LSECT                           000406W  002182 002277 002411 002495 002566 002632 002672 002699
  MSG1                            000390W  002139 002219 002347 002450 002516 002589
  MSG10                           000398W  003444
  MSG16                           000400W  001480
  MSG17                           000401W  001208
  MSG2                            000391W  001280
  MSG4                            000392W  001632
  MSG5                            000393W  001656
  MSG6                            000394W  001747
  MSG7                            000395W  002024
  MSG8                            000396W  002771
  MSG9                            000397W  003374
  OS-DELIMITER                    000229W  003393 003396 003398 003401 003404
  P-FUNCTION                      000550W  000552 001214 001226 003104
  P-OC-IMPLEMENTED                000551W
  PAGE-NO                         000154W  003114 003138 003139 003140
  PRINT-FILENAME                  000241W  003317 003421
  PROG-BASENAME                   000242W  001235 001237 003307 003313 003314 003316
  PROG-NAME                       000148W  001270 003280
  Q                               000177W  001275 001939 001994 002000 002081 002088 002091 002143

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    6
  Symbols of Module: COBXREF (COBXREF)
  ------------------------------------

  Data Section (WORKING-STORAGE)   Defn    Locations
  --------------------------------+---------------------------------------------------------------


                                           002166 002167 002168 002175 002186 002188 002189 002223
                                           002260 002261 002262 002269 002281 002283 002284 002352
                                           002416 002418 002419 002425 002426 002427 002435 002452
                                           002483 002484 002485 002488 002498 002500 002501 002520
                                           002551 002567 002570 002593 002611 002614 002635 002638
  Q2                              000178W  002270 002344 002358 002436 002446 002489
  REPORTS-IN-LOWER                000193W  001234 001255 001309 001314 001401 001755 002665 002742
  RESERVED-NAMES                  001142W  001213 003082
  RESVD-IDX                       001142W  003083 003084
  RESVD-IMPLEMENTED               001143W
  RESVD-TABLE-SIZE                001145W  001205 001221
  RESVD-WORD                      001142W  001144 001213 001222 003083
  S                               000170W  001939 001940 001945 001946 001968 001970 001972 001973
                                           001981 001983 001984 001990 001991 001995 001998 002004
                                           002008 002010 002012 002081 002083 002897 002922 002932
                                           002935 002941 002959 002978 002990
  S-POINTER                       000151W  001275 002513 002527 002571 002586 002616 002639 002647
                                           003428
  S-POINTER2                      000152W  001556 001663 001664 002822 002828 002879 002880 002883
                                           002889 002890 002897 002902 002904 002907 002921 002922
                                           002924 002926 002941 002942 002944 002959 002965 002978
                                           002981 002990 002998 003428
  S2                              000171W  001939 001972 001974
  SAVED-VARIABLE                  000235W  001378 001402 001405 001642 001726 001734 001740 001756
                                           001759 001778 001802
  SAVESKADATANAME                 000234W  002136 002160 002162 002216 002244 002254 002343 002376
                                           002378 002385 002392 002397 002399 002445 002478 002480
                                           002512 002550 002559 002585 002610 002623 003421
  SAVESKAWSORPD                   000236W  002255 002344 002379 002386 002393 002400 002446 002513
                                           002586 002615 002624 002638
  SAVESKAWSORPD2                  000237W  002256 002344 002380 002401 002446 002513
  SECTION-NAME                    000426W  003240
  SECTION-NAMES-TABLE             000414W  000423
  SECTION-SHORT-NAMES-TABLE       000429W  000438
  SECTION-USED-TABLE              000408W  002200 003426
  SECTTABLE                       000403W  000405
  SHORT-SECTION-NAME              000439W
  SHT-SECTION-NAME                000440W  002846 002848
  SORT1TMP                        000249W  003405
  SOURCE-EOF                      000204W  001278 001479 001862 002770 002876 003000
  SOURCE-LINE-END                 000158W  001663 002804 002835 002846 002849 002879 002889
  SOURCE-WORDS                    000159W  001913 002829 003005
  SOURCEFILENAME                  000240W  003271 003278 003300 003303 003307 003313 003315 003421
  SOURCEINWS                      000258W  001286 001324 001327 001330 001333 001352 001355 001358
                                           001415 001449 001452 001455 001921 002774 002778 002782
                                           002785 002794 002795 002800 002802 002813 002819 002820
                                           002846 002855 002857 002858 002880 002883 002901 002907
                                           002921 002923 002928 002932 002935 002942 002945 002981
                                           003034 003042 003043 003046 003053 003058 003061 003062
                                           003067
  STRING-POINTER                  000149W  003264 003270 003271 003279 003299 003328 003332 003380
                                           003381

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    7
  Symbols of Module: COBXREF (COBXREF)
  ------------------------------------

  Data Section (WORKING-STORAGE)   Defn    Locations
  --------------------------------+---------------------------------------------------------------


  STRING-POINTER2                 000150W  003299 003318
  SUPP-FILE-1                     000247W  001577 003399
  SUPP-FILE-2                     000248W  001576 003402
  SV1WHAT                         000259W  003240 003243
  SW-1                            000183W  003368
  SW-2                            000186W  003339
  SW-4                            000188W  003345
  SW-5                            000190W  003353
  SW-6                            000192W  003359
  SW-END-PROG                     000206W  001586 002821
  SW-GIT                          000212W  001622 001647 001674 001797 003254
  SW-HAD-END-PROG                 000209W  002766 002821
  SW-NESTED                       000215W  002821
  SW-SOURCE-EOF                   000203W  002776 003426
  T                               000172W  001994 002000 002043 002049 002068 002080 002081 002083
                                           002084 002085
  TEMP-PATHNAME                   000246W  003385 003386 003387 003388 003389 003390 003391 003392
                                           003394 003395 003397 003400 003403 003407
  USECT                           000409W  001261 002212 002443 002753
  VARIABLES                       001151W  001402 001405 001756 001759 002298 002311
  WASPICTURE                      000223W  001670 001671 002948
  WE-ARE-TESTING                  000191W  001325 001328 001331 001334 001353 001356 001359 001437
                                           001450 001453 001456 001572 002011 002056 003006 003045
                                           003243 003406
  WORD-DELIMIT                    000227W  001364 001382 001409 001462 001470 001493 001498 001511
                                           001520 001541 001662 001665 001667 001776 001781 001864
                                           001912 002881 002902 002908 002924 002927 002929 002942
                                           002946 002981 002985 003007
  WORD-DELIMIT2                   000228W  002960 002977 002981 002985 002991
  WORD-LENGTH                     000156W  001502 001598 001631 001632 001889 001918 001919 001923
                                           001924 001925 001926 001941 001959 002068 002069 002084
                                           002086 002882 002909 002973 002992 003008 003009 003226
                                           003229
  WS-ANAL1                        000238W  002201 002212 002213 002231 002247 002249 003164
  WS-RETURN-CODE                  000155W  001200 001201 001207
  WS-WC-DD                        000384W
  WS-WC-HH                        000385W
  WS-WC-MIN                       000386W
  WS-WC-MM                        000383W
  WS-WC-YY                        000382W  003283
  WS-WHEN-COMPILED                000381W  003281
  WSF1-1                          000265W  001303 001373 001391 001493 001495 001517 001696 001698
                                           001704 001865 001880 001883 001885 001888 001891 002906
                                           002912 002919 002920 002957 002963 002967 002970 002977
  WSF1-1-NUMBER                   000266W  001373 001391 001495 001517 001702 001878 002918
  WSF1-2                          000264W  001903 002916
  WSF1-3                          000263W  001898 001905 002914
  WSF3-1                          000272W  003227 003230
  WSF3-1-NUMERIC                  000273W
  WSF3-2                          000274W  003230
  WSFOUNDNEWWORD                  000277W  001304 001306 002006 002008 002010 002015 002079 002081
                                           002088 002089 002091 003423

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    8
  Symbols of Module: COBXREF (COBXREF)
  ------------------------------------

  Data Section (WORKING-STORAGE)   Defn    Locations
  --------------------------------+---------------------------------------------------------------


  WSFOUNDNEWWORD2                 000278W  002079 002083 002095 002096 002098 003423
  WSFOUNDNEWWORD3                 000279W  001938 002036 002060 002071 003422
  WSFOUNDNEWWORD4                 000280W  002741 002743 002749 002751 003104 003422 003460
  WSFOUNDNEWWORD5                 000281W  001688 001689 001810 001811 003040 003043 003067
  WSFOUNDWORD                     000262W  000271
  WSFOUNDWORD2                    000271W  001295 001304 001306 001310 001312 001315 001317 001366
                                           001369 001378 001384 001387 001388 001403 001406 001430
                                           001431 001436 001488 001529 001610 001613 001619 001623
                                           001631 001632 001656 001673 001677 001680 001684 001686
                                           001688 001689 001700 001725 001740 001757 001760 001771
                                           001791 001792 001796 001806 001808 001810 001811 001824
                                           001831 001839 001869 001881 001886 001918 001923 001924
                                           001945 001955 001956 001968 001973 001974 001981 001983
                                           001984 001986 001990 001991 001998 002004 002008 002010
                                           002012 002015 002025 002034 002036 002046 002057 002060
                                           002071 002081 002083 002090 002091 002097 002098 002741
                                           002743 002884 002896 002901 002910 002923 002942 002954
                                           002958 002960 002964 002971 002980 002981 002986 002991
                                           003008 003016 003020 003021 003083 003086
  Y                               000173W  001939 001990 001991 001993
  Z                               000174W  001700 001941 001955 001956 001957 001970 002033 002044
                                           002054 002971 002971 002973 002986 002986 002988 002990
                                           002991 002992
  Z2                              000175W  001939 001941 001943 001947 001953 001958 001968 001971
                                           001981 001983 001984 001986 001990 001991 001998 002004
                                           002007 002008 002081 002083 002084 002086
  Z3                              000176W  001939 001971 001974

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page    9
  Variable Tested [S]            Symbol (88-Conditions)
  --------------------------------------------------------------


  SN-TEST-1                       SNT1-ON
  SN-TEST-1                       SNT1-OFF
  SW-1                            ALL-REPORTS
  SW-2                            LIST-SOURCE
  SW-4                            DUMP-RESERVED-WORDS
  SW-5                            WE-ARE-TESTING
  SW-6                            REPORTS-IN-LOWER
  SW-END-PROG                     END-PROG
  SW-GIT                          GLOBAL-ACTIVE
  SW-HAD-END-PROG                 HAD-END-PROG
  SW-NESTED                       HAVE-NESTED
  SW-SOURCE-EOF                   SOURCE-EOF
  WSF1-1                          WSF1-1-NUMBER
  WSF3-1                          WSF3-1-NUMERIC

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:81  Page   10
  Variable Tested                Symbol (88-Conditions) [S]
  --------------------------------------------------------------


  SW-1                            ALL-REPORTS
  SW-4                            DUMP-RESERVED-WORDS
  SW-END-PROG                     END-PROG
  SW-GIT                          GLOBAL-ACTIVE
  SW-HAD-END-PROG                 HAD-END-PROG
  SW-NESTED                       HAVE-NESTED
  SW-2                            LIST-SOURCE
  SW-6                            REPORTS-IN-LOWER
  SN-TEST-1                       SNT1-OFF
  SN-TEST-1                       SNT1-ON
  SW-SOURCE-EOF                   SOURCE-EOF
  SW-5                            WE-ARE-TESTING
  WSF1-1                          WSF1-1-NUMBER
  WSF3-1                          WSF3-1-NUMERIC

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:82  Page   11
  Functions                        Defn    Locations
  --------------------------------+---------------------------------------------------------------


  CURRENT-DATE                    003281I
  E                               002926I  002928 002944 002945 003060 003062
  LOWER-CASE                      001235I  001256 001310 001315 001402 001403 001756 001757 002666
                                           002667 002743
  UPPER-CASE                      001237I  001312 001317 002778 003104 003322

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:82  Page   12
  Procedure                        Defn    Locations
  --------------------------------+---------------------------------------------------------------


  AA000-XREF-DATA                 001172S
  AA020-BYPASS-OPEN               001244P  001587
  AA030-READLOOP1                 001277P  001296
  AA040-READLOOP2                 001322P  001342
  AA041-GET-SN                    001344P  001326 001335 001354 001365 001383 001410
  AA042-GETWORD                   001362P  001368 001370 001374 001377
  AA044-GETWORD3                  001380P  001386 001389 001392 001395 001411
  AA045-EXIT                      001422P  001336 001349 001446 001522
  AA045-TEST-SECTION              001413P  001336 001349 001446 001522
  AA046-GET-CURRENCY              001425P  001367 001385 001432
  AA047-GETIO                     001441P  001329 001357 001463 001471 001494 001499 001503 001512
  AA047-GETWORD                   001460P  001469
  AA047-GETWORD2                  001477P  001489
  AA047-GETWORD3                  001491P  001496 001501 001513
  AA048-GET-NEXT                  001519P  001542
  AA048-GETIOC                    001515P  001332 001360 001451 001518 001530
  AA049-GETWORD                   001532P  001536 001543
  AA050-READLOOP3                 001545P  001454 001554 001560
  AA060-READLOOP3A                001551P  001290 001341 001351 001448 001457 001524
  BA000-EXIT                      001846P  001602
  BA000-PROCESS-WS                001592S  001557
  BA020-GETAWORD                  001593P  001599 001606 001627 001782 001787 001817
  BA040-CLEAR-TO-NEXT-PERIOD      001661P  001626 001672 001676 001679 001682 001692 001697 001699
                                           001701 001703 001705 001709 001715 001786 001816
  BA049-EXIT                      001717P  001626 001666 001668 001786 001816
  BA050-BYPASS-ADD-2-CON-TABLE    001765P  001748
  BA050-GET-USER-WORD             001720P  001652
  BA051-AFTER-DATANAME            001775P  001727
  BA051-AFTER-NEW-WORD            001790P  001735
  BA052-AFTER-INDEX               001819P  001678 001825
  BA053-AFTER-DEPENDING           001834P  001681 001840
  BB000-EXIT                      002101P  001861 001863
  BB000-PROCESS-PROCEDURE         001849S  001562
  BB010-NEW-RECORD                001850P
  BB020-GETAWORD                  001858P  001866 001877 001879 001882 001884 001887 001890 001899
                                           001904 001906 001931 001944 001954 001969 001975 001987
                                           002018 002021 002026 002070 002100
  BB030-CHK1                      001868P  001928
  BB040-CHK2                      001894P
  BB050-CHECK-SUBSCRIPTS          001933P  001892 002072
  BB051-CLEAR-LEFT-BRACE          001942P  001948
  BB052-CLEAR-RIGHT-BRACE         001952P  001960
  BB053-NUMERICS                  001967P
  BB054-SPACES                    002002P
  BB060-SCAN4-QUOTES              002028P  001996 002037
  BB070-GOT-QUOTE                 002041P  002047
  BB080-QUOTE-CLEAN               002053P  002062
  BB090-RECOVER-WORD              002064P  002045 002055
  BB100-SCAN4-COLON               002074P  002001
  BC000-EXIT                      002721P  002140 002150 002220 002348 002451 002517 002590 002600
  BC000-LAST-ACT                  002104S  001567
  BC010-GROUP-REPORT              002135P
  BC020-READ-SORTER               002146P  002155 002157
  BC030-ISX                       002153P  002144
  BC040-PRINTXREF                 002159P  002156

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:82  Page   13
  Procedure                        Defn    Locations
  --------------------------------+---------------------------------------------------------------


  BC050-CHECK-Q                   002164P  002148 002187
  BC060-CONNECTC                  002178P
  BC070-CONNECTD                  002185P  002161
  BC080-EXIT                      002191P  002156 002183
  BC090-LAST-PASS2                002194P  002129
  BC100-WORKING-STORAGE-REPORT    002208P  002202
  BC110-READ-SORTER               002229P  002238 002240
  BC120-ISX2                      002236P  002227
  BC130-PRINTXREF2                002242P  002239
  BC140-CHECK-Q                   002258P  002232 002282
  BC150-CONNECTC2                 002273P
  BC160-CONNECTD2                 002280P  002245
  BC170-EXIT                      002285P  002239 002248 002250 002278
  BC180-EXIT                      002288P  002202 002214 002234
  BC190-DO-CONDITIONS             002291P  002206
  BC192-PRINT-CONDITIONS          002306P  002304 002318 002332
  BC194-NOW-REVERSE               002320P  002305
  BC195-DONE                      002334P  002296
  BC200-LAST-PASS3                002339P
  BC210-READ-SORTER3              002354P  002368 002370
  BC220-ISX3                      002366P  002353
  BC230-PRINTXREF3                002372P  002369
  BC250-CONNECTC3                 002403P
  BC260-CONNECTD3                 002415P  002398
  BC270-EXIT                      002420P  002369 002381 002387 002395 002414
  BC280-CHECK-Q                   002423P  002356 002402 002417
  BC300-LAST-PASS4                002439P  002335
  BC310-READ-SORTER4              002455P  002462 002464
  BC320-ISX4                      002460P  002453
  BC330-PRINTXREF4                002465P  002463
  BC335-CHECK-Q                   002481P  002457 002499
  BC340-CONNECTC4                 002491P
  BC350-CONNECTD4                 002497P  002479
  BC360-EXIT                      002502P  002463 002470 002496
  BC399-EXIT                      002505P  002335 002444 002459
  BC400-LAST-PASS5                002508P  002364
  BC410-READ-SORTER5              002523P  002540 002542
  BC420-ISX5                      002534P  002521
  BC430-PRINTXREF5                002543P  002541
  BC440-CHECK-4OLD                002569P  002525 002557
  BC450-EXIT                      002578P  002541 002552 002555 002568
  BC500-LAST-PASS6                002581P  002533
  BC510-READ-SORTER6              002595P  002603 002605
  BC520-ISX6                      002601P  002594
  BC530-PRINTXREF6                002606P  002604
  BC540-CHECK-4OLD                002637P  002597
  BC540-CHECK-4OLD6               002646P  002598
  BC550-EXIT                      002652P  002604 002612 002636
  BC600-EXIT                      002681P  002205
  BC600-PRINT-GLOBALS             002655P  002205
  BC620-DO-GLOBAL-CONDITIONS      002684P  001569
  BC629-EXIT                      002719P  001569 002689
  ZZ000-INC-COBOLREFNO            002725P  002786 002809 002814 002826
  ZZ000-OUTPUTSOURCE              002728P  002787 002810 002815 002827
  ZZ000-ROUTINES                  002724S

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:82  Page   14
  Procedure                        Defn    Locations
  --------------------------------+---------------------------------------------------------------


  ZZ030-WRITE-SORT                002738P  001475 001510 001540 001625 001691 001714 001773 001794
                                           001813 001829 001844 001930 002020 002092 002099
  ZZ100-EXIT                      002868P  001274 001323 001348 001445 001521 001549 001605 002769
                                           002772 002777 002823 002839 002999
  ZZ100-GET-A-SOURCE-RECORD       002760P  001274 001323 001348 001445 001521 001549 001605 002783
                                           002788 002811 002816 002850 002999
  ZZ100-NEW-PROGRAM-POINT         002825P  002767
  ZZ110-EXIT                      003023P  001285 001297 001363 001372 001381 001390 001429 001461
                                           001478 001492 001516 001526 001533 001597 001620 001669
                                           001685 001724 001788 001793 001807 001823 001838 001859
                                           002878 002885 002911 003001
  ZZ110-GET-A-WORD                002871P  001285 001297 001363 001372 001381 001390 001429 001461
                                           001478 001492 001516 001526 001533 001597 001620 001669
                                           001685 001724 001788 001793 001807 001823 001838 001859
                                           002966 002968 003002
  ZZ110-GET-A-WORD-COPY-CHECK     003003P  002974 002996
  ZZ110-GET-A-WORD-LITERAL        002976P
  ZZ110-GET-A-WORD-LITERAL2       002979P  002961
  ZZ110-GET-A-WORD-OVERFLOW       002997P  002891 002905 002917
  ZZ110-GET-A-WORD-UNSTRING       002895P  002913 002915
  ZZ120-EXIT                      003073P  002803 003037 003047
  ZZ120-KILL-SPACE                003049P  003041 003056 003059 003069
  ZZ120-KILL-SPACE-EXIT           003070P  003041 003052
  ZZ120-REPLACE-MULTI-SPACES      003026P  002803
  ZZ130-EXIT                      003090P  001375 001393 001467 001497 001534 001707 001728 001870
                                           002016 003082
  ZZ130-EXTRA-RESERVED-WORD-CHECK 003076P  001375 001393 001467 001497 001534 001707 001728 001870
                                           002016
  ZZ140-EXIT                      003108P  002745 003103
  ZZ140-FUNCTION-CHECK            003093P  002745
  ZZ150-EXIT                      003221P  002141 002142 002172 002173 002221 002222 002266 002267
                                           002302 002316 002330 002351 002433 002476 002519 002576
                                           002592 002621 002644 002659 002660 002676 002677 002692
                                           002710 003159 003171 003181 003188 003194 003200 003206
                                           003213 003220
  ZZ150-WRITEHDB                  003111P  001272 002141 002172 002221 002266 002301 002315 002329
                                           002349 002431 002475 002518 002575 002591 002620 002643
                                           002659 002676 002691 002709 002736
  ZZ150-WRITEHDB1                 003146P
  ZZ150-WRITEHDB2                 003160P  002222 002267
  ZZ150-WRITEHDB2B                003172P  002660 002677
  ZZ150-WRITEHDB3                 003182P  002351 002433 002476
  ZZ150-WRITEHDB4                 003189P  002519 002576
  ZZ150-WRITEHDB5                 003195P  002592 002621 002644
  ZZ150-WRITEHDB6                 003201P  002692 002710
  ZZ150-WRITEHDB7                 003207P  002302 002316 002330
  ZZ150-WRITEHDB8                 003214P  002142 002173
  ZZ160-CLEAN-NUMBER              003224P  001640
  ZZ160-EXIT                      003231P  001640 003228
  ZZ170-CHECK-4-SECTION           003234P  001552 002838 002867
  ZZ170-EXIT                      003255P  001552 002838 002867 003237
  ZZ180-CHECK-FOR-PARAM-ERRORS    003277P  003266 003329 003333
  ZZ180-EXIT                      003411P  001216 003346 003377
  ZZ180-GET-PROGRAM-ARGS          003379P  003265
  ZZ180-OPEN-SOURCE-FILE          003258P  001216

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:82  Page   15
  Procedure                        Defn    Locations
  --------------------------------+---------------------------------------------------------------


  ZZ182-EXIT                      003408P  003275
  ZZ182-GET-ENV-SET-TEMPFILES     003383P  003275
  ZZ190-EXIT                      003429P  001197 001580
  ZZ190-INIT-PROGRAM              003414P  001197 001580
  ZZ200-EXIT                      003453P  001675 001780 001785 001798 001803 001832 003437 003445
  ZZ200-LOAD-GIT                  003432P  001675 001780 001785 001798 001803 001832
  ZZ310-CHECK-FOR-GLOBALS         003456P  002756
  ZZ319-EXIT                      003466P  002756

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:82  Page   16
  Unreferenced Working Storage Symbols


  COBOL-WORD-SIZE                 000200W
  ERROR-MESSAGES                  000389W
  P-OC-IMPLEMENTED                000551W
  RESVD-IMPLEMENTED               001143W
  SHORT-SECTION-NAME              000439W
  WS-WC-DD                        000384W
  WS-WC-HH                        000385W
  WS-WC-MIN                       000386W
  WS-WC-MM                        000383W
  WSF3-1-NUMERIC                  000273W

  ACS Cobol Xref v1.01.15          Dictionary File for COBXREF    15/11/15  15:08:00:82  Page   17
  Unreferenced Procedures


  AA000-XREF-DATA                 001172S
  BB010-NEW-RECORD                001850P
  BB040-CHK2                      001894P
  BB053-NUMERICS                  001967P
  BB054-SPACES                    002002P
  BC010-GROUP-REPORT              002135P
  BC060-CONNECTC                  002178P
  BC150-CONNECTC2                 002273P
  BC200-LAST-PASS3                002339P
  BC250-CONNECTC3                 002403P
  BC340-CONNECTC4                 002491P
  ZZ000-ROUTINES                  002724S
  ZZ110-GET-A-WORD-LITERAL        002976P
  ZZ150-WRITEHDB1                 003146P


FILE SECTION.
FD  A-REPORT
    LINAGE IS 13 LINES
    TOP 2
    FOOTING 2
    BOTTOM 3.

TOP
LINES
FOOTING
BOTTOM

$ vi -t WORKING-STORAGE

:tag name
    Go to tag by name
:ts
    Show the tag select list
:tn
    Next tag
:tp
    nasty halloween trick
:tf
    First tag
:tl
    Last tag

$ gdb hello
GNU gdb 6.7.1-debian
Copyright (C) 2007 Free Software Foundation, Inc.
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.  Type "show copying"
and "show warranty" for details.
This GDB was configured as "i486-linux-gnu"...
Using host libthread_db library "/lib/i686/cmov/libthread_db.so.1".
(gdb) break 106
Breakpoint 1 at 0xOBFUSCA: file hello.c, line 106.
(gdb) break 109
Breakpoint 2 at 0xTETHESY: file hello.c, line 109.
(gdb) run
Starting program: /home/brian/writing/cobol/hello
[Thread debugging using libthread_db enabled]
[New Thread 0xSTEMADDR (LWP 5782)]
[Switching to Thread 0xESSES6b0 (LWP 5782)]

Breakpoint 1, hello_ (entry=0) at hello.c:106
106         cob_new_display (0, 1, 1, &c_1);
(gdb) cont
Continuing.
Hello, world

Breakpoint 2, hello_ (entry=0) at hello.c:109
109       cob_set_location ("hello", "hello.cob", 6,
            "MAIN SECTION", "MAIN PARAGRAPH", "STOP");
(gdb) cont
Continuing.

Program exited normally.
(gdb)

GCobol
      D    IF 1 = 1
      D       DISPLAY "Debug Line"  END-DISPLAY
      D    ELSE
              DISPLAY "Normal Line" END-DISPLAY
      D    END-IF

GCobol
       01  debugmode pic x.
           88  debugmode-on values 'O', 'Y', 'J', 'o', 'y', 'j', '1'.

GCobol
           accept debugmode from Environment "DEBUGMODE"
           end-accept

GCobol
           IF debugmode-on
              DISPLAY "Debug Line"  END-DISPLAY
           ELSE
              DISPLAY "Normal Line" END-DISPLAY
           END-IF

GCobol
      D 01 debugmode pic x.
      D    88 debugmode-on values 'O', 'Y', 'J', 'o', 'y', 'j', '1'.

      ...

      D    accept debugmode from Environment "DEBUGMODE"
      D    end-accept

      ...

      D    IF debugmode-on
      D       DISPLAY "Debug Line"  END-DISPLAY
      D    ELSE
              DISPLAY "Normal Line" END-DISPLAY
      D    END-IF

#include <stdio.h>
int main(int argc, char *argv[]) {
    printf("Hello C compiled with cobc\n");
}

int hello(int argc, char *argv[]) {
    printf("Hello C compiled with cobc, run from hello.so with cobcrun\n");
}

$ cobc hello.c
$ cobcrun hello
Hello C compiled with cobc, run from hello.so with cobcrun

$ cobc -x hello.c
$ ./hello
Hello C compiled with cobc

[btiffin@home cobol]$ cobc -v -x hello.c
Executing:      gcc -c -I/usr/local/include -pipe -Wno-unused -fsigned-char
                -Wno-pointer-sign -o "/tmp/cob2785_0.o" "hello.c"
Return status:  0
Executing:      gcc -Wl,--export-dynamic -o "hello" "/tmp/cob2785_0.o"
                -L/usr/local/lib -lcob -lm -lgmp -lncurses -ldb -ldl
Return status:  0

int       cob_get_num_params ( void );
int       cob_get_param_constant ( int num_param );
int       cob_get_param_digits( int num_param );
int       cob_get_param_scale( int num_param );
int       cob_get_param_sign ( int num_param );
int       cob_get_param_size ( int num_param );
int       cob_get_param_type ( int num_param );
void *    cob_get_param_data ( int num_param );
cob_s64_t cob_get_s64_param  ( int num_param );
cob_u64_t cob_get_u64_param  ( int num_param );
char *    cob_get_picx_param ( int num_param, void *charfld, int charlen );
void *    cob_get_grp_param  ( int num_param, void *charfld, int charlen );
void      cob_put_s64_param  ( int num_param, cob_s64_t value );
void      cob_put_u64_param  ( int num_param, cob_u64_t value );
void      cob_put_picx_param ( int num_param, void *charfld );
void      cob_put_grp_param  ( int num_param, void *charfld, int charlen );

char *      cob_get_picx(void *cbldata, int len, void *charfld, int charlen);
cob_s64_t   cob_get_s64_comp3(void *cbldata, int len);
cob_s64_t   cob_get_s64_comp5(void *cbldata, int len);
cob_s64_t   cob_get_s64_compx(void *cbldata, int len);
cob_s64_t   cob_get_s64_pic9 (void *cbldata, int len);
cob_u64_t   cob_get_u64_comp3(void *cbldata, int len);
cob_u64_t   cob_get_u64_comp5(void *cbldata, int len);
cob_u64_t   cob_get_u64_comp6(void *cbldata, int len);
cob_u64_t   cob_get_u64_compx(void *cbldata, int len);
cob_u64_t   cob_get_u64_pic9 (void *cbldata, int len);
float       cob_get_comp1(void *cbldata);
double      cob_get_comp2(void *cbldata);
void        cob_put_comp1(float val, void *cbldata);
void        cob_put_comp2(double val, void *cbldata);
void        cob_put_picx( void *cbldata, int len, void *string);
void        cob_put_s64_comp3(cob_s64_t val, void *cbldata, int len);
void        cob_put_s64_pic9 (cob_s64_t val, void *cbldata, int  len);
void        cob_put_s64_comp5(cob_s64_t val, void *cbldata, int len);
void        cob_put_u64_comp3(cob_u64_t val, void *cbldata, int len);
void        cob_put_u64_comp5(cob_u64_t val, void *cbldata, int len);
void        cob_put_u64_comp6(cob_u64_t val, void *cbldata, int len);
void        cob_put_u64_compx(cob_u64_t val, void *cbldata, int len);
void        cob_put_u64_pic9 (cob_u64_t val, void *cbldata, int len);
void        cob_put_pointer(void *val, void *cbldata);

#define cobget_x1_compx(d)      (cobuns8_t)  cob_get_u64_compx(d, 1)
#define cobget_x2_compx(d)      (cobuns16_t) cob_get_u64_compx(d, 2)
#define cobget_x4_compx(d)      (cobuns32_t) cob_get_u64_compx(d, 4)
#define cobget_x8_compx(d)      (cobuns64_t) cob_get_u64_compx(d, 8)
#define cobget_sx1_compx(d)     (cobs8_t)    cob_get_s64_compx(d, 1)
#define cobget_sx2_compx(d)     (cobs16_t)   cob_get_s64_compx(d, 2)
#define cobget_sx4_compx(d)     (cobs32_t)   cob_get_s64_compx(d, 4)
#define cobget_sx8_compx(d)     (cobs64_t)   cob_get_s64_compx(d, 8)
#define cobget_x1_comp5(d)      (cobuns8_t)  cob_get_u64_comp5(d, 1)
#define cobget_x2_comp5(d)      (cobuns16_t) cob_get_u64_comp5(d, 2)
#define cobget_x4_comp5(d)      (cobuns32_t) cob_get_u64_comp5(d, 4)
#define cobget_x8_comp5(d)      (cobuns64_t) cob_get_u64_comp5(d, 8)
#define cobget_sx1_comp5(d)     (cobs8_t)    cob_get_s64_comp5(d, 1)
#define cobget_sx2_comp5(d)     (cobs16_t)   cob_get_s64_comp5(d, 2)
#define cobget_sx4_comp5(d)     (cobs32_t)   cob_get_s64_comp5(d, 4)
#define cobget_sx8_comp5(d)     (cobs64_t)   cob_get_s64_comp5(d, 8)
#define cobget_xn_comp5(d,n)    (cobuns64_t) cob_get_u64_comp5(d, n)
#define cobget_xn_compx(d,n)    (cobuns64_t) cob_get_u64_compx(d, n)
#define cobget_sxn_comp5(d,n)   (cobs64_t)   cob_get_s64_comp5(d, n)
#define cobget_sxn_compx(d,n)   (cobs64_t)   cob_get_s64_compx(d, n)

#define cobput_x1_compx(d,v)    (void)       cob_put_u64_compx((cob_u64_t)v,d,1)
#define cobput_x2_compx(d,v)    (void)       cob_put_u64_compx((cob_u64_t)v,d,2)
#define cobput_x4_compx(d,v)    (void)       cob_put_u64_compx((cob_u64_t)v,d,4)
#define cobput_x8_compx(d,v)    (void)       cob_put_u64_compx((cob_u64_t)v,d,8)
#define cobput_x1_comp5(d,v)    (void)       cob_put_u64_comp5((cob_u64_t)v,d,1)
#define cobput_x2_comp5(d,v)    (void)       cob_put_u64_comp5((cob_u64_t)v,d,2)
#define cobput_x4_comp5(d,v)    (void)       cob_put_u64_comp5((cob_u64_t)v,d,4)
#define cobput_x8_comp5(d,v)    (void)       cob_put_u64_comp5((cob_u64_t)v,d,8)
#define cobput_sx1_comp5(d,v)   (void)       cob_put_s64_comp5((cob_s64_t)v,d,1)
#define cobput_sx2_comp5(d,v)   (void)       cob_put_s64_comp5((cob_s64_t)v,d,2)
#define cobput_sx4_comp5(d,v)   (void)       cob_put_s64_comp5((cob_s64_t)v,d,4)
#define cobput_sx8_comp5(d,v)   (void)       cob_put_s64_comp5((cob_s64_t)v,d,8)
#define cobput_xn_comp5(d,n,v)  (void)       cob_put_u64_comp5(v, d, n)
#define cobput_xn_compx(d,n,v)  (void)       cob_put_u64_compx(v, d, n)
#define cobput_sxn_comp5(d,n,v) (void)       cob_put_s64_comp5(v, d, n)
#define cobput_sxn_compx(d,n,v) (void)       cob_put_s64_compx(v, d, n)

#define    cobtidy()   cob_tidy ()
#define    cobinit()   cob_extern_init ()
#define    cobexit(x)  cob_stop_run (x)

#define    cobgetenv(x)   cob_getenv (x)
#define    cobputenv(x)   cob_putenv (x)
#define    cobclear()     (void) cob_sys_clear_screen ()
#define    cobmove(y,x)   cob_set_cursor_pos (y, x)
#define    cobcols()      cob_get_scr_cols ()
#define    coblines()     cob_get_scr_lines ()
#define    cobaddstrc(x)  cob_display_text (x) /* no limit */
#define    cobprintf      cob_display_formatted_text  /* limit of 2047 */
#define    cobgetch()     cob_get_char ()

#include <libcob.h>

# call tcc and libtcc1 run-time compile from GnuCOBOL
# public domain example by Brian Tiffin, Feb 2016
.RECIPEPREFIX = >

calltcc: calltcc.cob add.cob
> export COB_CFLAGS='-DTCC_TARGET_X86_64'; \
 cobc -x -g -debug calltcc.cob add.cob \
 tcc.c libtcc.c tccpp.c tccgen.c tccelf.c tccasm.c tccrun.c x86_64-gen.c i386-asm.c

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/calltcc
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20160124  Modified: 2016-03-27/04:48-0400
      *> LICENSE
      *>   Copyright 2016 Brian Tiffin
      *>   GNU General Public License, GPL, 3.0 (or greater)
      *> PURPOSE
      *>   use tcc to compile some code and call it at run-time
      *> TECTONICS
      *> export COB_CFLAGS='-DTCC_TARGET_X86_64'
      *> cobc -x -g -debug calltcc.cob add.cob \
      *>      tcc.c libtcc.c tccpp.c tccgen.c tccelf.c tccasm.c \
      *>      tccrun.c x86_64-gen.c i386-asm.c
      *> ***************************************************************
       identification division.
       program-id. calltcc.
       author. Brian Tiffin.
       date-written. 2016-01-15/01:45-0500.
       date-modified. 2016-03-27/04:48-0400.
       date-compiled.
       installation. Requires source tree for tcc-0.9.26.
       remarks. Just for fun.
       security. Run-time compiled code.

       environment division.
       configuration section.
       source-computer. gnulinux.
       object-computer. gnulinux
           classification is canadian.

       special-names.
           locale canadian is "en_CA.UTF-8".

       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 c-code.
          05 value
"int fib(int n)" & x"0a" &
"{" & x"0a" &
"    if (n <= 2)" & x"0a" &
"        return 1;" & x"0a" &
"    else" & x"0a" &
"        return fib(n-1) + fib(n-2);" & x"0a" &
"}" & x"0a" & x"0a" &

"int foo(int n)" & x"0a" &
"{" & x"0a" &
'    printf("Hello, tcc\n");' & x"0a" &
'    printf("fib(%d) = %d\n", n, fib(n));' & x"0a" &
'    printf("add(%d, %d) = %d\n", n, 2 * n, add(n, 2 * n));' & x"0a" &
"    return 0;" & x"0a" &
z"}".

       01 tcc-state  usage pointer.
       01 tcc-result usage binary-long.

       01 TCC-OUTPUT-MEMORY usage binary-long value 0.
       01 TCC-RELOCATE-AUTO usage binary-long value 1.

       01 cob-entry  usage program-pointer.
       01 c-function usage program-pointer.

      *> ***************************************************************
       procedure division.
       call "tcc_new" returning tcc-state
           on exception
               display "no tcc_new" upon syserr
               perform hard-exception
       end-call

       call "tcc_set_lib_path" using
           by value tcc-state
           by reference z"."
           on exception
               display "no tcc_set_lib_path" upon syserr
               perform hard-exception
       end-call

       call "tcc_set_output_type" using
           by value tcc-state
           by value TCC-OUTPUT-MEMORY
           on exception
               display "no tcc_set_output_type" upon syserr
               perform hard-exception
       end-call

       call "tcc_compile_string" using
           by value tcc-state
           by reference c-code
           returning tcc-result
           on exception
               display "no tcc_compile_string" upon syserr
               perform hard-exception
       end-call
       if tcc-result not equal zero then
           display "tcc_compile_string failed: " tcc-result upon syserr
           display "Source: " upon syserr
           display c-code(1:length(c-code) - 1) upon syserr
           perform hard-exception
       end-if

      *> add.cob is an extra file in the compilation
       set cob-entry to entry "add"
       if cob-entry equal null then
           display '"add" lookup failure' upon syserr
           perform hard-exception
       end-if
       call "tcc_add_symbol" using
           by value tcc-state
           by reference z"add"
           by value cob-entry
           on exception
               display "no tcc_add_symbol" upon syserr
               perform hard-exception
       end-call

       call "tcc_relocate" using
           by value tcc-state
           by value TCC-RELOCATE-AUTO
           returning tcc-result
           on exception
               display "no tcc_relocate" upon syserr
               perform hard-exception
       end-call
       if tcc-result less than zero then
           display "code relocation failure: " tcc-result
           perform hard-exception
       end-if

      *> entry point in c-code is foo(n)
       call "tcc_get_symbol" using
           by value tcc-state
           by reference z"foo"
           returning c-function
           on exception
               display "no tcc_get_symbol" upon syserr
               perform hard-exception
       end-call
       if c-function equal null then
           display '"foo" symbol lookup failure' upon syserr
           perform hard-exception
       end-if

      *> call foo(32)
       call c-function using
           by value 32
       end-call
       display "foo return: " return-code

       call "tcc_delete" using by value tcc-state end-call

       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program calltcc.
      *> ***************************************************************
      *>****
>>ELSE
!doc-marker!
=======
calltcc
=======

.. contents::

Introduction
------------

Call the Tiny C Compiler, to compile some C code at run-time.

Tectonics
---------

::

    prompt$ make

Usage
-----

::

    prompt$ ./calltcc

Source
------

.. include::  calltcc.cob
   :code: cobolfree

.. include:: add.cob
   :code: cobolfree

.. include:: Makefile
   :code: make
>>END-IF

identification division.
program-id. add.
data division.
linkage section.
01 a-num usage binary-long.
01 b-num usage binary-long.
procedure division using
    by value a-num
    by value b-num.
compute return-code = a-num + b-num
goback.

prompt$ make
export COB_CFLAGS='-DTCC_TARGET_X86_64'; \
 cobc -x -g -debug calltcc.cob add.cob \
 tcc.c libtcc.c tccpp.c tccgen.c tccelf.c tccasm.c tccrun.c x86_64-gen.c
i386-asm.c

prompt$ ./calltcc
Hello, tcc
fib(32) = 2178309
add(32, 64) = 96
foo return: +000000000

-rwxrwxr-x  1 btiffin btiffin  457216 Mar 27 05:03 calltcc

GCobol
      * Add a null for calling C
       STRING current-url
           DELIMITED BY SPACE
           X"00" DELIMITED BY SIZE
           INTO display-url
       MOVE display-url TO current-url

      * Remove a null for display
       STRING current-url
           DELIMITED BY LOW-VALUE
           INTO display-url.

GCobol
      * Change nulls to spaces
       INSPECT current-url
           REPLACING ALL X"00" WITH SPACE.

GCobol
      * Assume IND is the first trailing space (or picture limit).
      * Note: GnuCOBOL auto initializes working-storage to SPACES or ZEROES
      *       depending on numeric or non-numeric pictures.
      * Remove null
       MOVE SPACE TO current-url(IND:1).

      * Add a zero terminator
       MOVE X"00" TO current-url(IND:1).

GCobol
       MOVE FUNCTION CONCATENATE(filename; X"00") TO c-field.

CALL "CFUNCTION" USING BY REFERENCE ADDRESS OF current-url.

DISPLAY WHEN-COMPILED.
DISPLAY FUNCTION WHEN-COMPILED.

07/05/0805.15.20
2008070505152000-0400

DISPLAY FUNCTION PI.
3.1415926535897932384626433832795029

DISPLAY FUNCTION E.
2.7182818284590452353602874713526625

 01 myconst CONSTANT AS 1.

*> Note that CONSTANT identifiers cannot be passed to
*>   functions, or in CALL BY REFERENCE, as that exposes the
*>   constant to modification, and is disallowed.

>>SOURCE FORMAT IS FREE
>>SOURCE FORMAT IS FIXED

Column
12345678901234567890

       >>SOURCE FORMAT IS FREE
identification division.
...

DECIMAL POINT IS COMMA

MOVE FUNCTION MAX(1, 2, 3, 4, 5) TO maximal

MOVE FUNCTION MAX(1 2 3 4 5) TO maximal

MOVE FUNCTION MAX(1,,,,,2,,,,,,,3,,,4,5) TO maximal

cobc --cb_conf=text-column:72

123456789012345678901234567890123456789012345678901234567890123456789012
       identification division.
       program-id. longcont.

       data division.
       working-storage section.
       01  longstr     pic X(80)
                       value "This will all be one string in FIXED forma
      -"t source code".
       01  otherstr    pic X(148) value "this
      -"string will have spaces between the words THIS and STRING, as
      -"continuation lines always fill to column 72.".
       procedure division.
       display longstr.
       display length longstr.
       display function length(function trim(longstr trailing)).
       display otherstr(1:72).
       display otherstr(73:75).
       display length otherstr.
       display function length(function trim(otherstr trailing)).
       goback.

$ cobc longcont.cob
$ cobcrun longcont

This will all be one string in FIXED format source code
80
00000055
this                           string will have spaces between the words
THIS and STRING, as   continuation lines always fill to column 72.
148
00000139

identification division.
program-id. longstr.

data division.
working-storage section.
01  longstr     pic X(80)
                value "This " & "will " & "all " & "be " &
                      "one " &
                      "string " & "in both FIXED and FREE" &
                      " format source code".
procedure division.
display longstr.
goback.

$ cobc longstr.cob
$ cobcrun longstr
This will all be one string in both FIXED and FREE format source code
$ cobc -free longstr.cob
$ cobcrun longstr
This will all be one string in both FIXED and FREE format source code

If you put a D in column 7 OC handles this as a comment. These lines are
only compiled if you run cobc with -fdebugging-line.

By using this you can put some test messages etc. into your program that
are only used if necessary (and therefore build with -fdebugging-line).

Column
12345678901234567890
       DISPLAY "Normal Line" END-DISPLAY
    >>DDISPLAY "Debug Line" END-DISPLAY

000100 identification division.
000200 program-id. mixcase.
000300 data division.
000400 working-storage section.
000500 01 SOMEUPPER pic x(9).
000600 01 SomeUpper pic x(9).
000700 01 someupper pic x(9).
000800
000900 procedure division.
001000 move "SOMEUPPER" to SOMEUPPER.
001100 move "SomeUpper" to SomeUpper.
001200 move "someupper" to someupper.
001300 display "SOMEUPPER: " SOMEUPPER end-display.
001400 display "SomeUpper: " SomeUpper end-display.
001500 display "someupper: " someupper end-display.
001600 stop run.

$ cobc -x mixcase.cob

mixcase.cob:10: Error: 'SOMEUPPER' ambiguous; need qualification
mixcase.cob:5: Error: 'SOMEUPPER' defined here
mixcase.cob:6: Error: 'SOMEUPPER' defined here
mixcase.cob:7: Error: 'SOMEUPPER' defined here

CALL "C$JUSTIFY" USING center-string "C" END-CALL.

CALL "c$justify" USING center-string "C" END-CALL.

The expressions "uppercase" and "lowercase" date back to early movable
type.  Typographers would keep two cases of metal casted letters,
Capitalized and normal.  Usually set on stacked shelves over the
workbench. The small letters, being used more frequently, ended up on the
lower, more easily reachable shelf; the lower case letters.

program-id. a.

$ ls -l empty.cob
-rw-r--r-- 1 root root 0 Jun 21 12:35 empty.cob

$ cobc -x -frelax-syntax empty.cob
empty.cob: 1: Warning: PROGRAM-ID header missing - assumed

$ ./empty
$

program-id.hello.procedure division.display "Hello, world".

$ cat hello.cob
display"Hello, world".

$ cobc -x -frelax-syntax -free hello.cob
hello.cob: 1: Warning: PROGRAM-ID header missing - assumed
hello.cob: 1: Warning: PROCEDURE DIVISION header missing - assumed

$ ./hello
Hello, world
$

000005* HELLO.COB GnuCOBOL FAQ example
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. hello.
000030 PROCEDURE DIVISION.
000040 DISPLAY "Hello, world".
000100 STOP RUN.

%!perl -ne 'printf("\%06d\%s\n", $. * 100, substr($_, 6, -1));'

000100* HELLO.COB GnuCOBOL FAQ example
000200 IDENTIFICATION DIVISION.
000300 PROGRAM-ID. hello.
000400 PROCEDURE DIVISION.
000500 DISPLAY "Hello, world".
000600 STOP RUN.

:set number

$ less -N

01  B-COUNT                         PIC 999 VALUE 0.
01  TEST-CASE                       PIC X(80)
    VALUE "This is my string.".

ONE-WAY.
    INSPECT FUNCTION REVERSE(TEST-CASE)
        TALLYING B-COUNT
        FOR LEADING ' '.
    DISPLAY B-COUNT.

TWO-WAY.
    INSPECT TEST-CASE
        TALLYING B-COUNT
        FOR TRAILING SPACE.
    DISPLAY B-COUNT.

THREE-WAY.
    IF TEST-CASE EQUAL SPACES
        COMPUTE B-COUNT = LENGTH OF TEST-CASE
    ELSE
        COMPUTE
            B-COUNT = LENGTH TEST-CASE -
                FUNCTION LENGTH(FUNCTION TRIM(TEST-CASE TRAILING))
        END-COMPUTE
    END-IF
    DISPLAY B-COUNT.

062
124
062

01 mynumber PIC 9(8)   VALUE 123.
01 myedit   PIC Z(7)9.
01 mychars  PIC X(8).

01 spcount  PIC 99     USAGE COMPUTATIONAL.

MOVE mynumber TO myedit
MOVE myedit TO mychars
DISPLAY mynumber END-DISPLAY
DISPLAY myedit END-DISPLAY

00000123
     123

FUNCTION TRIM(myedit LEADING)

CALL "C$JUSTIFY" USING mychars "L" END-CALL

MOVE 0 TO spcount
INSPECT myedit TALLYING spcount FOR LEADING SPACE
MOVE myedit(spcount + 1:) TO mychars

DISPLAY myedit END-DISPLAY
DISPLAY mychars END-DISPLAY

     123
123

MOVE 0 TO spcount
INSPECT mynumber TALLYING spcount FOR LEADING ZERO
DISPLAY mynumber
DISPLAY mynumber(spcount + 1:)

IDENTIFICATION DIVISION.
PROGRAM-ID. EXAMPLE.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Y PIC X(15).
01 T REDEFINES Y PIC -(5)9(7).99.
01 U REDEFINES Y PIC -9(7).99B(4).
01 X PIC S9(7)V9(2).
PROCEDURE DIVISION.
MOVE -1234567.89 TO X
MOVE X TO T
DISPLAY 'X: >' X '< Y: >' Y '<'
MOVE X TO U
DISPLAY 'X: >' X '< Y: >' Y '<'
GOBACK .

prompt$ cobc -xj aligning.cob
X: >12345678< Y: > -1234567.89<
X: >12345678< Y: >-1234567.89 <

01  MYSPACE   PIC X VALUE X"20".
    88 MYISASCII   VALUE SPACE.

IF MYISASCII
    DISPLAY "I'm ASCII" END-DISPLAY
END-IF

01  MYPOINTER    USAGE POINTER.

IF FUNCTION LENGTH(MYPOINTER) EQUALS 8
    DISPLAY "This is a 64 bit machine"
END-IF

>>IF P64 IS SET
display "Pointers are 64 bit"
>>ELSE
display "Pointers are 32 bits wide"
>>END-IF

>>IF P64 IS SET
01 size-mod CONSTANT AS 18.
>>ELSE
01 size-mod CONSTANT AS 8.
>>END-IF

01 c-size-t   PIC 9(size-mod) COMP-5.

GCobol*> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      29-Dec-2008
      *> Purpose:   Horsing around with recursion
      *> Tectonics: cobc -x recurse.cob
      *> ***************************************************************
       identification division.
       program-id. recurse.

       data division.
       working-storage section.
       78 n      value 4.
       01 fact usage binary-long.

      *> ***************************************************************
       procedure division.

       call "factorial" using by value n returning fact end-call
       display n "! = " fact end-display

       goback.
       end program recurse.
      *> ***************************************************************
      *> ***************************************************************

      *> ***************************************************************
       identification division.
       program-id. factorial is recursive.

       data division.
       local-storage section.
       01 result usage is binary-long.

       linkage section.
       01 num usage is binary-long.

      *> ***************************************************************
       procedure division using by value num.

       display "num: " num end-display
       if num equal zero
           move 1 to return-code
           display "ret: " return-code end-display
           goback
       end-if

       subtract 1 from num end-subtract
       call "factorial" using by value num returning result end-call
       compute return-code = (num + 1) * result end-compute
       display "ret: " return-code end-display
       goback.

       end program factorial.

num: +0000000004
num: +0000000003
num: +0000000002
num: +0000000001
num: +0000000000
ret: +000000001
ret: +000000001
ret: +000000002
ret: +000000006
ret: +000000024
4! = +0000000024

GCobol*> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      04-Feb-2009
      *> Purpose:   Factorial and overflow
      *> Tectonics: cobc -x overflowing.cob
      *> ***************************************************************
       identification division.
       program-id. overflowing.

       data division.
       working-storage section.
       01 fact   usage binary-long.
       01 answer usage binary-double.

      *> ***************************************************************
       procedure division.
       00-main.

       perform
           varying fact from 1 by 1
           until fact > 21
               add function factorial(fact) to zero giving answer
                   on size error
                       display
                           "overflow at: " fact " is " answer
                           " without test " function factorial(fact)
                       end-display
                   not on size error
                       display fact ": " answer end-display
               end-add
       end-perform
       .

       00-leave.
       goback.

       end program overflowing.
      *> ***************************************************************

+0000000001: +00000000000000000001
+0000000002: +00000000000000000002
+0000000003: +00000000000000000006
+0000000004: +00000000000000000024
+0000000005: +00000000000000000120
+0000000006: +00000000000000000720
+0000000007: +00000000000000005040
+0000000008: +00000000000000040320
+0000000009: +00000000000000362880
+0000000010: +00000000000003628800
+0000000011: +00000000000039916800
+0000000012: +00000000000479001600
+0000000013: +00000000006227020800
+0000000014: +00000000087178291200
+0000000015: +00000001307674368000
+0000000016: +00000020922789888000
+0000000017: +00000355687428096000
+0000000018: +00006402373705728000
+0000000019: +00121645100408832000
overflow at: +0000000020 is +00121645100408832000 without test 432902008176640000
overflow at: +0000000021 is +00121645100408832000 without test 197454024290336768

*> Author:    Brian Tiffin
*> Date:      04-Feb-2009   Modified: 2015-11-11/07:44-0500
*> Purpose:   Factorial and overflow with SIZE ERROR
*> Tectonics: cobc -xj overflowing.cob
*> ***************************************************************
 identification division.
 program-id. overflowing.

 data division.
 working-storage section.
 01 fact          pic 99.
 01 answer        usage binary-double.
 01 bigger-answer pic 9(38).
 01 float-answer  usage float-short.

*> ***************************************************************
 procedure division.
 00-main.

 perform
     varying fact from 1 by 1
     until fact > 22
         add function factorial(fact) to zero giving answer
             on size error
                 display "binary-double overflow at: "
                     fact " is " answer
                 display " intrinsic: " function factorial(fact)
             not on size error
                 move answer to float-answer
                 display fact ": " answer ", " float-answer
         end-add
 end-perform
 display space
 perform
     varying fact from 19 by 1
     until fact > 35
         add function factorial(fact) to zero giving bigger-answer
             on size error
                 display "pic 9(38) overflow at: "
                     fact " is " bigger-answer
                 display " intrinsic: " function factorial(fact)
             not on size error
                 move bigger-answer to float-answer
                 display fact ": " bigger-answer ", " float-answer
         end-add
 end-perform
 .

 00-leave.
 goback.

 end program overflowing.
*> ***************************************************************

prompt$ cobc -xj overflowing.cob
01: +00000000000000000001, 1
02: +00000000000000000002, 2
03: +00000000000000000006, 6
04: +00000000000000000024, 24
05: +00000000000000000120, 120
06: +00000000000000000720, 720
07: +00000000000000005040, 5040
08: +00000000000000040320, 40320
09: +00000000000000362880, 362880
10: +00000000000003628800, 3628800
11: +00000000000039916800, 39916800
12: +00000000000479001600, 4.790016E+08
13: +00000000006227020800, 6.2270208E+09
14: +00000000087178291200, 8.7178289E+10
15: +00000001307674368000, 1.3076744E+12
16: +00000020922789888000, 2.0922791E+13
17: +00000355687428096000, 3.5568741E+14
18: +00006402373705728000, 6.4023735E+15
19: +00121645100408832000, 1.216451E+17
20: +02432902008176640000, 2.432902E+18
binary-double overflow at: 21 is +02432902008176640000
 intrinsic: 51090942171709440000
binary-double overflow at: 22 is +02432902008176640000
 intrinsic: 1124000727777607680000

19: 00000000000000000000121645100408832000, 1.216451E+17
20: 00000000000000000002432902008176640000, 2.432902E+18
21: 00000000000000000051090942171709440000, 5.1090941E+19
22: 00000000000000001124000727777607680000, 1.1240007E+21
23: 00000000000000025852016738884976640000, 2.5852017E+22
24: 00000000000000620448401733239439360000, 6.2044838E+23
25: 00000000000015511210043330985984000000, 1.551121E+25
26: 00000000000403291461126605635584000000, 4.0329146E+26
27: 00000000010888869450418352160768000000, 1.0888869E+28
28: 00000000304888344611713860501504000000, 3.0488835E+29
29: 00000008841761993739701954543616000000, 8.8417619E+30
30: 00000265252859812191058636308480000000, 2.6525285E+32
31: 00008222838654177922817725562880000000, 8.2228384E+33
32: 00263130836933693530167218012160000000, 2.6313083E+35
33: 08683317618811886495518194401280000000, 8.6833179E+36
pic 9(38) overflow at: 34 is 08683317618811886495518194401280000000
 intrinsic: 295232799039604140847618609643520000000
pic 9(38) overflow at: 35 is 08683317618811886495518194401280000000
 intrinsic: 10333147966386144929666651337523200000000

GCobol >>SOURCE FORMAT IS FIXED
      ******************************************************************
      * Author:    Brian Tiffin
      * Date:      29-July-2008
      * Purpose:   Plot trig and a random income/expense/worth report
      * Tectonics: requires access to gnuplot. http://www.gnuplot.info
      *            cobc -Wall -x plotworth.cob
      *  OVERWRITES ocgenplot.gp ocgpdata.txt sincos.png ploworth.png
      ******************************************************************
       identification division.
       program-id. plotworth.

       environment division.
       input-output section.
       file-control.
           select scriptfile
               assign to "ocgenplot.gp"
               organization is line sequential.
           select outfile
               assign to "ocgpdata.txt"
               organization is line sequential.
           select moneyfile
               assign to "ocgpdata.txt"
               organization is line sequential.

       data division.
       file section.
       fd scriptfile.
          01 gnuplot-command pic x(82).
       fd outfile.
          01 outrec.
             03 x-value   pic -zzzzzz9.99.
             03 filler    pic x.
             03 sin-value pic -zzzz9.9999.
             03 filler    pic x.
             03 cos-value pic -zzzz9.9999.
       fd moneyfile.
          01 moneyrec.
             03 timefield pic 9(8).
             03 filler    pic x.
             03 income    pic -zzzzzz9.99.
             03 filler    pic x.
             03 expense   pic -zzzzzz9.99.
             03 filler    pic x.
             03 networth  pic -zzzzzz9.99.

       working-storage section.
       01 angle   pic s9(7)v99.

       01 dates   pic 9(8).
       01 days    pic s9(9).
       01 worth   pic s9(9).
       01 amount  pic s9(9).

       01 gplot   pic x(80) value is 'gnuplot -persist ocgenplot.gp'.
       01 result  pic s9(9).

       procedure division.

      * Create the script to plot sin and cos
       open output scriptfile.
       move "plot 'ocgpdata.txt' using 1:2 with lines title 'sin(x)'"
      - to gnuplot-command.
       write gnuplot-command.
       move "replot 'ocgpdata.txt' using 1:3 with lines title 'cos(x)'"
      - to gnuplot-command.
       write gnuplot-command.
       move "set terminal png; set output 'sincos.png'; replot"
      - to gnuplot-command.
       write gnuplot-command.
       close scriptfile.

      * Create the sinoidal data
       open output outfile.
       move spaces to outrec.
       perform varying angle from -10 by 0.01
           until angle > 10
               move angle to x-value
               move function sin(angle) to sin-value
               move function cos(angle) to cos-value
               write outrec
       end-perform.
       close outfile.

      * Invoke gnuplot
       call "SYSTEM" using gplot
                     returning result.
       if result not = 0
           display "Problem: " result
           stop run returning result
       end-if.

      * Generate script to plot the random networth
       open output scriptfile.
       move "set xdata time" to gnuplot-command.
       write gnuplot-command.
       move 'set timefmt "%Y%m%d"' to gnuplot-command.
       write gnuplot-command.
       move 'set format x "%m"' to gnuplot-command.
       write gnuplot-command.
       move 'set title "Income and expenses"' to gnuplot-command.
       write gnuplot-command.
       move 'set xlabel "2008 / 2009"' to gnuplot-command.
       write gnuplot-command.
       move 'plot "ocgpdata.txt" using 1:2 with boxes title "Income"
      -' linecolor rgb "green"' to gnuplot-command.
       write gnuplot-command.
       move 'replot "ocgpdata.txt" using 1:3 with boxes title "Expense"
      -' linecolor rgb "red"' to gnuplot-command.
       write gnuplot-command.
       move 'replot "ocgpdata.txt" using 1:4 with lines title "Worth"'
      -    to gnuplot-command.
       write gnuplot-command.
       move 'set terminal png; set output "plotworth.png"; replot'
      -    to gnuplot-command.
       write gnuplot-command.
       close scriptfile.

      * Generate a bi-weekly dataset with date, income, expense, worth
       open output moneyfile.
       move spaces to moneyrec.
       move function integer-of-date(20080601) to dates.
       move function random(0) to amount.

       perform varying days from dates by 14
           until days > dates + 365
               move function date-of-integer(days) to timefield
               compute amount = function random() * 2000
               compute worth = worth + amount
               move amount to income
               compute amount  = function random() * 1800
               compute worth = worth - amount
               move amount to expense
               move worth to networth
               write moneyrec
       end-perform.
       close moneyfile.

      * Invoke gnuplot again.  Will open new window.
       call "SYSTEM" using gplot
                     returning result.
       if result not = 0
           display "Problem: " result
           stop run returning result
       end-if.

       goback.

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140424
      *> License:   Licensed under the GPL 2
      *> Purpose:   MathGL plotting, with MathGL Script
      *> Tectonics: cobc -x mgl-parser.cob -lmgl
      *> ***************************************************************
       identification division.
       program-id. mgl-parser.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 mgl-gr               usage pointer.
       01 mgl-dt               usage pointer.
       01 mgl-parser           usage pointer.

      *> This example uses MathGL "double" C data, which is float-long
       01 dataset.
          05 dataitem          usage float-long occurs 100 times.
       01 item                 usage index.
       01 float-item           usage float-long.

      *> call by value needs helpers to align literal data types
       01 title-size           usage float-long value -2.0.

      *> MathGL script is newline sensitive, or use ":"
       01 newline              constant as x"0a".

      *> ***************************************************************
       procedure division.

      *> Prep a COBOL data set, in this case sinoidal
       perform varying item from 1 by 1 until item > 100
           compute float-item = item - 1 end-compute
           compute
               dataitem(item) = sin(4 * pi * float-item / 99)
           end-compute
       end-perform

      *> Initialize a MathGL graphic space
       call "mgl_create_graph" using
           by value 600
           by value 400
           returning mgl-gr
           on exception
               display "no MathGL, -lmgl" upon syserr end-display
               goback
       end-call

      *> Title the graph, as part of the plot
       call "mgl_title" using
           by value mgl-gr
           by content z"MGL parser sample"
           by content z""
           by value title-size
           returning omitted
       end-call

      *> create an MGL script handler
       call "mgl_create_parser" returning mgl-parser end-call

      *> register a variable, named "dat"
       call "mgl_parser_add_var" using
           by value mgl-parser
           by content z"dat"
           returning mgl-dt
       end-call

      *> Convert the COBOL dataset to an MGL array, (linked to "dat")
       call "mgl_data_set_double" using
           by value mgl-dt
           by reference dataset
           by value 100
           by value 1
           by value 1
           returning omitted
       end-call

      *> Send MGL script commands to plot the "dat" array
      *>     within 0 and 1, then draw a box, then axis
       call "mgl_parse_text" using
           by value mgl-gr
           by value mgl-parser
           by content
               z"plot dat; xrange 0 1 : box : axis"
           returning omitted
       end-call

      *> continue the script with some labeling
       call "mgl_parse_text" using
           by value mgl-gr
           by value mgl-parser
           by content
               z"xlabel 'x' : ylabel 'y'"
           returning omitted
       end-call

      *> use some control flow to draw some lines
      *>   red 'r' when less than 0, 'g' green otherwise
       call "mgl_parse_text" using
           by value mgl-gr
           by value mgl-parser
           by content
               "for $0 -1 1 0.1" & newline &
               "    if $0<0" & newline &
               "        line 0 0 -1 $0 'r'" & newline &
               "    else" & newline &
               "        line 0 0 -1 $0 'g'" & newline &
               "    endif" & newline &
               z"next"
           returning omitted
       end-call

      *> and save the graph
       call "mgl_write_png" using
           by value mgl-gr
           by content z"mgl-parser.png"
           by content z""
           returning omitted
       end-call

       goback.
       end program mgl-parser.

      *> ***************************************************************
      *int sample(HMGL gr)
      *{
      *  mgl_title(gr, "MGL parser sample", "", -2);
      *  double a[100];   // let a_i = sin(4*pi*x), x=0...1
      *  int i;
      *  for(i=0;i<100;i++)  a[i]=sin(4*M_PI*i/99);
      *  HMPR parser = mgl_create_parser();
      *  HMDT d = mgl_parser_add_var(parser, "dat");
      *  mgl_data_set_double(d,a,100,1,1);    // set data to variable
      *  mgl_parse_text(gr, parser, "plot dat; xrange 0 1\nbox\naxis");
      *  // you may break script at any line do something
      *  // and continue after that
      *  mgl_parse_text(gr, parser, "xlabel 'x'\nylabel 'y'");
      *  // also you may use cycles or conditions in script
      *  mgl_parse_text(gr, parser, "for $0 -1 1 0.1\nif $0<0\n"
      *    "line 0 0 -1 $0 'r':else:line 0 0 -1 $0 'g'\n"
      *    "endif\nnext");
      *  mgl_write_png(gr, "test.png", "");  // don't forgot to save picture
      *  return 0;
      *}

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140503
      *> License:   Licensed under the GPL 2
      *> Purpose:   MathGL plotting, with MathGL Script
      *> Tectonics: cobc -x mathgl-finance.cob mathgl-repo.cob -lmgl
      *> ***************************************************************
       identification division.
       program-id. mathgl-finance.

       environment division.
       configuration section.
       repository.
           function mathgl-script
           function all intrinsic.

data   data division.
       working-storage section.
      *> MathGL usually uses "double" C data, which is float-long
       01 dataset.
          05 dataitem          usage float-long occurs 100 times.
       01 item                 usage index.

       01 mathgl-return        usage binary-long.

      *> ***************************************************************
code   procedure division.

      *> Prep a COBOL data set, in this case, incrementally up, randomly
       move random(42) to dataitem(1)   *> seed the random function
       perform varying item from 1 by 1 until item > 99
           compute
               dataitem(item + 1) = dataitem(item) + random()
           end-compute
       end-perform

      *> Send MGL script commands to plot the "dat" array
      *>     within 1 and 100, then draw a box, then axis
      *>     continue the script with some labeling
      *> Upper range of 60, odds are the 100 random numbers
      *>     will sum up to 55.

       move mathgl-script(dataset,
           "subplot 1 2 0:" &
           "    ranges 1 100 0 60:" &
           "    plot dat : box : axis:" &
           "    xlabel 'days' : ylabel 'cash':" &
           "subplot 1 2 1:" &
           "    ranges 1 100 0 60:" &
           "    copy threed dat:" &
          z"    box : axis : bars threed 'o!rgb'")
         to mathgl-return

       display mathgl-return end-display
       goback.
       end program mathgl-finance.

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140503
      *> License:   Licensed under the GPL 2
      *> Purpose:   MathGL plotting, with MathGL Script, as a function
      *> Tectonics: cobc -x mathgl-finance.cob mathgl-repo.cob -lmgl
      *> ***************************************************************
       identification division.
       function-id. mathgl-script.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       01 mgl-gr               usage pointer.
       01 mgl-dt               usage pointer.
       01 mgl-parser           usage pointer.

      *> call by value needs helpers to align literal data types
       01 float-title-size     usage float-long value -1.6.

      *> MathGL script is newline sensitive, or use ":"
       01 newline              constant as x"0a".

       linkage section.
       01 mathgl-return        usage binary-long.
       01 mathgl-dataset.
          05 mathgl-y-value    usage float-long occurs 100 times.
       01 mathgl-text          pic x any length.

      *> ***************************************************************
       procedure division using mathgl-dataset mathgl-text
           returning mathgl-return.

       display length(mathgl-text) ":" trim(mathgl-text) end-display

      *> Initialize a MathGL graphic space
       call "mgl_create_graph" using
           by value 600
           by value 400
           returning mgl-gr
           on exception
               display "no MathGL, -lmgl" upon syserr end-display
               goback
       end-call

      *> Title the graph, as part of the plot
       call "mgl_title" using
           by value mgl-gr
           by content z"MathGL and GnuCOBOL"
           by content z""
           by value float-title-size
           returning omitted
       end-call

      *> create an MGL script handler
       call "mgl_create_parser" returning mgl-parser end-call

      *> register a variable, named "dat"
       call "mgl_parser_add_var" using
           by value mgl-parser
           by content z"dat"
           returning mgl-dt
       end-call

      *> Convert the COBOL dataset to an MGL array, (linked to "dat")
       call "mgl_data_set_double" using
           by value mgl-dt
           by reference mathgl-dataset
           by value 100
           by value 1
           by value 1
           returning omitted
       end-call

      *> plot the userland script
       call "mgl_parse_text" using
           by value mgl-gr
           by value mgl-parser
           by reference mathgl-text
           returning omitted
       end-call

      *> and save the graph
       call "mgl_write_png" using
           by value mgl-gr
           by content z"mathgl-finance.png"
           by content z""
           returning omitted
       end-call

       goback.
       end function mathgl-script.

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140503
      *> License:   Licensed under the GPL 2
      *> Purpose:   MathGL plotting, with MathGL Script
      *> Tectonics: cobc -x mathgl-finance.cob mathgl-repo.cob -lmgl
      *> ***************************************************************
       identification division.
       program-id. mathgl-finance.

       environment division.
       configuration section.
       repository.
           function mathgl-script
           function all intrinsic.

data   data division.
       working-storage section.
       01 graph-width          usage binary-long value 1200.
       01 graph-height         usage binary-long value 800.
       01 title-size           usage float-long value -1.4.
       01 graph-title          pic x(21) value z"MathGL and GnuCOBOL".
       01 output-filename      pic x(21) value z"mathgl-scripting.png".

      *> Using MathGL "double" C data, which is float-long
      *>  complicating factor is row-major order of the vectors.
      *>  3 by 12, not a 12 by 3.
       01 linkname             pic x(4) value z"dat".
       01 dataset.
          05 income            occurs 12 times usage float-long.
          05 expense           occurs 12 times usage float-long.
          05 month-total       occurs 12 times usage float-long.
       01 item                 usage index.
       01 x-elements           usage binary-long value 12.
       01 y-elements           usage binary-long value 3.
       01 z-elements           usage binary-long value 1.

       01 mathgl-return        usage binary-long.

      *> ***************************************************************
code   procedure division.

      *> Prep a COBOL data set. Some sample monthlies
       compute expense(1) = random(42) end-compute
       perform varying item from 1 by 1 until item > 12
           compute income(item) = 1000.0 * random() end-compute
           compute expense(item) = 800.0 * random() end-compute
           if item > 1 then
               compute month-total(item) = month-total(item - 1) +
                         income(item - 1) - expense(item - 1)
               end-compute
           end-if
       end-perform

      *> Send MGL script commands to plot the "dat" array
      *>     then draw a box, then axis
      *>     continue the script with some labeling
      *>  and subplots

       >>source format is free
       move mathgl-script(
           graph-width, graph-height
           title-size, graph-title
           output-filename
           linkname, dataset
           x-elements, y-elements, z-elements
           "subplot 1 3 0:" &
           "    ranges 0 12 -1000 2000:" &
           "    tuneticks 0:" &
           "    origin 0 0:" &
           "    plot dat 'obrg': box : axis:" &
           "    line 0 0 12 0 'k':" &
           "    xlabel 'month' : ylabel 'income, expense, #g{balance}':" &
           "subplot 1 3 2:" &
           "    ranges 0 12 -1000 2000:" &
           "    copy threed dat:" &
           "    box : axis : bars threed '#brg':" &
           "    xlabel '2014' : ylabel '#b{Income}, #r{Expenses}, #g{Worth}':" &
           "    table 0.5 0 dat '#b{income}\\n#r{expense}\\n#g{worth}' '#':" &
           "subplot 1 3 1:" &
           "    ranges 0 12 -1000 2000:" &
           "    rotate 50 50:" &
           "    alpha on:" &
           "    box '@' : axis : area threed '#brg':" &
          z"    xlabel '2014' : ylabel '#b{In}, #r{Out}, #g{Worth}'")
         to mathgl-return
       >>source format is fixed

      *> don't need the null on the z-string anymore
       inspect output-filename replacing all x"00" by " "
       display
           "Saved " output-filename " with status " mathgl-return
       end-display

      *> display image with feh command, white background
       call "SYSTEM" using concatenate("feh -B white " output-filename) end-call
      *> ask about removing image file after viewing
       call "SYSTEM" using concatenate("rm -vi " output-filename) end-call

       goback.
       end program mathgl-finance.

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140507
      *> License:   Licensed under the GPL 2
      *> Purpose:   MathGL plotting, with MathGL Script, as a function
      *> Tectonics: cobc -x mathgl-finance.cob mathgl-repo.cob -lmgl
      *> ***************************************************************
       identification division.
       function-id. mathgl-script.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

      *> MathGL graphic, data pointer, script handler
       01 mgl-gr               usage pointer.
       01 mgl-dt               usage pointer.
       01 mgl-parser           usage pointer.

      *> fat linkage, problem area, it's coupled.
       linkage section.
       01 mathgl-return        usage binary-long.
       01 graph-pane-width     usage binary-long.
       01 graph-pane-height    usage binary-long.
       01 title-size           usage float-long.
       01 graph-title          pic x any length.
       01 output-filename      pic x any length.
       01 mathgl-linkname      pic x any length.
       01 mathgl-dataset.
          05 data-income       occurs 12 times usage float-long.
          05 data-expense      occurs 12 times usage float-long.
          05 data-total        occurs 12 times usage float-long.
       01 x-elements           usage binary-long.
       01 y-elements           usage binary-long.
       01 z-elements           usage binary-long.
       01 mathgl-text          pic x any length.

      *> ***************************************************************
       procedure division using
           by value graph-pane-width graph-pane-height title-size
           by reference graph-title output-filename
           by reference mathgl-linkname mathgl-dataset
           by value x-elements y-elements z-elements
           by reference mathgl-text
           returning mathgl-return.

      *> Initialize a MathGL graphic space
       call "mgl_create_graph" using
           by value graph-pane-width
           by value graph-pane-height
           returning mgl-gr
           on exception
               display "no MathGL, -lmgl" upon syserr end-display
               goback
       end-call

      *> Title the graph, as part of the plot
       call "mgl_title" using
           by value mgl-gr
           by reference graph-title
           by content z""
           by value title-size
           returning omitted
       end-call

      *> create an MGL script handler
       call "mgl_create_parser" returning mgl-parser end-call

      *> register a variable, with a userland link name
       call "mgl_parser_add_var" using
           by value mgl-parser
           by reference mathgl-linkname
           returning mgl-dt
       end-call

      *> Convert the COBOL dataset to an MGL array,
      *>    (registered to the link name, above)
      *> for this example (and in the script)
      *> the name "dat" is used for userland access
       call "mgl_data_set_double" using
           by value mgl-dt
           by reference mathgl-dataset
           by value x-elements
           by value y-elements
           by value z-elements
           returning omitted
       end-call

      *> plot the userland script
       call "mgl_parse_text" using
           by value mgl-gr
           by value mgl-parser
           by reference mathgl-text
           returning omitted
       end-call

      *> and save the graph
       call "mgl_write_png" using
           by value mgl-gr
           by reference output-filename
           by content z""
           returning omitted
       end-call

      *> and free the graphing space
       call "mgl_delete_graph" using
           by value mgl-gr
           returning omitted
       end-call
       goback.
       end function mathgl-script.

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      03-Dec-2008
      *> Modified:   2017-07-07/07:52-0400
      *> Purpose:   Hello from GTK+
      *> Requires:  libgtk2.0, libgtk2.0-dev, gtk2.0, pkg-config
      *> Tectonics:
      *>     gcc -fPIC -c `pkg-config --cflags gtk+-2.0` ocgtk.c
      *>     cobc -x `pkg-config --libs gtk+-2.0` gtkhello.cob ocgtk.o
      *> ***************************************************************
       identification division.
       program-id. gtkhello.

       data division.

       working-storage section.
       01 result               usage binary-long.
       01 gtk-window           usage pointer.
       01 gtk-box              usage pointer.
       01 gtk-hello            usage pointer.
       01 gtk-textentry        usage pointer.
       01 gtk-goodbye          usage pointer.

       01 callback             usage procedure-pointer.
       01 params               usage pointer.

      *> **************************************************************
       procedure division.

      *> Initialize GTK
       CALL "CBL_OC_GTK_INIT_CHECK" returning result END-CALL
    >>D   display "init: " result end-display

      *> Create a toplevel window
       CALL "CBL_OC_GTK_WINDOW_NEW" returning gtk-window END-CALL
    >>D   display "win: " gtk-window end-display

      *> Set the titlebar - using cob_field now **HERE**
       CALL "CBL_OC_GTK_WINDOW_SET_TITLE"
               using by value gtk-window
                   by reference "GnuCOBOL GTK+"
       END-CALL
    >>D   display "title: " gtk-window end-display

      *> Set the border width
       CALL "CBL_OC_GTK_CONTAINER_SET_BORDER_WIDTH"
               using by value gtk-window
                   by value 5
       END-CALL
    >>D   display "border: " gtk-window end-display

      *> connect a window destroy, quit main loop handler
       set callback to entry "CBL_OC_destroy"
       CALL "CBL_OC_G_SIGNAL_CONNECT"
               using by value gtk-window
                   by reference "delete_event" & x"00"
                   by value callback
                   by value params
       END-CALL

      *> Create a vertically packed box
       CALL "CBL_OC_GTK_VBOX_NEW"
               using by value 0
                   by value 5
               returning gtk-box
       END-CALL
    >>D   display "box: " gtk-box end-display

      *> Add the box to the window
       CALL "CBL_OC_GTK_CONTAINER_ADD"
               using by value gtk-window
                   by value gtk-box
       END-CALL

      *> Create the hello button
       CALL "CBL_OC_GTK_BUTTON_NEW_WITH_LABEL"
           using by reference "Hello from GnuCOBOL and GTK" & x"00"
           returning gtk-hello
       END-CALL
    >>D   display "button: " gtk-hello end-display

      *> Connect the hello button to the hello code
       set callback to entry "CBL_OC_hello"
       CALL "CBL_OC_G_SIGNAL_CONNECT"
               using by value gtk-hello
                   by reference "clicked" & x"00"
                   by value callback
                   by value params
       END-CALL

      *> Pack the button into the box, top to bottom
       CALL "CBL_OC_GTK_BOX_PACK_START"
               using by value gtk-box
                   by value gtk-hello
                   by value 1
                   by value 1
                   by value 0
       END-CALL

      *> button is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-hello
       END-CALL

      *> Add a text entry field
       CALL "CBL_OC_GTK_ENTRY_NEW"
               returning gtk-textentry
       END-CALL

      *> Connect code to the text entry, passing the entry widget
       set callback to entry "CBL_OC_activate"
       CALL "CBL_OC_G_SIGNAL_CONNECT"
               using by value gtk-textentry
                   by reference "activate" & x"00"
                   by value callback
                   by value gtk-textentry
       END-CALL

      *> Pack the text field into the box, top to bottom
       CALL "CBL_OC_GTK_BOX_PACK_START"
               using by value gtk-box
                   by value gtk-textentry
                   by value 1
                   by value 1
                   by value 0
       END-CALL

      *> text field is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-textentry
       END-CALL

      *> Create the bye button
       CALL "CBL_OC_GTK_BUTTON_NEW_WITH_LABEL"
           using by reference "Goodbye from GnuCOBOL and GTK" & x"00"
               returning gtk-goodbye
       END-CALL
    >>D   display "button: " gtk-goodbye end-display

      *> Connect the bye button to the bye code
       set callback to entry "CBL_OC_destroy"
       CALL "CBL_OC_G_SIGNAL_CONNECT"
               using by value gtk-goodbye
                   by reference "clicked" & x"00"
                   by value callback
                   by value params
       END-CALL

      *> Pack the button into the box, under hello
       CALL "CBL_OC_GTK_BOX_PACK_START"
               using by value gtk-box
                   by value gtk-goodbye
                   by value 1
                   by value 1
                   by value 0
       END-CALL
    >>D   display "pack: " gtk-box end-display

      *> button is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-goodbye
       END-CALL

      *> box is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-box
       END-CALL

      *> window is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-window
       END-CALL

      *> Start up the event loop, control returned when GTK main exits
       CALL "CBL_OC_GTK_MAIN" END-CALL

      *> Something terminated the GTK main loop, sys-close or bye or
       display "ending..." end-display

       goback.
       end program gtkhello.
      *> **************************************************************

      *> **** window shutdown callback ********************************
       identification division.
       program-id. CBL_OC_destroy.

       environment division.
       configuration section.
       special-names.
           call-convention 0 is extern.

       data division.
       linkage section.
       01 gtk-window           usage pointer.
       01 gtk-data             usage pointer.

       procedure division extern using
           by value gtk-window by value gtk-data returning omitted.

       CALL "CBL_OC_GTK_MAIN_QUIT" END-CALL

       goback.
       end program CBL_OC_destroy.
      *> **************************************************************


      *> **** hello button click callback *****************************
       identification division.
       program-id. CBL_OC_hello.

       environment division.
       configuration section.
       special-names.
           call-convention 0 is extern.

       data division.
       linkage section.
       01 gtk-window           usage pointer.
       01 gtk-data             usage pointer.

       procedure division extern using
           by value gtk-window by value gtk-data returning omitted.

       display
               "Hello from GTK in GnuCOBOL at "
               function current-date
       end-display

       goback.
       end program CBL_OC_hello.

      *> **** text entry activation callback **************************
      *> This procedure called from GTK on enter key pressed in entry
       identification division.
       program-id. CBL_OC_activate.

       environment division.
       configuration section.
       special-names.
           call-convention 0 is extern.

       data division.
       working-storage section.
       01 textfield            pic x(32).
       01 textlen              usage binary-long.

       linkage section.
       01 gtk-window           usage pointer.
       01 gtk-data             usage pointer.

       procedure division extern using
           by value gtk-window by value gtk-data returning omitted.

       CALL "CBL_OC_GTK_ENTRY_GET_TEXT"
               using by value gtk-data
                     by reference textfield
               returning textlen
       END-CALL
       display "text: " textfield ", " textlen end-display

       goback.
       end program CBL_OC_activate.

/* GnuCOBOL GTK+ 2.0 wrapper */
/* Tectonics: cobc -c `pkg-config --cflags gtk+-2.0` ocgtk.c */

#include <memory.h>
#include <stdlib.h>
#include <libcob.h>

#include <gtk/gtk.h>
#include <glib.h>

#include "ocgtk.h"

/* Initialize the toolkit, abends if not possible */
int
CBL_OC_GTK_INIT(int argc, char *argv[])
{
    gtk_init(&argc, &argv);
    return 0;
}

/* Initialize the toolkit, return false if not possible */
/* Need pointers to argc and argv here */
int
CBL_OC_GTK_INIT_CHECK()
{
    gboolean gres = gtk_init_check(0, NULL);
    return (gres == TRUE) ? 0 : -1;
}

/* Create new window */
GtkWidget*
CBL_OC_GTK_WINDOW_NEW()
{
    return gtk_window_new(GTK_WINDOW_TOPLEVEL);
}

/* set the title */
int
CBL_OC_GTK_WINDOW_SET_TITLE(void *window, char *title)
{
    //struct cob_module *module;
    cob_module *module;
    cob_field  *title_field;
    char       *cstr;

    /* Error conditions simply return, doing nothing */
    if (cob_get_global_ptr()->cob_call_params < 2) { return 1; }

    module = cob_get_global_ptr()->cob_current_module;
    if (module == NULL) {
        //cob_runtime_error("No module!");
        //cob_stop_run(1);
        return 1;
    }

    //title_field = module->cob_procedure_parameters[1];
    title_field = module->cob_procedure_params[1];
    if (!title_field) { return 1; }

    cstr = (char *)malloc(title_field->size + 1);
    if (!cstr) { return 1; }

    memcpy(cstr, title_field->data, title_field->size);
    cstr[title_field->size] = '\0';

    gtk_window_set_title(GTK_WINDOW(window), cstr);

    free(cstr);
    return 0;
}

/* Widget sizing */
int
CBL_OC_GTK_WIDGET_SET_SIZE_REQUEST(void *widget, int x, int y)
{
    gtk_widget_set_size_request(GTK_WIDGET(widget), x, y);
    return 0;
}

/* Set border width */
int
CBL_OC_GTK_CONTAINER_SET_BORDER_WIDTH(void *window, int pixels)
{
    gtk_container_set_border_width(GTK_CONTAINER(window), pixels);
    return 0;
}

/* New vertical box */
GtkWidget*
CBL_OC_GTK_VBOX_NEW(int homogeneous, int spacing)
{
    return gtk_vbox_new((gboolean)homogeneous, (gint)spacing);
}

/* New horizontal box */
GtkWidget*
CBL_OC_GTK_HBOX_NEW(int homogeneous, int spacing)
{
    return gtk_hbox_new((gboolean)homogeneous, (gint)spacing);
}

/* packing boxes */
int
CBL_OC_GTK_BOX_PACK_START(void *gcont, void *gobj, int expand,
                          int fill, int padding)
{
    gtk_box_pack_start(GTK_BOX(gcont), gobj, (gboolean)expand,
                       (gboolean)fill, (guint)padding);
    return 0;
}

/* menus */
GtkWidget*
CBL_OC_GTK_MENU_BAR_NEW()
{
    return gtk_menu_bar_new();
}

GtkWidget*
CBL_OC_GTK_MENU_NEW()
{
    return gtk_menu_new();
}

GtkWidget*
CBL_OC_GTK_MENU_ITEM_NEW_WITH_LABEL(char *label)
{
    cob_module *module;
    cob_field  *title_field;
    char       *cstr;
    GtkWidget  *item;

    /* Error conditions simply return, doing nothing */
    if (cob_get_global_ptr()->cob_call_params < 1) { return NULL; }

    module = cob_get_global_ptr()->cob_current_module;
    if (module == NULL) {
        //cob_runtime_error("No module!");
        cob_stop_run(1);
    }

    title_field = module->cob_procedure_params[0];
    if (!title_field) { return NULL; }

    cstr = (char *)malloc(title_field->size + 1);
    if (!cstr) { return NULL; }

    memcpy(cstr, title_field->data, title_field->size);
    cstr[title_field->size] = '\0';

    item = gtk_menu_item_new_with_label(cstr);
    gtk_widget_set_tooltip_text(item, (gchar *)cstr);

    free(cstr);

    return item;
}

int
CBL_OC_GTK_MENU_ITEM_SET_SUBMENU(void *item, void *menu)
{
    gtk_menu_item_set_submenu(GTK_MENU_ITEM(item), menu);
    return 0;
}

int
CBL_OC_GTK_MENU_SHELL_APPEND(void *menu, void *item)
{
    gtk_menu_shell_append(GTK_MENU_SHELL(menu), item);
    return 0;
}

/* New button */
GtkWidget*
CBL_OC_GTK_BUTTON_NEW_WITH_LABEL(char *label)
{
    GtkWidget *button;
    button = gtk_button_new_with_label(label);
    if (button) {
        gtk_widget_set_tooltip_text(button, (gchar *)label);
    }
    return button;
}

/* New text entry */
GtkWidget*
CBL_OC_GTK_ENTRY_NEW() {
    return gtk_entry_new();
}

/* Set text in entry */
int
CBL_OC_GTK_ENTRY_SET_TEXT(void *entry, char *text)
{
    gtk_entry_set_text(GTK_ENTRY(entry), text);
    return 0;
}

/* Get the text in an entry */
int
CBL_OC_GTK_ENTRY_GET_TEXT(void *entry, char *text)
{
    cob_module *module;
    cob_field  *text_field;
    size_t     text_length;

    module = cob_get_global_ptr()->cob_current_module;
    text_field = module->cob_procedure_params[1];

    const gchar *entry_text;
    entry_text = gtk_entry_get_text(GTK_ENTRY(entry));
    text_length = entry_text ? strlen(entry_text) : 0;
    text_length = (text_length > text_field->size) ? text_field->size : text_length;

    memset(text_field->data, ' ', text_field->size);
    memcpy(text_field->data, entry_text, text_length);
    return (int)text_length;
}


/* connect event to callback */
int
CBL_OC_G_SIGNAL_CONNECT(int *gobj, char *sgn, void (cb)(void *, void *), void *parm)
{
    g_signal_connect(G_OBJECT(gobj), sgn, G_CALLBACK(cb), parm);
    return 0;
}

/* add object to container */
int
CBL_OC_GTK_CONTAINER_ADD(void *window, void *gobj)
{
    gtk_container_add(GTK_CONTAINER(window), gobj);
    return 0;
}

/* tell gtk that object is now ready */
int
CBL_OC_GTK_WIDGET_SHOW(void *gobj)
{
    gtk_widget_show(gobj);
    return 0;
}

/* tell gtk to ready all the wdigets */
int
CBL_OC_GTK_WIDGET_SHOW_ALL(void *window)
{
    gtk_widget_show_all(window);
    return 0;
}

/* Some dialogs */
GtkWidget*
CBL_OC_GTK_FILE_SELECTION_NEW(char *title)
{
    return gtk_file_selection_new(title);
}

/* the event loop */
int
CBL_OC_GTK_MAIN()
{
    gtk_main();
    return 0;
}

/* stop the gui */
int
CBL_OC_GTK_MAIN_QUIT()
{
    gtk_main_quit();
    return 0;
}

# ocgtk Make
.RECIPEPREFIX = >

gtkhello: gtkhello.cob ocgtk.c
> gcc -c -fPIC `pkg-config --cflags gtk+-2.0` ocgtk.c
> cobc -x -debug `pkg-config --libs gtk+-2.0` gtkhello.cob ocgtk.o

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      03-Dec-2008
      *> Purpose:   Hello from GTK+
      *> Requires:  libgtk2.0, libgtk2.0-dev, gtk2.0, pkg-config
      *> Tectonics:
      *>     cobc -c `pkg-config --cflags gtk+-2.0` ocgtk.c
      *>     cobc -x `pkg-config --libs gtk+-2.0` gtkhello.cob ocgtk.o
      *> ***************************************************************
       identification division.
       program-id. gtkhello.

       data division.

       working-storage section.
       01 result               usage binary-long.
       01 gtk-window           usage pointer.
       01 gtk-box              usage pointer.
       01 gtk-hello            usage pointer.
       01 gtk-textentry        usage pointer.
       01 gtk-goodbye          usage pointer.

       01 callback             usage procedure-pointer.
       01 params               usage pointer.

      *> **************************************************************
       procedure division.

      *> Initialize GTK
       CALL "CBL_OC_GTK_INIT_CHECK" returning result END-CALL
    >>D   display "init: " result end-display

      *> Create a toplevel window
       CALL "CBL_OC_GTK_WINDOW_NEW" returning gtk-window END-CALL
    >>D   display "win: " gtk-window end-display

      *> Set the titlebar - using cob_field now **HERE**
       CALL "CBL_OC_GTK_WINDOW_SET_TITLE"
               using by value gtk-window
                   by reference "GnuCOBOL GTK+"
       END-CALL
    >>D   display "title: " gtk-window end-display

      *> Set the border width
       CALL "CBL_OC_GTK_CONTAINER_SET_BORDER_WIDTH"
               using by value gtk-window
                   by value 5
       END-CALL
    >>D   display "border: " gtk-window end-display

      *> connect a window destroy, quit main loop handler
       set callback to entry "CBL_OC_destroy"
       CALL "CBL_OC_G_SIGNAL_CONNECT"
               using by value gtk-window
                   by reference "delete_event" & x"00"
                   by value callback
                   by value params
       END-CALL

      *> Create a vertically packed box
       CALL "CBL_OC_GTK_VBOX_NEW"
               using by value 0
                   by value 5
               returning gtk-box
       END-CALL
    >>D   display "box: " gtk-box end-display

      *> Add the box to the window
       CALL "CBL_OC_GTK_CONTAINER_ADD"
               using by value gtk-window
                   by value gtk-box
       END-CALL

      *> Create the hello button
       CALL "CBL_OC_GTK_BUTTON_NEW_WITH_LABEL"
           using by reference "Hello from GnuCOBOL and GTK" & x"00"
           returning gtk-hello
       END-CALL
    >>D   display "button: " gtk-hello end-display

      *> Connect the hello button to the hello code
       set callback to entry "CBL_OC_hello"
       CALL "CBL_OC_G_SIGNAL_CONNECT"
               using by value gtk-hello
                   by reference "clicked" & x"00"
                   by value callback
                   by value params
       END-CALL

      *> Pack the button into the box, top to bottom
       CALL "CBL_OC_GTK_BOX_PACK_START"
               using by value gtk-box
                   by value gtk-hello
                   by value 1
                   by value 1
                   by value 0
       END-CALL

      *> button is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-hello
       END-CALL

      *> Add a text entry field
       CALL "CBL_OC_GTK_ENTRY_NEW"
               returning gtk-textentry
       END-CALL

      *> Connect code to the text entry, passing the entry widget
       set callback to entry "CBL_OC_activate"
       CALL "CBL_OC_G_SIGNAL_CONNECT"
               using by value gtk-textentry
                   by reference "activate" & x"00"
                   by value callback
                   by value gtk-textentry
       END-CALL

      *> Pack the text field into the box, top to bottom
       CALL "CBL_OC_GTK_BOX_PACK_START"
               using by value gtk-box
                   by value gtk-textentry
                   by value 1
                   by value 1
                   by value 0
       END-CALL

      *> text field is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-textentry
       END-CALL

      *> Create the bye button
       CALL "CBL_OC_GTK_BUTTON_NEW_WITH_LABEL"
           using by reference "Goodbye from GnuCOBOL and GTK" & x"00"
               returning gtk-goodbye
       END-CALL
    >>D   display "button: " gtk-goodbye end-display

      *> Connect the bye button to the bye code
       set callback to entry "CBL_OC_destroy"
       CALL "CBL_OC_G_SIGNAL_CONNECT"
               using by value gtk-goodbye
                   by reference "clicked" & x"00"
                   by value callback
                   by value params
       END-CALL

      *> Pack the button into the box, under hello
       CALL "CBL_OC_GTK_BOX_PACK_START"
               using by value gtk-box
                   by value gtk-goodbye
                   by value 1
                   by value 1
                   by value 0
       END-CALL
    >>D   display "pack: " gtk-box end-display

      *> button is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-goodbye
       END-CALL

      *> box is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-box
       END-CALL

      *> window is ready to show
       CALL "CBL_OC_GTK_WIDGET_SHOW"
               using by value gtk-window
       END-CALL

      *> Start up the event loop, control returned when GTK main exits
       CALL "CBL_OC_GTK_MAIN" END-CALL

      *> Something terminated the GTK main loop, sys-close or bye or
       display "ending..." end-display

       goback.
       end program gtkhello.
      *> **************************************************************

      *> **** window shutdown callback ********************************
       identification division.
       program-id. CBL_OC_destroy.
       data division.
       linkage section.
       01 gtk-window           usage pointer.
       01 gtk-data             usage pointer.

       procedure division using by value gtk-window by value gtk-data.

       CALL "CBL_OC_GTK_MAIN_QUIT" END-CALL

       goback.
       end program CBL_OC_destroy.
      *> **************************************************************


      *> **** hello button click callback *****************************
       identification division.
       program-id. CBL_OC_hello.
       data division.
       linkage section.
       01 gtk-window           usage pointer.
       01 gtk-data             usage pointer.

       procedure division using by value gtk-window by value gtk-data.
       display
               "Hello from GTK in GnuCOBOL at "
               function current-date
       end-display

       goback.
       end program CBL_OC_hello.

      *> **** text entry activation callback **************************
      *> This procedure called from GTK on enter key pressed in entry
       identification division.
       program-id. CBL_OC_activate.
       data division.
       working-storage section.
       01 textfield            pic x(32).
       01 textlen              usage binary-long.

       linkage section.
       01 gtk-window           usage pointer.
       01 gtk-data             usage pointer.

       procedure division using by value gtk-window by value gtk-data.

       CALL "CBL_OC_GTK_ENTRY_GET_TEXT"
               using by value gtk-data
                   textfield
               returning textlen
       END-CALL
       display "text: " textfield ", " textlen end-display

       goback.
       end program CBL_OC_activate.

/* GnuCOBOL GTK+ 2.0 wrapper */
/* Tectonics: cobc -c `pkg-config --cflags gtk+-2.0` ocgtk.c */

#include <memory.h>
#include <stdlib.h>
#include <libcob.h>

#include <gtk/gtk.h>
#include <glib.h>

#include "ocgtk.h"

/* Initialize the toolkit, abends if not possible */
int
CBL_OC_GTK_INIT(int argc, char *argv[])
{
    gtk_init(&argc, &argv);
    return 0;
}

/* Initialize the toolkit, return false if not possible */
/* Need pointers to argc and argv here */
int
CBL_OC_GTK_INIT_CHECK()
{
    gboolean gres = gtk_init_check(0, NULL);
    return (gres == TRUE) ? 0 : -1;
}

/* Create new window */
GtkWidget*
CBL_OC_GTK_WINDOW_NEW()
{
    return gtk_window_new(GTK_WINDOW_TOPLEVEL);
}

/* set the title */
int
CBL_OC_GTK_WINDOW_SET_TITLE(void *window, char *title)
{
    struct cob_module *module;
    cob_field  *title_field;
    char       *cstr;

    /* Error conditions simply return, doing nothing */
    if (cob_get_global_ptr()->cob_call_params < 2) { return 1; }

    module = cob_get_global_ptr()->cob_current_module;
    if (module == NULL) {
        //cob_runtime_error("No module!");
        //cob_stop_run(1);
        return 1;
    }

    title_field = module->cob_procedure_parameters[1];
    if (!title_field) { return 1; }

    cstr = (char *)malloc(title_field->size + 1);
    if (!cstr) { return 1; }

    memcpy(cstr, title_field->data, title_field->size);
    cstr[title_field->size] = '\0';

    gtk_window_set_title(GTK_WINDOW(window), cstr);

    free(cstr);
    return 0;
}

/* Widget sizing */
int
CBL_OC_GTK_WIDGET_SET_SIZE_REQUEST(void *widget, int x, int y)
{
    gtk_widget_set_size_request(GTK_WIDGET(widget), x, y);
    return 0;
}

/* Set border width */
int
CBL_OC_GTK_CONTAINER_SET_BORDER_WIDTH(void *window, int pixels)
{
    gtk_container_set_border_width(GTK_CONTAINER(window), pixels);
    return 0;
}

/* New vertical box */
GtkWidget*
CBL_OC_GTK_VBOX_NEW(int homogeneous, int spacing)
{
    return gtk_vbox_new((gboolean)homogeneous, (gint)spacing);
}

/* New horizontal box */
GtkWidget*
CBL_OC_GTK_HBOX_NEW(int homogeneous, int spacing)
{
    return gtk_hbox_new((gboolean)homogeneous, (gint)spacing);
}

/* packing boxes */
int
CBL_OC_GTK_BOX_PACK_START(void *gcont, void *gobj, int expand,
                          int fill, int padding)
{
    gtk_box_pack_start(GTK_BOX(gcont), gobj, (gboolean)expand,
                       (gboolean)fill, (guint)padding);
    return 0;
}

/* menus */
GtkWidget*
CBL_OC_GTK_MENU_BAR_NEW()
{
    return gtk_menu_bar_new();
}

GtkWidget*
CBL_OC_GTK_MENU_NEW()
{
    return gtk_menu_new();
}

GtkWidget*
CBL_OC_GTK_MENU_ITEM_NEW_WITH_LABEL(char *label)
{
    struct cob_module *module;
    cob_field  *title_field;
    char       *cstr;
    GtkWidget  *item;

    /* Error conditions simply return, doing nothing */
    if (cob_get_global_ptr()->cob_call_params < 1) { return NULL; }

    module = cob_get_global_ptr()->cob_current_module;
    if (module == NULL) {
        //cob_runtime_error("No module!");
        cob_stop_run(1);
    }

    title_field = module->cob_procedure_parameters[0];
    if (!title_field) { return NULL; }

    cstr = (char *)malloc(title_field->size + 1);
    if (!cstr) { return NULL; }

    memcpy(cstr, title_field->data, title_field->size);
    cstr[title_field->size] = '\0';

    item = gtk_menu_item_new_with_label(cstr);
    gtk_widget_set_tooltip_text(item, (gchar *)cstr);

    free(cstr);

    return item;
}

int
CBL_OC_GTK_MENU_ITEM_SET_SUBMENU(void *item, void *menu)
{
    gtk_menu_item_set_submenu(GTK_MENU_ITEM(item), menu);
    return 0;
}

int
CBL_OC_GTK_MENU_SHELL_APPEND(void *menu, void *item)
{
    gtk_menu_shell_append(GTK_MENU_SHELL(menu), item);
    return 0;
}

/* New button */
GtkWidget*
CBL_OC_GTK_BUTTON_NEW_WITH_LABEL(char *label)
{
    GtkWidget *button;
    button = gtk_button_new_with_label(label);
    if (button) {
        gtk_widget_set_tooltip_text(button, (gchar *)label);
    }
    return button;
}

/* New text entry */
GtkWidget*
CBL_OC_GTK_ENTRY_NEW() {
    return gtk_entry_new();
}

/* Set text in entry */
int
CBL_OC_GTK_ENTRY_SET_TEXT(void *entry, char *text)
{
    gtk_entry_set_text(GTK_ENTRY(entry), text);
    return 0;
}

/* Get the text in an entry */
int
CBL_OC_GTK_ENTRY_GET_TEXT(void *entry, char *text)
{
    struct cob_module *module;
    cob_field  *text_field;
    size_t     text_length;

    module = cob_get_global_ptr()->cob_current_module;
    text_field = module->cob_procedure_parameters[1];

    const gchar *entry_text;
    entry_text = gtk_entry_get_text(GTK_ENTRY(entry));
    text_length = entry_text ? strlen(entry_text) : 0;
    text_length = (text_length > text_field->size) ? text_field->size : text_length;

    memset(text_field->data, ' ', text_field->size);
    memcpy(text_field->data, entry_text, text_length);
    return (int)text_length;
}


/* connect event to callback */
int
CBL_OC_G_SIGNAL_CONNECT(int *gobj, char *sgn, void (cb)(void *, void *), void *parm)
{
    g_signal_connect(G_OBJECT(gobj), sgn, G_CALLBACK(cb), parm);
    return 0;
}

/* add object to container */
int
CBL_OC_GTK_CONTAINER_ADD(void *window, void *gobj)
{
    gtk_container_add(GTK_CONTAINER(window), gobj);
    return 0;
}

/* tell gtk that object is now ready */
int
CBL_OC_GTK_WIDGET_SHOW(void *gobj)
{
    gtk_widget_show(gobj);
    return 0;
}

/* tell gtk to ready all the wdigets */
int
CBL_OC_GTK_WIDGET_SHOW_ALL(void *window)
{
    gtk_widget_show_all(window);
    return 0;
}

/* Some dialogs */
GtkWidget*
CBL_OC_GTK_FILE_SELECTION_NEW(char *title)
{
    return gtk_file_selection_new(title);
}

/* the event loop */
int
CBL_OC_GTK_MAIN()
{
    gtk_main();
    return 0;
}

/* stop the gui */
int
CBL_OC_GTK_MAIN_QUIT()
{
    gtk_main_quit();
    return 0;
}

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> *******************************************************
cob   *> Author:    Brian Tiffin
  web *> Date:      20130308, 20140814
      *> Purpose:   A cobweb GTK+ example
GTK+  *> License:   GPL 3.0 or greater
      *> Tectonics: cobc -x cobweb-gui.cob cobweb-gtk.so
      *> ********************************************************
       identification division.
       program-id. cobweb-gui.

       environment division.
       configuration section.
       repository.
           function new-window
           function new-box
           function new-label
           function new-entry
           function new-button
           function gtk-go

           function all intrinsic.

       data division.
       working-storage section.
       01 GTK-ORIENTATION-HORIZONTAL constant as 0.
       01 GTK-ORIENTATION-VERTICAL   constant as 1.

       01 result               pic x(8).

       01 gtk-window           usage pointer.

       01 gtk-box              usage pointer.
       01 orientation          usage binary-long.

       01 gtk-label            usage pointer.
       01 gtk-entry            usage pointer.
       01 gtk-button           usage pointer.

      *> ***************************************************************
       procedure division.

       move new-window() to gtk-window
       move GTK-ORIENTATION-HORIZONTAL to orientation
       move new-box(gtk-window, orientation) to gtk-box
       move new-label(gtk-box, z"Goodbye") to gtk-label
       move new-entry(gtk-box, "cobweb-entry-activated") to gtk-entry
       move new-button(gtk-box, z"you're leaving me today",
                       "cobweb-button-clicked") to gtk-button
       move gtk-go(gtk-window) to result

       goback.
       end program cobweb-gui.

move gtk-go(new-button(new-box(new-window(), 0),
            z"Hello", "cobweb-button-clicked"))
  to return-code

int
CBL_OC_GTKHTML (char *html_string)
{
        GtkWidget *app;
        GtkWidget *html;
        GtkWidget *scrolled_window;

        char *fakeargv[2] = {"happybday", ""};

        /* prepare our environment, we need gnome and gconf */
        gnome_init ("Example_1", "1.0", 1, fakeargv);
        gconf_init (1, fakeargv);

        /* create GtkHTML widget */
        html = gtk_html_new ();
        gtk_signal_connect (GTK_OBJECT (html), "url_requested",
                            GTK_SIGNAL_FUNC (url_requested), NULL);
        gtk_signal_connect (GTK_OBJECT (html), "object_requested",
                            GTK_SIGNAL_FUNC (object_requested), NULL);

        gtk_html_load_from_string (GTK_HTML (html), html_string, -1);

        /* create GNOME app and put GtkHTML in scrolled window in it */
        app = gnome_app_new ("Example_1", "Happy Birthday OpenCOBOL");

        scrolled_window = gtk_scrolled_window_new (NULL, NULL);
        gtk_scrolled_window_set_policy (GTK_SCROLLED_WINDOW (scrolled_window),
                                        GTK_POLICY_AUTOMATIC, GTK_POLICY_AUTOMATIC);
        gtk_container_add (GTK_CONTAINER (scrolled_window), html);

        gnome_app_set_contents (GNOME_APP (app), scrolled_window);
        gtk_window_set_default_size (GTK_WINDOW (app), 320, 100);
        gtk_widget_show_all (app);

        /* run the main loop */
        gtk_main ();

        return 0;
}
/**/

*> ***************************************************************
*> Author:    Brian Tiffin
*> Date:      27-Dec-2008
*> Purpose:   Happy Birthday GnuCOBOL
*> Tectonics:
*> gcc -c `pkg-config --cflags --libs libgnome-2.0 libgnomeui-2.0
*>       gtk+-2.0 libgtkhtml-3.14` hellogtk.c
*> cobc -lgtkhtml-3.14 -lgnomeui-2 -lSM -lICE -lglade-2.0
*>      -lbonoboui-2 -lgnomevfs-2 -lgnomecanvas-2 -lgnome-2 -lpopt
*>      -lbonobo-2 -lbonobo-activation -lORBit-2 -lart_lgpl_2
*>      -lgconf-2 -lgthread-2.0 -lrt -lgtk-x11-2.0 -lxml2
*>      -lgdk-x11-2.0 -latk-1.0 -lgdk_pixbuf-2.0 -lm
*>      -lpangocairo-1.0 -lpango-1.0 -lcairo -lgobject-2.0
*>      -lgmodule-2.0 -ldl -lglib-2.0 -x ocgtkhtml.cob hellogtk.o
*> ***************************************************************
 identification division.
 program-id. ocgtkhtml.

 data division.
 working-storage section.
 01 result               usage binary-long.
 01 html-string          pic x(512) value
     "<B><FONT COLOR=Blue>Happy Birthday 1.0</FONT> " &
     "<FONT COLOR=LimeGreen>OpenCOBOL 1.0!!</FONT></B><br />" &
     "<div align='center'><a href='http://opencobol.org'>" &
     "opencobol</a> <img src='file:smiley.png' />" &
     "<br /><br /><OBJECT CLASSID=close_button>Closebutton" &
     "</OBJECT></div>" & x"00".

*> ***************************************************************
 procedure division.

 call "CBL_OC_GTKHTML" using
     by reference html-string
     returning result
 end-call

 goback.
 end program ocgtkhtml.

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/gtk-function
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20170115  Modified: 2017-01-16/10:18-0500
      *> LICENSE
      *>   Dedicated to the public domain
      *> PURPOSE
      *>   gtk-server user defined function
      *> TECTONICS
      *>   cobc -x -g -debug gtkprogram.cob gtk-function.cob
      *> ***************************************************************
       identification division.
       program-id. gtk-function.
       author. Brian Tiffin.
       date-written. 2017-01-15/19:41-0500.
       date-modified. 2017-01-16/10:18-0500.
       date-compiled.
       installation. Requires GTK3+ and GTK-server.
       remarks. All GTK commands passed as text.
       security. Someone might whack on the fifo pipe while running.

       environment division.
       configuration section.

       repository.
           function gtk
           function all intrinsic.

       data division.
       working-storage section.
       01 cli                  pic x(80).
          88 helping           values "help", "-h", "--help".
      *> ********

       procedure division.
       accept cli from command-line
       if helping then
           display "GTK-server module"
       end-if
       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program gtk-function.
      *> ***************************************************************

      *> ***************************************************************
      *>****F* gtk-function/gtk
       identification division.
       function-id. gtk.

       environment division.
       configuration section.

       repository.
           function all intrinsic.

       input-output section.
       file-control.
           select optional gtk-fifo
           assign to gtk-fifo-name
           status is gtk-fifo-status
           organization is line sequential.

       data division.
       file section.
       fd gtk-fifo record varying depending on gtk-io-len.
       01 gtk-io               pic x(256).

       working-storage section.
       01 have-server          pic 9 value 0.

       01 gtk-server-options.
       >>IF DEBUG DEFINED
          05 filler            value "-debug".
       >>ELSE
          05 filler            value " ".
       >>END-IF

       01 tmp-name-size        constant as 4096.
       01 tmp-buffer           pic x(tmp-name-size).
       01 gtk-fifo-name-len    pic 9(4) value tmp-name-size.
       01 gtk-fifo-name.
          05 filler            pic x occurs 0 to tmp-name-size times
                               depending on gtk-fifo-name-len.
       01 gtk-fifo-status      pic xx.
          88 fifo-ok           value "00".
       01 gtk-io-len           pic 999.

       01 empty-string pic x value " ".

       linkage section.
       01 api pic x any length.
       01 op2 pic x any length.
       01 op3 pic x any length.
       01 op4 pic x any length.
       01 op5 pic x any length.
       01 op6 pic x any length.
       01 op7 pic x any length.
       01 op8 pic x any length.
       01 op9 pic x any length.
       01 server-result pic x(16).

       procedure division
           using api op2 op3 op4 op5 op6 op7 op8 op9
           returning server-result.

      *> one time init of the server
       if have-server equal zero then
           *> get a temporary file name
           call static "cob_temp_name" using
               tmp-buffer ".tmp"
               returning omitted
           end-call
           string tmp-buffer delimited by low-value into gtk-fifo-name
           move length(trim(gtk-fifo-name)) to gtk-fifo-name-len

           *> start up gtk-server with a pipe interface
           call "SYSTEM" USING
               concatenate("gtk-server -fifo=" gtk-fifo-name
                           space gtk-server-options " -detach")
           move 1 to have-server
       end-if

      *> ease of use, just fill in empty parameters with a space
       if op9 omitted then
           set address of op9 to address of empty-string
       end-if
       if op8 omitted then
           set address of op8 to address of empty-string
       end-if
       if op7 omitted then
           set address of op7 to address of empty-string
       end-if
       if op6 omitted then
           set address of op6 to address of empty-string
       end-if
       if op5 omitted then
           set address of op5 to address of empty-string
       end-if
       if op4 omitted then
           set address of op4 to address of empty-string
       end-if
       if op3 omitted then
           set address of op3 to address of empty-string
       end-if
       if op2 omitted then
           set address of op2 to address of empty-string
       end-if

       move concatenate(api space op2 space op3 space op4 space
                        op5 space op6 space op7 space op8 space
                        op9) to gtk-io
       perform gtk-routine
       move gtk-io to server-result

       >>IF DEBUG DEFINED
       display "api: " api " :" trim(server-result) ":"
       >>END-IF

      *> if this is a shutdown, reset the init flag
       if api equal "gtk_server_exit" and server-result = "ok" then
           move 0 to have-server
       end-if
       goback.
      *> ***************************************************************

      *> ********
       gtk-routine.
      *> write to pipe
       open output gtk-fifo
       if not fifo-ok then
           display "problem with " gtk-fifo-name upon syserr
           exit paragraph
       end-if

       move 256 to gtk-io-len
       write gtk-io
       if not fifo-ok then
           display "problem writing " trim(gtk-io) " to " gtk-fifo-name
              upon syserr
           exit  paragraph
       end-if

       close gtk-fifo
       if not fifo-ok then
           display "problem closing " gtk-fifo-name upon syserr
           exit
       end-if

      *> read from pipe
       open input gtk-fifo
       if not fifo-ok then
           display "problem with " gtk-fifo-name upon syserr
           exit paragraph
       end-if

       read gtk-fifo
       if not fifo-ok then
           display "problem reading " gtk-fifo-name upon syserr
           exit paragraph
       end-if

       close gtk-fifo
       if not fifo-ok then
           display "problem closing " gtk-fifo-name upon syserr
           exit paragraph
       end-if

       >>IF DEBUG DEFINED
       display "gtk-io: " gtk-io-len " :" trim(gtk-io) ":"
       >>END-IF
       .

       :EXCEPTION-HANDLERS:

       end function gtk.
      *> ***************************************************************
      *>****
>>ELSE
!doc-marker!
============
gtk-function
============

.. contents::

Introduction
------------

GTK-server scripting.  Commands (API calls) are sent to a text file
and results from GTK-server are read from the same FIFO text file.
Events are passed back as strings, as are all the handles and status
messages.

http://www.gtk-server.org/

Tectonics
---------

::

    prompt$ cobc -x gtkprogram.cob gtk-function.cob
    or
    prompt$ TMPDIR=. cobc -x -DDEBUG gtkprogram.cob gtk-function.cob

Usage
-----

::

    prompt$ ./gtk-function help

Source
------

.. include::  gtk-function.cob
   :code: cobolfree
>>END-IF

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/gtkdemo-fifo
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20170115  Modified: 2017-01-16/09:15-0500
      *> LICENSE
      *>   Dedicated to the public domain
      *> PURPOSE
      *>   gtkdemo-fifo GTK-server demo
      *> TECTONICS
      *>   cobc -x -g -debug gtkdemo-fifo.cob gtk-function.cob
      *> ***************************************************************
       identification division.
       program-id. gtkdemo-fifo.
       author. Brian Tiffin.
       date-written. 2017-01-15/19:41-0500.
       date-modified. 2017-01-16/09:15-0500.
       date-compiled.
       installation. Requires GTK3+ and GTK-server.
       remarks. All GTK commands passed as text.
       security. Someone might whack on the fifo pipe while running.

       environment division.
       configuration section.

       repository.
           function gtk
           function all intrinsic.

       data division.
       working-storage section.
       01 gtk-result           pic x(16).
       01 gtk-window           pic x(16).
       01 gtk-table            pic x(16).
       01 gtk-label            pic x(16).
       01 gtk-info             pic x(16).
       01 gtk-quit             pic x(16).
       01 gtk-dialog           pic x(16).
       01 event                pic x(16).

      *> ***************************************************************
       procedure division.
      *> send commands (API calls as text) to set up the GUI
       move gtk("gtk_init NULL NULL") to gtk-result
       move gtk("gtk_window_new 0") to gtk-window
       move gtk("gtk_window_set_title" gtk-window "'GTK-server Demo'")
         to gtk-result
       move gtk("gtk_window_set_default_size" gtk-window "400 200")
         to gtk-result
       move gtk("gtk_window_set_position" gtk-window "1") to gtk-result

      *> add a table with a label and some buttons
       move gtk("gtk_table_new 10 10 1") to gtk-table
       move gtk("gtk_container_add", gtk-window, gtk-table)
         to gtk-result

      *> A label
       move gtk("gtk_label_new 'Hello, from GTK-server'") to gtk-label
       move gtk("gtk_table_attach_defaults" gtk-table gtk-label
                "1 4 1 4") to gtk-result

      *> a button to invoke a dialog box (see main loop evaluate)
       move gtk("gtk_button_new_with_label" "'Info'") to gtk-info
       move gtk("gtk_table_attach_defaults" gtk-table gtk-info
                "1 4 6 9") to gtk-result

      *> a quit button
       move gtk("gtk_button_new_with_label 'Quit'") to gtk-quit
       move gtk("gtk_table_attach_defaults" gtk-table gtk-quit
                "6 9 6 9") to gtk-result

      *> a macro built into gtk-server.cfg
       move gtk('u_dialog Information "' & "'u_dialog macro'" &
                '" 200 130') to gtk-dialog

      *> show the gui
       move gtk("gtk_widget_show_all", gtk-window, "1") to gtk-result

      *> main loop
       move "0" to event
       perform until event = gtk-window or gtk-quit
           move gtk("gtk_server_callback WAIT") to event

       >>IF DEBUG DEFINED
           display "event :" trim(event) ":"
       >>END-IF

           evaluate event
               when gtk-dialog
                   move gtk("gtk_widget_hide", gtk-dialog) to gtk-result
               when "exit"
                   move gtk("gtk_widget_hide", gtk-dialog) to gtk-result
               when gtk-info
                   move gtk("gtk_widget_show_all", gtk-dialog)
                     to gtk-result
           end-evaluate
       end-perform

      *> shut down the server
       move gtk("gtk_server_exit") to gtk-result

       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program gtkdemo-fifo.
      *> ***************************************************************
      *>****
>>ELSE
!doc-marker!
============
gtkdemo-fifo
============

.. contents::

Introduction
------------

Demonstrate GTK-server scripting.  Commands (API calls) are sent to a
text file and results from GTK-server are read from the same FIFO file.
Events are passed back as strings, as are all the handles.

http://www.gtk-server.org/

Tectonics
---------

::

    prompt$ cobc -x gtkdemo-fifo.cob gtk-function.cob

Usage
-----

::

    prompt$ ./gtkdemo-fifo

Source
------

.. include::  gtkdemo-fifo.cob
   :code: cobolfree

.. include::  gtk-function.cob
   :code: cobolfree
>>END-IF

prompt$ cobc -DDEBUG -xj gktdemo-fifo.cob gtk-function.cob

gcsort sort fields"(1,5,CH,A,11,4,CH,A)"
             use inputfile record f,391 org sq give outputfile org sq

This will sort the file "inputfile", a fixed length file (391 byte each
record, organization sequential), and create a file "outputfile" sorted
(which is of the same type). The sort fields are :
(start, length, type, direction)
=> start=1
=> length=5
=> type = character (you can sort on comp3 fields, but ocsort don't handle it)
=> direction = ascending (or descending)
It's like an order by.
The omit/include condition allow to remove record from the file (ex if
character number 5 of this record is 'F', omit the record). You can use and,
or, greater than...)

prompt$ cd trunk/tools/ocsort
prompt$ make

# Create a sample data set, 118 byte records
prompt$ base64 /dev/urandom | head -n 100 | dd conv=block cbs=118 >samp1.txt

# test out the sort, keys 1-5 character, ascending and 11-14, ascending char
prompt$ time ./gcsort sort fields"(1,5,CH,A,11,4,CH,A)" \
             use samp1.txt record f,118 org sq give samp1.sor org sq
INPUT FILE :
        samp1.txt FIXED (118,118) SQ
OUTPUT FILE :
        samp1.sor FIXED (0,0) SQ
SORT FIELDS : (1,5,CH,A,11,4,CH,A)
Sort OK

real    0m0.003s
user    0m0.000s
sys     0m0.003s

prompt$ wc samp1.sor
0   100 11800 samp1.sor

prompt$ cobc -x verify.cob
prompt$ ./verify
done

...
118000000 bytes (118 MB) copied, 3.44348 s, 34.3 MB/s
prompt$ rm samp1.sor
prompt$ time ./gcsort sort fields"(1,5,CH,A,11,4,CH,A)" \
             use samp1.txt record f,118 org sq give samp1.sor org sq
INPUT FILE :
        samp1.txt FIXED (118,118) SQ
OUTPUT FILE :
        samp1.sor FIXED (0,0) SQ
SORT FIELDS : (1,5,CH,A,11,4,CH,A)
Sort OK

real    0m4.119s
user    0m1.413s
sys     0m2.700s

prompt$ time ./verify
done

real    0m0.541s
user    0m0.091s
sys     0m0.449s

prompt$ time wc samp1.sor
        0   1000000 118000000 samp1.sor

real    0m1.465s
user    0m1.427s
sys     0m0.036s

GCSORT*> ***************************************************************
       identification division.
       program-id. verify.

       environment division.
       input-output section.
       file-control.
           select inputfile
           assign to "samp1.sor"
           organization is sequential.

       data division.
       file section.
       fd inputfile.
           01 indata pic x(118).

       working-storage section.
       01 lastrec pic x(118).

      *> ***************************************************************
       procedure division.
       open input inputfile
       move low-values to lastrec

       perform forever
           read inputfile
               at end
                   close inputfile
                   display "done" end-display
                   stop run
               not at end
                   if lastrec(1:5) greater than indata(1:5)
                       display
                           "out of ascending order,   primary: "
                           lastrec(1:5) ", " indata(1:32)
                           upon syserr
                       end-display
                   end-if
                   if (lastrec(1:5) equal indata(1:5)) and
                      (lastrec(11:4) greater than indata(11:4))
                       display
                           "out of ascending order, secondary: "
                           lastrec(11:4) ", " indata(1:32)
                           upon syserr
                       end-display
                   end-if
                   move indata to lastrec
           end-read
       end-perform

       goback.
       end program verify.

USE        "USE clause"
GIVE       "GIVE clause"
SORT       "SORT clause"
MERGE      "MERGE clause"
FIELDS     "FIELDS instruction"
RECORD     "RECORD instruction"
ORG        "ORG instruction"
OUTREC     "OUTREC clause"
SUM        "SUM clause"
INCLUDE    "INCLUDE clause"
OMIT       "OMIT clause"
COND       "COND clause"
NONE       "NONE clause"
AND        "AND clause"
OR         "OR clause"

To execute a stand-alone Mainframe SORT, you have a file with a specific
DDName (SYSIN) and containing "Control Cards". Although sometime the DDName
varies, this is typical of a Mainframe Utility.

Micro Focus mimic SORT and other Mainframe utilities to enable
"off-the-Mainframe" development for a Mainframe target.

SORT Control Cards must start with at least one blank.

Generally, things go like this:

 INCLUDE/OMIT FIELDS=(...)
 INREC ....
 SORT/MERGE FIELDS=(...)
 SUM FIELDS=(...)
 OUTREC ...
 OUTFIL ... (which can be multiple)

INCLUDE/OMIT allows selection of the records required for the processing.

INREC allows processing before the SORT/MERGE/COPY takes place.

SORT/MERGE/COPY does what it says on the tin.

SUM does totalling of specified fields, or drops records entirely, for
duplicate keys.

OUTREC allows processing after the SORT/MERGE/COPY has taken place.

OUTFIL allows for final processing, one OUTFIL per file if multiples are
required, with futher selection possible (INCLUDE=/OMIT=).

To get an overview, locate the DFSORT: Getting Started manual with your
favourite search engine. To see the full power, have a look at the DFSORT:
Application Programming Guide.

On the Mainframe, a COBOL SORT or MERGE statement uses the installed SORT
product (usually DFSORT or SyncSORT).

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      17-Nov-2008
      *> Purpose:   Display Easter Day for any given year, 1580 - 2050
      *> Tectonics: cobc -x easter.cob
      *>            ./easter [year]
      *> ***************************************************************
       identification division.
       program-id. easter.

       data division.
       working-storage section.
       01 a    picture 9(8) usage comp-x.
       01 b    picture 9(8).
       01 c    picture 9(8).
       01 d    picture 9(8).
       01 z    picture 9(8).  *> Why z? COBOL has pi for pi and e for e
       01 f    picture 9(8).
       01 g    picture 9(8).
       01 h    picture 9(8).
       01 i    picture 9(8).
       01 j    picture 9(8).
       01 year picture 9(4).
       01 mo   picture 9(2).
       01 da   picture 9(2).
       01 args picture x(80).

      *> ***************************************************************
       procedure division.

       accept args from command-line end-accept
       if args not equal spaces
           move args to year
       else
           display "Year: " with no advancing end-display
           accept year end-accept
       end-if

       compute a = function mod(year 19)           end-compute
       divide  year by 100 giving b remainder c    end-divide
       divide  b    by   4 giving d remainder z    end-divide
       compute f = (b + 8) / 25                    end-compute
       compute g = (b - f + 1) / 3                 end-compute
       compute h = (19 * a) + b - d - g + 15       end-compute
       compute h = function mod(h 30)              end-compute
       divide  c    by   4 giving i remainder j    end-divide
       compute c = (z + i) * 2 + 32 - h - j        end-compute
       compute c = function mod(c 7)               end-compute
       compute b = (a + (11 * h) + (22 * c)) / 451 end-compute
       compute a = h + c - (7 * b) + 114           end-compute
       compute da = function mod(a 31) + 1         end-compute
       divide  a    by  31 giving mo               end-divide

       display  "yyyy/mm/dd: " year "/" mo "/" da  end-display
       goback.
       end program easter.

      *> ***************************************************************
      *> Snagged from a REBOL script, easter-day.r by Didier Cadieu
      *> http://www.rebol.org/view-script.r?script=easter-day.r
      *>
      *> easter-day: func [
      *>     {Compute the easter date for the wanted year.}
      *>     year [integer!] {Year for whitch you want the easter date}
      *>     /local a b c d z f g h i k
      *> ] [
      *>     a: year // 19
      *>     b: to integer! year / 100
      *>     c: year // 100
      *>     d: to integer! b / 4
      *>     z: b // 4
      *>     f: to integer! b + 8 / 25
      *>     g: to integer! b - f + 1 / 3
      *>     h: 19 * a + b - d - g + 15 // 30
      *>     i: to integer! c / 4
      *>     k: c // 4
      *>     c: z + i * 2 + 32 - h - k // 7
      *>     b: to integer! a + (11 * h) + (22 * c) / 451
      *>     a: h + c - (7 * b) + 114
      *>     to date! reduce [
      *>         a // 31 + 1
      *>         to integer! a / 31
      *>         year
      *>     ]
      *> ]

$ cobc -x easter.cob
$ ./easter 2011
yyyy/mm/dd: 2011/04/24
$ ./easter
Year: 2010
yyyy/mm/dd: 2010/04/04

It would have been slightly more appropriate to share a COBOL source that
tells when its Christmas. Let my give it a try (Proc. div. only):

 accept args from command-line end-accept
 if args not equal spaces
 move args to year
 else
 display "Year: " with no advancing end-display
 accept year end-accept
 end-if

 move 12 to mo
 move 25 to da
 display "yyyy/mm/dd: " year "/" mo "/" da end-display
 goback.
 end program xmas.

 Hmmmmm. Lot less variables needed so it seems ... should clean up working
 storage, but since I copy/pasted this and don't want (are forbidden) to fix
 what ain't broke I will not change that piece of the program. For sure NOBODY
 will ever need to fix this program anymore so NOBODY will be sitting for hours
 wondering what a is for. Or b. or c. Or ... whatever, I am a programmer and
 thus I am lazy by definition, and I want to turn around that logic so doing no
 clean-up proves my professionalism and eases my job. After all if all
 programmers are lazy, I must be a very good one and

 ...
 (5 minutes contemplating on fuzzy lazy logic)
 ...

 Happy Xmas

000100 IDENTIFICATION DIVISION.                                         00010025
000200 PROGRAM-ID. RCEASTER.                                            00020025
000300 AUTHOR. PAUL CHANDLER, MARCH 2013.                               00030025
000400********************************************************          00040025
000500*** THIS PROGRAM CALCULATES THE DATE OF EASTER FOR   ***          00050025
000600*** YEARS IN THE GREGORIAN CALENDAR. IT'S A PORT OF  ***          00060025
000700*** THE DONALD KNUTH ALGORITHM PUBLISHED IN VOLUME 1 ***          00070025
000800*** OF "THE ART OF COMPUTER PROGRAMMING".            ***          00080025
000900***                                                  ***          00090025
001000********************************************************          00100025
001100 ENVIRONMENT DIVISION.                                            00110025
001200 DATA DIVISION.                                                   00120025
001300 FILE SECTION.                                                    00130025
001400 WORKING-STORAGE SECTION.                                         00140025
001500 77  ACCEPT-YEAR            PIC 9(08).                            00150025
001600 01  WORKING-FIELDS     COMP.                                     00160025
001700     05 TGT-YEAR            PIC S9(08).                           00170025
001800     05 GOLDEN-NUMBER       PIC S9(08).                           00180025
001900     05 TGT-CENTURY         PIC S9(08).                           00190025
002000     05 LEAP-YEAR-CRCTN     PIC S9(08).                           00200025
002100     05 MOON-SYNC-CRCTN     PIC S9(08).                           00210025
002200     05 FIRST-SUNDAY        PIC S9(08).                           00220025
002300     05 EPACT               PIC S9(08).                           00230025
002400     05 FULL-MOON           PIC S9(08).                           00240025
002500     05 EASTER-SUNDAY       PIC S9(08).                           00250025
002600 01  DISPLAY-FIELDS.                                              00260025
002700     05 TGT-YEAR-DSP        PIC Z(08)-.                           00270025
002800     05 EASTER-MONTH        PIC X(06).                            00280025
002900     05 EASTER-SUNDAY-DSP   PIC Z(08)-.                           00290025
003000 PROCEDURE DIVISION.                                              00300025
003100     ACCEPT ACCEPT-YEAR.                                          00310025
003200     MOVE ACCEPT-YEAR TO TGT-YEAR TGT-YEAR-DSP                    00320025
003300     IF TGT-YEAR < 1583                                           00330025
003400        DISPLAY "YEAR MUST BE 1583 OR GREATER"                    00340025
003500        STOP RUN                                                  00350025
003600     ELSE                                                         00360025
003700        DISPLAY "EASTER DATE FOR:" TGT-YEAR-DSP                   00370025
003800     END-IF                                                       00380025
003900     COMPUTE GOLDEN-NUMBER   = FUNCTION MOD(TGT-YEAR, 19) + 1     00390025
004000     COMPUTE TGT-CENTURY     = (TGT-YEAR / 100) + 1               00400025
004100     COMPUTE LEAP-YEAR-CRCTN = (3 * TGT-CENTURY / 4) - 12         00410025
004200     COMPUTE MOON-SYNC-CRCTN = ((8 * TGT-CENTURY + 5) / 25) - 5   00420025
004300     COMPUTE FIRST-SUNDAY    =                                    00430025
004400         (5 * TGT-YEAR / 4)- LEAP-YEAR-CRCTN - 10                 00440025
004500******************************************************            00450025
004600*     TO MAKE THE EPACT CALCULATION MORE READABLE,   *            00460025
004700* THE COMPUTATION WILL BE DONE IN STAGES.            *            00470025
004800******************************************************            00480025
004900*                                                                 00490025
005000* STAGE #1: GET THE RAW NUMBER.....                  *            00500025
005100*                                                                 00510025
005200     COMPUTE EPACT =                                              00520025
005300         (11 * GOLDEN-NUMBER)                                     00530025
005400        + 20                                                      00540025
005500        + MOON-SYNC-CRCTN                                         00550025
005600        - LEAP-YEAR-CRCTN                                         00560025
005700*                                                                 00570025
005800* STAGE #2: GET THE MOD 30 VALUE...                  *            00580025
005900*                                                                 00590025
006000     COMPUTE EPACT = FUNCTION MOD(EPACT, 30)                      00600025
006100*                                                                 00610025
006200* STAGE #3: TO ENSURE THAT EPACT IS A POSITIVE NBR,  *            00620025
006300*           ADD 30 AND MOD 30 AGAIN.                 *            00630025
006400*                                                                 00640025
006500     ADD 30 TO EPACT                                              00650025
006600     COMPUTE EPACT = FUNCTION MOD(EPACT, 30)                      00660025
006700*                                                                 00670025
006800* ADJUST FOR YEARS WHEN ORTHODOX DIFFERS             *            00680025
006900*                                                                 00690025
007000     IF (EPACT = 25 AND GOLDEN-NUMBER > 11)                       00700025
007100     OR (EPACT = 24)                                              00710025
007200        ADD 1 TO EPACT                                            00720025
007300     END-IF                                                       00730025
007400*                                                                 00740025
007500* NEXT 2 STATEMENTS FIND FIRST FULL MOON AFTER MAR.21*            00750025
007600*                                                                 00760025
007700     SUBTRACT EPACT FROM 44 GIVING FULL-MOON                      00770025
007800     IF  EPACT  > 23                                              00780025
007900         ADD 30 TO FULL-MOON                                      00790025
008000     END-IF                                                       00800025
008100*                                                                 00810025
008200* ADVANCE SUNDAY TO THE FIRST SUNDAY AFTER FULL MOON *            00820025
008300*                                                                 00830025
008400     COMPUTE EASTER-SUNDAY =                                      00840025
008500         FULL-MOON                                                00850025
008600       + 7                                                        00860025
008700       - (FUNCTION MOD((FIRST-SUNDAY + FULL-MOON), 7))            00870025
008800*                                                                 00880025
008900* IF EASTER-SUNDAY > 31, EASTER IS IN APRIL - MOVE THE            00890025
009000* MONTH TO APRIL AND SUBTRACT 31 FROM EASTER-SUNDAY.              00900025
009100* OTHERWISE EASTER IS IN MARCH, USE THE DAY AS IS.                00910025
009200*                                                                 00920025
009300     IF  EASTER-SUNDAY > 31                                       00930025
009400         MOVE 'APRIL' TO EASTER-MONTH                             00940025
009500         SUBTRACT 31 FROM EASTER-SUNDAY                           00950025
009600     ELSE                                                         00960025
009700         MOVE 'MARCH' TO EASTER-MONTH                             00970025
009800     END-IF                                                       00980025
009900     MOVE EASTER-SUNDAY TO EASTER-SUNDAY-DSP                      00990025
010000     DISPLAY EASTER-MONTH EASTER-SUNDAY-DSP                       01000025
010100     STOP RUN.                                                    01010025

$ ./rceaster
2013
EASTER DATE FOR:    2013
MARCH       31

daniel b.:
... in a moment of madness ... about 20 years later ... compiles and runs
on your OpenCobol 1.1 ... now that I found out that I need gmp not to segfault
...  ;-)

Brian Tiffin:
daniel; Can I steal this for the OpenCOBOL FAQ?
Am I correct in assuming you wrote this Computus solution some 20 years
ago, and this is a recent port to OpenCOBOL?

daniel b.:
@Brian Tiffin ? daniel; Can I steal this for the OpenCOBOL FAQ?

Sure

@Brian Tiffin ? Am I correct in assuming you wrote this Computus solution
some 20 years ago, and this is a recent port to OpenCOBOL?

No, I just looked at the table of the Meeus? book citation, in the wiki and
wrote it from scratch. 20 years ago is the last time I touched COBOL, but
since I used it for 15 years before, it kind like sticks, LOL.

GCobol*
      * 2/15/2013 Adapted by daniel for OpenCobol 1.1 Compiler, from:
      * https://en.wikipedia.org/wiki/Computus#cite_note-otheralgs-45
      *
      * From Wikipedia: "Anonymous Gregorian algorithm:
      * 'A New York correspondent' submitted this algorithm for determining
      *   the Gregorian Easter to the journal Nature in 1876.[39][40]
      * It has been reprinted many times, in 1877 by Samuel Butcher in
      * The Ecclesiastical Calendar,[41]:225 in 1922 by H. Spencer Jones in
      * General Astronomy,[42] in 1977 by the Journal of the
      * British Astronomical Association,[43] in 1977 by The Old Farmer's Almanac,
      * in 1988 by Peter Duffett-Smith in Practical Astronomy with your Calculator,
      * and in 1991 by Jean Meeus in Astronomical Algorithms.[44]
      * Because of the Meeus' book citation, that is also called
      * 'Meeus/Jones/Butcher' algorithm"
      *
      * 2/16/2013 Added command line passing parameter, method from
      * Brian Tiffin example, hoping he won't mind ;-)
      * http://opencobol.add1tocobol.com/#when-is-easter
      *
      * 2/18/2013 Added rejection of years before 1582, on Paul Chandler
      * suggestion thank you, I missed that part
      *
      * 2/19/2013 Attempt to make more readable, reduced useless operations,
      * needs more work.
      * Changed names of some variables, based on:
      * http://www.linuxtopia.org/online_books/programming_books/
      *        python_programming/python_ch38.html
      *
      * 2/20/2013 Added comments on formula, eliminated all compute:
      * http://www.jones0086.freeserve.co.uk/b123sen.htm
      *
      * 2/22/2013 Added writeout to file complete table of easter occurrences,
      * selected using year 0000 as passing parameter
      *
      * 2/25/2013 Tried on windows
      *
       IDENTIFICATION DIVISION.
       PROGRAM-ID. easter.
      *
       ENVIRONMENT DIVISION.
      *
       CONFIGURATION SECTION.
      *
       INPUT-OUTPUT SECTION.
      *
       FILE-CONTROL.
       SELECT OPTIONAL OUT-FILE ASSIGN TO "easter-out.txt"
           ORGANIZATION IS LINE SEQUENTIAL
           ACCESS MODE IS SEQUENTIAL.
      *
       I-O-CONTROL.
      *
       DATA DIVISION.
      *
       FILE SECTION.
      *
       FD  OUT-FILE
           LABEL RECORDS ARE STANDARD.
           01  OUT-RECORD.
           05  RECORD-DATA PIC X(11) VALUE SPACES.
           05  RECORD-END-RET PIC X VALUE X'0d'.
           05  RECORD-END-LF PIC X VALUE X'0a'.
      *
       WORKING-STORAGE SECTION.
      *
       77  SELECTED-YEAR PIC 9999 VALUE ZERO.
       77  X PIC 9999 VALUE ZERO.
       77  Y PIC 9999 VALUE ZERO.
       77  METONIC-GOLDEN-NUMBER PIC 99 VALUE ZERO.
       77  CENTURY PIC 99 VALUE ZERO.
       77  YEAR-IN-CENTURY PIC 99 VALUE ZERO.
       77  LEAP-TEST400 PIC 99 VALUE ZERO.
       77  LEAP-TEST40 PIC 99 VALUE ZERO.
       77  MOON-SYNC1 PIC 99 VALUE ZERO.
       77  MOON-SYNC2 PIC 99 VALUE ZERO.
       77  EPACT PIC 99 VALUE ZERO.
       77  LEAP4 PIC 99 VALUE ZERO.
       77  LEAP4-OFFSET PIC 99 VALUE ZERO.
       77  ADVANCE-TO-SUNDAY PIC 99 VALUE ZERO.
       77  M PIC 99 VALUE ZERO.
       77  COMPUTED-MONTH PIC 99 VALUE ZERO.
       77  COMPUTED-DAY PIC 99 VALUE ZERO.
      *
       01  WS-TABLE VALUE ZEROS.
               03 WS-MONTH PIC XXX
                   OCCURS 12 TIMES.
      *
       77  ARGS PIC X(80) VALUE SPACES.
      *
       77  LOOP-FLAG PIC 9 VALUE ZERO.
      *
       01 WS-OUT-RECORD.
           05 WS-OUT-DAY PIC XX VALUE SPACES.
                 05 FILLER PIC X VALUE "-".
           05 WS-OUT-MONTH PIC XXX VALUE SPACES.
           05 FILLER PIC X VALUE "-".
           05 WS-OUT-YEAR PIC XXXX VALUE SPACES.
      *
       PROCEDURE DIVISION.
      *
       000-WS-TABLE-CTL.
       MOVE "JAN" TO WS-MONTH(1)
       MOVE "FEB" TO WS-MONTH(2)
       MOVE "MAR" TO WS-MONTH(3)
       MOVE "APR" TO WS-MONTH(4)
       MOVE "MAY" TO WS-MONTH(5)
       MOVE "JUN" TO WS-MONTH(6)
       MOVE "JUL" TO WS-MONTH(7)
       MOVE "AUG" TO WS-MONTH(8)
       MOVE "SEP" TO WS-MONTH(9)
       MOVE "OCT" TO WS-MONTH(10)
       MOVE "NOV" TO WS-MONTH(11)
       MOVE "DEC" TO WS-MONTH(12).
      *
       010-ARGS-CTL.
       ACCEPT ARGS FROM COMMAND-LINE.
       IF ARGS EQUAL 0000
           MOVE 1583 TO SELECTED-YEAR
           MOVE 1 TO LOOP-FLAG
           OPEN EXTEND OUT-FILE
           GO TO 105-METONIC-GOLDEN-NUMBER-CTL.
       IF ARGS NOT EQUAL SPACES
           MOVE ARGS TO SELECTED-YEAR
           GO TO 100-CHECK-YEAR-CTL.
       DISPLAY " " END-DISPLAY.
       DISPLAY "Gregorian Easter computation from year 1583 to 9999".
      *
       020-START-CTL.
       DISPLAY "Enter Year (YYYY): " WITH NO ADVANCING END-DISPLAY.
       ACCEPT SELECTED-YEAR FROM CONSOLE.
      *
       100-CHECK-YEAR-CTL.
       IF SELECTED-YEAR IS LESS THAN 1583
           DISPLAY "Invalid year, use year past 1582 " END-DISPLAY
           GO TO 020-START-CTL.
      *
       105-METONIC-GOLDEN-NUMBER-CTL.
       DIVIDE SELECTED-YEAR BY 19 GIVING X
           REMAINDER METONIC-GOLDEN-NUMBER
           ON SIZE ERROR GO TO 020-START-CTL END-DIVIDE.
      *
       110-CENTURY-CTL.
       DIVIDE SELECTED-YEAR BY 100 GIVING CENTURY
           REMAINDER YEAR-IN-CENTURY
           ON SIZE ERROR GO TO 020-START-CTL END-DIVIDE.
      *
       120-LEAP-TEST-CTL.
       DIVIDE CENTURY BY 4 GIVING LEAP-TEST400 REMAINDER LEAP-TEST40
           ON SIZE ERROR GO TO 020-START-CTL END-DIVIDE.
      *
       125-MOON-SYNC1-CTL.
      * formula MOON-SYNC1 = (CENTURY + 8) / 25
       ADD 8 TO CENTURY GIVING X
       DIVIDE X BY 25 GIVING MOON-SYNC1
           ON SIZE ERROR GO TO 020-START-CTL.
      *
       130-MOON-SYNC2-CTL.
       COMPUTE MOON-SYNC2 = (CENTURY - MOON-SYNC1 + 1) / 3
           ON SIZE ERROR GO TO 020-START-CTL.
      *
       135-EPACT-SYNC-CTL.
      * formula EPACT = ((19 * METHONIC-GOLDEN-NUMBER) + CENTURY -
      *                   LEAP-TEST400  - MOON-SYNC2 + 15) mod 30
       MULTIPLY 19 BY METONIC-GOLDEN-NUMBER GIVING X
       ADD CENTURY TO X GIVING X
       SUBTRACT LEAP-TEST400 FROM X GIVING X
       SUBTRACT MOON-SYNC2 FROM X GIVING X
       ADD 15 TO X GIVING X
       DIVIDE X BY 30 GIVING X REMAINDER EPACT
           ON SIZE ERROR GO TO 020-START-CTL END-DIVIDE.
      *
       140-LEAP4-CTL.
       DIVIDE YEAR-IN-CENTURY BY 4 GIVING LEAP4
           REMAINDER LEAP4-OFFSET
           ON SIZE ERROR GO TO 020-START-CTL END-DIVIDE.
      *
       150-ADVANCE-TO-SUNDAY-CTL.
      * formula ADVANCE-TO-SUNDAY = (32 + 2 * (LEAP-TEST40 + 2) + 2 * (YEAR-IN-CENTURY
      * / 4) - EPACT - K) mod 7
       MULTIPLY 2 BY LEAP-TEST40 GIVING X
       ADD 32 TO X GIVING X
       MULTIPLY 2 BY LEAP4 GIVING Y
       ADD Y TO X GIVING X
       SUBTRACT EPACT FROM X GIVING X
       SUBTRACT LEAP4-OFFSET FROM X GIVING X
       DIVIDE X BY 7 GIVING X REMAINDER ADVANCE-TO-SUNDAY
           ON SIZE ERROR GO TO 020-START-CTL END-DIVIDE.
      *
       160-M-CTL.
      * formula M = (METONIC-GOLDEN-NUMBER + (11 * EPACT)
      *             + (22 * ADVANCE-TO-SUNDAY)) / 451
       MULTIPLY 11 BY EPACT GIVING X
       ADD METONIC-GOLDEN-NUMBER TO X GIVING X
       MULTIPLY 22 BY ADVANCE-TO-SUNDAY GIVING Y
       ADD Y TO X GIVING X
       DIVIDE X BY 451 GIVING M
           ON SIZE ERROR GO TO 020-START-CTL END-DIVIDE.
      *
       200-COMPUTED-MONTH-CTL.
      * formula COMPUTED-MONTH = ((EPACT + ADVANCE-TO-SUNDAY - (7 * M) + 114) / 31)
       MULTIPLY 7 BY M GIVING X
       ADD EPACT TO ADVANCE-TO-SUNDAY GIVING Y
       SUBTRACT X FROM Y GIVING Y
       ADD 114 TO Y GIVING X
       DIVIDE X BY 31 GIVING COMPUTED-MONTH
           ON SIZE ERROR GO TO 020-START-CTL END-DIVIDE.
      *
       300-COMPUTED-DAY-CTL.
      * formula COMPUTED-DAY = ((EPACT + ADVANCE-TO-SUNDAY - (7 * M) + 114) mod 31) + 1
       MULTIPLY 7 BY M GIVING X
       ADD EPACT TO ADVANCE-TO-SUNDAY GIVING Y
       SUBTRACT X FROM Y GIVING Y
       ADD 114 TO Y GIVING X
       DIVIDE X BY 31 GIVING X REMAINDER Y
       ADD 1 TO Y GIVING COMPUTED-DAY
           ON SIZE ERROR GO TO 020-START-CTL.
      *
       400-PRINT-TABLE-CTL.
       MOVE COMPUTED-DAY TO WS-OUT-DAY.
       MOVE WS-MONTH(COMPUTED-MONTH) TO WS-OUT-MONTH.
       MOVE SELECTED-YEAR TO WS-OUT-YEAR.
       MOVE WS-OUT-RECORD TO OUT-RECORD.
       IF LOOP-FLAG EQUAL TO 1 WRITE OUT-RECORD.
       IF SELECTED-YEAR EQUAL TO 9999 AND LOOP-FLAG EQUAL TO 1
           CLOSE OUT-FILE.
      *
       500-LOOP-CTL.
       IF SELECTED-YEAR EQUAL TO 9999 AND LOOP-FLAG EQUAL TO 1
         MOVE 0 TO LOOP-FLAG
         GO TO 700-STOP.
       IF LOOP-FLAG EQUAL TO 1
           ADD 1 TO SELECTED-YEAR GIVING SELECTED-YEAR
           GO TO 105-METONIC-GOLDEN-NUMBER-CTL.
      *
       600-EXIT.
      *
       DISPLAY " " END-DISPLAY.
       DISPLAY "Easter day for year " SELECTED-YEAR ": " END-DISPLAY.
       DISPLAY COMPUTED-DAY "-" WS-MONTH(COMPUTED-MONTH) "-"
       SELECTED-YEAR END-DISPLAY.
       DISPLAY " " END-DISPLAY.
      *
       700-STOP.
       STOP RUN.
      *

$ ./dbeaster

Gregorian Easter computation from year 1583 to 9999
Enter Year (YYYY): 2013

Easter day for year 2013:
31-MAR-2013

$ ./dbeaster

Gregorian Easter computation from year 1583 to 9999
Enter Year (YYYY): 3013

Easter day for year 3013:
18-APR-3013

$ cobc --list-reserved | tail -n+3 | cut -f1 >~/.vim/ocreserved.lis

:set ignorecase
:set infercase
:set complete=k~/.vim/ocreserved.lis

:set virtualedit=all

" Auto load COBOL template
autocmd BufNewFile  *.cob      0r ~/lang/cobol/headfix.cob

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      30-Dec-2008
      *> Purpose:   Textualize a webpage
      *> Tectonics: cobc -x w3mcaller.cob
      *>            ./w3mcaller opencobol.org
      *> ***************************************************************
       identification division.
       program-id. w3mcaller.

       data division.
       working-storage section.
       01 args         pic x(256).
       01 command      pic x(256).
       01 result       usage binary-long.

      *> ***************************************************************
       procedure division.
       accept args from command-line.

       string
           "w3m -dump " delimited by size
           function trim(args) delimited by size
           into command
       end-string
       call "SYSTEM" using command returning result end-call

       goback.
       end program w3mcaller.

$ ./w3mcaller opencobol.org

[logo]
[arrow] HOME    [arrow] NEWS    [arrow] FORUM   [arrow] D       [arrow] LINK
                                                OWNLOAD
OpenCOBOL - an open-source COBOL compiler
                [arrow] Welcome to the OpenCOBOL Website!
                OpenCOBOL is an open-source COBOL compiler.
[arrow] Main    OpenCOBOL implements a substantial part of the
Menu            COBOL 85 and COBOL 2002 standards, as well as
Home News Wiki  many extensions of the existent COBOL
Forum Downloads compilers.
Links                                                           [arrow] Search
*               OpenCOBOL translates COBOL into C and compiles  [              ]
[arrow]         the translated code using the native C          [Search]
Download        compiler. You can build your COBOL programs on  Advanced Search
                various platforms, including Unix/Linux, Mac OS [arrow] Login
  • OpenCOBOL   X, and Microsoft Windows.                       Username:
    1.0                                                         [            ]
  • OpenCOBOL   The compiler is licensed under GNU General      Password:
    1.1         Public License.                                 [            ]
    pre-release The run-time library is licensed under GNU      [User Login]
                Lesser General Public License.                  Lost Password?
*
[arrow]         [arrow] Recent News                             Register now!
Documentation                                                   [arrow] Recent
                  • OpenCOBOL 1.0 released (2007/12/27)         Links
  • FAQ
  • Features    [arrow] Recent Topics                             • J&C
  • Install       Forum       Topic      Replies Views     Last     Migrations
    Guide                                                  Post     (2008/12/10)
  • User Manual           using gui                     2010/2/   • COBOL Data
                OpenCOBOL interface        18     733  28 10:12     Correlation
*                                                      federico     a... (2006/9
[arrow]                   SET index-var                 2010/2/     /21)
Development     OpenCOBOL TO DISP-FIELD     2     99   27 18:53   • COBOL User
                                                        wmklein     Groups :
  • SourceForge           implementation                2010/2/     COBU...
  • Mailing     OpenCOBOL of ocsort         7     308   27 5:15     (2006/1/17)
    List                                                btiffin   • The Kasten
  • Tasks                 select fname                  2010/2/     COBOL Page
                OpenCOBOL clause,           9     426  26 14:26     (2005/9/8)
*                         Variable value                   shaj   • Die COBOL
[arrow] Who's             as filename                               Connection
Online                                                  2010/2/     (2005/9/8)
12 user(s) are  OpenCOBOL Benchmarks        5     285  24 23:45   • University
online                                                  btiffin     of Limerick
                                                        2010/2/     (2005/9/8)
Members: 1      OpenCOBOL Default Colour    7     327  21 15:32   • Stefans
Guests: 11                                                  jgt     kleiner
                          OpenCOBOL 1.1                 2010/2/     COBOL Wo...
clemcoll,       OpenCOBOL compiler          8     451  20 21:52     (2005/9/8)
more...                   listing                       btiffin   • COBOL Web
*                         MOVE loops                    2010/2/     Development
[arrow] Powered OpenCOBOL when operands     9     443  20 20:39     (2005/6/8)
by                        are overlaying                  human   • Kobol
  SourceForge             [solved]                                  Kompany
                          0MQ (zeromq),                 2010/2/     (2005/6/8)
     Xoops      OpenCOBOL network           3     223  20 15:12   • CoCoLab
                          messaging and                 btiffin     (2005/6/8)
   Creative               OpenCOBOL
    Commons               Conversion
                          story from                    2010/2/
*               OpenCOBOL MicroFocus to    10     768  20 12:23
                          OC, on SUSE                     simrw
                          11.2
                Visit Forums

        Copyright (C) 2005 The OpenCOBOL Project. All rights reserved.
                   Powered by Xoops2 | PHP | MySQL | Apache
                                   ocean-net

export COB_LIBRARY_PATH=/home/developer/ocnewstuff:/home/developer/ocstuff

prompt$ sudo apt install regina-rexx libregina3 libregina3-dev

prompt$ ./configure --with-rexx --with-vbisam
prompt$ make
prompt$ make check
prompt$ sudo make install
prompt$ sudo ldconfig

       identification division.
       program-id. intrinsic-rexx.
       author. Brian Tiffin.
       date-written. 2017-03-07/03:42-0500.
       date-modified. 2017-03-12/19:24-0400.
       date-compiled.
       installation. Requires a build with --with-rexx and libregina.
       remarks. Rexx source evaluation, ALPHANUMERIC field returned.
       security. An embedded interpretter, use trusted sources.

       REPLACE ==newline== BY ==& x"0a" &==.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 answer pic 9(5).

      *> ***************************************************************
       procedure division.

      *> Hello, with an argument passed to Rexx
       perform 2 times
       display rexx("say 'Hello, REXX';" &
                    " parse arg a1; say arg(); say a1;" &
                    " return 'Hello, COBOL';", "test")
       end-perform
       display space

      *> invalid script data type
       display ":" rexx(1, 2) ":"
       perform soft-exception
       display space

      *> More arguments
       display rexx("say 'Hello, a second time';" &
                    " parse arg a1, a2, a3;" &
                    " say arg() a1 a2 a3;" &
                    " return 'Hello, again';", 1, 2, "abc")
       display space

      *> a little bit of realistic Rexx
       move rexx("delim = ';'" newline
           "parse arg theline" newline
           "do i = 1 by 1 while theline <> '' " newline
           "    parse var theline w.i (delim) theline" newline 
           "end" newline
           "w.0 = i - 1" newline
           "do i = 1 to w.0" newline
           "    say w.i" newline
           "end" newline
           "return w.0",
           "this;is;a;test;of;parsing;to;a;stem;variable")
         to answer
       display answer " components"
       display space

      *> Some math
       move rexx("return arg(1) * 6", 7) to answer
       display "Ultimate answer: " answer
       display space
  
      *> One way of sharing value between scripts is to use the stack
       display rexx(
           "a = 'abc'" newline
           "push a" newline
           "return a")
       display rexx(
           "pull a" newline
           "return a || 'def'")

      *> Some REXX date and string formatting features
       display rexx( 
           "/* get year, month, and day of month */" newline
           "parse value date('Standard') with yr 5 ." newline
           "return right(time( 'Civil'), 8)," newline
           " || center(date('Month'), 38)," newline
           " || substr(yr, 3)'.'right(date('Dayofyear'), 3, '0')")
 
      *> And a system command
       display rexx("address SYSTEM; 'ls *.cob'; return 'Nice'")
       
       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program intrinsic-rexx.
      *> ***************************************************************
      *>****
>>ELSE
!doc-marker!
==============
intrinsic-rexx
==============

.. contents::

Introduction
------------
Embedding Regina Rexx as a GnuCOBOL "intrinsic" function.

Tectonics
---------

::

    prompt$ ./configure --with-rexx
    prompt$ make
    prompt$ make check
    prompt$ sudo make install
    prompt$ sudo ldconfig

    prompt$ cobc -xj intrinsic-rexx.cob

Usage
-----

See http://regina-rexx.sourceforge.net/ for all the details of programming
with Regina Rexx.

Use rexx("script", ["args"...,]) as you would any other GnuCOBOL intrinsic
function (that returns an ALPHANUMERIC field).  For use with computational
COBOL verbs, wrap the REXX() function in NUMVAL().

.. codeblock:: cobolfree

    MOVE rexx("return arg(1) * arg(2)", 6, 7) TO answer
    COMPUTE answer = numval(rexx("return 42")) 
    

Source
------

.. include::  intrinsic-rexx.cob
   :code: cobolfree
>>END-IF

prompt$ cobc -xj intrinsic-rexx.cob

Hello, REXX
1
test
Hello, COBOL
Hello, REXX
1
test
Hello, COBOL

::

--Exception Report--
Time of exception:   2017031904160677-0400
Module:              intrinsic-rexx
Module-path:         /home/btiffin/wip/writing/gcfaq/listings/intrinsic-rexx
Module-source:       intrinsic-rexx.cob
Exception-file:      00
Exception-status:    EC-ARGUMENT-FUNCTION
Exception-location:
Exception-statement:

Hello, a second time
3 1 2 abc
Hello, again

this
is
a
test
of
parsing
to
a
stem
variable
00010 components

Ultimate answer: 00042

abc
ABCdef
  4:16am                March                 17.078
intrinsic-rexx.cob  libcobjna.cob  telco5.cob telco.cob
Nice

01 taxrate pic 999v999.

compute taxrate = numval(rexx(
    "address REXX; 'fetchrates.rexx' ARG(1)",
    "Ontario")) / 100.0

OPTIONS AREXX_BIFS

OPTIONS NOREGINA_BIFS

      *> curl-it.cob, fetch a web resource and push lines to REXX stack
       identification division.
       program-id. curl-it.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       REPLACE ==newline== BY ==& x'0a' &==.

       data division.
       working-storage section.
       01 url              pic x(80).
       01 rexx-rc          pic 9(9).
       01 rexx-data        pic x(2048).

       procedure division.
       curl-it-main.

       accept url from command-line
       if url equal spaces then
           move "example.edu" to url
       end-if
       move rexx-unrestricted(
           "/* argument from parameter list */"                 newline
           "url = ARG(1)"                                       newline
           "/* use curl to read the url and queue results */"   newline
           "address system" &
           " 'curl -s -L' url with output stem data."           newline
           "do i = 1 to data.0"                                 newline
           "    queue data.i"                                   newline
           "end"                                                newline
           "push data.0; return data.0", trim(url))
         to rexx-rc
       display "<!- " rexx-rc " lines read from " trim(url) " ->"

      *> We already have rexx-rc with the item count
      *> Demonstrate nesting intrinsics to show the item count again 
       display trim(rexx("pull data.0; return '<!-' data.0 '->'"))

      *> Now we have a FIFO queue of data lines
      *> Skip some and show some

      *> pull will wait for data from stdin if there is no queue
       perform varying tally from 1 by 1 until tally > 40 or rexx-rc
           move rexx(
               "if queued() > 0 then"                           newline
               "    pull dataline"                              newline
               "else"                                           newline
               "    dataline = 'queue empty'"                   newline
               "return dataline")
             to rexx-data
       end-perform

       perform varying tally from tally by 1 until tally > rexx-rc
           move rexx(
               "if queued() > 0 then"                           newline
               "    pull dataline"                              newline
               "else"                                           newline
               "    dataline = 'queue empty'"                   newline
               "return dataline")
             to rexx-data
           display trim(rexx-data)
       end-perform
 
       goback.
       end program curl-it.

prompt$ cobc -xj curl-it.cob
<!- 000000046 lines read from example.edu ->
<!- 46 ->
<P>THIS DOMAIN IS FOR USE IN ILLUSTRATIVE EXAMPLES IN DOCUMENTS. YOU MAY USE THIS
DOMAIN IN LITERATURE WITHOUT PRIOR COORDINATION OR ASKING FOR PERMISSION.</P>
<P><A HREF="HTTPS://WWW.IANA.ORG/DOMAINS/EXAMPLE">MORE INFORMATION...</A></P>
</DIV>
</BODY>
</HTML>

      *>
      *> REXX character translation, only return characters in arg 2
      *> Tectonics: cobc -xj only.cob
      *>
       identification division.
       program-id. only.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       REPLACE ==newline== BY ==& x'0a' &==.

       data division.
       working-storage section.
      *> translate only the given characters, effectively a filter
       01 rexx-only.
          05 value "only: return space(translate(arg(1),," &
                   "translate(xrange(),,arg(2))),0)"       newline
                   "return only(arg(1), arg(2))".
     
       procedure division.
       only-main.
      *> only digits
       display rexx(rexx-only,
                    "1997-01-01 was a great day", "0123456789")

      *> only vowels
       display rexx(rexx-only,
                    "1997-01-01 was a great day", "aeiouy")
       goback.
       end program only.

prompt$ cobc -xj only.cob
19970101
aaeaay

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/oorexx
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20151021  Modified:  2015-10-26/07:36-0400
      *> LICENSE
      *>   Copyright 2015 Free Software Foundation, Inc.
      *>   GNU Lesser General Public License, LGPL, 3.1 (or greater)
      *>   No warranty, expressed or implied
      *> PURPOSE
      *>   Embed Open Object Rexx scripting.
      *> TECTONICS
      *>   cobc -m gnucobol-rexx.cob -g -debug $(oorexx-config --libs)
      *> ***************************************************************
       identification division.
       program-id. gnucobol-rexx.
       author. Brian Tiffin.
       date-compiled. Displayed with --version.
       date-written. 2015-10-26/07:36-0400.
       installation. Copy gnucobol-rexx.so to library path.
       remarks.  Add Open Object Rexx to the mix.
       security. This embeds an interpreter, trusted source is implied.

       environment division.
       configuration section.
       source-computer. Ford.
       object-computer. Arthur.

       special-names.
       symbolic answer is 42
               hashtag is 36.

       repository.
           function rexx
           function all intrinsic.

       input-output section.
       file-control.
       i-o-control.

       data division.
       file section.

       working-storage section.

      *> Define some internal Rexx limits.  Change as needed.
       REPLACE ==:REXX-ARG-LIMIT:==     BY ==32==
               ==:REXX-ARG-SIZE:==      BY ==256==
               ==:REXX-CLI-SIZE:==      BY ==8192==
               ==:REXX-PROGNAME-SIZE:== BY ==128==
               ==:REXX-ENVNAME-SIZE:==  BY ==32==
               ==:REXX-EXITNAME-SIZE:== BY ==64==
               ==:REXX-RESULT-SIZE:==   BY ==32768==
       .

      *> cobcrun module testing options
       01 cli-option           pic x(9).
          88 helping           values "--help", "help", "-h".
          88 versioning        values "--version", "version", "-v".
          88 sourcing          values "--source", "source", "repo".
          88 shelling          values "--shell", "shell".
          88 demoing           values "--demo", "demo", "test", "check".

       01 built-on             pic xxxx/xx/xxBxx/xx/xxBxxxxxxx.

      *> ooRexx testing shell
       01 rexx-line            pic x(132).
          88 quitting          values "q", "quit", "exit".

      *> default script for testing instore, from callrexx2.c sample
       01 instore-script       pic x(426) value
           "call time 'Reset';" &
           "object1 = .example~new;" &
           "object2 = .example~new;" &
           "object3 = .example~new;" &
           "a.1 = object1~start('REPEAT', 4 , 'Object 1 running');" &
           "say a.1~result;" &
           "say 'The result method waits till START has completed:';" &
           "a.2 = object2~start('REPEAT', 2, 'Object 2 running');" &
           "a.3 = object3~start('REPEAT', 2, 'Object 3 running');" &
           "say a.2~result;" &
           "say a.3~result;" &
           "say 'main ended';" &
           "say 'Elapsed time: ' time('E');" &
           "exit;" &
           "::REQUIRES 'example.rex'".

      *> calling Rexx
       01 rexx-buffer          pic x(:REXX-RESULT-SIZE:).
       01 printf-int           usage binary-long.

      *> the rexx-result-record definition
       COPY 'gnucobol-rexx.cpy' REPLACING ==:PREFIX:== BY ==rexx==.

      *> Rexx calling COBOL
       01 rexx-userdata        pic x(32).

      *> ooRexx supports 32 and 64 bit interfaces
       >>IF P64 IS SET
       01 REXX-SIZE-MOD        constant as 18.
       01 REXX-DISP-MOD        constant as 17.
       >>ELSE
       01 REXX-SIZE-MOD        constant as 8.
       01 REXX-DISP-MOD        constant as 7.
       >>END-IF
       01 rexx-dropauth        pic 9(REXX-SIZE-MOD) comp-5.

       01 rexx-regrc           usage binary-long.
       01 rexx-entry           usage program-pointer.

      *> pretty print the result display
       01 display-length       pic z(REXX-DISP-MOD)9.

       01 underlines pic x(77).

       local-storage section.
       linkage section.
       report section.
       screen section.

      *> ***************************************************************
       procedure division.
       self-test.

       move function when-compiled to built-on
       inspect built-on replacing
           all "/" by ":" after initial space
           all " " by "." after initial space
           all "/" by "-"
         first " " by "/"

       move hashtag to underlines

      *> NOTE: requires rxapi daemon to be running
      *> Register an external GnuCOBOL subprogram
       call "RexxRegisterSubcomDll" using
           by content   z"extcob"
           by content   z"test-cobrexx"
           by content   z"extcommand"
           by reference rexx-userdata
           by value     rexx-dropauth
           returning    rexx-regrc
           on exception
               display "no RexxRegisterSubcomDll linkage" upon syserr
               perform soft-exception
       end-call
       if rexx-regrc not equal zero then
           display "RexxRegister failed, is rxapi daemon running?"
              upon syserr
       end-if

      *> Register a GnuCOBOL internal Rexx subprogram handler
       set rexx-entry to entry "rexxcommand"
       call "RexxRegisterSubcomExe" using
           by content   z"gnucobol"
           by value     rexx-entry
           returning    rexx-regrc
           on exception
               display "no RexxRegisterSubcomExe linkage" upon syserr
               perform soft-exception
       end-call
       if rexx-regrc not equal zero then
           display "RexxRegisterSub failed, is rxapi daemon running?"
              upon syserr
       end-if

      *> Register a function from a DSO
      *>   module test-cobrexx.so, Rexx name cobout, entry rexxternal
       call "RexxRegisterFunctionDll" using
           by content   z"cobout"
           by content   z"test-cobrexx"
           by content   z"rexxternal"
           returning    rexx-regrc
           on exception
               display "no RexxRegisterFunctionDll linkage" upon syserr
               perform soft-exception
       end-call
       if rexx-regrc not equal zero then
           display "RexxRegister failed, is rxapi daemon running?"
              upon syserr
       end-if

      *> Register a GnuCOBOL internal Rexx Call
       set rexx-entry to entry "fromrexx"
       call "RexxRegisterFunctionExe" using
           by content   z"cobol"
           by value     rexx-entry
           returning    rexx-regrc
           on exception
               display "no RexxRegisterFuncExe linkage" upon syserr
               perform soft-exception
       end-call
       if rexx-regrc not equal zero then
           display "RexxRegisterFunc failed, is rxapi daemon running?"
              upon syserr
       end-if

      *> cobcrun testing options
       accept cli-option from command-line
       evaluate true
           when helping
               display "Open Object Rexx from GnuCOBOL"
               display "cobcrun gnucobol-rexx "
                       " [help version source shell] [[demo] args...]"
               display "  default action is to run demo, with args"
               display space
               display "  help or --help will display this help"
               display "  version will display version"
               display "  source  will display the COBOL for repository"
               display "  shell   will start up a small Rexx REPL shell"
               display "  demo or test will run self tests"
               goback
           when versioning
               display "gnucobol-rexx Version: 0.6 " built-on
               goback
           when sourcing
               display "      *> gnucobol-rexx repository"
               display "       repository."
               display "           function rexx"
               display "           function all intrinsic."
               goback
           when shelling
               perform rexx-repl
               goback
       end-evaluate

      *> default action is to run the self-test demo
       display "Invoke Open Object Rexx " with no advancing
       display "with filename, environment, two arguments"
       perform display-underlines

       move rexx(1, "gnucobol.rex", "gnucobol", "abc 123", rexx-buffer)
         to rexx-condition
       perform show-results

       display "Invoke Open Object Rexx " with no advancing
       display "default filename, environment, args from command line"
       perform display-underlines

       initialize rexx-buffer
       move rexx(1, null, null, null, rexx-buffer) to rexx-condition
       perform show-results

       display "Invoke Open Object Rexx " with no advancing
       display "with script, rexx environment, args ignored by script"
       perform display-underlines

       initialize rexx-buffer
       move rexx(0, instore-script, "rexx", null, rexx-buffer)
         to rexx-condition
       perform show-results

       display "Invoke Open Object Rexx " with no advancing
       display "default script, default environment, two arguments"
       display "  script returns ooRexx version, and count of args"
       perform display-underlines

       initialize rexx-buffer
       move rexx(0, null, null, "ok 42", rexx-buffer) to rexx-condition
       perform show-results

       goback.

       show-results.
       move rexx-result-length to display-length
       display space
       display "Status : " rexx-rc ", " rexx-api-code
               ", " rexx-udf-code " Length: " trim(display-length)

      *> If the rexx result buffer was not large enough,
      *>   oorexx allocates a new one, which needs to be freed
       if rexx-result-pointer equal null then
           if rexx-result-length > 0 then
               display "Result :" rexx-buffer(1:rexx-result-length) ":"
           else
               display "Empty result"
           end-if
       else
           display "Address: " rexx-result-pointer with no advancing end-display

           call "printf" using
               by content " :%.*s:" & x"0a00"
               by value   rexx-result-length
               by value   rexx-result-pointer
               on exception
                   display "no printf linkage" upon syserr
                   perform soft-exception
           end-call


           *> This RexxFreeMemory must be called
           *>  if rexx-result-pointer is set
           call "RexxFreeMemory" using
               by value rexx-result-pointer
               on exception
                   display "No RexxFreeMemory linkage" upon syserr
                   perform soft-exception
           end-call
       end-if
       display space
       .

      *> An interactive test interpreter
       rexx-repl.
       display "For testing in the shell:"
       display "  call cobol arg1,arg2; say result"
       display "  address gnucobol; with command; return rc"
       display "  call cobout 1,2,3; return result           **"
       display "  address extcob; command; return rc         **"
       display "     ** If libtest-cobrexx.so is in search path"
       display space
       display "  any Rexx instructions, default address is gnucobol"
       display "  q to quit"

       display space
       display "GnuCOBOL ooRexx test shell: " built-on
       perform forever
           display "ooRexx: " with no advancing
           accept rexx-line on exception set quitting to true end-accept
           if quitting then exit perform end-if

           initialize rexx-buffer
           move rexx(0, rexx-line, "gnucobol", null, rexx-buffer)
             to rexx-condition
           perform show-results
       end-perform
       .

      *> informationals, warnings and abends
       soft-exception.
         display "Module:              " module-id upon syserr
         display "Module path:         " module-path upon syserr
         display "Module source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       display-underlines.
       display underlines
       display space
       .

       end program gnucobol-rexx.
      *> ***************************************************************
      *>****

      *> ***************************************************************
      *>****F* oorexx/rexx
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20151021  Modified:  2015-10-22/13:57-0400
      *> LICENSE
      *>   Copyright 2015 Free Software Foundation, Inc.
      *>   GNU Lesser General Public License, LGPL, 3.1 (or greater)
      *>   No warranty, expressed or implied
      *> PURPOSE
      *>   Call Rexx, as user defined function
      *> TECTONICS
      *>   cobc -m -g -debug gnucobol-rexx.cob $(oorexx-config --libs)
      *>   move function rexx(mode, script, env, args, ws-buf) to rexx-r
      *> ***************************************************************
       identification division.
       function-id. rexx.
       author. Brian Tiffin.
       date-compiled.
       date-written. 2015-10-22/13:57-0400.
       installation.
       remarks.  Add Open Object Rexx to the mix.
       security. This embeds an interpreter, trusted source is implied.

       environment division.
       configuration section.
       special-names.
       repository.
           function all intrinsic.
       input-output section.
       file-control.
       i-o-control.

       data division.
       file section.
       working-storage section.

      *> ooRexx supports 32 and 64 bit interfaces
       >>IF P64 IS SET
       01 REXX-SIZE-MOD   constant as 18.
       >>ELSE
       01 REXX-SIZE-MOD   constant as 8.
       >>END-IF

       01 RXCOMMAND        constant as 0.
       01 RXSUBROUTINE     constant as 1.
       01 RXFUNCTION       constant as 2.

       01 default-rexx     pic x(43) value
          'parse version v; return v || ", " || arg();'.

       01 rexx-all-args    pic x(:REXX-CLI-SIZE:).
       01 cli-arg          pic x(:REXX-ARG-SIZE:).

       local-storage section.
       01 rexx-arg-buffer.
          05 filler            occurs 0 TO :REXX-ARG-LIMIT: times
                               depending on rexx-arg-count.
             10 rexx-ws-arg    pic x(:REXX-ARG-SIZE:).

      *> RexxStart structure
       01 rexx-arg-count       pic 9(REXX-SIZE-MOD) comp-5.
       01 rexx-arguments.
          05 filler            occurs 0 TO :REXX-ARG-LIMIT: times
                               depending on rexx-arg-count.
             10 rexx-arg-len   pic 9(REXX-SIZE-MOD) comp-5.
             10 rexx-arg-ptr   usage pointer.
       01 rexx-program-name    pic x(:REXX-PROGNAME-SIZE:).
       01 rexx-instore.
          05 rexx-in0-len      pic 9(REXX-SIZE-MOD) comp-5.
          05 rexx-in0-ptr      usage pointer value NULL.
          05 rexx-in1-len      pic 9(REXX-SIZE-MOD) comp-5.
          05 rexx-in1-ptr      usage pointer value NULL.
       01 rexx-environment     pic x(:REXX-ENVNAME-SIZE:).
       01 rexx-calltype        usage binary-long.
       01 rexx-exits.          *> Not yet supported
          05 rexx-exitname     pic x(:REXX-EXITNAME-SIZE:).
          05 rexx-exitcode     usage binary-long.
       01 rexx-return-code     usage binary-short.
       01 rexx-result.
          05 rexx-result-len   pic 9(REXX-SIZE-MOD) comp-5.
          05 rexx-result-ptr   usage pointer.
       01 rexx-call-return     usage binary-long.

      *> wordexp fields
       01 we-sub               usage binary-short.
       01 expanded-words       usage pointer.
       01 expand-flags         pic 9(REXX-SIZE-MOD) comp-5.
       01 expanded-structure.
          05 we-wordc          pic 9(REXX-SIZE-MOD) comp-5.
          05 we-wordv          usage pointer.
          05 we-offs           pic 9(REXX-SIZE-MOD) comp-5 value 0.
       01 we-words             based.
          05 filler            occurs 0 to :REXX-ARG-LIMIT: times
                               depending on we-wordc.
             10 we-word        usage pointer.
       01 wordexp-result       usage binary-long.

       linkage section.
       01 rexx-mode            pic 9.
       01 rexx-script          pic x any length.
       01 rexx-address         pic x any length.
       01 rexx-argument-line   pic x any length.
       01 rexx-buffer          pic x any length.
       COPY 'gnucobol-rexx.cpy' REPLACING ==:PREFIX:== BY ==rexx==.

       report section.
       screen section.

      *> ***************************************************************
       procedure division using
           rexx-mode
           rexx-script
           rexx-address
           rexx-argument-line
           rexx-buffer
           returning rexx-condition
       .
       rexx.

      *> mode 0 is script text, otherwise filename
       if rexx-mode equal zero then
           if address of rexx-script equal null then
               set rexx-in0-ptr to address of default-rexx
               move length(default-rexx) to rexx-in0-len
           else
               set rexx-in0-ptr to address of rexx-script
               move length(rexx-script) to rexx-in0-len
           end-if
       else
           if address of rexx-script equal null then
               move z"gnucobol.rex" to rexx-program-name
           else
               move concatenate(trim(rexx-script), x"00")
                 to rexx-program-name
           end-if
       end-if

      *> GnuCOBOL environment
       if address of rexx-address equal null then
           move z"gnucobol" to rexx-environment
       else
           move concatenate(trim(rexx-address), x"00")
             to rexx-environment
       end-if

      *> get arguments from frame, or command line
       if address of rexx-argument-line equal null then
           accept rexx-all-args from command-line
           call "wordexp" using
               by content   concatenate(rexx-all-args, x"00")
               by reference expanded-structure
               by value     expand-flags
               returning    wordexp-result
               on exception
                   display "no wordexp linkage" upon syserr
                   move wordexp-result to rexx-udf-code
                   goback
           end-call
       else
           call "wordexp" using
               by content   concatenate(rexx-argument-line, x"00")
               by reference expanded-structure
               by value     expand-flags
               returning    wordexp-result
               on exception
                   display "no wordexp linkage" upon syserr
                   move wordexp-result to rexx-udf-code
                   goback
           end-call
       end-if

       if wordexp-result > 0 then
           display "Error: wordexp " wordexp-result upon syserr
           if address of rexx-argument-line equal null then
               display "Given: " trim(rexx-all-args) upon syserr
           else
               display "Given: " trim(rexx-argument-line) upon syserr
           end-if
       end-if

      *> spin the we-words into the Rexx argument array
       set address of we-words to we-wordv
       move we-wordc to rexx-arg-count

       move 1 to we-sub
       perform until we-sub > we-wordc
           if we-sub > :REXX-ARG-LIMIT: then
               display "Args limited to " :REXX-ARG-LIMIT: upon syserr
               exit perform
           end-if
           *> Rexx wants arg pointers and lengths, excluding null byte
           set rexx-arg-ptr(we-sub) to we-word(we-sub)
           call "strlen" using
               by value we-word(we-sub)
               returning rexx-arg-len(we-sub)
           end-call
           add 1 to we-sub
       end-perform

      *> set calltype, and the result buffer space
       move RXCOMMAND to rexx-calltype
       set rexx-result-ptr to address of rexx-buffer
       set rexx-result-len to length(rexx-buffer)

      *> Use instore (0) or program-name
       if rexx-mode equal 0 then
           call "RexxStart" using
               by value     rexx-arg-count
               by reference rexx-arguments
               by reference NULL
               by reference rexx-instore
               by reference rexx-environment
               by value     rexx-calltype
               by reference NULL
               by reference rexx-return-code
               by reference rexx-result
               returning    rexx-call-return
               on exception
                   display "no RexxStart linkage" upon syserr
                   perform soft-exception
           end-call
       else
           call "RexxStart" using
               by value     rexx-arg-count
               by reference rexx-arguments
               by reference rexx-program-name
               by reference NULL
               by reference rexx-environment
               by value     rexx-calltype
               by reference NULL
               by reference rexx-return-code
               by reference rexx-result
               returning    rexx-call-return
               on exception
                   display "no RexxStart linkage" upon syserr
                   perform soft-exception
           end-call
       end-if

      *> clear any parsed word expansion array
       call "wordfree" using
           expanded-structure
           on exception
               display "no wordfree linkage" upon syserr
               perform soft-exception
       end-call

      *> If the rexx result buffer is not large enough,
      *>   inform caller of new address, which needs to be freed
       if rexx-result-len > length(rexx-buffer) then
           set rexx-result-pointer to rexx-result-ptr
       else
           set rexx-result-pointer to null
       end-if

       move rexx-result-len to rexx-result-length
       move rexx-return-code to rexx-rc
       move rexx-call-return to rexx-api-code
       move 0 to rexx-udf-code
       goback.
      *> ***************************************************************

      *> informational warnings and abends
       soft-exception.
         display "Module:              " module-id upon syserr
         display "Module path:         " module-path upon syserr
         display "Module source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       end function rexx.
      *> ***************************************************************
      *>****

      *> ***************************************************************
      *>****P* oorexx/rexxcommand
      *> PURPOSE
      *>   Add a gnucobol subcommand address to Rexx
      *> TECTONICS
      *>   RexxRegisterSubcomExe("gnucobol", entry)
      *>   In Rexx, address gnucobol; with commands
      *> ***************************************************************
       identification division.
       program-id. rexxcommand.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       >>IF P64 IS SET
       01 REXX-SIZE-MOD        constant as 18.
       >>ELSE
       01 REXX-SIZE-MOD        constant as 8.
       >>END-IF

       01 buff         pic x(256) based.

       01 response.
          05 filler    pic x(35)
                       value "By your command. GnuCOBOL received ".
          05 in-msg    pic 999.
          05 filler    pic x(10) value " character".
          05 plural    pic x     value "s".

       linkage section.
       01 command.
          05 com-len   pic 9(REXX-SIZE-MOD) comp-5.
          05 com-ptr   usage pointer.
       01 flags        usage binary-short.
       01 rexx-rc.
          05 rc-len    pic 9(REXX-SIZE-MOD) comp-5.
          05 rc-ptr    usage pointer.

       procedure division using command flags rexx-rc.

      *> set the Rexx result buffer and length.
      *> Default space of 256 should be fine for most operations
       set address of buff to rc-ptr

       if com-len = 1 then
           move space to plural
       else
           initialize plural all to value
       end-if

       move com-len to in-msg
       move response to buff
       move length(trim(response trailing)) to rc-len

      *> if return-code is not 0, Rexx will complain,
      *>  and abort further processing
       move 0 to return-code
       goback.

       end program rexxcommand.
      *> ***************************************************************
      *>****


      *> ***************************************************************
      *>****P* oorexx/fromrexx
      *> PURPOSE
      *>   Call from Rexx into GnuCOBOL
      *> TECTONICS
      *>   RexxRegisterFunctionExe("name", entry)
      *>   In Rexx, call name args; say result
      *> ***************************************************************
       identification division.
       program-id. fromrexx.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       >>IF P64 IS SET
       01 REXX-SIZE-MOD   constant as 18.
       >>ELSE
       01 REXX-SIZE-MOD   constant as 8.
       >>END-IF

      *> the argv is an array of len, ptr
       01 argv         based.
          05 arg-len   pic 9(REXX-SIZE-MOD) comp-5.
          05 arg-ptr   usage pointer.

       01 buff         pic x(256) based.
       01 response.
          05 filler    pic x(27) value "Hello from GnuCOBOL, Rexx. ".
          05 arg-msg   pic 99.
          05 filler    pic x(9)  value " argument".
          05 plural    pic x(10) value "s received".
       01 singular     pic x(9) value " received".

       linkage section.
       01 rexx-name    usage pointer.
       01 argc         usage binary-long.
       01 arg-list     usage pointer.
       01 queue-ptr    usage pointer.
       01 rexx-rc.
          05 rc-len    pic 9(REXX-SIZE-MOD) comp-5.
          05 rc-ptr    usage pointer.

       procedure division using
           by value rexx-name argc arg-list queue-ptr
           by reference rexx-rc.

      *> there is a fair amount of indirection going on
       set address of argv to arg-list

      *> set the Rexx result buffer and length.
      *> Default space of 256 should be fine for most operations
       set address of buff to rc-ptr

       if argc = 1 then
           move singular to plural
       else
           initialize plural all to value
       end-if
       move argc to arg-msg

       move response to buff
       move length(trim(response trailing)) to rc-len

      *> if return-code is not 0, Rexx will complain,
      *>  and abort any further processing
       move 0 to return-code
       goback.

       end program fromrexx.
      *> ***************************************************************
      *>****
>>ELSE

sed ':loop;/!rst.marker!/{d};N;b loop' gnucobol-rexx.cob | sed '$d'
    | rst2html >gnucobol-rexx.html

=============
gnucobol-rexx
=============

.. header:: GnuCOBOL and Open Object Rexx

.. sidebar:: GnuCOBOL and Open Object Rexx

   .. contents::

gnucobol-rexx
-------------

A user defined function repository for Open Object Rexx in GnuCOBOL

::

    cobcrun gnucobol-rexx [arguments...]

Command line options, when running the main module from the repository include

     help
     version
     source
     shell
     and the default, demo to run quick tests.

There is a Rexx CALL command, as "cobol", registered which sets RESULT.

There is a "gnucobol" subcommand handler registered, which sets RC.
This ADDRESS will be the default when in the shell and when running the
quick tests.


UDF as::

    move rexx(mode, script, environment, argument, buffer)
      to rexx-result-record

Overview
--------

Call Open Object Rexx from GnuCOBOL.  Supports external and instore
scripts along with external or internal argument lists.

Uses a default external script of **gnucobol.rex** if no command is
given.

Uses the sample provided by RexxLA for **instore** scripting
which is paired with an external **example.rex** file. example.rex
includes the copyright notice to comply with the CPL v1.0 license.

Uses a default Rexx environment name address of "gnucobol".

Exit routines have not yet been tested.

Results are returned in the given working storage, or if necessary, a
buffer allocated by Rexx.

Prerequisites
-------------

Requires GnuCOBOL 2.0 and Open Object Rexx 4

::

    yum install oorexx oorexx-devel oorexx-libs oorexx-docs

rxapi
.....

The ``rxapi`` daemon MUST be running for many Open Object Rexx features
to properly operate.

::

    sudo /usr/bin/rxapid start

    or perhaps

    sudo /etc/init.d/rxapid start

function rexx usage
-------------------

The ``rexx`` function takes

::

    mode,   pic 9,     0 meaning script is internal, 1 meaning script is named
    script, pic x any, either the script text or filename
    env,    pic x any, the Rexx address environment
    args,   pic x any, a single string, parsed as shell word expansion
    buffer, pic x any, the Rexx result buffer

and returns a record structure of

::

       01 rexx-status.
          05 rexx-result-pointer   usage pointer.
       >>IF P64 IS SET
          05 rexx-result-length    pic 9(18) comp-5.
       >>ELSE
          05 rexx-result-length    pic 9(8) comp-5.
       >>END-IF
          05 rexx-rc               usage binary-short.
          05 rexx-api-code         usage binary-long.
          05 rexx-udf-code         usage binary-long.

Which is compatible with both 32 bit and 64 bit ooRexx releases, as is
the rest of the gnucobol-rexx module.


For example::

    01 ws-rexx     pic x(256).

    move rexx(1, "script.rex", "gnucobol", "from $HOME", ws-rexx)
      to rexx-status

- mode determines if the script is specified as an internal character
  string or filename.  0 for internal text, non-zero for external file.

- script is *script text* or *filename*.  The rexx function keeps a
  default internal script that echos back the Rexx version string, with a
  count of passed in arguments appended.  This is triggered for mode 0 and
  a NULL for *script text*.  A default filename of ``gnucobol.rex`` is used
  when mode is non-zero and NULL is used as the script parameter.

- env is the Rexx environment, used in Rexx address statements. Defaults
  to ``gnucobol`` if NULL is passed.

- args is a single character string of arguments, parsed as a shell word
  expansion.  That means tilde is expanded to home directory, dollar
  variables are substituted, and certain characters, like angle brackets,
  will need backslash escapes.  Full rules can be found in ``man 3
  wordexp``.  When the command line is involved, double substitutions may
  occur, as the shell may expand a dollar variable, and if the replacement
  starts with a dollar, ``wordexp`` will attempt another round of
  substitution.  Backslash escapes can control this behaviour.  Also
  calls ``wordfree`` when finished with argument lists.

- buffer is a COBOL working storage character allocation.  Rexx will use
  this space to hold results.  If the buffer is not large enough, Rexx
  will internally allocate a new working space.  The
  ``rexx-return-record`` rexx function return includes a
  rexx-result-pointer field.  If this field in non null, then the Rexx
  result space has been reallocated and a call to ``RexxFreeMemory`` is
  required.

- The return value of the ``rexx`` function is a COBOL record with fields
  for result-length, result-pointer, Rexx return code, RexxStart API
  result code, and a status value from the ``rexx`` UDF.

.. important:: Terminating zero bytes from C.
   Although Rexx returns a length, the result buffer may also include a
   terminating zero byte.  Use either reference modification when moving
   or displaying data in the Rexx result string buffer or change the
   character at rexx-buffer(rexx-result-length:1) to a space, when it
   is safe to do so.  (Modification of the terminating zero is **not**
   safe if Rexx reallocated the buffer space due to size overflow, so
   test rexx-result-pointer to make sure).

cobcrun
-------

The repository library includes a main module for self testing.  It
includes a demo program that exercises some features, and a small
interactive shell that allows typing in Rexx comands, and short
one line programs.

::

    Open Object Rexx from GnuCOBOL
    cobcrun gnucobol-rexx  [help version source shell] [[demo] args...]
      default action is to run demo, with args

      help or --help will display this help
      version will display version
      source  will display the COBOL for repository
      shell   will start up a small Rexx REPL shell
      demo or test will run self tests

libtest-cobrexx.cob
-------------------

Along with other testing features in the ``gnucobol-rexx`` module
default entry point, the code also links to two external sub-programs
for use withing Open Object Rexx.

``RexxRegisterSubcomDll`` is used to create an externally defined
command address of ``extcob``.

``RexxRegisterFunctionDll`` is used to define an external function, ``cobout``.

Both of the required GnuCOBOL subprograms as in libtest-rexx.cob.

Normal usage requires the rxapi_ daemon to be running, and the libary
must be part of the current shared library search path.

::

    LD_LIBRARY_PATH=. rlwrap cobcrun gnucobol-rexx shell

As that is a long command line, use the Makefile rule.

::

    make test

``rlwrap`` is not mandatory, but makes the shell REPL a more pleasant
experience, by adding GNU ``readline`` features to the normal GnuCOBOL
ACCEPT verb, without changing any code.  make test will attempt to use
rlwrap if it is available.

ooRexx shell
------------

Use q, quit, or send a keyboard EOF to exit the little shell.

::

    prompt$ make
    cobc -m -g -debug `oorexx-config --libs` gnucobol-rexx.cob

    prompt$ cobcrun gnucobol-rexx shell
    ooRexx: parse version . level .; return level

    Status : +00000, +0000000000, +0000000000
    Length : 000000000000000004
    Result :6.03:

    ooRexx: parse pull name; say "Hello, " || name; return name
    Rex
    Hello, Rex

    Status : +00000, +0000000000, +0000000000
    Length : 000000000000000003
    Result :Rex:

    ooRexx: return 21 * 2

    Status : +00042, +0000000000, +0000000000
    Length : 000000000000000002
    Result :42:

    ooRexx: q
    prompt$

gnucobol-rexx.cpy
-----------------

The ``rexx`` result record is defined in a copybook, and includes
replacable :PREFIX: pseudo-text.  There is also conditional compile
directives used to manage 32bit and 64bit Open Object Rexx issues.

The demonstration code uses

::

    COPY 'gnucobol-rexx.cpy' REPLACING ==:PREFIX:== BY ==rexx==.

giving:

.. sourcecode:: cobolfree

    01 rexx-condition.
       05 rexx-result-pointer   usage pointer.
       05 rexx-result-length    pic 9(18) comp-5.
       05 rexx-rc               usage binary-short.
       05 rexx-api-code         usage binary-long.
       05 rexx-udf-code         usage binary-long.

where result-length will either be a pic 9(8) or pic 9(18) treated as
comp-5 giving a 4 byte or 8 byte allocation and keeping stack frames in
proper sync.  *This same conditional compile sequence is used internally
for interfacing with* ``RexxStart``.

RexxStart
---------

``callrexx.cob`` uses the "Classic" form of invoking Rexx, with a C
interface, using ``RexxStart``.

Version 4 (or greater) of Open Object Rexx supports either 32bit or
64bit stack frames.

.. sourcecode:: c

    int REXXENTRY RexxStart (
         size_t,                       /* Num of args passed to rexx  */
         PCONSTRXSTRING,               /* Array of args passed to rex */
         CONSTANT STRING,              /* [d:][path] filename[.ext]   */
         PRXSTRING,                    /* Loc of rexx proc in memory  */
         CONSTANT STRING,              /* ASCIIZ initial environment. */
         int,                          /* type [command,subrtn,funct] */
         PRXSYSEXIT,                   /* SysExit env. names &  codes */
         short *,                      /* Ret code from if numeric    */
         PRXSTRING );                  /* Retvalue from the rexx proc */

This bit sizing is handled in ``callrexx.cob`` by defining either an
``9(8) comp-5`` or ``9(18) comp-5`` as determined by conditional compiler
directives.

Call RexxStart
--------------

For external scripts use:

.. sourcecode:: cobolfree

    call "RexxStart" using
        by value     rexx-arg-count
        by reference rexx-arguments
        by reference rexx-program-name
        by reference NULL
        by reference rexx-environment
        by value     rexx-calltype
        by reference NULL
        by reference rexx-return-code
        by reference rexx-result
        returning    rexx-call-return
        on exception
            display "no RexxStart linkage" upon syserr
            perform hard-exception
    end-call

or

.. sourcecode:: cobolfree

    call "RexxStart" using
        by value     rexx-arg-count
        by reference rexx-arguments
        by reference NULL
        by reference rexx-instore
        by reference rexx-environment
        by value     rexx-calltype
        by reference NULL
        by reference rexx-return-code
        by reference rexx-result
        returning    rexx-call-return
        on exception
            display "no RexxStart linkage" upon syserr
            perform hard-exception
    end-call

when scripts are held in working storage.

Reallocated Rexx
----------------

Here is some COBOL that attempts to handle reallocated buffer pointers.
The demo code just uses ``printf``.

Add a limiting value to the top REPLACE phrase.  256 meg is defined in
GnuCOBOL as the largest PIC size, even for BASED items.

.. sourcecode:: cobolfree

               ==:REXX-MAXIMUM-SIZE:==  BY ==268435455==

Add some based variables, and a pointer.

.. sourcecode:: cobolfree

      *> Handle reallocated Rexx result buffers
       01 based-rexx-ptr       usage pointer.
       01 based-rexx-buffer    pic x(:REXX-MAXIMUM-SIZE:) based.
       01 based-rexx-source    pic x(:REXX-MAXIMUM-SIZE:) based.

And some code to shuffle heap memory into working storage.

.. sourcecode:: cobolfree

           *> This display routine is only for demonstration
           *> Display the larger buffer
           if rexx-result-length > :REXX-MAXIMUM-SIZE: then
               move :REXX-MAXIMUM-SIZE: to rexx-result-length
               display " truncated for display"
           else
               display space
           end-if

           *> allocate a buffer, then move from the heaped pointer
           free based-rexx-ptr
           allocate rexx-result-length characters
               returning based-rexx-ptr
           set address of based-rexx-buffer to based-rexx-ptr
           set address of based-rexx-source to rexx-result-pointer
           move based-rexx-source(1:rexx-result-length)
             to based-rexx-buffer(1:rexx-result-length)

           display ":" based-rexx-buffer(1:rexx-result-length) ":"

           free based-rexx-ptr
           set address of based-rexx-buffer to null
           set address of based-rexx-source to null

Reference modification keeps COBOL from touching unallocated BASED
memory.

For the demonstration self-test, all that code was replaced with a
simple call to printf, with a sized string format specifier.

.. sourcecode:: cobolfree

        01 printf-int           usage binary-long.

           call "printf" using
               by content "%.*s" & x"0a00"
               by value   rexx-result-length
               by value   rexx-result-pointer
               returning printf-int
               on exception
                   display "no printf linkage" upon syserr
                   perform soft-exception
           end-call

Sources
-------

gnucobol-rexx.cob
.................

The rexx function, a main test-head and two subprograms registered to ooRexx.

.. include:: gnucobol-rexx.cob
   :code: cobolfree
   :end-before: !rst-marker

gnucobol-rexx.cob inline documenation
.....................................

This gnucobol-rexx documentation, as ReStructuredText

.. include:: gnucobol-rexx.cob
   :start-after: rst-marker!
   :code: rst

gnucobol-rexx.cpy
.................

The rexx function return structure.  32bit and 64bit ooRexx compatible.

.. include:: gnucobol-rexx.cpy
   :code: cobolfree

libtest-cobrexx.cob
...................

A sample exernal command, and external function. Optional when testing
gnucobol-rexx.

.. include:: libtest-cobrexx.cob
   :code: cobolfree

gnucobol.rex
............

Default script, customize to taste.

.. include:: gnucobol.rex
   :code: c

mycmd.rex
.........

Sample script for other testing.

.. include:: mycmd.rex
   :code: c

example.rex
...........

Example Rexx courtesy of IBM and RexxLA.  CPL 1.0 licence included.

Part of the self test in gnucobol-rexx.cob.

.. include:: example.rex
   :code: c

Makefile
........

The tectonics.

.. include:: Makefile
   :code: make

Sample run
..........

``cobcrun gnucobol-rexx`` version, help, demo

.. include:: gnucobol-rexx.run
   :literal:

/* Default script for GnuCOBOL Open Object Rexx */
parse source program;
say "Evaluating " program;

total_args = arg();
say "Total arguments: " total_args;

do arg_index = 1 to total_args by 1 for total_args
    say arg(arg_index);
end
say;

parse Version ver;
say "Rexx version: " ver;
say;

address "bash";
'cobc --version';

return ver;

/*----------------------------------------------------------------------------*/
/*                                                                            */
/* Copyright (c) 1995, 2004 IBM Corporation. All rights reserved.             */
/* Copyright (c) 2005-2006 Rexx Language Association. All rights reserved.    */
/*                                                                            */
/* This program and the accompanying materials are made available under       */
/* the terms of the Common Public License v1.0 which accompanies this         */
/* distribution. A copy is also available at the following address:           */
/* http://www.oorexx.org/license.html                          */
/*                                                                            */
/* Redistribution and use in source and binary forms, with or                 */
/* without modification, are permitted provided that the following            */
/* conditions are met:                                                        */
/*                                                                            */
/* Redistributions of source code must retain the above copyright             */
/* notice, this list of conditions and the following disclaimer.              */
/* Redistributions in binary form must reproduce the above copyright          */
/* notice, this list of conditions and the following disclaimer in            */
/* the documentation and/or other materials provided with the distribution.   */
/*                                                                            */
/* Neither the name of Rexx Language Association nor the names                */
/* of its contributors may be used to endorse or promote products             */
/* derived from this software without specific prior written permission.      */
/*                                                                            */
/* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS        */
/* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT          */
/* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS          */
/* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   */
/* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,      */
/* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED   */
/* TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,        */
/* OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY     */
/* OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING    */
/* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS         */
/* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.               */
/*                                                                            */
/*----------------------------------------------------------------------------*/
/*********************************************************************/
/*                                                                   */
/*  File Name:          example                                      */
/*                                                                   */
/* ----------------------------------------------------------------- */
/*                                                                   */
/*  Description:       script to test the REXX interpreter API       */
/*                                                                   */
/*********************************************************************/

::class example public
::method repeat
  expose loops
  use arg reps, msg
  do reps
     say msg
  end
  return 'Repeated' msg',' reps 'times.'

prompt$ make
cobc -m libtest-cobrexx.cob
cobc -m -g -debug `oorexx-config --libs` gnucobol-rexx.cob

prompt$ make sample
cobcrun gnucobol-rexx version >gnucobol-rexx.run
cobcrun gnucobol-rexx help >>gnucobol-rexx.run
cobcrun gnucobol-rexx >>gnucobol-rexx.run

prompt$ cat gnucobol-rexx.run
gnucobol-rexx Version: 0.6 2015-10-26/07:36:32.00-0400

Open Object Rexx from GnuCOBOL
cobcrun gnucobol-rexx  [help version source shell] [[demo] args...]
  default action is to run demo, with args

  help or --help will display this help
  version will display version
  source  will display the COBOL for repository
  shell   will start up a small Rexx REPL shell
  demo or test will run self tests

Invoke Open Object Rexx with filename, environment, two arguments
#############################################################################

Evaluating  LINUX COMMAND /home/btiffin/lang/rexx/gnucobol.rex
Total arguments:  2
abc
123
Rexx version:  REXX-ooRexx_4.1.0(MT) 6.03 17 Aug 2014
Address bash to echo shell
/bin/bash

Status : +00000, +0000000000, +0000000000 Length: 38
Result :REXX-ooRexx_4.1.0(MT) 6.03 17 Aug 2014:

Invoke Open Object Rexx default filename, environment, args from command line
#############################################################################

Evaluating  LINUX COMMAND /home/btiffin/lang/rexx/gnucobol.rex
Total arguments:  0
Rexx version:  REXX-ooRexx_4.1.0(MT) 6.03 17 Aug 2014
Address bash to echo shell
/bin/bash

Status : +00000, +0000000000, +0000000000 Length: 38
Result :REXX-ooRexx_4.1.0(MT) 6.03 17 Aug 2014:

Invoke Open Object Rexx with script, rexx environment, args ignored by script
#############################################################################

Object 1 running
Object 1 running
Object 1 running
Object 1 running
Repeated Object 1 running, 4 times.
The result method waits till START has completed:
Object 2 running
Object 3 running
Object 2 running
Object 3 running
Repeated Object 2 running, 2 times.
Repeated Object 3 running, 2 times.
main ended
Elapsed time:  0.000902

Status : +00000, +0000000000, +0000000000 Length: 0
Empty result

Invoke Open Object Rexx default script, default environment, two arguments
  script returns ooRexx version, and count of args
#############################################################################


Status : +00000, +0000000000, +0000000000 Length: 41
Result :REXX-ooRexx_4.1.0(MT) 6.03 17 Aug 2014, 2:

prompt$ ./callrexx
Evaluating  LINUX COMMAND /home/btiffin/lang/rexx/gnucobol.rex
Total arguments:  0

Rexx version:  REXX-ooRexx_4.1.0(MT) 6.03 17 Aug 2014

cobc (GNU Cobol) 2.0.0
Copyright (C) 2001,2002,2003,2004,2005,2006,2007 Keisuke Nishida
Copyright (C) 2006-2012 Roger While
Copyright (C) 2013-2015 Ron Norman
Copyright (C) 2009,2010,2012,2014,2015 Simon Sobisch
This is free software; see the source for copying conditions.  There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Built     Sep 05 2015 20:43:10
Packaged  Mrz 29 2015 14:56:23 UTC
C version "4.9.2 20150212 (Red Hat 4.9.2-6)"

Rexx status: +00000, +0000000000
Rexx length: 000000000000000038
Rexx result:REXX-ooRexx_4.1.0(MT) 6.03 17 Aug 2014:

prompt$ make shell
LD_LIBRARY_PATH=. rlwrap cobcrun gnucobol-rexx shell
For testing in the shell:
  call cobol arg1,arg2; say result
  address gnucobol; with command; return rc
  call cobout 1,2,3; return result           **
  address extcob; command; return rc         **
     ** If libtest-cobrexx.so is in search path

  any Rexx instructions, default address is gnucobol
  q to quit

GnuCOBOL ooRexx test shell: 2015-10-26/20:10:50.00-0400
ooRexx: call cobol 1,abc,3,4; return result

Status : +00000, +0000000000, +0000000000 Length: 48
Result :Hello from GnuCOBOL, Rexx. 04 arguments received:

ooRexx: call cobout 1,abc,3,4,5; return result

Status : +00000, +0000000000, +0000000000 Length: 45
Result :05 arguments received. Second argument   :ABC:

ooRexx: address gnucobol; command string; return rc

Status : +00000, +0000000000, +0000000000 Length: 49
Result :By your command. GnuCOBOL received 014 characters:

ooRexx: address extcobol; command string; return rc
     1 *-* command string;
       >>>   "COMMAND STRING"
       +++   "RC(30)"

Status : +00030, +0000000000, +0000000000 Length: 2
Result :30:

ooRexx: address extcob; command string; return rc

Status : +00000, +0000000000, +0000000000 Length: 67
Result :External command received 014 characters, first part:COMMAND STRING:

ooRexx: q
prompt$

move rexx(1, "script.rex", "gnucobol", "args from $HOME", ws-rexx)
  to rexx-status

move rexx(0, "parse version v; return v", "envofchoice",
             "args from $HOME and abroad", ws-rexx)
  to rexx-status

/* GnuCOBOL interface to Regina Rexx Interpreter */
/* Requires regina3 and regina3-dev */
/* cobc -I/usr/include/regina -c ocrexx.c */

#include <stdio.h>
#include <string.h>
#include <rexxsaa.h>

int ocrexx(char *script, char *args, char *resfield, int reslen, short *result) {
    APIRET rexxapiret;
    RXSTRING retstr;
    RXSTRING arglist[1];
    short  rexxret = 0;

    int ignore = 0;

    /* Initialize the engine, run the script */
    retstr.strptr = NULL;
    retstr.strlength = 0;
    arglist[0].strptr = args;
    arglist[0].strlength = strlen(args);

    rexxapiret = RexxStart(1, (PRXSTRING)&arglist, script, NULL, NULL,
        RXCOMMAND || RXRESTRICTED, NULL, &rexxret, &retstr);

    /* set result back to GnuCOBOL */
    memset(resfield, ' ', reslen);
    if (rexxapiret == 0) {
        memcpy(resfield, retstr.strptr,
              (retstr.strlength > reslen) ? reslen : retstr.strlength);
        *result = rexxret;
    }

    /* Let Rexx do all the memory alllocation */
    if (retstr.strptr != NULL) { ignore = RexxFreeMemory(retstr.strptr); }

    return (int)rexxapiret;
}

int ocrexxcmd(char *cmds, char *args, char *resfield, int reslen, short *result) {
    APIRET rexxapiret;
    RXSTRING retstr;
    RXSTRING arglist[1];
    RXSTRING instore[2];
    short rexxret = 0;

    int ignore = 0;

    /* For syntax check, no evaluate, taken from 8.4 of the Regina3.4 pdf */
    arglist[0].strptr = "//T";
    arglist[0].strlength = 3;

    arglist[0].strptr = args;
    arglist[0].strlength = strlen(args);

    /* Move the command(s) to the instore array */
    instore[0].strptr = cmds;
    instore[0].strlength = strlen(cmds);
    instore[1].strptr = NULL;
    instore[1].strlength = 0;

    /* Call Rexx. Use argcount 1 and &arglist to call syntax check */
    retstr.strptr = NULL;
    retstr.strlength = 0;
    rexxapiret = RexxStart(1, (PRXSTRING)&arglist, "FILLER",
                              (PRXSTRING)&instore, "COMMAND" /* NULL */,
        RXCOMMAND, NULL, &rexxret, &retstr);

    /* set result back to GnuCOBOL */
    memset(resfield, ' ', reslen);
    if (rexxapiret == 0) {
        memcpy(resfield, retstr.strptr,
              (retstr.strlength > reslen) ? reslen : retstr.strlength);
        *result = rexxret;
    }

    /* Let Rexx do all the memory alllocation */
    if (instore[1].strptr != NULL) { ignore = RexxFreeMemory(instore[1].strptr); }
    if (retstr.strptr != NULL) { ignore = RexxFreeMemory(retstr.strptr); }

    return (int)rexxapiret;
}
/**/

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *><* *****************
      *><* Rexx in GnuCOBOL
      *><* *****************
      *><*
      *><* :Author:    Brian Tiffin
      *><* :Date:      13-Nov-2008
      *><* :Purpose:   Very High Level Regina Rexx engine
      *><* :Requires:  regina-rexx, regina3, regina3-dev, OC 1.1 pre-rel
      *><* :Tectonics:
      *><*    | cobc -I/usr/include/regina -c ocrexx.c
      *><*    | cobc -x -lregina rexxcaller.cob ocrexx.o
      *><*    | ocdoc rexxcaller.cob rexxcaller.rst rexxcaller.html
      *> ***************************************************************
       identification division.
       program-id. rexxcaller.

       data division.
      *><*
      *><* =============
      *><* Working Store
      *><* =============
      *><*
      *><* ::
      *><*
      *><[
       working-storage section.
       01 newline constant as x"0a".
       01 trimmer              usage binary-long.
       01 apicode              usage binary-long.
       01 resultcode           usage binary-short.
       01 scriptname           pic x(12) value 'verrexx.cmd' & x'00'.
       01 argument             pic x(256) value 'OC1.1 args' & x"00".
       01 cmds                 pic x(1024).
       01 rexxstring           pic x(1048576).
      *><]

      *> **************************************************************
       procedure division.

      *><*
      *><* ===
      *><* API
      *><* ===
      *><*
      *><* ------
      *><* ocrexx
      *><* ------
      *><* Pass a null-term scriptname, a null-term argument string
      *><* the return value field and length, the return code and
      *><* returning the Rexx api result code.
      *><*
      *><* Usage::
      *><*
       compute
           trimmer = function length(function trim(scriptname))
       end-compute
       display
           "CALL Rexx with |" scriptname(1:trimmer - 1) "|"
       end-display
      *><[
       call "ocrexx"
           using
               by reference scriptname
               by reference argument
               by reference rexxstring
               by value function length(rexxstring)
               by reference resultcode
           returning apicode
       end-call
       display "|" apicode "|" resultcode with no advancing end-display
       display "|" function trim(rexxstring trailing) "|" end-display
      *><]

      *><*
      *><* ---------
      *><* ocrexxcmd
      *><* ---------
      *><* Usage::
      *><*
      *><[
       move "say 'Hello, world'; return 'From Rexx';" & x'00' to cmds.
       compute
           trimmer = function length(function trim(cmds))
       end-compute
       display newline
           "CALL Rexx command with |" cmds(1:trimmer - 1) "|"
       end-display
       call "ocrexxcmd"
           using
               by reference cmds
               by reference argument
               by reference rexxstring
               by value function length(rexxstring)
               by reference resultcode
           returning apicode
       end-call
       display "|" apicode "|" resultcode with no advancing end-display
       display "|" function trim(rexxstring trailing) "|" end-display
      *><]
      *><*
      *><* or perhaps::
      *><*
      *><[
       move
           "parse arg argument; say '##' || argument || '##';" & x"0a" &
           "capture = '';" & x"0a" &
           "address system 'cat tectonic && cat verrexx.cmd && ls -l" &
           " && w3m rexxcaller.html'" &
           " with output fifo '';" & x"0a" &
           "DO i=1 WHILE queued() \= 0;" & x"0a" &
           "    parse pull line;" & x"0a" &
           "    capture = capture || line || '0a'x;" & x"0a" &
           "END;" & x'0a' &
           "return capture;" & x'00' to cmds
       compute
           trimmer = function length(function trim(cmds))
       end-compute
       display newline
           "CALL Rexx command with |" cmds(1:trimmer - 1) "|"
       end-display
       call "ocrexxcmd"
           using
               by reference cmds
               by reference argument
               by reference rexxstring
               by value function length(rexxstring)
               by reference resultcode
           returning apicode
       end-call
      *><]
       display "|" apicode "|" resultcode with no advancing end-display
       display "|" function trim(rexxstring trailing) "|" end-display
       goback.
       end program rexxcaller.
      *><*

Parse Version ver;
Say ver;
return ver;

$ ./tectonic
CALL Rexx with |verrexx.cmd|
REXX-Regina_3.3(MT) 5.00 25 Apr 2004
ocrexx.c  ocrexx.o  rexxcaller  rexxcaller.cob  rexxcaller.html  rexxcaller.rst
    rexx.output  tectonic  verrexx.cmd
|+0000000000|+00000|REXX-Regina_3.3(MT) 5.00 25 Apr 2004|

CALL Rexx command with |say 'Hello, world'; return 'From Rexx';|
Hello, world
|+0000000000|+00000|From Rexx|

CALL Rexx command with |parse arg argument; say '##' || argument || '##';
capture = '';
address system 'cat tectonic && cat verrexx.cmd && ls -l &&
                 w3m rexxcaller.html' with output fifo '';
DO i=1 WHILE queued() \= 0;
    parse pull line;
    capture = capture || line || '0a'x;
END;
return capture;|
##OC1.1 args##
|+0000000000|+00000|cobc -I/usr/include/regina/ -c ocrexx.c
cobc -x -lregina rexxcaller.cob ocrexx.o
../ocdoc rexxcaller.cob rexxcaller.rst rexxcaller.html ../ocfaq.css
./rexxcaller
/* script for GnuCOBOL Regina Rexx */
Parse Version ver;
Say ver;
address system;
'ls';
return ver;
total 68
-rw-r--r-- 1 btiffin btiffin  2469 2008-11-16 11:09 ocrexx.c
-rw-r--r-- 1 btiffin btiffin  2568 2010-05-06 22:51 ocrexx.o
-rwxr-xr-x 1 btiffin btiffin 18128 2010-05-06 22:51 rexxcaller
-rw-r--r-- 1 btiffin btiffin  4477 2008-11-16 11:28 rexxcaller.cob
-rw-r--r-- 1 btiffin btiffin  9312 2010-05-06 22:51 rexxcaller.html
-rw-r--r-- 1 btiffin btiffin  3187 2010-05-06 22:51 rexxcaller.rst
-rw-r--r-- 1 btiffin btiffin  4131 2008-11-16 11:30 rexx.output
-rwxr-xr-x 1 btiffin btiffin   162 2008-11-16 11:21 tectonic
-rw-r--r-- 1 btiffin btiffin   101 2008-11-15 23:24 verrexx.cmd
Rexx in GnuCOBOL

 Author:   Brian Tiffin
  Date:    13-Nov-2008
 Purpose:  Very High Level Regina Rexx engine
Requires:  regina-rexx, regina3, regina3-dev, OC 1.1 pre-rel
           cobc -I/usr/include/regina -c ocrexx.c
Tectonics: cobc -x -lregina rexxcaller.cob ocrexx.o
           ocdoc rexxcaller.cob rexxcaller.rst rexxcaller.html

Working Store

working-storage section.
01 newline constant as x"0a".
01 trimmer              usage binary-long.
01 apicode              usage binary-long.
01 resultcode           usage binary-short.
01 scriptname           pic x(12) value 'verrexx.cmd' & x'00'.
01 argument             pic x(256) value 'OC1.1 args' & x"00".
01 cmds                 pic x(1024).
01 rexxstring           pic x(1048576).

API

ocrexx

Pass a null-term scriptname, a null-term argument string the return value field
and length, the return code and returning the Rexx api result code.

Usage:

call "ocrexx"
    using
        by reference scriptname
        by reference argument
        by reference rexxstring
        by value function length(rexxstring)
        by reference resultcode
    returning apicode
end-call
display "|" apicode "|" resultcode with no advancing end-display
display "|" function trim(rexxstring trailing) "|" end-display

ocrexxcmd

Usage:

move "say 'Hello, world'; return 'From Rexx';" & x'00' to cmds.
compute
    trimmer = function length(function trim(cmds))
end-compute
display newline
    "CALL Rexx command with |" cmds(1:trimmer - 1) "|"
end-display
call "ocrexxcmd"
    using
        by reference cmds
        by reference argument
        by reference rexxstring
        by value function length(rexxstring)
        by reference resultcode
    returning apicode
end-call
display "|" apicode "|" resultcode with no advancing end-display
display "|" function trim(rexxstring trailing) "|" end-display

or perhaps:

move
    "parse arg argument; say '##' || argument || '##';" & x"0a" &
    "capture = '';" & x"0a" &
    "address system 'cat tectonic && cat verrexx.cmd && ls -l" &
    " && w3m rexxcaller.html'" &
    " with output fifo '';" & x"0a" &
    "DO i=1 WHILE queued() \= 0;" & x"0a" &
    "    parse pull line;" & x"0a" &
    "    capture = capture || line || '0a'x;" & x"0a" &
    "END;" & x'0a' &
    "return capture;" & x'00' to cmds
compute
    trimmer = function length(function trim(cmds))
end-compute
display newline
    "CALL Rexx command with |" cmds(1:trimmer - 1) "|"
end-display
call "ocrexxcmd"
    using
        by reference cmds
        by reference argument
        by reference rexxstring
        by value function length(rexxstring)
        by reference resultcode
    returning apicode
end-call

|

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin, with some suggestions from human
      *> Date:      30-Nov-2008, 02-Dec-2008
      *> Purpose:   Demonstration of the SEARCH verb
      *> Tectonics: cobc -x searchlinear.cob
      *> ***************************************************************
       identification division.
       program-id. searchlinear.

       data division.

       working-storage section.
       01 taxinfo.
          05 tax-table occurs 4 times indexed by tt-index.
             10 province       pic x(2).
             10 taxrate        pic 999v9999.
             10 federal        pic 999v9999.
       01 prov                 pic x(2).
       01 percent              pic 999v9999.
       01 percentage           pic zz9.99.

      *> ***************************************************************
       procedure division.
       begin.

      *> ***************************************************************
      *> Sample for linear SEARCH, requires INDEXED BY table
      *> populate the provincial tax table; (not really, only a couple)
      *> populate Ontario and then PEI using different field loaders
       move 'AB' to province(1)
       move 'ON' to province(2)
       move 0.08 to taxrate(2)
       move 0.05 to federal(2)
       move 'PE00014000000000' to tax-table(3)
       move 'YT' to province(4)

      *> Find Ontario tax rate
       move "ON" to prov
       perform search-for-taxrate

      *> Setup for Prince Edward Island
       move 'PE' to prov
       perform search-for-taxrate

      *> Setup for failure
       move 'ZZ' to prov
       perform search-for-taxrate

       goback.
      *> ***************************************************************

       search-for-taxrate.
           set tt-index to 1
           search tax-table
               at end display "no province: " prov end-display
               when province(tt-index) = prov
                   perform display-taxrate
           end-search
       .

       display-taxrate.
           compute percent = taxrate(tt-index) * 100
           move percent to percentage
           display
               "found: " prov " at " taxrate(tt-index)
               "," percentage "%, federal rate of " federal(tt-index)
           end-display
       .

       end program searchlinear.

$ cobc -x searchlinear.cob && ./searchlinear
found: ON at 000.0800,  8.00%, federal rate of 000.0500
found: PE at 000.1400, 14.00%, federal rate of 000.0000
no province: ZZ

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin, with some suggestions from human
      *> Date:      30-Nov-2008, 02-Dec-2008
      *> Purpose:   Demonstration of the SEARCH ALL verb and table SORT
      *> Tectonics: cobc -x -fdebugging-line searchbinary.cob
      *> ***************************************************************
       identification division.
       program-id. searchbinary.

       environment division.
       input-output section.
       file-control.
           select optional wordfile
           assign to infile
           organization is line sequential.

       data division.
       file section.
       fd wordfile.
           01 wordrec          pic x(20).

       working-storage section.
       01 infile               pic x(256) value spaces.
          88 defaultfile       value '/usr/share/dict/words'.
       01 arguments            pic x(256).

      *> Note the based clause, this memory is initially unallocated
       78 maxwords             value 500000.
       01 wordlist             based.
          05 word-table occurs from 0 to maxwords times
              depending on wordcount
              descending key is wordstr
              indexed by wl-index.
             10 wordstr        pic x(20).
             10 wordline       usage binary-long.
       01 wordcount            usage binary-long.

       01 file-eof             pic 9 value low-value.
          88 at-eof            value high-values.

       01 word                 pic x(20).

      *> ***************************************************************
       procedure division.
       begin.

      *> Get the word file filename
       accept arguments from command-line end-accept
       if arguments not equal spaces
           move arguments to infile
       else
           set defaultfile to true
       end-if

      *> ***************************************************************
      *> Try playing with the words file and binary SEARCH ALL
      *>   requires KEY IS and INDEXED BY table description

      *> Point wordlist to valid memory
       allocate wordlist initialized

       open input wordfile

       move low-value to file-eof
       read wordfile
           at end set at-eof to true
       end-read

       perform
           with test before
           until at-eof or (wordcount >= maxwords)
               add 1 to wordcount
               move wordrec to wordstr(wordcount)
               move wordcount to wordline(wordcount)
               read wordfile
                   at end set at-eof to true
               end-read
       end-perform

       close wordfile

      *> ensure a non-zero length table when allowing optional file
       evaluate true                  also file-eof
           when wordcount = 0         also any
               move 1 to wordcount
               display "No words loaded" end-display
           when wordcount >= maxwords also low-value
               display "Word list truncated to " maxwords end-display
       end-evaluate

    >>D display "Count: " wordcount ": " wordstr(wordcount) end-display

      *> Sort the words from z to a
       sort word-table on descending key wordstr

      *> fetch a word to search for
       display "word to find: " with no advancing end-display
       accept word end-accept

      *> binary search the words for word typed in and display
      *> the original line number if/when a match is found
       set wl-index to 1
       search all word-table
           at end
               display
                   word " not a word of " function trim(infile)
               end-display
           when wordstr(wl-index) = word
               display
                   word " sorted to " wl-index ", originally "
                   wordline(wl-index) " of " function trim(infile)
               end-display
       end-search

      *> Release memory ownership
       free address of wordlist

       goback.
       end program searchbinary.

$ cobc -x searchbinary.cob
$ ./searchbinary
word to find: zygote
zygote   sorted to +000000018, originally +0000098552 of /usr/share/dict/words
$ ./searchbinary
word to find: abacus
abacus   sorted to +000080466, originally +0000018104 of /usr/share/dict/words

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      10-Apr-2010
      *> Purpose:   playing with the corncob pipe
      *> Tectonics: mkfifo corncob
      *>            cobc -x popcorn.cob
      *>            ls >corncob & ./popcorn
      *> ***************************************************************
       identification division.
       program-id. popcorn.

       environment division.
       configuration section.

       input-output section.
       file-control.
           select corncob
           assign to 'corncob'
           organization is line sequential
           .

       data division.
       file section.
       fd corncob.
          01 tobacco pic x(32768).

       working-storage section.
       01 filestat pic x value low-value.
          88 done        value high-value.
       01 liner    pic 99999.
       01 looper   pic 99999.
       01 atmost   constant as 32768.
       01 bowl.
          02 popcorn occurs 0 to atmost times depending on liner
              ascending key kernel.
             03 kernel pic x(132).

      *> ***************************************************************
       procedure division.

      *> Read from the pipe into a table
       open input corncob
       move zero to liner
       perform until done or (liner greater than or equal to atmost)
           read corncob
               at end
                   set done to true
               not at end
                   add 1 to liner end-add
                   move tobacco to kernel(liner)
           end-read
       end-perform
       close corncob

      *> Sort it descending and display
       sort popcorn on descending key kernel

       perform varying looper from 1 by 1 until looper > liner
           display
               "GnuCOBOL: " function trim(kernel(looper) trailing)
           end-display
       end-perform

       goback.
       end program popcorn.

$ rm corncob
$ mkfifo corncob
$ ls -d n* >corncob & ./popcorn
[1] 5033
GnuCOBOL: nums.cob
GnuCOBOL: nums
GnuCOBOL: network
[1]+  Done                    ls -d n* > corncob
$ ls -d n*
network  nums  nums.cob
$ date >corncob & ./popcorn
[1] 5037
GnuCOBOL: Sun Apr 11 08:04:48 EDT 2010
[1]+  Done                    date > corncob

Gnu    >>SOURCE FORMAT IS FIXED
COBOL *> ***************************************************************
      *>  Copyright 2015 Brian Tiffin
      *>   License: GPL v2.1 or later
      *>      Date: 20150216
      *>   Purpose: pipe execute and read, or write
      *> Tectonics: cobc cobweb-pipes.cob substring.c
      *> ***************************************************************
       identification division.
       function-id. pipe-open.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       linkage section.
       01 pipe-command         pic x any length.
       01 pipe-mode            pic x any length.
       01 pipe-record.
          05 pipe-pointer      usage pointer.
          05 filler            usage binary-long.

      *> ***************************************************************
       procedure division using
           pipe-command
           pipe-mode
         returning pipe-record.

       call "popen" using
           by content concatenate(trim(pipe-command), x"00")
           by content concatenate(trim(pipe-mode), x"00")
         returning pipe-pointer
         on exception
             display "link error: popen" upon syserr end-display
             move 255 to return-code
             goback
       end-call

       if pipe-pointer equal null then
           display "exec error: popen" upon syserr end-display
           move 255 to return-code
           goback
       end-if

       goback.
       end function pipe-open.

      *> ***************************************************************
       identification division.
       function-id. pipe-read.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 line-buffer-length   usage binary-long.

       linkage section.
       01 pipe-record-in.
          05 pipe-pointer      usage pointer.
          05 filler            usage binary-long.
       01 line-buffer          pic x any length.
       01 pipe-record-out.
          05 pipe-read-status  usage pointer.
          05 filler            usage binary-long.

      *> ***************************************************************
       procedure division using
           pipe-record-in
           line-buffer
         returning pipe-record-out.

       move length(line-buffer) to line-buffer-length
       call "fgets" using
           by reference line-buffer
           by value line-buffer-length
           by value pipe-pointer
         returning pipe-read-status
         on exception
             display "link error: fgets" upon syserr end-display
             move 255 to return-code
             goback
       end-call

       goback.
       end function pipe-read.

      *> ***************************************************************
       identification division.
       function-id. pipe-write.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 line-buffer-length   usage binary-long.

       linkage section.
       01 pipe-record-in.
          05 pipe-pointer      usage pointer.
          05 filler            usage binary-long.
       01 line-buffer          pic x any length.
       01 pipe-record-out.
          05 filler            usage pointer.
          05 pipe-write-status usage binary-long.

      *> ***************************************************************
       procedure division using
           pipe-record-in
           line-buffer
         returning pipe-record-out.

       call "fputs" using
           by content concatenate(trim(line-buffer), x"00")
           by value pipe-pointer
         returning pipe-write-status
         on exception
             display "link error: fputs" upon syserr end-display
             move 255 to return-code
             goback
       end-call

       goback.
       end function pipe-write.

      *> ***************************************************************
       identification division.
       function-id. pipe-close.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       linkage section.
       01 pipe-record.
          05 pipe-pointer      usage pointer.
          05 filler            usage binary-long.
       01 pclose-status        usage binary-long.

      *> ***************************************************************
       procedure division using pipe-record returning pclose-status.

       call "pclose" using
           by value pipe-pointer
         returning pclose-status
         on exception
             display "link error: pclose" upon syserr end-display
             move 255 to return-code
             goback
       end-call

       goback.
       end function pipe-close.


      *> ***************************************************************
       identification division.
       function-id. pinpoint.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 haystack-address     usage pointer.
       01 result-strstr        usage pointer.

       linkage section.
       01 haystack             pic x any length.
       01 needle               pic x any length.
       01 haystack-offset      usage binary-long.
       01 sub-location         usage binary-long value 0.

      *> ***************************************************************
       procedure division using
           haystack
           needle
           haystack-offset
         returning sub-location.

       call "substring" using
           by content concatenate(trim(haystack), x"00")
           by content concatenate(trim(needle), x"00")
           by value haystack-offset
           returning sub-location
           on exception
               display "link error: strstr" upon syserr end-display
bail           goback
       end-call

       goback.
       end function pinpoint.

      *> ***************************************************************
      *> if an integer is out of range, return a value in range
       identification division.
       function-id. entrammel.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       linkage section.
       01 unknown              usage binary-long.
       01 lowest-acceptable    usage binary-long.
       01 highest-acceptable   usage binary-long.
       01 entrammelled         usage binary-long.

      *> ***************************************************************
       procedure division using
           unknown
           lowest-acceptable
           highest-acceptable
         returning entrammelled.

       if unknown less than lowest-acceptable then
           move lowest-acceptable to entrammelled
       else
           if unknown greater than highest-acceptable then
               move highest-acceptable to entrammelled
           else
               move unknown to entrammelled
           end-if
       end-if

done   goback.

       end function entrammel.
      *> ***************************************************************

      *> ***************************************************************
      *>****F* cobweb/cmove
      *> PURPOSE
      *>   un-c a C string, into a modified occurs depending on table
       identification division.
       function-id. cmove.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 unused-return usage pointer.

       01 peeker usage pointer.
       01 newline-tester pic x based.
          88 trailing-newline value x"0a".

       linkage section.
       01 c-string usage pointer.
       01 cobol-odo-xfield pic x any length.
       01 c-length-as-odo-modified usage binary-long.
       01 strip-newline pic 9.
       01 c-length usage binary-long.

      *> ***************************************************************
       procedure division using
           c-string
           cobol-odo-xfield
           c-length-as-odo-modified
           optional strip-newline
         returning c-length.

      *> copy c-string to working store, limited by incoming odo
       if c-string not equal null then
           call "strlen" using by value c-string returning c-length
               on exception display "no strlen" upon syserr end-display
           end-call

           *> fence in the odo
           if c-length-as-odo-modified greater than
                                       length(cobol-odo-xfield) then
               move length(cobol-odo-xfield) to c-length-as-odo-modified
           end-if

           call "strncpy" using
               by reference cobol-odo-xfield
               by value c-string
               by value c-length-as-odo-modified
               returning unused-return
               on exception display "no strncpy" upon syserr end-display
           end-call
       end-if

      *> modifiy the odo field
       move c-length to c-length-as-odo-modified

      *> handle trailing newlines?
       if not strip-newline omitted then
           if strip-newline not equal zero then
               set peeker to address of cobol-odo-xfield
               set peeker up by c-length
               set peeker down by 1
               set address of newline-tester to peeker
               if trailing-newline then
                   subtract 1 from c-length-as-odo-modified
               end-if
           end-if
       end-if

       goback.
       end function cmove.
      *>****

*> graph to X
if graphing then
    move pipe-open(
        "graph -TX -x 1 13 -y -1000 6000" &
        " -X 'Month' -Y 'Pennies' -S 4", "w")
      to pipe-record
    move pipe-write(pipe-record,
        "1 1234 2 2345 3 3456 4 1234" &
        " 5 4567 6 3456 7 5678 8 2345" &
        " 9 4567 10 3456 11 5678 12 -500")
      to pipe-record-out
    move pipe-close(pipe-record) to return-code
    if return-code not equal 0 then
        display "return-code: " return-code
    end-if
    goback
end-if

-TX             type is X plot, lots of -T types.
-x 1 13         x range is low 1, high 13
-y -1000 6000   y range
-X 'Month'      x-axis label
-Y 'Pennies'    y-axis label
-S 4            sets a Symbol mode 4, the little circles

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20101119
      *> Purpose:   Pass arguments to ROOT/CINT invoked subprograms
      *> Tectonics: cobc -fimplicit-init -C cobparams.cob
      *> ***************************************************************
       identification division.
       program-id. cobparams.

       data division.
       linkage section.
       01 a-number usage binary-long.

      *> ***************************************************************
       procedure division using by reference a-number.
       display a-number end-display
       move a-number to return-code
       goback.
       end program cobparams.

$ cobc -fimplicit-init -C cobparams.cob

$ cobc -fimplicit-init -C cobparams.cob
$ root -l
root [0] gSystem->Load("/usr/local/lib/libcob.so");
root [1] .L cobparams.c+
root [2] int a = 0;
root [3] int d = 42;
root [4] a = cobparams((unsigned char*)&d);
+0000000042
root [5] printf("%d\n", a);
42
root [6]

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20101119
      *> Purpose:   Pass arguments to ROOT/CINT invoked subprograms
      *> Tectonics: cobc -fimplicit-init -C cobparams.cob
      *> ***************************************************************

       REPLACE ==ARRAYSIZE== BY ==450==.

       identification division.
       program-id. cobfloats.

       data division.
       working-storage section.
       01 cnt pic 999.
       01 val usage float-long.
       01 xes.
          02 an-x usage float-long occurs ARRAYSIZE times.
       01 yes.
          02 an-y usage float-long occurs ARRAYSIZE times.

       linkage section.
       01 vxes.
          02 an-x usage float-long occurs ARRAYSIZE times.
       01 vyes.
          02 an-y usage float-long occurs ARRAYSIZE times.

      *> ***************************************************************
       procedure division using by reference vxes, vyes.
       perform varying cnt from 1 by 1 until cnt >= ARRAYSIZE
           compute val = cnt * function random() end-compute
           move cnt to an-x in xes(cnt)
           move val to an-y in yes(cnt)
       end-perform
       move xes to vxes
       move yes to vyes
       move cnt to return-code
       goback.
       end program cobfloats.

$ cobc -fimplicit-init -C cobparams.cob
$ vi cobparams.c
... add a single line
...   #pragma K&R
... to lighten up CINT's type safety for ease of use at the console
$ root -l
root [0] gSystem->Load("/usr/local/lib/libcob.so");
root [1] .L cobparams.c+
root [2] int a = 0; double x[450]; double y[450];
root [3] a = cobfloats(&x, &y);
root [4] a
(int)450
root [5] printf("%f %f\n", x[42], y[42]);
43.000000 8.232543
root [6] TGraph *graph1 = new TGraph(450, x, y);
root [7] graph1->Draw("A*");
root [8] TGraphPolar *polar1 = new TGraphPolar(450, x, y);
root [9] polar1->SetLineColor(2);
root [10] polar1->Draw("AOL");

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140420
      *> Copyright (c) 2014, Brian Tiffin
      *> This free software is licensed under the GPL 2 without warranty
      *> Purpose:   GnuCOBOL minimal micro web server
      *> Tectonics: cobc -x gnucobol-microhttpd.cob -lmicrohttpd
      *> ***************************************************************
       identification division.
       program-id. gnucobol-microhttpd.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 MHD_HTTP_OK               constant   as 200.
       01 MHD_USE_SELECT_INTERNALLY constant   as 8.
       01 MHD_RESPMEM_PERSISTENT    constant   as 0.
       01 MHD_OPTION_END            constant   as 0.

       01 star-daemon               usage pointer.
       01 connection-handler-entry  usage program-pointer.

       01 server-command            pic x(80).

      *> ***************************************************************
       procedure division.
       set connection-handler-entry to
         entry "gnucobol-connection-handler"
       call "MHD_start_daemon" using
           by value MHD_USE_SELECT_INTERNALLY
           by value 8888
           by value 0
           by value 0
           by value connection-handler-entry
           by value 0
           by value MHD_OPTION_END
           returning star-daemon
           on exception
               display
                   "gnucobol-microhttpd: libmicrohttpd failure"
                   upon syserr
               end-display
       end-call
       display "wow, server.  help, info, quit" end-display
       perform until server-command = "quit"
           display "server: " with no advancing end-display
           accept server-command end-accept
           if server-command = "help" then
               display
                   "gnucobol-microhttpd: help, info, quit"
               end-display
           end-if
           if server-command = "info" then
               display
                   "gnucobol-microhttpd: info? help, quit"
               end-display
           end-if
       end-perform

       call "MHD_stop_daemon" using
           by value star-daemon
           on exception
               display
                   "gnucobol-microhttpd: libmicrohttpd failure"
                   upon syserr
               end-display
       end-call

       goback.
       end program gnucobol-microhttpd.
      *> ***************************************************************

      *> ***************************************************************
       identification division.
       program-id. gnucobol-connection-handler.

       data division.
       working-storage section.
       01 MHD_HTTP_OK               constant   as 200.
       01 MHD_RESPMEM_PERSISTENT    constant   as 0.
       01 webpage              pic x(132) value
          "<html><body>" &
          "Hello, world<br/>" &
          "from <b>GnuCOBOL</b> and <i>libmicrohttpd</i>" &
          "</body></html>".
       01 star-response                        usage pointer.
       01 mhd-result                           usage binary-long.

       linkage section.
       01 star-cls                             usage pointer.
       01 star-connection                      usage pointer.
       01 star-url                             usage pointer.
       01 star-method                          usage pointer.
       01 star-version                         usage pointer.
       01 star-upload-data                     usage pointer.
       01 star-upload-data-size                usage pointer.
       01 star-star-con-cls                    usage pointer.
       procedure division using
           by value star-cls
           by value star-connection
           by value star-url
           by value star-method
           by value star-version
           by value star-upload-data
           by value star-upload-data-size
           by reference star-star-con-cls
       .


       display "wow, connection handler" upon syserr end-display
       call "MHD_create_response_from_buffer" using
           by value length of webpage
           by reference webpage
           by value MHD_RESPMEM_PERSISTENT
           returning star-response
           on exception
               display
                   "gnucobol-microhttpd: libmicrohttpd failure"
                   upon syserr
               end-display
       end-call
       call "MHD_queue_response" using
           by value star-connection
           by value MHD_HTTP_OK
           by value star-response
           returning mhd-result
           on exception
               display
                   "gnucobol-microhttpd: libmicrohttpd failure"
                   upon syserr
               end-display
       end-call
       call "MHD_destroy_response" using
           by value star-response
       end-call

       move mhd-result to return-code

       goback.
       end program gnucobol-connection-handler.

      *> ***************************************************************
      *> from libmicrohttpd hellobrowser.c tutorial example
      *> ***************************************************************
      *> #include <sys/types.h>
      *> #include <sys/select.h>
      *> #include <sys/socket.h>
      *> #include <microhttpd.h>
      *>
      *> #define PORT 8888
      *>
      *> static int
      *> answer_to_connection(void *cls, struct MHD_Connection *connection,
      *>                     const char *url, const char *method,
      *>                     const char *version, const char *upload_data,
      *>                     size_t * upload_data_size, void **con_cls)
      *> {
      *>     const char *page = "<html><body>Hello, browser!</body></html>";
      *>     struct MHD_Response *response;
      *>     int ret;
      *>     response =
      *>        MHD_create_response_from_buffer(strlen(page), (void *) page,
      *>                                        MHD_RESPMEM_PERSISTENT);
      *>     ret = MHD_queue_response(connection, MHD_HTTP_OK, response);
      *>     MHD_destroy_response(response);
      *>     return ret;
      *> }
      *>
      *> int main()
      *> {
      *>     struct MHD_Daemon *daemon;
      *>     daemon = MHD_start_daemon(MHD_USE_SELECT_INTERNALLY, PORT, NULL, NULL,
      *>                              &answer_to_connection, NULL, MHD_OPTION_END);
      *>     if (NULL == daemon)
      *>        return 1;
      *>     getchar();
      *>     MHD_stop_daemon(daemon);
      *>     return 0;
      *> }

$ cobc -x gnucobol-microhttpd.cob -lmicrohttpd |$
$ ./gnucobol-microhttpd                        |$ curl http://localhost:8888
wow, server.  help, info, quit                 |<html><body>Hello, world<br/>from <b>GnuCOBOL</b>
server: wow, connection handler                |and <i>libmicrohttpd</i></body></html>
quit                                           |$
$                                              |$ curl http://localhost:8888
                                               |curl: (7) Failed connect to localhost:8888;
                                               |Connection refused
                                               |$

// vala .10 specific.  .11 changes string to uint8 array
// valac -c --pkg libsoup-2.4 --thread soupserver.vala

// Give the server a default
void default_handler (Soup.Server server, Soup.Message msg, string path,
                      GLib.HashTable? query, Soup.ClientContext client)
{
    string response_text = """
        <html>
          <body>
            <p>Current location: %s</p>
            <p><a href="/xml">Test XML</a></p>
            <p><a href="/cobol">Test COBOL</a></p>
            <p><a href="/exit">Tell server to exit</a></p>
          </body>
        </html>""".printf (path);

    msg.set_response ("text/html", Soup.MemoryUse.COPY,
                      response_text, response_text.size ());
    msg.set_status (Soup.KnownStatusCode.OK);
}


void xml_handler (Soup.Server server, Soup.Message msg, string path,
                  GLib.HashTable? query, Soup.ClientContext client)
{
    string response_text = "<node><subnode>test</subnode></node>";
    msg.set_response ("text/xml", Soup.MemoryUse.COPY,
                      response_text, response_text.size ());
}

void cobol_handler (Soup.Server server, Soup.Message msg, string path,
                  GLib.HashTable? query, Soup.ClientContext client)
{
    string response_text = """
        <html>
          <body>
            <p>Current location: %s</p>
            <p><a href="/xml">Test XML</a></p>
            <p><a href="/">Home</a></p>
            <p><a href="/exit">Tell server to exit</a></p>
          </body>
        </html>""".printf (path);

    msg.set_response ("text/html", Soup.MemoryUse.COPY,
                      response_text, response_text.size ());
    msg.set_status (Soup.KnownStatusCode.OK);
}

void exit_handler (Soup.Server server, Soup.Message msg, string path,
                  GLib.HashTable? query, Soup.ClientContext client)
{
    server.quit();
}

int CBL_OC_SOUPSERVER(ref Soup.Server* ss, int port) {
    var server = new Soup.Server(Soup.SERVER_PORT, port);
    server.add_handler("/", default_handler);
    server.add_handler("/xml", xml_handler);
    server.add_handler("/cobol", cobol_handler);
    server.add_handler("/exit", exit_handler);
    ss = (owned)server;
    stdout.printf("ss: %X\n", (uint)ss);
    return 0;
}

int CBL_OC_SOUPRUN(Soup.Server ss) {
    ss.run();
    return 0;
}

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20101205
      *> Purpose:   An HTTP server with libsoup
      *> Tectonics: valac -c --pkg libsoup-2.4 --thread soupserver.vala
      *>            cobc -x ocsoup.cob soupserver.vala.o -lglib-2.0
      *>                 -lsoup-2.4 -lgobject-2.0
      *> ***************************************************************
       identification division.
       program-id. ocsoup.

       data division.
       working-storage section.
       01 soup-server usage pointer.
       01 port usage binary-long value 8088.
       01 result usage binary-long.

      *> ***************************************************************
       procedure division.
       call "g_type_init" end-call
       display "Initialize soup HTTP server on port " port end-display
       call "CBL_OC_SOUPSERVER" using
           by reference soup-server
           by value port
           returning result
       end-call
       display "Result: " result " Server at: " soup-server end-display

       display "About to run server, ^C to terminate" end-display
       call "CBL_OC_SOUPRUN" using
           by value soup-server
           returning result
       end-call

       goback.
       end program ocsoup.

$ valac -c --pkg libsoup-2.4 --thread soupserver.vala
$ ... some warnings about unused methods ...
$ cobc -x ocsoup.cob soupserver.vala.o -lglib-2.0 -lsoup-2.4 -lgobject-2.0
$ ./ocsoup
Initialize soup HTTP server on port +0000008088
ss: 21CF060
Result: +0000000000 Server at: 0x00000000021cf060
About to run server, ^C to terminate

# Create the fossil distributed repository
$ mkdir ~/fossils
$ cd ~/fossils
$ fossil new nextbigthing.fossil

# Serve it up on the localhost port 8080
$ fossil server . &

# browse to the admin panel and do a little nicey nice config
$ opera http://localhost:8080/nextbigthing

# set up the working copy
$ cd ~/projects
$ mkdir nextbigthing
$ cd nextbigthing
$ fossil clone http://localhost:8080/nextbigthing nbt.fossil

# now look at the shiny copy of nextbig
$ ls
$ vi nextbigthing.cob
$ fossil add nextbigthing.cob
$ fossil ci -m "On to the next big thing"

# browse to the repo and create some wiki pages for morale boosting
$ opera http://localhost:8080/nextbigthing

# compile and run the next big thing
$ cobc -x nextbigthing.cob
$ ./nextbigthing

# browse again, and create the bug tickets
$ opera http://localhost:8080/nextbigthing/tktnew

all: rgbcobol

libcolors.so: colors.for
    gfortran -ffree-form -shared -fPIC -o libcolors.so colors.for

rgbcobol: rgbcobol.cob libcolors.so
    cobc -g -debug -x rgbcobol.cob -lcolors -L .

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20110411
      *> Purpose:   Call a FORTRAN color unit converter, rgb, hsv, ...
      *> Tectonics: gfortran -ffree-form -shared -fPIC
      *>                -o libcolors.so colors.for
      *>            cobc -x rgbcobol.cob -lcolors -L .
      *> ***************************************************************
       identification division.
       program-id. rgbcobol.

       data division.
       working-storage section.
       01 r usage float-short.
       01 g usage float-short.
       01 b usage float-short.

       01 h usage float-short value 12.21.
       01 l usage float-short value 21.12.
       01 s usage float-short value 23.32.

       01 st usage binary-long.

      *> ***************************************************************
       procedure division.
       move 000.0 to h
       move 050.0 to l
       move 100.0 to s
       display "Calling FORTRAN with " h space l space s end-display
       call "jucolor_" using 'hls', h, l, s, 'rgb', r, g, b, st end-call
       display "Returned             " r space g space b end-display
       display "Status of " st end-display
       call "showit_" end-call
       goback.
       end program rgbcobol.


 [btiffin@home fortran]$ ./rgbcobol
 Calling FORTRAN with 0.000000000000000000 50.000000000000000000 100.000000000000000000
  inside jucolor_:    0.0000000       0.0000000       50.000000       0.0000000       100.00000       0.0000000
 Returned             100.000000000000000000 0.000000000000000000 0.000000000000000000
 Status of +0000000000
  inside jucolor_:    0.0000000       0.0000000       50.000000       595.19684       100.00000      4.57103559E-41
  INPUT HLS PURE RED ==> OUTPUT RGB values are    100.00000       0.0000000       0.0000000
 ================================================================================
  inside jucolor_:    120.00000       100.00000       50.000000       0.0000000       100.00000       0.0000000
  INPUT HLS PURE GREEN OUTPUT RGB values are    0.0000000       100.00000       0.0000000
 ================================================================================
  inside jucolor_:    240.00000       0.0000000       50.000000       100.00000       100.00000       0.0000000
  INPUT HLS PURE BLUE OUTPUT RGB values are    0.0000000       0.0000000       100.00000
 ================================================================================
  inside jucolor_:    100.00000       0.0000000       0.0000000       0.0000000       0.0000000       0.0000000
  INPUT RGB PURE RED OUTPUT HLS values are    0.0000000       50.000000       100.00000
 ================================================================================
  inside jucolor_:    0.0000000       0.0000000       100.00000       50.000000       0.0000000       100.00000
  INPUT RGB PURE GREEN OUTPUT HLS values are    120.00000       50.000000       100.00000
 ================================================================================
  inside jucolor_:    0.0000000       120.00000       0.0000000       50.000000       100.00000       100.00000
  INPUT RGB PURE BLUE OUTPUT HLS values are    240.00000       50.000000       100.00000
  values are    240.00000       50.000000       100.00000
 ================================================================================


GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20110711
      *> Purpose:   Attempt calling a J sentence. APL in COBOL.
      *> Tectonics: cobc -x callj.cob -lj
      *> ***************************************************************
       identification division.
       program-id. callj.

       data division.
       working-storage section.
       77 jptr usage pointer.
       77 result usage binary-long.

      *> ***************************************************************
       procedure division.
       call "JInit" returning jptr end-call
       display jptr end-display

       call "JDo"
           using by value jptr
           by content z"a =. 1 + 1"
           returning result
       end-call
       display result end-display

       call "JDo"
           using by value jptr
           by content z"2 + 2"
           returning result
       end-call
       display result end-display

       call "JDo"
           using by value jptr
           by content z"('Test Data',CR,LF) 1!:2 <'temp.dat'"
           returning result
       end-call
       display result end-display

       call "JDo"
           using
             by value jptr
             by content z"load 'jgplsrc/test/test.ijs'"
           returning result
       end-call
       display result end-display

       call "JDo"
           using
             by value jptr
             by content z"bad=: TEST ddall"
           returning result
       end-call
       display result end-display

       call "JDo"
           using
             by value jptr
             by content z"BAD ddall"
           returning result
       end-call
       display result end-display
       goback.
       end program callj.

$ cobc -x callj.cob -lj
$ ./callj
0x00007f3b6ead7010
+0000000000
+0000000000
+0000000003
+0000000021
+0000000000
+0000000000

$ bin/build_defs
$ bin/build_tsdll

A test suite validates a J system. Read test/test.ijs and test/tsu.ijs for
more info.

$ j/bin/jconsole
   load 'test/test.ijs'
   bad=: TEST ddall NB. run all tests
   BAD ddall NB. report tests that failed

<INIT>
    <SETNAME> SUITE-DELIVERY-COST
    <SETDESC> Tests Suite for delivery costs
<ADDSUITE>
       * Add a test
       <SETNAME> FRANCE-TO-ITALY
       <SETPROG> TS000011
       <SETDESC> IF FROM='FR' and TO='IT' then TAXES=120€
<ADDTEST>
<RUN>

***************************************************************************
COBOL UNIT : A COBOL FRAMEWORK FOR UNIT TESTS.
***************************************************************************


COBOL UNIT Current release  : REL 1.00
COBOL UNIT Release date     : 2009-10-31
Language used for Logging   : EN
Verbosity Level of Log      : 1
End of the 'Testing Strategy Set up' Phase
Starting the 'Test Execution' Phase
|--- SUITE ' SUITE-DELIVERY-COST ' Running
|--- | TEST ' FRANCE-TO-ITALY ' Running
|    |- Assert ' FR => IT:TAX=120 ' success
|    |==> Test ' FRANCE-TO-ITALY ' * SUCCESS *
|    |      ( 000000001 Assertions, 000000000 Failures, 0 errors).
|==> SUITE ' SUITE-DELIVERY-COST ' SUCCESS
|    ( 000000000 test cases, 000000001 success, 000000000 failures, 000000000 errors)

***************************************************************************
* SUCCESS * ( 000000001 Suites run, 000000001 succeed, 000000000 failed)
***************************************************************************
( 00 min: 00 sec: 00 ms)

GCobol
         ENTRY "startGrid".
         MOVE FCHIUSO TO GRID-FILE-STATE.
         ACCEPT SOLODATA FROM DATE YYYYMMDD.
         ACCEPT ORA FROM TIME.
         MOVE DATAEORA TO STARTINGPOINT, PRMR-KEY-OF-LIGNE (GAP),
            DATAEORA-KR.
         PERFORM RWDWN.
         MOVE 0 TO RETURN-CODE.
         GOBACK.

         ENTRY "fillrow" USING BY REFERENCE pRiga,
                               BY VALUE     numRiga.
         ADD 1 TO numRiga.
         MOVE SUPER-LIGNE-PMP (numRiga) TO ROW-OUT.
         SET pRiga TO ADDRESS OF ROW-OUT.
         MOVE 0 TO RETURN-CODE.
         GOBACK.

Extern cob_init(argc As Integer, argv As Integer) As Integer In "libcob"
Extern startGrid() As Integer In "SCONTO:69"

$ sudo yum install llvm clang clang-analyzer clang-devel
$ export CC=clang
$ ./configure
GnuCOBOL Configuration:
  CC                   clang
  COB_CC               clang
  CFLAGS                -O2
  COB_CFLAGS           -I/usr/local/include
  COB_EXTRA_FLAGS
  LDFLAGS
  COB_LDFLAGS
  COB_LIBS             -L${exec_prefix}/lib -lcob -lm -lgmp -lncurses -ldb
  COB_CONFIG_DIR       ${prefix}/share/open-cobol/config
  COB_COPY_DIR         ${prefix}/share/open-cobol/copy
  COB_LIBRARY_PATH     ${exec_prefix}/lib/open-cobol
  COB_MODULE_EXT       so
  COB_SHARED_OPT       -shared
  COB_PIC_FLAGS        -fPIC -DPIC
  COB_EXPORT_DYN       -Wl,--export-dynamic
  COB_STRIP_CMD        strip --strip-unneeded
  Dynamic loading      System

$ scan-build make
scan-build: Removing directory '/tmp/scan-build-2012-05-23-2'
   because it contains no reports.

$ make check

# I had to make one change to cobc/cobc.c to remove -fno-gcse to avoid a
#  bunch of make check 'failures' due to a warning about unused -fno-gcse

$ sudo make install
$ sudo ldconfig

# cobc is built with clang, and uses clang when compiling
#   the .c generated from the .cob.

[btiffin@cobol]$ scan-build cobc -v -x hello.cob
scan-build: 'clang' executable not found in
    '/usr/lib64/clang-analyzer/scan-build/bin'.
scan-build: Using 'clang' from path: /usr/bin/clang
preprocessing hello.cob into /tmp/cob18158_0.cob
translating /tmp/cob18158_0.cob into /tmp/cob18158_0.c
clang -pipe -c -I/usr/local/include   -Wno-unused -fsigned-char
    -Wno-pointer-sign  -o /tmp/cob18158_0.o /tmp/cob18158_0.c
clang -pipe  -Wl,--export-dynamic -o hello /tmp/cob18158_0.o
    -L/usr/local/lib -lcob -lm -lgmp -lncurses -ldb
scan-build: Removing directory '/tmp/scan-build-2012-05-23-2'
    because it contains no reports.

[btiffin@cobol]$ ./hello
Hello
[btiffin@cobol]$ ls -la hello
-rwxrwxr-x. 1 btiffin btiffin 9630 May 23 12:37 hello

prompt$ ./configure --with-python
prompt$ make
prompt$ make check
prompt$ sudo make install
prompt$ sudo ldconfig

prompt$ ./configure --with-vbisam --with-rexx --with-python

      *>
      *> withpython.cob, embedded Python intrinsic
      *> Tectonics: cobc -xj withpython.cob
      *>
       >>SOURCE FORMAT IS FREE
       identification division.
       program-id. withpython.

       REPLACE ==newline== BY ==& x'0a' &==.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 answer                       pic x(80).       
       
       procedure division.
       sample-main.
       move python(
           "from time import time,ctime"                        newline
           "print('Python: Today is', ctime(time()))"           newline
           " "                                                  newline
           "def func(arg):"                                     newline
           "    return [ctime(time()), arg/2, arg, arg*2]"      newline
           " "                                                  newline
           "result = func(42)") to answer
       display "COBOL: " trim(answer)
       goback.
       end program withpython.

prompt$ cobc -xj withpython.cob
Python: Today is Sun Apr 23 01:49:07 2017
COBOL: ['Sun Apr 23 01:49:07 2017', 21.0, 42, 84]

       identification division.
       program-id. numbers.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 result pic s9(9).

       procedure division.
       display ":" python("print(6 * 7 * -1)") ":"
       
       move python("result = 6 * 7 * -1") to result
       display ":" result ":"

       display ":" python("result = {'value': 6 * 7 * -1}") ":"
       goback.
       end program numbers.

prompt$ cobc -xj python-number.cob
-42
::
:-000000042:
:{'value': -42}:

GCobol >>SOURCE FORMAT IS FIXED
      *> *******************************************************
      *> Author:    Brian Tiffin
      *> Date:      20130126
      *> Purpose:   Embed Python
      *> Tectonics: cobc -x cobpy.cob -lpython2.6
      *> *******************************************************
       identification division.
       program-id. cobpy.

       procedure division.
       call "Py_Initialize"
           on exception
               display "link cobpy with -lpython2.6" end-display
       end-call
       call "PyRun_SimpleString" using
           by reference
               "from time import time,ctime" & x"0a" &
               "print('Today is', ctime(time()))" & x"0a" & x"00"
           on exception continue
       end-call
       call "Py_Finalize" end-call
       goback.
       end program cobpy.

$ cobc -x cobpy.cob -lpython2.6
$ ./cobpy
('Today is', 'Sat Jan 26 20:01:41 2013')

GCobol >>SOURCE FORMAT IS FIXED
      *> *******************************************************
      *> Author:    Brian Tiffin
      *> Date:      20130126
      *> Modified:  2016-03-08/00:02-0500
      *> Copyright 2013,2016 Brian Tiffin
      *> Licensed under the GNU Library Public License, LGPL 2+
      *> Purpose:   Embed Python
      *> Tectonics: cobc -x cobkat.cob -lpython2.7
      *>     NOTES:    leaks, no Py_DECREF macros called.
      *> *******************************************************
       identification division.
       program-id. cobkat.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       77 python-name          usage pointer.
       77 python-module        usage pointer.
       77 python-dict          usage pointer.
       77 python-func          usage pointer.
       77 python-stringer      usage pointer.
       77 python-args          usage pointer.
       77 python-value         usage pointer.

       01 cobol-buffer-pointer usage pointer.
       01 cobol-buffer         pic x(80)               based.
       01 cobol-string         pic x(80).

       01 cobol-integer        usage binary-long.
       01 command-line-args    pic x(80).
       01 python-path          pic x(256).

      *> *******************************************************
       procedure division.

       REPLACE ==:CALL-EXCEPTION:== BY
       ==
           on exception
               display "internal python call problem" upon syserr
               perform soft-exception
       ==.

      *> Set the python search path to include current working dir first
       accept python-path from environment "PYTHONPATH"
       move concatenate(".:" python-path) to python-path
       set environment "PYTHONPATH" to python-path

      *> if python init fails, just bail
       call "Py_Initialize"
           on exception
               display "link cobpy with -lpython" upon syserr
               perform hard-exception
       end-call

      *> Python likes module names in Unicode
       call "PyUnicodeUCS4_FromString" using
           by reference "pythonfile" & x"00"
           returning python-name
           :CALL-EXCEPTION:
       end-call

      *> import the module, using PYTHONPATH
       call "PyImport_Import" using
           by value python-name
           returning python-module
           on exception
               display "module import failure" upon syserr
               perform hard-exception
       end-call
       call "Py_DecRef" using
           by value python-name
           :CALL-EXCEPTION:
       end-call

       if python-module equal null
           display "no pythonfile.py in PYTHONPATH" end-display
           goback
       end-if

      *> within the module, an attribute is "pythonfunction"
       call "PyObject_GetAttrString" using
           by value python-module
           by reference "pythonfunction" & x"00"
           returning python-func
           :CALL-EXCEPTION:
       end-call

      *> pythonfunction takes a single argument
       call "PyTuple_New" using
           by value 1
           returning python-args
           :CALL-EXCEPTION:
       end-call

      *> of type long, hard coded to the ultimate answer
       call "PyLong_FromLong" using
           by value 42
           returning python-value
           :CALL-EXCEPTION:
       end-call

      *> set first (only) element of the argument tuple
       call "PyTuple_SetItem" using
           by value python-args
           by value 0
           by value python-value
           :CALL-EXCEPTION:
       end-call

       display "Call pythonfunction from pythonfile.py with 42"

      *> call the function, arguments marshalled for Python
       call "PyObject_CallObject" using
           by value python-func
           by value python-args
           returning python-value
           :CALL-EXCEPTION:
       end-call

      *> we know we get a long back, hopefully 1764
       call "PyLong_AsLong" using
           by value python-value
           returning cobol-integer
           :CALL-EXCEPTION:
       end-call
       display "Python returned: " cobol-integer end-display

      *> Clean up the long, tuple, and function handle
       call "Py_DecRef" using
           by value python-value
           :CALL-EXCEPTION:
       end-call
       call "Py_DecRef" using
           by value python-args
           :CALL-EXCEPTION:
       end-call
       call "Py_DecRef" using
           by value python-func
           :CALL-EXCEPTION:
       end-call

      *> *******************************************************
      *> a function taking string and returning string
       call "PyObject_GetAttrString" using
           by value python-module
           by reference "pythonstringer" & x"00"
           returning python-stringer
           :CALL-EXCEPTION:
       end-call

       call "PyTuple_New" using
           by value 1
           returning python-args
           :CALL-EXCEPTION:
       end-call

      *> Use the GnuCOBOL command argument
       accept command-line-args from command-line end-accept
       display "Call 'pythonstringer' from pythonfile.py with " quote
           trim(command-line-args) quote

       call "PyString_FromString" using
           by reference
               function concatenate(
                   function trim(command-line-args)
                   x"00")
           returning python-value
           :CALL-EXCEPTION:
       end-call

      *> Set the function argument tuple to the cli args
       call "PyTuple_SetItem" using
           by value python-args
           by value 0
           by value python-value
           :CALL-EXCEPTION:
       end-call

      *> call the "pythonstringer" function
       call "PyObject_CallObject" using
           by value python-stringer
           by value python-args
           returning python-value
           :CALL-EXCEPTION:
       end-call

      *> return as String (with the MD5 hex digest tacked on)
       call "PyString_AsString" using
           by value python-value
           returning cobol-buffer-pointer
           :CALL-EXCEPTION:
       end-call

      *> one way of removing null while pulling data out of C
       set address of cobol-buffer to cobol-buffer-pointer
       string
           cobol-buffer delimited by x"00"
           into cobol-string
       end-string
       display "Python returned: " cobol-string end-display

      *> Clean up the string, tuple, function and the module
       call "Py_DecRef" using
           by value python-value
           :CALL-EXCEPTION:
       end-call
       call "Py_DecRef" using
           by value python-args
           :CALL-EXCEPTION:
       end-call
       call "Py_DecRef" using
           by value python-stringer
           :CALL-EXCEPTION:
       end-call
       call "Py_DecRef" using
           by value python-module
           :CALL-EXCEPTION:
       end-call

      *> and clear out
       call "Py_Finalize" :CALL-EXCEPTION: end-call
       goback.

      *> *******************************************************
       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:
       end program cobkat.

#
# Simple Python sample for GnuCOBOL embedding trial
#
def pythonfunction(i):
    return i * i

import hashlib
def pythonstringer(s):
    sum = hashlib.md5()
    sum.update(s)
    return s + ": " + sum.hexdigest()

prompt$ cobc -x -debug cobkat.cob -lpython2.7
prompt$ ./cobkat
Call pythonfunction from pythonfile.py with 42
Python returned: +0000001764
Call 'pythonstringer' from pythonfile.py with ""
Python returned: : d41d8cd98f00b204e9800998ecf8427e

prompt$ ./cobkat Python will use this for MD5 hash
Call pythonfunction from pythonfile.py with 42
Python returned: +0000001764
Call 'pythonstringer' from pythonfile.py with "Python will use this for MD5 hash"
Python returned: Python will use this for MD5 hash: c5577e3ab8dea11adede20a1949b5fb3

set environment "PYTHONPATH" to "."

/*******************************************************
** f i c l . h
** Forth Inspired Command Language
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
** Dedicated to RHS, in loving memory
** $Id: //depot/gamejones/ficl/ficl.h#33 $
********************************************************
**
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
** All rights reserved.
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
** I am interested in hearing from anyone who uses Ficl. If you have
** a problem, a success story, a defect, an enhancement request, or
** if you would like to contribute to the Ficl release, please
** contact me by email at the address above.
**
** L I C E N S E  and  D I S C L A I M E R
**
** Redistribution and use in source and binary forms, with or without
** modification, are permitted provided that the following conditions
** are met:
** 1. Redistributions of source code must retain the above copyright
**    notice, this list of conditions and the following disclaimer.
** 2. Redistributions in binary form must reproduce the above copyright
**    notice, this list of conditions and the following disclaimer in the
**    documentation and/or other materials provided with the distribution.
**
** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
** ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
** SUCH DAMAGE.
*/

GCobol >>SOURCE FORMAT IS FIXED
      *> ******************************************************
      *> Author:    Brian Tiffin
      *> Date:      20130220
      *> Purpose:   Embed ficl
      *> Tectonics: cobc -x callficl.cob -lficl -L.
      *>            LD_LIBRARY_PATH=. ./callficl
      *> ******************************************************
       identification division.
       program-id. callficl.

       data division.
       working-storage section.
       01 ficl-result usage binary-long.
       01 ficl-system usage pointer.
       01 ficl-vm     usage pointer.

      *> ******************************************************
       procedure division.
       call "ficlSystemCreate" using
           by value 0
           returning ficl-system
       end-call

       display ficl-system end-display

       call "ficlSystemCompileExtras" using
           by value ficl-system
       end-call

       call "ficlSystemCreateVm" using
           by value ficl-system
           returning ficl-vm
       end-call

       display ficl-vm end-display

       call "ficlVmEvaluate" using
           by value ficl-vm
           by reference ".ver cr quit" & x"00"
           returning ficl-result
       end-call

       display ficl-result end-display

       call "ficlVmEvaluate" using
           by value ficl-vm
           by reference
               ".( loading ooptest.fr ) cr load ooptest.fr" &
               x"0a" & " cr" & x"00"
           returning ficl-result
       end-call

       display ficl-result end-display

       goback.
       end program callficl.

\ OOP test stuff

only
also oop definitions

object subclass c-aggregate
c-byte obj: m0
c-byte obj: m1
c-4byte obj: m2
c-2byte obj: m3
end-class

object --> sub class1

cell: .a
cell: .b
: init
    locals| class inst |
    0 inst class --> .a !
    1 inst class --> .b !
;
end-class

class1 --> new c1inst

class1 --> sub class2
cell: .c
cell: .d

: init
    locals| class inst |
    inst class --> super --> init
    2 inst class --> .c !
    3 inst class --> .d !
;
end-class

class2 --> new c2inst

object subclass c-list
c-list ref: link
c-ref  obj: payload
end-class

\ test stuff from ficl.html
.( metaclass methods ) cr
metaclass --> methods

cr .( c-foo class ) cr
object --> sub c-foo
cell: m_cell1
    4 chars: m_chars
    : init   ( inst class -- )
        locals| class inst |
        0 inst class --> m_cell1 !
        inst class --> m_chars 4 0 fill
        ." initializing an instance of c_foo at " inst x. cr
    ;
end-class

.( c-foo instance methods... ) cr
c-foo --> new foo-instance
cr
foo-instance --> methods
foo-instance --> pedigree
cr
foo-instance 2dup
    --> methods
    --> pedigree
cr
c-foo --> see init
cr
foo-instance --> class --> see init

$ make -f Makefile.linux
$ make -f Makefile.linux main

$ cobc -g -debug -x callficl.cob -lficl -L .
$ LD_LIBRARY_PATH=. ./callficl
loading CORE EXT words
loading SEARCH & SEARCH-EXT words
loading Johns-Hopkins locals
loading MARKER
loading ficl O-O extensions
loading ficl utility classes
loading ficl string class
0x080569c0
0x08057928
Ficl version 4.0.31

-0000000056
loading ooptest.fr
metaclass methods
metaclassmethods:
debug   see     pedigree        methods id      offset-of       sub
resume-class    ref     allot-array     allot   alloc-array     alloc
new-array       new     array   instance        get-super       get-wid
get-size        .size   .wid    .super  .do-instance
Dictionary: 24 words, 7786 cells used of 12288 total



c-foo class
c-foo instance methods...
initializing an instance of c_foo at 806043C

c-foomethods:
init    m_chars m_cell1 .do-instance
Dictionary: 4 words, 7893 cells used of 12288 total

objectmethods:
debug   prev    next    index   methods size    pedigree        super
free    array-init      init    class   .do-instance
Dictionary: 13 words, 7893 cells used of 12288 total


c-foo object

c-foomethods:
init    m_chars m_cell1 .do-instance
Dictionary: 4 words, 7893 cells used of 12288 total

objectmethods:
debug   prev    next    index   methods size    pedigree        super
free    array-init      init    class   .do-instance
Dictionary: 13 words, 7893 cells used of 12288 total


c-foo object

: init
   0   (link) (instruction 136)
   1   2 (instruction 2)
   2   (toLocal) (instruction 140), with argument 0 (0)
   4   (toLocal) (instruction 140), with argument 1 (0x1)
   6   0 (instruction 17)
   7   (@local1) (instruction 146)
   8   (@local0) (instruction 142)
   9   s" m_cell1"
  13   exec-method
  14   ! (instruction 57)
  15   (@local1) (instruction 146)
  16   (@local0) (instruction 142)
  17   s" m_chars"
  21   exec-method
  22   4 (instruction 4)
  23   0 (instruction 17)
  24   fill (instruction 111)
  25   s" initializing an instance of c_foo at "
  36   type
  37   (@local1) (instruction 146)
  38   x.
  39   cr
  40   (unlink) (instruction 137)
;

: init
   0   (link) (instruction 136)
   1   2 (instruction 2)
   2   (toLocal) (instruction 140), with argument 0 (0)
   4   (toLocal) (instruction 140), with argument 1 (0x1)
   6   0 (instruction 17)
   7   (@local1) (instruction 146)
   8   (@local0) (instruction 142)
   9   s" m_cell1"
  13   exec-method
  14   ! (instruction 57)
  15   (@local1) (instruction 146)
  16   (@local0) (instruction 142)
  17   s" m_chars"
  21   exec-method
  22   4 (instruction 4)
  23   0 (instruction 17)
  24   fill (instruction 111)
  25   s" initializing an instance of c_foo at "
  36   type
  37   (@local1) (instruction 146)
  38   x.
  39   cr
  40   (unlink) (instruction 137)
;

-0000000257

/* like FICL_VM_STATUS_ERROR_EXIT, but leave dataStack & base alone */
#define FICL_VM_STATUS_QUIT         ( -56)
#define FICL_VM_STATUS_OUT_OF_TEXT  (-257)   /* hungry - normal exit */

GCobol*> *******************************************************
      *> Author:    Brian Tiffin
      *> Date:      20130224
      *> Purpose:   COBOL meets Shakespeare
      *> Tectonics: cobc -x -Ispl cobill.cob ocshake.c
      *>                    spl/libspl.c spl/strutils.c
      *>   pre-req: spl2c ocshake.spl and an spl/ distribution
      *> *******************************************************
       identification division.
       program-id. cobill.
       procedure division.
       call "ocshake" end-call
       goback.
       end program cobill.

The derp in SPL from GnuCOBOL.

Ajax, the loud mouth.

Dorcas, the d.
Escalus, the e.
Rosalind, the r.
Prospero, the p.
The Archbishop of Canterbury, the new line.


                    Act I: derping.

                    Scene I: derp.

[Enter Ajax and Dorcas]

Ajax:
    You amazing beautiful fine charming gentle delicious door.
    You are as honest as the sum of a bold brave hard proud
        noble stone wall and thyself.
    You are as trustworthy as the sum of a proud rich tree and thyself.
    Speak your mind.

[Exit Dorcas]
[Enter Escalus]

Ajax:
    You bluest peaceful smooth lovely warm embroidered summer's day.
    You are as beautiful as the sum of a fine honest
        fair sweet gentle wind and thyself.
    You are as lovely as the sum of a reddest sunny flower and thyself.
    You are as mighty as the sum of the sky and thyself.
    Speak your mind.

[Exit Escalus]
[Enter Rosalind]

Ajax:
    You fair reddest sweet rich smooth blossoming red rose.
    You are as rich as the difference between thyself and
        a golden gentle clearest wind.
    You are as rich as the difference between thyself and a proud white lantern.
    You are as rich as the difference between thyself and a honest morning.
    Speak your mind.

[Exit Rosalind]
[Enter Prospero]

Ajax:
    You proud prompt pretty loving gentle warm purple pony.
    You are as bold as the difference between thyself and an amazing
        cute delicious pretty purse.
    Speak your mind.

[Exeunt]

                    Scene II: a new line.

[Enter Ajax and The Archbishop of Canterbury]

Ajax:
    You are nothing.
    You are a bold beautiful blossoming wind.
    You are as cunning as the sum of thyself and a tiny thing.
    Speak your mind!

[Exeunt]

cobill: ocshake.spl cobill.cob
    spl/spl2c <ocshake.spl >ocshake.c
    sed -i 's/int main(void)/int ocshake(void)/' ocshake.c
    cobc -x -Ispl cobill.cob ocshake.c spl/libspl.c spl/strutils.c

$ make
spl/spl2c <ocshake.spl >ocshake.c
sed -i 's/int main(void)/int ocshake(void)/' ocshake.c
cobc -x -Ispl cobill.cob ocshake.c spl/libspl.c spl/strutils.c
$ ./cobill
derp
$

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20130226
      *> Purpose:   Embed Ruby for effect, no data exchange yet
      *> Tectonics: cobc -x callruby.cob -lruby1.8
      *> ***************************************************************
       identification division.
       program-id. callruby.

       procedure division.
       display "GnuCOBOL: initialize ruby" end-display
       call "ruby_init"
           on exception
               display "hint: link with -lruby1.8" end-display
               stop run giving 1
       end-call

       display "GnuCOBOL: evaluate ruby string" end-display
       call "rb_eval_string" using
           by content "puts 'Hello, world'" & x"00"
       end-call

       display "GnuCOBOL: evaluate ruby script.rb" end-display
       call "ruby_init_loadpath" end-call
       call "rb_load_file" using
           by content "script.rb" & x"00"
       end-call
       call "ruby_exec" end-call

       call "ruby_finalize" end-call
       display "GnuCOBOL: finalized ruby" end-display

       goback.
       end program callruby.

puts 'Hello, script'
puts 6*7
puts 'Goodbye, script'

$ cobc -x callruby.cob
$ ./callruby
GnuCOBOL: initialize ruby
hint: link with -lruby1.8

$ cobc -x callruby.cob -lruby1.8
$ ./callruby
GnuCOBOL: initialize ruby
GnuCOBOL: evaluate ruby string
Hello, world
GnuCOBOL: evaluate ruby script.rb
Hello, script
42
Goodbye, script
GnuCOBOL: finalized ruby

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/callmruby
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20151217  Modified: 2015-12-17/06:35-0500
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or greater)
      *> PURPOSE
      *>   callmruby program.
      *> TECTONICS
      *>   cobc -x -g -debug callmruby.cob -L. -lmruby
      *> ***************************************************************
       identification division.
       program-id. callmruby.
       author. Brian Tiffin.
       date-written. 2015-12-17/04:49-0500.
       date-modified. 2015-12-17/06:35-0500.
       installation. Requires libmruby.a in working dir
       remarks. May cause warnings from CALL static
       security. Script evaluator, so...

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 mrb-state usage pointer.
       01 mrb-result usage binary-long.

       01 mruby-code.
          05 value '4.times {|i| print "looping mruby #{i+1} time";' &
                   z"puts i+1 == 1 ? '.' : 's.'}".

      *> ***************************************************************
       procedure division.
       call static "mrb_open" returning mrb-state

       if mrb-state equal null then
           display "Error starting mruby" upon syserr
           perform hard-exception
       end-if
       call static "mrb_load_string" using
           by value mrb-state by reference mruby-code
           returning mrb-result

       call static "mrb_close" using by value mrb-state

       goback.
      *> ***************************************************************

      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .

       end program callmruby.
      *> ***************************************************************
      *>****
>>ELSE
!doc-marker!
=========
callmruby
=========

.. contents::

Introduction
------------

Tectonics
---------

::

    prompt$ cobc -x callmruby.cob -L. -lmruby

For less warnings, due to CALL static::

    prompt$ cobc -xj callmruby.cob -L. -lmruby -A '-Wno-implicit-function-declaration
-Wno-int-to-pointer-cast'

Usage
-----

::

    prompt$ ./callmruby

Source
------

.. include::  callmruby.cob
   :code: cobolfree
   :end-before: !doc-marker
>>END-IF

prompt$ cobc -xj callmruby.cob -L. -lmruby -A '-Wno-implicit-function-declaration
-Wno-int-to-pointer-cast'
looping mruby 1 time.
looping mruby 2 times.
looping mruby 3 times.
looping mruby 4 times.

prompt$ sudo yum install pure pure-devel pure-gen pure-doc

#!/usr/bin/pure -x
using system;
puts "Hello, world";

using "lib:hellocobol";
extern int hellocobol();

hellocobol;

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************
      *> Author:    Brian Tiffin
      *> Date:      20130612
      *> Purpose:   Call this COBOL program from pure
      *> Tectonics: cobc -fimplicit-init hellocobol.cob
      *>            pure -L. hellooc.pure
      *> ***************************************************
       identification division.
       program-id. hellocobol.

       procedure division.
       display "S'up?" end-display

       goback.
       end program hellocobol.

$ cobc hellocobol.cob
$ pure -L. hellooc.pure
Hello, world
Segmentation fault

$ cobc -fimplicit-init hellocobol.cob
$ pure -L. hellooc.pure
Hello, world
S'up?

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************
      *> Author:    Brian Tiffin
      *> Date:      20130612
      *> Purpose:   Call pure.  Nice.
      *> Tectonics: pure -o hello.o -c -x hello.pure 8
      *             cobc -x callpurefact.cob hello.o -lpure
      *> ***************************************************
       identification division.
       program-id. callpurefact.

       data division.
       working-storage section.
       01 pure-arg-pointer       usage pointer.
       01 fact-function-pointer  usage program-pointer.
       01 fact-result-pointer    usage pointer.
       01 pure-result            usage binary-long.
       01 fact-answer            usage binary-long.

      *> ***************************************************

       procedure division.

      *> Initialize pure, with empty argc argv.
       call "__pure_main__" using
           by value 0 by value 0
       end-call

      *> convert a 9 to a pure expression pointer argument
       call "pure_int" using
           by value 9
           returning pure-arg-pointer
       end-call

      *> resolve the link address to the function, "fact"
       set fact-function-pointer to entry "fact"

      *> call the pure function "fact"
      *>   using the program pointer
      *>   1 as the number of argumments
      *>   the address of the argument expression
      *>   returing a result expression pointer
       call "pure_funcall" using
           by value fact-function-pointer
           by value 1
           by value pure-arg-pointer
           returning fact-result-pointer
       end-call

      *> convert the result expression back to integer
       call "pure_is_int" using
           by value fact-result-pointer
           by reference fact-answer
           returning pure-result
       end-call
       display "fact 9 expecting 362880" end-display
       display "fact 9 result is " fact-answer end-display

       goback.
       end program callpurefact.
      *><*

using system;

fact n = if n>0 then n*fact (n-1) else 1;

main n = do puts ["Hello, world!", str (map fact (1..n))];

const n = if argc>1 then sscanf (argv!1) "%d" else 10;
if compiling then () else main n;

$ pure -o hello.o -c -x hello.pure 8
$ cobc -g -debug -W -x callpurefact.cob -lpure hello.o
$ ./callpurefact
Hello, world!
[1,2,6,24,120,720,5040,40320]
fact 9 expecting 362880
fact 9 result is +0000362880

01 c-char-star    usage pointer.
01 cobol-char     pic x based.
01 previous-char  pic x.

call "c-function" returning c-char-star end-call
if c-char-star equal null then
    display "all that work, for nothing?" end-display
    goback
end-if

set address of cobol-char to c-char-star
if cobol-char not equal to low-value
    move cobol-char to previous-char

    perform until cobol-char equal low-value
        set c-char-star up by 1
        set address of cobol-char to c-char-star

        if cobol-char equal low-value then
            display previous-char end-display
        else
            display previous-char with no advancing end-display
            move cobol-char to previous-char
        end-if
    end-perform
end-if

display OMITTED end-display

set address of c-char-buffer to c-char-star
string c-char-buffer delimited by x"00"
    into cobol-space
end-string

/**
 * Access a C external variable for the environment space
 */

#include <unistd.h>
extern char **environ;

char **value_of_environ() {
    return environ;
}

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> *****************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140321
      *> Purpose:   Display the process environment space
      *> License:   This source code is placed in the Public Domain
      *> Tectonics: cobc -x printenv.cob value-of-environ.c
      *> ******************************************************
       identification division.
       program-id. printenv.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 environ              usage pointer.
       01 envptr               usage pointer based.
       01 envbuf               pic x(8388608) based.
       01 charindex            usage index.

       >>DEFINE WINDIR PARAMETER
       >>IF WINDIR IS DEFINED
       01 newline              pic xx value x"0d0a".
       >>ELSE
       01 newline              pic x value x"0a".
       >>END-IF

      *> ******************************************************
       procedure division.
       call "value_of_environ" returning environ
           on exception
               display
                   "could not get value of environ" upon syserr
               end-display
       end-call

      *> Dereference the pointer to the array of pointers
       set address of envptr to environ
       perform until exit
           if envptr equal null then
               exit perform
           end-if

           set address of envbuf to envptr
           set charindex to 1
           perform until exit
               if envbuf(charindex:1) equal x"00" then
                   display newline with no advancing end-display
                   exit perform
               end-if
               display envbuf(charindex:1) with no advancing end-display
               set charindex up by 1
           end-perform

           *> Point to the next envvar pointer
           set environ up by byte-length(environ)
           set address of envptr to environ
       end-perform
       goback.
       end program printenv.

$ cobc -x printenv.cob value-of-environ.c
$ ./printenv

XDG_VTNR=1
SSH_AGENT_PID=xxxxx
XDG_SESSION_ID=1
HOSTNAME=local
DM_CONTROL=/var/run/xdmctl
IMSETTINGS_INTEGRATE_DESKTOP=yes
GPG_AGENT_INFO=/home/btiffin/...
GLADE_PIXMAP_PATH=:
SHELL=/bin/bash
TERM=xterm-256color
XDG_MENU_PREFIX=xfce-
XDG_SESSION_COOKIE=somemagicookievaluethatneednotbepublic
HISTSIZE=1000
LUA_INIT=@/home/btiffin/.local/luainit.lua
XDM_MANAGED=method=classic
KONSOLE_DBUS_SERVICE=:1.34
KONSOLE_PROFILE_NAME=Shell
PLAN9=/home/btiffin/inst/plan9port
WINDOWID=2936...
QTDIR=/usr/lib64/qt-3.3
GNOME_KEYRING_CONTROL=/run/user/500/keyring-idval
SHELL_SESSION_ID=anothermagicvalue
QTINC=/usr/lib64/qt-3.3/include
IMSETTINGS_MODULE=none
QT_GRAPHICSSYSTEM_CHECKED=1
USER=btiffin
LS_COLORS=rs=0:di=00;34:ln=00;36:mh=00:pi=40;33:so=00;35:do=00;35:
GLADE_MODULE_PATH=:
SSH_AUTH_SOCK=/tmp/andanothermagicvalue
SESSION_MANAGER=local/unix:@/tmp/.ICE-unix/12345,unix/unix:/tmp/.ICE-unix/12345
XDG_CONFIG_DIRS=/etc/xdg:/usr/local/etc/xdg
DESKTOP_SESSION=xfce
MAIL=/var/spool/mail/btiffin
PATH=/usr/local/firebird/bin:/home/btiffin/inst/unicon12/bin:/home/btiffin/bin
QT_IM_MODULE=xim
PWD=/home/btiffin/lang/cobol
XMODIFIERS=@im=none
KONSOLE_DBUS_WINDOW=/Windows/2
LANG=en_US.UTF-8
GNOME_KEYRING_PID=12345
KDE_IS_PRELINKED=1
KDEDIRS=/usr
KONSOLE_DBUS_SESSION=/Sessions/32
HISTCONTROL=erasedups
SSH_ASKPASS=somedirectory
HOME=/home/btiffin
COLORFGBG=0;15
XDG_SEAT=seat0
SHLVL=3
LANGUAGE=
GDL_PATH=+/usr/share/gnudatalanguage
LESS=-QX
LOGNAME=btiffin
CVS_RSH=ssh
QTLIB=/usr/lib64/qt-3.3/lib
XDG_DATA_DIRS=/usr/local/share:/usr/share
DBUS_SESSION_BUS_ADDRESS=unix:abstract=/tmp/andmoresensitivedata
LESSOPEN=||/usr/bin/lesspipe.sh %s
WINDOWPATH=1
PROFILEHOME=
XDG_RUNTIME_DIR=/run/user/500
DISPLAY=:0
QT_PLUGIN_PATH=/usr/lib64/kde4/plugins:/usr/lib/kde4/plugins
GLADE_CATALOG_PATH=:
XAUTHORITY=/tmp/.Xauth...
CCACHE_HASHDIR=
_=./printenv
OLDPWD=/home/btiffin/lang

PROCEDURE DIVISION RETURNING OMITTED

/****F* cobweb/voidcall_gtk
 *  NAME
 *    voidcall_gtk
 *  PURPOSE
 *    wrapping void C returns in callbacks for use with COBOL and GTK+
 *  INPUT
 *    GTK callback, (in this case always, voidcall_gtk)
 *    Actual COBOL callback program-pointer
 *  OUTPUT
 *    Eat the COBOL handler stack value and return as void
 *  SYNOPSIS
 *    voidcall_gtk(void *gtk, int (*cobfunc)(void *))
 *  SOURCE
*/
void
voidcall_gtk(void *gtk, int (*cobfunc)(void *))
{
    if ((cobfunc) && (cobfunc(gtk))) return; else return;
}
/*
 ****
*/

*> Start up the GIMP/Gnome Tool Kit
 cobgtk.
 call "gtk_init" using
     by value 0                          *> argc int
     by value 0                          *> argv pointer to pointer
     returning omitted                   *> void return, requires cobc 2010+
     on exception
         display
             "hellogtk link error, see pkg-config --libs gtk+-2.0"
             upon syserr
         end-display
         stop run returning 1
 end-call

*> Create a new window, returning handle as pointer
 call "gtk_window_new" using
     by value GTK-WINDOW-TOPLEVEL        *> it's a zero or a 1 popup
     returning gtk-window                *> and remember the handle
 end-call

*> More fencing, skimped on after this first test
 if gtk-window equal null then
     display
         "hellogtk service error, gtk_window_new"
         upon syserr
     end-display
     stop run returning 1
 end-if

*> Hint to not let the sample window be too small
 call "gtk_window_set_default_size" using
     by value gtk-window                 *> by value is used to get the C address
     by value 270                        *> a rectangle, wider than tall
     by value 90
     returning omitted                   *> another void
 end-call

*> Put in the title, it'll be truncated in a size request window
 call "gtk_window_set_title" using
     by value gtk-window                 *> pass the C handle
     by reference hello-msg              *> obligatory, with new Z strings
     returning omitted
 end-call

*> Connect a signal.  GnuCOBOL's SET ... TO ENTRY is AWESOME
 set gtk-quit-callback to entry "gtk_main_quit"
 call "g_signal_connect_data" using
     by value gtk-window
     by reference z"destroy"             *> with inline Z string
     by value gtk-quit-callback          *> function call back pointer
     by value 0                          *> pointer to data
     by value 0                          *> closure notify to manage data
     by value 0                          *> connect before or after flag
     returning gtk-quit-handler-id       *> not used in this sample
 end-call

*> Define a container. Boxey, but nice.
 call "gtk_box_new" using
     by value GTK-ORIENTATION-VERTICAL
     by value 8                          *> pixels between widgets
     returning gtk-box
 end-call

*> Add the label
 call "gtk_label_new" using
     by reference hello-msg
     returning gtk-label
 end-call

*> Add the label to the box
 call "gtk_container_add" using
     by value gtk-box
     by value gtk-label
     returning omitted
 end-call

*> Add a calendar widget
 call "gtk_calendar_new" returning gtk-calendar end-call
 call "gtk_container_add" using
     by value gtk-box
     by value gtk-calendar
     returning omitted
 end-call

*> Connect a signal.  GnuCOBOL doesn't generate void returns
*>  so this calls a C function two-liner that calls the
*>  COBOL entry, but returns void to the runtime stack frame
 set cob-calendar-callback to entry "calendarclick"
 set gtk-calendar-callback to entry "voidcall_gtk"
 call "g_signal_connect_data" using
     by value gtk-calendar
     by reference z"day_selected"        *> with inline Z string
     by value gtk-calendar-callback      *> function call back pointer
     by value cob-calendar-callback      *> pointer to COBOL proc
     by value 0                          *> closure notify to manage data
     by value 0                          *> connect before or after flag
     returning gtk-quit-handler-id       *> not used in this sample
 end-call

*> Add the box to the window
 call "gtk_container_add" using
     by value gtk-window
     by value gtk-box
     returning omitted
 end-call

*> ready to display
 call "gtk_widget_show_all" using
     by value gtk-window
     returning omitted
 end-call

*> Enter the GTK event loop
 call "gtk_main"
     returning omitted
 end-call

*> Control can pass back and forth to COBOL subprograms,
*>  but control flow stops above, until the window
*>  is torn down and the event loop exits
 display
     "GnuCOBOL: GTK main eventloop terminated normally"
     upon syserr
 end-display

 accept venue from environment "GDK_BACKEND" end-accept
 if broadway then
     display "Ken sends his regards" upon syserr end-display
 end-if
 .

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> *******************************************************
  cob *> Author:    Brian Tiffin
  web *> Date:      20140201
 call *> Purpose:   Support cobweb callbacks
backs *> Tectonics: cobc -x -C gnucobol-cobweb.cob
      *>            sed -i 's/stdio.h/fcgi_stdio.h/' gnucobol-cobweb.c
      *>            cobc -x gnucobol-cobweb.c -lfcgi buccaneer.so \
      *>                $(pkg-config --libs gtk+-2.0) voidcall_gtk.c \
      *>                support-cobweb.cob
      *>   Move gnucobol-cobweb to the cgi-bin directory
      *>   supporting libraries in the COB_LIBRARY_PATH
      *>   browse http://localhost/cgi-bin/gnucobol-cobweb
      *> ********************************************************
      *> Callbacks
       identification division.
       program-id. supporting-callbacks.
       data division.
       working-storage section.
       01 gtk-calendar-data.
          05 gtk-calendar-year  usage binary-long sync.
          05 gtk-calendar-month usage binary-long sync.
          05 gtk-calendar-day   usage binary-long sync.
       01 gtk-calendar-display.
          05 the-year           pic 9999.
          05 filler             pic x value "/".
          05 the-month          pic 99.
          05 filler             pic x value "/".
          05 the-day            pic 99.
       linkage section.
       01 gtk-widget usage pointer.

       procedure division.
       entry 'calendarclick' using
           by value gtk-widget
       call "gtk_calendar_get_date" using
           by value gtk-widget
           by reference gtk-calendar-year
           by reference gtk-calendar-month
           by reference gtk-calendar-day
       end-call
       move gtk-calendar-year to the-year
       move gtk-calendar-month to the-month
       move gtk-calendar-day to the-day
       display
           "In the year " the-year
           " somebody clicked "
           gtk-calendar-display
       end-display
       goback.

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140517
      *> License:   Licensed under the GNU GPL 2 (or later)
      *> Purpose:   Hello Jim
      *> Tectonics: cobc -x gnucobol-jim.cob -ljim
      *> ***************************************************************
       identification division.
       program-id. gnucobol-jim.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 jim-interpreter      usage pointer.
       01 cli-arguments        pic x(1024).

      *> quick cheat into the interp structure
       01 jim-result-object    usage pointer based.
       01 jim-string           usage pointer.
       01 jim-length           usage binary-long.
       01 jim-answer           pic x(1024) based.
       01 jim-as-numeric       pic 9(18).

      *> ***************************************************************

       procedure division.
       accept cli-arguments from command-line end-accept

       call "Jim_CreateInterp" returning jim-interpreter
           on exception
               display
                   "error: Jim_CreateInterp failure, needs -ljim"
                   upon syserr
               end-display
bail           goback
       end-call

       call "Jim_RegisterCoreCommands" using
           by value jim-interpreter
       end-call

       call "Jim_InitStaticExtensions" using
           by value jim-interpreter
       end-call

      *> Use a default hello script if no command arguments
       if cli-arguments equal spaces then
           call "Jim_Eval" using
               by value jim-interpreter
               by content z"return {Hello, COBOL}"
           end-call

      *> Jim_Result is a macro, boo, but it's the first address in the
      *>   Interp structure, snag it here as a quick cheat
      *>      jim-interpret is the address of a structure
      *>        jim-result-object pointer is first element
      *>   NOT A PORTABLE WAY, if you see this code, keep looking,
      *>        it should be updated to a proper implementation

           set address of jim-result-object to jim-interpreter
           call "Jim_GetString" using
               by value jim-result-object
               by reference jim-length
               returning jim-string
           end-call
           set address of jim-answer to jim-string
           display "Jim says: " jim-answer(1:jim-length) end-display

       else

      *> Evaluate a file
           call "Jim_EvalFile" using
               by value jim-interpreter
               by content trim(cli-arguments)
           end-call

           set address of jim-result-object to jim-interpreter
           call "Jim_GetString" using
               by value jim-result-object
               by reference jim-length
               returning jim-string
           end-call
           set address of jim-answer to jim-string
           display "Jim says: " jim-answer(1:jim-length) end-display

           move jim-answer(1:jim-length) to jim-as-numeric
           display "COBOL 9s: " jim-as-numeric end-display
       end-if

       call "Jim_FreeInterp" using
           by value jim-interpreter
       end-call

done   goback.
       end program gnucobol-jim.

return "S'up?"

# Tests that SIGALRM can interrupt read
set f [open "/dev/urandom" r]

set count 0
set error NONE

signal handle SIGALRM
catch -signal {
        alarm 0.5
        while {1} {
                incr count [string bytelength [read $f 100]]
        }
        alarm 0
        signal default SIGALRM
} error

puts "Read $count bytes in 0.5 seconds: Got $error"

$f close
return $count

[root]# yum install jimtcl jimtcl-devel

[jim]$ cobc -x gnucobol-jim.cob -ljim
[jim]$ ./gnucobol-jim
Jim says: Hello, COBOL
[jim]$ ./gnucobol-jim hello.tcl
Jim says: S'up?
COBOL 9s: 000000000000000000
[jim]$ ./gnucobol-jim timedread.tcl
Read 5505000 bytes in 0.5 seconds: Got SIGALRM
Jim says: 5505000
COBOL 9s: 000000000005505000

GCobol >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140610
      *> Purpose:   RLIB integration from GnuCOBOL, XML datasources
      *> License:   RLIB is licenced GPL 2.0, this source is too
      *> Tectonics: cobc -x gnucobol-rlib-xml.cob -lr
      *>   displays PDF output to standard out
      *> ***************************************************************
       identification division.
       program-id. rlib-xml.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

data   data division.
       working-storage section.

      *> see libsrc/rlib.h in the RLIB distribution
       01 rlib                 usage pointer.

      *> ***************************************************************
code   procedure division.

      *> Initialize an RLIB structure
       call "rlib_init" returning rlib on exception continue end-call
       if rlib equal null then
           display "No rlib_init, try -lr" upon syserr end-display
bail       goback
       end-if

      *> add in a new XML datasource, by the name of local_xml
       call "rlib_add_datasource_xml" using
           by value rlib
           by content z"local_xml"
       end-call

      *> add a query (xml data file) to the RLIB local_xml structure
       call "rlib_add_query_as" using
           by value rlib
           by content z"local_xml"
           by content z"data.xml"
           by content z"data"
       end-call

      *> add a report to the queue
       call "rlib_add_report" using
           by value rlib
           by content z"graph.xml"
       end-call

      *> set output form; "pdf", "html", "csv", "txt"
       call "rlib_set_output_format_from_text" using
           by value rlib
           by content z"pdf"
       end-call

      *> execute the rlib queue to buffer a report
       call "rlib_execute" using
           by value rlib
       end-call

      *> spool to stdout
       call "rlib_spool" using
           by value rlib
       end-call

      *> and free the structure
       call "rlib_free" using
           by value rlib
       end-call

done   goback.
       end program rlib-xml.

<?xml version="1.0"?>
<data>
    <rows>
        <row>
            <col>Bob</col>
            <col>Doan</col>
            <col>blue</col>
            <col>8</col>
            <col>3</col>
            <col>Green Eggs And Spam I Am I Am</col>
        </row>
        <row>
            <col>Eric</col>
            <col>Buruschkin</col>
            <col>green</col>
            <col>5</col>
            <col>5</col>
            <col>Green Eggs And Spam I Am I Am</col>
        </row>
        <row>
            <col>Mike</col>
            <col>Roth</col>
            <col>yellow</col>
            <col>9</col>
            <col>3</col>
            <col>Green Eggs And Spam I Am I Am</col>
        </row>
        <row>
            <col>Bob</col>
            <col>Kratz</col>
            <col>pink</col>
            <col>7</col>
            <col>6</col>
            <col>Green Eggs And Spam I Am I Am</col>
        </row>
        <row>
            <col>Steve</col>
            <col>Tilden</col>
            <col>purple</col>
            <col>9</col>
            <col>1</col>
            <col>Dude</col>
        </row>
    </rows>
    <fields>
        <field>first_name</field>
        <field>last_name</field>
        <field>color</field>
        <field>max</field>
        <field>min</field>
        <field>breakfast</field>
    </fields>
</data>

<?xml version="1.0"?>
<!DOCTYPE report >
<Part layout="'flow'" fontSize="14" orientation="landscape">
    <PageHeader>
        <Output>
            <Line fontSize="26" bgcolor="'yellow'">
                <literal link="'http://rlib.sicompos.com'">
                 RLIB IS Graphing       </literal>
                <literal>YES!</literal>
            </Line>
            <HorizontalLine size="4" bgcolor="'black'"/>
            <HorizontalLine size="10" bgcolor="'white'"/>
        </Output>
    </PageHeader>
    <pr>
        <pd width="98">
            <Report fontSize="12" orientation="landscape" query="'data'">
                <Graph type="'line'" subtype="'normal'" width="740" height="250"
                       title="'Double Y Axix!'" x_axis_title="'Team RLIB'"
                       y_axis_title="'Big $$$'" y_axis_title_right="'Small $'">
                    <Plot axis="'x'" field="first_name"/>
                    <Plot axis="'y'" field="val(max)" label="'Max'" side="'left'"/>
                    <Plot axis="'y'" field="val(min)" label="'Min'" side="'right'"/>
                </Graph>
            </Report>
        </pd>
    </pr>
    <PageFooter>
        <Output>
            <Line>
                <literal>Page: </literal>
                <field value="r.pageno" width="3" align="right"/>
                <literal>/</literal>
                <field value="r.totpages" width="3" align="right" delayed="yes"/>
            </Line>
        </Output>
    </PageFooter>
</Part>

$ cobc -x rlib-xml.cob -lr -g -debug
$ export COB_SET_TRACE=YES
$ ./rlib-xml >rlib-xml-graph.pdf
Source:     'rlib-xml.cob'
Program-Id: rlib-xml         Entry:     rlib-xml               Line: 27
Program-Id: rlib-xml         Section:   (None)                 Line: 27
Program-Id: rlib-xml         Paragraph: (None)                 Line: 27
Program-Id: rlib-xml         Statement: CALL                   Line: 27
Program-Id: rlib-xml         Statement: IF                     Line: 28
Program-Id: rlib-xml         Statement: CALL                   Line: 34
Program-Id: rlib-xml         Statement: CALL                   Line: 40
Program-Id: rlib-xml         Statement: CALL                   Line: 48
Program-Id: rlib-xml         Statement: CALL                   Line: 54
Program-Id: rlib-xml         Statement: CALL                   Line: 60
Program-Id: rlib-xml         Statement: CALL                   Line: 65
Program-Id: rlib-xml         Statement: CALL                   Line: 70
Program-Id: rlib-xml         Statement: GOBACK                 Line: 74
Program-Id: rlib-xml         Exit:      rlib-xml

/** Perl support for GnuCOBOL */
/* tectonics: cobc -x perlcob.cob perlsupport.c -lperl -L/usr/lib64/perl/CORE */

#include <EXTERN.h>
#include <perl.h>

/** needed for the macros */
static PerlInterpreter *my_perl;

/** return scalar value as an integer */
int CBL_OC_SvIV(PerlInterpreter *perl_instance, char *name) {
    my_perl = perl_instance;
    return SvIV(get_sv(name, 0));
}

/** GnuCOBOL doesn't support double on the return stack frame*/
static double CBL_OC_SvNV_intermediate;

/** return scalar value as float */
double * CBL_OC_SvNV(PerlInterpreter *perl_instance, char *name) {
    my_perl = perl_instance;
    CBL_OC_SvNV_intermediate = SvNV(get_sv(name, 0));
    return &CBL_OC_SvNV_intermediate;
}

/** return scalar value as char pointer */
char * CBL_OC_SvPV_nolen(PerlInterpreter *perl_instance, char *name) {
    my_perl = perl_instance;
    return SvPV_nolen(get_sv(name, 0));
}

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20140407
      *> Purpose:   cobweb embedded Perl
      *> Tectonics: cobc -x perlcob.cob -lperl -L/usr/lib64/perl5/CORE
      *>   -or- the Perl documented way of getting to the right paths
      *>            cobc -x -g -debug perlcob.cob \
      *>              `perl -MExtUtils::Embed -e ccopts -e ldopts`
      *> ***************************************************************
       identification division.
       program-id. perlcob.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

data   data division.
       working-storage section.
       01 perl-interpreter         usage pointer.
       01 perl-null                usage pointer value null.
       01 perl-scalar-reference    usage pointer.
       01 perl-result-int          usage binary-long.

       01 perl-integer             usage binary-long.

       01 perl-floater             usage pointer.
       01 perl-float               usage float-long based.

       01 perl-pointer             usage pointer.
       01 perl-char                pic x based.
       01 next-char                pic x based.

       01 perl-start-args.
          05 perl-argv             usage pointer sync.
          05 argv0                 usage pointer sync.
          05 argv1                 usage pointer sync.
          05 argv2                 usage pointer sync.
          05 argv3                 usage pointer sync.
       01 perl-strings.
          05 empty-string          pic x value x"00".
          05 express-string        pic xxx value "-e" & x"00".
          05 one-liner             pic x(80)
                value 'print "Hello, COBOL\nThis is process $$' &
                      ' on $^O\n";' & x"00".


      *> ***************************************************************
code   procedure division.
       call "Perl_sys_init" using
           by value 0
           by reference null
           on exception
               display
                   "perlcob: Perl_sys_init failure" upon syserr
               end-display
       end-call

       call "perl_alloc"
           returning perl-interpreter
           on exception
               display
                   "perlcob: perl_alloc failure" upon syserr
               end-display
       end-call
       if perl-interpreter equal null then
           display
               "perlcob: perl-interpreter null" upon syserr
           end-display
       end-if

       call "perl_construct" using by value perl-interpreter end-call

      *> Set up a fake argc, argv
       set perl-argv to address of argv0.
       set argv0 to address of empty-string.
       set argv1 to address of express-string.
       set argv2 to address of one-liner.
       set argv3 to null

       call "perl_parse" using
           by value perl-interpreter
           by value perl-null
           by value 3
           by value perl-argv
           by value perl-null
           returning perl-result-int
       end-call
       display
           "perlcob parse result:       " perl-result-int
       end-display

       call "perl_run" using
           by value perl-interpreter
           returning perl-result-int
       end-call
       display
           "perlcob run result:         " perl-result-int
       end-display

      *> a floating point evaluation
       call "Perl_eval_pv" using
           by value perl-interpreter
           by content '$a = 3.14; $a **= 2;' & x"00"
           by value 0
           returning perl-scalar-reference
           on exception
               display
                   "perlcob: Perl_eval_pv failure" upon syserr
               end-display
       end-call

       call "CBL_OC_SvNV" using
           by value perl-interpreter
           by content z"a"
           returning perl-floater
       end-call
       set address of perl-float to perl-floater
       display "perlcob 3.14**2 from perl:  " perl-float end-display

      *> scalar as integer evaluation
       call "Perl_eval_pv" using
           by value perl-interpreter
           by content '$a = 3; $a **= 2;' & x"00"
           by value 0
           returning perl-scalar-reference
           on exception
               display
                   "perlcob: Perl_eval_pv failure" upon syserr
               end-display
       end-call

       call "CBL_OC_SvIV" using
           by value perl-interpreter
           by content z"a"
           returning perl-integer
       end-call
       display "perlcob 3**2 from perl:     " perl-integer end-display

      *> a floating point evaluation
       call "Perl_eval_pv" using
           by value perl-interpreter
           by content '$a = 3.14; $a **= 20;' & x"00"
           by value 0
           returning perl-scalar-reference
           on exception
               display
                   "perlcob: Perl_eval_pv failure" upon syserr
               end-display
       end-call
       call "CBL_OC_SvNV" using
           by value perl-interpreter
           by content z"a"
           returning perl-floater
       end-call
       set address of perl-float to perl-floater
       display "perlcob 3.14**20 from perl: " perl-float end-display

       compute perl-float = 3.14 ** 20 end-compute
       display "COBOL   computed 3.14**20 : " perl-float end-display

      *> scalar as a null terminated string
       call "Perl_eval_pv" using
           by value perl-interpreter
           by content
               '$a = "rekcaH lreP rehtonA tsuJ"; ' &
               "$a = reverse($a);" & x"00"
           by value 1
           returning perl-scalar-reference
           on exception
               display
                   "perlcob: Perl_eval_pv failure" upon syserr
               end-display
       end-call
       call "CBL_OC_SvPV_nolen" using
           by value perl-interpreter
           by content z"a"
           returning perl-pointer
       end-call
       display "perlcob pointer from perl:  " perl-pointer end-display

       set address of perl-char to perl-pointer
       perform until perl-char equal x"00"
           set perl-pointer up by 1
           set address of next-char to perl-pointer

           if next-char not equal x"00" then
               display perl-char with no advancing end-display
           else
               display perl-char end-display
           end-if

           set address of perl-char to perl-pointer
       end-perform

      *> and just for fun, remove blank lines from CRUNCHME.txt
       call "Perl_eval_pv" using
           by value perl-interpreter
           by content
               'open FH, "CRUNCHME.txt" or die $!;'        & x"0a" &
               'while (<FH>) {'                            & x"0a" &
               '    print unless /^$/;'                    & x"0a" &
               '};'                                        & x"0a" &
               'close(FH);' & x"00"
           by value 0
           returning perl-scalar-reference
           on exception
               display
                   "perlcob: Perl_eval_pv failure" upon syserr
               end-display
       end-call

       call "CBL_OC_SvIV" using
           by value perl-interpreter
           by content z"a"
           returning perl-integer
       end-call
       display "perlcob from perl:     " perl-integer end-display

      *> cleanup
       call "perl_destruct" using by value perl-interpreter end-call
       call "perl_free" using by value perl-interpreter end-call

       call "Perl_sys_term" end-call
       goback.
       end program perlcob.

$ make perlcob
cobc -x -g -debug perlcob.cob perlsupport.c
     -I/usr/lib64/perl5/CORE -lperl -L/usr/lib64/perl5/CORE

$ export LD_LIBRARY_PATH=/usr/lib64/perl5/CORE/
$ ./perlcob
perlcob parse result:       +0000000000
Hello, COBOL
This is process 30917 on linux
perlcob run result:         +0000000000
perlcob 3.14**2 from perl:  9.8596
perlcob 3**2 from perl:     +0000000009
perlcob 3.14**20 from perl: 8681463855.993662
COBOL   computed 3.14**20 : 8681463855.993654
perlcob pointer from perl:  0x00000000019d4720
Just Another Perl Hacker
Perl will
remove
the empty
lines of
this file
perlcob from perl:     +0000000000

tar xvf bacon-3.0.1.tar.gz
cd bacon-3.0.1
./configure
make
sudo make install

REM BaCon from GnuCOBOL, Take 1

REM a little bit of logic programming ala Proglog
FUNCTION mortals()
    DECLARE human, mortal ASSOC int
    RELATE human TO mortal

    human("socrates") = TRUE
    human("sappho") = TRUE
    human("august") = TRUE

    PRINT "Mortals are:"
    LOOKUP mortal TO member$ SIZE amount
    FOR x = 0 TO amount - 1
        PRINT member$[x]
    NEXT
    RETURN 0
END FUNCTION


REM and times five
FUNCTION timesfive (NUMBER n)
    LOCAL i
    i = 5 * n
    RETURN i
END FUNCTION

$ bacon -f libdemo.bac
Converting 'libdemo.bac'... done, 26 lines were processed in 0.006 seconds.
Compiling 'libdemo.bac'... cc  -fPIC -c libdemo.bac.c
cc -o libdemo.so libdemo.bac.o -lbacon -lm -ldl -shared -rdynamic
Done, program 'libdemo.so' ready.

$ sudo cp -vi libdemo.so /usr/local/lib/
$ sudo ldconfig

GnuCOB >>SOURCE FORMAT IS FIXED
      *> TECTONICS
      *>   bacon -f libdemo.bac
      *>   sudo cp libdemo.so /usr/local/lib/
      *>   sudo ldconfig
      *>   cobc -x ldemo callbacon.cob -g -debug
       identification division.
       program-id. callbacon.

       data division.
       working-storage section.
       01 basic-result       usage binary-long.

       procedure division.
       call "mortals" end-call

       call "timesfive" using by value 8 returning basic-result end-call
       display basic-result space return-code end-display

       goback.
       end program callbacon.

$ cobc -x -g -debug callbacon.cob -ldemo
$ ./callbacon
Mortals are:
socrates
sappho
august
+0000000040 +000000040

'
' Demonstration program for SQlite3
'
' PvE - May 2010, GPL.
' ------------------------------------------------------------------------

' Include the binding
INCLUDE "sqlite3.bac"

' Name of the data file
CONST datafile$ = "data.sdb"

' Print version
PRINT NL$, "Using SQLite version: ", DB_VERSION$()

' Create a database
mydb = DB_OPEN(datafile$)

' Create table and add data
DB_SQL(mydb, "CREATE TABLE demo(someval INTEGER,  sometxt TEXT);")
DB_SQL(mydb, "INSERT INTO demo VALUES (123, 'Hello');")
DB_SQL(mydb, "INSERT INTO demo VALUES (234, 'BaCon');")
DB_SQL(mydb, "INSERT INTO demo VALUES (345, 'world');")
DB_SQL(mydb, "COMMIT;")

' Fetch some data
res = DB_SQL(mydb, "SELECT * FROM demo;")
IF res IS 0 THEN PRINT NL$, DB_RESULT$
ELSE PRINT NL$, DB_ERROR$

' Count the records
DB_SQL(mydb, "SELECT COUNT(*) FROM demo;")
PRINT "Amount of records: ", MID$(DB_RESULT$, INSTR(DB_RESULT$, NL$) + 1)

' Close database
res = DB_CLOSE(mydb)

' Print some info
PRINT "Size of data file is: ", FILELEN(datafile$), " bytes.", NL$

' Delete data file again
DELETE FILE datafile$

$ bacon sql.bac
Converting 'sql.bac'... done, 212 lines were processed in 0.032 seconds.
Compiling 'sql.bac'... cc  -c sql.bac.c
cc -o sql sql.bac.o -lbacon -lm -ldl
Done, program 'sql' ready.

$ ./sql

Using SQLite version: 3.8.3

someval sometxt
123     Hello
234     BaCon
345     world

Amount of records: 3

Size of data file is: 2048 bytes.

# nim c --noMain --noLinking --header:ultimate.h ultimate.nim
proc ultimate(a: cint): cint {.exportc.} =
  result = 1
  var days = a
  while days > 1:
    days -= 1
    result *= 42

GCOBOL
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU General Public License, GPL, 3.0 (or greater)
      *> PURPOSE
      *>   nicenim program. Original callnim used fibonacci,
      *>   an overly resource intensive proof of concept sample
      *> TECTONICS
      *> nicenim-static: nicenim.cob ultimate.nim
      *>  nim compile --app:staticlib --noMain --header ultimate.nim
      *>  cobc -x nicenim.cob -g -debug libultimate.nim.a
      *> nicenim: nicenim.cob ultimate.nim
      *>  nim compile --noMain --noLinking\
      *>      --header:ultimate.h ultimate.nim
      *>  cobc -x nicenim.cob nimcache/ultimate.c nimcache/system.c -g\
      *>      -debug -A '-I/home/btiffin/inst/langs/nim-0.10.2/lib'
      *>  The include directive needs to find nim dev headers, in lib
       identification division.
       program-id. nicenim.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 num usage binary-long.
       01 ans usage binary-long.
       01 chq pic $zzz,zzz,zz9.99.

       procedure division.
       display "a week on the hitchhiker's pay scale" end-display

       call "NimMain" end-call

       perform varying num from 1 by 1 until num > 5
           display "Pay for " with no advancing end-display
           evaluate num
             when 1 display "Monday   " with no advancing end-display
             when 2 display "Tuesday  " with no advancing end-display
             when 3 display "Wednesday" with no advancing end-display
             when 4 display "Thursday " with no advancing end-display
             when 5 display "Friday   " with no advancing end-display
           end-evaluate

           call "ultimate" using by value num returning ans end-call
           move ans to chq
           display " would be " chq end-display
       end-perform

       goback.
       end program nicenim.

# integrate Nim, using generated C sources
nicenim: nicenim.cob ultimate.nim
    nim compile -d:release --noMain --noLinking --header:ultimate.h ultimate.nim
    cobc -x nicenim.cob nimcache/ultimate.c nimcache/system.c \
         -g -debug -A '-I/home/btiffin/inst/langs/nim-0.10.2/lib'

# integrate Nim, static linkages
callnim-static: callnim.cob fib.nim
    nim compile --app:staticlib --noMain --header fib.nim
    cobc -x -K'NimMain' -K'fib' callnim.cob -g -debug libfib.nim.a

# integrate Nim, using generated C sources
callnim: callnim.cob fib.nim
    nim compile -d:release --noMain --noLinking --header:fib.h fib.nim
    cobc -x callnim.cob nimcache/fib.c nimcache/system.c \
         -g -debug -A '-I/home/btiffin/inst/langs/nim-0.10.2/lib'

nim compile -d:release --noMain --noLinking --header:ultimate.h ultimate.nim
config/nim.cfg(45, 2) Hint: added path: '/home/btiffin/.babel/pkgs/' [Path]
config/nim.cfg(46, 2) Hint: added path: '/home/btiffin/.nimble/pkgs/' [Path]
Hint: used config file '/home/btiffin/inst/langs/nim-0.10.2/config/nim.cfg' [Conf]
Hint: system [Processing]
Hint: ultimate [Processing]
Hint: operation successful (8759 lines compiled; 0.118 sec total; 10.102MB) [SuccessX]
cobc -x nicenim.cob nimcache/ultimate.c nimcache/system.c
     -g -debug -A '-I/home/btiffin/inst/langs/nim-0.10.2/lib'

a week on the hitchhiker's pay scale
Pay for Monday    would be           $1.00
Pay for Tuesday   would be          $42.00
Pay for Wednesday would be       $1,764.00
Pay for Thursday  would be      $74,088.00
Pay for Friday    would be   $3,111,696.00

# nim c --noMain --noLinking --header:fib.h fib.nim
proc fib(a: cint): cint {.exportc.} =
  if a <= 2:
    result = 1
  else:
    result = fib(a - 1) + fib(a - 2)

*>******************************************************************************
*>  This file is part of cobjapi.
*>
*>  choice.cob is free software: you can redistribute it and/or
*>  modify it under the terms of the GNU Lesser General Public License as
*>  published by the Free Software Foundation, either version 3 of the License,
*>  or (at your option) any later version.
*>
*>  choice.cob is distributed in the hope that it will be useful,
*>  but WITHOUT ANY WARRANTY; without even the implied warranty of
*>  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
*>  See the GNU Lesser General Public License for more details.
*>
*>  You should have received a copy of the GNU Lesser General Public License
*>  along with choice.cob.
*>  If not, see <http://www.gnu.org/licenses/>.
*>******************************************************************************

*>******************************************************************************
*> Program:      choice.cob
*>
*> Purpose:      Example GnuCOBOL program for JAPI
*>
*> Author:       Laszlo Erdos - https://www.facebook.com/wortfee
*>
*> Date-Written: 2014.12.24
*>
*> Tectonics:    Example for static link.
*>               cobc -x -free choice.cob cobjapi.o \
*>                                        japilib.o \
*>                                        imageio.o \
*>                                        fileselect.o
*>
*> Usage:        ./choice.exe
*>
*>******************************************************************************
*> Date       Name / Change description
*> ========== ==================================================================
*> 2003.02.26 This comment is only for History. The latest Version (V1.0.6) of
*>            JAPI was released on 02/26/2003. Homepage: http://www.japi.de
*>------------------------------------------------------------------------------
*> 2014.12.24 Laszlo Erdos:
*>            - GnuCOBOL support for JAPI added.
*>            - choice.c converted into choice.cob.
*>******************************************************************************

 IDENTIFICATION DIVISION.
 PROGRAM-ID. choice.
 AUTHOR.     Laszlo Erdos.

 ENVIRONMENT DIVISION.
 CONFIGURATION SECTION.
 REPOSITORY.
    FUNCTION J-SETDEBUG
    FUNCTION J-START
    FUNCTION J-FRAME
    FUNCTION J-CHOICE
    FUNCTION J-ADDITEM
    FUNCTION J-SETPOS
    FUNCTION J-SELECT
    FUNCTION J-SETNAMEDCOLORBG
    FUNCTION J-SHOW
    FUNCTION J-NEXTACTION
    FUNCTION J-GETSELECT
    FUNCTION J-QUIT
    FUNCTION ALL INTRINSIC.

 DATA DIVISION.

 WORKING-STORAGE SECTION.
*> function return value
 01 WS-RET                             BINARY-INT.

*> GUI elements
 01 WS-FRAME                           BINARY-INT.
 01 WS-OBJ                             BINARY-INT.
 01 WS-CHOICE                          BINARY-INT.

*> function args
 01 WS-DEBUG-LEVEL                     BINARY-INT.
 01 WS-XPOS                            BINARY-INT.
 01 WS-YPOS                            BINARY-INT.
 01 WS-ITEM                            BINARY-INT.

*> Constants for the cobjapi wrapper
 COPY "cobjapi.cpy".

 PROCEDURE DIVISION.

*>------------------------------------------------------------------------------
 MAIN-CHOICE SECTION.
*>------------------------------------------------------------------------------

*>  MOVE 5 TO WS-DEBUG-LEVEL
*>  MOVE J-SETDEBUG(WS-DEBUG-LEVEL) TO WS-RET

    MOVE J-START() TO WS-RET
    IF WS-RET = ZEROES
    THEN
       DISPLAY "can't connect to server"
       STOP RUN
    END-IF

*>  Generate GUI Objects
    MOVE J-FRAME("select a color") TO WS-FRAME

    MOVE J-CHOICE(WS-FRAME) TO WS-CHOICE

    MOVE J-ADDITEM(WS-CHOICE, "Red")     TO WS-RET
    MOVE J-ADDITEM(WS-CHOICE, "Green")   TO WS-RET
    MOVE J-ADDITEM(WS-CHOICE, "Blue")    TO WS-RET
    MOVE J-ADDITEM(WS-CHOICE, "Yellow")  TO WS-RET
    MOVE J-ADDITEM(WS-CHOICE, "White")   TO WS-RET
    MOVE J-ADDITEM(WS-CHOICE, "Black")   TO WS-RET
    MOVE J-ADDITEM(WS-CHOICE, "Magenta") TO WS-RET
    MOVE J-ADDITEM(WS-CHOICE, "Orange")  TO WS-RET

    MOVE 150 TO WS-XPOS
    MOVE 120 TO WS-YPOS
    MOVE J-SETPOS(WS-CHOICE, WS-XPOS, WS-YPOS) TO WS-RET

*>  Makes the given item the selected one for the choice.
    MOVE 3 TO WS-ITEM
    MOVE J-SELECT(WS-CHOICE, WS-ITEM) TO WS-RET

    MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-YELLOW) TO WS-RET
    MOVE J-SETNAMEDCOLORBG(WS-CHOICE, J-WHITE) TO WS-RET

    MOVE J-SHOW(WS-FRAME) TO WS-RET

*>  Waiting for actions
    PERFORM FOREVER
       MOVE J-NEXTACTION() TO WS-OBJ

       IF WS-OBJ = WS-CHOICE
       THEN
          MOVE J-GETSELECT(WS-CHOICE) TO WS-ITEM

          EVALUATE WS-ITEM
             WHEN 0 MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-RED)     TO WS-RET
             WHEN 1 MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-GREEN)   TO WS-RET
             WHEN 2 MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-BLUE)    TO WS-RET
             WHEN 3 MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-YELLOW)  TO WS-RET
             WHEN 4 MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-WHITE)   TO WS-RET
             WHEN 5 MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-BLACK)   TO WS-RET
             WHEN 6 MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-MAGENTA) TO WS-RET
             WHEN 7 MOVE J-SETNAMEDCOLORBG(WS-FRAME, J-ORANGE)  TO WS-RET
          END-EVALUATE

          MOVE J-SETNAMEDCOLORBG(WS-CHOICE, J-WHITE) TO WS-RET
       END-IF

       IF WS-OBJ = WS-FRAME
       THEN
          EXIT PERFORM
       END-IF
    END-PERFORM

    MOVE J-QUIT() TO WS-RET

    STOP RUN

    .
 MAIN-CHOICE-EX.
    EXIT.
 END PROGRAM choice.

$ cloc exam* --by-file | grep \\.cob | sort | \
   awk '{printf "%-40s %3s, %3s\n",$1,$3,$4}'
examples/digits/digits.cob                56,  96
examples/imageviewer/imageviewer.cob      55, 126
examples/mandelbrot/mandelbrot1.cob       60, 168
examples/mandelbrot/mandelbrot2.cob       60, 168
examples/mandelbrot/mandelbrot3.cob       61, 268
examples_simple/alert.cob                 53,  85
examples_simple/borderlayout.cob          54,  60
examples_simple/borderpanel.cob           54,  80
examples_simple/button.cob                54, 104
examples_simple/canvas.cob                59, 114
examples_simple/checkbox.cob              55, 116
examples_simple/choice.cob                55,  84
examples_simple/colors1.cob               59, 112
examples_simple/colors.cob                56, 108
examples_simple/componentlistener.cob     55, 110
examples_simple/cursor.cob                60, 118
examples_simple/daemon.cob                50,  28
examples_simple/dialog.cob                55,  94
examples_simple/dialogmodal.cob           57,  98
examples_simple/filedialog.cob            54,  69
examples_simple/flowlayout.cob            54, 125
examples_simple/flowsimple.cob            56,  73
examples_simple/focuslistener.cob         61,  65
examples_simple/font.cob                  64, 179
examples_simple/frame.cob                 53,  52
examples_simple/graphicbutton.cob         56,  84
examples_simple/graphic.cob               77, 282
examples_simple/graphiclabel.cob          53,  70
examples_simple/gridlayout.cob            54, 114
examples_simple/image.cob                 59, 128
examples_simple/insets.cob                54, 111
examples_simple/keylistener.cob           54,  71
examples_simple/label.cob                 53, 123
examples_simple/lines.cob                 54,  70
examples_simple/list.cob                  55,  88
examples_simple/listmultiple.cob          55, 116
examples_simple/menu.cob                  55, 134
examples_simple/mousebuttons.cob          54,  64
examples_simple/mouselistener.cob         54, 165
examples_simple/panel.cob                 53, 136
examples_simple/popupmenu.cob             53,  67
examples_simple/print.cob                 54,  97
examples_simple/radiobutton.cob           54,  77
examples_simple/rubberband.cob            54, 126
examples_simple/scaledimage.cob           57,  93
examples_simple/scrollbar.cob             55,  94
examples_simple/scrollpane.cob            54, 104
examples_simple/simple.cob                53,  36
examples_simple/simplemenu.cob            53,  51
examples_simple/textfield.cob             53,  80
examples_simple/vumeter.cob               54, 103
examples_simple/window.cob                54, 102
examples_simple/windowlistener.cob        54, 114
examples/texteditor/texteditor.cob        56, 163
examples/video/video.cob                  61, 117

cobolmac [options] <input >output [2>messages]

--help       Display this text and exit.
--version    Display the preprocessor version and exit.
--hardwarn   Treat all warnings like an error.
--verbose    Include Macro Begin/End comment lines.
--debug      Display additional error information.
--maclib     List the contents of the Macro Library.

    *> *************************************************************************
    *>  %MoveNumber(Number#,Destination#,Column#,Format#)
    *> -------------------------------------------------------------------------
    *>  Convert Number to the format specified by Format (available formats are
    *>  listed in this macros working-storage). Converted number is then moved
    *>  to Destination starting at the location specified by Column.
    *> *************************************************************************

    01  MoveNumber-macro.
      05  MoveNumber-pointer           pic s9(04) comp.
      05  MoveNumber-edits.
        *>             vvv - This is the value supplied in Format parameter.
        10  MoveNumber-4v0             pic z(3)9.
        10  MoveNumber-7v2             pic z(6)9.99.
        10  MoveNumber-9v2             pic z(8)9.99.

$define %MoveNumber=
move !3 to MoveNumber-column
add !1 to zero giving MoveNumber-!4 end-add

string
  MoveNumber-!4 delimited by size
  into !2 with pointer MoveNumber-column
end-string#

%MoveNumber(123#, output-field#, 1#, 4v0#)

move 1 to MoveNumber-column
add 123 to zero giving MoveNumber-4v0 end-add

string
    MoveNumber-4v0 delimited by size
    into output-field with pointer MoveNumver-column
end-string

#include <stdio.h>
int chello() {
    printf("%s\n", "Whassup, earth, whatya lookin for?");
    return 41;
}

        .file   "chello.c"
        .section        .rodata
        .align 8
.LC0:
        .string "Whassup, earth, whatya lookin for?"
        .text
        .globl  chello
        .type   chello, @function
chello:
.LFB0:
        .cfi_startproc
        pushq   %rbp
        .cfi_def_cfa_offset 16
        .cfi_offset 6, -16
        movq    %rsp, %rbp
        .cfi_def_cfa_register 6
        movl    $.LC0, %edi
        call    puts
        movl    $41, %eax
        popq    %rbp
        .cfi_def_cfa 7, 8
        ret
        .cfi_endproc
.LFE0:
        .size   chello, .-chello
        .ident  "GCC: (GNU) 4.9.2 20150212 (Red Hat 4.9.2-6)"
        .section        .note.GNU-stack,"",@progbits

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20150617
      *> Purpose:   An assembler integration sample
      *> Tectonics: gcc -S chello.c
      *>            cobc -x hello.cob chello.s
      *> ***************************************************************
       identification division.
       program-id. hello.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 pretty-42 pic 99.

      *> ***************************************************************
       procedure division.

       display "Hello, world" end-display

       call "chello" on exception display "earth?" end-display end-call
       move return-code to pretty-42
       display pretty-42 end-display

       if pretty-42 not equal 42 then
           display "universally unfulfilled" upon syserr end-display
       end-if

       goback.
       end program hello.

prompt$ cobc -x hello.cob chello.s
Command line:   cobc -x -v hello.cob chello.s
Preprocessing:  hello.cob -> /tmp/cob29021_0.cob
Return status:  0
Parsing:        /tmp/cob29021_0.cob (hello.cob)
Return status:  0
Translating:    /tmp/cob29021_0.cob -> /tmp/cob29021_0.c (hello.cob)
Executing:      gcc -std=gnu99 -c -I/usr/local/include -pipe -Wno-unused
                -fsigned-char -Wno-pointer-sign -o "/tmp/cob29021_0.o"
                "/tmp/cob29021_0.c"
Return status:  0
Executing:      gcc -std=gnu99 -c -I/usr/local/include -pipe -Wno-unused
                -fsigned-char -Wno-pointer-sign -fPIC -DPIC -o
                "/tmp/cob29021_1.o" "chello.s"
Return status:  0
Executing:      gcc -std=gnu99 -Wl,--export-dynamic -o "hello"
                "/tmp/cob29021_0.o" "/tmp/cob29021_1.o" -L/usr/local/lib -lcob
                -lm -lvbisam -lgmp -lncursesw -ldl
Return status:  0
prompt$ ./hello
Hello, world
Whassup, earth, whatya lookin for?
41
universally unfulfilled

call    puts
movl    $41, %eax
popq    %rbp

call    puts
movl    $42, %eax
popq    %rbp

        .file   "chello.c"
        .section        .rodata
        .align 8
.LC0:
        .string "Whassup, earth, whatya lookin for?"
        .text
        .globl  chello
        .type   chello, @function
chello:
.LFB0:
        .cfi_startproc
        pushq   %rbp
        .cfi_def_cfa_offset 16
        .cfi_offset 6, -16
        movq    %rsp, %rbp
        .cfi_def_cfa_register 6
        movl    $.LC0, %edi
        call    puts
        movl    $42, %eax
        popq    %rbp
        .cfi_def_cfa 7, 8
        ret
        .cfi_endproc
.LFE0:
        .size   chello, .-chello
        .ident  "GCC: (GNU) 4.9.2 20150212 (Red Hat 4.9.2-6)"
        .section        .note.GNU-stack,"",@progbits

prompt$ cobc -x hello.cob chello.s
prompt$ ./hello
Hello, world
Whassup, earth, whatya lookin for?
42

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* project/cpuid
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20150405  Modified: 2015-11-13/11:54-0500
      *> LICENSE
      *>   Public Domain sample
      *> PURPOSE
      *>   Exercise the CPUID opcode.
      *> TECTONICS
      *>   cobc -xjg -debug cpuid.cob vendor.s brand.s fixunsign.s
      *> ***************************************************************
       identification division.
       program-id. cpuid.
       author. Brian Tiffin.
       date-written. 2015-11-13/11:54-0500.
       remarks. GnuCOBOL with x86_64 assembler, NOT cross-platform

       environment division.
       configuration section.
       source-computer.
       object-computer.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 maximum-function     usage unsigned-long.

      *> ***************************************************************
       procedure division.

       call "vendorid" returning maximum-function
           on exception
               display "no vendorid linkage" upon syserr
               perform soft-exception
       end-call
       display "CPUID normal maximum  : " maximum-function

       call "brand" returning maximum-function
           on exception
               display "no brand linkage" upon syserr
               perform soft-exception
       end-call

      *> Bug in GnuCOBOL is casting unsigned to signed
      *> This fixes the returned value in place
       call "negate" using
           by value maximum-function
           by reference maximum-function
           on exception
               display "no signextend linkage" upon syserr
               perform soft-exception
       end-call
       display "CPUID extended maximum: " maximum-function
          with no advancing
       call "printf" using
           by content ", 0x%X" & x"0a00"
           by value maximum-function
           on exception
               display "no printf linkage" upon syserr
               perform soft-exception
       end-call
       move 0 to return-code
       goback.
      *> ***************************************************************

      *> informational warnings and abends
       soft-exception.
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .

       end program cpuid.
      *> ***************************************************************
      *>****

>>ELSE
!rst-marker!
=====
cpuid
=====

cobc -xjg -debug -A '-Wa\,--defsym,DEBUG=1' cpuid.cob vendor.s brand.s fix-unsign.s
Vendor                : AuthenticAMD, with highest CPUID function: 13
CPUID normal maximum  : 00000000000000000013
Processor Brand string: AMD A10-5700 APU with Radeon(tm) HD Graphics
      **DEBUG** Number: 7fffffe2, Address: 0x603200
      **DEBUG** Number: 8000001e, Address: 0x603200
CPUID extended maximum: 00000000002147483678, 0x8000001E


Introduction
------------

CPUID is an opcode providing manufacturer and system configuration.

Source
------

cpuid.cob

.. include:: cpuid.cob
   :code: cobolfree
   :end-before: !rst-marker

vendor.s

.. include:: vendor.s
   :code: gas

brand.s

.. include:: brand.s
   :code: gas

fix-unsign.s

.. include:: fix-unsign.s
   :code: gas

>>END-IF

# Peek into CPUID to get basic chip vendor info
# x86_64 ABI
# Author: Brian Tiffin, with starter code from CPUID wikipedia page
# Public Domain sample
# Modified: 2015-11-13/15:20-0500

# cobc -x cpuinfo.cob vendor.s

    .data

# Display the Vendor tag (3 4byte registers)
#  and the highest CPUID function available
msg:
    .asciz "Vendor                : %.12s, with highest CPUID function: %i\n"

    .text
    .align  32

# setup the vendor entry point
    .globl  vendor

vendor:

# setup a local variable space
    pushq   %rbp
    pushq   %rbx
    movq    %rsp,%rbp
    subq    $24,%rsp

# call CPUID with function 0
    xorl    %eax,%eax
    cpuid

# save the max function number
    movl    %eax, 16(%rsp)

# move the Vendor tag to the local stack frame
    movl    %ebx,0(%rsp)
    movl    %edx,4(%rsp)
    movl    %ecx,8(%rsp)

# prep the printf call, args are rdi, rsi, rdx and rax
    movq    $msg, %rdi
    movq    %rsp, %rsi
    movl    %eax, %edx
    xorb    %al,%al
    call    printf

# return value is the highest CPUID function code allowed
    movl    16(%rsp), %eax

# restore the callers stack, rbx and rbp registers
    movq    %rbp,%rsp
    popq    %rbx
    popq    %rbp

    ret

# Peek into CPUID to get Vendor branding
# x86_64 ABI
# Author: Brian Tiffin, with starter code from CPUID wikipedia page
# Public Domain sample
# Modified: 2015-11-13/08:41-0500

# cobc -x callasm.cob brand.s

.section .data

msg: .asciz "Processor Brand string: %.48s\n"
err: .asciz "Processor Brand feature unsupported.\n"

.section .text

.globl brand
#.type brand,@function
.align 32

# set the brand entry point, and set aside local space
brand:
    pushq   %rbp
    movq    %rsp,   %rbp
    subq    $54,    %rsp
    pushq   %rbx

# call CPUID, for extended information
#   returning the highest extended code allowed
    movl    $0x80000000,    %eax
    cpuid

# save the result for return to COBOL
    movl    %eax, 48(%rsp)

# If not supported, display a message
    cmpl    $0x80000004,    %eax
    jl  error

# 48 bytes of data, three operations; subcode 80000002, 3 and 4
# 16 bytes returned on each CPUID operation
# ASCII data loaded in EAX, EBX, ECX, EDX
    movl    $0x80000002,    %esi
    movq    %rsp,   %rdi

.align 16
get_brand:
    movl    %esi,   %eax
    cpuid

    movl    %eax, (%rdi)
    movl    %ebx, 4(%rdi)
    movl    %ecx, 8(%rdi)
    movl    %edx, 12(%rdi)

    addl    $1, %esi
    addq    $16, %rdi
    cmpl    $0x80000004, %esi
    jle get_brand

# display the concatenated string
print_brand:
    movq    $msg, %rdi
    movq    %rsp, %rsi
    xorb    %al, %al
    call    printf

    jmp end

.align 16
error:
    movq    $err, %rdi
    xorb    %al, %al
    call    printf

.align 16
end:
# return with max extended code in eax
    movl    48(%rsp), %eax

    popq    %rbx
    movq    %rbp, %rsp
    popq    %rbp

    ret

# negate a bug, correct values cast from unsigned to signed
# x86_64 ABI
# Author: Brian Tiffin
# Public Domain sample
# Modified: 2015-11-13/15:10-0500

# cobc -x cpuid.cob vendor.s brand.c fix-unsign.s

.ifdef DEBUG
# fixed data space
    .data
msg:
    .asciz "      **DEBUG** Number: %x, Address: %p\n"
.endif

# code section
    .text
    .align  32

# setup the unsign-clip negate entry point
    .globl  fixunsign

fixunsign:

# setup a local variable space
    pushq   %rbp
    pushq   %rbx
    movq    %rsp,%rbp
    subq    $16,%rsp

# save the given numbers
    movl    %edi, 0(%rsp)
    movq    %rsi, 8(%rsp)

.ifdef DEBUG
# prep the printf call, args are rdi, rsi, rdx and rax
    movq    $msg, %rdi
    movl    0(%rsp), %esi
    movq    8(%rsp), %rdx
    xorb    %al,%al
    call    printf
.endif

# negate the value in place
    movl    0(%rsp), %edx
    negl    %edx
    movq    8(%rsp), %rax
    movl    %edx, (%rax)

.ifdef DEBUG
# prep the printf call, args are rdi, rsi, rdx and rax
    movq    $msg, %rdi
    movl    %edx, %esi
    movq    8(%rsp), %rdx
    xorb    %al,%al
    call    printf
.endif

# give back the number, which will suffer cast to int
    movl    0(%rsp), %eax

# restore the callers stack, rbx and rbp registers
    movq    %rbp,%rsp
    popq    %rbx
    popq    %rbp

    ret

.RECIPEPREFIX = >

cpuid: cpuid.cob
> cobc -xjg -debug -A '-Wa\,--defsym,DEBUG=1' \
    cpuid.cob vendor.s brand.s fix-unsign.s

prompt$ make -B

cobc -xjg -debug -A '-Wa\,--defsym,DEBUG=1' cpuid.cob vendor.s brand.s fix-unsign.s
Vendor                : AuthenticAMD, with highest CPUID function: 13
CPUID normal maximum  : 00000000000000000013
Processor Brand string: AMD A10-5700 APU with Radeon(tm) HD Graphics
      **DEBUG** Number: 7fffffe2, Address: 0x603200
      **DEBUG** Number: 8000001e, Address: 0x603200
CPUID extended maximum: 00000000002147483678, 0x8000001E

prompt$ sudo apt-get install libiberty-dev

prompt$ tar xvf lightning-2.1.0.tar.gz
prompt$ cd lightning-2.1.0
prompt$ ./configure --enable-disassembler
prompt$ make
prompt$ make check
prompt$ sudo make install
prompt$ sudo ldconfig

#include <stdio.h>
#include <lightning.h>

static jit_state_t *_jit;

typedef int (*pifi)(int);    /* Pointer to Int Function of Int */

int main(int argc, char *argv[])
{
  jit_node_t  *in;
  pifi         incr;

  init_jit(argv[0]);
  _jit = jit_new_state();

  jit_prolog();                    /*      prolog              */
  in = jit_arg();                  /*      in = arg            */
  jit_getarg(JIT_R0, in);          /*      getarg R0           */
  jit_addi(JIT_R0, JIT_R0, 1);     /*      addi   R0, R0, 1    */
  jit_retr(JIT_R0);                /*      retr   R0           */

  incr = jit_emit();
  jit_clear_state();

  /* call the generated code, passing 5 as an argument */
  printf("%d + 1 = %d\n", 5, incr(5));

  jit_destroy_state();
  finish_jit();
  return 0;
}

prompt$ gcc -o incr incr.c -llightning
prompt$ ./incr
5 + 1 = 6
prompt$

#include <stdio.h>
#include <lightning.h>

static jit_state_t *_jit;

typedef int (*pifi)(int);    /* Pointer to Int Function of Int */

int main(int argc, char *argv[])
{
  jit_node_t  *in;
  pifi         incr;

  init_jit(argv[0]);
  _jit = jit_new_state();

  jit_prolog();                    /*      prolog              */
  in = jit_arg();                  /*      in = arg            */
  jit_getarg(JIT_R0, in);          /*      getarg R0           */
  jit_addi(JIT_R0, JIT_R0, 1);     /*      addi   R0, R0, 1    */
  jit_retr(JIT_R0);                /*      retr   R0           */

  jit_print();               /* show me the code */

  incr = jit_emit();
  jit_clear_state();

  /* call the generated code, passing 5 as an argument */
  printf("%d + 1 = %d\n", 5, incr(5));

  jit_destroy_state();
  finish_jit();
  return 0;
}

prompt$ gcc -o incr incr.c -llightning
prompt$ ./incr
L0: /* prolog */
        arg 0x0
        movr %rax %rdi
        addi %rax %rax 0x1
        live %rax
    jmpi L0
5 + 1 = 6

#include <stdio.h>
#include <lightning.h>

static jit_state_t *_jit;

typedef int (*pifi)(int);    /* Pointer to Int Function of Int */

int main(int argc, char *argv[])
{
  jit_node_t  *in;
  pifi         incr;

  init_jit(argv[0]);
  _jit = jit_new_state();

  jit_prolog();                    /*      prolog              */
  in = jit_arg();                  /*      in = arg            */
  jit_getarg(JIT_R0, in);          /*      getarg R0           */
  jit_addi(JIT_R0, JIT_R0, 1);     /*      addi   R0, R0, 1    */
  jit_retr(JIT_R0);                /*      retr   R0           */

  jit_print();               /* show me the code */

  incr = jit_emit();
  jit_clear_state();

  /* call the generated code, passing 5 as an argument */
  printf("%d + 1 = %d\n", 5, incr(5));

  jit_disassemble();        /* now show me the real code */

  jit_destroy_state();
  finish_jit();
  return 0;
}

prompt$ gcc -o incr incr.c -llightning
prompt$ ./incr
L0: /* prolog */
        arg 0x0
        movr %rax %rdi
        addi %rax %rax 0x1
        live %rax
    jmpi L0
5 + 1 = 6
    0x7f86af1b3000      sub    $0x30,%rsp
    0x7f86af1b3004      mov    %rbp,(%rsp)
    0x7f86af1b3008      mov    %rsp,%rbp
    0x7f86af1b300b      sub    $0x18,%rsp
    0x7f86af1b300f      mov    %rdi,%rax
    0x7f86af1b3012      add    $0x1,%rax
    0x7f86af1b3016      mov    %rbp,%rsp
    0x7f86af1b3019      mov    (%rsp),%rbp
    0x7f86af1b301d      add    $0x30,%rsp
    0x7f86af1b3021      retq

*> TECTONICS
*>   cobc -x -g -debug inc.cob -llightning
*> ***************************************************************
 identification division.
 program-id. inc.

 data division.
 working-storage section.
 01 jit    usage pointer.

*> ***************************************************************
 procedure division.

 call "init_jit" using by content z"inc"
 call "jit_new_state" returning jit

 display jit
 goback.

prompt$ export COB_LDFLAGS='-Wl,--no-as-needed'
prompt$ cobc -xjdg inc.cob -llightning
0x00000000015b2d80

*> TECTONICS
*>   cobc -x -g -debug inc.cob -llightning
*> ***************************************************************
 identification division.
 program-id. inc.

 data division.
 working-storage section.
 01 jit    usage pointer.

*> ***************************************************************
 procedure division.

 call "init_jit" using by content z"inc"
 call "jit_new_state" returning jit

 call "jit_prolog"

 display jit
 goback.

prompt$ cobc -jxdg inc.cob -llightning
inc.cob: 17: libcob: Cannot find module 'jit_prolog'

prompt$ ag jit_prolog /usr/local/include/lightning.h
191:#define jit_prolog()                _jit_prolog(_jit)
538:     * to get a label just before a jit_prolog() call */
890:extern void _jit_prolog(jit_state_t*);

*> TECTONICS
*>   cobc -x -g -debug inc.cob -llightning
*> ***************************************************************
 identification division.
 program-id. inc.

 data division.
 working-storage section.
 01 jit    usage pointer.

*> ***************************************************************
 procedure division.

 call "init_jit" using by content z"inc"
 call "jit_new_state" returning jit

 call "_jit_prolog" using by value jit returning omitted

 display jit
 goback.

prompt$ cobc -jxdg inc.cob -llightning
0x0000000001161d80

prompt$ vi /usr/local/include/lightning.h
...
700 hours later
...

/*
* Short program to convert GNU Lightning JIT enums to GnuCOBOL constants
*  tectonics: gcc -o find-jit-enums find-jit-enums.c
*             ./find-jit-enums >lightning-enums.cpy
*/

#include <stdio.h>
#include <lightning.h>

#define display(NAME) printf("       01 %-28s constant as %d.\n", #NAME, NAME)

int
main(int argc, char **argv)
{
    display(JIT_R0);
    display(jit_code_addi);
}

prompt$ gcc -o find-jit-enums find-jit-enums.c
prompt$ ./find-jit-enums
       01 JIT_R0                       constant as 0.
       01 jit_code_addi                constant as 11.

*> TECTONICS
*>   cobc -x -g -debug inc.cob -llightning
*> ***************************************************************
 identification division.
 program-id. inc.
 installation. Requires GNU Lightning
 remarks. Create an incrementing function at runtime
 security. Writes new code at runtime

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.

 working-storage section.
 01 args   usage pointer value null.
 01 jit    usage pointer.
 01 inarg  usage pointer.
 01 incr   usage program-pointer.

*> Enums from lightning.h
 01 JIT_R0        constant as 0.
 01 jit_code_addi constant as 10.

 01 answer usage binary-long.

*> ***************************************************************
 procedure division.

 call "init_jit" using by content z"inc"
 call "jit_new_state" returning jit

 call "_jit_prolog" using by value jit

 call "_jit_arg" using by value jit returning inarg
 call "_jit_getarg_l" using by value jit JIT_R0 inarg

 call "_jit_new_node_www" using
     by value jit jit_code_addi JIT_R0 JIT_R0 1

 call "_jit_retr" using by value jit JIT_R0
 call "_jit_emit" using by value jit returning incr
 call "_jit_clear_state" using by value jit

 call incr using by value 5 returning answer
 display answer
 call incr using by value 41 returning answer
 display answer

 call "_jit_disassemble" using by value jit
 call "_jit_destroy_state" using by value jit
 call "finish_jit"
 goback.

prompt$ cobc -xjd inc.cob -llightning
+0000000006
+0000000042
    0x7f6dbc2d1000      sub    $0x30,%rsp
    0x7f6dbc2d1004      mov    %rbp,(%rsp)
    0x7f6dbc2d1008      mov    %rsp,%rbp
    0x7f6dbc2d100b      sub    $0x18,%rsp
    0x7f6dbc2d100f      mov    %rdi,%rax
    0x7f6dbc2d1012      add    $0x1,%rax
    0x7f6dbc2d1016      mov    %rbp,%rsp
    0x7f6dbc2d1019      mov    (%rsp),%rbp
    0x7f6dbc2d101d      add    $0x30,%rsp
    0x7f6dbc2d1021      retq

   *> jit-code3(instruction, dest-reg, source-reg, operand)
    $define %jit-code3i=
    call "_jit_new_node_www" using
        by value jit
        by value jit_code_!1
        by value JIT_!2
        by value JIT_!3
        by value !4
    end-call
    #

%jit-code3i(addi, R0, R0, 1)

# Makefile for cobweb-jit, gas and GNU Lightning integration
.RECIPEPREFIX = >

rpnasm: rpnasm.cbl lightning-enums.cpy
> cobolmac -q <rpnasm.cbl >rpnasm.cob
ifdef show
> cobc -x -g -debug -fdebugging-line rpnasm.cob -llightning
else
>cobc -x rpnasm.cob -llightning
endif
#> cobolmac -q <rpnasm.cbl | cobc - -x -llightning

lightning-enums.cpy: find-jit-enums.c /usr/local/include/lightning.h
> gcc -o find-jit-enums find-jit-enums.c
> ./find-jit-enums >lightning-enums.cpy

/*
* Short program to convert GNU Lightning JIT enums to GnuCOBOL constants
*  tectonics: gcc -o find-jit-enums find-jit-enums.c
*             ./find-jit-enums >lightning-enums.cpy
*/

#include <stdio.h>
#include <lightning.h>

#define display(NAME) printf("       01 %-28s constant as %d.\n", #NAME, NAME)

int
main(int argc, char **argv)
{
    display(JIT_R0);
    display(JIT_R1);
    display(JIT_R2);
    display(JIT_FP);
    display(jit_code_addi);
    display(jit_code_addr);
    display(jit_code_subr);
    display(jit_code_mulr);
    display(jit_code_divr);
    display(jit_code_movi);
    display(jit_code_movr);
    display(jit_code_stxi_i);
    display(jit_code_ldxi_i);
}

 GCobol >>SOURCE FORMAT IS FREE
 >>IF docpass NOT DEFINED
       *> ***************************************************************
       *>****J* project/rpnasm
       *> AUTHOR
       *>   Brian Tiffin
       *> DATE
       *>   20151126  Modified: 2016-07-21/06:56-0400
       *> LICENSE
       *>   Copyright 2015 Brian Tiffin
       *>   GNU General Public License, GPL, 3.0 (or greater)
       *> PURPOSE
       *>   Generates temp conversion calculator functions, on the fly.
       *> TECTONICS
       *>   cobolmac <rpnasm.cbl >rpnasm.cob
       *>   cobc -x -g -debug rpnasm.cob
       *> ***************************************************************
       *> ****** Macro definitions ******

       *> init-jit and create new state
        $define %init-jit=
        call "init_jit" using
            by content z"rpnasm"
            on exception
                display "error: no liblightning" upon syserr
                perform hard-exception
        end-call

        call "jit_new_state" returning jit end-call
        if jit equal null then
            display "error: jit_new_state retuned null" upon syserr
            perform hard-exception
        end-if
        #

       *> emit, emits current jit buffer
        $define %emit=
     >>D call "_jit_print" using by value jit end-call
        call "_jit_emit" using by value jit end-call
        #

       *> address, resolve the function addresses
        $define %address=
        call "_jit_address" using by value jit !1 returning !2 end-call
        #

       *> clear-jit, clear GNU Lightning work space
        $define %clear-jit=
        call "_jit_clear_state" using by value jit end-call
     >>D call "_jit_disassemble" using by value jit end-call
        #

       *> finish-jit, destroy and finish with GNU Lightning
        $define %finish-jit=
        call "_jit_destroy_state" using by value jit end-call
        call "finish_jit" end-call
        #

       *> Compile in an rpn calculator expression
        $define %compile-rpn=
        call "compile-rpn" using
            jit
            by content !1
            returning !2
        end-call
        #

       *> ***************************************************************
        identification division.
        program-id. rpnasm.
        author. Brian Tiffin.
        date-written. 2015-11-25/23:39-0500.
        date-modified. 2016-07-21/03:07-0400.
        date-compiled.
        installation. Requires COBOLMAC and GNU lightning.
        remarks. Generate simple calculator function dynamically.
        security. Self modifying code.

        environment division.
        configuration section.
        source-computer.
        object-computer.
        special-names.
        repository.
            function all intrinsic.

        input-output section.
        file-control.
        i-o-control.

        data division.
        file section.

        working-storage section.
        01 args                 usage pointer value null.
        01 jit                  usage pointer.

        01 jit-nc               usage pointer.
        01 jit-nf               usage pointer.
        01 jit-one              usage pointer.

        01 c2f                  usage program-pointer.
        01 f2c                  usage program-pointer.

        01 one-off              usage program-pointer.
        01 expression.
           05                   value z"x 123 + 456 * x - x *".

        01 cli                  pic x(80).
        01 jit-user             usage pointer.
        01 user-program         usage program-pointer.

        01 answer               usage binary-long.
        01 temp                 pic s999.
        01 show                 pic -999.

        local-storage section.
        linkage section.
        report section.
        screen section.


       *> ***************************************************************
        procedure division.
        accept cli from command-line

        %init-jit

       *> Compile in a Celsius to Fahrenheit calculator
        %compile-rpn(z"32 x 9 * 5 / +"#, jit-nc#)

       *> Compile in an F to C calculator
          *> **** try without a zstring, see if it still works ****
        %compile-rpn(z"x 32 - 5 * 9 /"#, jit-nf#)

       *> Compile in a one off
        %compile-rpn(expression#, jit-one#)

       *> compile in user entered expression
        if cli not equal spaces then
            call "compile-rpn" using
                jit
                by content concatenate(trim(cli), x"00")
                returning jit-user
            end-call
        end-if

        %emit

       *> lighting has the entry point addresses
        %address(jit-nc#, c2f#)
        %address(jit-nf#, f2c#)

        %address(jit-one#, one-off#)

        if jit-user not equal null then
            %address(jit-user#, user-program#)
        end-if

        %clear-jit

       *> Show some results
        display "Celsius   : " with no advancing
        perform varying temp from -100 by 20 until temp > 100
            display temp space with no advancing
        end-perform
        display space

        display "Fahrenheit: " with no advancing
        perform varying temp from -100 by 20 until temp > 100
            call c2f using by value temp returning answer
            move answer to show
            display show space with no advancing
        end-perform
        display space
        display space

        display "Fahrenheit: " with no advancing
        perform varying temp from -100 by 20 until temp > 140
            display temp space with no advancing
        end-perform
        display space

        display "Celsius   : " with no advancing
        perform varying temp from -100 by 20 until temp > 140
            call f2c using by value temp returning answer
            move answer to show
            display show space with no advancing
        end-perform
        display space
        display space

        call one-off using by value 42 returning answer
        display "(rpn x=42) :" trim(substitute(expression, x"00", space))
                ": is " answer

        if jit-user not equal null then
            call user-program using by value 42 returning answer
            display "(user rpn x=42) :" trim(cli) ": is " answer
        end-if

        %finish-jit

        goback.
       *> ***************************************************************

       *> informational warnings and abends
        soft-exception.
          display "Module:              " module-id upon syserr
          display "Module-path:         " module-path upon syserr
          display "Module-source:       " module-source upon syserr
          display "Exception-file:      " exception-file upon syserr
          display "Exception-status:    " exception-status upon syserr
          display "Exception-location:  " exception-location upon syserr
          display "Exception-statement: " exception-statement upon syserr
        .

        hard-exception.
            perform soft-exception
            stop run returning 127
        .

        end program rpnasm.
       *> ***************************************************************
       *>****

       *>****P* rpnasm/compile-rpn
       *> PURPOSE
       *>   Compiles calculator functions on the fly
       *> ***************************************************************
       *> ****** Macro definitions ******

        $define %note=
        call "_jit_note" using
            by value jit
            by reference NULL by value 0
            returning jit-node
        end-call
        #

        $define %prolog=
        call "_jit_prolog" using by value jit
        end-call
        #

        $define %arg=
        call "_jit_arg" using by value jit returning !1
        end-call
        #

        $define %getarg=
        call "_jit_getarg_l" using by value jit JIT_!1 returning !2
        end-call
        #

        $define %allocai=
        call "_jit_allocai" using by value jit !1 returning !2
        end-call
        #

        $define %ret=
        call "_jit_retr" using by value jit JIT_!1
        end-call
        #

        $define %epilog=
        call "_jit_epilog" using by value jit
        end-call
        #

       *> stack-push(register, stack-pointer)
        $define %stack-push=
        set address of inter to !2
        move inter to solid
        call "_jit_new_node_www" using
            by value jit
            by value jit_code_stxi_i
            by value size 8 solid
            by value JIT_FP
            by value JIT_!1
        end-call
        add 4 to inter
        #

       *> stack-pop(register, stack-pointer)
        $define %stack-pop=
        set address of inter to !2
        subtract 4 from inter
        move inter to solid
        call "_jit_new_node_www" using
            by value jit
            by value jit_code_ldxi_i
            by value JIT_!1
            by value JIT_FP
            by value size 8 solid
        end-call
        #

       *> jit-code1(instruction, reg)
        $define %jit-code1=
        call "_jit_new_node_ww" using
            by value jit
            by value jit_code_!1
            by value JIT_!2
        end-call
        #

       *> jit-code1i(instruction, operand)
        $define %jit-code1i=
        call "_jit_new_node_ww" using
            by value jit
            by value jit_code_!1
            by value !2
        end-call
        #

       *> jit-code2(instruction, dest-reg, source-reg)
        $define %jit-code2=
        call "_jit_new_node_ww" using
            by value jit
            by value jit_code_!1
            by value JIT_!2
            by value JIT_!3
        end-call
        #

       *> jit-code2i(instruction, dest-reg, source) with immediate
        $define %jit-code2i=
        call "_jit_new_node_ww" using
            by value jit
            by value jit_code_!1
            by value JIT_!2
            by value !3
        end-call
        #

       *> jit-code3(instruction, dest-reg, source-reg, operand)
        $define %jit-code3=
        call "_jit_new_node_www" using
            by value jit
            by value jit_code_!1
            by value JIT_!2
            by value JIT_!3
            by value JIT_!4
        end-call
        #

       *> ****** End macros ******

       *> ***************************************************************
        identification division.
        program-id. compile-rpn.
        remarks. Compile simple calculator function.
        environment division.
        configuration section.
        source-computer.
        object-computer.
        special-names.
        repository.
            function all intrinsic.

        data division.
        working-storage section.
       *> Enums from lightning.h
        COPY lightning-enums.

        01 inarg                usage pointer.
        01 stack                usage pointer.
        01 stack-size           usage binary-long.
        01 inter                usage binary-long based.
        01 solid                usage binary-double.

        01 expr                 usage pointer.
        01 chr                  pic x based.
        01 buff                 pic x(32).
        01 intval               usage binary-long.
        01 n                    usage binary-long.
        01 result               usage binary-long.

        01 jit-node-record.
           05 jit-node          usage pointer.

        linkage section.
        01 jit        usage pointer.
        01 expression pic x any length.

       *> ***************************************************************
        procedure division using
            jit expression
            returning jit-node-record.

        %note

        %prolog
        %arg(inarg#)

        *> allocate enough stack for 32 4 byte integers
        %allocai(128#, stack-size#)

        set stack to address of stack-size

        %getarg(R2#, inarg#)

        set expr to address of expression
        set address of chr to expr

        perform until chr equal x"00"
            call "sscanf" using by value expr
                by content z"%[0-9]%n"
                by reference buff
                by reference n
                returning result

            if result not equal zero
                move buff(1:n) to intval
                set expr up by n
                set expr down by 1
                %stack-push(R0#, stack#)
                %jit-code2i(movi#, R0#, intval#)
            else
                evaluate true
                    when chr equal 'x'
                        %stack-push(R0#, stack#)
                        %jit-code2(movr#, R0#, R2#)
                    when chr equal '+'
                        %stack-pop(R1#, stack#)
                        %jit-code3(addr#, R0#, R1#, R0#)
                    when chr equal '-'
                        %stack-pop(R1#, stack#)
                        %jit-code3(subr#, R0#, R1#, R0#)
                    when chr equal '*'
                        %stack-pop(R1#, stack#)
                        %jit-code3(mulr#, R0#, R1#, R0#)
                    when chr equal '/'
                        %stack-pop(R1#, stack#)
                        %jit-code3(divr#, R0#, R1#, R0#)
                    when chr equal space
                        continue
                    when other
                        display "cannot compile: " expression upon syserr
                        stop run
                end-evaluate
            end-if

            set expr up by 1
            set address of chr to expr
        end-perform

        %ret(R0#)
        %epilog

     >>D call "_jit_disassemble" using by value jit

        goback.
        end program compile-rpn.
 >>ELSE
 !doc-marker!

======
rpnasm
======

.. contents::

Introduction
------------

Reverse Polish Notation  calculators generated on the fly
with GNU lightning, and COBOLMAC macros.

The calculator is then used to produce temperature conversion charts.
and a simple one-off expression.

Tectonics
---------

    prompt$ cobolmac rpnasm.cbl >rpnasm.cob
    prompt$ cobc -x -g -debug rpnasm.cob -llightning

Usage
-----

    prompt$ ./rpnasm

Source
------

.. include::  rpnasm.cbl
   :code: cobolfree

>>END-IF

01 JIT_R0                       constant as 0.
01 JIT_R1                       constant as 1.
01 JIT_R2                       constant as 2.
01 JIT_FP                       constant as 15.
01 jit_code_addi                constant as 11.
01 jit_code_addr                constant as 10.
01 jit_code_subr                constant as 16.
01 jit_code_mulr                constant as 23.
01 jit_code_divr                constant as 29.
01 jit_code_movi                constant as 76.
01 jit_code_movr                constant as 75.
01 jit_code_stxi_i              constant as 127.
01 jit_code_ldxi_i              constant as 109.

prompt$ make show=yes
cobolmac -q <rpnasm.cbl >rpnasm.cob
cobc -x -g -debug -fdebugging-line rpnasm.cob -llightning
prompt$ time ./rpnasm 'x x + 2 *'

        #note
L0: # prolog
        arg 0x0
        movr %r11 %rdi
        stxi_i 0xffffffffffffff78 %rbp %rax
        movi %rax 0x20
        stxi_i 0xffffffffffffff7c %rbp %rax
        movr %rax %r11
        stxi_i 0xffffffffffffff80 %rbp %rax
        movi %rax 0x9
        ldxi_i %r10 %rbp 0xffffffffffffff80
        mulr %rax %r10 %rax
        stxi_i 0xffffffffffffff80 %rbp %rax
        movi %rax 0x5
        ldxi_i %r10 %rbp 0xffffffffffffff80
        divr %rax %r10 %rax
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        addr %rax %r10 %rax
        live %rax
    jmpi L1
L1: # epilog
        #note
L2: # prolog
        arg 0x0
        movr %r11 %rdi
        stxi_i 0xffffffffffffff78 %rbp %rax
        movr %rax %r11
        stxi_i 0xffffffffffffff7c %rbp %rax
        movi %rax 0x20
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        subr %rax %r10 %rax
        stxi_i 0xffffffffffffff7c %rbp %rax
        movi %rax 0x5
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        mulr %rax %r10 %rax
        stxi_i 0xffffffffffffff7c %rbp %rax
        movi %rax 0x9
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        divr %rax %r10 %rax
        live %rax
    jmpi L3
L3: # epilog
        #note
L4: # prolog
        arg 0x0
        movr %r11 %rdi
        stxi_i 0xffffffffffffff78 %rbp %rax
        movr %rax %r11
        stxi_i 0xffffffffffffff7c %rbp %rax
        movi %rax 0x7b
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        addr %rax %r10 %rax
        stxi_i 0xffffffffffffff7c %rbp %rax
        movi %rax 0x1c8
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        mulr %rax %r10 %rax
        stxi_i 0xffffffffffffff7c %rbp %rax
        movr %rax %r11
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        subr %rax %r10 %rax
        stxi_i 0xffffffffffffff7c %rbp %rax
        movr %rax %r11
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        mulr %rax %r10 %rax
        live %rax
    jmpi L5
L5: # epilog
        #note
L6: # prolog
        arg 0x0
        movr %r11 %rdi
        stxi_i 0xffffffffffffff78 %rbp %rax
        movr %rax %r11
        stxi_i 0xffffffffffffff7c %rbp %rax
        movr %rax %r11
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        addr %rax %r10 %rax
        stxi_i 0xffffffffffffff7c %rbp %rax
        movi %rax 0x2
        ldxi_i %r10 %rbp 0xffffffffffffff7c
        mulr %rax %r10 %rax
        live %rax
    jmpi L7
L7: # epilog

      sub    $0x30,%rsp
      mov    %rbp,(%rsp)
      mov    %rsp,%rbp
      sub    $0x98,%rsp
      mov    %rdi,%r11
      mov    %eax,-0x88(%rbp)
      mov    $0x20,%eax
      mov    %eax,-0x84(%rbp)
      mov    %r11,%rax
      mov    %eax,-0x80(%rbp)
      mov    $0x9,%eax
      movslq -0x80(%rbp),%r10
      imul   %r10,%rax
      mov    %eax,-0x80(%rbp)
      mov    $0x5,%eax
      movslq -0x80(%rbp),%r10
      mov    %rax,%r12
      mov    %r10,%rax
      cqto
      idiv   %r12
      movslq -0x84(%rbp),%r10
      add    %r10,%rax
      mov    %rbp,%rsp
      mov    (%rsp),%rbp
      add    $0x30,%rsp
      retq
      sub    $0x30,%rsp
      mov    %rbp,(%rsp)
      mov    %rsp,%rbp
      sub    $0x98,%rsp
      mov    %rdi,%r11
      mov    %eax,-0x88(%rbp)
      mov    %r11,%rax
      mov    %eax,-0x84(%rbp)
      mov    $0x20,%eax
      movslq -0x84(%rbp),%r10
      sub    %r10,%rax
      neg    %rax
      mov    %eax,-0x84(%rbp)
      mov    $0x5,%eax
      movslq -0x84(%rbp),%r10
      imul   %r10,%rax
      mov    %eax,-0x84(%rbp)
      mov    $0x9,%eax
      movslq -0x84(%rbp),%r10
      mov    %rax,%r12
      mov    %r10,%rax
      cqto
      idiv   %r12
      mov    %rbp,%rsp
      mov    (%rsp),%rbp
      add    $0x30,%rsp
      retq
      sub    $0x30,%rsp
      mov    %rbp,(%rsp)
      mov    %rsp,%rbp
      sub    $0x98,%rsp
      mov    %rdi,%r11
      mov    %eax,-0x88(%rbp)
      mov    %r11,%rax
      mov    %eax,-0x84(%rbp)
      mov    $0x7b,%eax
      movslq -0x84(%rbp),%r10
      add    %r10,%rax
      mov    %eax,-0x84(%rbp)
      mov    $0x1c8,%eax
      movslq -0x84(%rbp),%r10
      imul   %r10,%rax
      mov    %eax,-0x84(%rbp)
      mov    %r11,%rax
      movslq -0x84(%rbp),%r10
      sub    %r10,%rax
      neg    %rax
      mov    %eax,-0x84(%rbp)
      mov    %r11,%rax
      movslq -0x84(%rbp),%r10
      imul   %r10,%rax
      mov    %rbp,%rsp
      mov    (%rsp),%rbp
      add    $0x30,%rsp
      retq
      sub    $0x30,%rsp
      mov    %rbp,(%rsp)
      mov    %rsp,%rbp
      sub    $0x98,%rsp
      mov    %rdi,%r11
      mov    %eax,-0x88(%rbp)
      mov    %r11,%rax
      mov    %eax,-0x84(%rbp)
      mov    %r11,%rax
      movslq -0x84(%rbp),%r10
      add    %r10,%rax
      mov    %eax,-0x84(%rbp)
      mov    $0x2,%eax
      movslq -0x84(%rbp),%r10
      imul   %r10,%rax
      mov    %rbp,%rsp
      mov    (%rsp),%rbp
      add    $0x30,%rsp
      retq

Celsius   : -100 -080 -060 -040 -020 +000 +020 +040 +060 +080 +100
Fahrenheit: -148 -112 -076 -040 -004  032  068  104  140  176  212

Fahrenheit: -100 -080 -060 -040 -020 +000 +020 +040 +060 +080 +100 +120 +140
Celsius   : -073 -062 -051 -040 -028 -017 -006  004  015  026  037  048  060

(rpn x=42) :x 123 + 456 * x - x *: is +0003158316
(user rpn x=42) :x x + 2 *: is +0000000168

real    0m0.009s
user    0m0.008s
sys     0m0.004s

Programmer: "Well, look at that, I can generate assembly on the fly."
Security:   "No you can't."
Programmer: "Sure, look, it's right here, a reverse polish calculator.
             I just have to type it in and try it on the EC12."
Security:   "Maybe you didn't hear me; no you can't and no you won't."
Programmer: "Oh, ..., right.  I'll try it on my Hercules z/Linux node
             at home tonight."
Security:   "Much better thinking. We're good here, right?"
Programmer: "Yes, Ma'am. Sorry, lost view of the forest from the tree."
Security:   "All right then. It is pretty cool. Tell me how it goes."

*> ***************************************************************
*> LICENSE
*>   Public domain sample
*> PURPOSE
*>   Demonstrate interfacing to the D programming language
*> TECTONICS
*>   dmd -c hellod.d
*>   cobc -x -g -debug calld.cob hellod.o -lphobos2
*> ***************************************************************
 identification division.
 program-id. calld.

 data division.
 file section.
 working-storage section.
 01 aug usage binary-long.
 01 ans usage binary-long.

 procedure division.
*> Initialize D
 call "rt_init"
      on exception display "no -lphobos2" upon syserr end-display
 end-call
 if return-code not equal 1 then
     display "D phobos initialize failed" upon syserr end-display
 end-if

*> dynamic call, returns 42 plus the value in the augend
 call "dadd" using by value aug returning ans end-call
 display ans end-display

*> and a static call, for no reason really, other than testing
*>   would segfault without the rt_init call above
 call static "hellod" returning omitted end-call

*> run down D support
 call "rt_term"
     on exception display "no phobos2" upon syserr end-display
 end-call

 goback.
 end program calld.
*>****

// Hello D
import std.stdio;

// these functions are setup for the C ABI
extern (C) {
    void hellod() {
        writeln("Hello, D");
    }

    int dadd(int aug) {
        return aug + 42;
    }
}

prompt$ dmd -c hellod.d
prompt$ cobc -x -g -debug calld.cob hellod.o -lphobos2
prompt$ ./calld
+0000000042
Hello, D
prompt$

prompt$ dmd --help
DMD64 D Compiler v2.067.1
Copyright (c) 1999-2014 by Digital Mars written by Walter Bright
Documentation: http://dlang.org/
Config file: /etc/dmd.conf
Usage:
  dmd files.d ... { -switch }

  files.d        D source files
  @cmdfile       read arguments from cmdfile
  -allinst       generate code for all template instantiations
  -c             do not link
  -color[=on|off]   force colored console output on or off
  -conf=path     use config file at path
  -cov           do code coverage analysis
  -cov=nnn       require at least nnn% code coverage
  -D             generate documentation
  -Dddocdir      write documentation file to docdir directory
  -Dffilename    write documentation file to filename
  -d             silently allow deprecated features
  -dw            show use of deprecated features as warnings (default)
  -de            show use of deprecated features as errors (halt compilation)
  -debug         compile in debug code
  -debug=level   compile in debug code <= level
  -debug=ident   compile in debug code identified by ident
  -debuglib=name    set symbolic debug library to name
  -defaultlib=name  set default library to name
  -deps          print module dependencies (imports/file/version/debug/lib)
  -deps=filename write module dependencies to filename (only imports)
  -fPIC          generate position independent code
  -dip25         implement http://wiki.dlang.org/DIP25 (experimental)
  -g             add symbolic debug info
  -gc            add symbolic debug info, optimize for non D debuggers
  -gs            always emit stack frame
  -gx            add stack stomp code
  -H             generate 'header' file
  -Hddirectory   write 'header' file to directory
  -Hffilename    write 'header' file to filename
  --help         print help and exit
  -Ipath         where to look for imports
  -ignore        ignore unsupported pragmas
  -inline        do function inlining
  -Jpath         where to look for string imports
  -Llinkerflag   pass linkerflag to link
  -lib           generate library rather than object files
  -m32           generate 32 bit code
  -m64           generate 64 bit code
  -main          add default main() (e.g. for unittesting)
  -man           open web browser on manual page
  -map           generate linker .map file
  -boundscheck=[on|safeonly|off]   bounds checks on, in @safe only, or off
  -noboundscheck no array bounds checking (deprecated, use -boundscheck=off)
  -O             optimize
  -o-            do not write object file
  -odobjdir      write object & library files to directory objdir
  -offilename    name output file to filename
  -op            preserve source path for output files
  -profile       profile runtime performance of generated code
  -property      enforce property syntax
  -release       compile release version
  -run srcfile args...   run resulting program, passing args
  -shared        generate shared library (DLL)
  -transition=id show additional info about language change identified by 'id'
  -transition=?  list all language changes
  -unittest      compile in unit tests
  -v             verbose
  -vcolumns      print character (column) numbers in diagnostics
  --version      print compiler version and exit
  -version=level compile in version code >= level
  -version=ident compile in version code identified by ident
  -vtls          list all variables going into thread local storage
  -vgc           list all gc allocations including hidden ones
  -verrors=num   limit the number of error messages (0 means unlimited)
  -w             warnings as errors (compilation will halt)
  -wi            warnings as messages (compilation will continue)
  -X             generate JSON file
  -Xffilename    write JSON file to filename

/// Hello D from GnuCOBOL
/// License: use freely for any purpose
/// Date: 20150707
/// Tectonics: dmd -D hellod.d -unittest -main calld.o -L'-lcob'
module hellod;

import std.stdio;

/// hellogc is declared with C calling conventions
/// and defined in calld.cob
extern (C) int hellogc();

// Inner D functions, callable from GnuCOBOL with C conventions
extern (C) {

    /// ubiquitous hello, and call to GnuCOBOL
    void hellod() {
        writeln("Hello, D");
        hellogc();
    }

    /// Add 42 to a given augend
    /// Returns: the given integer increased by 42
    int dadd(int aug) {
        return aug + 42;
    }

    ///
    unittest {
        assert(dadd(0) == 41);
        assert(dadd(42) == 84);
    }
}


 prompt$ cobc -c calld.cob
 prompt$ dmd hellod.d -unittest -main calld.o -L'-lcob'
 prompt$ ./hellod
 core.exception.AssertError@hellod.d(30): unittest failure
 ----------------
 ./hellod(void hellod.__unittest_fail(int)+0x2f) [0x493bf7]
 ./hellod(void hellod.__unittestL29_1()+0x1a) [0x4700ca]
 ./hellod(void hellod.__modtest()+0x9) [0x493b91]
 ./hellod(int core.runtime.runModuleUnitTests().__foreachbody3(object.ModuleInfo*)+0x34) [0x4a1cb0]
 ./hellod(int object.ModuleInfo.opApply(scope int delegate(object.ModuleInfo*)).__lambda2(immutable(object.ModuleInfo*))+0x1c) [0x49693c]
 ./hellod(int rt.minfo.moduleinfos_apply(scope int delegate(immutable(object.ModuleInfo*))).__foreachbody2(ref rt.sections_elf_shared.DSO)+0x47) [0x49b7df]
 ./hellod(int rt.sections_elf_shared.DSO.opApply(scope int delegate(ref rt.sections_elf_shared.DSO))+0x42) [0x49b856]
 ./hellod(int rt.minfo.moduleinfos_apply(scope int delegate(immutable(object.ModuleInfo*)))+0x25) [0x49b775]
 ./hellod(int object.ModuleInfo.opApply(scope int delegate(object.ModuleInfo*))+0x25) [0x496915]
 ./hellod(runModuleUnitTests+0xa8) [0x4a1b44]
 ./hellod(void rt.dmain2._d_run_main(int, char**, extern (C) int function(char[][])*).runAll()+0x17) [0x498477]
 ./hellod(void rt.dmain2._d_run_main(int, char**, extern (C) int function(char[][])*).tryExec(scope void delegate())+0x2a) [0x49842a]
 ./hellod(_d_run_main+0x1dc) [0x4983a4]
 ./hellod(main+0x17) [0x493c1f]
 /usr/lib64/libc.so.6(__libc_start_main+0xf0) [0x375481ffe0]
 prompt$


/// Hello D from GnuCOBOL
/// License: use freely for any purpose
/// Date: 20150707
/// Tectonics: cobc -c calld.cob $(BR) dmd -D hellod.d
///                 -unittest -main calld.o -L'-lcob'
module hellod;

import std.stdio;

/// hellogc is declared with C calling conventions and defined in $(B calld.cob)
extern (C) int hellogc();

// Inner D functions, callable from GnuCOBOL with C conventions
extern (C) {

    /// ubiquitous hello, and call to GnuCOBOL
    void hellod() {
        writeln("Hello, D");
        hellogc();
    }

    /// Add 42 to a given augend
    /// Returns: the given integer increased by 42
    int dadd(int aug) {
        return aug + 42;
    }

    ///
    unittest {
        assert(dadd(0) == 42);
        assert(dadd(42) == 84);
    }
}

prompt$ dmd -D hellod.d -unittest -main calld.o -L'-lcob'
prompt$ ./hellod
prompt$

Gnu   *> ***************************************************************
COBOL *> LICENSE
calls *>   Public domain sample
D     *> PURPOSE
and   *>   Demonstrate interfacing to the D programming language
D     *> TECTONICS
calls *>   dmd -c hellod.d
COBOL *>   cobc -x -g -debug calld.cob hellod.o -lphobos2
      *> ***************************************************************
       identification division.
       program-id. calld.

       data division.
       file section.
       working-storage section.
       01 aug usage binary-long.
       01 ans usage binary-long.

       procedure division.
      *> Initialize D
       call "rt_init"
            on exception display "no -lphobos2" upon syserr end-display
       end-call
       if return-code not equal 1 then
           display "D phobos initialize failed" upon syserr end-display
       end-if

      *> dynamic call, returns 42 plus the value in the augend
       call "dadd" using by value aug returning ans end-call
       display ans end-display

      *> and a static call, for no reason really, other than testing
      *>   would segfault without the rt_init call above
       call static "hellod" returning omitted end-call

      *> run down D support
       call "rt_term"
           on exception display "no phobos2" upon syserr end-display
       end-call

       goback.
       end program calld.
      *>****

      *> ***************************************************************
      *> D will call this subprogram
       identification division.
       program-id. hellogc.
       procedure division.

       display "Hello, GnuCOBOL" end-display

       goback.
       end program hellogc.

prompt$ dmd -c hellod.d
prompt$ cobc -x -g -debug calld.cob hellod.o -lphobos2
prompt$ ./calld
+0000000042
Hello, D
Hello, GnuCOBOL
prompt$

// Dependencies
var Cobol = require("cobol");

// Execute some COBOL snippets
Cobol(function () { /*
       IDENTIFICATION DIVISION.
       PROGRAM-ID. HELLO.
       ENVIRONMENT DIVISION.
       DATA DIVISION.
       PROCEDURE DIVISION.

       PROGRAM-BEGIN.
           DISPLAY "Hello world".

       PROGRAM-DONE.
           STOP RUN.
*/ }, function (err, data) {
    console.log(err || data);
});
// => "Hello World"

Cobol(__dirname + "/args.cbl", {
    args: ["Alice"]
}, function (err, data) {
    console.log(err || data);
});
// => "Your name is: Alice"

IDENTIFICATION DIVISION.
PROGRAM-ID. CLIOPTIONS.
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.

01 argv                 pic x(100) value spaces.

PROCEDURE DIVISION.
ACCEPT argv FROM argument-value
DISPLAY "Your name is:" argv
STOP RUN.

VERIFY FILE INVOICE-FILE READ HAPPENED 24 TIMES
VERIFY FILE INVOICE-FILE OPEN HAPPENED ONCE
VERIFY FILE ERROR-LOG WRITE NEVER HAPPENED
VERIFY FILE INPUT-FILE OPEN HAPPENED NO MORE THAN ONCE
VERIFY FILE MASTER-FILE READ HAPPENED AT LEAST 2 TIMES
VERIFY CICS START TRANSID('TR01') HAPPENED ONCE
VERIFY PARAGRAPH 1000-PARA-A WAS PERFORMED 4 TIMES
VERIFY PARA 2000-PARA-B PERFORMED AT LEAST 3 TIMES
VERIFY PARAGRAPH 3000-PARA-C WAS NEVER PERFORMED
VERIFY PARA 4000-PARA-D NEVER PERFORMED

ZUTZCWS
SAMPLET

TESTSUITE 'GREETING AND FAREWELL (FAREWELL WILL FAIL)'

TESTCASE 'IT RETURNS HELLO, WORLD! AS GREETING'
MOVE 'GREETING' TO WS-MESSAGE-TYPE
PERFORM 2000-SPEAK
EXPECT WS-MESSAGE TO BE 'HELLO, WORLD!'

TESTCASE 'IT RETURNS GOODBYE, CRUEL WORLD! AS FAREWELL'
MOVE 'FAREWELL' TO WS-MESSAGE-TYPE
PERFORM 2000-SPEAK
EXPECT WS-MESSAGE TO BE 'GOODBYE, CRUEL WORLD!'

SAMPLE
       IDENTIFICATION DIVISION.
       PROGRAM-ID.  SAMPLE.
      *****************************************************************
      * TRIVIAL PROGRAM TO EXERCISE ZUTZCPC.
      *****************************************************************
       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  FILLER.
           05  WS-MESSAGE-TYPE          PIC X(08) VALUE SPACES.
           05  WS-MESSAGE               PIC X(40) VALUE SPACES.
       PROCEDURE DIVISION.

       2000-SPEAK.
           IF WS-MESSAGE-TYPE IS EQUAL TO 'GREETING'
               MOVE 'HELLO, WORLD!' TO WS-MESSAGE
           END-IF
           IF WS-MESSAGE-TYPE IS EQUAL TO 'FAREWELL'
               MOVE 'SEE YOU LATER, ALLIGATOR!' TO WS-MESSAGE
           END-IF
           .

       9999-END.
           .

echo 'SAMPLE'
echo 'This example demonstrates a minimal unit test setup'
echo
./run-ut SAMPLEC SAMPLE SAMPLET

SAMPLE
This example demonstrates a minimal unit test setup

==================================================
Running: ./run-ut SAMPLEC SAMPLE SAMPLET

TEST SUITE:
GREETING AND FAREWELL (FAREWELL WILL FAIL)

     PASS:   1. IT RETURNS HELLO, WORLD! AS GREETING
**** FAIL:   2. IT RETURNS GOODBYE, CRUEL WORLD! AS FAREWELL
    EXPECTED <GOODBYE, CRUEL WORLD!                                       >,
         WAS <SEE YOU LATER, ALLIGATOR!                                   >

  2 TEST CASES WERE EXECUTED
  1 PASSED
  1 FAILED
=================================================

MOCKUP
            TESTSUITE 'DEMONSTRATE CICS COMMAND MOCKS'

       *****************************************************************
       * DEMONSTRATE MOCKING EXEC CICS COMMANDS WITH ZUTZCPC.
       *****************************************************************

            TESTCASE 'Mock behavior of EXEC CICS READ DATASET'
            MOCK
                CICS READ DATASET('MYFILE')
                     RIDFLD('AAAAA')
                     INTO(WS-RECORD)
                MOVE 'AAAAABBBBBCCCCCDDDDDEEEEE' TO WS-RECORD
            END-MOCK
            PERFORM 0100-READ-DATASET
            EXPECT WS-FIELD-3 TO BE 'CCCCC'
            EXPECT EIBRESP TO BE NUMERIC ZERO
            VERIFY
                CICS READ DATASET('MYFILE')
                     RIDFLD('AAAAA')
                     INTO(WS-RECORD)
                HAPPENED ONCE


            TESTCASE 'Mock behavior of EXEC CICS WRITE DATASET'
            MOCK
                CICS WRITE DATASET('YOURFILE')
                     RIDFLD('AAAAA')
                     FROM(WS-RECORD)
            END-MOCK
            PERFORM 0200-WRITE-DATASET
            EXPECT EIBRESP TO BE NUMERIC ZERO

$ ./run-examples
SAMPLE
This example demonstrates a minimal unit test setup

==================================================
Running: ./run-ut SAMPLEC SAMPLE SAMPLET

TEST SUITE:
GREETING AND FAREWELL (FAREWELL WILL FAIL)

     PASS:   1. IT RETURNS HELLO, WORLD! AS GREETING
**** FAIL:   2. IT RETURNS GOODBYE, CRUEL WORLD! AS FAREWELL
    EXPECTED <GOODBYE, CRUEL WORLD!                                       >,
         WAS <SEE YOU LATER, ALLIGATOR!                                   >

  2 TEST CASES WERE EXECUTED
  1 PASSED
  1 FAILED
=================================================
FIZZBUZZ
This example demonstrates a unit test suite for
an implementation of FizzBuzz

==================================================
Running: ./run-ut FIZZBUZC FIZZBUZZ FIZZBUZT

TEST SUITE:
UNIT TESTS FOR FIZZBUZZ.CBL

     PASS:   1. IT RETURNS FIZZ FOR THE NUMBER 3 (DIVISIBLE BY 3)
     PASS:   2. IT RETURNS FIZZ FOR THE NUMBER 6 (DIVISIBLE BY 3)
     PASS:   3. IT RETURNS FIZZ FOR THE NUMBER 12 (DIVISIBLE BY 3)
     PASS:   4. IT RETURNS BUZZ FOR THE NUMBER 5 (DIVISIBLE BY 5)
     PASS:   5. IT RETURNS BUZZ FOR THE NUMBER 25 (DIVISIBLE BY 5)
     PASS:   6. IT RETURNS BUZZ FOR THE NUMBER 10 (DIVISIBLE BY 5)
     PASS:   7. IT RETURNS FIZZBUZZ FOR THE NUMBER 15 (DIV BY 3 AND 5)
     PASS:   8. IT RETURNS FIZZBUZZ FOR THE NUMBER 30 (DIV BY 3 AND 5)
     PASS:   9. IT RETURNS FIZZBUZZ FOR THE NUMBER 45 (DIV BY 3 AND 5)
     PASS:  10. IT RETURNS 4 FOR THE NUMBER 4 (NOT DIV BY 3 OR 5)
     PASS:  11. IT RETURNS BAZ FOR THE NUMBER 7 (DIV BY 7)

 11 TEST CASES WERE EXECUTED
 11 PASSED
  0 FAILED
=================================================
CONVERT
This example demonstrates unit tests for a batch program
that processes files. It shows how to organize the code
so that file access is not necessary to support the
automated unit tests

==================================================
Running: ./run-ut CONVERTC CONVERT CONVERTT

TEST SUITE:
CONVERT COMMA-DELIMITED FILE TO FIXED FORMAT

     PASS:   1. IT CONVERTS TEXT FIELD 1 TO UPPER CASE
     PASS:   2. IT CONVERTS TEXT FIELD 1 TO UPPER CASE
     PASS:   3. IT HANDLES EMPTY TEXT FIELD 1
     PASS:   4. IT CENTERS TEXT FIELD 2 AND CAPITALIZES FIRST LETTER
     PASS:   5. IT HANDLES EMPTY TEXT FIELD 2
     PASS:   6. IT FINDS THE STATE NAME FOR A VALID STATE CODE
     PASS:   7. IT RETURNS SPACES FOR AN INVALID STATE CODE
     PASS:   8. IT CONVERTS DECIMAL VALUE 10.45 TO 010.4500
     PASS:   9. IT CONVERTS AN EMPTY DECIMAL VALUE TO ZEROES

  9 TEST CASES WERE EXECUTED
  9 PASSED
  0 FAILED
=================================================
CONVER2
Same as CONVERT, but the program under test is written in
"classic" Cobol style (period after every statement)

==================================================
Running: ./run-ut CONVERTC CONVER2 CONVERTT

TEST SUITE:
CONVERT COMMA-DELIMITED FILE TO FIXED FORMAT

     PASS:   1. IT CONVERTS TEXT FIELD 1 TO UPPER CASE
     PASS:   2. IT CONVERTS TEXT FIELD 1 TO UPPER CASE
     PASS:   3. IT HANDLES EMPTY TEXT FIELD 1
     PASS:   4. IT CENTERS TEXT FIELD 2 AND CAPITALIZES FIRST LETTER
     PASS:   5. IT HANDLES EMPTY TEXT FIELD 2
     PASS:   6. IT FINDS THE STATE NAME FOR A VALID STATE CODE
     PASS:   7. IT RETURNS SPACES FOR AN INVALID STATE CODE
     PASS:   8. IT CONVERTS DECIMAL VALUE 10.45 TO 010.4500
     PASS:   9. IT CONVERTS AN EMPTY DECIMAL VALUE TO ZEROES

  9 TEST CASES WERE EXECUTED
  9 PASSED
  0 FAILED
=================================================
INVDATE
This example demonstrates unit test cases that have a
dependency on the system clock

==================================================
Running: ./run-ut INVDATEC INVDATE INVDATET

TEST SUITE:
UNIT TESTS FOR INVDATE.CBL

     PASS:   1. IT DETERMINES THE NEXT INVOICE DATE IN A 30-DAY MONTH
     PASS:   2. IT DETERMINES THE NEXT INVOICE DATE IN A 31-DAY MONTH
     PASS:   3. IT DETERMINES THE NEXT INVOICE DATE IN FEB, NON LEAP
     PASS:   4. IT DETERMINES THE NEXT INVOICE DATE IN FEB, LEAP

  4 TEST CASES WERE EXECUTED
  4 PASSED
  0 FAILED
=================================================
FILEDEMO
This example demonstrates mocking batch file accesses

==================================================
Running: ./run-ut FILEDEMC FILEDEMO FILEDEMT

TEST SUITE:
DEMONSTRATE FILE MOCKS

     PASS:   1. IT MOCKS SUCCESSFUL FILE OPEN INPUT
     PASS:   2. IT MOCKS READING AFTER EOF
     PASS:   3. IT MOCKS FILE-NOT-FOUND ON OPEN INPUT
     PASS:   4. IT MOCKS ERROR ON FILE OPEN INPUT
     PASS:   5. VERIFY     0 ACCESSES

  5 TEST CASES WERE EXECUTED
  5 PASSED
  0 FAILED
=================================================
CALLDEMO
This example demonstrates mocking CALL statements

==================================================
Running: ./run-ut CALLDEMC CALLDEMO CALLDEMT

TEST SUITE:
DEMONSTRATE CALL STATEMENT MOCKS

     PASS:   1. Mock behavior of basic CALL statement
     PASS:   2. Mock behavior of basic CALL statement
     PASS:   3. VERIFY     1 ACCESS
     PASS:   4. Mock behavior of classic CALL statement
     PASS:   5. Mock behavior of classic CALL statement
     PASS:   6. Mock CALL to dynamic subprogram
     PASS:   7. Mock CALL to dynamic subprogram

  7 TEST CASES WERE EXECUTED
  7 PASSED
  0 FAILED
=================================================
PARADEMO
This example demonstrates mocking paragraphs

==================================================
Running: ./run-ut PARADEMC PARADEMO PARADEMT

TEST SUITE:
DEMONSTRATE FILE MOCKS

     PASS:   1. IT MOCKS PARAGRAPH 2000-PARA-B
     PASS:   2. IT MOCKS PARAGRAPH 2000-PARA-B
     PASS:   3. VERIFY     1 ACCESS
     PASS:   4. IT MOCKS PARAGRAPH 1000-PARA-A
     PASS:   5. IT MOCKS PARAGRAPH 1000-PARA-A
     PASS:   6. VERIFY     1 ACCESS

  6 TEST CASES WERE EXECUTED
  6 PASSED
  0 FAILED
=================================================
SUBPROG
This example demonstrates how to set up unit tests for
a called subprogram

==================================================
Running: ./run-ut SUBPROGC SUBPROG SUBPROGT SUBPROGD

TEST SUITE:
DEMONSTRATE UNIT TESTING A CALLED SUBPROGRAM

     PASS:   1. IT RETURNS VALUE A TO THE CALLER
     PASS:   2. IT RETURNS VALUE B TO THE CALLER

  2 TEST CASES WERE EXECUTED
  2 PASSED
  0 FAILED
=================================================
CICSDEMO
This example demonstrates isolated unit tests for a
CICS application program. It does not require a CICS
environment to run.

==================================================
Running: ./run-ut CICSDEMC CICSDEMO CICSDEMT CICSDRIV

TEST SUITE:
DEMONSTRATE CICS COMMAND MOCKS

     PASS:   1. Mock behavior of EXEC CICS READ DATASET
     PASS:   2. Mock behavior of EXEC CICS READ DATASET
     PASS:   3. VERIFY     1 ACCESS
     PASS:   4. Mock behavior of EXEC CICS WRITE DATASET

  4 TEST CASES WERE EXECUTED
  4 PASSED
  0 FAILED
=================================================

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* SWIG/polyglot
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20150924
      *>   Modified: 2015-10-02/20:11-0400
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU General Public License, GPL, 3.0 (or greater)
      *> PURPOSE
      *>   polyglot programming with SWIG.
      *> TECTONICS
      *>   requires polyglot-swig.i and the Makefile
      *>   make [java | perl | python | tcl]
      *> ***************************************************************
       identification division.
       program-id. polyglot.
       author. Brian Tiffin.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 datetime             pic XXXX/XX/XXBXX/XX/XX.

      *> ***************************************************************
       procedure division.

       move function current-date to datetime
       inspect datetime replacing all "/" by ":" after initial space

       display "Hello from GnuCOBOL" end-display
       display "It is now " datetime end-display

       move 42 to return-code
       goback.
      *>****
>>ELSE

==============
polyglot usage
==============

Indistinguishable from magic.

Introduction
------------

Assembling a polyglot GnuCOBOL application can be as simple as:

    prompt$ make perl
    prompt$ perl
    use polyglot;
    polyglot::polyglot;

    prompt$ make tcl
    prompt$ tclsh
    % load polyglot.so polyglot
    % polyglot

    prompt$ make python
    prompt$ python
    py> import _polyglot
    py> _polyglot.polyglot()

    prompt$ make java
    prompt$ java main


Source
------

.. code-include::  polyglot.cob
   :language: cobol

.. code-include::  polyglot-swig.i
   :language: c

.. code-include::  Makefile
   :language: makefile

.. code-include::  main.java
   :language: java
>>END-IF

/* Polyglot programming with GnuCOBOL and SWIG */
/* Brian Tiffin, 20150924 */
%module polyglot
%{
int polyglot();
%}

int polyglot();

# polyglot programming with GnuCOBOL and SWIG

help:
    @echo "Targets include: java, perl, python, tcl, and contract"

java: polyglot.cob main.java polyglot-swig.i
    swig -java polyglot-swig.i
    cobc -fimplicit-init -C polyglot.cob
    gcc -c -fPIC polyglot.c polyglot-swig_wrap.c \
        -I/usr/lib/jvm/java-1.8.0-openjdk-1.8.0.60-14.b27.fc21.x86_64/include \
        -I/usr/lib/jvm/java-1.8.0-openjdk-1.8.0.60-14.b27.fc21.x86_64/include/linux
    gcc -shared -lcob polyglot.o polyglot-swig_wrap.o -o libpolyglot.so
    javac main.java
    @echo "Now do: java main"

perl: polyglot.cob polyglot-swig.i
    swig -perl5 polyglot-swig.i
    cobc -fimplicit-init -C polyglot.cob
    gcc -c `perl -MConfig -e 'print join(" ", \
        @Config{qw(ccflags optimize cccdlflags)}, "\
        -I$$Config{archlib}/CORE")'` polyglot.c polyglot-swig_wrap.c
    gcc `perl -MConfig -e 'print $$Config{lddlflags}'` \
        -lcob polyglot.o polyglot-swig_wrap.o -o polyglot.so
    @echo "Now do: perl; use polyglot; polyglot::polyglot;"

python: polyglot.cob polyglot-swig.i
    swig -python polyglot-swig.i
    cobc -fimplicit-init -C polyglot.cob
    gcc -fpic -c polyglot.c polyglot-swig_wrap.c -I/usr/include/python2.7
    ld -shared -lcob polyglot.o polyglot-swig_wrap.o -o _polyglot.so
    @echo "Now do: python; import _polyglot; _polyglot.polyglot()"

tcl: polyglot.cob polyglot-swig.i
    swig -tcl polyglot-swig.i
    cobc -fimplicit-init -C polyglot.cob
    gcc -fpic -c polyglot.c polyglot-swig_wrap.c
    gcc -shared -lcob polyglot.o polyglot-swig_wrap.o -o polyglot.so
    @echo "Now do: tclsh; load ./polyglot.so polyglot; polyglot"

contract: contract.cob contract-swig.i
    swig -python contract-swig.i
    cobc -fimplicit-init -C contract.cob
    gcc -fpic -c contract.c contract-swig_wrap.c -I/usr/include/python2.7
    ld -shared -lcob contract.o contract-swig_wrap.o -o _contract.so
    @echo "Now do: python; import _contract; _contract.contract(42)"

/* polyglot programming with GnuCOBOL, SWIG and Java */
import java.lang.reflect.Field;

public class main {
  public static void main(String argv[]) throws Exception {
    // set the library path, and invalidate the sys path cache
    System.setProperty("java.library.path", ".");
    Field fieldSysPath = ClassLoader.class.getDeclaredField("sys_paths");
    fieldSysPath.setAccessible(true);
    fieldSysPath.set(null, null);

    // and now we can load the library in current working dir
    System.loadLibrary("polyglot");
    polyglot.polyglot();
  }
}

prompt$ make perl
swig -perl5 polyglot-swig.i
cobc -fimplicit-init -C polyglot.cob
gcc -c `perl -MConfig -e 'print join(" ", \
    @Config{qw(ccflags optimize cccdlflags)}, \
    "-I$Config{archlib}/CORE")'` polyglot.c polyglot-swig_wrap.c
gcc `perl -MConfig -e 'print $Config{lddlflags}'` \
    -lcob polyglot.o polyglot-swig_wrap.o -o polyglot.so
Now do: perl; use polyglot; polyglot::polyglot;

prompt$ perl
use polyglot;
my $rc = polyglot::polyglot;
print($rc, "\n");

Hello from GnuCOBOL
It is now 2015/09/25 06:32:36
42

prompt$ make java
swig -java polyglot-swig.i
cobc -fimplicit-init -C polyglot.cob
gcc -c -fPIC polyglot.c polyglot-swig_wrap.c \
    -I/usr/lib/jvm/java-1.8.0-openjdk-1.8.0.60-14.b27.fc21.x86_64/include \
    -I/usr/lib/jvm/java-1.8.0-openjdk-1.8.0.60-14.b27.fc21.x86_64/include/linux
gcc -shared -lcob polyglot.o polyglot-swig_wrap.o -o libpolyglot.so
javac main.java
Now do: java main

prompt$ java main
Hello from GnuCOBOL
It is now 2015/09/25 06:32:00

prompt$ make python
swig -python polyglot-swig.i
cobc -fimplicit-init -C polyglot.cob
gcc -fpic -c polyglot.c polyglot-swig_wrap.c -I/usr/include/python2.7
ld -shared -lcob polyglot.o polyglot-swig_wrap.o -o _polyglot.so
Now do: python; import _polyglot; _polyglot.polyglot()

prompt$ python
Python 2.7.8 (default, Jul  5 2015, 14:16:16)
[GCC 4.9.2 20150212 (Red Hat 4.9.2-6)] on linux2
Type "help", "copyright", "credits" or "license" for more information.
>>> import _polyglot
>>> a = _polyglot.polyglot()
Hello from GnuCOBOL
It is now 2015/09/25 06:33:21
>>> print(a)
42

prompt$ make tcl
swig -tcl polyglot-swig.i
cobc -fimplicit-init -C polyglot.cob
gcc -fpic -c polyglot.c polyglot-swig_wrap.c
gcc -shared -lcob polyglot.o polyglot-swig_wrap.o -o polyglot.so
Now do: tclsh; load ./polyglot.so polyglot; polyglot

prompt$ tclsh
% load ./polyglot.so polyglot
% polyglot
Hello from GnuCOBOL
It is now 2015/09/25 06:34:12
42

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* SWIG/contract
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20150924
      *>   Modified: 2015-09-25/07:33-0400
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU General Public License, GPL, 3.0 (or greater)
      *> PURPOSE
      *>   polyglot contract programming with SWIG.
      *> TECTONICS
      *>   requires contract-swig.i and the Makefile
      *>   make contract
      *> ***************************************************************
       identification division.
       program-id. contract.
       author. Brian Tiffin.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 datetime             pic XXXX/XX/XXBXX/XX/XX.

       linkage section.
       01 argument             usage binary-long.

      *> ***************************************************************
       procedure division using by value argument.

       display argument end-display
       move function current-date to datetime
       inspect datetime replacing all "/" by ":" after initial space

       display "Hello from GnuCOBOL" end-display
       display "It is now " datetime end-display

       add 42 to argument giving return-code
       goback.
      *>****
>>ELSE

==============
contract usage
==============

Indistinguishable from magic.

Introduction
------------

Assembling a polyglot GnuCOBOL application with contracts, can be as
simple as::

    prompt$ make contract
    prompt$ python
    py> import _contract
    py> _contract.contract(2)
    py> _contract.contract(-1)

Source
------

.. code-include::  contract.cob
      :language: cobol

.. code-include::  contract-swig.i
      :language: c

.. code-include::  Makefile
      :language: makefile
>>END-IF

/* Contract programming with GnuCOBOL and SWIG */
/* Brian Tiffin, 20150924 */
%module contract
%{
int contract(int argument);
%}

%contract contract(int argument) {
require:
    argument >= 0;
ensure:
    contract == argument + 42;
}

int contract(int argument);

prompt$ make contract
swig -python contract-swig.i
cobc -fimplicit-init -C contract.cob
gcc -fpic -c contract.c contract-swig_wrap.c -I/usr/include/python2.7
ld -shared -lcob contract.o contract-swig_wrap.o -o _contract.so
Now do: python; import _contract; _contract.contract()

prompt$ python
Python 2.7.8 (default, Jul  5 2015, 14:16:16)
[GCC 4.9.2 20150212 (Red Hat 4.9.2-6)] on linux2
Type "help", "copyright", "credits" or "license" for more information.
>>> import _contract
>>> _contract.contract(3)
+0000000003
Hello from GnuCOBOL
It is now 2015/10/03 07:08:01
45

>>> _contract.contract(-1)
Traceback (most recent call last):
  File "<stdin>", line 1, in <module>
RuntimeError: Contract violation: require: (arg1>=0)

>>> _contract.contract(0)
+0000000000
Hello from GnuCOBOL
It is now 2015/10/03 07:08:21
42

small '128[@.+]' >codes.txt

small '.+[.+]' >allbytes.txt

small '16[0@# +]'
000 001 002 003 004 005 006 007 008 009 010 011 012 013 014 015

small '16[@# +]'
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

:Bbottle-{2!}s+ of beer;:Oon the wall;:Mmore;099+[# B O\, # B\.
Take one down and pass it around\, -{no M2!}# B O\.

]No M B O\, no M B\.
Go to the store and buy some M4\, 99 B O\.

prompt $ ./small -f 99bottles.small
99 bottles of beer on the wall, 99 bottles of beer.
Take one down and pass it around, 98 bottles of beer on the wall.

98 bottles of beer on the wall, 98 bottles of beer.
Take one down and pass it around, 97 bottles of beer on the wall.

...

2 bottles of beer on the wall, 2 bottles of beer.
Take one down and pass it around, 1 bottle of beer on the wall.

1 bottle of beer on the wall, 1 bottle of beer.
Take one down and pass it around, no more bottles of beer on the wall.

No more bottles of beer on the wall, no more bottles of beer.
Go to the store and buy some more, 99 bottles of beer on the wall.

0[Printable Ascii Chart in small s.c.r.i.p.t., by Brian Tiffin]
10[ ]Printable ASCII Chart
10[ ]21[=]
032+:~0@# .  ;15[~5[16+~]10.79-]~4[16+~]10.

prompt$ small -f asciichart.small

          Printable ASCII Chart
          =====================
032    048 0  064 @  080 P  096 `  112 p
033 !  049 1  065 A  081 Q  097 a  113 q
034 "  050 2  066 B  082 R  098 b  114 r
035 #  051 3  067 C  083 S  099 c  115 s
036 $  052 4  068 D  084 T  100 d  116 t
037 %  053 5  069 E  085 U  101 e  117 u
038 &  054 6  070 F  086 V  102 f  118 v
039 '  055 7  071 G  087 W  103 g  119 w
040 (  056 8  072 H  088 X  104 h  120 x
041 )  057 9  073 I  089 Y  105 i  121 y
042 *  058 :  074 J  090 Z  106 j  122 z
043 +  059 ;  075 K  091 [  107 k  123 {
044 ,  060 <  076 L  092 \  108 l  124 |
045 -  061 =  077 M  093 ]  109 m  125 }
046 .  062 >  078 N  094 ^  110 n  126 ~
047 /  063 ?  079 O  095 _  111 o

COBOL  >>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin
      *> Date:      20130730, 20130810
      *> Purpose:   small s.c.r.i.p.t.
      *> Tectonics: ./configure; make; make check && sudo make install
      *>              or, cobc -x small.cob
      *> License:   As with all entries on esolang.org
      *>            small s.c.r.i.p.t. is dedicated to the Public Domain
      *> ***************************************************************
       identification division.
       program-id. small.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       input-output section.
       file-control.

           select program-channel
           assign to program-filename
           organization is line sequential
           status is program-channel-status
           .

      *> Magic numbers
       replace ==SMALL-BUFFER== by  ==32768==
                ==BIG-BUFFER==  by ==1048576==.

       data division.
       file section.
       fd program-channel.
           01 source-line      pic x(SMALL-BUFFER).


       working-storage section.
       01 argv                 pic x(BIG-BUFFER).
       01 current-arg          pic x(256).
          88 helping             value "-h", "--h", "--help".
          88 versioning          value "-v", "--v", "--version".
          88 use-file            value "-f", "--f", "--file".
          88 done-arguments      value high-value.
       01 file-used            pic x.
          88 file-loaded         value high-value.

       01 program-source.
          05 source-tape       pic x
                                 occurs 0 to BIG-BUFFER times
                                 depending on tape-length.
       01 tape-length          usage index.
       01 tape-position        usage index.
       01 ascii-value          pic 999.

       01 program-filename     pic x(256).

      *> Support single quote call
       01 first-quote          usage index.
       01 second-quote         usage index.
       01 symbol-len           pic 999.

      *> Memory.
       01 main-memory.
          05 memory-cell       usage binary-char unsigned
                                 occurs 0 to SMALL-BUFFER times
                                 depending on maximum-cell.
       01 maximum-cell         usage index value 1.
       01 current-cell         usage index value 1.
       01 fetch-cell           usage index value 1.
       01 character-value      pic x.

      *> numeric literal modes
       01 zero-context         pic x.
          88 leading-zero        value high-value
                                 when set to false is low-value.
       01 number-content       pic x.
          88 numbering           value high-value
                                 when set to false is low-value.
       01 last-number          usage binary-char unsigned.
       01 default-value        usage binary-char unsigned.
       01 zeroed-number        pic 999.
       01 formatted-number     pic zz9.

       01 colon-dictionary.
          05 colon-offsets     usage index occurs 256 times.

       01 colon-callstack.
          05 colon-returns     usage index
                                 occurs 0 to SMALL-BUFFER times
                                 depending on colons.
       01 colons               usage index.

       01 loop-stack.
          05 loop-offsetlimits  occurs 0 to 256 times
                                  depending on this-loop.
             10 loop-offsets   usage index.
             10 loop-is-numbered   pic x.
             10 loop-limits    usage index.
       01 this-loop            usage index.
       01 loop-limit           usage index.
       01 bracket-counter      usage binary-long.
       01 enter-block          usage index.

      *> I/O channels
       01 program-channel-status.
          88 no-more-source          value high-value.
          05 source-status-one     pic 9.
          05 filler                pic 9.

      *> for comma
       01 user-line            pic x(SMALL-BUFFER).
       01 current-char         usage index.

      *> fsync output
       01 flush-status         usage binary-long.

      *> unix newline, should test for the other two kinds.
       01 newline pic x value x"0a".

      *> ***************************************************************
       procedure division.
       start-here.

      *> Parse command line options if any
           move high-values to current-arg
           accept current-arg from argument-value end-accept
           perform until done-arguments
               evaluate true
                   when helping
                       perform show-help
                   when versioning
                       perform show-version
                   when use-file
                       perform read-program-from-file
               end-evaluate

               move high-values to current-arg
               accept current-arg from argument-value end-accept
           end-perform

      *> Accept program text from command line
           if not file-loaded then
               accept argv from command-line end-accept
               set tape-length to BIG-BUFFER

               if argv not equal spaces then
                   move argv to program-source
               else
                   move "small s\.c\.r\.i\.p\.t\.10."
                     to program-source
               end-if
           end-if

           set tape-length to length(trim(program-source))
           set tape-position to 1
       .

      *>
      *> The big goto
      *>
       process-next.
           if tape-position greater than tape-length then
               go to script-end
           end-if

           compute
               ascii-value = ord(source-tape(tape-position))
           end-compute

           go to
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo

               echo L034 L035 L036 echo echo echo L040
               echo echo echo L044 L045 L046 L047 echo
               L049 L050 L051 L052 L053 L054 L055 L056
               L057 L058 L059 L060 L061 echo L063 L064

               L065 echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo L092 L093 L094 echo echo

               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo L124 echo L126 echo echo

               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo

               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo

               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo

               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
               echo echo echo echo echo echo echo echo
           depending on ascii-value
       .

      *> If we get here, the small engine is broken, and it would be
      *>  uncool to fall through to the stepper.
       fail-safe.
           display
               "small engine problem. You get to laugh, and yell FAIL"
           end-display
           go script-end
       .

      *> we get here by jumping.  Handles digits and symbols that
      *>  need to pass literal value context to the next symbol
      *>  all other symbols reset context registers
       next-step.
           set tape-position up by 1
           go to process-next
       .

      *> or here for most symbols
       next-reset.
           move 0 to last-number
           set leading-zero numbering to false
           set tape-position up by 1
           go to process-next
       .

      *> The end.  s.c.r.i.p.t. complete.
       script-end.
      *> single quote CALL sets return-code, so clear it just in case
           move 0 to return-code
           goback.
      *> ***************************************************************

      *> The opcodes
      *> Ordinals start at 1
      *> Default runtime is to check for and execute colon defs, or echo
       echo.
           if colon-offsets(ascii-value) equal zero then
               display
                   source-tape(tape-position) with no advancing
               end-display
               move 0 to last-number
               set leading-zero numbering to false
           else
               set colons up by 1
               set colon-returns(colons) to tape-position
               set tape-position to
                   colon-offsets(ascii-value)
           end-if
           compute
               ascii-value = ord(source-tape(tape-position))
           end-compute

      *> Call step instead of reset so colon definitions can assume a
      *>  literal context when called.
           go to next-step
       .

      *> GOTO tape position
       L034.
    >>D    display " STORE " end-display
           if numbering then
               if leading-zero then
                   move last-number to tape-position
                   set tape-position down by 1
               else
                   add last-number to tape-position end-add
               end-if
           else
               move memory-cell(current-cell) to tape-position
           end-if

      *> When small implements audio, this will play some Grateful Dead
      *>                     SPACE
      *> as the tape position would be beyond the program source
           if (tape-position greater than tape-length)
           or (tape-position less than zero) then
               set tape-length to tape-position
           end-if

           go to next-reset
       .

      *> Quote in a string
       L035.
    >>D    display " QUOTE " end-display
           if numbering then
               move last-number to current-cell
               if current-cell is greater than maximum-cell then
                   set maximum-cell to current-cell
               end-if
           end-if

           perform until tape-position is greater than tape-length
               set tape-position up by 1
               if source-tape(tape-position) = '"' then
                   exit perform
               end-if
               move source-tape(tape-position) to character-value
               if leading-zero then
                   perform rot13-convert
               end-if
               compute memory-cell(current-cell) =
                   ord(character-value) - 1
               end-compute

      *> Do a little dance, to avoid cell advance if no more characters
               set tape-position up by 1
               if (tape-position less than or equal to tape-length) and
                  (source-tape(tape-position) not = '"') then
                   set current-cell up by 1
                   if current-cell is greater than maximum-cell then
                       set maximum-cell to current-cell
                   end-if
               end-if
               set tape-position down by 1
           end-perform

           go to next-reset
       .

      *> Display as number
       L036.
    >>D    display " OCTOTHORP " end-display
           if numbering then
               move last-number to default-value
           else
               move memory-cell(current-cell) to default-value
           end-if
           if leading-zero then
               move default-value to zeroed-number
               display zeroed-number with no advancing end-display
           else
               move default-value to formatted-number
               display
                   trim(formatted-number leading) with no advancing
               end-display
           end-if

           go to next-reset
       .

      *> single quote CALL
       L040.
    >>D    display " CALL " end-display
           set first-quote to tape-position
           set second-quote to tape-position
           set second-quote up by 1
           perform until second-quote > tape-length
               if source-tape(second-quote) equal "'" then
                   set tape-position to second-quote
                   exit perform
               end-if
               set second-quote up by 1
           end-perform

           set second-quote down by 1
           compute
               symbol-len = second-quote - first-quote
           end-compute
           set first-quote up by 1

      *> If numbering, then set cell to last-number
           if numbering then
               set current-cell to last-number
               if current-cell greater than maximum-cell then
                   set maximum-cell to current-cell
               end-if
           end-if

      *> For leading zero, pass address, leave status in last-number
           if leading-zero then
               call program-source(first-quote : symbol-len) using
                   by value address of memory-cell(current-cell)
                   returning last-number
                   on exception
                       display "failed: "
                           program-source(first-quote : symbol-len)
                       end-display
               end-call
           else
               call program-source(first-quote : symbol-len) using
                   by value memory-cell(current-cell)
                   returning memory-cell(current-cell)
                   on exception
                       display "failed: "
                           program-source(first-quote : symbol-len)
                       end-display
              end-call
           end-if

           go to next-step
       .

      *> Add
       L044.
    >>D    display " PLUS " end-display
           if leading-zero then
               move zero to memory-cell(current-cell)
           end-if
           if numbering then
               move last-number to default-value
           else
               move 1 to default-value
           end-if
           add default-value to memory-cell(current-cell) end-add

           go to next-reset
       .

      *> Accept input
       L045.
    >>D    display " COMMA " end-display
           accept user-line end-accept

           if numbering then
               move last-number to default-value
           else
               move 1 to default-value
           end-if

           set current-char to 1
           perform until default-value equal zero
               compute memory-cell(current-cell) =
                   ord(user-line(current-char:1)) - 1
               end-compute
               set default-value down by 1
               if default-value greater than zero then
                   set current-char up by 1
                   set current-cell up by 1
                   if current-cell greater than maximum-cell then
                       set maximum-cell to current-cell
                   end-if
               end-if
           end-perform

           go to next-reset
       .

      *> Subtract
       L046.
    >>D    display " MINUS " end-display
           if leading-zero then
               move zero to memory-cell(current-cell)
           end-if
           if numbering then
               move last-number to default-value
           else
               move 1 to default-value
           end-if
           subtract
               default-value from memory-cell(current-cell)
           end-subtract

           go to next-reset
       .

      *> Output as ASCII
       L047.
    >>D    display " DOT " end-display
           if numbering then
               move last-number to default-value
           else
               move memory-cell(current-cell) to default-value
           end-if
           move char(default-value + 1) to character-value
           if leading-zero then
               perform rot13-convert
           end-if
           if character-value not equal 10 then
               display character-value with no advancing end-display
           else
               call "fsync" using by value 1
                   returning flush-status
                   on exception display "fsync fail" end-display
               end-call
           end-if

           go to next-reset
       .

      *> Zero, with special rules for leading
       L049.
    >>D    display " Zero " end-display
           if numbering then
               multiply
                   last-number by 10 giving last-number
               end-multiply
           else
              set last-number to zero
              set leading-zero numbering to true
           end-if
           go to next-step
       .

      *> Digits, build up number
       L050.
    >>D    display " One " end-display
           perform prep-digit
           add 1 to last-number end-add
           go to next-step
       .

       L051.
    >>D    display " Two " end-display
           perform prep-digit
           add 2 to last-number end-add
           go to next-step
       .

       L052.
    >>D    display " Three " end-display
           perform prep-digit
           add 3 to last-number end-add
           go to next-step
       .

       L053.
    >>D    display " Four " end-display
           perform prep-digit
           add 4 to last-number end-add
           go to next-step
       .

       L054.
    >>D    display " Five " end-display
           perform prep-digit
           add 5 to last-number end-add
           go to next-step
       .

       L055.
    >>D    display " Six " end-display
           perform prep-digit
           add 6 to last-number end-add
           go to next-step
       .

       L056.
    >>D    display " Seven " end-display
           perform prep-digit
           add 7 to last-number end-add
           go to next-step
       .

       L057.
    >>D    display " Eight " end-display
           perform prep-digit
           add 8 to last-number end-add
           go to next-step
       .

       L058.
    >>D    display " Nine " end-display
           perform prep-digit
           add 9 to last-number end-add
           go to next-step
       .

       L059.
    >>D    display " COLON " end-display
           if numbering then
              move last-number to default-value
              add 1 to default-value end-add
           else
              set tape-position up by 1
              if tape-position not greater than tape-length
                  move ord(source-tape(tape-position)) to default-value
              else
                  go to next-reset
              end-if
           end-if

           set colon-offsets(default-value) to tape-position
           perform until source-tape(tape-position) = ";"
               set tape-position up by 1
               if tape-position greater than tape-length then
                   display "end of tape before ;" end-display
                   exit perform
               end-if
           end-perform

           go to next-reset
       .

       L060.
    >>D    display " SEMI-COLON " end-display
           if colons greater than zero then
               set tape-position to colon-returns(colons)
               set colons down by 1
           else
      *> no colon, semi-colon can suck it, and be ignored.
               continue
           end-if

           go to next-reset
       .

       L061.
    >>D    display " LESS-THAN " end-display
           if leading-zero then
               set current-cell to maximum-cell
           end-if
           if numbering then
               move last-number to default-value
           else
               move 1 to default-value
           end-if

           subtract default-value from current-cell end-subtract

           go to next-reset
       .

       L063.
    >>D    display " GREATER-THAN " end-display
           if leading-zero then
               move zero to current-cell
           end-if
           if numbering then
               move last-number to default-value
           else
               move 1 to default-value
           end-if

           add default-value to current-cell end-add
           if current-cell greater than maximum-cell then
               set maximum-cell to current-cell
           end-if

           go to next-reset
       .

       L064.
    >>D    display " QUESTIONMARK " end-display
           if leading-zero then
               display "Debug" end-display
           end-if
           if numbering then
               move last-number to default-value
           else
               compute last-number = random() * 1000 end-compute
               compute
                   last-number = mod(last-number, 255) + 1
               end-compute
           end-if

           move last-number to memory-cell(current-cell)
           go to next-reset
       .

       L065.
    >>D    display " FETCH " end-display
           if numbering then
               add
                   last-number to current-cell giving fetch-cell
               end-add
           else
               move current-cell to fetch-cell
               set numbering to true
           end-if
           if leading-zero then
               if last-number equal zero then
                   move current-cell to fetch-cell
               else
                   move last-number to fetch-cell
               end-if
           end-if

           if fetch-cell greater than maximum-cell then
               set maximum-cell to fetch-cell
           end-if

           move memory-cell(fetch-cell) to last-number

           go to next-step
       .

       L092.
    >>D    display " BRACKET " end-display
           set this-loop up by 1
           if numbering then
               move last-number to loop-limit
           else
               if loop-is-numbered(this-loop) equal high-value then
                   move loop-limits(this-loop) to loop-limit
               else
                   move memory-cell(current-cell) to loop-limit
               end-if
           end-if

      *> If current is zero, skip to end of the (nested) loop
           move 0 to bracket-counter
           if loop-limit equal zero then
               move low-value to loop-is-numbered(this-loop)
               set this-loop down by 1
               perform until tape-position greater than tape-length
                   set tape-position up by 1
                   if source-tape(tape-position) = '[' then
                       add 1 to bracket-counter end-add
                   end-if
                   if source-tape(tape-position) = "]" then
                       if bracket-counter = zero then
                           exit perform
                       end-if
                       subtract 1 from bracket-counter end-subtract
                   end-if
               end-perform
           else
      *> small allows for counted loops, and needs to remember
               if numbering then
                   move high-value to loop-is-numbered(this-loop)
                   move loop-limit to loop-limits(this-loop)
               end-if
               set loop-offsets(this-loop) to tape-position
      *> Next step will advance, decrement it here to account
               set loop-offsets(this-loop) down by 1
           end-if

           go to next-reset
       .

      *> Output next operator, regardless
       L093.
    >>D    display " BACKSLASH " end-display
           if numbering then
               move last-number to default-value
           else
               move 1 to default-value
           end-if

      *> Special backslash escape mode  with 0\
           if default-value equal zero then
               perform until tape-position equal to tape-length
                   set tape-position up by 1
                   if source-tape(tape-position) = '\' then
                       exit perform
                   end-if
                   display
                      source-tape(tape-position) with no advancing
                   end-display
               end-perform
               if tape-position greater than tape-length then
                   go to script-end
               end-if
           else
               perform until default-value equal zero
                   set tape-position up by 1
                   move source-tape(tape-position) to character-value
                   if leading-zero then
                       perform rot13-convert
                   end-if
                   display character-value with no advancing end-display
                   set default-value down by 1
               end-perform
          end-if

          go to next-reset
       .

       L094.
    >>D    display " CLOSE BRACKET " end-display
           if loop-is-numbered(this-loop) equal high-value then
               set loop-limits(this-loop) down by 1
           end-if

           set tape-position to loop-offsets(this-loop)
           set this-loop down by 1

           go to next-reset
       .

       L124.
    >>D    display " BRACE " end-display
           if numbering then
               move last-number to enter-block
           else
               move memory-cell(current-cell) to enter-block
           end-if

      *> If current is not zero, skip to end of the (nested) block
           move 0 to bracket-counter
           if enter-block not equal zero then
               perform until tape-position greater than tape-length
                   set tape-position up by 1
                   if source-tape(tape-position) = '{' then
                       add 1 to bracket-counter end-add
                   end-if
                   if source-tape(tape-position) = "}" then
                       if bracket-counter = zero then
                           exit perform
                       end-if
                       subtract 1 from bracket-counter end-subtract
                   end-if
               end-perform
           end-if

           go to next-reset
       .

       L126.
    >>D    display " CLOSE BRACE " end-display

           go to next-reset
       .

      *>
      *> Support routines
      *>

      *> code common to all digits, except 0
       prep-digit.
           if numbering then
               multiply
                   last-number by 10 giving last-number
               end-multiply
           else
              set last-number to zero
              set numbering to true
           end-if
       .

      *> secret sam decoder rings
       rot13-convert.
           inspect character-value converting
                "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
                     to
                "NOPQRSTUVWXYZABCDEFGHIJKLMnopqrstuvwxyzabcdefghijklm"
       .

      *> --file support
       read-program-from-file.
           set tape-length to 0
           accept program-filename from argument-value end-accept

           if program-filename equal spaces then
               move 27 to tape-length
               move "small s\.c\.r\.i\.p\.t\.10." to program-source
           else
               open input program-channel
               if source-status-one not equal zero then
                   display "Sorry, file " trim(program-filename)
                          " not accessible."
                   end-display
                   move 1 to return-code
                   goback
               end-if

               read program-channel
                   at end set no-more-source to true
               end-read
               perform until no-more-source
                   set tape-length up by length(trim(source-line))
                   set tape-length up by 1
      *> add in newline, stripped by LINE SEQUENTIAL
                   move concatenate(trim(program-source)
                           trim(source-line) newline)
                   to program-source
                   read program-channel
                       at end set no-more-source to true
                   end-read
               end-perform
               close program-channel
      *> Remove final newline as possibly unwanted output
               if source-tape(tape-length) equal newline then
                   set tape-length down by 1
               end-if
           end-if
           set file-loaded to true
       .

       show-version.
           display "small s.c.r.i.p.t. 0.6.2" end-display
           goback
       .

       show-help.

       >>SOURCE FORMAT IS FREE
           display
               "small s.c.r.i.p.t." newline
               "-v0.6.2  Aug 2013-" newline
               "A single character read interpret programming toyol" newline
               "by Brian Tiffin, while horsing around with autoconf and OpenCOBOL"
               newline newline
               "Operators include:" newline
               "  ' allowing CALL of a link library symbol" newline
               '  " for placing strings into memory' newline
               "  : colon definitions of the next character" newline
               "  ; marking the end of a colon definition" newline
               "  > for advancing the memory pointer" newline
               "  < for retreating the memory pointer" newline
               "  + adding to current cell" newline
               "  - subtracting from current cell" newline
               "  [ opening a (nestable) enter when not zero loop" newline
               "  ] closing a loop" newline
               "  { opening a (nestable) enter on zero block" newline
               "  } closing a zero block" newline
               "  . to output ascii" newline
               "  , to accept ascii" newline
               "  # to output number" newline
               "  ? randomize cell or numbered debug" newline
               "  @ fetch numbered cell and treat as literal number to next operator"
               newline
               "  \ to echo next operator, or number thereof" newline
               "  ! set source tape position to value or relative value" newline
               "  0 leading zeros further modify behaviour of next operator" newline
               "  1 to 9 for building up numbers, which modify behaviour of"
               " next operator" newline
               "  all other characters are echoed" newline
               "Usage: small [--help] [--version] [--file name] [program-text]"
               newline
           end-display
       >>SOURCE FORMAT IS FIXED

           goback
       .
       end program small.

prompt$ small
small s.c.r.i.p.t.

prompt$ small '65.10.'
A

prompt$ small '065+.10.'
A

prompt$ small '05+[@#-]10.'
54321

prompt$ small '"Hello, world">0+01'"'"'puts'"'"'#10.'
Hello, world
13

"Hello, world">0+01'puts'#

"Hello, world"  lays down a string
>0+             advances the current cell and lays down a null byte
01              puts a "zeroed" 1 in the immediate value register
'puts'          calls puts with one argument (the 1 taken from the register)
#               displays the result code as a numeric string.

iissso

iissiso

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Date:      20131017
Dead  *> Purpose:   Deadfish in COBOL
 fish *> License:   Public Domain
      *> Tectonics: cobc -x deadfish.cob
      *> ***************************************************************
       identification division.
       program-id. deadfish.

       data division.
       working-storage section.
       77 n                    usage binary-int unsigned.
       77 fishhead             pic x.

      *> ***************************************************************
       procedure division.

       perform forever
           call "printf" using z">> " end-call
           call "scanf" using z"%c" fishhead end-call
           if (n equal -1) or (n equal 256) then move 0 to n end-if
           evaluate fishhead
               when equal "d"
                   subtract 1 from n giving n end-subtract
               when equal "i"
                   add 1 to n giving n end-add
               when equal "o"
                   call "printf" using x"25641000" by value n end-call
               when equal "s"
                   multiply n by n end-multiply
               when equal "h"
                   exit perform
               when other
                   call "printf" using x"0a00" end-call
           end-evaluate
       end-perform

Fish   goback.
 dead  end program deadfish.

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> ***************************************************************
      *> Date:      20131017
Dead  *> Purpose:   Deadfish in COBOL
 fish *> License:   Public Domain
      *> Tectonics: cobc -x deadfish.cob
      *> ***************************************************************
       identification division.
       program-id. deadfish.

       data division.
       working-storage section.
       77 n                    usage binary-int unsigned.
       77 p                    pic -z(8)9.
       77 fishhead             pic x(8192).
       77 newline              pic x value x"0a".

      *> ***************************************************************
       procedure division.

       perform forever
           display ">> " with no advancing
           accept fishhead
           perform varying tally from 1 by 1
             until tally > function length(function trim(fishhead))
               if (n equal -1) or (n equal 256) then move 0 to n end-if
               evaluate fishhead(tally:1)
                   when equal "d"
                       subtract 1 from n giving n
                   when equal "i"
                       add 1 to n giving n
                   when equal "o"
                       move n to p
                       display function trim(p)
                   when equal "s"
                       multiply n by n
                   when equal "h"
                       goback
                   when other
                       display newline with no advancing
               end-evaluate
           end-perform
       end-perform

Fish   goback.
 dead  end program deadfish.

#!/usr/local/bin/cobc -xj
GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/system-info
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20151209  Modified: 2015-12-10/18:32-0500
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or greater)
      *> PURPOSE
      *>   Display sysinfo structure or free ram
      *> TECTONICS
      *>   cobc -x -g -debug system-info.cob
      *> ***************************************************************
       identification division.
       program-id. system-info.
       author. Brian Tiffin.
       date-written. 2015-12-09/23:38-0500.
       date-modified. 2015-12-10/18:32-0500.
       installation. GnuCOBOL 2.0.

       environment division.
       configuration section.
       source-computer.
       object-computer.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 sysinfo-code    usage binary-long.
       01 sysinfo.
          05 uptime       usage binary-c-long.
          05 loads        usage binary-c-long unsigned occurs 3 times.
          05 totalram     usage binary-c-long unsigned.
          05 freeram      usage binary-c-long unsigned.
          05 sharedram    usage binary-c-long unsigned.
          05 bufferram    usage binary-c-long unsigned.
          05 totalswap    usage binary-c-long unsigned.
          05 freeswap     usage binary-c-long unsigned.
          05 procs        usage unsigned-short.
          05 totalhigh    usage binary-c-long unsigned sync.
          05 freehigh     usage binary-c-long unsigned.
          05 mem-unit     usage binary-long   unsigned.
          05 filler       pic x(20).

       01 sys-show.
          05 uptime       pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 loads        pic zz,zzz,zzz,zzz,zzz,zzz,zz9 occurs 3 times.
          05 totalram     pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 freeram      pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 sharedram    pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 bufferram    pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 totalswap    pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 freeswap     pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 procs        pic bbbbbbbbbbbbbbbbbbbbzz,zz9.
          05 totalhigh    pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 freehigh     pic zz,zzz,zzz,zzz,zzz,zzz,zz9.
          05 mem-unit     pic bbbbbbbbbbbbbz,zzz,zzz,zz9.
          05 filler       pic x(20).

       01 enumerate       usage binary-c-long.
       01 show-total      pic zzzzzzzzzzzzzzz999.
       01 show-free       pic zzzzzzzzzzzzzzz999.

       01 cli             pic x(32).
          88 freeing      values "--free", "--memory", "free".
          88 pretty       values "--pretty", "pretty".

      *> ***************************************************************
       procedure division.
       accept cli from command-line

       call "sysinfo" using sysinfo returning sysinfo-code
           on exception
               display "no sysinfo linkage" upon syserr
               perform hard-exception
       end-call
       if sysinfo-code not equal 0 then
           call "perror" using "sysinfo: "
           perform hard-exception
       end-if

       if freeing then
           compute enumerate = totalram of sysinfo * mem-unit of sysinfo
           move enumerate to show-total
           compute enumerate = freeram of sysinfo * mem-unit of sysinfo
           move enumerate to show-free
           display trim(show-free) " of " trim(show-total)
           goback
       end-if

       if pretty then
           move corresponding sysinfo to sys-show
           perform varying tally from 1 by 1 until tally > 3
               move loads of sysinfo(tally) to loads of sys-show(tally)
           end-perform

           display "uptime   : " uptime of sys-show
           display "loads(1) : " loads of sys-show(1)
           display "loads(2) : " loads of sys-show(2)
           display "loads(3) : " loads of sys-show(3)
           display "totalram : " totalram of sys-show
           display "freeram  : " freeram of sys-show
           display "bufferram: " bufferram of sys-show
           display "totalswap: " totalswap of sys-show
           display "freeswap : " freeswap of sys-show
           display "procs    : " procs of sys-show
           display "totalhigh: " totalhigh of sys-show
           display "freehigh : " freehigh of sys-show
           display "mem-unit : " mem-unit of sys-show
       else
           display "uptime   :" uptime of sysinfo
           display "loads(1) : " loads of sysinfo(1)
           display "loads(2) : " loads of sysinfo(2)
           display "loads(3) : " loads of sysinfo(3)
           display "totalram : " totalram of sysinfo
           display "freeram  : " freeram of sysinfo
           display "bufferram: " bufferram of sysinfo
           display "totalswap: " totalswap of sysinfo
           display "freeswap : " freeswap of sysinfo
           display "procs    : " procs of sysinfo
           display "totalhigh: " totalhigh of sysinfo
           display "freehigh : " freehigh of sysinfo
           display "mem-unit : " mem-unit of sysinfo
       end-if
       goback.
      *> ***************************************************************

      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .

       end program system-info.
      *> ***************************************************************
      *>****
>>ELSE
!doc-marker!
========
system-info
========

.. contents::

Introduction
------------

Tectonics
---------

    prompt$  cobc -x -g -debug system-info.cob

Usage
-----

    prompt$ chmod +x system-info.cob
    prompt$ ./system-info.cob
    prompt$ ./system-info [free | pretty]

Source
------

.. include::  system-info.cob
   :code: cobolfree
>>END-IF

prompt$ ./system-info.cob
uptime   :+00000000000000117744
loads(1) : 00000000000000003264
loads(2) : 00000000000000005920
loads(3) : 00000000000000009536
totalram : 00000000007809716224
freeram  : 00000000003545804800
bufferram: 00000000000850726912
totalswap: 00000000007751069696
freeswap : 00000000007751069696
procs    : 00490
totalhigh: 00000000000000000000
freehigh : 00000000000000000000
mem-unit : 0000000001

prompt$ ./system-info pretty
uptime   :                    117,810
loads(1) :                        608
loads(2) :                      1,408
loads(3) :                      4,352
totalram :              7,809,716,224
freeram  :              3,703,771,136
bufferram:                845,275,136
totalswap:              7,751,069,696
freeswap :              7,751,069,696
procs    :                        483
totalhigh:                          0
freehigh :                          0
mem-unit :                          1

prompt$ ./system-info free
3706732544 of 7809716224

*> check combination of long and short options
  IDENTIFICATION DIVISION.
  PROGRAM-ID. getopt-test.
  DATA DIVISION.
  WORKING-STORAGE SECTION.
     01 long-options.
          05 OPTIONRECORD OCCURS 2 TIMES.
              10 option-name  PIC X(25).
              10 HAS-VALUE    PIC 9.
              10 VALPOINT     POINTER     VALUE NULL.
              10 VAL          PIC X(4).

      01 short-options PIC X(256).
      01 LONGIND PIC 99.
      01 LONG-ONLY PIC 9 VALUE 1.
      01 RETURN-CHAR PIC X(4).
      01 OPT-VAL PIC X(10).
      01 RET-DISP PIC S9 VALUE 0.

      01 COUNTER PIC 9 VALUE 0.

  PROCEDURE DIVISION.
      MOVE "jkl"     TO SO.

      MOVE "version" TO ONAME     (1).
      MOVE 0         TO HAS-VALUE (1).
      MOVE "v"       TO VAL       (1).

      MOVE "verbose" TO ONAME     (2).
      MOVE 0         TO HAS-VALUE (2).
      MOVE "V"       TO VAL       (2).

      PERFORM WITH TEST AFTER
              VARYING COUNTER FROM 0 BY 1
              UNTIL RETURN-CODE = -1
         CALL 'CBL_OC_GETOPT' USING
            BY REFERENCE SO LO LONGIND
            BY VALUE     LONG-ONLY
            BY REFERENCE RETURN-CHAR OPT-VAL
         END-CALL

         EVALUATE COUNTER
            WHEN 0
               IF RETURN-CHAR NOT = 'v' THEN
                  DISPLAY '0-ERROR: ' RETURN-CHAR END-DISPLAY
               END-IF
            WHEN 1
               IF RETURN-CHAR NOT = 'V' THEN
                  DISPLAY '1-ERROR: ' RETURN-CHAR END-DISPLAY
               END-IF
            WHEN 2
               IF RETURN-CHAR NOT = 'j' THEN
                  DISPLAY '2-ERROR: ' RETURN-CHAR END-DISPLAY
               END-IF
            WHEN 3
               IF RETURN-CHAR NOT = 'k' THEN
                  DISPLAY '3-ERROR: ' RETURN-CHAR END-DISPLAY
               END-IF
            WHEN 4
               IF RETURN-CHAR NOT = 'l' THEN
                  DISPLAY '4-ERROR: ' RETURN-CHAR END-DISPLAY
               END-IF
            WHEN 5
               IF RETURN-CODE NOT = -1 THEN
                  MOVE RETURN-CODE TO RET-DISP
                  DISPLAY 'last RETURN-CODE wrong: ' RET-DISP
                  END-DISPLAY
               END-IF
               EXIT PERFORM
         END-EVALUATE
      END-PERFORM.

      MOVE 0 TO RETURN-CODE.

      IF COUNTER NOT = 5 THEN
         MOVE RETURN-CODE TO RET-DISP
         DISPLAY 'CBL_OC_GETOPT returned -1 too early: ' COUNTER
         END-DISPLAY
      END-IF.

      STOP RUN.

prompt$ cobc -x getopt-test.cob
prompt$ ./getopt-test --version --verbose -jkl

$ ./getopt-test -j -k -l -v -V
0-ERROR: j
1-ERROR: k
2-ERROR: l
./getopt-main: option '-v' is ambiguous; possibilities: '--version' '--verbose'
3-ERROR: ?
./getopt-main: unrecognized option '-V'
4-ERROR: ?

#!/bin/bash

#!/usr/local/bin/cobc -xjF
identification division.
program-id. hello.
procedure division.
display "Hello, shell"
goback.

prompt$ chmod +x script-sample.cob
prompt$ ./script-sample.cob
Hello, shell

#!/usr/local/bin/cobc -xjFv
identification division.
program-id. hello.
procedure division.
display "Hello, shell"
goback.

prompt$ ./script-sample.cob
Command line:   /usr/local/bin/cobc -xjFv ./script-sample.cob
Preprocessing:  ./script-sample.cob -> /tmp/cob23060_0.cob
Return status:  0
Parsing:        /tmp/cob23060_0.cob (./script-sample.cob)
Return status:  0
Translating:    /tmp/cob23060_0.cob -> /tmp/cob23060_0.c (./script-sample.cob)
Executing:      gcc -c -I/usr/local/include -pipe -Wno-unused -fsigned-char
                -Wno-pointer-sign -o "/tmp/cob23060_0.o" "/tmp/cob23060_0.c"
Return status:  0
Executing:      gcc -Wl,--export-dynamic -o "script-sample"
                "/tmp/cob23060_0.o" -L/usr/local/lib -lcob -lm -lgmp
                -lncursesw -ldb -ldl
Return status:  0
Executing:      ./script-sample
Hello, shell
Return status:  0

#!/bin/bash
cobc -x -o fromhere - <<"EOCode"

      *> Modified: 2015-12-08/06:46-0500
       identification division.
       program-id. SAMPLE.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       01 data-in pic x(64).

       procedure division.
       demonstration section.

       accept data-in
       display trim(data-in)

       goback.
       end program SAMPLE.
EOCode
if [ $? -eq 0 ]; then
    ./fromhere <<EOD
Process $$ running $0 with shell options $-
EOD
    ./fromhere <<"EOD"
Process $$ running $0 with shell options $-
EOD
fi

$ ./fromhere.cob
Process 23135 running ./fromhere.cob with shell options hB
Process $$ running $0 with shell options $-

#!/bin/bash
cobc -x -o reproduce - <<"END-OF-CODE"
      *> Modified: 2015-12-16/01:36-0500
       identification division.
       program-id. reproduce.
       author. Brian Tiffin.
       remarks. Example, donated to the Public Domain.
       installation. Requires GnuCOBOL 2r631 or greater.

       data division.
       working-storage section.

       01 data-in pic x(64).

       procedure division.
       demonstration section.

       perform until exit
           accept data-in
               on exception exit perform
           end-accept
           display function trim(data-in trailing)
       end-perform

       goback.
       end program reproduce.
END-OF-CODE
if [ $? -eq 0 ]; then
    ./reproduce <<EOD
$(cat reproduce.cob)
EOD
fi

prompt$ chmod +x reproduce.cob
prompt$ ./reproduce.cob

#!/bin/bash
cobc -x -o reproduce - <<"END-OF-CODE"
      *> Modified: 2015-12-16/01:37-0500
       identification division.
       program-id. reproduce.
       author. Brian Tiffin.
       remarks. Example, donated to the Public Domain.
       installation. Requires GnuCOBOL 2r631 or greater.

       data division.
       working-storage section.

       01 data-in pic x(80).

       procedure division.
       demonstration section.

       perform until exit
           accept data-in
               on exception exit perform
           end-accept
           display function trim(data-in trailing)
       end-perform

       goback.
       end program reproduce.
END-OF-CODE
if [ $? -eq 0 ]; then
    ./reproduce <<EOD
$(cat reproduce.cob)
EOD
fi

prompt$ ./reproduce.cob | diff reproduce.cob -
prompt$

GCobol >>SOURCE FORMAT IS FREE
      *> ***************************************************************
      *>****J* gnucobol/tops-1
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20151220  Modified: 2015-12-20/07:55-0500
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or greater)
      *> PURPOSE
      *>   Display some Postscript.
      *> TECTONICS
      *>   cobc -x -g -debug tops-1.cob
      *> ***************************************************************
       identification division.
       program-id. tops-1.
       author. Brian Tiffin.
       date-written. 2015-12-20/04:30-0500.
       date-modified. 2015-12-20/07:55-0500.
       date-compiled.
       installation. Requires ghostscript.
       remarks. Hello, Postscript.
       security.

      *> ***************************************************************
       procedure division.
       display "%!PS"
       display "/Times-Roman 20 selectfont"
       display "72 396 moveto"
       display "(Hello, postscript) show"
       display "showpage"
       goback.
       end program tops-1.
      *> ***************************************************************
      *>****

%!PS
/Times-Roman 20 selectfont
72 396 moveto
(Hello, postscript) show
showpage

GCobol >>SOURCE FORMAT IS FREE
      *> ***************************************************************
      *>****J* gnucobol/tops-2
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20151220  Modified: 2015-12-20/10:10-0500
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or greater)
      *> PURPOSE
      *>   tops-2 program.
      *> TECTONICS
      *>   cobc -x -g -debug tops-2.cob
      *> ***************************************************************
       identification division.
       program-id. tops-2.
       author. Brian Tiffin.
       date-written. 2015-12-20/04:30-0500.
       date-modified. 2015-12-20/10:10-0500.
       date-compiled.
       installation. Requires ghostscript.
       remarks. Fill a page with Times-Roman 5pt to 36pt.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 base-y      pic 999 value 792.   *> 11 inches at 72 pt.
       01 page-y      pic 999.

       01 show-point  pic zzzz.
       01 show-x      pic z9.
       01 show-y      pic zzz9.
       01 y-point     pic 9999.

      *> ***************************************************************
       procedure division.
       display "%!PS"
       move 72 to show-x
       move 72 to y-point
       compute page-y = base-y - y-point
       move page-y to show-y
       perform varying tally from 5 by 1 until tally > 36
           move tally to show-point
           display "/Times-Roman " tally " selectfont"
           display show-x " "  show-y " moveto "
                   "(Times-Roman " trim(show-point) ") show "
                   400 show-y " moveto "
                   "(at " trim(show-x) " " trim(show-y) ") show"
           add tally to y-point
           compute page-y = base-y - y-point
           move page-y to show-y
       end-perform
       display "showpage"
       goback.

       end program tops-2.
      *> ***************************************************************
      *>****

%!PS
/Times-Roman 00005 selectfont
72  720 moveto (Times-Roman 5) show 400 720 moveto (at 72 720) show
/Times-Roman 00006 selectfont
72  715 moveto (Times-Roman 6) show 400 715 moveto (at 72 715) show
/Times-Roman 00007 selectfont
72  709 moveto (Times-Roman 7) show 400 709 moveto (at 72 709) show
/Times-Roman 00008 selectfont
72  702 moveto (Times-Roman 8) show 400 702 moveto (at 72 702) show
/Times-Roman 00009 selectfont
72  694 moveto (Times-Roman 9) show 400 694 moveto (at 72 694) show
/Times-Roman 00010 selectfont
72  685 moveto (Times-Roman 10) show 400 685 moveto (at 72 685) show
/Times-Roman 00011 selectfont
72  675 moveto (Times-Roman 11) show 400 675 moveto (at 72 675) show
/Times-Roman 00012 selectfont
72  664 moveto (Times-Roman 12) show 400 664 moveto (at 72 664) show
/Times-Roman 00013 selectfont
72  652 moveto (Times-Roman 13) show 400 652 moveto (at 72 652) show
/Times-Roman 00014 selectfont
72  639 moveto (Times-Roman 14) show 400 639 moveto (at 72 639) show
/Times-Roman 00015 selectfont
72  625 moveto (Times-Roman 15) show 400 625 moveto (at 72 625) show
/Times-Roman 00016 selectfont
72  610 moveto (Times-Roman 16) show 400 610 moveto (at 72 610) show
/Times-Roman 00017 selectfont
72  594 moveto (Times-Roman 17) show 400 594 moveto (at 72 594) show
/Times-Roman 00018 selectfont
72  577 moveto (Times-Roman 18) show 400 577 moveto (at 72 577) show
/Times-Roman 00019 selectfont
72  559 moveto (Times-Roman 19) show 400 559 moveto (at 72 559) show
/Times-Roman 00020 selectfont
72  540 moveto (Times-Roman 20) show 400 540 moveto (at 72 540) show
/Times-Roman 00021 selectfont
72  520 moveto (Times-Roman 21) show 400 520 moveto (at 72 520) show
/Times-Roman 00022 selectfont
72  499 moveto (Times-Roman 22) show 400 499 moveto (at 72 499) show
/Times-Roman 00023 selectfont
72  477 moveto (Times-Roman 23) show 400 477 moveto (at 72 477) show
/Times-Roman 00024 selectfont
72  454 moveto (Times-Roman 24) show 400 454 moveto (at 72 454) show
/Times-Roman 00025 selectfont
72  430 moveto (Times-Roman 25) show 400 430 moveto (at 72 430) show
/Times-Roman 00026 selectfont
72  405 moveto (Times-Roman 26) show 400 405 moveto (at 72 405) show
/Times-Roman 00027 selectfont
72  379 moveto (Times-Roman 27) show 400 379 moveto (at 72 379) show
/Times-Roman 00028 selectfont
72  352 moveto (Times-Roman 28) show 400 352 moveto (at 72 352) show
/Times-Roman 00029 selectfont
72  324 moveto (Times-Roman 29) show 400 324 moveto (at 72 324) show
/Times-Roman 00030 selectfont
72  295 moveto (Times-Roman 30) show 400 295 moveto (at 72 295) show
/Times-Roman 00031 selectfont
72  265 moveto (Times-Roman 31) show 400 265 moveto (at 72 265) show
/Times-Roman 00032 selectfont
72  234 moveto (Times-Roman 32) show 400 234 moveto (at 72 234) show
/Times-Roman 00033 selectfont
72  202 moveto (Times-Roman 33) show 400 202 moveto (at 72 202) show
/Times-Roman 00034 selectfont
72  169 moveto (Times-Roman 34) show 400 169 moveto (at 72 169) show
/Times-Roman 00035 selectfont
72  135 moveto (Times-Roman 35) show 400 135 moveto (at 72 135) show
/Times-Roman 00036 selectfont
72  100 moveto (Times-Roman 36) show 400 100 moveto (at 72 100) show
showpage

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/tops
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20151220  Modified: 2015-12-20/09:50-0500
      *> LICENSE
      *>   Copyright 2015 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or greater)
      *> PURPOSE
      *>   tops program.
      *> TECTONICS
      *>   cobc -x -g -debug tops.cob -lgs
      *> ***************************************************************
       identification division.
       program-id. tops.
       author. Brian Tiffin.
       date-written. 2015-12-20/04:30-0500.
       date-modified. 2015-12-20/09:50-0500.
       date-compiled.
       installation. Requires libgs.so
       remarks. Drive a postscript engine.
       security. Embeds a programming language.

       environment division.
       configuration section.
       source-computer. gnulinux.
       object-computer.
           classification is canadian.

       special-names.
           locale canadian is "en_CA.UTF-8".

       repository.
           function all intrinsic.

       data division.
       file section.
       working-storage section.
       01 gs-inst              usage pointer.
       01 gs-status            usage binary-long.
       01 gs-exit-code         usage binary-long.

       01 cob-argc             usage binary-long value 2.
       01 cob-argv.
          05 cob-args          usage pointer occurs 2 times.
       01 cob-argv-1           pic x(8) value z"notused".
       01 cob-argv-2           pic x(18) value z"-sDEVICE=nullpage".

       01 GS-ARG-ENCODING-UTF8 constant as 1.
       01 gs-command.
          05 value "currentpagedevice /PageSize get == " &
                   "40 2 add == " &
                   "version == " &
                   "devicenames == " &
                   "flush" & x"0a00".

       01 stdout-callback      usage program-pointer.

      *> ***************************************************************
       procedure division.
       set cob-args(1) to address of cob-argv-1.
       set cob-args(2) to address of cob-argv-2.

       call "gsapi_new_instance" using
           by reference gs-inst
           by reference NULL
           returning gs-status
           on exception
               display "Error: no gsapi_new_instance" upon syserr
               perform hard-exception
       end-call
       if gs-status less than zero then
           display "Error: gsapi_new_instance: " gs-status upon syserr
           perform hard-exception
       end-if

       call "gsapi_set_arg_encoding" using
           by value gs-inst
           by value GS-ARG-ENCODING-UTF8
           returning gs-status
           on exception
               display "Error: no gsapi_set_encoding" upon syserr
               perform hard-exception
       end-call
       if gs-status not equal zero then
           display "Error: gsapi_set_arg_encoding: " gs-status
              upon syserr
           perform hard-exception
       end-if

       call "gsapi_init_with_args" using
           by value gs-inst
           by value cob-argc
           by reference cob-argv
           returning gs-status
           on exception
               display "Error: no gsapi_init_with_args" upon syserr
               perform hard-exception
       end-call
       if gs-status not equal zero then
           display "Error: gsapi_init_with_args: " gs-status
              upon syserr
           perform hard-exception
       end-if

       set stdout-callback to entry "stdout-handler"
       if stdout-callback equal NULL then
           display "stdout-handler = " stdout-callback upon syserr
       end-if
       call "gsapi_set_stdio" using
           by value gs-inst
           by reference NULL
           by value stdout-callback
           by reference NULL
           returning gs-status
           on exception
               display "Error: no gsapi_set_stdio" upon syserr
               perform hard-exception
       end-call
       if gs-status not equal zero then
           display "Error: gsapi_set_stdio: " gs-status upon syserr
           perform hard-exception
       end-if

       call "gsapi_run_string" using
           by value gs-inst
           by reference gs-command
           by value 0
           by reference gs-exit-code
           returning gs-status
           on exception
               display "Error: no gsapi_run_string" upon syserr
               perform hard-exception
       end-call
       if gs-status not equal zero then
           display "Error: gsapi_run_string: " gs-status upon syserr
           perform soft-exception
       end-if

       display space
       display "pausing ghostscript rundown" with no advancing
       accept omitted

       call "gsapi_exit" using
           by value gs-inst
           returning gs-status
           on exception
               display "Error: no gsapi_exit" upon syserr
               perform hard-exception
       end-call
       if gs-status not equal zero then
           display "Error: gsapi_exit: " gs-status upon syserr
           perform soft-exception
       end-if

       set return-code to gs-status
       goback.

      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program tops.
      *> ***************************************************************
      *> ***************************************************************
       identification division.
       program-id. "stdout-handler".
       data division.
       linkage section.
       01 gs-calling-inst      usage pointer.
       01 stdout-buffer        pic x(65535).
       01 stdout-len           usage binary-long.

       procedure division using
           by reference gs-calling-inst
           by reference stdout-buffer
           by value stdout-len.

       display stdout-buffer(1:stdout-len) with no advancing
       move stdout-len to return-code
       goback.
       .
      *>****
>>ELSE
!doc-marker!
====
tops
====

.. contents::

Introduction
------------

Embed a postscript engine, gs in particular.  Send it some commands.

Tectonics
---------

::

    prompt$ cobc -x tops.cob -lgs

Usage
-----

::

    prompt$ ./tops

Source
------

.. include::  tops.cob
   :code: cobolfree
>>END-IF

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
 promtp$ cobc -xj tops.cob -lgs
 GPL Ghostscript 9.16 (2015-03-30)
 Copyright (C) 2015 Artifex Software, Inc.  All rights reserved.
 This software comes with NO WARRANTY: see the file PUBLIC for details.
 [612.0 792.0]
 42
 (3010)
 [/md50Eco /hpdj690c /alc1900 /bmpsep1 /lp8700 /fmpr /psdrgb /ijs /ln03
 /djet500 /pkmraw /pjxl300 /lbp8 /cdeskjet /mgrgray2 /md50Mono /hpdj850c
 /alc2000 /bmpsep8 /lp8800c /fs600 /sgirgb /png16 /lp1800 /djet500c /pksm
 /pr1000 /lex2050 /cdj1600 /mgrgray4 /md5k /hpdj855c /alc4000 /ccr /lp8900 /gdi
 /spotcmyk /png16m /lp1900 /dl2100 /pksmraw /pr1000_4 /lex3200 /cdj500
 /mgrgray8 /mj500c /hpdj870c /alc4100 /cfax /lp9000b /hl1240 /sunhmono /png256
 /lp2000 /dnj650c /plan /pr150 /lex5700 /cdj550 /mgrmono /mj6000c /hpdj890c
 /alc8500 /cif /lp9000c /hl1250 /tiff12nc /png48 /lp2200 /epl2050 /plan9bm
 /pr201 /lex7000 /cdj670 /miff24 /mj700v2c /hpdjplus /alc8600 /devicen /lp9100
 /hl7x0 /tiff24nc /pngalpha /lp2400 /epl2050p /planc /pxlcolor /lips2p /cdj850
 /pam /mj8000c /hpdjportable /alc9100 /dfaxhigh /lp9200b /hpdj1120c /tiff32nc
 /pnggray /lp2500 /epl2120 /plang /pxlmono /lips3 /cdj880 /pamcmyk32 /ml600
 /ibmpro /ap3250 /dfaxlow /lp9200c /hpdj310 /tiff48nc /pngmono /lp2563 /epl2500
 /plank /r4081 /lips4 /cdj890 /pamcmyk4 /necp6 /imagen /appledmp /eps2write
 /lp9300 /hpdj320 /tiff64nc /nullpage /lp3000c /epl2750 /planm /rinkj /lips4v
 /cdj970 /pbm /npdl /itk24i /atx23 /faxg3 /lp9400 /hpdj340 /tiffcrle /x11
 /lp7500 /epl5800 /plib /rpdl /lj250 /cdjcolor /pbmraw /oce9050 /itk38 /atx24
 /faxg32d /lp9500c /hpdj400 /tiffg3 /display /x11alpha /lp7700 /epl5900 /plibc
 /samsunggdi /lj3100sw /cdjmono /pcx16 /oki182 /iwhi /atx38 /faxg4 /lp9600
 /hpdj500 /tiffg32d /bbox /x11cmyk /lp7900 /epl6100 /plibg /sj48 /lj4dith
 /cdnj500 /pcx24b /oki4w /iwlo /bj10e /fpng /lp9600s /hpdj500c /tiffg4 /bit
 /x11cmyk2 /lp8000 /epl6200 /plibk /st800 /lj4dithp /chp2200 /pcx2up /okiibm
 /iwlq /bj10v /inferno /lp9800c /hpdj510 /tiffgray /bitcmyk /x11cmyk4 /lp8000c
 /eplcolor /plibm /stcolor /lj5gray /cljet5 /pcx256 /oprp /jetp3852 /bj10vh
 /ink_cov /lps4500 /hpdj520 /tifflzw /bitrgb /x11cmyk8 /lp8100 /eplmono /pnm
 /t4693d2 /lj5mono /cljet5c /pcxcmyk /opvp /jj100 /bj200 /inkcov /lps6500
 /hpdj540 /tiffpack /bitrgbtags /x11gray2 /lp8200c /eps9high /pnmraw /t4693d4
 /ljet2p /cljet5pr /pcxgray /paintjet /la50 /bjc600 /jpeg /lq850 /hpdj550c
 /tiffscaled /bmp16 /x11gray4 /lp8300c /eps9mid /ppm /t4693d8 /ljet3 /coslw2p
 /pcxmono /pcl3 /la70 /bjc800 /jpegcmyk /lxm3200 /hpdj560c /tiffsep /bmp16m
 /x11mono /lp8300f /epson /ppmraw /tek4696 /ljet3d /coslwxl /pgm /photoex /la75
 /bjc880j /jpeggray /lxm5700m /hpdj600 /tiffsep1 /bmp256 /lp8400f /epsonc
 /ps2write /uniprint /ljet4 /cp50 /pgmraw /picty180 /la75plus /bjccmyk /mag16
 /m8510 /hpdj660c /txtwrite /bmp32b /lp8500c /escp /pdfwrite /xes /ljet4d
 /declj250 /pgnm /pj /laserjet /bjccolor /mag256 /md1xMono /hpdj670c /xcf
 /bmpgray /lp8600 /escpage /psdcmyk /cups /ljet4pjl /deskjet /pgnmraw /pjetxl
 /lbp310 /bjcgray /mgr4 /md2k /hpdj680c /xpswrite /bmpmono /lp8600f /fmlbp
 /psdcmykog /pwgraster /ljetplus /dj505j /pkm /pjxl /lbp320 /bjcmono /mgr8]

move jvm-create("-Djava.class.path=."
                "-verbose:class")
  to extranseous

Type Signature Java Type
Z boolean
B byte
C char
S short
I int
J long
F float
D double
L fully-qualified-class ;
V void
[ type to specify array of type
( arg-types ) ret-type

public class TestJVM {
    public static String hello(String entity) {
        System.out.println("Java: Hello, " + entity);
        return "Sent greeting to " + entity;
    }
}

prompt$ javac TestJVM.java

display "COBOL: " jvm(
    "TestJVM",
    "hello",
    "(Ljava/lang/String;)Ljava/lang/String;",
    "world")

prompt$ cobc -xj testjvm.cob

Java: Hello, world
COBOL: Sent greeting to world

// Embed frink, http://frinklang.org
public class EmbedFrink {

    // Initialize Frink
    static frink.parser.Frink interp = new frink.parser.Frink();

    // Unrestricted Frink
    public static String DoFrink(String express) {
        String results;

        try
        {
           results = interp.parseString(express);
        }
        catch (frink.errors.FrinkException fee)
        {
           results = fee.toString();
        }

        return results;
    }

    // Restrictive Frink, once restricted always restricted
    public static String SecureFrink(String express) {
        interp.setRestrictiveSecurity(true);
        return DoFrink(express);
    }
}

procedure division.
sample-main.
move jvm-create(
    "-Djava.compiler=NONE"
    "-Djava.class.path=.:" &
        "/home/btiffin/inst/langs/frink/frink.jar"
    "-Djava.library.path=."
    ) to return-code

display "1 barrel + 2 gallons is " jvm(
    "EmbedFrink", "DoFrink",
    "(Ljava/lang/String;)Ljava/lang/String;"
    "1 barrel + 2 gallons -> ""cups""")

1 barrel + 2 gallons is 704 cups

cobsub*
       identification division.
       program-id. cobsubtest.
       data division.
       linkage section.
       01  PassedParameter pic X(72).
       procedure division using
       by reference     PassedParameter.
       A-Main Section.
               display 'Starting cobsubtest.cbl'
               display 'Called With ['  PassedParameter ']'

               move 'We changed it!' to PassedParameter
               move 2 TO return-code.

               goback.

cobsub*
       identification division.
       program-id. cobsubtest2.
       data division.
       linkage section.
       01  PassedParameter pic X(72).
       procedure division using
       by reference     PassedParameter.
       A-Main Section.
               display 'Starting cobsubtest2:'
               display 'Called With [' PassedParameter ']'
               move 8 TO return-code.
               goback.

import com.sun.jna.*;

/*
 * libcob interface, initialising GnuCOBOL run time
 */
interface libcob extends Library {
        libcob INSTANCE = (libcob) Native.loadLibrary("cob", libcob.class);
        void cob_init(int argc, Pointer argv);
}

/*
 * first COBOL program interface, single program
 */
interface subtest extends Library {
        subtest INSTANCE = (subtest) Native.loadLibrary("cobsubtest",
subtest.class);
        int cobsubtest(Pointer aValue);
}

/*
 * second COBOL program interface, single program
 */
interface subtest2 extends Library {
        subtest2 INSTANCE = (subtest2) Native.loadLibrary("cobsubtest2",
subtest2.class);
        int cobsubtest2(Pointer aValue);
}

public class jnacob {
        public static void main(String[] args) {

                /*
                 * try and initialise the GnuCOBOL run time
                 * calling cob_init with no parameters
                 */
                try {
                        libcob.INSTANCE.cob_init(0, null);
                } catch (UnsatisfiedLinkError e) {
                        System.out.println("Libcob Exception" + e);
                }

                /*
                 * call a GnuCOBOL program, passing a PIC X(72)
                 * space filled
                 */
                try {
                        // JAVA string
                        String stringThing = new String("We Did It!");

                        // make a Pointer and space fill
                        Pointer pointer;
                        pointer = new Memory(72);
                        byte space = 32;
                        pointer.setMemory(0,72,space);
                        byte[] data = Native.toByteArray(stringThing);
                        pointer.write(0, data, 0, data.length - 1);

                        int rc;

                        // call the GnuCOBOL program
                        rc=subtest.INSTANCE.cobsubtest(pointer);

                        // display return-code
                        System.out.print("COBOL Return Code ");
                        System.out.println(rc);

                        // call the second test
                        rc=subtest2.INSTANCE.cobsubtest2(pointer);
                        System.out.print("COBOL Return Code ");
                        System.out.println(rc);

                } catch (UnsatisfiedLinkError e) {
                        System.out.println("subtest Exception" + e);
                }
        }
}

javac -classpath ./jna-4.2.1.jar jnacob.java
cobc -o libcobsubtest.so cobsubtest.cbl
cobc -o libcobsubtest2.so cobsubtest2.cbl
java -classpath ./jna-4.2.1.jar:. jnacob

Starting cobsubtest.cbl
Called With [We Did It!                                              ]
COBOL Return Code 2
Starting cobsubtest2:
Called With [We changed it!                                          ]
COBOL Return Code 8

############################################################################
#
#   File:     concord.icn
#
#   Subject:  Program to produce concordance
#
#   Author:   Ralph E. Griswold
#
#   Date:     October 9, 1994
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#  This program produces a simple concordance from standard input to standard
#  output. Words less than three characters long are ignored.
#
#     There are two options:
#
#   -l n    set maximum line length to n (default 72), starts new line
#   -w n    set maximum width for word to n (default 15), truncates
#
#     There are lots of possibilities for improving this program and adding
#  functionality to it. For example, a list of words to be ignored could be
#  provided.  The formatting could be made more flexible, and so on.
#
############################################################################
#
#     Note that the program is organized to make it easy (via item()) to
#  handle other kinds of tabulations.
#
############################################################################
#
#  Links: options
#
############################################################################

link options

global uses, colmax, namewidth, lineno

procedure main(args)
   local opts, uselist, name, line, pad, i, j, fill

   opts := options(args, "l+w+")        # process options
   colmax := \opts["l"] | 72
   namewidth := \opts["w"] | 15

   pad := repl(" ", namewidth)
   uses := table()
   lineno := 0

   every tabulate(item(), lineno)       # tabulate all the citations

   uselist := sort(uses, 3)         # sort by uses
   while fill := left(get(uselist), namewidth) do {
      line := format(get(uselist))      # line numbers
      while (*line + namewidth) > colmax do {   # handle long lines
         line ?:= {
            i := j := 0
             every i := upto(' ') do {
                if i > (colmax - namewidth) then break
                else j := i
                }
             write(fill, tab(j))
             move(1)
             fill := pad
             tab(0)             # new value of line
             }
         }
         if *line > 0 then write(fill, trim(line))
      }

end

#  Add to count of line number to citations for name.
#
procedure tabulate(name, lineno)

   /uses[name] := table(0)
   uses[name][lineno] +:= 1

   return

end

#  Format the line numbers, breaking long lines as necessary.
#
procedure format(linenos)
   local i, line

   linenos := sort(linenos, 3)
   line := ""

   while line ||:= get(linenos) do
      line ||:= ("(" || (1 < get(linenos)) || ") ") | " "

   return line

end

#  Get an item. Different kinds of concordances can be obtained by
#  modifying this procedure.
#
procedure item()
   local i, word, line

   while line := read() do {
      lineno +:= 1
      write(right(lineno, 6), "  ", line)
      line := map(line)             # fold to lowercase
      i := 1
      line ? {
         while tab(upto(&letters)) do {
            word := tab(many(&letters))
            if *word >= 1 then suspend word # skip short words
            }
         }
      }

end

prompt$ iconc -c concord.icn

# Linking Icon into a GnuCOBOL program
.RECIPEPREFIX = >

callicon: callicon.cob concord.c
> cobc -x -g -debug callicon.cob concord.c \
  /usr/lib/iconc/dlrgint.o /usr/lib/iconc/rt.a \
  -lpthread -lX11 -lxcb -lXau -lXdmcp \
  -L/usr/lib/iconc -lIgpx

concord.c: concord.icn
> iconc -c concord.icn
> sed -i 's/int main[(]argc, argv[)]/int imain(argc, argv)/' concord.c
> sed -i 's/c_exit[(]EXIT_SUCCESS[)]/return(EXIT_SUCCESS)/' concord.c

GCOBOL identification division.
       program-id. callicon.
       author. Brian Tiffin.
       date-written. 2016-02-07/12:10-0500.
       date-modified. 2016-02-07/19:14-0500.
       installation. Requires Icon 9.4.3
       remarks. Embed and call an Icon program

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 argc usage binary-long value 1.
       01 argv.
          05 argv-0 usage pointer.
          05 argv-1 usage pointer.
       01 pname.
          05 value z"callicon".

       01 icon-result usage binary-long.

      *> ***************************************************************
       procedure division.
       set argv-0 to address of pname
       call "imain" using by value argc by reference argv
           returning icon-result
           on exception
               display "bad Icon run-time linkage" upon syserr
               perform hard-exception
       end-call
       display "Icon result: " icon-result
       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program callicon.

prompt$ make
iconc -c concord.icn
Translating to C:
concord.icn:
/usr/lib/icon-ipl/options.icn:
No errors; no warnings
sed -i 's/int main[(]argc, argv[)]/int imain(argc, argv)/' concord.c
sed -i 's/c_exit[(]EXIT_SUCCESS[)]/return(EXIT_SUCCESS)/' concord.c
cobc -x -g -debug callicon.cob concord.c \
  /usr/lib/iconc/dlrgint.o /usr/lib/iconc/rt.a \
  -lpthread -lX11 -lxcb -lXau -lXdmcp \
  -L/usr/lib/iconc -lIgpx

prompt$ ./callicon <callicon.cob

     1         identification division.
     2         program-id. callicon.
     3         author. Brian Tiffin.
     4         date-written. 2016-02-07/12:10-0500.
     5         date-modified. 2016-02-07/19:14-0500.
     6         installation. Requires Icon 9.4.3
     7         remarks. Embed and call an Icon program
     8
     9         environment division.
    10         configuration section.
    11         repository.
    12             function all intrinsic.
    13
    14         data division.
    15         working-storage section.
    16         01 argc usage binary-long value 1.
    17         01 argv.
    18            05 argv-0 usage pointer.
    19            05 argv-1 usage pointer.
    20         01 pname.
    21            05 value z"callicon".
    22
    23         01 icon-result usage binary-long.
    24
    25        *> ***************************************************************
    26         procedure division.
    27         set argv-0 to address of pname
    28         call "imain" using by value argc by reference argv
    29             returning icon-result
    30             on exception
    31                 display "bad Icon run-time linkage" upon syserr
    32                 perform hard-exception
    33         end-call
    34         display "Icon result: " icon-result
    35         goback.
    36        *> ***************************************************************
    37
    38         REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
    39         ==
    40        *> informational warnings and abends
    41         soft-exception.
    42           display space upon syserr
    43           display "--Exception Report-- " upon syserr
    44           display "Time of exception:   " current-date upon syserr
    45           display "Module:              " module-id upon syserr
    46           display "Module-path:         " module-path upon syserr
    47           display "Module-source:       " module-source upon syserr
    48           display "Exception-file:      " exception-file upon syserr
    49           display "Exception-status:    " exception-status upon syserr
    50           display "Exception-location:  " exception-location upon syserr
    51           display "Exception-statement: " exception-statement upon syserr
    52         .
    53
    54         hard-exception.
    55             perform soft-exception
    56             stop run returning 127
    57         .
    58         ==.
    59
    60         :EXCEPTION-HANDLERS:
    61
    62         end program callicon.
abends         40
address        27
all            12
also           38
an             7
and            7 40
argc           16 28
argv           17 18 19 27 28
author         3
bad            31
binary         16 23
brian          3
by             28(2) 38
call           7 28 33
callicon       2 21 62
configuration  10
current        44
data           14
date           4 5 44
display        31 34 42 43 44 45 46 47 48 49 50 51
division       1 9 14 26
embed          7
end            33 62
environment    9
exception      30 32 38 41 43 44 48(2) 49(2) 50(2) 51(2) 54 55 60
file           48(2)
function       12
goback         35
handlers       38 60
hard           32 54
icon           6 7 23 29 31 34(2)
id             2 45
identification 1
imain          28
informational  40
installation   6
intrinsic      12
linkage        31
location       50(2)
long           16 23
modified       5
module         45(2) 46(2) 47(2)
of             27 44
on             30
path           46(2)
perform        32 55
pname          20 27
pointer        18 19
procedure      26
program        2 7 62
reference      28
remarks        7
replace        38
report         43
repository     11
requires       6
result         23 29 34(2)
returning      29 56
run            31 56
section        10 15
set            27
soft           41 55
source         47(2)
space          42
statement      51(2)
status         49(2)
stop           56
storage        15
syserr         31 42 43 44 45 46 47 48 49 50 51
tiffin         3
time           31 44
to             27
upon           31 42 43 44 45 46 47 48 49 50 51
usage          16 18 19 23
using          28
value          16 21 28
warnings       40
working        15
written        4
z              21
Icon result: +0000000000

30 32 38 41 43 44 48(2) 49(2) 50(2) 51(2) 54 55 60

import gui
$include "guih.icn"

class WindowApp : Dialog ()

  # -- automatically called when the dialog is created
  method component_setup ()
    # add 'hello world' label
    label := Label("label=Hello world","pos=0,0")
    add (label)

    # make sure we respond to close event
    connect(self, "dispose", CLOSE_BUTTON_EVENT)
  end
end

# create and show the window
procedure main ()
  w := WindowApp ()
  w.show_modal ()
end

prompt$ unicon hello-unicon.icn -x
Parsing hello-unicon.icn: ......  inherits gui__Dialog from dialog.icn
  inherits gui__Component from component.icn
  inherits lang__Object from object.icn
  inherits util__SetFields from setfields.icn
  inherits util__Connectable from connectable.icn

/home/btiffin/inst/langs/unicon-svn/bin/icont -c   -O hello-unicon.icn
/tmp/uni96130157
Translating:
hello-unicon.icn:
  WindowApp_component_setup
  WindowApp
  WindowAppinitialize
  main
No errors
/home/btiffin/inst/langs/unicon-svn/bin/icont  hello-unicon.u -x
Linking:
Executing:

link graphics
procedure main()
   WOpen("size=100,20") | stop("No window")
   WWrites("Hello, world")
   WDone()
end

prompt$ unicon hello-icon.icn -x
Parsing hello.icn: ..
/home/btiffin/inst/langs/unicon-svn/bin/icont -c   -O hello.icn
/tmp/uni20774585
Translating:
hello.icn:
  main
No errors
/home/btiffin/inst/langs/unicon-svn/bin/icont  hello.u -x
Linking:
Executing:

prompt$ unicon --help
Usage: unicon [-cBCstuEGyZM] [-Dsym=val] [-f s] [-o ofile]
   [--help] [-version] [-features] [-v i] file... [-x args]
options may be one of:
   -B          : bundle VM (iconx) into executable
   -c          : compile only, do not link
   -C          : generate (optimized) C code executable
   -Dsym[=val] : define preprocessor symbol
   -E          : preprocess only, do not compile
   -features   : report Unicon features supported in this build
   -fs         : prevent removal of unreferenced declarations
   -G          : generate graphics (wiconx) executable
   -M          : report error message to the authorities
   -o ofile    : generate executable named ofile
   -O          : optimize (under construction)
   -s          : work silently
   -t          : turn on tracing
   -u          : warn of undeclared variables
   -v i        : set diagnostic verbosity level to i
   -version    : report Unicon version
   -x args     : execute immediately
   -y          : parse (syntax check) only, do not compile
   -Z          : compress icode

prompt$ unicon -features
Unicon Version 12.3.  Feb 29, 2016
UNIX
POSIX
DBM
ASCII
co-expressions
native coswitch
concurrent threads
dynamic loading
environment variables
event monitoring
external functions
keyboard functions
large integers
multiple programs
pattern type
pipes
pseudo terminals
system function
messaging
graphics
3D graphics
X Windows
JPEG images
CCompiler gcc 5.2.1
Physical memory: 7809204224 bytes
Revision 4384
Arch x86_64
CPU cores 4
Binaries at /home/btiffin/inst/langs/unicon-svn/bin/

 Cobol

 The package accepts standard Cobol Copybooks, look up the Cobol definition
on the Web for more details. Here is a Sample:

000600*
000700*   RECORD LENGTH IS 27.
000800*
000900        03  DTAR020-KCODE-STORE-KEY.
001000            05 DTAR020-KEYCODE-NO      PIC X(08).
001100            05 DTAR020-STORE-NO        PIC S9(03)   COMP-3.
001200        03  DTAR020-DATE               PIC S9(07)   COMP-3.
001300        03  DTAR020-DEPT-NO            PIC S9(03)   COMP-3.
001400        03  DTAR020-QTY-SOLD           PIC S9(9)    COMP-3.
001500        03  DTAR020-SALE-PRICE         PIC S9(9)V99 COMP-3.

RecordEditor XML

Record can be described via XML like the following. The easiest way to
define a RecordEditor-XML file is to use the Layout-Wizard

<?xml version="1.0" ?>
<RECORD RECORDNAME="DTAR020" COPYBOOK="DTAR020" DELIMITER="&lt;Tab&gt;"
FONTNAME="CP037" FILESTRUCTURE="Default" STYLE="0" RECORDTYPE="RecordLayout"
LIST="Y" QUOTE="" RecSep="default">
  <FIELDS>
    <FIELD NAME="KEYCODE-NO" POSITION="1"  LENGTH="8" TYPE="Char" />
    <FIELD NAME="STORE-NO"   POSITION="9"  LENGTH="2" TYPE="Mainframe Packed Decimal (comp-3)" />
    <FIELD NAME="DATE"       POSITION="11" LENGTH="4" TYPE="Mainframe Packed Decimal (comp-3)" />
    <FIELD NAME="DEPT-NO"    POSITION="15" LENGTH="2" TYPE="Mainframe Packed Decimal (comp-3)" />
    <FIELD NAME="QTY-SOLD"   POSITION="17" LENGTH="5" TYPE="Mainframe Packed Decimal (comp-3)" />
    <FIELD NAME="SALE-PRICE" POSITION="22" LENGTH="6" DECIMAL="2" TYPE="Mainframe Packed Decimal (comp-3)" />
  </FIELDS>
</RECORD>

*******************************
* Location Download
*******************************

 01 Ams-Vendor.
    03 Brand               Pic x(3).
    03 Location-Number     Pic 9(4).
    03 Location-Type       Pic XX.
    03 Location-Name       Pic X(35).
    03 Address-1           Pic X(40).
    03 Address-2           Pic X(40).
    03 Address-3           Pic X(35).
    03 Postcode            Pic 9(10).
    03 State               Pic XXX.
    03 Location-Active     Pic X.

prompt$ cobc -x callpiet.cob npiet.c -g -debug
prompt$ ./callpiet examples/sortgnu.ppm
Pietsort: a sorting program written in piet
Copyright 2010 Joshua Schulter
How many elements to be sorted?
? 6
elements:
? 1
? 6
? 5
? 2
? 4
? 3
the sorted list:
1
2
3
4
5
6
This work by Joshua Schulter is licensed under
the CC-GNU GPL version 2.0 or later.

GCobol >>SOURCE FORMAT IS FREE

REPLACE ==callpiet== BY ==program-name==.
>>IF docpass NOT DEFINED

      *> ***************************************************************
      *>****p* project/callpiet
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   2015-03-26
      *> LICENSE
      *>   GNU General Public License, GPL, 3.0 (or greater)
      *> PURPOSE
      *>   call piet program/picture.
      *> TECTONICS
      *>   cobc -x callpiet.cob npiet.c -g -debug
      *> ***************************************************************
       identification division.
       program-id. callpiet.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 picture-file  pic x(80).
       01 zpicture      pic x(81).
       01 argvs.
          03 argv       usage pointer occurs 2 times.

       procedure division.

      *> fake the argc, argv
       accept picture-file from command-line end-accept
       if picture-file equal spaces then
           move "examples/hi.ppm" to picture-file
       end-if
       set argv(1) to address of picture-file

       move concatenate(trim(picture-file), x"00") to zpicture
       set argv(2) to address of zpicture

       call "piet" using
           by value 2
           by reference argvs
           on exception
               display "error: no piet linkage" upon syserr
       end-call

       goback.
       end program callpiet.
      *> ***************************************************************
>>ELSE
==============
callpiet usage
==============

    ./callpiet picture-file

Introduction
------------

Source
------

.. code-include::  callpiet.cob
   :language: cobol
>>END-IF

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****p* project/callpiet
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   2016-03-24
      *> LICENSE
      *>   GNU General Public License, GPL, 3.0 (or greater)
      *> PURPOSE
      *>   call piet program/picture.
      *> TECTONICS
      *>   cobc -x callpiet.cob npiet.c -g -debug
      *> ***************************************************************
       identification division.
       program-id. callpiet.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       >>IF P64 IS SET
       01 SIZE-MOD             constant as 18.
       >>ELSE
       01 SIZE-MOD             constant as 8.
       >>END-IF

       01 cli                  pic x(1024).
       01 prog                 pic x(9) value "callpiet".

      *> wordexp fields
       01 we-sub               usage binary-short.
       01 expanded-words       usage pointer.
       01 expand-flags         pic 9(SIZE-MOD) comp-5.
       01 expanded-structure.
          05 we-wordc          pic 9(SIZE-MOD) comp-5.
          05 we-wordv          usage pointer.
          05 we-offs           pic 9(SIZE-MOD) comp-5 value 0.
       01 wordexp-result       usage binary-long.

       procedure division.

      *> set the argc, argv
       accept cli from command-line
       if cli equal spaces then
           move "nhello.ppm" to cli
       end-if

       call "wordexp" using
           by content   concatenate(prog, space, trim(cli), x"00")
           by reference expanded-structure
           by value     expand-flags
           returning    wordexp-result
           on exception
               display "no wordexp linkage" upon syserr
               goback
       end-call

      *> call piet from the npiet-1.3d distribution
       call "piet" using
           by value we-wordc
           by value we-wordv
           on exception
               display "error: no piet linkage" upon syserr
       end-call

       goback.
       end program callpiet.
      *> ***************************************************************
>>ELSE
!doc-marker!
========
callpiet
========

    ./callpiet [options] picture-file

Introduction
------------
Piet programs use coloured pixels as instruction.  Art as code.

See http://www.dangermouse.net/esoteric/piet/samples.html for the
language designers collection of samples.

See http://www.dangermouse.net/esoteric/piet.html for the language
description.

The embedded Piet interpreter is from npiet-1.3d by Erik Schoenfelder

Usage
-----

    ./callpiet [options] [picture-file]

Uses npiet-1.3d, and the same command line options are supported.
picture-file defaults to ``nhello.ppm``, if not given.

Tectonics can include -A and -Q options to extend the features
built into the npiet engine.

-DHAVE_PNG for PNG support, along with GD, GIF library checks

Source
------

.. code-include::  callpiet.cob
   :language: cobol

.. image:: nhello-big.png

.. image:: sortgnu.png
>>END-IF

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****L* cobweb/dbus [0.2]
      *> Author:
      *>   Brian Tiffin
      *> Colophon:
      *>   Part of the GnuCobol free software project
      *>   Copyright (C) 2016, Brian Tiffin
      *>   Date      20160322
      *>   Modified: 2016-04-14/00:02-0400
      *>   Licensed for use under the
      *>   GNU Library General Public License, LGPL, 3 or superior
      *>   Documentation licensed GNU GPL, version 2.1 or greater
      *>   HTML Documentation thanks to ROBODoc --cobol
      *> Purpose:
      *>   Demonstrate GnuCobol functional bindings to D-Bus
      *>   Main module includes repository output and self test
      *>   ONLY A STARTER KIT. Effective use will require customization.
      *> Synopsis:
      *>   |dotfile cobweb-dbus.dot
      *>   |html <br />
      *>   Functions include
      *>   |exec cobcrun cobweb-dbus >cobweb-dbus.repository
      *>   |html <pre>
      *>   |copy cobweb-dbus.repository
      *>   |html </pre>
      *>   |exec rm cobweb-dbus.repository
      *> Tectonics:
      *>   cobc -x -g -debug cobweb-dbus.cob $(pkg-config --libs dbus-1)
      *>   robodoc --cobol --src ./ --doc cobwebdbus --multidoc \
      *>           --rc robocob.rc --css cobodoc.css
      *>   # run rst2html
      *>   > sed ':loop;/!rst.marker!/{d};N;b loop' $^ \
      *>   | sed '$${/^$$/d;}' \
      *>   | sed '$$d' | rst2html >$*.html
      *> Example:
      *>   procedure division.
      *>   move dbus-query(dbus-identity, "a message") to dbus-response
      *>   goback.
      *> Notes:
      *>   D-Bus has a reputation as being finicky, but seems fairly
      *>   stable now.
      *> Screenshot:
      *>   image:cobweb-dbus1.png
      *> Source:
       identification division.
       program-id. cobweb-dbus.
       author. Brian Tiffin.
       date-written. 2016-03-22/17:01-0400.
       date-modified. 2016-04-14/00:02-0400.
       date-compiled.
       installation. Requires libdbus version 1.
       remarks. Main module is test head, it forks servers for testing.
       security. Session D-Bus, no extra security layer in place.

       environment division.
       configuration section.
       source-computer. gnulinux.
       object-computer. gnulinux
           classification is canadian.

       special-names.
           locale canadian is "en_CA.UTF-8".

       repository.
           function dbus-listen
           function dbus-query
           function dbus-signal
           function dbus-catch
           function all intrinsic.

       input-output section.
       file-control.
       i-o-control.

       data division.
       file section.

      *> In lieu of copybooks
       REPLACE ==:DBUS-DATA:== BY
       ==
       01 DBUS_BUS_SESSION                      usage binary-long value 0.

       01 DBUS_NAME_FLAG_REPLACE_EXISTING       usage binary-long value 2.
       01 DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER usage binary-long value 1.
       01 DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER usage binary-long value 4.

       01 DBUS_TYPE_INVALID          usage binary-long value 0.
       01 DBUS_TYPE_BOOLEAN          usage binary-long value 98.
       01 DBUS_TYPE_STRING           usage binary-long value 115.
       01 DBUS_TYPE_UINT32           usage binary-long value 117.
       01 DBUS_TYPE_INT64            usage binary-long value 120.
       01 dbus-type                  usage binary-long.

       01 stderr                     usage pointer.
       01 hosted                     usage binary-long.

       01 dbus-connection            usage pointer.
       01 dbus-message               usage pointer.

       01 dbus-result                usage binary-long.
       01 conn-result                usage binary-long.

       01 dbus-param                 usage pointer.
       01 dbus-pending               usage pointer.

       01 dbus-reply                 usage pointer.
       01 param-length               usage binary-double.

       01 response-field-stat        usage binary-long.
       01 response-field-level       usage binary-long.
       01 response-field-length      usage binary-double.
       01 response-field-serial      usage binary-long.
       01 field-string               usage pointer.
       01 field-workspace            pic x(256).

       01 dbus-timeout               usage binary-long value -1.

       01 dbus-error                 pic x(128).
       01 dbus-error-message         usage pointer.

       01 DBusMessageIter.
          05 dummy1                  usage pointer.
          05 dummy2                  usage pointer.
          05 dummy3                  usage binary-long.
          05 dummy4                  usage binary-long.
          05 dummy5                  usage binary-long.
          05 dummy6                  usage binary-long.
          05 dummy7                  usage binary-long.
          05 dummy8                  usage binary-long.
          05 dummy9                  usage binary-long.
          05 dummy10                 usage binary-long.
          05 dummy11                 usage binary-long.
          05 pad1                    usage binary-long.
          05 pad2                    usage binary-long.
          05 pad3                    usage pointer.
       01 dbus-args                  usage pointer.
       01 iter-result                usage binary-long.
       01 dbus-indirect              usage pointer.

       01 len-signal-interface       usage binary-long.

       01 listener-interval          constant as 100000000.
       01 catcher-interval           constant as 100000000.
       01 fork-pause                 constant as 500000000.
       ==.

       REPLACE ALSO ==:DBUS-IDENTITY-LINKAGE:== BY
       ==
       01 dbus-identity.
           05 dbus-server-name       pic x(32).
           05 dbus-client-name       pic x(32).
           05 dbus-source-name       pic x(32).
           05 dbus-catch-name        pic x(32).
           05 dbus-method-path       pic x(32).
           05 dbus-method-interface  pic x(32).
           05 dbus-method-name       pic x(32).
           05 dbus-signal-path       pic x(32).
           05 dbus-signal-interface  pic x(32).
           05 dbus-signal-name       pic x(32).
           05 dbus-name              pic x(32).
           05 dbus-verbose           pic 9.
       ==.

       working-storage section.
       01 cli                        pic x(16).
          88 helping                 value "help", "-h", "--help".
          88 testing                 values "test", "testing", "check".
          88 quieting                value "quiet".
          88 verbosing               value "verbose".

       01 newline                    pic x value x"0a".

       01 result                     usage binary-long.
       01 process-id                 usage binary-long.
       01 process-status             usage binary-long.

       :DBUS-DATA:

       01 dbus-identity.
           05 dbus-server-name       pic x(32) value z"gnucobol.method.server".
           05 dbus-client-name       pic x(32) value z"gnucobol.method.caller".
           05 dbus-source-name       pic x(32) value z"gnucobol.signal.source".
           05 dbus-catch-name        pic x(32) value z"gnucobol.signal.sink".
           05 dbus-method-path       pic x(32) value z"/gnucobol/method/Object".
           05 dbus-method-interface  pic x(32) value z"gnucobol.method.Type".
           05 dbus-method-name       pic x(32) value z"SampleMethod".
           05 dbus-signal-path       pic x(32) value z"/gnucobol/signal/Object".
           05 dbus-signal-interface  pic x(32) value z"gnucobol.signal.Type".
           05 dbus-signal-name       pic x(32) value z"SampleSignal".
           05 dbus-name              pic x(32).
           05 dbus-verbose           pic 9     value 0.

       01 dbus-response              usage binary-long.
       01 dbus-final                 usage binary-long.

       local-storage section.
       linkage section.
       report section.
       screen section.

      *> ***************************************************************
       procedure division.
       display "      *> cobweb-dbus UDF repository"           newline
               "       repository."                            newline
               "           function dbus-listen"               newline
               "           function dbus-query"                newline
               "           function dbus-signal"               newline
               "           function dbus-catch"                newline

       accept cli from command-line
       if helping then
           display "cobweb-dbus"
           display "cobcrun cobweb-dbus [help | quiet | test | verbose]"
           display "  verbose runs testing with internal udf displays"
           display "  and quiet only displays failures during testing"
           goback
       end-if

      *> default to showing test head messages but not internals
       move 1 to dbus-verbose

       if quieting then
           move 0 to dbus-verbose
           set testing to true
       end-if
       if verbosing then
           move 2 to dbus-verbose
           display "one   #   is testhead messaging" newline
                   "two   ##  is dbus-listen, dbus-catch server" newline
                   "three ### is dbus-query, dbus-signal test" newline
           set testing to true
       end-if

       if testing then
          *> fork a listener, query a few times, and then shut it down
           if dbus-verbose greater than 0 then
               display "# fork listener #"
           end-if
           call "fork" returning process-id
           if process-id is less than zero then
               call "perror" using z"cobweb-dbus fork process error"
               perform hard-exception
           end-if

           *> child process code, listen server
           if process-id equal zero then
               move dbus-listen(dbus-identity) to dbus-final
               if dbus-verbose greater than 0 then
                   display "# dbus-listen exited with " dbus-final
                           " #" newline
               end-if
               goback
           end-if

          *> **********************************************************
          *> test continues, start talking to listener after a pause
           if dbus-verbose greater than 0 then
               display "# listener is " process-id " #"
           end-if
           call "CBL_OC_NANOSLEEP" using fork-pause

           if dbus-verbose greater than 0 then
               display newline "# send query 'Test' #"
           end-if
           move dbus-query(dbus-identity, "Test") to dbus-response
           if dbus-response not equal 4 then
               display "First query test failed, wanted 4: "
                       dbus-response upon syserr
           end-if

           if dbus-verbose greater than 0 then
               display newline "# send query 'Test two' #"
           end-if
           move dbus-query(dbus-identity, "Test two") to dbus-response
           if dbus-response not equal 8 then
               display "Second query test failed, wanted 8: "
                       dbus-response upon syserr
           end-if

           if dbus-verbose greater than 0 then
               display newline "# send query 'Test three' #"
           end-if
           move dbus-query(dbus-identity, "Test three") to dbus-response
           if dbus-response not equal 10 then
               display "Third query test failed, wanted 10: "
                       dbus-response upon syserr
           end-if

           if dbus-verbose greater than 0 then
               display newline "# send query 'Test four' #"
           end-if
           move dbus-query(dbus-identity, "Test four") to dbus-response
           if dbus-response not equal 9 then
               display "Fourth query test failed, wanted 9: "
                       dbus-response upon syserr
           end-if

           if dbus-verbose greater than 0 then
               display newline "# send query to quit #"
           end-if
           move dbus-query(dbus-identity, "quit") to dbus-response
           if dbus-response not equal 4 then
               display "quit query failed, wanted 4: "
                       dbus-response upon syserr
           end-if

          *> wait for listener to terminate
           call "waitpid" using
               by value process-id
               by reference process-status
               by value 0
               returning result
           if result not equal process-id then
               display "Unexpected listener wait result: "
                       result ", " process-id
                  upon syserr
           end-if
           if process-status not equal 0 then
               display "Unexpected listener status: " process-status
                  upon syserr
           end-if
          *> **********************************************************

          *> fork a catcher, signal, and then shut it down
           move zero to process-id
           if dbus-verbose greater than 0 then
               display newline newline "# fork catcher #"
           end-if
           call "fork" returning process-id
           if process-id is less than zero then
               call "perror" using z"cobweb-dbus fork process error"
               perform hard-exception
           end-if

           *> child process code, catch server
           if process-id equal zero then
               move dbus-catch(dbus-identity) to dbus-final
               if dbus-verbose greater than 0 then
                   display "# dbus-catch exited with " dbus-final " #"
                   display space
               end-if
               goback
           end-if

          *> **********************************************************
          *> test continues, send signals to catcher after a pause
           if dbus-verbose greater than 0 then
               display "# catcher is " process-id " #"
           end-if
           call "CBL_OC_NANOSLEEP" using fork-pause

           if dbus-verbose greater than 0 then
               display newline "# broadcast signal with 'beep' #"
           end-if

           move dbus-signal(dbus-identity, "beep") to dbus-response
           if dbus-response not equal 4 then
               display "signal test failed, wanted 4: "
                       dbus-response upon syserr
           end-if

          *> sleep to match the sleep interval of catcher loop
           call "CBL_OC_NANOSLEEP" using catcher-interval
           if dbus-verbose greater than 0 then
               display newline "# broadcast signal with 'new' #"
           end-if

           move dbus-signal(dbus-identity, "new") to dbus-response
           if dbus-response not equal 3 then
               display "new signal failed, wanted 3: "
                       dbus-response upon syserr
           end-if

           call "CBL_OC_NANOSLEEP" using catcher-interval
           if dbus-verbose greater than 0 then
               display newline "# broadcast signal to quit #"
           end-if

           move dbus-signal(dbus-identity, "quit") to dbus-response
           if dbus-response not equal -1 then
               display "quit signal failed, wanted -1: "
                       dbus-response upon syserr
           end-if

          *> wait for catcher to terminate
           call "waitpid" using
               by value process-id
               by reference process-status
               by value 0
               returning result
           if result not equal process-id then
               display "Unexpected catcher wait result: "
                       result ", " process-id
                  upon syserr
           end-if
           if process-status not equal 0 then
               display "Unexpected catcher status: " process-status
                  upon syserr
           end-if
       end-if

       move 0 to return-code
       goback.
      *> ***************************************************************

      *> add support routines, once again in lieu of copybooks
       REPLACE ALSO ==:DBUS-HANDLERS:== BY
       ==
      *> D-Bus error handling
       dbus-error-init.
       call "dbus_error_init" using
           by reference dbus-error
           returning omitted
           on exception
               display "dbus_error_init exception" upon syserr
               perform soft-exception
       end-call
       .

       dbus-error-test.
       call "dbus_error_is_set" using
           by reference dbus-error
           returning dbus-result
           on exception
               display "dbus_error_is_set exception" upon syserr
               perform soft-exception
       end-call
       if dbus-result not equal zero then
           call "CBL_OC_HOSTED" using stderr "stderr" returning hosted
           if hosted equal 1 or stderr equal null then
               display "error fetching stderr" upon syserr
               perform soft-exception
           else
               call "fprintf" using
                   by value stderr
                   by content "D-Bus error: (%s)" & x"0a00"
                   by value dbus-error-message
                   on exception
                       display "fprintf exception" upon syserr
                       perform soft-exception
               end-call
           end-if

           if dbus-result not equal zero then
               call "perror" using z"cobweb-dbus stderr close error"
               perform soft-exception
           end-if

           call "dbus_error_free" using
               by reference dbus-error
               returning omitted
               on exception
                   display "dbus_error_is_set exception" upon syserr
                   perform soft-exception
           end-call
       end-if
       .

      *> D-Bus bus init
       dbus-bus-get.
       call "dbus_bus_get" using
           by value DBUS_BUS_SESSION
           by reference dbus-error
           returning dbus-connection
           on exception
               display "dbus_bus_get exception" upon syserr
               perform soft-exception
       end-call
       perform dbus-error-test

       if dbus-result not equal zero then
           display "D-Bus connection error" upon syserr
           perform hard-exception
       end-if

       if dbus-connection equal null then
           display "D-Bus connection null" upon syserr
           perform hard-exception
       end-if
       .

       dbus-bus-request-name.
       call "dbus_bus_request_name" using
           by value dbus-connection
           by content dbus-name
           by value DBUS_NAME_FLAG_REPLACE_EXISTING
           by reference dbus-error
           returning dbus-result
           on exception
               display "dbus_bus_request_name exception" upon syserr
               perform soft-exception
       end-call
       move dbus-result to conn-result
       perform dbus-error-test

       if conn-result not equal DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER
                            and DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER
           display "Not primary owner: (" conn-result ")" upon syserr
           perform hard-exception
       end-if
       .

      *> D-Bus reading writing
       dbus-connection-read-write.
       call "dbus_connection_read_write" using
           by value dbus-connection
           by value 0                 *> read timeout 0 for non-blocking
           returning dbus-result
           on exception
               display "dbus_connection_read_write exception"
                  upon syserr
               perform soft-exception
       end-call

       call "dbus_connection_pop_message" using
           by value dbus-connection
           returning dbus-message
           on exception
               display "dbus_connection_pop_message exception"
                  upon syserr
               perform soft-exception
       end-call
       .

       dbus-connection-send.
       call "dbus_connection_send" using
           by value dbus-connection
           by value dbus-message
           by reference response-field-serial
           returning dbus-result
           on exception
               display "dbus_message_iter_append_basic exception"
                  upon syserr
               perform soft-exception
       end-call
       if dbus-result equal zero then
           display "D-Bus resource exhaustion" upon syserr
           perform hard-exception
       end-if
       .

       dbus-connection-send-with-reply.
       call "dbus_connection_send_with_reply" using
           by value dbus-connection
           by value dbus-message
           by reference dbus-pending
           by value dbus-timeout
           returning dbus-result
           on exception
               display "dbus_connection_send_with_reply exception"
                  upon syserr
               perform soft-exception
       end-call
       if dbus-pending equal null then
           display "D-Bus pending call null" upon syserr
           perform hard-exception
       end-if
       .

       dbus-pending-call-block.
       call "dbus_pending_call_block" using
           by value dbus-pending
           returning omitted
           on exception
               display "dbus_pending_call_block exception" upon syserr
               perform soft-exception
       end-call
       .

       dbus-pending-call-steal-reply.
       call "dbus_pending_call_steal_reply" using
           by value dbus-pending
           returning dbus-message
           on exception
               display "dbus_pending_call_block exception" upon syserr
               perform soft-exception
       end-call
       if dbus-message equal null then
           display "D-Bus reply null" upon syserr
           perform hard-exception
       end-if
       .

       dbus-connection-flush.
       call "dbus_connection_flush" using
           by value dbus-connection
           returning omitted
           on exception
               display "dbus_connection_flush exception" upon syserr
               perform soft-exception
       end-call
       .
      *> D-Bus message management
       dbus-message-iter-init.
       initialize DBusMessageIter all to value
       set dbus-args to address of DBusMessageIter
       call "dbus_message_iter_init" using
           by value dbus-message
           by value dbus-args
           returning dbus-result
           on exception
               display "dbus_message_iter_init exception" upon syserr
               perform soft-exception
       end-call
       .

       dbus-message-iter-init-append.
       set dbus-args to address of DBusMessageIter
       call "dbus_message_iter_init_append" using
           by value dbus-message
           by value dbus-args
           returning omitted
           on exception
               display "dbus_message_iter_init_append exception"
                  upon syserr
               perform soft-exception
       end-call
       .

       dbus-message-iter-get-arg-type.
       call "dbus_message_iter_get_arg_type" using
           by value dbus-args
           returning iter-result
           on exception
               display "dbus_message_iter_get_arg_type exception"
                  upon syserr
               perform soft-exception
       end-call
       .

       dbus-message-iter-get-basic.
       call "dbus_message_iter_get_basic" using
           by value dbus-args
           by value dbus-indirect
           returning omitted
           on exception
               display "dbus_message_iter_get_basic" upon syserr
               perform soft-exception
       end-call
       .

       dbus-message-iter-next.
       call "dbus_message_iter_next" using
           by value dbus-args
           returning dbus-result
           on exception
               display "dbus_message_iter_next exception" upon syserr
               perform soft-exception
       end-call
       .

       dbus-message-iter-append-basic.
       call "dbus_message_iter_append_basic" using
           by value dbus-args
           by value dbus-type
           by value dbus-indirect
           returning dbus-result
           on exception
               display "dbus_message_iter_append_basic exception"
                  upon syserr
               perform soft-exception
       end-call
       if dbus-result equal zero then
           display "D-Bus resource exhaustion" upon syserr
           perform hard-exception
       end-if
       .

      *> D-Bus method and signal handling
       dbus-message-new-method-call.
       call "dbus_message_new_method_call" using
           by content dbus-server-name
           by content dbus-method-path
           by content dbus-method-interface
           by content dbus-method-name
           returning dbus-message
           on exception
               display "dbus_message_new_method_call exception"
                  upon syserr
               perform soft-exception
       end-call
       if dbus-message equal null then
           display "D-Bus message null" upon syserr
           perform hard-exception
       end-if
       .

       dbus-message-is-method-call.
       call "dbus_message_is_method_call" using
           by value dbus-message
           by content dbus-method-interface
           by content dbus-method-name
           returning dbus-result
           on exception
               display "dbus_message_is_method_call exception"
                  upon syserr
               perform soft-exception
       end-call
       .

       dbus-message-new-signal.
       call "dbus_message_new_signal" using
           by content dbus-signal-path
           by content dbus-signal-interface
           by content dbus-signal-name
           returning dbus-message
           on exception
               display "dbus_message_new_signal exception" upon syserr
               perform soft-exception
       end-call
       if dbus-message equal null then
           display "D-Bus message null" upon syserr
           perform hard-exception
       end-if
       .

       dbus-message-is-signal.
       call "dbus_message_is_signal" using
           by value dbus-message
           by content dbus-signal-interface
           by content dbus-signal-name
           returning dbus-result
           on exception
               display "dbus_message_is_signal exception" upon syserr
               perform soft-exception
       end-call
       .

       dbus-bus-add-match.
       compute len-signal-interface =
           length(trim(dbus-signal-interface)) - 1

       call "dbus_bus_add_match" using
           by value dbus-connection
           by content concatenate("type='signal',interface='",
               dbus-signal-interface(1:len-signal-interface)
               z"'")
           by reference dbus-error
           on exception
               display "dbus_bus_add_match exception" upon syserr
               perform soft-exception
       end-call
       .

      *> D-Bus resource unreference
       dbus-message-unref.
       call "dbus_message_unref" using
           by value dbus-message
           returning omitted
           on exception
               display "dbus_message_unref exception" upon syserr
               perform soft-exception
       end-call
       .

       dbus-connection-unref.
       if dbus-connection not equal null then
           perform dbus-connection-flush

           call "dbus_connection_unref" using
               by value dbus-connection
               returning omitted
               on exception
                   display "dbus_connection_unref exception" upon syserr
                   perform soft-exception
           end-call
       end-if
       .

       dbus-pending-call-unref.
       call "dbus_pending_call_unref" using
           by value dbus-pending
           returning omitted
           on exception
               display "dbus_pending_call_unref exception" upon syserr
               perform soft-exception
       end-call
       .
       ==.

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> exception warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program cobweb-dbus.
      *>****

      *> ***************************************************************

*>****F* dbus/listen [0.2]
*> Purpose:
*> Start a session D-Bus listener
*> Input:
*>   dbus-identity
*> Output:
*>   dbus-final
*> Source:
 identification division.
 function-id. dbus-listen.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 :DBUS-DATA:

 01 not-method-call            usage binary-long.

 01 reply-status               usage binary-long.
    88 quitting                value -1.

*> limited for testing
 01 bailer                     usage binary-long value 1.
    88 bailing                 value 150.

 linkage section.
 :DBUS-IDENTITY-LINKAGE:

 01 dbus-final                 usage binary-long.

*> ***************************************************************
 procedure division using dbus-identity returning dbus-final.

 if dbus-verbose greater than 1 then
     display "## START LISTENING [" current-date "] ##"
 end-if

 perform dbus-error-init
 perform dbus-bus-get

 move dbus-server-name to dbus-name
 perform dbus-bus-request-name

*> play nice, and sleep during waits with non blocking read
 move 1 to bailer
 perform until exit
     add 1 to bailer
     if bailing then exit perform end-if

     perform dbus-connection-read-write
     if dbus-message equal null then
         call "CBL_OC_NANOSLEEP" using listener-interval
         exit perform cycle
     end-if

     perform dbus-message-is-method-call
     if dbus-result not equal zero then
         if dbus-verbose greater than 1 then
             display "## REPLYING [" current-date "] ##"
         end-if
         call "reply-to-method-call" using
             dbus-message
             dbus-connection
             returning reply-status
             on exception
                 display "reply-to-method-call exception"
                    upon syserr
                 set quitting to true
                 perform soft-exception
         end-call
     else
         add 1 to not-method-call
     end-if

     perform dbus-message-unref

     if quitting then exit perform end-if

 end-perform

 perform dbus-connection-unref

 if dbus-verbose greater than 1 then
     display "## STOP LISTENING. Ignored: " not-method-call
             " [" current-date "] ##"
 end-if
 move 0 to dbus-final
 goback
 .

 :DBUS-HANDLERS:

 :EXCEPTION-HANDLERS:
 end function dbus-listen.

*>****
*> ***************************************************************

*>****S* dbus/reply-to-method-call [0.2]
*> Purpose:
*>   Handle D-Bus reply
*> Input:
*>   dbus-message pointer
*>   dbus-connection pointer
*> Output:
*>   quit status integer
*> Source:
 identification division.
 program-id. reply-to-method-call.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 :DBUS-DATA:
 :DBUS-IDENTITY-LINKAGE:

 01 quit-flag                  usage binary-long.
 01 quit-length                usage binary-c-long value 4.

 linkage section.
 01 dbus-reply-message         usage pointer.
 01 dbus-reply-connection      usage pointer.

 procedure division using
     dbus-reply-message
     dbus-reply-connection.
     *> returning quit-flag.

 move 1 to response-field-stat
 move 20042 to response-field-level

 if dbus-verbose greater than 1 then
     display "### IN REPLY" with no advancing
 end-if

*> move linkage to names expected by paragraphs
 set dbus-message to dbus-reply-message
 set dbus-connection to dbus-reply-connection

 perform dbus-message-iter-init
 if dbus-result equal zero then
     display "reply-to-method-call expected arguments" upon syserr
 else
     perform dbus-message-iter-get-arg-type
     if iter-result not equal DBUS_TYPE_STRING then
         display "reply-to-method expected string" upon syserr
     else
         set dbus-indirect to address of dbus-param
         perform dbus-message-iter-get-basic
         if dbus-param not equal null then
             if dbus-verbose greater than 1
                 call "printf" using
                     by content z" with (%s) "
                     by value dbus-param
                     on exception
                         display "printf exception" upon syserr
                         perform soft-exception
                 end-call
                 display "[" current-date "] ###"
             end-if
             call "strlen" using
                 by value dbus-param
                 returning param-length
                 on exception
                     display "strlen exception" upon syserr
                     perform soft-exception
             end-call
             call "strncmp" using
                 by value dbus-param
                 by content z"quit"
                 by value quit-length
                 returning quit-flag
                 on exception
                     display "strncmp exception" upon syserr
                     perform soft-exception
             end-call
         else
             move 0 to param-length
         end-if
     end-if
 end-if

*> create the reply from the incoming message
 call "dbus_message_new_method_return" using
     by value dbus-message
     returning dbus-reply
     on exception
         display "dbus_message_new_method_return exception"
            upon syserr
         perform soft-exception
 end-call

 call "dbus_message_iter_init_append" using
     by value dbus-reply
     by value dbus-args
     returning omitted
     on exception
         display "dbus_message_iter_init_append exception"
            upon syserr
         perform soft-exception
 end-call

*> turns out DBUS_BOOLEAN is 32 bits
 set dbus-indirect to address of response-field-stat
 move DBUS_TYPE_BOOLEAN to dbus-type
 perform dbus-message-iter-append-basic

 set dbus-indirect to address of response-field-level
 move DBUS_TYPE_UINT32 to dbus-type
 perform dbus-message-iter-append-basic

 set dbus-indirect to address of param-length
 move DBUS_TYPE_INT64 to dbus-type
 perform dbus-message-iter-append-basic

*> send the reply
*> overwriting message field with reply for these paragraphs
 set dbus-message to dbus-reply
 perform dbus-connection-send
 perform dbus-connection-flush

 perform dbus-message-unref

 if quit-flag equal 0 then
     move -1 to return-code
 else
     move 0 to return-code
 end-if
 goback.

 :DBUS-HANDLERS:

 :EXCEPTION-HANDLERS:
 end program reply-to-method-call.
*>****
*> ***************************************************************

*>****F* dbus/query [0.2]
*> Purpose:
*> Send a query string to a D-Bus listener
*> Input:
*>   dbus-identity
*>   message pic x any
*> Output:
*>   dbus-response
*> Source:
 identification division.
 function-id. dbus-query.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 :DBUS-DATA:

 01 quit-flag                  usage binary-long.
 01 quit-length                usage binary-c-long value 4.

 linkage section.
 :DBUS-IDENTITY-LINKAGE:

 01 dbus-string                pic x any length.
 01 dbus-final                 usage binary-long.

 procedure division using
     dbus-identity
     dbus-string
   returning dbus-final.

*> the quit message
 if dbus-string = "quit" then move -1 to dbus-final end-if

 move concatenate(trim(dbus-string), x"00")
   to field-workspace

 if dbus-verbose greater than 1 then
     display "### SEND QUERY " dbus-string
             " [" current-date "] ###"
 end-if

 perform dbus-error-init
 perform dbus-bus-get

 move dbus-client-name to dbus-name
 perform dbus-bus-request-name

*> create the method call
 perform dbus-message-new-method-call

 perform dbus-message-iter-init-append

*> add the passed in string
 set field-string to address of field-workspace
 set dbus-indirect to address of field-string
 move DBUS_TYPE_STRING to dbus-type
 perform dbus-message-iter-append-basic

*> send message and get the reply handle
 perform dbus-connection-send-with-reply
 perform dbus-connection-flush

 if dbus-verbose greater than 1 then
     display "### Request sent [" current-date "] ###"
 end-if

 perform dbus-message-unref

*> wait for the pending reply
 perform dbus-pending-call-block
 perform dbus-pending-call-steal-reply
 perform dbus-pending-call-unref

*> Read the response values
 perform dbus-message-iter-init
 if dbus-result equal zero then
     display "Message has no arguments" upon syserr
 else
     perform dbus-message-iter-get-arg-type

     perform until iter-result = DBUS_TYPE_INVALID
         evaluate iter-result
             when equal DBUS_TYPE_BOOLEAN
                 set dbus-indirect to address of response-field-stat
                 perform dbus-message-iter-get-basic
                 if dbus-verbose greater than 1 then
                     display "### got stat " response-field-stat
                        with no advancing
                 end-if

             when equal DBUS_TYPE_UINT32
                 set dbus-indirect to address of response-field-level
                 perform dbus-message-iter-get-basic
                 if dbus-verbose greater than 1 then
                     display " level of " response-field-level
                             " [" current-date "] ###"
                 end-if

             when equal DBUS_TYPE_INT64
                 set dbus-indirect to address of response-field-length
                 perform dbus-message-iter-get-basic
                 if dbus-verbose greater than 1 then
                     display "### result of "
                             response-field-length
                             " [" current-date "] ###"
                 end-if

                 *> use length of input string as function result
                 move response-field-length to dbus-final

             when equal DBUS_TYPE_STRING
                 if dbus-verbose greater than 1 then
                     display "### got an erroneous string"
                        with no advancing
                 end-if
                 set dbus-indirect to address of dbus-param
                 perform dbus-message-iter-get-basic
                 if dbus-verbose greater than 1
                     and dbus-param not equal null then
                     call "printf" using
                         by content z" of (%s) "
                         by value dbus-param
                         on exception
                             display "printf exception"
                                upon syserr
                             perform soft-exception
                     end-call
                     display "[" current-date "] ###"
                 end-if

             when other
                 if dbus-verbose greater than 1 then
                     display "### got an unexpected " iter-result
                             " [" current-date "] ###"
                 end-if
         end-evaluate

         perform dbus-message-iter-next
         perform dbus-message-iter-get-arg-type

     end-perform
 end-if

 perform dbus-message-unref

 goback
 .

 :DBUS-HANDLERS:

 :EXCEPTION-HANDLERS:
 end function dbus-query.
*>****
*> ***************************************************************

*>****F* dbus/signal [0.2]
*> Purpose:
*> Send a query string to a D-Bus listener
*> Input:
*>   dbus-identity
*>   message pic x any
*> Output:
*>   dbus-response
*> Source:
 identification division.
 function-id. dbus-signal.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 :DBUS-DATA:

 01 quit-flag                  usage binary-long.
 01 quit-length                usage binary-c-long value 4.

 linkage section.
 :DBUS-IDENTITY-LINKAGE:

 01 dbus-string                pic x any length.
 01 dbus-final                 usage binary-long.

 procedure division using
     dbus-identity
     dbus-string
   returning dbus-final.

*> the quit signal
 if dbus-string = "quit" then
     move -1 to dbus-final
 else
     move length(dbus-string) to dbus-final
 end-if

 if dbus-verbose greater than 1 then
     display "### SEND SIGNAL " dbus-string " [" current-date "] ###"
 end-if

 perform dbus-error-init

 perform dbus-bus-get

 move dbus-source-name to dbus-name
 perform dbus-bus-request-name

*> create the signal
 perform dbus-message-new-signal

 perform dbus-message-iter-init-append

*> add the passed in string
 move concatenate(trim(dbus-string), x"00")
   to field-workspace

 set field-string to address of field-workspace
 set dbus-indirect to address of field-string
 move DBUS_TYPE_STRING to dbus-type
 perform dbus-message-iter-append-basic

*> send the signal
 perform dbus-connection-send
 perform dbus-connection-flush

 if dbus-verbose greater than 1 then
     display "### Signal sent [" current-date "] ###"
 end-if

 perform dbus-message-unref

 goback
 .

 :DBUS-HANDLERS:

 :EXCEPTION-HANDLERS:
 end function dbus-signal.
*>****
*> ***************************************************************

      *>****F* dbus/catch [0.2]
      *> Purpose:
      *> Catch signals to the bus
      *> Input:
      *>   dbus-identity
      *>   message pic x any
      *> Output:
      *>   dbus-response
      *> Source:
       identification division.
       function-id. dbus-catch.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       :DBUS-DATA:

       01 quit-flag                  usage binary-long.
       01 quit-length                usage binary-c-long value 4.

       01 not-our-signal             usage binary-long.

      *> limiter for testing
       01 bailer                     usage binary-long value 1.
          88 bailing                 value 0.

       01 reply-status               usage binary-long.
          88 quitting                value -1.

       linkage section.
       :DBUS-IDENTITY-LINKAGE:

       01 dbus-final                 usage binary-long.

      *> ***************************************************************
       procedure division using dbus-identity returning dbus-final.

       if dbus-verbose greater than 1 then
           display "## CATCH SIGNALS [" current-date "] ##"
       end-if

       perform dbus-error-init

       perform dbus-bus-get

       move dbus-catch-name to dbus-name
       perform dbus-bus-request-name

       perform dbus-bus-add-match
       perform dbus-connection-flush
       if dbus-verbose greater than 1 then
           display "## MATCH RULE SENT [" current-date "] ##"
       end-if

      *> play nice, and sleep during waits with non blocking read
       move 1 to bailer
       perform until exit
           add 1 to bailer
           if bailing then exit perform end-if

           perform dbus-connection-read-write

           if dbus-message equal null then
               call "CBL_OC_NANOSLEEP" using catcher-interval
               exit perform cycle
           end-if

           perform dbus-message-is-signal
           if dbus-result not equal zero then
               if dbus-verbose greater than 1 then
                   display "## CATCH" with no advancing
               end-if
               perform dbus-message-iter-init
               if dbus-result equal zero then
                   display "Signal has no arguments" upon syserr
               else
                   perform dbus-message-iter-get-arg-type
                   if iter-result not equal DBUS_TYPE_STRING then
                       display "catcher expected a string" upon syserr
                   else
                       set dbus-indirect to address of dbus-param
                       perform dbus-message-iter-get-basic
                       if dbus-param not equal null then
                           if dbus-verbose greater than 1 then
                               call "printf" using
                                   by content z" with (%s) "
                                   by value dbus-param
                                   on exception
                                       display "printf exception"
                                          upon syserr
                                       perform soft-exception
                               end-call
                               display "[" current-date "] ##"
                           end-if
                           call "strlen" using
                               by value dbus-param
                               returning param-length
                               on exception
                                   display "strlen exception"
                                      upon syserr
                                   perform soft-exception
                           end-call
                           call "strncmp" using
                               by value dbus-param
                               by content z"quit"
                               by value quit-length
                               returning quit-flag
                               on exception
                                   display "strncmp exception"
                                      upon syserr
                                   perform soft-exception
                           end-call
                           if quit-flag equal 0 then
                               set quitting to true
                           end-if
                       end-if
                   end-if
               end-if
           else
               add 1 to not-our-signal
           end-if

           perform dbus-message-unref

           if quitting then
               exit perform
           end-if

       end-perform
       if dbus-verbose greater than 1 then
           display "## STOP CATCHING. Ignored: " not-our-signal
                   " [" current-date "] ##"
       end-if
       move 0 to dbus-final
       goback
       .

       :DBUS-HANDLERS:

       :EXCEPTION-HANDLERS:
       end function dbus-catch.
      *>****
      *> ***************************************************************
>>ELSE
!doc-marker!
===========
cobweb-dbus
===========

.. contents::

Introduction
------------
D-Bus sample with user defined functions.

Includes an example of

- dbus-listen to loop and listen for method calls until told to quit
- dbus-query  to send a method call and await response

- dbus-catch  to loop and listen for signals until told to quit
- dbus-signal  to broadcase a signal

Tectonics
---------

::

    prompt$ cobc -m -d -frelax cobweb-dbus.cob $(pkg-config --libs dbus-1)

    -frelax is required due to long names

Usage
-----

::

    prompt$ cobcrun cobweb-dbus test
    prompt$ cobcrun cobweb-dbus verbose (for noisy internals testing)
    prompt$ cobcrun cobweb-dbus quiet (only display failures in testing)

Customization
-------------

This is not really a stand alone library.  It requires customization to
add application specific logic.  The sample creates method calls that
send a string and expect three values in return;

- a status true/false
- an integer "application version"
- length of the sent string

from a listener process.  The listener is forked into a child process
for cobcrun testing of the library.

There is also a signal routine that attaches a string to the broadcast
and a catch loop (again, forked during main module testing).

Both the listen and catch loops react to a 'quit' message to stop
and exit.

See dbus-identity in the main module for names used for methods and
signals.  These are SESSION bus tests.  SYSTEM bus setups will require
external D-Bus configurations for security setting.

Source
------

.. include::  cobweb-dbus.cob
   :code: cobolfree
>>END-IF

# dbus samples
.RECIPEPREFIX = >

cobweb-dbus.so: cobweb-dbus.cob
> cobc -m -d -v cobweb-dbus.cob -frelax `pkg-config --libs dbus-1`

.PHONY: test verbose quiet cobweb-dbus
cobweb-dbus: cobweb-dbus.so

test: cobweb-dbus
> cobcrun cobweb-dbus test

verbose: cobweb-dbus
> cobcrun cobweb-dbus verbose

quiet: cobweb-dbus
> cobcrun cobweb-dbus quiet

prompt$ make
cobc -m -d -v cobweb-dbus.cob -frelax `pkg-config --libs dbus-1`
Loading standard configuration file 'default.conf'
Command line:   cobc -m -d -v -frelax -ldbus-1 cobweb-dbus.cob
Preprocessing:  cobweb-dbus.cob -> /tmp/cob18777_0.cob
Return status:  0
Parsing:        /tmp/cob18777_0.cob (cobweb-dbus.cob)
cobweb-dbus.cob: 200: Warning: 'REPORT SECTION' not implemented
Return status:  0
Translating:    /tmp/cob18777_0.cob -> /tmp/cob18777_0.c (cobweb-dbus.cob)
Executing:      gcc -I/usr/local/include -pipe -Wno-unused -fsigned-char
                -Wno-pointer-sign -shared -fPIC -DPIC -Wl,--export-dynamic -o
                "cobweb-dbus.so" "/tmp/cob18777_0.c" -Wl,--no-as-needed
                -L/usr/local/lib -lcob -lm -lvbisam -lgmp -lncurses -ldl
                -l"dbus-1"
Return status:  0

prompt$ make quiet
cobcrun cobweb-dbus quiet
      *> cobweb-dbus UDF repository
       repository.
           function dbus-listen
           function dbus-query
           function dbus-signal
           function dbus-catch

prompt$ make test
cobcrun cobweb-dbus test
      *> cobweb-dbus UDF repository
       repository.
           function dbus-listen
           function dbus-query
           function dbus-signal
           function dbus-catch

# fork listener #
# listener is +0000018790 #

# send query 'Test' #

# send query 'Test two' #

# send query 'Test three' #

# send query 'Test four' #

# send query to quit #
# dbus-listen exited with +0000000000 #



# fork catcher #
# catcher is +0000018791 #

# broadcast signal with 'beep' #

# broadcast signal with 'new' #

# broadcast signal to quit #
# dbus-catch exited with +0000000000 #

prompt$ make verbose
cobcrun cobweb-dbus verbose
      *> cobweb-dbus UDF repository
       repository.
           function dbus-listen
           function dbus-query
           function dbus-signal
           function dbus-catch

one   #   is testhead messaging
two   ##  is dbus-listen, dbus-catch server
three ### is dbus-query, dbus-signal test

# fork listener #
# listener is +0000018794 #
## START LISTENING [2016041400103452-0400] ##

# send query 'Test' #
### SEND QUERY Test [2016041400103502-0400] ###
### Request sent [2016041400103503-0400] ###
## REPLYING [2016041400103513-0400] ##
### got stat +0000000001 level of +0000020042 [2016041400103513-0400] ###
### result of +00000000000000000004 [2016041400103513-0400] ###

# send query 'Test two' #
### SEND QUERY Test two [2016041400103513-0400] ###
### Request sent [2016041400103513-0400] ###
## REPLYING [2016041400103523-0400] ##
### got stat +0000000001 level of +0000020042 [2016041400103523-0400] ###
### result of +00000000000000000008 [2016041400103523-0400] ###

# send query 'Test three' #
### SEND QUERY Test three [2016041400103523-0400] ###
### Request sent [2016041400103523-0400] ###
## REPLYING [2016041400103533-0400] ##
### got stat +0000000001 level of +0000020042 [2016041400103533-0400] ###
### result of +00000000000000000010 [2016041400103533-0400] ###

# send query 'Test four' #
### SEND QUERY Test four [2016041400103533-0400] ###
### Request sent [2016041400103533-0400] ###
## REPLYING [2016041400103543-0400] ##
### got stat +0000000001 level of +0000020042 [2016041400103543-0400] ###
### result of +00000000000000000009 [2016041400103543-0400] ###

# send query to quit #
### SEND QUERY quit [2016041400103543-0400] ###
### Request sent [2016041400103543-0400] ###
## REPLYING [2016041400103553-0400] ##
## STOP LISTENING. Ignored: +0000000002 [2016041400103553-0400] ##
# dbus-listen exited with +0000000000 #

### got stat +0000000001 level of +0000020042 [2016041400103553-0400] ###
### result of +00000000000000000004 [2016041400103553-0400] ###


# fork catcher #
# catcher is +0000018795 #
## CATCH SIGNALS [2016041400103553-0400] ##
## MATCH RULE SENT [2016041400103553-0400] ##

# broadcast signal with 'beep' #
### SEND SIGNAL beep [2016041400103603-0400] ###
### Signal sent [2016041400103603-0400] ###
## CATCH with (beep) [2016041400103603-0400] ##

# broadcast signal with 'new' #
### SEND SIGNAL new [2016041400103613-0400] ###
### Signal sent [2016041400103613-0400] ###
## CATCH with (new) [2016041400103613-0400] ##

# broadcast signal to quit #
### SEND SIGNAL quit [2016041400103623-0400] ###
### Signal sent [2016041400103623-0400] ###
## CATCH with (quit) [2016041400103633-0400] ##
## STOP CATCHING. Ignored: +0000000003 [2016041400103633-0400] ##
# dbus-catch exited with +0000000000 #

prompt$

Red/System [
    Title: "hello red, callable"
]

hello: function [] [
    print "Hello, world"
]

#export [hello]

prompt$ red -dlib hello-red.red

-=== Red Compiler 0.5.3 ===-

Compiling /home/btiffin/lang/red/hello-red.red ...

Compiling to native code...
...compilation time : 196 ms
...linking time     : 9 ms
...output file size : 5164 bytes
...output file      : /home/btiffin/lang/red/hello-red.so

GCobol >>SOURCE FORMAT IS FREE
REPLACE ==SAMPLE== BY ==program-name==.
>>IF docpass NOT DEFINED
      *> **************************************
      *>****J* project/SAMPLE
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20150610
      *> LICENSE
      *>   GNU General Public License, GPL, 3.0
      *> PURPOSE
      *>   SAMPLE program.
      *> TECTONICS
      *>   red -dlib hello-red.red
      *>   cobc -x callred.cob hello-red.so
      *> ***************************************
       identification division.
       program-id. SAMPLE.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       input-output section.
       file-control.

       data division.
       file section.
       working-storage section.
       local-storage section.
       linkage section.
       report section.
       screen section.

      *> ****************************************
       procedure division.

       call "hello" end-call

       goback.
       end program SAMPLE.
      *> ****************************************
      *>****
>>ELSE
============
SAMPLE usage
============

Introduction
------------

Source
------

.. code-include::  SAMPLE.cob
   :language: cobol
>>END-IF

prompt$ cobc -x callred.cob hello-red.so
prompt$ ./callred
Hello, world
prompt$

export CFLAGS='-m32'
export LDFLAGS='-m32'
./configure
make
make check
source tests/atconfig
source tests/atlocal

SIGNAL identification division.
       program-id. signals.
       data division.
       working-storage section.
       01 signal-flag  pic 9 external.
          88 signalled value 1.
       01 half-seconds usage binary-long.
       01 start-time   usage binary-c-long.
       01 end-time     usage binary-c-long.
       01 handler      usage program-pointer.
       01 SIGINT       constant as 2.

       procedure division.
       call "gettimeofday" using start-time null
       set handler to entry "handle-sigint"
       call "signal" using by value SIGINT by value handler

       perform until exit
           if signalled then exit perform end-if
           call "CBL_OC_NANOSLEEP" using 500000000
           if signalled then exit perform end-if
           add 1 to half-seconds
           display half-seconds
       end-perform

       call "gettimeofday" using end-time null
       subtract start-time from end-time
       display "Program ran for " end-time " seconds"
       goback.
       end program signals.

      *> SIGINT handler
       identification division.
       program-id. handle-sigint.
       data division.
       working-storage section.
       01 signal-flag  pic 9 external.

       linkage section.
       01 the-signal   usage binary-long.

       procedure division using by value the-signal returning omitted.
       move 1 to signal-flag
       goback.
       end program handle-sigint.

SIGNAL identification division.
       program-id. sigactions.
       data division.
       working-storage section.
       01 signal-flag      pic 9 external.
          88 signalled     value 1.

       01 start-time       usage binary-c-long.
       01 end-time         usage binary-c-long.
       01 show-time        pic z(8)9.

       01 half-seconds     usage binary-long.
       01 display-halves   pic z(8)9.

       01 result           usage binary-long.
       01 SIGINT           constant as 2.

      *> here be dragons, examine <signal.h> for struct sigaction
       01 new-sigaction.
          05 sa-handler    usage program-pointer.
          05 sa-sigaction  usage program-pointer.
          05 sa-mask       pic x(128).
          05 sa-flags      usage binary-c-long.
          05 sa-restorer   usage program-pointer.
       01 old-sigaction.
          05 sa-handler    usage program-pointer.
          05 sa-sigaction  usage program-pointer.
          05 sa-mask       pic x(128).
          05 sa-flags      usage binary-c-long.
          05 sa-restorer   usage program-pointer.

      *> **************************************************************
       procedure division.
       call "gettimeofday" using start-time null

       display "Install SIGINT handler" at 0101
          with erase screen background-colour 7 foreground-colour 0
       set sa-handler in new-sigaction to entry "handle-sigint"
       call "sigaction" using
           by value SIGINT
           by reference new-sigaction
           by reference old-sigaction
           returning result
           on exception
               display "error calling sigaction" upon syserr
       end-call
       if result < zero then
           display "sigaction error" upon syserr
       end-if

      *> spin wait, with counter
       perform until exit
           if signalled then exit perform end-if
           call "CBL_OC_NANOSLEEP" using 500000000
           if signalled then exit perform end-if

           add 1 to half-seconds
           move half-seconds to display-halves
           display "Spin until Ctrl-C:" at 0201
              with background-colour 7 foreground-colour 0
           display display-halves at 0219
              with background-colour 7 foreground-colour 0
       end-perform

       call "gettimeofday" using end-time null
       subtract start-time from end-time
       move end-time to show-time
       display "Program ran for " at 0601
              with background-colour 7 foreground-colour 0
       display show-time at 0617
              with background-colour 7 foreground-colour 0
       display " seconds" at 0626
              with background-colour 7 foreground-colour 0

       display "Restored previous SIGINT behaviour" at 0701
          with background-colour 7 foreground-colour 0
       call "sigaction" using
           by value SIGINT
           by reference old-sigaction
           by reference null
           returning result
           on exception
               display "error calling sigaction" upon syserr
       end-call

       display "Enter to exit: " at 0801
          with background-colour 7 foreground-colour 0
       accept omitted
       goback.
       end program sigactions.

      *> **************************************************************
       identification division.
       program-id. handle-sigint.
       data division.
       working-storage section.
       01 signal-flag      pic 9 external.
       01 show-signal      pic 99.

       linkage section.
       01 the-signal       usage binary-long.

       procedure division using by value the-signal returning omitted.
       move the-signal to show-signal
       display "Caught SIGINT" at 0401
          with background-colour 3 foreground-colour 0
       display show-signal at 0415
          with background-colour 6 foreground-colour 0
       move 1 to signal-flag
       goback.
       end program handle-sigint.

prompt$ cobc -x -d sigactions.cob
Install SIGINT handler
Spin until Ctrl-C:       15

Caught SIGINT 02

Program ran for         7 seconds
Restored previous SIGINT behaviour
Enter to exit:
prompt$

prompt$ ./sigactions

Install SIGINT handler
Spin until Ctrl-C:        6

Caught SIGINT 02

Program ran for         4 seconds
Restored previous SIGINT behaviour
Enter to exit:

sigactions.cob: 89: Caught Signal (Signal SIGINT)
Abnormal termination - File contents may be incorrect
prompt$

X11    identification division.
       program-id. x11-sup.
       installation. cobc -x x11-sup.cob -lX11
       remarks. Use of private data is likely not cross platform.

       data division.
       working-storage section.
       01 msg.
          05 filler            value z"S'up, Earth?".
       01 msg-len              usage binary-long value 12.

       01 x-display            usage pointer.
       01 x-window             usage binary-c-long.

      *> GnuCOBOL does not evaluate C macros, need to peek at opaque
      *> data from Xlib.h
      *> some padding is added, due to this comment in the Xlib header
      *> "there is more to this structure, but it is private to Xlib"
       01 x-display-private    based.
          05 x-ext-data        usage pointer sync.
          05 private1          usage pointer.
          05 x-fd              usage binary-long.
          05 private2          usage binary-long.
          05 proto-major-version   usage binary-long.
          05 proto-minor-version   usage binary-long.
          05 vendor            usage pointer sync.
          05 private3          usage pointer.
          05 private4          usage pointer.
          05 private5          usage pointer.
          05 private6          usage binary-long.
          05 allocator         usage program-pointer sync.
          05 byte-order        usage binary-long.
          05 bitmap-unit       usage binary-long.
          05 bitmap-pad        usage binary-long.
          05 bitmap-bit-order  usage binary-long.
          05 nformats          usage binary-long.
          05 screen-format     usage pointer sync.
          05 private8          usage binary-long.
          05 x-release         usage binary-long.
          05 private9          usage pointer sync.
          05 private10         usage pointer sync.
          05 qlen              usage binary-long.
          05 last-request-read usage binary-c-long unsigned sync.
          05 request           usage binary-c-long unsigned sync.
          05 private11         usage pointer sync.
          05 private12         usage pointer.
          05 private13         usage pointer.
          05 private14         usage pointer.
          05 max-request-size  usage binary-long unsigned.
          05 x-db              usage pointer sync.
          05 private15         usage program-pointer sync.
          05 display-name      usage pointer.
          05 default-screen    usage binary-long.
          05 nscreens          usage binary-long.
          05 screens           usage pointer sync.
          05 motion-buffer     usage binary-c-long unsigned.
          05 private16         usage binary-c-long unsigned.
          05 min-keycode       usage binary-long.
          05 max-keycode       usage binary-long.
          05 private17         usage pointer sync.
          05 private18         usage pointer.
          05 private19         usage binary-long.
          05 x-defaults        usage pointer sync.
          05 filler            pic x(256).

       01 x-screen-private     based.
          05 scr-ext-data      usage pointer sync.
          05 display-back      usage pointer.
          05 root              usage binary-c-long.
          05 x-width           usage binary-long.
          05 x-height          usage binary-long.
          05 m-width           usage binary-long.
          05 m-height          usage binary-long.
          05 x-ndepths         usage binary-long.
          05 depths            usage pointer sync.
          05 root-depth        usage binary-long.
          05 root-visual       usage pointer sync.
          05 default-gc        usage pointer.
          05 cmap              usage pointer.
          05 white-pixel       usage binary-c-long unsigned sync.
          05 black-pixel       usage binary-c-long unsigned.
          05 max-maps          usage binary-long.
          05 min-maps          usage binary-long.
          05 backing-store     usage binary-long.
          05 save_unders       usage binary-char.
          05 root-input-mask   usage binary-c-long sync.
          05 filler            pic x(256).

       01 event.
          05 e-type usage      binary-long.
          05 filler            pic x(188).
          05 filler            pic x(256).
       01 Expose               constant as 12.
       01 KeyPress             constant as 2.

      *> ExposureMask or'ed with KeyPressMask, from X.h
       01 event-mask           usage binary-c-long value 32769.

      *> make the box around the message wide enough for the font
       01 x-char-struct.
          05 lbearing          usage binary-short.
          05 rbearing          usage binary-short.
          05 string-width      usage binary-short.
          05 ascent            usage binary-short.
          05 descent           usage binary-short.
          05 attributes        usage binary-short unsigned.
       01 font-direction       usage binary-long.
       01 font-ascent          usage binary-long.
       01 font-descent         usage binary-long.

       01 XGContext            usage binary-c-long.
       01 box-width            usage binary-long.
       01 box-height           usage binary-long.

      *> ***************************************************************
       procedure division.

       call "XOpenDisplay" using by reference null returning x-display
           on exception
               display function module-id " Error: "
                       "no XOpenDisplay linkage, requires libX11"
                  upon syserr
               stop run returning 1
       end-call
       if x-display equal null then
           display function module-id " Error: "
                   "XOpenDisplay returned null" upon syserr
           stop run returning 1
       end-if
       set address of x-display-private to x-display

       if screens equal null then
           display function module-id " Error: "
                   "XOpenDisplay associated screen null" upon syserr
           stop run returning 1
       end-if
       set address of x-screen-private to screens

       call "XCreateSimpleWindow" using
           by value x-display root 10 10 200 50 1
                    black-pixel white-pixel
           returning x-window
       call "XStoreName" using
           by value x-display x-window by reference msg

       call "XSelectInput" using by value x-display x-window event-mask

       call "XMapWindow" using by value x-display x-window

       call "XGContextFromGC" using by value default-gc
           returning XGContext
       call "XQueryTextExtents" using by value x-display XGContext
           by reference msg by value msg-len
           by reference font-direction font-ascent font-descent
           x-char-struct
       compute box-width = string-width + 8
       compute box-height = font-ascent + font-descent + 8

       perform forever
          call "XNextEvent" using by value x-display by reference event
          if e-type equal Expose then
              call "XDrawRectangle" using
                  by value x-display x-window default-gc 5 5
                           box-width box-height
              call "XDrawString" using
                  by value x-display x-window default-gc 10 20
                  by reference msg by value msg-len
          end-if
          if e-type equal KeyPress then exit perform end-if
       end-perform

       call "XCloseDisplay" using by value x-display

       goback.
       end program x11-sup.

apt-get install pari-gp pari-gp2c libpari-dev`

prompt$ gp -q
? 123456! + 0.
2.6040699049291378729513930560926568818 E574964
? quit
prompt$

prompt$ cat fact.gp
123456! + 0.
prompt$ gp2c fact.gp

/*-*- compile-command: "cc -c -o fact.gp.o -g -O3 -Wall -fomit-frame-pointer
-fno-strict-aliasing -fPIC -I"/usr/include/x86_64-linux-gnu" fact.gp.c && cc
-o fact.gp.so -shared -g -O3 -Wall -fomit-frame-pointer -fno-strict-aliasing
-fPIC -Wl,-shared -Wl,-z,relro fact.gp.o -lc -lm -L/usr/lib/x86_64-linux-gnu
-lpari"; -*-*/
#include <pari/pari.h>
/*
GP;install("init_fact","vp","init_fact","./fact.gp.so");
*/
void init_fact(long prec);
/*End of prototype*/

void
init_fact(long prec)      /* void */
{
  mpadd(mpfact(123456), real_0(prec));
  return;
}

identification division.
program-id. sample.

environment division.
configuration section.
repository.
    function all intrinsic.

data division.
working-storage section.
01 pari-factorial usage pointer.
01 pari-zero usage pointer.
01 pari-result usage pointer.

procedure division.
sample-main.

call "pari_init" using by value 8000000 2 returning omitted

call "mpfact" using by value 123456 returning pari-factorial
call "real_0" using by value 31 returning pari-zero
call "mpadd" using by value pari-factorial pari-zero
   returning pari-result

call "pari_printf" using by content "%Ps" & x"0a00"
   by value pari-factorial

call "pari_printf" using by content "%Ps" & x"0a00"
   by value pari-result

call "pari_close" returning omitted
goback.
end program sample.

prompt$ cobc -xj callgp.cob -lpari
...
2.6040699049291378729513930560926568818 E574964
prompt$

prompt$ cobc -xj callgp.cob -lpari | head -c 255
2604069904929137872951393056092656881827
3270409503019584610185579952057379676834
1579356071661712790873552001706166600085
7261271456698589373086528293431724412115
2865814030204645985573419251305342231135
5734910507562777350465693373539659735869
465710825190620
...
prompt$ cobc -xj callgp.cob -lpari | wc
      2       3  575014

prompt$ time cobc -xj callgp.cob -lpari | tail -1
2.6040699049291378729513930560926568818 E574964

real    0m0.270s
user    0m0.228s
sys     0m0.024s

prompt$ gp -q

? plot(X=0,4*Pi,sin(X))

0.9996892 |'''''_""x''''''''''''''''''''''''''''x""_'''''''''''''''''''''|
          |    _    "                          x    x                    |
          |          "                        x      _                   |
          |   "       x                                                  |
          |  _                               "        x                  |
          |            x                    _                            |
          | _                                          "                 |
          |             "                  _                             |
          |_                                            "                |
          |              x                _                              |
          _                               :              x               _
          ````````````````x``````````````:```````````````````````````````:
          |                              "                x             :|
          |                _                                            "|
          |                             "                  _             |
          |                 _                                          " |
          |                            "                    x            |
          |                  x        _                               "  |
          |                                                  x       _   |
          |                   "      x                        _          |
          |                    x    x                          _    "    |
-0.999689 |....................."__x............................x__".....|
          0                                                       12.56637

? sin(x)
%3 = x - 1/6*x^3 + 1/120*x^5 - 1/5040*x^7 + 1/362880*x^9
       - 1/39916800*x^11 + 1/6227020800*x^13
       - 1/1307674368000*x^15 + O(x^17)

*> Tectonics: cobc -xj callgretl.cob -lgretl-1.0
 identification division.
 program-id. sample.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 01 fname.
    05 value z"sample.gdt".
 01 dset usage pointer.
 01 prn  usage pointer.
 01 err  usage binary-long.

 procedure division.
 sample-main.
 call "libgretl_init" returning omitted
 call "gretl_print_new" using by value 1 by reference NULL
     returning prn
 call "datainfo_new" returning dset

 call "gretl_read_native_data" using fname by value dset
     returning err
 if err equal zero then
     call "pprintf" using by value prn
        by content "Data from %s is OK" & x"0a00"
        by reference fname
     call "print_smpl" using by value dset 0 prn
     call "varlist" using by value dset prn
 else
     call "pprintf" using by value prn
        by content "Error %d reading %s" & x"0a00"
        by value err
        by reference fname
 end-if

 call "destroy_dataset" using by value dset returning omitted
 call "gretl_print_destroy" using by value prn returning omitted
 call "libgretl_cleanup" returning omitted

 goback.
 end program sample.

*> #include <gretl/libgretl.h>
*>
*> int main (int argc, char **argv)
*> {
*>     char *fname;
*>     DATASET *dset;
*>     PRN *prn;
*>     int err;
*>
*>     if (argc >= 2) {
*>         fname = argv[1];
*>     } else {
*>         exit(EXIT_FAILURE);
*>     }
*>
*>     libgretl_init();
*>     prn = gretl_print_new(GRETL_PRINT_STDOUT, NULL);
*>     dset = datainfo_new();
*>
*>     err = gretl_read_native_data(fname, dset);
*>     if (err) {
*>         pprintf(prn, "Got error %d reading data from %s\n", err, fname);
*>         errmsg(err, prn);
*>     } else {
*>         pprintf(prn, "Read data from %s OK\n", fname);
*>         print_smpl(dset, 0, prn);
*>         varlist(dset, prn);
*>     }
*>
*>     destroy_dataset(dset);
*>     gretl_print_destroy(prn);
*>     libgretl_cleanup();
*>
*>     return 0;
*> }

prompt$ cobc -xj callgretl.cob -lgretl-1.0
Data from sample.gdt is OK
Full data range: 1964:1 - 1991:2 (n = 110)

Listing 5 variables:
  0) const     1) period    2) r         3) M         4) D

prompt$

<?xml version="1.0"?>
<!DOCTYPE gretldata SYSTEM "gretldata.dtd">

<gretldata name="data10-1" frequency="4" startobs="1964.1" endobs="1991.2"
type="time-series">
<description>
DATA10-1:  Quarterly data for the U.S.
    r = INTEREST RATE: U.S.TREASURY BILLS,AUCTION AVG,3-MO(%)
        RANGE 3.514 - 15.904.
    M = MONEY SUPPLY M2 (BILLIONS OF 1987 DOLLARS),
        RANGE 1461.733 - 2915.233.
    D = FEDERAL CYCLICALLY ADJ BUDGET: DEFICIT (+) or SURPLUS (-)
        (BILLIONS OF DOLLARS), RANGE 0.6 - 213.
    Source: Citibase, INTRATE AND MONEY SUPPLY ARE AVERAGED FROM
    Monthly data.
</description>
<variables count="4">
<variable name="period"/>
<variable name="r"
 label="interest rate: u.s.treasury bills,auction avg, 3-mo(%)"/>
<variable name="M"
 label="money supply m2 (billions of 1987 dollars)"/>
<variable name="D"
 label="federal cyclically adj budget: deficit (+) or surplus (-) ($
billions)"/>
</variables>
<observations count="110" labels="false">
<obs>1964.1 3.619 1461.733 6.3 </obs>
<obs>1964.2 3.561 1484.567 10.0 </obs>
<obs>1964.3 3.584 1514.300 6.1 </obs>
<obs>1964.4 3.771 1542.267 4.0 </obs>
<obs>1965.1 3.993 1568.867 0.6 </obs>
<obs>1965.2 3.972 1581.200 2.4 </obs>
<obs>1965.3 3.952 1605.967 10.7 </obs>
<obs>1965.4 4.262 1632.567 13.9 </obs>

<!-- snipped out 1966 through 1989 -->

<obs>1990.1 8.023 2891.533 190.5 </obs>
<obs>1990.2 8.033 2889.633 182.0 </obs>
<obs>1990.3 7.743 2872.467 157.6 </obs>
<obs>1990.4 7.247 2840.867 179.1 </obs>
<obs>1991.1 6.237 2838.767 97.8 </obs>
<obs>1991.2 5.763 2853.800 145.6 </obs>
</observations>
</gretldata>

*> Tectonics: cobc -xjgd callgretl.cob -lgretl-1.0 build-model.c
*>                 -A "$(pkg-config --cflags glib-2.0)"
 identification division.
 program-id. sample.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 01 fname.
    05 value z"sample.gdt".
 01 dset usage pointer.
 01 prn  usage pointer.
 01 err  usage binary-long.

 01 list.
    05 list-data usage binary-long occurs 6 times.

 01 model usage pointer.
 01 OLS usage binary-long value 88.
 01 OPT-NONE usage binary-long value 0.
 01 LISTSEP usage binary-long value -100.

 procedure division.
 sample-main.
 call "libgretl_init" returning omitted

 call "gretl_print_new" using by value 1 by reference NULL
     returning prn

 call "datainfo_new" returning dset
 if dset equal null then
     move 10 to err
 else
     call "gretl_read_native_data" using fname by value dset
         returning err
 end-if
 if err equal zero then
     call "pprintf" using by value prn
        by content "Data from %s is OK" & x"0a00"
        by reference fname
     call "print_smpl" using by value dset 0 prn
     call "varlist" using by value dset prn
 else
     call "pprintf" using by value prn
        by content "Error %d reading %s" & x"0a00"
        by value err
        by reference fname
 end-if

*> build the regression model field list
 move 5 to list-data(1)
 move 1 to list-data(2)
 move 0 to list-data(3)
 move 1 to list-data(4)
 move LISTSEP to list-data(5)
 move 1 to list-data(6)

*> the arma model is a struct return, so needs a wrapper
 call "build_model" using list NULL by value dset OPT-NONE prn
     returning model

*> not quite right yet, gretl sets model->errcode as well
 if model equal null then
     call "pprintf" using by value prn
        by content "Error building arma model" & x"0a00"
        by value err
        by reference fname
 else
     call "printmodel" using by value model dset OPT-NONE prn
 end-if

 call "gretl_model_free" using by value model
 call "destroy_dataset" using by value dset returning omitted
 call "gretl_print_destroy" using by value prn returning omitted
 call "libgretl_cleanup" returning omitted

 goback.
 end program sample.

#include <stdio.h>
#include <gretl/libgretl.h>

MODEL *build_model(int *list, int *pqlags, DATASET *dset, int opts, PRN *prn)
{

    MODEL *model;
    model = gretl_model_new();
    *model = arma(list, pqlags, dset, opts, prn);
    return model;
}

prompt$ cobc -xjgd callgretl.cob -lgretl-1.0 build-model.c \
             -A "$(pkg-config --cflags glib-2.0)"

Data from sample.gdt is OK
Full data range: 1975:1 - 1990:4 (n = 64)

Listing 12 variables:
  0) const     1) QNC       2) PRICE     3) INCOME    4) PRIME
  5) UNEMP     6) STOCK     7) POP       8) WINTER    9) SPRING
 10) SUMMER   11) FALL


Function evaluations: 39
Evaluations of gradient: 13

Model 1: ARMA, using observations 1975:1-1990:4 (T = 64)
Estimated using Kalman filter (exact ML)
Dependent variable: QNC
Standard errors based on Hessian

             coefficient   std. error      z      p-value
  --------------------------------------------------------
  const      2438.33       124.004       19.66    4.45e-86 ***
  phi_1         0.867301     0.0857710   10.11    4.90e-24 ***
  theta_1      -0.473176     0.140395    -3.370   0.0008   ***

Mean dependent var   2488.594   S.D. dependent var   332.9220
Mean of innovations  10.96802   S.D. of innovations  262.8761
Log-likelihood      -447.6958   Akaike criterion     903.3916
Schwarz criterion    912.0271   Hannan-Quinn         906.7936

                        Real  Imaginary    Modulus  Frequency
  -----------------------------------------------------------
  AR
    Root  1           1.1530     0.0000     1.1530     0.0000
  MA
    Root  1           2.1134     0.0000     2.1134     0.0000
  -----------------------------------------------------------

sudo apt-get install gretl libgretl1-dev

* CBL_OC_SOCKET server sample
 IDENTIFICATION DIVISION.
 PROGRAM-ID. server.

 ENVIRONMENT DIVISION.
 CONFIGURATION SECTION.
 INPUT-OUTPUT SECTION.
 DATA DIVISION.
 FILE SECTION.
 WORKING-STORAGE SECTION.

 01 PORT   PIC X(4) VALUE "1234".
 01 HNDL   PIC X(4).
 01 LISTEN   PIC X(4).
 01 BUFF   PIC X(64000).
 01 BYTES  PIC 9(5).
 01 RECV   PIC 9(5).
 01 RESULT PIC 9(3).
 01 OUT    PIC X(25).
 01 dummy pic x.


 PROCEDURE DIVISION.

 MAIN-PARAGRAPH.

        DISPLAY "Opening socket for incoming connections ...".
        CALL "CBL_OC_SOCKET"
             USING "00" PORT LISTEN GIVING RESULT
        END-CALL.
        perform handle-error.

*        CALL "CBL_OC_SOCKET"
*             USING "98" GIVING RESULT.

 ACCEPT-CONN.

        DISPLAY "Listening for incomming connections ...".
        CALL "CBL_OC_SOCKET"
             USING "07" LISTEN HNDL GIVING RESULT
        END-CALL.
        perform handle-error.

        DISPLAY "Getting data from client ...".
        MOVE 14 TO RECV.
        MOVE SPACES TO BUFF.
        CALL "CBL_OC_SOCKET"
               USING "04" HNDL RECV BUFF GIVING RESULT
        END-CALL.
        perform handle-error.

        MOVE SPACES TO OUT.
        MOVE BUFF TO OUT.
        DISPLAY "Client says: " OUT.

        DISPLAY "Sending data and waiting for response ...".
        MOVE "Hello client !" TO BUFF.
        MOVE 14 TO BYTES.
        MOVE 17 TO RECV.

        CALL "CBL_OC_SOCKET"
               USING "05" HNDL BYTES RECV BUFF GIVING RESULT
        END-CALL.
        perform handle-error.

        MOVE SPACES TO OUT.
        MOVE BUFF TO OUT.
        DISPLAY "Client responds: " OUT.

        DISPLAY "Sending data ...".
        MOVE 13 TO BYTES.
        MOVE "Hasta la vista" TO BUFF.

        CALL "CBL_OC_SOCKET"
             USING "03" HNDL BYTES BUFF GIVING RESULT
        END-CALL.
        perform handle-error.

        DISPLAY "Closing connection ...".
        CALL "CBL_OC_SOCKET"
               USING "06" HNDL GIVING RESULT
        END-CALL.
        perform handle-error.

        go to accept-conn.

        accept dummy.

        STOP RUN.

 HANDLE-ERROR SECTION.
        DISPLAY "Result is: " RESULT.
        IF RESULT NOT = 0
        THEN
             CALL "CBL_OC_SOCKET" USING "99" GIVING RESULT
             DISPLAY "OS-ERROR: " RESULT
             accept dummy
             STOP RUN
        END-IF
        .

* CBL_OC_SOCKET client sample
 IDENTIFICATION DIVISION.
 PROGRAM-ID. client.

 ENVIRONMENT DIVISION.
 CONFIGURATION SECTION.
 INPUT-OUTPUT SECTION.
 DATA DIVISION.
 FILE SECTION.
 WORKING-STORAGE SECTION.

 01 IP     PIC X(15) VALUE "127.0.0.1".
 01 PORT   PIC X(4) VALUE "1234".
 01 HNDL   PIC X(4).
 01 BUFF   PIC X(64000).
 01 BYTES  PIC 9(5).
 01 RECV   PIC 9(5).
 01 RESULT PIC 9(3).
 01 OUT    PIC X(25).
 01 dummy pic x.

 PROCEDURE DIVISION.


 start-proc.
* Connect...
        DISPLAY "Connect to server ...".
        CALL "CBL_OC_SOCKET"
             USING "02" IP PORT HNDL GIVING RESULT
        END-CALL.
        perform handle-error.

* send data
        DISPLAY "Sending some data ...".
        MOVE "Hello server !" TO BUFF.
        MOVE 14 TO BYTES.
        CALL "CBL_OC_SOCKET"
             USING "03" HNDL BYTES BUFF GIVING RESULT
        END-CALL.
        perform handle-error.

* receive data
        DISPLAY "Reading some data ...".
        MOVE SPACES TO BUFF.
        MOVE 14 TO RECV.
        CALL "CBL_OC_SOCKET"
             USING "04" HNDL RECV BUFF GIVING RESULT
        END-CALL.
        perform handle-error.

        MOVE SPACES TO OUT.
        MOVE BUFF TO OUT.
        DISPLAY "Server says: " OUT.

* send response
        DISPLAY "Sending data ...".
        MOVE 17 TO BYTES.
        MOVE "Good bye server !" TO BUFF.

        CALL "CBL_OC_SOCKET"
             USING "03" HNDL BYTES BUFF GIVING RESULT
        END-CALL.
        perform handle-error.

        DISPLAY "Reading some data ...".
        MOVE SPACES TO BUFF.
        MOVE 13 TO RECV.
        CALL "CBL_OC_SOCKET"
             USING "04" HNDL RECV BUFF GIVING RESULT
        END-CALL.
        perform handle-error.

        MOVE SPACES TO OUT.
        MOVE BUFF TO OUT.
        DISPLAY "Server says: " OUT.

        DISPLAY "Closing socket ...".
        CALL "CBL_OC_SOCKET"
             USING "06" HNDL GIVING RESULT
        END-CALL.
        perform handle-error.

*       accept port.

        call 'C$SLEEP' using '1'.

        go to start-proc.

        STOP RUN.

 HANDLE-ERROR SECTION.
        DISPLAY "Result is: " RESULT.
        IF RESULT NOT = 0
        THEN
             CALL "CBL_OC_SOCKET" USING "99" GIVING RESULT
             DISPLAY "OS-ERROR: " RESULT
             accept dummy
             STOP RUN
        END-IF.

// Neko from GnuCOBOL test
// tectonics: nekoc faqtest.neko
//            neko faqtest

$print("The virtual machine is working !\n");
test = $loader.loadprim("std@test",0);
test();
$print("Test successful\n");

// load and call some date primitives
now = $loader.loadprim("std@date_now", 0)();
date = $loader.loadprim("std@date_format", 2)(now, null);
$print(date, "\n");

// Exception handler, clean
try {
    shell = $loader.loadprim("std@sys_command", 1);
    rc = shell("ls faqtest.*");
    $print("Shell returned: ", rc, "\n");
} catch e {
    $print("Raised: ", e, "\n");
}

// Exception handler, purposeful error
try {
    erroneous = $loader.loadprim("std@not_in_std_library", 0);
    rc = erroneous();
    $print("erroneous: ", rc, "\n");
} catch e {
    $print("Raised: ", e, ": ", $typeof(e),
           "\n        from ", $excstack(), " from ", $callstack(), "\n");
}

// Export a value and a function for use from GnuCOBOL
$exports.x = 7;
$exports.f = function(x) {return x * (x - 1);}

// display after exception handler, so we know it keeps running
$print("f(", $exports.x, ") = ", $exports.f($exports.x), "\n");

prompt$ nekoc nekotest.neko
prompt$ neko nekotest
The virtual machine is working !
Calling a function inside std library...
Test successful
2016-07-04 11:26:31
nekotest.n  nekotest.neko
Shell returned: 0
Raised: load.c(357) : Primitive not found : std@not_in_std_library(0): 5
        from [[faqtest.neko,26]] from [[faqtest.neko,31]]
f(7) = 42

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/cobweb-neko
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20160708  Modified: 2016-07-09/17:49-0400
      *> LICENSE
      *>   Copyright 2016 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or superior)
      *> VERSION
      *>   0.3
      *> PURPOSE
      *>   Embed NekoVM for running compiled HaXe programs.
      *>   (only handles int, string, and function in version 0.3)
      *> TECTONICS
      *>   haxe -neko haxetest.n -main Demonstration
      *>   cobc -debug cobweb-neko.cob -lneko
      *>   cobcrun cobweb-neko [bytecodefile]
      *> ***************************************************************

       identification division.
       program-id. cobweb-neko.
       author. Brian Tiffin.
       date-written. 2016-07-08/04:22-0400.
       date-modified. 2016-07-09/17:49-0400.
       date-compiled.
       installation.
       remarks. cobweb-neko function repository, and test head
       security. embeds NekoVM, and allows bytecode file named from cli

       REPLACE ==:NEKO-RECORD:== BY ==
       01 neko-record.
          05 neko-value        usage pointer.
          05 actual-value      redefines neko-value usage binary-double.
       ==

       ==:NEKO-TAGS:== BY ==
       01 TAG-INT              constant as h"FF".
       01 TAG-NULL             constant as 0.
       01 TAG-FLOAT            constant as 1.
       01 TAG-BOOL             constant as 2.
       01 TAG-STRING           constant as 3.
       01 TAG-OBJECT           constant as 4.
       01 TAG-ARRAY            constant as 5.
       01 TAG-FUNCTION         constant as 6.
       01 TAG-ABSTRACT         constant as 7.
       01 TAG-INT32            constant as 8.
       01 TAG-PRIMITIVE        constant as 22.
       01 TAG-JITFUN           constant as 38.
       01 TAG-32-BITS          constant as h"FFFFFFFF".
       ==

       ==:EXCEPTION-HANDLERS:== BY ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       function-exception.
           perform soft-exception
           move 127 to return-code
           goback
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       environment division.
       configuration section.
       source-computer. gnulinux.
       object-computer. gnulinux
           classification is canadian.

       special-names.
           locale canadian is "en_CA.UTF-8".

       repository.
           function neko-load
           function neko-unload
           function neko-type
           function neko-lookup
           function neko-decode
           function neko-call
           function neko-string
           function neko-unstring
           function haxe-unstring
           function all intrinsic.

       input-output section.
       file-control.
       i-o-control.

       data division.
       file section.

       working-storage section.
       01 neko-initialized     pic x value low-value external.

       01 cli                  pic x(32) value "haxetest.n".

       01 url.
          05 filler            value "http://example.com".

       01 module-record.
          05 module            usage pointer.
       01 neko-exception       usage pointer.
       01 neko-object          usage pointer.
       01 neko-class           usage pointer.

       :NEKO-RECORD:

       01 v-x                  usage pointer.
       01 v-f                  usage pointer.
       01 v-answer             usage pointer.
       01 x                    usage binary-double.
       01 answer               usage binary-double.

       01 v-url                usage pointer.
       01 v-read               usage pointer.
       01 v-page               usage pointer.

       01 v-len                usage pointer.
       01 coblen               usage binary-long value 1.
       01 MAXLEN               constant as 8388608.
       01 cobbuf.
          05 pic x occurs 0 to MAXLEN times depending on coblen.

       :NEKO-TAGS:

      *> ***************************************************************
       procedure division.
       haxe-neko-main.

      *> start NekoVM given bytecode file on command line or default
       accept cli from command-line
       if cli equal spaces then
           initialize cli all to value
       end-if

       move neko-load(cli) to module-record

      *> Module loaded, now for the application part
       perform neko-application

      *> cleanup NekoVM
       move neko-unload to neko-record
       goback.
      *> *************************************************************

      *>
      *> application code example
      *>
       neko-application.

      *> assume Haxe provides value x, function f and reads string url
      *> from inside class Demonstration

       move neko-lookup(module, "__classes") to neko-record
       set neko-object to neko-value

       move neko-lookup(neko-object, "Demonstration") to neko-record
       set neko-class to neko-value

      *> assume no such class for straight nekotest test
       if neko-class equal null then
           set neko-class to module
       end-if

      *> Look for f(x) example
       move neko-lookup(neko-class, "x") to neko-record
       set v-x to neko-value
       move neko-decode(neko-record) to x

       move neko-lookup(neko-class, "f") to neko-record
       set v-f to neko-value

       if neko-type(v-f) equal TAG-FUNCTION then
           move neko-call(v-f, v-x) to neko-record
           set v-answer to neko-value
           move neko-decode(neko-record) to answer

           display "f(" x ") = " answer
       end-if

      *> see if there is a requestUrl example
       move neko-string(trim(url)) to neko-record
       set v-url to neko-value

       move neko-lookup(neko-class, "requestUrl") to neko-record
       set v-read to neko-value

       if neko-type(v-read) equal TAG-FUNCTION then
           *> call the Haxe function
           display "Read: " trim(url)
           move neko-call(v-read, v-url) to neko-record
           set v-page to neko-value

           *> dereference the haxe String class data
           move MAXLEN to coblen
           move haxe-unstring(v-page, cobbuf, coblen) to neko-record
           display "Haxe returned: " coblen " bytes"
           display cobbuf
       end-if

      *> end sample neko-application
       .

       :EXCEPTION-HANDLERS:

       end program cobweb-neko.
      *> ***************************************************************
      *>****

      *>****F* cobweb-neko/neko-lookup
      *> PURPOSE
      *>   lookup a neko field inside given object, by name
       identification division.
       function-id. neko-lookup.

       environment division.
       configuration section.
       repository.
           function neko-type
           function all intrinsic.

       data division.
       working-storage section.
       01 field-id             usage pointer.
       01 field-value          usage pointer.
       :NEKO-TAGS:

       linkage section.
       01 neko-object          usage pointer.
       01 neko-key             pic x any length.
       :NEKO-RECORD:

       procedure division using neko-object neko-key
           returning neko-record.

       neko-field-lookup.
       set neko-value to null

       if (neko-object equal null) or
          (neko-type(neko-object) equal TAG-NULL) then
           goback
       end-if

       call "neko_val_id" using
           by content concatenate(trim(neko-key), x"00")
           returning field-id
       if field-id equal null then
           display "error: neko_val_id " neko-key upon syserr
           perform soft-exception
           goback
       end-if

       call "neko_val_field" using by value neko-object field-id
           returning field-value
       if field-value equal null then
           display "error: neko_val_field " neko-key upon syserr
           perform soft-exception
           goback
       end-if

       set neko-value to field-value
       goback
       .

       :EXCEPTION-HANDLERS:

       end function neko-lookup.
      *>****

      *>****F* cobweb-neko/neko-string
      *> PURPOSE
      *>   allocate a neko string value
      *>   if wanted-size not given, copy existing source
      *>   if wanted-size given and source is low-values, allocate empty
      *>   if wanted-size given copy existing to new for wanted-size
       identification division.
       function-id. neko-string.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 field-value          usage pointer.
       01 given-size           usage binary-long.

       linkage section.
       01 source-data          pic x any length.
       01 wanted-size          pic 9 any length.
       :NEKO-RECORD:

       procedure division using source-data optional wanted-size
           returning neko-record.

       neko-allocate-string.
       set neko-value to null

       if wanted-size is omitted then
           call "neko_alloc_string" using
               by content concatenate(source-data, x"00")
               returning field-value

           if field-value equal null then
               display "error: neko_alloc_string " trim(source-data)
                  upon syserr
               perform soft-exception
               goback
           end-if
       else
           move wanted-size to given-size
           if given-size is less than zero then
               display "error: neko-string invalid size" wanted-size
                  upon syserr
               perform soft-exception
               goback
           end-if
           if source-data equal low-values then
               call "neko_alloc_empty_string" using
                   by value given-size
                   returning field-value

               if field-value equal null then
                   display "error: neko_alloc_empty_string " wanted-size
                      upon syserr
                   perform soft-exception
                   goback
               end-if
           else
               call "neko_copy_string" using
                   by content concatenate(source-data, x"00")
                   by value given-size
                   returning field-value

               if field-value equal null then
                   display "error: neko_copy_string "
                      trim(source-data) ", " wanted-size
                      upon syserr
                   perform soft-exception
                   goback
               end-if
           end-if
       end-if

       set neko-value to field-value
       goback
       .

       :EXCEPTION-HANDLERS:

       end function neko-string.
      *>****

      *>****F* cobweb-neko/neko-unstring
      *> PURPOSE
      *>   Pull the character data out of a neko vstring
      *>   Filling cobol buffer, settting length and
      *>   returning cdata address
       identification division.
       function-id. neko-unstring.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 field-value          usage pointer.
       01 length-value         usage pointer.

       01 string-value         based.
          05 v-type            usage binary-long.
          05 cdata             pic x.

       linkage section.
       01 neko-vstring         usage pointer.
       01 cobol-buffer         pic x any length.
       01 neko-length          usage binary-long.
       :NEKO-RECORD:

       procedure division using neko-vstring cobol-buffer neko-length
           returning neko-record.

       dereference-haxe-string.
       set neko-value to null

       if neko-vstring not equal null then
           set address of string-value to neko-vstring
           call "strlen" using cdata returning neko-length
           call "memcpy" using
               cobol-buffer cdata
               by value min(neko-length length(cobol-buffer))
           set neko-value to address of cdata
       end-if

       goback
       .

       :EXCEPTION-HANDLERS:

       end function neko-unstring.
      *>****

      *>****F* cobweb-neko/haxe-unstring
      *> PURPOSE
      *>   pull character data out of a haxe string
      *>   haXe String type is a class object, with members length, __s
       identification division.
       function-id. haxe-unstring.

       environment division.
       configuration section.
       repository.
           function neko-type
           function neko-lookup
           function neko-decode
           function all intrinsic.

       data division.
       working-storage section.
       01 field-value          usage pointer.
       01 length-value         usage pointer.

       01 string-value         based.
          05 v-type            usage binary-long.
          05 v-str             pic x.
       :NEKO-TAGS:

       linkage section.
       01 haxe-value           usage pointer.
       01 cobol-buffer         pic x any length.
       01 haxe-length          usage binary-long.
       :NEKO-RECORD:

       procedure division using haxe-value  cobol-buffer haxe-length
           returning neko-record.

       dereference-haxe-string.
       set neko-value to null

      *> Haxe String is a class, data in member __s
       if neko-type(haxe-value) equal TAG-OBJECT then

           move neko-lookup(haxe-value, "length") to neko-record
           if neko-type(neko-record) equal TAG-INT then
               set length-value to neko-value
               move neko-decode(neko-record) to haxe-length
           end-if

           move neko-lookup(haxe-value, "__s") to neko-record
           if neko-type(neko-record) equal TAG-STRING then
               set address of string-value to neko-value
               call "memcpy" using
                   cobol-buffer v-str
                   by value min(haxe-length length(cobol-buffer))
           end-if
           set neko-value to address of v-str
       end-if

       goback
       .

       :EXCEPTION-HANDLERS:

       end function haxe-unstring.
      *>****

      *>****F* cobweb-neko/neko-call
      *> PURPOSE
      *>   call a neko/haxe function
       identification division.
       function-id. neko-call.

       environment division.
       configuration section.
       repository.
           function neko-type
           function all intrinsic.

       data division.
       working-storage section.
       01 neko-result          usage pointer.
       :NEKO-TAGS:

       linkage section.
       01 neko-function        usage pointer.
       01 neko-arg1            usage pointer.
       01 neko-arg2            usage pointer.
       01 neko-arg3            usage pointer.
       :NEKO-RECORD:

       procedure division using neko-function optional neko-arg1
           returning neko-record.

       neko-function-call.
       set neko-value to null

       if neko-type(neko-function) not equal TAG-FUNCTION then
           display "error: not a function " neko-type(neko-function)
              upon syserr
           goback
       end-if

       evaluate number-of-call-parameters
           when 1
               call "neko_val_call0" using
                   by value neko-function
                   returning neko-result
           when 2
               call "neko_val_call1" using
                   by value neko-function neko-arg1
                   returning neko-result
           when 3
               call "neko_val_call2" using
                   by value neko-function neko-arg1 neko-arg2
                   returning neko-result
           when 4
               call "neko_val_call3" using
                   by value neko-function neko-arg1 neko-arg2 neko-arg3
                   returning neko-result
       end-evaluate

       set neko-value to neko-result
       goback
       .

       :EXCEPTION-HANDLERS:

       end function neko-call.
      *>****

      *>****F* cobweb-neko/neko-type
      *> PURPOSE
      *>   return type tag give a neko value
       identification division.
       function-id. neko-type.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 neko-one             usage binary-double value 1.
       01 neko-result          usage binary-double.
       01 low-byte             usage binary-long value 1.
       01 all-bytes            usage binary-long value 8.
       01 deref-value          usage binary-double based.
       01 neko-fourbits        usage binary-long value 15.

       :NEKO-TAGS:

       linkage section.
       :NEKO-RECORD:
       01 neko-vtype           usage binary-double.

       procedure division using neko-record returning neko-vtype.
       decode-neko-type.

       move neko-one to neko-result
       call "CBL_AND" using actual-value neko-result by value low-byte
       if neko-result equal 1 then
           move TAG-INT to neko-vtype
           goback
       end-if

       set address of deref-value to neko-value
       move neko-fourbits to neko-result
       call "CBL_AND" using deref-value neko-result by value all-bytes

       move neko-result to neko-vtype
       goback
       .

       end function neko-type.
      *>****

      *>****F* cobweb-neko/neko-decode
      *> PURPOSE
      *>   decode neko integer or leave alone
      *>   neko overlays 31-bit integers with the other value tags
      *>   low bit set is an integer
       identification division.
       function-id. neko-decode.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 neko-one             usage binary-double value 1.
       01 neko-result          usage binary-double.
       01 low-byte             usage binary-long value 1.

       linkage section.
       :NEKO-RECORD:
       01 neko-decoded.
          05 neko-integer      usage binary-double.

       procedure division using neko-record returning neko-decoded.
       decode-neko-value.

       move neko-one to neko-result
       call "CBL_AND" using actual-value neko-result by value low-byte
       if neko-result equal 1 then
           divide actual-value by 2 giving neko-integer
       end-if

       goback
       .

       end function neko-decode.
      *>****

      *>****F* cobweb-neko/neko-load
      *> PURPOSE
      *>   load neko bytecode file
      *>   initialize NekoVM on first call
       identification division.
       function-id. neko-load.

       environment division.
       configuration section.
       repository.
           function neko-lookup
           function neko-type
           function all intrinsic.

       data division.
       working-storage section.
       01 neko-initialized     pic x                 external.
       01 vm                   usage pointer.
       01 module               usage pointer.
       01 loader               usage pointer.
       01 args.
          05 arg               usage pointer occurs 2 times.
       01 neko-exception       usage pointer.

       01 lookup-record.
          05 function-value    usage pointer.

       :NEKO-TAGS:

       linkage section.
       01 bytecode-file        pic x any length.
       :NEKO-RECORD:

       procedure division using bytecode-file returning neko-record.
       neko-loader.

       set neko-value to null

      *> Initialize NekoVM
       if neko-initialized equal low-value then
           call "neko_global_init" using null returning omitted
               on exception
                   display "error initializing NekoVM (-lneko)"
                      upon syserr
                   perform hard-exception
           end-call

           call "neko_vm_alloc" using null returning vm
           if vm equal null then
               display "error: neko_vm_alloc" upon syserr
               goback
           end-if

           call "neko_vm_select" using by value vm returning omitted

           call "neko_default_loader" using
                null by value 0 returning loader
           if loader equal null then
               display "error: neko_default_loader" upon syserr
               perform hard-exception
           end-if

           move high-value to neko-initialized
       end-if

      *> Load bytecode module
       call "neko_alloc_string" using
           by content concatenate(trim(bytecode-file), x"00")
           returning arg(1)

       if arg(1) equal null then
           display "error: neko_alloc_string " trim(bytecode-file)
              upon syserr
           perform hard-exception
       end-if
       set arg(2) to loader

       move neko-lookup(loader, "loadmodule") to lookup-record
       if neko-type(loader) not equal TAG-OBJECT then
           display "error: no Neko loader" upon syserr
           perform hard-exception
       end-if

       call "neko_val_callEx" using
           by value loader function-value
           by reference args
           by value 2
           by reference neko-exception
           returning module
       end-call

       if module equal null then
           display "error: neko_val_callEx loadmodule" upon syserr
           perform hard-exception
       end-if

       if neko-exception not equal null then
           display "error: Neko exception " neko-exception upon syserr
           perform hard-exception
       end-if

       set neko-value to module
       goback.

       :EXCEPTION-HANDLERS:

       end function neko-load.
      *>****

      *>****F* cobweb-neko/neko-unload
      *> PURPOSE
      *>   neko rundown
       identification division.
       function-id. neko-unload.

       data division.
       linkage section.
       :NEKO-RECORD:

       procedure division returning neko-record.
       neko-unloader.
       set neko-value to null

       call "neko_global_free" returning omitted

       goback.
       .
       end function neko-unload.
      *>****

>>ELSE
!doc-marker!

===========
cobweb-neko
===========

.. contents::

Introduction
------------
Haxe/Neko integration with GnuCOBOL.

Haxe is best described as a cross-platform multi-target toolkit
programming language.  One of the Haxe targets, the default, is Neko.
Neko is both a source level programming language and a Virtual Machine,
NekoVM. (There is also a NekoML meta language source compiler).

The cobweb-neko system embeds the NekoVM allowing it to run bytecode
generated from any of Haxe, Neko, NekoML or any future language that
targets this handy little virtual machine.

Haxe programming offers much more, so the pairing of GnuCOBOL and Neko
will offer some interestiong potentials to anyone looking to web enable
applications with COBOL in the mix.

Tectonics
---------

::

    prompt$ nekoc nekotest.neko
      or
    prompt$ haxe -neko haxetest.n -main Demonstration
      or
    prompt$ cobc -dg cobweb-neko.cob -lneko
    prompt$ cobcrun cobweb-neko [bytecodefile - defaults to haxetest.n]

    prompt$ cobc -xdgj cobweb-neko.cob -lneko

Usage
-----

Prepare a bytecode file, with either ``nekoc`` or ``haxe -neko``.

Allow cobweb-neko to load the virtual machine, and add GnuCOBOL code to
take advantage of features available with Haxe and Neko.

A note on Strings.  NekoVM supports a ``string`` data-type.  Haxe wraps
this in an actual class.

Passing a Neko string to Haxe is best handled with

.. sourcecode:: haxe

    static function test(str:Dynamic) {
        var haxestr:String = neko.Lib.nekoToHaxe(str)
        ... use the haxestr String
    }

There is also a supporting neko.Lib.haxeToNeko converter.

Receiving a String from Haxe requires a lookup by GnuCOBOL to retrieve a
member element ``__s`` for use.  This data is a NekoVM ``value`` which
requires further treatment to get into COBOL working store.

Use ``haxe-unstring(value)`` or ``neko-unstring(value)`` as appropriate.
Assume any Haxe function will receive neko-string when embedded in
GnuCOBOL, so it will require translation with
``neko.Lib.nekoToHaxe(str)``.

::

    prompt$ ./cobweb-neko nekobytecode.n
    prompt$ cobcrun cobweb-neko nekobytecode.n



Source
------

.. include::  cobweb-neko.cob
   :code: cobolfree

.. include:: nekotest.neko
   :code: neko

.. include:: Demonstration.hx
   :code: haxe

>>END-IF

using StringTools;

class Demonstration {
    @author("Brian Tiffin")
    @date("July 2016")

    public static var page:String;
    public static var x:Int = 7;
    public static function f(x:Int):Int {return x * (x - 1);}

    public static function requestUrl(u:String):String {
        var url:String = neko.Lib.nekoToHaxe(u);
        page = haxe.Http.requestUrl(url);
        trace("page size: " + page.length);
        return page;
    }

    public static function main():Void {
        var people = [
            "Elizabeth" => "Programming",
            "Joel" => "Design"
        ];
        for (name in people.keys()) {
            var job = people[name];
            trace('$name does $job for a living!');
        }

        #if neko
        trace("neko is defined");
        #end

        #if python
        trace("python is defined");
        #end

        #if sys
        //trace(Sys.environment());
        #end

        trace("Codesize: " + neko.vm.Module.local().codeSize());
    }
}

# Making with some Haxe/Neko
.RECIPEPREFIX = >

cobweb-neko.so: cobweb-neko.cob haxetest.n
> cobc -d cobweb-neko.cob -lneko

cobweb-neko: cobweb-neko.cob haxetest.n
> cobc -xjd cobweb-neko.cob -lneko

haxetest.n: Demonstration.hx
> haxe -neko haxetest.n -main Demonstration

callneko: callneko.cob nekotest.n
> cobc -xd callneko.cob -lneko

nekotest.n: nekotest.neko
> nekoc nekotest.neko

# Translate to neko source
file.neko: Testing.hx
> haxe -neko file.neko -D neko-source -main Testing Testing.hx

file.n: file.neko
> nekoc file.neko

file: file.n
> nekotools boot file.n

# Compile to bytecode
testing.n: Testing.hx
> haxe -neko testing.n -main Testing

# Make some flash, requires flash-test.html
flash.swf: Flash.hx
> haxe -swf flash.swf -main Flash Flash.hx

moving-flash.swf: MovingFlash.hx
> haxe -swf moving-flash.swf -main MovingFlash -swf-version 15 \
       -swf-header 200:200:30:f68712

.PHONY: clean test help
clean:
> -rm cobweb-neko cobweb-neko.so cobweb-neko.c cobweb-neko.c.* cobweb-neko.i
> -rm nekotest.n haxetest.n

test: cobweb-neko.so haxetest.n nekotest.n
> cobcrun cobweb-neko
> cobcrun cobweb-neko nekotest.n

help:
> @echo "targets include:"
> @echo "    cobweb-neko.so"
> @echo "    cobweb-neko"
> @echo "    clean"
> @echo "    test"
> @echo "    and this help"

prompt$ make test
haxe -neko haxetest.n -main Demonstration
cobc -d cobweb-neko.cob -lneko
nekoc nekotest.neko
cobcrun cobweb-neko

Demonstration.hx:25: Elizabeth does Programming for a living!
Demonstration.hx:25: Joel does Design for a living!
Demonstration.hx:29: neko is defined
Demonstration.hx:40: Codesize: 29377
f(+00000000000000000007) = +00000000000000000042
Read: http://example.com
Demonstration.hx:14: page size: 1270
Haxe returned: +0000001270 bytes
<!doctype html>
<html>
<head>
    <title>Example Domain</title>

    <meta charset="utf-8" />
    <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
    <meta name="viewport" content="width=device-width, initial-scale=1" />
    <style type="text/css">
    body {
        background-color: #f0f0f2;
        margin: 0;
        padding: 0;
        font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif;

    }
    div {
        width: 600px;
        margin: 5em auto;
        padding: 50px;
        background-color: #fff;
        border-radius: 1em;
    }
    a:link, a:visited {
        color: #38488f;
        text-decoration: none;
    }
    @media (max-width: 700px) {
        body {
            background-color: #fff;
        }
        div {
            width: auto;
            margin: 0 auto;
            border-radius: 0;
            padding: 1em;
        }
    }
    </style>
</head>

<body>
<div>
    <h1>Example Domain</h1>
    <p>This domain is established to be used for illustrative examples in documents.
    You may use this domain in examples without prior coordination or asking for
    permission.</p>
    <p><a href="http://www.iana.org/domains/example">More information...</a></p>
</div>
</body>
</html>

cobcrun cobweb-neko nekotest.n

The virtual machine is working !
Calling a function inside std library...
Test successful
2016-07-09 18:14:03
nekotest.n  nekotest.neko
Shell returned: 0
Raised: load.c(357) : Primitive not found : std@not_in_std_library(0): 5
        from [[nekotest.neko,33]] from [[nekotest.neko,38]]
f(7) = 42
f(+00000000000000000007) = +00000000000000000042

<html>
<head><title>Haxe Flash</title></head>
<body bgcolor="#dddddd">
<object classid="clsid:d27cdb6e-ae6d-11cf-96b8-444553540000"
        width="400"
    height="300"
    id="haxe"
    align="middle">
<param name="movie" value="flash.swf"/>
<param name="allowScriptAccess" value="always" />
<param name="quality" value="high" />
<param name="scale" value="noscale" />
<param name="salign" value="lt" />
<param name="bgcolor" value="#ffffff"/>
<embed src="flash.swf"
       bgcolor="#ffffff"
       width="400"
       height="300"
       name="haxe"
       quality="high"
       align="middle"
       allowScriptAccess="always"
       type="application/x-shockwave-flash"
       pluginspage="http://www.macromedia.com/go/getflashplayer"
/>
</object>
</body>
</html>

class Flash {
    static function main() {
        var mc:flash.display.MovieClip = flash.Lib.current;
        mc.graphics.beginFill(0xFF0000);
        mc.graphics.moveTo(50,50);
        mc.graphics.lineTo(100,50);
        mc.graphics.lineTo(100,100);
        mc.graphics.lineTo(50,100);
        mc.graphics.endFill();

        trace("Hello, World");
    }
}

import flash.display.MovieClip;
import flash.display.Sprite;
import flash.events.MouseEvent;
import flash.events.Event;

import flash.text.TextFormat;
import flash.text.TextField;

class MovingFlash extends MovieClip {
        var r : Sprite;
        var x_ori:Int;
        var y_ori:Int;
        var theta:Float;
        var cos_theta:Float;
        var sin_theta:Float;
        
        public function new() {
                super();
                x_ori=50;
                y_ori=50;
                theta =0.01;
                cos_theta = Math.cos(theta);
                sin_theta = Math.sin(theta);
                var background:Sprite = new Sprite ();
                background.graphics.beginFill(0xffaaaa);
                background.graphics.drawRect(0,0,200,200);
                addChild(background);
                
                r = new Sprite();
                r.graphics.beginFill(0xaaaaff);
                r.graphics.drawRect(40,40,20,20);
                addChild(r);
                r.addEventListener("enterFrame",move);
        }
        
        function move(e:Event) {
                var new_x = cos_theta * (e.target.x-x_ori) - sin_theta *(e.target.y-y_ori);
                var new_y = sin_theta * (e.target.x-x_ori) + cos_theta *(e.target.y-y_ori);
                e.target.x = new_x+x_ori;
                e.target.y = new_y+y_ori;
        }
        
        static function main() {
                var tf = new TextFormat();
                tf.font = "Times New Roman";
                tf.size = 16;
                tf.color = 0x000000;
                
                var textblock = new TextField();
                textblock.autoSize = LEFT;
                textblock.text = "Flash animation from HaXe";
                textblock.setTextFormat(tf);
                
                var m:MovingFlash = new MovingFlash();
                flash.Lib.current.addChild(m);
                flash.Lib.current.addChild(textblock);
        }
}

class Testing {
  static function main() {
    var people = [
      "Elizabeth" => "Programming",
      "Joel" => "Design"
    ];
    for (name in people.keys()) {
      var job = people[name];
      trace('$name does $job for a living!');
    }
  }
}

prompt$ haxe -neko testing.n -main Testing Testing.hx
prompt$ neko testing
Testing.hx:9: Elizabeth does Programming for a living!
Testing.hx:9: Joel does Design for a living!

prompt$ haxe -python testing.py -main Testing Testing.hx

# Generated by Haxe 3.3.0



class Testing:
    __slots__ = ()

    @staticmethod
    def main():
        _g = haxe_ds_StringMap()
        _g.h["Elizabeth"] = "Programming"
        _g.h["Joel"] = "Design"
        tmp = _g.keys()
        while tmp.hasNext():
            name = tmp.next()
            print(str((((("" + ("null" if name is None else name)) + " does ")
            + HxOverrides.stringOrNull(_g.h.get(name,None))) + " for a living!")))


class haxe_IMap:
    __slots__ = ()


class haxe_ds_StringMap:
    __slots__ = ("h",)

    def __init__(self):
        self.h = dict()

    def keys(self):
        return python_HaxeIterator(iter(self.h.keys()))



class python_HaxeIterator:
    __slots__ = ("it", "x", "has", "checked")

    def __init__(self,it):
        self.checked = False
        self.has = False
        self.x = None
        self.it = it

    def next(self):
        if (not self.checked):
            self.hasNext()
        self.checked = False
        return self.x

    def hasNext(self):
        if (not self.checked):
            try:
                self.x = self.it.__next__()
                self.has = True
            except Exception as _hx_e:
                _hx_e1 = _hx_e
                if isinstance(_hx_e1, StopIteration):
                    s = _hx_e1
                    self.has = False
                    self.x = None
                else:
                    raise _hx_e
            self.checked = True
        return self.has



class HxOverrides:
    __slots__ = ()

    @staticmethod
    def stringOrNull(s):
        if (s is None):
            return "null"
        else:
            return s

prompt$ python3 testing.py
Elizabeth does Programming for a living!
Joel does Design for a living!

prompt$ ./cobweb-neko testing.n
Testing.hx:9: Elizabeth does Programming for a living!
Testing.hx:9: Joel does Design for a living!

Neko Virtual Machine (neko) and Neko Tools (nekotools)
======================================================

Copyright (C)2005-2016 Haxe Foundation

Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.

environment division.
configuration section.
repository.
    function evaluate-math
    function create-equation
    function evaluate-x
    function destroy-equation
    function all intrinsic.


data division.
working-storage section.
COPY cobweb-math REPLACING ==:tag:== BY ====.

01 x          usage float-long.
01 answer     usage float-long.
01 extraneous usage binary-long.
...


procedure division.
*> basic calculator math
display evaluate-math("(1 + 2 * 3 / 4 - 5)^6")

*> equation using x, (with automatically computed derivative)
move create-equation("x^5 + sin(x)^2", "derivative")
  to evaluator-record
perform varying x from 0.0 by 0.1 until x > 1.0
    move evaluate-x(evaluator, x) to answer
    display "f(" x ") = " answer
    move evaluate-x(evaluator-prime, x) to answer
    display "f'(" x ") = " answer
end-perform
move destroy-equation(evaluator-record) to extraneous

*> Repository for cobweb-math
    function create-equation
    function evaluate-equation
    function destroy-equation
    function evaluate-x
    function evaluate-xy
    function evaluate-xyz
    function evaluate-math

prompt$ cobc -c -static say2.cob
prompt$ cobc -c -static datatype.cob

prompt$ ar q libgbc.a say2.o datatype.o
prompt$ go run testDataTypes.go

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/cobweb-libcox
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20161211  Modified: 2016-12-12/19:00-0500
      *> LICENSE
      *>   Copyright (c) 2016 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or superior)
      *> PURPOSE
      *>   cobweb-libcox demonstration program.
      *>   A seed work, customize to suit local site requirements.
      *> TECTONICS
      *>   cobc -x -g -debug cobweb-libcox.cob libcox.c
      *>   cobc -b cobweb-libcox.cob libcox.c
      *> ***************************************************************
       identification division.
       program-id. cobweb-libcox.
       author. Brian Tiffin.
       date-written. 2016-12-11/20:26-0500.
       date-modified. 2016-12-12/19:00-0500.
       date-compiled.
       installation. Needs libcox, from http://libcox.symisc.net.
       remarks.
       security. Complex C library, evaluates user entered commands.

       environment division.
       configuration section.
       source-computer. gnulinux.
       object-computer. gnulinux
           classification is canadian.

       special-names.
           locale canadian is "en_CA.UTF-8".

       repository.
           function libcox-exec
           function libcox-list
           function all intrinsic.

       input-output section.
       file-control.
       i-o-control.

       REPLACE
       ==:LIBCOX-RECORD:== BY
       ==
          05 libcox-handle     usage pointer.
          05 libcox-value      usage pointer.
          05 libcox-elements   usage binary-long.
          05 libcox-type       usage binary-long.
          05 libcox-int        usage binary-long.
          *> BUG: GnuCOBOL CALL is still tripping up on 64 bit returns
          05 libcox-trick      usage pointer.
          05 libcox-int64  redefines libcox-trick usage binary-double.
          05 libcox-bool       usage binary-long.
          05 libcox-double     usage float-long.
          05 libcox-string     usage pointer.
          05 rc                usage binary-long.
       ==
       ==:LIBCOX-TABLE:== BY
       ==
          05 libcox-array      occurs 512 times.
             10 libcox-entry   pic x(64).
       ==
       .

       data division.
       file section.

       working-storage section.
       01 cli                  pic x(8).
          88 quiet-you         values "--quiet", "quiet", "q", "-q".

       01 libcox-record.
          :LIBCOX-RECORD:
       01 extraneous           usage binary-long.

      *> for string types
       01 libcox-store         pic x(1048576).

      *> for array types
       01 libcox-table.
          :LIBCOX-TABLE:

      *> for pretty print of disk space info
       01 show64               pic zzz,zzz,zzz,zzz,zzz,999.

      *> ***************************************************************
       procedure division.

       accept cli from command-line
       if quiet-you then goback end-if

      *> show the system type
       display "uname"
       move libcox-exec(libcox-record, "uname", libcox-store)
         to extraneous
       display trim(libcox-store)

      *> fetch the list of known libcox commands
       display space
       display "CMD_LIST"
       move libcox-list(libcox-record, "CMD_LIST", libcox-table)
         to extraneous
       perform varying tally from 1 by 1 until tally > libcox-elements
           display tally ": " trim(libcox-array(tally))
       end-perform

      *> a directory listing, as array
       display space
       display "ls"
       move libcox-list(libcox-record, "ls", libcox-table)
         to extraneous
       perform varying tally from 1 by 1 until tally > libcox-elements
           display tally ": " trim(libcox-array(tally))
       end-perform

      *> a filename listing, as string
       display space
       display "glob *.cob"
       move libcox-exec(libcox-record, "glob *.cob", libcox-store)
         to extraneous
       display libcox-type " " trim(libcox-store)

      *> explode a string by delimiter
       display space
       display 'explode , a,b,c,d'
       move libcox-list(libcox-record,
                        'explode , a,b,c,d,', libcox-table)
         to extraneous
       perform varying tally from 1 by 1 until tally > libcox-elements
           display tally ": " trim(libcox-array(tally))
       end-perform

      *> cat files into a string
       display space
       display 'cat libcox-license.txt'
       move libcox-exec(libcox-record,
                        'cat libcox-license.txt', libcox-store)
         to extraneous
       display trim(libcox-store)

       display space
       display "disk_total_space, disk_free_space"
       move libcox-exec(libcox-record, "dt ./", libcox-store)
         to extraneous
       move libcox-int64 to show64
       display trim(show64) " bytes total, " with no advancing
       move libcox-exec(libcox-record, "df ./", libcox-store)
         to extraneous
       move libcox-int64 to show64
       display trim(show64) " bytes free "
       display libcox-type " " trim(libcox-store)

      *> rundown the command evaluation engine
       call static "libcox_release" using by value libcox-handle
       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program cobweb-libcox.
      *> ***************************************************************
      *>****

      *> ***************************************************************
      *>****F* cobweb-libcox/libcox-exec
      *> PURPOSE
      *>   evaluate a libcox command string
       identification division.
       function-id. libcox-exec.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 inner-rc             usage binary-long.
       01 extraneous-pointer   usage pointer.

       linkage section.
       01 libcox-record.
          :LIBCOX-RECORD:
       01 libcox-command       pic x any length.
       01 libcox-buffer        pic x any length.
       01 extraneous           usage binary-long.

       procedure division using
           libcox-record
           libcox-command
           libcox-buffer
           returning extraneous.

      *> initialize the command processor if needs be
       if libcox-handle equal null then
           call static "libcox_init" using libcox-handle returning rc
               on exception
                   display "no libcox binding" upon syserr end-display
                   goback
           end-call
           if (rc not equal zero) or (libcox-handle equal null) then
               display "libcox init failure" upon syserr
               goback
           end-if
       end-if

      *> evaluate a command
       call static "libcox_exec" using
           by value libcox-handle
           by reference libcox-value
           by content concatenate(libcox-command x"00")
           by value -1
           returning rc
       end-call
       if rc not equal zero then
           display "libcox command evaluation failure" upon syserr
           goback
       end-if

      *> clear any pervious result
       move spaces to libcox-buffer

      *> pass back some usability information
       call static "libcox_value_is_int" using
           by value libcox-value returning inner-rc
       end-call
       if inner-rc not equal zero then
           move 1 to libcox-type
           call static "libcox_value_to_int" using
               by value libcox-value
               returning libcox-int
           end-call
          *> BUG: GnuCOBOL CALL is still tripping up on 64 bit returns
           call static "libcox_value_to_int64" using
               by value libcox-value
               returning libcox-trick
           end-call
           go string-it
       end-if

       call static "libcox_value_is_float" using
           by value libcox-value returning inner-rc
       end-call
       if inner-rc not equal zero then
           move 2 to libcox-type
           call static "libcox_value_to_double" using
               by value libcox-value
               returning libcox-double
           end-call
           go string-it
       end-if

       call static "libcox_value_is_bool" using
           by value libcox-value returning inner-rc
       end-call
       if inner-rc not equal zero then
           move 3 to libcox-type
           call static "libcox_value_to_double" using
               by value libcox-value
               returning libcox-bool
           end-call
           go string-it
       end-if

       call static "libcox_value_is_string" using
           by value libcox-value returning inner-rc
       end-call
       if inner-rc not equal zero then
           move 4 to libcox-type
          *> get the result as string
           call static "libcox_value_to_string" using
               by value libcox-value
               by reference libcox-elements
               returning libcox-string
           end-call

          *> truncate move the result string to the given COBOL space
          *> return record gets the libcox character count
           call static "memmove" using
               libcox-buffer
               by value libcox-string
               by value min(libcox-elements, length(libcox-buffer))
               returning extraneous-pointer
           end-call
           go out
       end-if


       call static "libcox_value_is_null" using
           by value libcox-value returning inner-rc
       end-call
       if inner-rc not equal zero then
           move 5 to libcox-type
           go out
       end-if

       call static "libcox_value_is_array" using
           by value libcox-value returning inner-rc
       end-call
       if inner-rc not equal zero then
           move 6 to libcox-type
           go string-it
       end-if

      *> Unknown type
       move -1 to libcox-type
       .

       string-it.
      *> get the result as string, just because
       call static "libcox_value_to_string" using
           by value libcox-value
           by reference libcox-elements
           returning libcox-string
       end-call

      *> truncate move the result string to the given COBOL space
      *> return record gets the libcox character count
       call static "memmove" using
           libcox-buffer
           by value libcox-string
           by value min(libcox-elements, length(libcox-buffer))
           returning extraneous-pointer
       end-call
       .

       out.
      *> free the result memory
       call static "libcox_exec_result_destroy" using
           by value libcox-handle libcox-value
           returning extraneous
       end-call

       goback.
       end function libcox-exec.
      *> ***************************************************************
      *>****

      *> ***************************************************************
      *>****F* cobweb-libcox/libcox-list
      *> PURPOSE
      *>   evaluate a libcox command string,
      *>   assuming result is array of strings
       identification division.
       function-id. libcox-list.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 libcox-item          usage pointer.
       01 libcox-index         usage binary-long.
       01 extraneous-pointer   usage pointer.

      *> somewhat redundant, but allows table indexing
       01 libcox-table based.
          :LIBCOX-TABLE:

       linkage section.
       01 libcox-record.
          :LIBCOX-RECORD:
       01 libcox-command       pic x any length.
       01 libcox-buffer        pic x any length.  *> passed as table
       01 extraneous           usage binary-long.

       procedure division using
           libcox-record
           libcox-command
           libcox-buffer
           returning extraneous.

      *> allow COBOL table indexing
       set address of libcox-table to address of libcox-buffer

      *> initialize the command processor if needs be
       if libcox-handle equal null then
           call static "libcox_init" using libcox-handle returning rc
               on exception
                   display "no libcox binding" upon syserr end-display
                   goback
           end-call
           if (rc not equal zero) or (libcox-handle equal null) then
               display "libcox init failure" upon syserr
               goback
           end-if
       end-if

      *> evaluate a command
       call static "libcox_exec" using
           by value libcox-handle
           by reference libcox-value
           by content concatenate(libcox-command x"00")
           by value -1
           returning rc
       end-call
       if rc not equal zero then
           display "libcox command evaluation failure" upon syserr
           goback
       end-if

      *> ensure we have a array
       call static "libcox_value_is_array" using
           by value libcox-value
           returning rc
       end-call

       move 0 to libcox-index
       if rc not equal zero then
           *> fill the table with space
           move spaces to libcox-table

           *> get first element
           call static "libcox_array_next_elem" using
               by value libcox-value
               returning libcox-item
           end-call

           *> move each array element to a string in the table
           perform until libcox-item equal null
               add 1 to libcox-index
               call static "libcox_value_to_string" using
                   by value libcox-item
                   by reference libcox-elements
                   returning libcox-string
               end-call
               call static "memmove" using
                   libcox-array(libcox-index)
                   by value libcox-string
                   by value min(libcox-elements
                                length(libcox-array(libcox-index)))
                   returning extraneous-pointer
               end-call
               call static "libcox_array_next_elem" using
                   by value libcox-value
                   returning libcox-item
               end-call
           end-perform
       end-if

      *> return record gets the array element count
       move libcox-index to libcox-elements

      *> free the result memory
       call static "libcox_exec_result_destroy" using
           by value libcox-handle libcox-value
           returning extraneous
       end-call
       .

       end function libcox-list.
      *> ***************************************************************
      *>****
>>ELSE

!doc-marker!
=============
cobweb-libcox
=============

.. contents::

Introduction
------------

The libcox system call and standard utility library, embedded in GnuCOBOL.

Tectonics
---------

::

    For a demonstration executable:
    prompt$ cobc -x [-j=quiet] cobweb-libcox.cob libcox.c

    User defined function repository as DSO
    prompt$ cobc -b cobweb-libcox.cob libcox.c
    prompt& cobcrun cobweb-libcox

    Link time usage of the repository
    prompt$ LD_RUN_PATH=. cobc -x program.cob -L. -l:cobweb-libcox

Usage
-----

::

    prompt$ ./cobweb-libcox

    In COBOL programs with
    repository.
        function libcox-exec
        function libcox-list


Source
------

.. include:: cobweb-libcox.cob
   :code: cobolfree

.. include:: libcox-license.txt
>>END-IF

prompt$ cobc -xj cobweb-libcox.cob libcox.c
uname
Linux 4.4.0-53-generic #74-Ubuntu SMP Fri Dec 2 15:59:10 UTC 2016
btiffin-CM1745 x86_64

CMD_LIST
00001: glob
00002: list
00003: ls
00004: mmap
00005: cat
00006: CMD_LIST
00007: time
00008: microtime
00009: getdate
00010: gettimeofday
00011: date
00012: strftime
00013: gmdate
00014: localtime
00015: idate
00016: mktime
00017: base64_decode
00018: base64_encode
00019: urldecode
00020: urlencode
00021: size_format
00022: strrev
00023: strrchr
00024: strripos
00025: strrpos
00026: stripos
00027: strpos
00028: stristr
00029: strstr
00030: bin2hex
00031: strtoupper
00032: strtolower
00033: rtrim
00034: ltrim
00035: trim
00036: explode
00037: implode
00038: strncasecmp
00039: strcasecmp
00040: strncmp
00041: strcmp
00042: strlen
00043: html_decode
00044: html_escape
00045: chunk_split
00046: substr_count
00047: substr_compare
00048: substr
00049: base_convert
00050: baseconvert
00051: octdec
00052: bindec
00053: hexdec
00054: decbin
00055: decoct
00056: dechex
00057: round
00058: os
00059: osname
00060: uname
00061: umask
00062: slink
00063: symlink
00064: lnk
00065: link
00066: fnmatch
00067: strglob
00068: pathinfo
00069: basename
00070: dirname
00071: touch
00072: file_type
00073: filetype
00074: dt
00075: disk_total_space
00076: df
00077: disk_free_space
00078: chgrp
00079: chown
00080: chmod
00081: delete
00082: remove
00083: rm
00084: unlink
00085: usleep
00086: sleep
00087: chroot
00088: lstat
00089: stat
00090: tmpdir
00091: temp_dir
00092: tmp_dir
00093: fileexists
00094: file_exists
00095: filemtime
00096: file_mtime
00097: filectime
00098: file_ctime
00099: fileatime
00100: file_atime
00101: filesize
00102: file_size
00103: isexec
00104: is_exec
00105: is_executable
00106: iswr
00107: is_wr
00108: is_writable
00109: isrd
00110: is_rd
00111: is_readable
00112: isfile
00113: is_file
00114: islnk
00115: is_lnk
00116: islink
00117: is_link
00118: isdir
00119: is_dir
00120: getgid
00121: getuid
00122: gid
00123: uid
00124: getusername
00125: username
00126: getpid
00127: pid
00128: random
00129: rand
00130: getenv
00131: fullpath
00132: full_path
00133: real_path
00134: realpath
00135: rename
00136: set_env
00137: setenv
00138: putenv
00139: env
00140: echo
00141: mkdir
00142: rmdir
00143: getcwd
00144: cwd
00145: pwd
00146: chdir
00147: cd

ls
00001: ph7.c
00002: libcox.c
00003: call-vedis.cob
00004: unqlite.c
00005: call-libcox.cob
00006: tt.v
00007: ph7.h

glob *.cob
+0000000006
["call-vedis.cob","call-libcox.cob"]

explode , a,b,c,d
00001: a
00002: b
00003: c
00004: d

cat libcox-license.txt
/*
 * Symisc libcox: Cross Platform Utilities & System Calls.
 * Copyright (C) 2014, 2015 Symisc Systems http://libcox.net/
 * Version 1.7
 * For additional information on licensing, redistribution of this file, and
for a DISCLAIMER OF ALL WARRANTIES
 * please contact Symisc Systems via:
 *       licensing@symisc.net
 *       contact@symisc.net
 * or visit:
 *      http://libcox.net/
 */
/*
 * Copyright (C) 2014, 2015 Symisc Systems, S.U.A.R.L [M.I.A.G Mrad Chems
Eddine <chm@symisc.net>].
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY SYMISC SYSTEMS ``AS IS'' AND ANY EXPRESS
 * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
 * NON-INFRINGEMENT, ARE DISCLAIMED.  IN NO EVENT SHALL SYMISC SYSTEMS
 * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */

disk_total_space, disk_free_space
976,481,013,760 bytes total, 865,996,541,952 bytes free
+0000000001 865996541952

/*
  jx9 scripting sample with UnQLite
*/

// Create the collection 'users'
if( !db_exists('users') ){
    /* Try to create it */
   $rc = db_create('users');
   if ( !$rc ){
     //Handle error
      print db_errlog();
   return;
   }
}

// JSON objects to be stored in the 'users' collection
$zRec = [
{
   name : 'james',
   age  : 27,
   mail : 'dude@example.com'
},
{
   name : 'robert',
   age  : 35,
   mail : 'rob@example.com'
},
{
   name : 'monji',
   age  : 47,
   mail : 'monji@example.com'
},
{
  name : 'barzini',
  age  : 52,
  mail : 'barz@mobster.com'
}
];

// Store the records
$rc = db_store('users',$zRec);

// Handle error
if (!$rc) {
    print db_errlog();
    return;
}

// Add One more record
$rc = db_store('users', {name : 'alex', age : 19, mail : 'alex@example.com'});
if (!$rc) {
    print db_errlog();
    return;
}

// The print commands will be redirected by the VM to a GnuCOBOL callback
print "Total number of stored records: ", db_total_records('users'), JX9_EOL;

// Sample query, age test
print "Query; people over 40", JX9_EOL;
$query = function($rec) {
    // People over 40
    if ($rec.age > 40) {
        return TRUE;
    }
    return FALSE;
};

// Fetch data using db_fetch_all() filter
$data = db_fetch_all('users', $query);

// Display each record
foreach ($data as $rec) {
    print $rec, JX9_EOL;
}

GCobol >>SOURCE FORMAT IS FREE
      *> ***************************************************************
      *>****J* gnucobol/callback-unqlite
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20161213  Modified: 2017-01-20/17:37-0500
      *> LICENSE
      *>   Copyright 2016 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or superior)
      *> PURPOSE
      *>   callback-unqlite program.
      *> TECTONICS
      *>   cobc -x -g -debug callback-unqlite.cob unqlite.c
      *> ***************************************************************
       identification division.
       program-id. callback-unqlite.
       author. Brian Tiffin.
       date-written. 2016-12-13/07:50-0500.
       date-modified. 2017-01-20/17:37-0500.
       installation. Just include unqlite.c in the build.
       security. Evaluates an external Jx9 script.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 unqlite-db               usage pointer.
       01 unqlite-vm               usage pointer.
       01 rc                       usage binary-long.

       01 jx9-script.
          05 value z"unqlite-sample.jx9".

       01 UNQLITE_OPEN_CREATE      usage binary-long value 4.
       01 UNQLITE_VM_CONFIG_OUTPUT usage binary-long value 1.
       01 callback                 usage program-pointer.
       01 invocations              usage binary-long value 0 external.

      *> ***************************************************************
       procedure division.

      *> Create an in memory document store
       call static "unqlite_open" using
           by reference unqlite-db
           by content z":mem:"
           by value UNQLITE_OPEN_CREATE
           returning rc
           on exception
               display "no unqlite" upon syserr end-display
               perform hard-exception
       end-call
       if (rc not equal zero) or (unqlite-db equal null) then
           display "unqlite open failure" upon syserr
           perform hard-exception
       end-if

       call static "unqlite_compile_file" using
           by value unqlite-db
           by content jx9-script
           by reference unqlite-vm
           returning rc
       end-call
       if (rc not equal zero) or (unqlite-vm equal null) then
           display "jx9 compile of " jx9-script " failed" upon syserr
           perform hard-exception
       end-if

      *> the UnQLite VM will call the vmoutput callback with data
       set callback to entry "vmoutput"
       call static "unqlite_vm_config" using
           by value unqlite-vm
           by value UNQLITE_VM_CONFIG_OUTPUT
           by value callback
           by reference NULL
       end-call

      *> the script populates, and then queries the document store
       call static "unqlite_vm_exec" using by value unqlite-vm

       call static "unqlite_vm_release" using by value unqlite-vm
       call static "unqlite_close" using by value unqlite-db

      *> each piece of output will cause a callback invocation
       display "Callback invoked " invocations " times"
       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program callback-unqlite.
      *> ***************************************************************
      *>****

      *> ***************************************************************
       identification division.
       program-id. vmoutput.

       data division.
       working-storage section.
       01 invocations          usage binary-long  external.
       01 cobol-buffer         pic x(256) based.

       01 UNQLITE-OK           constant as 0.
       01 UNQLITE-ABORT        constant as 1.

       linkage section.
       01 vm-data              usage pointer.
       01 vm-len               usage binary-long.
       01 vm-user              usage pointer.

      *> Called by the UnQLite virtual machine
       procedure division extern using by value vm-data vm-len vm-user.

       add 1 to invocations
       if vm-data not equal null then
           set address of cobol-buffer to vm-data
           display cobol-buffer(1:vm-len) with no advancing
           move UNQLITE-OK to return-code
       else
           move UNQLITE-ABORT to return-code
       end-if

       goback.
       end program vmoutput.

prompt$ cobc -xj -debug callback-unqlite.cob unqlite.c -w
Total number of stored records: 5
Query; people over 40
{"name":"monji","age":47,"mail":"monji@example.com","__id":2}
{"name":"barzini","age":52,"mail":"barz@mobster.com","__id":3}
Callback invoked +0000000009 times

#define duk_eval_string(ctx,src)  \
        ((void) duk_eval_raw((ctx), (src), 0, 1 /*args*/ | DUK_COMPILE_EVAL |
        DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN | DUK_COMPILE_NOFILENAME))

((void) duk_eval_raw((ctx), ("print('Hello world!');"), 0, 1 |
(1 << 3) | (1 << 8) | (1 << 9) | (1 << 10)));

GCobol >>SOURCE FORMAT IS FREE
      *> ***************************************************************
      *>****J* gnucobol/cobduk
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20161122  Modified: 2016-11-22/01:44-0500
      *> LICENSE
      *>   Copyright 2016 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or superior)
      *> PURPOSE
      *>   Integrate Duktape
      *> TECTONICS
      *>   cobc -x -g -debug cobduk.cob duktape.c
      *> ***************************************************************
       identification division.
       program-id. cobduk.
       author. Brian Tiffin.
       date-written. 2016-11-22/00:18-0500.
       date-modified. 2016-11-22/01:44-0500.
       installation. Needs Duktape 1.5.1
       remarks. Just add duktape.c
       security. Probably worth keeping an eye on the ECMAScripting.

       environment division.
       configuration section.
       source-computer. gnulinux.
       object-computer. gnulinux
           classification is canadian.

       special-names.
           locale canadian is "en_CA.UTF-8".

       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 duk-ctx usage pointer.
       01 duk-str usage pointer.
       01 based-str pic x(80) based.
       01 fixed-str pic x(80).

      *> ***************************************************************
       procedure division.
      *> Init Duktape
       call "duk_create_heap" using null null null null null
           returning duk-ctx
           on exception
               display "error: no duktape" upon syserr
               perform soft-exception
               goback
       end-call
       if duk-ctx equal null then
           display "duktape init failed" upon syserr
           goback
       end-if

      *> Evaluate a test hello
       call "duk_eval_raw" using
           by value duk-ctx
           by content z"print('Hello, world');"
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> Evaluate a custom Duktape JSON encode, no replace, 4 spaces
       call "duk_eval_raw" using
           by value duk-ctx
           by content z"print(Duktape.enc('jx', {foo: 123}, null, 4));"
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> Evaluate a more JSON Duktape JSON encode, no replace, 4 spaces
       call "duk_eval_raw" using
           by value duk-ctx
           by content z"print(Duktape.enc('jc', {foo: 123}, null, 4));"
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> decode some JSON, and print out a field
       call "duk_eval_raw" using
           by value duk-ctx
           by content "print(Duktape.dec('jx', " & z'"{foo:123}").foo);'
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> stringy some JSON, leave data on the Duktape stack
       call "duk_eval_raw" using
           by value duk-ctx
           by content
               z"var res = JSON.stringify({foo: 123}, null, 4); res;"
           by value 0 b"11100001001"
           returning omitted
       end-call

      *> get the character data into COBOL, -1 is top of stack
       call "duk_get_string" using
           by value duk-ctx
           by value -1
           returning duk-str
       end-call
       if duk-str not equal null then
           set address of based-str to duk-str
           string based-str delimited by low-value into fixed-str
           display "COBOL view of JSON: " fixed-str
       else
           display "JSON conversion failed" upon syserr
       end-if

       goback.
      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program cobduk.
      *> ***************************************************************

prompt$ cobc -xj cobduk.cob duktape.c
Hello, world
{
    foo: 123
}
{
    "foo": 123
}
123
COBOL view of JSON: {
    "foo": 123
}

GCobol >>SOURCE FORMAT IS FREE
      *> ***************************************************************
      *>****J* gnucobol/cobweb-cjson
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20170122  Modified: 2017-01-22/17:50-0500
      *> LICENSE
      *>   Copyright 2017 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or superior)
      *> PURPOSE
      *>   JSON parser example.
      *> TECTONICS
      *>   cobc -x -g -debug cobweb-cjson.cob cJSON.c
      *> ***************************************************************
       identification division.
      program-id. cobweb-cjson.
       author. Brian Tiffin.
       date-written. 2017-01-22/15:30-0500.
       date-modified. 2017-01-22/17:50-0500.
       installation. Requires cJSON.c and cJSON.h.
       remarks. Low level JSON parsing and construction.
       security. Should be no issues, even for external resources.

       data division.
       working-storage section.

       REPLACE ==:NEWLINE== BY ==& x"0a" &==.

       01 json-root            usage pointer.
       01 json-object          usage pointer.
       01 json-field           usage pointer.
       01 json-out             usage pointer.

       01 json             based.
          05 json-next         usage pointer.
          05 json-prev         usage pointer.
          05 json-child        usage pointer.
          05 json-type         usage binary-long sync.
          05 valuestring       usage pointer     sync.
          05 valueint          usage binary-long sync.
          05 valuedouble       usage float-long  sync.
          05 json-name         usage pointer     sync.

       01 json-data.
          05 value
             '{' :NEWLINE
             '    "name": "Jack (\"Bee\") Nimble",' :NEWLINE
             '    "format": {' :NEWLINE
             '        "type":       "rect",' :NEWLINE
             '        "width":      1920,' :NEWLINE
             '        "height":     1080,' :NEWLINE
             '        "interlace":  false,' :NEWLINE
             '        "frame rate": 24,' :NEWLINE
             '        "price":      123.34' :NEWLINE
             '    }' :NEWLINE
            z'}'.

       01 json-double          usage float-long.

      *> ***************************************************************
       procedure division.
      *> Parse some JSON
       display "GnuCOBOL: Parse JSON from a fixed COBOL field"
       call static "cJSON_Parse" using json-data returning json-root.

      *> if the parse works, do a pretty print
       if json-root not equal null then
           call static "cJSON_Print" using
               by value json-root
               returning json-out
           end-call
           if json-out not equal null then
               call "printf" using
                   by content "%s" & x"0a00"
                   by value json-out
               end-call
               call "free" using by value json-out
           else
               display "JSON print problem" upon syserr
           end-if
       else
           display "JSON parse problem" upon syserr
           goback
       end-if

      *> retrieve the frame rate
       call static "cJSON_GetObjectItem" using
           by value json-root
           by reference z"format"
           returning json-object
       end-call

       call static "cJSON_GetObjectItem" using
           by value json-object
           by reference z"frame rate"
           returning json-field
       end-call
       if json-field not equal null then
           set address of json to json-field
           display "frame rate: " valueint
       else
           display "JSON lookup problem" upon syserr
       end-if

      *> retrieve the price
       call static "cJSON_GetObjectItem" using
           by value json-object
           by reference z"price"
           returning json-field
       end-call
       if json-field not equal null then
           set address of json to json-field
           display "price     : " valuedouble
       else
           display "JSON lookup problem" upon syserr
       end-if

      *> free the entire structure
       call static "cJSON_Delete" using
           by value json-root
           returning omitted
       end-call

      *> Create some JSON
       display "GnuCOBOL: Build some JSON from scratch"
       call static "cJSON_CreateObject" returning json-root
       if json-root equal null then
           display "Problem creating JSON object" upon syserr
           goback
       end-if

      *> build a JSON string object
       call static "cJSON_CreateString" using
           z'JSON from GnuCOBOL'
           returning json-field
       end-call
       call static "cJSON_AddItemToObject" using
           by value json-root
           by reference z"title"
           by value json-field
       end-call

       call static "cJSON_CreateObject" returning json-object

       call static "cJSON_AddItemToObject" using
           by value json-root
           by reference z"fields"
           by value json-object
       end-call

       call static "cJSON_CreateString" using
           z'"quoted value"'
           returning json-field
       end-call
       call static "cJSON_AddItemToObject" using
           by value json-object
           by reference z"key"
           by value json-field
       end-call

       move 42 to json-double
       call static "cJSON_CreateNumber" using
           by value json-double
           returning json-field
       end-call
       call static "cJSON_AddItemToObject" using
           by value json-object
           by reference z"integer"
           by value json-field
       end-call

       move 21.42 to json-double
       call static "cJSON_CreateNumber" using
           by value json-double
           returning json-field
       end-call
       call static "cJSON_AddItemToObject" using
           by value json-object
           by reference z"double"
           by value json-field
       end-call

      *> print the constructed JSON
       call static "cJSON_Print" using
           by value json-root
           returning json-out
       end-call
       if json-out not equal null then
           call "printf" using
               by content "%s" & x"0a00"
               by value json-out
           end-call
           call "free" using by value json-out
       else
           display "JSON print problem" upon syserr
       end-if

      *> free the entire structure
       call static "cJSON_Delete" using
           by value json-root
           returning omitted
       end-call

       goback.
       end program cobweb-cjson.
      *> ***************************************************************
      *>****

prompt$ cobc -xj cobweb-cjson.cob cJSON.c
GnuCOBOL: Parse JSON from a fixed COBOL field
{
        "name": "Jack (\"Bee\") Nimble",
        "format":       {
                "type": "rect",
                "width":     1920,
                "height":    1080,
                "interlace": false,
                "frame rate":   24,
                "price":     123.340000
        }
}
frame rate: +0000000024
price     : 123.34
GnuCOBOL: Build some JSON from scratch
{
        "title":        "JSON from GnuCOBOL",
        "fields":       {
                "key":  "\"quoted value\"",
                "integer":   42,
                "double":    21.420000
        }
}

(* HelloFpc, module called from GnuCOBOL *)
(* Tectonics: fpc -CD hellofpc.pp *)
library hellofpc;

function HelloFpc(DataIn: Integer): Integer; cdecl;

    begin
        WriteLn('Hello, world');
        WriteLn('DataIn: ', DataIn);
        HelloFpc := DataIn * 2;
    end;

    exports
        HelloFpc;
end.

      *>
      *> callpascal.cob, Pascal integration with GnuCOBOL
      *>
      *> Tectonics:
      *>   fpc -CD hellofpc.pp  
      *>   LD_RUN_PATH=. cobc -xj callpascal.cob -L. -l:libhellofpc.so
      *>
       identification division.
       program-id. callpascal.

       procedure division.
       callfpc-main.

       call "HelloFpc" using by value 42 end-call
       display "fpc returned: " return-code
       move zero to return-code

       goback.
       end program callpascal.

prompt$ fpc -CD hellofpc.pp
Free Pascal Compiler version 3.0.0+dfsg-2 [2016/01/28] for x86_64
Copyright (c) 1993-2015 by Florian Klaempfl and others
Target OS: Linux for x86-64
Compiling hellofpc.pp
Linking libhellofpc.so
/usr/bin/ld.bfd: warning: link.res contains output sections; did you forget -T?
20 lines compiled, 0.1 sec

prompt$ LD_RUN_PATH=. cobc -x callpascal.cob -L. -l:libhellofpc.so
Hello, world
DataIn: 42
+000000084

import com.sun.jna.{Library, Native, Platform}

trait CobLibrary extends Library {
    def cob_init(argc: Int, argv: Array[String]): Void
    def cob_tidy(): Int
    def cobjna(s: String): Int
    def puts(s: String): Int
}

object CobLibrary {
    def Instance = Native.loadLibrary("cobjna",
        classOf[CobLibrary]).asInstanceOf[CobLibrary]
}

object JnaCob {
    def main(args: Array[String]) {

        /* Initialize libcob */
        /* Could pass the current args array, but this makes one up */
        CobLibrary.Instance.cob_init(4, 
            Array("JnaCob", "argv", "from", "Scala"))

        /* Call GnuCOBOL subprogram with a string */
        
        var rc: Int = CobLibrary.Instance.cobjna("Scala calling GnuCOBOL")
        println("RETURN-CODE from GnuCOBOL = " + rc)

        /* rundown libcob */
        CobLibrary.Instance.cob_tidy()

        /* Display arguments passed to scala using C puts */
        for ((arg, i) <- args.zipWithIndex) {
            CobLibrary.Instance.puts(
                "Argument %d: %s".format(i.asInstanceOf[AnyRef], arg))
        }

        println()
        /* Call GnuCOBOL again, with reinit because of previous cob_tidy */
        CobLibrary.Instance.cob_init(5, 
            Array("JnaCob", "argv", "from", "Scala", "a second time"))

        /* Call GnuCOBOL subprogram with a string */
        
        rc = CobLibrary.Instance.cobjna("Call GnuCOBOL again")
        println("RETURN-CODE from GnuCOBOL = " + rc)

        /* rundown libcob */
        CobLibrary.Instance.cob_tidy()
    }
}

      *>
      *> Called from Scala via JNA as
      *>   var rc: Int = CobLibrary.Instance.cobjna("data")
      *> 
       identification division.
       program-id. cobjna.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 cli pic x(80).

       linkage section.
       01 args pic x(80).

       procedure division using args.
       cobjna-main.

       display "Hello, from GnuCOBOL at " CURRENT-DATE

      *> Seems JNA does not pass through the command line
       accept cli from command-line
       display "COMMAND-LINE: " trim(cli)

      *> Display the string parameter passed from Scala
       move spaces to cli
       string args delimited by low-value into cli
       display "passed: " trim(cli)

      *> Return the length of the item to Scala
       move length(trim(cli)) to return-code

       goback.
       end program cobjna.

# Scala to GnuCOBOL via JNA
.RECIPEPREFIX=>

JnaCob: JnaCob.scala libcobjna.cob
> @echo 'Requires "source setcp.sh" for CLASSPATH setting'
> scalac JnaCob.scala
> cobc -debug -m libcobjna.cob
> @echo
> LD_LIBRARY_PATH=. scala JnaCob Testing 1 2 3

prompt$ make
Requires "source setcp.sh" for CLASSPATH setting
scalac JnaCob.scala
cobc -debug -m libcobjna.cob

LD_LIBRARY_PATH=. scala JnaCob Testing 1 2 3
Hello, from GnuCOBOL at 2017022404262716-0500
COMMAND-LINE: argv from Scala
passed: Scala calling GnuCOBOL
RETURN-CODE from GnuCOBOL = 22
Argument 0: Testing
Argument 1: 1
Argument 2: 2
Argument 3: 3

Hello, from GnuCOBOL at 2017022404262718-0500
COMMAND-LINE: argv from Scala a second time
passed: Call GnuCOBOL again
RETURN-CODE from GnuCOBOL = 19

      *>
      *> callmumps.cob, integrate FIS-GT.M MUMPS
      *> Tectonics:
      *>     requires GT.M demo setup and gtm_access.ci
      *>     cobc -xj callmumps.cob
      *>
       >>SOURCE FORMAT IS FREE
       identification division.
       program-id. callmumps.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 gtm-message-len constant as 2048.
       01 gtm-status usage binary-long.
       01 gtm-message pic x(gtm-message-len).
       
       01 gtm-error pic x(2048).
       01 err-key pic x(10).

       01 env pic x(2048).
       01 home pic x(2048).
       01 pwd pic x(2048).

       01 data-key occurs 3 times.
          05 filler pic x(32).
       01 data-value occurs 3 times.
          05 data-length usage binary-c-long.
          05 data-address usage pointer.
          05 data-cobol pic x(16).

       01 mumps-key pic x(32).
       01 mumps-value.
          05 mumps-length usage binary-c-long.
          05 mumps-address usage pointer.
          05 mumps-buffer pic x(16).

       01 gtm-zversion.
          05 value 'write $zversion,!'.
       01 gtm-zsystem.
          05 value 'zsystem "'.
       01 gtm-lke.
          05 value 'lke show"'.
       01 gtm-command pic x(256).

       procedure division.
       callmumps-main.
  
      *> Set up GT.M environment variables
       move all spaces to env
       accept env from environment "gtm_dist"
       if env equals spaces then
           set environment "gtm_dist" to
           "/usr/lib/x86_64-linux-gnu/fis-gtm/V6.2-002A-2build1_x86_64"
       end-if

       move all spaces to env
       accept env from environment "gtmgbldir"
       if env equals spaces then
           accept home from environment "HOME"
           set environment "gtmgbldir" to concatenate(
               trim(home) "/.fis-gtm/V6.2-002A_x86_64/g/gtm.gld")
       end-if
       
       move all spaces to env
       accept env from environment "gtmroutines"
       if env equals spaces then
           accept home from environment "HOME"
           move module-path to pwd
           move rexx("return filespec('PATH', arg(1))", pwd) to pwd
           accept env from environment "gtm_dist"
           set environment "gtmroutines" to concatenate(
               trim(pwd)
               space trim(home) "/.fis-gtm/V6.2-002A_x86_64/r"
               space trim(env) "/libgtmutil.so"
               space trim(env))
       end-if

       move all spaces to env
       accept env from environment "GTMCI"
       if env equals spaces then
           move module-path to pwd
           move rexx("return filespec('PATH', arg(1))", pwd) to pwd
           set environment "GTMCI" to concatenate(
               trim(pwd) "/gtm_access.ci")
       end-if

       move all spaces to env
       accept env from environment "gtmdir"
       if env equals spaces then
           accept home from environment "HOME"
           set environment "gtmdir" to concatenate(
               trim(home) "/.fis-gtm")
       end-if

       move all spaces to env
       accept env from environment "gtmver"
       if env equals spaces then
           set environment "gtmver" to "V6.2-002A_x86_64"
       end-if

      *> Initialize the GT.M runtime
       call "gtm_init" returning gtm-status
           on exception display "no gtm_init" upon syserr end-display
       end-call
       move "gtm_init:" to err-key
       perform gtm-error-test

      *> Enable the access routines, via the gtm_access.ci file       
       call "gtm_ci" using "gtminit" gtm-error returning gtm-status
           on exception display "no gtm_ci" upon syserr end-display
       end-call
       move "gtminit:" to err-key
       perform gtm-error-test

      *> prep some data
       move z'^Capital("Canada")' to data-key(1)
       move z"Ottawa" to data-cobol(1)
       set data-address(1) to address of data-cobol(1)
       move length(trim(data-cobol(1))) to data-length(1)

       move z'^Capital("United States")' to data-key(2)
       move z"Washington" to data-cobol(2)
       set data-address(2) to address of data-cobol(2)
       move length(trim(data-cobol(2))) to data-length(2)

       move z'^Capital("Mexico")' to data-key(3)
       move z"Mexico City" to data-cobol(3)
       set data-address(3) to address of data-cobol(3)
       move length(trim(data-cobol(3))) to data-length(3)
       
      *> Set some values
       move "gtmset:" to err-key
       perform varying tally from 1 by 1 until tally > 3
           call "gtm_ci" using "gtmset"
               data-key(tally) data-value(tally) gtm-error
               returning gtm-status
           end-call
           perform gtm-error-test
       end-perform

      *> Get a value
       display space
       display "Retrieve a capital city"
       move z'^Capital("United States")' to mumps-key
       set mumps-address to address of mumps-buffer
       move length(mumps-buffer) to mumps-length
       
       call "gtm_ci" using "gtmget" mumps-key mumps-value gtm-error
           returning gtm-status
       end-call
       move "gtmget:" to err-key
       perform gtm-error-test

       display mumps-length ", " 
               trim(substitute(mumps-buffer x"00" space))
       call "printf" using ":%.*s:" & x"0a00"
           by value mumps-length mumps-address

      *> grab a lock
       call "gtm_ci" using "gtmlock" "+^CIDemo($Job)" gtm-error
           returning gtm-status
       end-call
       move "gtmlock:" to err-key
       perform gtm-error-test

      *> interpret some MUMPS
       display space
       accept env from environment "gtm_dist"
       move concatenate(gtm-zversion space
                        gtm-zsystem trim(env) "/" gtm-lke x"00")
         to gtm-command
       display "Execute: " trim(substitute(gtm-command x"00" space))
       call "gtm_ci" using "gtmxecute" trim(gtm-command) gtm-error
           returning gtm-status
       end-call
       move "gtmxecute:" to err-key
       perform gtm-error-test

      *> clean up the demo storage
       display space
       display "Remove Capital data, then demonstrate error"

       call "gtm_ci" using "gtmkill" z"^Capital" gtm-error
           returning gtm-status
       end-call
       move "gtmkill:" to err-key
       perform gtm-error-test

      *> Get a value, which will fail as ^Capital is gone
       move z'^Capital("Canada")' to mumps-key
       move spaces to mumps-buffer
       move length(mumps-buffer) to mumps-length
       
       call "gtm_ci" using "gtmget" mumps-key mumps-value gtm-error
           returning gtm-status
       end-call
       move "gtmget:" to err-key
       perform gtm-error-test

      *> show an actual error message       
       perform gtm-error-display

      *> run down GT.M
       call "gtm_exit" returning gtm-status
           on exception display "no gtm_exit" upon syserr
       end-call
       move "gtm_exit:" to err-key
       perform gtm-error-test

      *> put up warning about tty settings
       display space
       display "GT.M engine will leave terminal in a custom state:"
       display "  ** use 'stty sane' or 'reset' to normalize **"
       goback.

      *> ****************
       gtm-error-test.
       if gtm-status not equal zero then
           display err-key space gtm-status trim(gtm-error) upon syserr
           call "gtm_zstatus" using gtm-message by value gtm-message-len
           display trim(substitute(gtm-message x"00" space)) upon syserr
       end-if
       .

       gtm-error-display.
       display err-key space gtm-status trim(gtm-error) upon syserr
       call "gtm_zstatus" using gtm-message by value gtm-message-len
       display trim(substitute(gtm-message x"00" space)) upon syserr
       .

       end program callmumps.

gtmget    : void get^%gtmaccess( I:gtm_char_t*, O:gtm_string_t*, O:gtm_char_t* )
gtminit	  : void init^%gtmaccess( O:gtm_char_t* )
gtmkill	  : void kill^%gtmaccess( I:gtm_char_t*, O:gtm_char_t* )
gtmlock	  : void lock^%gtmaccess( I:gtm_char_t*, O:gtm_char_t* )
gtmorder  : void order^%gtmaccess( I:gtm_char_t*, O:gtm_string_t*, O:gtm_char_t* )
gtmquery  : void query^%gtmaccess( I:gtm_char_t*, O:gtm_string_t*, O:gtm_char_t* )
gtmset    : void set^%gtmaccess( I:gtm_char_t*, I:gtm_string_t*, O:gtm_char_t*)
gtmxecute : void xecute^%gtmaccess( I:gtm_char_t*, O:gtm_char_t* )

# GnuCOBOL MUMPS integration with fis-gtm
.RECIPEPREFIX=>

export gtm_dist ?= /usr/lib/x86_64-linux-gnu/fis-gtm/V6.2-002A-2build1_x86_64
callmumps: callmumps.cob gtm_access.ci
> LD_RUN_PATH=$(gtm_dist) cobc -x callmumps.cob -L$(gtm_dist) -lgtmshr
> -./callmumps
> stty sane

prompt$ make -B
LD_RUN_PATH=/usr/lib/x86_64-linux-gnu/fis-gtm/V6.2-002A-2build1_x86_64 \
cobc -x callmumps.cob \
-L/usr/lib/x86_64-linux-gnu/fis-gtm/V6.2-002A-2build1_x86_64 -lgtmshr \
./callmumps

Retrieve a capital city
+00000000000000000011, Washington
:Washington:

Execute: write $zversion,! zsystem
"/usr/lib/x86_64-linux-gnu/fis-gtm/V6.2-002A-2build1_x86_64/lke show"
GT.M V6.2-002A Linux x86_64

DEFAULT
^CIDemo(5680) Owned by PID= 5680 which is an existing process
%GTM-I-LOCKSPACEUSE, Estimated free lock space: 98% of 40 pages

Remove Capital data, then demonstrate error
gtmget:    +0000000000,M7,Z150372994,
150372994,get+1^%gtmaccess,%GTM-E-GVUNDEF, Global variable undefined:
^Capital("Canada")

GT.M engine will leave terminal in a custom state:
  ** use 'stty sane' or 'reset' to normalize **
stty sane

prompt$ $(gtm_dist)/gtm -direct

s a = 4 s b = 2 w a w b k a k b

set a = 4
set b = 2
write a
write b
kill a
kill b

      *>
      *> ported.cob, for use with Elixir and iex
      *>
      *> tectonics:
      *>   cobc -x ported.cob
      *>   iex> port = Port.open({:spawn, "./ported"}, [:binary])
      *>   iex> Port.command(port, "info 123\n")
      *>
       identification division.
       program-id. ported.
       author. Brian Tiffin.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 incoming pic x(32).
       01 data-flag    pic x.
          88 nodata    value low-values when set to false high-values.
       01 newline      pic xx value x"0d0a".

       01 command      pic x(32).
          88 exiting   value "exit".
          88 crashing  value "crash".
          88 infoing   value "info".
          88 statusing value "status".

       01 arg          pic x(32).
       01 dl           pic x occurs 2 times.

       01 void         pic x(4) value "void" based.
       01 attempts     usage binary-long.
       01 unknowns     usage binary-long.
      
       procedure division.
       start-ported.
      *> display "COBOL: In ported" newline upon syserr
       set nodata to false
       accept incoming on exception set nodata to true end-accept

       perform until nodata
           move substitute(incoming x"00" space x"0a" space) to incoming
      *>   display "COBOL: accepted " trim(incoming) newline upon syserr
           move spaces to command arg
           unstring incoming
               delimited by all space or all "," or x"0a"
               into command delimiter in dl(1)
                    arg     delimiter in dl(2)

           add 1 to attempts
           evaluate true
               when exiting
                   exit perform
               when crashing
                   set address of void to null
                   display void
               when statusing
                   display "Attempts: " attempts ", Errors: ", unknowns
               when infoing
                   if arg equals space then
                       display "Customer list..."
                   else
                       display "Customer " trim(arg) ": info"
                   end-if
               when other
                   add 1 to unknowns
           end-evaluate

           set nodata to false
           accept incoming on exception set nodata to true end-accept
       end-perform
      *> display "COBOL: Out ported" newline upon syserr

       goback.
       end program ported.

#
# GnuCOBOL as a port demo
#
defmodule Ported do
    @moduledoc """
    A small demonstration of a GnuCOBOL program in an Elixir port
    """

    @spec start(String.t) :: none
    @doc """
    Start the external port, given a command string

    Parameters

      - cmd: Command string, defaulting to ./ported

    Examples

        iex> Ported.start
    """
    def start(cmd \\ "./ported") do
        port = Port.open({:spawn, cmd}, [:binary])
        Agent.start(fn -> [p: port] end, name: :p)
    end

    @spec get_port :: port
    @doc """
    The open port is stashed away in an Agent
    """
    def get_port() do
        elem(hd(Agent.get(:p, &(&1))), 1)
    end

    @spec say(String.t) :: none
    @doc """
    Send a command to GnuCOBOL and display response.
    Relies on proper line terminators to avoid a read hang
    """
    def say(str) do
        port = get_port
        Port.command(port, str <> "\n")
        receive do
            {^port, {:data, result}} ->
                IO.puts("Got: #{inspect result}")
            after 50 ->
                IO.puts("Timeout: #{inspect port}")
        end
    end
end

prompt$ cobc -x ported.cob
prompt$ elixirc ported.ex

prompt$ iex
Erlang/OTP 18 [erts-7.3] [source] [64-bit] [smp:4:4] [async-threads:10]
[kernel-poll:false]

Interactive Elixir (1.1.0-dev) - press Ctrl+C to exit (type h() ENTER for
help)
iex(1)> s(Ported)
@spec say(String.t()) :: none()
@spec get_port() :: port()
@spec start(String.t()) :: none()
iex(2)> h(Ported)
* Ported

A small demonstration of a GnuCOBOL program in an Elixir port

iex(3)> Ported.start
{:ok, #PID<0.61.0>}
iex(4)> Ported.say("info 12345")
Got: "Customer 12345: info\n"
:ok
iex(5)> Ported.say("info 54321")
Got: "Customer 54321: info\n"
:ok
iex(6)> Ported.say("status")
Got: "Attempts: +0000000003, Errors: +0000000000\n"
:ok
iex(7)> Ported.say("invalid")
Timeout: #Port<0.1416>
:ok
iex(8)> Ported.say "status"
Got: "Attempts: +0000000005, Errors: +0000000001\n"
:ok
iex(9)> Ported.say "exit"
Timeout: #Port<0.1416>
:ok
iex(10)> Ported.say "status"
** (ArgumentError) argument error
    :erlang.port_command(#Port<0.1416>, "status\n")
    ported.ex:48: Ported.say/1
iex(10)>
BREAK: (a)bort (c)ontinue (p)roc info (i)nfo (l)oaded
       (v)ersion (k)ill (D)b-tables (d)istribution
a
prompt$

# GnuCOBOL and Rust
.RECIPEPREFIX = >

caller: caller.cob libcalled.so
> LD_RUN_PATH=. cobc -xj caller.cob -L. -lcalled

libcalled.so: called.rs
> rustc --crate-type=dylib called.rs

COBOL *>-<*
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      *>
      *> Date started: April 2017
      *> Modified: 2017-04-27/00:24-0400 btiffin
      *>+<*
      *>
      *> caller.cob
      *> Tectonics: cobc -xj caller.cob -lcalled -L.
      *>
       identification division.
       program-id. sample.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 rptr usage pointer.
       01 rust-buffer pic x(80) based.
       01 rust-data pic x(80).

       procedure division.
       sample-main.
       call "hello_rust" returning rptr
       if rptr not equal null then
           set address of rust-buffer to rptr
           string rust-buffer delimited by low-value into rust-data
       end-if
       display ":" trim(rust-data) ":"
       goback.
       end program sample.

#[no_mangle]
pub extern fn hello_rust() -> *const u8 {
    "Hello, world\0".as_ptr()
}

prompt$ make -B
rustc --crate-type=dylib called.rs
LD_RUN_PATH=. cobc -xj caller.cob -L. -lcalled
:Hello, world:

# GnuCOBOL, Rust and Cargo
.RECIPEPREFIX = >

callnamed: callnamed.cob target/release/libnamed.so
> LD_RUN_PATH=target/release cobc -xj callnamed.cob -lnamed -Ltarget/release

target/release/libnamed.so: named.rs
> cargo build --lib --release

[package]

name = "named"
version = "0.0.1"
authors = ["Brian Tiffin <btiffin@gnu.org>"]

[lib]
name = "named"
path = "named.rs"
crate-type = ["dylib"]

[[bin]]
name = "named"
path = "named.rs"

use std::io;

#[no_mangle]
pub extern fn named() {
    println!("Enter your name:");
    let mut name = String::new();
    io::stdin().read_line(&mut name).expect("Failed To read Input");
    println!("Hello '{}'!", name.trim());
}

fn main() {
    named();
}

identification division.
program-id. sample.

data division.
working-storage section.

procedure division.
display "GnuCOBOL start"
call "named"
display "GnuCOBOL end"
goback.

end program sample.

prompt$ make -B
cargo build --lib --release
warning: file found to be present in multiple build targets:
/home/btiffin/lang/rust/samples/named.rs
    Finished release [optimized] target(s) in 0.0 secs
LD_RUN_PATH=target/release cobc -xj callnamed.cob -lnamed -Ltarget/release
GnuCOBOL start
Enter your name:
Blue
Hello 'Blue'!
GnuCOBOL end

[package]
name="punt"
version = "0.6.0"
authors = ["Bluey <btiffin@gnu.org>"]
links = "punt"
build = "build.rs"

[dependencies]
libc = "0.2.0"

[[bin]]
name = "punting"
path = "calling.rs"

// build.rs

use std::process::Command;
//use std::env;
//use std::path::Path;

fn main() {
    //let out_dir = env::var("OUT_DIR").unwrap();

    // note that there are a number of downsides to this approach, the comments
    // below detail how to improve the portability of these commands.

    //Command::new("gcc").args(&["src/hello.c", "-c", "-fPIC", "-o"])
    //                   .arg(&format!("{}/hello.o", out_dir))
    //                   .status().unwrap();
    //Command::new("ar").args(&["crus", "libhello.a", "hello.o"])
    //                  .current_dir(&Path::new(&out_dir))
    //                  .status().unwrap();

    //println!("cargo:rustc-link-search=native={}", out_dir);

    //Command::new("cobc").args(&["libpunt.cob", "-m", "-w", "-fimplicit-init"])
    //                    .status().unwrap();

    Command::new("make").arg("libpunt.so").status().unwrap();
    println!("cargo:rustc-link-search={}", ".");
    println!("cargo:rustc-link-lib=punt");
}

prompt$ LD_RUN_PATH=. cargo run
   Compiling punt v0.6.0 (file:///home/btiffin/lang/rust)
    Finished dev [unoptimized + debuginfo] target(s) in 0.63 secs
     Running `target/debug/punting`
sent 42, got: 84

# Include a resource for compilation as object code
# Defines two global symbols, resource and resource_size
# Tectonics:
#   Modify the filename for the .inbin directive and the symbol names
#   cobc -xj cobol.cob incbin.s

    .section .rodata

    .global resource
    .type   resource, @object
    .align  4
resource:
    .incbin "rexxlib.rexx"
resource_end:

    .global resource_size
    .type   resource_size, @object
    .align  4
resource_size:
    .int    resource_end - resource

/* REXX source code loaded by incbin.s*/
say "Hello, world"
return 0

*>-<*
*> Author: Brian Tiffin
*> Dedicated to the public domain
*>
*> Date started: April 2017
*> Modified: 2017-04-01/23:24-0400 btiffin
*>+<*
*>
*> resinc.cob, include resources from object file
*> Tectonics: cobc -xj resinc.cob incbin.s
*>
 >>SOURCE FORMAT IS FREE
 identification division.
 program-id. resource-include.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 01 symbol-pointer               usage program-pointer.
 01 resource-pointer             usage pointer.
 01 data-size-pointer            usage pointer.
 01 text-data                    pic x(256) based.
 01 show-data                    pic x(256).
 01 data-size                    usage binary-long based.
 01 default-value                usage binary-long value 0.
 01 extraneous                   pic 9.

 procedure division.
 resource-main.

*> lookup the resource address
 set symbol-pointer to entry "resource"
 if symbol-pointer = NULL then
     display "no ""resource"" symbol found" upon syserr
 else
     set resource-pointer to symbol-pointer
     set address of text-data to resource-pointer

     *> example of retrieving the associated resource size
     set symbol-pointer to entry "resource_size"
     if symbol-pointer = NULL then
         set address of data-size to address of default-value
         display "default-size: " data-size
     else
         set data-size-pointer to symbol-pointer
         set address of data-size to data-size-pointer
         display "data-size: " data-size
     end-if

     *> in this case, just look for a null byte
     string text-data delimited by low-value into show-data

     *> evaluate the resource as REXX text
     display "Evaluate: " length(trim(show-data))
     display trim(show-data)
     move rexx(trim(show-data)) to extraneous
 end-if

 goback.
 end program resource-include.

prompt$ make resinc
cobc -xj resinc.cob incbin.s

data-size: +0000000069
Evaluate: 000000069
/* REXX source code loaded by incbin.s*/
say "Hello, world"
return 0

Hello, world

*>-<*
*> Author: Brian Tiffin
*> Dedicated to the public domain
*>
*> Date started: April 2017
*> Modified: 2017-04-02/23:01-0400 btiffin
*>+<*
*>
*> tryarc.cob, testing libarchive
*> Tectonics:
*>   ar cr testing.a some files
*>   cobc -xj tryarc.cob -larchive
*>
 >>SOURCE FORMAT IS FREE
 identification division.
 program-id. tryarc.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 01 arc                          usage pointer.
 01 arc-entry                    usage pointer.
 01 arc-format                   usage binary-long.

 01 rc                           usage binary-long.
 01 msg                          usage pointer.
 01 errmsg                       usage pointer.

 01 entry-buffer                 usage pointer.
 01 entry-size                   usage binary-c-long.
 01 entry-offset                 usage binary-double.

 procedure division.
 sample-main.

 call "archive_read_new" returning arc
     on exception display "error: no libarchive" upon syserr
 end-call
 if arc equal null then
     display "error: archive_read_new failed" upon syserr
     goback
 end-if
 call "archive_read_support_filter_all" using by value arc
 call "archive_read_support_format_all" using by value arc

 call "archive_read_open_filename" using
     by value arc
     by reference "testing.a"
     by value 10240
     returning rc
 end-call
 perform error-check

 call "archive_file_count" using by value arc returning arc-format
 display "arc count: " arc-format

 call "archive_read_next_header" using
     by value arc
     by reference arc-entry
     returning rc
 end-call
 perform error-check

 perform until rc not equal zero
     call "archive_format" using by value arc returning arc-format

     call "archive_entry_pathname" using
         by value arc-entry
         returning msg
     end-call
     perform error-check
     call "printf" using "Type: %d Name :%s: " & x'0a00'
         by value arc-format msg

     call "archive_read_data_block" using
         by value arc
         by reference entry-buffer entry-size entry-offset
         returning rc
     end-call
     perform error-check
     if entry-buffer not equal null then
         call "printf" using "%.*s"
             by value entry-size entry-buffer
     end-if
     perform until rc not equal zero
         call "archive_read_data_block" using
             by value arc
             by reference entry-buffer entry-size entry-offset
             returning rc
         end-call
         perform error-check
         if entry-buffer not equal null then
             call "printf" using "%.*s"
                 by value entry-size entry-buffer
         end-if
     end-perform

     call "archive_read_next_header" using
         by value arc
         by reference arc-entry
         returning rc
     end-call
     perform error-check
 end-perform
 call "archive_file_count" using by value arc returning arc-format
 display "arc count: " arc-format

 call "archive_read_close" using by value arc
 call "archive_read_free" using by value arc

 goback.

*> ********************
 error-check.
 if rc less than zero then
     call "archive_error_string" using
         by value arc
         returning errmsg
     end-call
     if errmsg not equal null then
         call "printf" using "%s" & x'0a00' by value errmsg
     end-if
 end-if
 .
 end program tryarc.

# Archiving and resource embedding utilities
.RECIPEPREFIX = >

resinc: resinc.cob incbin.s rexxlib.rexx
> cobc -xj resinc.cob incbin.s

testing.a:
> ar cr testing.a resinc.cob incbin.s rexxlib.rexx tryarc.cob

tryarc: tryarc.cob
> cobc -xj tryarc.cob -larchive

prompt$ make testing.a
ar cr testing.a resinc.cob incbin.s rexxlib.rexx tryarc.cob

prompt$ make -B tryarc
cobc -xj tryarc.cob -larchive

arc count: +0000000000
Type: 458753 Name :resinc.cob:
      *>-<*
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      ...
       end-if

       goback.
       end program resource-include.
Type: 458753 Name :incbin.s:
/*
  Include a resource for compilation as object code
  Defines two global symbols, resource and resource_size
  Tectonics:
      Modify the filename for the .incbin directive and the symbol names
      cobc -xj cobol.cob incbin.s
  Started: April 2017
  Modified: 2017-04-02/15:17-0400 btiffin
*/
    .section .rodata

    .global resource
    .type   resource, @object
    .align  4
resource:
    .incbin "rexxlib.rexx"
resource_end:

    .global resource_size
    .type   resource_size, @object
    .align  4
resource_size:
    .int    resource_end - resource
Type: 458753 Name :rexxlib.rexx:
/* REXX source code loaded by incbin.s*/
say "Hello, world"
return 0
Type: 458753 Name :tryarc.cob:
      *>-<*
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      ...
       end-if
   .
   end program sample.
arc count: +0000000004

arc count: +0000000000
Type: 458753 Name :resinc.cob:
Type: 458753 Name :incbin.s:
Type: 458753 Name :rexxlib.rexx:
Type: 458753 Name :tryarc.cob:
arc count: +0000000004

call "archive_read_support_filter_all" using by value arc
call "archive_read_support_format_all" using by value arc

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****J* gnucobol/call-vedis
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   20161202  Modified: 2017-04-28/15:53-0400 btiffin
      *> LICENSE
      *>   Copyright 2016 Brian Tiffin
      *>   GNU Lesser General Public License, LGPL, 3.0 (or superior)
      *> PURPOSE
      *>   Embed vedis in GnuCOBOL demo.
      *> TECTONICS
      *>   cobc -x -g -debug call-vedis.cob vedis.c
      *> ***************************************************************
       identification division.
       program-id. call-vedis.
       author. Brian Tiffin.
       date-written. 2016-12-02/00:15-0500.
       date-modified. 2017-04-28/15:53-0400.
       date-compiled.
       installation. Single source file amalgam.
       remarks. Memory store available with ":mem:" filename.
       security. Command driven database engine.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 vedis usage pointer.
       01 rc usage binary-long.
       01 result-address usage pointer.
       01 result-length usage binary-long.
       01 based-address usage pointer.
       01 based-result pic x(4096) based.
       01 result pic x(4096).

       01 keystr pic x(8).
       01 valstr pic x(32).
       01 chr pic 999.
       01 seed usage float-long.

       01 counter pic 9(6).

      *> ***************************************************************
       procedure division.

       move random() to seed
       move random(seed) to seed
       move seed to chr
       move random(chr) to seed

      *> Create a demo "tt.v" file
       call "vedis_open" using vedis by content z"tt.v" returning rc
           on exception display "no vedis linkage" upon syserr
       end-call
       if rc not equal zero then display "vedit_open: " rc end-if
       if vedis equal null then
           display "no vedis init" upon syserr
           goback
       end-if

      *> commands are evaluated as text command lines
      *> Get a command list
       call "vedis_exec" using
           by value vedis
           by content z"CMD_LIST"
           by value -1
           returning rc
       end-call

      *> result pulled by type; this is a list but also a string form
       if rc equal zero then
           call "vedis_exec_result" using
               by value vedis
               by reference result-address
               returning rc
           end-call
           if result-address not equal null then
               call "vedis_value_to_string" using
                   by value result-address
                   by reference result-length
                   returning based-address
               end-call
               if based-address not equal null then
                   set address of based-result to based-address
                   string based-result delimited by x"00" into result
                   display trim(result)
               end-if
           end-if
       else
           display "cmd_list fail " rc upon syserr
       end-if

      *> Vedis can be tuned with various configuration settings
      *>   the enum value 2 sets a MAX_PAGE_CACHE hint
      *> call "vedis_config" using by value vedis 2 1000000 returning rc
      *> display "config rc " rc

      *> A set and get
       call "vedis_exec" using
           by value vedis
           by content z"SET test 'Hello, world'"
           by value -1
           returning rc
       end-call

       call "vedis_exec" using
           by value vedis
           by content z"GET test"
           by value -1
           returning rc
       end-call
       if rc equal 0 then
           call "vedis_exec_result" using
               by value vedis
               by reference result-address
               returning rc
           end-call

           if result-address not equal null then
               call "vedis_value_to_string" using
                   by value result-address
                   by reference result-length
                   returning based-address
               end-call
               if based-address not equal null then
                   set address of based-result to based-address
                   move all spaces to result
                   string based-result delimited by x"00" into result
                   display trim(result)
               end-if
           end-if
       else
           display "GET failed" upon syserr
       end-if

      *> a small benchmark pass
       display "10,000 random key inserts using SET"
       display current-date
       perform varying counter from 1 by 1 until counter > 10000
           perform varying tally from 1 by 1 until tally > 8
                compute chr = random() * 26.0 + 65 + 1
                move char(chr) to keystr(tally:1)
           end-perform
           perform varying tally from 1 by 1 until tally > 32
                compute chr = random() * 26.0 + 97 + 1
                move char(chr) to valstr(tally:1)
           end-perform

           if mod(counter, 1000) equal 0 then
               display counter ": ", keystr ", " valstr
           end-if

           call "vedis_exec" using
               by value vedis
               by content concatenate("SET " keystr " '" valstr z"'")
               by value -1
               returning rc
           end-call
           if rc not equal 0 then display "vedis SET: " rc end-if

           *> timing will be noticeably slower with commit
           *> call "vedis_commit" using by value vedis returning rc
       end-perform

       call "vedis_close" using by value vedis returning rc
       if rc not equal 0 then display "close rc: " rc end-if
       display current-date
       goback.


      *> ***************************************************************

       REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
       ==
      *> informational warnings and abends
       soft-exception.
         display space upon syserr
         display "--Exception Report-- " upon syserr
         display "Time of exception:   " current-date upon syserr
         display "Module:              " module-id upon syserr
         display "Module-path:         " module-path upon syserr
         display "Module-source:       " module-source upon syserr
         display "Exception-file:      " exception-file upon syserr
         display "Exception-status:    " exception-status upon syserr
         display "Exception-location:  " exception-location upon syserr
         display "Exception-statement: " exception-statement upon syserr
       .

       hard-exception.
           perform soft-exception
           stop run returning 127
       .
       ==.

       :EXCEPTION-HANDLERS:

       end program call-vedis.
      *> ***************************************************************
      *>****
>>ELSE
!doc-marker!
========
call-vedis
========

.. contents::

Introduction
------------
Vedis is a key-value storage engine with a rich set of commands.

Tectonics
---------

::

    prompt$ cobc -x call-vedis.cob vedis.c

Usage
-----

::

    prompt$ ./call-vedis

Source
------

.. include::  call-vedis.cob
   :code: cobolfree
>>END-IF

prompt$ cobc -xj call-vedis.cob vedis.c
["BEGIN","ROLLBACK","COMMIT","VEDIS","TABLE_LIST","CMD_LIST","ABORT","PR
INT","ECHO","OS","DATE","TIME","STR_SPLIT","STRIP_TAG","GETCSV","SIZE_FM
T","SOUNDEX","BASE64_DEC","BASE64","RANDSTR","GETRANDMAX","RAND","LPUSH"
,"LPOP","LLEN","LINDEX","SLEN","SINTER","SDIFF","SMEMBERS","SREM","STOP"
,"SPEEK","SPOP","SISMEMBER","SCARD","SADD","HSETNX","HMSET","HSET","HGET
ALL","HVALS","HKEYS","HMGET","HLEN","HDEL","HEXISTS","HGET","DECRBY","IN
CRBY","DECR","INCR","GETSET","MSETNX","MSET","SETNX","SET","MGET","MOVE"
,"COPY","GET","STRLEN","APPEND","EXISTS","REMOVE","DEL"]
Hello, world
10,000 random key inserts using SET
2017042815551871-0400
001000: RHSMAOFB, affctvbimnxzpkvykcttegrvnjioxoqy
002000: JFGLYZYU, sznvifxqjosrkajaaeiadkunqayozxjs
003000: RDEOWWUO, ounywhlblrmwrdodydndisiavmprikgx
004000: NTUGZLAS, ejacjomkrlpvdunygvtcwicjbxpajqtn
005000: JCWFYBQS, jxazalotcabocgcdbycnakrjnopmpgez
006000: JEWJREWA, wbepdpamutavniuidvlhiuarzxbqbyry
007000: TOUIHPYR, dizqeuofcmgscbfyggoffgmzughcwfta
008000: AQBDZMPE, hdnyayywjfkuhospnplcfdkguljuxzyf
009000: LFNJPGHH, yzxwxiqwmylfryopzbomxcejhssxzzex
010000: BQCBWOKG, bbsdaxrieirltpqfrzdpakdbbgdxvnex
2017042815551975-0400

*>-<*
*> Author: Brian Tiffin
*> Dedicated to the public domain
*>
*> Date started: April 2017
*> Modified: 2017-04-28/17:31-0400 btiffin
*>+<*
*>
*> call-ph7.cob, integration with Symisc PH7 PHP
*> Tectonics: cobc -xj call-ph7.cob ph7.c
*>
 >>SOURCE FORMAT IS FREE
 identification division.
 program-id. call-ph7.

 REPLACE ==newline== BY ==& x'0a' &==.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 01 ph7-engine usage pointer.
 01 rc usage binary-long.
 01 ph7-vm usage pointer.
 01 ph7-exitstatus usage binary-long.
 01 ph7-consumer usage program-pointer.

*> The PH7 script text
 01 ph7-script. 05 value
     "<?php echo 'Welcome guest'.PHP_EOL;" newline
     "echo 'System time: ' . date('Y-m-d H:i:s').PHP_EOL;" newline
     "echo 'System: ' . substr(php_uname(),0,16).PHP_EOL;" newline
     z"?>".

 procedure division.
 call-ph7-main.
 call static "ph7_init" using ph7-engine returning rc
     on exception
         display "no ph7_init linked: " rc upon syserr end-display
 end-call
 if (ph7-engine equal null) or (rc not equal zero) then
*> bail
     display "ph7_init fail: " rc upon syserr
     goback
 end-if

 call static "ph7_compile_v2" using
      by value ph7-engine
      by reference ph7-script
      by value -1                *> compute length internally
      by reference ph7-vm
      by value 0                 *> Compile-flags
      returning rc
 end-call
 if (ph7-vm equal null) or (rc not equal zero) then
     display "ph7_compile_v2 fail: " rc upon syserr
     goback
 end-if

 set ph7-consumer to entry "ph7consumer"
 if ph7-consumer equal null then
     display "no ph7consumer: " upon syserr
     goback
 end-if

 call static "ph7_vm_config" using
     by value ph7-vm
     by value 1                 *> PH7_VM_CONFIG_OUTPUT (ph7.h)
     by value ph7-consumer
     by value 0                 *> unused private data
     returning rc
 if rc not equal zero then
     display "ph7_compile_v2 fail: " rc upon syserr
     goback
 end-if

 call static "ph7_vm_exec" using
     by value ph7-vm
     by reference ph7-exitstatus
     returning rc
 end-call
 if rc not equal zero then
     display "script fail: " rc ", " ph7-exitstatus upon syserr
 end-if

 call static "ph7_vm_release" using by value ph7-vm
 call static "ph7_release" using by value ph7-engine

 goback.
 end program call-ph7.

*>
*> Capture PH7 output requests, and just print them
*>
 identification division.
 program-id. ph7consumer.

 data division.
 linkage section.
 01 ph7-output usage pointer.
 01 ph7-outlen usage binary-long.
 01 ph7-userdata usage pointer.

 procedure division using
     by value ph7-output ph7-outlen ph7-userdata.

 if ph7-output not equal null then
     call "printf" using "%.*s"
         by value ph7-outlen ph7-output
     end-call
     move 0 to return-code
 else
     move 1 to return-code
 end-if

 goback.
 end program ph7consumer.

prompt$ cobc -Wno-unfinished -xj call-ph7.cob ph7.c
Welcome guest
System time: 2017-04-28 17:32:32
System: Linux 4.4.0-75-g

GCobol >>SOURCE FORMAT IS FREE
>>IF docpass NOT DEFINED
      *> ***************************************************************
      *>****p* project/lws
      *> AUTHOR
      *>   Brian Tiffin
      *> DATE
      *>   2015-06-10
      *>   Modified: 2017-06-10/00:41-0400
      *> LICENSE
      *>   GNU Lesser General Public License, LGPL, 3.0 (or greater)
      *> PURPOSE
      *>   Demonstrate a simple libwebsocket protocol handler
      *>
      *> TECTONICS
      *>   cobc -x lws.cob -g -debug
      *>   browse http://localhost:9000 (enter quit to halt server)
      *> ***************************************************************
       identification division.
       program-id. lws.
       author. Brian Tiffin.
       date-compiled.
       date-written. 2017-06-09/17:02-0400.
       installation. Requires libwebsocket 2.1 or greater.
       remarks.
       security. Exposes network port.

       environment division.
       configuration section.
       special-names.
       repository.
           function all intrinsic.

       data division.

       working-storage section.
       01 quit-flag pic x value low-value external.
          88 quitting value high-value.

       01 protocols.
          05 filler occurs 3 times.
             10 protocol-name usage pointer sync.
             10 protocol-handler usage program-pointer sync.
             10 protocol-session-size usage binary-double sync.
             10 protocol-rx-buffer-size usage binary-double sync.
             10 protocol-id usage binary-long sync.
             10 protocol-user usage pointer sync.
             10 protocol-tx-buffer-size usage binary-double sync.

       01 http-name.
          05 filler value z"http-only".
       01 simple-name.
          05 filler value z"simple-protocol".

       01 context-info.
          05 ci-port usage binary-long sync.
          05 iface usage pointer sync.
          05 ci-protocols usage pointer sync.
          05 extensions usage pointer sync.
          05 token-limits usage pointer sync.
          05 ssl-private-key-password usage pointer sync.
          05 ssl-cert-filepath usage pointer sync.
          05 ssl-private-key-filepath usage pointer sync.
          05 ssl-ca-filepath usage pointer sync.
          05 ssl-cipher-list usage pointer sync.
          05 http-proxy-address usage pointer sync.
          05 http-proxy-port usage binary-long sync.
          05 gid usage binary-long value -1 sync.
          05 uid usage binary-long value -1 sync.
          05 ci-options usage binary-long sync.
          05 ci-user usage pointer sync.
          05 ka-time usage binary-long sync.
          05 ka-probe usage binary-long sync.
          05 ka-interval usage binary-long sync.
          05 provided_client_ssl_ctx usage pointer sync.
          05 max-http-header-data usage binary-short sync.
          05 max-http-header-pool usage binary-short sync.
          05 count-threads usage binary-long sync.
          05 fd-limit-per-threads usage binary-long sync.
          05 timeout-secs usage binary-long sync.
          05 ecdh-curve usage pointer sync.
          05 vhost-name usage pointer sync.
          05 plugin-dirs usage pointer sync.
          05 pvo usage pointer sync.
          05 keepalive_timeout usage binary-long sync.
          05 log-filepath usage pointer sync.
          05 mounts usage pointer sync.
          05 server-string usage pointer sync.
          05 pt-serv-buf-size usage binary-long sync.
          05 max-http-header-data2 usage binary-long sync.
          05 ssl-options-set usage binary-c-long sync.
          05 ssl-option-clear usage binary-c-long sync.
          05 ws-ping-pong-interval usage binary-short sync.
          05 headers usage pointer sync.
          05 reject-service-keywords usage pointer sync.
          05 external-baggage-free-ondestroy usage pointer sync.
          05 client-ssl-private-key-password usage pointer sync.
          05 client-ssl-cert-filepath usage pointer sync.
          05 client-ssl-private-key-filepath usage pointer sync.
          05 client-ssl-ca-filepath usage pointer sync.
          05 client-ssl-cipher-list usage pointer sync.
          05 fops usage pointer sync.
          05 simultaneous-ssl-restriction usage binary-long sync.
          05 socks-proxy-address usage pointer sync.
          05 socks-proxy-port usage binary-long sync.
          05 filler usage pointer occurs 8 times sync.

       01 context usage pointer.

      *> ***************************************************************
       procedure division.

      *> First protocol is always http-only
       set protocol-name(1) to address of http-name
       set protocol-handler(1) to entry "callback_http"
       if protocol-handler(1) equal null then
           display "no callback_http entry error" upon syserr
           move 1 to return-code
           goback
       end-if
       move 0 to protocol-session-size(1)
       move 0 to protocol-rx-buffer-size(1)

      *> Second is our simple testing protocol
       set protocol-name(2) to address of simple-name
       set protocol-handler(2) to entry "callback_simple"
       if protocol-handler(2) equal null then
           display "no callback_simple entry error" upon syserr
           move 1 to return-code
           goback
       end-if
       move 0 to protocol-session-size(2)
       move 0 to protocol-rx-buffer-size(2)

      *> end of protocol support list
       set protocol-name(3) to NULL
       set protocol-handler(3) to NULL
       move 0 to protocol-session-size(3)
       move 0 to protocol-rx-buffer-size(3)

      *> zero out the context space
       move all low-values to context-info

      *> port 9000, gid/uid reset of server, link the simple protocol
       move 9000 to ci-port
       move -1 to gid uid
       set ci-protocols to address of protocols

      *> create the websocket context
       call "lws_create_context" using context-info returning context.
       if context equal null then
           display "lws_create_context error" upon syserr
           move 1 to return-code
           goback
       end-if

       display "Starting server..." upon syserr
       perform until quitting
           call "lws_service" using by value context 50 *> milliseconds
           add 1 to tally
       end-perform
       display "Leaving server... tally at " tally upon syserr

       call "lws_context_destroy" using by value context

       move 0 to return-code
       goback.
       end program lws.
      *> ***************************************************************

      *> ***************************************************************
       identification division.
       program-id. callback_http.

       environment division.
       configuration section.
       special-names.
           call-convention 0 is extern.
       repository.
           function all intrinsic.

       data division.
       linkage section.
       01 wsi usage pointer.
       01 reason usage binary-long.
       01 user usage pointer.
       01 inp usage pointer.
       01 len usage binary-double.

       procedure division extern using
           by value wsi
           by value reason
           by value user
           by value inp
           by value len.

      *> HTTP not implemented for this example
       move 0 to return-code
       goback.

       end program callback_http.
      *> ***************************************************************

      *> ***************************************************************
       identification division.
       program-id. callback_simple.

       environment division.
       configuration section.
       special-names.
           call-convention 0 is extern.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 LWS-WRITE-TEXT constant as 0.

       01 LWS-CALLBACK-ESTABLISHED constant as 0.
       01 LWS-CALLBACK-CLOSED constant as 4.
       01 LWS-CALLBACK-RECEIVE constant as 6.

       01 copy-buffer pic x(8192) based.

       01 work-buffer pic x(8192).
          88 quitting values "QUIT".
       01 quit-flag pic x external.

       linkage section.
       01 wsi usage pointer.
       01 reason usage binary-long.
       01 user usage pointer.
       01 inp usage pointer.
       01 len usage binary-long.

       procedure division extern using
           by value wsi
           by value reason
           by value user
           by value inp
           by value len.

       >>IF DEBUG DEFINED
           display "callback_simple"
           display "wsi: " wsi
           display "reason: " reason
           display "user: " user
           display "inp: " inp
           display "len: " len
       >>END-IF

       evaluate reason
           when = LWS-CALLBACK-ESTABLISHED
               display "Connection established" upon syserr

           when = LWS-CALLBACK-CLOSED
               display "Connection closed" upon syserr

           when = LWS-CALLBACK-RECEIVE
       >>IF DEBUG DEFINED
               display "got data: " inp ", " len
               call "printf" using "printf: %.*s" & x"0a00"
                   by value len by value inp
       >>END-IF

               *> Shuffle into nice safe working store, with transform
               set address of copy-buffer to inp
               move upper-case(copy-buffer(1:len)) to work-buffer
               set address of copy-buffer to NULL

               *> Normal servers would have a more sophisticated exit
               if quitting then
                   move high-value to quit-flag
                   goback
               end-if

               *> Send the work-buffer back to the client
               call "lws_write" using
                   by value wsi
                   by reference work-buffer
                   by value len
                   by value LWS-WRITE-TEXT

           when other
               display "websocket reason: " reason upon syserr
       end-evaluate

       move 0 to return-code
       goback.

       end program callback_simple.
>>ELSE

!doc-marker!
==========
lws sample
==========

Introduction
------------

Tectonics
---------

.. sourcecode:: make

lws: lws.cob
        cobc -x lws.cob

docs:
        sed ':loop;/!doc-marker!/{d};N;b loop' lws.cob \
        | sed '$$d' | rst2html >lws.html

clean:
        -rm lws lws.c.* lws.c lws.i

Source
------

.. include::  lws.cob
   :code: cobolfree
>>END-IF

<!DOCTYPE html>
<html>
    <!-- GnuCOBOL libwebsocket demo -->
    <!-- Dedicated to the public domain -->
    <head>
        <meta charset="utf-8">
        <script src="https://ajax.googleapis.com/ajax/libs/jquery/3.2.1/jquery.min.js"></script>
        <script type="text/javascript">
            $(function () {
                window.WebSocket = window.WebSocket || window.MozWebSocket;

                var websocket = new WebSocket('ws://127.0.0.1:9000',
                                              'simple-protocol');

                websocket.onopen = function () {
                    $('h2').css('color', 'green');
                };

                websocket.onclose = function () {
                    $('h2').css('color', 'gold');
                };
                websocket.onerror = function () {
                    $('h2').css('color', 'red');
                };

                websocket.onmessage = function (message) {
                    console.log(message.data);
                    $('#replacement').append($('<p>', { text: message.data }));
                };

                $('button').click(function (e) {
                    e.preventDefault();
                    websocket.send($('input').val());
                });
            });
        </script>
    </head>
    <body>
        <h2>GnuCOBOL libwebsockets test</h2>
        <form>
            <input type="text" />
            <button>Send</button>
        </form>
        <p>Responses:</p>
        <div id="replacement"
             style="overflow:scroll; height:320px; width:180px;
                    border:2px dotted lightgray;">
        </div>
    </body>
</html>

prompt$ cobc -xj -g -w lws.cob -lwebsockets &
[1] 15978

prompt$
[2017/06/10 00:45:32:5409] NOTICE: Initial logging level 7
[2017/06/10 00:45:32:5413] NOTICE: Libwebsockets version: 2.2.0
btiffin@localhost.localdomain-v2.0.0-397-g3ec32b1
[2017/06/10 00:45:32:5415] NOTICE: IPV6 not compiled in
[2017/06/10 00:45:32:5416] NOTICE: libev support not compiled in
[2017/06/10 00:45:32:5418] NOTICE: libuv support not compiled in
[2017/06/10 00:45:32:5420] NOTICE:  Threads: 1 each 1024 fds
[2017/06/10 00:45:32:5422] NOTICE:  mem: platform fd map:  8192 bytes
[2017/06/10 00:45:32:5424] NOTICE:  Compiled with OpenSSL support
[2017/06/10 00:45:32:5426] NOTICE:  SSL disabled: no
LWS_SERVER_OPTION_DO_SSL_GLOBAL_INIT
[2017/06/10 00:45:32:5428] NOTICE: Creating Vhost 'default' port 9000, 2
protocols, IPv6 off
[2017/06/10 00:45:32:5431] NOTICE:  Listening on port 9000
[2017/06/10 00:45:32:5433] NOTICE:  mem: per-conn:          568 bytes +
protocol rx buf
[2017/06/10 00:45:32:5435] NOTICE:  canonical_hostname = localhost.localdomain
Starting server...
websocket reason: +0000000027

prompt$ seamonkey index.html

websocket reason: +0000000020
Connection established
Leaving server... tally at 00602
[2017/06/10 00:46:02:5814] NOTICE: lws_context_destroy: ctx 0xe24e00
Connection closed
websocket reason: +0000000028
[2017/06/10 00:46:02:5816] NOTICE: lws_context_destroy2: ctx 0xe24e00

prompt$
[1]+  Done                    cobc -xj -g -w lws.cob -lwebsockets

      *>
      *> xforms-chart.cob, demonstrate a bar chart
      *> Tectonics: cobc -xj xforms-chart.cob -lforms
      *>
       >>SOURCE FORMAT IS FREE
       identification division.
       program-id. sample.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       COPY xforms.

       01 argc                         usage binary-long.
       01 argv                         usage pointer.

       01 base-colour                  pic 999.

       01 form                         usage pointer.
       01 form-box                     usage pointer.

       01 chart-objects.
          05 chart-object              usage pointer occurs 4 times.

       01 items                        constant as 12.
       01 chart-items.
          05 chart-item                occurs items times.
             10 chart-name             pic x(16).
             10 chart-value            usage float-long.
             10 chart-colour           usage binary-long.

       01 exit-button                  usage pointer.
       01 form-button                  usage pointer.

       01 xforms-window                usage binary-long.
       01 xforms-display               usage pointer.

       01 close-callback               usage program-pointer.
       01 close-install-status         usage binary-long.

       procedure division.
       sample-main.

       call "CBL_GC_HOSTED" using argc "argc"
       call "CBL_GC_HOSTED" using argv "argv"

       call "fl_initialize" using argc argv z"XForms" NULL by value 0
           returning xforms-display
           on exception
               display
                   "Error: no XForms (-lforms)" upon syserr
               end-display
               goback
       end-call

      *> fill in some chart data
       move "Jan" to chart-name(1)
       move 23.23 to chart-value(1)

       move "Feb" to chart-name(2)
       move 42.42 to chart-value(2)

       move "Mar" to chart-name(3)
       move 64.64 to chart-value(3)

       move "Apr" to chart-name(4)
       move 13.13 to chart-value(4)

       move "May" to chart-name(5)
       move 84.84 to chart-value(5)

       move "Jun" to chart-name(6)
       move 66.66 to chart-value(6)

       move "Jul" to chart-name(7)
       move 77.77 to chart-value(7)

       move "Aug" to chart-name(8)
       move 12.12 to chart-value(8)

       move "Sep" to chart-name(9)
       move 55.55 to chart-value(9)

       move "Oct" to chart-name(10)
       move 99.99 to chart-value(10)

       move "Nov" to chart-name(11)
       move 42.42 to chart-value(11)

       move "Dec" to chart-name(12)
       move 66.66 to chart-value(12)

      *> let GnuCOBOL control image shutdown from system menu
       set close-callback to entry "xforms-close"
       if close-callback not equal null then
           call "fl_set_atclose" using
               by value close-callback
               by reference NULL
               returning close-install-status
       else
           display "XForms close will terminate program" upon syserr
       end-if

      *> Build a new form to demontrate the chart object
       call "fl_bgn_form" using by value FL-UP-BOX 320 270
           returning form
       
       call "fl_add_box" using
           by value FL-UP-BOX 0 0 320 270
           by reference NULL
           returning form-box

      *> Can be BAR, HORBAR, LINE, FILL, SPIKE, PIE or SPECIALPIE   
       call "fl_add_chart" using
           by value FL-BAR-CHART 5 5 310 200
           by reference "Bar chart"
           returning chart-object(1)
      *> call "fl_set_object_color" using
      *>     by value chart-object(1) FL-BLACK 0
      *> call "fl_set_chart_lcolor" using
      *>     by value chart-object(1) FL-WHITE

      *> stay safe with the incrementing colour range
       compute base-colour = random(form) * random() * 100
       if base-colour > 255 - items then
           compute base-colour = 255 - items
       end-if
       perform varying tally from 1 by 1 until tally > items
           compute chart-colour(tally) = tally + base-colour
           if chart-colour(tally) = FL-BLACK then
               move FL-WHITE to chart-colour(tally)
           end-if
           call "fl_add_chart_value" using
               by value chart-object(1)
               by value chart-value(tally)
               by reference
                   concatenate(trim(chart-name(tally) trailing), x"00")
               by value chart-colour(tally)
       end-perform
      
       call "fl_add_button" using
           by value FL-NORMAL-BUTTON 110 230 80 30
           by reference z"Exit"
           returning exit-button

       call "fl_end_form" returning omitted 

       call "fl_show_form" using
           by value form FL-PLACE-CENTER FL-TRANSIENT
           by reference "Charts"
           returning xforms-window

       call "fl_do_forms" returning form-button
       
       call "fl_finish" returning omitted 
       goback.

       end program sample.
      *> ***************************************************************

      *> Give process rundown control to GnuCOBOL
       identification division.
       program-id. xforms-close.

       environment division.
       configuration section.
       special-names.
           call-convention 0 is extern.
   
       data division.
       working-storage section.
       01 FL-IGNORE constant as -1.

       linkage section.
       01 xform usage pointer.
       01 close-data usage pointer.

       procedure division extern using
           by value xform close-data.

      *> IGNORE close or just stop run, otherwise XForms calls exit()
       move FL-IGNORE to return-code
       stop run.

       end program xforms-close.
     *> ***************************************************************

      *>
      *> xforms-clock.cob, demonstrate some clock objects
      *> Tectonics: cobc -xj xforms-clock.cob -lforms
      *>
       >>SOURCE FORMAT IS FREE
       identification division.
       program-id. sample.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.

       COPY xforms.

       01 argc                         usage binary-long.
       01 argv                         usage pointer.

       01 form                         usage pointer.
       01 form-box                     usage pointer.
       01 clock-forms.
          05 clock-form                usage pointer occurs 4 times.
       01 exit-button                  usage pointer.
       01 form-button                  usage pointer.

       01 xforms-window                usage binary-long.
       01 xforms-display               usage pointer.

       01 close-callback               usage program-pointer.
       01 close-install-status         usage binary-long.

       01 hour                         usage binary-long.
       01 minute                       usage binary-long.
       01 second                       usage binary-long.
       01 show-hour                    pic 99.
       01 show-minute                  pic 99.
       01 show-second                  pic 99.

       procedure division.
       sample-main.
       call "CBL_GC_HOSTED" using argc "argc"
       call "CBL_GC_HOSTED" using argv "argv"

       call "fl_initialize" using argc argv z"XForms" NULL by value 0
           returning xforms-display
           on exception
               display
                   "Error: no XForms (-lforms)" upon syserr
               end-display
               goback
       end-call

      *> let GnuCOBOL control image shutdown from system menu
       set close-callback to entry "xforms-close"
       if close-callback not equal null then
           call "fl_set_atclose" using
               by value close-callback
               by reference NULL
               returning close-install-status
       else
           display "XForms close will terminate program" upon syserr
       end-if

       call "fl_bgn_form" using by value FL-UP-BOX 460 350
           returning form
       
       call "fl_add_box" using
           by value FL-UP-BOX 0 0 460 350
           by reference NULL
           returning form-box
   
       call "fl_add_clock" using
           by value FL-ANALOG-CLOCK 5 5 220 200
           by reference "Analog with seconds"
           returning clock-form(1)
      
       call "fl_add_clock" using
           by value FL-ANALOG-CLOCK 280 55 110 100
           by reference "Analog without seconds"
           returning clock-form(2)

      *> local patch
       call "fl_set_clock_hide_seconds" using
           by value clock-form(2) 1
           on exception continue
       end-call

       call "fl_add_clock" using
           by value FL-DIGITAL-CLOCK 65 240 100 35
           by reference "Digital with seconds"
           returning clock-form(3)
       call "fl_set_object_color" using
           by value clock-form(3) FL-COL1 FL-BLACK

       call "fl_add_clock" using
           by value FL-DIGITAL-CLOCK 290 240 100 35
           by reference "Digital am/pm"
           returning clock-form(4)
       call "fl_set_clock_hide_seconds" using
           by value clock-form(4) 1
           on exception continue
       end-call

       call "fl_set_clock_ampm" using
           by value clock-form(4) 1
       call "fl_set_object_color" using
           by value clock-form(4) FL-COL1 FL-BLACK
       call "fl_set_object_lsize" using
           by value clock-form(4) FL-MEDIUM-SIZE
       call "fl_set_object_lstyle" using 
           by value clock-form(4) FL-BOLD-STYLE

       call "fl_add_button" using
           by value FL-NORMAL-BUTTON 190 300 80 30
           by reference z"Exit"
           returning exit-button

       call "fl_end_form" returning omitted 

       call "fl_show_form" using
           by value form FL-PLACE-MOUSE FL-TRANSIENT
           by reference "Clocks"
           returning xforms-window
       call "fl_do_forms" returning form-button
       
       call "fl_get_clock" using
           by value clock-form(1)
           by reference hour minute second
       move hour to show-hour
       move minute to show-minute
       move second to show-second
       display "Exited at: " show-hour ":" show-minute ":" show-second

       call "fl_finish" returning omitted 
       goback.

       end program sample.
      *> ***************************************************************

      *> Give process rundown control to GnuCOBOL
       identification division.
       program-id. xforms-close.

       environment division.
       configuration section.
       special-names.
           call-convention 0 is extern.
   
       data division.
       working-storage section.
       01 FL-IGNORE constant as -1.

       linkage section.
       01 xform usage pointer.
       01 close-data usage pointer.

       procedure division extern using
           by value xform close-data.

      *> IGNORE close or just stop run, otherwise XForms calls exit()
       move FL-IGNORE to return-code
       stop run.

       end program xforms-close.
     *> ***************************************************************

repository.
       function agar-window
       function agar-windowshow
       function agar-zoom
       function agar-setevent
       function agar-eventname
       function agar-setevent-with-field
       function agar-eventloop
       function agar-box
       function agar-label
       function agar-button
       function agar-checkbox
       function agar-textbox
       function agar-combo
       function agar-close-datasource
       function agar-console
       function agar-consolemsg
       function agar-dirdlg
       function agar-editable
       function agar-execute
       function agar-filedlg
       function agar-fixed
       function agar-fixed-put
       function agar-fixed-del
       function agar-fixed-size
       function agar-fixed-move
       function agar-fixedplotter
       function agar-fixedplottercurve
       function agar-fixedplotterdatum
       function agar-fontselector
       function agar-bindvariable
       function agar-get-error
       function agar-get-error-pic
       function agar-graph
       function agar-graphvertex
       function agar-graphvertex-label
       function agar-graphvertex-position
       function agar-graphedge
       function agar-graphedge-label
       function agar-hsvpal
       function agar-kill-process
       function agar-menu
       function agar-menunode
       function agar-menuaction
       function agar-mpane
       function agar-netsocket
       function agar-netsocketfree
       function agar-netsocketset
       function agar-netsocketset-add
       function agar-netsocketset-first
       function agar-netsocketset-next
       function agar-netpoll
       function agar-netresolve
       function agar-netconnect
       function agar-netbind
       function agar-netaccept
       function agar-netclose
       function agar-netread
       function agar-netread-pic
       function agar-netwrite
       function agar-netwrite-pic
       function agar-notebook
       function agar-notebook-add
       function agar-numerical
       function agar-open-core
       function agar-open-core-pic
       function agar-open-file
       function agar-open-filehandle
       function agar-open-netsocket
       function agar-pane
       function agar-pixmap
       function agar-pixmap-file
       function agar-pixmap-surface
       function agar-pixmap-surface-scaled
       function agar-progressbar
       function agar-radio
       function agar-scrollview
       function agar-separator
       function agar-set-style
       function agar-slider
       function agar-socket
       function agar-static-icon
       function agar-table
       function agar-timer
       function agar-tlist-add
       function agar-treetbl
       function agar-read
       function agar-read-pic
       function agar-read-at
       function agar-read-at-pic
       function agar-wait-on-process
       function agar-widget-focus
       function agar-widget-unfocus
       function agar-write
       function agar-write-pic
       function agar-write-at
       function agar-write-at-pic

/*
  Author: Brian Tiffin
  Dedicated to the public domain

  Date started: August 2018
  Modified: 2018-08-09/17:42-0400 btiffin

  Tectonics:
    gcc [-D AGAR] -o gcv gcv.c
    export CFLAGS
    ./gcv expression includefiles spec

*/

/* gcv, Get C Value, given an expression, include files and spec */
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <unistd.h>

int
main(int argc, char** argv)
{

    int rc;
    int i;
    FILE *tmpfile;
    char leader;
    char opt;
    char *datatype;  /* the printf spec (without percent) for output handling */

    if (argc > 1 && (!strcmp(argv[1], "-h") || !strcmp(argv[1], "--help"))) {
        printf("Usage: gcv 'expression' [includes...] [-V|-C|-E|-'spec']\n");
        printf("  compile a C fragment and print the value given a printf spec\n");
        printf("  include as many headers as it takes to resolves symbols\n");
        printf("  last argument can be -V, -C, -E, or -spec or %%c-of-spec\n");
        printf("\n");
        printf("  -v, --version and -h, --help also supported\n");
        printf("\n");
        printf("  Relies on exported CFLAGS to manage include file search path\n");
        return 0;
    }
    if (argc > 1 && (!strcmp(argv[1], "-v") || !strcmp(argv[1], "--version"))) {
        printf("gcv version 0.3 Aug 2018\n");
        return 0;
    }
    /* Remain silent on no args as this is paired with commands.sed for substitution */
    if (argc < 2) return 0;

    /* if not help, then treat last option as the style or printf spec, default %d */
    leader = argv[argc-1][0];
    opt = argv[argc-1][1];
    datatype = "%d";
    if (leader == '-'&& (opt != 'V' && opt != 'C' && opt != 'E')) { datatype = &argv[argc-1][1]; }
    if (leader == '%') { datatype = &argv[argc-1][0]; }

    /* create a small C program */
    tmpfile = fopen("gcv.tmp.c", "w");
    if (tmpfile) {

        /* transform underscores in names to dashes */
        char *underdash = strdup(argv[1]);
        for (char* current_pos = underdash; (current_pos = strchr(underdash, '_')) != NULL; *current_pos = '-');

        /* extra arguments are include files to load to get at symbols */
        for (i = 2; i < argc; i++) {
            if (argv[i] && strcmp(argv[i], "stdio.h") &&
                strcmp(argv[i], "stddef.h") &&
#ifdef AGAR
                strcmp(argv[i], "agar/core.h") &&
                strcmp(argv[i], "agar/gui.h") &&
#endif
                argv[i][0] != '-' && argv[i][0] != '%') {
                fprintf(tmpfile, "%s%s%s", "#include \"", argv[i], "\"\n");
            }
        }
        fprintf(tmpfile, "%s", "#include <stdio.h>\n");
        fprintf(tmpfile, "%s", "#include <stddef.h>\n");
#ifdef AGAR
        fprintf(tmpfile, "%s", "#include \"agar/core.h\"\n");
        fprintf(tmpfile, "%s", "#include \"agar/gui.h\"\n\n");
#endif
        fprintf(tmpfile, "%s", "int main(int argc, char** argv) {\n");

        if (leader == '-' && opt == 'C') {
            fprintf(tmpfile, "    %s%s%s%s%s", "printf(\"01 %s%d%s\", \"", underdash, " constant as \", (int)(", argv[1], "), \".\\n\");\n");
        } else if (leader == '-' && opt == 'V') {
            fprintf(tmpfile, "    %s%s%s%s%s", "printf(\"   05 %s%d%s\", \"", underdash, " usage binary-long value \", (int)(", argv[1], "), \".\\n\");\n");
        } else {
            fprintf(tmpfile, "    %s%s%s%s%s", "printf(\"", datatype, "\", ", argv[1], ");\n");
        }
        fprintf(tmpfile, "%s", "}\n");

        free(underdash);
    }

    rc = fclose(tmpfile);
    if (!rc) {
        if (leader == '-' && opt == 'E') {
            rc = system("cat gcv.tmp.c");
            rc = system("echo gcc \"$CFLAGS\" -o gcv.tmp gcv.tmp.c");
            rc = system("gcc $CFLAGS -o gcv.tmp gcv.tmp.c");
        } else {
            rc = system("gcc -w $CFLAGS -o gcv.tmp gcv.tmp.c");
        }
        if (!rc) {
            rc = system("./gcv.tmp");
        }
    }

    /* only leave generated sources around with -E echo */
    if (leader != '-' || opt != 'E') {
        rc = unlink("./gcv.tmp.c");
    }
    rc = unlink("./gcv.tmp");
    return rc;
}

prompt$ export CFLAGS='-I/usr/local/include -I/usr/local/include/agar'
prompt$ ./gcv AG_WINDOW_FADEIN agar/core.h agar/gui.h
134217728prompt$

prompt$ ./gcv AG_WINDOW_FADEIN agar/core.h agar/gui.h -C
01 AG-WINDOW-FADEIN constant as 134217728.

prompt$ ./gcv AG_WINDOW_FADEIN agar/core.h agar/gui.h -'0x%08X'
0x08000000

prompt$ sed -re 's/(ls)/\1/e'
This is not replaced
ls
that was.

# Date started: August 2018
# Modified: 2018-08-14/18:23-0400 btiffin
#
# commands.sed, markup command substitution
# Dedicated to the public domain
#
# Tectonics:
#    Needs local copy of gcv.c compiled and ready in current working dir
#    sed -rf commands.sed [inputfiles]

# Replace #indent prog params# with the captured output indented 4 spaces
s%#indent ([^ ]*)[ ]?([^ ]*)[ ]?([^ ]*)[ ]?([^ ]*)[ ]?(.*)#%\1 \2 \3 \4 \5 | sed 's/^/    /'%e

# Replace #command prog params# with the captured output
s%#command ([^ ]*)[ ]?([^ ]*)[ ]?([^ ]*)[ ]?([^ ]*)[ ]?(.*)#%\1 \2 \3 \4 \5%e

# Replace include file constants, enums, and C expressions
s#(.*)\[\[symbol[ ]?(.*)[ ]?(.*)\]\](.*)#printf "%s%s%s" "\1" "$(./gcv \2 \3)" "\4"#e

# Replace include file constants, enums, and C expressions wrapped in single quotes
s#(.*)\[\[eval[ ]?'(.*)'[ ]?(.*)\]\](.*)#printf "%s%s%s" "\1" "$(./gcv "\2" \3)" "\4"#e

# Output suitable for replacement in COBOL source
s#(.*)\[\[constant[ ]?(.*)[ ]?(.*)\]\](.*)#printf "%s%s%s" "\1" "$(./gcv \2 \3 -C)" "\4"#e
s#(.*)\[\[value[ ]?(.*)[ ]?(.*)\]\](.*)#printf "%s%s%s" "\1" "$(./gcv \2 \3 -V)" "\4"#e

# Non gcv shell replacement
s#(.*)\[\[shell[ ]?([^ ]*)[ ]?'(.*)'[ ]?\]\](.*)#printf "%s%s%s" "\1" "$("\2" "\3")" "\4"#e

01 C-SIZEOF-FILE constant as [[eval 'sizeof(FILE)']].
01 FILE-STRUCTURE PIC X(C-SIZEOF-FILE) BASED.

prompt$ sed -rf commands.sed program.gcv

01 C-SIZEOF-FILE constant as 216.
01 FILE-STRUCTURE PIC X(C-SIZEOF-FILE) BASED.

prompt$ sed -rf commands.sed program.gcv >program.cob
prompt$ cobc -xj program.cob

      *>
      *> Simple windowed application
      *> Tectonics:
      *>   cobc -xj swapp.cob cobweb-agar.cob `agar-config --libs`
      *>
       >>SOURCE FORMAT IS FIXED
       identification division.
       program-id. swapp.

       environment division.
       configuration section.
       repository.
           function agar-window
           function agar-box
           function agar-label
           function agar-button
           function agar-windowshow
           function agar-eventloop
           function all intrinsic.

       data division.
       working-storage section.
       01 window-positions.
          05 AG-WINDOW-CENTER          usage binary-long value 5.

       01 AG-NOFLAGS                   usage binary-long value 0.
       01 AG-WINDOW-SHOW               usage binary-long value 1.

       01 AG-BOX-HORIZ                 usage binary-long value 0.
       01 AG-BOX-EXPAND                usage binary-long value 6.

       01 AG-LABEL-EXPAND              usage binary-long value 3.

       01 agar-window-record.
          05 agar-win usage pointer.
    
       01 agar-box-record.
          05 agar-box-widget usage pointer.
    
       01 agar-label-record.
          05 agar-label-widget usage pointer.

       01 agar-button-record.
          05 agar-button-widget usage pointer.

       01 rc usage binary-long.

       01 total-clicks-plural.
          05 total-click-display.
             10 value "There have been ".
             10 total-clicks pic 9(6).
             10 value " click".
          05 value "s ".

       linkage section.
       01 event usage pointer.

       procedure division.
       simple-main.

       move agar-window(AG-WINDOW-CENTER, numval(280), numval(32),
                        "Click counter") to agar-window-record

       move agar-box(agar-win, AG-BOX-HORIZ, AG-BOX-EXPAND)
         to agar-box-record

       move agar-label(agar-box-widget, AG-LABEL-EXPAND,
            "There have been no clicks yet") to agar-label-record

       move agar-button(agar-box-widget, AG-NOFLAGS, "click me",
                        "upclick", "buttonname", numval(1))
         to agar-button-record

       move agar-windowshow(agar-win, AG-WINDOW-SHOW) to rc
       move agar-eventloop to rc

       goback.

      *> internal entry point for event callback
       entry "upclick" using by value event.
           add 1 to total-clicks
           if total-clicks equal 1
               *> tweaking a literal for sake of grammar and spelling
               inspect total-click-display
                   replacing all "have" by "has "
               call "AG_LabelTextS" using
                   by value agar-label-widget
                   by content concatenate(total-click-display, x"00")
                   returning omitted
               end-call
               inspect total-click-display
                   replacing all "has " by "have"
           else
               call "AG_LabelTextS" using
                   by value agar-label-widget
                   by content concatenate(total-clicks-plural, x"00")
                   returning omitted
               end-call
           end-if

       goback.
       end program swapp.

COPY screenio.

01  mouse-flags PIC 9(4).

...

    COMPUTE mouse-flags = COB-AUTO-MOUSE-HANDLING
                        + COB-ALLOW-LEFT-DOWN
                        + COB-ALLOW-MIDDLE-DOWN
                        + COB-ALLOW-RIGHT-DOWN

    SET ENVIRONMENT "COB_MOUSE_FLAGS" TO mouse-flags.

Environment name: COB_MOUSE_FLAGS
Parameter name: mouse_flags
Purpose: specify which mouse events will be sent as function key
to the application during ACCEPT and how they will be handled
Type: int (by bits)
Default: 1
Note: 0 disables the mouse cursor, any other value enables it,
any value containing 1 will enable internal handling (click
to position, double-click to enter).
See copy/screenio.cpy for list of events and their values.
Alias: MOUSE_FLAGS
Example: 11 (enable internal handling => 1, left press => 2,
double-click => 8; 1+2+8=11)

Environment name: COB_MOUSE_INTERVAL
Parameter name: mouse_interval
Purpose: specifies the maximum time (in thousands of a second)
that can elapse between press and release events for them to be
recognized as a click.
Type: int (0 - 166)
Default: 100
Note: 0 disables the click resolution (instead press + release
are recognized), also disables positioning by mouse click

SPECIAL-NAMES.
   CURSOR IS data-name.   *> where data-name is PIC 9(4) or 9(6).

I write this note to thank everyone involved with GnuCOBOL and to
encourage their continued progress.

We became involved with a project earlier this year that required us to
become familiar with the provisioning and day-to-day operation of a High
Performance Computing Cluster (HPCC).

When delivered the cluster will have several thousand cores. We built a
test bed with 124 cores to gain experience before going live.

The project is entirely open source. We are using CentOS as the operating
system, Warewulf (Lawrence Berkeley National Laboratory) as the
provisioner, and Slurm (Lawrence Livermore National Laboratory) as the
job scheduler.

We wanted a long running chore that could be run in a parallel manner. We
needed to learn about bottlenecks, failures, and the care and feeding of
jobs that run on many processors for many months.

The application that we chose to use was computing prime numbers because
of it's relative simplicity and embarrassingly parallel nature.

We used GnuCOBOL as the application language. As we know it generates C
code so the arithmetic functions should be pretty fast.

We compute primes in groups of one billion (10^9) and store the results on
5TB USB drives.

Today we are computing in the range slightly above 1,430,000,000,000,000
and have consumed about 34TB of storage.

GnuCOBOL has performed like a champ.

Once again please accept our thanks.

jimc

As of November 30, 2015 we are working on the numbers above
1,600,000,000,000,000.

GnuCOBOL tells us that the lowest prime in the block of one billion numbers
below the 1.6 number above is 1,599,999,000,000,041 and that the average gap
between prime numbers in that block is (believe it or not) only 35. Even at
this number there are 28,559,866 primes within the block of one billion.

We plan to continue storing the primes up to 1,699,999,999,999,999 so that
we can realize the maximal prime gap 1,131
(https://primes.utm.edu/notes/GapsTable.html). After that the storage
requirements increase by powers of 10 and that will cost some real money.

Even though we will stop storing the primes we plan to continue computing
them and then analyzing each group of a billion.

jimc

As of April 9, 2016 we are working on the numbers above 7,074,943,000,000,000.

We have 118 cores dedicated to the chore. They have been running over 21 days
without a computational, network, or hardware error.

What a great product GnuCOBOL is.

the lowest prime is 11,000,000,000,000,003
the highest prime is 11,000,000,999,999,081
there are 27,078,841 primes
the largest gap between primes is 546
the average gap between primes is 36
there are 967,954 twin primes (separated by two)

extern proc SAMPLE(): int;

SAMPLE();

*> PURPOSE
*>   Chapel calling COBOL.
*> TECTONICS
*>   cobc -fimplicit-init -c hello.cob -g -debug
*>   chpl cobol.chpl hello.o -lcob
 identification division.
 program-id. SAMPLE.

 procedure division.
 display "Hello, chapel" end-display
 goback.
 end program SAMPLE.

prompt$ cobc -fimplicit-init -c hello.cob -g -debug
prompt$ chpl cobol.chpl hello.o -lcob
In file included from /usr/include/sys/types.h:25:0,
   from /home/btiffin/inst/langs/chapel/chapel-1.11.0/runtime//include/sys_basic.h:75,
   from /tmp/chpl-btiffin-23559.deleteme/chpl__header.h:4,
   from /tmp/chpl-btiffin-23559.deleteme/_main.c:1:
/usr/include/features.h:148:3: warning: #warning "_BSD_SOURCE and _SVID_SOURCE
   are deprecated, use _DEFAULT_SOURCE" [-Wcpp]
 # warning "_BSD_SOURCE and _SVID_SOURCE are deprecated, use _DEFAULT_SOURCE"
   ^
In file included from /tmp/chpl-btiffin-23559.deleteme/_main.c:30:0:
/tmp/chpl-btiffin-23559.deleteme/cobol.c: In function ‘chpl__init_cobol’:
/tmp/chpl-btiffin-23559.deleteme/cobol.c:14:1: warning:
    implicit declaration of function ‘SAMPLE’ [-Wimplicit-function-declaration]
 SAMPLE();
 ^

prompt$ ./a.out
Hello, chapel

 extern "C" {
     wondertype awesomefunction(superdata input) {
         earthshatteringcpluplus_code
     }
}

cd ~/lang/cobol/

cd $HOME
mkdir gcfaq/tutorial
cd gcfaq/tutorial

      *>
      *> hello.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. hello.

       procedure division.
       display "Hello, world"
       goback.

       end program hello.

Counting columns in a line of COBOL source text (historically important)
IGNORE the first 6 colums
      Indicator column is column 7.  * for comments, - for continuation, others
      |A margin starts in column 8, all "real" source code starts here
      ||   B margin starts in column 12, but B margin is now deemed OBSOLETE
      ||   |       (Columns 73-80 are ignored, just like the first 6)   IGNORE..
      ||   |                                                            |
      || 1 |       2         3         4         5         6         7  |      8
123456*89012345678901234567890123456789012345678901234567890123456789012XXXXXXXX

      * Comment line, the asterisk HAS to be in column 7
      *> New standard "to end of line" comment
      *> Can be anywhere past any FIXED form "A" margin

cobc -x hello.cob

prompt$ cobc -x hello.cob

./hello

prompt$ ./hello
Hello, world

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
GCOBOL*>-<*                                                             
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      *>
      *> Date started: January 2017
      *> Modified: 2017-02-02/17:22-0500 btiffin
      *>
      *> Tectonics:
      *>   cobc -x hello.cob
      *>   ./hello
      *>+<*
      *>
      *> hello.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. hello.

       procedure division.
       display "Hello, world"
       goback.

       end program hello.

        DISPLAY "Hello, world".

prompt$ cobc -x -frelax-syntax hello-oneliner.cob
hello-oneliner.cob: 1: warning: PROGRAM-ID header missing - assumed
hello-oneliner.cob: 1: warning: PROCEDURE DIVISION header missing - assumed

prompt$ ./hello-oneliner
Hello, world

I Enter Data Properly

      *>
      *> hello-wrong-order.cob, GnuCOBOL FAQ tutorial error example
      *> This program will NOT compile properly, divisions out of order
      *>
       procedure division.
       display "Hello, world"
       goback.

       identification division.
       program-id. hello-wrong.

       end program hello-wrong.

prompt$ cobc -x hello-wrong-order.cob
hello-wrong-order.cob: 15: error: PROGRAM-ID header missing

I Enter Data Properly
I E D P

IDENTIFICATION
ENVIRONMENT
DATA
PROCEDURE

      *>
      *> hello-missing-period.cob, GnuCOBOL FAQ tutorial error
      *> This program will NOT compile, missing a full stop after
      *>  IDENTIFICATION DIVISION
      *>
       identification division
       program-id. hello-missing.

       procedure division.
       display "Hello, world"
       goback.

       end program hello-missing.

prompt$ cobc -x hello-missing-period.cob
hello-missing-period.cob: 17: error: syntax error, unexpected PROGRAM-ID, expecting .

01 CUSTOMER-NAME        PIC X(40).
01 ITEMS-PURCHASED      PIC 999999.

      *>
      *> simple-data.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. simple-data.

       data division.
       working-storage section.
       01 program-message      PIC X(64).
       01 answer               PIC 99.

       procedure division.

       move "simple-data.cob example" to program-message
       display program-message

       move "compute 6 times 7" to program-message
       display program-message

       move "answer is:" to program-message
       display program-message

       compute answer = 6 * 7.
       display answer

       goback.
       end program simple-data.

prompt$ cobc -x -j simple-data.cob
simple-data.cob example                                         
compute 6 times 7                                               
answer is:                                                      
42

prompt$ ./simple-data
simple-data.cob example                                         
compute 6 times 7                                               
answer is:                                                      
42

prompt$ ./simple-data | tr ' ' '.'
simple-data.cob.example.........................................
compute.6.times.7...............................................
answer.is:......................................................
42

123456*89012345678901234567890123456789012345678901234567890123456789012

000100*  This is a comment line
000200 IDENTIFICATION DIVISION.
000300 ...

      *>
      *> just-if.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. just-if.

       data division.
       working-storage section.
       01 result               pic 999.

       procedure division.

       multiply 6 by 7 giving result

       if result is less than 100 then
           display "The ultimate answer seems reasonable: " result
       end-if

       if result is greater than or equal to 100 then
           display "There is something wrong with the universe: " result
       end-if

       goback.
       end program just-if.

prompt$ cobc -free -x -j just-if.cob
The ultimate answer seems reasonable: 042

      *>
      *> just-if-symbols.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. just-if-symbols.

       data division.
       working-storage section.
       01 result               pic 999.

       procedure division.

       compute result = 6 * 7

       if result < 100 then
           display "The ultimate answer seems reasonable: " result
       end-if

       if result > 100 then
           display "There is something wrong with the universe: " result
       end-if

       goback.
       end program just-if-symbols.

prompt$ cobc -free -x -j just-if-symbols.cob
The ultimate answer seems reasonable: 042

*>
*> just-if-free.cob, GnuCOBOL FAQ tutorial FORMAT FREE example
*>
identification division.
program-id. just-if-free.

data division.
working-storage section.
01 result               pic 999.

procedure division.

multiply 6 by 7 giving result

if result is less than 100 then
    display "The ultimate answer seems reasonable: " result
end-if

if result is greater than 100 then
    display "There is something wrong with the universe: " result
end-if

goback.
end program just-if-free.

prompt$ cobc -free -x -j just-if-free.cob
The ultimate answer seems reasonable: 042

prompt$ cobc -x -j just-if-free.cob
just-if-free.cob: 2: error: invalid indicator 'h' at column 7
just-if-free.cob: 3: error: invalid indicator 'i' at column 7
just-if-free.cob: 5: error: invalid indicator 'e' at column 7
just-if-free.cob: 6: error: invalid indicator 'i' at column 7
just-if-free.cob: 8: error: invalid indicator 't' at column 7
just-if-free.cob: 9: error: invalid indicator 'o' at column 7
just-if-free.cob: 13: error: invalid indicator 't' at column 7
just-if-free.cob: 15: error: invalid indicator 'f' at column 7
just-if-free.cob: 16: error: invalid indicator 'm' at column 7
just-if-free.cob: 18: error: invalid indicator 'i' at column 7
just-if-free.cob: 19: error: invalid indicator 'g' at column 7
just-if-free.cob: 20: error: invalid indicator 'u' at column 7
just-if-free.cob: 22: error: invalid indicator 'u' at column 7
just-if-free.cob: 24: error: invalid indicator 'l' at column 7
just-if-free.cob: 26: error: invalid indicator 'u' at column 7
just-if-free.cob: 27: error: invalid indicator 's' at column 7
just-if-free.cob: 30: error: invalid indicator 'u' at column 7
just-if-free.cob: 31: error: invalid indicator 's' at column 7
just-if-free.cob: 34: error: invalid indicator '.' at column 7
just-if-free.cob: 35: error: invalid indicator 'o' at column 7
just-if-free.cob: 36: error: PROGRAM-ID header missing

>>SOURCE FORMAT IS FREE

*>GCOB >>SOURCE FORMAT IS FREE
      *>-<*
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      *>
      *> Date started: January 2017
      *> Modified: 2017-01-29/17:28-0500
      *>
      *> Tectonics:
      *>   cobc -x just-if.cob
      *>   ./just-if
      *>+<*
      *>
      *> just-if.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. just-if.

       data division.
       working-storage section.
       01 result               pic 999.

       procedure division.

       multiply 6 by 7 giving result

       if result is less than 100 then
           display "The ultimate answer seems reasonable: " result
       end-if

       if result is greater than 100 then
           display "There is something wrong with the universe: " result
       end-if

       goback.
       end program just-if.

      *>
      *> ifelse.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. ifelse.

       data division.
       working-storage section.
       01 result               pic 99.

       procedure division.

       multiply 6 by 7 giving result

       if result equals 42 then
           display "The ultimate answer is still " result
       else
           display "There is something wrong with the universe: " result
       end-if

       goback.
       end program ifelse.

prompt$ cobc -xj ifelse.cob
The ultimate answer is still 42

The ultimate answer is still 42

      *>
      *> performing.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. performing.

       data division.
       working-storage section.
       01 counter              pic 9   value 1.

       procedure division.

      *> normal flow starts here
       display counter
 
      *> then branches to a procedure, then returns back
       perform increment-counter
    
      *> and carries on with the next line
       display counter

      *> then we return to the caller, in this case the operating system
       goback.

      *> a named paragraph 
       increment-counter.
           add 1 to counter
       .

       end program performing.

prompt$ cobc -xj performing.cob
1
2

      *>
      *> going.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. going.

       data division.
       working-storage section.
       01 counter              pic 9   value 1.

       procedure division.

      *> normal flow starts here
       display counter
 
      *> then jumps
       go to the-bottom
    
      *> this is dead code, never executed
       display "Why am I even here?"

      *> the following full stop is required so that GnuCOBOL
      *> knows that this part of the program is terminated and to allow
      *> the next named paragraph to be recognized.
       .

      *> a named paragraph 
       the-bottom.
           display "Jumped to the-bottom"

           *> return to the caller, in this case the operating system
           goback.

       end program going.

prompt$ cobc -xj going.cob
1
Jumped to the-bottom

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
*>GCOB*>-<*
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      *>
      *> Date started: January 2017
      *> Modified: 2018-07-21/03:27-0400 btiffin
      *>
      *> Tectonics:
      *>   cobc -x going.cob
      *>   ./going
      *>+<*
      *>
      *> going.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. going.

       data division.
       working-storage section.
       01 counter              pic 9   value 1.

       procedure division.

      *> normal flow starts here
       display counter
 
      *> then jumps
       go to the-bottom
    
      *> this is dead code, never executed
       display "Why am I even here?"

      *> the following full stop is required so that GnuCOBOL
      *> knows that this part of the program is terminated and to allow
      *> the next named paragraph to be recognized.
       .

      *> a named paragraph 
       the-bottom.
           display "Jumped to the-bottom"

           *> return to the caller, in this case the operating system
           goback.

       end program going.

prompt$ cobc -x going.cob -Wunreachable
going.cob: 31: warning: unreachable statement 'DISPLAY'

*>GCOB*>-<*
      *> Author: Brian Tiffin
      *> Dedicated to the public domain
      *>
      *> Date started: January 2017
      *> Modified: 2017-01-30/01:15-0500
      *>
      *> Tectonics:
      *>   cobc -x evaluating.cob
      *>   ./evaluating
      *>+<*
      *>
      *> evaluating.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. evaluating.

       data division.
       working-storage section.
       01 first-field           pic 9.
       01 second-field          pic X.

       procedure division.

       move 1 to first-field
       move "C" to second-field

      *> inside a when conditional, the subject need not be mentioned
       evaluate first-field also second-field
           when = 1         also = "A"
               display "1A"
           when = 1         also = "B"
               display "1B"
           when = 1         also = "C"
               display "1C"
               display "This is the when block that executes"
           when = 1         also any
               display "This is also true, but the first one wins"
           when other
               perform no-matches
       end-evaluate

       goback.

       no-matches.
           display "No matches found: " first-field ", " second-field
       .
       end program evaluating.

cobc -xj evaluating.cob

prompt$ cobc -xj evaluating.cob
1C
This is the when block that executes

WHEN = 1 also = "A"

IF (first-test = 1) AND (second-test = "A")

WHEN = 1 ALSO = "A" THRU "Z"

      *>
      *> goloop.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. goloop.

       data division.
       working-storage section.
       01 counter              pic 9   value 1.

       procedure division.

       loop-here.

           display counter
           add 1 to counter
           if counter < 4 then GO TO loop-here end-if
       .

       goback.
       end program goloop.

prompt$ cobc -xj goloop.cob
1
2
3

while condition do loop-block
do loop-block until condition

perform paragraph-label until condition

perform until condition loop-block

perform varying identifer from n by step until condition

pre-condition
while condition do loop-block

      *>
      *> perform-loop.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. perform-loop.

       data division.
       working-storage section.
       01 counter              pic 9   value 1.

       procedure division.

      *> normal flow starts here
       display counter
 
      *> loop using a procedure subroutine
       perform increment-counter until counter > 7
    
      *> show the result
       display counter

      *> return to the to the operating system
       goback.

      *> a named paragraph 
       increment-counter.
           add 1 to counter
       .

       end program perform-loop.

cobc -xj perform-loop.cob

prompt$ cobc -xj perform-loop.cob
1
8

      *>
      *> perform-loop-infinite.cob, infinite loop error
      *>
       identification division.
       program-id. perform-loop-infinite.

       data division.
       working-storage section.
       01 counter              pic 9   value 1.

       procedure division.

       display counter
 
      *> loop will never terminate, counter limited to max of nine.
       perform increment-counter until counter > 10
    
      *> show the result, which will never happen
       display counter

      *> return to the to the operating system, never happens
       goback.

      *> this add could have an ON SIZE ERROR clause
       increment-counter.
           add 1 to counter
       .

      *> this program will need operator intervention
       end program perform-loop-infinite.

      *>
      *> inline-perform.cob, GnuCOBOL FAQ tutorial
      *>
       identification division.
       program-id. inline-perform.

       data division.
       working-storage section.
       01 counter              pic 99.

       procedure division.

      *> an inline perform loop
       perform varying counter from 1 by 1 until counter > 10
           display counter
       end-perform

      *> return to the to the operating system
       goback.
       end program inline-perform.

cobc -xj inline-perform.cob

prompt$ cobc -xj inline-perform.cob
01
02
03
04
05
06
07
08
09
10

Address: 00 01 02 03
  value: 0A 0B 0C 0D

Address: 00 01 02 03
  value: 0D 0C 0B 0A

By default, data items of usage binary or comp are stored in the big-endian
form. On those machines whose native byte order is little-endian, this is not
quite efficient.

If you prefer, you can store binary items in the native form of your machine.
Set the config option binary-byteorder to native in your config file

In addition, setting the option binary-size to 2-4-8 or 1-2-4-8 is more
efficient than others.

CONFIGURATION SECTION.
SPECIAL-NAMES.
CURRENCY SIGN IS "#".

/* set/get errno */

#include <errno.h>

int reset_errno() {
    errno = 0;
    return errno;
}

int get_errno() {
    return errno;
}
/**/

$ cobc -c geterrno.c
$ cobc -x program.cob geterrno.o

CALL "reset_errno" END-CALL
MOVE FUNCTION SQRT(-1) TO root
CALL "get_errno" RETURNING result END-CALL
IF result NOT EQUAL ZERO
   CALL "perror" USING NULL RETURNING OMITTED END-CALL
END-IF

Numerical argument out of domain

$ info gdb for the details.

GCobol >>SOURCE FORMAT IS FREE
      *> ***************************************************************
      *>****p* samples/readlen
      *> Author:
      *>   Brian Tiffin
      *> Date:
      *>   20150725
      *> License:
      *>   Copyright 2015 Brian Tiffin
      *>   GNU Library General Public License, LGPL, 3.0 (or greater)
      *> Purpose:
      *>   Retrieve actual length of line sequential read
      *> Tectonics:
      *>   cobc -x -g -debug -W readlen.cob
      *> SOURCE
      *> ***************************************************************
       identification division.
       program-id. readlen.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       input-output section.
       file-control.
           select testfile
           assign to "testfile.txt"
           organization is line sequential
           file status is testfile-status
           .

       data division.
       file section.
       fd testfile
          record is varying in size from 0 to 132 characters
          depending on actual.
       01 testline.
          05 databytes pic x occurs 0 to 132 times depending on actual.

       working-storage section.
       01 actual pic 999 value 132.
       01 testfile-status pic 99.

      *> ***************************************************************
       procedure division.
       open input testfile
       if testfile-status greater than 9 then
           display
               "error: testfile.txt open failed with " testfile-status
               upon syserr
           end-display
           move 1 to return-code
           goback
       end-if

       perform until exit
           move 132 to actual
           read testfile end-read
           if testfile-status greater than 10 then
               display
                   "error: testfile.txt read failed with " testfile-status
                   upon syserr
               end-display
               move 1 to return-code
               goback
           end-if

           if testfile-status greater than 9 then
               exit perform
           end-if

           display actual ": " testline end-display
       end-perform

       close testfile
       if testfile-status greater than 9 then
           display
               "error: testfile.txt close failed with " testfile-status
               upon syserr
           end-display
           move 1 to return-code
           goback
       end-if

       goback.
       end program readlen.
      *> ***************************************************************
      *>****

abcdefghijklmnopqrstuvwxyz
abc
abcde

abc
abcdefghijklmnopqrstuvwxyz

prompt$ cobc -x -g -debug -W readlen.cob
prompt$ ./readlen
026: abcdefghijklmnopqrstuvwxyz
003: abc
005: abcde
000:
026: abc
026: abcdefghijklmnopqrstuvwxyz

fd testfile record varying depending on tracking-field.

# robodoc.rc for GnuCOBOL
#
items:
    NAME
    AUTHOR
    DATE
    PURPOSE
    TECTONICS
    SYNOPSIS
    INPUTS
    OUTPUTS
    SIDE EFFECTS
    HISTORY
    BUGS
    EXAMPLE
    SOURCE
ignore items:
    HISTORY
    BUGS
item order:
    PURPOSE
    SYNOPSIS
    INPUTS
    OUTPUTS
source items:
    SYNOPSIS
preformatted items:
    INPUTS
    OUTPUTS
format items:
    PURPOSE
    SIDE EFFECTS
options:
#    --src ./
#    --doc ./doc
    --html
    --syntaxcolors
#    --singledoc
#   --multidoc
    --index
    --tabsize 4
headertypes:
    J  "Projects"          robo_projects    2
    F  "Files"             robo_files       1
    e  "Makefile Entries"  robo_mk_entries
    x  "System Tests"      robo_syst_tests
    q  Queries             robo_queries
ignore files:
    README
    CVS
    *.bak
    *~
    "a test_*"
accept files:
    *.cob
    *.COB
    *.cbl
    *.CBL
    *.cpy
    *.CPY
header markers:
    *>****
remark markers:
    *>
end markers:
    *>****
header separate characters:
    ,
header ignore characters:
    [
remark begin markers:
    *>+
remark end markers:
    *>-
source line comments:
    *>
# GnuCOBOL keywords *><*
keywords:
    accept
    access
    active-class
    add
    address
    advancing
    after
    aligned
    all
    allocate
    alphabet
    alphabetic
    alphabetic-lower
    alphabetic-upper
    alphanumeric
    alphanumeric-edited
    also
    alter
    alternate
    and
    any
    anycase
    are
    area
    areas
    argument-number
    argument-value
    arithmetic
    as
    ascending
    assign
    at
    attribute
    auto
    auto-skip
    automatic
    autoterminate
    b-and
    b-not
    b-or
    b-xor
    background-color
    based
    beep
    before
    bell
    binary
    binary-c-long
    binary-char
    binary-double
    binary-long
    binary-short
    bit
    blank
    blink
    block
    boolean
    bottom
    by
    byte-length
    call
    cancel
    cd
    center
    cf
    ch
    chain
    chaining
    character
    characters
    class
    class-id
    classification
    close
    code
    code-set
    col
    collating
    cols
    column
    columns
    comma
    command-line
    commit
    common
    communication
    comp
    comp-1
    comp-2
    comp-3
    comp-4
    comp-5
    comp-x
    computational
    computational-1
    computational-2
    computational-3
    computational-4
    computational-5
    computational-x
    compute
    condition
    configuration
    constant
    contains
    content
    continue
    control
    controls
    converting
    copy
    corr
    corresponding
    count
    crt
    currency
    cursor
    cycle
    data
    data-pointer
    date
    day
    day-of-week
    de
    debugging
    decimal-point
    declaratives
    default
    delete
    delimited
    delimiter
    depending
    descending
    destination
    detail
    disable
    disk
    display
    divide
    division
    down
    duplicates
    dynamic
    ebcdic
    ec
    egi
    else
    emi
    enable
    end
    end-accept
    end-add
    end-call
    end-compute
    end-delete
    end-display
    end-divide
    end-evaluate
    end-if
    end-multiply
    end-of-page
    end-perform
    end-read
    end-receive
    end-return
    end-rewrite
    end-search
    end-start
    end-string
    end-subtract
    end-unstring
    end-write
    entry
    entry-convention
    environment
    environment-name
    environment-value
    eo
    eol
    eop
    eos
    equal
    equals
    erase
    error
    escape
    esi
    evaluate
    exception
    exception-object
    exclusive
    exit
    expands
    extend
    external
    factory
    false
    fd
    file
    file-control
    file-id
    filler
    final
    first
    float-extended
    float-long
    float-short
    footing
    for
    foreground-color
    forever
    format
    free
    from
    full
    function
    function-id
    generate
    get
    giving
    global
    go
    goback
    greater
    group
    group-usage
    heading
    high-value
    high-values
    highlight
    i-o
    i-o-control
    id
    identification
    if
    ignoring
    implements
    in
    index
    indexed
    indicate
    inherits
    initial
    initialize
    initialized
    initiate
    input
    input-output
    inspect
    interface
    interface-id
    into
    intrinsic
    invalid
    invoke
    is
    just
    justified
    key
    label
    last
    lc_all
    lc_collate
    lc_ctype
    lc_messages
    lc_monetary
    lc_numeric
    lc_time
    leading
    left
    length
    less
    limit
    limits
    linage
    linage-counter
    line
    line-counter
    lines
    linkage
    local-storage
    locale
    lock
    low-value
    low-values
    lowlight
    manual
    memory
    merge
    message
    method
    method-id
    minus
    mode
    move
    multiple
    multiply
    national
    national-edited
    native
    negative
    nested
    next
    no
    none
    normal
    not
    null
    nulls
    number
    numbers
    numeric
    numeric-edited
    object
    object-computer
    object-reference
    occurs
    of
    off
    omitted
    on
    only
    open
    optional
    options
    or
    order
    organization
    other
    output
    overflow
    overline
    override
    packed-decimal
    padding
    page
    page-counter
    paragraph
    perform
    pf
    ph
    pic
    picture
    plus
    pointer
    position
    positive
    present
    previous
    printer
    printing
    procedure
    procedure-pointer
    procedures
    proceed
    program
    program-id
    program-pointer
    prompt
    property
    prototype
    purge
    queue
    quote
    quotes
    raise
    raising
    random
    rd
    read
    receive
    record
    recording
    records
    recursive
    redefines
    reel
    reference
    relation
    relative
    release
    remainder
    removal
    renames
    replace
    replacing
    report
    reporting
    reports
    repository
    required
    reserve
    reset
    resume
    retry
    return
    returning
    reverse-video
    rewind
    rewrite
    rf
    rh
    right
    rollback
    rounded
    run
    same
    screen
    sd
    search
    seconds
    section
    secure
    segment
    select
    self
    send
    sentence
    separate
    sequence
    sequential
    set
    sharing
    sign
    signed
    signed-int
    signed-long
    signed-short
    size
    sort
    sort-merge
    source
    source-computer
    sources
    space
    spaces
    special-names
    standard
    standard-1
    standard-2
    start
    statement
    status
    step
    stop
    string
    strong
    sub-queue-1
    sub-queue-2
    sub-queue-3
    subtract
    sum
    super
    suppress
    symbol
    symbolic
    sync
    synchronized
    system-default
    table
    tallying
    tape
    terminal
    terminate
    test
    text
    than
    then
    through
    thru
    time
    times
    to
    top
    trailing
    true
    type
    typedef
    ucs-4
    underline
    unit
    universal
    unlock
    unsigned
    unsigned-int
    unsigned-long
    unsigned-short
    unstring
    until
    up
    update
    upon
    usage
    use
    user-default
    using
    utf-16
    utf-8
    val-status
    valid
    validate
    validate-status
    value
    values
    varying
    when
    with
    working-storage
    write
    yyyyddd
    yyyymmdd
    zero
    zeroes
    zeros

$ robodoc --src program.cob --doc program --singlefile --rc robocob.rc

" Vim syntax file
" Language: COBOL
" Maintainers: Davyd Ondrejko
" (formerly Sitaram Chamarty
" James Mitchell
" Last change: 2001 Sep 02

" For version 5.x: Clear all syntax items
" For version 6.x: Quit when a syntax file was already loaded

" Stephen Gennard
" - added keywords - AS, REPOSITORY
" - added extra cobolCall bits

if version < 600
  syntax clear
elseif exists("b:current_syntax")
  finish
endif

" MOST important - else most of the keywords wont work!
if version < 600
  set isk=@,48-57,-
else
  setlocal isk=@,48-57,-
endif

syn case ignore

if exists("cobol_legacy_code")
  syn match cobolKeys "^\a\{1,6\}" contains=cobolReserved
else
  syn match cobolKeys "" contains=cobolReserved
endif

syn keyword cobolReserved contained ACCEPT ACCESS ADD ADDRESS ADVANCING AFTER
syn keyword cobolReserved contained ALPHABET ALPHABETIC
syn keyword cobolReserved contained ALPHABETIC-LOWER ALPHABETIC-UPPER
syn keyword cobolReserved contained ALPHANUMERIC ALPHANUMERIC-EDITED ALS
syn keyword cobolReserved contained ALTERNATE AND ANY ARE AREA AREAS
syn keyword cobolReserved contained ASCENDING ASSIGN AT AUTHOR BEFORE BINARY
syn keyword cobolReserved contained BLANK BLOCK BOTTOM BY CANCEL CBLL CD
syn keyword cobolReserved contained CF CH CHARACTER CHARACTERS CLASS
syn keyword cobolReserved contained CLOCK-UNITS CLOSE COBOL CODE CODE-SET
syn keyword cobolReserved contained COLLATING COLUMN COMMA COMMON
syn keyword cobolReserved contained COMMUNICATIONS COMPUTATIONAL COMPUTE
syn keyword cobolReserved contained CONFIGURATION CONTENT CONTINUE
syn keyword cobolReserved contained CONTROL CONVERTING CORR CORRESPONDING
syn keyword cobolReserved contained COUNT CURRENCY DATA DATE DATE-COMPILED
syn keyword cobolReserved contained DATE-WRITTEN DAY DAY-OF-WEEK DE
syn keyword cobolReserved contained DEBUG-CONTENTS DEBUG-ITEM DEBUG-LINE
syn keyword cobolReserved contained DEBUG-NAME DEBUG-SUB-1 DEBUG-SUB-2
syn keyword cobolReserved contained DEBUG-SUB-3 DEBUGGING DECIMAL-POINT
syn keyword cobolReserved contained DELARATIVES DELETE DELIMITED DELIMITER
syn keyword cobolReserved contained DEPENDING DESCENDING DESTINATION
syn keyword cobolReserved contained DETAIL DISABLE DISPLAY DIVIDE DIVISION
syn keyword cobolReserved contained DOWN DUPLICATES DYNAMIC EGI ELSE EMI
syn keyword cobolReserved contained ENABLE END-ADD END-COMPUTE END-DELETE
syn keyword cobolReserved contained END-DIVIDE END-EVALUATE END-IF
syn keyword cobolReserved contained END-MULTIPLY END-OF-PAGE END-PERFORM
syn keyword cobolReserved contained END-READ END-RECEIVE END-RETURN
syn keyword cobolReserved contained END-REWRITE END-SEARCH END-START
syn keyword cobolReserved contained END-STRING END-SUBTRACT END-UNSTRING
syn keyword cobolReserved contained END-WRITE ENVIRONMENT EQUAL ERROR ESI
syn keyword cobolReserved contained EVALUATE EVERY EXCEPTION
syn keyword cobolReserved contained EXTEND EXTERNAL FALSE FD FILE
syn keyword cobolReserved contained FILE-CONTROL FILLER FINAL FIRST FOOTING FOR FROM
syn keyword cobolReserved contained GENERATE GIVING GLOBAL GREATER GROUP
syn keyword cobolReserved contained HEADING HIGH-VALUE HIGH-VALUES I-O
syn keyword cobolReserved contained I-O-CONTROL IDENTIFICATION IN INDEX
syn keyword cobolReserved contained INDEXED INDICATE INITIAL INITIALIZE
syn keyword cobolReserved contained INITIATE INPUT INPUT-OUTPUT INSPECT
syn keyword cobolReserved contained INSTALLATION INTO IS JUST
syn keyword cobolReserved contained JUSTIFIED KEY LABEL LAST LEADING LEFT
syn keyword cobolReserved contained LENGTH LOCK MEMORY
syn keyword cobolReserved contained MERGE MESSAGE MODE MODULES MOVE
syn keyword cobolReserved contained MULTIPLE MULTIPLY NATIVE NEGATIVE NEXT NO NOT
syn keyword cobolReserved contained NUMBER NUMERIC NUMERIC-EDITED
syn keyword cobolReserved contained OBJECT-COMPUTER OCCURS OF OFF OMITTED ON OPEN
syn keyword cobolReserved contained OPTIONAL OR ORDER ORGANIZATION OTHER
syn keyword cobolReserved contained OUTPUT OVERFLOW PACKED-DECIMAL PADDING
syn keyword cobolReserved contained PAGE PAGE-COUNTER PERFORM PF PH PIC
syn keyword cobolReserved contained PICTURE PLUS POSITION POSITIVE
syn keyword cobolReserved contained PRINTING PROCEDURE PROCEDURES PROCEED
syn keyword cobolReserved contained PROGRAM PROGRAM-ID PURGE QUEUE QUOTES
syn keyword cobolReserved contained RANDOM RD READ RECEIVE RECORD RECORDS
syn keyword cobolReserved contained REDEFINES REEL REFERENCE REFERENCES
syn keyword cobolReserved contained RELATIVE RELEASE REMAINDER REMOVAL
syn keyword cobolReserved contained REPLACE REPLACING REPORT REPORTING
syn keyword cobolReserved contained REPORTS RERUN RESERVE RESET RETURN
syn keyword cobolReserved contained RETURNING REVERSED REWIND REWRITE RF RH
syn keyword cobolReserved contained RIGHT ROUNDED SAME SD SEARCH SECTION
syn keyword cobolReserved contained SECURITY SEGMENT SEGMENT-LIMITED
syn keyword cobolReserved contained SELECT SEND SENTENCE SEPARATE SEQUENCE
syn keyword cobolReserved contained SEQUENTIAL SET SIGN SIZE SORT
syn keyword cobolReserved contained SORT-MERGE SOURCE SOURCE-COMPUTER
syn keyword cobolReserved contained SPECIAL-NAMES STANDARD
syn keyword cobolReserved contained STANDARD-1 STANDARD-2 START STATUS
syn keyword cobolReserved contained STRING SUB-QUEUE-1 SUB-QUEUE-2
syn keyword cobolReserved contained SUB-QUEUE-3 SUBTRACT SUM SUPPRESS
syn keyword cobolReserved contained SYMBOLIC SYNC SYNCHRONIZED TABLE TALLYING
syn keyword cobolReserved contained TAPE TERMINAL TERMINATE TEST TEXT
syn keyword cobolReserved contained THAN THEN THROUGH THRU TIME TIMES TO TOP
syn keyword cobolReserved contained TRAILING TRUE TYPE UNIT UNSTRING
syn keyword cobolReserved contained UNTIL UP UPON USAGE USE USING VALUE VALUES
syn keyword cobolReserved contained VARYING WHEN WITH WORDS WORKING-STORAGE WRITE

" new
syn keyword cobolReserved contained AS LOCAL-STORAGE LINKAGE SCREEN ENTRY

" new - btiffin
syn keyword cobolReserved contained END-ACCEPT END-DISPLAY

" new
syn keyword cobolReserved contained environment-name environment-value argument-number
syn keyword cobolReserved contained call-convention identified pointer

syn keyword cobolReserved contained external-form division wait national

" new -- oo stuff
syn keyword cobolReserved contained repository object class method-id
syn keyword cobolReserved contained method object static
syn keyword cobolReserved contained class-id class-control private
syn keyword cobolReserved contained inherits object-storage
syn keyword cobolReserved contained class-object protected delegate
syn keyword cobolReserved contained try catch raise end-try super property
syn keyword cobolReserved contained override instance equals

" new - new types
syn match cobolTypes "condition-value"hs=s,he=e
syn match cobolTypes "binary-char"hs=s,he=e
syn match cobolTypes "binary-c-long"hs=s,he=e
syn match cobolTypes "binary-long"hs=s,he=e
syn match cobolTypes "binary-short"hs=s,he=e
syn match cobolTypes "binary-double"hs=s,he=e
syn match cobolTypes "procedure-pointer"hs=s,he=e
syn match cobolTypes "object reference"hs=s,he=e

syn match cobolReserved contained "\<CONTAINS\>"
syn match cobolReserved contained "\<\(IF\|ELSE|INVALID\|END\|EOP\)\>"
syn match cobolReserved contained "\<ALL\>"

syn keyword cobolConstant SPACE SPACES NULL ZERO ZEROES ZEROS LOW-VALUE LOW-VALUES

syn keyword cobolReserved contained fold folder

if exists("cobol_legacy_code")
  syn match cobolMarker "^.\{6\}"
  syn match cobolBadLine "^.\{6\}[^ D\-*$/].*"hs=s+6
  " If comment mark somehow gets into column past Column 7.
  syn match cobolBadLine "^.\{6\}\s\+\*.*"
endif

syn match cobolNumber "\<-\=\d*\.\=\d\+\>" contains=cobolMarker,cobolComment
syn match cobolPic "\<S*9\+\>" contains=cobolMarker,cobolComment
syn match cobolPic "\<$*\.\=9\+\>" contains=cobolMarker,cobolComment
syn match cobolPic "\<Z*\.\=9\+\>" contains=cobolMarker,cobolComment
syn match cobolPic "\<V9\+\>" contains=cobolMarker,cobolComment
syn match cobolPic "\<9\+V\>" contains=cobolMarker,cobolComment
syn match cobolPic "\<-\+[Z9]\+\>" contains=cobolMarker,cobolComment
syn match cobolTodo "todo" contained

if exists("cobol_mf_syntax")
  syn region cobolComment start="*>" end="$" contains=cobolTodo,cobolMarker
endif

syn keyword cobolGoTo GO GOTO
syn keyword cobolCopy COPY

" cobolBAD: things that are BAD NEWS!
syn keyword cobolBAD ALTER ENTER RENAMES

" cobolWatch: things that are important when trying to understand a program
syn keyword cobolWatch OCCURS DEPENDING VARYING BINARY COMP REDEFINES
syn keyword cobolWatch REPLACING THROW
syn match cobolWatch "COMP-[123456XN]"

" new - btiffin, added Intrinsics
syn keyword cobolWatch ABS ACOS ANNUITY ASIN ATAN BYTE-LENGTH CHAR
syn keyword cobolWatch COS CURRENT-DATE DATE-OF-INTEGER DATE-TO-YYYYMMDD
syn keyword cobolWatch DAY-OF-INTEGER DAY-TO-YYYYDDD E EXCEPTION-FILE
syn keyword cobolWatch EXCEPTION-LOCATION EXCEPTION-STATEMENT
syn keyword cobolWatch EXCEPTION-STATUS EXP EXP10 FACTORIAL FRACTION-PART
syn keyword cobolWatch INTEGER INTEGER-OF-DATE INTEGER-OF-DAY INTEGER-PART
syn keyword cobolWatch LENGTH LOCALE-DATE LOCALE-TIME LOG LOG10 LOWER-CASE
syn keyword cobolWatch MAX MEAN MEDIAN MIDRANGE MIN MOD NUMVAL NUMVAL-C
syn keyword cobolWatch ORD ORD-MAX ORD-MIN PI PRESENT-VALUE RANDOM RANGE
syn keyword cobolWatch REM REVERSE SECONDS-FROM-FORMATTED-TIME
syn keyword cobolWatch SECONDS-PAST-MIDNIGHT SIGN SIN SQRT
syn keyword cobolWatch STANDARD-DEVIATION STORED-CHAR-LENGTH SUM TAN
syn keyword cobolwatch SUBSTITUTE SUBSTITUTE-CASE
syn keyword cobolWatch TEST-DATE-YYMMDD TEST-DAY-YYYYDDD TRIM UPPER-CASE
syn keyword cobolWatch VARIANCE WHEN-COMPILED YEAR-TO-YYYY

syn region cobolEXECs contains=cobolLine start="EXEC " end="END-EXEC"

syn match cobolComment "^.\{6\}\*.*"hs=s+6 contains=cobolTodo,cobolMarker
syn match cobolComment "^.\{6\}/.*"hs=s+6 contains=cobolTodo,cobolMarker
syn match cobolComment "^.\{6\}C.*"hs=s+6 contains=cobolTodo,cobolMarker

if exists("cobol_legacy_code")
  syn match cobolCompiler "^.\{6\}$.*"hs=s+6
  syn match cobolDecl "^.\{6} \{1,8}\(0\=1\|77\|78\) "hs=s+7,he=e-1 contains=cobolMarker
  syn match cobolDecl "^.\{6} \+[1-8]\d "hs=s+7,he=e-1 contains=cobolMarker
  syn match cobolDecl "^.\{6} \+0\=[2-9] "hs=s+7,he=e-1 contains=cobolMarker
  syn match cobolDecl "^.\{6} \+66 "hs=s+7,he=e-1 contains=cobolMarker
  syn match cobolWatch "^.\{6} \+88 "hs=s+7,he=e-1 contains=cobolMarker
else
  syn match cobolWhiteSpace "^*[ \t]"
  syn match cobolCompiler "$.*"hs=s,he=e contains=cobolWhiteSpace,cobolTypes
  syn match cobolDecl "0\=[1-9] *$"hs=s,he=e-1 contains=cobolWhiteSpace,cobolTypes
  syn match cobolDecl "66 *$"hs=s,he=e-1 contains=cobolWhiteSpace,cobolTypes
  syn match cobolWatch "88 *$"hs=s,he=e-1 contains=cobolWhiteSpace,cobolTypes
endif

syn match cobolBadID "\k\+-\($\|[^-A-Z0-9]\)"

syn keyword cobolCALLs CALL CANCEL GOBACK INVOKE PERFORM END-PERFORM END-CALL RUN
syn match cobolCALLs "STOP \+RUN"
syn match cobolCALLs "EXIT \+PROGRAM"
syn match cobolCALLs "EXIT \+PROGRAM \+RETURNING"
syn match cobolCALLs "EXIT \+PERFORM"
syn match cobolCALLs "EXIT \+METHOD"
syn match cobolCALLs "EXIT \+SECTION"
syn match cobolCALLs "STOP " contains=cobolString

syn match cobolExtras /\<VALUE \+\d\+\./hs=s+6,he=e-1

" zero terminated strings eg: pic x(10) value z"My C String"
if exists("cobol_mf_syntax")
  syn match cobolString /z"[^"]*\("\|$\)/
endif

syn match cobolString /"[^"]*\("\|$\)/
syn match cobolString /'[^']*\('\|$\)/

" new - btiffin, added libcob calls
syn match cobolWatch /\(["']\)SYSTEM\1/
syn match cobolWatch /["']CBL_ERROR_PROC["']/
syn match cobolWatch /["']CBL_EXIT_PROC["']/
syn match cobolWatch /["']CBL_OPEN_FILE["']/
syn match cobolWatch /["']CBL_CREATE_FILE["']/
syn match cobolWatch /["']CBL_READ_FILE["']/
syn match cobolWatch /["']CBL_WRITE_FILE["']/
syn match cobolWatch /["']CBL_CLOSE_FILE["']/
syn match cobolWatch /["']CBL_FLUSH_FILE["']/
syn match cobolWatch /["']CBL_DELETE_FILE["']/
syn match cobolWatch /["']CBL_COPY_FILE["']/
syn match cobolWatch /["']CBL_CHECK_FILE_EXIST["']/
syn match cobolWatch /["']CBL_RENAME_FILE["']/
syn match cobolWatch /["']CBL_GET_CURRENT_DIR["']/
syn match cobolWatch /["']CBL_CHANGE_DIR["']/
syn match cobolWatch /["']CBL_CREATE_DIR["']/
syn match cobolWatch /["']CBL_DELETE_DIR["']/
syn match cobolWatch /["']CBL_AND["']/
syn match cobolWatch /["']CBL_OR["']/
syn match cobolWatch /["']CBL_NOR["']/
syn match cobolWatch /["']CBL_XOR["']/
syn match cobolWatch /["']CBL_IMP["']/
syn match cobolWatch /["']CBL_NIMP["']/
syn match cobolWatch /["']CBL_EQ["']/
syn match cobolWatch /["']CBL_NOT["']/
syn match cobolWatch /["']CBL_TOUPPER["']/
syn match cobolWatch /["']CBL_TOLOWER["']/
syn match cobolWatch /["']\\364["']/
syn match cobolWatch /["']\\365["']/
syn match cobolWatch /["']\\221["']/
syn match cobolWatch /["']C$NARG["']/
syn match cobolWatch /["']C$PARAMSIZE["']/
syn match cobolWatch /["']C$MAKEDIR["']/
syn match cobolWatch /["']C$CHDIR["']/
syn match cobolWatch /["']C$SLEEP["']/
syn match cobolWatch /["']C$COPY["']/
syn match cobolWatch /["']C$FILEINFO["']/
syn match cobolWatch /["']C$DELETE["']/
syn match cobolWatch /["']C$TOUPPER["']/
syn match cobolWatch /["']C$TOLOWER["']/
syn match cobolWatch /["']C$JUSTIFY["']/
syn match cobolWatch /["']CBL_OC_NANOSLEEP["']/

if exists("cobol_legacy_code")
  syn region cobolCondFlow contains=ALLBUT,cobolLine start="\<\(IF\|INVALID\|END\|EOP\)\>"
      skip=/\('\|"\)[^"]\{-}\("\|'\|$\)/ end="\." keepend
  syn region cobolLine start="^.\{6} " end="$" contains=ALL
endif

if exists("cobol_legacy_code")
  " catch junk in columns 1-6 for modern code
  syn match cobolBAD "^ \{0,5\}[^ ].*"
endif

" many legacy sources have junk in columns 1-6: must be before others
" Stuff after column 72 is in error - must be after all other "match" entries
if exists("cobol_legacy_code")
  syn match cobolBadLine "^.\{6}[^*/].\{66,\}"
endif

" Define the default highlighting.
" For version 5.7 and earlier: only when not done already
" For version 5.8 and later: only when an item doesn't have highlighting yet
if version >= 508 || !exists("did_cobol_syntax_inits")
  if version < 508
    let did_cobol_syntax_inits = 1
    command -nargs=+ HiLink hi link <args>
  else
    command -nargs=+ HiLink hi def link <args>
  endif
  HiLink cobolBAD Error
  HiLink cobolBadID Error
  HiLink cobolBadLine Error
  HiLink cobolMarker Comment
  HiLink cobolCALLs Function
  HiLink cobolComment Comment
  HiLink cobolKeys Comment
  HiLink cobolCompiler PreProc
  HiLink cobolEXECs PreProc
  HiLink cobolCondFlow Special
  HiLink cobolCopy PreProc
  HiLink cobolDecl Type
  HiLink cobolTypes Type
  HiLink cobolExtras Special
  HiLink cobolGoTo Special
  HiLink cobolConstant Constant
  HiLink cobolNumber Constant
  HiLink cobolPic Constant
  HiLink cobolReserved Statement
  HiLink cobolString Constant
  HiLink cobolTodo Todo
  HiLink cobolWatch Special
  delcommand HiLink
endif

let b:current_syntax = "cobol"

" vim: ts=6 nowrap

## --------------------------------------- ##
## GnuCOBOL 1.1 test suite: Syntax Tests. ##
## --------------------------------------- ##
  1: COPY: file not found                            ok
  2: COPY: replacement order                         ok
  3: COPY: separators                                ok
  4: COPY: partial replacement                       ok
  5: COPY: recursive replacement                     ok
  6: Invalid PROGRAM-ID                              ok
  7: Invalid PROGRAM-ID type clause (1)              ok
  8: Invalid PROGRAM-ID type clause (2)              ok
  9: Undefined data name                             ok
 10: Undefined group name                            ok
 11: Undefined data name in group                    ok
 12: Reference not a group name                      ok
 13: Incomplete 01 definition                        ok
 14: Same labels in different sections               ok
 15: Redefinition of 01 items                        ok
 16: Redefinition of 01 and 02 items                 ok
 17: Redefinition of 02 items                        ok
 18: Redefinition of 77 items                        ok
 19: Redefinition of 01 and 77 items                 ok
 20: Redefinition of 88 items                        ok
 21: Ambiguous reference to 02 items                 ok
 22: Ambiguous reference to 02 and 03 items          ok
 23: Ambiguous reference with qualification          ok
 24: Unique reference with ambiguous qualifiers      ok
 25: Undefined procedure name                        ok
 26: Redefinition of section names                   ok
 27: Redefinition of section and paragraph names     ok
 28: Redefinition of paragraph names                 ok
 29: Ambiguous reference to paragraph name           ok
 30: Non-matching level numbers (extension)          ok
 31: Ambiguous AND/OR                                ok
 32: START on SEQUENTIAL file                        ok
 33: Subscripted item requires OCCURS clause         ok
 34: The number of subscripts                        ok
 35: OCCURS with level 01, 66, 77, and 88            ok
 36: OCCURS with variable-occurrence data item       ok
 37: Nested OCCURS clause                            ok
 38: OCCURS DEPENDING followed by another field      ok
 39: OCCURS DEPENDING without TO clause              ok
 40: REDEFINES: not following entry-name             ok
 41: REDEFINES: level 02 by 01                       ok
 42: REDEFINES: level 03 by 02                       ok
 43: REDEFINES: level 66                             ok
 44: REDEFINES: level 88                             ok
 45: REDEFINES: lower level number                   ok
 46: REDEFINES: with OCCURS                          ok
 47: REDEFINES: with subscript                       ok
 48: REDEFINES: with variable occurrence             ok
 49: REDEFINES: with qualification                   ok
 50: REDEFINES: multiple redefinition                ok
 51: REDEFINES: size exceeds                         ok
 52: REDEFINES: with VALUE                           ok
 53: REDEFINES: with intervention                    ok
 54: REDEFINES: within REDEFINES                     ok
 55: Numeric item (integer)                          ok
 56: Numeric item (non-integer)                      ok
 57: Numeric item with picture P                     ok
 58: Signed numeric literal                          ok
 59: Alphabetic item                                 ok
 60: Alphanumeric item                               ok
 61: Alphanumeric group item                         ok
 62: Numeric-edited item                             ok
 63: Alphanumeric-edited item                        ok
 64: MOVE SPACE TO numeric or numeric-edited item    ok
 65: MOVE ZERO TO alphabetic item                    ok
 66: MOVE alphabetic TO x                            ok
 67: MOVE alphanumeric TO x                          ok
 68: MOVE alphanumeric-edited TO x                   ok
 69: MOVE numeric (integer) TO x                     ok
 70: MOVE numeric (non-integer) TO x                 ok
 71: MOVE numeric-edited TO x                        ok
 72: Operands must be groups                         ok
 73: MOVE: misc                                      ok
 74: Category check of Format 1                      ok
 75: Category check of Format 2                      ok
 76: Category check of literals                      ok
 77: SET: misc                                       ok

## ------------- ##
## Test results. ##
## ------------- ##

All 77 tests were successful.
PASS: ./syntax
## ------------------------------------ ##
## GnuCOBOL 1.1 test suite: Run Tests. ##
## ------------------------------------ ##
  1: DISPLAY literals                                ok
  2: DISPLAY literals, DECIMAL-POINT is COMMA        ok
  3: Hexadecimal literal                             ok
  4: DISPLAY data items with VALUE clause            ok
  5: DISPLAY data items with MOVE statement          ok
  6: GLOBAL at same level                            ok
  7: GLOBAL at lower level                           ok
  8: non-numeric subscript                           ok
  9: The range of subscripts                         ok
 10: Subscript out of bounds (1)                     ok
 11: Subscript out of bounds (2)                     ok
 12: Value of DEPENDING ON N out of bounds (lower)   ok
 13: Value of DEPENDING ON N out of bounds (upper)   ok
 14: Subscript bounds with ODO (lower)               ok
 15: Subscript bounds with ODO (upper)               ok
 16: Subscript bounds with ODO                       ok
 17: Subscript by arithmetic expression              ok
 18: Separate sign positions                         ok
 19: Static reference modification                   ok
 20: Dynamic reference modification                  ok
 21: Static out of bounds                            ok
 22: Offset underflow                                ok
 23: Offset overflow                                 ok
 24: Length underflow                                ok
 25: Length overflow                                 ok
 26: ACCEPT                                          ok
 27: INITIALIZE group entry with OCCURS              ok
 28: INITIALIZE OCCURS with numeric edited           ok
 29: INITIALIZE complex group (1)                    ok
 30: INITIALIZE complex group (2)                    ok
 31: INITIALIZE with REDEFINES                       ok
 32: Source file not found                           ok
 33: Comma separator without space                   ok
 34: LOCAL-STORAGE                                   ok
 35: EXTERNAL data item                              ok
 36: EXTERNAL AS data item                           ok
 37: cobcrun validation                              ok
 38: MOVE to itself                                  ok
 39: MOVE with refmod                                ok
 40: MOVE with refmod (variable)                     ok
 41: MOVE with group refmod                          ok
 42: MOVE indexes                                    ok
 43: MOVE X'00'                                      ok
 44: Level 01 subscripts                             ok
 45: Class check with reference modification         ok
 46: Index and parenthesized expression              ok
 47: String concatenation                            ok
 48: Alphanumeric and binary numeric                 ok
 49: Dynamic call with static linking                ok
 50: CALL m1. CALL m2. CALL m1.                      ok
 51: CALL binary literal parameter/LENGTH OF         ok
 52: INSPECT REPLACING LEADING ZEROS BY SPACES       ok
 53: INSPECT: No repeat conversion check             ok
 54: INSPECT: REPLACING figurative constant          ok
 55: INSPECT: TALLYING BEFORE                        ok
 56: INSPECT: TALLYING AFTER                         ok
 57: INSPECT REPLACING TRAILING ZEROS BY SPACES      ok
 58: INSPECT REPLACING complex                       ok
 59: SWITCHES                                        ok
 60: Nested PERFORM                                  ok
 61: EXIT PERFORM                                    ok
 62: EXIT PERFORM CYCLE                              ok
 63: EXIT PARAGRAPH                                  ok
 64: EXIT SECTION                                    ok
 65: 88 with FILLER                                  ok
 66: Non-overflow after overflow                     ok
 67: PERFORM ... CONTINUE                            ok
 68: STRING with subscript reference                 ok
 69: UNSTRING DELIMITED ALL LOW-VALUE                ok
 70: READ INTO AT-END sequence                       ok
 71: First READ on empty SEQUENTIAL INDEXED file     ok
 72: REWRITE a RELATIVE file with RANDOM access      ok
 73: SORT: table sort                                ok
 74: SORT: EBCDIC table sort                         ok
 75: SORT nonexistent file                           ok
 76: PIC ZZZ-, ZZZ+                                  ok
 77: Larger REDEFINES lengths                        ok
 78: PERFORM type OSVS                               ok
 79: Sticky LINKAGE                                  ok
 80: COB_PRE_LOAD test                               ok
 81: COB_LOAD_CASE=UPPER test                        ok
 82: 88 level with FALSE IS clause                   ok
 83: ALLOCATE/FREE with BASED item                   ok
 84: INITIZIALIZE with reference modification        ok
 85: CALL with OMITTED parameter                     ok
 86: ANY LENGTH                                      ok
 87: COMP-5                                          ok
 88: Hexadecimal numeric literal                     ok
 89: Semi-parenthesized condition                    ok
 90: ADDRESS OF                                      ok
 91: LENGTH OF                                       ok
 92: WHEN-COMPILED                                   ok
 93: Complex OCCURS DEPENDING ON                     ok
 94: MOVE NON-INTEGER TO ALPHA-NUMERIC               ok
 95: CALL USING file-name                            ok
 96: CALL unusual PROGRAM-ID.                        ok
 97: Case independent PROGRAM-ID                     ok
 98: PROGRAM-ID AS clause                            ok
 99: Quoted PROGRAM-ID                               ok
100: ASSIGN MF                                       ok
101: ASSIGN IBM                                      ok
102: ASSIGN mapping                                  ok
103: ASSIGN expansion                                ok
104: ASSIGN with COB_FILE_PATH                       ok
105: NUMBER-OF-CALL-PARAMETERS                       ok
106: PROCEDURE DIVISION USING BY ...                 ok
107: PROCEDURE DIVISION CHAINING ...                 ok
108: STOP RUN RETURNING                              ok
109: ENTRY                                           ok
110: LINE SEQUENTIAL write                           ok
111: LINE SEQUENTIAL read                            ok
112: ASSIGN to KEYBOARD/DISPLAY                      ok
113: Environment/Argument variable                   ok
114: DECIMAL-POINT is COMMA (1)                      ok
115: DECIMAL-POINT is COMMA (2)                      ok
116: DECIMAL-POINT is COMMA (3)                      ok
117: DECIMAL-POINT is COMMA (4)                      ok
118: DECIMAL-POINT is COMMA (5)                      ok
119: 78 Level (1)                                    ok
120: 78 Level (2)                                    ok
121: 78 Level (3)                                    ok
122: Unreachable statement                           ok
123: RETURN-CODE moving                              ok
124: RETURN-CODE passing                             ok
125: RETURN-CODE nested                              ok
126: FUNCTION ABS                                    ok
127: FUNCTION ACOS                                   ok
128: FUNCTION ANNUITY                                ok
129: FUNCTION ASIN                                   ok
130: FUNCTION ATAN                                   ok
131: FUNCTION CHAR                                   ok
132: FUNCTION COMBINED-DATETIME                      ok
133: FUNCTION CONCATENATE                            ok
134: FUNCTION CONCATENATE with reference modding     ok
135: FUNCTION COS                                    ok
136: FUNCTION DATE-OF-INTEGER                        ok
137: FUNCTION DATE-TO-YYYYMMDD                       ok
138: FUNCTION DAY-OF-INTEGER                         ok
139: FUNCTION DAY-TO-YYYYDDD                         ok
140: FUNCTION E                                      ok
141: FUNCTION EXCEPTION-FILE                         ok
142: FUNCTION EXCEPTION-LOCATION                     ok
143: FUNCTION EXCEPTION-STATEMENT                    ok
144: FUNCTION EXCEPTION-STATUS                       ok
145: FUNCTION EXP                                    ok
146: FUNCTION FACTORIAL                              ok
147: FUNCTION FRACTION-PART                          ok
148: FUNCTION INTEGER                                ok
149: FUNCTION INTEGER-OF-DATE                        ok
150: FUNCTION INTEGER-OF-DAY                         ok
151: FUNCTION INTEGER-PART                           ok
152: FUNCTION LENGTH                                 ok
153: FUNCTION LOCALE-DATE                            ok
154: FUNCTION LOCALE-TIME                            ok
155: FUNCTION LOCALE-TIME-FROM-SECONDS               ok
156: FUNCTION LOG                                    ok
157: FUNCTION LOG10                                  ok
158: FUNCTION LOWER-CASE                             ok
159: FUNCTION LOWER-CASE with reference modding      ok
160: FUNCTION MAX                                    ok
161: FUNCTION MEAN                                   ok
162: FUNCTION MEDIAN                                 ok
163: FUNCTION MIDRANGE                               ok
164: FUNCTION MIN                                    ok
165: FUNCTION MOD                                    ok
166: FUNCTION NUMVAL                                 ok
167: FUNCTION NUMVAL-C                               ok
168: FUNCTION ORD                                    ok
169: FUNCTION ORD-MAX                                ok
170: FUNCTION ORD-MIN                                ok
171: FUNCTION PI                                     ok
172: FUNCTION PRESENT-VALUE                          ok
173: FUNCTION RANGE                                  ok
174: FUNCTION REM                                    ok
175: FUNCTION REVERSE                                ok
176: FUNCTION REVERSE with reference modding         ok
177: FUNCTION SECONDS-FROM-FORMATTED-TIME            ok
178: FUNCTION SECONDS-PAST-MIDNIGHT                  ok
179: FUNCTION SIGN                                   ok
180: FUNCTION SIN                                    ok
181: FUNCTION SQRT                                   ok
182: FUNCTION STANDARD-DEVIATION                     ok
183: FUNCTION STORED-CHAR-LENGTH                     ok
184: FUNCTION SUBSTITUTE                             ok
185: FUNCTION SUBSTITUTE with reference modding      ok
186: FUNCTION SUBSTITUTE-CASE                        ok
187: FUNCTION SUBSTITUTE-CASE with reference mod     ok
188: FUNCTION TAN                                    ok
189: FUNCTION TRIM                                   ok
190: FUNCTION TRIM with reference modding            ok
191: FUNCTION UPPER-CASE                             ok
192: FUNCTION UPPER-CASE with reference modding      ok
193: FUNCTION VARIANCE                               ok
194: FUNCTION WHEN-COMPILED                          ok

## ------------- ##
## Test results. ##
## ------------- ##

All 194 tests were successful.
PASS: ./run

## Run time tests with -O option ##

## ------------------------------------ ##
## GnuCOBOL 1.1 test suite: Run Tests. ##
## ------------------------------------ ##
  1: DISPLAY literals                                ok
  2: DISPLAY literals, DECIMAL-POINT is COMMA        ok
  3: Hexadecimal literal                             ok
  4: DISPLAY data items with VALUE clause            ok
  5: DISPLAY data items with MOVE statement          ok
  6: GLOBAL at same level                            ok
  7: GLOBAL at lower level                           ok
  8: non-numeric subscript                           ok
  9: The range of subscripts                         ok
 10: Subscript out of bounds (1)                     ok
 11: Subscript out of bounds (2)                     ok
 12: Value of DEPENDING ON N out of bounds (lower)   ok
 13: Value of DEPENDING ON N out of bounds (upper)   ok
 14: Subscript bounds with ODO (lower)               ok
 15: Subscript bounds with ODO (upper)               ok
 16: Subscript bounds with ODO                       ok
 17: Subscript by arithmetic expression              ok
 18: Separate sign positions                         ok
 19: Static reference modification                   ok
 20: Dynamic reference modification                  ok
 21: Static out of bounds                            ok
 22: Offset underflow                                ok
 23: Offset overflow                                 ok
 24: Length underflow                                ok
 25: Length overflow                                 ok
 26: ACCEPT                                          ok
 27: INITIALIZE group entry with OCCURS              ok
 28: INITIALIZE OCCURS with numeric edited           ok
 29: INITIALIZE complex group (1)                    ok
 30: INITIALIZE complex group (2)                    ok
 31: INITIALIZE with REDEFINES                       ok
 32: Source file not found                           ok
 33: Comma separator without space                   ok
 34: LOCAL-STORAGE                                   ok
 35: EXTERNAL data item                              ok
 36: EXTERNAL AS data item                           ok
 37: cobcrun validation                              ok
 38: MOVE to itself                                  ok
 39: MOVE with refmod                                ok
 40: MOVE with refmod (variable)                     ok
 41: MOVE with group refmod                          ok
 42: MOVE indexes                                    ok
 43: MOVE X'00'                                      ok
 44: Level 01 subscripts                             ok
 45: Class check with reference modification         ok
 46: Index and parenthesized expression              ok
 47: String concatenation                            ok
 48: Alphanumeric and binary numeric                 ok
 49: Dynamic call with static linking                ok
 50: CALL m1. CALL m2. CALL m1.                      ok
 51: CALL binary literal parameter/LENGTH OF         ok
 52: INSPECT REPLACING LEADING ZEROS BY SPACES       ok
 53: INSPECT: No repeat conversion check             ok
 54: INSPECT: REPLACING figurative constant          ok
 55: INSPECT: TALLYING BEFORE                        ok
 56: INSPECT: TALLYING AFTER                         ok
 57: INSPECT REPLACING TRAILING ZEROS BY SPACES      ok
 58: INSPECT REPLACING complex                       ok
 59: SWITCHES                                        ok
 60: Nested PERFORM                                  ok
 61: EXIT PERFORM                                    ok
 62: EXIT PERFORM CYCLE                              ok
 63: EXIT PARAGRAPH                                  ok
 64: EXIT SECTION                                    ok
 65: 88 with FILLER                                  ok
 66: Non-overflow after overflow                     ok
 67: PERFORM ... CONTINUE                            ok
 68: STRING with subscript reference                 ok
 69: UNSTRING DELIMITED ALL LOW-VALUE                ok
 70: READ INTO AT-END sequence                       ok
 71: First READ on empty SEQUENTIAL INDEXED file     ok
 72: REWRITE a RELATIVE file with RANDOM access      ok
 73: SORT: table sort                                ok
 74: SORT: EBCDIC table sort                         ok
 75: SORT nonexistent file                           ok
 76: PIC ZZZ-, ZZZ+                                  ok
 77: Larger REDEFINES lengths                        ok
 78: PERFORM type OSVS                               ok
 79: Sticky LINKAGE                                  ok
 80: COB_PRE_LOAD test                               ok
 81: COB_LOAD_CASE=UPPER test                        ok
 82: 88 level with FALSE IS clause                   ok
 83: ALLOCATE/FREE with BASED item                   ok
 84: INITIZIALIZE with reference modification        ok
 85: CALL with OMITTED parameter                     ok
 86: ANY LENGTH                                      ok
 87: COMP-5                                          ok
 88: Hexadecimal numeric literal                     ok
 89: Semi-parenthesized condition                    ok
 90: ADDRESS OF                                      ok
 91: LENGTH OF                                       ok
 92: WHEN-COMPILED                                   ok
 93: Complex OCCURS DEPENDING ON                     ok
 94: MOVE NON-INTEGER TO ALPHA-NUMERIC               ok
 95: CALL USING file-name                            ok
 96: CALL unusual PROGRAM-ID.                        ok
 97: Case independent PROGRAM-ID                     ok
 98: PROGRAM-ID AS clause                            ok
 99: Quoted PROGRAM-ID                               ok
100: ASSIGN MF                                       ok
101: ASSIGN IBM                                      ok
102: ASSIGN mapping                                  ok
103: ASSIGN expansion                                ok
104: ASSIGN with COB_FILE_PATH                       ok
105: NUMBER-OF-CALL-PARAMETERS                       ok
106: PROCEDURE DIVISION USING BY ...                 ok
107: PROCEDURE DIVISION CHAINING ...                 ok
108: STOP RUN RETURNING                              ok
109: ENTRY                                           ok
110: LINE SEQUENTIAL write                           ok
111: LINE SEQUENTIAL read                            ok
112: ASSIGN to KEYBOARD/DISPLAY                      ok
113: Environment/Argument variable                   ok
114: DECIMAL-POINT is COMMA (1)                      ok
115: DECIMAL-POINT is COMMA (2)                      ok
116: DECIMAL-POINT is COMMA (3)                      ok
117: DECIMAL-POINT is COMMA (4)                      ok
118: DECIMAL-POINT is COMMA (5)                      ok
119: 78 Level (1)                                    ok
120: 78 Level (2)                                    ok
121: 78 Level (3)                                    ok
122: Unreachable statement                           ok
123: RETURN-CODE moving                              ok
124: RETURN-CODE passing                             ok
125: RETURN-CODE nested                              ok
126: FUNCTION ABS                                    ok
127: FUNCTION ACOS                                   ok
128: FUNCTION ANNUITY                                ok
129: FUNCTION ASIN                                   ok
130: FUNCTION ATAN                                   ok
131: FUNCTION CHAR                                   ok
132: FUNCTION COMBINED-DATETIME                      ok
133: FUNCTION CONCATENATE                            ok
134: FUNCTION CONCATENATE with reference modding     ok
135: FUNCTION COS                                    ok
136: FUNCTION DATE-OF-INTEGER                        ok
137: FUNCTION DATE-TO-YYYYMMDD                       ok
138: FUNCTION DAY-OF-INTEGER                         ok
139: FUNCTION DAY-TO-YYYYDDD                         ok
140: FUNCTION E                                      ok
141: FUNCTION EXCEPTION-FILE                         ok
142: FUNCTION EXCEPTION-LOCATION                     ok
143: FUNCTION EXCEPTION-STATEMENT                    ok
144: FUNCTION EXCEPTION-STATUS                       ok
145: FUNCTION EXP                                    ok
146: FUNCTION FACTORIAL                              ok
147: FUNCTION FRACTION-PART                          ok
148: FUNCTION INTEGER                                ok
149: FUNCTION INTEGER-OF-DATE                        ok
150: FUNCTION INTEGER-OF-DAY                         ok
151: FUNCTION INTEGER-PART                           ok
152: FUNCTION LENGTH                                 ok
153: FUNCTION LOCALE-DATE                            ok
154: FUNCTION LOCALE-TIME                            ok
155: FUNCTION LOCALE-TIME-FROM-SECONDS               ok
156: FUNCTION LOG                                    ok
157: FUNCTION LOG10                                  ok
158: FUNCTION LOWER-CASE                             ok
159: FUNCTION LOWER-CASE with reference modding      ok
160: FUNCTION MAX                                    ok
161: FUNCTION MEAN                                   ok
162: FUNCTION MEDIAN                                 ok
163: FUNCTION MIDRANGE                               ok
164: FUNCTION MIN                                    ok
165: FUNCTION MOD                                    ok
166: FUNCTION NUMVAL                                 ok
167: FUNCTION NUMVAL-C                               ok
168: FUNCTION ORD                                    ok
169: FUNCTION ORD-MAX                                ok
170: FUNCTION ORD-MIN                                ok
171: FUNCTION PI                                     ok
172: FUNCTION PRESENT-VALUE                          ok
173: FUNCTION RANGE                                  ok
174: FUNCTION REM                                    ok
175: FUNCTION REVERSE                                ok
176: FUNCTION REVERSE with reference modding         ok
177: FUNCTION SECONDS-FROM-FORMATTED-TIME            ok
178: FUNCTION SECONDS-PAST-MIDNIGHT                  ok
179: FUNCTION SIGN                                   ok
180: FUNCTION SIN                                    ok
181: FUNCTION SQRT                                   ok
182: FUNCTION STANDARD-DEVIATION                     ok
183: FUNCTION STORED-CHAR-LENGTH                     ok
184: FUNCTION SUBSTITUTE                             ok
185: FUNCTION SUBSTITUTE with reference modding      ok
186: FUNCTION SUBSTITUTE-CASE                        ok
187: FUNCTION SUBSTITUTE-CASE with reference mod     ok
188: FUNCTION TAN                                    ok
189: FUNCTION TRIM                                   ok
190: FUNCTION TRIM with reference modding            ok
191: FUNCTION UPPER-CASE                             ok
192: FUNCTION UPPER-CASE with reference modding      ok
193: FUNCTION VARIANCE                               ok
194: FUNCTION WHEN-COMPILED                          ok

## ------------- ##
## Test results. ##
## ------------- ##

All 194 tests were successful.
PASS: ./run-O
## ---------------------------------------------- ##
## GnuCOBOL 1.1 test suite: Data Representation. ##
## ---------------------------------------------- ##
  1: BINARY: 2-4-8 big-endian                        ok
  2: BINARY: 2-4-8 native                            ok
  3: BINARY: 1-2-4-8 big-endian                      ok
  4: BINARY: 1-2-4-8 native                          ok
  5: BINARY: 1--8 big-endian                         ok
  6: BINARY: 1--8 native                             ok
  7: BINARY: full-print                              ok
  8: DISPLAY: Sign ASCII                             ok
  9: DISPLAY: Sign ASCII (2)                         ok
 10: DISPLAY: Sign EBCDIC                            ok
 11: PACKED-DECIMAL dump                             ok
 12: PACKED-DECIMAL display                          ok
 13: PACKED-DECIMAL move                             ok
 14: PACKED-DECIMAL arithmetic (1)                   ok
 15: PACKED-DECIMAL arithmetic (2)                   ok
 16: PACKED-DECIMAL numeric test                     ok
 17: POINTER: display                                ok

## ------------- ##
## Test results. ##
## ------------- ##

All 17 tests were successful.
PASS: ./data-rep

## Data representation tests with -O option ##

## ---------------------------------------------- ##
## GnuCOBOL 1.1 test suite: Data Representation. ##
## ---------------------------------------------- ##
  1: BINARY: 2-4-8 big-endian                        ok
  2: BINARY: 2-4-8 native                            ok
  3: BINARY: 1-2-4-8 big-endian                      ok
  4: BINARY: 1-2-4-8 native                          ok
  5: BINARY: 1--8 big-endian                         ok
  6: BINARY: 1--8 native                             ok
  7: BINARY: full-print                              ok
  8: DISPLAY: Sign ASCII                             ok
  9: DISPLAY: Sign ASCII (2)                         ok
 10: DISPLAY: Sign EBCDIC                            ok
 11: PACKED-DECIMAL dump                             ok
 12: PACKED-DECIMAL display                          ok
 13: PACKED-DECIMAL move                             ok
 14: PACKED-DECIMAL arithmetic (1)                   ok
 15: PACKED-DECIMAL arithmetic (2)                   ok
 16: PACKED-DECIMAL numeric test                     ok
 17: POINTER: display                                ok

## ------------- ##
## Test results. ##
## ------------- ##

All 17 tests were successful.
PASS: ./data-rep-O
==================
All 5 tests passed
==================

"Tectonics" gcide "The Collaborative International Dictionary of English v.0.48"
Tectonics \Tec*ton"ics\, n.
1. The science, or the art, by which implements, vessels,
dwellings, or other edifices, are constructed, both
agreeably to the end for which they are designed, and in
conformity with artistic sentiments and ideas.
[1913 Webster]

sh-4.2$ cobc -x spanish.cob
spanish.cob: 49: Error: 'missing-file' is not defined
spanish.cob: 49: Error: 'missing-file' is not a file name

sh-4.2$ LC_MESSAGES=es_ES cobc -x spanish.cob
spanish.cob: 49: Error: 'missing-file' no esta definido
spanish.cob: 49: Error: 'missing-file' no es nombre de archivo

Subject: FOREVER and a small request for involvement

I just updated the FAQ and was wondering if anyone could come up with a
better/different short sample program than the one I use in

http://opencobol.add1tocobol.com/#forever

The one I have also demonstrates the CYCLE clause of EXIT PERFORM, but reading
it, it seems a little, umm, lame for what is a pretty powerful program flow
construct.

[i]Plus I'd like to show off a little more community involvement and spread
some credit around.[/i]

Cheers,
Brian
----------------------------------------------------------------

I think it's fine and think you should leave it as it is...

human
----------------------------------------------------------------

human;

I know it's "fine", kinda, but I'm also trying to get some of the lurkers out
into the open.  :-)

Hoping that some small steps will lead to bigger bolder steps.

Plus, the post was a thinly veiled self promotion and the, [i]as always[/i],
greater desire to inform that OpenCOBOL supports FOREVER along with EXIT
PERFORM CYCLE.

As I add reserved words to the FAQ in the future, I may post up more of these
challenges [i]in a thinly veiled disguise to highlight the feature[/i].

Cheers,
Brian
----------------------------------------------------------------

As one of the "lurkers", may I offer an excuse.  I think that many of us who do
not make a contribution, are ordinary cobol people who know nothing of C or web
based extensions or GUI or database extensions. Much of the discussion here
seems pretty esoteric. There is no place where one feels that it would be
appropriate to post ordinary basic cobol programs or even tips. I think this is
a pity, but I don't have any solutions. Going way back to the computer language
cobol group in the pre YK2 years, it was apparent that cobol programmers were a
most ungenerous lot.  "Do your own homework", and "I do this for money not for
free" were common responses with a few exceptions like WM Klein and J McLendon.
Perhaps the decline of cobol might have made people more open. Even though
cobol is the accounting language, you can't I think find books with debtors,
creditors, stock payroll and general ledger. You can find them in basic, but
not cobol. I think that if there was a place where low level people could
contribute, perhaps they might. It is not approprate to clutter up this forum,
but it would need to be a place which is just as simple to write to, else most
of us would be unable to join in.
John.
----------------------------------------------------------------

Thanks for the post John.

Exactly the catch-22 I wanted to break here.  OpenCOBOL is for sharing.  And
yes, old school COBOL is/was very much "top-secret, tight lipped programming".
We can change that.

No need to feel you have to talk C bindings, or GUI or highfalutin issues.

A nice challenge on a short sample of

PERFORM FOREVER
   do some thing
   now get me outta here
   do some other thing
END-PERFORM

was what I wanted to start up.

A sample on a neat INSPECT trick, or a blurb on preferred section/paragraph
naming.  Anything.  OpenCOBOL doesn't have to be closed like the olden days.
[i]And to be honest, it is to great credit that most COBOLers kept their tight
lips, when I just know that some of them wanted to help, or point out mistakes,
or show off, but couldn't, due to the nature of the work they were/are
doing.[/i]  We can, and we should, flap some loose lips.  :-)

Do that here on opencobol.org.  I'd read the posts, and feel better for the
reading, and the learning, of all the old and new techniques.

I blather on with samples and bindings to show what OpenCOBOL is capable of,
but a pure COBOL discussion would be more than welcome.  It'd be appreciated.

Unless it sounds like actual homework and it'd hurt more than help, there won't
be many "Do your own homework" remarks...umm, I hope ([i]no, I'm pretty
sure[/i]).

[b]To everyone[/b]; join in, the water's fine.   ;-)

In the FAQ as it stands, there are over 500 reserved words in section 4 and
only a mere hundred or so have code samples.  I'd gladly read submissions here,
get permission and then include them (with or without credit at author's
desire) for everyone's benefit.

If we start to overwhelm the forum and people want to direct compiler questions
to Roger, we can work out a way to keep his perception of the signal to noise
ratio high enough for productive usage of time.

Cheers,
Brian
----------------------------------------------------------------

Did not know that existed.

       >>SOURCE FORMAT IS FREE
id division.
program-id. read_forever.
environment division.
input-output section.
file-control.
    select my-file
        organization line sequential
        assign to "myfile".

data division.
file section.
fd  my-file.
01  my-record         pic x(80).

procedure division.
    open input my-file
    perform forever
        read my-file
        at end
            exit perform
        end-read
        display my-record
    end-perform
    close my-file
    goback.

Cool.  No need for a goto, a file status, or any working-storage at all.

Too bad it's apparently not standard.
----------------------------------------------------------------

Yep, no standard - but a real nice extension.

If you want to do this the standard way do [code]
    [...]
    perform until 0 = 1
        read my-file
        at end
           exit perform
        end-read
        display my-record
        end-display
    end-perform
    [...]

OpenCOBOL may supports PERFORM UNTIL EXIT, too (this is a MF extension, if I
remember this correct).

human
----------------------------------------------------------------

   OK Brian here is how we did this in the original dialects of COBOL.

   In an effort to show how the language has changed, I offer the
following version of Brian's program.  While many styles can be effectively
used in COBOL programming, this program is an example of the style used in
programming shops where I worked.

    The first six columns of each source line were reserved for the source
code sequence number (usually page and line number).  We generally used the
first three columns to represent the ascending page number and the last three
for the line number on the page.  Skipping ten numbers between each original
line allowed us to insert additional lines when needed.  You can see that an
insertion was made at 001045.  These sequence numbers were desirable in that
the program was punched on cards with one card for each line.  If the source
card deck was accidently dropped the sequence numbers allowed us to get the
source deck back into order.

     You will also notice that the code is all in uppercase.  Quite simply,
early line printers could not print lowercase.  Take a look at line 001080.
While even early compilers would have allowed us to write "VALUE 0" we
would spell out the word zero since the difference in appearance between
an alphabetic letter O and a numeric zero was easy to miss when reading
the program.

     All of the environment division has been left out of this program,
although it was almost always necessary.  The numbers after "FOREVERLOOP"
on line 001070 were the version number of the program.  It was our habit
to keep a journal (in comment lines) at the beginning of the program
describing modifications that were made to the program.

     The variable names start with "WS-".  This allowed the reader of the
program to understand that the variable in question was in the WORKING-
STORAGE instead of being part of a file descriptor, thus making it easier
to find.

     Numeric fields were almost always signed, both for efficiency
at run-time and to allow for the possibility of a value going negative even
if it should not.  COMP asked the compiler to use the most efficient method
to store the value on the architecture on which the program was going to run.

     You will see that the display statements start their display with "I) ".
We used this to make reading console output easier.  "I)" was for normal
information, "W)" was for warnings, and "T)" was for terminal conditions.

     From a syntactical standpoint this code was written to the COBOL-68
standard.  Structured programming constructs were not available.

     Paragraphs were numbered in ascending sequence in order to make
finding a paragraph easier.

     Sentences were kept short and periods were used as often as we could use them.

001010 IDENTIFICATION DIVISION.
001020 PROGRAM-ID. FOREVERLOOP.
001030*
001040 DATA DIVISION.
001050 WORKING-STORAGE SECTION.
001060 01  WS-PROGRAM-NAME                  PIC X(16)
001070                                        VALUE "FOREVERLOOP  001".
001080 01  WS-COBOL                         PIC S9 COMP VALUE ZERO.
001090 01  WS-C                             PIC S9 COMP VALUE 1.
001100 01  WS-FORTRAN                       PIC S9 COMP VALUE 2.
001110 01  WS-ED1S                          PIC Z-.
001110*
001010 PROCEDURE DIVISION.
001020     DISPLAY "I) PROGRAM ", WS-PROGRAM-NAME, " BEGINNING".
001030 0100-LOOP.
001040     ADD 1 TO WS-COBOL.
001045     MOVE WS-COBOL TO WS-ED1S.
001050     DISPLAY "I) COBOL AT ", WS-ED1S.
001060     IF WS-COBOL IS GREATER THAN WS-FORTRAN
001070         THEN GO TO 0800-ENDER.
001080     IF WS-COBOL IS EQUAL TO 1
001090         THEN DISPLAY "I) COBOL STILL CREEPING UP ON C".
001100     GO TO 0100-LOOP.
001110*
001120 0800-ENDER.
001130     DISPLAY "I) COBOL SURPASSED C AND FORTRAN".
001140     DISPLAY "I) PROGRAM ", WS-PROGRAM-NAME, " TERMINATED".
001150*
001160     STOP RUN.

The run-time output is below:

[code]
I) PROGRAM FOREVERLOOP  001 BEGINNING
I) COBOL AT 1
I) COBOL STILL CREEPING UP ON C
I) COBOL AT 2
I) COBOL AT 3
I) COBOL SURPASSED C AND FORTRAN
I) PROGRAM FOREVERLOOP  001 TERMINATED
[/code]

Please note that I am not advocating this style.  However it is a good example
of traditional methods.
----------------------------------------------------------------

You made one "syntax" error for duplicating "old-style" (required for Standard
conformance) programming.

You hae DISPLAY statement immediately following the PROCEDURE DIVISON header.
Up until "more recent" Standards, you were required to have either a section or
paragraph header and could NOT have statements "outside" of a named procedure.

P.S.  In the days of "numbered lines" and all upper-case, you probably would
have also had a REMARKS paragraph, but that was optional.
----------------------------------------------------------------

As is usually the case, Mr. Klein is correct. :-)

Chalk it up to CRS (Can't Remember Stuff).

Yes the "old-style" relied a lot more on the environment division, including
the ability to specify both a source computer and an object computer.  This
would allow the compilers that supported it to output different object code
depending on the object computer specified.

A compile of a simple listing program done on a four tape 1401 would take about
15 minutes and then you had to run the result through the Autocoder macro
assembler.

The 360's would generally compile directly (without the Autocoder step) and
would get the job done in a few minutes but if you were not authorized to be in
the computer room you had to wait until someone in production saw fit to run
your compile for you.
----------------------------------------------------------------

Like OMG!  I learned COBOL on the 1401.  And I remember pops letting me
practice on the week ends on the 360.

Good times...  But the PC is so much more convenient!
----------------------------------------------------------------

Now thats what I'm talking about.

John, Jim, Frank, Bill, human;  If you don't mind, I'd like to include nearly
this entire thread in the FAQ, (under what heading I'm not sure, but this is
some wicked good COBOL technical [i]and cultural[/i] wisdom).

Damon; not to worry, I plan on including as many of your snippets as the future
will bear.  ;-)

More of this please...[i]he said, hinting towards the anonymous readers[/i].

Cheers,
Brian
----------------------------------------------------------------

I added a more contemporary method of doing the same thing for the COBOL
newbies.

001010 IDENTIFICATION DIVISION.
001020 PROGRAM-ID. FOREVERLOOP.
001030*
021611**************************************************************
021611*                                                            *
021611*  This program will demonstrate various techniques and      *
021611*  coding styles.                                            *
021611*                                                            *
021611*  Version 001--Shows a COBOL68 technique                    *
021611*               02/15/2011--J C Currey                       *
021611*                                                            *
021611*  Version 002--Shows an OpenCOBOL 1.1 technique             *
021611*               02/16/2011--J C Currey                       *
021611*                                                            *
021611**************************************************************
001040 DATA DIVISION.
001050 WORKING-STORAGE SECTION.
001060 01  WS-PROGRAM-NAME                  PIC X(16)
021611                                        VALUE "FOREVERLOOP  002".
001080 01  WS-COBOL                         PIC S9 COMP VALUE ZERO.
001090 01  WS-C                             PIC S9 COMP VALUE 1.
001100 01  WS-FORTRAN                       PIC S9 COMP VALUE 2.
001110 01  WS-ED1S                          PIC Z-.
001110*
001010 PROCEDURE DIVISION.
001020     DISPLAY "I) PROGRAM ", WS-PROGRAM-NAME, " BEGINNING".
021611*
021611*    THIS CODE SHOWS HOW WE WOULD DO IT WITH COBOL68
021611*
001030 0100-LOOP.
001040     ADD 1 TO WS-COBOL.
001045     MOVE WS-COBOL TO WS-ED1S.
001050     DISPLAY "I) COBOL AT ", WS-ED1S.
001060     IF WS-COBOL IS GREATER THAN WS-FORTRAN
001070         THEN GO TO 0800-ENDER.
001080     IF WS-COBOL IS EQUAL TO 1
001090         THEN DISPLAY "I) COBOL STILL CREEPING UP ON C".
001100     GO TO 0100-LOOP.
001110*
001120 0800-ENDER.
001130     DISPLAY "I) COBOL SURPASSED C AND FORTRAN".
021611     DISPLAY " ".
021611*
021611*    Now we will do the same thing a newer way
021611*
021611     perform with test after
021611       varying ws-cobol from 1 by 1
021611       until ws-cobol is greater than ws-fortran
021611         move ws-cobol to ws-ed1s
021611         display "I) COBOL at ", ws-ed1s
021611         evaluate ws-cobol
021611           when 1
021611             display "I) COBOL still creeping up on C"
021611           when 3
021611             display "I) COBOL surpassed C and FORTRAN"
021611         end-evaluate
021611     end-perform.
021611*
001140     DISPLAY "I) PROGRAM ", WS-PROGRAM-NAME, " TERMINATED".
001150*
001160     STOP RUN.

The explanation was then updated

    In an effort to show how the language has changed, I offer the
following version of Brian's program.  While many styles can be effectively
used in COBOL programming, this program is an example of the style used in
programming shops where I worked.

    The first six columns of each source line were reserved for the source
code sequence number (usually page and line number).  We generally used the
first three columns to represent the ascending page number and the last three
for the line number on the page.  Skipping ten numbers between each original
line allowed us to insert additional lines when needed.  You can see that an
insertion was made at 001045.  These sequence numbers were desirable in that
the program was punched on cards with one card for each line.  If the source
card deck was accidently dropped the sequence numbers allowed us to get the
source deck back into order.

     You will also notice that the code is all in uppercase.  Quite simply,
early line printers could not print lowercase.  Take a look at line 001080.
While even early compilers would have allowed us to write "VALUE O" we
would spell out the word zero since the difference in appearance between
an alphabetic letter O and a numeric zero was easy to miss when reading
the program.

     All of the environment division has been left out of this program,
although it was almost always necessary.  The numbers after "FOREVERLOOP"
on line 001070 were the version number of the program.  It was our habit
to keep a journal (in comment lines) at the beginning of the program
describing modifications that were made to the program.

     The variable names start with "WS-".  This allowed the reader of the
program to understand that the variable in question was in the WORKING-
STORAGE instead of being part of a file descriptor, thus making it easier
to find.

     Numeric fields were almost always signed, both for efficiency
at run-time and to allow for the possibility of a value going negative even
if it should not.  COMP asked the compiler to use the most efficient method
to store the value on the architecture on which the program was going to run.

     You will see that the display statements start their display with "I) ".
We used this to make reading console output easier.  "I)" was for normal
information, "W)" was for warnings, and "T)" was for terminal conditions.

     From a syntactical standpoint this code was written to the COBOL-68
standard.  Structured programming constructs were not available.

     Paragraphs were numbered in ascending sequence in order to make
finding a paragraph easier.

*************************

     Version 002 shows how one might code the application with OpenCOBOL 1.1.

     A modification log has been added via comments at the beginning of
the program.

     Note that the sequence numbers are now being used to store the
date that the new or changed code was made.  By looking at the modification
date and then referring to the modification log, one can determine what
changed from version to version.

     Structured programming constructs have been used.

I expect that there may be some discussion as to which method is easier to
read and understand.

jimc
----------------------------------------------------------------

This is a variation of the 'perform forever' program.

       >>SOURCE FORMAT IS FREE
program-id. "readForever".
*>
*>
*> Author.       rkeane
*> Written:      16 Feb 2011
*> Purpose:      A variation of submitted "read-forever"
*>
environment division.
input-output section.
file-control.
    select my-file assign to "myFile"
      organization line sequential.

data division.
file section.
fd  myFile.
01  myRecord                           pic x(80).
working-storage section.
*>
procedure division.
main.
  open input myFile

  perform forever
    read myFile
      not at end
        display myRecord

      at end
        perform finish
        goback               *>Program exit
    end-read                 *>End read myFile
  end-perform                *>End perform forever
exit.

finish.
  close my-file
exit.

Using non-structured statements:

procedure division.
main.
  open input myFile.
0100-loop.
  read myFile next record
    at end close myFile
           stop run.
  display myRecord.
  go to 0100-loop.
----------------------------------------------------------------

I don't know if anyone else is getting this sensation, but is COBOL becoming
cool enough for the internet generation now? Thanks to open folk and OpenCOBOL?
[i]Or did I just jinx the tide?[/i]  :-)

Cheers,
Brian
----------------------------------------------------------------

Yep,
One thing that I saw on earlier posts to
the newsgroup cobol was -
What is the need/justification for an
empty inline perform group.
ie.
PERFORM
...
END-PERFORM

None of the discussions then realized that
there is a -
EXIT PERFORM [CYCLE]

Therefore, it is a method to to
define an exit condition without having paragraphs.

ie. (very simply)
PERFORM
 READ xxx
 AT END
    EXIT PERFORM
 END-READ
 MOVE something TO somewhere
END-PERFORM

.. test xxx status and somewhere

There are, of course, other variations.
Basically, it means that you code without
using section/paragraphs.
(Recommended, if only from performance point of view)

Note that the CYCLE option offers interesting possibilities.

Roger

000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. BITWISE.
000300 AUTHOR. PAUL CHANDLER.
000400********************************************************
000500***                                                  ***
000600*** COPYRIGHT PAUL CHANDLER 1976, 1994, 2012.        ***
000700***                                                  ***
000800*** THIS PROGRAM IS FREE SOFTWARE: YOU CAN           ***
000900*** REDISTRIBUTE IT AND/OR MODIFY IT UNDER THE TERMS ***
001000*** OF THE GNU LESSER GENERAL PUBLIC LICENSE AS      ***
001100*** PUBLISHED BY THE FREE SOFTWARE FOUNDATION, EITHER***
001200*** VERSION 3 OF THE LICENSE, OR (AT YOUR OPTION) ANY***
001300*** LATER VERSION.                                   ***
001400***                                                  ***
001500*** THIS PROGRAM IS DISTRIBUTED IN THE HOPE THAT IT  ***
001600*** WILL BE USEFUL,BUT WITHOUT ANY WARRANTY; WITHOUT ***
001700*** EVEN THE IMPLIED WARRANTY OF MERCHANTABILITY OR  ***
001800*** FITNESS FOR A PARTICULAR PURPOSE.SEE THE GNU     ***
001900*** LESSER GENERAL PUBLIC LICENSE FOR MORE DETAILS.  ***
002000***                                                  ***
002100*** YOU SHOULD HAVE RECEIVED A COPY OF THE GNU LESSER***
002200*** GENERAL PUBLIC LICENSE ALONG WITH THIS PROGRAM.  ***
002300*** IF  NOT, A COPY MAY BE OBTAINED AT:              ***
002400***            HTTP://WWW.GNU.ORG/LICENSES/          ***
002500***                                                  ***
002600***        ===== BITWISE VERSION 1.0 =====           ***
002700***                                                  ***
002800*** INITIAL VERSION: JULY 1974.                      ***
002900*** LAST UPDATED...: APRIL 2013                      ***
003000***                                                  ***
003100*** THIS PROGRAM PERFORMS BITWISE OPERATIONS ON AN   ***
003200*** INPUT BYTE, USING THE PRINCIPLE  OF 'INVERSE     ***
003300*** BINARY WEIGHTING'.                               ***
003400***                                                  ***
003500*** THE PROCESS IS:                                  ***
003600*** (A) THE CONTENTS OF THE LINKAGE SECTION          ***
003700***     (BITWISE-PARMS) ARE SYNTAX-CHECKED. IF ERRORS***
003800***     ARE ENCOUNTERED, A CODE IDENTIFYING THE      ***
003900***     ERROR IS RETURNED TO THE CALLING PROGRAM IN  ***
004000***     FIELD BWP-RETURN-CODE.                       ***
004100*** (B) THE UNARY OPERAND (AND THE BINARY OPERAND IF ***
004200***     OP IS  'AND', 'OR', OR 'XOR') ARE CONVERTED  ***
004300***     TO AN  8-CHARACTER PATTERN OF THE VALUE'S    ***
004400***     BINARY EQUIVALENT (EG. 'A' IS CONVERTED TO   ***
004500***     '01000001' IN THE ASCII CHARACTER SET.       ***
004600***                                                  ***
004700*** (C) THE OP SPECIFIED IN FLD  BWP-OP IS PERFORMED ***
004800***     USING THE OPERANDS AS APPROPRIATE. THE RESULT***
004900***     IS TEMPORARILY STORED AS AN 8-CHARACTER      ***
005000***     PATTERN IN FIELD BWP-RESULT.                 ***
005100***                                                  ***
005200*** (D) BWP-RESULT IS CONVERTED TO THE FORMAT SET BY ***
005300***     THE CALLING PROGRAM IN FIELD BWP-FMT-RESULT  ***
005400***     AND CONTROL IS RETURNED TO THE CALLER.       ***
005500***                                                  ***
005600*** ADDITIONAL DETAIL FOR THE USE OF THIS PROGRAM    ***
005700*** IS PROVIDED IN THE ACCOMPANYING DOCUMENTATION.   ***
005800********************************************************
005900 ENVIRONMENT DIVISION.
006000 DATA DIVISION.
006100 FILE SECTION.
006200 WORKING-STORAGE SECTION.
006300 01  WORKBENCH-FLDS.
006400     05  WBF-FLAGS.
006500         10  WBF-FLAG-VALIDATE     PIC X(01).
006600             88  WBF-INPUT-VALID     VALUE 'Y'.
006700     05  WBF-BINARIES              BINARY.
006800         10  WBF-STARTING-WEIGHT   PIC S9(04)
006900                                     VALUE +128.
007000         10  WBF-SCALE             PIC S9(04).
007100         10  WBF-CURRENT-BIT       PIC S9(04).
007200         10  WBF-CHK-PTN-CNT       PIC S9(04).
007300             88 WBF-CHK-PTN-ERR    VALUE 0 THRU 7.
007400     05  WBF-CHAR.
007500         10  WBF-UNARY             PIC X(08).
007600         10  WBF-BINARY            PIC X(08).
007700         10  WBF-CHK               PIC X(08).
007800         10  WBF-CHK-PTN-RDF REDEFINES WBF-CHK.
007900             15 WBF-CHK-PTN        PIC X(08).
008000         10  WBF-CHK-BIN-RDF REDEFINES WBF-CHK.
008100             15 WBF-CHK-BIN        PIC 9(04)  BINARY.
008200                88 WBF-CHK-BIN-OK    VALUE 0 THRU 255.
008300             15 FILLER             PIC X(06).
008400     05  WBF-INPT-VAL.
008500         10 WBF-INPT-AREA-CHR.
008600            15 FILLER              PIC X(01)
008700                                     VALUE LOW-VALUES.
008800            15 WBF-INPT-VAL-CHR    PIC X(01).
008900         10 WBF-INPT-AREA-BIN REDEFINES WBF-INPT-AREA-CHR.
009000            15 WBF-INPT-VAL-BIN    PIC 9(04)  BINARY.
009100     05  WBF-PACK-FMT              PIC X(01).
009200         88  WBF-PACK-FMT-PTRN       VALUE 'P'.
009300         88  WBF-PACK-FMT-BNRY       VALUE 'B'.
009400         88  WBF-PACK-FMT-CHAR       VALUE 'C'.
009500     05  WBF-PACK                  PIC X(08).
009600     05  WBF-PACK-RDF-BIN REDEFINES WBF-PACK.
009700         10  WBF-PACK-BIN          PIC 9(04)  BINARY.
009800         10  WFILLER               PIC X(06).
009900     05  WBF-PACK-RDF-CHR REDEFINES WBF-PACK.
010000         10  FILLER                PIC X(01).
010100         10  WBF-PACK-CHR          PIC X(01).
010200         10  FILLER                PIC X(06).
010300 LINKAGE SECTION.
010400 COPY BWPARMS.
010500 PROCEDURE DIVISION USING BITWISE-PARMS.
010600     PERFORM 10000-VALIDATE
010700     IF  BWP-NO-ERRORS
010800         IF  BWP-OP-XLAT
010900             PERFORM 20000-BWP-OP-XLAT
011000         ELSE
011100             PERFORM 30000-BWP-OP-TEST
011200         END-IF
011300     END-IF
011400     GOBACK
011500     .
011600 10000-VALIDATE.
011700     SET BWP-NO-ERRORS             TO TRUE
011800     IF  NOT BWP-OP-VALID
011900         SET BWP-OP-ERROR          TO TRUE
012000     END-IF
012100     IF  NOT BWP-FMT-UNARY-VALID
012200         SET BWP-FMT-UNARY-ERROR   TO TRUE
012300     END-IF
012400     IF  BWP-FMT-UNARY-PTRN
012500         MOVE BWP-UNARY-PTN        TO WBF-CHK-PTN
012600         PERFORM 11000-CHK-PTN
012700         IF  WBF-CHK-PTN-ERR
012800             SET BWP-PTN-UNARY-ERROR
012900                                   TO TRUE
013000         END-IF
013100     END-IF
013200     IF  BWP-FMT-UNARY-BNRY
013300         MOVE BWP-UNARY-BIN        TO WBF-CHK-BIN
013400         IF  NOT WBF-CHK-BIN-OK
013500             SET BWP-UNARY-OVF-ERROR
013600                                   TO TRUE
013700         END-IF
013800     END-IF
013900     IF  BWP-OP-BINARY
014000         IF NOT BWP-FMT-BINARY-VALID
014100            SET BWP-FMT-BINARY-ERROR
014200                                   TO TRUE
014300         END-IF
014400         IF BWP-FMT-BINARY-PTRN
014500             MOVE BWP-BINARY-PTN   TO WBF-CHK-PTN
014600             PERFORM 11000-CHK-PTN
014700             IF WBF-CHK-PTN-ERR
014800                 SET BWP-PTN-BINARY-ERROR
014900                                   TO TRUE
015000             END-IF
015100         END-IF
015200         IF BWP-FMT-BINARY-BNRY
015300             MOVE BWP-BINARY-BIN    TO WBF-CHK-BIN
015400             IF NOT WBF-CHK-BIN-OK
015500                 SET BWP-BINARY-OVF-ERROR
015600                                       TO TRUE
015700             END-IF
015800         END-IF
015900     END-IF
016000     IF  NOT BWP-FMT-RESULT-VALID
016100         SET BWP-FMT-RESULT-ERROR  TO TRUE
016200     END-IF
016300     .
016400 11000-CHK-PTN.
016500     MOVE ZERO                     TO WBF-CHK-PTN-CNT
016600     INSPECT WBF-CHK-PTN
016700       TALLYING WBF-CHK-PTN-CNT    FOR ALL '0'
016800     INSPECT WBF-CHK-PTN
016900       TALLYING WBF-CHK-PTN-CNT    FOR ALL '1'
017000     .
017100 20000-BWP-OP-XLAT.
017200     MOVE BWP-FMT-UNARY            TO WBF-PACK-FMT
017300     EVALUATE TRUE
017400     WHEN BWP-FMT-UNARY-BNRY
017500         MOVE BWP-UNARY-BIN        TO WBF-PACK-BIN
017600     WHEN BWP-FMT-UNARY-CHAR
017700         MOVE BWP-UNARY-CHR        TO WBF-PACK-CHR
017800     WHEN OTHER
017900         MOVE BWP-UNARY            TO WBF-PACK
018000     END-EVALUATE
018100     PERFORM 40000-PACK
018200     PERFORM 50000-TRANSLATE
018300     IF  BWP-FMT-RESULT-BNRY
018400     OR  BWP-FMT-RESULT-CHAR
018500         MOVE BWP-RESULT           TO WBF-PACK
018600         MOVE 'P'                  TO WBF-PACK-FMT
018700         PERFORM 40000-PACK
018800         IF  BWP-FMT-RESULT-BNRY
018900             MOVE SPACES           TO BWP-RESULT
019000             MOVE WBF-PACK-BIN     TO BWP-RESULT-BIN
019100         ELSE
019200             MOVE SPACES           TO BWP-RESULT
019300             MOVE WBF-PACK-CHR     TO BWP-RESULT-CHR
019400         END-IF
019500     END-IF
019600     .
019700 30000-BWP-OP-TEST.
019800     MOVE BWP-UNARY                TO WBF-PACK
019900     EVALUATE TRUE
020000     WHEN BWP-FMT-UNARY-BNRY
020100         MOVE BWP-UNARY-BIN        TO WBF-PACK-BIN
020200     WHEN BWP-FMT-UNARY-CHAR
020300         MOVE BWP-UNARY-CHR        TO WBF-PACK-CHR
020400     WHEN OTHER
020500         MOVE BWP-UNARY            TO WBF-PACK
020600     END-EVALUATE
020700     MOVE BWP-FMT-UNARY            TO WBF-PACK-FMT
020800     PERFORM 40000-PACK
020900     PERFORM 50000-TRANSLATE
021000     MOVE BWP-RESULT               TO WBF-UNARY
021100     MOVE BWP-BINARY               TO WBF-PACK
021200     MOVE BWP-FMT-BINARY           TO WBF-PACK-FMT
021300     EVALUATE TRUE
021400     WHEN BWP-FMT-BINARY-BNRY
021500         MOVE BWP-BINARY-BIN       TO WBF-PACK-BIN
021600     WHEN BWP-FMT-BINARY-CHAR
021700         MOVE BWP-BINARY-CHR       TO WBF-PACK-CHR
021800     WHEN OTHER
021900         MOVE BWP-BINARY           TO WBF-PACK
022000     END-EVALUATE
022100     PERFORM 40000-PACK
022200     PERFORM 50000-TRANSLATE
022300     MOVE BWP-RESULT               TO WBF-BINARY
022400     MOVE ZEROES                   TO BWP-RESULT
022500     EVALUATE TRUE
022600     WHEN BWP-OP-AND
022700         PERFORM VARYING WBF-CURRENT-BIT FROM 1 BY 1
022800         UNTIL WBF-CURRENT-BIT > 8
022900             IF  WBF-BINARY (WBF-CURRENT-BIT:1) = '1'
023000             AND WBF-UNARY    (WBF-CURRENT-BIT:1) = '1'
023100                 MOVE '1'          TO BWP-RESULT
023200                                     (WBF-CURRENT-BIT:1)
023300             END-IF
023400         END-PERFORM
023500     WHEN BWP-OP-OR
023600         PERFORM VARYING WBF-CURRENT-BIT FROM 1 BY 1
023700         UNTIL WBF-CURRENT-BIT > 8
023800             IF  WBF-BINARY (WBF-CURRENT-BIT:1) = '1'
023900             OR  WBF-UNARY    (WBF-CURRENT-BIT:1) = '1'
024000                 MOVE '1'          TO BWP-RESULT
024100                                     (WBF-CURRENT-BIT:1)
024200             END-IF
024300         END-PERFORM
024400     WHEN BWP-OP-XOR
024500         PERFORM VARYING WBF-CURRENT-BIT FROM 1 BY 1
024600         UNTIL WBF-CURRENT-BIT > 8
024700             IF  WBF-UNARY    (WBF-CURRENT-BIT:1) NOT EQUAL
024800                 WBF-BINARY (WBF-CURRENT-BIT:1)
024900                 MOVE '1'          TO BWP-RESULT
025000                                     (WBF-CURRENT-BIT:1)
025100             END-IF
025200         END-PERFORM
025300     WHEN BWP-OP-NOT
025400         PERFORM VARYING WBF-CURRENT-BIT FROM 1 BY 1
025500         UNTIL WBF-CURRENT-BIT > 8
025600             IF  WBF-UNARY    (WBF-CURRENT-BIT:1) = '0'
025700                 MOVE '1'          TO BWP-RESULT
025800                                     (WBF-CURRENT-BIT:1)
025900             END-IF
026000         END-PERFORM
026100     END-EVALUATE
026200     IF  BWP-FMT-RESULT-BNRY
026300     OR  BWP-FMT-RESULT-CHAR
026400         MOVE BWP-RESULT           TO WBF-PACK
026500         MOVE 'P'                  TO WBF-PACK-FMT
026600         PERFORM 40000-PACK
026700         IF  BWP-FMT-RESULT-BNRY
026800             MOVE SPACES           TO BWP-RESULT
026900             MOVE WBF-PACK-BIN     TO BWP-RESULT-BIN
027000         ELSE
027100             MOVE SPACES           TO BWP-RESULT
027200             MOVE WBF-PACK-CHR     TO BWP-RESULT-CHR
027300         END-IF
027400     END-IF
027500     .
027600 40000-PACK.
027700     EVALUATE TRUE
027800     WHEN WBF-PACK-FMT-BNRY
027900         MOVE WBF-PACK-BIN         TO WBF-INPT-VAL-BIN
028000     WHEN WBF-PACK-FMT-CHAR
028100         MOVE WBF-PACK-CHR         TO WBF-INPT-VAL-CHR
028200     WHEN OTHER
028300         MOVE 0                    TO WBF-INPT-VAL-BIN
028400         MOVE WBF-STARTING-WEIGHT  TO WBF-SCALE
028500         PERFORM VARYING WBF-CURRENT-BIT FROM 1 BY 1
028600         UNTIL WBF-CURRENT-BIT > 8
028700             IF  WBF-PACK (WBF-CURRENT-BIT:1) = '1'
028800                 ADD WBF-SCALE
028900                                   TO WBF-INPT-VAL-BIN
029000            END-IF
029100            COMPUTE WBF-SCALE = WBF-SCALE / 2
029200         END-PERFORM
029300         MOVE SPACES               TO WBF-PACK
029400         MOVE WBF-INPT-VAL-BIN     TO WBF-PACK-BIN
029500     END-EVALUATE
029600     .
029700 50000-TRANSLATE.
029800     MOVE WBF-STARTING-WEIGHT      TO WBF-SCALE
029900     MOVE ALL ZEROES               TO BWP-RESULT
030000     MOVE 1                        TO WBF-CURRENT-BIT
030100     PERFORM VARYING WBF-CURRENT-BIT FROM 1 BY 1
030200     UNTIL WBF-CURRENT-BIT > 8
030300        IF   WBF-INPT-VAL-BIN >= WBF-SCALE
030400            MOVE '1'               TO BWP-RESULT
030500                                     (WBF-CURRENT-BIT:1)
030600            COMPUTE WBF-INPT-VAL-BIN =
030700                    WBF-INPT-VAL-BIN - WBF-SCALE
030800        END-IF
030900        COMPUTE WBF-SCALE = WBF-SCALE / 2
031000     END-PERFORM
031100     .
031200 END PROGRAM BITWISE.

000010*****************************************************************
000020* CALLING AREA FOR THE 'BITWISE' SUBPROGRAM                     *
000021* WRITTEN BY.....: PAUL CHANDLER.                               *
000022* INITIAL VERSION: JULY 1974.                                   *
000023* LAST MODIFIED..: APRIL 2013.                                  *
000030*****************************************************************
000100 01 BITWISE-PARMS.                                                00010000
000200    05  BWP-UNARY                  PIC X(08).
000210    05  BWP-UNARY-RDF-PTN   REDEFINES BWP-UNARY.
000220        10  BWP-UNARY-PTN          PIC X(08).
000300    05  BWP-UNARY-RDF-BIN   REDEFINES BWP-UNARY.
000400        10  BWP-UNARY-BIN          PIC 9(04) BINARY.
000500        10  FILLER                 PIC X(06).
000600    05  BWP-UNARY-RDF-CHR   REDEFINES BWP-UNARY.
000700        10  BWP-UNARY-CHR          PIC X(01).
000800        10  FILLER                 PIC X(07).
000900    05  BWP-BINARY                 PIC X(08).
000910    05  BWP-BINARY-RDF-PTN  REDEFINES BWP-BINARY.
000920        10  BWP-BINARY-PTN         PIC X(08).
001000    05  BWP-BINARY-RDF-BIN  REDEFINES BWP-BINARY.
001100        10  BWP-BINARY-BIN         PIC 9(04) BINARY.
001200        10  FILLER                 PIC X(06).
001300    05  BWP-BINARY-RDF-CHR  REDEFINES BWP-BINARY.
001400        10  BWP-BINARY-CHR         PIC X(01).
001500        10  FILLER                 PIC X(07).
001600    05  BWP-RESULT                 PIC X(08).
001610    05  BWP-RESULT-RDF-PTN  REDEFINES BWP-RESULT.
001620        10  BWP-RESULT-PTN         PIC X(08).
001700    05  BWP-RESULT-RDF-BIN  REDEFINES BWP-RESULT.
001800        10  BWP-RESULT-BIN         PIC 9(04) BINARY.
001900        10  FILLER                 PIC X(06).
002000    05  BWP-RESULT-RDF-CHR  REDEFINES BWP-RESULT.
002100        10  BWP-RESULT-CHR         PIC X(01).
002200        10  FILLER                 PIC X(07).
002300    05  BWP-OP                     PIC X(04).
002500        88 BWP-OP-XLAT               VALUE 'XLAT'.
002600        88 BWP-OP-AND                VALUE 'AND '.
002700        88 BWP-OP-OR                 VALUE 'OR  '.
002800        88 BWP-OP-XOR                VALUE 'XOR '.
002900        88 BWP-OP-NOT                VALUE 'NOT '.
003000        88 BWP-OP-UNARY              VALUE 'NOT ',
003100                                           'XLAT'.
003200        88 BWP-OP-BINARY             VALUE 'AND ',
003300                                           'OR  ',
003400                                           'XOR '.
003500        88 BWP-OP-VALID              VALUE 'NOT ',
003600                                           'XLAT',
003700                                           'AND ',
003800                                           'OR  ',
003900                                           'XOR '.
004000    05  BWP-FMTS.
004100        10  BWP-FMT-UNARY          PIC X(01).
004300            88 BWP-FMT-UNARY-PTRN    VALUE 'P'.
004400            88 BWP-FMT-UNARY-BNRY    VALUE 'B'.
004500            88 BWP-FMT-UNARY-CHAR    VALUE 'C'.
004600            88 BWP-FMT-UNARY-VALID   VALUE 'B'
004700                                           'C'
004800                                           'P'.
005000        10  BWP-FMT-BINARY         PIC X(01).
005200            88 BWP-FMT-BINARY-PTRN   VALUE 'P'.
005300            88 BWP-FMT-BINARY-BNRY   VALUE 'B'.
005400            88 BWP-FMT-BINARY-CHAR   VALUE 'C'.
005500            88 BWP-FMT-BINARY-VALID  VALUE 'B'
005600                                           'C'
005700                                           'P'.
005800        10  BWP-FMT-RESULT         PIC X(01).
006000            88 BWP-FMT-RESULT-PTRN   VALUE 'P'.
006100            88 BWP-FMT-RESULT-BNRY   VALUE 'B'.
006200            88 BWP-FMT-RESULT-CHAR   VALUE 'C'.
006300            88 BWP-FMT-RESULT-VALID  VALUE 'B'
006400                                           'C'
006500                                           'P'.
006600        10  BWP-RETURN-CODE        PIC 9(01).
006800            88 BWP-NO-ERRORS         VALUE 0.
006900            88 BWP-OP-ERROR          VALUE 1.
007000            88 BWP-FMT-UNARY-ERROR   VALUE 2.
007100            88 BWP-FMT-BINARY-ERROR  VALUE 3.
007200            88 BWP-FMT-RESULT-ERROR  VALUE 4.
007300            88 BWP-PTN-UNARY-ERROR   VALUE 5.
007400            88 BWP-PTN-BINARY-ERROR  VALUE 6.
007500            88 BWP-UNARY-OVF-ERROR   VALUE 7.
007600            88 BWP-BINARY-OVF-ERROR  VALUE 8.

000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID. DEMO.                                                00020016
000300 AUTHOR. PAUL CHANDLER, APRIL 2013.                               00030014
000400********************************************************          00040000
000500*** THIS PROGRAM DEMO'S THE BITWISE TOOLBOX          ***          00050036
000600********************************************************          00060000
000700 ENVIRONMENT DIVISION.                                            00070000
000800 DATA DIVISION.                                                   00080000
000900 FILE SECTION.                                                    00090000
001000 WORKING-STORAGE SECTION.                                         00100000
001100 01  WS-BITWISE                    PIC X(08)                      00110036
001200                                     VALUE 'BITWISE '.            00120037
001300 COPY BWPARMS.                                                    00130036
001400 PROCEDURE DIVISION.                                              00140000
001500***===                                       ===***               00150039
001600***===      TEST #1                          ===***               00160039
001700***===  A SIMPLE CONVERSION. GET A DISPLAYABLE =***               00170039
001800***===  BIT BATTERN FOR THE CHARACTER 'A'      =***               00180039
001900***===                                       ===***               00190039
002000     DISPLAY '*                '                                  00200029
002100     DISPLAY                                                      00210028
002200     '*** CASE 1 - TRANSLATE ''A'', RETURN PATTERN ***'           00220028
002300     DISPLAY '*                '                                  00230029
002400     MOVE 'XLAT'                   TO BWP-OP                      00240039
002500     MOVE 'A'                      TO BWP-UNARY-CHR               00250039
002600     MOVE 'C'                      TO BWP-FMT-UNARY               00260036
002700     MOVE SPACES                   TO BWP-BINARY                  00270036
002800                                      BWP-FMT-BINARY              00280036
002900     MOVE 'P'                      TO BWP-FMT-RESULT              00290036
003000     PERFORM DISPLAY-INPUT                                        00300023
003100     CALL WS-BITWISE               USING BITWISE-PARMS            00310036
003200     PERFORM DISPLAY-RETURN                                       00320024
003300*                                                                 00330030
003400***===                                       ===***               00340039
003500***===      TEST #2                          ===***               00350039
003600***===  CONVERT THE PATTERN GENERATED IN CASE 1=***               00360039
003700***===  TO ITS NUMERIC EQUIVALENT.             =***               00370039
003800***===                                       ===***               00380039
003900     DISPLAY '*                '                                  00390029
004000     DISPLAY                                                      00400029
004100     '*** CASE 2 - TAKE THE PATTERN WE JUST GENERATED      *'     00410039
004200     '***          AND DISPLAY ITS NUMERIC VALUE           *'     00420039
004300     DISPLAY '*                '                                  00430029
004400     MOVE BWP-RESULT-PTN           TO BWP-UNARY                   00440039
004500     MOVE 'P'                      TO BWP-FMT-UNARY               00450036
004600     MOVE 'B'                      TO BWP-FMT-RESULT              00460036
004700     PERFORM DISPLAY-INPUT                                        00470029
004800     CALL WS-BITWISE               USING BITWISE-PARMS            00480036
004900     PERFORM DISPLAY-RETURN                                       00490029
005000*                                                                 00500030
005100*                                                                 00510039
005200***===                                       ===***               00520039
005300***===      TEST #3                          ===***               00530039
005400***===  CONVERT THE NUMERIC GENERATED IN CASE 2=***               00540039
005500***===  TO ITS CHARACTER EQUIVALENT, BRINGING  =***               00550039
005600***===  US BACK TO THE 'A' INPUT OF CASE 1     =***               00560039
005700***===                                       ===***               00570039
005800     DISPLAY '*                '                                  00580030
005900     DISPLAY                                                      00590030
006000     '*** CASE 3 - TRANSLATE NUMERIC, RETURN CHAR  ***'           00600030
006100     DISPLAY '*                '                                  00610030
006200     MOVE BWP-RESULT-BIN           TO BWP-UNARY-BIN               00620039
006300     MOVE 'B'                      TO BWP-FMT-UNARY               00630036
006400     MOVE 'C'                      TO BWP-FMT-RESULT              00640036
006500     PERFORM DISPLAY-INPUT                                        00650030
006600     CALL WS-BITWISE               USING BITWISE-PARMS            00660036
006700     PERFORM DISPLAY-RETURN                                       00670030
006800*                                                                 00680030
006810*                                                                 00681039
006820***===                                       ===***               00682039
006830***===      TEST #4                          ===***               00683039
006840***===  'OR' 2  NUMERICS TOGETHER AND RETURN ===***               00684039
006850***===  THE RESULTING BINARY PATTERN           =***               00685039
006870***===                                       ===***               00687039
006900     DISPLAY '*                '                                  00690031
007000     DISPLAY                                                      00700031
007100     '*** CASE 4 - ''OR'' 15 & 240, RETURN PATTERN**'             00710031
007200     DISPLAY '*                '                                  00720031
007300     MOVE 'OR  '                   TO BWP-OP                      00730036
007400     MOVE 15                       TO BWP-UNARY-BIN               00740036
007500     MOVE 240                      TO BWP-BINARY-BIN              00750036
007600     MOVE 'B'                      TO BWP-FMT-UNARY               00760036
007700                                      BWP-FMT-BINARY              00770036
007800     MOVE 'P'                      TO BWP-FMT-RESULT              00780036
007900     PERFORM DISPLAY-INPUT                                        00790031
008000     CALL WS-BITWISE               USING BITWISE-PARMS            00800036
008100     PERFORM DISPLAY-RETURN                                       00810031
008200*                                                                 00820031
008220***===                                       ===***               00822039
008230***===      TEST #5                          ===***               00823039
008240***===  'AND' 2 NUMERICS TOGETHER AND RETURN ===***               00824039
008250***===  THE RESULTING BINARY PATTERN           =***               00825039
008260***===                                       ===***               00826039
008270*                                                                 00827039
008300     DISPLAY '*                '                                  00830032
008400     DISPLAY                                                      00840032
008500     '*** CASE 5 - ''AND'' 255 & 70, RETURN PATTERN**'            00850032
008600     DISPLAY '*                '                                  00860032
008700     MOVE 'AND '                   TO BWP-OP                      00870036
008800     MOVE 255                      TO BWP-UNARY-BIN               00880036
008900     MOVE  70                      TO BWP-BINARY-BIN              00890036
009000     MOVE 'B'                      TO BWP-FMT-UNARY               00900036
009100                                      BWP-FMT-BINARY              00910036
009200     MOVE 'P'                      TO BWP-FMT-RESULT              00920036
009300     PERFORM DISPLAY-INPUT                                        00930032
009400     CALL WS-BITWISE               USING BITWISE-PARMS            00940036
009500     PERFORM DISPLAY-RETURN                                       00950032
009510*                                                                 00951039
009520***===                                       ===***               00952039
009530***===      TEST #6                          ===***               00953039
009540***===  'NOT' A RANDOM PATTERN. WE'LL RETURN ===***               00954039
009550***===  THE RSULT AS A PATTERN SO THAT THE BIT =***               00955039
009551***===  INVERSION IS EASIER TO SEE.            =***               00955139
009560***===                                       ===***               00956039
009570*                                                                 00957039
009700     DISPLAY '*                '                                  00970033
009800     DISPLAY                                                      00980033
009900     '*** CASE 6 - ''NOT'' A RANDOM PATTERN**'                    00990033
010000     DISPLAY '*                '                                  01000033
010100     MOVE 'NOT '                   TO BWP-OP                      01010036
010200     MOVE '10110101'               TO BWP-UNARY                   01020036
010300     MOVE 'P'                      TO BWP-FMT-UNARY               01030036
010400     PERFORM DISPLAY-INPUT                                        01040033
010500     CALL WS-BITWISE               USING BITWISE-PARMS            01050036
010600     PERFORM DISPLAY-RETURN                                       01060033
010610*                                                                 01061039
010620***===                                       ===***               01062039
010630***===      TEST #7                          ===***               01063039
010640***===  'XOR' 2 PATTERNS. AGAIN, WE'LL RETURN===***               01064039
010650***===  THE RSULT AS A PATTERN SO THAT THE BIT =***               01065039
010660***===  INTERACTIONS EASIER TO SEE.            =***               01066039
010670***===                                       ===***               01067039
010680*                                                                 01068039
010800     DISPLAY '*                '                                  01080035
010900     DISPLAY                                                      01090035
011000     '*** CASE 7 - ''XOR'' PATTERN VS PATTERN'                    01100035
011100     DISPLAY '*                '                                  01110035
011200     MOVE 'XOR '                   TO BWP-OP                      01120036
011300     MOVE '10110101'               TO BWP-UNARY                   01130036
011400     MOVE '01101100'               TO BWP-BINARY                  01140036
011500     MOVE 'P'                      TO BWP-FMT-UNARY               01150036
011600                                      BWP-FMT-BINARY              01160036
011700     PERFORM DISPLAY-INPUT                                        01170035
011800     CALL WS-BITWISE               USING BITWISE-PARMS            01180036
011900     PERFORM DISPLAY-RETURN                                       01190035
011910*                                                                 01191039
011920***===                                       ===***               01192039
011930***===      TESTS #8 AND #9                  ===***               01193039
011940***===  A COUPLE OF ERROR CASES. #8 TRIES TO ===***               01194039
011950***===  TRANSLATE A PATTERN NOT CORRECTLY SET  =***               01195039
011960***===  TO ONES AND ZEROES, #9 TRIES TO CONVERT=***               01196039
011961***===  A NUMERIC VALUE TOO LARGE TO FIT WITHIN=***               01196139
011970***===  ONE BYTE.                            ===***               01197039
011971***===                                       ===***               01197139
011980*                                                                 01198039
012100     DISPLAY '*                '                                  01210038
012200     DISPLAY                                                      01220038
012300     '*** CASE 8 - BAD PATTERN INPUT'                             01230039
012400     DISPLAY '*                '                                  01240038
012500     MOVE 'XLAT'                   TO BWP-OP                      01250038
012600     MOVE '1       '               TO BWP-UNARY                   01260038
012700     MOVE 'P'                      TO BWP-FMT-UNARY               01270038
012800     PERFORM DISPLAY-INPUT                                        01280038
012900     CALL WS-BITWISE               USING BITWISE-PARMS            01290038
013000     PERFORM DISPLAY-RETURN                                       01300038
013100*                                                                 01310038
013200     DISPLAY '*                '                                  01320038
013300     DISPLAY                                                      01330038
013400     '*** CASE 9 - BAD BINARY INPUT'                              01340039
013500     DISPLAY '*                '                                  01350038
013600     MOVE 256                      TO BWP-UNARY-BIN               01360038
013700     MOVE 'B'                      TO BWP-FMT-UNARY               01370038
013800     PERFORM DISPLAY-INPUT                                        01380038
013900     CALL WS-BITWISE               USING BITWISE-PARMS            01390038
014000     PERFORM DISPLAY-RETURN                                       01400038
014100*                                                                 01410038
014200     GOBACK                                                       01420038
014300     .                                                            01430004
014400 DISPLAY-INPUT.                                                   01440023
014500     DISPLAY '*                '                                  01450029
014600     DISPLAY '***** INPUT *****'                                  01460027
014700     DISPLAY '*                '                                  01470029
014800     DISPLAY 'OP.........: ' BWP-OP                               01480036
014900     IF  BWP-FMT-UNARY-BNRY                                       01490036
015000         DISPLAY 'UNARY......: ' BWP-UNARY-BIN                    01500036
015100     ELSE                                                         01510027
015200         DISPLAY 'UNARY......: ' BWP-UNARY                        01520036
015300     END-IF                                                       01530027
015400     DISPLAY 'UNARY FMT..: ' BWP-FMT-UNARY                        01540036
015500     IF  BWP-OP-BINARY                                            01550036
015600         IF  BWP-FMT-BINARY-BNRY                                  01560036
015700             DISPLAY 'BINARY.....: ' BWP-BINARY-BIN               01570036
015800         ELSE                                                     01580027
015900             DISPLAY 'BINARY.....: ' BWP-BINARY                   01590036
016000         END-IF                                                   01600027
016100         DISPLAY 'BINARY FMT.: ' BWP-FMT-BINARY                   01610036
016200     END-IF                                                       01620023
016300     DISPLAY 'RESULT FMT.: ' BWP-FMT-RESULT                       01630036
016400     .                                                            01640025
016500 DISPLAY-RETURN.                                                  01650023
016600     DISPLAY '***              '                                  01660027
016700     DISPLAY '**** RETURN  ****'                                  01670027
016800     DISPLAY '***              '                                  01680027
016900     IF  BWP-NO-ERRORS                                            01690036
017000         IF  BWP-FMT-RESULT-BNRY                                  01700036
017100             DISPLAY 'RESULT    = ' BWP-RESULT-BIN                01710036
017200         ELSE                                                     01720023
017300             DISPLAY 'RESULT    = ' BWP-RESULT                    01730036
017400         END-IF                                                   01740023
017500     ELSE                                                         01750023
017600         DISPLAY 'ERROR ' BWP-RETURN-CODE                         01760036
017700     END-IF                                                       01770023
017800     DISPLAY '*                '                                  01780031
017900     .                                                            01790025
018000 END PROGRAM DEMO.                                                01800016

*
*** CASE 1 - TRANSLATE 'A', RETURN PATTERN ***
*
*
***** INPUT *****
*
OP.........: XLAT
UNARY......: A
UNARY FMT..: C
RESULT FMT.: P
**** RETURN  ****
RESULT    = 01000001

*
*
*** CASE 2 - TAKE THE PATTERN WE JUST GENERATED      **
**           AND DISPLAY ITS NUMERIC VALUE           *
*
*
***** INPUT *****
*
OP.........: XLAT
UNARY......: 01000001
UNARY FMT..: P
RESULT FMT.: B
**** RETURN  ****
RESULT    = 0065
*

*
*** CASE 3 - TRANSLATE NUMERIC, RETURN CHAR  ***
*
*
***** INPUT *****
*
OP.........: XLAT
UNARY......: 0065
UNARY FMT..: B
RESULT FMT.: C
**** RETURN  ****
RESULT    = A
*

*
*** CASE 4 - 'OR' 15 & 240, RETURN PATTERN**
*
*
***** INPUT *****
*
OP.........: OR
UNARY......: 0015
UNARY FMT..: B
BINARY.....: 0240
BINARY FMT.: B
RESULT FMT.: P
**** RETURN  ****
RESULT    = 11111111
*

*
*** CASE 5 - 'AND' 255 & 70, RETURN PATTERN**
*
*
***** INPUT *****
*
OP.........: AND
UNARY......: 0255
UNARY FMT..: B
BINARY.....: 0070
BINARY FMT.: B
RESULT FMT.: P
**** RETURN  ****
RESULT    = 01000110
*

*
*** CASE 6 - 'NOT' A RANDOM PATTERN**
*
*
***** INPUT *****
*
OP.........: NOT
UNARY......: 10110101
UNARY FMT..: P
RESULT FMT.: P
**** RETURN  ****
RESULT    = 01001010
*

*
*** CASE 7 - 'XOR' PATTERN VS PATTERN
*
*
***** INPUT *****
*
OP.........: XOR
UNARY......: 10110101
UNARY FMT..: P
BINARY.....: 01101100
BINARY FMT.: P
RESULT FMT.: P
**** RETURN  ****
RESULT    = 11011001
*

*
*** CASE 8 - BAD PATTERN INPUT
*
*
***** INPUT *****
*
OP.........: XLAT
UNARY......: 1
UNARY FMT..: P
RESULT FMT.: P
**** RETURN  ****
ERROR 5
*

*
*** CASE 9 - BAD BINARY INPUT
*
*
***** INPUT *****
*
OP.........: XLAT
UNARY......: 0256
UNARY FMT..: B
RESULT FMT.: P
**** RETURN  ****
ERROR 7
*

[...] *
         MOVE 0 TO hVar3
         PERFORM UNTIL hVar3 > 2
           COMPUTE hVar3 = hVar3 + 1
           EXEC SQL
            SELECT
             TestCol1, TestCol2
            INTO
             :hVar1, :hVar2
            FROM
             TestTab
            WHERE TestCol1=:hVar3
           END-EXEC
           IF SQLCODE NOT < 0 AND NOT = 100
            DISPLAY 'SELECTED in LOOP iteration ' hVar3
            DISPLAY '  hVar1 ' hVar1 ' hVar2 ' hVar2
           END-IF
        END-PERFORM.
[...] *

GNU   *
Cobol *
       IDENTIFICATION DIVISION.
       PROGRAM-ID. esqlOCGetStart1.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       EXEC SQL
         BEGIN DECLARE SECTION
       END-EXEC.
       01  HOSTVARS.
           05 BUFFER               PIC X(1024).
           05 hVarD                PIC S9(5)V99.
           05 hVarC                PIC X(50).
           05 hVarN                PIC 9(12).
       EXEC SQL
          END DECLARE SECTION
       END-EXEC.
       PROCEDURE DIVISION.
       MAIN SECTION.
      *-----------------------------------------------------------------*
      * CONNECT TO THE DATABASE
      * also possible with DSN: 'youruser/yourpasswd@yourODBC_DSN'
      *-----------------------------------------------------------------*
         STRING 'DRIVER={MySQL ODBC 5.2w Driver};'
                'SERVER=localhost;'
                'PORT=3306;'
                'DATABASE=test;'
                'USER=youruser;'
                'PASSWORD=yourpasswd;'
      * example for DB specific ODBC parameter:
      *   no compressed MySQL connection (would be the DEFAULT anyway)
                'COMRESSED_PROTO=0;'
           INTO BUFFER.
         EXEC SQL
           CONNECT TO :BUFFER
         END-EXEC.
         PERFORM SQLSTATE-CHECK.
      *-----------------------------------------------------------------*
      * CREATE  TABLEs
      *-----------------------------------------------------------------*
      * TESTPERSON
         MOVE SPACES TO BUFFER.
         STRING
           'CREATE TABLE TESTPERSON('
             'ID DECIMAL(12,0), '
             'NAME CHAR(50) NOT NULL, '
             'PRIMARY KEY (ID))'
           INTO BUFFER.
         EXEC SQL
           EXECUTE IMMEDIATE  :BUFFER
         END-EXEC
         IF SQLSTATE='42S01'
           DISPLAY ' Table TESTPERSON already exists.'
         ELSE
           PERFORM SQLSTATE-CHECK
           DISPLAY ' created Table TESTPERSON'
           PERFORM INSDATAPERSON.
      * TESTGAME
         MOVE SPACES TO BUFFER.
         STRING
           'CREATE TABLE TESTGAME('
             'ID DECIMAL(12,0), '
             'NAME CHAR(50) NOT NULL, '
             'PRIMARY KEY (ID))'
           INTO BUFFER.
         EXEC SQL
           EXECUTE IMMEDIATE  :BUFFER
         END-EXEC
         IF SQLSTATE='42S01'
           DISPLAY ' Table TESTGAME already exists.'
         ELSE
           PERFORM SQLSTATE-CHECK
           DISPLAY ' created Table TESTGAME'
           PERFORM INSDATAGAME.
      * TESTPOINTS
         MOVE SPACES TO BUFFER.
         STRING
           'CREATE TABLE TESTPOINTS('
             'PERSONID DECIMAL(12,0), '
             'GAMEID DECIMAL(12,0), '
             'POINTS DECIMAL(6,2), '
             'CONSTRAINT POINTS_CONSTRAINT1 FOREIGN '
               'KEY (PERSONID) REFERENCES TESTPERSON(ID), '
             'CONSTRAINT POINTS_CONSTRAINT2 FOREIGN '
               'KEY (GAMEID) REFERENCES TESTGAME(ID),'
             'PRIMARY KEY (PERSONID, GAMEID))'
           INTO BUFFER.
         EXEC SQL
           EXECUTE IMMEDIATE  :BUFFER
         END-EXEC
         IF SQLSTATE='42S01'
           DISPLAY ' Table TESTPOINTS already exists.'
         ELSE
           PERFORM SQLSTATE-CHECK
           DISPLAY ' created Table TESTPOINTS'
           PERFORM INSDATAPOINTS.
      *-----------------------------------------------------------------*
      * SELECT SUM of POINTS for persons >1
      *-----------------------------------------------------------------*
         EXEC SQL
           SELECT
             SUM(POINTS)
           INTO
             :hVarD
           FROM
             TESTPERSON, TESTPOINTS
           WHERE PERSONID>1 AND PERSONID=ID
         END-EXEC
         PERFORM SQLSTATE-CHECK
         IF SQLCODE NOT = 100
           DISPLAY 'SELECTED '
           DISPLAY '  SUM of POINTS for persons >1 ' hVarD
         ELSE
           DISPLAY ' No points found'
         END-IF.
      *-----------------------------------------------------------------*
      * SELECT ALL with CURSORS
      *-----------------------------------------------------------------*
         EXEC SQL
           DECLARE CUR_ALL CURSOR FOR
           SELECT
             TESTPERSON.NAME,
             POINTS
           FROM
             TESTPERSON, TESTPOINTS
           WHERE PERSONID=ID
         END-EXEC
         PERFORM SQLSTATE-CHECK
         EXEC SQL
           OPEN CUR_ALL
         END-EXEC
         PERFORM SQLSTATE-CHECK
         PERFORM UNTIL SQLCODE = 100
           EXEC SQL
             FETCH CUR_ALL
             INTO
               :hVarC,
               :hVarD
           END-EXEC
           PERFORM SQLSTATE-CHECK
           IF SQLCODE NOT = 100
             DISPLAY 'FETCHED '
             DISPLAY '  person ' hVarC ' points: ' hVarD
           ELSE
             DISPLAY ' No points found'
           END-IF
         END-PERFORM.
      *-----------------------------------------------------------------*
      * DROP  TABLEs
      *-----------------------------------------------------------------*
      *   MOVE 'DROP TABLE TESTPOINTS' TO BUFFER.
      *   EXEC SQL
      *     EXECUTE IMMEDIATE  :BUFFER
      *   END-EXEC
      *   PERFORM SQLSTATE-CHECK.
      *   MOVE 'DROP TABLE TESTGAME' TO BUFFER.
      *   EXEC SQL
      *     EXECUTE IMMEDIATE  :BUFFER
      *   END-EXEC
      *   PERFORM SQLSTATE-CHECK.
      *   MOVE 'DROP TABLE TESTPERSON' TO BUFFER.
      *   EXEC SQL
      *     EXECUTE IMMEDIATE  :BUFFER
      *   END-EXEC
      *   PERFORM SQLSTATE-CHECK.
      *   DISPLAY ' dropped Tables '
      *-----------------------------------------------------------------*
      * COMMIT CHANGES
      *-----------------------------------------------------------------*
         EXEC SQL
           COMMIT
         END-EXEC.
         PERFORM SQLSTATE-CHECK.
      *-----------------------------------------------------------------*
      * DISCONNECT FROM THE DATABASE
      *-----------------------------------------------------------------*
         EXEC SQL
           CONNECT RESET
         END-EXEC.
         PERFORM SQLSTATE-CHECK.
         STOP RUN.
         .
      *-----------------------------------------------------------------*
      * CHECK SQLSTATE AND DISPLAY ERRORS IF ANY
      *-----------------------------------------------------------------*
       SQLSTATE-CHECK SECTION.
           IF SQLCODE < 0
                      DISPLAY 'SQLSTATE='  SQLSTATE,
                              ', SQLCODE=' SQLCODE
              IF SQLERRML > 0
                 DISPLAY 'SQL Error message:' SQLERRMC(1:SQLERRML)
              END-IF
              MOVE SQLCODE TO RETURN-CODE
              STOP RUN
           ELSE IF SQLCODE > 0 AND NOT = 100
                      DISPLAY 'SQLSTATE='  SQLSTATE,
                              ', SQLCODE=' SQLCODE
              IF SQLERRML > 0
                 DISPLAY 'SQL Warning message:' SQLERRMC(1:SQLERRML)
              END-IF
           END-IF.
           .
       INSDATAPERSON SECTION.
      *-----------------------------------------------------------------*
      * INSERT Data
      *-----------------------------------------------------------------*
      * TESTPERSON
         MOVE 0 TO hVarN.
         PERFORM UNTIL hVarN > 2
           COMPUTE hVarN = hVarN + 1
           STRING 'Testpers '
                  hVarN
             INTO hVarC
           EXEC SQL
            INSERT INTO TESTPERSON SET
             ID=:hVarN,
             NAME=:hVarC
           END-EXEC
           PERFORM SQLSTATE-CHECK
           DISPLAY 'INSERTED '
           DISPLAY '  Person ' hVarN ' NAME ' hVarC
         END-PERFORM.
       INSDATAGAME SECTION.
      * TESTGAME
         MOVE 0 TO hVarN.
         PERFORM UNTIL hVarN > 3
           COMPUTE hVarN = hVarN + 1
           STRING 'Testgame '
                  hVarN
             INTO hVarC
           EXEC SQL
            INSERT INTO TESTGAME SET
             ID=:hVarN,
             NAME=:hVarC
           END-EXEC
           PERFORM SQLSTATE-CHECK
           DISPLAY 'INSERTED '
           DISPLAY '  Game ' hVarN ' NAME ' hVarC
         END-PERFORM.
       INSDATAPOINTS SECTION.
      * TESTPOINTS
         MOVE 0 TO hVarN.
         MOVE 0 TO hVarD.
         PERFORM UNTIL hVarN > 2
           COMPUTE hVarN = hVarN + 1
           COMPUTE hVarD = hVarN + 0.75
           EXEC SQL
            INSERT INTO TESTPOINTS SET
             PERSONID=:hVarN,
             GAMEID=:hVarN,
             POINTS=:hVarD
           END-EXEC
           PERFORM SQLSTATE-CHECK
           DISPLAY 'INSERTED '
           DISPLAY '  POINTS for person/game ' hVarN ' : ' hVarD
         END-PERFORM.

c:\esqlOC\release\esqlOC.exe -static -o c:\Temp\esqlOCGetStart1.cob \
   c:\Temp\esqlOCGetStart1.sqb

SET OC_RUNTIME=c:\OpenCobol_bin
SET esqlOC_RUNTIME=c:\esqlOC\release
SET COB_CFLAGS=-I %OC_RUNTIME%
SET COB_LIBS=%OC_RUNTIME%\libcob.lib %OC_RUNTIME%\mpir.lib %esqlOC_RUNTIME%\ocsql.lib
SET COB_CONFIG_DIR=%OC_RUNTIME%\config\
set PATH=C:\WINDOWS\system32;%OC_RUNTIME%
call "%PROGRAMFILES%\Microsoft Visual Studio 10.0\VC\vcvarsall.bat"
%OC_RUNTIME%\cobc.exe -fixed -v -x -static -o c:\Temp\esqlOCGetStart1.exe \
   c:\Temp\esqlOCGetStart1.cob

%PROGRAMFILES%\MySQL5.6\mysql-5.6.13-win32\bin\mysql -u youruser -p --host=localhost
    --execute "CREATE DATABASE IF NOT EXISTS test;"

SET OC_RUNTIME=c:\OpenCobol_bin
SET esqlOC_RUNTIME=c:\esqlOC\release
set PATH=%OC_RUNTIME%;%esqlOC_RUNTIME%
c:\Temp\esqlOCGetStart1.exe

Microsoft Windows XP [Version 5.1.2600]
(C) Copyright 1985-2001 Microsoft Corp.

c:\~$dir temp
 Volume in Laufwerk C: hat keine Bezeichnung.
 Volumeseriennummer: 75F6-3F89

 Verzeichnis von c:\temp

08.11.2013  18:18    <DIR>          .
08.11.2013  18:18    <DIR>          ..
08.11.2013  18:10             9.169 esqlOCGetStart1.sqb
               1 Datei(en)          9.169 Bytes
               2 Verzeichnis(se), 51.086.712.832 Bytes frei

c:\~$c:\esqlOC\release\esqlOC.exe -static -o c:\Temp\esqlOCGetStart1.cob \
    c:\Temp\esqlOCGetStart1.sqb
c:\esqlOC\release\esqlOC.exe: ESQL for OpenCobol Version 2 Build May  8 2013

c:\~$dir temp
 Volume in Laufwerk C: hat keine Bezeichnung.
 Volumeseriennummer: 75F6-3F89

 Verzeichnis von c:\temp

08.11.2013  18:18    <DIR>          .
08.11.2013  18:18    <DIR>          ..
08.11.2013  18:18            17.973 esqlOCGetStart1.cob
08.11.2013  18:10             9.169 esqlOCGetStart1.sqb
               2 Datei(en)         27.142 Bytes
               2 Verzeichnis(se), 51.086.692.352 Bytes frei

c:\~$SET OC_RUNTIME=c:\OpenCobol_bin

c:\~$SET esqlOC_RUNTIME=c:\esqlOC\release

c:\~$SET COB_CFLAGS=-I %OC_RUNTIME%

c:\~$SET COB_LIBS=%OC_RUNTIME%\libcob.lib %OC_RUNTIME%\mpir.lib \
     %esqlOC_RUNTIME%\ocsql.lib

c:\~$SET COB_CONFIG_DIR=%OC_RUNTIME%\config\

c:\~$set PATH=C:\WINDOWS\system32;%OC_RUNTIME%

c:\~$call "%PROGRAMFILES%\Microsoft Visual Studio 10.0\VC\vcvarsall.bat"
Setting environment for using Microsoft Visual Studio 2010 x86 tools.

c:\~$%OC_RUNTIME%\cobc.exe -fixed -v -x -static -o c:\Temp\esqlOCGetStart1.exe \
     c:\Temp\esqlOCGetStart1.cob
Preprocessing:  c:\Temp\esqlOCGetStart1.cob to
                C:\DOKUME~1\DOK-AD~1\LOKALE~1\Temp\cob13.cob
Return status:  0
Parsing:        C:\DOKUME~1\DOK-AD~1\LOKALE~1\Temp\cob13.cob
Return status:  0
Translating:    C:\DOKUME~1\DOK-AD~1\LOKALE~1\Temp\cob13.cob to
                C:\DOKUME~1\DOK-AD~1\LOKALE~1\Temp\cob14.c
Executing:      cl /c -I c:\OpenCobol_bin /MD /Fo"esqlOCGetStart1.obj"
                "C:\DOKUME~1\DOK-AD~1\LOKALE~1\Temp\cob14.c"
Microsoft (R) 32-Bit C/C++-Optimierungscompiler Version 16.00.40219.01 für 80x86
Copyright (C) Microsoft Corporation. Alle Rechte vorbehalten.

cob14.c
Return status:  0
Executing:      cl /MD /Fe"c:\Temp\esqlOCGetStart1" "esqlOCGetStart1.obj"
                c:\OpenCobol_bin\libcob.lib c:\OpenCobol_bin\mpir.lib
                c:\esqlOC\release\ocsql.lib /link /manifest
Microsoft (R) 32-Bit C/C++-Optimierungscompiler Version 16.00.40219.01 für 80x86
Copyright (C) Microsoft Corporation. Alle Rechte vorbehalten.

Microsoft (R) Incremental Linker Version 10.00.40219.01
Copyright (C) Microsoft Corporation.  All rights reserved.

/out:c:\Temp\esqlOCGetStart1.exe
/manifest
esqlOCGetStart1.obj
c:\OpenCobol_bin\libcob.lib
c:\OpenCobol_bin\mpir.lib
c:\esqlOC\release\ocsql.lib
Return status:  0
Executing:      mt /manifest "c:\Temp\esqlOCGetStart1.exe.manifest"
                /outputresource:"c:\Temp\esqlOCGetStart1.exe";#1
Microsoft (R) Manifest Tool version 5.2.3790.2076
Copyright (c) Microsoft Corporation 2005.
All rights reserved.
Return status:  0

c:\~$dir temp
 Volume in Laufwerk C: hat keine Bezeichnung.
 Volumeseriennummer: 75F6-3F89

 Verzeichnis von c:\temp

08.11.2013  18:18    <DIR>          .
08.11.2013  18:18    <DIR>          ..
08.11.2013  18:18            17.973 esqlOCGetStart1.cob
08.11.2013  18:18            17.408 esqlOCGetStart1.exe
08.11.2013  18:10             9.169 esqlOCGetStart1.sqb
               3 Datei(en)         44.550 Bytes
               2 Verzeichnis(se), 51.086.667.776 Bytes frei

c:\~$SET OC_RUNTIME=c:\OpenCobol_bin

c:\~$SET esqlOC_RUNTIME=c:\esqlOC\release

c:\~$set PATH=%OC_RUNTIME%;%esqlOC_RUNTIME%

c:\~$c:\Temp\esqlOCGetStart1.exe
 created Table TESTPERSON
INSERTED
  Person 000000000001 NAME Testpers 000000000001
INSERTED
  Person 000000000002 NAME Testpers 000000000002
INSERTED
  Person 000000000003 NAME Testpers 000000000003
 created Table TESTGAME
INSERTED
  Game 000000000001 NAME Testgame 000000000001
INSERTED
  Game 000000000002 NAME Testgame 000000000002
INSERTED
  Game 000000000003 NAME Testgame 000000000003
INSERTED
  Game 000000000004 NAME Testgame 000000000004
 created Table TESTPOINTS
INSERTED
  POINTS for person/game 000000000001 : +00001.75
INSERTED
  POINTS for person/game 000000000002 : +00002.75
INSERTED
  POINTS for person/game 000000000003 : +00003.75
SELECTED
  SUM of POINTS for persons >1 +00006.50
FETCHED
  person Testpers 000000000001                              points: +00001.75
FETCHED
  person Testpers 000000000002                              points: +00002.75
FETCHED
  person Testpers 000000000003                              points: +00003.75
 No points found

c:\~$

ENVIRONMENT DIVISION.
configuration section.
repository.
    function current-stock-price
    function all intrinsic.

PROCEDURE DIVISION.
display current-stock-price("GOOG") end-display

# GnuCOBOL
# Contributed by Brian Tiffin (btiffin@gnu.org)
#   add to local data/elvis.syn installation
#   Permission given to copy, modify, and redistribute
#
# Comments in COBOL are
#     * in column 7 (for fixed format sources) or
#     *> anywhere in a line
#
language gnucobol cobol
extension .cob .cbl .cpy .COB .CBL .CPY
comment *>
comment *
anchor 7 *
preprocessor #
keyword accept access active-class add address advancing
keyword after aligned all allocate alphabet alphabetic
keyword alphabetic-lower alphabetic-upper alphanumeric
keyword alphanumeric-edited also alter alternate and any
keyword anycase are area areas argument-number
keyword argument-value arithmetic as ascending ascii
keyword assign at attribute auto auto-skip automatic
keyword autoterminate away-from-zero b-and b-not b-or
keyword b-xor background-color background-colour based
keyword beep before bell binary binary-c-long binary-char
keyword binary-double binary-int binary-long
keyword binary-long-long binary-short bit blank blink
keyword block boolean bottom by byte-length call cancel
keyword capacity cd center cf ch chain chaining character
keyword characters class class-id classification close
keyword code code-set col collating cols column columns
keyword comma command-line commit common communication
keyword comp comp-1 comp-2 comp-3 comp-4 comp-5 comp-6
keyword comp-x computational computational-1
keyword computational-2 computational-3 computational-4
keyword computational-5 computational-x compute condition
keyword configuration constant contains content continue
keyword control controls conversion converting copy corr
keyword corresponding count crt crt-under currency cursor
keyword cycle data data-pointer date day day-of-week de
keyword debugging decimal-point declaratives default
keyword delete delimited delimiter depending descending
keyword destination detail disable disc disk display
keyword divide division down duplicates dynamic ebcdic ec
keyword egi else emi empty-check enable end end-accept
keyword end-add end-call end-chain end-compute end-delete
keyword end-display end-divide end-evaluate end-if
keyword end-multiply end-of-page end-perform end-read
keyword end-receive end-return end-rewrite end-search
keyword end-start end-string end-subtract end-unstring
keyword end-write entry entry-convention environment
keyword environment-name environment-value eo eol eop eos
keyword equal equals erase error escape esi evaluate
keyword exception exception-object exclusive exit expands
keyword extend external factory false fd file file-control
keyword file-id filler final first float-binary-128
keyword float-binary-32 float-binary-64 float-decimal-16
keyword float-decimal-34 float-extended float-infinity
keyword float-long float-not-a-number float-short footing
keyword for foreground-color foreground-colour forever
keyword format free from full function function-id
keyword function-pointer generate get giving global go
keyword goback greater group group-usage heading
keyword high-value high-values highlight i-o i-o-control
keyword id identification if ignore ignoring implements in
keyword index indexed indicate indirect inherits initial
keyword initialise initialised initialize initialized
keyword initiate input input-output inspect interface
keyword interface-id intermediate into intrinsic invalid
keyword invoke is just justified kept key keyboard label
keyword last lc_all lc_collate lc_ctype lc_messages
keyword lc_monetary lc_numeric lc_time leading left
keyword left-justify leftline length length-check less
keyword limit limits linage linage-counter line
keyword line-counter lines linkage local-storage locale
keyword lock low-value low-values lower lowlight manual
keyword memory merge message method method-id minus mode
keyword move multiple multiply name national
keyword national-edited native nearest-away-from-zero
keyword nearest-even nearest-toward-zero negative nested
keyword next no no-echo none normal not null nulls number
keyword numbers numeric numeric-edited object
keyword object-computer object-reference occurs of off
keyword omitted on only open optional options or order
keyword organisation organization other output overflow
keyword overline override packed-decimal padding page
keyword page-counter paragraph perform pf ph pic picture
keyword plus pointer position positive prefixed present
keyword previous printer printing procedure
keyword procedure-pointer procedures proceed program
keyword program-id program-pointer prohibited prompt
keyword property prototype purge queue quote quotes raise
keyword raising random rd read receive record recording
keyword records recursive redefines reel reference
keyword references relation relative release remainder
keyword removal renames replace replacing report reporting
keyword reports repository required reserve reset resume
keyword retry return returning reverse-video reversed
keyword rewind rewrite rf rh right right-justify rollback
keyword rounded rounding run same screen scroll sd search
keyword seconds section secure segment segment-limit
keyword select self send sentence separate sequence
keyword sequential set sharing sign signed signed-int
keyword signed-long signed-short size sort sort-merge
keyword source source-computer sources space space-fill
keyword spaces special-names standard standard-1
keyword standard-2 standard-binary standard-decimal start
keyword statement static status stdcall step stop string
keyword strong sub-queue-1 sub-queue-2 sub-queue-3
keyword subtract sum super suppress symbol symbolic sync
keyword synchronised synchronized system-default tab table
keyword tallying tape terminal terminate test text than
keyword then through thru time time-out timeout times to
keyword top toward-greater toward-lesser trailing
keyword trailing-sign transform true truncation type
keyword typedef ucs-4 underline unit universal unlock
keyword unsigned unsigned-int unsigned-long unsigned-short
keyword unstring until up update upon upper usage use user
keyword user-default using utf-16 utf-8 val-status valid
keyword validate validate-status value values varying wait
keyword when with words working-storage write yyyyddd
keyword yyyymmdd zero zero-fill zeroes zeros author
keyword date-compiled date-modified date-written
keyword installation remarks security return-code
keyword sort-return number-of-call-parameters
keyword cob-crt-status sysin sysipt
keyword stdin sysout syslist syslst stdout printer syserr
keyword stderr console c01 c02 c03 c04 c05 c06 c07 c08 c09
keyword c10 c11 c12 csp formfeed call-convention switch-0
keyword switch-1 switch-2 switch-3 switch-4 switch-5
keyword switch-6 switch-7 switch-8 switch-9 switch-10
keyword switch-11 switch-12 switch-13 switch-14 switch-15
keyword sw0 sw1 sw2 sw3 sw4 sw5 sw6 sw7 sw8 sw9 sw10 sw11
keyword sw12 sw13 sw14 sw15 system cbl_and cbl_change_dir
keyword cbl_check_file_exist cbl_close_file cbl_copy_file
keyword cbl_create_dir cbl_create_file cbl_delete_dir
keyword cbl_delete_file cbl_eq cbl_error_proc
keyword cbl_exit_proc cbl_flush_file cbl_get_csr_pos
keyword cbl_get_current_dir cbl_get_scr_size cbl_imp
keyword cbl_nimp cbl_nor cbl_not cbl_oc_getopt
keyword cbl_oc_nanosleep cbl_open_file cbl_or
keyword cbl_read_file cbl_rename_file cbl_tolower
keyword cbl_toupper cbl_write_file cbl_xor c$calledby
keyword c$chdir c$copy c$delete c$fileinfo c$getpid
keyword c$justify c$makedir c$narg c$paramsize c$printable
keyword c$sleep c$tolower c$toupper x91 xe4 xe5
keyword xf4 xf5 abs acos annuity asin atan
keyword boolean-of-integer byte-length char char-national
keyword combined-datetime concatenate cos currency-symbol
keyword current-date date-of-integer date-to-yyyymmdd
keyword day-of-integer day-to-yyyyddd display-of e
keyword exception-file exception-file-n exception-location
keyword exception-location-n exception-statement
keyword exception-status exp exp10 factorial
keyword formatted-current-date formatted-date
keyword formatted-datetime formatted-time fraction-part
keyword highest-algebraic integer integer-of-boolean
keyword integer-of-date integer-of-day
keyword integer-of-formatted-date integer-part length
keyword length-an locale-compare locale-date locale-time
keyword locale-time-from-seconds log log10 lower-case
keyword lowest-algebraic max mean median midrange min mod
keyword module-caller-id module-date module-formatted-date
keyword module-id module-path module-source module-time
keyword monetary-decimal-point
keyword monetary-thousands-separator national-of
keyword numeric-decimal-point numeric-thousands-separator
keyword numval numval-c numval-f ord ord-max ord-min pi
keyword present-value random range rem reverse
keyword seconds-from-formatted-time seconds-past-midnight
keyword sign sin sqrt standard-compare standard-deviation
keyword stored-char-length substitute substitute-case sum
keyword tan test-date-yyyymmdd test-day-yyyyddd
keyword test-formatted-datetime test-numval test-numval-c
keyword test-numval-f trim upper-case variance
keyword when-compiled year-to-yyyy debug
keyword fixed defined parameter override else-if source
startword -_
inword -_$
string '
string "
function (
ignorecase true

//COBUCLG  JOB (001),'COBOL BASE TEST',                                 00010000
//             CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1)                        00020000
//BASETEST EXEC COBUCLG                                                 00030000
//COB.SYSIN DD *                                                        00040000
 00000* VALIDATION OF BASE COBOL INSTALL                                00050000
 01000 IDENTIFICATION DIVISION.                                         00060000
 01100 PROGRAM-ID. 'HELLO'                                              00070000
 02000 ENVIRONMENT DIVISION.                                            00080000
 02100 CONFIGURATION SECTION.                                           00090000
 02110 SOURCE-COMPUTER.  GNULINUX.                                      00100000
 02120 OBJECT-COMPUTER.  HERCULES.                                      00110000
 02200 SPECIAL-NAMES.                                                   00120000
 02210     CONSOLE IS CONSL.                                            00130000
 03000 DATA DIVISION.                                                   00140000
 04000 PROCEDURE DIVISION.                                              00150000
 04100 00-MAIN.                                                         00160000
 04110     DISPLAY 'HELLO, WORLD' UPON CONSL.                           00170000
 04120     STOP RUN.                                                    00180000
//LKED.SYSLIB DD DSNAME=SYS1.COBLIB,DISP=SHR                            00190000
//            DD DSNAME=SYS1.LINKLIB,DISP=SHR                           00200000
//GO.SYSPRINT DD SYSOUT=A                                               00210000
//                                                                      00220000


 First banner page, other page breaks removed. This line was added by hand, and was not part of the generated listing.

                          CCCCCCCCCC   OOOOOOOOOOOO  BBBBBBBBBBB   UU        UU   CCCCCCCCCC   LL             GGGGGGGGGG
                        CCCCCCCCCCCC  OOOOOOOOOOOO  BBBBBBBBBBBB  UU        UU  CCCCCCCCCCCC  LL            GGGGGGGGGGGG
                       CC        CC  OO        OO  BB        BB  UU        UU  CC        CC  LL            GG        GG
                      CC            OO        OO  BB        BB  UU        UU  CC            LL            GG
                     CC            OO        OO  BB       BB   UU        UU  CC            LL            GG
                    CC            OO        OO  BBBBBBBBBB    UU        UU  CC            LL            GG
                   CC            OO        OO  BBBBBBBBBB    UU        UU  CC            LL            GG     GGGGG
                  CC            OO        OO  BB       BB   UU        UU  CC            LL            GG     GGGGG
                 CC            OO        OO  BB        BB  UU        UU  CC            LL            GG        GG
                CC        CC  OO        OO  BB        BB  UU        UU  CC        CC  LL            GG        GG
               CCCCCCCCCCCC  OOOOOOOOOOOO  BBBBBBBBBBBB  UUUUUUUUUUUU  CCCCCCCCCCCC  LLLLLLLLLLLL  GGGGGGGGGGGG
               CCCCCCCCCC   OOOOOOOOOOOO  BBBBBBBBBBB    UUUUUUUUUU    CCCCCCCCCC   LLLLLLLLLLLL   GGGGGGGGGG



                     JJJJJJJJJJ       11                                                                AAAAAAAAAA
                     JJJJJJJJJJ      111                                                               AAAAAAAAAAAA
                         JJ         1111                                                               AA        AA
                         JJ           11                                                               AA        AA
                         JJ           11                                                               AA        AA
                         JJ           11                                                               AAAAAAAAAAAA
                         JJ           11                                                               AAAAAAAAAAAA
                         JJ           11                                                               AA        AA
                   JJ    JJ           11                                                               AA        AA
                   JJ    JJ           11                                                               AA        AA
                   JJJJJJJJ       1111111111                                                           AA        AA
                    JJJJJJ        1111111111                                                           AA        AA


 ****A  START  JOB    1  COBUCLG   COBOL BASE TEST       ROOM        5.07.22 AM 20 JUL 15  PRINTER1  SYS TK4-  JOB    1  START  A****
 ****A  START  JOB    1  COBUCLG   COBOL BASE TEST       ROOM        5.07.22 AM 20 JUL 15  PRINTER1  SYS TK4-  JOB    1  START  A****
 ****A  START  JOB    1  COBUCLG   COBOL BASE TEST       ROOM        5.07.22 AM 20 JUL 15  PRINTER1  SYS TK4-  JOB    1  START  A****
 ****A  START  JOB    1  COBUCLG   COBOL BASE TEST       ROOM        5.07.22 AM 20 JUL 15  PRINTER1  SYS TK4-  JOB    1  START  A****

                                                 J E S 2   J O B   L O G


 05.07.21 JOB    1  IEF677I WARNING MESSAGE(S) FOR JOB COBUCLG  ISSUED
 05.07.21 JOB    1  $HASP373 COBUCLG  STARTED - INIT  1 - CLASS A - SYS TK4-
 05.07.21 JOB    1  IEF403I COBUCLG - STARTED - TIME=05.07.21
 05.07.21 JOB    1  IEC130I SYSPUNCH DD STATEMENT MISSING
 05.07.21 JOB    1  IEC130I SYSLIB   DD STATEMENT MISSING
 05.07.22 JOB    1  IEC130I SYSPUNCH DD STATEMENT MISSING
 05.07.22 JOB    1  IEFACTRT - Stepname  Procstep  Program   Retcode
 05.07.22 JOB    1  COBUCLG    BASETEST  COB       IKFCBL00  RC= 0000
 05.07.22 JOB    1  COBUCLG    BASETEST  LKED      IEWL      RC= 0000
 05.07.22 JOB    1  +HELLO, WORLD
 05.07.22 JOB    1  COBUCLG    BASETEST  GO        PGM=*.DD  RC= 0000
 05.07.22 JOB    1  IEF404I COBUCLG - ENDED - TIME=05.07.22
 05.07.22 JOB    1  $HASP395 COBUCLG  ENDED


 ------ JES2 JOB STATISTICS ------


  20 JUL 15 JOB EXECUTION DATE


         22 CARDS READ


        179 SYSOUT PRINT RECORDS


          0 SYSOUT PUNCH RECORDS


       0.00 MINUTES EXECUTION TIME

     1     //COBUCLG  JOB (001),'COBOL BASE TEST',                                 JOB    1
           //             CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1)                        00020000
     2     //BASETEST EXEC COBUCLG                                                 00030000
     3     XXCOBUCLG PROC SOUT='*'                                                 00000100
     4     XXCOB  EXEC  PGM=IKFCBL00,                                              00000200
           XX           PARM='LOAD,SUPMAP,SIZE=2048K,BUF=1024K'                    00000300
     5     XXSYSPRINT  DD SYSOUT=&SOUT                                             00000400
     6     XXSYSUT1 DD UNIT=SYSDA,SPACE=(460,(700,100))                            00000500
     7     XXSYSUT2 DD UNIT=SYSDA,SPACE=(460,(700,100))                            00000600
     8     XXSYSUT3 DD UNIT=SYSDA,SPACE=(460,(700,100))                            00000700
     9     XXSYSUT4 DD UNIT=SYSDA,SPACE=(460,(700,100))                            00000800
    10     XXSYSLIN DD DSNAME=&LOADSET,DISP=(MOD,PASS),UNIT=SYSDA,                 00000900
           XX             SPACE=(80,(500,100))                                     00001000
    11     //COB.SYSIN DD *                                                        00040000
    12     XXLKED EXEC PGM=IEWL,PARM='LIST,XREF,LET',COND=(5,LT,COB)               00001100
    13     XXSYSLIN  DD DSNAME=&LOADSET,DISP=(OLD,DELETE)                          00001200
    14     XX  DD  DDNAME=SYSIN                                                    00001300
    15     XXSYSLMOD DD DSNAME=&GODATA(RUN),DISP=(NEW,PASS),UNIT=SYSDA,            00001400
           XX             SPACE=(1024,(50,20,1))                                   00001500
    16     //LKED.SYSLIB DD DSNAME=SYS1.COBLIB,DISP=SHR                            00190000
           X/SYSLIB DD   DSNAME=SYS1.COBLIB,DISP=SHR                               00001600
    17     //            DD DSNAME=SYS1.LINKLIB,DISP=SHR                           00200000
    18     XXSYSUT1 DD UNIT=(SYSDA,SEP=(SYSLIN,SYSLMOD)),SPACE=(1024,(50,20))      00001700
    19     XXSYSPRINT DD SYSOUT=&SOUT                                              00001800
    20     XXGO  EXEC PGM=*.LKED.SYSLMOD,COND=((5,LT,COB),(5,LT,LKED))             00001900
    21     //GO.SYSPRINT DD SYSOUT=A                                               00210000
           //                                                                      00220000

  STMT NO. MESSAGE
 -
     5     IEF653I SUBSTITUTION JCL - SYSOUT=*
    19     IEF653I SUBSTITUTION JCL - SYSOUT=*
    20     IEF686I DDNAME REFERRED TO ON DDNAME KEYWORD IN PRIOR STEP WAS NOT RESOLVED
 IEF236I ALLOC. FOR COBUCLG COB BASETEST
 IEF237I JES2 ALLOCATED TO SYSPRINT
 IEF237I 140  ALLOCATED TO SYSUT1
 IEF237I 170  ALLOCATED TO SYSUT2
 IEF237I 190  ALLOCATED TO SYSUT3
 IEF237I 180  ALLOCATED TO SYSUT4
 IEF237I 190  ALLOCATED TO SYSLIN
 IEF237I JES2 ALLOCATED TO SYSIN
 IEC130I SYSPUNCH DD STATEMENT MISSING
 IEC130I SYSLIB   DD STATEMENT MISSING
 IEC130I SYSPUNCH DD STATEMENT MISSING
 IEF142I COBUCLG COB BASETEST - STEP WAS EXECUTED - COND CODE 0000
 IEF285I   JES2.JOB00001.SO0102                         SYSOUT
 IEF285I   SYS15201.T050721.RA000.COBUCLG.R0000001      DELETED       *--------6
 IEF285I   VOL SER NOS= WORK00.
 IEF285I   SYS15201.T050721.RA000.COBUCLG.R0000002      DELETED       *--------6
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   SYS15201.T050721.RA000.COBUCLG.R0000003      DELETED       *--------9
 IEF285I   VOL SER NOS= WORK03.
 IEF285I   SYS15201.T050721.RA000.COBUCLG.R0000004      DELETED       *--------3
 IEF285I   VOL SER NOS= WORK02.
 IEF285I   SYS15201.T050721.RA000.COBUCLG.LOADSET       PASSED        *-------15
 IEF285I   VOL SER NOS= WORK03.
 IEF285I   JES2.JOB00001.SI0101                         SYSIN
 IEF373I STEP /COB     / START 15201.0507
 IEF374I STEP /COB     / STOP  15201.0507 CPU    0MIN 00.05SEC SRB    0MIN 00.03SEC VIRT   820K SYS   208K
 ************************************************************************************************************************************
 *     1. Jobstep of job: COBUCLG     Stepname: COB         Program name: IKFCBL00   Executed on 20.07.15 from 05.07.21 to 05.07.22 *
 *         elapsed time  00:00:00,13                      CPU-Identifier:  TK4-           Page-in:      0                           *
 *             CPU time  00:00:00,08               Virtual Storage used:    820K         Page-out:      0                           *
 *           corr. CPU:  00:00:00,08   CPU time has been corrected by  1 / 1,0  multiplier                                          *
 *                                                                                                                                  *
 *     I/O Operation                                                                                                                *
 *     Number of records read via DD * or DD DATA:     14                                                                           *
 *     DMY.......0 140.......6 170.......6 190.......9 180.......3 190......15 DMY.......0                                          *
 *                                                                                                                                  *
 *                                          Charge for step (w/o SYSOUT):          0,13                                             *
 ************************************************************************************************************************************
 IEF236I ALLOC. FOR COBUCLG LKED BASETEST
 IEF237I 190  ALLOCATED TO SYSLIN
 IEF237I DMY  ALLOCATED TO
 IEF237I 170  ALLOCATED TO SYSLMOD
 IEF237I 148  ALLOCATED TO SYSLIB
 IEF237I 148  ALLOCATED TO
 IEF237I 140  ALLOCATED TO SYSUT1
 IEF237I JES2 ALLOCATED TO SYSPRINT
 IEF142I COBUCLG LKED BASETEST - STEP WAS EXECUTED - COND CODE 0000
 IEF285I   SYS15201.T050721.RA000.COBUCLG.LOADSET       DELETED       *-------16
 IEF285I   VOL SER NOS= WORK03.
 IEF285I   SYS15201.T050721.RA000.COBUCLG.GODATA        PASSED        *--------9
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   SYS1.COBLIB                                  KEPT          *--------7
 IEF285I   VOL SER NOS= MVSRES.
 IEF285I   SYS1.LINKLIB                                 KEPT          *--------0
 IEF285I   VOL SER NOS= MVSRES.
 IEF285I   SYS15201.T050721.RA000.COBUCLG.R0000005      DELETED       *--------0
 IEF285I   VOL SER NOS= WORK00.
 IEF285I   JES2.JOB00001.SO0103                         SYSOUT
 IEF373I STEP /LKED    / START 15201.0507
 IEF374I STEP /LKED    / STOP  15201.0507 CPU    0MIN 00.02SEC SRB    0MIN 00.00SEC VIRT   264K SYS   200K
 ************************************************************************************************************************************
 *     2. Jobstep of job: COBUCLG     Stepname: LKED        Program name: IEWL       Executed on 20.07.15 from 05.07.22 to 05.07.22 *
 *         elapsed time  00:00:00,05                      CPU-Identifier:  TK4-           Page-in:      0                           *
 *             CPU time  00:00:00,02               Virtual Storage used:    264K         Page-out:      0                           *
 *           corr. CPU:  00:00:00,02   CPU time has been corrected by  1 / 1,0  multiplier                                          *
 *                                                                                                                                  *
 *     I/O Operation                                                                                                                *
 *     Number of records read via DD * or DD DATA:      0                                                                           *
 *     190......16 DMY.......0 170.......9 148.......7 148.......0 140.......0 DMY.......0                                          *
 *                                                                                                                                  *
 *                                          Charge for step (w/o SYSOUT):          0,03                                             *
 ************************************************************************************************************************************
 IEF236I ALLOC. FOR COBUCLG GO BASETEST
 IEF237I 170  ALLOCATED TO PGM=*.DD
 IEF237I JES2 ALLOCATED TO SYSPRINT
 HELLO, WORLD
 IEF142I COBUCLG GO BASETEST - STEP WAS EXECUTED - COND CODE 0000
 IEF285I   SYS15201.T050721.RA000.COBUCLG.GODATA        KEPT          *--------0
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   JES2.JOB00001.SO0104                         SYSOUT
 IEF373I STEP /GO      / START 15201.0507
 IEF374I STEP /GO      / STOP  15201.0507 CPU    0MIN 00.00SEC SRB    0MIN 00.00SEC VIRT     8K SYS   188K
 IEF237I 170  ALLOCATED TO SYS00001
 IEF285I   SYS15201.T050722.RA000.COBUCLG.R0000001      KEPT          *--------0
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   SYS15201.T050721.RA000.COBUCLG.GODATA        DELETED
 IEF285I   VOL SER NOS= WORK01.
 IEF375I  JOB /COBUCLG / START 15201.0507
 IEF376I  JOB /COBUCLG / STOP  15201.0507 CPU    0MIN 00.07SEC SRB    0MIN 00.03SEC

   CB545 V2 LVL78 01MAY72                 IBM OS AMERICAN NATIONAL STANDARD COBOL                       DATE JUL 20,2015


    1


 00001    00000* VALIDATION OF BASE COBOL INSTALL                                00050000
 00002    01000 IDENTIFICATION DIVISION.                                         00060000
 00003    01100 PROGRAM-ID. 'HELLO'                                              00070000
 00004    02000 ENVIRONMENT DIVISION.                                            00080000
 00005    02100 CONFIGURATION SECTION.                                           00090000
 00006    02110 SOURCE-COMPUTER.  GNULINUX.                                      00100000
 00007    02120 OBJECT-COMPUTER.  HERCULES.                                      00110000
 00008    02200 SPECIAL-NAMES.                                                   00120000
 00009    02210     CONSOLE IS CONSL.                                            00130000
 00010    03000 DATA DIVISION.                                                   00140000
 00011    04000 PROCEDURE DIVISION.                                              00150000
 00012    04100 00-MAIN.                                                         00160000
 00013    04110     DISPLAY 'HELLO, WORLD' UPON CONSL.                           00170000
 00014    04120     STOP RUN.                                                    00180000
    2



 *STATISTICS*     SOURCE RECORDS =    14     DATA DIVISION STATEMENTS =           PROCEDURE DIVISION STATEMENTS =     2
 *OPTIONS IN EFFECT*     SIZE = 2097152  BUF = 1048576  LINECNT = 57  SPACE1, FLAGW,   SEQ,   SOURCE
 *OPTIONS IN EFFECT*     NODMAP, NOPMAP, NOCLIST,   SUPMAP, NOXREF,   LOAD, NODECK, APOST, NOTRUNC, NOLIB, NOVERB
 *OPTIONS IN EFFECT*       ZWB

  F64-LEVEL LINKAGE EDITOR OPTIONS SPECIFIED LIST,XREF,LET
           DEFAULT OPTION(S) USED -  SIZE=(231424,55296)



                                                 CROSS REFERENCE TABLE


   CONTROL SECTION                       ENTRY

     NAME    ORIGIN  LENGTH                NAME   LOCATION     NAME   LOCATION     NAME   LOCATION     NAME   LOCATION
   HELLO         00     2F2
   ILBOSTP0*    2F8      35
                                         ILBOSTP1     30E



   LOCATION  REFERS TO SYMBOL  IN CONTROL SECTION             LOCATION  REFERS TO SYMBOL  IN CONTROL SECTION
       278            ILBOSTP0        ILBOSTP0                     27C            ILBOSTP1        ILBOSTP0

  ENTRY ADDRESS       00

  TOTAL LENGTH       330
 ****RUN       DOES NOT EXIST BUT HAS BEEN ADDED TO DATA SET
 AUTHORIZATION CODE IS         0.

                          CCCCCCCCCC   OOOOOOOOOOOO  BBBBBBBBBBB   UU        UU   CCCCCCCCCC   LL             GGGGGGGGGG
                        CCCCCCCCCCCC  OOOOOOOOOOOO  BBBBBBBBBBBB  UU        UU  CCCCCCCCCCCC  LL            GGGGGGGGGGGG
                       CC        CC  OO        OO  BB        BB  UU        UU  CC        CC  LL            GG        GG
                      CC            OO        OO  BB        BB  UU        UU  CC            LL            GG
                     CC            OO        OO  BB       BB   UU        UU  CC            LL            GG
                    CC            OO        OO  BBBBBBBBBB    UU        UU  CC            LL            GG
                   CC            OO        OO  BBBBBBBBBB    UU        UU  CC            LL            GG     GGGGG
                  CC            OO        OO  BB       BB   UU        UU  CC            LL            GG     GGGGG
                 CC            OO        OO  BB        BB  UU        UU  CC            LL            GG        GG
                CC        CC  OO        OO  BB        BB  UU        UU  CC        CC  LL            GG        GG
               CCCCCCCCCCCC  OOOOOOOOOOOO  BBBBBBBBBBBB  UUUUUUUUUUUU  CCCCCCCCCCCC  LLLLLLLLLLLL  GGGGGGGGGGGG
               CCCCCCCCCC   OOOOOOOOOOOO  BBBBBBBBBBB    UUUUUUUUUU    CCCCCCCCCC   LLLLLLLLLLLL   GGGGGGGGGG



                     JJJJJJJJJJ       11                                                                AAAAAAAAAA
                     JJJJJJJJJJ      111                                                               AAAAAAAAAAAA
                         JJ         1111                                                               AA        AA
                         JJ           11                                                               AA        AA
                         JJ           11                                                               AA        AA
                         JJ           11                                                               AAAAAAAAAAAA
                         JJ           11                                                               AAAAAAAAAAAA
                         JJ           11                                                               AA        AA
                   JJ    JJ           11                                                               AA        AA
                   JJ    JJ           11                                                               AA        AA
                   JJJJJJJJ       1111111111                                                           AA        AA
                    JJJJJJ        1111111111                                                           AA        AA


 ****A   END   JOB    1  COBUCLG   COBOL BASE TEST       ROOM        5.07.22 AM 20 JUL 15  PRINTER1  SYS TK4-  JOB    1   END   A****
 ****A   END   JOB    1  COBUCLG   COBOL BASE TEST       ROOM        5.07.22 AM 20 JUL 15  PRINTER1  SYS TK4-  JOB    1   END   A****
 ****A   END   JOB    1  COBUCLG   COBOL BASE TEST       ROOM        5.07.22 AM 20 JUL 15  PRINTER1  SYS TK4-  JOB    1   END   A****
 ****A   END   JOB    1  COBUCLG   COBOL BASE TEST       ROOM        5.07.22 AM 20 JUL 15  PRINTER1  SYS TK4-  JOB    1   END   A****


 05.07.21 JOB    1  IEF677I WARNING MESSAGE(S) FOR JOB COBUCLG  ISSUED
 05.07.21 JOB    1  $HASP373 COBUCLG  STARTED - INIT  1 - CLASS A - SYS TK4-
 05.07.21 JOB    1  IEF403I COBUCLG - STARTED - TIME=05.07.21
 05.07.21 JOB    1  IEC130I SYSPUNCH DD STATEMENT MISSING
 05.07.21 JOB    1  IEC130I SYSLIB   DD STATEMENT MISSING
 05.07.22 JOB    1  IEC130I SYSPUNCH DD STATEMENT MISSING
 05.07.22 JOB    1  IEFACTRT - Stepname  Procstep  Program   Retcode
 05.07.22 JOB    1  COBUCLG    BASETEST  COB       IKFCBL00  RC= 0000
 05.07.22 JOB    1  COBUCLG    BASETEST  LKED      IEWL      RC= 0000
 05.07.22 JOB    1  +HELLO, WORLD
 05.07.22 JOB    1  COBUCLG    BASETEST  GO        PGM=*.DD  RC= 0000
 05.07.22 JOB    1  IEF404I COBUCLG - ENDED - TIME=05.07.22
 05.07.22 JOB    1  $HASP395 COBUCLG  ENDED

//COBUCLG  JOB CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1)
//HELOWRLD EXEC COBUCLG,PARM.COB='MAP,LIST,LET'
//COB.SYSIN DD *
  001  IDENTIFICATION DIVISION.
  002  PROGRAM-ID.  'HELLO'.
  003  ENVIRONMENT DIVISION.
  004  CONFIGURATION SECTION.
  005  SOURCE-COMPUTER.  IBM-360.
  006  OBJECT-COMPUTER.  IBM-360.
  0065 SPECIAL-NAMES.
  0066     CONSOLE IS CNSL.
  007  DATA DIVISION.
  008  WORKING-STORAGE SECTION.
  009  77  HELLO-CONST   PIC X(12) VALUE 'HELLO, WORLD'.
  075  PROCEDURE DIVISION.
  090  000-DISPLAY.
  100      DISPLAY HELLO-CONST UPON CNSL.
  110      STOP RUN.
//LKED.SYSLIB DD DSNAME=SYS1.COBLIB,DISP=SHR
//            DD DSNAME=SYS1.LINKLIB,DISP=SHR
//GO.SYSPRINT DD SYSOUT=A
//


 //COBUCLG  JOB CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1)
 //HELOWRLD EXEC COBUCLG,PARM.COB='MAP,LIST,LET'
 XXCOB  EXEC  PGM=IKFCBL00,REGION=86K,PARM='LOAD,SUPMAP'                 05000018
 XXSYSPRINT  DD SYSOUT=A                                                 10000018
 XXSYSUT1 DD UNIT=SYSDA,SPACE=(460,(700,100))                            15000018
 XXSYSUT2 DD UNIT=SYSDA,SPACE=(460,(700,100))                            20000018
 XXSYSUT3 DD UNIT=SYSDA,SPACE=(460,(700,100))                            25000018
 XXSYSUT4 DD UNIT=SYSDA,SPACE=(460,(700,100))                            30000018
 XXSYSLIN DD DSNAME=&LOADSET,DISP=(MOD,PASS),UNIT=SYSDA,                 35000018
 XX             SPACE=(80,(500,100))                                     40000018
 //COB.SYSIN DD *
 IEF236I ALLOC. FOR COBUCLG  COB      HELOWRLD
 IEF237I 352   ALLOCATED TO SYSPRINT
 IEF237I 151   ALLOCATED TO SYSUT1
 IEF237I 352   ALLOCATED TO SYSUT2
 IEF237I 150   ALLOCATED TO SYSUT3
 IEF237I 352   ALLOCATED TO SYSUT4
 IEF237I 151   ALLOCATED TO SYSLIN
 IEF237I 150   ALLOCATED TO SYSIN

   CB545 V2 LVL78 01MAY72                 IBM OS AMERICAN NATIONAL STANDARD COBOL                       DATE FEB 25,1984


    1


 00001     001  IDENTIFICATION DIVISION.
 00002     002  PROGRAM-ID.  'HELLO'.
 00003     003  ENVIRONMENT DIVISION.
 00004     004  CONFIGURATION SECTION.
 00005     005  SOURCE-COMPUTER.  IBM-360.
 00006     006  OBJECT-COMPUTER.  IBM-360.
 00007     0065 SPECIAL-NAMES.
 00008     0066     CONSOLE IS CNSL.
 00009     007  DATA DIVISION.
 00010     008  WORKING-STORAGE SECTION.
 00011     009  77  HELLO-CONST   PIC X(12) VALUE 'HELLO, WORLD'.
 00012     075  PROCEDURE DIVISION.
 00013     090  000-DISPLAY.
 00014     100      DISPLAY HELLO-CONST UPON CNSL.
 00015     110      STOP RUN.
                                2



 *STATISTICS*     SOURCE RECORDS =    15     DATA DIVISION STATEMENTS =     1     PROCEDURE DIVISION STATEMENTS =     2
 *OPTIONS IN EFFECT*     SIZE =   81920  BUF =    2768  LINECNT = 57  SPACE1, FLAGW,   SEQ,   SOURCE
 *OPTIONS IN EFFECT*     NODMAP, NOPMAP, NOCLIST, NOSUPMAP, NOXREF,   LOAD, NODECK, APOST, NOTRUNC, NOLIB, NOVERB
 *OPTIONS IN EFFECT*       ZWB

 IEC130I SYSPUNCH DD STATEMENT MISSING
 IEC130I SYSLIB   DD STATEMENT MISSING
 IEC130I SYSPUNCH DD STATEMENT MISSING
 IEF142I - STEP WAS EXECUTED - COND CODE 0000
 IEF285I   SYS84056.T093538.SV000.COBUCLG.R0000001      SYSOUT
 IEF285I   VOL SER NOS= WORK02.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.R0000002      DELETED
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.R0000003      DELETED
 IEF285I   VOL SER NOS= WORK02.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.R0000004      DELETED
 IEF285I   VOL SER NOS= SYSRES.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.R0000005      DELETED
 IEF285I   VOL SER NOS= WORK02.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.LOADSET       PASSED
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.S0000006      SYSIN
 IEF285I   VOL SER NOS= SYSRES.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.S0000006      DELETED
 IEF285I   VOL SER NOS= SYSRES.
 IEF373I STEP /COB     / START 84056.0937
 IEF374I STEP /COB     / STOP  84056.0937 CPU   0MIN 00.08SEC MAIN  84K LCS   0K
 XXLKED EXEC PGM=IEWL,PARM='LIST,XREF,LET',COND=(5,LT,COB),REGION=96K    45000018
 XXSYSLIN  DD DSNAME=&LOADSET,DISP=(OLD,DELETE)                          50000018
 XX  DD  DDNAME=SYSIN                                                    55000018
 XXSYSLMOD DD DSNAME=&GODATA(RUN),DISP=(NEW,PASS),UNIT=SYSDA,            60000018
 XX             SPACE=(1024,(50,20,1))                                   65000018
 //LKED.SYSLIB DD DSNAME=SYS1.COBLIB,DISP=SHR
 X/SYSLIB DD   DSNAME=SYS1.COBLIB,DISP=SHR                               70000018
 //            DD DSNAME=SYS1.LINKLIB,DISP=SHR
 XXSYSUT1 DD UNIT=(SYSDA,SEP=(SYSLIN,SYSLMOD)),SPACE=(1024,(50,20))      75000018
 XXSYSPRINT DD SYSOUT=A                                                  80000018
 IEF236I ALLOC. FOR COBUCLG  LKED     HELOWRLD
 IEF237I 151   ALLOCATED TO SYSLIN
 IEF237I 151   ALLOCATED TO SYSLMOD
 IEF237I 350   ALLOCATED TO SYSLIB
 IEF237I 350   ALLOCATED TO
 IEF237I 150   ALLOCATED TO SYSUT1
 IEF237I 151   ALLOCATED TO SYSPRINT

 F128-LEVEL LINKAGE EDITOR OPTIONS SPECIFIED LIST,XREF,LET
           DEFAULT OPTION(S) USED -  SIZE=(131072,18432)


                                                 CROSS REFERENCE TABLE


   CONTROL SECTION                       ENTRY

     NAME    ORIGIN  LENGTH                NAME   LOCATION     NAME   LOCATION     NAME   LOCATION     NAME   LOCATION

   HELLO         00     308
   ILBODSP0*    308     700
   ILBOSTP0*    A08      35
                                         ILBOSTP1     A1E


   LOCATION  REFERS TO SYMBOL  IN CONTROL SECTION             LOCATION  REFERS TO SYMBOL  IN CONTROL SECTION

       260            ILBOSTP0        ILBOSTP0                     264            ILBODSP0        ILBODSP0
       268            ILBOSTP1        ILBOSTP0
  ENTRY ADDRESS       00
  TOTAL LENGTH       A40

 ****RUN       DOES NOT EXIST BUT HAS BEEN ADDED TO DATA SET


 IEF142I - STEP WAS EXECUTED - COND CODE 0000
 IEF285I   SYS84056.T093538.RV000.COBUCLG.LOADSET       DELETED
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.GODATA        PASSED
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   SYS1.COBLIB                                  KEPT
 IEF285I   VOL SER NOS= MVTRES.
 IEF285I   SYS1.LINKLIB                                 KEPT
 IEF285I   VOL SER NOS= MVTRES.
 IEF285I   SYS84056.T093538.RV000.COBUCLG.R0000007      DELETED
 IEF285I   VOL SER NOS= SYSRES.
 IEF285I   SYS84056.T093538.SV000.COBUCLG.R0000008      SYSOUT
 IEF285I   VOL SER NOS= WORK01.
 IEF373I STEP /LKED    / START 84056.0937
 IEF374I STEP /LKED    / STOP  84056.0937 CPU   0MIN 00.04SEC MAIN  96K LCS   0K
 XXGO  EXEC PGM=*.LKED.SYSLMOD,COND=((5,LT,COB),(5,LT,LKED))             85000018
 //GO.SYSPRINT DD SYSOUT=A
 //
 IEF236I ALLOC. FOR COBUCLG  GO       HELOWRLD
 IEF237I 151   ALLOCATED TO PGM=*.DD
 IEF237I 352   ALLOCATED TO SYSPRINT
 HELLO, WORLD
 IEF142I - STEP WAS EXECUTED - COND CODE 0000
 IEF285I   SYS84056.T093538.RV000.COBUCLG.GODATA        PASSED
 IEF285I   VOL SER NOS= WORK01.
 IEF285I   SYS84056.T093538.SV000.COBUCLG.R0000009      DELETED
 IEF285I   VOL SER NOS= WORK02.
 IEF373I STEP /GO      / START 84056.0937
 IEF374I STEP /GO      / STOP  84056.0937 CPU   0MIN 00.01SEC MAIN   8K LCS   0K
 IEF285I   SYS84056.T093538.RV000.COBUCLG.GODATA        DELETED
 IEF285I   VOL SER NOS= WORK01.
 IEF375I  JOB /COBUCLG / START 84056.0937
 IEF376I  JOB /COBUCLG / STOP  84056.0937 CPU   0MIN 00.13SEC


<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE language SYSTEM "language.dtd">
<!-- Cobol highlighting for Kate by Robert G. Willan
     Thanks to Matthias M. Schneider, who's COBOL mode for JEdit I copied
     the list of keywords from.  Tweaks for GnuCOBOL by Brian Tiffin.
     -->
<language name="Cobol" version="1.00" kateversion="2.4" section="Sources"
          extensions="*.cbl;*.cob;*.pco"
          mimetype="application/x-cobol;text/x-cobol"
          casesensitive="0"
          author="Robert G. Willan" license="">
  <highlighting>
    <list name="keyword">
      <item> ACCEPT </item>
      <item> ACCESS </item>
      <item> ACTUAL </item>
      <item> ADD </item>
      <item> ADDRESS </item>
      <item> ADVANCING </item>
      <item> AFTER </item>
      <item> ALL </item>
      <item> ALLOCATE </item>
      <item> ALPHABET </item>
      <item> ALPHABETIC </item>
      <item> ALPHABETIC-LOWER </item>
      <item> ALPHABETIC-UPPER </item>
      <item> ALPHANUMERIC </item>
      <item> ALPHANUMERIC-EDITED </item>
      <item> ALSO </item>
      <item> ALTER </item>
      <item> ALTERNATE </item>
      <item> ANY </item>
      <item> API </item>
      <item> APPLY </item>
      <item> ARE </item>
      <item> AREA </item>
      <item> AREAS </item>
      <item> ARGUMENT-NUMBER </item>
      <item> ARGUMENT-VALUE </item>
      <item> ASCENDING </item>
      <item> ASCII </item>
      <item> ASSIGN </item>
      <item> AT </item>
      <item> ATTRIBUTE </item>
      <item> AUTHOR </item>
      <item> AUTO </item>
      <item> AUTO-SKIP </item>
      <item> AUTOMATIC </item>
      <item> AUTOTERMINATE </item>
      <item> AWAY-FROM-ZERO </item>

      <item> BACKGROUND-COLOR </item>
      <item> BACKGROUND-COLOUR </item>
      <item> BACKWARD </item>
      <item> BASED </item>
      <item> BASIS </item>
      <item> BEEP </item>
      <item> BEFORE </item>
      <item> BEGINNING </item>
      <item> BELL </item>
      <item> BINARY </item>
      <item> BINARY-C-LONG </item>
      <item> BINARY-CHAR </item>
      <item> BINARY-DOUBLE </item>
      <item> BINARY-INT </item>
      <item> BINARY-LONG </item>
      <item> BINARY-LONG-LONG </item>
      <item> BINARY-SHORT </item>
      <item> BLANK </item>
      <item> BLINK </item>
      <item> BLOCK </item>
      <item> BOTTOM </item>
      <item> BY </item>

      <item> C01 </item>
      <item> C02 </item>
      <item> C03 </item>
      <item> C04 </item>
      <item> C05 </item>
      <item> C06 </item>
      <item> C07 </item>
      <item> C08 </item>
      <item> C09 </item>
      <item> C10 </item>
      <item> C11 </item>
      <item> C12 </item>
      <item> CALL </item>
      <item> CALL-CONVENTION </item>
      <item> CANCEL </item>
      <item> CAPACITY </item>
      <item> CBL </item>
      <item> CD </item>
      <item> CF </item>
      <item> CH </item>
      <item> CHAIN </item>
      <item> CHAINING </item>
      <item> CHANGED </item>
      <item> CHARACTER </item>
      <item> CHARACTERS </item>
      <item> CLASS </item>
      <item> CLASSIFICATION </item>
      <item> CLOCK-UNITS </item>
      <item> CLOSE </item>
      <item> COB-CRT-STATUS </item>
      <item> COBOL </item>
      <item> CODE </item>
      <item> CODE-SET </item>
      <item> COL </item>
      <item> COLLATING </item>
      <item> COLUMN </item>
      <item> COLUMNS </item>
      <item> COLS </item>
      <item> COM-REG </item>
      <item> COMMA </item>
      <item> COMMAND-LINE </item>
      <item> COMMIT </item>
      <item> COMMON </item>
      <item> COMMUNICATION </item>
      <item> COMP </item>
      <item> COMP-0 </item>
      <item> COMP-1 </item>
      <item> COMP-2 </item>
      <item> COMP-3 </item>
      <item> COMP-4 </item>
      <item> COMP-5 </item>
      <item> COMP-6 </item>
      <item> COMP-X </item>
      <item> COMPUTATIONAL </item>
      <item> COMPUTATIONAL-0 </item>
      <item> COMPUTATIONAL-1 </item>
      <item> COMPUTATIONAL-2 </item>
      <item> COMPUTATIONAL-3 </item>
      <item> COMPUTATIONAL-4 </item>
      <item> COMPUTATIONAL-5 </item>
      <item> COMPUTATIONAL-6 </item>
      <item> COMPUTATIONAL-X </item>
      <item> COMPUTE </item>
      <item> CONDITION </item>
      <item> CONFIGURATION </item>
      <item> CONSOLE </item>
      <item> CONSTANT </item>
      <item> CONTAINS </item>
      <item> CONTENT </item>
      <item> CONTINUE </item>
      <item> CONTROL </item>
      <item> CONTROLS </item>
      <item> CONVERSION </item>
      <item> CONVERTING </item>
      <item> COPY </item>
      <item> CORE-INDEX </item>
      <item> CORR </item>
      <item> CORRESPONDING </item>
      <item> COUNT </item>
      <item> CRT </item>
      <item> CRT-UNDER </item>
      <item> CURRENCY </item>
      <item> CURRENT-DATE </item>
      <item> CURSOR </item>
      <item> CYCLE </item>
      <item> CYL-INDEX </item>
      <item> CYL-OVERFLOW </item>

      <item> DATA </item>
      <item> DATE </item>
      <item> DATE-COMPILED </item>
      <item> DATE-MODIFIED </item>
      <item> DATE-WRITTEN </item>
      <item> DAY </item>
      <item> DAY-OF-WEEK </item>
      <item> DBCS </item>
      <item> DE </item>
      <item> DEBUG </item>
      <item> DEBUG-CONTENTS </item>
      <item> DEBUG-ITEM </item>
      <item> DEBUG-LINE </item>
      <item> DEBUG-NAME </item>
      <item> DEBUG-SUB-1 </item>
      <item> DEBUG-SUB-2 </item>
      <item> DEBUG-SUB-3 </item>
      <item> DEBUGGING </item>
      <item> DECIMAL-POINT </item>
      <item> DECLARATIVES </item>
      <item> DEFAULT </item>
      <item> DELETE </item>
      <item> DELIMITED </item>
      <item> DELIMITER </item>
      <item> DEPENDING </item>
      <item> DESCENDING </item>
      <item> DESTINATION </item>
      <item> DE </item>
      <item> DETAIL </item>
      <item> DISABLE </item>
      <item> DISC </item>
      <item> DISK </item>
      <item> DISP </item>
      <item> DISPLAY </item>
      <item> DISPLAY-1 </item>
      <item> DISPLAY-ST </item>
      <item> DIVIDE </item>
      <item> DIVISION </item>
      <item> DOWN </item>
      <item> DUPLICATES </item>
      <item> DYNAMIC </item>

      <item> EBCDIC </item>
      <item> EC </item>
      <item> ECHO </item>
      <item> EGCS </item>
      <item> EGI </item>
      <item> EJECT </item>
      <item> ELSE </item>
      <item> EMI </item>
      <item> EMPTY-CHECK </item>
      <item> ENABLE </item>
      <item> END </item>
      <item> END-ACCEPT </item>
      <item> END-ADD </item>
      <item> END-CALL </item>
      <item> END-CHAIN </item>
      <item> END-COMPUTE </item>
      <item> END-DELETE </item>
      <item> END-DISPLAY </item>
      <item> END-DIVIDE </item>
      <item> END-EVALUATE </item>
      <item> END-IF </item>
      <item> END-INVOKE </item>
      <item> END-MULTIPLY </item>
      <item> END-OF-PAGE </item>
      <item> END-PERFORM </item>
      <item> END-READ </item>
      <item> END-RECEIVE </item>
      <item> END-RETURN </item>
      <item> END-REWRITE </item>
      <item> END-SEARCH </item>
      <item> END-START </item>
      <item> END-STRING </item>
      <item> END-SUBTRACT </item>
      <item> END-UNSTRING </item>
      <item> END-WRITE </item>
      <item> ENDING </item>
      <item> ENTER </item>
      <item> ENTRY </item>
      <item> ENVIRONMENT </item>
      <item> ENVIRONMENT-NAME </item>
      <item> ENVIRONMENT-VALUE </item>
      <item> EOL </item>
      <item> EOP </item>
      <item> EOS </item>
      <item> EQUAL </item>
      <item> EQUALS </item>
      <item> ERASE </item>
      <item> ERROR </item>
      <item> ESCAPE </item>
      <item> ESI </item>
      <item> EVALUATE </item>
      <item> EVERY </item>
      <item> EXAMINE </item>
      <item> EXCEEDS </item>
      <item> EXCEPTION </item>
      <item> EXCESS-3 </item>
      <item> EXCLUSIVE </item>
      <item> EXEC </item>
      <item> EXECUTE </item>
      <item> EXHIBIT </item>
      <item> EXIT </item>
      <item> EXTEND </item>
      <item> EXTENDED-SEARCH </item>
      <item> EXTERNAL </item>

      <item> FACTORY </item>
      <item> FALSE </item>
      <item> FD </item>
      <item> FH-FCD </item>
      <item> FH-KEYDEF </item>
      <item> FILE </item>
      <item> FILE-CONTROL </item>
      <item> FILE-ID </item>
      <item> FILE-LIMIT </item>
      <item> FILE-LIMITS </item>
      <item> FILLER </item>
      <item> FINAL </item>
      <item> FIRST </item>
      <item> FIXED </item>
      <item> FLOAT-DECIMAL-16 </item>
      <item> FLOAT-DECIMAK-34 </item>
      <item> FLOAT-LONG </item>
      <item> FLOAT-SHORT </item>
      <item> FOOTING </item>
      <item> FOR </item>
      <item> FOREGROUND-COLOR </item>
      <item> FOREGROUND-COLOUR </item>
      <item> FOREVER </item>
      <item> FORMAT </item>
      <item> FREE </item>
      <item> FROM </item>
      <item> FULL </item>
      <item> FUNCTION </item>
      <item> FUNCTION-ID </item>

      <item> GENERATE </item>
      <item> GIVING </item>
      <item> GLOBAL </item>
      <item> GO </item>
      <item> GOBACK </item>
      <item> GREATER </item>
      <item> GRID </item>
      <item> GROUP </item>

      <item> HEADING </item>
      <item> HIGH </item>
      <item> HIGH-VALUE </item>
      <item> HIGH-VALUES </item>
      <item> HIGHLIGHT </item>

      <item> I-O </item>
      <item> I-O-CONTROL </item>
      <item> ID </item>
      <item> IDENTIFICATION </item>
      <item> IF </item>
      <item> IGNORE </item>
      <item> IGNORING </item>
      <item> IN </item>
      <item> INDEX </item>
      <item> INDEXED </item>
      <item> INDICATE </item>
      <item> INHERITING </item>
      <item> INITIAL </item>
      <item> INITIALISE </item>
      <item> INITIALISED </item>
      <item> INITIALIZE </item>
      <item> INITIALIZED </item>
      <item> INITIATE </item>
      <item> INPUT </item>
      <item> INPUT-OUTPUT </item>
      <item> INSERT </item>
      <item> INSPECT </item>
      <item> INSTALLATION </item>
      <item> INTO </item>
      <item> INTRINSIC </item>
      <item> INVALID </item>
      <item> INVOKE </item>
      <item> IS </item>

      <item> JAPANESE </item>
      <item> JUST </item>
      <item> JUSTIFIED </item>

      <item> KANJI </item>
      <item> KEPT </item>
      <item> KEY </item>
      <item> KEYBOARD </item>

      <item> LABEL </item>
      <item> LAST </item>
      <item> LEADING </item>
      <item> LEAVE </item>
      <item> LEFT </item>
      <item> LEFT-JUSTIFY </item>
      <item> LEFTLINE </item>
      <item> LENGTH </item>
      <item> LENGTH-CHECK </item>
      <item> LESS </item>
      <item> LIMIT </item>
      <item> LIMITS </item>
      <item> LIN </item>
      <item> LINAGE </item>
      <item> LINAGE-COUNTER </item>
      <item> LINE </item>
      <item> LINE-COUNTER </item>
      <item> LINES </item>
      <item> LINKAGE </item>
      <item> LOCAL-STORAGE </item>
      <item> LOCALE </item>
      <item> LOCK </item>
      <item> LOCKING </item>
      <item> LOW </item>
      <item> LOW-VALUE </item>
      <item> LOW-VALUES </item>
      <item> LOWER </item>
      <item> LOWLIGHT </item>

      <item> MANUAL </item>
      <item> MASTER-INDEX </item>
      <item> MEMORY </item>
      <item> MERGE </item>
      <item> MESSAGE </item>
      <item> METHOD </item>
      <item> MINUS </item>
      <item> MODE </item>
      <item> MODULES </item>
      <item> MORE-LABELS </item>
      <item> MOVE </item>
      <item> MULTIPLE </item>
      <item> MULTIPLY </item>

      <item> NAME </item>
      <item> NAMED </item>
      <item> NATIONAL </item>
      <item> NATIONAL-EDITED </item>
      <item> NATIVE </item>
      <item> NCHAR </item>
      <item> NEAREST-AWAY-FROM-ZERO </item>
      <item> NEAREST-EVEN </item>
      <item> NEAREST-TOWARD-ZERO </item>
      <item> NEGATIVE </item>
      <item> NEXT </item>
      <item> NO </item>
      <item> NO-ECHO </item>
      <item> NOMINAL </item>
      <item> NORMAL </item>
      <item> NOTE </item>
      <item> NSTD-REELS </item>
      <item> NULL </item>
      <item> NULLS </item>
      <item> NUMBER </item>
      <item> NUMBER-OF-CALL-PARAMETERS </item>
      <item> NUMBERS </item>
      <item> NUMERIC </item>
      <item> NUMERIC-EDITED </item>

      <item> OBJECT </item>
      <item> OBJECT-COMPUTER </item>
      <item> OBJECT-STORAGE </item>
      <item> OCCURS </item>
      <item> OF </item>
      <item> OFF </item>
      <item> OMITTED </item>
      <item> ON </item>
      <item> ONLY </item>
      <item> OOSTACKPTR </item>
      <item> OPEN </item>
      <item> OPTIONAL </item>
      <item> ORDER </item>
      <item> ORGANISATION </item>
      <item> ORGANIZATION </item>
      <item> OTHER </item>
      <item> OTHERWISE </item>
      <item> OUTPUT </item>
      <item> OVERFLOW </item>
      <item> OVERLINE </item>

      <item> PACKED-DECIMAL </item>
      <item> PADDING </item>
      <item> PAGE </item>
      <item> PAGE-COUNTER </item>
      <item> PARAGRAPH </item>
      <item> PASSWORD </item>
      <item> PERFORM </item>
      <item> PF </item>
      <item> PH </item>
      <item> PIC </item>
      <item> PICTURE </item>
      <item> PLUS </item>
      <item> POINTER </item>
      <item> POS </item>
      <item> POSITION </item>
      <item> POSITIONING </item>
      <item> POSITIVE </item>
      <item> PREVIOUS </item>
      <item> PRINT </item>
      <item> PRINT-SWITCH </item>
      <item> PRINTER </item>
      <item> PRINTER-1 </item>
      <item> PRINTING </item>
      <item> PRIVATE </item>
      <item> PROCEDURE </item>
      <item> PROCEDURE-POINTER </item>
      <item> PROCEDURES </item>
      <item> PROCEED </item>
      <item> PROCESSING </item>
      <item> PROGRAM </item>
      <item> PROGRAM-ID </item>
      <item> PROGRAM-POINTER </item>
      <item> PROMPT </item>
      <item> PROTECTED </item>
      <item> PUBLIC </item>
      <item> PURGE </item>

      <item> QUEUE </item>
      <item> QUOTE </item>
      <item> QUOTES </item>

      <item> RANDOM </item>
      <item> RANGE </item>
      <item> RD </item>
      <item> READ </item>
      <item> READY </item>
      <item> RECEIVE </item>
      <item> RECORD </item>
      <item> RECORD-OVERFLOW </item>
      <item> RECORDING </item>
      <item> RECORDS </item>
      <item> RECURSIVE </item>
      <item> REDEFINES </item>
      <item> REEL </item>
      <item> REFERENCE </item>
      <item> REFERENCES </item>
      <item> RELATIVE </item>
      <item> RELEASE </item>
      <item> RELOAD </item>
      <item> REMAINDER </item>
      <item> REMARKS </item>
      <item> REMOVAL </item>
      <item> RENAMES </item>
      <item> REORG-CRITERIA </item>
      <item> REPLACE </item>
      <item> REPLACING </item>
      <item> REPORT </item>
      <item> REPORTING </item>
      <item> REPORTS </item>
      <item> REPOSITORY </item>
      <item> REQUIRED </item>
      <item> REREAD </item>
      <item> RERUN </item>
      <item> RESERVE </item>
      <item> RESET </item>
      <item> RETURN </item>
      <item> RETURN-CODE </item>
      <item> RETURNING </item>
      <item> REVERSE </item>
      <item> REVERSE-VIDEO </item>
      <item> REVERSED </item>
      <item> REWIND </item>
      <item> REWRITE </item>
      <item> RF </item>
      <item> RH </item>
      <item> RIGHT </item>
      <item> RIGHT-JUSTIFY </item>
      <item> ROLLBACK </item>
      <item> ROUNDED </item>
      <item> RUN </item>

      <item> S01 </item>
      <item> S02 </item>
      <item> S03 </item>
      <item> S04 </item>
      <item> S05 </item>
      <item> SAME </item>
      <item> SCREEN </item>
      <item> SCROLL </item>
      <item> SD </item>
      <item> SEARCH </item>
      <item> SECTION </item>
      <item> SECURE </item>
      <item> SECURITY </item>
      <item> SEEK </item>
      <item> SEGMENT </item>
      <item> SEGMENT-LIMIT </item>
      <item> SELECT </item>
      <item> SELECTIVE </item>
      <item> SEND </item>
      <item> SENTENCE </item>
      <item> SEPARATE </item>
      <item> SEQUENCE </item>
      <item> SEQUENTIAL </item>
      <item> SERVICE </item>
      <item> SET </item>
      <item> SHARING </item>
      <item> SHIFT-IN </item>
      <item> SHIFT-OUT </item>
      <item> SIGN </item>
      <item> SIGNED </item>
      <item> SIGNED-INT </item>
      <item> SIGNED-LONG </item>
      <item> SIGNED-SHORT </item>
      <item> SIZE </item>
      <item> SKIP1 </item>
      <item> SKIP2 </item>
      <item> SKIP3 </item>
      <item> SORT </item>
      <item> SORT-CONTROL </item>
      <item> SORT-CORE-SIZE </item>
      <item> SORT-FILE-SIZE </item>
      <item> SORT-MERGE </item>
      <item> SORT-MESSAGE </item>
      <item> SORT-MODE-SIZE </item>
      <item> SORT-OPTION </item>
      <item> SORT-RETURN </item>
      <item> SOURCE </item>
      <item> SOURCE-COMPUTER </item>
      <item> SPACE </item>
      <item> SPACE-FILL </item>
      <item> SPACES </item>
      <item> SPECIAL-NAMES </item>
      <item> STANDARD </item>
      <item> STANDARD-1 </item>
      <item> STANDARD-2 </item>
      <item> START </item>
      <item> STATIC </item>
      <item> STATUS </item>
      <item> STDCALL </item>
      <item> STEP </item>
      <item> STOP </item>
      <item> STORE </item>
      <item> STRING </item>
      <item> SUB-QUEUE-1 </item>
      <item> SUB-QUEUE-2 </item>
      <item> SUB-QUEUE-3 </item>
      <item> SUBTRACT </item>
      <item> SUM </item>
      <item> SUPER </item>
      <item> SUPPRESS </item>
      <item> SYMBOLIC </item>
      <item> SYNC </item>
      <item> SYNCHRONISED </item>
      <item> SYNCHRONIZED </item>
      <item> SYSIN </item>
      <item> SYSIPT </item>
      <item> SYSLST </item>
      <item> SYSOUT </item>
      <item> SYSPCH </item>
      <item> SYSPUNCH </item>
      <item> SYSTEM-DEFAULT </item>

      <item> TAB </item>
      <item> TABLE </item>
      <item> TALLY </item>
      <item> TALLYING </item>
      <item> TAPE </item>
      <item> TERMINAL </item>
      <item> TERMINATE </item>
      <item> TEST </item>
      <item> TEXT </item>
      <item> THAN </item>
      <item> THEN </item>
      <item> THROUGH </item>
      <item> THRU </item>
      <item> TIME </item>
      <item> TIME-OF-DAY </item>
      <item> TIME-OUT </item>
      <item> TIMEOUT </item>
      <item> TIMES </item>
      <item> TITLE </item>
      <item> TO </item>
      <item> TOP </item>
      <item> TOTALED </item>
      <item> TOTALING </item>
      <item> TOWARD-GREATER </item>
      <item> TOWARD-LESSER </item>
      <item> TRACE </item>
      <item> TRACK-AREA </item>
      <item> TRACK-LIMIT </item>
      <item> TRACKS </item>
      <item> TRAILING </item>
      <item> TRAILING-SIGN </item>
      <item> TRANSFORM </item>
      <item> TRUE </item>
      <item> TYPE </item>
      <item> TYPEDEF </item>

      <item> UNDERLINE </item>
      <item> UNEQUAL </item>
      <item> UNIT </item>
      <item> UNLOCK </item>
      <item> UNSIGNED </item>
      <item> UNSIGNED-INT </item>
      <item> UNSIGNED-LONG </item>
      <item> UNSIGNED-SHORT </item>
      <item> UNSTRING </item>
      <item> UNTIL </item>
      <item> UP </item>
      <item> UPDATE </item>
      <item> UPON </item>
      <item> UPPER </item>
      <item> UPSI-0 </item>
      <item> UPSI-1 </item>
      <item> UPSI-2 </item>
      <item> UPSI-3 </item>
      <item> UPSI-4 </item>
      <item> UPSI-5 </item>
      <item> UPSI-6 </item>
      <item> UPSI-7 </item>
      <item> USAGE </item>
      <item> USE </item>
      <item> USER </item>
      <item> USER-DEFAULT </item>
      <item> USING </item>

      <item> VALUE </item>
      <item> VALUES </item>
      <item> VARIABLE </item>
      <item> VARYING </item>

      <item> WAIT </item>
      <item> WHEN </item>
      <item> WHEN-COMPILED </item>
      <item> WITH </item>
      <item> WORDS </item>
      <item> WORKING-STORAGE </item>
      <item> WRITE </item>
      <item> WRITE-ONLY </item>
      <item> WRITE-VERIFY </item>

      <item> YYYYDDD </item>
      <item> YYYYMMDD </item>

      <item> ZERO </item>
      <item> ZERO-FILL </item>
      <item> ZEROES </item>
      <item> ZEROS </item>
    </list>

    <list name="builtinfuncs">
      <item> ACOS </item>
      <item> ANNUITY </item>
      <item> ASIN </item>
      <item> ATAN </item>
      <item> BYTE-LENGTH </item>
      <item> CHAR </item>
      <item> COMBINED-DATETIME </item>
      <item> CONCATENATE </item>
      <item> COS </item>
      <item> CURRENT-DATE </item>
      <item> DATE-OF-INTEGER </item>
      <item> DATE-TO-YYYYMMDD </item>
      <item> DAY-OF-INTEGER </item>
      <item> DAY-TO-YYYYDD </item>
      <item> E </item>
      <item> EXCEPTION-FILE </item>
      <item> EXCEPTION-LOCATION </item>
      <item> EXCEPTION-STATEMENT </item>
      <item> EXCEPTION-STATUS </item>
      <item> EXP </item>
      <item> EXP10 </item>
      <item> FACTORIAL </item>
      <item> FORMATTED-CURRENT-DATE </item>
      <item> FORMATTED-DATE </item>
      <item> FORMATTED-DATETIME </item>
      <item> FORMATTED-TIME </item>
      <item> FRACTION-PART </item>
      <item> HIGHEST-ALGEBRAIC </item>
      <item> INTEGER </item>
      <item> INTEGER-OF-DATE </item>
      <item> INTEGER-OF-DAY </item>
      <item> INTEGER-OF-FORMATTED-DATE </item>
      <item> INTEGER-PART </item>
      <item> LENGTH-AN </item>
      <item> LOCALE- </item>
      <item> LOG </item>
      <item> LOCALE-COMPARE </item>
      <item> LOCALE-DATE </item>
      <item> LOCALE-TIME </item>
      <item> LOCALE-TIME-FROM-SECONDS </item>
      <item> LOG10 </item>
      <item> LOWER-CASE </item>
      <item> HIGHEST-ALGEBRAIC </item>
      <item> MAX </item>
      <item> MEAN </item>
      <item> MEDIAN </item>
      <item> MIDRANGE </item>
      <item> MIN </item>
      <item> MODULE-CALLER-ID </item>
      <item> MODULE-DATE </item>
      <item> MODULE-FORMATTED-TIME </item>
      <item> MODULE-ID </item>
      <item> MODULE-PATH </item>
      <item> MODULE-SOURCE </item>
      <item> MODULE-TIME </item>
      <item> MONETARY-DECIMAL-POINT </item>
      <item> MONETARY-THOUSANDS-SEPARATOR </item>
      <item> NUMERIC-DECIMAL-POINT </item>
      <item> NUMERIC-THOUSANDS-SEPARATOR </item>
      <item> NUMVAL </item>
      <item> NUMVAL-C </item>
      <item> NUMVAL-F </item>
      <item> ORD </item>
      <item> ORD-MAX </item>
      <item> ORD-MIN </item>
      <item> PI </item>
      <item> PRESENT-VALUE </item>
      <item> RANDOM </item>
      <item> RANGE </item>
      <item> REM </item>
      <item> REVERSE </item>
      <item> SECONDS-FROM-FORMATTED-TIME </item>
      <item> SECONDS-PAST-MIDNIGHT </item>
      <item> SIGN </item>
      <item> SIN </item>
      <item> SQRT </item>
      <item> STANDARD-DEVIATION </item>
      <item> STORED-CHAR-LENGTH </item>
      <item> SUBSTITUTE </item>
      <item> SUBSTITUTE-CASE </item>
      <item> SUM </item>
      <item> TAN </item>
      <item> TEST-DATE-YYYYMMDD </item>
      <item> TEST-DAY-YYYYDDD </item>
      <item> TEST-FORMATTED-DATETIME </item>
      <item> TEST-NUMVAL </item>
      <item> TEST-NUMVAL-C </item>
      <item> TEST-NUMVAL-F </item>
      <item> TRIM </item>
      <item> UPPER-CASE </item>
      <item> VARIANCE </item>
      <item> WHEN-COMPILED </item>
      <item> YEAR-TO-YYYY </item>
    </list>

    <list name="operators">
      <item> AND </item>
      <item> OR </item>
      <item> NOT </item>
    </list>

    <list name="prep">
      <item> [COPY-PREFIX] </item>
      <item> [COUNT] </item>
      <item> [DISPLAY] </item>
      <item> [EXECUTE] </item>
      <item> [PG] </item>
      <item> [PREFIX] </item>
      <item> [PROGRAM] </item>
      <item> [SPECIAL-PREFIX] </item>
      <item> [TESTCASE] </item>
    </list>

    <contexts>
      <context name="Normal" attribute="Normal Text" lineEndContext="#stay">
        <!-- Embedded SQL, treated as a special code block.  Must be first,
             before the Keywords are declared (EXEC is also a keyword). -->
        <StringDetect attribute="Embedded SQL" String="EXEC SQL" context="sql-code"/>

        <keyword attribute="Preprocessor"     String="prep"         context="#stay"/>
        <keyword attribute="Keyword"          String="keyword"      context="#stay"/>
        <keyword attribute="Builtin Function" String="builtinfuncs" context="#stay"/>
        <keyword attribute="Operator"         String="operators"    context="#stay"/>
        <keyword attribute="Embedded SQL"     String="specialvars"  context="#stay"/>

        <!-- Note that these comment lines must be before the operators, etc,
             because the RegExpr's are searched in the order they are declared
             in this file, and if the '*' operator comes first, then the
             comments starting with '*' in col 7 don't get recognized. -->
        <!-- Comment: * in col 7 means rest of line is a comment -->
        <DetectChar   attribute="Comment" char="*"         context="line-comment"
                      column   ="6"/>
        <DetectChar   attribute="Comment" char="*"         context="line-comment"
                      column   ="0"/>
        <RegExpr      attribute="Comment" String="\*&gt;"  context="line-comment" />

        <!-- Comment: columns 73-80 are always comments -->
        <!-- <RegExpr      attribute="Comment" String=".+"      context="#stay"
                      column   ="72"/> -->
        <!-- Comment: columns 1-6 are line-numbering or comments (Micro Focus) -->
        <!-- <RegExpr      attribute="Comment" String="^......" context="#stay"/> -->

        <!-- Special highlighting for paragraph names - Starts in col7 and ends with
             either a period or the word SECTION. -->
        <RegExpr attribute="Paragraph" String="[-0-9a-zA-Z]+(?=( *\.)|( +SECTION *\.))"
                 context  ="#stay"     column="7"/>

        <!-- Single Quoted and Double Quoted strings -->
        <!-- Note that strings continued across lines using continuation '-' in
             column 7 are not considered.  Any program having such continuations
             will get its highlighting messed up because of unmatched quotes. -->
        <DetectChar   attribute="String"  char="'"      context="single-Q-string"/>
        <DetectChar   attribute="String"  char="&quot;" context="double-Q-string"/>

        <RegExpr attribute="String"  String="z'"
                 context="single-Q-string"/>
        <RegExpr attribute="String"  String="z&quot;"
                 context="double-Q-string"/>

        <!-- compiler directives -->
        <RegExpr attribute="String"       String=">>"        context="#stay"/>

        <!-- This is required so identifiers stay normal.  Otherwise, you have to
             mess with the Integers regex to try to allow S9V99 and such, which
              I couldn't make work. -->
        <RegExpr attribute="Normal" String="[0-9a-zA-Z]+[-a-zA-Z][\-0-9a-zA-Z]*"
                 context  ="#stay"/>

        <!-- Highlighting for numbers -->
        <RegExpr attribute="Int"     String="[0-9]+"
                 context  ="#stay"/>
        <RegExpr attribute="Int"     String="[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?"
                 context  ="#stay"/>
        <RegExpr attribute="String"  String="[Xx]&quot;[0-9a-fA-F]+&quot;"
                 context  ="#stay"/>

        <!-- Hex strings X, and hex integers, H -->
        <RegExpr attribute="String"  String="[Xx]'[0-9a-fA-F]+'"
                 context="#stay"/>
        <RegExpr attribute="Int"     String="[Hh]'[0-9a-fA-F]+'"
                 context="#stay"/>
        <RegExpr attribute="Int"     String="[Hh]&quot;[0-9a-fA-F]+&quot;"
                 context="#stay"/>

        <RegExpr attribute="Octal"   String="%[1-9]\d*"
                 context  ="#stay"/>

        <!-- Operators defined here.  The minus is separate because it must be
             separated by spaces, since otherwise it could just be part of an
              identifier name. -->
        <RegExpr      attribute="Operator" context="#stay"
                      String="[\-+*/%\|\[\]\{\}=\!&lt;&gt;!^&amp;~]"/>
        <StringDetect attribute="Operator" String=" - "     context="#stay"/>
        <RegExpr      attribute="Keyword"  String="[\(\)]"  context="#stay"/>
      </context>

      <context name="line-comment" attribute="Comment" lineEndContext="#pop">
        <HlCChar      attribute="Comment"                   context="#stay"/>
      </context>

      <context name="sql-code" attribute="Embedded SQL" lineEndContext="#stay">
        <HlCChar      attribute="Embedded SQL"                   context="#stay"/>
        <StringDetect attribute="Embedded SQL" String="END-EXEC" context="#pop"/>

        <!-- Comment: * in col 7 means rest of line is a comment -->
        <DetectChar attribute="Comment" char="*"         context="line-comment"
                    column   ="6"/>
        <DetectChar   attribute="Comment" char="*"         context="line-comment"
                    column   ="0"/>
        <RegExpr      attribute="Comment" String="\*&gt;"  context="line-comment" />

        <!-- Comment: columns 73-80 are always comments -->
        <!-- <RegExpr    attribute="Comment" String=".+"      context="#stay"
                    column   ="72"/> -->
        <!-- Comment: columns 1-6 are line-numbering or comments (Micro Focus) -->
        <!-- <RegExpr    attribute="Comment" String="^......" context="#stay"/> -->
      </context>

      <context name="single-Q-string" attribute="String" lineEndContext="#stay">
        <HlCStringChar attribute="String"                      context="#stay"/>
        <RegExpr       attribute="Operator" String="%[a-zA-Z]" context="#stay"/>
        <DetectChar    attribute="String"   char="'"           context="#pop"/>
      </context>

      <context name="double-Q-string" attribute="String" lineEndContext="#stay">
        <HlCStringChar attribute="String"                      context="#stay"/>
        <RegExpr       attribute="Operator" String="%[a-zA-Z]" context="#stay"/>
        <DetectChar    attribute="String"   char="&quot;"      context="#pop"/>
      </context>

    </contexts>
    <itemDatas>
      <itemData name="Normal Text"      defStyleNum="dsNormal"/>
      <itemData name="Keyword"          defStyleNum="dsKeyword"/>
      <itemData name="Operator"         defStyleNum="dsChar"/>
      <itemData name="Builtin Function" defStyleNum="dsDataType"/>
      <itemData name="Paragraph"        defStyleNum="dsRegionMarker"/>
      <itemData name="Embedded SQL"     defStyleNum="dsOthers"/>
      <itemData name="Preprocessor"     defStyleNum="dsChar"/>
      <itemData name="Comment"          defStyleNum="dsComment"/>
      <itemData name="String"           defStyleNum="dsString"/>
      <itemData name="Int"              defStyleNum="dsDecVal"/>
      <itemData name="Hex"              defStyleNum="dsString"/>
      <itemData name="Octal"            defStyleNum="dsString"/>
     </itemDatas>
  </highlighting>
   <general>
     <!-- Must use WeakDelimiter because some keywords are made up of two
          words separated by a dash. -->
     <keywords casesensitive   = "0"
               weakDeliminator = "-"/>
   </general>
</language>
<!--
// kate: space-indent on; indent-width 2; replace-tabs on;
-->

>>SOURCE FORMAT IS FREE
*>****************************************************************
*> OpenCobol/Postgresql engine
*>
*> Compile with:
*>
*>
*>     cobc -m -free libpgsql.cbl -lpq
*>
*> Refer to libpq-fe.h for data definitions
*> Refer to http://www.postgresql.org/docs/8.3/static/libpq.html
*>
*> Change History:
*> 2008-Oct-3 gc Created from lessons learned in psqltest.cbl
*> 2009-Nov   gc return a list of base tables
*> 2009-Dec   gc Clean up libpq field translation errors
*>
*> Roger While says the USAGE BINARY-XXX [SIGNED/UNSIGNED]
*> where XXX is CHAR, SHORT, LONG, DOUBLE
*> giving 1, 2, 4, 8 byte binary fields
*>
*> Copyright (c) 2008 Gerald Chudyk <gchudyk@ekotech.com>
*>
*> Permission to use, copy, modify, and distribute this software for any
*> purpose with or without fee is hereby granted, provided that the above
*> copyright notice and this permission notice appear in all copies.
*>
*> THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
*> WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
*> MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
*> ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
*> WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
*> ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
*> OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*>
*>
*>****************************************************************
 identification division.
 program-id. libpgsql.
 environment division.
 configuration section.
 special-names.
 crt status is crtStatus.
 Repository.
    Function all intrinsic. *> removes need for 'function' keyword
 input-output section.
 file-control.
 select log-file assign to "psqlog.txt"
     organization is line sequential.
 data division.
 file section.
 fd  log-file.
 01  log-rec                 pic x(80).
 01  filler redefines log-rec.
     05 log-date             pic 999/99/99.
     05 filler               pic x.
     05 log-text             pic x(70).
 working-storage section.
 01  sw-debug-switch         pic x value space.
     88 sw-debug             value "D" false space.

 01  charCommand             pic x(10).
 01  charConninfo            pic x(512).
 01  charConninfoStatus      pic x(128).
 01  charDate                pic 999/999/99.
 01  charFrom                pic x(1023).
 01  charPQerrorMessage      pic x(1024).
 01  charParameterStatus     pic x(128).
 01  charParamName           pic x(30).
 01  charSelectTables        pic x(100) value
     "SELECT table_name, table_type FROM INFORMATION_SCHEMA.TABLES" &
     " where table_schema='public';" & x"00".
 01  charTo                  pic x(2048).
 01  charVersion             pic x(4) value "v1.0".

 01  crtStatus.
      05 crtStatusKey1        pic 9.
      05 crtStatusKey2        pic 9.
      05 crtStatusFunctionKey redefines crtStatusKey2 pic 99 comp.
      05 crtStatusKey3        pic 99 comp.
      05 filler               pic x.

 01  vTemp                    pic x(1024)  based.

 01  ptrFieldName            usage pointer.
 01  ptrExecStatusType       usage pointer.
 01  ptrPQcmdStatus          usage pointer.
 01  ptrPQcmdTuples          usage pointer.
 01  ptrPGconn               usage pointer.
 01  ptrPQerrorMessage       usage pointer.
 01  ptrPQescapeByteaConn    usage pointer.
 01  ptrPGExecStatusType     usage pointer.
 01  ptrPQfname              usage pointer.
 01  ptrPQgetvalue           usage pointer.
 01  ptrPQoidStatus          usage pointer.
 01  ptrPQparameterStatus    usage pointer.
 01  ptrPQprint              usage pointer.
 01  ptrPQresStatus          usage pointer.
 01  ptrPGresult             usage pointer.
 01  intptrPGresult      redefines ptrPGresult usage binary-long.
 01  ptrPQresultErrorMessage usage pointer.
 01  ptrPQresultErrorField   usage pointer.
 01  intptrPQresultErrorField redefines ptrPQresultErrorField usage binary-long.
 01  ptrPQftablecol          usage pointer.
 01  ptrReturn               usage pointer.
 01  ptrTableOID             usage pointer.


 01  dbName                  pic x(128) value "mentor".
 01  dbUser                  pic x(128) value "gc".
 01  dbPassword              pic x(128) value "2manysecrets".
 01  dbHost                  pic x(128) value "amnesiac.eko.lan".
 01  dbHostAddr              pic x(128) value "192.168.2.4".
 01  dbPort                  pic x(128) value "5432".
 01  dbOptions               pic x(128).
 01  dbServerVersion         usage binary-long.
 01  dbErrorMsg              pic x(1000).

 01  intCharCount                    usage binary-long.
 01  intColumnCount                  usage binary-long.
 01  intColumnNumber                 usage binary-long.
 01  intConnStatusType               usage binary-long. *> connection status.
     88 CONNECTION_OK                value 0.
     88 CONNECTION_BAD               value 1.
*>   Additional asynchronous (nonblocking) connection status values follow:
*>   The existence of these should never be relied upon.
*>   They should only be used for user feedback or similar purposes.
     88 CONNECTION_STARTED           value 2. *> Waiting for connection to be made.
     88 CONNECTION_MADE              value 3. *> Connection OK; waiting to send.
     88 CONNECTION_AWAITING_RESPONSE value 4. *> Waiting for a response from the postmaster.
     88 CONNECTION_AUTH_OK           value 5. *> Received authentication; waiting for backend startup.
     88 CONNECTION_SETENV        value 6. *> Negotiating SSL.
     88 CONNECTION_SSL_STARTUP       value 7. *> Negotiating SSL.
     88 CONNECTION_NEEDED        value 8. *> Negotiating SSL.

 01  intDate                         pic 9(8) comp-5.

 01  intError                        usage binary-long.

 01  intExecStatusType               usage binary-long.
     88 PGRES_EMPTY_QUERY            value 0. *> Empty query string was executed
     88 PGRES_COMMAND_OK             value 1. *> A query command that doesn't return
                                              *>   anything was executed properly by the
                                              *>   backend
     88 PGRES_TUPLES_OK              value 2. *> A query command that returns tuples was
                                              *>   executed properly by the backend, PGresult
                                              *>   contains the result tuples
     88 PGRES_COPY_OUT               value 3. *> Copy Out data transfer in progress
     88 PGRES_COPY_IN                value 4. *> Copy In data transfer in progress
     88 PGRES_BAD_RESPONSE           value 5. *> An unexpected response was recv'd from the backend
     88 PGRES_NONFATAL_ERROR         value 6. *> Notice or warning message
     88 PGRES_FATAL_ERROR            value 7. *> Query failed

 01  intFieldCode                    usage binary-long.
     88 PG_DIAG_SEVERITY          value "S".
     88 PG_DIAG_SQLSTATE          value "C".
     88 PG_DIAG_MESSAGE_PRIMARY       value "M".
     88 PG_DIAG_MESSAGE_DETAIL        value "D".
     88 PG_DIAG_MESSAGE_HINT      value "H".
     88 PG_DIAG_STATEMENT_POSITION    value "P".
     88 PG_DIAG_INTERNAL_POSITION     value "p".
     88 PG_DIAG_INTERNAL_QUERY        value "q".
     88 PG_DIAG_CONTEXT           value "W".
     88 PG_DIAG_SOURCE_FILE       value "F".
     88 PG_DIAG_SOURCE_LINE       value "L".
     88 PG_DIAG_SOURCE_FUNCTION       value "R".

 01  intFromLength                     usage binary-long.

 01  intPGresult                usage binary-long.

 01  intPostgresPollingStatusType      usage binary-long.
     88  PGRES_POLLING_FAILED          value 0.
     88  PGRES_POLLING_READING         value 1. *> These two indicate that one may
     88  PGRES_POLLING_WRITING         value 2. *> use select before polling again
     88  PGRES_POLLING_OK              value 3. *>
 01  intPGexecStatusType               usage binary-long.
 01  intPGTransactionStatusType        usage binary-long.
     88 PQTRANS_IDLE                   value 0. *> connection idle
     88 PQTRANS_ACTIVE                 value 1. *> command in progress
     88 PQTRANS_INTRANS                value 2. *> idle, within transaction block
     88 PQTRANS_INERROR                value 3. *> idle, within failed transaction
     88 PQTRANS_UNKNOWN                value 4. *> cannot determine status
 01  intPGVerbosity                    usage binary-long.
     88 PQERRORS-TERSE                 value 0. *> single-line error messages
     88 PQERRORS-DEFAULT               value 1. *> recommended style
     88 PQERRORS-VERBOSE               value 2. *> all the facts, ma'am
 01  intPQbackendPID                   usage binary-long.
 01  intPQconnectionNeedsPassword      usage binary-long.
 01  intPQconnectionUsedPassword       usage binary-long.
 01  intPQntuples                      usage binary-long.
 01  intPQnfields                      usage binary-long.
 01  intPQfnumber                      usage binary-long.
 01  intPQftablecol                    usage binary-long.
 01  intPQfformat                      usage binary-long.
     88 PQFFORMAT_TEXT                 value 0.
     88 PQFFORMAT_BINARY               value 1.
 01  intPQfsize                        usage binary-long.
 01  intPQbinaryTuples                 usage binary-long.
 01  intPQfmod                         usage binary-long.
 01  intPQgetisnull                    usage binary-long.
 88 PQGETISNULL-TRUE           value 1.
 88 PQGETISNULL-FALSE          value zero.
 01  intPQgetlength                    usage binary-long.
 01  intPQnparams                      usage binary-long.
 01  intPQsocket               usage binary-long.
 01  intResult                         usage binary-long.
 01  intRowNumber                      usage binary-long.
 01  intToLength                       usage binary-long.

 01  lngFieldLength                    usage binary-long.

 01  oidPQftype                        usage binary-long.
 01  oidPQparamtype                    usage binary-long.
 01  oidPQoidValue                     usage binary-long.

 01  sqlCommand                        pic x(1024).
 01  sqlRequest                        pic x(50).
     88 sqlRequestConnect_timeout      value "connect_timeout".
     88 sqlRequestCreate               value "create".
     88 sqlRequestDelete               value "delete".
     88 sqlRequestDbname               value "dbname".
     88 sqlRequestGsslib               value "gsslib".
     88 sqlRequestHost                 value "host".
     88 sqlRequestHostaddr             value "hostaddr".
     88 sqlRequestKrbsrvname           value "krbsrvname".
     88 sqlRequestOptions              value "options".
     88 sqlRequestPassword             value "password".
     88 sqlRequestPort                 value "port".
     88 sqlRequestRequiressl           value "requiressl".
     88 sqlRequestSelect               value "sql".
     88 sqlRequestService              value "service".
     88 sqlRequestSslmode              value "sslmode".
     88 sqlRequestTty                  value "tty".
     88 sqlRequestUser                 value "user".

 01  sqlString                         pic x(1024).

 01  tblPGtype.
     05 tblPGtype-tuple                occurs 300 times.
       10 tblPGtypeOID                 pic x(4) comp-x.
       10 tblPGtypeName                pic x(23).

 Linkage Section.

 copy '../cpy/lsrecord.cpy'.

 procedure division using lsRecord lsRequest lsReply.

 main.
     perform a-initialize
     evaluate true
     when DEBUG_COMMAND
    perform b-set-debug
     when START_DB_COMMAND
        perform c-start-db
     when CLOSE_DB_COMMAND
        perform d-close-db
     when START_CONN_COMMAND
        perform e-start-connection
 when POLL_COMMAND
    perform f-poll-connection
     when CLOSE_CONN_COMMAND
        perform g-close-connection
     when GET_DBNAME_COMMAND
        perform h-get-db-name
     when GET_BASE_TABLES_COMMAND
        perform j-get-base-table-list
     when SQL_COMMAND
        perform x-sql-exec
     when MORE_COMMAND
        perform y-reply-to-select
     when other
        set LS_BAD_COMMAND to true
     end-evaluate
     exit program
     stop run
     .
 a-initialize.
     if lsConnHandle not = null
        set ptrPGconn to lsConnHandle
     end-if
     .
 b-set-debug.
     set SW-DEBUG to true
     open output log-file
     initialize log-rec
     accept intDate from date
     move intDate to log-date
     string charVersion " Debug started " delimited by size into log-text
     write log-rec
     .
 c-start-db.
     if lsConnHandle = null
        if lsRequest > space
           move lsRequest to charConnInfo
   initialize intCharCount
           compute intCharCount = length(charConnInfo)
           perform varying intCharCount from intCharCount by -1
              until intCharCount = 1
              or charConnInfo(intCharCount:1) > space
           end-perform
           add 1 to intCharCount
           move low-value to charConnInfo(intCharCount:1)
           perform pq-connect-db
           set lsConnHandle to ptrPGconn
           perform pq-status
           if CONNECTION_OK
              set LS_RESULT_OK to true
           else
   if CONNECTION_STARTED
       display "Waiting for connection to be made"
   else
   if CONNECTION_MADE
       display "Connection OK; waiting to send"
   else
   if CONNECTION_AWAITING_RESPONSE
       display "Waiting for a response from the postmaster"
   else
               set LS_CONNECTION_ATTEMPT_FAILED to true
           end-if
        else
           set LS_CONNECTION_DATA_REQUIRED to true
        end-if
 else
        set LS_CONNECTION_HANDLE_NOT_EMPTY to true
     end-if
     .
 d-close-db.
     perform pq-clear
     initialize lsRecordHandle
     .
 e-start-connection.
     if lsConnHandle = null
        if lsRequest > space
           move lsRequest to charConnInfo
   initialize intCharCount
           compute intCharCount = length(charConnInfo)
           perform varying intCharCount from intCharCount by -1
              until intCharCount = 1
              or charConnInfo(intCharCount:1) > space
           end-perform
           add 1 to intCharCount
           move low-value to charConnInfo(intCharCount:1)
           perform pq-connect-start
           set lsConnHandle to ptrPGconn
           perform pq-status
           if CONNECTION_OK
              set LS_RESULT_OK to true
           else
   if CONNECTION_STARTED
       display "Waiting for connection to be made"
   else
   if CONNECTION_MADE
       display "Connection OK; waiting to send"
   else
   if CONNECTION_AWAITING_RESPONSE
       display "Waiting for a response from the postmaster"
   else
               set LS_CONNECTION_ATTEMPT_FAILED to true
           end-if
        else
           set LS_CONNECTION_DATA_REQUIRED to true
        end-if
 else
        set LS_CONNECTION_HANDLE_NOT_EMPTY to true
     end-if
     .

 f-poll-connection.
     perform pq-connect-poll
 if PGRES_POLLING_OK
        set LS_RESULT_OK to true
 else if PGRES_POLLING_READING
    set LS_CONNECTION_POLL_READING to true
 else if PGRES_POLLING_WRITING
    set LS_CONNECTION_POLL_WRITING to true
 else if PGRES_POLLING_FAILED
        set LS_CONNECTION_ATTEMPT_FAILED to true
        set lsConnHandle to null
 end-if
 .
 g-close-connection.
     perform pq-finish
     initialize lsRecord
     .
 h-get-db-name.
     perform pq-db
 move dbName to lsReply
     .
 j-get-base-table-list.
*> This paragraph will return a list of base tables
*> in the current database.
*>
*> If this paragraph is called with lsRecordCount initialized
*> to zero then the lsRecordCount will be set to the number
*> of base tables in the list, lsRecordCusor will be set to 1,
*>  lsFieldLength will give the length of the first record,
*> and the first record will be in lsReply.
*>
*> Subsequent calls will result in lsRecordCursor being incremented
*> by 1 until all valid records have been returned.
*>
*> Fields in record will be separated by 1 low-value character.
*>
*>
 Move charSelectTables to sqlCommand
     perform pq-exec
     perform pq-result-status
 if (PGRES_BAD_RESPONSE
 or PGRES_NONFATAL_ERROR
 or PGRES_FATAL_ERROR)
        initialize lsReply vTemp
        perform pq-error-message
        set address of vTemp to ptrPQerrorMessage
        unstring vTemp delimited by low-value into lsReply
        set LS_RESULT_SELECT_FAILED to true
     else
        perform pq-n-tuples               *> how many rows?
    if lsRecordCursor > intPQntuples
    or intPQntuples = zero
           set LS_RESULT_AT_END to true
   initialize lsRecordCount
        else
            move intPQntuples to lsRecordCount
        perform pq-n-fields               *> How many columns?
            if intPQnfields = zero
               set LS_RESULT_AT_END to true
            else
               move intPQnfields to lsColumnCount
       move lsRecordCursor to intRowNumber
       if intRowNumber > zero
          subtract 1 from intRowNumber    *> count starts at zero
       end-if
       move lsColumnCursor to intColumnNumber
       if intColumnNumber > zero
          subtract 1 from intColumnNumber     *> count starts at zero
       end-if
       perform pq-get-length
       move intPQgetlength to lsFieldLength
       perform pq-f-format
       move intPQfformat to lsFieldFormat
       perform pq-get-is-null
       if PQGETISNULL-TRUE
      set FIELD_IS_NULL to true
       else
      set FIELD_IS_NULL to false
          perform pq-f-name
          initialize lsFieldName lsFieldNameLength
          set address of vTemp to ptrPQfname
          unstring vTemp delimited by low-value into lsFieldName
          count in lsFieldNameLength
          perform pq-get-value
          initialize lsReply
          set address of vTemp to ptrPQgetValue
          unstring vTemp delimited by low-value into lsReply
       end-if
            end-if
        end-if
 end-if
 perform pq-clear
 .
*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 x-sql-exec.
     if lsRecordHandle not = zero
        set LS_HANDLE_MISSING to true
        exit paragraph
     end-if

 move lsRequest to sqlCommand
 perform varying intCharCount from function length(sqlCommand) by -1
  until sqlCommand(intCharCount:1) > space
 end-perform
 add 1 to intCharCount
 move low-value to sqlCommand(intCharCount:1)
     perform pq-exec
     perform pq-result-status
 evaluate true
 when PGRES_EMPTY_QUERY
    set LS_PGRES_EMPTY_QUERY to true
     when PGRES_COMMAND_OK
        set LS_PGRES_COMMAND_OK to true
 when PGRES_TUPLES_OK
    set LS_PGRES_TUPLES_OK to true
    perform x1-get-tuple-info
    perform x2-get-field-info
    perform x3-get-length-info
 when PGRES_COPY_OUT
    set LS_PGRES_COPY_OUT to true
 when PGRES_COPY_IN
    set LS_PGRES_COPY_IN to true
 when PGRES_BAD_RESPONSE
    set LS_PGRES_BAD_RESPONSE to true
 when PGRES_NONFATAL_ERROR
    set LS_PGRES_NONFATAL_ERROR to true
 when PGRES_FATAL_ERROR
    set LS_PGRES_FATAL_ERROR to true
     end-evaluate

*>  This will return the above evaluate results in text form
 perform pq-res-status
 set address of vTemp to ptrPQresStatus
 initialize lsReply
     unstring vTemp delimited by low-value into lsReply
     perform pq-result-error-message

 perform pq-error-message
     set address of vTemp to ptrPQerrorMessage
     initialize lsReply
     unstring vTemp delimited by low-value into lsReply

*> fieldcode is an error field identifier;
*> NULL is returned if the PGresult is not an error or warning result,
*> or does not include the specified field.

 set PG_DIAG_SEVERITY to true
 perform pq-result-error-field
 if ptrPQresultErrorField > null
        set address of vTemp to ptrPQresultErrorField
        initialize lsReply
        unstring vTemp delimited by low-value into lsReply
 end-if

 *> The SQLSTATE code identifies the type of error that has occurred;
 *> it can be used by front-end applications to perform specific operations
 *> (such as error handling) in response to a particular database error.
 *> This field is not localizable, and is always present.
 set PG_DIAG_SQLSTATE to true
 perform pq-result-error-field
 if ptrPQresultErrorField > null
        set address of vTemp to ptrPQresultErrorField
        initialize lsState
        move vTemp(1:5) to lsState
 end-if
     .
 x1-get-tuple-info.
     perform pq-n-tuples
     move intPQntuples to lsRecordCursor
 .
 x2-get-field-info.
     perform pq-n-fields
 subtract 1 from intPQnfields giving lsColumnCount
*>           move intPQnfields to lsColumnCount
 .
 x3-get-length-info. *> length of first row
 initialize lsFieldLength intPQgetlength intRowNumber intColumnNumber
 perform with test after
  varying intColumnNumber from 0 by 1
  until intColumnNumber = lsColumnCount
     perform pq-get-length
     add intPQgetlength to lsFieldLength
 end-perform
 .
 y-reply-to-select.
     set ptrPGresult to lsRecordHandle
     perform pq-n-tuples
     if intPQntuples = zero
        set LS_RESULT_AT_END to true
     else
        if lsRecordCursor = zero
           move intPQntuples to lsRecordCursor
        end-if
        perform pq-n-fields
        if intPQnfields = zero
           set LS_RESULT_AT_END to true
        else
           if lsColumnCount = zero
              move intPQnfields to lsColumnCount
           end-if
           move lsColumnCount to intColumnNumber
           perform pq-f-name     *> return current column name
           set address of vTemp to ptrPQfname
           unstring vTemp delimited by low-value into lsFieldName
           set address of vTemp to null
           perform pq-get-length *> length of current field
           move intPQgetlength to lsFieldLength
           perform pq-get-value  *> value of current field
           set address of vTemp to ptrPQgetValue
           unstring vTemp delimited by low-value into lsReply
           perform pq-f-type     *> oid of current field data type
           move oidPQftype to lsFieldFormat
        end-if
     end-if
     .

*>****************************************************************
*> Postgresql libpq library routines.
*>
*> see http://www.postgresql.org/docs/8.3/interactive/libpq.html
*> (the PostgreSQL online documentation is very good)
*>
*>****************************************************************

*>>>>>>>>>>>>>>>>>>>>>
*> Status routines.
*>
 pq-status.
     *> Returns the status of the connection.
     initialize intConnStatusType
     call "PQstatus"
          using by value ptrPGconn,
          returning intConnStatusType
     .
 pq-error-message.
     *>Returns the error message most recently
     *> generated by an operation on the connection.
     initialize ptrPQerrorMessage
     call "PQerrorMessage"
          using by value ptrPGconn
          returning ptrPQerrorMessage
     .
 pq-result-status.
     *> Returns the result status of the command.
     call "PQresultStatus"
          using by value ptrPGresult
          returning intExecStatusType
     .
 pq-res-status.
     *> Converts the enumerated type returned by PQresultStatus
     *> into a string constant describing the status code.
     *> The caller should not free the result.
     initialize ptrPQresStatus
     call "PQresStatus"
          using by value intExecStatusType
          returning ptrPQresStatus
     .
 pq-result-error-message.
     *> Returns the error message associated with the command
     *> Returns an empty string if there was no error.
 *>
 *> Immediately following a PQexec or PQgetResult call,
 *> PQerrorMessage (on the connection) will return the same
 *> string as PQresultErrorMessage (on the result).
 *> However, a PGresult will retain its error message until
 *> destroyed, whereas the connection's error message will
 *> change when subsequent operations are done.
 *> Use PQresultErrorMessage when you want to know the status
 *> associated with a particular PGresult; use PQerrorMessage
 *> when you want to know the status from the latest operation
 *> on the connection.
 *>
     call "PQresultErrorMessage"
          using by value ptrPGresult
          returning ptrPQresultErrorMessage
     set address of vTemp to ptrPQresultErrorMessage
       .
 pq-result-error-field.
     *> Returns an individual field of an error report.
     call "PQresultErrorField"
          using by value ptrPGresult
          by value intFieldCode
          returning ptrPQresultErrorField
     .
 pq-transaction-status.
     *> Returns the current in-transaction status of the server.
     initialize intPGTransactionStatusType
     call "PQtransactionStatus"
          returning intPGTransactionStatusType
     display "dbExecErrorCode: " intPGTransactionStatusType
     .
 pq-parameter-status.
     *> Looks up a current parameter setting of the server.
     call "PQparameterStatus"
          using by value ptrPGconn
          by value charParamName
          returning ptrPQparameterStatus
     set address of vTemp to ptrPQparameterStatus
     unstring vTemp delimited by low-value into charParameterStatus
     .
 pq-backend-PID.
     *> Returns the process ID (PID) of the
     *> backend server process handling this connection.
     call "PQbackendPID"
           using by value ptrPGconn
           returning intPQbackendPID
     .
 pq-connection-needs-password.
     *> Returns true (1) if the connection
     *>  authentication method required a password,
     *>  but none was available. Returns false (0) if not.
     *> This function can be applied after a failed connection
     *> attempt to decide whether to prompt the user for a password.
     call "PQconnectionNeedsPassword"
           using by value ptrPGconn
           returning intPQconnectionNeedsPassword
     .
 pq-connection-used-password.
     *> Returns true (1) if the connection authentication
     *> method used a caller-supplied password. Returns false (0) if not.
     *> This function detects whether a password supplied
     *> to the connection function was actually used.
     *> Passwords obtained from other sources (such as the .pgpass file)
     *> are not considered caller-supplied.
     call "PQconnectionUsedPassword"
           using by value ptrPGconn
           returning intPQconnectionUsedPassword
     .
*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
*> Database information
*>
 pq-db.
     initialize ptrReturn dbName
     call "PQdb"
          using by value ptrPGconn
          returning ptrReturn
     set address of vTemp to ptrReturn
     unstring vTemp delimited by low-value into dbName
     .
  pq-user.
     initialize ptrReturn dbUser
     call "PQuser"
          using by value ptrPGconn
          returning ptrReturn
     set address of vTemp to ptrReturn
     unstring vTemp delimited by low-value into dbUser
     .
  pq-pass.
     initialize ptrReturn dbPassword
     call "PQpass"
          using by value ptrPGconn
          returning ptrReturn
     set address of vTemp to ptrReturn
     unstring vTemp delimited by low-value into dbPassword
     .
 pq-host.
     initialize ptrReturn dbHost
     call "PQhost"
          using by value ptrPGconn
          returning ptrReturn
     set address of vTemp to ptrReturn
     unstring vTemp delimited by low-value into dbHost
     .
 pq-port.
     initialize ptrReturn dbPort
     call "PQport"
          using by value ptrPGconn
          returning ptrReturn
     set address of vTemp to ptrReturn
     unstring vTemp delimited by low-value into dbPort
     .
 pq-options.
     initialize ptrReturn dbOptions
     call "PQoptions"
          using by value ptrPGconn
          returning ptrReturn
     set address of vTemp to ptrReturn
     unstring vTemp delimited by low-value into dbOptions
     .
 pq-server-version.
     initialize ptrReturn dbServerVersion
     call "PQserverVersion"
          using by value ptrPGconn
          returning dbServerVersion
     .

*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
*> Connection routines
*>
 pq-connect-db.
     *> Connect to the db server in a Synchronous (blocking) manner.
     *> An application program can have several backend connections open at one time.
     *> Note that this function will always return a non-null object pointer,
     *> unless perhaps there is too little memory even to allocate the PGconn object.
     *> The PQstatus function should be called to check whether a connection was
     *> successfully made before queries are sent via the connection object.
     set ptrPGconn to null.
     call "PQconnectdb"
           using by reference charConninfo
           returning ptrPGconn
     .
 pq-connect-start.
     *> Connect to the db server in an Asynchronous (nonblocking) manner.
     *> An application program can have several backend connections open at one time.
     *> Note that this function will always return a non-null object pointer,
     *> unless perhaps there is too little memory even to allocate the PGconn object.
     *> The PQstatus function should be called to check whether a connection was
     *> successfully made before queries are sent via the connection object.
     set ptrPGconn to null.
     call "PQconnectStart"
          using by reference charConninfo
          returning ptrPGconn
     .
 pq-connect-poll.
     call "PQconnectPoll"
          using by value ptrPGconn,
          returning intPostgresPollingStatusType
     .
 pq-socket.
     call "PQsocket"
          using by value ptrPGconn,
          returning intPQsocket
     .
 pq-reset.
     *> Resets the communication channel to the server.
     call "PQreset"
          using by value ptrPGconn
     .
 pq-finish.
     *> Closes the connection to the server.
     *> Also frees memory used by the PGconn object.
     call "PQfinish"
          using by value ptrPGconn
      .

*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
*> Command execution routines
*>
*>    pw-escape-string.
*>       *> PQescapeStringConn escapes a string for use within an SQL command.
*>        initialize charTo intFromLength intToLength
*>        inspect charFrom tallying intFromLength for trailing space
*>        compute intFromLength = (length of charFrom) - intFromLength
*>
*>        call "PQescapeStringConn"
*>             using by value ptrPGconn
*>             by reference charTo
*>             by reference charFrom
*>             by value intFromLength
*>             by value intError
*>             returning intToLength
*>        .
 pq-exec.
    *> Submits a command to the server and waits for the result.
     call "PQexec"
          using by value ptrPGconn
          by reference sqlCommand
          returning ptrPGresult
     .
 pq-make-empty-pg-result.
    *> Constructs an empty PGresult object with the given status.

     call "PQmakeEmptyPGresult"
          using by value ptrPGconn
          by reference ptrPGExecStatusType
          returning ptrPGresult
     .
 pq-clear.
    *> Frees the storage associated with a PGresult.
    *> Every command result should be freed via PQclear
    *> when it is no longer needed.

     call "PQclear"
          using by value ptrPGresult
     set ptrPGresult to null
     .
*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
*> Replies to command execution.
*>
 pq-n-tuples.
     *> Returns the number of rows (tuples) in the query result.
     call "PQntuples"
          using by value ptrPGresult
          returning intPQntuples
     .
 pq-n-fields.
     *> Returns the number of Fields (fields)
     *> in each row of the query result.
     call "PQnfields"
          using by value ptrPGresult
          returning intPQnfields
     .
 pq-f-name.
     *> Returns the Field name associated with the given Field number.
     *> Field numbers start at 0.
     call "PQfname"
          using by value ptrPGresult
          by value intColumnNumber
          returning ptrPQfname
     .
 pq-f-number.
     *> Returns the Field number associated with the given Field name.
     *> -1 is returned if the given name does not match any Field.
     call "PQfnumber"
          using by value ptrPGresult
          by value ptrFieldName
          returning intPQfnumber
     .
 pq-f-table-col.
     *> Returns the Field number (within its table)
     *> of the Field making up the specified query result Field.
     *> Query-result Field numbers start at 0,
     *> but table Fields have nonzero numbers.
     *> Zero is returned if the Field number is out of range,
     *> or if the specified Field is not a simple reference
     *> to a table Field, or when using pre-3.0 protocol.
     call "PQftablecol"
          using by value ptrPGresult
          by value intColumnNumber
      returning intPQftablecol
     .
 pq-f-format.
     *> Returns the Field number (within its table)
     *> of the Field making up the specified query result Field.
     *> Query-result Field numbers start at 0,
     *> but table Fields have nonzero numbers.
     *> Format code zero indicates textual data representation,
     *> while format code one indicates binary representation.
     call "PQfformat"
          using by value ptrPGresult
          by value intColumnNumber
      returning intPQfformat
     .
 pq-f-type.
     *> Returns the data type associated with the given Field number.
     *> The integer returned is the internal OID number of the type.
     *> Field numbers start at 0.
     *> You can query the system table pg_type to obtain the names
     *> and properties of the various data types. The OIDs of the built-in
     *> data types are defined in the file src/include/catalog/pg_type.h.
     call "PQftype"
          using by value ptrPGresult
          by value intColumnNumber
      returning oidPQftype
     .
 pq-f-mod.
     *> Returns the type modifier of the Field associated with the given Field number.
     *> Field numbers start at 0.
     *> The interpretation of modifier values is type-specific;
     *> they typically indicate precision or size limits.
     *> The value -1 is used to indicate "no information available".
     *> Most data types do not use modifiers, in which case the value is always -1.
     call "PQfmod"
          using by value ptrPGresult
          by value intColumnNumber
      returning intPQfmod
     .
 pq-get-value.
     *> Returns a single field value of one row of a PGresult.
     *> Row and Field numbers start at 0.
     *> The caller should not free the result directly.
     *> It will be freed when the associated PGresult handle is passed to PQclear.
     *> For data in text format, the value returned by PQgetvalue
     *> is a null-terminated character string representation of the field value.
     *> An empty string is returned if the field value is null.
     *> See PQgetisnull to distinguish null values from empty-string values.
     *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 call "PQgetvalue"
          using by value ptrPGresult
          by value intRowNumber
          by value intColumnNumber
          returning ptrPQgetValue
 end-call
     *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
     .
 pq-get-is-null.
     *> Tests a field for a null value. Row and Field numbers start at 0.
     *> This function returns 1 if the field is null
     *> and 0 if it contains a non-null value.
     call "PQgetisnull"
          using by value ptrPGresult
          by value intRowNumber
          by value intColumnNumber
          returning intPQgetisnull
     .
 pq-get-length.
     *> Returns the actual length of a field value in bytes.
     *> Row and column numbers start at 0.
     *> This is the actual data length for the particular data value,
     *> that is, the size of the object pointed to by PQgetvalue.
     *> For text data format this is the same as strlen().
     *> For binary format this is essential information.
     call "PQgetlength"
          using by value ptrPGresult
          by value intRowNumber
          by value intColumnNumber
      returning intPQgetlength
     .

*>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
*> These functions are used to extract information from PGresult objects
*> that are not SELECT results.
*>
 pq-cmd-status.
     *> Returns the command status tag from the SQL command that generated the PGresult.
     *> Commonly this is just the name of the command,
     *> but it might include additional data such as the number of rows processed.
     *> The caller should not free the result directly.
     *> It will be freed when the associated PGresult handle is passed to PQclear.
     call "PQcmdStatus"
          using by value ptrPGresult
      returning ptrPQcmdStatus
     .
 pq-cmd-tuples.
     *> This function returns a string containing the number of rows
     *> affected by the SQL statement that generated the PGresult.
     call "PQcmdTuples"
          using by value ptrPGresult
      returning ptrPQcmdTuples
     .
 end program libpgsql.

01  lsRecord.
    05 lsConnHandle          usage pointer.
    05 lsRecordHandle            usage pointer.
    05 lsRequestHandle           usage pointer.
    05 lsReplyHandle         usage pointer.
    05 lsRequestLength           pic 9(9) comp-5.
    05 lsReplyLength         pic 9(9) comp-5.
    05 lsRecordCount         pic 9(9) comp-5.
    05 lsRecordCursor            pic 9(9) comp-5.
    05 lsColumnCount         pic 9(9) comp-5.
    05 lsColumnCursor            pic 9(9) comp-5.
    05 lsFieldFormat         pic 9(9) comp-5.
   88 FIELD_FORMAT_IS_TEXT               value zero.
   88 FIELD_FORMAT_IS_BINARY             value zero.
05 lsFieldNull           pic 9.
   88 FIELD_IS_NULL                  value 1 false is zero.
    05 lsFieldLength         pic 9(9) comp-5.
05 lsFieldNameLength         pic 9(9) comp-5.
05 lsFieldName           pic x(128).
    05 lsCommand             pic x(10).
       88 ABORT_COMMAND                  value "ABORT".
       88 CLOSE_CONN_COMMAND             value "CLOSECONN".
       88 CLOSE_DB_COMMAND               value "CLOSEDB".
       88 CREATE_COMMAND                 value "CREATE".
       88 DEBUG_COMMAND                  value "DEBUG".
       88 DELETE_COMMAND                 value "DELETE".
       88 DROP_COMMAND                   value "DROP".
       88 GET_BASE_TABLES_COMMAND            value "GETBASETBL".
       88 GET_DBNAME_COMMAND             value "GETDBNAME".
       88 GET_HOSTNAME_COMMAND               value "GETHOST".
       88 GET_PORT_COMMAND               value "GETPORT".
       88 GET_USER_COMMAND               value "GETUSER".
       88 INSERT_COMMAND                 value "INSERT".
       88 MORE_COMMAND                   value "MORE".
       88 POLL_COMMAND                   value "POLL".
       88 SQL_COMMAND                    value "SQL".
       88 START_CONN_COMMAND             value "STARTCONN".
       88 START_DB_COMMAND               value "STARTDB".
    05 lsResult              pic 9(9) comp-5.
       88 LS_RESULT_OK                   value 0.
       88 LS_CONNECTION_ATTEMPT_FAILED           value 1.
       88 LS_CONNECTION_DATA_REQUIRED            value 2.
       88 LS_CONNECTION_HANDLE_NOT_EMPTY         value 3.
       88 LS_CONNECTION_HANDLE_EMPTY         value 4.
   88 LS_CONNECTION_RETURNED_NULL            value 5.
   88 LS_CONNECTION_POLL_FAILED          value 6.
   88 LS_CONNECTION_POLL_READING         value 7.
   88 LS_CONNECTION_POLL_WRITING         value 8.
       88 LS_RESULT_AT_END               value 10.
       88 LS_RESULT_SELECT_FAILED            value 11.
       88 LS_HANDLE_MISSING              value 13.
   88 LS_BAD_COMMAND                 value 14.
       88 LS_PGRES_EMPTY_QUERY               value 20.
   88 LS_PGRES_COMMAND_OK                value 21.
       88 LS_PGRES_TUPLES_OK             value 22.
       88 LS_PGRES_COPY_OUT              value 23.
       88 LS_PGRES_COPY_IN               value 24.
       88 LS_PGRES_BAD_RESPONSE              value 25.
   88 LS_PGRES_NONFATAL_ERROR            value 26.
       88 LS_PGRES_FATAL_ERROR               value 27.
   88 lS_TEST                    value 99.
    05  lsResultStatus           pic x(1024).
    05  lsDiagSeverity           pic x(10).
   88 LS_Diag_Severity_ERROR             value "ERROR".
   88 LS_Diag_Severity_FATAL             value "FATAL".
   88 LS_Diag_Severity_PANIC             value "PANIC".
   88 LS_Diag_Severity_WARNING           value "WARNING".
   88 LS_Diag_Severity_NOTICE            value "NOTICE".
   88 LS_Diag_Severity_DEBUG             value "DEBUG".
   88 LS_Diag_Severity_INFO              value "INFO".
   88 LS_Diag_Severity_LOG               value "LOG".
    05  lsState              pic x(5).
   88 SUCCESSFULL_COMPLETION         value "00000".
   88 WARNING                value "01000".
   88 NO_DATA                value "02000".
   88 SQL_STATEMENT_NOT_YET_COMPLETE     value "03000".
   88 CONNECTION_EXCEPTION           value "08000".
   88 TRIGGERED_ACTION_EXCEPTION     value "09000".
   88 FEATURE_NOT_SUPPORTED          value "0A000".
   88 INVALID_TRANSACTION_INITIATION     value "0B000".
   88 LOCATOR_EXCEPTION          value "0F000".
   88 INVALID_GRANTOR            value "0L000".
   88 INVALID_ROLE_SPECIFICATION     value "0P000".
   88 CARDINALITY_VIOLATION          value "21000".
   88 DATA_EXCEPTION             value "22000".
   88 INTEGRITY_CONSTRAINT_VIOLATION     value "23000".
   88 INVALID_CURSOR_STATE           value "24000".
   88 INVALID_TRANSACTION_STATE      value "25000".
   88 INVALID_SQL_STATEMENT_NAME     value "26000".
   88 TRIGGERED_DATA_CHANGE_VIOLATION    value "27000".
   88 INVALID_AUTHORIZATION_SPEC     value "28000".
   88 DEPENDENT_PRIVILEGE_DESCRIPTORS    value "2B000".
   88 INVALID_TRANSACTION_TERMINATION    value "2D000".
   88 SQL_ROUTINE_EXCEPTION          value "2F000".
   88 INVALID_CURSOR_NAME            value "34000".
   88 EXTERNAL_ROUTINE_EXCEPTION     value "38000".
   88 EXTERNAL_ROUTINE_INVOCATION        value "39000".
   88 SAVEPOINT_EXCEPTION            value "3B000".
   88 INVALID_CATALOG_NAME           value "3D000".
   88 INVALID_SCHEMA_NAME            value "3F000".
   88 TRANSACTION_ROLLBACK           value "40000".
   88 SYNTAX_ERROR_OR_ACCESS_RULE        value "42000".
   88 WITH_CHECK_OPTION_VIOLATION        value "44000".
   88 INSUFFICIENT_RESOURCES         value "53000".
   88 PROGRAM_LIMIT_EXCEEDED         value "54000".
   88 OBJ_NOT_IN_PREREQUISITE_STATE      value "55000".
   88 OPERATOR_INTERVENTION          value "57000".
   88 EXTERNAL_SYSTEM_ERROR          value "58000".
   88 CONFIGURATION_FILE_ERROR       value "F0000".
   88 PLPGSQL_ERROR              value "P0000".
   88 RAISE_EXCPTION             value "P0001".
   88 NO_DATA_FOUND              value "P0002".
   88 TOO_MANY_ROWS              value "P0003".
   88 INTERNAL_ERROR             value "XX000".
   88 DATA_CORRUPTED             value "XX001".
   88 INDEX_CORRUPTED            value "XX002".

01  lsRequest                pic x(4000).
01  lsReply              pic x(1024).

*> Modified: 2015-12-08/06:46-0500
 identification division.
 program-id. SAMPLE.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.
 :DATABOOK:

 procedure division.
 demonstration section.
 :CODEBOOK:

 goback.

*> informational warnings and abends
 soft-exception.
   display space upon syserr
   display "--Exception Report-- " upon syserr
   display "Time of exception:   " current-date upon syserr
   display "Module:              " module-id upon syserr
   display "Module-path:         " module-path upon syserr
   display "Module-source:       " module-source upon syserr
   display "Exception-file:      " exception-file upon syserr
   display "Exception-status:    " exception-status upon syserr
   display "Exception-location:  " exception-location upon syserr
   display "Exception-statement: " exception-statement upon syserr
 .

 hard-exception.
     perform soft-exception
     stop run returning 127
 .

 end program SAMPLE.

#!/usr/local/bin/cobc -xj

       COPY template REPLACING
       ==:DATABOOK:== BY
       ==

       01 x            pic s9v99.
       01 domain       pic s9v9(5).
       01 degrees      pic s999v9.
       01 answer       pic s9(5)v9(5).

       ==
       ==:CODEBOOK:== BY
       ==

       perform varying x from -1.0 by 0.25 until x > 1.0
           compute domain = pi * x
           compute degrees rounded = domain * 180 / pi
           move tan(domain) to answer
           display "tan(" domain ") = tan(" degrees "°)  = " answer
       end-perform

       ==
       .

*> Modified: 2015-12-08/06:46-0500
 identification division.
 program-id. SAMPLE.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 data division.
 working-storage section.

 01 x            pic s9v99.
 01 domain       pic s9v9(5).
 01 degrees      pic s999v9.
 01 answer       pic s9(5)v9(5).

 procedure division.
 demonstration section.

 perform varying x from -1.0 by 0.25 until x > 1.0
     compute domain = pi * x
     compute degrees rounded = domain * 180 / pi
     move tan(domain) to answer
     display "tan(" domain ") = tan(" degrees "°)  = " answer
 end-perform

 goback.

*> informational warnings and abends
 soft-exception.
   display space upon syserr
   display "--Exception Report-- " upon syserr
   display "Time of exception:   " current-date upon syserr
   display "Module:              " module-id upon syserr
   display "Module-path:         " module-path upon syserr
   display "Module-source:       " module-source upon syserr
   display "Exception-file:      " exception-file upon syserr
   display "Exception-status:    " exception-status upon syserr
   display "Exception-location:  " exception-location upon syserr
   display "Exception-statement: " exception-statement upon syserr
 .

 hard-exception.
     perform soft-exception
     stop run returning 127
 .

 end program SAMPLE.

#!/usr/local/bin/cobc -xj

prompt$ cobc -xj tan-sample.cob

prompt$ chmod +x tan-sample.cob
prompt$ ./tan-sample.cob

*> Modified: 2015-12-09/02:58-0500
 identification division.
 program-id. SAMPLE.

 environment division.
 configuration section.
 repository.
     function all intrinsic.

 input-output section.
 file-control.
     select optional input-file
         assign to :INPUT-NAME:
         organization is line sequential
         file status is input-status.

     select output-file
         assign to :OUTPUT-NAME:
         organization is line sequential
         file status is output-status.

 data division.
 file section.
 fd input-file record varying depending on input-actual.
    01 input-line pic x(8192).
 fd output-file record varying depending on output-actual.
    01 output-line pic x(8192).

 working-storage section.
 01 input-status         pic xx.
 01 input-actual         pic 9(4).
 01 output-status        pic xx.
 01 output-actual        pic 9(4).
 01 status-number        pic 99.

 :DATABOOK:

 procedure division.
 demonstration section.

 :CODEBOOK:

 goback.

 open-files.
 open input input-file
 perform input-check

 open output output-file
 perform output-check
 .

 close-files.
 close input-file
 perform input-check

 close output-file
 perform output-check
 .

 delete-output.
 delete file output-file
 .

 read-input.
 read input-file
 perform input-check
 .

 write-output.
 write output-line
 perform output-check
 .

 input-check.
 move input-status to status-number
 if status-number greater than 9 then
     display "Error with input-file: " :INPUT-NAME:
        " status: " status-number
        upon syserr
     perform hard-exception
 end-if
 .

 output-check.
 move output-status to status-number
 if status-number greater than 9 then
     display "Error with ouput-file: " :OUTPUT-NAME:
        " status: " status-number
        upon syserr
     perform hard-exception
 end-if
 .

*> informational warnings and abends
 warnings section.
 soft-exception.
   display space upon syserr
   display "--Exception Report-- " upon syserr
   display "Time of exception:   " current-date upon syserr
   display "Module:              " module-id upon syserr
   display "Module-path:         " module-path upon syserr
   display "Module-source:       " module-source upon syserr
   display "Exception-file:      " exception-file upon syserr
   display "Exception-status:    " exception-status upon syserr
   display "Exception-location:  " exception-location upon syserr
   display "Exception-statement: " exception-statement upon syserr
 .

 hard-exception.
     perform soft-exception
     stop run returning 127
 .

 end program SAMPLE.

COPY line-sequential-template REPLACING
==:INPUT-NAME:==  BY =="quoted-name-optional"==
==:OUTPUT-NAME:== BY =="quoted-name-created"==
==:DATABOOK:==    BY ==working-storage definitions==
==:CODEBOOK:==    BY ==procedure statements==
.

identification division.
author. Brian Tiffin.
date-written. 2015-12-16/06:07-0500.
remarks. Self replicating code, Public Domain.
installation. tectonics: cobc -xj quine.cob.
program-id. quine.
data division.
working-storage section.
01 s pic x(7).
01 n pic 99.
01 source-code.
   05 value "identification division.                        ".
   05 value "author. Brian Tiffin.                           ".
   05 value "date-written. 2015-12-16/06:07-0500.            ".
   05 value "remarks. Self replicating code, Public Domain.  ".
   05 value "installation. tectonics: cobc -xj quine.cob.    ".
   05 value "program-id. quine.                              ".
   05 value "data division.                                  ".
   05 value "working-storage section.                        ".
   05 value "01 s pic x(7).                                  ".
   05 value "01 n pic 99.                                    ".
   05 value "01 source-code.                                 ".
   05 value "01 redefines source-code.                       ".
   05 value "   05 t pic x(48) occurs 24 times.              ".
   05 value "procedure division.                             ".
   05 value "perform varying n from 1 by 1 until n > 11      ".
   05 value "   display s function trim(t(n) trailing)       ".
   05 value "end-perform                                     ".
   05 value "perform varying n from 1 by 1 until n > 24      ".
   05 value "   display s '   05 value ' quote t(n) quote '.'".
   05 value "end-perform                                     ".
   05 value "perform varying n from 12 by 1 until n > 24     ".
   05 value "   display s function trim(t(n) trailing)       ".
   05 value "end-perform                                     ".
   05 value "goback.                                         ".
01 redefines source-code.
   05 t pic x(48) occurs 24 times.
procedure division.
perform varying n from 1 by 1 until n > 12
   display s function trim(t(n) trailing)
end-perform
perform varying n from 1 by 1 until n > 24
   display s '   05 value ' quote t(n) quote '.'
end-perform
perform varying n from 13 by 1 until n > 25
   display s function trim(t(n) trailing)
end-perform
goback.

prompt$ cobc -xj quine.cob
       identification division.
       author. Brian Tiffin.
       date-written. 2015-12-16/06:07-0500.
       remarks. Self replicating code, Public Domain.
       installation. tectonics: cobc -xj quine.cob.
       program-id. quine.
       data division.
       working-storage section.
       01 s pic x(7).
       01 n pic 99.
       01 source-code.
          05 value "identification division.                        ".
          05 value "author. Brian Tiffin.                           ".
          05 value "date-written. 2015-12-16/06:07-0500.            ".
          05 value "remarks. Self replicating code, Public Domain.  ".
          05 value "installation. tectonics: cobc -xj quine.cob.    ".
          05 value "program-id. quine.                              ".
          05 value "data division.                                  ".
          05 value "working-storage section.                        ".
          05 value "01 s pic x(7).                                  ".
          05 value "01 n pic 99.                                    ".
          05 value "01 source-code.                                 ".
          05 value "01 redefines source-code.                       ".
          05 value "   05 t pic x(48) occurs 24 times.              ".
          05 value "procedure division.                             ".
          05 value "perform varying n from 1 by 1 until n > 11      ".
          05 value "   display s function trim(t(n) trailing)       ".
          05 value "end-perform                                     ".
          05 value "perform varying n from 1 by 1 until n > 24      ".
          05 value "   display s '   05 value ' quote t(n) quote '.'".
          05 value "end-perform                                     ".
          05 value "perform varying n from 12 by 1 until n > 24     ".
          05 value "   display s function trim(t(n) trailing)       ".
          05 value "end-perform                                     ".
          05 value "goback.                                         ".
       01 redefines source-code.
          05 t pic x(48) occurs 24 times.
       procedure division.
       perform varying n from 1 by 1 until n > 11
          display s function trim(t(n) trailing)
       end-perform
       perform varying n from 1 by 1 until n > 24
          display s '   05 value ' quote t(n) quote '.'
       end-perform
       perform varying n from 12 by 1 until n > 24
          display s function trim(t(n) trailing)
       end-perform
       goback.

prompt$ cobc -xj quine.cob  | diff quine.cob -
prompt$

local-storage section.
1 n pic 99.
1 c. 5 value
"local-storage section.                  " &
"1 n pic 99.                             " &
"1 c. 5 value                            " &
". 1 redefines c.                        " &
"5 t pic x(40) occurs 12.                " &
"perform varying n from 1 by 1 until n>3 " &
"display function trim(t(n) trailing).   " &
"perform varying n from 1 by 1 until n>12" &
"display quote t(n) quote ' &'.          " &
"display quote ' ' quote no advancing.   " &
"perform varying n from 4 by 1 until n>12" &
"display function trim(t(n) trailing).   " &
" ". 1 redefines c.
5 t pic x(40) occurs 12.
perform varying n from 1 by 1 until n>3
display function trim(t(n) trailing).
perform varying n from 1 by 1 until n>12
display quote t(n) quote ' &'.
display quote ' ' quote no advancing.
perform varying n from 4 by 1 until n>12
display function trim(t(n) trailing).

linkage section. 78 c value "display 'linkage section. 78 c value
' x'22' c x'222e20' c.". display 'linkage section. 78 c value ' x'22' c x'222e20' c.

prompt$ cobc -xjF -frelax shortest-quine.cob | diff shortest-quine.cob -
shortest-quine.cob: 1: Warning: PROGRAM-ID header missing - assumed
shortest-quine.cob: 1: Warning: DATA DIVISION header missing - assumed
shortest-quine.cob: 1: Warning: PROCEDURE DIVISION header missing - assumed
prompt$

$ ./shortest-quine.cob
linkage section. 78 c value "display 'linkage section. 78 c value
' x'22' c x'222e20' c.". display 'linkage section. 78 c value ' x'22' c x'222e20' c.

--- /home/btiffin/wip/writing/gcfaq/bubble-generator.tcl
+++ /home/btiffin/wip/writing/gcfaq/bubble-cobol.tcl
@@ -4,7 +4,7 @@
 # text descriptions.
 #
 
-source [file join [file dirname [info script]] bubble-generator-data.tcl]
+source [file join [file dirname [info script]] bubble-cobol-data.tcl]
 
 # Top-level displays
 #
@@ -36,6 +36,8 @@
 set tagcnt 0                      ;# tag counter
 set font1 {Helvetica 16 bold}     ;# default token font
 set font2 {GillSans 14 bold}      ;# default variable font
+set font3 {Helvetica 16}          ;# GnuCOBOL extension font
+set font4 {GillSans 14}           ;# GnuCOBOL extension variable font
 set RADIUS 9                      ;# default turn radius
 set HSEP 17                       ;# horizontal separation
 set VSEP 9                        ;# vertical separation
@@ -123,12 +125,37 @@
     set txt [string range $txt 1 end]
     set font $::font2
     set istoken 1
+    set iswide 0
   } elseif {[regexp {^[a-z]} $txt]} {
     set font $::font2
     set istoken 0
+    set iswide 0
+  } elseif {[regexp {^\+[A-Z>$]} $txt]} {
+    set txt [string range $txt 1 end]
+    set font $::font3
+    set istoken 1
+    set iswide 0
+  } elseif {[regexp {^\+[a-z]} $txt]} {
+    set txt [string range $txt 1 end]
+    set font $::font4
+    set istoken 0
+    set iswide -26
+  } elseif {[regexp {^_[a-z_]} $txt]} {
+    set txt [string range $txt 1 end]
+    set txt [string map {"_" " "} $txt]
+    set font $::font4
+    set istoken 0
+    set iswide -38
+  } elseif {[regexp {^_[A-z]} $txt]} {
+    set txt [string range $txt 1 end]
+    set txt [string map {"_" " "} $txt]
+    set font $::font1
+    set istoken 1
+    set iswide 0
   } else {
     set font $::font1
     set istoken 1
+    set iswide 0
   }
   set id1 [.c create text 0 0 -anchor c -text $txt -font $font -tags $tag]
   foreach {x0 y0 x1 y1} [.c bbox $id1] break
@@ -136,7 +163,7 @@
   set rad [expr {($h+1)/2}]
   set top [expr {$y0-2}]
   set btm [expr {$y1}]
-  set fudge [expr {int(3*$istoken + [string length $txt]*1.4)}]
+  set fudge [expr {int(3*$istoken + [string length $txt]*1.4 + $iswide)}]
 #puts "fudge($txt)=$fudge"
   set left [expr {$x0+$fudge}]
   set right [expr {$x1-$fudge}]
@@ -660,7 +687,7 @@
   .c postscript -file $name.ps -width [expr {$x1+2}] -height [expr {$y1+2}]
   global DPI
   .c delete bgrect
-  exec convert -density ${DPI}x$DPI -antialias $name.ps $name.gif
+  exec convert -density "${DPI}x$DPI" -antialias $name.ps $name.gif
   if {$do_xv} {
     if {[catch {exec xv $name.gif &}]} {
       exec display $name.gif &
@@ -671,6 +698,11 @@
 proc draw_all_graphs {} {
   global all_graphs
   set f [open all.html w]
+  puts {
+<h2>GnuCOBOL syntax diagrams</h2>
+<p>By Brian Tiffin, modelled on code and data used for the SQLite project developed by Dr. Richard Hipp.</p>
+<p><i>These diagrams are dedicated to the public domain.</i></p>
+} 
   foreach {name graph} $all_graphs {
     if {[regexp {^X-} $name]} continue
     puts $f "<h3>$name:</h3>"

# This file contains the data used to generate the GnuCOBOL syntax diagrams
#  with bubble-cobol.tcl

# Graphs:
#
set all_graphs {
    cobc-marketing {
        line {or Heritage Experience {or _Data_stores /eSQL /macros} past /present future}
            /cobc {or
            {opt {line -m module}}
            {line -x executable}
            {line -b build-together}
            {line -c object}
            {line -h help}
            {line ... _much_more}
            GnuCOBOL
        } {loop {or COBOL 
                     {line {or C C++} {or nil Ada BASIC Java Lua Python Tcl/Tk Rexx
                       _myriad_others}}
                     Assembler _Object_Code
                     _Static_Archive _[Dynamic]_Shared_Object}}
        _Bank_on_IT
    }

    cobol-directive {
        line {or
                nil
                copy-directive
                replace-directive
                if-directive
                define-directive
        }
    }
    copy-directive {
        stack
            {line COPY {or literal-1 text-name-1} {opt {line {or OF IN} literal-2}}
                {opt {line SUPPRESS {opt PRINTING}}}}
            {opt {line REPLACING {loop {or
                {line {or ==pseudo-text-1== text-1 literal-3 word-1}
                    BY {or ==pseudo-text-2== text-2 literal-4 word-2}}
                {line {or LEADING TRAILING} ==partial-word-1== BY ==partial-word-2==}}}
        }}
        .
    }

    replace-directive {
        stack
        {line REPLACE {or
            {line {opt ALSO} {loop {or
                {line ==pseudo-text-1== BY ==pseudo-text-2==}
                {line {or LEADING TRAILING} ==partial-word-1== BY ==partial-word-2==}
            }}}
            {line {opt LAST} OFF}}}
        .
    }

    define-directive {
        line {or >>DEFINE +$DEFINE} {opt +CONSTANT} compilation-variable-1 {opt AS}
            {or
                {line {or arithmetic-expression-1 literal-1 PARAMETER} {opt OVERRIDE}}
                OFF}
    }
            

    if-directive {
       stack
           {line {or >>IF +$IF} {or constant-conditional-1 {line compilation-variable-1 
               {opt IS} {line {opt NOT} DEFINED}}} {opt text-1}}
           {opt {line {loop {line {or +>>ELSE-IF +>>ELIF +$ELSE-IF +$ELIF}
               {or +constant-conditional-2 {line +compilation-variable-2 
               {opt +IS} {line {opt +NOT} +DEFINED}}} {opt +text-2}}}}} 
           {opt {line {or >>ELSE +$ELSE} {opt text-3}}}
           {or >>END-IF +$END-IF}
    } 

    cobol-statement {
        or
            nil
            accept-statement
            add-statement
            allocate-statement
            call-statement
            cancel-statement
            close-statement
            compute-statement
            continue-statement
            delete-statement
            display-statement
            divide-statement
            evaluate-statement
            exit-statement
            free-statement
            generate-statement
            go-statement
            goback-statement
            if-statement
            initialize-statement
            initiate-statement
            inspect-statement
            invoke-statement
            merge-statement
            move-statement
            multiply-statement
            open-statement
            perform-statement
            raise-statement
            read-statement
            release-statement
            resume-statement
            return-statement
            rewrite-statement
            search-statement
            set-statement
            sort-statement
            start-statement
            stop-statement
            string-statement
            subtract-statement
            suppress-statement
            terminate-statement
            transform-statement
            unlock-statement
            unstring-statement
            use-statement
            validate-statement
            write-statement
    }

    accept-statement {
        stack
        {line ACCEPT
            {or +OMITTED
                {line identfier-1
                    {or {opt FROM CONSOLE}
                        {line FROM device}
                        {line FROM DATE {opt YYYYMMDD}}
                        {line FROM DAY {opt YYYYDDD}}
                        {line FROM DAY-OF-WEEK}
                        {line FROM TIME}
                        {line +FROM +COMMAND-LINE}
                        {line +FROM +ARGUMENT-NUMBER}
                        {line +FROM +ARGUMENT-VALUE}
                        {line +FROM +ENVIRONMENT +environment-variable}
                        {line +FROM +ENVIRONMENT-VALUE}
                        {line +FROM +ESCAPE-KEY}
                        {line +FROM +USER +NAME}
                        {line +FROM +EXCEPTION +STATUS}
                        {line +FROM +COLUMNS}
                        {line +FROM +LINES}
                        {line AT line-column {opt +WITH +extended-attributes}}
                    }
                }
            }}
            {opt {line
                {opt {line {opt ON} EXCEPTION imperative-1}}
                {opt {line NOT {opt ON} EXCEPTION imperative-2}}
            }}
            {opt END-ACCEPT}  
    }

    add-statement {
        stack
            {line ADD {or
                {line
                    {loop {or literal-1 identifier-1}}
                    {or
                        {line {or TO GIVING} 
                            {loop {line identifier-2 {opt rounded-phrase}}}}
                        {line TO {or literal-2 identifier-2} 
                              GIVING {loop {line identifier-3 {opt rounded-phrase}}}
                        }
                    }
                }
                {line {or CORRESPONDING CORR} identifier-4 TO identifier-5 
                    {opt rounded-phrase}}
            }}
            {opt {line
                {opt {line {opt ON} SIZE ERROR imperative-1}}
                {opt {line NOT {opt ON} SIZE ERROR imperative-2}}}}
            {opt END-ADD}
    }
    rounded-phrase {
        line ROUNDED
            {opt {line MODE {opt IS} {or
                AWAY-FROM-ZERO
                NEAREST-AWAY-FROM-ZERO
                NEAREST-EVEN
                NEAREST-TOWARD-ZERO
                PROHIBITED
                TOWARD-GREATER
                TOWARD-LESSER
                TRUNCATION}
           }
       }
    }

    allocate-statement {
        line ALLOCATE {or
            {line arithmetic-expression-1 CHARACTERS}
            data-name-1
        }
        {opt {or INITIALIZED +INITIALISED}}
        {opt {line RETURNING data-name-2}}
    }

    alter-statement {
        line +ALTER {loop {line +procedure-name-1 +TO 
            {opt +PROCEED +TO} +procedure-name-2}}
    } 

    call-statement {
        stack {
            line CALL {opt {or +STATIC +STDCALL +mnemonic-name}}
                {or identifier-1 literal-1}}
            {opt {line USING {loop {or
                {line {loop {line {opt {opt {line {opt BY} REFERENCE}}}
                    {or identifier-2 literal-2 OMITTED}}}}
                {line {loop {line {opt {line {opt BY} CONTENT}}
                    {or expression-1 identifier-2 literal-2}}}}
                {line {loop {line {opt {line {opt BY} VALUE {opt +size-mod}}}
                    {or identifier-2 literal-2}}}}
            }}}}
            {opt {line {or RETURNING +GIVING} 
                {opt {or +INTO {line +ADDRESS {opt +OF}}}}
                    {or identifier-3 {or +NULL +OMITTED}}}}
            {opt {line {opt {or {line {opt ON} EXCEPTION} 
              {line {opt ON} OVERFLOW}} imperative-1}
            {opt {or {line NOT {opt ON} EXCEPTION imperative-2}
              {line +NOT {opt +ON} +OVERFLOW +imperative-2}}}}}
            {opt END-CALL}
    }

    cancel-statement {
        line CANCEL {loop {or identifier-1 literal-1}}
    }

    close-statement {
        line CLOSE {loop {line file-name-1 {opt {or
            {line {or REEL UNIT} {opt FOR} REMOVAL}
            {line {opt WITH} {or {line NO REWIND} LOCK}}
        }}}}
    }

    compute-statement {
        stack 
            {line COMPUTE {loop {line identifier-1 
                {opt rounded-phrase}}} = arithmetic-expression-1}
            {opt {line
                {opt {line {opt ON} SIZE ERROR imperative-1}}
                {opt {line NOT {opt ON} SIZE ERROR imperative-2}}}}
            {opt END-COMPUTE}
    }
 
    commit-statement {
        line +COMMIT
    }

    continue-statement {
        line CONTINUE
    }

    delete-statement {
        stack
            {line DELETE {or
                {line +FILE {loop +file-name-1}}
                {line file-name-2 {opt RECORD}
                    {opt {line INVALID {opt KEY} imperative-1}} 
                    {opt {line NOT INVALID {opt KEY} imperative-2}}
            }}}
            {opt END-DELETE}
    }
            
    display-statement {
        stack
        {line DISPLAY
            {or
            {line {loop {or identifier-1 literal-1}} 
                {opt {line UPON mnemonic-name}} {opt {line {opt WITH}
                  NO ADVANCING}}}
            {line {or identifier-1 literal-1} AT line-column
                {opt +WITH +extended-attributes}}
            {line {or +identfier-1 +literal-1}
                {or 
                    {line +UPON +ENVIRONMENT-NAME}
                    {line +UPON +ENVIRONMENT-VALUE}
                    {line +UPON +ARGUMENT-NUMBER}
                    {line +UPON +ARGUMENT-VALUE}
                    {line +UPON +COMMAND-LINE}
                }}}}
        {opt {line
             {opt {line {opt ON} EXCEPTION imperative-1}}
             {opt {line NOT {opt ON} EXCEPTION imperative-2}}}}
        {opt END-DISPLAY}
    }

    divide-statement {
        stack
            {line DIVIDE {or identifier-1 literal-1}}
            {or
                 {line INTO {loop {line identifier-2 {opt rounded-phrase}}}}
                 {line BY {line identifier-2 {opt rounded-phrase}}}
                 {line {or INTO BY} {or identifier-2 literal-2}
                     GIVING {loop {line identifier-3 {opt rounded-phrase}}}}
                 {line {or INTO BY} {or identifier-2 literal-2}
                     {line GIVING {line identifier-3 {opt rounded-phrase}}}
                     {line REMAINDER identifier-4}}
            }
            {opt {line
                {opt {line {opt ON} SIZE ERROR imperative-1}}
                {opt {line NOT {opt ON} SIZE ERROR imperative-2}}}}
            {opt END-DIVIDE}
    }

    evaluate-statement {
        stack
            {line EVALUATE selection-subject
                {opt {loop {line ALSO selection-subject}}}}
            {line {loop {line WHEN selection-object
                {opt {loop {line ALSO selection-object}}}}} imperative-1}
            {opt {line WHEN OTHER imperative-2}}
            {opt END-EVALUATE}
    }

    exit-statement {
        stack
            {line EXIT {or
            nil
            {line {or PARAGRAPH SECTION FUNCTION 
                      {line PROGRAM {opt {or +RETURNING +GIVING}}}}}
            {line PERFORM {opt CYCLE}}}}
    }  

    free-statement {
        line FREE {loop data-name-1}
    }

    generate-statement {
        line GENERATE {or data-name-1 report-name-1}
    }

    go-statement {
        or
            {line GO {opt TO} {or
                procedure-name-1
                {line {loop procedure-names} {line DEPENDING {opt ON}
                  identifier-1}}}}
            {line +GO {opt +TO} {opt _target-procedure_(modified_by_alter)}}
    }

    goback-statement {
        line GOBACK
    }

    if-statement {
        line IF condition-1 {opt THEN} statement-1 {opt {line ELSE statement-2}}
            {opt END-IF}
    }

    initialize-statement {
        stack
            {line {or INITIALIZE +INITIALISE} {loop identifier-1}
                {opt {line {opt WITH} FILLER}}}
            {opt {line {or ALL category-name} {opt TO} VALUE}}
            {opt {line {opt THEN} REPLACING {loop {line category-name
                {opt DATA} BY {or identifier-1 literal-1}}}}}
            {opt {line {opt THEN} {opt TO} DEFAULT}}
    }
    category-name {
        line {or ALPHABETIC ALPHANUMERIC ALPHANUMERIC-EDITED DATA-POINTER
                 FUNCTION-POINTER NATIONAL NATIONAL-EDITED PROGRAM-POINTER}
    }

    initiate-statement {
        line INITIATE {loop report-name-1}
    }

    inspect-statement {
        line INSPECT identifier-1 {or
            {line TALLYING tallying-phrase}
            {line REPLACING replacing-phrase}
            {line TALLYING tallying-phrase REPLACING replacing-phrase}
            {line CONVERTING {or identifier-2 literal-1} TO 
                {or identifier-3 literal-2} {opt before-after-phrase}}    
        }
    }

    tallying-phrase {
        loop {line identifier-2 FOR {or
            {line CHARACTERS {opt before-after-phrase}}
            {loop {line ALL {or identifier-3 literal-1}
                {opt before-after-phrase}}}
            {loop {line LEADING {or identifier-3 literal-1}
                {opt before-after-phrase}}}
            {loop {line +TRAILIING {or +identifier-3 +literal-1}
                {opt +before-after-phrase}}}
        }}
    }

    before-after-phrase {
        or {line BEFORE {opt INITIAL} {or identifier-4 literal-2}}
            {line AFTER {opt INITIAL} {or identifier-4 literal-2}}
    }

    replacing-phrase {
        or
            {line CHARACTERS BY {opt identifier-5 literal-3}
                {opt before-after-phrase}}
            {loop {line ALL {or identifier-5 literal-3}
                {opt before-after-phrase}}}
            {loop {line LEADING {or identifier-5 literal-3}
                {opt before-after-phrase}}}
            {loop {line FIRST {or identifier-5 literal-3}
                {opt before-after-phrase}}}
            {loop {line +TRAILIING {or +identifier-5 +literal-3}
                {opt +before-after-phrase}}}
    }

    merge-statement {
        stack
            {line MERGE filename-1 {opt {loop {line {opt ON}
                {or ASCENDING DESCENDING} {opt KEY} {loop data-name-1}}}}}
            {opt {line {opt COLLATING} SEQUENCE {or
                {line IS alphabet-name-1 {opt alphabet-name-2}}
                {or
                    {line {opt FOR} ALPHANUMERIC {opt IS} alphabet-name-1}
                    {line {opt FOR} NATIONAL {opt IS} alphabet-name-2}}}}}
            {line USING filename-2 {loop file-name-3}}
            {or 
                {line OUTPUT PROCEDURE {opt IS} procedure-name-1
                    {opt {line {or THROUGH THRU}} procedure-name-2}}
                {line GIVING {loop file-name-4}}}
    }

    move-statement {
        line MOVE {or
            {line {or identifier-1 literal-1} TO {loop identifier-2}}
            {line {or CORRESPONDING CORR} identifier-3 TO identifier-4}}
    }

    multiply-statement {
        stack
            {line MULTIPLY {or
                {line {or identifier-1 literal-1} BY {loop {line identifier-2
                    {opt rounded-phrase}}}}
                {line {or identifier-1 literal-1} BY {or identifier-2 literal-2}
                    GIVING {loop {line identifier-3 {opt rounded-phrase}}}}}}
            {opt {line
                {opt {line {opt ON} SIZE ERROR imperative-1}}
                {opt {line NOT {opt ON} SIZE ERROR imperative-2}}}}
            {opt END-MULTIPLY}
    } 

    open-statement {
        line OPEN {loop {line {or INPUT OUTPUT I-O EXTEND}
                {opt {line SHARING {opt WITH} {or
                    {line ALL {opt OTHER}} {line NO {opt OTHER}}
                      {line READ ONLY}}}} {loop {line file-name-1 {opt {or 
                        {line {opt WITH} {or {line NO REWIND} LOCK}}
                        +REVERSED}}}}}}
    }
    
    perform-statement {
        line {or /perform-procedure /perform-inline}
    }

    perform-procedure-statement {
        stack
        {line PERFORM procedure-1 {opt {line {or THROUGH THRU} procedure-2}}}
        {opt {line {or
            {line {or identifier-1 integer-1} TIMES}
            {line {opt {line {opt WITH} TEST {or BEFORE AFTER}}}
            {or 
                {line UNTIL condition-1}
                varying-phrase}}}}}
    }

    perform-inline-statement {
        line PERFORM {or nil
            {line {or identifier-1 integer-1} TIMES}
            {line {opt {line {opt WITH} TEST {or BEFORE AFTER}}}
                {or 
                    {line UNTIL condition-1}
                    varying-phrase}}
            +FOREVER}
        imperative-1 END-PERFORM
    }

    varying-phrase {
        indentstack 2
        {line VARYING {or identifier-2 index-name-1}
          FROM {or identifier-3 index-name-2 literal-1}
          /by {or identifier-4 literal-2} UNTIL condition-1}
        {opt {loop {line AFTER {or identifier-5 index-name-3}
          FROM {or identifier-6 index-name-4 literal-3} 
          /by {or identifier-7 literal-4} UNTIL condition-2}}}
    }

    read-statement {
        stack
        {line READ file-name-1 {opt {or {opt NEXT} PREVIOUS}} {opt RECORD}
          {opt {line INTO identifier-1}}}
        {opt {line
          {opt {line ADVANCING {opt ON} LOCK}}
          {opt {line IGNORING LOCK}}
          {opt {line {opt WITH} {opt NO} LOCK}}}}
        {opt {line
          {opt {line {opt AT} END imperative-1}}
          {opt {line NOT {opt AT} END imperative-2}}}}
        {opt END-READ}
    }

    ready-statement {
        line +READY +TRACE
    }

    release-statement {
        line RELEASE record-name-1 {opt {line FROM {or identifier-1 literal-1}}}
    }

    reset-statement {
        line +RESET +TRACE
    }

    return-statement {
        stack 
            {line RETURN file-name-1 {opt RECORD} {opt {line INTO identifier-1}}}
            {line {opt AT} END imperative-1 {opt {line NOT {opt AT}
              END imperative-2}}}
            {opt END-RETURN}
    }

    rewrite-statement {
        stack
            {line REWRITE {or record-name-1 {line FILE file-name-1}} {opt RECORD}
              {opt {line FROM {or identifier-1 literal-1}}}}
            {opt {line {opt WITH} {opt NO} LOCK}}
            {opt {line {opt {line INVALID {opt KEY} imperative-1}}
              {opt {line NOT INVALID {opt KEY} imperative-2}}}}
            {opt END-REWRITE}
    }

    rollback-statement {
        line +ROLLBACK
    }

    search-statement {
        line {or /search-linear /search-all}
    }
 
    search-linear-statement {
        stack
            {line SEARCH identifier-1 {opt {line VARYING 
              {or identifier-2 index-name-1}}}}
            {opt {line {opt AT} END imperative-1}}
            {line {loop {line WHEN condition-1 
              {or imperative-2 {line NEXT SENTENCE}}}}}
            {opt {line {opt END-SEARCH}}}
    }

    search-all-statement {
        stack
            {line SEARCH ALL identifier-1 {opt {line {opt AT} END imperative-1}}}
            {line WHEN {or 
                {line data-name-1 {or {line {opt IS} EQUAL {opt TO}}
                  {line {opt IS} =}}
                  {or identifier-3 literal-1 arithmetic-expression-1}}
                condition-name-1}}
            {opt {line {loop {line AND {or
                {line data-name-2 {or {line {opt IS} EQUAL {opt TO}}
                  {line {opt IS} =}}
                  {or identifier-4 literal-2 arithmetic-expression-2}}
                condition-name-2}}}}}
            {or imperative-2 {line NEXT SENTENCE}}
            {opt END-SEARCH}
    }

    set-statement {
        line SET {or
            {line {loop {or index-name-1 identifier-1}}
              TO {or arithmetic-expression-1 index-name-2 identifier-2}}
            {line {loop {line {opt ADDRESS {opt OF}} identifier-1}}
              TO ADDRESS {opt OF} identifier-2}
            {line {loop index-name-1} {line {or UP DOWN} BY 
              arthimetic-expression-1}}
            {line {loop {line {loop mnemonic-name-1} TO {or ON OFF}}}}
            {line {loop {line {loop condition-name-1} TO {or TRUE FALSE}}}}
            {line screen-name-1 ATTRIBUTE {loop {line
                {or BELL BLINK HIGHLIGHT LOWLIGHT REVERSE-VIDEO UNDERLINE
                  +LEFTLINE +OVERLINE } {or ON OFF}}}}
            {line {loop +identifier-1}
              +TO {line +ENTRY {or +identifier-2 +literal-1}}}
            {line +ENVIRONMENT {or +identifier-1 +literal-1}
              +TO {or +identifier-2 +literal-2}}
        }
    }

    sort-statement {
        line {or /sort-file /sort-table}
    }

    sort-file-statement {
        stack
            {line SORT file-name-1
              {opt {loop {line {opt ON} {or ASCENDING DESCENDING}
              KEY {loop data-name-1}}}}}
            {opt {line {opt WITH} DUPLICATES {opt IN} {opt ORDER}}}
            {opt {line {opt COLLATING} SEQUENCE {opt IS} alphabet-1
              {opt alphabet-2}}}
            {opt {line {or
                {line INPUT PROCEDURE {opt IS} procedure-name-1
                  {opt {line {or THROUGH THRU} procedure-name-2}}}
                {line USING {loop file-name-2}}}}} 
            {opt {line {or
                {line OUTPUT PROCEDURE {opt IS} procedure-name-3
                  {opt {line {or THROUGH THRU} procedure-name-4}}}
                {line GIVING {loop file-name-3}}}}} 
    }

    sort-table-statement {
        stack
            {line SORT data-name-1
              {opt {loop {line {opt ON} {or ASCENDING DESCENDING}
              KEY {loop data-name-1}}}}}
            {opt {line {opt WITH} DUPLICATES {opt IN} {opt ORDER}}}
            {opt {line {opt COLLATING} SEQUENCE {opt IS} alphabet-1
              {opt alphabet-2}}}
    }

    start-statement {
        stack
            {line START file-name-1 {or
              FIRST
              {line KEY relational-1 {or data-name-1 record-key-1}
                {opt {line {opt WITH} {or LENGTH +SIZE} arithmetic-expression-1}}} 
              LAST}}
            {opt {line {opt {line INVALID {opt KEY} imperative-1}}
                       {opt {line NOT INVALID {opt KEY} imperative-2}}}}
            END-START
    }

    stop-statement {
        line STOP {or
            {line RUN {opt {or
                {line {opt WITH} {or ERROR NORMAL} {opt STATUS}
                  {or identifier-1 literal-1}}
                {line {or +RETURNING +GIVING} {or +identifier-2 +literal-2}}}}}
            +literal-3}
    }

    string-statement {
        stack
            {line STRING {line {loop {line {loop {or identifier-1 literal-1}}
              {opt {line DELIMITED {opt BY}} {or identifier-2 literal-2 SIZE}}}}}}
            {line INTO identifier-3 {opt {line {opt WITH} POINTER identifier-4}}}
            {opt {line {opt {line {opt ON} OVERFLOW imperative-1}}
                       {opt {line NOT {opt ON} OVERFLOW imperative-2}}}}
            {opt END-STRING}
    }
 
    subtract-statement {
        stack
            {line SUBTRACT {or
                {line
                    {loop {or literal-1 identifier-1}}
                    {or
                        {line FROM 
                            {loop {line identifier-2 {opt rounded-phrase}}}}
                        {line FROM {or literal-2 identifier-2} 
                              GIVING {loop {line identifier-3 {opt rounded-phrase}}}
                        }
                    }
                }
                {line {or CORRESPONDING CORR} identifier-4 FROM identifier-5 
                    {opt rounded-phrase}}
            }}
            {opt {line
                {opt {line {opt ON} SIZE ERROR imperative-1}}
                {opt {line NOT {opt ON} SIZE ERROR imperative-2}}}}
            {opt END-SUBTRACT}
    }

    suppress-statement {
        line SUPPRESS {opt PRINTING}
    }

    terminate-statement {
        line TERMINATE {loop report-name-1}
    }

    transform-statement {
        line +TRANSFORM +identifier-1 +FROM {or +identifier-2 +literal-1}
          +TO {or +identifier-3 {line {opt +ALL} +literal-2}} 
    }

    unlock-statement {
        line UNLOCK file-name-1 {opt {or RECORD RECORDS}}
    }

    unstring-statement {
        stack
            {line UNSTRING identifier-1
                {opt {line DELIMITED {opt BY} {opt ALL} {or identifier-2 literal-1}
                    {opt {loop {line OR {opt ALL} {or identifier-3 literal-2}}}}}}}
            {line INTO {loop {line identifier-4 
              {opt {line DELIMITER {opt IN} identifier-5}}
              {opt {line COUNT {opt IN} identifier-6}}}}}
            {opt {line {opt WITH} POINTER identifier-7}}
            {opt {line TALLYING {opt IN} identifier-8}}
            {opt {line {opt {line {opt ON} OVERFLOW imperative-1}}
              {opt {line NOT {opt ON} OVERFLOW imperative-2}}}}
            {opt END-UNSTRING}
    }
    
    use-statement {
       line USE {or
           {line {opt GLOBAL} {opt AFTER} {opt STANDARD} {or EXCEPTION ERROR}
             {opt PROCEDURE} {opt ON} {or {loop file-name-1} INPUT OUTPUT IO EXTEND}}
           {line {opt GLOBAL} BEFORE REPORTING identifier-1}
           {line {opt +FOR} +DEBUGGING {opt +ON} {loop {or
             {line {or +procedure {line +ALL +PROCEDURES}}}
             {line +ALL {opt +REFERENCES} {opt +OF} +identifier-2}}}}
           {line {opt +AT} +PROGRAM {or +START +END}} 
           {line {opt AFTER} {loop {line {or {line EXCEPTION CONDITION} EC}
             {or exception-name-1 {line exception-name-2 {loop {line FILE file-name-2}}}}}}}}
    }

    write-statement {
        line {or write-sequential write-random}
    }
            
    write-sequential-statement {
        stack
            {line WRITE {or record-name-1 {line {opt FILE} file-name-1}}
              {opt {line FROM {or identifier-1 literal-1}}}}
            {opt {line {or BEFORE AFTER} ADVANCING {or
              {line {or identifier-2 integer-1} {or LINE LINES}}
                {or mnemonic-name-1 PAGE}}}}
            {opt {line {opt WITH} {opt NO} LOCK}}
            {opt {line {opt {line {opt AT} {or END-OF-PAGE EOP} imperative-1}}
              {opt {line NOT {opt AT} {or END-OF-PAGE EOP} imperative-2}}}}
            {opt END-WRITE}
    }
    write-random-statement {
        stack
            {line WRITE {or record-name-1 {line {opt FILE} file-name-1}}
              {opt {line FROM {or identifier-1 literal-1}}}}
            {opt {line {opt WITH} {opt NO} LOCK}}
            {opt {line {opt {line INVALID {opt KEY} imperative-1}}
              {opt {line NOT INVALID {opt KEY} imperative-2}}}}
            {opt END-WRITE}
    }
}

GNU    >>SOURCE FORMAT IS FIXED
Cobol *> *******************************************************
cob   *> Author:    Brian Tiffin
  web *> Date:      20130308, 20140712
      *> Purpose:   A cobweb extension, periodic table
atomic*> License:   GPL 3.0 or greater
chart *> Tectonics:
      *>  cobc -x -g -debug cobweb-periodic.cob support-cobweb.cob
      *>    voidcall.c `pkg-config --libs gtk+-3.0`
      *> ********************************************************
       identification division.
       program-id. cobweb-periodic.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       input-output section.
       file-control.
           select element-data
           assign to "elements.txt"
           organization is line sequential
           status is element-data-status
           .

       data division.
       file section.
       fd element-data.
          01 element-record.
             05 element-id     pic 999.
             05 filler         pic x.
             05 element-short  pic xxx.
             05 filler         pic x.
             05 element-period pic 99.
             05 filler         pic x.
             05 element-group  pic 99.
             05 filler         pic x.
             05 element-color  pic x(24).
             05 filler         pic x.
             05 element-info   pic x(64).

       working-storage section.
      *>
      *> the periodic table of the elements, shared with a callback
      *>   updates here need to be synched with support-cobweb.cob
      *>
       01 elements is external.
          05 element occurs 118 times indexed by elem.
             10 sym            pic xxx.
             10 cg             pic 99.
             10 rp             pic 99.
             10 color          pic x(24).
             10 info           pic x(64).
       01 element-data-status  pic 9999.

      *> cheat C out of chasing a null byte
       01 button-zname.
          05 button-number           pic zzzz9.
          05 filler                  pic x value x"0a".
          05 button-name             pic xxx.
          05 filler                  pic x value x"00".

       01 venue                      pic x(8).
          88 broadway                    values "broadway", "BROADWAY".

       01 gtk-window                 usage pointer.
       01 gtk-settings               usage pointer.
       01 gtk-box                    usage pointer.
       01 gtk-label                  usage pointer.
       01 gtk-spacer                 usage pointer.
       01 gtk-grid                   usage pointer.
       01 gtk-button                 usage pointer.
       01 gtk-quit-callback          usage program-pointer.
       01 gtk-quit-handler-id        usage pointer.
       01 gtk-void-callback          usage program-pointer.
       01 cob-button-callback        usage program-pointer.

       01 gdk-color                  pic x(32).

       01 gtk-info-label             is external usage pointer.

       01 p usage index.
       01 g usage index.

       01 GTK-WINDOW-TOPLEVEL        constant as 0.

       01 GTK-ORIENTATION-HORIZONTAL constant as 0.
       01 GTK-ORIENTATION-VERTICAL   constant as 1.

       01 banner-msg           pic x(27)
                                 value z"GNU Cobol periodic buttons".

      *> destined to be a callable, not a main, linkage in the future
       linkage section.
       01 gtk-widget                 usage pointer.
       01 gtk-data                   usage pointer.

      *> ********************************************************

gui   *> ********************************************************
       procedure division.

      *> populate the element data
       open input element-data
       if element-data-status not equal zero then
           display
               "Sorry, no elements.txt data" upon syserr
           end-display
           stop run returning 1
       end-if

      *> pull in the element data, fill a table
       perform varying elem from 1 by 1 until elem > 118
           read element-data at end exit perform end-read
           if element-data-status not equal 0 then exit perform end-if
           move element-short to sym(elem)
           move element-group to cg(elem)
           move element-period to rp(elem)
           move element-color to color(elem)
           move element-info to info(elem)
       end-perform
       close element-data

      *> Start up the GIMP/Gnome Tool Kit
       call "gtk_init" using
           by value 0                          *> argc int
           by value 0                          *> argv pointer to pointer
           returning omitted                   *> void return, requires cobc 2010+
           on exception
               display
                   "gtk_init link error, see pkg-config --libs gtk+-3.0"
                   upon syserr
               end-display
               stop run returning 1
       end-call

      *> Create a new window, returning handle as pointer
       call "gtk_window_new" using
           by value GTK-WINDOW-TOPLEVEL        *> it's a zero or a 1 popup
           returning gtk-window                *> and remember the handle
       end-call

      *> More fencing, skimped on after this first test
       if gtk-window equal null then
           display
               "GTK service error; gtk_window_new NULL"
               upon syserr
           end-display
           stop run returning 1
       end-if

      *> Hint to not let the sample window be too small
       call "gtk_window_set_default_size" using
           by value gtk-window                 *> by value is used to get the C address
           by value 270                        *> a rectangle, wider than tall
           by value 90
           returning omitted                   *> another void
       end-call

      *> Put in the title, it'll be truncated in a size request window
       call "gtk_window_set_title" using
           by value gtk-window                 *> pass the C handle
           by reference banner-msg
           returning omitted
       end-call

      *> Connect death signals.
       set gtk-quit-callback to entry "gtk_main_quit"
       call "g_signal_connect_data" using
           by value gtk-window
           by reference z"destroy"             *> with inline Z string
           by value gtk-quit-callback          *> function call back pointer
           by value 0                          *> pointer to data
           by value 0                          *> closure notify to manage data
           by value 0                          *> connect before or after flag
           returning gtk-quit-handler-id       *> not used in this sample
       end-call
       call "g_signal_connect_data" using
           by value gtk-window
           by reference z"delete_event"        *> with inline Z string
           by value gtk-quit-callback          *> function call back pointer
           by value 0                          *> pointer to data
           by value 0                          *> closure notify to manage data
           by value 0                          *> connect before or after flag
           returning gtk-quit-handler-id       *> not used in this sample
       end-call

      *> Define a container. Boxey, but nice.  Layout top to bottom.
       call "gtk_box_new" using
           by value GTK-ORIENTATION-VERTICAL
           by value 8                          *> pixels between widgets
           returning gtk-box
       end-call

      *> Add the label
       call "gtk_label_new" using
           by reference banner-msg
           returning gtk-label
       end-call

      *> Add the label to the box
       call "gtk_container_add" using
           by value gtk-box
           by value gtk-label
           returning omitted
       end-call

      *> Instead of fiddling with each button, make a grid
       call "gtk_grid_new" returning gtk-grid end-call

       *> row and column for the chart is in the elements data
       *>  g is element group, p is period
       perform varying elem from 1 by 1 until elem > 118
           move cg(elem) to g
           move rp(elem) to p

          *> name the button
           move sym(elem) to button-name
           move elem to button-number

          *> Add a button
           call "gtk_button_new_with_label" using
               by reference button-zname
               returning gtk-button
           end-call

          *> BOO! no background color mod with the default GNOME
          *>  theme, Adwaita, due to the theme wanting to apply
          *>  gradients...  Rassafrassa, Styling... for color?

          *> possible workaround, turn off the Adwaita theme
           call "gtk_settings_get_default"
               returning gtk-settings
           end-call
           call "g_object_set" using
               by value gtk-settings
               by content z"gtk-theme-name"
               by value 0
               by value 0
               returning omitted
           end-call

           call "gdk_rgba_parse" using
               by reference gdk-color
               by content concatenate(trim(color(elem)), x"00")
           end-call
           call "gtk_widget_override_background_color" using
               by value gtk-button
               by value 0
               by reference gdk-color
               returning omitted
           end-call

           call "gtk_grid_attach" using
               by value gtk-grid
               by value gtk-button
               by value p               *> column, element group
               by value g               *> row, element period
               by value 1               *> cells width
               by value 1               *> cells height
               returning omitted
           end-call

      *> Connect a signal.  GNU Cobol doesn't generate void returns
      *>  so this calls a C function two-liner that calls the
      *>  COBOL entry, but returns void to the runtime stack frame
           set cob-button-callback to entry "buttonclick"
           set gtk-void-callback to entry "voidcall"
           call "g_signal_connect_data" using
               by value gtk-button
               by reference z"clicked"             *> with inline Z string
               by value gtk-void-callback          *> function call back pointer
               by value cob-button-callback        *> pointer to COBOL proc
               by value 0                          *> closure notify to manage data
               by value 0                          *> connect before or after flag
               returning gtk-quit-handler-id       *> not used in this sample
           end-call

       end-perform

      *> Force the empty row 8
       call "gtk_label_new" using
           by content z"---"
           returning gtk-spacer
       end-call
       call "gtk_grid_attach" using
           by value gtk-grid
           by value gtk-spacer
           by value 3               *> left-side attached to
           by value 8               *> top-of-cell row, element period
           by value 1               *> cells width
           by value 1               *> cells height
           returning omitted
       end-call

      *> the info box
       call "gtk_label_new" using
           by content "Click an element to see more information," &
                      " including;" & x"0a" &
                      "name, class, normal state," &
                     z" atomic weight and electron orbits"
           returning gtk-info-label
       end-call
       call "gdk_rgba_parse" using
           by reference gdk-color
           by content z"white"
       end-call
       call "gtk_widget_override_background_color" using
           by value gtk-info-label
           by value 0
           by reference gdk-color
           returning omitted
       end-call
       call "gtk_grid_attach" using
           by value gtk-grid
           by value gtk-info-label
           by value 3               *> left-side attached to
           by value 2               *> top-of-cell row, element period
           by value 10              *> cells width
           by value 2               *> cells height
           returning omitted
       end-call


      *> Add the big fat grid to the box
       call "gtk_container_add" using
           by value gtk-box
           by value gtk-grid
           returning omitted
       end-call

      *> Add some control buttons to the box, only the self destruct button in this case
       call "gtk_button_new_with_label" using
           by content z"Exit"
           returning gtk-button
       end-call
       call "gtk_container_add" using
           by value gtk-box
           by value gtk-button
           returning omitted
       end-call
       set gtk-quit-callback to entry "gtk_main_quit"
       call "g_signal_connect_data" using
           by value gtk-button
           by reference z"clicked"
           by value gtk-quit-callback
           by value 0
           by value 0
           by value 0
           returning gtk-quit-handler-id
       end-call

      *> Add the box to the window
       call "gtk_container_add" using
           by value gtk-window
           by value gtk-box
           returning omitted
       end-call

      *> ready to display
       call "gtk_widget_show_all" using
           by value gtk-window
           returning omitted
       end-call

      *> Enter the GTK event loop
       call "gtk_main" returning omitted end-call

      *> Control can pass back and forth to COBOL subprograms,
      *>  by event, but control flow stops above, until the
      *>  window is torn down and the event loop exits
       display
           "GNU Cobol: GTK main eventloop terminated normally"
           upon syserr
       end-display

       accept venue from environment "GDK_BACKEND" end-accept
       if broadway then
           display "Ken sends his regards" upon syserr end-display
       end-if

done   goback.
COOL   end program cobweb-periodic.


   1 H   01x01 medium spring green      Hydrogen nonmetal gas 1.00794 [1]
   2 He  18x01 peru                     Helium noble gas 4.002602 [2]
   3 Li  01x02 coral                    Lithium alkali-metal solid 6.941 [2 1]
   4 Be  02x02 moccasin                 Beryllium alkaline-earth-metal solid 9.01218 [2 2]
   5 B   13x02 tan                      Boron metalloid solid 10.811 [2 3]
   6 C   14x02 medium spring green      Carbon nonmetal solid 12.011 [2 4]
   7 N   15x02 medium spring green      Nitrogen nonmetal gas 14.00674 [2 5]
   8 O   16x02 medium spring green      Oxygen nonmetal gas 15.9994 [2 6]
   9 F   17x02 orange                   Fluorine halogen gas 18.998403 [2 7]
  10 Ne  18x02 peru                     Neon noble gas 20.1797 [2 8]
  11 Na  01x03 coral                    Sodium alkali-metal solid 22.989768 [2 8 1]
  12 Mg  02x03 moccasin                 Magnesium alkaline-earth-metal solid 24.305 [2 8 2]
  13 Al  13x03 silver                   Aluminum poor-metal solid 26.981539 [2 8 3]
  14 Si  14x03 tan                      Silicon metalloid solid 28.0855 [2 8 4]
  15 P   15x03 medium spring green      Phosphorus nonmetal solid 30.973762 [2 8 5]
  16 S   16x03 medium spring green      Sulphur nonmetal solid 32.066 [2 8 6]
  17 Cl  17x03 orange                   Chlorine halogen gas 35.4527 [2 8 7]
  18 Ar  18x03 peru                     Argon noble gas 39.948 [2 8 8]
  19 K   01x04 coral                    Potassium alkali-metal solid 39.0983 [2 8 8 1]
  20 Ca  02x04 moccasin                 Calcium alkaline-earth-metal solid 40.078 [2 8 8 2]
  21 Sc  03x04 thistle                  Scandium transition-metal solid 44.95591 [2 8 9 2]
  22 Ti  04x04 thistle                  Titanium transition-metal solid 47.88 [2 8 10 2]
  23 V   05x04 thistle                  Vanadium transition-metal solid 50.9415 [2 8 11 2]
  24 Cr  06x04 thistle                  Chromium transition-metal solid 51.9961 [2 8 13 1]
  25 Mn  07x04 thistle                  Manganese transition-metal solid 54.93805 [2 8 13 2]
  26 Fe  08x04 thistle                  Iron transition-metal solid 55.847 [2 8 14 2]
  27 Co  09x04 thistle                  Cobalt transition-metal solid 58.9332 [2 8 15 2]
  28 Ni  10x04 thistle                  Nickel transition-metal solid 58.6934 [2 8 16 2]
  29 Cu  11x04 thistle                  Copper transition-metal solid 63.546 [2 8 18 1]
  30 Zn  12x04 thistle                  Zinc transition-metal solid 65.39 [2 8 18 2]
  31 Ga  13x04 silver                   Gallium poor-metal solid 69.723 [2 8 18 3]
  32 Ge  14x04 tan                      Germanium metalloid solid 72.61 [2 8 18 4]
  33 As  15x04 tan                      Arsenic metalloid solid 74.92159 [2 8 18 5]
  34 Se  16x04 medium spring green      Selenium nonmetal solid 78.96 [2 8 18 6]
  35 Br  17x04 orange                   Bromine halogen liquid 79.904 [2 8 18 7]
  36 Kr  18x04 peru                     Krypton noble gas 83.8 [2 8 18 8]
  37 Rb  01x05 coral                    Rubidium alkali-metal solid 85.4678 [2 8 18 8 1]
  38 Sr  02x05 moccasin                 Strontium alkaline-earth-metal solid 87.62 [2 8 18 8 2]
  39 Y   03x05 thistle                  Yttrium transition-metal solid 88.90585 [2 8 18 9 2]
  40 Zr  04x05 thistle                  Zirconium transition-metal solid 91.224 [2 8 18 10 2]
  41 Nb  05x05 thistle                  Niobium transition-metal solid 92.90638 [2 8 18 12 1]
  42 Mo  06x05 thistle                  Molybdenum transition-metal solid 95.94 [2 8 18 13 1]
  43 Tc  07x05 thistle                  Technetium transition-metal solid 97.9072 [2 8 18 13 2]
  44 Ru  08x05 thistle                  Ruthenium transition-metal solid 101.07 [2 8 18 15 1]
  45 Rh  09x05 thistle                  Rhodium transition-metal solid 102.9055 [2 8 18 16 1]
  46 Pd  10x05 thistle                  Palladium transition-metal solid 106.42 [2 8 18 18 0]
  47 Ag  11x05 thistle                  Silver transition-metal solid 107.8682 [2 8 18 18 1]
  48 Cd  12x05 thistle                  Cadmium transition-metal solid 112.411 [2 8 18 18 2]
  49 In  13x05 silver                   Indium poor-metal solid 114.818 [2 8 18 18 3]
  50 Sn  14x05 silver                   Tin poor-metal solid 118.71 [2 8 18 18 4]
  51 Sb  15x05 tan                      Antimony metalloid solid 121.760 [2 8 18 18 5]
  52 Te  16x05 tan                      Tellurium metalloid solid 127.6 [2 8 18 18 6]
  53 I   17x05 orange                   Iodine halogen solid 126.90447 [2 8 18 18 7]
  54 Xe  18x05 peru                     Xenon noble gas 131.29 [2 8 18 18 8]
  55 Cs  01x06 coral                    Cesium alkali-metal solid 132,90543 [2 8 18 18 8 1]
  56 Ba  02x06 moccasin                 Barium alkaline-earth-metal solid 137.327 [2 8 18 18 8 2]
  57 La  03x09 orchid                   Lanthanum lanthanide solid 138.9055 [2 8 18 18 9 2]
  58 Ce  04x09 orchid                   Cerium lanthanide solid 140.115 [2 8 18 20 8 2]
  59 Pr  05x09 orchid                   Praseodymium lanthanide solid 140.90765 [2 8 18 21 8 2]
  60 Nd  06x09 orchid                   Noedymium lanthanide solid 144.24  [2 8 18 22 8 2]
  61 Pm  07x09 orchid                   Promethium lanthanide solid 144.9127 [2 8 18 23 8 2]
  62 Sm  08x09 orchid                   Samarium lanthanide solid 150.36 [2 8 18 24 8 2]
  63 Eu  09x09 orchid                   Europium lanthanide solid 151.965 [2 8 18 25 8 2]
  64 Gd  10x09 orchid                   Gadolinium lanthanide solid 157.25 [2 8 18 25 9 2]
  65 Tb  11x09 orchid                   Terbium lanthanide solid 158.92534 [2 8 18 27 8 2]
  66 Dy  12x09 orchid                   Dysprosium lanthanide solid 162.50 [2 8 18 28 8 2]
  67 Ho  13x09 orchid                   Holmium lanthanide solid 164.93032 [2 8 18 29 8 2]
  68 Er  14x09 orchid                   Erbium lanthanide solid 167.26 [2 8 18 30 8 2]
  69 Tm  15x09 orchid                   Thulium lanthanide solid 168.93421 [2 8 18 31 8 2]
  70 Yb  16x09 orchid                   Ytterbium lanthanide solid 173.04 [2 8 18 32 8 2]
  71 Lu  17x09 orchid                   Lutetium  lanthanide solid 174.967 [2 8 18 32 9 2]
  72 Hf  04x06 thistle                  Hafnium transition-metal solid 178.49 [2 8 18 32 10 2]
  73 Ta  05x06 thistle                  Tantalum transition-metal solid 180.9479 [2 8 18 32 11 2]
  74 W   06x06 thistle                  Tungsten transition-metal solid 183.84 [2 8 18 32 12 2]
  75 Re  07x06 thistle                  Rhenium transition-metal solid 186.207 [2 8 18 32 13 2]
  76 Os  08x06 thistle                  Osmium transition-metal solid 190.23 [2 8 18 32 14 2]
  77 Ir  09x06 thistle                  Iridium transition-metal solid 192.22 [2 8 18 32 15 2]
  78 Pt  10x06 thistle                  Platinum transition-metal solid 195.08 [2 8 18 32 17 1]
  79 Au  11x06 thistle                  Gold transition-metal solid 196.96654 [2 8 18 32 18 1]
  80 Hg  12x06 thistle                  Mercury transition-metal liquid 200.59 [2 8 18 32 18 2]
  81 Tl  13x06 silver                   Thallium poor-metal solid 204.3833 [2 8 18 32 18 3]
  82 Pb  14x06 silver                   Lead poor-metal solid 207.2 [2 8 18 32 18 4]
  83 Bi  15x06 silver                   Bismuth poor-metal solid 208.98037 [2 8 18 32 18 5]
  84 Po  16x06 tan                      Polonium metalloid solid 208.9824 [2 8 18 32 18 6]
  85 At  17x06 orange                   Astatine halogen solid 209.9871 [2 8 18 32 18 7]
  86 Rn  18x06 peru                     Radon noble gas 222.0176 [2 8 18 32 18 8]
  87 Fr  01x07 coral                    Francium alkali-metal solid 223.0197 [2 8 18 32 18 8 1]
  88 Ra  02x07 moccasin                 Radium alkaline-earth-metal solid 226.0254 [2 8 18 32 18 8 2]
  89 Ac  03x10 salmon                   Actinium actinide solid 227.0278 [2 8 18 32 18 9 2]
  90 Th  04x10 salmon                   Thorium actinide solid 232.0381 [2 8 18 32 18 10 2]
  91 Pa  05x10 salmon                   Protactinium actinide solid 231.03588 [2 8 18 32 20 9 2]
  92 U   06x10 salmon                   Uranium actinide solid 238.0289 [2 8 18 32 21 9 2]
  93 Np  07x10 salmon                   Neptunium actinide solid 237.048 [2 8 18 32 22 9 2]
  94 Pu  08x10 salmon                   Plutonium actinide solid 244.0642 [2 8 18 32 24 8 2]
  95 Am  09x10 salmon                   Americium actinide solid 243.0614 [2 8 18 32 25 8 2]
  96 Cm  10x10 salmon                   Curium actinide solid 247.0703 [2 8 18 32 25 9 2]
  97 Bk  11x10 salmon                   Berkelium actinide solid 247.0703 [2 8 18 32 26 9 2]
  98 Cf  12x10 salmon                   Californium actinide solid 251.0796 [2 8 18 32 28 8 2]
  99 Es  13x10 salmon                   Einsteinium actinide solid 252.083 [2 8 18 32 29 8 2]
 100 Fm  14x10 salmon                   Fermium actinide solid 257.0951 [2 8 18 32 30 8 2]
 101 Md  15x10 salmon                   Mendelevium actinide solid 258.1 [2 8 18 32 31 8 2]
 102 No  16x10 salmon                   Nobelium actinide solid 259.1009 [2 8 18 32 32 8 2]
 103 Lr  17x10 salmon                   Lawrencium actinide solid 262.11 [2 8 18 32 32 9 2]
 104 Rf  04x07 thistle                  Rutherfordium transition-metal solid 261 [2 8 18 32 32 10 2]
 105 Db  05x07 thistle                  Dubnium transition-metal solid 262 [2 8 18 32 32 11 2]
 106 Sg  06x07 thistle                  Seaborgium transition-metal solid 266 [2 8 18 32 32 12 2]
 107 Bh  07x07 thistle                  Bohrium transition-metal solid 264 [2 8 18 32 32 13 2]
 108 Hs  08x07 thistle                  Hassium transition-metal solid 269 [2 8 18 32 32 14 2]
 109 Mt  09x07 thistle                  Meitnerium transition-metal solid 268 [2 8 18 32 32 15 2]
 110 Ds  10x07 thistle                  Darmstadmium transition-metal solid 269 [2 8 18 32 32 17 1]
 111 Rg  11x07 thistle                  Roentgenium transition-metal solid 272 [2 8 18 32 32 18 1]
 112 Uub 12x07 thistle                  Ununbium transition-metal liquid 277 [2 8 18 32 32 18 2]
 113 Uut 13x07 silver                   Ununtrium poor-metal solid n/a [2 8 18 32 32 18 3]
 114 Uuq 14x07 silver                   Ununquadium poor-metal solid 289  [2 8 18 32 32 18 4]
 115 Uup 15x07 silver                   Ununpentium poor-metal solid n/a [2 8 18 32 32 18 5]
 116 Uuh 16x07 silver                   Ununhexium poor-metal solid n/a [2 8 18 32 32 18 6]
 117 Uus 17x07 orange                   Ununseptium halogen solid n/a [2 8 18 32 32 18 7]
 118 Uuo 18x07 peru                     Ununoctium noble gas n/a [2 8 18 32 32 18 8]


                    GNU GENERAL PUBLIC LICENSE
                       Version 3, 29 June 2007

 Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

                            Preamble

  The GNU General Public License is a free, copyleft license for
software and other kinds of works.

  The licenses for most software and other practical works are designed
to take away your freedom to share and change the works.  By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users.  We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors.  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.

  To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights.  Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received.  You must make sure that they, too, receive
or can get the source code.  And you must show them these terms so they
know their rights.

  Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.

  For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software.  For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.

  Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so.  This is fundamentally incompatible with the aim of
protecting users' freedom to change the software.  The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable.  Therefore, we
have designed this version of the GPL to prohibit the practice for those
products.  If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.

  Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary.  To prevent this, the GPL assures that
patents cannot be used to render the program non-free.

  The precise terms and conditions for copying, distribution and
modification follow.

                       TERMS AND CONDITIONS

  0. Definitions.

  "This License" refers to version 3 of the GNU General Public License.

  "Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.

  "The Program" refers to any copyrightable work licensed under this
License.  Each licensee is addressed as "you".  "Licensees" and
"recipients" may be individuals or organizations.

  To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy.  The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.

  A "covered work" means either the unmodified Program or a work based
on the Program.

  To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy.  Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.

  To "convey" a work means any kind of propagation that enables other
parties to make or receive copies.  Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.

  An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License.  If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.

  1. Source Code.

  The "source code" for a work means the preferred form of the work
for making modifications to it.  "Object code" means any non-source
form of a work.

  A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.

  The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form.  A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.

  The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities.  However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work.  For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.

  The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.

  The Corresponding Source for a work in source code form is that
same work.

  2. Basic Permissions.

  All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met.  This License explicitly affirms your unlimited
permission to run the unmodified Program.  The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work.  This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.

  You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force.  You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright.  Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.

  Conveying under any other circumstances is permitted solely under
the conditions stated below.  Sublicensing is not allowed; section 10
makes it unnecessary.

  3. Protecting Users' Legal Rights From Anti-Circumvention Law.

  No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.

  When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.

  4. Conveying Verbatim Copies.

  You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.

  You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.

  5. Conveying Modified Source Versions.

  You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:

    a) The work must carry prominent notices stating that you modified
    it, and giving a relevant date.

    b) The work must carry prominent notices stating that it is
    released under this License and any conditions added under section
    7.  This requirement modifies the requirement in section 4 to
    "keep intact all notices".

    c) You must license the entire work, as a whole, under this
    License to anyone who comes into possession of a copy.  This
    License will therefore apply, along with any applicable section 7
    additional terms, to the whole of the work, and all its parts,
    regardless of how they are packaged.  This License gives no
    permission to license the work in any other way, but it does not
    invalidate such permission if you have separately received it.

    d) If the work has interactive user interfaces, each must display
    Appropriate Legal Notices; however, if the Program has interactive
    interfaces that do not display Appropriate Legal Notices, your
    work need not make them do so.

  A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit.  Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.

  6. Conveying Non-Source Forms.

  You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:

    a) Convey the object code in, or embodied in, a physical product
    (including a physical distribution medium), accompanied by the
    Corresponding Source fixed on a durable physical medium
    customarily used for software interchange.

    b) Convey the object code in, or embodied in, a physical product
    (including a physical distribution medium), accompanied by a
    written offer, valid for at least three years and valid for as
    long as you offer spare parts or customer support for that product
    model, to give anyone who possesses the object code either (1) a
    copy of the Corresponding Source for all the software in the
    product that is covered by this License, on a durable physical
    medium customarily used for software interchange, for a price no
    more than your reasonable cost of physically performing this
    conveying of source, or (2) access to copy the
    Corresponding Source from a network server at no charge.

    c) Convey individual copies of the object code with a copy of the
    written offer to provide the Corresponding Source.  This
    alternative is allowed only occasionally and noncommercially, and
    only if you received the object code with such an offer, in accord
    with subsection 6b.

    d) Convey the object code by offering access from a designated
    place (gratis or for a charge), and offer equivalent access to the
    Corresponding Source in the same way through the same place at no
    further charge.  You need not require recipients to copy the
    Corresponding Source along with the object code.  If the place to
    copy the object code is a network server, the Corresponding Source
    may be on a different server (operated by you or a third party)
    that supports equivalent copying facilities, provided you maintain
    clear directions next to the object code saying where to find the
    Corresponding Source.  Regardless of what server hosts the
    Corresponding Source, you remain obligated to ensure that it is
    available for as long as needed to satisfy these requirements.

    e) Convey the object code using peer-to-peer transmission, provided
    you inform other peers where the object code and Corresponding
    Source of the work are being offered to the general public at no
    charge under subsection 6d.

  A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.

  A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling.  In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage.  For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product.  A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.

  "Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source.  The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.

  If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information.  But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).

  The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed.  Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.

  Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.

  7. Additional Terms.

  "Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law.  If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.

  When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it.  (Additional permissions may be written to require their own
removal in certain cases when you modify the work.)  You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.

  Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:

    a) Disclaiming warranty or limiting liability differently from the
    terms of sections 15 and 16 of this License; or

    b) Requiring preservation of specified reasonable legal notices or
    author attributions in that material or in the Appropriate Legal
    Notices displayed by works containing it; or

    c) Prohibiting misrepresentation of the origin of that material, or
    requiring that modified versions of such material be marked in
    reasonable ways as different from the original version; or

    d) Limiting the use for publicity purposes of names of licensors or
    authors of the material; or

    e) Declining to grant rights under trademark law for use of some
    trade names, trademarks, or service marks; or

    f) Requiring indemnification of licensors and authors of that
    material by anyone who conveys the material (or modified versions of
    it) with contractual assumptions of liability to the recipient, for
    any liability that these contractual assumptions directly impose on
    those licensors and authors.

  All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10.  If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term.  If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.

  If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.

  Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.

  8. Termination.

  You may not propagate or modify a covered work except as expressly
provided under this License.  Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).

  However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.

  Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.

  Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License.  If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.

  9. Acceptance Not Required for Having Copies.

  You are not required to accept this License in order to receive or
run a copy of the Program.  Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance.  However,
nothing other than this License grants you permission to propagate or
modify any covered work.  These actions infringe copyright if you do
not accept this License.  Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.

  10. Automatic Licensing of Downstream Recipients.

  Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License.  You are not responsible
for enforcing compliance by third parties with this License.

  An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations.  If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.

  You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License.  For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.

  11. Patents.

  A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based.  The
work thus licensed is called the contributor's "contributor version".

  A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version.  For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.

  Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.

  In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement).  To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.

  If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients.  "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.

  If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.

  A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License.  You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.

  Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.

  12. No Surrender of Others' Freedom.

  If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all.  For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.

  13. Use with the GNU Affero General Public License.

  Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work.  The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.

  14. Revised Versions of this License.

  The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

  Each version is given a distinguishing version number.  If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation.  If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.

  If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.

  Later license versions may give you additional or different
permissions.  However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.

  15. Disclaimer of Warranty.

  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. Limitation of Liability.

  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.

  17. Interpretation of Sections 15 and 16.

  If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.

                     END OF TERMS AND CONDITIONS


Type of format	Format	Example Value
Basic calendar format	`YYYYMMDD`	`19950215`
Extended calendar date	`YYYY-MM-DD`	`1995-02-15`
Basic ordinal date	`YYYYDDD`	`1995046`
Extended ordinal date	`YYYY-DDD`	`1995-046`
Basic week date	`YYYYWwwD`	`1995W063`
Extended week date	`YYYY-Www-D`	`1995-W06-3`
Basic local time	`hhmmss`	`051427`
Extended local time	`hh:mm:ss`	`05:14:27`
Basic local time (fractional)	`hhmmss.sssssssss`	`051427.812479168`
Extended local time (fractional)	`hh:mm:ss.sssssssss`	`05:14:27.812479168`
Basic UTC time	`hhmmssZ`	`101427Z`
Extended UTC time	`hh:mm:ssZ`	`10:14:27Z`
Basic UTC time (fractional)	`hhmmss.sssssssssZ`	`101427.812479168Z`
Extended UTC time (fractional)	`hh:mm:ss.sssssssssZ`	`10:14:27.812479168Z`
Basic offset time	`hhmmss+hhmm`	`051427-0500`
Extended offset time	`hh:mm:ss+hh:mm`	`05:14:27-05:00`
Basic offset time (frac)	`hhmmss.sssssssss+hhmm`	`051427.812479168-0500`
Extended offset time (frac)	`hh:mm:ss.sssssssss+hh:mm`	`05:14:27.812479168-05:00`
Combined basic date and time	`YYYYMMDDThhmmss`	`19950215T051427`
Combined extended date time	`YYYY-MM-DDThh:mm:ss+hh:mm`	`1995-02-15T05:14:27-05:00`
Combined basic date time (frac)	`YYYYMMDDThhmm.ss+hhmm`	`19950215T051427.81-0500`

choice.jpg		mandelbrot2.jpg

A simple, yet powerful choice selector		Resizeable, Mandelbrot set computed in GnuCOBOL

Topic	Link
Up and running	https://www.youtube.com/watch?v=3lx9ZeP47Hg
Copybook to JSON	https://www.youtube.com/watch?v=RTqMMWOyvuU
COBOL on the Cloud	https://www.youtube.com/watch?v=Wn2tE4VVYYQ
COBOL as FaaS	https://www.youtube.com/watch?v=rsezV9vcXek

1.5.1 repology¶

1.5.2 kiska.net repository¶

1.5.3 sourceforge¶

1.5.4 Windows™ MinGW¶

1.5.4.1 Older cuts¶

1.5.5 MinGW official¶

1.5.6 Windows™ Visual Studio vc11 native¶

1.5.7 Mario’s file pile¶

1.5.8 Online compilers¶

1.10.1 Educational benefits of the test suite¶

1.11.1 What’s missing?¶

1.12.1 telco billing¶

1.12.1.1 Roger’s telco benchmark update¶

1.13.1 GnuCOBOL with FastCGI¶

1.13.2 FastCGI without changing #includes¶

1.13.3 running on hosted services¶

1.14.1 GTK¶

1.14.2 A GTK server¶

1.14.3 Tcl/Tk¶

1.14.4 Vala, WebKit¶

1.14.5 Redirect to browser¶

1.14.6 X11¶

1.14.7 Java AWT¶

1.14.8 XForms¶

1.14.9 Agar¶

1.15.1 Gix-IDE¶

1.15.2 OpenCOBOLIDE¶

1.15.3 Geany¶

1.16.1 FAQ author’s take on it¶

1.16.2 Nagasaki Prefecture¶

1.16.3 Stories from Currey Adkins¶

1.16.4 Public Accounting¶

1.16.5 ACAS¶

1.16.6 A platform port¶

1.16.7 The COBJAPI angle¶

1.16.8 A thank-you note¶

1.16.9 Commercial Support¶

1.17.1 COBOL programming examples¶

1.17.2 COBOL Programming Course¶

1.17.3 Up and Running with COBOL¶

1.17.4 jaymoseley.com¶

1.17.5 tutorialspoint.com¶

1.17.6 newcobug.com¶

1.17.7 SimoTime Technologies¶

1.18.1 The GnuCOBOL Programmer’s Guide¶

1.18.2 The OpenCobol Programmer’s Guide¶

1.19.1 Contribution Guidelines¶

1.19.2 Translation Efforts¶

1.22.1 A ROBODoc experiment¶

1.22.2 A Doxygen pass across the compiler source code¶

1.22.3 A Doxygen pass, application with compiler suite¶

1.22.4 What was used to colour the source code listings?¶

1.25.1 At GNU¶

1.25.2 on SourceForge¶

1.25.3 add1tocobol¶

1.25.4 Stickleback¶

1.25.5 other places¶

1.28.1 Really?¶

1.28.2 A 5-7-5 haiku?¶

1.28.3 One in cbrain¶

2.1.1 Published Standards¶

2.1.2 The Gartner estimate¶

2.2.1 COBOL 2014¶

2.4.1 Building the 2.2 stable release¶

2.4.2 Building from trunk¶

2.4.3 Building the 2.2 stable version¶

2.4.4 Building GnuCOBOL 3.0 release candidates¶

2.4.5 occurlrefresh¶

2.4.6 Building the reportwriter version¶

3.1.1 From source with GNU/Linux¶

3.1.2 Debian¶

3.1.3 Ubuntu¶

3.1.4 Fedora¶

3.1.5 Windows¶

3.1.5.1 Older news, pre 2020¶

3.1.6 Macintosh¶

3.1.6.1 homebrew¶

3.1.7 CentOS¶

3.1.8 MINIX¶

3.2.1 GnuCOBOL build time environment variables¶

1.28.3 One in cbrain ¶