4.1.116 CONTENT¶
A CALL clause that controls how arguments are passed.
CALL "subprog" USING BY CONTENT alpha-var.
alpha-var will not be modifiable by subprog, as a copy is passed.
See REFERENCE and VALUE for the other CALL argument controls.
GnuCOBOL FAQ¶
Dedicated to the living memory of Roger While (1950-2015)
| Authors: | Brian Tiffin [btiffin]
Answers, quotes and contributions:
Ganymede, Rildo Pragana, Bill Woodger, Federico Priolo, Arnold Trembley
Frank Swarbrick, Angus, DamonH, Parhs, Gerald Chudyk, Steve Williams,
László Erdős, Reinhard Prehofer, Edward Hart, many others.
Compiler by:
Roger While [Roger],
Keisuke Nishida [Keisuke],
Ron Norman [Ron],
Sergey Kashyrin [Sergey],
Simon Sobisch [human],
Philipp Böhme,
Joe Robbins,
Ed Hart,
Luke Smith,
Brian Tiffin,
(with the invaluable assistance of many others)
Special credits to
Gary Cutler author of the GnuCOBOL Programmers Guide
Joseph James Frantz for hosting and advocacy [aoirthoir]
|
|---|---|
| Version: | 2.1.175, July 21th, 2016 |
| Status: | never complete; like a limit,  |
| Copyright: | Copyright © 2008-2016 Brian Tiffin |
| ChangeLog: | ChangeLog |
| Acknowledgment: | Below is a copy of the long standing acknowledgment request that appears in all versions of the CODASYL COBOL Journal of Development and most ANSI/ISO COBOL standards. |
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:
The COBOL standard acknowledgment, with respect and gratitude.
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.
Many thanks to the original designers, supporting organizations, and individuals of the day.
Note
Regarding COBOL Standards, Official COBOL Standards: There are many references to standards in this document. Very few of them are technically correct references. Apologies to all the hard working men and women of the technical committees for this unintentional slight. For specific details on what wordings should be used please see What are the Official COBOL Standards?
1.1 What is GnuCOBOL?¶
GnuCOBOL is a free COBOL compiler. GnuCOBOL is a GNU software project.
GnuCOBOL implements a substantial part of the COBOL 85 and COBOL 2002 standards, as well as many extensions of the existent COBOL compilers.
GnuCOBOL translates COBOL into C and compiles the translated code using the configured C compiler, usually gcc. You can build your COBOL programs on various platforms, including Unix/Linux, Mac OS X, Microsoft Windows, OS/400, z/OS 390 mainframes, among others..
GnuCOBOL was OpenCOBOL. OpenCOBOL started around 2002, and on September 26th, 2013, GnuCOBOL was accepted and dubbed a GNU package by Dr. Richard Stallman. One day before the 30th anniversary of the GNU announcement.
The official page for GnuCOBOL is:
http://savannah.gnu.org/projects/gnucobol
A valuable reference, the GnuCOBOL Programmer's Guide can be
found at GnuCOBOL Programmers Guide.
The original OpenCOBOL Programmer's Guide can be found at
OpenCOBOL Programmers Guide.
In this author’s opinion, GnuCOBOL is a world class COBOL compiler, very capable with almost all of the COBOL 85 specifications, plus having some very internet ready, next generation potentials.
GnuCOBOL REDEFINES programming is the motto.
Coincidentally, that motto is compilable source code.
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 motto.cob
Hi
Ignore the tricky formatting, that was all for looks on a particular forum that only allows 52 characters on a line before scrolling. GnuCOBOL normally looks far more professional than the odd snippet of fun you may read in this document.
1.2 What is COBOL?¶
COBOL is an acronym for COmmon Business Oriented Language. This author has always thought of it as “Common Business” Oriented more than Common “Business Oriented”, but that emphasis is perhaps up to the reader’s point of view.
As an aside: I’d like to steal the O in COmmon, and haven’t found a suitable word as of yet. Common Originally Business Oriented Language, was tried, trying to connote “it’s been extended”, but it sounds diminishing, like GNU Cobol can’t do Business anymore. Which isn’t the case. So, the quest continues.
A discussion group posting on LinkedIn tweaked this again, Common Object Business Oriented Language. I like it. And with GnuCOBOL C++, perhaps Sergey can lead the charge/change.
Later... and even better, perhaps:
Common Objective Business Oriented Language.
A stable, business oriented language, that helps people meet the common objectives; across all the computing platforms, around the globe. That is not an official acronym or anything, just a suggestion.
1.3 How is GnuCOBOL licensed?¶
The compiler is licensed under the GNU General Public License.
The run-time library is licensed under GNU Lesser General Public License.
All source codes were copyright by the respective authors. With many thanks to Roger While and Keisuke Nishida for sharing their work with the world.
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.
What this licensing means, roughly, is:
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, MUST provide
access to source code and be licensed under the GNU GPL. Modifications to the
run time library code, if distributed to others, must also provide access to
the source code of the library changes, and be licensed under the LGPL. This
ensures that no one is allowed to close modified sources as their own, nor
deny anyone else the chance to copy and re-distribute the compiler source
code, including redistrubuted changes. If modified sources are personal, or
never distributed outside an organization, there is no burden to release
the source. 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.
Berkeley Data Base license:
Please note: this applies to default GnuCOBOL binary builds.
Any verion 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.
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.
Note
While GnuCOBOL can be held to a high standard of quality and robustness, the authors do not claim it to be a “Standard Conforming” implementation of COBOL.
1.4 What platforms are supported by GnuCOBOL?¶
OpenCobol 1.0 hosted on SourceForge.net, compiles on:
- All 32-bit MS Windows (95/98/NT/2000/XP)
- All POSIX (Linux/BSD/UNIX-like OSes)
- OS/X
GnuCOBOL 1.1, the current official release version has been built on
- MS Windows native
- MS Windows with Cygwin
- GNU/Linux
- POSIX Systems including OpenSolaris
- OS/X
- AS/400
- HP Integrity HPUX 11.23
- RS600 AIX 5
- 390 Mainframe z/OS OMVS/USS
- others, Raspberry Pi (quote was $35 for hardware, OS and GnuCOBOL)
1.5 Are there pre-built GnuCOBOL packages?¶
Yes. Debian APT, and RPM packages exist. Packages for NetBSD. Many.
Google opencobol packages for older builds, and gnu cobol for any late
breaking news.
A Debian Advanced Package Tool binary package exists for GnuCOBOL 1.1 as
open-cobol and lists dependencies of
- libc6 (>= 2.7-1),
- libcob1,
- libcob1-dev (= 1.0-1),
- libdb4.5 (>= 4.5.20-3),
- libdb4.5-dev,
- libgmp3-dev,
- libgmp3c2,
- libltdl3-dev,
- libncurses5 (>= 5.6+20071006-3)
Thanks to the gracious efforts of Bart Martens, bartm on Debian’s .org domain.
Fedora and RedHat yum repositories usually have open-cobol as a choice
for
yum install open-cobol
GnuCOBOL packages are slowly being introduced, and will likely see a revision from open-cobol-1.1 to GnuCOBOL 2.0 and gnucobol, after some release announcements and posting to GNU servers.
1.5.1 kiska.net repository¶
Also check out kiska.net for binary builds on various platforms. Thanks to Sergey Kashyrin, who is also the author of the version that emits C++ intermediates.
1.5.2 sourceforge¶
There are GnuCOBOL links at http://cobol.sourceforge.net
In particular, http://sourceforge.net/projects/cobol/files/open-cobol/ can come in handy, with sources and MinGW binaries at a minimum. Maybe more as time goes on.
1.5.3 Windows™ MinGW¶
Arnold Trembley put together an INNO installer, based on Gary Cutler’s MinGW builds of OpenCOBOL 1.1. Makes it pretty easy to get COBOL running on a PC. You can find it attached to SourceForge discussions, or at Arnold’s site:
1.5.4 MinGW official¶
An official GnuCOBOL project MinGW build, put together by Simon Sobisch, is stored on SourceForge, at
http://sourceforge.net/projects/open-cobol/files/gnu-cobol/1.1/ directly downloaded as
As the name implies, this complete compiler build includes Berkeley DB for ISAM, PDCurses for extended screen IO, and MPIR for the decimal arithmetic and other multiprecision math features of GnuCOBOL.
This build is now also included in Colin’s OpenCOBOLIDE.
1.5.5 Windows™ Visual Studio vc11 native¶
Paraphrased from some posts by Simon on the forge:
New upload of http://sourceforge.net/projects/open-cobol/files/gnu-cobol/2.0/gnu-cobol-2.0_nightly_r411_win32_vc11_bin.7z - works correctly now
http://sourceforge.net/projects/open-cobol/files/gnu-cobol/win_prerequistes/win_prerequistes_vc11.7z was uploaded, too
Keep an eye on http://sourceforge.net/projects/open-cobol/files/gnu-cobol/2.0/ for the latest snapshots.
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.
1.7 How complete is GnuCOBOL?¶
OpenCOBOL 1.0 implements a substantial portion of COBOL 85, supports many of the advances and clarifications of COBOL 2002, and includes many extensions in common use from Micro Focus COBOL, ACUCOBOL and other existent compilers.
GnuCOBOL 2.0 implements a more substantial portion of the COBOL 85 Dialect, COBOL 2002 and a growing number of vendor extensions. Some proposed COBOL 2014 features have also been implemented. Compatibility support includes:
- MF for Micro Focus
- IBM for IBM compatibility
- MVS
- BS2000
GnuCOBOL also includes some advanced features allowing source code such as
CALL "cfunction" USING BY REFERENCE ADDRESS OF VAR-IN-LINKAGE-SECTION.
Passing the equivalent of char**, pointer to pointer to char. Just as a small example of the level of coverage and flexibility provided by GnuCOBOL.
DISPLAY
FUNCTION UPPER-CASE(
FUNCTION SUBSTITUTE(
"This is the orginal string.";
"original"; "new"; "string"; "text"
)
)
To allow for substitution of mixed length strings, something not normally so easy in COBOL. The above will output:
THIS IS THE NEW TEXT.
Note
While GnuCOBOL can be held to a high standard of quality and robustness, the authors do not claim it to be a “Standard Conforming” implementation of COBOL.
1.8 Will I be amazed by GnuCOBOL?¶
This author believes so. For a free implementation of COBOL, GnuCOBOL may surprise you in the depth and breadth of its COBOL feature support, usability and robustness.
COBOL has historically been very secretive and low key. Its domain of use being very secretive and low key. COBOL programmers rarely work on systems that would allow for open internet chat regarding details, let alone existence. It is a tribute to the professionalism of these programmers that most people rarely, if ever, hear the name COBOL, a programming language with billions of lines of source code compiled and in production around the world over half a century.
GnuCOBOL is poised to change that historic trend, and allow for the long overdue sharing of wisdom that legions of COBOL developers have accumulated over 50 years of success and failure. The GnuCOBOL conversation may be more POSIX than mainframe, but there is now room to share, critique and pass on the hard lessons learned from critical systems computing. Given that millions of COBOL programmers kept billions of lines of COBOL source out of the press, surely some of the wisdom can be passed on in a way that keeps all the secrets secret while curious developers are exposed to COBOL outside the vaults.
1.9 Who do I thank for GnuCOBOL?¶
Many people. In particular Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, and Sergey Kashyrin.
See the THANKS file in the source code archive for more names of people that have worked on the OpenCOBOL, now GnuCOBOL, project. Roger points out that the list is woefully incomplete. To quote:
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.
1.10 Does GnuCOBOL include a Test Suite?¶
Why yes it does. 74 syntax tests, 170 coverage tests, and 16 data representation tests in the February 2009 pre-release.
88 syntax, 253 coverage, and 22 data tests in a 2010 cut. 456 tests in the 2014 sources, and growing. (501 tests in early 2015).
From a development tarball:
$ make check
will evaluate and report on the test suite. See make check listing for a current output listing of a test run.
make check is built with Autotools autotest, a Perl based test harness.
It supports a few options, one in particular:
$ TESTSUITEFLAGS='--jobs=4' make check
will run tests in parallel, pick a number appropriate to the number of cores.
A quad core pass with --jobs=4
00:24.86 elapsed 300%CPU
and without TESTSUITEFLAGS (some may be pre-cached etc...)
01:24.72 elapsed 100%CPU
85 seconds down to 25 seconds, when tested in parallel.
1.11 Does GnuCOBOL pass the NIST Test Suite?¶
Mostly. Not all. All attempted tests are passed. Over 9000.
The National Institute of Standards and Technology, NIST, maintained, and now archives a COBOL 85 implementation verification suite of tests. A compressed archive of the tests, last updated in 1993, to include Intrinsic Functions, can be found at
http://www.itl.nist.gov/div897/ctg/cobol_form.htm
GnuCOBOL passes many of the tests included in the NIST sponsored COBOL 85 test suite.
While the system successfully compiles over 400 modules, failing none of the over 9700 tests attempted; GnuCOBOL does not claim conformance to any level of COBOL Standard.
Instructions for use of the NIST suite is included in the build archive under:
tests/cobol85/README
Basically, it is a simple uncompress and make then sit back and relax.
The scripts run GnuCOBOL over some 424 programs/modules and includes thousands
of different, purposely complicated stress test passes.
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
With the addition of GLOBAL support, the GnuCOBOL-reportwriter pre-release fails none of the attempted tests.
The summary.log from a run in November 2013 with initial Report Writer support:
------ 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
This is up from the 1.1 Feb 2009 release count of 9082.
1.11.1 What’s missing?¶
GnuCOBOL-reportwriter does not include support for:
Advanced facilities:
CM - COMMUNICATION SECTION tests
and limits tests within the:
DB - Debugging facilities tests
OB - Obsolete facilities tests
sections.
1.12 What about GnuCOBOL and benchmarks?¶
COBOL has a legacy dating back to 1959. Many features of the COBOL standard provide defaults more suitable to mainframe architecture than the personal computer a 3rd millennium GnuCOBOL developer will likely be using.
GnuCOBOL, by default, generates code optimized for big-endian hardware.
Fairly dramatic speed improvements on Intel architecture can come from simple
USAGE IS COMPUTATIONAL-5 clauses in the DATA DIVISION.
1.12.1 telco billing¶
There is a benchmark posted at http://speleotrove.com/decimal/telco.html and thanks to Bill Klein [wmklein], there is a COBOL entry. From the source code listed below, you should only have to modify
Input-Output Section.
File-Control.
Select InFile Assign to
"C:\expon180.1e6".
Select OutFile Assign to
"C:\TELCO.TXT"
Line
Sequential.
to point to the correct filename for your local copy of the benchmark million entry file and a suitable OutFile name for a clean compile and run.
Update: There is a version tuned for GnuCOBOL, especially the ROUNDED NEAREST-EVEN support. It gives correct results for what would be common default GnuCOBOL settings and compiler configurations, and Banker’s Rounding. Listed below.
In summary, the benchmark reads a large input file containing a suitably distributed list of telephone call durations (each in seconds). For each call, a charging rate is chosen and the price calculated and rounded to hundredths. One or two taxes are applied (depending on the type of call) and the total cost is converted to a character string and written to an output file. Running totals of the total cost and taxes are kept; these are displayed at the end of the benchmark for verification.
A run on an older pentium 4 and the million number file gave:
$ 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
2 seconds for the short test, 12 for the long, on a fairly small machine.
A more recent 1.1 pre-release, on a dual quad-core Xeon box running Linux SLES 10 64-bit:
$ 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
3.4 seconds cache-hot, long test. Not bad.
With Bill’s permission, the benchmark code is listed here: (with the first few lines added for the benefit of an indent based code highlighter)
COBOL
bench
mark
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
.
Datafiles and other code listings are copyright Mike Cowlishaw and IBM, so go to the speleotrove site, linked above, for all the details.
I’ll opine; Bill’s COBOL is a LOT easier to read than the other entries, being C, C#, Java. (The Turbo Pascal link seems broken, can’t speak to the readability), but I’m calling COBOL for the win on this one, wire to wire.
1.12.1.1 Roger’s telco benchmark update¶
Update
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
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
.
1.13 Can GnuCOBOL be used for CGI?¶
Yes. Through standard IO redirection and the extended
ACCEPT ... FROM ENVIRONMENT ... feature, GnuCOBOL is more than capable
of supporting advanced Common Gateway Interface programming. See
How do I use GnuCOBOL for CGI? for a sample Hello Web program.
Also see Can GnuCOBOL display the process environment space?
Here’s a screenshot of GnuCOBOL running in Apache server CGI, in the Cloud as a Juju Charm.
More specially, this screenshot was taken on a Fedora 19, XFCE desktop with a libvirt VM install of Ubuntu 13.04, running Firefox and browsing a locally spawned cloud instance. where the instantiation of the Juju Charm creates another virtual machine, installs a base operating system, compiles and installs GnuCOBOL with Report Writer, builds up a small testsuite of CGI ready COBOL applications, installs everything, starts apache and serves up the pages.
And it all just works
1.13.1 GnuCOBOL with FastCGI¶
FastCGI can also work with GnuCOBOL. A small wrinkle in the tectonics is
that the standard IO C header file that is generated by cobc needs to be
swapped out for fcgi_stdio.h. This isn’t too bad, as cobc can be used
to generate intermediate C and after a quick text replacement, can then be
called a second time to compile the generated C code into an executable
suitable for placing in the web server space.
# 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
The CGI processing code then needs to add a simple looping structure internally.
*> 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
Some platforms (ala Cygwin) may need
call STATIC "FCGI_Accept" returning fastcgi-accept
to get proper linkage with libfcgi.
1.13.2 running on hosted services¶
For those developers looking to serve GnuCOBOL applications on hosted systems
without super user privileges, see How do I use LD_RUN_PATH with GnuCOBOL?
for some pointers on getting hosted executables installed properly.
LD_RUN_PATH can make it easier for CGI programs to find a locally
installed libcob runtime, something a hosted service may not provide.
1.14 Does GnuCOBOL support a GUI?¶
Yes, but not out of the box. There is not currently (January 2016) anything that ships with the product.
Third party extensions for Tcl/Tk and linkage to GTK+ and other frameworks do allow for graphical user interfaces. See Does GnuCOBOL support the GIMP ToolKit, GTK+? and Can GnuCOBOL interface with Tcl/Tk?.
1.14.1 GTK¶
The expectation is that GTK+ will be completely bound as a callable interface. That is currently (January 2016) not the case, with perhaps 2% of the GTK+ functionality wrapped (but with that 2%, fully functional graphical interfaces are possible).
An experimental FUNCTION-ID wrapper is working out well
This procedure division: (part the of the library self-test)
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.
produced
with the shell vte, being a fully functional terminal widget.
9 moves for a gui.
1.14.2 Tcl/Tk¶
The Tcl/Tk engine is already quite complete but does place most of the burden of GUI development squarely on the Tk side.
1.14.3 Vala, WebKit¶
Vala will also open up a quick path to GUI development with GnuCOBOL. There is already an embedded web browser using the Vala bindings to WebKit. See Can GnuCOBOL interface with Vala? for a lot more details.
1.14.4 Redirect to browser¶
GDK 3 supports a backend called Broadway. Transform GTK desktop applications to websockets and HTML5 web guis. Here is a GnuCOBOL sample, written to explore the desktop GTK calendar widget, redirected to a browser using GDK Broadway, with clicks in the browser window invoking GnuCOBOL graphical event callback handlers, no change to the desktop application source code.
More on this in A GTK+ calendar
Here is a GTK based interactive periodic table of the elements, written in GNU Cobol (6 lines of C support code), linked to GTK+ 3.0, and running with
broadwayd :1 &
BROADWAY_DISPLAY=:1 GDK_BACKEND=broadway ./cobweb-periodic
Without recompiling, the events and graphics are handled by the browser.
See cobweb-periodic listing for the source code that produced that image. Please note that with recent changes to GTK+ theming, as of 3.16, the buttons are no longer properly coloured. New code needs to be written to provide CSS property management for GTK+ button colours.
1.14.5 X11¶
There are also a few examples of using X11 directly from GnuCOBOL. See Can GnuCOBOL interface with X11? for details.
1.14.6 Java AWT¶
Another very powerful option for graphics programming is available with the COBJAPI user defined function repository. See What is COBJAPI? for more information.
1.15 Does GnuCOBOL have an IDE?¶
- IDE
- Interactive Development Environment
Yes. (And no, there is no IDE that ships with the product but there is a contributor interactive development environment, written explicity for GnuCOBOL). There are also other IDEs that support COBOL.
The add1tocobol team was working to create extensions for the GNAT Programming Studio. This was working out quite nicely, but more effort would be required to make this a viable alternative for GnuCOBOL developers.
See Can the GNAT Programming Studio be used with GnuCOBOL? for more information. Update: this effort is likely abondoned. See OpenCOBOLIDE, below, for the current leading, and project approved, GnuCOBOL IDE.
There is also the Eclipse IDE and a major project for integrating COBOL but this will not be GnuCOBOL specific.
Many text editors have systems in place for invoking compilers. SciTE, Crimson Editor, Vim and emacs, to name but a few of the dozens of programmer text editors that support edit/compile/test development cycles. See Kate for some notes and details on the GnuCOBOL development potentials in the KDE Advanced Text Editor.
See Does GnuCOBOL work with make? for some information on command line compile assistance.
1.15.1 OpenCOBOLIDE¶
There is a GnuCOBOL specific IDE getting good press, posted in PyPi at https://pypi.python.org/pypi/OpenCobolIDE
By Colin Duquesnoy. He just released version 4.6.2 (June 2015), and it now includes a MinGW binary build that Simon put together for developers running Microsoft Windows. (see What is the current version of GnuCOBOL?)
From Colin:
OpenCobolIDE v4.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)
Nice system. People like it. From Robert W. Mills, author of cobolmac,
(See Does GnuCOBOL support source code macros?)
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.
It is best to visit the LaunchPad cobcide parent pages for the latest, but as mentioned above, version 4.6.2 source code is available at
1.15.2 Geany¶
Geany is a light weight GTK based development environment and has surprisingly pleasant COBOL support. http://www.geany.org/
There are other IDEs that support COBOL. Google may respond with a list that suits taste.
1.16 Can GnuCOBOL be used for production applications?¶
Depends. GnuCOBOL is still in active development. Feature coverage is growing, and while the current implementation offers great coverage, applicability to any given situation would need to be analyzed, and risks evaluated, before commitment to production use.
The licensing allows for commercial use, but GnuCOBOL also ships with notice of indemnity, meaning that there are no guarantees when using GnuCOBOL, directly or indirectly.
And yes, GnuCOBOL is used in production environments.
See the chapter on GnuCOBOL in production for a growing list of details regarding GnuCOBOL in production environments.
From [Roger]:
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.
1.16.1 FAQ author’s take on it¶
If GnuCOBOL is going to break, it’s going to break right in front of you, during compiles. If something is not fully supported, GnuCOBOL fails very early on in the trial process. With most COBOL 85 and many nifty COBOL 2014 features, if cobc doesn’t complain during compiles, then GnuCOBOL is a very trustworthy and robust COBOL. If you work with newer features, beyond 1989 instrinics, there may be more reason to keep an eye on things. It would be due diligent to run comprehesive tests before committing to mandatory regulatory reporting systems or other life and core critical deployments. Be prepared to scan emitted C source codes. Know that GnuCOBOL is a free software system. Critical issues can be, are being, and will be addressed. No permission is required to try and make GnuCOBOL a better, more reliable system, and there is a host of very smart people willing to pitch a hand forwarding that goal.
1.16.2 Nagasaki Prefecture¶
Reported on opencobol.org, The Nagasaki Prefecture, population 1.44 million and 30,000 civil employees is using GnuCOBOL in support of its payroll management system. A team of 3 ported and maintain a suite of 200 COBOL programs, mingled with Perl and specialized reporting modules, running on Nec PX9000 big iron and Xeon servers.
1.16.3 Stories from Currey Adkins¶
Another post from opencobol.org in April 2009, reprinted with permission.
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
Another reference by Jim, some 6 months later in February 2010, which seems to be enough time for any rose-coloured glass effect to have worn off if it was going to.
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
I hope people don’t mind a little advertising in this FAQ, but Jim has done a lot for GnuCOBOL, and his company is a community minded company. http://curreyadkins.com/custom-programming-linux-php-apache-open-source/
1.16.4 Public Accounting¶
Another from opencobol.org
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.
1.16.5 ACAS¶
From Vincent Coen, also author of the CobXRef utility used by cobc -Xref.
Applewood Computers Accounting System.
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.
1.16.6 A platform port¶
From SourceForge:
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.
1.16.7 The COBJAPI angle¶
With László Erdős’s COBJAPI contribution, an entirely new way of programming COBOL has appeared. Rod Gobby was impressed enough to take on the task of porting his company software inventory to this new system.
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
Another quote from Oscar on SourceForge
...
this is amazing what you can do with this compiler and now that java GUI
can be invoked using COBJAPI i feel so great.
See What is COBJAPI? for some details on this very powerful sub-system.
1.16.8 Commercial Support¶
Although we’d rather that free COBOL is also fiscally free; anyone needing commercially backed technical support or development assistance can contact Open COBOL by the C Side. OCCSide Corporation.
Full disclosure: This author is a involved in the corporation, and we maintain a contact and project management space at http://occside.peoplecards.ca/
1.17 Where can I get more information about COBOL?¶
The COBOL FAQ by William M Klein is a great place to start.
A google of the search words “COBOL” or “GnuCOBOL” or “OpenCOBOL” are bound to lead to enough days worth of reading of in-depth articles, opinions and technical information to satisfy the greatest of curiosities.
Please ignore the “COBOL is dead” tone that many of these articles may be permeated with. COBOL isn’t dead, but it is usually used in domains that require the highest level of secrecy, so the billions of lines of production COBOL in use around the globe, rarely, if ever, get mentioned in internet chatter. Hopefully by reading through this document, and keeping an open eye on reality versus trends, you will see the importance that COBOL has held, does hold, and will hold in the computing and programming arena.
A new spec for COBOL 2014 was Published in May 2014 by Donald Nelson of ISO/IEC with adoption by ANSI in October 2014. Not dead, or dying or any such thing. With free COBOL, in GnuCOBOL, it’s still dancing.
As a side note, when the original specification was being written, one of the committee members, Howard Bromberg commissioned a tomestone, in 1960. Ignore the trend setter tones and look to the reality. http://www.computerhistory.org/fellowawards/hall/bios/Grace,Hopper/
This is highly subject to change, but a Draft of 2014 is/was available at http://www.cobolstandard.info/j4/index.htm and in particular http://www.cobolstandard.info/j4/files/std.zip
Note
While GnuCOBOL can be held to a high standard of quality and robustness, the authors do not claim it to be a “Standard Conforming” implementation of COBOL.
1.17.1 COBOL programming examples¶
For COBOL code samples, (aside from the listings included in this document, and with a much wider range of authoring style), the Rosetta Code website is a very good reference. See Rosetta Code for more information on this comprehensive programming language resource.
1.17.2 COBOL Programming Course¶
One of the preeminent COBOL learning resources on the internet, are the tutorials, example programs, COBOL programming exercises, lecture and other notes written for the Department of Computer Science and Information Systems of the University of Limerick, by Michael Coughlan.
http://www.csis.ul.ie/cobol/ for all the links, and
http://www.csis.ul.ie/cobol/course/Default.htm for most of the courseware links, but don’t miss out on the other pages linked on the “All Things COBOL” main page. These pages are over a decade old, and like all things COBOL, still very relevant at that young of an age.
1.17.3 Up and Running with COBOL¶
Hosted by Peggy Fisher, and Lynda.com, there is a very well done set of video tutorials available for getting Up and Running with COBOL. Peggy runs through setting up GnuCOBOL with Windows and Notepad++, and then follows up with
- Describing Data
- Control Structures
- Sequential Files
- Advanced Sequential Files
- Direct Access files
- Tables in COBOL
- String Handling
Well spoken, well paced. About 50 videos, taking a little over 3 hours start to finish.
Recommended for anyone wanted to get setup with GnuCOBOL on Windows, and a recommended share to anyone looking to get into COBOL programming in general.
Peggy touches on mainframe issues when discussing some COBOL issues, so this is a fairly solid start for anyone interested in COBOL programming.
There is a scrolling transcript that keeps pace with the dialogue, and these are professional grade vidoes.
https://www.lynda.com/COBOL-tutorials/Up-Running-COBOL/411377-2.html
1.17.4 jaymoseley.com¶
Jay Moseley has written up quite a few COBOL related tutorials, and has added a lot to the world of the Hercules System/390 emulator. He dug in and wrote up bootstrapping instructions for old MVS releases so people can experiment with versions of big iron operating systems on home computers. Including getting a public domain copy of a 1972 version of IBM ANS COBOL up and running.
See Hercules for more details.
Jay has also added a GnuCOBOL page to his large mix of information pages.
http://jaymoseley.com/gnucobol/index.html
You’ll find sample programs for parsing CSV, displaying the number of days between dates, and lots more.
See REPORT for a very complete sample and introduction to using the ReportWriter features that are available in the reportwriter branch of the GnuCOBOL source tree.
1.17.5 tutorialspoint.com¶
There is an online learning centre, tutorialspoint.com Simply Easy Learning, and they have posted courseware for COBOL, JCL, and many other topics.
Before reading any further, note this critique, from Bill Woodger (July, 2015):
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.
As you can tell, I disagree with not pointing out the tutorialspoint tutorial, but you will likely be much better off starting with Micheal Coughlan’s CSIS tutorials, listed above.
The COBOL course includes source listings with a Try It button, OpenCOBOL used in the background to run compiles and display results to the web forms. (Once GnuCOBOL 2.0 makes its way into the main free software distribution repositories, they will very likely upgrade to the latest builds)
They also include instructions for setting up Hercules, a System/370 emulator, and include IBM MVS samples, including JCL listings to launch UCOB compiles. The Hercules samples are “at home only” and have not been linked to the web form Try It buttons. Any COBOL tried online will be passed through a GnuCOBOL compiler, and will, by neccesity, only work with sources supported by GnuCOBOL (or more accurately, OpenCOBOL pre-release 1.1).
1.17.6 newcobug.com¶
After the passing of Thomas Perry in 2014, cobug.com went off the air. It is archived in the Wayback Machine, and those pages became the starting point for Robert Skolnick’s new newcobug.com site.
https://web.archive.org/web/20140108215107/http://www.cobug.com/cobol.html
cobug.com was for many years, a go to place for all things COBOL related, in particular a vendor agnostic, but still commercially oriented set of COBOL pages.
Robert will be trying to ensure the continuity of the site, and modernizing it along the way, at http://newcobug.com. He has even gone as far as adding a subdomain, (which we have not yet taken full advantage of), for GnuCOBOL related COBOL issues. http://gnucobol.newcobug.com. Robert, being involved with a large internet service provider in Brazil, is well versed in all things internet, and newcobug.com has a very good chance of becoming the new cobug.com.
1.18 Where can I get more information about GnuCOBOL?¶
Current project activities are at SourceForge.
The discussions on the opencobol.org website permanently redirected to SourceForge, have been archived at http://open-cobol.sourceforge.net/files/opencobol.org-archive.tar.gz (2Mb) and as plain text at http://open-cobol.sourceforge.net/files/opencobol.org-archive.txt (8Mb).
add1tocobol.com is a place to find out about a few of the fan initiatives. (An older website is readonly at http://oldsite.add1tocobol.com)
1.18.1 The GnuCOBOL Programmer’s Guide¶
A very well written and masterful OpenCOBOL reference and COBOL development guide. By Gary Cutler, GnuCOBOL Programmers Guide.
1.18.2 The OpenCobol Programmer’s Guide¶
Is still available, at OpenCOBOL Programmers Guide.
1.19 Can I help out with the GnuCOBOL project?¶
Absolutely. Visit the SourceForge project space and either post a message asking what needs to be done, or perhaps join the development mailing list to find out the current state of development. See Is there a GnuCOBOL mailing list? for some details. GnuCOBOL is an official GNU, GPL licensed, free software project, with a small team that handles the read/write permissions on SourceForge. The project is very open to code submissions. Having this central point of development allows for the consistency and the very high level of quality control enjoyed by GnuCOBOL users.
1.19.1 Contribution Guidelines¶
First to clarify a little bit. The GnuCOBOL “project” has two parts. The
official GnuCOBOL compiler source tree, and external free software
contributions, currently held in a source tree named contrib. Ok three
parts; from the point of view of the “project”, we will gladly reference free
software, commentary, and other free resources related to GnuCOBOL and COBOL by
simple request or notice from authors. The keyword is free, freedom free. In
term of the “project”, free COBOL is the main theme. Terminology wise, the
“project” encompasses more than the GnuCOBOL project, a name normally
associated with the official source tree, but being only a small part of the
big picture.
Officially, GnuCOBOL is a GNU project, so we will abide by the rules and recommendations provided by this very successful free software foundation. Write access to the sources is restricted to those that have signed legal copyright transfer documents, noted below.
GnuCOBOL is also a COBOL project. Not all contributions are part of the legally copyrighted GnuCOBOL sources, owned by the Free Software Foundation, Inc. Be that code, documentation, or other media. Contributions can be made under other forms and licensing, and they are addressed separately. No blocks will be put in place of anyone wanting to help, aside from the overriding concerns that pay homage to the principles of free software.
The GNU recommendations can be found at http://www.gnu.org/prep/standards/standards.html which includes
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.
There is more commentary on the need for the inconvenience and a lot more in the GNU Coding Standards, , but again, the “project” is more than the compiler project.
That’s GNU, and contributions to the GnuCOBOL source tree. Contributions outside that tree are also welcome, as long they count as free software.
GnuCOBOL adds, from the project lead, Simon Sobisch, human;
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=).
The rule for project approved samples can be seen as:
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.
And that’s for code.
Full disclosure: I’ve been writing samples for this FAQ that usually compile warning free with -W by adding scope terminators with END-DISPLAY, END-ACCEPT, END-COMPUTE etc. I thought approved samples followed the MUST rule.
It has been pointed out that a few of these scope terminators aren’t just more typing, they also clutter long understood source code constructs when there are no conditional imperatives such as ON EXCEPTION.
DOH! 2008 through 2015. I don’t really want to count how many hours have been spent typing END-DISPLAY into code examples. As of Oct 2015, there will be less of those.
Other contributions include cheerleading, bug reports, discussions, notice of free COBOL that works with the compiler, or should, but needs porting, etc.
And a big one, which will require signatures for reassignment, internationalization and translations.
1.19.2 Translation Efforts¶
A new project has started to see native language support in the cobc
compiler and run-time systems. Skip ahead a little to see the links for the new
efforts. What follows in hitorical information, just for completeness.
From Simon, some many moons ago, when he went by the nickname human.
Subject: OC in your native language - translators needed
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 724) 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.
Later edit
For a new translation create a new catalogue from the pot file. I encourage everybody to use a GUI for that. Some explanations how to do that with my favourite language file editor [url=http://www.poedit.net/]Poedit[/url] and some general instructions:
- File->New catalogue from POT-file (choose latest open-cobol.pot)
- Insert project name: “open-cobol 2.0” and the rest as needed
- Save file with chosen language abbreviation like it is placed in http://www.iana.org/assignments/language-subtag-registry
- Start translation
Some hints for Poedit first-time-users:
- Choose the string you want to translate in the upper pane.
- Translate the text in the lower pane.
- Always keep special characters like %s, %d, n, ... The % are place holders (values will be inserted there by OpenCOBOL). n is a line break, t a tab, etc
- Use [ALT]+[C] often. It copies the original string to the translation field where you can change what’s needed. This function can be found in edit menu, too.
- If you’re not sure if one of the translations is correct mark it as fuzzy with [ALT]+[U] or via edit menu.
Current assignments of translations: fr: eraso (finished [updates will be needed later]) [earlier: Bear (maybe aouizerate, too)] hi: Yanni de: erstazi es: jcurrey (finished [updates will be needed later]) ja: minemaz (later) it: ?federico?
OK, here is the http://www.filedropper.com/open-cobol]pot-file from 11-09-06.
human
Update: March 2015
The GnuCOBOL translation effort will be included in an official translation project. Thanks to the many volunteers there. From Simon:
http://translationproject.org/
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.
...
Later:
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.
Activity will take place on http://translationproject.org
To try Spanish messaging, see Setting Locale, basically export
LC_MESSAGES=es_ES before calling the compiler.
And please note that these translations are only the compiler and libcob run-time messages, not COBOL syntax or reserved word spellings in source code. COBOL is, by specification, an English programming language.
1.20 Is there a GnuCOBOL mailing list?¶
Yes. The GnuCOBOL development mailing list is graciously hosted by
SourceForge. The ML archive is available at
http://sourceforge.net/p/open-cobol/mailman/open-cobol-list/
and once you have subscribed, the list will accept messages at the
open-cobol-list email destination at lists.sourceforge.net.
1.21 Where can I find more information about COBOL standards?¶
The COBOL 85 standard is documented in
- ANSI X3.23-1985
- ISO 1989-1985
- ANSI X3.23a-1989
- ANSI X3.23b-1993
This is highly subject to change, but a Draft of COBOL 2014 is/was available at http://www.cobolstandard.info/j4/index.htm and in particular http://www.cobolstandard.info/j4/files/std.zip
In May 2014, the new specification for COBOL 2014 was Published by ISO/IEC. The document was approved in early summer, and adopted by ANSI in Octber, 2014.
Note
While GnuCOBOL can be held to a high standard of quality and robustness, the authors do not claim it to be a “Standard Conforming” implementation of COBOL.
1.22 Can I see the GnuCOBOL source codes?¶
Absolutely. Being a free software system, all sources that are used to build the compiler are available and free.
Visit http://sourceforge.net/p/open-cobol/code/HEAD/tree/ to browse the current SVN repository.
The SourceForge Files section has links to older release and pre-release archives.
Most distributions of GNU/Linux will also have source code bundles. For example
$ apt-get source open-cobol
on Debian GNU/Linux will retrieve the most recent released package sources.
1.22.1 A ROBODoc experiment¶
A ROBODoc experimental project to document the source codes is hosted at ocrobo. See ROBODoc Support for a sample configuration file.
The ROBODoc homepage is at http://rfsber.home.xs4all.nl/Robo/robodoc.html.
Frans accepted changes to the main ROBODoc source tree, hosted at https://github.com/gumpu/ROBODoc to be more friendly with COBOL sourcecode, dashes in names being the biggest change.
Downloads of versions beyond 4.99.42 of ROBODoc will be COBOL friendly when
passed the --cobol command line option. ROBODoc is in the Fedora package
repos and work is in progress to have this package re-included in Debian
repositories.
1.22.2 A Doxygen pass across the compiler source code¶
This is mentioned elsewhere, but the GnuCOBOL compiler source code bundle works beautifully with Doxygen. Mix application and compiler sources for overwhelmingly complete call graphs.
Is there GnuCOBOL API documentation?
Dimitri van Heesch’s 1.7.4 release of Doxygen, http://www.doxygen.org was used to produce http://opencobol.add1tocobol.com/doxy/.
1.22.3 A Doxygen pass, application with compiler suite¶
Along with Gary’s OCic.cbl http://opencobol.add1tocobol.com/doxyapp/ to
demonstrate how easy it is to generate world class, audit friendly source
code documentation, drilled right down to how the COBOL run-time is interacting
with the operating system.
1.22.4 What was used to colour the source code listings?¶
I wrote a Pygments lexer, mushed it into a local copy of Pygments and then call a rst2html-pygments.py program. Requires a fair amount of mucking about. See ReStructuredText and Pygments for some details.
As of January 2013, the COBOL lexer is in mainline Pygments. No more mucking about required. Georg Brandl did a wonderful job of refactoring the COBOL highlighter into his Pygments system. Many thanks to Georg, Tim and team Pocoo.
https://bitbucket.org/birkenfeld/pygments-main/pull-request/72/adding-an-opencobol-lexer
This is now included on SourceForge. In the discussion groups, source code can be highlighted using SourceForge markup. A blank line, a line starting with six tildes, another line starting with two colons, followed by a language tag. Many, available, but for fixed form COBOL use cobol, for less indented, free form COBOL, use cobolfree. Then code, then six closing tildes.
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.
Giving:
SAMPLE
* Next big thing
IDENTIFICATION DIVISION.
PROGRAM-ID. big-thing-42.
PROCEDURE DIVISION.
DISPLAY "ok, what now?"
GOBACK.
and
PERFORM 3 TIMES
DISPLAY "Yeah, that!"
END-PERFORM
This is a context free regular expression colourizer. It gets true COBOL wrong, but mostly right, for the benefit of colour.
Initial indentation counts. Code starting with column 8 followed by a comment in column 7 can confuse the indentation detection. That can be fixed by adding a sequence number tag in columns 1 through 6 to the first line of code in the listing.
1.23 What happened to opencobol.org?¶
Due to robot spam, new registrations on opencobol.org were disabled in 2012.
The active site is now hosted by SourceForge, at
http://sourceforge.net/projects/open-cobol/
In case anyone is wondering, as of May 2014, 1 (one) entry has shown up in the spam folder and required moderation. Thanks, SourceForge; frees up many hours of volunteer time. Many. There was spam in the reviews, well, hit count hounds, and even those seem to be dealt with, quietly in the background. Nice.
opencobol.org was redirected to the SourceForge site in October of 2015. There is an archive of the forum posts, and knowledge base, stashed away at
http://open-cobol.sourceforge.net/files/opencobol.org-archive.txt
which is about 8 megabytes of text. Sadly this archive does not include all the metadata (author, and timestamps) that were included with the forum entries, but is still a treasure trove of GnuCOBOL related technical wisdoms.
1.24 What is COBOL in Latin?¶
I came up with Publicus Negotiatio Cursus Lingua, and then smarter people suggested:
- negotium orientatur lingua plebeius
- generalis negotium pertineo lingua
- de communi codice pro calculorum negotii
- codex communis pro calculorum negotii
I like the last one. ccpcn, pronounce that as kick-pickin’.
Thanks to Ray, Paul, and Daniel on LinkedIn.
1.25 Where can I find open COBOL source code?¶
Although open source COBOL is still rare, and free even rarer, that is slowly changing. This entry will be a perpetually growing list, until the universe is at peace.
Last updated: June 11th, 2013. If you know of a worthy entry, drop me a note.
1.25.1 At GNU¶
1.25.2 on SourceForge¶
GnuCOBOL is hosted on SourceForge at http://sourceforge.net/projects/open-cobol/
Other projects include:
- http://sourceforge.net/projects/cobcurses/ A curses screen design utility for OpenCOBOL
- http://sourceforge.net/projects/koopa/ a COBOL parser (generator)
- http://sourceforge.net/projects/cobol/ the open COBOL Utilities Project
- http://sourceforge.net/projects/record-editor/ which accepts COBOL copy books
- http://sourceforge.net/projects/cobol2html/ which auto documents COBOL
- http://sourceforge.net/projects/cobolxmlfilepar/ a one pass XML parser
- http://sourceforge.net/projects/acas/ Applewood Computers Accounting System
- http://sourceforge.net/projects/geekcode21gener/ Geekcode generator, written in COBOL
- http://sourceforge.net/projects/ocic-gui/ Gary Cutler’s Compiler assistant, rewritten in a C# gui
- http://sourceforge.net/projects/apac-accounting/ a Business Management system
1.25.3 add1tocobol¶
The good folk that host this FAQ, also host http://oldsite.add1tocobol.com and http://add1tocobol.com
1.25.4 Stickleback¶
Wim Niemans’ Project Stickleback, http://stickleback.nlbox.com/
1.25.5 other places¶
- https://sites.google.com/site/cobolunit/ a Unit Testing framework for COBOL, written in COBOL
1.26 What is bubble-generator?¶
Or, where did the GnuCOBOL syntax diagrams come from?
Dr. Richard Hipp created a small set of Tcl/Tk scripts to assist in drawing
syntax diagrams for SQLite. These public domain scripts were modified
slightly to create the syntax diagrams used in the GnuCOBOL FAQ, as
bubble-cobol.tcl and bubble-cobol-data.tcl. In keeping with the
spirit set by Dr. Hipp, the syntax diagrams in this document are also
dedicated to the public domain.
Sourced from the SQLite repository, and discovered at http://wiki.tcl.tk/21708. In this author’s opinion, true to Richard’s other works, these scripts produce beautiful diagrams. Tcl/Tk is used to produce Postscript outputs, which are then further processed by ImageMagick to produce the final .gif and .png images.
Extra font control was added, and in the GnuCOBOL FAQ version of the syntax diagrams, a non-bold font is used to denote GnuCOBOL extensions that are not part of the COBOL 2014 specification. Or at least, attempts were made to do so. GnuCOBOL does not claim any level of conformance to standard, and the syntax diagrams in this document are not indicative of COBOL syntax as defined by ISO and/or ANSI.
Although subject to change and correction, the sources used are listed here under bubble-cobol.tcl.
1.28 Do you know any good jokes?¶
Maybe.
A computer without COBOL and Fortran is like a piece of chocolate cake without ketchup or mustard.
John Krueger
A determined coder can write COBOL programs in any language.
Author: unknown
Rumour has it that the object oriented specification for COBOL was code named
ADD 1 TO COBOL GIVING COBOL.
Author: unknown
A less verbose, more concise version; very unCOBOL that
ADD 1 TO COBOL.
Thanks to aoirthoir
And, just because;
ADD 1 TO COBOL GIVING GnuCOBOL
A common disrespect of COBOL joke is that the acronym stands for:
Completely Obsolete Business Oriented Language.
Author unkown
We know better. The reality is:
Can’t Obsolesce Because Of Legacy. And why would you want to?
Brian Tiffin
COBOL
Certainly Old But Often Limber.
Brian Tiffin
Ruby on Rails? Don’t forget COBOL ON COGS.
Eat COBOL, 200 billion lines can’t be wrong.
Brian Tiffin
What did COBOL yell to the escaping thief?
STOP RUN RETURNING NOW.
Brian Tiffin
A COBOL programmer’s husband asks, “Honey can you go to the store and get some milk. And if they have eggs, get a dozen.” After twenty minutes she returns and flops 12 bags of milk on the table. He looks at her curiously, “Honey, why did you do that?” She responds flatly, “They had eggs.”
Author unknown
What did COBOL reply to the executive? Yes, I can
PERFORM JUMPS THRU HOOPS.
Brian Tiffin
What did GnuCOBOL reply to the executive? Sir, I can
PERFORM JUMPS THRU FLAMING-HOOPS UNTIL HELL-FREEZES-OVER.
And being COBOL, I have to show you how little code it takes:
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.
Wrote COBOL all morning, all afternoon and into the night. Another carpe, diem’ed.
Brian Tiffin, ripped from a meme, then farberized
The lady down the street didn’t believe I could build a car out of spaghetti.
You should have seen the look on her face when I drove pasta.
Author unknown
This is your captain speaking.
THIS IS YOUR CAPTAIN SHOUTING.
Author unknown
How many COBOL programmers does it take to change a light bulb?
One. COBOL programmers understand how the world works, they can change a light bulb. Which then lets them see their keyboard so they can fill out screen PF103D, submit job LB103R and request approval for a backup T5W-60.
Brian Tiffin
1.28.1 Really?¶
Ok, sorry for the lame.
Here is a link to some actual humour; Bob the Dinosaur, thanks to Scott Adams.
http://dilbert.com/strips/comic/1997-11-04/
And another one; Grace Hopper, by Zach Weinersmith at Saturday Morning Breakfast Cereal.
http://www.smbc-comics.com/?id=2516 (with a small snip from the actual comic, Copyright 2012 Zach Weiner)
Zach also coined the phrase, “off-by-frog”.
http://www.smbc-comics.com/?id=2831
That comic spawned the writing of frogSort, officially known as the
Weinersmith Fly By Frog Sort, or weiner sort.
Sorry, back to lame; sweet, sweet, lame.
*> ********************************************************
*> 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.
Which is an easter egg in the cbrain esoteric programming language, when requesting help for Citizen Band code 10-94, Request for long count. Returns CB code 10-7, Leaving air, radio off.
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.
1.28.2 A 5-7-5 haiku?¶
How about a 5-7-5 haiku?
program-id. one.
procedure division. add
1 to return-code.
*btiffin*
Compiles to a program that returns a failure code when run. Fails as poetry, fails as code. Your welcome.
I wasn’t allowed to post that as an actual Haiku on wikipedia. Call it a 5-7-5. Because, it isn’t, really, Haiku.
So...ummm, it could be program-id. sun. or...
springing into life
soaking sun, drinking summer
falling to winter
Take that. I respect the wikipedia discussion decision, but come on, program one compiles and executes. Even if it was based on Canadian elementary and high-school, missing the point, 5-7-5 fake haiku.
2 History¶
2.1 What is the history of COBOL?¶
Starting in 1959, a committee was formed under the sponsorship of the United States Department of Defense to recommend a short range option regarding business computing. The Conference on Data System Languages (CODASYL) led by Joe Wegstein of National Bureau of Standards (now National Institute of Standards and Technology) developed a new language, and created the first standardized business computer programming language.
The COmmon Business Oriented Language acronym was announced on September 18th, 1959.
Late in 1960, essentially the same COBOL program ran on two different hardware platforms, and stakeholders espied the potential for fulfilling the objective of industry wide, compatible business systems.
Rear Admiral Grace Hopper is affectionately referred to as the (grand)mother of the COBOL language, as she and her previous work with FLOW-MATIC, greatly influenced the specifications of the first COBOL. She is said to have argued strongly for words over symbols. So, COBOL has ADD, SUBTRACT, MULTIPLY, and DIVIDE and not just +, -, *, and /.
Grace Hopper discussing COBOL in 1961.
Courtesy of Jeffrey Chuan Chu, and the Computer History Museum.
http://www.computerhistory.org/collections/catalog/102722559
Grace is often referred to as Admiral Grace Hopper. She was not actually an admiral. She was promoted to captain by the United States Navy in 1973, then, by special Presidential appointment, to commodore in 1983. The rank title of commodore was officially changed by the Navy in 1985, to rear admiral (lower half).
2.1.1 Published Standards¶
Standards have been published for:
- COBOL-68
- COBOL-74
- COBOL-85
- COBOL-89 Intrinsic Functions
- COBOL-2002
- COBOL-2014
and these roughly correspond to the year they were produced. Note the y2k flavour of four digit naming occurred after the millennium change. Again, please note that these are not offical titles. Official titles look more like the newest one (2014), shown here:
ISO/IEC 1989:2014 Information technology – Programming languages, their environments and system software interfaces – Programming language COBOL, which was published in May 2014.
See the Wikipedia entry for COBOL which has a lot more details. Including names other than just Grace Hopper, who also deserve to be credited with the initial design and implementation of what was eventually named COBOL-60.
2.1.2 The Gartner estimate¶
Estimates vary, but it is reasonable to believe that of the some 300,000,000,000 (three hundred thousand million, 300 billion) lines of computer source code in production as of 1995, 200,000,000,000 (200 billion) lines were COBOL. A full 2/3rds of the world’s source code at the time.
Please note: the above line count estimate is approaching urban legend status and its reutterance is frowned upon now. I looked, and only witnessed a cycle of referenced material, but found no material. Besides, it’s an old number.
Even then, there was, is, and will be, a lot of source form COBOL. A lot.
Compiled COBOL literally (literately?) dominates in many core critical Business, and perhaps even some Engineering computing areas. When records and fields are being processed, like say financial transactions or inventories, COBOL shines in legible correctness. Words and not always just code. Good for business. Started that way in 1959, still that way; and more, now and into the unforseeable future.
2.2 What are the Official COBOL Standards?¶
Many thanks to William Klein, [wmklein] for details on what wordings are to be used when referencing COBOL Standards:
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.
2.2.1 COBOL 2014¶
ISO/IEC 1989:2014 Information technology – Programming languages, their environments and system software interfaces – Programming language COBOL, was published in May 2014.
http://www.iso.org/iso/home/store/catalogue_tc/catalogue_detail.htm?csnumber=51416
There is a pre-vote copy stashed away at open-std.org
Note
While GnuCOBOL can be held to a high standard of quality and robustness, the authors do not claim it to be a “Standard Conforming” implementation of COBOL.
2.3 What is the development history of GnuCOBOL?¶
OpenCOBOL was initially developed by Keisuke Nishida [Keisuke] from experience working on TinyCOBOL originally developed by Rildo Pragana.
The first public release was version 0.9.0 on January 25th, 2002.
Development continued apace, with version 0.30 released by Keisuke on August 8th, 2004.
Roger While [Roger] then took up the role as lead developer on October 30th, 2004.
Sergey Kashyrin [Sergey] posted the C++ emitter, GnuCOBOL 2.0 CPP on September 27th, 2013. The same day Richard Stallman dubbed OpenCOBOL an official GNU project, as GNU Cobol. Sergey followed along with the rename. September 21st, 2014, a spelling change to GnuCOBOL.
Ron Norman [Ron] had code posted for Report Writer, which became GnuCOBOL with Report Writer on November 23rd, 2013.
- Version 0.31
- was released February 1st, 2005.
- Version 0.32
- was released May 12th, 2005.
- Version 0.33
- started on May 13th, 2005.
- Version 1.0
- was released on December 27th, 2007.
- Version 1.1
- was released on SourceForge on May 4th, 2012.
- Version 1.1CE
- went into active development on May 4th, 2012.
- Version 2.0
- was released in September 2013.
- Version 2.0 CPP, C++
- was released in September 2013.
- Report Writer Version
- was posted to SourceForge for trial in November 2013.
- GNU Cobol version 1.1
- was posted with a digital signature to ftp.gnu.org/gnu/gnucobol on January 18th, 2014. Due to a mismatch caused during build testing, the first cut source kit was replaced, January 20th, 2014.
- GnuCOBOL
- GnuCOBOL became the preferred spelling on September 21st, 2014.
2.4 What is the current version of GnuCOBOL?¶
ftp://ftp.gnu.org/gnu/gnucobol/gnu-cobol-1.1.tar.gz is the official GNU release.
Simon Sobisch has put together a MinGW binary build of GnuCOBOL 1.1 for use with Windows(tm), hosted at http://sourceforge.net/projects/open-cobol/files/gnu-cobol/1.1/ file name is GnuCOBOL_1.1_MinGW_BDB_PDcurses_MPIR.7z
Other versions include:
- 1.1 Stable by Keisuke Nishada and Roger While
- 2.0 Pre-release with FUNCTION-ID support by Roger While.
- 2.0 C++ emitter by Sergey Kashryin
These are all on SourceForge at http://sourceforge.net/p/open-cobol/code/
http://sourceforge.net/p/open-cobol/code/HEAD/tree/branches/gnu-cobol-2.0/ is the main branch.
A pre-release, with Report Writer module by Ron Norman is the feature leading development source.
The next official releases will be from the GnuCOBOL 2.0 branch. This is the branch that has the most complete continuity of Roger While’s compiler developments.
Making the choice:
These are all good compilers. Until you are preparing for production rollouts, don’t worry too much about which version of the sources you use to build up applications. GnuCOBOL COBOL is pretty much COBOL, and these versions vary more in implementation details than anything else. Porting between versions will likely be zero effort, beyond verification.
For COBOL 85 with a little 2002, GnuCOBOL 1.1 is still a very valid choice.
For User Defined Functions, Report Writer, C++ emitter, IEEE FLOAT, then 2.0 is the better starting point. Slightly more risk, worthy of extra testing and analysis before committing to production use, until such time that there is a release announcement.
Older versions:
OpenCOBOL 1.0 was released December 27th, 2007 by Roger While [Roger].
The decision to go 1.0 from the 0.33 version followed many incremental enhancements from 2005 through till late in 2007.
OpenCOBOL 1.1 pre-release became active on December 27th, 2007 and major developments occurred publicly until February, 2009. The pre-release source tar can be found at GnuCOBOL 1.1 with installer instructions at GnuCOBOL Install and in the INSTALLING text file of the sources.
The 1.1 pre-release of February 2009 was tagged as release on SourceForge in May of 2012. The 1.1 community edition is now in development as the 2.0 branch at http://sourceforge.net/projects/open-cobol
Newer versions:
GnuCOBOL with Report Writer will be mainline trunk as of early 2015. Later edit: Late 2015? Even still, the pre-release reportwriter SVN branch is sweet code, works great. Feature packed, Ron is doing world class work.
2.0 is the lead branch at this point. It’ll be released first.
2.4.1 Building the 1.1 stable version¶
After a download and extract from http://sourceforge.net/projects/open-cobol/files/latest/download?source=files
$ tar xvf gnu-cobol-1.1.tar.gz
$ cd gnu-cobol-1.1
$ ./configure
$ make
$ make check
$ sudo make install
$ sudo ldconfig
will place a new set of binaries in /usr/local, ready to roll.
The ldconfig after make install is important, GnuCOBOL
installs shared libraries, and the link loader cache needs to
be informed.
Be sure to see What are the configure options available for building GnuCOBOL? for all the available options for building from sources.
2.4.2 occurlrefresh¶
If you build a pre-release OC1.1 or GnuCOBOL 2.0 , you will be able to compile
the occurlrefresh.cbl (with occurlsym.cpy) application and an early
occurl.c libCURL wrapper that allows file transfers off the Internet.
occurlrefresh includes default filenames for retrieving the most recent
pre-release source archive and only updates the local copy if there has been a
newer upstream release.
Thanks to [aoirthoir] for hosting these; currently (January 2016) at
and then simply
$ ./occurlrefresh
to download any new development archives. libCURL tests the modification
timestamps, so this procedure is very resource efficient, only pulling from the
server if there is something new. A -b option is accepted that will spawn
off tar, configure and the make pass to compile a fresh copy.
-b does not do an install, you’ll still have to do that manually after
verifying that everything is ok.
2.4.3 Building the reportwriter version¶
Get the source
$ svn checkout svn://svn.code.sf.net/p/open-cobol/code/branches/reportwriter \
gnu-cobol-rw
$ cd gnu-cobol-rw/
or with wget, thanks to Simon for the snippet.
$ mkdir reportwriter
$ wget -N -e robots=off -r -np -nH --cut-dirs =5 \
http://svn.code.sf.net/p/open-cobol/code/branches/reportwriter
$ chmod 775 configure tests/testsuite
$ touch cobc/*pars*.c* cobc/pplex.c* cobc/scanner.c* cobc/*.hpp tests/testsuite
Set up for an out of tree build. Not necessary, but cleaner.
$ mkdir build
$ cd build
$ ../configure --help # to see any options you may want to tweak
$ ../configure # note the .. up directory, while in build/
and the make, test, and install
$ make
$ make check
$ sudo make install
$ sudo ldconfig
and for more validation, the NIST COBOL 85 test suite
$ cd tests/cobol85
$ wget http://www.itl.nist.gov/div897/ctg/suites/newcob.val.Z
$ uncompress newcob.val.Z
$ make test
Party, big party. Dancing, and woo hoos, like it’s 1985. Actually, the last test suite update was in 1993, shortly after Instrinsic Functions.
While the test is running, take a look at REPORT.
Or, read through some of the NIST test code, perhaps SM/SM101A.CBL, a program
that puts COPY through its paces. Please note that newcob.val is not
for redistribution. Get it from the source, and share the link, not the
file.
2.5 What is the future of COBOL?¶
That is a good question. What follows is strictly opinion, and readers are encouraged to make the future and not wait for it to just happen.
COBOL is still very much in use with large systems, and big iron COBOL is a big business, all on its own. Millions are spent setting up and maintaining COBOL development systems. Many millions. That can be seen as a good thing, a bad thing, or a neutral thing. Some people are deeply invested in COBOL and see change as anathema. Some people are itching to get away from what they see as a money pit, stagnant as the world progresses. Some may be suffering internal conflict, split by both those extreme views.
Reality is likely somewhere in the middle. And part of the opinion, this author leans to staying with COBOL unless there are some serious reasons not to. User interface, interoperability and networking portions of hertitage applications come to mind. With GnuCOBOL, staying with COBOL may be a more attractive option. Source codes may need only minimal change, the money pit shrinks considerably, and at the same time interoperability potentials may increase, considerably. Keep all the heritage COBOL, extend into the future and build up, not sideways.
COBOL 2014 has some very nice features. Not all the features a modern development team may want or need, networking and user interface come to mind again, but a very solid core for problem solving. GnuCOBOL being a trans-compiler heavily rooted in C (or C++, thanks to Sergey), bridges the business computing model enshrined in COBOL, with the computer sciences enshrined in just about all the other programming development systems in use today. There are C implementations of nearly all mainstream programming languages. Java is actually based on a C implementation, as is Python, Perl, Ruby, PHP, to name but a few. There are C implementations of Ada, Fortran, BASIC, Lisp, Prolog, Javascript, a very long list. COBOL is a first class citizen in all of these environments with GnuCOBOL. GnuCOBOL bridges the gap between Business and Science, and can take on either role, fully, or in a mixed paradigm.
Need a network module? CALL it, or use cobc to link object code directly
into a master program. Need a slicker user interface, use cobweb-gtk or
cobweb-tk and offer up modern screens. CALL a few other modules and have a
browser ready interface. Need the flexibility of some advanced data structure
or multiprocessing system? Link it in. Need the Cloud? Put an instance of
GnuCOBOL on your Cloud. Need a DevOps strategy, well, build that layer around
heritage and let your GnuCOBOL developers talk with your GnuCOBOL operations
teams. Need to interoperate with some monster third party system? Dig in,
knowing full well that it’ll work at the common layer of the C application
binary interface.
The future of COBOL is what we will make of it. High costs no longer needs to be the primary area of modernization discussions surrounding heritage COBOL systems. They can be, for those that feel the need to spend; and there will be vendors willing to sign you up, for decades to come. Or, for those willing, GnuCOBOL will be waiting to ease some of the financial burdens, and open up the future to the opportunities that await.
3 Using GnuCOBOL¶
3.1 How do I install GnuCOBOL?¶
Installation instructions can be found at GnuCOBOL Install, but there are now a few ways to install GnuCOBOL.
3.1.1 From source with GNU/Linux¶
$ wget http://sourceforge.net/projects/open-cobol/files/gnu-cobol/1.1/gnu-cobol-1.1.tar.gz
$ tar xvf gnu-cobol-1.1.tar.gz
$ cd gnu-cobol-1.1
$ ./configure
$ make
$ make check
$ sudo make install
$ sudo ldconfig
January 2015:
A note on versions. OpenCOBOL 1.1 Feb 2009 was the last public pre-release of what is now GnuCOBOL.
There were two rebranding passes. OpenCOBOL to GNU Cobol then to GnuCOBOL. GNU Cobol 1.1 is the package listed here. It is OpenCOBOL 1.1 with rebranding, and a fair number of bug fixes and improvements.
Alternatively, for later, more feature rich, but less tested GnuCOBOL 2, change the wget to:
wget -N -e robots=off -r -np -nH --cut-dirs =5 \
http://svn.code.sf.net/p/open-cobol/code/branches/gnu-cobol-2.0
for the master development branch. Or, Report Writer. Close to 2.0, but diverged earlier, at a point that will require a merge into master.
wget -N -e robots=off -r -np -nH --cut-dirs =5 \
http://svn.code.sf.net/p/open-cobol/code/branches/reportwriter
or for a C++ version, again, an earlier 2.0 branch point:
wget -N -e robots=off -r -np -nH --cut-dirs =5 \
http://svn.code.sf.net/p/open-cobol/code/branches/gnu-cobol-cpp
or:
wget -N -e robots=off -r -np -nH --cut-dirs =5 \
http://svn.code.sf.net/p/open-cobol/code/branches/fileiorewrite
The backslashes represent an ignored newline. If you combine the lines, drop the backslash. It is only there for width control, the wget command is all one line.
Reportwriter will be folded into 2.0, fileiorewrite is a fileio.c rewrite, and will be merged into master, as well. The C++ version is close to baseline. gnu-cobol-cpp will remain a separate branch for the forseeable future.
If you are reading this for the first time, and looking for a COBOL 85 compiler, go with the initial gnu-cobol-1.1 instructions. All these compilers are valid, working COBOL compilers. But gnu-cobol-1.1 (which is very close to open-cobol-1.1, the version in most major distros) is very likely the most common installation type, by far. Years and years of accumulated installs.
GnuCOBOL 2.0 is close to ready, but not stamped for production by the development team quite yet. It too is a valid COBOL compiler, passing over 9700 NIST tests, but, production use would come with warnings to include an extra round of verification and site suitability testing.
For anyone that needs to care, 1.1 is GPL (and LGPL) 2+, newer cuts are GPL (and LGPL) 3+.
Please see What are the differences between OpenCOBOL 1.1 and GnuCOBOL 1.1?
3.1.2 Debian¶
The Debian binary package makes installing GnuCOBOL 1.0 a snap. From root or using sudo
$ apt-get install open-cobol
3.1.3 Ubuntu¶
The Ubuntu repositoies are very similar to Debian, using the same APT tool set.
Note on linking: Please be aware that Ubuntu has made a change to default link optimization that currently REQUIRE an external setting for the proper use of GnuCOBOL (and the older named OpenCOBOL) with dynamic libraries.
export COB_LD_FLAGS='-Wl, --no-as-needed'
before any compiles that use -l (minus ell) options to include named libraries.
See Why can’t libcob find my link modules at run-time? for further details.
3.1.5 Windows¶
And then we get to Windows™. A lot of people seem to have trouble with getting GnuCOBOL up and running with Windows. This situation has steadily improved since 2009, and continues to improve as of 2015.
First, builds can be from sources using Cygwin or MinGW. These two extensions to Windows provide a necessary layer of POSIX features that GnuCOBOL was created with (and for).
With Cygwin, you can simply follow the instructions listed above for building on GNU/Linux. Cygwin provides almost all of the same tools.
For MinGW, read the OC_GettingStarted_Windows document by [wmklein] available online at
Also see What is the current version of GnuCOBOL? and visual studio.
One recent addition for easing the burden with Windows installs came from Arnold Trembley. He put together an amalgam of intstructions and code to create a bundle that when extracted should have you up and running with a MinGW GnuCOBOL system in a very short period of time.
From Arnold:
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.
And from a happy customer (Eugenio Di Lorenzo) that just wanted to get GnuCOBOL installed with a minimum of fuss:
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.
Following Eugenio’s advice, a home for Arnold’s works will be in the GnuCOBOL project space at:
3.1.6 Macintosh¶
From Ganymede on opencobol.org
HOWTO: Installling OpenCOBOL 1.0.0 (with BerkeleyDB) under Mac OS 10.5.x-10.6.x
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
3.1.6.1 homebrew¶
And an update from Martin Ward. This is likely how GnuCOBOL 2 compile from
source efforts should be approached in 2015 and beyond. Martin needed
32 bit pointers, and struggled through to come up with a homebrew
solution to his GnuCOBOL build.
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!
3.1.7 CentOS¶
From the discussion forum on SourceForge, by Stuart Bishop.
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
But, GnuCOBOL has some nice fixes, as it was being rebranded from OpenCOBOL.
The wget might be better as
$ wget http://sourceforge.net/projects/open-cobol/files/gnu-cobol/1.1/gnu-cobol-1.1.tar.gz
...
$ cd ...gnu-cobol-1.1
...
or one of the others, listed above; reportwriter, C++, fileio rewrite, 2.0; Go with the 2.0 pre-releases, it’s the master branch, and reportwriter, for very well done REPORT SECTION support. Passes NIST suport tests, and most report code thrown at it, say back to 68. Almost 50 years of backwards compatibility and a chance to revitalize COBOL assets, perhaps thought lost to price / value ratios for run-time fees versus perceived value for some older report layouts.
3.2 What are the configure options available for building GnuCOBOL?¶
configure is a de facto standard development tool for POSIX compliant operating systems, in particular GNU/Linux. It examines the current environment and creates a Makefile suitable for the target computer and the package being built.
For GnuCOBOL, the ./configure script accepts --help as a command line
option to display all of the available configuration choices.
`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>.
3.2.1 GnuCOBOL build time environment variables¶
- LD_RUN_PATH
- Embeds build time library paths in the compiler. Handy when on hosts without root access. Point cobc at user built libcob and dependency libraries when needed. If set while compiling as well, CGI binaries will know where to find libcob and any other custom DSO files.
- LD_LIBRARY_PATH
- Run time shared library path, can effect lookup order during
./configure, make, but mentioned here as an alternative to LD_RUN_PATH. Complicating factor when running GnuCOBOL CGI on shared hosts. An intermediate script is needed to set LD_LIBRARY_PATH to point to local user account libcob. (Or hint to staff to install GnuCOBOL, very likely (as of 2014) in repositories asopen-cobol. Some package maintainers have separated the GPL compiler and LGPL run-time support intoopen-cobolandlibcob1(along with -dev header packages for both). - COB_CC
- The C compiler invoked during the cobc build chain.
- COB_CFLAGS
- The flags passed to the C compiler during the build chain.
- COB_LDFLAGS
- The link flags pass to the C compiler.
- COB_LIBS
- The default -l libraries used during the C compiler phase. -lm -lcob etcetera. These commands and options are displayed with cobc -v.
- COB_CONFIG_DIR
- Hmm, news says this was dropped, but it’ll effect where .conf dialect support files are found.
- COB_COPY_DIR
- Path to COPY books.
- COBCPY
- Path to COPY books. Knowing Roger these are cumulative.
- COB_LIBRARY_PATH
- Sets a default.
- COB_VARSEQ_FORMAT
- Determines a few code paths during make.
- COB_UNIX_LF
- Sets a default.
3.3 Does GnuCOBOL have any other dependencies?¶
GnuCOBOL relies on a native C compiler with POSIX compatibility. GCC being a freely available compiler collection supported by most operating systems currently (January 2016) in use.
GnuCOBOL requires the following external libraries to be installed:
- GNU MP (libgmp) 4.1.2 or later
- libgmp is used to implement decimal arithmetic. GNU MP is licensed under GNU Lesser General Public License.
- GNU Libtool (libltdl)
- libltdl is used to implement dynamic CALL statements. GNU Libtool is licensed under GNU Lesser General Public License.
NOTE - Libtool is not required for Linux and Windows (including MinGW and Cygwin)
The following libraries are optional:
- Berkeley DB (libdb) 1.85 or later
libdb can be used to implement indexed file I/O and SORT/MERGE. Berkeley DB is licensed under the original BSD License (1.85) or their own open-source license (2.x or later). Note that, as of 2.x, if you linked your software with Berkeley DB, you must distribute the source code of your software along with your software, or you have to strike a deal with Oracle Corporation.
For more information about Oracle Berkeley DB dual licensing see:
http://www.oracle.com/technetwork/database/berkeleydb/downloads/licensing-098979.html
- Ncurses (libncurses) 5.2 or later
- libncurses can be used to implement SCREEN SECTION. Ncurses is licensed under a BSD-style license.
3.4 How does the GnuCOBOL compiler work?¶
GnuCOBOL is a multi-stage command line driven compiler. Command line options control what stages are performed during processing.
- Preprocess
- Translate
- Compile
- Assemble
- Link
- Build
GnuCOBOL produces intermediate C source code that is then passed to a configured
C compiler and other tools. the GNU C compiler, gcc being a standard.
The main tool, cobc, by default, produces modules, linkable shared
object files. Use cobc -x to produce executables (with a main).
3.4.1 Example of GnuCOBOL stages¶
Documenting the output of the various stages of GnuCOBOL compilation.
3.4.2 Original source code¶
hello.cob
000100* HELLO.COB GnuCOBOL FAQ example
000200 IDENTIFICATION DIVISION.
000300 PROGRAM-ID. hello.
000400 PROCEDURE DIVISION.
000500 DISPLAY "Hello, world".
000600 STOP RUN.
3.4.3 Preprocess¶
$ cobc -E hello.cob
Preprocess only pass. One operation of the preprocessor is to convert FIXED format to FREE format. COPY includes are also read in along with REPLACE substitution. The above command displayed:
# 1 "hello.cob"
IDENTIFICATION DIVISION.
PROGRAM-ID. hello.
PROCEDURE DIVISION.
DISPLAY "Hello, world".
STOP RUN.
to standard out.
3.4.4 Translate¶
$ cobc -C hello.cob
Translate only; preprocesses and then translates the COBOL sources into C.
You can examine these files to get a good sense of how the GnuCOBOL
environment interacts with the native C facilities.
GnuCOBOL 1.1 produced hello.c.h and hello.c.
3.4.5 hello.c.h¶
/* 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};
/* ---------------------------------------------- */
3.4.6 hello.c¶
/* 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 */
3.4.7 Generate assembler¶
Using the -S switch asks cobc to ask the C compiler tool chain to
not process farther than the assembler code generation phase.
$ cobc -S hello.cob
3.4.8 hello.s¶
.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
Produces hello.s.
3.4.10 Build modules¶
$ cobc -m hello.cob
Build dynamically loadable module. The is the default behaviour.
This example produces hello.so or hello.dll.
$ cobc -b hello.cob
will do the same thing, but in this case, the extended Build is the same as the
single Module build with -m. -b will build a dynamically loadable
module that includes all of the entry points created from multiple command line
inputs. It’s fun; you can mix .cob, .c, and -l libs and GnuCOBOL does the right
thing gluing it all together. -b Build is suited to Programming In The Large
and using cobcrun.
3.4.11 Module run¶
$ cobcrun hello
Hello, world
Will scan the DSO hello.so, and then link, load, and execute hello.
3.4.12 Create executable¶
$ cobc -x hello.cob
Create an executable program. This examples produces hello or
hello.exe.
Important:. cobc produces a Dynamic Shared Object by default.
To create executables, you need to use -x.
$ ./hello
Hello, world
GnuCOBOL also supports features for multiple source, multiple language programming, detailed in the FAQ at Does GnuCOBOL support modules?.
3.4.13 Run job¶
There is an additional cobc switch in GnuCOBOL 2.0, -j that asks the
compiler to execute the program (or module) after compilation.
$ cobc -xj hello.cob
Hello, world
The job switch allows GnuCOBOL programs to follow a Compile, Link and Go
development paradigm. -j will invoke cobcrun when -m or -b
builds are requested.
3.4.14 Interpreter directive¶
It even goes one step further, using the power of hash-bang POSIX style shell interpreter directives. GnuCOBOL programs can be treated as scripts.
For example, given hello-cobol.sh
#!/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.
with chmod +x hello-cobol.sh you get
$ ./hello-cobol.sh
Hello, world
Scripted COBOL. (Or at least it feels like it; the text passed to the
interpreter, which is effectively cobc, is compiled and executed due to
the -xj compiler switches).
3.4.15 sizes for hello on Fedora 16¶
The directory listing after using the various cobc options:
-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
3.5 What is cobc?¶
cobc is the GnuCOBOL compiler. It processes source code into object,
library or executable code.
See What compiler options are supported? for more information.
3.6 What is cobcrun?¶
cobcrun is the GnuCOBOL driver program that allows the execution of
programs stored in GnuCOBOL modules.
The cobc compiler, by default, produces modules (the -m option).
These modules are linkable dynamic shared objects (DSO). Using GNU/Linux
for example
$ cobc -x hello.cob
$ ./hello
Hello, world
$ cobc hello.cob
$ cobcrun hello
Hello, world
The cobc -x hello.cob built an executable binary called hello. The
cobc hello.cob produced a DSO hello.so, and cobcrun resolves the
entry point and executes the code, right from the DSO.
cobcrun is the compiler author’s preferred way to manage GnuCOBOL
development. It alleviates knowing which source file needs -x while
encouraging proper modular programming, a mainstay of GnuCOBOL.
There is a cobcrun command line switch, -M in GnuCOBOL 2.0 that
offers even more flexibility when running modules.
It will preset COB_LIBRARY_PATH with any optional path and COB_PRE_LOAD
with an optional module basename. Ending slash only sets path.
-M will accept path/file, path/, or file.
# 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
3.7 What is cob-config?¶
cob-config is a small program that can be used to display the C compiler
flags and libraries required for compiling. Using GNU/Linux for example
$ 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
You may need to use these features during mixed source language development,
usually by back-ticking the command output inline with other gcc commands.
3.8 What compiler options are supported?¶
The GnuCOBOL system strives to follow standards, yet also remain a viable compiler option for the many billions of existing lines of COBOL sources, by supporting many existing extensions to the COBOL language. Many details of the compile can be controlled with command line options. Please also see What are the GnuCOBOL compile time configuration files? for more details on this finely tuned control.
$ 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
3.8.1 For 2.0 with reportwriter that becomes¶
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/>
3.8.2 A note on -A and -Q¶
The -A and -Q swiches can get a bit tricky. These pass options on to the C compiler by cobc and some escaping is sometimes necessary.
For example: To pass a defined symbol all the way through to the Assembly layer you could use:
cobc -xjgv -debug -A '-Wa\,--defsym,DEBUG=1' cpuid.cob vendor.s brand.s negate.s
to inform the compiler toolchain to pass the option to gcc, which would
then pass the option to as, as in:
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
In this case the assembler support files included these lines
.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
with conditional assembly directives that produced the:
Number: 7fffffe2, Address: 0x6031e0
Number: 8000001e, Address: 0x6031e0
output lines during the execution of cpuid, by assembling in calls to
printf. In this case ALL the assembled files are getting the DEBUG=1
definition, and finer control would mean splitting up the cobc command into
separate steps, if that was not wanted in some of the other assembler files.
3.9 What dialects are supported by GnuCOBOL?¶
Using the std=<dialect> compiler option, GnuCOBOL can be configured to
compile using specific historical COBOL compiler features and quirks.
Supported dialects include:
- default
- cobol85
- cobol2002
- ibm
- mvs
- mf
- bs2000
For details on what options and switches are used to support these dialect
compiles, see the config/ directory of your GnuCOBOL installation. For
Debian GNU/Linux, that will be /usr/share/open-cobol/config/ if you used
APT to install a GnuCOBOL package or /usr/local/share/open-cobol/config/
after a build from the source archive. Or, /usr/share/gnucobol/config
for packages from the GnuCOBOL versions of the source tree, as they become
available.
For example: the bs2000.conf file restricts data representations to 2, 4 or 8 byte binary while mf.conf allows data representations from 1 thru 8 bytes. cobol85.conf allows debugging lines, cobol2002.conf configures the compiler to warn that this feature is obsolete.
3.9.1 Supported Literal values¶
GnuCOBOL strives to be a useful COBOL compiler. By supporting features provided by other compilers, there are some extensions in GnuCOBOL that will not be in the COBOL standards document. GnuCOBOL does not claim any level of conformance with any official COBOL specifications, but does strive to be useful.
The cobc compiler supports:
DISPLAY B#101
DISPLAY O#1777777777777777777777
DISPLAY X#ffffffffffffffff
DISPLAY H#ffffffffffffffff
DISPLAY "ABC" & "DEF" *> literal concatenation
DISPLAY X"0a00"
DISPLAY H"DECAFBAD"
MOVE Z"C-string" TO nine-character-field-with-zero-byte
3.10 What extensions are used if cobc is called with/without “-ext” for COPY?¶
From Roger on opencobol.org
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.
From Simon on SourceForge
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
The /usr/local/share/gnu-cobol is relative to the installation prefix. It
might be /usr/share/gnu-cobol or other system directory, and can be set
during ./configure when building GnuCOBOL from source.
3.11 What are the GnuCOBOL compile time configuration files?¶
To assist in the support of the various existent COBOL compilers, GnuCOBOL reads configuration files controlling various aspects of a compile pass.
Each supported dialect will also have a .conf file in the
config/ sub-directory of its installation. For Debian GNU/Linux, these
will be in /usr/share/open-cobol/config/ or
/usr/local/share/open-cobol/config under default package and default
make conditions.
For example, the default configuration, default.conf is:
# 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
3.11.1 reportwriter default.conf¶
# 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
3.11.2 differences with ibm.conf¶
$ 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
3.12 Does GnuCOBOL work with make?¶
Absolutely. Very well, but no built in rules for GNU make yet.
Makefile command entries, (after the rule, commands are preceded by TAB, not spaces).
A sample (unsophisticated) makefile
# 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
And now to work with a small program called program.cob, use
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
The last rule, occurlrefresh is an example of how a multi-part project can be supported. Simply type
$ make occurlrefresh
and make will check the timestamps for occurl.c, occurlsym.cpy and occurlrefresh.cbl and then build up the executable if any of those files have changed compared to timestamp of the binary.
The program.mark rule is a little dangerous, it modifies the source before
continuing on to cobc -x. Probably not overly wise in a production
environment.
See Tectonics for another word to describe building code.
3.13 Do you have a reasonable source code skeleton for GnuCOBOL?¶
Maybe. Style is a very personal developer choice. GnuCOBOL pays homage to this freedom of choice.
Below is a template that can be loaded into Vim when editing new files of type
.cob or .cbl.
" Auto load COBOL template
autocmd BufNewFile *.cob 0r ~/lang/cobol/header.cob
autocmd BufNewFile *.cbl 0r ~/lang/cobol/header.cob
The filename is installation specific, and would need to change in any given
~/.vimrc config file. But in the local case, it loads from
$HOME/lang/cobol/header.cob and looks like:
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
It includes empty versions (that still compile) of most sections, in the right order. deleting the unnecessary lines is pretty easy, and act as handy reminders.
This skeleton also includes started lines for in source documentation. The
only rule for those documentation lines is that no line can start with > or
$ (as that would trigger the GnuCOBOL preprocessor as it scans through the
text looking for >>END-IF, or >>ELSE, or other compiler directives).
These lines can be processed with rst2html and there is a sample make rule
listed under, Does GnuCOBOL work with make? as make program.html that
includes the simple steps for extracting and processing the documentation.
A few other ./vimrc settings allow for automatically filling in the
author and date-written paragraphs, as well as setting the
Modified: timestamp when writing out the buffer. Customize with your own
name and timestamp preferences.
" 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()
Here is a FIXED form header that this author used to use. It includes
ocdoc lines.
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
Fill in the program-id and end program to compile. Fill in the ocdoc title for generating documentation. See What is ocdoc? for more information on (one method of) inline documentation.
Here are some other templates that can cut and pasted.
Fixed form, in lowercase, with some starter lines thrown in as reminders.
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.
Fixed form in UPPERCASE
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 .
The GCobol “sequence number” can safely be removed. It is there to ensure proper alignment in the browser.
FREE FORM can be compiled with cobc -free or use the supported compiler
directive:
>>SOURCE FORMAT IS FREE
the above line must start in column 7 unless cobc -free is used.
*> ** >>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 .
These files can be downloaded from
As listed above, head-full.cob has a lot of gunk in it, and is more
useful as a reminder than a day to day default. See autoload a skeleton.
Please excuse the small sample command interpreter, it’s my homage to Python and:
$ 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
>>>
If you know I want to exit, just exit, don’t tell me I did it wrong. Having said that, this reminder source plays out ala:
$ 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?
quit
DEBUG: cleansing input: quit
I know you want to quit, but I'm being unfriendly; type 'exit', you user you
What is your command?
‘exit’
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?
“EXIT”
DEBUG: cleansing input: "EXIT"
fine, leaving now
Note
There are tricks to ensure that FIXED FORMAT source code can be
compiled in a both a FIXED and FREE FORMAT mode. That includes:
- using free form end of line comments,
*>in column 7 and 8, or later - no sequence numbers or notes in column 1-6, the saddest concession
- write DEBUG line compiler directives with the
>>Dstarting in column 5 (so theDends up in column 7) - avoid
-continuation lines,&being a handy replacement that may well enhance readability when literals are involved - judicious use of the
>>SOURCE FORMAT IS ...directive, placed at column 8 or later, to toggle around tricky bits of comment and code sections
3.14 Can GnuCOBOL be used to write command line stdin, stdout filters?¶
Absolutely. It comes down to SELECT name ASSIGN TO KEYBOARD for
standard input, and SELECT name ASSIGN TO DISPLAY for standard out.
Below is a skeleton that can be used to write various filters. These programs can be used as command line pipes, or with redirections.
$ cat datafile | filter
$ filter <inputfile >outputfile
filter.cob. You’ll want to change the 01-transform paragraph to do all
the processing of each record. This skeleton simply copies stdin to stdout,
with a limit of 32K records so that may need to be changed as well or
tests made to ensure the default LINE SEQUENTIAL mode of
KEYBOARD and DISPLAY are appropriate for the task at hand.
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
3.14.1 CBL_OC_HOSTED¶
A recent entry in the GnuCOBOL system call library allows for quick access to some of the common variables hosted by the C run-time system.
CBL_OC_HOSTED provides access to
- stdin to pointer to stream
- stdout to pointer
- stderr to pointer
- argc to binary-long
- argv to pointer to char pointer pointer
- errno to pointer with address of errno
If GnuCOBOL is built with HAVE_TIMEZONE defined, CBL_OC_HOSTED can also return
- tzname to pointer to pointer to two element char pointer array
- timezone to binary-c-long, number of seconds West of UTC.
- daylight to binary-long, 0/1 flag for daylight savings time
Treat all returned values as read only, except for errno which is a reference to the actual field and can be read and modified through a BASED integer.
*> POSIX stream IO mix and match with GnuCOBOL
01 result usage binary-long.
01 stdin usage pointer.
01 errno usage pointer.
01 err 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_OC_HOSTED" stdin "stdin"
call "CBL_OC_HOSTED" errno "errno"
set address of err to errno
call "fgets" using buffer by value 80 stdin returning got
if got equal null then
display "stdin error: " err upon syserr
move 0 to err
end-if
set environment "TZ" to "PST8PDT"
call "tzset" returning omitted
call "CBL_OC_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
The CBL_OC_HOSTED system call makes it just that little bit easier to
interact with POSIX and C from GnuCOBOL.
3.15 How do you print to printers with GnuCOBOL?¶
GnuCOBOL and COBOL in general does not directly support printers. That role is delegated to the operating system. Having said that, there are a few ways to get data to a printer.
3.15.1 printing with standard out¶
Writing directly to standard out, as explained in
Can GnuCOBOL be used to write command line stdin, stdout filters? and
then simply piping to lpd should usually suffice to get text to your
printer.
$ ./cobprog | lp
$ ./yearend | lp -d $PRESIDENTSPRINTER
Don’t try the above with the DISPLAY verb; use WRITE TO stdout, with stdout
selected and assigned to the DISPLAY name.
3.15.2 calling the system print¶
Files can be routed to the printer from a running program with sequences such as
CALL "SYSTEM"
USING "lp os-specific-path-to-file"
RETURNING status
END-CALL
3.15.3 print control library calls¶
And then we open up the field of callable libraries for print support. Below is some template code for sending files to a local CUPS install.
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.
3.15.4 print to PDF with CUPS¶
As it turns out, the above code snippet can be used to print directly to a PDF defined cups-pdf printer. By
$ apt-get install cups cups-pdf
under Debian, you can then
call "cupsPrintFile"
using
"PDFer" & x"00"
"cupscob.cob" & x"00"
"cupscob.pdf" & x"00"
by value 0
by reference NULL
returning result
end-call
assuming PDFer is a Class or printer with a PDF member. A PDF
version of the text in cupscob.cob will be placed in ~/PDF/
as cupscob.pdf.
Roger While added this wisdom:
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
The code with a little more documentation, in case it turns out to be useful.
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
3.15.5 Jim Currey’s prtcbl¶
Jim kindly donated this snippet. One of his earliest efforts establishing a base of GnuCOBOL resources. prtcbl produces source code listing with results piped to a printer.
A few customizations. This version requires a change to a filename for printer control, location of copybooks, and possible changes to the system lp command line.
Stash a print setup string in the file so named. The program prompts for input, output and printer.
Jim pointed out that this was early attempts with OpenCOBOL as a tool to support better in house development, and was nice enough to let me reprint it.
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.
3.16 Can I run background processes using GnuCOBOL?¶
Absolutely. Using the CALL "SYSTEM" service. Some care must be
shown to properly detach the input output handles, and to instruct
the processes to ignore hangup signals along with the “run in
a background subshell” control.
CALL "SYSTEM"
USING
"nohup whatever 0</dev/null 1>mystdout 2>mystderr &"
RETURNING result
END-CALL
runs whatever in the background, detaches stdin, sends standard
output to the file mystdout and standard error to mystderr.
The above example is for POSIX_ shell operating systems. As always, the commands sent through SYSTEM are VERY operating system dependent.
3.17 Is there GnuCOBOL API documentation?¶
Absolutely. Sort of. And it’s beautiful, complete and awe inspiring.
Dimitri van Heesch’s 1.7.4 release of Doxygen, http://www.doxygen.org was used to produce http://opencobol.add1tocobol.com/doxy/ and along with Gary’s OCic.cbl http://opencobol.add1tocobol.com/doxyapp/ to highlight the absolutely beautiful compiler and application documentation available for GnuCOBOL now. These pages were produced with very little effort with only a few small tweaks to the Doxygen generated Doxyfile (to turn on all files, and to generate call graphs). The sample pass produces a 1400 page beauty of a reference manual in PDF generated from the Doxygen LaTex output. 2950 pages for the sample application run.
GnuCOBOL ships as a developer tarball and Doxygen was let loose on the source tree after a ./configure and make pass. When the -C output of Gary Cutler’s OCic.cbl was placed into the tree, the output includes the call graphs that exercise some of the GnuCOBOL run-time library. This application level documentation is world class.
Regarding the above “sort of”. This was a near effortless use of Doxygen. GnuCOBOL was not touched and the sources have no explicit Doxygen tags. It also excludes many of the automake, libtool, bison and flex source files. Even still, beautiful. The compiler API is now an easy grok, and application level documentation (doxyapp using OCic.cbl as a sample) should satisfy the world’s most ruthless code auditor and meticulous development team lead.
See http://opencobol.add1tocobol.com/doxy/d2/dd4/structcb__field.html for a tantalizing sample of cb_field collaboration diagram and completeness of source code coverage. See http://opencobol.add1tocobol.com/doxyapp/d4/da8/OCic_8c.html for a view of how Doxygen handles the application level documentation. All for free.
3.18 How do I use LD_RUN_PATH with GnuCOBOL?¶
LD_RUN_PATH can be a saving grace for developers that want to build
GnuCOBOL on hosted environments. LD_RUN_PATH is similar to
LD_LIBRARY_PATH but builds the shared library path into cobc and then
all of the binaries compiled with cobc. That means you can cherry pick the
link loader paths when you build GnuCOBOL in a way that can add support for
unsupported host features.
If you want a recent version of ncurses on your hosting service, but don’t have root permissions, you can build it into one of your own directories then
EXPORT LD_RUN_PATH=mylibdir
./configure ; make ; make install
to build your GnuCOBOL. All compiles with cobc will now include mylibdir
during compiles, and better yet, the binaries produced will also include
mylibdir in the search path at run-time.
If you don’t have RECORD_PATH in your cobc then you can simply compile
with
LD_RUN_PATH=mylibdir cobc -x nextbigthing.cob
to achieve similar results.
With the CGI interface, see How do I use GnuCOBOL for CGI?, you can now build up a complete web side solution using GnuCOBOL with little worry about being stuck on link library dependencies or running scripts to setup any path variables before safely using your cgi-bin binaries.
LD_RUN_PATH is magical. It also avoids many security problems that can
occur if you rely on LD_LIBRARY_PATH user environment settings. Your
cobc will have your search path and not some /home/badusers
trickery settings as LD_RUN_PATH searches come before LD_LIBRARY_PATH.
Relying on LD_LIBRARY_PATH is deemed a Don’t do by some experts.
LD_RUN_PATH is a much safer bet.
3.19 What GNU build tool options are available when building GnuCOBOL?¶
The sources for the GnuCOBOL compiler follows GNU standards whenever possible. This includes being built around the GNU build system.
3.19.1 Basics¶
From an end-user perspective, what this means is that the source code distributions follow these basic steps:
tar xvf open-cobol-1.1.tar.gz
cd open-cobol-1.1
./configure
make
make check
sudo make install
sudo ldconfig
But that is just scratching the surface of the possibilities. See
What are the configure options available for building GnuCOBOL? for
the first steps with ./configure.
3.19.2 Out of tree builds¶
Next up, GnuCOBOL fully supports out-of-source-tree builds.
From Roger:
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".
This can be made a lot easier to remember by using a shell function.
Add the following to $HOME/.bashrc (and edit the path names).
# 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
}
And now, it is a simpler:
prompt$ use-cobol 2.0
prompt$ use-cobol reportwriter
prompt$ use-cobol c++
You could also add strings to the case statement patterns to match personal
taste, as in 2\.0 | 2 | simon) and use:
prompt$ use-cobol simon
prompt$ use-cobol ron
prompt$ use-cobol sergey
prompt$ use-cobol joe
prompt$ use-cobol experiment
if that is easier to remember. And use what ever name for the use-cobol
function that you please.
Please note that because of the way shell scripts work, those atconfig and
atlocal lines don’t work from an external script. You have to invoke the
source shell command from the current shell, and shell functions do that.
If you like to keep your ~/.bashrc clean, then source in the definition of the
function. As long as the function runs from the current shell and not a
sub-shell it will work, otherwise all the environment settings are forgotten,
as the environment is never passed up to a parent process, only down to
children.
3.19.3 Autotest options¶
By developing the GnuCOBOL system around the GNU build tools, developers receive a great many options for free.
make check can include TESTSUITEFLAGS.
The TESTSUITEFLAGS allows for options that include:
make check TESTSUITEFLAGS="--list"to list the available tests and descriptions"--verbose"to show a little more information during the tests"--jobs=n"to run n tests in parallel. On multi core systems, the speed up is fairly dramatic. For 425 tests, normally 1 minute 22 seconds,--jobs=4ran in 36 seconds (on a small little AMD Athlon(tm) II X2 215 Processor). The more cores, the more dramatic the improvement.
3.20 Why don’t I see any output from my GnuCOBOL program?¶
This is actually a frequently asked question, and it usually has the same answer.
GnuCOBOL uses the Curses and NCurses packages for advanced terminal features and
SCREEN SECTION handling. This uses stdscr for input and output, and not the
standard CONSOLE, SYSIN, SYSOUT character interface modes. One feature of the
Curses handler is the concept of a secondary screen buffer, which is erased during
initialization and then disappears at rundown. This can happen so fast on short
display programs that it looks like nothing happens.
program-id. helloat.
DISPLAY "Hello, world" LINE 5 COLUMN 5
goback.
Running that code will cause the Curses package to initialize a secondary
buffer, display the Hello string, then immediately restore the original screen
buffer during goback. It will look like nothing is output when ./helloat
is run. There are a few fixes for this.
- delay rundown with a
CALL "C$SLEEP" USING 5 END-CALL ACCEPT OMITTEDwhich will wait for a carriage return (GnuCOBOL 2.0)ACCEPT unused-variablecan also be used to pause a program before exit- or even better, dump the secondary buffer from all Curses screen handling
The last option is discussed here.
3.20.1 SMCUP and RMCUP¶
https://blogs.oracle.com/samf/entry/smcup_rmcup_hate is a great article that discusses, and sledgehammer fixes, the curses init screen clearing issue, leaving output on the stdout terminal, not an alternate screen.
First to find out the actual terminal capabilities, (and what control file is going to change):
$ infocmp | head -2
shows:
# Reconstructed via infocmp from file: /home/btiffin/.terminfo/x/xterm-256color
xterm-256color|xterm with 256 colors,
There is some voodoo with infocmp (and tic, the terminal information
compiler), to worry about. By default, infocmp reads local user files, but this
change can also effect the entire system, if run as root.
Using a super user context:
[btiffin@localhost junk]$ sudo infocmp | head -2
# Reconstructed via infocmp from file: /usr/share/terminfo/x/xterm-256color
xterm-256color|xterm with 256 colors,
gives us the system file.
After creating a just in case copy of /usr/share/terminfo/x/xterm-256color it
is time to get rid of the alternate stdscr.
$ infocmp >xterm.terminfo
$ vi xterm.terminfo
$ # get rid of smcup= and rmcup= upto and including the comma
$ tic xterm.terminfo
in my case, the temporary xterm.terminfo looked like:
...
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,
...
and becomes:
...
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,
...
rmcup and smcup edited out. (The end bits of the first and last lines
of the listing.)
After the tic command completes, there is a shiny new local
/home/btiffin/.terminfo/x/xterm-256color compiled terminfo file that has no
alternate terminal screen capabilities. All output will happen in the primary
screen buffer. I see no downside to this.
As long as you don’t run the terminal info compiler, tic, as root, the
files in /usr/share/terminfo/... will still be the originals, and a new
local copy is made. tic will overwrite the system file if it can, but will
move on and create a local compiled file, if it cannot write to the system.
Until you are sure, best to run this locally and not as the superuser.
The script in Sam’s blog, mentioned above, will alleviate doing this manually every time the system updates the terminfo database.
So now, code like the following that displays data on line 2, column 12 and line 3, column 13
identification division.
program-id. helloscreen.
procedure division.
display "Hello, world" at 0212
display "Goodbye, smcup/rmcup" at 0313
goback.
end program helloscreen.
and then the command below; which still blanks the screen, but now leaves output on the terminal after goback.
[btiffin@home forum]$ ./helloscreen
Hello, world
Goodbye, smcup/rmcup
[btiffin@home forum]$
and GnuCOBOL displays things using advanced terminal capabilities, but leaves the data on screen after image exit.
Never worry about smcup/rmcup hate on curses init again. Not just GnuCOBOL
and curses, but vi, less, man and any other alternate screen application. For
the win. This change effects old school TE TI termcap calls too.
Curses will still play havoc with screen section programs in pipes; as stdin, stdout are a little special with curses involved. This is a minor annoyance that won’t come up as often and piping screen interactive programs has always been laden in voodoo anyway.
3.21 What are the GnuCOBOL compiler run-time limits?¶
This may well be a long term entry, updated as facts come in
Some limits are only found by careful examination of code.
For instance, field names are limited to 31 characters, unless
-frelax-syntax is used in which case the maximum is 61.
Some limits are enumerated.
3.21.1 libcob/common.h¶
From libcob/common.h May 2014
/* 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
...
How configurable are these, when needs press? Change developer would need to comb over the run-time, to make sure there aren’t hidden assumptions.
For instance, MAX_FIELD_PARAMS, is included in a field by field copy in
libcob/call.c indexed by number. Change to that value would need
other source changes in support.
Umm, start mucking around with MAX_DIGITS, and expect to comb over a LOT of GNU
Cobol source. The first 500 lines of libcob/common.h is optimization
macros, let alone the hooks in numeric.c, move, and on and on into the big
blue. Or, read this, go, “oh yeah? I can write that.” and show me up while
enhancing the world.
COBOL fields (and group total) can be 258 megabytes, COB_MAX_FIELD_SIZE.
MAX_FD_RECORD limits are likely entangled by external forces, and again, more reading.
Terminal buffer is MEDIUM_BUFF, 8K, as is the free form line limit.
Environment variable lookup space is LARGE_BUFF, so 16K.
Details are usually gleaned with a grep across the source tree.
3.22 What are the GnuCOBOL run-time environment variables?¶
- COB_LEGACY
- Effect screen attributes for non input fields when set to Y.
- COB_LIBRARY_PATH
- Augments the run time DSO search path.
- COB_LS_NULLS
- Inserts a 0 byte before any x value less than x‘20’ when set to Y. From asking around, this is very likely related to legacy print file support. I may be rumour mongering, but I trust the sources.
- COB_LS_FIXED
- Writes to LINE SEQUENTIAL files will be padded with spaces to the FD length when set to Y.
- COB_PRE_LOAD
- A colon separated list of DSO names. This comes in very handy when coming to grips with both foreign libraries and GnuCOBOL dynamic shared object files.
- COB_SET_DEBUG
- Turns on >>D lines when set to Y.
- COB_SYNC
- Explicit flush after writes when set.
GnuCOBOL 1.1 COB_SYNC values:
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)
GnuCOBOL 2.0 settings
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
There is an extreme performance penalty with COB_SYNC set. Be warned.
The setting was added for systems that need files to be immediately written because of likely power outages without UPS, or similar concerns, not for file sharing issues.
For the GnuCOBOL-reportwriter branch, Ron has added code to allow COB_SYNC
settings on a per-file basis, but until those changes are merged into GnuCOBOL
2.0, the COB_SYNC setting is global, and effects all file write operations
during a run.
- DB_HOME
- Used by Berkeley DB for file sharing, pointing to file directory.
- ESC_DELAY
- For ncurses, SCREEN SECTION, detection of the ESC key is delayed, allowing for detection of extended keyboard keys, ala Function and cursor keys. Historically, on slow serial lines of old, this delay was set to a noticable value, approaching one second. Now, the delay can be safely set to less than 100 milliseconds, roughly the threshold of human noticeability. export ESC_DELAY=25 being a sane choice.
- OCREPORTDEBUG
- This is Ron’s, it may go away
- COB_BELL
- COB_DISABLE_WARNINGS
- COB_ENV_MANGLE
- COB_FILE_PATH
- COB_LS_USES_CR
- COB_REDIRECT_DISPLAY
- COB_SCREEN_EXCEPTIONS
- COB_SCREEN_ESC
- COB_SET_TRACE
- COB_SORT_CHUNK
- COB_SORT_MEMORY
- COB_TIMEOUT_SCALE
- COB_TRACE_FILE
- COB_UNIX_LF
- COB_VARSEQ_FORMAT
- LOGNAME
- TEMP
- TMP
- TMPDIR
- USERNAME
3.23 What are the differences between OpenCOBOL 1.1 and GnuCOBOL 1.1?¶
Thanks to Simon Sobisch, for putting these back port ChangeLog notes together. Nice
the differences of OpenCOBOL 1.1 and GnuCOBOL 1.1 (this release had the temporary name GNU Cobol, but I’ll stick to the newer one when referencing it
3.23.1 General:¶
- test suite and ANSI 85 tests will pass if no ISAM is configured, too (ISAM tests are skipped in this case)
- configure: Added check for using GMP library, better checks for BDB
- included CBL_OC_DUMP for hex-dumping
- security issue: following CVE-2009-4029 distribution tarballs are created with mode 755, not 777
- tarstamp.h includes a printable definition for COB_NUM_TAR_DATE & COB_NUM_TAR_TIME
- name change shows it’s really free, not only open-source (like others) and it shows it has a quality that’s worth to be GNU
- credits to more of the people involved
- minor fixes of typing errors
- support for icc, better support for IBM390, MSC, BORLANDC, WATCOMC
- remove extraneous include files (most stuff was integrated in libcob.h)
- fix warnings from C compiler when building GnuCOBOL
- compiler configuration files are complete (include every option)
3.23.2 libcob:¶
- FUNCTIONs: correctly compute RANDOM number [bugs:#72], don’t crash on large-scale numbers with INTEGER and MOD, don’t loose precision with MOD and REM [bugs:#37]
- ACCEPT DAY OF WEEK fixed
- new system routine C$GETPID
- fix INSPECT converting for SPACE[S] / ZERO[ES] ...
- fixes for UNSTRING: delimited by all delimiter size > 1, see [bugs:#54]; UNSTRING INTO; UNSTRING with multiple variable length fields
- ACCEPT SCREEN: Changed insert key default to off, added environment variable COB_INSERT_MODE, Y or y to get old behaviour (insert default becomes on)
- ACCEPT: fix for PDCurses and numpad in general; new return values Tab = 2007, Back tab = 2008; end key positions to end of data (was end of field), backspace key moves remainder left (inserts space at end or 0 for numerics)
- fix for PDCurses with COLOR_PAIRS
- fixing results for SUBTRACT int FROM PIC S9(n)V9(m) COMP-3, ADD 1 TO PIC S9(n)V9(m) VALUE -0.1, ADD with binary-truncate:no (for example with -std=ibm or std=mf)
- fileio: lineseq_write adds ‘n’ in some cases (compatibility to MF) - be aware that this changes current behaviour (when WRITE AFTER/BEFORE are mixed)
- fileio: Fix problem to rewrite INDEXED (VBISAM) record with alternate key
- fileio: Prevent runtime crash when ASSIGN is missing in SELECT FILE
3.23.3 cobc:¶
- new options –info (output of most important configuration/environment details); –list-system (displaying all registered system routines), -A and -Q (add options to C compile / link phase)
- Warn if -Debug is used (because likely -debug was intended)
- support for spaces in path names passed to cobc
- enable linking of already assembled modules for different UNIXes
- FREE: Remove of exception for NULL address (as this is explicit allowed)
- fix incorrect counting of number of digits for “$”, “+”, and “-” [bugs:#39]
- Lexer was missing comment lines in FREE format, i.e. trying to process “* COPY 12345.” and look for “12345” file as a copybook :-)
- Added check for maximum size of group items
- new compiler configuration default-organization: set to either record-sequential (default=old behaviour) or line-sequential
- better warning/error messages
3.24 What is runtime.cfg?¶
New in the reportwriter branch, runtime.cfg is an assistive file the allows
control over the run time environment for GnuCOBOL.
Placed in the same directory as the configuration files, runtime.cfg
supports a small domain specific language, for setting and resetting various
environment variables that influence a lot of GnuCOBOL features.
You can also include other configuration files, specific for the job at hand.
Valid keywords include:
- setenv
- unsetenv
- include
- includeif
- reset
The default runtime.cfg entry includes documentation on how it all works.
# GNU Cobol runtime configuration
#
# Copyright (C) 2015 Simon Sobisch
#
# This file is part of the GNU Cobol runtime.
#
# The GNU Cobol 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.
#
# GNU Cobol 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 GNU Cobol. If not, see <http://www.gnu.org/licenses/>.
#
## General instructions
#
# The initial runtime.cfg file is found in the installdir/gnu-cobol/config
# or the environment variable COB_RUNTIME_CONFIG may define which runtime
# configuration file to read.
# If settings are included in the runtime environment file multiple times
# then the last setting value is used.
# 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 rutime configuration file(s)
# Any enviroment variable may be set with the directive setenv
# Example: setenv COB_LIBARAY_PATH ${LD_LIBRARY_PATH}
# 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 unset with the directive "unsetenv var"
# (one var per line) can be used. Example: unsetenv COB_LIBRARY_PATH
# The directives unset and unsetenv are equivalent
# Runtime configuration files can include other files, with the include directive
# Example: "include my-runtime-configuration-file".
# To include another configuration file only if it is present use:
# includeif runtime-configuration-file
# You can also use ${env} 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 using
# what is the environment variable name or via 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 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 to not-active programs
# Alias: default_cancel_mode (0 = yes)
# Type: boolean (evaluated for true only)
# Default: false
# Example: PHYSICAL_CANCEL TRUE
#
## File I/O
#
# Environment name: COB_MF_FILES
# Parameter name: mf_files
# Purpose: declare that sequential/relative files should be in
# Micro Focus compatible format
# Type: boolean (evaluated for true only)
# Default: false
# Example: mf_files True
# Environment name: COB_VARSEQ_FORMAT
# Parameter name: varseq_format
# Purpose: declare format to be used for variable length sequential files
# Type: 0 means 2 byte record length (big-endian) preceeds record
# 1 means 4 byte record length (big-endian) preceeds record
# 2 means 4 byte record length (local machine int) preceeds record
# 3 means 2 byte length (local machine short) preceeds record
# b32 means 'type 2' above but the 'int' is in Big-Endian format
# l32 means 'type 2' above but the 'int' is in Little-Endian format
# mf means create the file in Micro Focus compatible format
# Default: 0
# Example: VARSEQ_FORMAT 1
# Environment name: COB_VARREL_FORMAT
# Parameter name: varrel_format
# Purpose: declare format to be used for variable length relative files
# Type: gc means 'size_t' record length (local machine) preceeds
# maxiumum length data record
# mf means file is in Micro Focus format
# b32 means Big-Endian 32-bit 'int' record length preceeds data
# b64 means Big-Endian 64-bit 'int' record length preceeds data
# l32 means Little-Endian 32-bit 'int' record length preceeds data
# l64 means Little-Endian 64-bit 'int' record length preceeds data
# Default: gc
# NOTE: 'gc' results in files which cannot be used if copied between
# machines of different hardware archeticture
# Example: VARREL_FORMAT mf
# Environment name: COB_VARFIX_FORMAT
# Parameter name: varfix_format
# Purpose: declare format to be used for fixed length relative files
# Type: gc means 'size_t' record length (local machine) preceeds
# fixed length data record
# mf means file is in Micro Focus format
# b32 means Big-Endian 32-bit 'int' record length preceeds data
# b64 means Big-Endian 64-bit 'int' record length preceeds data
# l32 means Little-Endian 32-bit 'int' record length preceeds data
# l64 means Little-Endian 64-bit 'int' record length preceeds data
# Default: gc
# NOTE: 'gc' results in files which cannot be used if copied between
# machines of different hardware archeticture
# Example: VARFIX_FORMAT mf
# 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 as fixed length (or variable)
# 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
# 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_LS_VALIDATE
# Parameter name: ls_validate
# Purpose: Defines for LINE SEQUENTIAL files that the data should be
# validated as it is read/written
# Type: boolean
# Default: false
# Example: LS_VALIDATE = 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, NONE
# Default: NONE
# 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:
# Type: boolean
# Default: false
# Example: screen_esc Yes
# Environment name: COB_SCREEN_EXCEPTIONS
# Parameter name: screen_exceptions
# Purpose:
# Type: boolean
# Default: false
# Example: screen_exceptions Yes
# Environment name: COB_TIMEOUT_SCALE
# Parameter name: timeout_scale
# Purpose:
# Type: integer
# 1 means 100, 2 means 10, 3 means 1
# Default: 1000
# Example: timeout_scale 3
# Environment name: COB_LEGACY
# Parameter name: legacy
# Purpose:
# Type: boolean
# Default: not set
# Example: timeout_scale 3
# Environment name: COBPRINTER
# Parameter name: printer
# Purpose: Defines command line used for 'popen' of DISPLAY UPON PRINTER
# This is very similar to Micro Focus COBPRINTER
# Each DISPLAY UPON PRINTER statement executed by your COBOL program
# causes a new invocation of command-line. (new process start)
# Each invocation receives the data referenced in the DISPLAY
# statement, and is followed by an end-of-file condition.
# Type: string
# Default: not set
# Example: print 'cat >>/tmp/myprt.log'
# Environment name: COB_DISPLAY_PRINTER
# Parameter name: display_printer
# Purpose: Defines file to be appended to by DISPLAY UPON PRINTER
# Each DISPLAY UPON PRINTER does fopen to apped to the file
# and then closes the file
# Type: string
# Default: not set
# Example: display_printer '/tmp/myprt.log'
#
## Report I/O
#
# Environment name: COB_COL_JUST_LRC
# Parameter name: col_just_lrc
# Purpose: If true, then COLUMN defined as LEFT, RIGHT or CENTER
# will have the data justified within the field limits
# If false, then the data is just copied into the column as is
# Type: boolean
# Default: TRUE
# Example: col_just_lrc True
3.25 How do I get the length of a LINE SEQUENTIAL read?¶
When using ACCESS MODE IS LINE SEQUENTIAL the number of bytes read for the
current record will be set in an identifier by using an FD VARYING
DEPENDING ON clause.
For example,
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 65535 TIMES
DEPENDING ON infile-record-length.
That can be shortened to
FD infile RECORD VARYING DEPENDING ON infile-record-length.
Implicitly set on READ, and controls lengths of WRITE when explicitly set before a WRITE or REWRITE operation.
This FD VARYING clause can also be specified with normal SEQUENTIAL (BINARY SEQUENTIAL) access mode, but that mode is more generally used with already known values and fixed length records.
The identifier can be pretty much any NUMERIC type, but is limited to PIC 9(9) in size, just shy of one billion for record lengths.
3.26 Why can’t libcob find my link modules at run-time?¶
Under normal circumstances, this is not a problem. But, Windows™, GNU/Linux and other operating systems can suffer from a layer of complexity that needs to be overcome for smooth use of dynamic link libraries.
One important issue regarding Ubuntu based distributions of GNU/Linux: A change was made by Canonical™ regarding the link load optimizer, that breaks GnuCOBOL’s ability to find dynamic shared objects, by not including hints as to what libraries are required in executables.
Setting
export COB_LDFLAGS='-Wl, --no-as-needed'
before running cobc will work around the problem until new versions
of GnuCOBOL 2.0 (or later) make their way into the Ubuntu repositories.
And now for some of the more common complexities that developers face.
Most advanced operating systems include a cache of, and/or, a search path to loadable link modules. This may need to be managed by GnuCOBOL application developers to play well with the operating system at hand.
GNU/Linux uses a fair number of environment variables for controlling the search path and a fairly sophisticated system that manages the DSO ecosystem. For historic reasons, almost all the variables and utilities start with LD, as ld is the “link LoaDer”.
LD_LIBRARY_PATH is likely the most commonly used way to manage the search
path for loading dynamic shared objects. LD_RUN_PATH can also be used, and
it hard codes some of the search path in the native executable.
GnuCOBOL adds a layer to the run-time search path with COB_LIBRARY_PATH and
can pre load libraries through the used of COB_PRE_LOAD.
Compile time options can be specified in COB_LDFLAGS and the C compiler’s
LDFLAGS.
GnuCOBOL version 2 includes cobc command line options that allow custom
options to be passed to the underlying C compiler during compilation, which
can be used to solve most, if not all, technical challenges.
-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
For more information see:
More information can be found in some of the more complex example build rules used with things like the SWIG entry at
3.26.1 colons and sem-colons¶
Here is a note from massimo and Ivan on a SourceForge thread as they were coming to grips with linkage issues on Windows.
The problem:
libcob: Cannot find module 'gtk_init'
The trial:
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
And a little later, a solution:
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
3.27 How do I measure GnuCOBOL performance?¶
With great care and attention to detail.
Measuring performance is a rather tricky business. There are many pitfalls in gleaning accurate performance information. But for day to day ballpark estimates there are a variety of tools to sate curiousity, from simple to outright complex.
3.27.1 Benchmarks¶
There are not a lot of publicly available COBOL benchmark programs. This is partly due to the historically closed nature of big business COBOL and partly due to the lack of a free COBOL compiler of GnuCOBOL quality during the long history of COBOL development. That status should change now that GnuCOBOL is more widely available.
One benchmark used with GnuCOBOL is the Telco billing program, listed in the FAQ at What about GnuCOBOL and benchmarks? from code written by Bill Klein and modified by Roger While. More benchmarking suites will be added to this FAQ as they become known and available.
3.27.2 GNU/Linux¶
For most of the examples listed below, anagrams.cob was used. Sources
for this word sorting application can be found on Rosetta Code at:
http://rosettacode.org/wiki/Anagrams#COBOL
There are some very easy ways to get a rough measure of GnuCOBOL program performance when running GNU/Linux.
The time command is one of the first level entries.
prompt$ time cobc -x anagrams.cob
real 0m0.115s
user 0m0.088s
sys 0m0.020s
Compiling the code took just over 1/10th of a second from a human perspective
with about 2/100ths of a second of measurable time in the Linux kernel,
and another 8/100ths of a second in GNU userland. CPU values, I/O and
especially I/O waits can influence the real value considerably.
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
These are very rough estimates, and very dependent on current system activity and a host of other factors. Rough estimates, also limited by available resolution of measurable time slices.
The timestamps displayed by GnuCOBOL started at 17.999 and ended at 18.034, so
just over 3/10ths of a second for the run, including all the I/O to disk and
screen. Which is pretty close to the 4/10ths reported by time for the
real field. As shown, the code scanned for anagrams from a list of 25104
words, read in from a text file with one word per line.
The gprof command is another entry level tool. These profiling feature
are added by passing the -pg option to the gcc compile step when
building a GnuCOBOL executable (or object code).
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_
The gcc -pg compile and link option inserts code to allow for simple
function call profiling. This data is captured to gmon.out during a run.
Turns out the anagram sample ran too fast for gprof to pick out much data.
A second level tool is the Linux kernel perf tool. It goes much deeper in
analysis.
perf creates a perf.data during recording and pumps out a wide variety
of information during reporting. This is a kernel tool as of Linux 2.6.31
(released in 2009), and is still deemed a lightweight performance measurement
tool advertised as “more than just counters”.
Recording a run:
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) ]
And then reporting details from the generated perf.data:
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
Showing where the anagram program spent most of its time. perf is a kernel
tool, and normally needs root access to get at some of the details. Those
details are not included in this GNU userspace run and perf gave a warning
pointing that out.
3.27.3 Other measurement tools¶
There are a lot of performance measurment tools, but for anything beyond very rough estimates, there needs to be a fair investment in time and attention to detail as each sample is analysed.
For Microsoft Windows, a few searches of MSDN will lead to list of official performance analysis tools that are available to developers on that platform.
For Apple, looking at XCode tools such as Instruments will provide a good
start at measuring performance of GnuCOBOL executables.
3.27.4 -debug performance implications¶
Adding -debug to a cobc command line has very negligible impact on
run-time of GnuCOBOL programs. There are quite a few extra C code lines
generated, mostly to track section, paragraph and source line number for
exception reporting, and there are also boundary checks added and a few other
safey measures, but overall they don’t add much burden to executables. These
C source lines usually compile down to a few small tests or variable settings,
and will have little overall impact on performance, except in the most extreme
cases of number crunching applications.
The anagrams.cob timing measurments with and without -debug ended up within the margin of error for the values. There was a wider range of timing values between various runs, then was detected by adding -debug, or not.
The GnuCOBOL project recommends compiling programs with -debug, even for production installs. Unless there are mitigating circumstances, the extra protections and ability for GnuCOBOL to report exact line numbers during exceptions are well worth it, and the -debug option is recommended by the project contributors. It’s optional and needs to be explicitly requested, but even for production builds, this setting is a recommended practice.
3.28 Are there bugs in GnuCOBOL?¶
Yes, some.
Not to put GnuCOBOL in the wrong light. It’s a capable compiler, but it’s not perfect, considering the nearly infinite permutations allowed in COBOL software development. Complexities can sometimes lead to compilation problems. But, in terms of trust, if the compilation succeeds, odds are strongly in favour of the runtime code doing the right thing. GnuCOBOL bugs are most often triggered at compile time, and there are usually work arounds. If there are problems with generated code, the problem will usually be immediately evident on initial tests.
If the compilation succeeds, and initial tests succeed, you can place as much faith in GnuCOBOL as any other complex compiler. When more faith is required, the generated C source codes can be passed through a myriad of static analysis and validation programs that are available for free and for fee. Beyond that, the generated assembler listings can be examined, and beyond that, runtime debuggers are always available.
To increase peace of mind, valgrind is a very capable tool. With point
releases, the core GnuCOBOL test suite passes without leak, both in compiler
and compiled code, or it doesn’t ship.
Almost done with the reputation disclaimers and marketing speak, but two more things needs to be addressed, and this is not unique to GnuCOBOL.
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.
And now on to the realities of some known problems.
Of special note are the edge cases surrounding foreign function interfacing and BY VALUE parameter handling with CALL and PROCEDURE DIVISION USING. COBOL has a very specfic, and rigid, view of data types, and it is sometimes tricky mapping that to non-COBOL programs with different features allowed in call frame setup.
CALL BY VALUE and PROCEDURE DIVISION USING BY VALUE need special
care and attention.
When calling FUNCTION-ID numeric literals can cause problems, the data is
currently passed to the function as a string form. PIC 9 ANY LENGTH in
the LINKAGE SECTION may work, but the best work around is to use
intermediate working storage and MOVE, as then GnuCOBOL will have explicit
data types to work with. Numerical literals currently have no default type
with GnuCOBOL User Defined Functions. This will be fixed, but for now, the
intermediate working storage method works the best.
User Defined Functions cannot return POINTER data, but can return a
record that has a POINTER as the first field.
01 user-pointer USAGE POINTER.
MOVE user-function(user-data) TO user-pointer
will not properly compile. It’s a bug, and it will be fixed.
01 user-record.
05 user-pointer USAGE POINTER.
MOVE user-function(user-data) to user-record
will properly compile and execute. Functions are great for returning group
items, so the above RETURNING block can add all sorts of other fields to
the return values for user functions.
In terms of core COBOL, there are still a few bugs that need to be found and fixed, but not many. The NIST testsuite passes with flying colours, the internal integrity checks during compiler builds are extensive and growing.
4 Reserved Words¶
- 4.1 What are the GnuCOBOL RESERVED words?
- 4.2 Does GnuCOBOL implement any Intrinsic FUNCTIONs?
- 4.3 Can you clarify the use of FUNCTION in GnuCOBOL?
- 4.4 What is the difference between the LENGTH verb and FUNCTION LENGTH?
- 4.5 What STOCK CALL LIBRARY does GnuCOBOL offer?
- 4.6 What are the XF4, XF5, and X91 routines?
- 4.7 What is CBL_OC_NANOSLEEP?
- 4.8 How do you use C$JUSTIFY?
- 4.9 What preprocessor directives are supported by GnuCOBOL?
- 4.10 What are the GnuCOBOL mnemonics?
- 4.11 What are the GnuCOBOL DATA DIVISION level numbers?
4.1 What are the GnuCOBOL RESERVED words?¶
COBOL is a reserved word rich language. The GnuCOBOL compiler recognizes:
514 words in OC 1.1, 136 of which are marked not yet implemented. 378 functional reserved words, as of August 2008.
592 words listed in the reportwriter branch, 472 marked implemented as of January 2015.
4.1.1 ACCEPT¶
Makes data available from the keyboard or operating system to named data items.
GnuCOBOL supports both standard and extended ACCEPT statements.
Most extended ACCEPT statements will require an advanced terminal screen
initialization, which can obscure CONSOLE input and output. See
Why don’t I see any output from my GnuCOBOL program? for some details on
this issue.
A short list of ACCEPT sources:
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 an Enter/Return keystroke. *Extension*
No data from the keyboard (Ctrl-D in a GNU/Linux terminal, for instance) can be
detected with ON EXCEPTION conditional statements.
ACCEPT datafield
ON EXCEPTION
display "datafield got EOF, not changed"
END-ACCEPT
Otherwise, on EOF and console ACCEPT, COBOL will continue, with the accept destination field unchanged.
ACCEPT exception-pic9-4 FROM EXCEPTION-STATUS
comes in handy when dealing with
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
4.1.2 ACCESS¶
Defines a file’s access mode. One of DYNAMIC, RANDOM, SEQUENTIAL, or LINE SEQUENTIAL.
LINE SEQUENTIAL is not standard in the specification, but common with
many COBOL implementations, and very handy when processing text files.
See How do I get the length of a LINE SEQUENTIAL read? for some details.
An example setting up RANDOM access by key:
SELECT filename
ASSIGN TO "filename.dat"
ACCESS MODE IS RANDOM
RELATIVE KEY IS keyfield.
4.1.3 ACTIVE-CLASS¶
Not yet implemented. Object COBOL feature.
4.1.4 ADD¶
Sums two or more numerics, with an eye toward financial precision and error detection. Can also be used with CORRESPONDING to add entire groups of matching fieldnames together.
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
With ROUNDED options:
4.1.4.1 TO and GIVING¶
Bill Woodger points out that using TO and GIVING together can lead to some confusion. With
ADD 1 TO GnuCOBOL
GnuCOBOL is a receiving field and is modified, adding the literal to
current contents.
ADD 1 TO GnuCOBOL GIVING NewCOBOL
GnuCOBOL is a sending field and is not modified. Even though it reads
well as English, some programmers may assume that the TO field is being
changed, when it is not. A more concise expression might be:
ADD 1 GnuCOBOL GIVING NewCOBOL
Both are valid, both are to specificiation, but you might make a maintainer’s life easier if you don’t use both TO and GIVING in the same statement.
4.1.4.2 ADD CORRESPONDING¶
*> 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
==
.
field-a, field-b match. field-c, field-d do not (due to grouping level). fielf-g is an erroneous outcome. There is a bug. The ADD CORRESPONDING, which is treated partly as a field by field add, but also partly like a raw group data add. (Hint: it has to do with low-nibbles in the ASCII encoding system, “abc” is equivalent to x”616263”) but the non-numeric data should not be included in the field match.
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
See Sample shortforms for the sample-template listing.
4.1.5 ADDRESS¶
Allows program access to memory address reference and, under controlled conditions, assignment.
SET pointer-variable TO ADDRESS OF linkage-store
SET ADDRESS OF based-var TO pointer-from-c
CALL "program" RETURNING ADDRESS OF linkage-or-based-var
For an example, using a POINTER along with a BASED POINTER, it is possible to traverse a C, null terminated, string without a buffer allocation, see Can GnuCOBOL display the process environment space?
4.1.6 ADVANCING¶
Programmer control of newline output and paging.
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"
4.1.7 AFTER¶
- An optional INSPECT clause
- An optional WRITE clause
- When specifying out-of-band, declarative procedures
- Nested PERFORM clause
- influence when loop conditional testing occurs
A sample with nested AFTER and TEST AFTER
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.
Will display 55 lines of output. 1 to 11 and 1 to 5. Removing the WITH TEST AFTER clause would cause 40 lines of output. 1 to 10 and 1 to 4.
Same nested loop without the TEST AFTER control flow modifier
PERFORM
VARYING variable FROM 1 BY 1
UNTIL variable > 10
AFTER inner FROM 1 BY 1
UNTIL inner > 4
DISPLAY variable ", " inner
END-PERFORM
Which gives 40 output lines. The WITH TEST AFTER in the original listing applies to both the outer and the nested loops.
With INSPECT:
INSPECT variable REPLACING "/" BY ":" AFTER INITIAL SPACE
With WRITE, usually when generating output destined for printing:
WRITE title-record AFTER ADVANCING PAGE
WRITE record-name AFTER ADVANCING 2 LINES
Declartives:
procedure division.
declaratives.
handlers section.
use after standard error procedure on input.
display "Error during read" upon syserr
exit
.
end declaratives.
4.1.8 ALIGNED¶
Not yet implemented feature that will influence the internal alignment of
not yet implemented USAGE BIT fields.
4.1.9 ALL¶
A multipurpose reserved in context word.
INSPECT variable REPLACING ALL "123" WITH "456".
MOVE ALL QUOTES TO var.
4.1.10 ALLOCATE¶
Allocates working storage for a BASED element, or allocate a given size of heap storage.
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
See FREE.
4.1.11 ALPHABET¶
* 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.
4.1.12 ALPHABETIC¶
One of the GnuCOBOL data class (category) tests.
IF variable IS ALPHABETIC
DISPLAY "alphabetic"
END-IF
ALPHABETIC is defined as a data item that uses only A in the
PICTURE clause. Finding examples of ALPHABETIC data use is difficult,
which means this type is rarely used, favouring ALPHANUMERIC instead.
When tested, only data that are upper case A to Z and lower case a to z
will return true, all others, including any digits 0 to 9 will return false.
4.1.13 ALPHABETIC-LOWER¶
One of the GnuCOBOL data class (category) tests.
IF variable IS ALPHABETIC-LOWER
DISPLAY "alphabetic-lower"
END-IF
4.1.14 ALPHABETIC-UPPER¶
One of the GnuCOBOL data class (category) tests.
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
4.1.15 ALPHANUMERIC¶
A COBOL data category, probably the most common. PIC X. ALPHANUMERIC can be used with INITIALIZE, along with other category names.
INITIALIZE data-record REPLACING ALPHANUMERIC BY literal-value
4.1.16 ALPHANUMERIC-EDITED¶
A trickier to describe COBOL data category. See PICTURE for details on the editing characters available with GnuCOBOL.
INITIALIZE data-record
REPLACING ALPHANUMERIC-EDITED BY identifier-1
4.1.17 ALSO¶
A powerful, multiple conditional expression feature of EVALUATE.
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
4.1.18 ALTER¶
Obsolete, but still supported verb that modifies the jump target for GO TO
statements.
Use with care. Unless you are writing a state machine engine, maybe.
ALTER should rarely be used in COBOL applications without due reason.
GnuCOBOL 2.0 may support this verb, to increase support for legacy code, but NOT as homage to a good idea. To be honest, I might like to see a GnuCOBOL Flying Spaghetti Monster (that works), simply for the eye rolling of righteous indignation, and perhaps the schadenfreude.
Reality is, 2.0 does support ALTER. NIST Test Suite runs now pass over 9,700 tests, up from just under 9,100 with 1.1. Use with care.
A contrived example of ALTER label PROCEEDING TO. Two samples of the output follow, one without, and one with COB_SET_TRACE enabled.
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.
Giving:
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$
Again, except for passing more tests within the NIST COBOL85 stress test, use of ALTER is discouraged. But, under some circumstances, may be a justified path to modify a complex system faced with new legal requirements and only a few minutes to spare before a monthly report needs to be filed. Know it is there, and use with care and understanding.
From Bill Woodger:
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.
And then more from Bill:
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
.
Or:
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.
Simon Sobisch added some commentary to the commentary:
> 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!
4.1.19 ALTERNATE¶
Defines an ALTERNATE key for ISAM data structures.
SELECT file
ASSIGN TO filename
ACCESS MODE IS RANDOM
RECORD KEY IS key-field
ALTERNATE KEY IS alt-key WITH DUPLICATES.
4.1.20 AND¶
A logic operator. COBOL rules of precedence are; NOT, AND, OR.
IF field = "A" AND num = 3
DISPLAY "got 3"
END-IF
COBOL also allows abbreviated combined relational conditions.
IF NOT (a NOT > b AND c AND NOT d)
code
END-IF
is equivalent to
IF NOT (((a NOT > b) AND (a NOT > c)) AND (NOT (a NOT > d)))
code
END-IF
4.1.21 ANY¶
Allows for any value is TRUE in an EVALUATE statement WHEN clause.
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
4.1.22 ANYCASE¶
Not yet implemented. Will allow case insensitive match of currency symbols with FUNCTION NUMVAL-C.
4.1.23 ARE¶
Allows for multiple conditional VALUES.
01 cond-1 PIC X.
88 first-truth VALUES ARE "A" "B" "C".
88 second-truth VALUES ARE "X" "Y" "Z".
4.1.24 AREA¶
Controls SORT, MERGE and RECORD data definitions.
I-O-CONTROL.
SAME RECORD AREA FOR file1, file2.
4.1.26 ARGUMENT-NUMBER¶
Holds the number of OS parsed command line arguments, and can act as the explicit index when retrieving ARGUMENT-VALUE data. ARGUMENT-NUMBER can be used in ACCEPT FROM and DISPLAY UPON expressions.
ACCEPT command-line-argument-count FROM ARGUMENT-NUMBER
DISPLAY 2 UPON ARGUMENT-NUMBER
ACCEPT indexed-command-line-argument FROM ARGUMENT-VALUE
See COMMAND-LINE for more information on the unparsed command invocation string.
4.1.27 ARGUMENT-VALUE¶
Returns the next command line argument. This post from John on opencobol.org is an excellent idiom for parsing command line arguments without too much worry as to the order.
>>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.
Example run:
./cmdline --recv "john ellis" -e -f
invalid switch: -f
john ellis email
4.1.28 ARITHMETIC¶
Not yet implemented feature of the not yet implemented OPTIONS paragraph of the IDENTIFICATION DIVISION.
4.1.29 AS¶
Can be used to change the external linkage name of a program or function.
PROGRAM-ID. program-name AS literal.
Part of a CONSTANT clause
01 const-id AS 123.
01 str-const AS "abc".
Can also change the reference name for EXTERNAL items.
01 shared-data pic x(4) is external AS "newname".
4.1.30 ASCENDING¶
COBOL table support.
01 CLUBTABLE.
05 MEMBER-DATA OCCURS 1 TO 7000000000 TIMES
DEPENDING ON PEOPLE
ASCENDING KEY IS HOURS-DONATED.
Sort order control.
sort clubtable ASCENDING key hours-donated
Also see DESCENDING.
4.1.31 ASCII¶
American Standard Code for Information Interchange.
One of the two main character encodings supported by GnuCOBOL.
See EBCDIC for the other common encoding used in COBOL programming.
ASCII to EBCDIC conversion the GnuCOBOL way
SPECIAL-NAMES.
ALPHABET ALPHA IS ASCII.
ALPHABET BETA IS EBCDIC.
PROCEDURE DIVISION.
INSPECT variable CONVERTING ALPHA TO BETA
But note that that is only safe for character data. Numeric fields will not always convert properly with that mechanism.
See the GNU/Linux command man ascii for a full list of ASCII characters
and numeric values. Keep in mind that COBOL is an ordinal system, and
counting starts at one. See FUNCTION ORD FUNCTION CHAR for some details
of this potential issue when programming.
4.1.32 ASSIGN¶
Assign a name to a file or other external resource.
SELECT input-file
ASSIGN TO "filename.ext"
The actual filename used is dependent on a configuration setting.
Under default configuration settings, filename-mapping is set to yes.
See What are the GnuCOBOL compile time configuration files? for details.
# 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
So, under GNU/Linux, bash shell
$ export DD_DATAFILE='/tmp/opencobol.dat'
$ ./myprog
the program will find the data in /tmp/opencobol.dat
$ export DD_DATAFILE='/tmp/other.dat'
$ ./myprog
this run of the same program will find the data in /tmp/other.dat
As shown in the sample .conf comments, the order of environment variable lookup proceeds through three environment variables before using a literal as the filename.
- DD_DATAFILE
- dd_DATAFILE
- DATAFILE
- and finally “DATAFILE”
where DATAFILE is the name used in
ASSIGN TO name
and can be any valid COBOL identifier, or string leading to a valid operating system filename.
4.1.33 AT¶
Controls cursor positioning of ACCEPT and DISPLAY screen oriented verbs.
*> 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
AT syntax allows for 4 digit and 6 digit values. llcc or lllccc,
where the total length determines if the line and column subfields are treated
as 2 or 3 digits each.
4.1.34 ATTRIBUTE¶
Manage screen field attributes. SET ON OFF for
SET screen-name ATTRIBUTE BLINK OFF
4.1.35 AUTHOR¶
An informational statement in the IDENTIFICATION DIVISION. Deemed OBSOLETE,
but still commonly seen. GnuCOBOL treats this as a to end of line comment
phrase, periods are not required. Multiples AUTHOR statements are allowed.
4.1.36 AUTO¶
Automatic cursor flow to next field in screen section.
4.1.37 AUTO-SKIP¶
Alias for AUTO
4.1.38 AUTOMATIC¶
LOCK MODE IS AUTOMATIC. See MANUAL and EXCLUSIVE for more LOCK options.
4.1.39 AUTOTERMINATE¶
Alias for AUTO
4.1.40 AWAY-FROM-ZERO¶
A rounding MODE. See ROUNDED for more details on the different modes.
| AWAY-FROM-ZERO | +2.49 | -2.49 | +2.50 | -2.50 | +3.49 | -3.49 | +3.50 | -3.50 | +3.51 | -3.51 |
|---|---|---|---|---|---|---|---|---|---|---|
| Becomes | +3 | -3 | +3 | -3 | +4 | -4 | +4 | -4 | +4 | -4 |
A COBOL example (also demonstrating user names that are the same as in context compiler words):
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.
displays:
2, 1
X being rounded away from zero from 1.1 to 2.
4.1.41 B-AND¶
Not yet implemented BIT field operation. See What STOCK CALL LIBRARY does GnuCOBOL offer? CBL_AND for alternatives allowing bitwise operations.
4.1.42 B-NOT¶
Not yet implemented BIT field operation. See What STOCK CALL LIBRARY does GnuCOBOL offer? CBL_NOT for alternatives allowing bitwise operations.
4.1.43 B-OR¶
Not yet implemented BIT field operation. See What STOCK CALL LIBRARY does GnuCOBOL offer? CBL_OR for alternatives allowing bitwise operations.
For example:
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.
giving:
$ cobc -x bits.cob
$ ./bits
002 006 1 +0000000000
s1 is read, t2 is read and written.
For a COBOL source code solution to BIT operations, Paul Chandler was nice enough to publish BITWISE.cbl and a full listing is included at BITWISE.
4.1.44 B-XOR¶
Not yet implemented BIT field operation. See What STOCK CALL LIBRARY does GnuCOBOL offer? CBL_XOR for alternatives allowing bitwise operations.
4.1.45 BACKGROUND-COLOR¶
05 BLANK SCREEN BACKGROUND-COLOR 7 FOREGROUND-COLOR 0.
4.1.46 BACKGROUND-COLOUR¶
Alternate spelling for BACKGROUND-COLOR.
4.1.47 BASED¶
Defines unallocated working storage. The address of the variable will need to be set before access or a run-time error will occur.
01 based-var PIC X(80) BASED.
A sample posted by [human]
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 ---------------------------------------
4.1.48 BEEP¶
Ring the terminal bell during DISPLAY output. Alias for BELL
DISPLAY "Beeeeep" LINE 3 COLUMN 1 WITH BEEP END-DISPLAY.
4.1.49 BEFORE¶
Sets up a PERFORM loop to test the conditional before execution of the
loop body. See AFTER for the alternative. BEFORE is the default.
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
Also used with the WRITE verb.
WRITE record-name
BEFORE ADVANCING some-number LINES
And to control how the INSPECT verb goes about its job.
INSPECT character-var TALLYING
the-count FOR ALL "tests" BEFORE "prefix"
And in the declaratives for REPORT SECTION control.
USE BEFORE REPORTING
...
4.1.50 BELL¶
Ring the terminal bell during DISPLAY output. Alias for BEEP
DISPLAY "Beeeeep" LINE 3 COLUMN 1 WITH BELL END-DISPLAY.
4.1.51 BINARY¶
01 result PIC S9(8) USAGE BINARY
4.1.52 BINARY-C-LONG¶
Extension.
With GnuCOBOL’s tight integration with the C Application Binary Interface the compiler authors have built in support that guarantees a native system C long value being the same bit size between COBOL and C modules. This increases coverage of the plethora of open C library functions that can be directly used with the CALL verb. Including cases where callback functions that require long stack parameters (that can’t as easily be wrapped in thin C code layers) can now be used more effectively and safely.
4.1.53 BINARY-CHAR¶
Defines an 8 bit usage item.
4.1.54 BINARY-DOUBLE¶
Defines a 64 bit usage item.
4.1.55 BINARY-INT¶
Extension. Equivalent to BINARY-LONG 32 bit data item.
4.1.56 BINARY-LONG¶
32 bit native USAGE modifier.
BINARY-LONG SIGNED -2147483648 [-2**31] < n < 2147483648 [2**31]
BINARY-LONG UNSIGNED 0 <= n < 4294967296 [2**32]
Will almost fit in an S9(9) or 9(9). In COBOL, picture 9(10)
doesn’t really work either, as the 10 digits needed to hold 4,294,967,296
would allow for 9,999,999,999 and that actually requires 34 bits of
information.
The largest value that COBOL can hold in 32 bits and still represent the decimal value required by PICTURE 9, is 999,999,999. It is a fundamental difference between base-2 and base-10 representations.
For PIC 9(9) USAGE COMP-5, COBOL allocates 32 bits. Just don’t try
and go to a billion in binary and then display it as USAGE DISPLAY as
things won’t be right.
There was longstanding misinformation here, pointed out by Simon, the old,
wrong documentation was S9(8). Repeat. Wrong. Don’t believe everything
you read here. Verify it, just in case.
As an example, with GnuCOBOL in January of 2016
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.
With a run sample of:
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
You can’t blame COBOL for the erroneous display of 2 ** 30 when converted
to decimal. You can’t blame the computer either. You can only lament the
tragedy that is the human machine interface, and rise to the challenge.
4.1.57 BINARY-LONG-LONG¶
Extension. Equivalent to BINARY-DOUBLE.
4.1.58 BINARY-SHORT¶
16 bit native USAGE. Will fit in S9(5), or 9(5), but note that due
to the differences in decimal and binary representations, the picture may end
up with invalid decimal data. 32767 will display properly with pic s9(5),
70000 (for example) will not, as it requires more then 16 bits in base-2.
4.1.59 BIT¶
Not yet implemented. See What STOCK CALL LIBRARY does GnuCOBOL offer? for alternatives allowing bitwise operations.
4.1.60 BLANK¶
05 BLANK SCREEN BACKGROUND-COLOR 7 FOREGROUND-COLOR 0.
4.1.62 BLOCK¶
A supported, but ignored, file control block control clause. Most POSIX operating systems do not honour attempts to override file and record block sizing. Some TAPE device drivers may honour the setting, but GnuCOBOL simply ignores the phrase.
FD file-name
BLOCK CONTAINS 1 TO n RECORDS
4.1.63 BOOLEAN¶
An as yet unsupported data category.
4.1.64 BOTTOM¶
A LINAGE setting for the number of lines to use for a bottom margin. The bottom margin defaults to zero lines.
FD mini-report
linage is 16 lines
with footing at 15
lines at top 2
lines at bottom 2.
4.1.65 BY¶
VARYING loop variable step value. GnuCOBOL requires this clause and there
is no default step value. Can be any numeric type or value, postitive or
negative, integer or floating point.
PERFORM the-procedure
VARYING step-counter FROM 1 BY step-size
UNTIL step-counter > counter-limit
4.1.66 BYTE-LENGTH¶
Human incisors average about 16mm.
More to the point, BYTE-LENGTH returns the length, in bytes, of a data item. See FUNCTION BYTE-LENGTH. This will become more important as NATIONAL data item support increases in the GnuCOBOL implementations.
4.1.67 CALL¶
The GnuCOBOL CALL verb provides access to library functions. It accepts a
string literal, or name stored in an identifier, when resolving the control
flow transfer address. This assumes the called procedure returns, COBOL
controlled flow proceeding in sequence to the statement immediately following
the END-CALL.
The USING phrase allows argument passing to and from subprograms. GnuCOBOL
includes internal rules for the data representation of the call stack entities,
that depend on the COBOL PICTURE and USAGE clauses. subprogram return
values are captured with a RETURNING phrase.
See What STOCK CALL LIBRARY does GnuCOBOL offer? for a list of CALL
entry names that are included in the GnuCOBOL run-time support libraries.
For some old, historical information see http://open-cobol.sourceforge.net/historical/open-cobol/C-Interface.html
CALL is the verb that opens up access to the plethora of C based ABI
libraries. A plethora, and the standard C library is accessible without
explicit linkage as a bonus.
One item of note is C pointers. Especially those passed around as handles.
When calling a C routine that returns a handle, the RETURNING identifier
will receive a C pointer. To use that handle in later CALL statements, the
argument from COBOL should usually be passed BY VALUE. This passes the C
pointer, not the address of the COBOL identifier, as the default BY
REFERENCE argument handling would do.
Below is a sample that allows fairly carefree use of CBL_OC_DUMP during
development. ON EXCEPTION CONTINUE.
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
*> 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
*> 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
*> Get a dump of the memory used by stuff, abort if not linked <*
call "CBL_OC_DUMP" using stuff 12 end-call
goback.
end program callon.
See What is CBL_OC_DUMP? for details of the subprogram.
A run-time session shows:
$ cobc -x callon.cob
$ ./callon
float-short: 3.14159274
3.1415927 4 +0000000024
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@............
float-short: 3.14159274
3.1415927 4 +0000000024
Offset HEX-- -- -- -5 -- -- -- -- 10 -- -- -- -- 15 -- CHARS----1----5-
000000 61 62 63 64 65 66 67 68 69 6a 6b 6c abcdefghijkl....
Offset HEX-- -- -- -5 -- -- -- -- 10 -- -- -- -- 15 -- CHARS----1----5-
000000 61 62 63 64 65 66 67 68 69 6a 6b 6c abcdefghijkl....
So, the first CALL to CBL_OC_DUMP doesn’t ‘fail’ as the ON EXCEPTION
CONTINUE traps the condition and lets the program carry on without a dump
displayed. The last CALL does abend the program with ‘Cannot find module’
when CBL_OC_DUMP is not compiled in, to show the difference.
4.1.67.1 CALL STATIC¶
Sometimes it is just nice to link in subprograms at compile time.
GnuCOBOL 2.0 and up supports a -K”name” (multiple uses allowed) cobc
option to inform the compiler to link that call module statically, into the
object code. By default CALL is dynamic.
CALL STATIC "puts" USING a-zstring END-CALL
will link to the libc function at compile time, and not rely on the run-time dynamic linker. Works well with Cygwin compiles, which can have a tough time finding the POSIX support DLLs at run-time. See STATIC.
4.1.67.2 CALL STDCALL¶
Changes the call frame handler. With STDCALL, called subprogram are
responsible for parameter stack cleanup adjustment, not the caller. _std
modifier is generated in the intermediate C sources. See STDCALL.
4.1.67.3 RETURNING OMITTED¶
One sticky point with COBOL and CALL. Foreign functions, C in particular,
can specify void return. That means no value is placed on top of the call
frame. Unless told otherwise, COBOL will assume that value is there, possibly
popping it off, and corrupting, a call frame stack. To CALL void C, or
assembler routine, for another case, use CALL ... RETURNING OMITTED.
4.1.68 CANCEL¶
Virtual cancel of a module is supported. Physical cancel support is on the development schedule.
4.1.69 CAPACITY¶
Not yet supported.
4.1.70 CD¶
A control clause of the as yet unsupported COMMUNICATION DIVISION.
4.1.71 CENTER¶
An as yet unsupported keyword.
4.1.74 CHAIN¶
Not yet supported.
Invokes a subprogram, with no return of control implied. The chained program unit virtually becomes the main program within the run unit.
4.1.75 CHAINING¶
Passes procedure division data through WORKING-STORAGE and can be used for shell command line arguments as well, as in CALL “myprog” USING string END-CALL.
from opencobol.org by human
WORKING-STORAGE SECTION.
01 cmd-argument.
02 some-text pic x(256).
procedure division Chaining cmd-argument.
display 'You wrote:'
'>"' function trim(some-text) '"'
'from shell command line'
4.1.77 CHARACTERS¶
A multi use keyword.
Used in SPECIAL-NAMES
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.
Output:
$ cobc -x figuratives.cob
$ ./figuratives
thing tabbed thing
and another tabbed thing
other, things
MOVE a-comma : ,
MOVE symbolic: ,,,,,,,,,,,,,,,,,,,,
Used in INSPECT
INSPECT str TALLYING TALLY FOR CHARACTERS BEFORE INITIAL ','
INSPECT str REPLACING CHARACTERS BY '*' AFTER INITIAL ':'
Used in a File Description FD
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.
In the above case, identifier-1 will set a record size limit for write, but
will be filled with the actual length read for reads. Handy for LINE
SEQUENTIAL files and getting at how many characters come in on each line.
Used in ALLOCATE
ALLOCATE 100 * cell-size CHARACTERS RETURNING heap-pointer
4.1.78 CLASS¶
Used to create character classes in SPECIAL-NAMES. In some circumstances, character classes can be used to validate data in a very concise way.
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
4.1.79 CLASS-ID¶
An as yet unsupported Object COBOL class identifier clause.
4.1.80 CLASSIFICATION¶
An as yet unsupported source code internationalization clause.
4.1.81 CLOSE¶
Close an open file. GnuCOBOL will implicitly close all open resources at termination of a run unit and will display a warning message stating it did so, and the danger of potentially unsafe termination.
CLOSE input-file
4.1.82 COB-CRT-STATUS¶
Predefined PIC 9(4) special register for CRT status. This field is not predefined if an explicit
CRT STATUS IS user-field
is used in a SPECIAL-NAMES paragraph.
4.1.83 CODE¶
A clause of a report descriptor, RD.
4.1.84 CODE-SET¶
An as yet unsupported data internationalization clause.
4.1.85 COL¶
Alias for COLUMN.
4.1.86 COLLATING¶
Allows definition within a program unit of a character set.
OBJECT-COMPUTER. name.
PROGRAM COLLATING SEQUENCE IS alphabet-1.
4.1.87 COLS¶
Alias for COLUMNS.
4.1.88 COLUMN¶
- A REPORT SECTION RD descriptor clause.
- Also used for positional DISPLAY and ACCEPT, which implicitly uses SCREEN SECTION style ncurses screen IO.
DISPLAY var-1 LINE 1 COLUMN 23
When using the condensed form of extended AT, the first two (or three) digits are LINE and the last two (or three) digits are COLUMN. These literal values can be either four or six digits.
DISPLAY "Text" AT 0203
DISPLAY "Text" AT 002101 WITH REVERSE-VIDEO
4.1.90 COMMA¶
A SPECIAL-NAMES clause supporting commas in numeric values versus the default period decimal point. COBOL was way ahead of the internationalization curve, and this feature has caused compiler writers no little grief in its time, a challenge they rise to and deal with for the world’s benefit.
DECIMAL POINT IS COMMA
4.1.91 COMMAND-LINE¶
Provides access to command line arguments.
ACCEPT the-args FROM COMMAND-LINE END-ACCEPT
COMMAND-LINE is a single character field.
See ARGUMENT-VALUE and ARGUMENT-NUMBER for access to separate shell expanded arguments.
The special system library CBL_OC_HOSTED can also be used to access the
commonly referred to argc and argv argument count and array of
separate argument string pointers that are passed to main funtions
by POSIX friendly operating systems.
4.1.92 COMMIT¶
Flushes ALL current locks, synching file I/O buffers. GnuCOBOL supports safe transactional processing with ROLLBACK capabilities. Assuming the ISAM handler configured when building the compiler can support LOCK_
In tandem with ROLLBACK, the commitment boundary is from OPEN to first COMMIT or ROLLBACK, then until the next COMMIT or ROLLBACK, repeating until CLOSE.
Only a single commitment point is ever active, per file.
4.1.93 COMMON¶
PROGRAM-ID. CBL_OC_PROGRAM IS COMMON PROGRAM.
Ensures a nested subprogram is also available to other nested subprograms with a program unit hierarchy.
4.1.94 COMMUNICATION¶
currently (January 2016) unsupported section, but see Does GnuCOBOL support Message Queues? for an alternative.
4.1.95 COMP¶
A binary USAGE form. Short for COMPUTATIONAL. By COBOL standard, this form is an implementation depedent form. Usually one of the fastest native forms, but not that safe when transferring data between machines, even those compiled with the same version of GnuCOBOL, as it depends on hardware platform.
4.1.96 COMP-1¶
Equivalent of FLOAT-SHORT single precision floating point. GnuCOBOL uses IEEE 754 standard floating point representation.
Alias for COMPUTATIONAL-1
4.1.97 COMP-2¶
Equivalent of FLOAT-LONG double precision floating point. GnuCOBOL uses IEEE 754 standard floating point representation.
See COMPUTATIONAL-2
4.1.98 COMP-3¶
PACKED DECIMAL binary storage form. See COMPUTATIONAL-3
4.1.99 COMP-4¶
Equivalent to BINARY and COMP. See COMPUTATIONAL-4
4.1.100 COMP-5¶
A hardware preferred binary storage form, with allowed PICTURE. This can lead to some interesting edge cases.
For example; PIC S9(4) will need 2 bytes of storage. That leads to values between -32768 and +32767. But, a PIC S9(4) is limited to display usage in the range -9999 to +9999. Internal and external view can differ considerably.
Dual PIC and BINARY fields need to be treated with care and respect. COMP-5
is subject to external high order truncation when displayed by PICTURE and
during PICTURE based MOVE instructions. The compiler option -fnotrunc
can modify this behaviour and may display fields wider than the PICTURE.
COMP-5 is always native memory storage order, independent of the
binary-byteorder configuration setting.
COMP-5 will share the same byte order forms as C programs on the same platform.
COMP-5 byte order may not be suitable for some network data when using common
Intel chip sets, as the internet uses big-endian form and Intel is
commonly little-endian layout.
A compile time test, using the Compiler Directive Facility is available with a predefined ENDIAN symbol. It will hold BIG or LITTLE at compile time.
>>IF ENDIAN = "BIG"
big end code
>>END-IF
>>IF ENDIAN = "LITTLE"
little end code
>>END-IF
See COMPUTATIONAL-5
4.1.102 COMP-X¶
A binary USAGE format with PICTURE data allowed to be any alphanumeric type. PIC X data can be treated as computational numerics with COMP-X.
Stored in memory dependent on the binary-byteorder configuration setting.
Can be native or big-endian order. COMP-X allows binary data that use
PIC X definitions. By default, GnuCOBOL stores BINARY data in big-endian
order.
Please note that the binary-byteorder setting can vary from compile to
compile and the same source code can produce different binary fields when this
setting is changed between compiles. GnuCOBOL keeps an internal flag attached
to each and every field that determines whether byte reording code is needed
when managing platform byte order and current ‘COBOL’ byte order.
Unless involved in cross platform data sharing or networking, programmers will rarely have to worry about this as the compiler keeps track and swaps bytes as needed.
*> 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
==
.
Giving:
$ cobc -xj compx-sample.cob
sample-template.cob: 12: Warning: Numeric value is expected
465407834
465407835
See Sample shortforms for the sample-template listing.
COMPUTATIONAL-X is the long form alias of COMP-X.
4.1.103 COMPUTATIONAL¶
Implementors choice binary storage form; GnuCOBOL is a big-endian default. With most Intel personal computers and operating systems like GNU/Linux, COMPUTATIONAL-X will run faster, as internal byte swapping can be avoided.
The default byte-order is controlled by compile time configuration though, and care must be taken when making assumptions if data is being transferred over the network or between machines. See What are the GnuCOBOL compile time configuration files? and What is rumtime.cfg? for more details on these low level issues. As this is compile time control, looking at current settings may not be accurate compared to the executable, which may have been compiled when different settings where in place. This can really only be verified from inside the executable itself, with a byte-order test at runtime.
An example for byte-order testing can be found in the CBL_OC_DUMP sources
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.
Where the first byte of the value 128 in byline will be zero for little-endian and non-zero for big-endian storage. Endian order testing has to make assumptions about known bit layouts of multiple byte numeric data to be reliable and it is difficult to make this determination by external means. Native order is not always applicable as GnuCOBOL will add code to swap bytes depending on the byte-order configuration setting at compile time if needed.
4.1.104 COMPUTATIONAL-1¶
Single precision float. Equivalent to FLOAT-SHORT.
4.1.105 COMPUTATIONAL-2¶
Double precision float. Equivalent to FLOAT-LONG.
4.1.106 COMPUTATIONAL-3¶
Equivalent to PACKED DECIMAL. Packed decimal is stored as two digits per byte, always sign extended and influenced by a .conf setting binary-size. COMPUTATIONAL-6 is UNSIGNED PACKED.
4.1.107 COMPUTATIONAL-4¶
Equivalent to BINARY.
4.1.108 COMPUTATIONAL-5¶
Native form.
4.1.109 COMPUTATIONAL-6¶
Unsigned packed decimal form, see COMPUTATIONAL-3.
4.1.110 COMPUTATIONAL-X¶
Binary form, allowing PIC X data to be treated as a computational numeric value.
4.1.111 COMPUTE¶
Computational arithmetic.
COMPUTE circular-area = radius ** 2 * FUNCTION PI END-COMPUTE
GnuCOBOL supports the normal gamut of arithmetic expressions.
- Add +
- Subtract -
- Multiply *
- Divide /
- Raise to power **
Order of precedence rules apply.
- unary minus, unary plus
- exponentiation
- multiplication, division
- addition, subtraction
Spaces and expressions
Due to COBOL allowing dash in user names, care must be taken to properly space arithmetic expressions.
Some examples of seemingly ambiguous and potentially dangerous code
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.
That is not three times var minus one, it is 3 times var-1 GnuCOBOL will complain.
$ cobc -x computing.cob
computing.cob:18: Error: 'var-1' is not defined
whew, saved!
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.
With the above source, the compile will succeed.
$ cobc -x computing.cob
GnuCOBOL will, (properly, according to standard), compile this as three times var-1. Not saved, if you meant 3 times var minus 1.
GnuCOBOL programmers are strongly encouraged to use full spacing inside COMPUTE statements.
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 supports ON SIZE ERROR, NOT ON SIZE ERROR conditionals for safety, and many ROUNDED modifiers for bankers. There are eight (8) different roundings.
COMPUTE
total ROUNDED MODE NEAREST-AWAY-FROM-ZERO =
total - amount * rate / time-span
END-COMPUTE
With the default being NEAREST-AWAY-FROM-ZERO with ROUNDED, and TRUNCATION when the ROUNDED keyword is not present.
4.1.112 CONDITION¶
As yet unsupported USE AFTER EXCEPTION CONDITION clause.
4.1.113 CONFIGURATION¶
A SECTION of the ENVIRONMENT DIVISION. Holds paragraphs for
4.1.114 CONSTANT¶
A data definition keyword allowing for constant values. These values cannot
be passed by reference, nor can the data name be used with ADDRESS OF.
01 enumerated-value CONSTANT AS 500.
01 some-string CONSTANT AS "immutable value".
4.1.117 CONTINUE¶
A placeholder, no operation verb. That’s not quite true, continue breaks
out of the current statement, doing nothing else.
The sample below isn’t good design, only a poor example.
if action-flag = "C" or "R" or "U" or "D"
continue
else
display "invalid action-code"
end-if
A pretty handy use for continue, while developing and coming to grips with
C structures and unknown datums:
call "CBL_OC_DUMP" using cstruct ON EXCEPTION CONTINUE end-call
Including CBL_OC_DUMP in the cobc tectonics, causes a hex dump. Without linkage; no runtime error, just continue, avoiding a stop run.
4.1.118 CONTROL¶
REPORT SECTION clause for setting control break data fields.
4.1.119 CONTROLS¶
REPORT SECTION clause for setting control break data fields.
4.1.121 CONVERTING¶
A clause of the INSPECT verb.
INSPECT X CONVERTING "012345678" TO "999999999".
GnuCOBOL supports an extension statement, TRANSFORM which is identical in
effect to INSPECT CONVERTING.
4.1.122 COPY¶
The COBOL include preprocessor verb. Source text is inserted from an external text file, sometimes called a copybook, and treated as if it was typed into the current source file (with some possible REPLACING modifications during the copy include operation).
Also see REPLACE and Does GnuCOBOL support COPY includes?.
For example
Given cobweb-gtk-data-preamble.cpy
*> Repository default data names
01 gtk-window-record.
05 gtk-window usage pointer.
05 gwr-pointer usage pointer.
05 gwr-number usage binary-long.
*> ...
with cobweb-gtk.cob
*> 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.
then cobc -x cobweb-gtk.cob which will start up a compile, with part of the
data division loaded with some ease of use data field names that may ship with
FUNCTION-ID repositories, perhaps the REPOSITORY list itself in another
copybook, and perhaps some init code needed by the library or application.
See What extensions are used if cobc is called with/without “-ext” for COPY?
for details regarding the search path used by COPY.
4.1.122.1 COPY REPLACING¶
In the real world, copybooks are often created with some form of tag. The tag is replaced at compile time so that multiple copies of the same record layout can be used without having conflicting names.
copybook.cpy
01 :tag:-record.
05 :tag:-keyfield PIC X(8).
05 :tag:-description PIC X(32).
05 :tag:-itemlist PIC X(8) OCCURS subitems TIMES.
contrived.cob
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.
4.1.122.2 Full stop and COPY¶
Many samples in this document are single sentence COBOL programs. No periods in the procedure division, except the last and only one, required to end a COBOL program source unit. This is likely an extremely rare style of production COBOL development. There will be numerous required full stop periods in the procedure division, to separate sections and named paragraphs in almost all useful COBOL programs. Mentioning this here to setup the context for the following notice.
Of note:
COPY statements always needs a period, regardless of where they are in the source program. The period terminates the COPY statement, and does NOT get included in the compilation source.
4.1.123 CORR¶
Alias for CORRESPONDING.
4.1.124 CORRESPONDING¶
Move, or do arthimetic, any and all sub fields with matching names within records.
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
4.1.125 COUNT¶
Sets the count of characters set in an UNSTRING substring.
From the GnuCOBOL Programmer’s Guide’s UNSTRING entry.
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
4.1.126 CRT¶
SPECIAL-NAMES.
CONSOLE IS CRT
CRT STATUS is identifier-1.
CONSOLE IS CRT allows “CRT” and “CONSOLE” to be used interchangeably on DISPLAY but this is a default for newer GnuCOBOL implementations.
CRT STATUS IS establishes a PIC 9(4) field for screen ACCEPT status codes. There is also an implicit COB-CRT-STATUS register defined for all programs, that will be used if no explicit field is established.
4.1.127 CRT-UNDER¶
Alias for CRT.
4.1.128 CURRENCY¶
SPECIAL-NAMES.
CURRENCY SIGN IS literal-1.
Default currency sign is the dollar sign “$”.
4.1.129 CURSOR¶
Tracks the line/column location of screen ACCEPT.
SPECIAL-NAMES.
CURSOR IS identifier-2.
identifier-2 is to be declared as PIC 9(4) or 9(6). If 4, the field is LLCC. With 9(6) it is LLLCCC where L is line and C is column, zero relative.
4.1.130 CYCLE¶
A clause that causes EXIT PERFORM to return to the top of a loop. See FOREVER for an example.
4.1.131 DATA¶
A magical DIVISION. One of COBOL’s major strength is the rules surrounding the DATA DIVISION and pictorial record definitions.
4.1.132 DATA-POINTER¶
An as yet unsupported Object COBOL feature.
4.1.133 DATE¶
An ACCEPT source. 6 digit and 8 digit Gregorian dates.
- ACCEPT ident-1 FROM DATE
- ACCEPT ident-2 FROM DATE YYYYMMDD
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
4.1.134 DATE-COMPILED¶
An informational paragraph in the IDENTIFICATION DIVISION. Deemed OBSOLETE, but still in use. GnuCOBOL treats this as a comment paragraph.
4.1.135 DATE-MODIFIED¶
An informational paragraph in the IDENTIFICATION DIVISION. Deemed OBSOLETE, but still in use. GnuCOBOL treats this as a comment paragraph.
4.1.136 DATE-WRITTEN¶
An informational paragraph in the IDENTIFICATION DIVISION. Deemed OBSOLETE, but still in use. GnuCOBOL treats this as a comment paragraph.
4.1.137 DAY¶
An ACCEPT source. Access the current date in Julian form. Returns yyddd and yyyyddd formats.
- ACCEPT ident-1 FROM DAY
- ACCEPT ident-2 FROM DAY YYYYDDD
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
4.1.138 DAY-OF-WEEK¶
An ACCEPT source. Single digit day of week. 1 for Monday, 7 for Sunday.
accept the-day from day-of-week
4.1.139 DE¶
Report Writer shortcut for DETAIL. This author found this type of shortcut very unCOBOL, until trying to layout a report, when it made a lot more practical sense in FIXED form COBOL.
4.1.140 DEBUGGING¶
A SOURCE-COMPUTER clause and DECLARATIVE phrase.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER mine
WITH DEBUGGING MODE.
DEBUGGING MODE can also be toggled on with the -fdebugging-line cobc option, and will compile in ‘D’ lines.
PROCEDURE DIVISION.
DECLARATIVES.
decl-debug section.
USE FOR DEBUGGING ON ALL PROCEDURES
decl-paragraph.
DISPLAY "Why is this happening to me?"
END DECLARATIVES.
USE FOR DEBUGGING sets up a section that is executed when the named section is entered. Powerful. It can also name a file, and the debug section is evaluated after open, close, read, start etc. Identifiers can be also be named and the debug section will trigger when referenced (usually after).
4.1.141 DECIMAL-POINT¶
Allows internationalization for number formatting. In particular
IDENTIFICATION DIVISION.
PROGRAM-ID. 'MEMALL'.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES. DECIMAL-POINT IS COMMA.
will cause GnuCOBOL to interpret numeric literals along the lines of 123,45 as one hundred twenty three and forty five one hundredths.
DECIMAL-POINT IS COMMA, while world friendly, can be the cause of ambiguous parsing and care must be taken by developers that use comma to separate parameters to FUNCTIONs.
4.1.142 DECLARATIVES¶
An imperative entry that can control exception handling of file operations and turn on debug entry points.
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.
4.1.143 DEFAULT¶
A multi-use clause used in
- CALL ... SIZE IS DEFAULT
- ENTRY ... SIZE IS DEFAULT
- INITIALIZE ... WITH ... THEN TO DEFAULT
4.1.144 DELETE¶
- Allows removal of records from RELATIVE and INDEXED files.
- Allows removing files by COBOL name, including all associated support files.
DELETE filename-1 RECORD
INVALID KEY
DISPLAY "no delete"
NOT INVALID KEY
DISPLAY "record removed"
END-DELETE
4.1.144.1 GC 2.0¶
GnuCOBOL 2.0 and up, allows for file deletes.
DELETE FILE
filename-1 filename-2 filename-3
END-DELETE
will remove files by FD SELECT name, including any implicit .idx key index files used by ISAM handlers, or delete by literal filesystem name.
4.1.145 DELIMITED¶
A fairly powerful keyword used with the STRING and UNSTRING verbs. Accepts literals and the BY SIZE modifier.
STRING null-terminated
DELIMITED BY LOW-VALUE
INTO no-zero
END-STRING
4.1.146 DELIMITER¶
Tracks which delimiter was used for a substring in an UNSTRING operation.
From Gary’s OCic.cbl
UNSTRING Expand-Code-Rec
DELIMITED BY ". " OR " "
INTO SPI-Current-Token
DELIMITER IN Delim
WITH POINTER Src-Ptr
END-UNSTRING
4.1.147 DEPENDING¶
Sets a control identifier for variable OCCURS table definitions.
01 TABLE-DATA.
05 TABLE-ELEMENTS
OCCURS 1 TO 100 TIMES DEPENDING ON crowd-size
INDEXED BY cursor-var.
10 field-1 PIC X.
4.1.148 DESCENDING¶
Controls a descending sort and/or retrieval order, with
4.1.149 DESTINATION¶
Currently unsupported data descriptor. Part of VALIDATE.
4.1.150 DETAIL¶
A report descriptor detail line control clause.
4.1.151 DISABLE¶
An unsupported COMMUNICATION SECTION control verb.
4.1.152 DISC¶
Alternate spelling for DISK.
4.1.153 DISK¶
A SELECT devicename phrase.
ASSIGN TO DISK USING dataname
Alternative spelling of DISC is allowed.
4.1.154 DISPLAY¶
A general purpose output, and operating environment setting verb.
- prints values to default console or other device
- set the current ARGUMENT-NUMBER influencing subsequent access ACCEPT FROM ARGUMENT-VALUE statements
- specify explicit COMMAND-LINE influencing subsequent access with ACCEPT FROM COMMAND-LINE, but not ARGUMENT-VALUE access
- sets environment variables, as part of a two step process.
(Use the more concise SET ENVIRONMENT instead)
- DISPLAY “envname” UPON ENVIRONMENT-NAME
- DISPLAY “envname-value” UPON ENVIRONMENT-VALUE
DISPLAY "First value: " a-variable " and another string"
DISPLAY "1" 23 "4"
The setting of environment variables does not influence the owning process shell.
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"
gives:
$ ENVNAME="parent shell value"
$ ./disps
COBOL value
$ echo $ENVNAME
parent shell value
4.1.155 DIVIDE¶
Highly precise arithmetic.
Supports various forms:
- DIVIDE INTO
- DIVIDE INTO GIVING
- DIVIDE BY GIVING
- DIVIDE INTO with REMAINDER
- DIVIDE BY with REMAINDER
For example:
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
The 2014 standard requires conforming implementations to use 1,000 digits of precision for intermediate results. There will be no rounding errors when properly calculating financials in a COBOL program.
4.1.156 DIVISION¶
Ahh, sub-divisions. I think my favourite is the DATA DIVISION. It gives COBOL a distinctive and delicious flavour in a picturesque codescape.
Divisions must be specified in the order below within each source program unit.
- IDENTIFICATION DIVISION.
- ENVIRONMENT DIVISION.
- DATA DIVISION.
- PROCEDURE DIVISION.
A handy mnemonic may be “I Enter Data Properly”.
GnuCOBOL is flexible enough to compile files with only a PROCEDURE DIVISION, and even then it really only needs a PROGRAM-ID. See What is the shortest GnuCOBOL program? for an example.
4.1.157 DOWN¶
Allows decrement of an index control or pointer variable.
SET ind-1 DOWN BY 2
SET ptr-1 DOWN BY 8
Also used for SCREEN SECTION scroll control.
SCROLL DOWN 5 LINES
4.1.158 DUPLICATES¶
Allows duplicate keys in indexed files.
SELECT filename
ALTERNATE RECORD KEY IS altkey WITH DUPLICATES
Also for SORT control.
SORT filename ON DESCENDING KEY keyfield
WITH DUPLICATES IN ORDER
USING sort-in GIVING sort-out.
4.1.159 DYNAMIC¶
A file access mode allowing runtime control over SEQUENTIAL and RANDOM access for INDEXED and RELATIVE ORGANIZATION.
SELECT filename
ORGANIZATION IS RELATIVE
ACCESS MODE IS DYNAMIC
4.1.160 EBCDIC¶
Extended Binary Coded Decimal Interchange Code.
A character encoding common to mainframe systems, therefore COBOL, therefore GnuCOBOL. Different than ASCII and GnuCOBOL supports both through efficient mappings. See https://en.wikipedia.org/wiki/EBCDIC for more info.
ASCII to EBCDIC conversion the GnuCOBOL way
SPECIAL-NAMES.
ALPHABET ALPHA IS NATIVE.
ALPHABET BETA IS EBCDIC.
PROCEDURE DIVISION.
INSPECT variable CONVERTING ALPHA TO BETA
4.1.161 EC¶
An unsupported short form for USE AFTER EXCEPTION CONDITION
4.1.162 EGI¶
An unsupported COMMUNICATION SECTION word.
4.1.163 ELSE¶
Alternate conditional branch point.
IF AGE IS ZERO
DISPLAY "Cigar time"
ELSE
DISPLAY "What is it with kids anyway?"
END-IF
For multi branch conditionals, see EVALUATE.
4.1.164 EMI¶
An unsupported COMMUNICATION SECTION word.
4.1.165 EMPTY-CHECK¶
Alias for the REQUIRED screen attribute.
4.1.166 ENABLE¶
An unsupported COMMUNICATION SECTION control verb.
4.1.168 END-ACCEPT¶
Explicit terminator for ACCEPT.
4.1.169 END-ADD¶
Explicit terminator for ADD.
4.1.170 END-CALL¶
Explicit terminator for CALL.
4.1.172 END-COMPUTE¶
Explicit terminator for COMPUTE.
4.1.173 END-DELETE¶
Explicit terminator for DELETE.
4.1.174 END-DISPLAY¶
Explicit terminator for DISPLAY.
Many samples from this FAQ used to use END-DISPLAY, they are being purged, as of October 2015, unless necessary.
4.1.175 END-DIVIDE¶
Explicit terminator for DIVIDE.
4.1.176 END-EVALUATE¶
Explicit terminator for EVALUATE.
4.1.177 END-IF¶
Explicit terminator for IF.
4.1.178 END-MULTIPLY¶
Explicit terminator for MULTIPLY.
4.1.179 END-OF-PAGE¶
A LINAGE phrase used by WRITE controlling end of page imperative clause.
4.1.180 END-PERFORM¶
Explicit terminator for PERFORM.
4.1.181 END-READ¶
Explicit terminator for READ.
4.1.182 END-RECEIVE¶
Explicit terminator for RECEIVE.
4.1.183 END-RETURN¶
Explicit terminator for RETURN.
4.1.184 END-REWRITE¶
Explicit terminator for REWRITE.
4.1.185 END-SEARCH¶
Explicit terminator for SEARCH.
4.1.186 END-START¶
Explicit terminator for START.
4.1.187 END-STRING¶
Explicit terminator for STRING.
4.1.188 END-SUBTRACT¶
Explicit terminator for SUBTRACT.
4.1.189 END-UNSTRING¶
Explicit terminator for UNSTRING.
4.1.190 END-WRITE¶
Explicit terminator for WRITE.
4.1.191 ENTRY¶
Allows for CALL entry points without being fully specified subprograms. Great for defining callbacks required by many GUI frameworks.
See Does GnuCOBOL support the GIMP ToolKit, GTK+? for an example.
4.1.192 ENTRY-CONVENTION¶
An as yet unsupported clause.
4.1.193 ENVIRONMENT¶
Divisional name. And allows access to operating system environment variables. GnuCOBOL supports
- CONFIGURATION SECTION
- INPUT-OUTPUT SECTION
within the ENVIRONMENT DIVISION.
Also a context sensitive keyword for access to the process environment variables.
- SET ENVIRONMENT “env-var” TO value
- ACCEPT var FROM ENVIRONMENT “env-var” END-ACCEPT
4.1.194 ENVIRONMENT-NAME¶
Provides access to the running process environment variables.
4.1.195 ENVIRONMENT-VALUE¶
Provides access to the running process environment variables.
4.1.196 EO¶
An unsupported short form for USE AFTER EXCEPTION OBJECT
4.1.197 EOL¶
ERASE to End Of Line.
4.1.198 EOP¶
LINAGE clause short form for END-OF-PAGE.
4.1.199 EOS¶
ERASE to End Of Screen.
4.1.200 EQUAL¶
Conditional expression to compare two data items for equality.
4.1.201 EQUALS¶
Conditional expression to compare two data items for equality.
4.1.202 ERASE¶
A screen section data attribute clause that can control which portions of the screen are cleared during DISPLAY, and ACCEPT.
01 form-record.
02 first-field PIC xxx
USING identifier-1
ERASE EOL.
4.1.203 ERROR¶
A DECLARATIVES clause that can control error handling.
USE AFTER STANDARD ERROR PROCEDURE ON filename-1
Program return control.
STOP RUN WITH ERROR STATUS stat-var.
4.1.204 ESCAPE¶
Programmer access to escape key value during ACCEPT.
ACCEPT identifier FROM ESCAPE KEY END-ACCEPT
Data type is 9(4).
4.1.205 ESI¶
Unsupported COMMUNICATION SECTION control.
4.1.206 EVALUATE¶
A very powerful and concise selection construct.
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
4.1.207 EXCEPTION¶
Allow detection of CALL problem.
CALL "CBL_OC_DUMP" ON EXCEPTION CONTINUE END-CALL
4.1.208 EXCEPTION-OBJECT¶
Unsupported object COBOL data item reference.
4.1.209 EXCLUSIVE¶
Mode control for file locks.
4.1.210 EXIT¶
A program control flow verb. Used for both inline, and paragraph/section programming.
GnuCOBOL supports
EXIT PERFORM CYCLE causes an inline perform to return control to the
VARYING, UNTIL or TIMES clause, testing the conditional to see if another
cycle is required. EXIT PERFORM without the CYCLE option causes flow to
continue passed the end of the current PERFORM loop.
4.1.211 EXPANDS¶
Unsupported COMMUNICATION SECTION control.
4.1.212 EXTEND¶
Open a resource in an append mode.
4.1.213 EXTERNAL¶
Clause to specify external data item, file connection and program unit.
77 shared-var PIC S9(4) IS EXTERNAL AS 'shared_var'.
Can come in handy while cheating, errr, during development, before a better data coupling design pattern is established.
*> ********************************************************
*> 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.
from early cobweb-gui.cob. A button linked to a text entry through an external.
gtk-entry-data being an 01 external definition in cobweb-gui main as well.
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.
Please note, as advised, this is cheating. A more practical data coupling will be developed, before cobweb-gtk hits a 1.0 reference implementation.
4.1.214 FACTORY¶
An unsupported object COBOL keyword.
4.1.215 FALSE¶
Logical false and conditional set condition.
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
Runs as:
$ ./conditionals
1
0
Also used in EVALUATE, inverting the normal sense of WHEN
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
4.1.216 FD¶
The record side of the COBOL file system. The File Descriptor. COBOL provides lots of control over file access. FD is part of that engine.
Sort files use SD
Some FD phrases are old, and their uses have been overtaken by features of modern operating systems.
- BLOCK CONTAINS
- RECORDING MODE IS
Others are pretty cool. LINAGE is one example. FD supports a mini report
writer feature. Control over lines per page, header, footer and a line
counter, LINAGE IS, that is implicitly maintained by GnuCOBOL during file
writes. These files are usually reports, but they don’t have to be, LINAGE
can be used for a simple step counter when you’d like progress displays of
file updates.
Other recognized file descriptions include:
- RECORD IS VARYING IN SIZE FROM 1 TO 999999999 DEPENDING ON size-variable Record sizes need to fit in PIC 9(9), just shy of a thousand million.
- CODE-SET IS alphabet-name
- DATA RECORD IS data-name
- LABEL RECORDS ARE STANDARD (or OMITTED)
- RECORD CONTAINS 132 CHARACTERS
FD filename-sample
RECORD IS VARYING IN SIZE FROM 1 TO 32768 CHARACTERS
DEPENDING ON record-size-sample.
4.1.217 FILE¶
FILE is another multi use COBOL word.
- A SECTION of the DATA DIVISION.
The FILE section holds file description paragraphs and buffer layouts.
data division.
FILE section.
fd cobol-file-selector.
01 cobol-io-buffer pic x(132).
- a context word for setting name for FILE STATUS fields in FILE-CONTROL paragraphs.
Some programmers don’t like seeing COBOL code that does not verify and test
FILE STATUS, so you should. See ISAM for the numeric codes supported.
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".
- a context word as part of the PROCEDURE DIVISION declarative statements allowing for out-of-band exception handling for file access.
Exception handling with declaratives can be powerful, but some programmers find the out of band nature of where the source code that caused a problem compared to where the error handler is, distasteful.
procedure division.
declaratives.
error-handling section.
USE AFTER EXCEPTION FILE filename-maybe.
error-handler.
display "Exception on filename"
.
end declaratives.
Support for USE AFTER EXCEPTION FILE is a work in progress. Using
DECLARATIVES forces use of section names in the PROCEDURE DIVISION.
- a context word as part of DELETE FILE filenames.
DELETE FILE file-selector-1 file-selector-2
DELETE FILE is supported in GnuCOBOL 2.0.
4.1.217.1 GnuCOBOL FILE STATUS codes¶
The condition of a COBOL I/O operation is set in an identifier specified in a FILE STATUS IS clause.
John Ellis did us the favour of codifying the GnuCOBOL FILE STATUS codes
From http://oldsite.add1tocobol.com/tiki-list_file_gallery.php?galleryId=1 statcodes.cpy courtesy of John Ellis.
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'.
Download and then in your WORKING-STORAGE SECTION use
COPY “statcodes.cpy”.
Or, perhaps even better, is a callable sub-program developed by Steve Williams
as part of his most excellent World Cities COBOL tutorial samples,
checkfilestatus.cpy.
Hosted at http://sourceforge.net/p/open-cobol/contrib/HEAD/tree/trunk/samples/worldcities/
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.
Giving human readable messages when reporting on status conditions.
4.1.218 FILE-CONTROL¶
Files. The paragraph in the INPUT-OUTPUT section, in the ENVIRONMENT division. It’s verbose, a little voodooey, and totally worth it.
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".
4.1.219 FILE-ID¶
File naming clause. Assigned name may be device, FD clause specifies value of the file identifier.
VALUE OF FILE-ID IS file-ids in summary-array
more specifically
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".
An alternative, and likely more common, method is to set the actual filename
(or the enviroment variable that references the actual filename) in the
ASSIGN clause. GnuCOBOL has a configuration setting to control how the
actual filenames are mapped, see ASSIGN. VALUE OF FILE-ID is not ISO
standard COBOL.
4.1.220 FILLER¶
Data division clause, for unnamed data allocations; filler, if you will.
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).
FILLER is an optional word, and this code snippet is equivalent.
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).
COBOL even allows the compiler to count the length of FILLER sub-fields when
literals are involved. No need for the pic x(35).
01 the-record.
05 first-field pic x(10).
05 value "this space intentionally left blank".
05 third-field pic x(10).
Personal preference of this author is to explicitly type FILLER.
4.1.221 FINAL¶
A Report Writer feature to allow for end or report summation control.
CONTROLS ARE FINAL, datafield-1, datafield-2
4.1.222 FIRST¶
Inside an RD report description, specifies placement of FIRST DETAIL line.
4.1.223 FLOAT-BINARY-128¶
Not yet supported. 128 bit floating point data type.
4.1.224 FLOAT-BINARY-32¶
Not yet supported. 32 bit floating point data type.
4.1.225 FLOAT-BINARY-64¶
Not yet supported. 64 bit floating point data type.
4.1.226 FLOAT-DECIMAL-16¶
IEEE Std 754-2008 defined 16 digit floating decimal data type.
64 bit internal storage.
#!/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
==
.
With a run sample showing default formatting:
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
See Sample shortforms for the sample-template listing.
4.1.227 FLOAT-DECIMAL-34¶
IEEE Std 754-2008 defined 34 digit floating decimal data type.
128 bit internal storage.
#!/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
==
.
And a run to show default and two sample picture forms:
$ ./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
A float-decimal-34 as a 128 bit value:
2 ** 128 as D-34 = 3402823669209384634633746074317682E5
And to maximum numeric digits (from 126 bits):
2 ** 126 as 9(38) = 85070591730234615865843651857942050000
as numeric-edit = 85,070,591,730,234,615,865,843,651,857,942,050,000
See Sample shortforms for the sample-template listing.
4.1.228 FLOAT-EXTENDED¶
Not yet supported. GnuCOBOL recognizes but does not yet support FLOAT-EXTENDED and will abend a compile.
4.1.229 FLOAT-INFINITY¶
Not yet supported. Value will represent floting point infinity.
4.1.230 FLOAT-LONG¶
GnuCOBOL supports floating point long.
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.
displays:
$ ./threes
(1/3) as short 0.333333343267440796
(1/3) as long 0.333333333333333315
(1/6) as pic 0.16666666666666666666666666666666666
(1/6) rounded 0.16666666666666666666666666666666667
4.1.231 FLOAT-NOT-A-NUMBER¶
Not yet supported. Value will represent a special bit pattern for floating point NAN.
4.1.232 FLOAT-SHORT¶
GnuCOBOL supports short floating point.
4.1.233 FOOTING¶
A LINAGE clause that specifies the footer area of a page. A WRITE statement to a linage report file will set END-OF-PAGE when the LINAGE-COUNTER is within the footing area. This can be used to skip over or trigger summary lines. The footing area is part of the page body. When not specified, the footing area is the last line of the page body.
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
In the above, the AT END-OF-PAGE condition is true when writing to report
line 13, (and 14, the write of the running-summary) before advancing past the
bottom margin and top margin and writing an initial header line on the next
report page. Assuming there are more records to process given this little
example.
4.1.234 FOR¶
Multi purpose keyword
- Used in INSPECT field TALLYING tally-field FOR ...
- USE FOR DEBUGGING
- SAME AREA FOR
4.1.235 FOREGROUND-COLOR¶
Screen section foreground color control. See What are the GnuCOBOL SCREEN SECTION colour values?
4.1.236 FOREGROUND-COLOUR¶
Alternate spelling for FOREGROUND-COLOR.
4.1.237 FOREVER¶
Provides for infinite loops. Use EXIT PERFORM or EXIT PERFORM CYCLE to control program flow.
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.
Which produces:
$ 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
I asked on opencobol.org for some input, and an interesting conversation ensued. I’ve included the forum thread archive, nearly in its entirety, to give a sense of various programmer styles and group thought processing. See Performing FOREVER?.
4.1.238 FORMAT¶
Source format directive. cobc defaults to FIXED format source. If
--free is specified then the directive can start in column one, but due to
FIXED format convention, by default, the directive must start in column 8
or later, allowing for the initial sequence number and comment columns.
So, to enter free format COBOL, it has to be with the first greater than symbol
in column 8 or later. Looks weird, for FREE code, but it’s a rule. Unless
you override the default FIXED behaviour with cobc --free.
Most samples in this manual start with a trivial short comment and
123456 >>SOURCE FORMAT IS FIXED
both to terrify and confuse beginners and to trick source code highlighters that rely on indentation. Mostly for for the former.
4.1.239 FREE¶
- Properly cleans up ALLOCATE alloted memory
- source format directive.
>>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
4.1.240 FROM¶
- source of information clause to
ACCEPT - initial value in a
PERFORM VARYINGloop - subtraction
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
Note: Versions of the FAQ between Oct 2015 and July 2016 had a bug in this listing; it had to do with statement terminators.
The old listing had a code fragment of
ACCEPT var FROM ENVIRONMENT "path"
ON EXCEPTION
DISPLAY "No path"
NOT ON EXCEPTION
DISPLAY var
END-ACCEPT
And that actually parses as
ACCEPT var FROM ENVIRONMENT "path"
ON EXCEPTION
DISPLAY "No path"
NOT ON EXCEPTION
DISPLAY var
END-ACCEPT
The NOT ON EXCEPTION clause was attached to the inner DISPLAY, not part of
the ACCEPT statement. One of the places where COBOL can look right at a
glance, but actually does what it is told, perhaps not what you meant.
As pointed out by Simon, in the conversation that uncovered this bug,
explained thanks to the sharp eyes of Edward, cobc -Wterminator would
display a warning for this source structure. The explicit END-DISPLAY is
required in this case for properly functioning code.
4.1.241 FULL¶
A screen section screen item control operator, requesting the normal terminator be ignored until the field is completely full or completely empty.
4.1.242 FUNCTION¶
Allows use of the many GnuCOBOL supported intrinsic functions.
DISPLAY FUNCTION TRIM(" trim off leading spaces" LEADING).
See Does GnuCOBOL implement any Intrinsic FUNCTIONs? for details.
4.1.243 FUNCTION-ID¶
Implemented in GnuCOBOL 2.0 and later versions, including Sergey’s C++ intermediate source version.
Functional COBOL is relatively new, although it has been in the spec for a while, it is not yet widely available to COBOL programmers. User Defined Functions are a modern COBOL feature.
Below is an example that defines a read-url function, that can be used
in COBOL expressions, just as an intrinsic function.
This code is experimental, and hopefully a real read-url
will be published in a cobweb shareable library, very soon.
curlit.cob an example of using the read-url function.
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/open-cobol/", 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.
and the copybook for libCURL messages, gccurlsym.cpy.
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).
Functional COBOL can open up new usage models, and will definitely help with source code sharing and reusable COBOL frameworks.
call-wrap wrapping a subprogram CALL as a user defined function.
Here is a sample that allows for some callable subprograms to be used in a functional manner (this version is limited to CALL signatures that take an integer and return an integer, but can be modified for other argument lists).
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.
This is a little fragile, and fully robust bindings would require a complete
marshaling layer, but this works for call signatures with integer sized
returns. f would be a poor choice of name for a generic functional
wrapper, but it should be short, for use in expressions.
$ 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
4.1.244 FUNCTION-POINTER¶
An entry address data type, for pointing to user defined functions.
See PROGRAM-POINTER.
4.1.246 GET¶
Unsupported.
4.1.247 GIVING¶
Destination control for computations, and return value clause.
ADD 1 TO cobol GIVING GnuCOBOL.
4.1.248 GLOBAL¶
Multi use keyword for scope modification.
- working storage scope attribute
- a file description, FD scope attribute
- USE [GLOBAL] FOR REPORTING declarative
A global identifier is accessible to all contained programs.
* 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:
4.1.249 GO¶
GO TO is your friend. Edsger was wrong. Transfer control to a named paragraph or section.
See ALTER for details of monster goto power.
GO can also be qualified, for branching to same named parapraphs within different sections.
GnuCOBOL supports:
GO TO labelGO TO list of labels DEPENDING on some-valueGO TO X OF A- and with ALTER, plain old
GO., where the target is set by ALTER.
Reading code with a plain
GO.
is a very good sign that ALTER is in play. The syntax allows for the much
less friendly:
GO paragraph.
that is altered after the fact, but that is much harder to spot.
There are times when GO is appropriate, but it should be used purposefully
and within reasonable limits.
Here is an unreasonable, contrived example, a hodge podge of the various GO forms, that when collected into one source file, cook up as bksetti.
Gloss over this one. The latter listings will limit the forms to maintain some semblence of sanity.
*> A contrivance of bsketti
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 bsketti 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.
Giving:
$ 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
Ok, now for listings of a more educational nature.
*> 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.
Section and qualified GO (with just a little spaghetti).
*> 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.
Which shows:
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
Some commentary from Bill Woodger, regarding qualified GO. Previous versions of these code listings did not include qualified GO TO and that part of the sample is due to his suggetion, listed below.
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?
And now a small contrived sample of computed GO.
*> 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.
Which shows:
prompt$ cobc -xj going-computed.cob
motto, depending on province: 2
Ut incepit Fidelis sic permanet.
See ALTER for the example of modified GO TO branching, pulled out from
the spaghetti code in the original going.cob listing.
4.1.250 GOBACK¶
A return. This will work correctly for all cases. A return to the operating system or a return to a called program.
GOBACK.
Unlike STOP RUN, GOBACK will properly unwind nested programs, and only
return to the operating system when it occurs in a top level program.
4.1.251 GREATER¶
COBOL conditional expression, IF A GREATER THAN B. See LESS
4.1.252 GROUP¶
Report Writer data line grouping clause.
4.1.253 GROUP-USAGE¶
An unsupported BIT clause.
4.1.254 HEADING¶
Report Writer RD clause specifying first line of page for HEADING.
4.1.255 HIGH-VALUE¶
A figurative ALPHABETIC constant, being the highest character value in the COLLATING sequence. It’s invalid to MOVE HIGH-VALUE to a NUMERIC field.
4.1.256 HIGH-VALUES¶
Plural of HIGH-VALUE.
4.1.257 HIGHLIGHT¶
Screen control for field intensity.
4.1.258 I-O¶
An OPEN mode allowing for both read and write.
4.1.259 I-O-CONTROL¶
A paragraph in the INPUT-OUTPUT section, allowing sharing memory areas for different files.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
I-O-CONTROL.
SAME RECORD AREA FOR filename-1 filename-2.
4.1.260 ID¶
Short form for IDENTIFICATION.
4.1.261 IDENTIFICATION¶
The initial division for GnuCOBOL programs.
IDENTIFICATION DIVISION.
PROGRAM-ID. sample.
Many historical paragraphs from the IDENTIFICATION DIVISION have been deemed obsolete. GnuCOBOL will treat these as comment paragraphs. Including
- AUTHOR
- DATE-WRITTEN
- DATE-MODIFIED
- DATE-COMPILED
- INSTALLATION
- REMARKS
- SECURITY
4.1.262 IF¶
Conditional branching.
In COBOL, conditionals are quite powerful and there are many conditional expressions allowed with concise shortcuts.
IF A = 1 OR 2
MOVE 1 TO B
END-IF
That is equivalent to
IF (A = 1) OR (A = 2)
MOVE 1 TO B
END-IF
4.1.264 IGNORING¶
READ filename-1 INTO identifer-1 IGNORING LOCK END-READ
4.1.265 IMPLEMENTS¶
Unsupported Object COBOL expression.
4.1.266 IN¶
A data structure reference and name conflict resolution qualifier.
MOVE "abc" TO field IN the-record IN the-structure
Synonym for OF
4.1.267 INDEX¶
A COBOL data type for indexing structures, and implicitly used by such things as in memory table SORT.
01 cursor-var USAGE INDEX.
SET cursor-var UP BY 1.
4.1.268 INDEXED¶
An ISAM file organization.
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
.
Sets an indexing control identifier for OCCURS data arrays.
01 TABLE-DATA.
05 TABLE-ELEMENTS
OCCURS 1 TO 100 TIMES DEPENDING ON crowd-size
INDEXED BY cursor-var.
10 field-1 PIC X.
4.1.269 INDICATE¶
GROUP INDICATE is a REPORT SECTION RD clause that specifies that printable item is output only on the first occurrence of its report group for that INITIATE, control break, or page advance.
4.1.270 INDIRECT¶
Not yet implemented.
4.1.271 INHERITS¶
An unsupported Object COBOL clause.
4.1.272 INITIAL¶
A modifier for the PROGRAM-ID clause, that causes the entire DATA DIVISION to be set to an initial state each time the subprogram is executed by CALL.
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.
Gives:
[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
INITIAL sets the-value to 42 upon each and every entry, without-initial multiplies through 42, 84, 168 (or would have, if not constrained to pic 99).
4.1.273 INITIALISE¶
Alternate spelling for the INITIALIZE verb.
4.1.274 INITIALISED¶
Alternate spelling for INITIALIZED.
4.1.275 INITIALIZE¶
Sets selected data to specified values.
Where category-name is:
A sample of the INITIALIZE verb posted to opencobol.org by human
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 -------------------------------------
Outputs:
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
4.1.276 INITIALIZED¶
A modifier for the ALLOCATE verb, filling the target with a default value.
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 ":"
displays:
: :
:ALLOCATED:
4.1.278 INPUT¶
A mode of the OPEN verb for file access.
OPEN INPUT datafile
Note that OPEN INPUT will fail if the named files does not exist, unless
the associated SELECT phrase includes the OPTIONAL keyword. GnuCOBOL returns
a status “35” and aborts a run without an OPTIONAL SELECT.
A SORT clause allowing programmer controlled input read passes where sortable records are passed to the sort algorithm using RELEASE.
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.
See the SORT entry for an example program that exercises an INPUT
PROCEDURE.
4.1.279 INPUT-OUTPUT¶
A section in the ENVIRONMENT DIVISION of a COBOL source file containing FILE and I-O control paragraphs.
environment division.
input-output section.
file-control.
select htmlfile
assign to filename
organization is record sequential.
GnuCOBOL supports
paragraphs within the INPUT-OUTPUT SECTION.
4.1.280 INSPECT¶
Provides very powerful parsing and replacement to COBOL, and GnuCOBOL supports
the full gamut of options. GnuCOBOL also supports a few common extensions,
such as the TRAILING modifier for INSPECT ... REPLACING ....
With tallying-phrase
And replacing-phrase
Where before-after-phrase is
A small example that reformats WHEN-COMPILE for a more readable display:
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.
Example output:
Formatted function WHEN-COMPILED 2010/03/25 23/05/0900-04/00
after INSPECT REPLACING 2010/03/25 23:05:0900-04:00
See ASCII for a quick way of converting character data to EBCDIC.
4.1.280.1 printable characters¶
Here is a short sample of replacing character fields with printable, and trimmable fields, or printable with dotted replacements.
It is a work in progress. This example uses two different methods. Two working-storage fields, or only one field and an all-code ALPHABET. Plus this is using details for CCSID-37, EBCDIC code page 37. It may include a a lot more printables than would normally be practical for z/OS work.
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.
The plan is to eventually have a copybook that ships with GnuCOBOL, or Intrinsic Function extension to handle conversion/testing for printable fields.
Sample run showing:
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 ......:
The raw data is split into two lines as cat -v sees the x"0a" as a
newline, not a character to use ^ and M- notation for.
4.1.281 INSTALLATION¶
An informational clause in the IDENTIFICATION DIVISION. Deemed OBSOLETE, but still in use. GnuCOBOL treats this as an end of line comment keyword, periods not required, all source up to the next newline is simply ignored.
4.1.282 INTERFACE¶
Unsupported.
4.1.283 INTERFACE-ID¶
Not yet implemented. An unsupported Object COBOL clause in the IDENTIFICATION division.
4.1.284 INTERMEDIATE¶
Not yet implemented.
4.1.285 INTO¶
Division. See DIVIDE for more details.
DIVIDE A INTO B GIVING C.
With READ
READ filespec RECORD INTO record-space
With RETURNING
CALL "subprogram" RETURNING INTO result
STRING source-field DELIMITED BY LOW-VALUE ... INTO destination-field
UNSTRING source-field DELIMITED BY "," INTO dest-field-1 ...
4.1.286 INTRINSIC¶
Used in REPOSITORY to allow the optional use of “FUNCTION” keyword.
environment division.
configuration section.
repository.
function all intrinsic.
The source unit will now allow for program lines such as
move trim(" abc") to dest
move function trim(" abc") to dest
to compile the same code.
4.1.287 INVALID¶
Key exception imperative phrase.
READ filename-1
INVALID KEY
DISPLAY "Bad key" END-DISPLAY
NOT INVALID KEY
DISPLAY "Good read" END-DISPLAY
END-READ
Please note that scope terminators are very good idea inside imperative clauses, so it is wise to get in the habit of explicitly terminating any and all reserved words that allow optional terminators, otherwise there is risk that one imperative conditional will be syntactically attached to an unintended phrase, leading to hard to track down and non-obvious problems.
4.1.288 INVOKE¶
Unsupported Object COBOL method call.
4.1.289 IS¶
Readability word. A IS LESS THAN B is equivalent to A LESS B.
4.1.290 JUST¶
Alias for JUSTIFIED.
4.1.291 JUSTIFIED¶
Tweaks storage rules in weird JUST ways, lessening the voodoo behind MOVE instructions, he said, sarcastically.
77 str1 pic x(40) justified right.
4.1.293 KEY¶
Multi use, always means key:
- RELATIVE KEY IS
- ALTERNATE RECORD KEY IS
- NOT INVALID KEY
- SORT filename ON DESCENDING KEY keyfield
- START indexing KEY IS LESS THAN keyfield
4.1.294 KEYBOARD¶
A special value for Standard Input device. Handy for getting at CGI POST data.
file-control.
select cgi-in
assign to keyboard.
4.1.295 LABEL¶
A record label. As with most record labels, falling into disuse.
4.1.296 LAST¶
- Used in START to prepare a read of the last record.
START filename-1 LAST
INVALID KEY
MOVE ZERO TO record-count
>>D DISPLAY "No last record for " filename-1
END-START
- A Report Writer RD clause specifying line on page for
LAST DETAILreport output.
4.1.297 LC_ALL¶
A reserved but unsupported category group. See Setting Locale. GnuCOBOL is ‘locale’ aware, but it is currently more external than in COBOL source. For now, it is safest to assume LC_ALL=C, but this can be configured differently when GnuCOBOL is built.
4.1.298 LC_COLLATE¶
A reserved but unsupported category name. Will be used with SET.
4.1.299 LC_CTYPE¶
A reserved but unsupported Locale category name. Will be used with SET.
4.1.300 LC_MESSAGES¶
A reserved but unsupported category name. See Setting Locale. GnuCOBOL is ‘locale’ aware, but it is currently more external than in COBOL source.
GnuCOBOL 2.0 extends locale support to the compiler messages.
$ export LC_MESSAGES=es_ES
$ cobc -x fdfgffd.cob
cobc: fdfgffd.cob: No existe el fichero o el directorio
4.1.301 LC_MONETARY¶
A reserved but unsupported Locale category name. Will be used with SET.
4.1.302 LC_NUMERIC¶
A reserved but unsupported Locale category name. Will be used with SET.
4.1.303 LC_TIME¶
A reserved but unsupported Locale category name. Will be used with SET.
4.1.304 LEADING¶
Multipurpose.
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.
as well as use in the COBOL preprocessor:
COPY "copy.inc"
REPLACING LEADING ==TEST== BY ==FIRST==
LEADING ==NORM== BY ==SECOND==.
4.1.305 LEFT¶
SYNCHRONIZED control.
4.1.306 LEFT-JUSTIFY¶
Not yet implemented.
4.1.307 LEFTLINE¶
Screen attribute. Horizontal line will appear to the left of the field.
4.1.308 LENGTH¶
A ‘cell-count’ length. Not always the same as BYTE-LENGTH. Due to a possible ambiguity with FUNCTION LENGTH, the OF keyword is mandatory in some parsing contexts during compiles.
4.1.309 LENGTH-CHECK¶
Alias for the FULL screen attrbiute.
4.1.310 LESS¶
A comparison operation.
IF requested LESS THAN OR EQUAL TO balance
PERFORM transfer
ELSE
PERFORM reject
END-IF
4.1.311 LIMIT¶
Report Writer RD clause for PAGE LIMIT IS lines-per-page LINES.
4.1.312 LIMITS¶
Recognized Report Writer clause.
4.1.313 LINAGE¶
LINAGE is a clause in a File Descriptor FD which triggers the run time library
to maintain a LINAGE-COUNTER SPECIAL-REGISTER during file WRITE
operations and can be used for paging, skip line control, and others such
and FOOTING areas.
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 99.
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.
Using
$ ./linage except.cob
Produces a mini-report of:
****************** 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.
See except.cob under the FUNCTION EXCEPTION-STATUS entry.
4.1.314 LINAGE-COUNTER¶
An internal GnuCOBOL noun, or Special Register. Value is readonly and is maintained during WRITEs to files that have a LINAGE clause. Useful for quick reports and logical page layouts.
4.1.315 LINE¶
- LINE SEQUENTIAL files.
- Screen and Report section line control.
For LINE SEQUENTIAL files, the length of a read, and the length to write
can be managed with an FD clause.
FD testfile
RECORD IS VARYING IN SIZE FROM 0 TO 132 CHARACTERS
DEPENDING ON actual.
The programmer defined identifier actual can be pretty much any NUMERIC type. It will be set after READ and will determine the length to WRITE.
See How do I get the length of a LINE SEQUENTIAL read? for more details.
LINE is also a keyword with extended ACCEPT, DISPLAY, with SCREEN
and REPORT SECTION layouts, and descriptors.
ACCEPT identifier LINE NUMBER 10 POSITION NUMBER 20.
When using the condensed form of extended AT, the first two (or three) digits are LINE and the last two (or three) digits are COLUMN. These literal values can be either four or six digits.
DISPLAY "Text" AT 0203
DISPLAY "Text" AT 002101 WITH REVERSE-VIDEO
4.1.316 LINE-COUNTER¶
Special register for the Report Writer module.
4.1.317 LINES¶
- Screen section line control
- Screen occurs control
- and area scrolling
- Report Writer paging control
4.1.318 LINKAGE¶
A SECTION in the DATA DIVISION. Used for call frame data handling when the current run unit may not be in charge of the location of working storage. Defaults to uninitialized references which must be set with USING in a CALL or explicitly with SET ADDRESS. References without initialization will cause an addressing segfault.
4.1.319 LOCAL-STORAGE¶
A SECTION in the DATA DIVISION. Data defined in local storage will be local to the running module and re-entrant within subprogram call trees.
4.1.320 LOCALE¶
Unsupported in GnuCOBOL 1.1pre-rel. Support added in 2.0
A SPECIAL-NAMES entry giving GnuCOBOL an international flair.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
LOCALE spanish IS 'ES_es'.
4.1.322 LOW-VALUE¶
A figurative ALPHABETIC constant, being the lowest character value in the COLLATING sequence.
MOVE LOW-VALUE TO alphanumeric-1.
IF alphabetic-1 EQUALS LOW-VALUE
DISPLAY "Failed validation"
END-IF.
It’s invalid to MOVE LOW-VALUE to a numeric field.
4.1.324 LOWER¶
Screen field attribute. Converting input to lower case.
4.1.325 LOWLIGHT¶
A screen attribute for DISPLAY and SCREEN SECTION fields.
SCREEN SECTION.
01 example.
05 FILLER
LINE 1 COLUMN 10
VALUE IS "Example:"
LOWLIGHT.
Will display the Example: legend in a dimmed video if supported with the current terminal settings.
4.1.326 MANUAL¶
LOCK MODE IS MANUAL WITH LOCK ON MULTIPLE RECORDS. See AUTOMATIC and EXCLUSIVE for more LOCK options.
4.1.327 MEMORY¶
An OBJECT-COMPUTER clause.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
OBJECT-COMPUTER.
MEMORY SIZE IS 8 CHARACTERS.
4.1.328 MERGE¶
Combines two or more identically sequenced files on a set of specified keys.
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
A more complete example, merging regional transaction files with those of HQ, in preparation for a batch run.
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.
Input data files (64 byte records, 8 character id, 3 character action) of
master-sample.dat
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
and some regional files, east-transact-sample.dat
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
and west-transact-sample.dat
11111111 CHQ 0001111.11 withdrawal from account one
44444444 DEP 0000044.44 deposit to account four
66666666 BAL balance request for account six
giving a new night run tranasction file, merged-transactions.dat.
$ 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
and
$ 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
- The merged transaction file will be created each time.
- The MERGE verb will not complain if some input files are not found.
4.1.329 MESSAGE¶
Unsupported Communication Section clause.
4.1.330 METHOD¶
Unsupported Object COBOL feature.
4.1.331 METHOD-ID¶
Unsupported Object COBOL feature.
4.1.332 MINUS¶
Screen section relative line and column control. Relative to last fixed line or column given in layout. Two fields in a row, at minus 8, will be aligned, not offset from each other.
05 some-field pic x(16)
line number is plus 1
column number is minus 8
4.1.334 MOVE¶
A workhorse of the COBOL paradigm. MOVE is a highly flexible, intelligent, safe, and sometimes perplexing data movement verb.
01 alphanum-3 PIC XXX.
01 num2 PIC 99.
MOVE "ABCDEFG" TO xvar3
DISPLAY xvar3
MOVE 12345 TO num2
DISPLAY num2
displays:
ABC
45
Note the 45, MOVE uses a right to left rule when moving numerics, high digits are truncated, not low digits. A left to right rule is used when moving character data.
Entire groups (of similarily named sub items) can be moved with
MOVE CORRESPONDING ident-1 TO ident-2
only the group items of the same name (and relative hierarchy level) will be transferred from the ident-1 group to the ident-2 fields.
4.1.335 MULTIPLE¶
LOCK MODE IS MANUAL WITH LOCK ON MULTIPLE RECORDS.
4.1.336 MULTIPLY¶
A standard mathematics operation. Overflow and otherwise untrustable results
can be handled with an ON SIZE ERROR phrase. COBOL will silently allow
size errors (leaving any receiving fields with previous values) if the phrase
is not used. The responsibility for managing unreliable results is placed in
the hands of the application programmer.
MULTIPLY var-1 BY var-2 GIVING var-3
ON SIZE ERROR
SET invalid-result TO TRUE
END-MULTIPLY
4.1.338 NATIONAL¶
NATIONAL character usage. Not yet supported. GnuCOBOL does support PICTURE N.
4.1.339 NATIONAL-EDITED¶
Category.
4.1.340 NATIVE¶
An ALPHABET. Most mainframes are EBCDIC, and most other systems are ASCII. Most of this document assumes ASCII coding conventions. With a reasonable amount of diligence, GnuCOBOL programs can be written to perform correctly running under any native platform character set.
4.1.341 NEAREST-AWAY-FROM-ZERO¶
A ROUNDED MODE. NEAREST-AWAY-FROM-ZERO is the GnuCOBOL, (and COBOL 2014
standard) default when only the keyword ROUNDED, without MODE, is specified.
| NEAREST-AWAY-FROM-ZERO | +2.49 | -2.49 | +2.50 | -2.50 | +3.49 | -3.49 | +3.50 | -3.50 | +3.51 | -3.51 |
|---|---|---|---|---|---|---|---|---|---|---|
| Becomes | +2 | -2 | +3 | -3 | +3 | -3 | +4 | -4 | +4 | -4 |
4.1.342 NEAREST-EVEN¶
A ROUNDED MODE. NEAREST-EVEN is commonly referred to as Banker’s
rounding. An alternating system where 2.5 rounds down to 2, and 3.5 rounds up to 4.
| NEAREST-EVEN | +2.49 | -2.49 | +2.50 | -2.50 | +3.49 | -3.49 | +3.50 | -3.50 | +3.51 | -3.51 |
|---|---|---|---|---|---|---|---|---|---|---|
| Becomes | +2 | -2 | +2 | -2 | +3 | -3 | +4 | -4 | +4 | -4 |
4.1.343 NEAREST-TOWARD-ZERO¶
A ROUNDED MODE. Positive values round downward, negative values round upward.
| NEAREST-TOWARD-ZERO | +2.49 | -2.49 | +2.50 | -2.50 | +3.49 | -3.49 | +3.50 | -3.50 | +3.51 | -3.51 |
|---|---|---|---|---|---|---|---|---|---|---|
| Becomes | +2 | -2 | +2 | -2 | +3 | -3 | +3 | -3 | +4 | -4 |
4.1.345 NESTED¶
An unsupported program-prototype CALL clause.
4.1.346 NEXT¶
- With READ, to read the next record, possibly by KEY.
- Also an obsolete, but supported, control flow verb with
NEXT SENTENCE.
READ index-sequential-file NEXT RECORD INTO ident-1
IF condition-1
NEXT SENTENCE
ELSE
PERFORM do-something.
NEXT SENTENCE
Think of NEXT SENTENCE as “go look ahead for a full stop source code
period, and jump past it” flow control. CONTINUE is a smarter, inner
structure friendly, “jump out a level - usually by doing nothing” flow control
mechanism. Many of the samples in this document are single sentence programs,
and NEXT SENTENCE doesn’t really apply with that style.
4.1.347 NO¶
Specify NO locks, NO sharing, NO rewind, NO carriage return.
CLOSE filename-1 WITH NO REWIND
READ file-1 WITH NO LOCK
DISPLAY field-1 WITH NO ADVANCING
4.1.348 NO-ECHO¶
Screen field attribute, alias for SECURE, intended for passwords or other sensitive data input.
4.1.349 NONE¶
Unsupported DEFAULT IS NONE.
4.1.351 NOT¶
Conditional negation. See AND, OR. Also used in operational conditional expressions such as NOT ON SIZE ERROR, in which case, the conditional statements can trust that the operation was sound, not overflowing the receiving data field.
IF NOT production
CALL "test-thing"
NOT ON EXCEPTION
DISPLAY "Linkage to thing, OK, called"
END-CALL
END-IF
4.1.352 NULL¶
A zero address pointer. A symbolic literal.
SET ADDRESS OF ptr TO NULL
IF ptr EQUAL NULL
DISPLAY "ptr not valid"
END-IF
NULL is not LOW-VALUE. Don’t do this, I mistakenly use
CALL "thing" RETURNING NULL END-CALL
all the time when meaning ``void`` return. It’s wrong. It’s
CALL "thing" RETURNING OMITTED END-CALL
Please note.
MOVE CONCATENATE(TRIM(cbl-string TRAILING) NULL) TO c-string
is wrong as well, and is not the same as
MOVE CONCATENATE(TRIM(cbl-string TRAILING) LOW-VALUE) TO c-string
or a literal ``x”00”`` for LOW-VALUE. NULL is a pointer type, not really a value, except when its a value. :-)
4.1.355 NUMBER-OF-CALL-PARAMETERS¶
Predefined special register for use in subprograms.
4.1.356 NUMBERS¶
Plural of NUMBER.
4.1.357 NUMERIC¶
- Category-name and category test.
- Linkage data clause for ANY NUMERIC
if NUMERIC '20140101' then
display 'only numbers'
end-if
if NUMERIC '2014010a' then
display 'only numbers'
end-if
The first tests true, and the second does not.
GnuCOBOL 2.0 and above supports a data clause that is the equivalent of ANY LENGTH for numbers.
*> 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.
And a run sample of:
prompt$ cobc -xj any-numeric-sample.cob
Received: 00042
Length : +0000000005
Received: 000000000000000000000000000042
Length : +0000000030
Received: 42
Length : +0000000002
4.1.358 NUMERIC-EDITED¶
Category-name.
INITIALIZE data-record REPLACING NUMERIC-EDITED BY literal-value
4.1.359 OBJECT¶
Unsupported Object COBOL feature.
4.1.360 OBJECT-COMPUTER¶
Environment division, configuration section run-time machine paragraph.
GnuCOBOL supports
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.
4.1.361 OBJECT-REFERENCE¶
Unsupported Object COBOL feature.
4.1.362 OCCURS¶
Controls multiple occurrences of data structures, allowing for arrays, commonly
called “tables” in COBOL. All tables use 1 relative indexing, there is no
element 0 in COBOL but there can a zero in the depending on variable.
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 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)
Would display a day by name (assuming the first day being Sunday), and then a
main-record with the contained main-field limited to a given length.
4.1.363 OF¶
A data structure reference and name conflict resolution qualifier.
MOVE "abc" TO the-field OF the-record OF the-structure
Synonym for IN
4.1.364 OFF¶
A control status and setting for an external switch. See ON.
SPECIAL-NAMES.
SWITCH-1 IS mainframe
ON STATUS IS bigiron
OFF STATUS IS pc
...
SET mainframe TO OFF
4.1.365 OMITTED¶
Allows for:
- placeholders in call frames, see OPTIONAL
- testing for explicity omitted parameters
- specifying omitted label records
- and void returns for CALL
- PROCEDURE DIVISION RETURNING OMITTED generates subprograms with
voidreturns. A GnuCOBOL extension.
OMITTED with CALL arguments is only allowed with BY REFERENCE data.
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
4.1.366 ON¶
Turn on a switch. See OFF.
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
Debug control
USE FOR DEBUGGING ON ALL PROCEDURES
Starts conditional clause.
- [NOT] ON EXCEPTION
- [NOT] ON SIZE ERROR
ADD 1 TO wafer-thin-mint
ON SIZE ERROR
SET get-a-bucket TO TRUE
END-ADD
Sets a size limiting index on a table
table
01 wordlist based.
05 word-table occurs maxwords times
depending ON wordcount
descending key is wordstr
indexed by wl-index.
10 wordstr pic x(20).
10 wordline usage binary-long.
4.1.367 ONLY¶
Sharing control.
SELECT file-name-1
ASSIGN TO "actual-name"
SHARING WITH READ ONLY
ONLY is also an unsupported Object COBOL FACTORY phrase.
4.1.368 OPEN¶
Opens a file selector.
Modes include
OPEN INPUT SHARING WITH ALL OTHER infile
OPEN EXTEND SHARING WITH NO OTHER myfile
4.1.369 OPTIONAL¶
- Allows for referencing non-existent files.
- Allows for optionally OMITTED call arguments.
Code below shows optional file open and optional CALL arguments.
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.
The use of OPTIONAL in a SELECT statement can be important when input files may not exist. Without the OPTIONAL phrase, processing will halt during OPEN INPUT, which may or may not be a useful behaviour.
4.1.370 OPTIONS¶
A currently unsupported paragraph of the IDENTIFICATION division.
4.1.371 OR¶
Logical operation. See AND, NOT. GnuCOBOL supports COBOL’s logical expression shortcuts. Order of precedence can be controlled with parenthesis, and default to NOT, AND, OR, right to left.
IF A NOT EQUAL 1 OR 2 OR 3 OR 5
DISPLAY "FORE!"
END-IF
4.1.372 ORDER¶
Sort clause to influence how duplicates are managed.
sort sort-work
ascending key work-rec with duplicates in order
using sort-in
giving sort-out.
In 1.1pre-rel, WITH DUPLICATES IN ORDER is a default.
4.1.373 ORGANISATION¶
Alternate spelling for ORGANIZATION.
4.1.374 ORGANIZATION¶
Defines a file’s storage organization. One of
- INDEXED
- RELATIVE
- SEQUENTIAL
- GnuCOBOL also supports a LINE SEQUENTIAL structure.
4.1.375 OTHER¶
File sharing option, ALL OTHER, NO OTHER.
EVALUATE‘s else clause.
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
4.1.376 OUTPUT¶
sort sort-work
on descending key work-rec
collating sequence is mixed
input procedure is sort-transform
output procedure is output-uppercase.
4.1.377 OVERFLOW¶
Conditional clause for STRING and UNSTRING that will trigger on space overflow conditions.
4.1.378 OVERLINE¶
A display control for SCREEN section fields, placing a horizontal line over the input field.
4.1.379 OVERRIDE¶
Unsupported Object COBOL METHOD-ID clause.
4.1.380 PACKED-DECIMAL¶
Numeric USAGE clause, equivalent to COMPUTATIONAL-3. Holds each digit in a 4-bit field.
From the opencobol-2.0 tarball testsuite
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.
With a support file to dump the first 10 bytes of each record
#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;
}
/**/
Which compiles and captures as:
$ 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
4.1.381 PADDING¶
Defines a character to use for short record padding.
ORGANIZATION IS LINE SEQUENTIAL PADDING CHARACTER IS '*'
4.1.382 PAGE¶
Write and Report writer clause.
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
4.1.383 PAGE-COUNTER¶
A special register, qualified by Report Name.
4.1.384 PARAGRAPH¶
An allowable EXIT point.
NAMED-PARAGRAPH.
PERFORM FOREVER
IF solution
EXIT PARAGRAPH
END-IF
PERFORM solve-the-puzzle.
END-PERFORM.
4.1.385 PERFORM¶
A COBOL procedural and inline control flow verb.
Historic COBOL used only named procedure performs, modern COBOL adds inline perform loops.
The procedural form.
And the inline loop form.
Both forms using a varying-phrase of
In the diagram above, the keyword BY was shown in the non-standard font. GnuCOBOL differs to the standard here, in that BY is not an optional clause in GnuCOBOL. The spec allows a default of ``BY 1`` if not explicitily stated, GnuCOBOL has no such default, and the clause is mandatory.
A named procedure perform inside an inline loop example:
beginning.
PERFORM FOREVER
PERFORM miracles
END-PERFORM
GOBACK.
miracles.
DISPLAY wonders
4.1.388 PIC¶
A commonly used short form of PICTURE.
4.1.389 PICTURE¶
The PICTURE clause, more commonly PIC, is easily one of COBOL’s greatest strengths. Fully detailed pictorial data definitions. The internal complexity is left to compiler authors, while developers and management are free to describe data at a very high conceptual level.
The two most common picture characters are 9 and X, for numeric and alphanumeric data respectively. For alphabetic data, A can be used.
Aside from data storage pictures, a vast array of edit pictures are allowed for control of input and output formatting.
+, -, A, B, N, X, Z, "*", 'CR', 'DB', E, S, V, ".", ",", P, currency symbol
GnuCOBOL offers full standards support of all alpha, alphanumeric and numeric storage specifiers as well as full support for edit and numeric-edit clauses. See currency symbol for details on handling monentary prefixes, which defaults to “$”, without the quotes. CR and DB are literals for display of CRedit and DeBit items, and there are no actual quotes around them, or the asterisk, period or comma symbols; shown above for clarity.
PICTURE symbols:
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.
An example of some of the PICTURE options
*>>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.
*><*
Outputs:
-------------------------------------------------------------------------------------
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
A PICTURE that allows for comma separated thousands:
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 ":"
Gives:
: 001:
: 123:
: 123,456:
:123,456,789:
The commas, which are “insert edit” picture items, when associated with the special Z and asterisk field edit characters, take on the aspect of the space fill on zero or asterisk fill on zero nature of the * and Z items.
Floating currency symbols work in a similar, but slightly different way.
01 show-value PIC ***,***,999.
Gives:
:********001:
:********123:
:****123,456:
:123,456,789:
Making this a little more money oriented, and
01 show-value PIC $$$,$$$,$$9.
Gives:
: $1:
: $123:
: $123,456:
:$23,456,789:
Which is not a great way of treating multimillionaire customers, so
01 show-value PIC $$$$,$$$,$$9.99.
move 123456789.50 to show-value
display ":" show-value ":"
would be a better form, showing:
: $1.50:
: $123.50:
: $123,456.50:
:$123,456,789.50:
For your bigger customers, GnuCOBOL handles up to 38 characters of picture, so bring in that business. Then treat people to some powerful programming and entice them to fill up those accounts and make the big orders.
01 big-value pic $$$$,$$$,$$$,$$$,$$$,$$$,$$$,$$$,$$$,$$$,$$9.99.
: $1.50:
: $123.50:
: $123,456.50:
: $123,456,789.50:
: $1,550,057,000,000.00:
Accoring to the internet, that last number is the Gross Domestic Product of Canada as reported in 2015. Lots and lots of wiggle room.
4.1.390 PLUS¶
Screen section relative line / column control during layout. Relative to last literal, not last PLUS or MINUS. In the code below, both value-4 and value-5 will be displayed on line 4.
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.
4.1.391 POINTER¶
Allocates a restricted use variable for holding addresses.
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 is just a teenie-weenie bit of voodoo
*> Pass the REFERENCE or use RETURNING if C sets the value. Use
*> VALUE when you want C to have its 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 USING BY VALUE.
*> <*
Given that GnuCOBOL is so tightly bound to the C ABI, there are times when a COBOL programmer is faced with variable length zero terminated C strings and structures. Many times, a reasonable sized PICTURE clause will suffice, but sometimes that places artificial limits on otherwise less restrictive code.
If it is only for DISPLAY purposes, one idiom for accessing C char *
data is using POINTER and BASED memory. From an embedded Perl sample:
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
Similar code sequences can be used to traverse more complicated structures, sliding through data by setting the address of BASED storage.
4.1.392 POSITION¶
Alias for COLUMN in screen section layouts. Also an obsolete, recognized, but not supported, tape layout clause:
MULTIPLE FILE TAPE CONTAINS file-1 POSITION 1 file-2 POSITION 80
4.1.394 PREFIXED¶
Not yet implemented.
4.1.395 PRESENT¶
Report Writer clause used for optional field and group output.
05 field PIC X(16) PRESENT WHEN sum > 0.
4.1.397 PRINTER¶
Special name.
SPECIAL-NAMES.
PRINTER IS myprint
DISPLAY "test" UPON PRINTER
Reacts to
- COBPRINTER
- A command used to
popenwith data lines written when UPON PRINTER is used for WRITE or DISPLAY.
export COBPRINTER='cat >>printfile.txt'
- COB_DISPLAY_PRINTER
- A filename that is used with
fopen(fd-file, "a")before each write UPON PRINTER.
export COB_DISPLAY_FILE='printfile.txt'
4.1.398 PRINTING¶
Report Writer declarative to SUPPRESS report printing.
4.1.400 PROCEDURE-POINTER¶
Alias for PROGRAM-POINTER, capable of holding a callable address.
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
4.1.404 PROGRAM-ID¶
The program identifier. Case sensitive, unlike all other GnuCOBOL identifiers. GnuCOBOL produces C Application Binary Interface linkable entities and this identifier must conform to those rules. Dashes in names are replaced by a hex string equivalent.
4.1.405 PROGRAM-POINTER¶
A data USAGE clause defining a field that can hold the executable address of a CALL routine.
77 callback USAGE PROGRAM-POINTER.
...
SET callback TO ENTRY a-program-id
CALL callback
on exception "no linkage to callback" upon syserr
END-CALL
4.1.406 PROHIBITED¶
A ROUNDED modifier, for no rounding allowed.
COMPUTE var ROUNDED MODE IS PROHIBITED = 1.1 END-COMPUTE
Sets an exception, 4101, that can be retrieved with
ACCEPT unexpected-rounding FROM EXCEPTION STATUS END-ACCEPT
For example
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.
gives:
01.17, 4101
01.18, 0000
03.12, 0000
size error: 03.12, 4101
4.1.408 PROPERTY¶
Unsupported Object COBOL phrase.
4.1.409 PROTECTED¶
Extended ACCEPT field attribute.
ACCEPT variable-1
LINE <line> COLUMN <column>
WITH
AUTO-SKIP | AUTO
[PROTECTED] SIZE [IS] variable-2 | literal-2
END-ACCEPT
4.1.410 PROTOTYPE¶
Unsupported Object COBOL phrase.
4.1.411 PURGE¶
Unsupported Communication Section clause.
4.1.412 QUEUE¶
Unsupported Communication Section clause.
4.1.414 QUOTES¶
A figurative constant representing ‘”’.
01 var PICTURE X(4).
MOVE ALL QUOTES TO var
DISPLAY var
Outputs:
""""
4.1.415 RAISE¶
Exception handling. There IS support for exceptions in GnuCOBOL but it is currently fairly limited. See FUNCTION EXCEPTION-LOCATION for a sample. RAISE is not yet recognized.
4.1.416 RAISING¶
Exception handling. There IS support for exceptions in GnuCOBOL but it is currently limited. RAISING is not yet recognized.
4.1.417 RANDOM¶
A file access mode. RANDOM access allows seeks to any point in a file, usually by KEY.
There is also an intrinsic for generating random numbers, FUNCTION RANDOM.
4.1.418 RD¶
Report writer DATA division, REPORT section descriptor.
DATA DIVISION.
REPORT SECTION.
RD report-1
PAGE LIMIT IS 66 LINES.
4.1.419 READ¶
A staple of COBOL. Read a record, forwards or backwards, with or without locking.
READ infile PREVIOUS RECORD INTO back-record
AT END
SET attop TO TRUE
NOT AT END
PERFORM cursor-calculator
END-READ
4.1.420 READY¶
Along with RESET, allows for programmatic control over TRACE line output.
A sample of run-time line trace:
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.
With and without line 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
COB_SET_TRACE=Y with cobc -debug (or -ftrace or -ftraceall) will trace ALL
lines by default, but will still honour RESET and READY TRACE blocks.
4.1.421 RECEIVE¶
An unsupported Communication Section clause.
4.1.422 RECORD¶
Multiple use phrase.
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
4.1.423 RECORDING¶
An obsolete, recognized, but ignored file descriptor clause.
FD file
RECORD IS VARYING IN SIZE FROM 1 TO 80 CHARACTERS
DEPENDING ON size-field
RECORDING MODE IS F.
4.1.425 RECURSIVE¶
Specifies a PROGRAM-ID as having the recursive attribute. Recursive sub programs can CALL themselves.
This qualifier has implications on how GnuCOBOL allocates storage. Normally storage is stacked, recursion can chew through stack space very quickly. Sub programs marked RECURSIVE are usually allocated using the memory heap.
PROGRAM-ID nextbigthing IS RECURSIVE.
4.1.426 REDEFINES¶
A very powerful DATA division control allowing for redefinition of memory storage, including incompatible data by type.
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 X PIC X.
01 G REDEFINES X.
02 A PIC X.
02 B REDEFINES A PIC 9.
PROCEDURE DIVISION.
STOP RUN.
4.1.428 REFERENCE¶
The default COBOL CALL argument passing mode. CALL arguments can be
BY REFERENCE
BY CONTENT
BY VALUE
where by reference passes a reference pointer, allowing data modification
inside sub programs. User defined functions are always passed arguments
BY REFERENCE.
4.1.430 RELATION¶
Unsupported.
4.1.431 RELATIVE¶
File organization where the position of a logical record is determined by its relative record number.
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.
with sample screens:
Adding, Overwriting. 00 to finish
Record: 04
First name: Brad____________________________________________
Last name: Tiffin__________________________________________________________
Relation: brother_________________________
allowing for new record additions or overwrites of existing key numbers, and:
Which record? 00 to quit
Record: 03
First name: Brian
Last name: Tiffin
Relation:
where typing in a nicknum record number retrieves the relative record.
4.1.432 RELEASE¶
Release a record to a SORT.
Used with INPUT PROCEDURE of SORT verb.
RELEASE record-1 FROM identifier-1
4.1.433 REMAINDER¶
Access to integer remainders during division. See DIVIDE and COMPUTE.
DIVIDE
hex-val BY 16 GIVING left-nibble REMAINDER right-nibble
END-DIVIDE
4.1.434 REMARKS¶
An informational paragraph in the IDENTIFICATION DIVISION. Deemed OBSOLETE, but still in use. GnuCOBOL treats this as a comment paragraph.
4.1.435 REMOVAL¶
A close clause.
CLOSE filename-1 REEL FOR REMOVAL
Specifies that the file is stored on multiple removable tapes/disks. Not all systems support such devices.
4.1.436 RENAMES¶
GnuCOBOL supports regrouping of level 02-49 data items with level 66 and RENAMES.
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.
giving:
$ ./sixtysix
master : 00000006vsixtysix ABCD000000066
field-1 : -000000066
sixtysix: sixtysix
group-66: sixtysix ABCD000000066
4.1.437 REPLACE¶
A COBOL preprocessor text manipulation directive.
For example:
REPLACE ==MARKER== BY ==DISPLAY "REPLACE EXAMPLE" END-DISPLAY==.
identification division.
program-id. prog.
procedure division.
MARKER
goback.
end program prog.
And then to see how that REPLACE is working, use cobc with the -E argument
# 1 "replacing.cob"
identification division.
program-id. prog.
procedure division.
DISPLAY "REPLACE EXAMPLE" END-DISPLAY
goback.
end program prog.
REPLACE is a state sensitive word that keeps a stack of active replacements when nested. How these work can be controlled with
REPLACE OFF.
REPLACE LAST OFF.
REPLACE ALSO ==partial-text== BY ==partial-replacement==.
REPLACE ALSO can be your friend when you need to override some small
issues with generic source code templates.
4.1.438 REPLACING¶
The preprocessor REPLACING clause uses pseudo-text for its operands; COBOL
text delimited by literal ==. Substitutions can also use straight text,
but pseudo-text is likely more prevalent in existing COBOL sources, as it helps
avoid unintentional replacements of coincidentally matching program sources.
COPY "copy.inc"
REPLACING LEADING ==TEST== BY ==FIRST==
TRAILING ==NORM== BY ==SECOND==.
4.1.439 REPORT¶
Report Writer section and File descriptor clause.
Thanks to Ron Norman, GnuCOBOL supports the Report Writer module.
This example copied from Jay Moseley’s Hercules support for Report Writer tutorial, with permission.
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
with
$ 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
giving
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%
Please see http://www.jaymoseley.com/hercules/compiling/cobolrw.htm for a full Report Writer tutorial, and the source archive (plus data for the DATAIN required above). Jay gave permission for this copy, but do yourself a favour and read through the tutorial. It’s well done.
4.1.440 REPORTING¶
USE BEFORE REPORTING declarative for Report Writer.
4.1.441 REPORTS¶
Report Writer file descriptor clause associating files with named reports.
4.1.442 REPOSITORY¶
A paragraph of the CONFIGURATION SECTION. GnuCOBOL supports the FUNCTION ALL INTRINSIC clause of the REPOSITORY. Allows source code to use intrinsic functions without the FUNCTION keyword.
GCobol >>SOURCE FORMAT IS FIXED
*> ***************************************************************
*> Author: Brian Tiffin
*> Date: 20110213
*> Purpose: Demonstrate an intrinstric 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.
Sample output:
$ cobc -x functionall.cob
$ ./functionall
3.1415926535897932384626433832795029 2.7182818284590452353602874713526625
3.1415926535897932384626433832795029 2.7182818284590452353602874713526625
Without the repository paragraph:
$ cobc -x functionall.cob
functionall.cob:19: Error: 'pi' undefined
functionall.cob:19: Error: 'e' undefined
4.1.442.1 Function library main module¶
There is a plan to have libraries of user defined functions define a main
module, named the same as the external library filename (for use with
cobcrun) that displays a REPOSITORY paragraph suitable for cut and paste
into application programs.
$ 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.
4.1.443 REQUIRED¶
Recognized but ignored Screen section field attribute.
4.1.444 RESERVE¶
An unsupported SELECT clause.
4.1.445 RESET¶
- Report Writer data control field clause.
- program trace line output verb
See REPORT for more details on SUM reset controls, and page counter resets.
SUM OF identifier-1 RESET ON FINAL
NEXT GROUP IS NEXT PAGE WITH RESET
Statement tracing is controlled by environment and cobc options.
- -debug
- -ftrace
- -ftracell
- COB_SET_TRACE environment setting
READY TRACE
display "statement trace"
RESET TRACE
Program-Id: tracing Statement: DISPLAY Line: 12
statement trace
See READY for more details.
4.1.446 RESUME¶
Unsupported declarative control flow statement.
4.1.447 RETRY¶
Unsupported record locking wait and retry clause.
- RETRY n TIMES
- RETRY FOR n SECONDS
- RETRY FOREVER
4.1.450 RETURNING¶
- Specify the destination of CALL results.
01 result PIC S9(8).
CALL "libfunc" RETURNING result END-CALL
- Specify the return field for a subprogram or user defined function.
PROCEDURE DIVISION USING thing RETURNING otherthing
4.1.451 REVERSE-VIDEO¶
SCREEN section field display attribute. Functionality dependent on terminal and operating system support and settings.
4.1.452 REVERSED¶
An ignored clause for OPEN.
4.1.453 REWIND¶
A really cool lyric in the Black Eyed Peas song, “Hey Mama”.
Historically used for for tape drive control. It is supported syntax, but ignored by GnuCOBOL.
close tax-file with no rewind
4.1.454 REWRITE¶
Allows overwrite of records where the primary key already exists.
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.
And a sample program to show REWRITE used with a sample SEQUENTIAL file.
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
With a sample run of:
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
The dd command was used instead of cat for verification as SEQUENTIAL
files have no implied newlines. With cat, the file will display as one
long line of data (unless is happens to contain explicit newline bytes).
REWRITE can work with LINE SEQUENTIAL files (support in the reportwriter branch), but the record lengths must be identical when each line is overwritten, and well, it’s asking for trouble. Better to READ and WRITE a new file.
Please note that REWRITE is a fairly risky operation. Failures may leave files in a state where re-runs are impossible and original information is effectively lost.
4.1.455 RF¶
Short form for REPORT FOOTING.
4.1.456 RH¶
Short form for REPORT HEADING.
4.1.457 RIGHT¶
Ignored SYNCHRONIZED clause.
4.1.458 RIGHT-JUSTIFY¶
Not yet implemented.
4.1.459 ROLLBACK¶
Recognized but not fully supported revert of transactional file writes.
See COMMIT.
4.1.460 ROUNDED¶
Well defined rounding clause applied to arithmetic. Defined well enough for bank managers to feel comfortable handing their calculations over to a bunch of programmers.
COMPUTE total-value ROUNDED = 1.0 / 6.0
Recent standards have defined quite a few explicit ROUNDED MODE IS behaviour
modifiers.
- AWAY-FROM-ZERO
- NEAREST-AWAY-FROM-ZERO
- NEAREST-EVEN
- NEAREST-TOWARD-ZERO
- PROHIBITED
- TOWARD-GREATER
- TOWARD-LESSER
- TRUNCATION
With the default being NEAREST-AWAY-FROM-ZERO with modeless ROUNDED,
and TRUNCATION when the ROUNDED keyword is not present.
An example of the various ROUNDED MODE phrases:
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
Giving:
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
4.1.461 ROUNDING¶
Not yet implemented.
Will be part of an OPTIONS paragraph in the IDENTIFICATION DIVISION to
explicitly set behaviour for INTERMEDIATE ROUNDING.
4.1.462 RUN¶
A stopping point.
STOP RUN RETURNING 1
Terminates run regardless of nesting depth, returning control (and result) to operating system. See GOBACK and EXIT PROGRAM for other run unit terminations.
4.1.463 SAME¶
I-O-CONTROL clause for SAME RECORD AREA.
4.1.464 SCREEN¶
Screen section. curses/ncurses based terminal user interface.
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.
being a poor representation of the plethora of field attribute control allowed in GnuCOBOL screen section.
Screen field attributes include:
- JUSTIFIED RIGHT
- BLANK WHEN ZERO
- OCCURS integer-val TIMES
- BELL, BEEP
- AUTO, AUTO-SKIP, AUTOTERMINATE
- UNDERLINE
- OVERLINE
- SECURE
- REQUIRED
- FULL
- PROMPT
- REVERSE-VIDEO
- BLANK LINE
- BLANK SCREEN
- ERASE EOL
- ERASE EOS
- SIGN IS LEADING SEPARATE CHARACTER
- SIGN IS TRAILING SEPARATE CHARACTER
- LINE NUMBER IS [PLUS] integer-val
- COLUMN NUMBER IS [PLUS] integer-val
- FOREGROUND-COLOR IS integer-val HIGHLIGHT, LOWLIGHT
- BACKGROUND-COLOR IS integer-val BLINK
- PICTURE IS picture-clause USING identifier
- PICTURE IS picture-clause FROM identifier, literal
- PICTURE IS picture-clause TO identifier
- VALUE is literal
During ACCEPT, USING fields are read/write, FROM fields are read and TO fields are write.
See What are the GnuCOBOL SCREEN SECTION colour values? for colour values.
Also see Why don’t I see any output from my GnuCOBOL program? and Does GnuCOBOL support SCREEN SECTION? for more details and tidbits.
4.1.467 SEARCH¶
A powerful table and file search verb. Comes in two forms, linear and binary search all.
Serial search:
Binary search:
Linear search can be used on unsorted data, search all requires the information to be properly sorted by defined table or file key.
See Linear SEARCH and SORT and binary SEARCH ALL for examples.
4.1.468 SECONDS¶
Clause of unsupported read/write RETRY on lock.
4.1.469 SECTION¶
COBOL source code is organized in DIVISION, SECTION, paragraphs and sentences. GnuCOBOL supports user named sections and recognizes the following list of pre-defined sections.
Use of DECLARATIVES requires user named sections.
User defined section and paragraph names provide for source code organization and use of PERFORM (arguably, with paragraph THROUGH paragraph) for tried and true COBOL procedural programming.
Most samples in this document do not take advantage of the programming in the large features provided by section programming. Perhaps check out http://sourceforge.net/projects/acas/ for PITL sources.
4.1.470 SECURE¶
SCREEN section field attribute. Displayed as asterisks.
4.1.471 SECURITY¶
An informational paragraph in the IDENTIFICATION DIVISION. Deemed OBSOLETE, but still in use. GnuCOBOL treats this as a comment paragraph.
4.1.472 SEGMENT¶
Unsupported Communication section clause.
4.1.473 SEGMENT-LIMIT¶
An ignored clause of the OBJECT-COMPUTER paragraph.
4.1.474 SELECT¶
FILE-CONTROL phrase. Associates files with names, descriptors, and options.
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 INDEX
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.
though, naming a quick file can be as simple as
SELECT myfile ASSIGN TO "name.txt".
which will be a default LINE SEQUENTIAL file.
Note the OPTIONAL in the big crufty file descriptor. Optional files allow for OPEN when non existent.
4.1.475 SELF¶
Unsupported Object COBOL clause.
4.1.476 SEND¶
Unsupported Communication section verb.
4.1.477 SENTENCE¶
An obsolete control flow clause. CONTINUE is preferred to NEXT SENTENCE.
Flow jumps to the next sentence, normally determined by full stop period, and not just the next statement.
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"
.
Above, the first display line would be skipped over by NEXT SENTENCE, as the statement is still part of the MOVE and IF “sentence”. The next sentence occurs after the full stop. Used properly, it can be powerful, but it has hidden GO TO properties that can make it hard to quickly understand code flow.
4.1.478 SEPARATE¶
Fine tuned control over leading and trailing sign indicator.
77 field-1 PICTURE S9(8) SIGN IS TRAILING SEPARATE.
This option can make it much easier to port data into and out of systems as the sign is not encoded in the value, and less prone to binary representation differences between different hardware architectures.
4.1.479 SEQUENCE¶
Controls COLLATING sequence for character compares, by defining a character set.
4.1.480 SEQUENTIAL¶
GnuCOBOL supports both fixed length SEQUENTIAL and newline terminated LINE SEQUENTIAL file access.
The POSIX dd command can come in handy when dealing with COBOL SEQUENTIAL
file access modes. Normal SEQUENTIAL (unlike LINE SEQUENTIAL) files have no
implicit newlines between records. Records are simply a number of bytes,
usually (but not always) equal fixed length. dd has options for handling
fixed length records.
For example:
dd if=inputfile.dat cbs=80 conv=unblock status=none
Will add newlines after reading and converting 80 byte records.
dd if=textfile.txt of=output.dat cbs=80 conv=block status=none
will read a normal newline terminated text file and write out space padded 80
byte records. See the man page for dd for more information and the many
options available regarding input, output byte size and conversion types.
See REWRITE for a sample program that uses READ, WRITE and REWRITE on a
ORGANIZATION IS SEQUENTIAL
ACCESS MODE IS SEQUENTIAL
dataset.
4.1.480.1 Variable length sequential¶
A contrived example of Variable Length Sequential file processing:
*> 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.
Showing (with GnuCOBOL 2.0, configured with VBISAM):
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
A real program using variable length sequential would have more meaningful reasons to use the different lengths, very likely with different record layouts interspersed throughout the file. And there would be a more rigorous list of type tags used to determine what each record actually contained. In this case the records are just random data except for the ones marked “CUSTINFO”.
One feature of variable length records is that there has to be a way to determine the expected record contents, often marked in the record itself in the first few bytes of each record. Otherwise the runtime won’t know where to put records, or what the fields are supposed to mean.
This is one of the reasons that in COBOL, you WRITE records and READ files.
Each file can have different records. READ may not know what is next,
but WRITE always knows what record is being written.
4.1.481 SET¶
Multi-purpose verb for assigning values and operating enviroment settings.
- SET ADDRESS OF ptr-var TO var.
- SET ENVIRONMENT “name” TO “value”.
- SET screen-name-1 ATTRIBUTE BLINK OFF
- SET condition-name-1 TO TRUE
That last one is pretty cool. An 88 level conditional set TRUE will cause the associated value to change to a value that satisfies the condition as true.
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
00 and 42 are displayed.
4.1.482 SHARING¶
File sharing option.
- SHARING WITH NO OTHER
- SHARING WITH ALL OTHER
- SHARING WITH READ ONLY
Functionality dependent on build options and operating system running GnuCOBOL.
4.1.483 SIGN¶
Fine tuned control over leading and trailing sign indicator.
77 field-1 PICTURE S9(8) SIGN IS TRAILING SEPARATE.
4.1.484 SIGNED¶
GnuCOBOL supports the full gamut of COBOL numeric data storage. SIGNED and UNSIGNED being part and parcel.
4.1.485 SIGNED-INT¶
A native storage format NUMERIC data USAGE clause. Equivalent to BINARY-LONG, BINARY-LONG SIGNED, and SIGNED-LONG.
4.1.486 SIGNED-LONG¶
A native storage format NUMERIC data USAGE clause. Equivalent to BINARY-LONG, BINARY-LONG SIGNED, and SIGNED-INT.
4.1.487 SIGNED-SHORT¶
A native storage format NUMERIC data USAGE clause. Equivalent to BINARY-SHORT SIGNED.
4.1.488 SIZE¶
Multi purpose.
- GnuCOBOL allows SIZE IS control on CALL arguments.
CALL "c-function" USING
BY VALUE UNSIGNED SIZE IS 2 short-field
RETURNING new-value
END-CALL
Will properly pass a 16 bit unsigned value.
- Arithmetic operations allow for declaratives ON SIZE errors.
ADD 1 TO gnucobol
ON SIZE ERROR
SET erroneous TO TRUE
NOT ON SIZE ERROR
DISPLAY "ADDING 1 TO COBOL"
END-ADD
- STRING has a DELIMITED BY SIZE option, to include entire fields.
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
- In the OBJECT-COMPUTER paragraph
MEMORY SIZE IS integer-1 WORDS
but that would scanned and ignored by GnuCOBOL.
4.1.489 SORT¶
Sort a file or table.
File sort:
Table sort:
GnuCOBOL fully supports USING, GIVING as well as INPUT PROCEDURE and OUTPUT PROCEDURE clauses for the SORT verb.
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.
In the next sample, demonstrating INPUT PROCEDURE and OUTPUT PROCEDURE take note of the RETURN and RELEASE verbs as they are key to record by record control over sort operations.
Also, just to complicate things, this sample sorts using a mixed-case alphabet (but also places capital A out of order to demonstrate special cases that can codified in an ALPHABET).
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.
Here is a snippet describing TABLE sorts by [John]
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.
Exercise for the audience. Could the above code be simplified by using
MOVE CORRESPONDING cbRecord to table-columns(tcindex)
...
MOVE CORRESPONDING table-columns(tcindex) to showdata
with a few judicious field name changes?
4.1.489.1 An OCSort support tool¶
There is an external sort utility referenced in What is OCSort?
4.1.489.2 IN ORDER¶
The COBOL spec includes a sub-clause for SORT when duplicates are
involved.
SORT
WITH DUPLICATES
SORT
WITH DUPLICATES IN ORDER
The IN ORDER clause is a default, and effectively ignored with GnuCOBOL,
all sort operations are IN ORDER, meaning that duplicate keyed entries remain
in the same order as they occur in the original input after a sort. There is
no rearrangement of records with duplicate keys. This may cause some deltas
with other COBOL compilers when IN ORDER is not specified, in that those
compilers may well rearrange the records with duplicate keys. GnuCOBOL will
not and differences may be detected when analyzing GnuCOBOL as a replacement
for other compilers. Be aware of the default IN ORDER when testing
GnuCOBOL viability in detail. Thanks to James White for bringing this
difference to attention. This default IN ORDER behaviour applies to
both file and in memory table sorts.
4.1.490 SORT-MERGE¶
Used in an I-O-CONTROL paragraph with the SAME clause:
SAME SORT-MERGE AREA FOR filename-1.
The SORT-MERGE keyword and SORT keyword are equivalent in this case.
4.1.491 SORT-RETURN¶
A SPECIAL-REGISTER used by the GnuCOBOL SORT routines.
- +000000000 for success
- +000000016 for failure
A programmer may set SORT-RETURN in an INPUT PROCEDURE.
4.1.492 SOURCE¶
Compiler directive controlling source code handling.
>>SOURCE FORMAT IS FIXED
>>SOURCE FORMAT IS FREE
GnuCOBOL allows use of this directive at programmer whim, multiple times per file, within current scan rules. cobc defaults to FIXED format source handling, so the directive must occur beyond the sequence and indicator columns, column 8 or later, unless the -free compile option is used on the command line.
This can be handy when keeping indent sensitive syntax highlighters happy; use the sequence number and comment column for a reference tag, followed by an explicit
GCobol >>SOURCE FORMAT IS what-it-is-fixed-being-boxey-but-nice
or rolly eyes, wondering why old people can only count to 80, 132 if they are really old.
e_e >>source free
SOURCE is also used when defining split key ISAM. Split keys are in the reportwriter of branch of GnuCOBOL 2, and await merge with mainline GnuCOBOL 2.0 sources.
SELECT ...
RECORD KEY IS newkey-name SOURCE is dname-a dname-f dname-c
Also a Report Writer data source clause.
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.
4.1.493 SOURCE-COMPUTER¶
A paragraph of the IDENTIFICATION division. Treated as a comment.
4.1.494 SOURCES¶
SOURCES ARE report writer clause.
4.1.495 SPACE¶
A figurative constant representing a space character.
4.1.496 SPACES¶
A figurative constant representing space characters.
4.1.497 SPECIAL-NAMES¶
GnuCOBOL supports a fair complete set of the SPECIAL-NAMES in common use.
- CONSOLE IS CRT
- SYSIN IS mnemonic-name-1
- SYSOUT IS
- SYSLIST IS
- SYSLST IS
- PRINTER IS
- SYSERR IS
- CONSOLE IS mnemonic-name-7
- SWITCH-1 IS mnemonic-name-n ON STATUS IS condition-name-1 OFF STATUS IS condition-name-2
- SWITCH-2
- ...
- SWITCH-8 IS ...
- C01 IS mnemonic-name-m
- ...
- C12 IS
- ALPHABET alphabet-name IS NATIVE, STANDARD-1, STANDARD-2, EBCDIC literal-1 THRU literal-2 [ALSO literal-3]
- SYMBOLIC CHARACTERS symbol-character IS integer-1 IN alphabet-name
- CLASS class-name IS literal THRU literal-2
- LOCALE locale-name IS identifier-1
- CURRENCY SIGN IS literal
- DECIMAL-POINT IS COMMA
- CURSOR IS identifier-1
- CRT STATUS IS identifier-1
- SCREEN CONTROL IS identifier-1 PENDING
- EVENT STATUS IS identifier-1 PENDING
4.1.498 STANDARD¶
- LABEL RECORDS ARE STANDARD
4.1.501 STANDARD-BINARY¶
Not yet implemented.
4.1.502 STANDARD-DECIMAL¶
Not yet implemented.
4.1.503 START¶
Sets internal file fields that will influence sequential READ NEXT and READ PREVIOUS for INDEXED files.
Can also be used to seek to the FIRST or LAST record of a file for SEQUENTIAL access modes.
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
The conditionals are quite powerful.
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 <=
See Does GnuCOBOL support ISAM? for some example source code.
4.1.504 STATEMENT¶
Unsupported.
4.1.505 STATIC¶
Static linkage to CALL targets, resolved at compile time.
CALL STATIC "puts" USING a-zstring RETURNING out-count END-CALL
is handy when working on Cygwin and getting at libc routines.
4.1.506 STATUS¶
Multi-purpose.
- CRT STATUS IS
- FILE STATUS IS
- EVENT STATUS IS
- SWITCH-1 IS thing ON STATUS IS conditional-1
See GnuCOBOL FILE STATUS codes for more info on FILE STATUS.
4.1.507 STDCALL¶
A CALL modifier, tweaking things explicitly for Win32 call and return protocols (which is, historically, a difference between Pascal and C application binary interface argument stack cleanup assumptions).
STDCALL generates code that places the responsibility of parameter stack
cleanup on the called subprogram, not the caller. This implies the callee
knows how many arguments to expect, and is not as flexible as the default
behaviour. Unlike the default cdecl mode where callers are responsible
for adjusting the parameter stack after a call.
CALL STDCALL "CreateWindowEx" USING ...
4.1.508 STEP¶
Report Writer OCCURS sub-clause.
4.1.509 STOP¶
End a run and return control to the operating system.
Example of stop returning a status value:
STOP RUN RETURNING 5.
Forms include:
- STOP RUN
- STOP RUN RETURNING stat
- STOP RUN GIVING stat
- STOP RUN WITH ERROR STATUS stat
- STOP RUN WITH NORMAL STATUS stat
This permanent stop returns control to the operating system, with no regard to program nesting. The entire process is halted.
4.1.509.1 Temporary STOP¶
There is a special case, non standard extension, supported with GnuCOBOL 2.0:
- STOP literal
This will pause a program with the given message, assumed to be a string
literal, then await a keyboard return as if ACCEPT OMITTED END-ACCEPT was
compiled in. Execution continues after the message has been acknowledged.
Ctrl-C, (or similar) keystroke would send a terminating signal to the program.
4.1.510 STRING¶
String together a set of variables with controlled delimiters.
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
Outputs:
var is full at 5
adefg
GnuCOBOL also fully supports the WITH POINTER clause to set the initial and track the position in the output character variable.
4.1.511 STRONG¶
Unsupported.
4.1.512 SUB-QUEUE-1¶
Unsupported Communication section clause.
4.1.513 SUB-QUEUE-2¶
Unsupported Communication section clause.
4.1.514 SUB-QUEUE-3¶
Unsupported Communication section clause.
4.1.515 SUBTRACT¶
Arithmetic operation.
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
4.1.516 SUM¶
A report writer, break controlled, tally field.
03 COLUMN 38 PIC $$,$$9.99 SUM PRR-GROSS-PAY.
See REPORT.
4.1.517 SUPER¶
Unsupported Object COBOL keyword.
4.1.518 SUPPRESS¶
- Report Writer SUPPRESS PRINTING declarative.
- File write SUPPRESS WHEN alternate sparse key clause.
4.1.520 SYMBOLIC¶
SPECIAL-NAMES clause for SYMBOLIC characters, allowing user define figurative constants similar to QUOTES.
SPECIAL-NAMES.
SYMBOLIC CHARACTERS NUL IS 1
SOH IS 2
BEL IS 8
TAB IS 9.
can also be laid out as
SPECIAL-NAMES.
SYMBOLIC CHARACTERS NUL SOH BEL TAB
ARE 1 2 8 9.
4.1.521 SYNC¶
Alias for SYNCHRONIZED
4.1.522 SYNCHRONISED¶
Alternate spelling for SYNCHRONIZED.
4.1.523 SYNCHRONIZED¶
Control padding inside record definitions, in particular to match C structures.
01 infile.
03 slice occurs 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.
The pointers will align with the host expectations when passed to the C ABI, avoiding those embarrassing bus errors during big screen demos and presentations.
4.1.524 SYSTEM-DEFAULT¶
OBJECT-COMPUTER clause for locale support.
CHARACTER CLASSIFICATION IS SYSTEM-DEFAULT
4.1.525 TAB¶
Extended ACCEPT field attribute. Alias for AUTO.
4.1.526 TABLE¶
Unsupported keyword, but GnuCOBOL fully supports tables, including SORT.
4.1.527 TALLY¶
Automatically defined register.
Defined as:
GLOBAL PIC 9(5) USAGE BINARY VALUE ZERO
From tests/testsuite.src/run_extensions.at
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.
Display 00001.
4.1.528 TALLYING¶
INSPECT clause for counting occurrences of a literal.
INSPECT record-1 TALLYING ident-1 FOR LEADING "0"
4.1.529 TAPE¶
A device type used in ASSIGN.
4.1.530 TERMINAL¶
Unsupported Communication section clause.
4.1.532 TEST¶
Allows control over when loop conditionals are tested. WITH TEST BEFORE is the default. WITH TEST AFTER will always evaluate the body of the loop at least once.
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
4.1.533 TEXT¶
Unsupported Communication section clause.
4.1.534 THAN¶
Part of the conditional clauses for readability.
IF A GREATER THAN 10
DISPLAY "A > 10"
END-IF
4.1.535 THEN¶
A somewhat disdained keyword that is part of the IF THEN ELSE control structure.
IF A > 10 THEN
DISPLAY "A GREATER THAN 10"
ELSE
DISPLAY "A LESS THAN OR EQUAL TO 10"
END-IF
4.1.536 THROUGH¶
Used in definitions for alphabets in SPECIAL-NAMES and a procedural clause allowing PERFORM from one label THROUGH (inclusive) to another label and all paragraphs in between. Also used to specify grouping with RENAMES.
PERFORM 100-open-files THROUGH 100-files-end
4.1.537 THRU¶
Commonly used alias for THROUGH.
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.
4.1.538 TIME¶
An ACCEPT FROM source. Allows access to current clock; two digit hour, minute, second, hundreths.
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
4.1.539 TIME-OUT¶
Alternate spelling for TIMEOUT.
4.1.540 TIMEOUT¶
A screen field attribute. An extended ACCEPT will complete, as if a terminating keystroke had occured, at the end of timeout.
For systems using curses, ncurses, pdcurses, etc, timeout values will be in
milliseconds, scaled by COB_TIMEOUT_SCALE. Negative values will cause
a blocking read, wait until keyboard interaction. Zero will return immediately,
with a CRT-STATUS indicator if no keystrokes are waiting. Maybe? depending?.
4.1.541 TIMES¶
- Used in an OCCURS clause of the data division.
01 squeeze usage index value 10.
01 accordian.
05 pleat occurs 1 to 10 times depending on sqeeze pic x.
- A counted loop.
PERFORM 5 TIMES
DISPLAY "DERP"
END-PERFORM
The implicit internal counter is not accessible to COBOL sources inside the loop.
4.1.542 TO¶
Multi-purpose destination specifier.
ADD 1 TO cobol GIVING GnuCOBOL
ON SIZE ERROR
DISPLAY "Potential exceeds expectations"
END-ADD
4.1.543 TOP¶
A LINAGE clause, setting the number of lines used for the top margin of a page. Default top margin is zero.
FD mini-report
linage is 16 lines
with footing at 15
lines at top 2
lines at bottom 2.
4.1.544 TOWARD-GREATER¶
A ROUNDED MODE, where all fractions round up.
| TOWARD-GREATER | +2.49 | -2.49 | +2.50 | -2.50 | +3.49 | -3.49 | +3.50 | -3.50 | +3.51 | -3.51 |
|---|---|---|---|---|---|---|---|---|---|---|
| Becomes | +3 | -2 | +3 | -2 | +4 | -3 | +4 | -3 | +4 | -3 |
4.1.545 TOWARD-LESSER¶
A ROUNDED MODE, where all fractions round down.
| TOWARD-LESSER | +2.49 | -2.49 | +2.50 | -2.50 | +3.49 | -3.49 | +3.50 | -3.50 | +3.51 | -3.51 |
|---|---|---|---|---|---|---|---|---|---|---|
| Becomes | +2 | -3 | +2 | -3 | +3 | -4 | +3 | -4 | +3 | -4 |
4.1.546 TRACE¶
Turning on and off runtime program statement trace output.
READY TRACE
display "traced output, showing source line"
RESET TRACE
4.1.547 TRAILING¶
Multi-purpose. FUNCTION TRIM allows a TRAILING keyword. An INSPECT TALLYING sub-clause.
4.1.549 TRANSFORM¶
An extension, nearly equivalent to INSPECT var CONVERTING pattern-1 TO
pattern-2.
Patterns need to be the same size, a character position by character position global replace of the source.
move "ABBCCCBBA" to data-to-change
TRANSFORM data-to-change FROM "ABC" TO "XYZ"
display data-to-change
XYYZZZYYX
Every A replaced by X, B by Y, C by Z.
4.1.550 TRUE¶
- Used in
EVALUATEto trigger control flow when the WHEN test expression succeeds as true. - A SET target.
- When used with a conditional 88 level name, will set the corresponding
field to a listed
VALUE, the first, in case ofVALUES.
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
Displays:
a
To make friends and influence people, you can also EVALUATE FALSE, which
adds floating, invisible NOT logic to all the conditional tests. A sure fire
way of getting people to like you.
EVALUATE FALSE
WHEN 0 equal 1
display "Yes, that is, false"
END-EVALUATE
4.1.551 TRUNCATION¶
A ROUNDED MODE behaviour. TRUNCATION is the default action when no
ROUNDED or ROUNDED MODE phrase is specified for a calculation. By
default, COBOL simply truncates fractional results, regardless of magnitude.
| TRUNCATION | +2.49 | -2.49 | +2.50 | -2.50 | +3.49 | -3.49 | +3.50 | -3.50 | +3.51 | -3.51 |
|---|---|---|---|---|---|---|---|---|---|---|
| Becomes | +2 | -2 | +2 | -2 | +3 | -3 | +3 | -3 | +3 | -3 |
2.99 becomes 2 when truncating, -2.99 becomes -2, for example. For a receiving field with 2 decimal places, -2.999 becomes -2.99, as does -2.991.
4.1.552 TYPE¶
- A Report Writer report group clause.
- Also, an unsupported data description clause.
4.1.553 TYPEDEF¶
Unsupported data description clause that will allow user defined record layouts.
4.1.554 UCS-4¶
Currently unsupported Universal Character Set alphabet. UCS-4 would store international code points in 4 bytes.
4.1.555 UNDERLINE¶
SCREEN section field attribute. For terminfo, the terminal is sent smul,
the character field, and then rmul. For a VT100 or VT100 emulation, that
becomes Escape, open square bracket, 4m (smul) and Escape, open square bracket, 24m
(rmul).
In this author’s opinion, underlining is a terminal capability worthy of
disabling, on a modern X11 console. Along with blink and SMCUP, RMCUP shadow
screens. For extended screen operations with GnuCOBOL, it can be beneficial
to read up on termcap and terminfo.
4.1.557 UNIVERSAL¶
Unsupported Object COBOL exception object clause.
4.1.558 UNLOCK¶
Manual record unlock and buffer write sync.
A small code sample:
UNLOCK filename-1 RECORDS
4.1.559 UNSIGNED¶
Usage clause specifying that a value will not include any sign and therefore can’t be negative.
4.1.560 UNSIGNED-INT¶
A native storage format NUMERIC data USAGE clause. Equivalent to BINARY-LONG UNSIGNED and the same size as SIGNED-INT.
4.1.561 UNSIGNED-LONG¶
A native storage format NUMERIC data USAGE clause. Equivalent to BINARY-LONG UNSIGNED and the same size as SIGNED-LONG.
4.1.562 UNSIGNED-SHORT¶
A native storage format NUMERIC data USAGE clause. Equivalent to BINARY-SHORT UNSIGNED and sized as SIGNED-SHORT.
4.1.563 UNSTRING¶
A powerful string decomposition verb.
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
4.1.564 UNTIL¶
Sets a loop conditional.
PERFORM VARYING ident-1 FROM 1 BY 1 UNTIL ident-1 > 10
CALL "thing" USING BY VALUE ident-1 END-CALL
END-PERFORM
4.1.566 UPDATE¶
SCREEN section field attribute.
4.1.567 UPON¶
A DISPLAY destination clause.
display "Warning: read length truncated" upon syserr
display "This is going to be cool" UPON PRINTER
There is code going into the reportwriter branch to allow shell script control when using a PRINTER destination.
- Set
COBPRINTERto a command string to be used bypopento control external print support features.
prompt$ export COBPRINTER='cat >>prt.log'
- Use
COB_DISPLAY_PRINTERas a filename tofopen(file, "a");for each write UPON PRINTER.
prompt$ export COB_DISPLAY_PRINTER='prt.log'
4.1.568 UPPER¶
A screen field attribute, input data converted to UPPERCASE.
4.1.569 USAGE¶
GnuCOBOL uses standard big-endian internal storage by default. USAGE clauses influence the data representation. The INTEL architecture uses little-endian form and GnuCOBOL programmers developing for this common chipset may need to pay heed to this for performance purposes. As per the standards, GnuCOBOL supports COMPUTATIONAL-5 native usage.
GnuCOBOL enables use of one to eight byte binary representations in both big and little endian forms.
Along with full support of all common COBOL PICTURE clauses both storage and display, GnuCOBOL supports USAGE clauses of:
- BINARY
- COMPUTATIONAL, COMP
- COMP-1
- COMP-2
- COMP-3
- COMP-4
- COMP-5
- COMP-X
- FLOAT-LONG
- FLOAT-SHORT
- DISPLAY
- INDEX
- PACKED-DECIMAL
- POINTER
- PROGRAM-POINTER
- SIGNED-SHORT
- SIGNED-INT
- SIGNED-LONG
- UNSIGNED-SHORT
- UNSIGNED-INT
- UNSIGNED-LONG
- BINARY-CHAR SIGNED
- BINARY-CHAR UNSIGNED
- BINARY-CHAR
- BINARY-SHORT SIGNED
- BINARY-SHORT UNSIGNED
- BINARY-SHORT
- BINARY-LONG SIGNED
- BINARY-LONG UNSIGNED
- BINARY-LONG
- BINARY-DOUBLE SIGNED
- BINARY-DOUBLE UNSIGNED
- BINARY-DOUBLE
- BINARY-C-LONG SIGNED
- BINARY-C-LONG UNSIGNED
- BINARY-C-LONG
4.1.571 USER¶
An ACCEPT source for getting process owner user name.
4.1.572 USER-DEFAULT¶
OBJECT-COMPUTER clause for locale support.
CHARACTER CLASSIFICATION IS USER-DEFAULT
4.1.574 UTF-16¶
Unsupported internationalization clause.
4.1.575 UTF-8¶
Unsupported internationalization clause.
4.1.576 VAL-STATUS¶
Alias for the unsupported VALIDATE-STATUS clause of the VALIDATE statement.
4.1.577 VALID¶
Unsupported.
4.1.578 VALIDATE¶
Unsupported data validation verb.
4.1.579 VALIDATE-STATUS¶
Unsupported clause of the VALIDATE statement.
4.1.580 VALUE¶
Muti use keyword.
- A CALL frame argument modifier. Dereferencing the argument.
- Sets initial values in data descriptions
- as well as values deemed true with 88 level conditional names.
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
4.1.581 VALUES¶
Plural of VALUE when more than one entry is used in an 88 conditional name.
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.
4.1.582 VARYING¶
- Sets a looping variable with PERFORM.
PERFORM VARYING loop-counter FROM 1 BY 1 UNTIL loop-counter > 10
DISPLAY loop-counter
END-PERFORM
- An FD clause for variant sized records
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 65535 TIMES
DEPENDING ON infile-record-length.
With the DEPENDING clause, GnuCOBOL will set the actual length of a READ into
the DEPENDING ON identifier, which also sets the length for WRITE.
The entire FD clause can be shortened, without setting a range, to:
FD infile RECORD VARYING DEPENDING ON infile-record-length.
Especially useful for RECORD BINARY SEQUENTIAL and LINE SEQUENTIAL
file access.
4.1.583 WAIT¶
SHARING file access LOCK timeout management. Support depends on ISAM engine in use. BDB, VBISAM, and others, have locking timeout support. On timeout FILE STATUS will be set to “47” input-denied.
READ infile NEXT RECORD WITH WAIT END-READ
4.1.584 WHEN¶
A very powerful keyword used in EVALUATE phrases for specifying conditional expressions.
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
4.1.585 WHEN-COMPILED¶
An obsolete special register.
identification division.
program-id. when-compiled-sample.
date-written. 2015-10-28/00:17-0400.
procedure division.
display when-compiled
stop run.
The special register returns a build time stamp in the form MM/DD/YYhh.mm.ss which is an ambiguous value, and its use is discouraged.
prompt$ cobc -xj when-compiled-sample.cob
10/28/1500.20.10
The preferred method is FUNCTION WHEN-COMPILED.
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.
Producing a more reasonable value:
$ cobc -xj when-compiled-sample.cob
10/28/1500.21.29
2015102800212900-0400
Far less ambiguous, and more in tune with international concerns.
When FUNCTION ALL INTRINSIC is in effect in the CONFIGURATION SECTION,
the latter output format takes precedence over the old special register form.
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.
giving:
prompt$ cobc -xj when-compiled-sample.cob
2015102800263700-0400
2015102800263700-0400
Advice: Use FUNCTION WHEN-COMPILED explicitly, or ensure code is compiled
with FUNCTION ALL INTRINSIC set in the REPOSITORY paragraph.
Note: WHEN-COMPILED is set once during any particular compilation pass, all programs, and/or nested programs within a source build will have the same value. The same is true for FUNCTION WHEN-COMPILED.
Also please note: This is for source code compiles. Programs in previously
compiled, binary object or link libraries will have their own separate
WHEN-COMPILED value, set when the library was compiled, not when a program
using CALL links to it. Both the caller and called will have a setting, taken
from the date and time when cobc passed over the sources, and not during
any later, non source form, object linkage times.
4.1.587 WORDS¶
Ignored OBJECT-COMPUTER MEMORY clause.
4.1.588 WORKING-STORAGE¶
A DATA division section. Unless BASED, all fields are allocated and fixed in memory (for the running program within a module).
4.1.589 WRITE¶
Record write to file, with features for page control.
Write sequential:
Random file:
Unlike READ that uses filenames syntax, WRITE uses record buffer syntax by default, which must be related to the file through the FD file descriptor. GnuCOBOL supports LINAGE and WRITE has support for ‘report’ paging and line control.
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
4.1.590 YYYYDDD¶
Modifies ACCEPT var FROM DAY to use full 4 digit year for the Julian date retrieval.
ACCEPT date-var FROM DAY YYYYDDD
4.1.591 YYYYMMDD¶
Modifies ACCEPT var FROM DATE to use full 4 digit year.
#!/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 ":"
==
.
Giving:
$ ./yyyymmdd-sample.cob
:00151213:
:20151213:
4.1.592 ZERO¶
Figurative and numeric constant for the value 0.
#!/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
==
.
Giving:
prompt$ ./zero-sample.cob
0
As can be see here, the figurative constant is used to set the value, for testing the value, and as a display item. When used as a sending field (in MOVE or DISPLAY for example) figurative contants are limited by the receiving field length and/or type. If that length is indeterminant, a length of one is assumed.
See Sample shortforms for the sample-template listing.
4.1.593 ZERO-FILL¶
Not yet implemented. Extension.
4.1.594 ZEROES¶
Plural of ZERO.
#!/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
==
.
Giving:
prompt$ ./zeroes-sample.cob
+00000000.00
See Sample shortforms for the sample-template listing.
4.1.595 ZEROS¶
Alternate spelling for ZEROES.
#!/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
==
.
Giving:
prompt$ ./zeros-sample.cob
GOOSE EGGS
but that tongue in cheek sample is not something you’d put in a bank report. In school? Maybe a chuckle. At work? Probably sacked. In this FAQ? Go ahead, roll your eyes, this is the last reserved word and it deserved a sample.
See Sample shortforms for the sample-template listing.
4.2 Does GnuCOBOL implement any Intrinsic FUNCTIONs?¶
Yes. Most of the COBOL 2014 Standard is covered.
4.2.1 FUNCTION ABS¶
Absolute value of numeric argument
#!/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
==
.
With a run sample of:
$ ./abs-sample.cob
Abs of: -42.42 is 42.42
Abs of: -0.42 is 0.42
Abs of: 42.42 is 42.42
See Sample shortforms for the sample-template.cob listing.
4.2.2 FUNCTION ACOS¶
The ACOS function returns a numeric value (in radians) that approximates the arccosine of the argument.
The domain of the arccosine function is -1 to +1. Domain errors return a result of 0. The inverse cosine function returns a range of 0 thru π
#!/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°
See Sample shortforms for the sample-template.cob listing.
4.2.3 FUNCTION ANNUITY¶
Compute the ratio of an annuity paid based on arguments of interest and number of periods.
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.
Outputs:
Monthly rate: +0.0067 Periods: 36 Annuity ratio: +0.0314
4.2.4 FUNCTION ASIN¶
The ASIN function returns a numeric value (in radians) that approximates the arcsine of the argument.
The domain of the arcsine function is -1 to +1. Domain errors return a result of 0. The inverse sine function returns a range of -π/2 thru π/2
#!/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°
See Sample shortforms for the sample-template.cob listing.
4.2.5 FUNCTION ATAN¶
The ATAN function returns a numeric value (in radians) that approximates the arctangent of the argument.
The domain of the arctangent function is all real numbers. The inverse tangent function returns a range of -π/2 thru π/2
#!/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°
Plotting these values to a terminal, which can come in handy for command line COBOL programs.
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
Giving:
1.5 +----------------+-----------------+----------------+-------------****
| : : : ****** |
| : : : ****** |
1 +...............................................******...............+
| : : ****** : |
| : : ***** : |
0.5 +....................................*...............................+
| : :* : |
| : * : |
0 +..................................*.................................+
| : * : |
| : *: : |
| : * : : |
-0.5 +................................*...................................+
| : ***** : : |
| : ****** : : |
-1 +...............******...............................................+
| ****** : : : |
| ****** : : : |
-1.5 ****-------------+-----------------+----------------+----------------+
-10 -5 0 5 10
See Sample shortforms for the sample-template.cob listing.
4.2.6 FUNCTION BOOLEAN-OF-INTEGER¶
Not yet implemented.
Will return a USAGE BIT field given an integer argument and bit width.
4.2.7 FUNCTION BYTE-LENGTH¶
The BYTE-LENGTH function returns an integer that is the internal storage length of the given argument.
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.
Outputs:
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
4.2.8 FUNCTION CHAR¶
The CHAR function returns a ONE character alphanumeric field whose value is the character in the current collating sequence having the ordinal position equal to the value of the integer argument. The argument must be greater than 0 and less than or equal to the number of positions in the collating sequence. Errors in the argument range return 0 (the LOW-VALUE by default).
See ASCII or EBCDIC and details of the ALPHABET clause.
DISPLAY FUNCTION CHAR(66).
Would output A in the ASCII character set. Note this may be different than what some expect. GnuCOBOL CHAR is 1 thru 128 not 0 thru 127 as a C programmer may be used to.
And to add a little confusion, most personal computers use an extended character set, usually erroneously called ASCII with a range of 0 to 255. A more appropriate name may be ISO-8859-1 Latin 1. See ASCII for more accurate details. This author is often guilty of this misnomer of the use of the term ASCII.
4.2.9 FUNCTION CHAR-NATIONAL¶
Not yet implemented.
Will return a character from the national program collating sequence, given an integer argument representing the ordinal position in the sequence. From 1 to the length of the alphabet.
4.2.10 FUNCTION COMBINED-DATETIME¶
Returns a common datetime form from integer date (years and days from 1600 to 10000) and numeric time arguments (seconds in day). Date should be from 1 to 3067671 and time should be from 1 to 86400. The character string returned is in the form, 7 digits dot 5 digits.
DISPLAY FUNCTION COMBINED-DATETIME(1; 1)
Outputs:
0000001.00001
4.2.11 FUNCTION CONCATENATE¶
Concatenate the given fields. CONCATENATE is a GnuCOBOL extension.
MOVE "Cobol" TO stringvar
MOVE FUNCTION CONCATENATE("GNU "; stringvar) TO goodsystem
DISPLAY goodsystem
4.2.12 FUNCTION COS¶
The COS function returns a numeric value that approximates the cosine of the argument (in radians).
The domain of the cosine function is all real numbers, with a nominal domain of 0 thru π with a zero returned at π/2. The cosine function returns a range of -1 thru +1.
#!/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
==
.
And a run sample of:
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
See Sample shortforms for the line-sequential-template.cob listing.
4.2.13 FUNCTION CURRENCY-SYMBOL¶
returns the current character symbol for monentary value picture clauses and outputs.
At time of testing this looked broken... cobc/parser.y has some support but if looks unfinished.
currency-symbol.cob
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.
*>****
The above feels wrong and the following looks wrong.
$ cobc -x currency-symbol.cob
$ ./currency-symbol
giving:
$
004242.00
&4242.00
I may have a misconfigured LOCALE and or misunderstanding of currency sign and symbol. There is code for WITH PICTURE SYMBOL “literal” but it is incomplete.
4.2.14 FUNCTION CURRENT-DATE¶
Returns an alphanumeric field of length 21 with the current date, time and timezone information in the form YYYYMMDDhhmmsscc±tznn
DISPLAY FUNCTION CURRENT-DATE.
Example Output:
2008080921243796-0400
See FUNCTION FORMATTED-CURRENT-DATE for an easier to read form.
4.2.15 FUNCTION DATE-OF-INTEGER¶
Converts an integer date, (days on the Gregorian calendar, since December 31 1600) to YYYYMMDD form
#!/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
==
.
Outputs:
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
50,000 days after December 31, 1600, being November 23rd, 1737.
See Sample shortforms for the sample-template.cob listing.
4.2.16 FUNCTION DATE-TO-YYYYMMDD¶
Converts a two digit year date format to four digit year form using a sliding window pivot of the optional second argument. The pivot defaults to 50.
The GnuCOBOL implementation of DATE-TO-YYYYMMDD also accepts an optional third argument, replacing the default century value of 1900 and is treated as the years added to the given year portion of the first argument and modified by the sliding 100 window pivot.
Domain errors occur for year values less than 1600 and greater than 999,999. There is no validation of the input date.
Because of the sliding window, this function is dependent on the date of evaluation
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)
When run in August, 2008 produces:
20000101
20500101
19610101
19990101
18990101
17990101
19990101
20990101
4.2.17 FUNCTION DAY-OF-INTEGER¶
Converts a Gregorian integer date form to Julian date form (YYYDDD) based on days since December 31, 1600. Errors return 0
DISPLAY FUNCTION DAY-OF-INTEGER(97336).
1867182
97,336 days after 16001231 being the 182nd day of the year 1867. Canada’s date of Confederation and recognized birthday.
4.2.18 FUNCTION DAY-TO-YYYYDDD¶
Converts a Julian 2 digit year and three digit day integer to a four digit year form. See FUNCTION DATE-TO-YYYYMMDD for some of the details of the calculations involved.
4.2.19 FUNCTION DISPLAY-OF¶
Not yet implemented.
4.2.20 FUNCTION E¶
Returns Euler’s number as an alphanumeric field to 34 digits of accuracy after the decimal. E forms the base of the natural logarithms. It has very unique and important properties such as:
- the derivative of ex is ex
- and the area below the curve of y = 1/x for 1 <= x <= e is exactly 1.
- making it very useful in calculations of Future Value with compound interest.
DISPLAY FUNCTION E
outputs:
2.7182818284590452353602874713526625
A small graph to show the magic area.
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.
The area in red is exactly 1. Well, not on this plot exactly, as it is somewhat sloppy with the xstep end case and the precisions.
See Can GnuCOBOL be used for plotting? for some details on plotting.
4.2.21 FUNCTION EXCEPTION-FILE¶
This special-register holds the error number and name of the source file that caused an input output exception. See FUNCTION EXCEPTION-STATUS for an example.
4.2.22 FUNCTION EXCEPTION-FILE-N¶
Not yet implemented.
4.2.23 FUNCTION EXCEPTION-LOCATION¶
This special-register can be queried for the location of the last exception. See FUNCTION EXCEPTION-STATUS for example source code. Note: This feature requires compilation with -fsource-location compiler switch. This option is also turned on with -g and -debug debugging info compiles. Information includes PROGRAM-ID, section and source line.
4.2.24 FUNCTION EXCEPTION-LOCATION-N¶
Not yet implemented.
4.2.25 FUNCTION EXCEPTION-STATEMENT¶
This special-register holds the statement that was executing when the latest exception was raised. See FUNCTION EXCEPTION-STATUS for an example. Note: This feature requires compilation with -fsource-location compiler switch. This option is also turned on with -g debugging info compiles.
4.2.26 FUNCTION EXCEPTION-STATUS¶
This FUNCTION returns the current exception status. The example below is courtesy of Roger While, from a post he made announcing the FUNCTION EXCEPTION- features.
Source format is free, compile with cobc -x -g -free except.cob
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.
Example output:
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
Tip
See the source file libcob/exception.def for a list of the plethora of run-time exceptions supported by GnuCOBOL.
4.2.27 FUNCTION EXP¶
Returns an approximation of Euler’s number (see FUNCTION E) raised to the power of the numeric argument.
DISPLAY FUNCTION EXP(1)
outputs:
2.718281828459045091
Note
Be aware that this approximation seems accurate to “only” 15 decimal places. Diligent programmers need to be aware of the foibles of floating point mathematics and take these issues into consideration.
4.2.28 FUNCTION EXP10¶
Returns an approximation of the value 10 raised to the power of the numeric argument.
DISPLAY FUNCTION EXP10(1.0)
DISPLAY FUNCTION EXP10(1.2)
DISPLAY FUNCTION EXP10(10)
Outputs:
10.000000000000000000
15.848931924611132871
10000000000.000000000000000000
4.2.29 FUNCTION FACTORIAL¶
Computes the factorial of the integral argument. Valid domain of 0 to 19 with a range of 1 to 121645100408832000.
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.
Outputs:
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
Kind of the same thing, with some zero out formatting.
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.
Which outputs:
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
4.2.30 FUNCTION FORMATTED-CURRENT-DATE¶
Returns the current date, formatted as per the given format specification, matching those of ISO 8601.
See FUNCTION FORMATTED-DATETIME for the allowable format specifications.
display formatted-current-date("YYYY-Www-D")
2015-W49-3
display formatted-current-date("YYYY-MM-DD")
2015-12-02
On Wednesday, December 2nd 2015, the 49th week, 3rd day of the week.
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
The Z spec (Zulu time) displays the time field relative to UTC, not local time.
If the current time zone cannot be determined, the initial +/- symbol is displayed as a 0, so that would have been shown as:
display formatted-current-date("YYYY-MM-DDThh:mm:ss+hh:mm")
2015-12-02T03:47:05000:00
4.2.31 FUNCTION FORMATTED-DATE¶
Returns a formatted time given:
- an ISO 8601 format spec
- an integer date form
- an optional offset from UTC expressed in minutes.
See FUNCTION FORMATTED-DATETIME for the allowable format specifications.
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))))
On December 2nd, 2015 displayed:
2015-12-02
2015-W49-3
4.2.32 FUNCTION FORMATTED-DATETIME¶
Returns a formatted combined date and time, given
- an ISO 8601 specification
- an integer date form
- a time in numeric form
- an optional offset from UTC expressed in minutes.
The table below uses:
Wednesday, February 15, 1995, at 05:14:27.812479168304 Eastern Standard Time
for the example value illustrations.
| 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 |
All valid date and time formats are allowed with the combined date and time specifications, and not all combinations are listed here.
4.2.33 FUNCTION FORMATTED-TIME¶
Returns a formatted time given:
- an ISO 8601 specification
- a time in numeric form as a number of seconds past midnight
- an optional offset from UTC, expressed in minutes.
See FUNCTION FORMATTED-DATETIME for the allowable format specifications.
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.
giving:
prompt$ cobc -xj formatted-time-sample
201512012253247400000
000082404
22:53:24
22:53:24-05:00
4.2.34 FUNCTION FRACTION-PART¶
Returns a numeric value that is the fraction part of the argument. Keeping the sign.
DISPLAY FUNCTION FRACTION-PART(FUNCTION E)
DISPLAY FUNCTION FRACTION-PART(-1.5)
DISPLAY FUNCTION FRACTION-PART(-1.0)
DISPLAY FUNCTION FRACTION-PART(1)
Outputs:
+.718281828459045235
-.500000000000000000
+.000000000000000000
+.000000000000000000
4.2.35 FUNCTION HIGHEST-ALGEBRAIC¶
Returns the highest value allowed in the argument’s data type.
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.
giving:
./highest-algebraic
004242.00 : 0999999.99
$4242.00 : 0099999.99
.06 : 0000000.99
4.2.36 FUNCTION INTEGER¶
Returns the greatest integer less than or equal to the numeric argument.
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)
Outputs:
-000000000000000003 -000000000000000004
+000000000000000003 +000000000000000003
-000000000000000001 +000000000000000000 +000000000000000000
Note the -4, greatest integer less than or equal to the argument.
4.2.37 FUNCTION INTEGER-OF-BOOLEAN¶
Not yet implemented.
4.2.38 FUNCTION INTEGER-OF-DATE¶
Converts a date in the Gregorian calender to an integer form. Expects a numeric argument in the form YYYYMMDD based on years greater than or equal to 1601 and less than 10000. Month values range from 1 to 12. Days range from 1 to 31 and should be valid for the specified month and year. Invalid input returns unpredictable results and sets the exception EC-ARGUMENT-FUNCTION to exist. See FUNCTION DATE-OF-INTEGER for the converse function.
4.2.39 FUNCTION INTEGER-OF-DAY¶
Converts a Julian date of YYYYDDD to integer date form. See FUNCTION DAY-OF-INTEGER for the converse intrinsic function. Invalid arguments return an undefined result and set the exception EC-ARGUMENT-FUNCTION to exist.
4.2.40 FUNCTION INTEGER-OF-FORMATTED-DATE¶
Returns an integer date form given
- an ISO 8601 format specification
- a date string appropriate for the spec
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
The first day of the first week of 2014 was actually December 30th, 2013.
See FUNCTION FORMATTED-DATETIME for a table of supported format specifications.
4.2.41 FUNCTION INTEGER-PART¶
Returns the integer part of the numeric argument. Similar to FUNCTION INTEGER but returns different values for negative arguments.
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)
Outputs:
-000000000000000003 -000000000000000003
+000000000000000003 +000000000000000003
+000000000000000000 +000000000000000000 +000000000000000000
4.2.42 FUNCTION LENGTH¶
Returns an integer that is the length in character positions of the given argument.
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
Outputs:
20 10 3
16 19
4.2.43 FUNCTION LENGTH-AN¶
In GnuCOBOL 2.0 this is an alias for FUNCTION BYTE-LENGTH.
4.2.44 FUNCTION LOCALE-COMPARE¶
Not yet implemented.
4.2.45 FUNCTION LOCALE-DATE¶
Returns a culturally appropriate date given an alphanumeric of 8 character positions in the form “YYYYMMDD” and an optional locale name that has been associated with a locale in the SPECIAL-NAMES paragraph.
See https://en.wikipedia.org/wiki/Locale for a start at the very detail rich computational requirements of LOCALE.
Will set EC-ARGUMENT-FUNCTION to exist for invalid input.
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.
Which produced:
[btiffin@home cobol]$ cobc -x locales.cob
[btiffin@home cobol]$ ./locales
06/22/2012
02:15:16 PM
11:00:00 AM
I live in Canada, but usually run Fedora with LANG=en_US.utf8
and so
[btiffin@home cobol]$ export LANG='en_CA.utf8'
[btiffin@home cobol]$ ./locales
22/06/12
02:15:16 PM
11:00:00 AM
Boo, day month year form. Sad, 2 digit year? What kinda backwater land do I live in? Time to write strongly worded letters to some committees. :)
I just looked, and it seems Canada is listed as DD/MM/YY; I’m moving to Germany.
[btiffin@home cobol]$ export LANG=en_DK.utf8
[btiffin@home cobol]$ ./locales
2012-06-22
14:15:16
11:00:00
Joy. year month day. Hmm, what about Hong Kong?
[btiffin@home cobol]$ LANG=en_HK.utf8 ./locales
Sunday, June 22, 2012
02:15:16 EST
11:00:00 EST
Nice.
If you want to run your system through its locales, try
$ locs=( $(locale -a) )
$ for l in ${locs[@]}; do echo $l; LANG=$l ./locales; done
and expect some unicode in the output.
Oh, and along with FUNCTION EXCEPTION-STATUS you can detect invalid arguments.
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.
giving:
$ ./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
4.2.46 FUNCTION LOCALE-TIME¶
Returns a culturally appropriate date given an alphanumeric of 6 character positions in the form “HHMMSS” and an optional locale name that has been associated with a locale in the SPECIAL-NAMES paragraph. See https://en.wikipedia.org/wiki/Locale for a start at the very detail rich computational requirements of LOCALE.
Will set EC-ARGUMENT-FUNCTION to exist for invalid input.
See FUNCTION LOCALE-DATE.
4.2.47 FUNCTION LOCALE-TIME-FROM-SECONDS¶
Returns a culturally appropriate date given an alphanumeric number of seconds and an optional locale name that has been associated with a locale in the SPECIAL-NAMES paragraph.
See https://en.wikipedia.org/wiki/Locale for a start at the very detail rich computational requirements of LOCALE.
Will set EC-ARGUMENT-FUNCTION to exist for invalid input.
See FUNCTION LOCALE-DATE.
4.2.48 FUNCTION LOG¶
Returns an approximation of the natural logarithmic value of the given numeric argument. Uses a base of FUNCTION E.
DISPLAY FUNCTION LOG(100)
DISPLAY FUNCTION LOG(FUNCTION E)
gives:
4.60517018598809137
000000001
4.2.49 FUNCTION LOG10¶
Returns an approximation of the base-10 logarithmic value of the given numeric argument.
DISPLAY FUNCTION LOG10(100)
gives:
000000002
4.2.50 FUNCTION LOWER-CASE¶
Convert any uppercase character values (A-Z) in the argument to lowercase (a-z).
4.2.51 FUNCTION LOWEST-ALGEBRAIC¶
Returns the lowest value allowed in the argument’s data type.
4.2.52 FUNCTION MAX¶
Returns the maximum value from the list of arguments.
DISPLAY FUNCTION MAX ( "def"; "abc"; )
DISPLAY FUNCTION MAX ( 123.1; 123.11; 123 )
Outputs:
def
123.11
4.2.53 FUNCTION MEAN¶
Returns the arithmetic mean (average) of the list of numeric arguments.
DISPLAY FUNCTION MEAN( 1; 2; 3; 4; 5; 6; 7; 8; 9 )
Outputs:
+5.00000000000000000
4.2.54 FUNCTION MEDIAN¶
Returns the middle value of the arguments formed by arranging the list in sorted order.
DISPLAY FUNCTION MEDIAN( 1; 2; 3; 4; 5; 6; 7; 8; 9 )
Outputs:
5
4.2.55 FUNCTION MIDRANGE¶
Returns the arithmetic mean (average) of the minimum and maximum argument from the list of numeric arguments.
DISPLAY FUNCTION MIDRANGE( 1; 2; 3; 4; 5; 6; 7; 8; 9 )
Outputs:
5.000000000000000000
4.2.56 FUNCTION MIN¶
Returns the minimum value from the list of arguments.
DISPLAY FUNCTION MIN ( "def"; "abc";)
DISPLAY FUNCTION MIN ( 123.1; 123.11; 123 )
Outputs:
abc
123
4.2.57 FUNCTION MOD¶
Returns an integer value of that is the first-argument modulo second-argument.
DISPLAY FUNCTION MOD( 123; 23 )
Outputs:
+000000000000000008
4.2.58 FUNCTION MODULE-CALLER-ID¶
Returns the program-id of the calling program, if there is one.
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.
with a sample run of
$ date
Thu Sep 4 04:01:32 EDT 2014
$ cobc -x module-dash.cob
$ ./module-dash
prog
20140904
Sep 04 2014 04:01:34
prog2
/home/btiffin/lang/cobol/module-dash
module-dash.cob
040134
4.2.59 FUNCTION MODULE-DATE¶
Returns time current module was compiled.
4.2.60 FUNCTION MODULE-FORMATTED-DATE¶
Returns the formatted date of when the current module was compiled.
4.2.61 FUNCTION MODULE-ID¶
Returns the program name of the current module.
4.2.62 FUNCTION MODULE-PATH¶
Returns the source code path used when compiling module.
4.2.63 FUNCTION MODULE-SOURCE¶
Returns the source file used when compiling module.
4.2.64 FUNCTION MODULE-TIME¶
Returns time current module was compiled.
4.2.65 FUNCTION MONETARY-DECIMAL-POINT¶
Returns the character representing the LOCALE based fiscal decimal point.
4.2.66 FUNCTION MONETARY-THOUSANDS-SEPARATOR¶
Returns the character representing the LOCALE based visual numeric grouping separator for fiscal data.
4.2.67 FUNCTION NATIONAL-OF¶
Not yet implemented.
Will return a national character string representing the characters in the argument.
4.2.68 FUNCTION NUMERIC-DECIMAL-POINT¶
Renurns the character representing the LOCALE based decimal point.
4.2.69 FUNCTION NUMERIC-THOUSANDS-SEPARATOR¶
Returns the character representing the LOCALE based visual numeric grouping separator.
4.2.70 FUNCTION NUMVAL¶
Returns the numeric value represented by the character string argument.
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.
gives:
-09876.1234
000000000
The “B” in field F, breaks the numeric conversion. NUMVAL is actually fairly complicated and forgiving of inputs, but will return 0 on invalid numeric conversions.
GnuCOBOL 2 will also provide FUNCTION TEST-NUMVAL.
4.2.71 FUNCTION NUMVAL-C¶
Returns the numeric value represented by the culturally appropriate currency specification argument. With optional currency symbol.
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.
gives:
-09876.1234
in a LOCALE that uses the percent sign as a currency symbol.
GnuCOBOL 2 will also provide FUNCTION TEST-NUMVAL-C.
4.2.72 FUNCTION NUMVAL-F¶
Returns the numeric value represented by the culturally appropriate floating point argument string.
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.
gives:
-000001234
GnuCOBOL 2 also provides FUNCTION TEST-NUMVAL-C (as the NUMVAL- functions can cause runtime errors given invalid input).
4.2.73 FUNCTION ORD¶
Returns the integer value that is the ordinal position of the character argument in the program’s collating sequence. COBOL uses 1 as the lowest ordinal for character sequencing.
DISPLAY FUNCTION ORD("J")
Outputs (on an ASCII system with no ALPHABET clause):
00000075
Note that COBOL uses 1 as the first value for collating. So ASCII 74 is ORD 75 for “J”.
4.2.74 FUNCTION ORD-MAX¶
Returns the integer that is the ordinal position of the maximum value of the given argument list.
DISPLAY ORD-MAX( 9; 8; 7; 6; 5; 4; 3; 2; 1 )
DISPLAY ORD-MAX( 'abc'; 'def'; 'ghi' )
Outputs:
00000001
00000003
4.2.75 FUNCTION ORD-MIN¶
Returns the integer that is the ordinal position of the minimum value from the argument list.
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.
Outputs:
00000009
00000003
Notice how ord-min did not require FUNCTION, as the REPOSITORY entry allows this to be skipped in the source codes.
4.2.76 FUNCTION PI¶
Returns an approximation of the ratio of the circumference by the diameter of a circle. It returns an alphanumeric with 34 digits after the decimal. Please be aware of the limitations of using these types of approximated values in computations.
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.
Outputs:
$ 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.
4.2.77 FUNCTION PRESENT-VALUE¶
Returns an approximation of the present value from a discount rate and list of future period end amounts. It attempts to reflect the future value of $1.00 given time, inflation and interest.
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.
Outputs:
$ ./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
For details, talk to a professional.
rant Any COBOL programmer using financial functions for use by others HAS to attain some level of domain expertise in the mathematics at work, as well as a level of technical competence to read through and defend both the COBOL source code and the generated C code that GnuCOBOL emits before compiling. rant over
4.2.78 FUNCTION RANDOM¶
Returns a pseudo-random number greater than or equal to 0.0 and less than 1.0, in a rectangular distribution.
FUNCTION RANDOM takes an optional numeric seed value for the generation of
a sequence of pseudo-random numbers. The seed must be zero or a positive
integer.
DISPLAY FUNCTION RANDOM(1)
DISPLAY FUNCTION RANDOM(1)
DISPLAY FUNCTION RANDOM()
Outputs:
+00000000.1804289383
+00000000.1804289383
+000000000.846930886
The random numbers are sequences, relative to the last given seed, and will be
reproducible given the same seed value. For unpredictable random values, the
seed will need to be from an unpredictable source; for instance the nano second
hardware clock. For more true randomness, Linux has /dev/random and
/dev/urandom. These are all pseudo-random values, not truly random.
To convert from 0.0 <= FUNCTION RANDOM() < 1.0 to a different range, some
arithmetic is required. For example; to get a range from 1 to 10, multiply
the result of FUNCTION RANDOM() by 10.0. This gives a range of 0.0 to
almost 10.0 (but less than actual 10.0). Add 1.0 to get a range of 1.0 to
almost 11.0, and move that to a two digit integer. Truncation will take care
of the rest, giving a fairly even distribution of random values from 1 to 10,
inclusive.
*> 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
==
.
See Sample shortforms for the full sample-template listing.
The sequence is reproducible. Use random(new-seed) to have different
values for different runs of a program.
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
With 1 million passes, each value from 1 to 10 occurred just about 100,000 times each, plus or minus a few tenths of a percent. Different initial seeds would give different counts.
Please note that these sequences are predictable. GnuCOBOL will generate the same sequence of random numbers (unless explicitly seeded) for every run of program. As a matter of fact, GnuCOBOL will generate the same sequence of numbers for any given seed value.
To create an initially less predictable sequence, you need to provide a somewhat random seed value. One common method is to use portions of the system clock as a first seed. Mickey White offered up this sequence, using bytes 8-16 of the datetime stamp:
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
.
One more, please note. This only creates less predictable, not unpredictable sequences. Due to the nature of pseudo-random number generators, these are not truly random. For applications that require a sequence that can outwit a determined guesser, more sophisticated methods are needed. The seed must be changed at unpredictable intervals to avoid known sequence patterns. Some form of unpredictable entropy needs to be used, such as relatively random network activity, hi-res timing of mouse movements or keyboard taps or other nondeterministic source.
The instrinsic FUNCTION RANDOM() in GnuCOBOL is not a
cryptographically secure random number generator. At least not without
surrounding code that ensures an initial (and ever changing) nondeterministic
seeding algorithm.
Having said that, for most uses, FUNCTION RANDOM is random enough. You’ll
have to expend a great deal of effort to predict the next generated value,
once seeded.
With the above listing, Simon Sobisch added
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.
4.2.79 FUNCTION RANGE¶
Returns the value of the minimum argument subtracted from the maximum argument from the list of numeric arguments.
DISPLAY FUNCTION RANGE(1; 2; 3; 4; 5; 6; 7; 8; 9)
Outputs:
+000000000000000008
4.2.80 FUNCTION REM¶
Returns the numeric remainder of the first argument divided by the second.
DISPLAY FUNCTION REM(123; 23)
Outputs:
+000000000000000008
4.2.81 FUNCTION REVERSE¶
Returns the reverse of the given character string.
DISPLAY FUNCTION REVERSE("abc")
Outputs:
cba
4.2.82 FUNCTION SECONDS-FROM-FORMATTED-TIME¶
This function converts a time that is in a specified format to a numeric value representing the number of seconds after midnight.
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.
This test would fail if 01:02:03 was not returned as 3723 seconds past midnight.
Argument 1 takes the form hhmmss and expects argument 2 to be a matching length numeric item, or 0 is returned.
4.2.83 FUNCTION SECONDS-PAST-MIDNIGHT¶
Returns the seconds past the previous midnighti, from the current system time.
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.
giving:
prompt$ cobc -xj seconds-past-midnight-sample.cob
201512012253247400000
000082404
22:53:2
4.2.84 FUNCTION SIGN¶
Returns +1 for positive, 0 for zero and -1 for a negative numeric argument.
4.2.85 FUNCTION SIN¶
Returns an approximation for the trigonometric sine of the given numeric angle (expressed in radians) argument.
The domain of the sine function is all real numbers, with a nominal domain of 0 thru π with a zero returned at n* π and peaks at n* π/2. The sine function returns a cyclic range of -1 thru +1.
#!/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
==
.
And a sample run of:
$ ./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
See Can GnuCOBOL be used for plotting? for another sample graph using gnuplot.
See Sample shortforms for the line-sequential-template.cob listing.
4.2.86 FUNCTION SQRT¶
Returns an approximation of the square root of the given numeric argument.
DISPLAY FUNCTION SQRT(-1)
CALL "perror" USING NULL RETURNING OMITTED
DISPLAY FUNCTION SQRT(2)
Outputs:
0.000000000000000000
Numerical argument out of domain
1.414213562373095145
Note: CALL "perror" exposes a bug in GnuCOBOL versions packaged before June
2009 where the stack may eventually underflow due to improper handling of
void return C functions. Versions supporting RETURNING OMITTED fix
this problem.
An actual application that needs to verify the results of square roots or other C library numerical functions might be better off placing a small C wrapper to set and get the global errno for testing in COBOL sources.
4.2.87 FUNCTION STANDARD-COMPARE¶
Not yet implemented.
4.2.88 FUNCTION STANDARD-DEVIATION¶
Returns an approximation of the standard deviation from the given list of numeric arguments.
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
4.2.89 FUNCTION STORED-CHAR-LENGTH¶
Returns the numeric value of the internal storage length of the given argument, in bytes, not counting trailing spaces.
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.
and:
prompt$ cobc -xj stored-char-length-sample.cob
:default value : 000000013
: : 000000000
:/usr/local/bin/ : 000000015
:/usr/local/bin : 000000014
Along with reference modification, FUNCTION STORED-CHAR-LENGTH can come in
quite handy when dealing with statements that may or may not react well to
trailing spaces in a field. In the short listing above, the INSPECT REPLACING
TRAILING extension only replaces exact character matches, any trailing spaces
would defeat some of the more useful features of this statement, as when
removing a trailing slash from a directory name.
4.2.90 FUNCTION SUBSTITUTE¶
FUNCTION SUBSTITUTE is a GnuCOBOL extension to the suite of intrinsic functions.
DISPLAY
FUNCTION SUBSTITUTE("this is a test",
"this", "that",
"is a", "was",
"test", "very cool!")
Will display:
that was very cool!
having changed this for that, is a for was, and test with very cool!
The new intrinsic accepts:
SUBSTITUTE(subject, lit-pat-1, repl-1 [, litl-pat-2, repl-2, ...])
where lit-pat just means the scan is for literals, not that you have to use literal constants. WORKING-STORAGE identifiers are fine for any of the subject, the search patterns or the replacements.
As with all intrinsics, you receive a new field and the subject is untouched.
Note
The resulting field can be shorter, the same length or longer than the subject string.
This is literal character global find and replace, and there are no wildcards or other pattern expressions. Unlike INSPECT, this function does not require same length patterns and replacements. Each pattern replacement pair uses the original subject, not any intermediate in progress result.
As this is an alphanumeric operation, a reference modification is also allowed
MOVE FUNCTION SUBSTITUTE(subject, pat, repl)(2:4) TO xvar4
to result in 4 characters starting at the second position after the substitution.
4.2.91 FUNCTION SUBSTITUTE-CASE¶
Similar to SUBSTITUTE, but ignores upper and lower case of subject when matching patterns.
display substitute("ABCDEF-GHIJKL",
"abcdef-", "abc case ")
display substitute-case("ABCDEF-GHIJKL",
"abcdef-", "abc case ")
Outputs:
ABCDEF-GHIJKL
abc case GHIJKL
The pattern did not match in the first statement, but did with the SUBSTITUTE-CASE insensitive function.
4.2.92 FUNCTION SUM¶
Returns the numeric value that is the sum of the given list of numeric arguments.
One of the nice features of this function is that the result can be moved directly to an edited-numeric display item.
#!/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
==
.
With a run sample of:
prompt$ ./sum-sample.cob
501,551
+0501551
-501,551
See Sample shortforms for the full sample-template.cob.
4.2.93 FUNCTION TAN¶
Returns an approximation for the trigonometric tangent of the given numeric angle (expressed in radians). Returns ZERO if the argument would cause an infinity or other size error.
#!/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
==
.
shows:
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
Where “~=” denotes “approximately equals”.
See Sample shortforms for the full sample-template.cob.
4.2.94 FUNCTION TEST-DATE-YYYYMMDD¶
Test for valid date in numeric yyyymmdd form.
Returns 0 for success, 1 if the year is not in range, 2 if the month is not in range and 3 if the day is not in range.
#!/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
==
.
Giving:
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
The year 2000 was a leap year, 1900 was not.
See Sample shortforms for the full sample-template.cob.
4.2.95 FUNCTION TEST-DAY-YYYYDDD¶
Test for valid date in numeric yyyyddd form. Years from 1601 to 9999, days from 1 to 365/366.
Returns 0 for success, 1 if the year is not in range, 2 if the day of year is not in range.
#!/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
==
.
With a sample run of:
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
1900 was not a leap year, while the year 2000 was.
See Sample shortforms for the sample-template.cob copybook.
4.2.96 FUNCTION TEST-FORMATTED-DATETIME¶
Returns 0 is the given date and/or time string matches the initial ISO 8601 datetime format specification. If the given date time does not conform to the spec, then TEST-FORMATTED-DATETIME returns the first character position within the string that caused an error.
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
See FUNCTION FORMATTED-DATETIME for a table of supported format specifications.
4.2.97 FUNCTION TEST-NUMVAL¶
Tests the given string for conformance to the rules used by FUNCTION NUMVAL.
Returns 0 if the value conforms, a character position of the first non conforming charater, or the length plus one for other cases such as all spaces.
4.2.98 FUNCTION TEST-NUMVAL-C¶
Tests the given string for conformance to the rules used by FUNCTION NUMVAL-C for items with currency symbols and debit/credit tags.
Returns 0 if the value conforms, a character position of the first non conforming character, or the length plus one for other, cases such as all spaces.
The LOCALE and ANYCASE options are not yet supported.
#!/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
==
.
With a run sample that tests default currency symbol ($ in this case) and a
# symbol:
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
See Sample shortforms for the sample-template listing.
4.2.99 FUNCTION TEST-NUMVAL-F¶
Tests the given string for conformance to the rules used by FUNCTION NUMVAL-F with floating numbers in the COBOL view of scientific notation.
Returns 0 if the value conforms, a character position of the first non conforming character, or the length plus one for other cases, such as all spaces or empty strings.
#!/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
==
.
And a sample run of:
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
See Sample shortforms for the sample-template listing.
4.2.100 FUNCTION TRIM¶
Returns a character string that is the argument trimmed of spaces. Defaults to trimming both ends, but can be passed LEADING or TRAILING qualifier arguments.
DISPLAY '"' FUNCTION TRIM(" abc ") '"'
DISPLAY '"' FUNCTION TRIM(" abc " LEADING) '"'
DISPLAY '"' FUNCTION TRIM(" abc " TRAILING) '"'
Outputs:
"abc"
"abc "
" abc"
4.2.101 FUNCTION UPPER-CASE¶
Returns a copy of the alphanumeric argument with any lower case letters replaced by upper case letters.
DISPLAY FUNCTION UPPER-CASE("# 123 abc DEF #")
Outputs:
# 123 ABC DEF #
4.2.102 FUNCTION VARIANCE¶
Returns the variance of a series of numbers. The variance is defined as the square of the FUNCTION STANDARD-DEVIATION
DISPLAY FUNCTION VARIANCE(1 2 3 4 5 6 7 8 9 100)
+818.250000000000000
4.2.103 FUNCTION WHEN-COMPILED¶
Returns a 21 character alphanumeric field of the form YYYYMMDDhhmmsscc±zzzz e.g. 2008070505152000-0400 representing when a module or executable is compiled.
The WHEN-COMPILED special register also reflects when an object module was compiled, but its use was deemed obsolete and discouraged in newer COBOL programming (newer, meaning anything after 1989).
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.
For a test
$ cobc -c whenpart1.cob && sleep 15 && cobc -c whenpart2.cob &&
> sleep 15 && cobc -x whenshow.cob whenpart1.o whenpart2.o
$ ./whenshow
gives:
First part :2008082721391500-0400
Second part:2008082721393000-0400
Main part :2008082721394500-0400
The value returned from FUNCTION WHEN-COMPILED is not an easy read, and
there are some simple tricks to make this valuable information a little more
pleasing to the eye.
One of the simplest:
01 ws-when-compiled PIC X(8)BX(8).
...
MOVE WHEN-COMPILED TO ws-when-compiled
DISPLAY "prognam " ws-when-compiled
To easily break up the field into date and time fragments.
Using INSPECT is another handy way of making the result more human friendly. From the GLOBAL reserved word code listing, for example.
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
Showing:
Built on 2015-10-27/23:32:46.00-0400
which is a bit easier to read than:
Built on 2015102723324600-0400
REDEFINES can also be used to good effect for this:
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
The above code, posted to the GnuCOBOL project forums by Bill Woodger, an experienced developer with an eye for COBOL programming in the large, and techniques that can avoid mistakes before they happen, (unlike many of the code samples in this FAQ that lean very much to programming in the small), came with a short explanation:
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 :-)
COBOL source code has a tendency to be very long lived. The harder it is to use improperly, the better it is, for everyone involved.
4.2.104 FUNCTION YEAR-TO-YYYY¶
Converts a two digit year to a sliding window four digit year. The optional second argument (default 50) is added to the date at execution time to determine the ending year of a 100 year interval. Results are dependant on current year, as the window slides.
4.3 Can you clarify the use of FUNCTION in GnuCOBOL?¶
Yes. This information is from [Roger], posted to the opencobol forums.
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)).
One clarification to the above quote was pointed out by Roger. The line:
be used anywhere where a source item is valid.
should be:
be used anywhere where a sending field is valid.
4.4 What is the difference between the LENGTH verb and FUNCTION LENGTH?¶
From [Roger]:
The standard only defines FUNCTION LENGTH.
The LENGTH OF phrase is an extension (from MF)
4.5 What STOCK CALL LIBRARY does GnuCOBOL offer?¶
GnuCOBOL 1.0 ships with quite a few callable features. See CALL. Looking through the source code, you’ll find the current list of service calls in:
libcob/system.def
With the GnuCOBOL-reportwriter pre-release, August 2014, that list included
/* 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_CSR_POS", 1, cob_sys_get_csr_pos)
COB_SYSTEM_GEN ("CBL_GET_CURRENT_DIR", 3, cob_sys_get_current_dir)
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_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 ("CBL_OPEN_FILE", 5, cob_sys_open_file)
COB_SYSTEM_GEN ("CBL_OR", 3, cob_sys_or)
COB_SYSTEM_GEN ("CBL_READ_FILE", 5, cob_sys_read_file)
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 ("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 ("\221", 2, cob_sys_x91)
COB_SYSTEM_GEN ("\344", 0, cob_sys_clear_screen)
COB_SYSTEM_GEN ("\345", 0, cob_sys_sound_bell)
COB_SYSTEM_GEN ("\364", 2, cob_sys_xf4)
COB_SYSTEM_GEN ("\365", 2, cob_sys_xf5)
/**/
Note the “SYSTEM”. This CALL sends a command string to the shell. It acts as
a wrapper to the standard C library “system” call. “SYSTEM” removes any
trailing spaces from the argument and appends the null terminator required for
the C library system function. While shell access opens yet another
powerful door for the GnuCOBOL programmer, diligent developers will need to
pay heed to cross platform issues when calling the operating system.
4.5.1 list-system¶
GnuCOBOL 2 has a cobc option --list-system to get at the stock library
list.
$ 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_CSR_POS 1
CBL_GET_CURRENT_DIR 3
CBL_GET_SCR_SIZE 2
CBL_IMP 3
CBL_NIMP 3
CBL_NOR 3
CBL_NOT 2
CBL_OC_GETOPT 6
CBL_OC_HOSTED 2
CBL_OC_NANOSLEEP 1
CBL_OPEN_FILE 5
CBL_OR 3
CBL_READ_FILE 5
CBL_RENAME_FILE 2
CBL_TOLOWER 2
CBL_TOUPPER 2
CBL_WRITE_FILE 5
CBL_XOR 3
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
For reference:
- x”E4”, decimal 228, is clear screen, changes screen mode, best used with awareness of this extended terminal I/O behaviour
- x”E5”, decimal 229, is for ringing the terminal bell.
4.5.2 A CBL_ERROR_PROC example¶
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.
with tectonics:
$ 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)**
errorproc.cob update for GnuCOBOL 2. The ENTRY keyword, used to produce linker entry point symbols in this example, doesn’t work properly with the new GnuCOBOL linkage. There is no way to force a STATIC entry, and the dynamic linker is missing an internal scan hook.
The sample above, will work for GNU Cobol 1.1, but NOT for GnuCOBOL 2.0. or later. At least not at time of writing, Dec 2014. The sample needs to be rewritten to use PROGAM-ID. entry points, instead of the shortcut ENTRY statements.
The listing below, should compile with GnuCOBOL, but it’s wrong. ;-) Intermingled local and working-storage that hasn’t been recoded. Making it a less useful example, being off kilter. And wrong.
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.
4.5.3 byte access files¶
GnuCOBOL supports CBL_READ_FILE and CBL_WRITE_FILE, along with an open and close, and supporting file management funtions, for byte offset and request length access to files.
Seekable streams are the assumed POSIX file access method, and the byte functions allow byte access to these files and streams. Most operating systems will support offset and length access.
The example below is a small marquee, reading 40 bytes of a file, with a incrementing offset, to slide characters across a screen section field at about 5.9 characters per second. Inefficiently, and expensively.
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.
showing:
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
with characters from the source file used as the sliding message.
4.5.4 Some stock library explanations¶
This small gem of a help file was written up by Vincent Coen, included here for our benefit.
Note
The code below is a work in progress. If you see this attention box; the file is not yet deemed complete.
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.
4.6 What are the XF4, XF5, and X91 routines?¶
From opencobol.org
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
Use
CALL X"F4" USING
BYTE-VAR
ARRAY-VAR
RETURNING STATUS-VAR
to pack the last bit of each byte in the 8 byte ARRAY-VAR into corresponding bits of the 1 byte BYTE-VAR.
The X”F5” routine takes the eight bits of byte and moves them to the corresponding occurrence within array.
X”91” is a multi-function routine.
CALL X"91" USING
RESULT-VAR
FUNCTION-NUM
PARAMETER-VAR
RETURNING STATUS-VAR
As mentioned by Roger, GnuCOBOL supports FUNCTION-NUM of 11, 12 and 16.
11 and 12 get and set the on off status of the 8 (eight) run-time GnuCOBOL switches definable in the SPECIAL-NAMES paragraph. 16 returns the number of call parameters given to the current module.
GnuCOBOL 2 adds:
- X”E4” for clearing the screen.
- X”E5” for ringing the terminal bell.
4.7 What is CBL_OC_NANOSLEEP?¶
CBL_OC_NANOSLEEP allows (upto) nanosecond sleep timing. It accepts a 64 bit integer value which may be in character or numeric data forms.
CALL "CBL_OC_NANOSLEEP" USING 500000000
RETURNING STATUS
END-CALL
Would wait one-half second. It may be easier to grok if the source code uses string catenation; “500” & “000000” for example.
Nanosecond timing support is a hardware and platform dependency issue.
4.8 How do you use C$JUSTIFY?¶
The C$JUSTIFY sub program can centre, or justify strings left or right.
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
.
Producing
$ ./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|
4.9 What preprocessor directives are supported by GnuCOBOL?¶
GnuCOBOL 1.1 supports a limited number of directives.
- >>D for conditional debug line compilation
- >>SOURCE for changing fixed and free format preprocessing modes
- *> for inline comments, column 1+ in free form, column 7+ in fixed
GnuCOBOL 2.0 supports a much wider subset of standard directives and existent extensions. Some are only recognized and will be ignored with a warning until implemented.
- >>D
- >>DEFINE
- >>DISPLAY
- >>IF
- >>ELSE
- >>ELIF
- >>ELSE-IF
- >>END-IF
- >>LEAP-SECOND
- >>SET
- >>SOURCE
- >>TURN
4.9.1 >>D¶
Debug line control. GnuCOBOL only compiles these lines if the -fdebugging-line command line option is set.
4.9.2 >>DEFINE¶
Define a compile time symbol.
- >>DEFINE identifier AS literal
- >>DEFINE identifier AS literal OVERRIDE
- >>DEFINE identifier OFF
- >>DEFINE identifier PARAMETER
- >>DEFINE CONSTANT identifier
The -D command line option can be used to define symbols.
4.9.3 >>DISPLAY¶
Display the literal text following the directive, during compile time. Can be placed inside conditional compile directives. Quoting not required, text ends at newline.
4.9.4 >>IF¶
Conditional compile directive. Will include source lines upto >>END-IF, an >>ELSE-IF or >>ELSE clause if condition is true.
- >>IF identifier DEFINED
- >>IF conditional-expression
4.9.4.1 Predefined symbols¶
The GnuCOBOL compiler, predefines a set of compile time option tests.
In C, the definition is set at compile time, if the expression is true.
/* CB_PARSE_DEF (name, return value if true) */
CB_PARSE_DEF ("OPENCOBOL", 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)
This can be used for handy things like bit size assumptions (with the given
cobc configuration, at time of the preprocessing phase of a compile
sequence).
>>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
Currently the C++ branch sets GNUCOBOL and not OPENCOBOL. That will change soon after this writing.
There will be OPENCOBOL, GNUCOBOL, GNUCOBCPP (or other C++ tag), soon, as of March 7, 2015.
There are also some testable values for native endian byte order, and character set:
>>IF ENDIAN = "BIG"
>>IF ENDIAN = "LITTLE"
>>IF CHARSET = "ASCII"
>>IF CHARSET = "EBCDIC"
>>IF CHARSET = "UNKNOWN"
4.9.5 >>ELSE-IF¶
Allows for multiple conditions in a conditional compile sequence.
4.9.6 >>ELIF¶
Alias for >>ELSE-IF.
4.9.7 >>ELSE¶
Compiles in source lines upto an >>END-IF if the previous >>IF or >>ELSE-IF conditions test false.
4.9.8 >>END-IF¶
Terminates a conditional compile block.
4.9.9 >>LEAP-SECOND¶
Ignored.
4.9.10 >>SET¶
Allows modification of compiler source text handling behaviour.
- >>SET CONSTANT
- >>SET SOURCEFORMAT
- >>SET FOLDCOPYNAME | FOLD-COPY-NAME
- >>SET NOFOLDCOPYNAME | NOFOLD-COPY-NAME
- >>SET AS
- >>SET literal
- >>SET {SET_PAREN_LIT}
- >>SET working-store-var
4.9.11 >>SOURCE¶
GnuCOBOL fully supports FREE and FIXED format source. The compiler defaults FIXED form sources, so this directive is usually placed at column 8 or beyond. The command line arguments -free and -fixed controls the default for the first line of source.
See What source formats are accepted by GnuCOBOL? for more details.
4.9.12 >>TURN¶
Will allow modification of exception code handling, when implemented.
4.9.13 Example of compiler directives¶
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.
Testing with:
$ 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.
4.10 What are the GnuCOBOL mnemonics?¶
$ cobc --list-mnemonics
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
Hmm, that doesn’t list KEYBOARD or DISPLAY, two handy device names.
4.11 What are the GnuCOBOL DATA DIVISION level numbers?¶
COBOL is defined with separate DATA and PROCEDURE divisions. This was purposeful in the origin design of the language, from the earliest days.
GnuCOBOL supports the full gamut of data grouping allowed by COBOL, and many of the existing extensions that have been developed by various vendors.
Basically, most level numbers allow for hierarchial field grouping within records.
01 is the base level, and all records must start here or at 77.
02 through 49 are for sub-groups and heirarchial structuring. Aside from higher values being included in lower numbered groups, a programmer is free to skip level numbers.
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.
is the same structure as
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.
and
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.
Note how, in the second example, 25 contains 33 and the next 25 contains 44. In memory this is still an equivalent layout.
Early COBOL developers found that wedging new sub-fields into record layouts was easier when the groups skipped a few numbers, allowing for a 03 and 04 between a 01 and 05, instead of needing to bump all the level numbers up by one, and risking mistakes. So, it is more common to see 01, 05, 10, 15 instead of 01, 02, 03, 04.
COBOL requires that fields have types and sizes, and groups do not, but they may have attributes, such as GLOBAL_.
4.11.1 Special Data Levels¶
GnuCOBOL also supports the common COBOL special data level numbers.
66 is for renaming fields, groups and sub-groupings. See RENAMES
- 77 for single entry, not subdivided or part of any subdivision, elementary
data fields.
- 78 for constants, but COBOL 2002 has a new CONSTANT keyword that may be
preferred to the 78 non standard extension.
- 88 for conditionals, where the values listed are not stored, but return true
if the previously listed field (at any level number from 01 to 49, or 77) contains any of the values listed.
5 Features and extensions¶
5.1 How do I use GnuCOBOL for CGI?¶
GnuCOBOL is more than capable of being a web server backend tool.
- One of the tricks is assigning an input stream to KEYBOARD when you need to get at POST data.
- Another is using the ACCEPT var FROM ENVIRONMENT feature.
Modern day web programming requires security considerations, even for simple samples. Defensive programming is a mainstay of COBOL development, and developers should always keep in mind that the network is an actively hostile environment. In the sample below, all form and environment data is stripped of all less-than, greater-than and ampersand symbols. Ruthless, but much safer.
Full confession, an early binary of this code was publicly hosted for too
many years, for people to try; it simply echoes some web form and environment
data. It did not have the inspect converting, and I have no idea if anyone
ever thought of using it to launch cross site scripting attacks. An insecure
tiny piece of how-to might well have caused someone else some grief. (I looked,
through log archives after realizing, and found no trace of any shenanigans,
but still). When it comes to network facing applications:
caveat amplificator, *developer beware*
Here is gnucobolcgi.cob, a sample of simple GET and POST handling. Far more sophisticated browser friendly applications can be written in GnuCOBOL in surprisingly few lines of source code.
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 <, >, and &"
" 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: "
"</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.
Once compiled and placed in an appropriate cgi-bin directory of your web server, a simple form can be used to try the example.
cgienvform.html
<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>
5.1.1 AJAX¶
From a post on opencobol.org by DamonH:
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.
ajax.html
<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>
An old screenshot from Vala WebKit embedded in OpenCobol sample. To be clear, this is a screenshot of a COBOL application, that includes an embedded brower, displaying AJAX invoked COBOL CGI binaries; (installed on shared host without superuser access). Take this one step further, and the browser application could utilize libSOUP and be its own webserver.
Sometimes, just wow. Ok, feel the need for marketing speak. “Moving beyond COBOL? Why? Move COBOL beyond.”
and the current GnuCOBOL copy from the Konqueror web browser.
For those developers looking to serve GnuCOBOL applications on hosted systems and no super user privileges, see How do I use LD_RUN_PATH with GnuCOBOL? for some pointers on local library linkage.
5.1.2 jQuery¶
Umm, this gets a LOT easier to read with jQuery. The above AJAX listing is reduced to:
The HTML part
<script type="text/javascript" src="/js/jquery.js"></script>
And the AJAX with jQuery
$.ajax({
url: "/gnucobol-cobweb/gnucobol-sample/default.cgi",
data: {
report: "RWEX06"
},
success: function( data ) {
$( "#gnucobol-sample" ).html( "<pre>" + data + "</pre>" );
}
});
which would fill an element on a web page, tagged gnucobol-sample
with the output of Jay Moseley’s Report Writer tutorial sample 6, all nicely
wrapped in a pre block. Later triggers can refill the named div (or other
element) with more exciting blocks of ancient COBOL lore. Valuable lore,
lifted to the web in a few lines of script and some recompiles.
5.1.3 CGIFORM¶
And now, for a larger scale full application that demontrates handling form fields, URI percent decoding, and mulitpart File Upload capabilities. This is a much longer listing than normally included in the FAQ, but is much more comprehensive, and more pratical for any developers looking to include server side GnuCOBOL handling in their application suites.
Jump to What is ocdoc? to skip past these listings, if you are simply scrolling down through the document at this time.
All this code goodness is a Contributions entry along with the GnuCOBOL project, get it with
svn checkout svn://svn.code.sf.net/p/open-cobol/contrib/ gnucobol-contrib
cd gnucobol-contrib/trunk/samples/cgiform
First up, László’s readme file and some hints on customization.
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.
and from a post on SourceForge
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.
And now the HTML control form:
<!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>
The main server side GnuCOBOL code, cgiform.cob:
(This is a lot of code, skip past by clicking What is ocdoc? if you aren’t looking for GnuCOBOL CGI assistance at this time).
*>******************************************************************************
*> 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.
As with all of László’s contributions, there is also a sample Makefile, to
get you up and rolling quickly.
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
And some small Cygwin starter scripts.
cygwin_apache_start.sh
# 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
and finally, cygwin_apache_stop.sh
# Stop Apache2
/usr/sbin/apachectl2 stop
With that example, you should now be ready to take on the web with GnuCOBOL programming. Many thanks to László Erdős for sharing his creations and hard work.
Click CGIFORM to skip to the top of the listings.
5.2 What is ocdoc?¶
ocdoc is a small utility used to annotate sample programs and to support generation of Usage Documentation using COBOL sourced ReStructuredText extract lines.
ocdoc.cob
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
5.2.1 ocdoc generated ocdoc documentation¶
See ocdoc.html for the output from processing ocdoc.cob with ocdoc using the tectonics listed in the source. skin.css ends up embedded in the html.
$ cobc -x ocdoc.cob
$ ./ocdoc ocdoc.cob ocdoc.rst ocdoc.html skin.css
5.3 What is CBL_OC_DUMP?¶
CBL_OC_DUMP is somewhat of a community challenge application to allow for runtime data dumps. Multiple postings to opencobol.org has refined the hex display callable to:
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.
Example displays:
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 {...............
Or with OC_DUMP_EXT environment variable set to Y:
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 ................
5.3.1 Update to OC_CBL_DUMP¶
human posted a new version that displays the dump upon SYSERR. Goes to show the activity that can spring forth from a keen and engaged community.
Edit 19-Oct-2010: Put all dump-outputs to syserr. Removed unused paragraphs and minor beauty changes.
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.
5.4 Does GnuCOBOL support any SQL databases?¶
Yes. There are embedded SQL engines for GnuCOBOL and PostgreSQL, Oracle, and Firebird. There has also been efforts made for accessing DB2.
5.4.1 OCESQL¶
Brought to us by the developers behind the Open Source COBOL Consortium in Japan. It may require a pass through Google Translate, but see
http://www.osscons.jp/osscobol/download/
and look to DB interface tool (Open COBOL ESQL) v1.0.0
Coded for ./configure; make; make check && sudo make install
Will require PostgreSQL as well as the development headers.
While you are on the site, you may want to look at the UTF-8 and SJIS character set versions of the GnuCOBOL compiler.
5.4.1.1 Running ocesql¶
What follows is from the sample/ directory that ships with
ocesql-1.0.0.tar.gz.
Please note: for the FAQ, some lines have been deleted, that are commented out in the sample, as they are for use in Japan. The ocesql preprocessor is Unicode ready, but the data entries in Japanese have been removed from the listings here.
First, inserting and populating a sample table, EMP, the employees. Fields include (test) employee number, sample name, and sample salary.
INSERTTBL.cbl
******************************************************************
* 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.
******************************************************************
Running the oceqsl preprocessor:
prompt$ ocesql INSERTTBL.cbl inserttbl.cob
Gives
******************************************************************
* 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.
******************************************************************
Giving:
prompt$ cobc -x inserttbl.cob -locesql
prompt$ ./inserttbl
*** INSERTTBL STARTED ***
*** SQL ERROR ***
SQLSTATE: 01
SQLCODE: -0000000402
SQLERRMC:
Which is a pretty good indication that the PostgreSQL server is NOT running. So (on a Fedora 22 box, with PostgreSQL 9.4 installed):
prompt$ systemctl start postgresql
And another intial run of:
prompt$ ./inserttbl
*** INSERTTBL STARTED ***
*** SQL ERROR ***
SQLSTATE: 42P01
SQLCODE: -000000400
SQLERRMC: ERROR: table "emp" does not exist
And during the initial run, the table did not exist and drop table
reported an error, but that first run has now created it, so one more run to
get a clean listing:
prompt$ ./inserttbl
*** INSERTTBL STARTED ***
*** INSERTTBL FINISHED ***
And the sample data is now in place. If you look closely, the sample data has negative salaries, for testing purposes. These hard coded values use a sign field of ‘p’ in the numerics. This is pretty low level stuff, and would not be something you would normally be faced with. But, it’s a good thing to know about if the situation ever does come up.
Now to test the newly created table.
FETCHTBL.cbl
******************************************************************
* 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.
******************************************************************
After processing with:
$ 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
=======================================================
The input for the cobc compiler looks like
******************************************************************
* 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.
******************************************************************
Each of the generated lines prefixed with an easy to spot sequence value.
Compile with:
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 ***
And repeating: Some of the example salaries listed above are negative, on purpose, as part of the test head, and work as expected. (Although it would not be the nicest of pay days if this was production data).
GnuCOBOL and PostgreSQL go great together. Many thanks to the team in Japan for a job well done.
PostgreSQL is one of the world’s preeminent free software projects. It is a very well documented, very well written SQL database engine, more than capable of handling the largest work loads. And GnuCOBOL can now benefit with a very comprehensive ESQL preprocessor.
Oh, and one point. The sqlca.cbl copybook that ships with ocesql is
NOT the same as the generic sqlca.cpy that ships with GnuCOBOL. Take care
to ensure that your programs use the correct file when compiling. ocesql
includes a command line option to help keep things straight for your
installation, but you still want to be mindful of the difference:
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]
ocesql/copy/sqlca.cbl
******************************************************************
* 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).
******************************************************************
versus the file that ships with GnuCOBOL:
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).
5.4.2 esqlOC¶
By Sergey Kashyrin, for access to MariaDB and other ODBC compliant SQL engines.
See Getting Started with esqlOC for a complete write up. Another beauty.
5.4.3 Firebird gpre¶
The good folk at IBPheonix have modified the Firebird gpre COBOL
preprocessor slightly and it now integrates well with GnuCOBOL. The Firebird
database has been in use in production (originally as InterBase) since 1981.
Firebird started with a fork of the open source InterBase 6.0. Instructions
on getting the COBOL gpre command to link with embedded Firebird is documented
at http://www.ibphoenix.com/resources/documents/how_to/doc_382
5.4.4 Oracle¶
Oracle’s procob preprocessor generates code that can be compiled with GnuCOBOL. procob is an Oracle® licensed product.
- as reported on opencobol.org the procob 10.2 Oracle preprocessor produces code that compiles and executes just fine with GnuCOBOL 1.1 See note about data sizes and the binary-size: configuration below.
5.4.5 DB2¶
Dick Rietveld has posted up the steps to link GnuCOBOL programs to DB2.
See http://db2twilight.blogspot.nl/2014/01/linuxdb2-running-cobol-with-inline-sql.html
László Erdős also added some very informative DB2 linkage samples to the GnuCOBOL contributions tree on SourceForge.
https://sourceforge.net/p/open-cobol/contrib/HEAD/tree/trunk/samples/DB2sample/
László’s entry covers you how to pre-compile and compile a GnuCOBOL program with embedded IBM DB2 SQL. The focus lies on the DB2MODx.sqb modules, and not on the DB2TESTx.cob test program.
Samples build on each other and demonstrate
- Connect
- Select
- Insert
- Update
- Delete
- Paging
- Listing
He uses a BOOK database and walks people through the steps in a very thorough and easy to follow manner. Build tests use Cygwin on Windows 7, GnuCOBOL 2, and IBM DB2 Express-C 10.5 (64 bit).
The main DB2MOD.sqb file is
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.
And the initial CONNECT sample from example1/
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.
As with all László’s contributions, there is a lot to learn from DB2sample, and if you are using GnuCOBOL with DB2, then this is a recommended read, and download.
5.4.6 Other SQL engines¶
Along with the GnuCOBOL specific ocesql pre processor, procob and
gpre, there are are at least two usable CALL extensions. There are
currently (January 2016) quite a few active developments for easing SQL engine access.
- There are workable prototypes for SQLite at
ocshell.c
- with a sample usage program at sqlscreen.cob
- and supporting documentation at sqlscreen.html
- The SQLite extension comes in two flavours; a shell mode discussed above and a direct API interface housed at ocsqlite.c
- A libdbi (generic database access) extension is also available. See cobdbi for full details.
- Jim Currey’s team has kindly posted an ease-of-use MySQL preprocessing layer.
- Rumours of a potential Postgres layer have also been heard.
- Not a rumour anymore. Work on a nicely complete PostgreSQL binding was posted by gchudyk in 2009, listed in the Notes section. See libpgsql.cob
- AND as a thing to watch for, one of the good people of the GnuCOBOL community has written a layer that converts READ and WRITE verbiage to SQL calls at run time. More on this as it progresses.
5.4.7 Oracle procob and binary data sizes¶
Details of the configuration setting for proper Oracle procob processing.
From Angus on opencobol.org
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
5.4.8 Direct PostgreSQL Sample¶
Nowhere near as complete as the binding that Gerald later posted to opencobol.org, the example below was a starting point.
Note that the PostgreSQL runtime library is libpq, ending in q not g.
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
display "After PQfinish: " pgconn end-display
goback.
end program pgcob.
with a run sample (September 2014):
$ 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
And the original, which confused more than helped. It does not have enough COBOL style fencing to be a program that can withstand change. And fails in ways that aren’t overly educational.
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 <*
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.
Run from a user account that has default PostgreSQL credentials:
$ 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.
Note that User after is not the valid answer, shown on purpose. The connection had been closed and the status was correctly reported as non-zero, being an error, but this example continued through as a demonstration.
Please note: The second (original copy) is included here for historical don’t purposes. Don’t write code like that, it doesn’t age well, and it can confuse.
5.4.9 Oracle 12.1¶
Thanks to Reinhard Prehofer for a little clarificaiton on Oracle® integration.
WORKING SAMPLES FOR GnuCobol 2.0 connecting to Oracle 12.1 under ubuntu
I have seen a lot of questions and hints (some correct, other misleading) as of how to get Oracle procob-programs up and running with GnuCobol. Here is a summary of my steps where I am using the oracle sample provided in a previous post:
- the prerequisites.
best have a look at https://help.ubuntu.com/community/Oracle%20Instant%20Client which explains in detail (and correctly !) how to set up a runtime system for Oracle unter ubuntu. I downloaded the latest releases, which were 12.1.0.2 . Download the correct version - 32 or 64Bit, depending on your operating system, of course.
Run the following commands after downloading:
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
have a close look where your Oracle has been installed to and set the ORACLE_HOME to the appropriate directory - which ist the “client64” subdir for the 64bit installation:
# 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
(it is an old trick dating back to the last yearthousand to use TWO_TASK in addition to ORACLE_SID ... )
Using procob and thus embedded sql, you have to define your db-connection in the “tnsnames.ora” file. After above installation, you will have to do the following:
mkdir -p $ORACLE_HOME/network/admin
cd $ORACLE_HOME/network/admin
and there create your tnsadmin.ora file - or just transfer it from another installation where the entries have been verified to work. The entry thus should look like the following lines:
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)
)
)
- Precompile
use Oracle procob for precompiling the *.pco into a cobol-file You are free to invoke that precompiler on any host/operating system So it need not be the same machine where you later on are using your GnuCobol installation.
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.
There is NO NEED to change anything in the OraSimple.cbl file so in contrast to other messages or post I have seen and read herein, no upper/lower-case replacmenet of SQLADR => sqladr etc has to be done. just take the file (with UPPERCASE SQLADR, SQLBEX etc) and statically link it together with some Oracle-libraries. The Interface file for cobol (“cobsqlintf.o”) takes care of the UPPERCASE-SQL-library calls and matches them to those in the libclntsh etc.
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
you should get a compiler report like:
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
we are about to execute the program.
Maybe its not the worst idea to enable tracing, so you could see the line where whatever problem might have occured.
export COB_SET_TRACE=YES
export COB_TRACE_FILE=./my_cobol_trace.log
export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH
and now => fire the command:
./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
be aware that userid and passwd are hardcoded
move 'scott' to hv-userid.
move 'tiger' to hv-passwd.
and that the connection to Oracle is combined in such a way:
scott/tiger@MYORADB
Ubuntu-version in use, btw:
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
And finally the coding “OraSimple.pco” => you have to use procob to get the rather lenghty OraSimple.cbl, which I included as an attachment.
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.
5.4.10 ODBC¶
Steve Williams posted a Simple ODBC sample to
http://sourceforge.net/p/open-cobol/discussion/contrib/thread/3d4f1141/
as Simpleodbc.tar.gz.
Here is the README:
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
If you haven’t seen Steve’s work, do yourself a favour and snag a copy of his tarball. The World Cities application suites he has contributed are a great way of learning COBOL, and in particular, a great way of learning well fenced, good, sound COBOL. Unlike many of the loose samples that are written here in the FAQ, Steve demonstrates more professional code, with very informative error messages and robust code checks, for the inevitable times when something goes wrong. Plus, they demonstrate larger file access than most of the small examples here. His samples highlight how GnuCOBOL can chew through multimillion record datasets, with ease.
5.5 Does GnuCOBOL support ISAM?¶
Yes. The official release used Berkeley DB, but there are also experimental configurations of the compiler that use VBISAM, CISAM, DISAM or other external handlers. See What are the configure options available for building GnuCOBOL? for more details about these options. The rest of this entry assumes the default Berkeley database.
ISAM is an acronym for Indexed Sequential Access Method.
GnuCOBOL has fairly full support of all standard specified ISAM compile and runtime semantics.
Update: GnuCOBOL supports split keys, reportwriter branch has functional code, as of April 2015. The second listing will work with pre-release reportwriter.
For example
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 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).
*> 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
*> 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
which outputs:
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
on any first runs, when indexed-file.dat does not exist.
Subsequent runs have the same output with:
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
prepended, as the WRITE INVALID KEY clause triggers a REWRITE to allow overwriting key and data when setting up the sample.
Update: The reportwriter branch suppports split keys, sample was quickly changed to:
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
5.5.1 FILE STATUS¶
Historically, the condition of a COBOL I/O operation is set in an identifier specified in a FILE STATUS IS clause.
John Ellis did us the favour of codifying the GnuCOBOL FILE STATUS codes. See GnuCOBOL FILE STATUS codes for the details.
5.5.2 VBISAM¶
Along with GnuCOBOL, Roger While also put in efforts to “libtoolize” a database engine called VBISAM, by Trevor van Bremen (the VB in VBISAM).
More details follow, but the latest, most debugged version of VBISAM is shipped as part of opensource-cobol from the OSS Consortium based in Japan, and can be downloaded from:
https://github.com/opensourcecobol/opensource-cobol/tree/master/vbisam
For the curious, opensource-cobol is a version of OpenCOBOL 1.1 with
enhancements enabling SJIS and UTF-8 character encoding that makes OpenCOBOL
more useful for use in Japan. Based on OpenCOBOL 1.1, opensource-cobol is now
at version 1.4.0J. This is the same team that developed the ocesql
engine that allows embedded SQL EXEC handling in GnuCOBOL using PostgreSQL.
The VBISAM engine is one of 4 main configurable database engines that ship with the GnuCOBOL source kit.
./configuredefaults to using Berkeley DB, now owned by Oracle Corporation../configure --with-vbisamsets up GnuCOBOL to build with Trevor’s database engine../configure --with-cisamsets up GnuCOBOL to build with CISAM../configure --with-disamsets up GnuCOBOL to build with DISAM.
CISAM and DISAM are proprietary engines from IBM, and will require a license purchase, but GnuCOBOL knows how to make the calls into these libraries.
The main free software alternative to libdb is libvbisam.
VBISAM is not quite as mature as libdb, and has nowhere near the number of
active installs, but it is a respectable alternative ISAM engine to libdb.
The VBISAM project is hosted on SourceForge at http://sourceforge.net/projects/vbisam/, but that code repository is now approaching 12 years of age.
Sources for version 2.0, with Roger’s changes to allow it to fit into a GnuCOBOL build can be found at http://sourceforge.net/projects/vbisam/files/vbisam2/ and includes the following README:
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.
5.6 Does GnuCOBOL support modules?¶
Yes. Quite nicely in fact. Dynamically! COBOL modules, and object files of many other languages are linkable. As GnuCOBOL uses intermediate C, linkage to other languages is well supported across many platforms. The GnuCOBOL CALL instruction maps COBOL USAGE to many common C stack frame data representations.
Multipart, complex system development is well integrated in the GnuCOBOL model.
$ cobc -b hello.cob goodbye.cob
Combines both source files into a single dynamically loadable module. Example produces hello.so.
Using the -l link library option, GnuCOBOL has access to most shared libraries supported on its platforms.
$ cobc -x -lcurl showcurl.cob
Will link the /usr/lib/libcurl.so (from the cURL project) to showcurl. The GnuCOBOL CALL verb will use this linked library to resolve calls at runtime.
Large scale systems are at the heart of COBOL development and GnuCOBOL is no exception.
For more information, see What is COB_PRE_LOAD?.
5.7 What is COB_PRE_LOAD?¶
COB_PRE_LOAD is an environment variable that controls what dynamic link modules are included in a run.
For example:
$ cobc occurl.c
$ cobc occgi.c
$ cobc -x myprog.cob
$ export COB_PRE_LOAD=occurl:occgi
$ ./myprog
That will allow the GnuCOBOL runtime link resolver to find the entry point for CALL “CBL_OC_CURL_INIT” in the occurl.so module. Note: the modules listed in the COB_PRE_LOAD environment variable DO NOT have extensions. GnuCOBOL will do the right thing on the various platforms.
If the DSO files are not in the current working directory along with the executable, the COB_LIBRARY_PATH can be set to find them.
See What is COB_LIBRARY_PATH? for information on setting the module search path.
5.8 What is the GnuCOBOL LINKAGE SECTION for?¶
Argument passing in COBOL is normally accomplished through the LINKAGE SECTION. This section does not allocate or initialize memory as would definitions in the WORKING-STORAGE SECTION.
Care must be taken to inform COBOL of the actual source address of these variables before use. Influences CHAINING and USING phrases. See CALL for more details.
5.9 What does the -fstatic-linkage GnuCOBOL compiler option do?¶
Under normal conditions, the LINKAGE SECTION is unallocated and uninitialized. When a LINKAGE SECTION variable, that is not part of the USING phrase (not a named calling argument), any memory that has been addressed becomes unaddressable across calls. -fstatic-linkage creates static addressing to the LINKAGE SECTION.
From [Roger]:
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.
With some rumours that this may become the default in future releases of GnuCOBOL, and the -fstatic-linkage option may be deprecated.
5.10 Does GnuCOBOL support Message Queues?¶
Yes, but not out of the box. A linkable POSIX message queue layer is available.
/* 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;
}
/**/
With a sample of usage. Note the linkage of the rt.so realtime library.
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.
5.11 Can GnuCOBOL interface with Lua?¶
Yes. Lua can be embedded in GnuCOBOL applications.
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
*><*
With usage document at oclua.html
The above code uses a wrapper layer of C code
/* 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);
}
/**/
and this sample Lua script oclua.lua
-- Start
-- Script: oclua.lua
print("Lua prints hello")
hello = "Hello GnuCOBOL from Lua"
return math.pi, hello
-- End
5.12 Can GnuCOBOL use ECMAScript?¶
Yes. Using the SpiderMonkey engine. And with libseed a GNOME project
exposing JavaScriptCore from WebKitGTK.
5.13 Can GnuCOBOL use JavaScript?¶
Yes. A wrapper for the SpiderMonkey engine allows GnuCOBOL access to core JavaScript. You’ll need a copy of the Mozilla spidermonkey library installed, along with the development headers for smjs for this to work.
/* 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;
}
/**/
A sample GnuCOBOL application:
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.
And with a sample script:
ocjsscript.js
var x = 2
var y = 39
var z = "42"
// boths line evaluate to 42
eval("x + y + 1")
eval(z)
Sample output:
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
5.13.1 Seed¶
A far more powerful linkage to Javascript is available through the Seed
project and libseed-gtk.
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
With a sample run of:
$ 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
The example also displays a browser window, an empty window and a window with a button and hover over tooltip. The Seed project provides fairly easy access to the entire GNOME software stack.
5.14 Can GnuCOBOL interface with Scheme?¶
Yes, directly embedded with Guile and libguile.
callguile.cob
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.
script.scm
(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)
Outputs:
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
Of course using Scheme for financial calculations in a GnuCOBOL application would not be a smart usage. This is just a working sample.
5.15 Can GnuCOBOL interface with Tcl/Tk?¶
Yes. GnuCOBOL supports the Tcl/Tk embedding engine developed by Rildo Pragana as part of the TinyCOBOL project. We have been given permission by Rildo to embed his engine in GnuCOBOL.
See http://ww1.pragana.net/cobol.html for sources.
A working sample
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.
Which uses two Tcl/Tk scripts
#!/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
## ** ##
and
#!/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]"
}
}
}
}
5.16 Can GnuCOBOL interface with Falcon PL?¶
Yes, yes it can.
This is from the linked post ... but the Falcon programming language embeds in GnuCOBOL just fine.
falconscript.fal
> "Falcon list comprehension called from GnuCOBOL"
sums = [].mfcomp( {x,y=> x+y}, .[1 2 3], .[4 5 6] )
return sums.describe()
And a quick sample:
$ ./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]
A Falcon list comprehension with mfcomp applies the reduction x+y on 1 and 4, 1 and 5, 1 and 6, then 2 and 4, 2 and 5 etc.
From opencobol.org back in 2010:
callfalcon.cob
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.
and, with EXTERN “C” to get C++ to play nice with the nameing
/*
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;
}
}
}
and falconscript.fal
> "Falcon called from OpenCOBOL"
return "42"
Built with:
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
with falconscript.fal
> "Falcon list comprehension called from OpenCOBOL"
sums = [].mfcomp( {x,y=> x+y}, .[1 2 3], .[4 5 6] )
return sums.describe()
Repeating the initial example from above:
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]
FalconPL has some nice features.
saying = List("Have", "a", "nice", "day")
for elem in saying
>> elem
formiddle: >> " "
forlast: > "!"
end
giving:
Have a nice day!
5.17 Can GnuCOBOL interface with Ada?¶
Yes. The freely available gnat system can be used and will create object files that can be included in a GnuCOBOL project.
This example compiles an gnat package that includes hello and ingress PROCEDURE and a echo FUNCTION. These will be called from a GnuCOBOL adacaller.cob program.
The gnat specification file
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;
The gnat implementation body
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;
The adacaller.cob source file
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.
And the tectonics; Debian GNU/Linux build.sh
gnatgcc -c helloada.adb
gnatbind -n helloada
gnatgcc -c b~helloada.adb
cobc -x -lgnat adacaller.cob helloada.o b~helloada.o
An important step is the creation of the object file from the gnatbind output with -n that is used in the final GnuCOBOL executable.
Sample run using ./adacaller:
Hello from Ada and GnuCOBOL
Passing integer to Ada from GnuCOBOL
GnuCOBOL passed: 42
Ada echo
Ada return: +000000009
See Can the GNAT Programming Studio be used with GnuCOBOL? for more.
5.18 Can GnuCOBOL interface with Vala?¶
Yes. Very easily. The Vala design philosophy of producing C application binary interface code means that Vala is directly usable with GnuCOBOL’s CALL statement.
See https://wiki.gnome.org/Projects/Vala for some details on this emerging programming environment.
This interface will be seeing more and more use as it really does open the door to some very powerful extensions.
- WebKit embedding
- PDF Viewers
- GTK
- Media streaming
- much more
5.18.1 Call GnuCOBOL programs from Vala¶
Using a few simple tricks, Vala can easily call GnuCOBOL programs. Vala uses a predictable link module naming convention. Inside a class, from.vala, the linker will try and find from_vala_name, in this case from_vala_ochello.
/* 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();
}
/**/
So the PROGRAM-ID here is from_vala_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.
The tectonics might seem a little bit mysterious. cobc is used to produce C source code, including calls for initialization of the GnuCOBOL runtime.
valac is then used to compile and link the Vala source, the generated ochello.c and then the gcc compiler is passed the -lcob to link in libcob.so.
5.18.2 Call GnuCOBOL from a Vala GTK gui application¶
And another experiment, with a gui button and repeated timer calls.
callhellogui.vala
// 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);
}
ochellogui.cob
And here we define from_vala_ochello, from_vala_fishy, from_vala_datey.
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.
Tectonics similar to the first sample. With this one, a timer fires every 50 milliseconds passing data back and forth between Vala and GnuCOBOL unsafely, mind you. If you push button “42”, a message is printed to standard out.
Along with the GUI button, produces:
$ ./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
...
5.18.3 Call Genie program from GnuCOBOL¶
Here is a sample that calls a small Genie program.
piping.gs, a small program that spawns out some shell commands. One fails on purpose, ech is not a valid executable. The next echo call has the output captured in ret_stdout. 42 is then passed as the return code to GnuCOBOL.
// 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
callgenie.cob
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
The Vala/Genie link naming is predictable. Inside a class, wrapper, the Genie generated link name is wrapper_hellogenie.
With a sample run producing:
[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
5.18.4 Pass data to and from Genie¶
The Genie
// 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
The COBOL
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.
The Output
$ 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
5.19 Can GnuCOBOL interface with S-Lang?¶
Yes. The S-Lang engine can be used with GnuCOBOL for two purposes. Supporting a very nice terminal and keyboard programmer interface S-Lang can be used to scan the keyboard for non-waiting ACCEPT key routines. As a bonus, S-Lang has a very nice scripting engine that allows easy and direct linkage of script variables with GnuCOBOL defined storage members.
5.19.1 Setup¶
You will need the S-Lang library for this interface. Under Debian that is simply
$ apt-get install libslang2
See http://www.jedsoft.org/slang for details of this very capable library.
5.19.2 Keyboard control¶
This sample only show S-Lang terminal input. A very sophisticated terminal output control interface is also available.
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
Outputs:
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
having tapped, A, F1, Ctrl-A, Ctrl-B, C, EscEsc and Ctrl-C. The S-Lang abort handler pretty much takes over the Ctrl-C handling in this sample so it looks at though Ctrl-C was tapped twice, but it wasn’t.
5.19.3 Scripting¶
S-Lang also provides a very comprehensive scripting language, which is very easy to embed.
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.
Which produces:
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
5.20 Can the GNAT Programming Studio be used with GnuCOBOL?¶
Yes. Extensions to smooth the integration of GnuCOBOL development in gnat-gps is posted at http://svn.wp0.org/ocdocs/brian/opencobol.xml
<?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>\*>|[ ]{6}\*</New_Line_Comment_Start>
<String_Delimiter>"</String_Delimiter>
<Constant_Character>'</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>*>OC<*
*>>SOURCE FORMAT IS FIXED
*> ***************************************************************
*> Author: Brian Tiffin
*> Date: %D
*> Purpose: %_
*> Tectonics: make
*> ***************************************************************
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.
*> ***************************************************************
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>"</String_Delimiter>
<Constant_Character>'</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 >>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>
which allows for development screens like
or to be honest would do, if the final touches were added to the XML to integrate more with the GPS suite. There is more work required to make a proud developer’s interface. Anyone?
5.21 Does GnuCOBOL support SCREEN SECTION?¶
Yes. The GnuCOBOL 1.1 pre-release now includes support for SCREEN SECTION. Experimental release for this support occurred in early July, 2008.
The compiler recognizes most (if not all) of the Screen description entry of the COBOL 2014 Draft standard.
External variables that influence screen handling include
- COB_SCREEN_EXCEPTIONS=Y
- To enable exceptions during ACCEPT.
- COB_SCREEN_ESC=Y
- To enable handling of the escape key.
Note: When turning on COB_SCREEN_ESC, curses needs to be put in a mode that allows differentiation of Escape prefixed terminal control and the actual Esc key. There is a default timer set to 1 full second before bare Esc key processing is started. This delay is based on old terminal speeds and can be shorted to under 1/10th of a second on most modern systems. Changing this value is depedant on operating system and curses implementation, but a common setting is
export ESCDELAY=100
./tui-program
ESCDELAY values are in milliseconds, and most humans do not notice keyboard delays of under 100 milliseconds. Values as small as 25 milliseconds will not cause issues with modern hardware, the time taken to prefix terminal controls being much faster than was possible with dialup modems and 300 baud terminals of decades past. PDCurses does not test for the ESCDELAY setting.
See Does GnuCOBOL support CRT STATUS? for more information on key codes and exception handling.
According to the standard a SCREEN SECTION ACCEPT does not need to be proceeded by a DISPLAY. The extra DISPLAY won’t hurt, but is not necessary.
5.21.1 Environment variables in source code¶
Thanks to Gary Cutler and opencobol.org.
In order to detect the PgUp, PgDn or PrtSc (screen print) keys, you must first set the environment variable COB_SCREEN_EXCEPTIONS to a non-blank value.
If you want to detect the Esc key, you must set COB_SCREEN_EXCEPTIONS as described above AND you must also set COB_SCREEN_ESC to a non-blank value. Fortunately, both of these can be done within your GnuCOBOL program, as long as they’re done before the ACCEPT.
SET ENVIRONMENT 'COB_SCREEN_EXCEPTIONS' TO 'Y'
SET ENVIRONMENT 'COB_SCREEN_ESC' TO 'Y'
5.22 What are the GnuCOBOL SCREEN SECTION colour values?¶
The FOREGROUND-COLOR and BACKGROUND-COLOR clauses will accept
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.
The compiler actually ships with a COPY book,
/usr/local/share/gnu-cobol/copy/screenio.cpy
and
COPY screenio.
gives access to (along with many extended keycode values)
*> 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.
The display of these colours are also influenced by HIGHLIGHT, LOWLIGHT and REVERSE-VIDEO options. For instance, brown will display as yellow when HIGHLIGHT is used.
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.
Which, showed up looking like
but many issues come into play getting colour on a screen and results will vary, considerably, between monitors.
5.23 Does GnuCOBOL support CRT STATUS?¶
Yes.
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
...
There is also a special GnuCOBOL variable, COB-CRT-STATUS which can be used instead of the CRT STATUS special name.
There is also a COPY text that ships with GnuCOBOL, copy/screenio.cpy that
can be included in the DATA DIVISION. COPY screenio. provides 78 level
constants for supported key status codes. Some values include:
- COB-SCR-F1 thru
- COB-SCR-F64
- COB-SCR-ESC
examine the screenio.cpy file to see the other definitions.
5.24 What is CobCurses?¶
CobCurses is an optional package designed to work with OpenCOBOL 1.0, before GnuCOBOL 1.1 SCREEN SECTION support was initiated. It has many features beyond simple SCREEN SECTION handling.
See http://sourceforge.net/projects/cobcurses for full details. This is a major piece of work by Warren Gay, ve3wwg.
From an opencobol.org posting by Warren announcing release 0.95:
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
5.25 What is CobXRef?¶
CobXRef is a COBOL cross-referencing utility written by Vincent Coen and ported to GnuCOBOL 1.1.
Current source code is available at http://svn.wp0.org/add1/tools/cobxref or http://sourceforge.net/projects/cobxref/ and is currently (January 2016) in active development.
Update: July, 2014, code posted to the SVN tree at
http://sourceforge.net/p/open-cobol/contrib/HEAD/tree/
Full support for cobc -Xref during compiles should be easier for everyone
to get installed soon, when contrib is packaged with the distribution.
The CobXRef system ships with full documentation and information for building from source is included in the readme file.
Fetching the utility
prompt$ svn checkout svn://svn.code.sf.net/p/open-cobol/contrib/ gnucobol-contrib
prompt$ cd gnucobol-contrib/trunk/tools/cobxref
prompt$ ./comp-cobxref.sh
Visit the project space at http://sourceforge.net/projects/cobxref/ for the latest information. Or the GnuCOBOL forums.
Example using the cobxref.cbl GnuCOBOL program for sourcecode:
prompt$ cobc -Xref cobxref.cbl
prompt$ cat cobxref.lst
Please note that formfeeds have been removed from the listing.
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
5.26 Does GnuCOBOL implement Report Writer?¶
Yes, yes it does, as of November 2013, released as a branch on SourceForge.
See REPORT.
GnuCOBOL also supports LINAGE. See Does GnuCOBOL implement LINAGE?
5.27 Does GnuCOBOL implement LINAGE?¶
Yes. LINAGE sets up logical pages inside file descriptors enhancing the WRITE operations and enabling the END-OF-PAGE clause.
FILE SECTION.
FD A-REPORT
LINAGE IS 13 LINES
TOP 2
FOOTING 2
BOTTOM 3.
LINAGE clauses can set:
TOP
LINES
FOOTING
BOTTOM
The LINAGE-COUNTER noun is maintained during writes to LINAGE output files.
See LINAGE for a sample program.
5.28 Can I use ctags with GnuCOBOL?¶
Yes.
Use the Exuberant version of ctags. Exuberant ctags recognizes COBOL,
producing a TAGS or tags file suitable for emacs, vi, nedit and
other editors that support the ctags format. ctags, by default, only
supports the competition, C and Fortran.
After running ctags program.cob
$ vi -t WORKING-STORAGE
will open program.cob and start at the line defining the working-storage section. Note: tags are case-sensitive and for larger projects, the above vi command would start an edit of the first file with an occurrence of WORKING-STORAGE found in the tags.
5.28.1 Vim and ctags¶
Handy keys to remember with ctags and vim:
: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
5.29 What about debugging GnuCOBOL programs?¶
GnuCOBOL internal runtime checks are enabled with -debug.
Support for tracing is enabled with -ftrace and -ftraceall.
Source line location is enabled with -fsource-location, and implied
with the -g and -debug options..
Activation of FIXED format D indicator debug lines is enabled with
-fdebugging-line. In FREE format, >>D can be used anywhere on
a line. See Does GnuCOBOL support D indicator debug lines?.
-fstack-check will perform stack checking when -debug or -g is
used.
-fsyntax-only will ask the compiler to only check for syntax errors,
and not emit any output.
To view the intermediate files that are generated, using -C will
produce the .c source files and any .c.l.h and c.h header files.
-save-temps[=dir] will leave all intermediate files in the current
directory or the optional directory specified, including .i files that
are the COBOL sources after COPY processing.
Support for gdb is enabled with -g.
$ 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)
Setting a break at line 106 and 109 was found by a quick look through the C
code from $ cobc -C hello.cob and seeing where the DISPLAY call and
STOP RUN was located. Note: just because; the gdb displayed addresses were
obfuscated from this listing.
5.29.1 Some debugging tricks¶
From [human] on opencobol.org:
If you want to have different outputs in debug / normal mode use a fake if 1 = 1 like
GCobol
D IF 1 = 1
D DISPLAY "Debug Line" END-DISPLAY
D ELSE
DISPLAY "Normal Line" END-DISPLAY
D END-IF
For using the environment Just define
GCobol
01 debugmode pic x.
88 debugmode-on values 'O', 'Y', 'J', 'o', 'y', 'j', '1'.
put an
GCobol
accept debugmode from Environment "DEBUGMODE"
end-accept
at the beginning of each program (or define debugmode as external) and use it in your programs like
GCobol
IF debugmode-on
DISPLAY "Debug Line" END-DISPLAY
ELSE
DISPLAY "Normal Line" END-DISPLAY
END-IF
For having no debug code in runtime you can combine these two
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
In this way you have fast code at runtime (if not compiled with -fdebugging-line) and can switch the output during development.
The advantages over a compiler switch to disable the displays are:
- You can always use display in your program, not only for debug information.
- You see in the code what you do.
- If compiled with lines that have ‘D’ indicator you can switch at runtime.
- If compiled without lines that have ‘D’ indicator you can have faster and smaller modules.
5.29.2 Animator¶
Federico Priolo posted this beauty of a present on opencobol.org
TP-COBOL-DEBUGGER
http://sourceforge.net/projects/tp-cobol-debugg/ and on his company site at http://www.tp-srl.it/
A system to preprocess GnuCOBOL inserting animator source code that at runtime provides a pretty slick stepper with WORKING-STORAGE display.
This open source bundle is GnuCOBOL. Compile the animator, run it over your own programs and it generates a new source file that when compiled and evaluated, runs in a nice SCREEN SECTION showing original source and a view pane into WORKING-STORAGE.
5.29.3 Unit testing¶
See What is COBOLUnit? for links to a well defined full on Unit testing framework for COBOL, written in GnuCOBOL.
See What is cobol-unit-test? for details of ZUTZCPC, a preprocessor and small Domain Specific Langauge that allows for isolated unit testing of individual paragraphs in COBOL programs.
5.30 Is there a C interface to GnuCOBOL?¶
Most definitely. GnuCOBOL generates C (and C++ with Sergey’s branch) and can be seen as a dual COBOL and C system, or a pure COBOL system depending on application developer choice.
As a short example, showing off a little of cobc’s ease of use when it comes to C source code.
hello.c
#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");
}
With a sample run of
$ 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
That pretty much treated cobc as a very capable C compiler.
Much of this FAQ leans to treating GnuCOBOL as a COBOL/C system, but for those that prefer, GnuCOBOL is also a tried and true COBOL system.
5.30.1 TCC¶
GnuCOBOL can even embed a C compiler, for C code on the fly. The Tiny C Compiler, TCC works very well with GnuCOBOL. http://bellard.org/tcc/
Applications can link to libtcc1.a and use the API that allows for in
memory compilation, or as is done here, build the entire compiler into an
application from source.
Tested with TCC 0.9.26 from http://download.savannah.gnu.org/releases/tinycc/
This Makefile:
# 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
Along with some controlling COBOL and a subprogram for testing
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
calltcc.cob and a small add.cob routine
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.
And then:
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
On demand, on the fly, C compiles. And the C can call back into GnuCOBOL
subprogams. By the way; calltcc can actually be used as a full blown C
compiler as well. The entire TCC stack is included in the executable, which
weighs in at just under half a meg of binary. All you’d need to do is pass
command arguments to the built in tcc command line parser.
Although calltcc uses fixed C sources, they are still only character string variables, and the code could easily come from user input or other sources.
-rwxrwxr-x 1 btiffin btiffin 457216 Mar 27 05:03 calltcc
On a 64bit GNU/Linux system running Xubuntu 15.10. TCC supports a few chipsets, but is mainly an X86 compiler.
.. index:: C; idioms
5.31 What are some idioms for dealing with C char * data from GnuCOBOL?¶
Thanks to Frank Swarbrick for pointing these idioms out
To add or remove a null terminator, use the STRING verb. For example
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.
Or to make changes in place
GCobol
* Change nulls to spaces
INSPECT current-url
REPLACING ALL X"00" WITH SPACE.
Or there is also modified references in GnuCOBOL
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).
And the GnuCOBOL CONCATENATE intrinsic
GCobol
MOVE FUNCTION CONCATENATE(filename; X"00") TO c-field.
[Roger] While points out: X”00” is almost always interchangeable with LOW-VALUE.
In all of the above snippets, the source code X”00” can be replaced by the
COBOL noun LOW-VALUE or LOW-VALUES. Except when a program collating
sequence is active and where the first character is not X”00”.
With the CALL verb, use ADDRESS OF and/or BY REFERENCE
CALL "CFUNCTION" USING BY REFERENCE ADDRESS OF current-url.
The above being equivalent to char** in C.
COBOL, by its nature, passes all arguments by reference. That can
be overridden with the BY VALUE clause and the BY CONTENT clause.
5.32 Does GnuCOBOL support COPY includes?¶
Yes. COPY is fully supported, all variations from the standards up to and including the proposed 2014 standards.
Inline REPLACE text substitutions are also supported.
The -I compiler option influences the copybook search path and
-E can be used to examine the after COPY preprocessor output.
There is also -ffold-copy-upper and -ffold-copy-lower compiler
controls.
5.33 Does GnuCOBOL support WHEN-COMPILED?¶
Yes, both as a special register, and as an intrinsic function.
DISPLAY WHEN-COMPILED.
DISPLAY FUNCTION WHEN-COMPILED.
07/05/0805.15.20
2008070505152000-0400
Note: The WHEN-COMPILED special register is non-standard and was deemed obsolete as far back as 1984.
See WHEN-COMPILED for more details, and use FUNCTION WHEN-COMPILED explicitly in any new programs.
5.34 What is PI in GnuCOBOL?¶
With GnuCOBOL 1.1
DISPLAY FUNCTION PI.
3.1415926535897932384626433832795029
DISPLAY FUNCTION E.
2.7182818284590452353602874713526625
Thats 34 digits after the decimal. Developers that need to know the tolerances for use in calculations are directed to poke around the freely available source code, and to read up on GMP.
5.35 Does GnuCOBOL support the Object features of the 2002 standard?¶
Not yet. July 2008
5.36 Does GnuCOBOL implement level 78?¶
Yes. Data division 78 level clauses can be used for constants, translated at compile time. This common non-standard extension is supported in GnuCOBOL.
5.37 Does GnuCOBOL implement CONSTANT?¶
Current OC 1.1 has preliminary support for a subset of the standard conforming “CONSTANT” phrase. For example:
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.
Note: there is a syntax difference between level 78 and CONSTANT. Level 78s
are an extension, CONSTANT is in the COBOL 2014 specification and is only
allowed for 01 level items.
5.38 What source formats are accepted by GnuCOBOL?¶
Both FIXED and FREE source formats are supported. FIXED format follows the traditional 1-6, 7, 8-72 special columns of the COBOL standards.
1-6 is a free space, ignore by the compiler. Historically this was used as the line indicator for when decks of punch cards were dropped on the floor and had to be manually resorted, and as a protection from fraying around the edges of thin cardboard punch cards so the code was indented a little.
7 is an indicator column. Can hold, * - / and D special symbols.
8-72 is read by the compiler as COBOL source.
73 and beyond, (usually 80 columns max back when card punch input was used) is reserved as a sequence number. IBM mainframe editors will commonly place a sequential number in this field, historically used as a validation measure by the read hardware to ensure cards (source lines) were properly read in the right order, and none of the cards happened to get stuck together. And it was also anothe margin of indentation that helped alleviate the problems of frayed cardboard edges.
See https://en.wikipedia.org/wiki/Punched_card_input/output
and https://en.wikipedia.org/wiki/Punched_cards for some of the details
surrounding the early history of FIXED form COBOL.
Dating back to very early computers, ala 1940 and 1950, right up until the early 1980’s when modern consoles and cathrode ray tubes became all the rage. Now we enjoy wide full colour flat screens, but COBOL was designed and developed many years before that future became our very pleasant computing present.
A “line” of source code, used to be read into the computer encoded on a thin cardboard punch card.
Image in the Public Domain, courtesy of Wikimedia Commons, dedicated by user Arnold Reinhold.
Hence 80 columns. The history of these card forms touch on some of the reasons for the still standard 8 1/2 inch width of most sheets of paper in North America, and just happened to match the size of printed paper money of the era, as the boxes that held the cards of that time could be shared between various government departments.
The compiler directives:
>>SOURCE FORMAT IS FREE
>>SOURCE FORMAT IS FIXED
can be used at anytime to change to lexical scanning rules. The directive must
occur at column 8 or beyond if the ACTIVE scan format is FIXED. As per
the 2002 standard the SOURCE directive can be used to switch formats multiple
times within a compilation unit.
Please note, that cobc defaults to FIXED format processing, unless
given the -free command line switch. That means that for any initial
change to FREE format, the directive needs to start in column 8 or greater
or it will not be recognized.
Column
12345678901234567890
>>SOURCE FORMAT IS FREE
identification division.
...
After the initial directive (or -free switch), you are free to code COBOL
starting at column 1.
Continuation indicators in column 7 are not applicable to FREE format and
are not supported in this mode of translation. String catenation can always
be used (the & operator) to continue long strings across line boundaries.
The special *> (till end of line comment) is supported in both FREE and
FIXED forms, but by necessity will need to be placed at column 7 or
greater in FIXED format sources.
The -free and -fixed options to cobc also influence the expected
source formats, with the default being mandated by the standards as FIXED.
5.38.1 commas¶
Commas undergo special handling by COBOL. For the most part, they are ignored, and never actually passed to the compiler after the text manipulation phase of the toolchain. This is complicated by the
DECIMAL POINT IS COMMA
mode allowed in the SPECIAL-NAMES paragraph as part of the COBOL standard. Then, commas are passed to the compiler, but only when forming numeric literals.
Ignoring DECIMAL POINT IS COMMA for a moment.
MOVE FUNCTION MAX(1, 2, 3, 4, 5) TO maximal
That source is passed to the compiler proper (after the preprocessing text manipulation phase) as
MOVE FUNCTION MAX(1 2 3 4 5) TO maximal
So is this source line:
MOVE FUNCTION MAX(1,,,,,2,,,,,,,3,,,4,5) TO maximal
All commas are stripped out, and the compiler only sees the 5 numbers.
When DECIMAL POINT IS COMMA is active, the line above becomes a syntax
error as GnuCOBOL tries to figure out if the first number is actually 1,2
(being 1.2) in that mode.
5.39 Does GnuCOBOL support continuation lines?¶
Yes. A dash - in column 7 can be used for continuation lines. But, by
necessity continuation lines only apply in FIXED format source code.
FREE format COBOL does not support continuation as there is no real
meaning to the indicator column 7 in FREE form source.
GnuCOBOL normally stops reading FIXED format source code at column 72, and starts at column 8. The Text Manipulation phase reads column 7, strips out anything in column 1-6 and truncates the source line at column 72. Ignoring that GnuCOBOL supports a configuration option
cobc --cb_conf=text-column:72
which can be used to extend the right margin, but that setting is outside
normal FIXED format COBOL processing, and ignored by FREE format
processing.
Under normal circumstances, FIXED format sources are segmented as 1-6, 7,
with 8-72 being the actual code.
Note that in this example there is no terminating quote on the string continuations, but there is an extra starting quote following each column 7 hyphen. Also note that the first line of numbers below, is not COBOL, but shown as a visible column counter.
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.
Compiled with:
$ cobc longcont.cob
$ cobcrun longcont
produces:
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
Note: The DISPLAY of otherstr was split to avoid any wide browser scrolling, not for any COBOL reasons.
Also note that the rules for continuation lines are quite difficult to describe simply and concerned GnuCOBOL programmers are urged to read through the standards documents for full details. It all makes sense, once it makes sense.
5.40 Does GnuCOBOL support string concatenation?¶
Absolutely. Sources that need long strings, or those wishing to enhance
source code readability, can use the & operator
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.
Run this with
$ 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
And for an Intrinsic FUNCTION unique to GnuCOBOL, see FUNCTION CONCATENATE.
5.41 Does GnuCOBOL support D indicator debug lines?¶
Yes, in two forms. As for continuation lines, column
7 has no meaning for SOURCE FORMAT IS FREE source code so the standard
D in column 7 can not be used. FORMAT FREE source code can use the
>>D compiler directive instead. Use D lines as
a conditional include of a source code line. These debug lines will only
be compiled if the -fdebugging-line compiler switch is used.
From human on opencobol.org
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).
GnuCOBOL also supports a >>D debug compile time directive and
a handy trick for those that like to write code that be compiled in both
FIXED and FREE forms, is to place the directive in column 5, 6 and 7.
Column
12345678901234567890
DISPLAY "Normal Line" END-DISPLAY
>>DDISPLAY "Debug Line" END-DISPLAY
This allows use of the directive form in FORMAT FREE and also, with the D in column 7, will compile properly in FORMAT FIXED. In FORMAT FIXED the >> in columns 5 and 6 will be ignored as part of the sequence number field.
For more information on debugging support see What about debugging GnuCOBOL programs?
5.42 Does GnuCOBOL support mixed case source code?¶
Absolutely, kind of. Mixed case and mixed format, ASCII and EBCDIC. Most COBOL compilers have not required uppercase only source code for quite a few years now. Still, most COBOL compilers including GnuCOBOL folds parts of the source to uppercase with certain rules before translating.
The compiler is case insensitive to user names, but not all system link names depending on operating system rules.
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.
Attempted compile with:
$ cobc -x mixcase.cob
produces:
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
Note; that although the folded declarations conflict, the DISPLAY quoted strings will NOT be folded, and would display as expected.
Case sensitivity is also at the mercy of operating system conventions. Under GNU/Linux, GnuCOBOL’s dynamic link loader is case sensitive.
CALL "C$JUSTIFY" USING center-string "C" END-CALL.
is not the same as
CALL "c$justify" USING center-string "C" END-CALL.
In support of case folding and COPY libraries, GnuCOBOL supports -ffold-copy-lower and -ffold-copy-upper. For mixing and matching legacy sources.
Trivia:
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.
5.43 What is the shortest GnuCOBOL program?¶
All that is needed is a program-id. Doesn’t do much.
program-id. a.
Update: It turns out that an empty file is the shortest GnuCOBOL that will do nothing. From Roger
$ 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
$
(Alternate to -frelax-syntax is -std=mf)
5.44 What is the shortest Hello World program in GnuCOBOL?¶
A short version of GnuCOBOL hello world, compiled -free
program-id.hello.procedure division.display "Hello, world".
Thanks to human and the opencobol.org forums.
Please note: This is not good COBOL form, and is only shown as an example of the possibilities.
Update: From Roger the shortest hello world program can be
$ 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
$
So, that means, display"Hello, world". is all you need, if you
compile with relax-syntax.
5.45 How do I get those nifty sequential sequence numbers in a source file?¶
FIXED format COBOL uses the first 6 positions of each line as a programmer
defined sequence field. This field is stripped as part of the
preprocessing and is not validated. Historically, the sequence numbers
were used to verify that card punch cards were read into a card reader in the
proper order. Many legacy COBOL programs have sequentially numbered sequence
values. Here is a little vi trick to renumber the sequence field by 100s.
Given
000005* HELLO.COB GnuCOBOL FAQ example
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. hello.
000030 PROCEDURE DIVISION.
000040 DISPLAY "Hello, world".
000100 STOP RUN.
Running the following ex filter, in Vim, after a : command mode
keystroke:
%!perl -ne 'printf("\%06d\%s\n", $. * 100, substr($_, 6, -1));'
produces a nicely resequenced source file.
000100* HELLO.COB GnuCOBOL FAQ example
000200 IDENTIFICATION DIVISION.
000300 PROGRAM-ID. hello.
000400 PROCEDURE DIVISION.
000500 DISPLAY "Hello, world".
000600 STOP RUN.
- Note: Only use this on already FIXED form source. If used on any FREE format COBOL, the first 6 columns will be damaged and require an undo.
This has no effect on the compilation process, it only effects the appearance of the sources.
Note
Be careful not to confuse SEQUENCE NUMBERS with source code LINE NUMBERS. They are not the same.
- Vim: For users of the Vim editor, the command
:set number
will display the number of each source line. Many editors support the display of line numbers. Even
$ less -N
can be used to display line numbers of its input.
5.46 Is there a way to count trailing spaces in data fields using GnuCOBOL?¶
Yes. Quite a few. But instead of resorting to a PERFORM VARYING sequence try
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.
produces:
062
124
062
The second value is 124 as TWO-WAY accumulates another 62 after ONE-WAY. The INSPECT verb does not initialize a TALLYING variable.
Information modified from opencobol.org forum post.
5.47 Is there a way to left justify an edited numeric field?¶
Yes, a couple of ways.
Assuming a working storage of
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
With GnuCOBOL, the intrinsic
FUNCTION TRIM(myedit LEADING)
will trim leading whitespace. The LEADING is not really necessary as TRIM removes both leading and trailing whitespace.
GnuCOBOL also ships with a library function for justification of strings
CALL "C$JUSTIFY" USING mychars "L" END-CALL
to left justify an alphanumeric field. “R” for right, or “C” for centre.
But a generic idiom that should work across all capable COBOL systems
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:)
Uses the INSPECT verb to count leading spaces, then reference modification to move the characters one past the spaces till the end of the edit field to an alpha field.
With intelligent use of picture clauses, and redefines, the alignment may be a simple move. Courtesy of Bill Woodger.
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 .
T gives right-alignment, U gives left-alignment. As both REDEFINES occupy the full 15 bytes, there is no need to take account of any value in Y prior to the MOVEs to T or U.
Output is:
prompt$ cobc -xj aligning.cob
X: >12345678< Y: > -1234567.89<
X: >12345678< Y: >-1234567.89 <
5.48 Is there a way to detemermine when GnuCOBOL is running ASCII or EBCDIC?¶
GnuCOBOL supports both ASCII and EBCDIC character encodings. A simple test such as
01 MYSPACE PIC X VALUE X"20".
88 MYISASCII VALUE SPACE.
IF MYISASCII
DISPLAY "I'm ASCII" END-DISPLAY
END-IF
can be used to determine the character set at run-time.
5.49 Is there a way to determine when GnuCOBOL is running on 32 or 64 bits?¶
GnuCOBOL builds and supports both 32 and 64 bit architectures. A simple test such as
01 MYPOINTER USAGE POINTER.
IF FUNCTION LENGTH(MYPOINTER) EQUALS 8
DISPLAY "This is a 64 bit machine"
END-IF
can be used to determine the native bit size at run-time.
GnuCOBOL 2.0, with the addition of the COBOL 2014 Compiler Directives and an
extension, comes preloaded with some compile time settings that can be tested.
P64 is one of them.
>>IF P64 IS SET
display "Pointers are 64 bit"
>>ELSE
display "Pointers are 32 bits wide"
>>END-IF
This can come in handy when dealing with size_t data from C and numerics.
>>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.
When passed in CALL, BY VALUE, c-size-t will have a right size on the stack frame, 4 or 8 bytes, and will have the right allocations when passed BY REFERENCE.
5.50 Does GnuCOBOL support recursion?¶
Yes. Not completely to standard currently (January 2016), as there are no restrictions on calling programs in a recursive manner, but yes.
A made up example using a factorial called program
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.
Produces:
num: +0000000004
num: +0000000003
num: +0000000002
num: +0000000001
num: +0000000000
ret: +000000001
ret: +000000001
ret: +000000002
ret: +000000006
ret: +000000024
4! = +0000000024
Of course the Intrinsic FUNCTION FACTORIAL might be a more efficient and much easier way at getting factorials.
5.51 Does GnuCOBOL capture arithmetic overflow?¶
Yes. Here is one sample using ADD with ON SIZE ERROR.
And please note that OVERFLOW is a conditional for STRING. In COBOL, what this author terms ‘overflow’ is less technically correct than ‘size error’ when using COBOL arithmetic terminology.
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.
*> ***************************************************************
which outputs:
+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
GnuCOBOL 2.0 has a significantly larger numerically accurate range.
*> 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 " instrinsic: " 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.
*> ***************************************************************
Showing:
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
instrinsic: 295232799039604140847618609643520000000
pic 9(38) overflow at: 35 is 08683317618811886495518194401280000000
instrinsic: 10333147966386144929666651337523200000000
5.52 Can GnuCOBOL be used for plotting?¶
Yes.
- indirectly with an external call to gnuplot
- indirectly with integrated engines like Octave
- directly, with libraries like MathGL
5.52.1 gnuplot¶
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.
Which displays and saves:
5.52.2 MathGL¶
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;
*}
giving
and, while MathGL is designed for scientific visualization, there are
features that allow for sophisticated financial graphics.
At time of posting, this use of MathGL is not overly sophisticated, but don’t let that stop anyone else.
The beginnings of a Financial Graphics Function repository perhaps?
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.
from this early, poorly factored function repository.
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.
A real GnuCOBOL mathgl-script UDF will need to factor out
- graphic pane size
- title
- array dimensions for x, y, z
- etc...
Here is a later cut
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.
with an almost factored (but still requires more decoupling)
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.
producing three subplots, and a table. The script could well be in a secure
text file. dat used in the script text to reference the COBOL dataset.
5.53 Does GnuCOBOL support the GIMP ToolKit, GTK+?¶
Yes. A binding for GTK+ is in the works. Early samples have proven workable and screenshots of GnuCOBOL GUI screens are shown here.
Simple buttons
Text entry widget
Sample GnuCOBOL that generated the above
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.
Using this very early thin wrapper to GTK+
/* 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;
}
/**/
A screenshot with added menu and file dialog after hitting File -> Open
5.53.1 The functional GTK+ project¶
With GnuCOBOL support of FUNCTION-ID and improvements in the C interface
model, the entire GTK binding is now slated for development using very few
lines of C (less than 12 lines so far, required for wrapping event callback
handlers that have void return signatures).
The following (along with the soon to be published supporting function library)
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.
compiles to executable to display a prototype window of
Goodbye, process, A GnuCOBOL, user FUNCTION, GTK+ example.
Floating a window that will send a SIGTERM to the given process id on text
entry or button click. (Both, cobweb-entry-activated and
cobweb-button-clicked are callback handlers written in COBOL).
The plan is to build an easy to use GUI toolbox for COBOL programmers.
Using the function model, a Hello button program could be a single expression
move gtk-go(new-button(new-box(new-window(), 0),
z"Hello", "cobweb-button-clicked"))
to return-code
requiring no working store definitions, but that is stretching things a little bit too much.
5.53.2 A web browsing widget embedded in GnuCOBOL?¶
Yep.
A short sample, made for GnuCOBOL 1.0’s first birthday, Dec 27th, 2008.
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;
}
/**/
displays
when called with this COBOL.
*> ***************************************************************
*> 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.
5.54 What is OCSort?¶
Proof of concept release as of February 2010
A powerful external sort utility, for use with sequential (fixed length record) files.
A preliminary version can be referenced from http://oldsite.add1tocobol.com/tiki-download_file.php?fileId=74
but the sources are now included in the GnuCOBOL Contributions tree
http://sourceforge.net/p/open-cobol/contrib/HEAD/tree/
OCSort supports a variety of sorting options, for example:
ocsort sort fields"(1,5,CH,A,11,4,CH,A)"
use inputfile record f,391 org sq give outputfile org sq
Users of MFSORT may recognize the syntax. Explaining the above example, Angus posted:
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...)
A run sample:
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 ./ocsort 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
Only sorting 100 records, less than blink time. Here’s one million records:
...
118000000 bytes (118 MB) copied, 3.44348 s, 34.3 MB/s
prompt$ rm samp1.sor
prompt$ time ./ocsort 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
Respectable numbers. (on a machine that reports 6800.08 bogomips). The sort was verified with a little COBOL.
The secondary key (11,4,CH,A), gets very litte exercise with this /dev/urandom example. Not many random values spew out with duplicate primary keys (1,5,CH,A). Some, but not many per million; maybe 500ish tests with (by odds, some) 1000 duplicated keys per million urandom records generated. Odds of a triplet key are quite a bit lower.
Treat the code above as a rudimentary performance test, not so much a secondary key accuracy stress test, but, OCSort has passed all tests here, however limited.
OCSort*> ***************************************************************
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.
trunk/tools/ocsort/parser.y manages the OCSort command language.
Support includes:
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"
though most of the those keywords have limited sub options compared to MFSORT or DFSORT.
This utility needs more documentation. It is a 0.0.1 release, so, please try it out, before committing to production.
This blurb came in from Bill Woodger on a SourceForge Discussion page.
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).
Please keep in mind, OCSort is a 0.0.1 release, it won’t be as powerful or reliable as the software described in the books Bill mentioned.
5.55 When is Easter?¶
A short program to display the day of Easter for a given year. I found out later that this calculation is known as the Computus.
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
*> ]
*> ]
Sample, with and without command line argument.
$ cobc -x easter.cob
$ ./easter 2011
yyyy/mm/dd: 2011/04/24
$ ./easter
Year: 2010
yyyy/mm/dd: 2010/04/04
5.55.1 Easter program critique¶
What follows is a warning to those people learning COBOL with the help of this document. The variable names used to implement the algorithm to find Easter day are near to useless as to intent and or reason. It’s not good COBOL style and I got called on it. Take the critique for what you will, I took it as ‘hey, come on, port better code if you’re going to show it off’. Keep in mind that if you are ever fortunate enough to work with core business COBOL, what I got as a critique, could well be an embarrassing drumming from a boss and threats of firings. And as a side-note, be willing to take drummings and learn from them before the threats of firings occur. Programmers should never be defensive over code, but open and willing to better. In this case, the original REBOL is a port from another language based on the anonymous gregorian algorithm submitted to Nature in 1876.
I posted a link to the easter.cob source code above, as a Christmas post on a LinkedIn COBOL group, and got this feedback from Huib Klink; I respect his posts and opinions.
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
So, I looked into it, and learned something I find very cool. The calculation has a name and its name is The Computus. That’s awesome. Sadly, the Anonymous Gregorian algorithm detailed on Wikipedia uses the same useless variable names and the sample remains obfuscated, as I think the original sent into a newspaper in 1876 was intended. See https://en.wikipedia.org/wiki/Computus
5.55.2 A real COBOL Computus¶
From Paul Chandler during a discussion on LinkedIn in COBOL Profressionals.
This one is nice folks. Defensible.
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 THE MONTH. 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
Tectonics are a simple cobc -x rceaster.cob. ACCEPTs the year.
$ ./rceaster
2013
EASTER DATE FOR: 2013
MARCH 31
Thanks Paul.
5.55.3 Another Computus¶
Thanks to daniel b, who listed a solution and the ensuing discussion on LinkedIn:
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.
Here is another COBOL solution to the Computus.
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.
*
Tectonics once again, a simple cobc -x dbeaster.cob.
$ ./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
Thanks to Daniel. Note, I already had easter.cob, so this one is dbeaster.cob for the FAQ.
5.56 Does Vim support GnuCOBOL?¶
Very well. See cobol.vim for a syntax highlighter tuned for GnuCOBOL.
Vim’s Visual Block mode can be very handy at reforming COBOL source code.
Author’s choice. gcfaq.rst is edited using Vim, Bram Moolenaar’s vi enhancement. See below for some settings that can make GnuCOBOL more productive.
5.56.1 vim code completion¶
For code completion (Ctrl-P while in insert mode) start by creating a reserved word list using your cobc command
$ cobc --list-reserved | tail -n+3 | cut -f1 >~/.vim/ocreserved.lis
followed by this change in ~/.vimrc
:set ignorecase
:set infercase
:set complete=k~/.vim/ocreserved.lis
5.56.2 freedom¶
To free the cursor (allowing the cursor to travel past line endings) use:
:set virtualedit=all
5.56.3 autoload a skeleton¶
For a quick template when starting a new file (in .vimrc, change the filename ~/lang/cobol/headfix.cob to where you keep your favourite COBOL starter skeleton).
" Auto load COBOL template
autocmd BufNewFile *.cob 0r ~/lang/cobol/headfix.cob
5.56.4 elvis¶
elvis is an early fork of vi, and heavily influenced the development of vim.
Vim has surpassed elvis, perhaps, but elvis includes features that can come in very handy for certain editing tasks. elvis includes different display modes, including html, tex, syntax, and even a hex edit mode.
See Elvis support for GnuCOBOL for a sytax highlighter for elvis.
Useful when hunting down misaligned UTF-8, and other hidden byte issues in text files, especially after a platform transfer. Anyone familiar with Vim, should have a copy of elvis installed, for those special times.
5.57 What is w3m?¶
w3m is a text based web browser. GnuCOBOL can leverage some of the power of this application by directly calling it with SYSTEM.
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.
Sample run on 28-Feb-2010:
$ ./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
5.58 What is COB_LIBRARY_PATH?¶
If the DSO files are not in the current working directory along with the executable, the COB_LIBRARY_PATH can be set to find them.
On GNU/Linux and bash it could be
export COB_LIBRARY_PATH=/home/developer/ocnewstuff:/home/developer/ocstuff
to search for DSO files in directories ocnewstuff then ocstuff, giving your testing versions priority during development.
5.59 Can GnuCOBOL interface with Rexx?¶
Yes, both Regina Rexx and Open Object Rexx can be embedded directly in GnuCOBOL and be extended with GnuCOBOL modules.
5.59.1 Open Object Rexx¶
Courtesy of IBM, RexxLA, and currently a SourceForge project at
http://sourceforge.net/projects/oorexx/
A demonstration of embedding Open Object Rexx in GnuCOBOL.
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 :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 :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
The inline documentation block for gnucobol-rexx uses ReStructuredText and can
be built with rst2html, or Sphinx, by extracting everything after an
!rst-marker! line.
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:
with
/* 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;
The instore (Rexx script passes from internal working-storage, and not as an
external filename) sample, is straight from IBM and RexxLA shipped with
ooRexx 4.1 and calls an external sample script, example.rex. Listed here
to also satisfy the CPL 1.0 license requirements.
/*----------------------------------------------------------------------------*/
/* */
/* 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.'
A flying carpet run of:
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:
And a little shell pass. gnucobol-rexx.cob includes a small Read Evaulate Print Loop for testing Rexx instructions. This listing shows commands that test the internal and external function and command registration, allowing ooRexx access to GnuCOBOL subprograms.
The sample includes addessing an unknown host environment, extcobol instead
of the actual extcob that was registered by gnucobol-rexx.
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$
With gnucobol-rexx, GnuCOBOL developers need only
move rexx(1, "script.rex", "gnucobol", "args from $HOME", ws-rexx)
to rexx-status
or
move rexx(0, "parse version v; return v", "envofchoice",
"args from $HOME and abroad", ws-rexx)
to rexx-status
to leverage the powers of Open Object Rexx scripting.
5.59.2 Regina Rexx¶
Courtesy of Mike Cowlishaw, original designer of Rexx, and currently a SourceForge project at
http://sourceforge.net/projects/regina-rexx/
A Regina Rexx layer can be as simple as
ocrexx.c
/* 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;
}
/**/
with a usage example of
rexxcaller.cob
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.
*><*
And as a sample Rexx script
verrexx.cmd
Parse Version ver;
Say ver;
return ver;
With a sample run producing:
$ ./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
|
and the ocdoc output at rexxcaller.html
5.60 Does GnuCOBOL support table SEARCH and SORT?¶
Yep.
This is a two part example. A small tax table search, and a dictionary sort and lookup.
5.60.1 Linear SEARCH¶
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.
A sample run producing:
$ 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
5.60.2 SORT and binary SEARCH ALL¶
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 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.
with some sample words and a Debian 5.0.4 system:
$ 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
See SORT for other examples.
5.61 Can GnuCOBOL handle named pipes?¶
Yes. Here is a sample, using a tongue-in-cheek corncob filename, and a more practical function repository to follow.
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 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.
With a sample run producing:
$ 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
5.61.1 popen¶
There is a cobweb-pipes function repository, stored in contrib/trunk/tool/cobweb/ in the GnuCOBOL project Contributions SVN repository. Command pipes can make for some very handy, quick and mini, COBOL application development. The piggy bank example below, uses literals, a more realistic usage would be summary records from in house data tables.
Note: this version of the source listing uses a string referencing method that may be superseded by BASED OCCURS DEPENDING ON tables.
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.
*>****
Function repositories allow for very concise application development and nice, short, procedure divisions.
*> 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
giving a quick pop up X display. If graph knows the X and Y ranges on invocation, it will plot data live, as it is piped to the graph command. Custom ticker applications in, 40 lines of source?
Plotting data; in three MOVE statements.
Decrypting the graph command line, a little:
-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
The data pairs are month number, x, and penny count, y.
The graph command is invoked, with a “w” write pipe, so the child process takes
standard input from the GnuCOBOL parent program, and writes its output to
standard out. The standard output of graph is irrelevant in this case, the
objective is the pop-up X11 plot window, but it is a pipe, the output can be
ignored, or passed on to further commands in a tool chain.
Note that the plot clearly shows that someone had to borrow $5 from their big sister to get through December.
5.62 Can GnuCOBOL interface with ROOT/CINT?¶
Yes. The Feburary 2009 pre-release generates C code that can be loaded by the ROOT/CINT framework. ROOT is a high energy physics data analysis framework released by CERN. ROOT/CINT embeds the CINT C/C++ interactive interpreter.
See https://root.cern.ch/drupal/content/cint for details.
GnuCOBOL programmers can use ROOT/CINT for interactive testing of COBOL subprograms.
Given
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.
and the command line
$ cobc -fimplicit-init -C cobparams.cob
gives a set of C source code output for cobparams.
ROOT/CINT can then be used to play with the program.
$ 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]
There is some magic in the above snippet. ROOT preloads the runtime libcob.so. Then its .L command is used with the plus + option to interpret and link load the cobc generated cobparams.c file.
The ROOT/CINT console now has access to the cobparams “function”, defined by GnuCOBOL to have an unsigned char pointer as its BY REFERENCE access; A cast of the integer d’s address allows CINT to call up the COBOL subprogram, passing the 42 for DISPLAY and then returning the same value as the result. The interactively defined integer a, gets this 42 from GnuCOBOL’s RETURN-CODE.
5.62.1 Graphing sample¶
ROOT/CINT is built for analysis. So, plotting and graphing are built-in.
Given
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.
And then a console session of:
$ 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");
produces the following graphs; some constrained random numbers, and a circular view of those random numbers. Nerd heaven.
5.63 Can GnuCOBOL be used to serve HTTP?¶
Not directly, COBOL preceding the World Wide Web by some 35 years, but yes.
5.63.1 GNU libmicrohttpd¶
There is a GNU project, a C library, designed to allow for an embedded HTTP server in applications. Works well with GnuCOBOL.
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;
*> }
And a side by side terminal session capture; emacs is pretty handy.
$ 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; Connect
|ion refused
|$
5.63.2 libsoup HTTP server¶
Vala and libsoup is another way to embed a server.
Given soupserver.vala
// 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;
}
and ocsoup.cob
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.
and a little bash
$ 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
The next steps are getting the add_handler callbacks into COBOL, and then play with the template and replace model.
5.64 Is there a good SCM tool for GnuCOBOL?¶
In this author’s opinion, yes. Fossil.
Where SCM is Software Configuration Management, and not simply Source Code Management, which Fossil does quite well.
See the Fossil site, snag a tar ball, make, and move the binary to /usr/bin.
Then, to start up your next GnuCOBOL COBOL project:
# 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
Ahh, morale boosting bugs. :)
5.64.1 cobweb-words¶
There is a long term goal to provide a COBOL reference system using Fossil and its many features. An initial, nearly empty, prototype is hosted on SourceForge at
http://open-cobol.sourceforge.net/cgi-bin/gnucobol
The idea is to provide online (and local) access to COBOL help features. Statement explanations, notes, idioms, starter COBOL source templates, and anything else that can make life easier for COBOL developers, young and old. The system will allow any and all interested parties to update these documents to ensure the help is the best COBOL help that the internet can provide. These help files will be accessibe from the command line, the browser, and eventually from graphical applications.
Fossil natively supports its own internal wiki formatting, and Markdown. The
embedded documentation feature of Fossil can deliver over 200 known internet
MIME types, so cobweb-words will have access to full multimedia files as
the help system is built up over time.
TH1
Fossil has a Tcl-like language interpreter built into it, originally for controlling and customizing the Ticket sub-system, and then for header and footer webpage output. Now it allows for “programmable” documentation pages. TH1 can (and will) be used to provide dynamic documentation.
See http://www.hwaci.com/cgi-bin/fossil/doc/tip/www/th1.md for some technical details.
5.65 Does GnuCOBOL interface with FORTRAN?¶
Yes. Quite well in the GNU land. gfortran produces C ABI object code that
plays very well with cobc and CALL.
For example; snuggled away at http://fortranwiki.org/fortran/show/jucolor is a color unit converter; RGB to HLS, HSV to RGB, etc...
And with a simple Makefile ala
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 .
and some COBOL
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.
which produces
[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 ================================================================================
The weird numbers on the second “inside jucolor_” are uninitialized gfortran variables, displayed before being set, not great, but safe enough for a one off.
5.67 Does GnuCOBOL interface with J?¶
Yes, kinda, but not really, yet. Jsoftware posted GPL 3 licensed source code for the J programming language in 2011. J was designed by the creator of APL, the late Kenneth Iverson, along with Roger Hui. The torch now carried by his son, Eric Iverson, of Jsoftware.
J is a synthesis of APL, using only ASCII characters combined with dots and colons to represent the special symbols used in APL. APL, A Programming Language, developed in the 1960’s, is very terse, using a graphical symbol set, requiring special keyboards, that allowed for mathematical notion in source code. J “simplifies” the symbol set to ASCII characters, paired with . and : to form inflections (or digraphs).
Initial tests have proven somewhat successful, but there is more work required before integration with libj in GnuCOBOL is ready for prime-time. In particular, I/O is not functional with the listing given below.
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.
produces:
$ cobc -x callj.cob -lj
$ ./callj
0x00007f3b6ead7010
+0000000000
+0000000000
+0000000003
+0000000021
+0000000000
+0000000000
So libj inits, and can JDo J sentences, but there is a little more background effort to properly set J I/O and PATH settings into an array of callbacks. Doable, just have to ask the good folk at Jsoftware for a little assistance. More coming soon.
The GPL 3 J version 7.01b source code can be found at http://www.jsoftware.com/ Compiling the sources took a little reading, but built clean on 64bit Fedora 14 after a quick edit of jgplsrc/bin/jconfig. Needed to set BITS to 64 and added readline support, as command line recall is more fun than no command line recall when running jconsole. After that bin/build_libj bin/build_jconsole all went smooth as silk. libj.so was copied to /usr/lib64 and the above code compiled and linked just fine.
As did:
$ 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
with a full test suite pass, all successful. Once the callbacks are properly installed in the sample GnuCOBOL above, I’m sure the error 3 will be resolved for 1:!2 write to file as well as running the test suite from within JDo, which currently reports error 21. The above GnuCOBOL listing is the poor man’s 10 minute guide to integrating J.
5.68 What is COBOLUnit?¶
A well documented, full featured Unit testing framework for COBOL, written in GnuCOBOL with a GPL license.
http://sites.google.com/site/cobolunit/
- Tutorials
- Installation instructions, with videos
- Open sources
Test suite configuration files look like:
<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>
and with the scaffolding in place, a success report looking like:
***************************************************************************
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)
5.69 Can GnuCOBOL interface with Gambas?¶
Yes. See http://code.google.com/p/gambascobolgui/downloads/list for a working sample.
As a taster, the Gambas (http://gambas.sourceforge.net/en/main.html) sample calls GnuCOBOL coded as
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.
which this author found to be a pretty neat way of packaging GnuCOBOL other language callables.
The Gambas is nicely clean. Below being a snippet from the sample.
Extern cob_init(argc As Integer, argv As Integer) As Integer In "libcob"
Extern startGrid() As Integer In "SCONTO:69"
5.70 Does GnuCOBOL work with LLVM?¶
Yes. Almost first try for the February 2009 pre-release of 1.1. The compiler sources has a conditional use of a -fno-gcse switch that tripped warnings in clang causing some unit test failure reports. One change to compile out the -fno-gcse in cobc/cobc.c, and a simple:
$ 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
And GnuCOBOL is good to go with clang and the LLVM universe. The above compiles GnuCOBOL with clang, and the installed cobc will use clang as the compiler after processing the COBOL sources. This is grand news in terms of anyone worried about GnuCOBOL viability into the future. The existent C ABI space and now the growing LLVM software pool. Nice.
5.71 Does GnuCOBOL interface with Python?¶
Yes. Embedding Python can be accomplished using purely COBOL sources. Extending Python, to allow calling COBOL modules, will usually require a small amount of glue code written in C.
Very high level Python embedding is pretty straight forward, been there, done that.
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.
Giving:
$ cobc -x cobpy.cob -lpython2.6
$ ./cobpy
('Today is', 'Sat Jan 26 20:01:41 2013')
Python dutifully displayed the tuple. But what fun is Python if it is just for high level script side effects? Lots, but still.
Pure embedding.
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.
with pythonfile.py
#
# 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()
Giving:
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
Oh, in case you’re reading along, 1764 is the ultimate answer, squared.
The GnuCOBOL source line of
set environment "PYTHONPATH" to "."
before Py_Initialize, saves an oops when you need to find current
working directory Python scripts.
Although there was a sample written to demonstrate extending Python with
GnuCOBOL sub-programs, a better alternative is using SWIG. See Does
GnuCOBOL work with SWIG? for an example of integrating COBOL modules with
Python scripts. SWIG makes extending Python a very easy thing to do.
5.72 Can GnuCOBOL interface with Forth?¶
Yes, ficl, Forth Inspired Command Language embeds nicely.
Ok, I said, easy, I meant almost easy, as I had to hunt down a sysdep.h file and could not get 4.10 to go, but 4.0.31 works the beauty, once the sysdep.h was put in place.
First, the license compliance.
/*******************************************************
** 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.
*/
And then the COBOL, callficl.cob
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.
and the test file ooptest.fr
\ 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
and finally, the run. The first two commands building up ficl and the libficl shared library, the next two for COBOL:
$ 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
Turns out that return codes -56 and -257 are ok codes, (from ficl.h)
/* 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 */
GnuCOBOL does Forth.
p.s. One small note. The ficl load word, load ooptest.fr needed a newline after the filename. Normally Forth uses a straight up space delimited word parser, but ficl accounts for filenames with spaces in them. Nice feature.
5.73 Can GnuCOBOL interface with Shakespeare?¶
Yes. The reference implementation of the Shakespeare Programming Language builds into GnuCOBOL applications that can CALL SPL modules.
Technicals: I downloaded Marlowe which fixes the reference implementation problem with Roman Numerals.
https://bitbucket.org/kcartmell/marlowe/downloads
Then inside a working dir (/lang/cobol/cobill/ for instance) create spl, untar, and make SPL. I assume the spl/ sub directory in the Makefile listed below.
What is happening here isn’t runtime link loading, it is simply building the SPL engine into COBOL, and then CALL the result of spl2c.
This first cut lacks art. Lacks. Sad, so verily verily sad.
cobill.cob
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.
Then some cowardly SPL, ocshake.spl
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]
A Makefile of:
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
Then a run of:
$ 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
$
derp, in a 20K binary, from 2K of source.
I am kinda proud of Scene II, it reads well. The rest of this Shakespeare program needs some Fahrenheit 451.
5.74 Can GnuCOBOL interface with Ruby?¶
Yes. Ruby 1.8 links without issue.
This example is only calling Ruby for side effect, without data exchange.
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.
and script.rb
puts 'Hello, script'
puts 6*7
puts 'Goodbye, script'
and a run test of:
$ 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
5.74.1 mruby¶
Turns out the code listing above broke with Ruby 1.9.
And it also turns out that embedding Ruby got a lot easier, with Mini Ruby.
A project by Yukihiro Matsumoto, mruby is the new “by design” way of embedding Ruby. mruby 1.2 supports Ruby 2.1 core.
The default make creates a statically linked library, libmruby.a. So,
CALL static comes into play. This can lead to some warnings during the C
compile phase of the GnuCOBOL toolchain, as there is no way (currently) for
the COBOL sources to know about the mruby.h header files. These warnings
can be suppressed, by cobc once initial issues have been verified as ok.
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
With a sample run of:
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.
Anyone serious about mixing Ruby with GnuCOBOL programming should take a look
at mruby. http://www.mruby.org/
5.75 Can GnuCOBOL interface with Pure?¶
Yes. Yes it can.
Pure is a term rewriting functional programming language by Albert Graef. Influenced by Haskell, the system generates C code as part of the just in time compiler. The successor of Q.
Given a Fedora with LLVM installed, and a:
$ sudo yum install pure pure-devel pure-gen pure-doc
Below is a little test program, to see if pure can call GnuCOBOL
hellooc.pure
#!/usr/bin/pure -x
using system;
puts "Hello, world";
using "lib:hellocobol";
extern int hellocobol();
hellocobol;
And a little snippet of COBOL introduction
hellocobol.cob
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.
With a first try of:
$ cobc hellocobol.cob
$ pure -L. hellooc.pure
Hello, world
Segmentation fault
Oops. Kept the error above in, to show the fix. The object code needs to initialize GnuCOBOL:
$ cobc -fimplicit-init hellocobol.cob
$ pure -L. hellooc.pure
Hello, world
S'up?
Yayy, success one. Pure can call GnuCOBOL.
And then to leverage Pure power from GnuCOBOL, as things should be, power balance wise.
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 should be 362880" end-display
display "fact 9 result is " fact-answer end-display
goback.
end program callpurefact.
*><*
Below is the tutorial hello program for Pure. pure is used to compile this,
and in this example, is passed an initial argument of 8 for the ubiquitous
factorial functional hello.
GnuCOBOL will call this main, mapping out 8 factorial results, then will call
the defined fact function with an argument of 9.
hello.pure
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;
And then:
$ 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 should be 362880
fact 9 result is +0000362880
So, yayy, success. GnuCOBOL can handle Pure integration. Pure looks
pretty sweet.
5.76 Can GnuCOBOL process null terminated strings?¶
Yes. With care.
One aspect of interfacing with C, is the indeterminant length of data blocks. C strings assume a zero null byte terminator. No need to know length before hand. This does not align with the fixed length requirements of COBOL.
There are various ways to handle this situation, old, and new.
A new way, for display, with BASED allocation, and a sliding pointer.
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
Most of that dance is to allow GnuCOBOL to decide how to flush the output buffer, as there is no current support for
display OMITTED end-display
and there should/will be, just like ACCEPT which will wait and discard input. display omitted would be a buffer flush end of line without the space.
Zero length items are another issue.
There is also
- z”Z quoted string literal”
- “string literal with append of null” & x”00”
- “string literal with append of null in most character sets” & low-value
And some STRING code when you need COBOL working-storage
set address of c-char-buffer to c-char-star
string c-char-buffer delimited by x"00"
into cobol-space
end-string
5.77 Can GnuCOBOL display the process environment space?¶
Yes, almost. One small snippet of C code is required to get at a
global variable, char **environ.
/**
* Access a C external variable for the environment space
*/
#include <unistd.h>
extern char **environ;
char **value_of_environ() {
return environ;
}
and then COBOL that processes the array of character string pointers.
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.
and a run sample of:
$ 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
5.78 Can GnuCOBOL generate callable programs with void returns?¶
Yes. GnuCOBOL builds after March 2016 can generate code for subprograms with no return value. For GnuCOBOL 1.1 and early 2.0 releases, the answer is no.
PROCEDURE DIVISION RETURNING OMITTED
GnuCOBOL can CALL void functions, and can generate functions with a void return signature. This is normally not an issue, but becomes a problem when using GnuCOBOL with certain frameworks, that require particular signatures for call backs.
For builds of GnuCOBOL previous to March 2016, a small piece of C code may help.
For instance, many GTK+ features support a call back handler for reacting to
events. Unfortunately, most of these functions are expected to return void.
Fortunately, GTK+ also supports userdata pointers with most of the call
back signatures. This userdata field can be used to allow for GnuCOBOL
source code that manages GUI event call backs.
5.78.1 voidcall_gtk.c¶
/****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;
}
/*
****
*/
This can then be used to wrap a call back, allowing GnuCOBOL to take part in GTK+ event handling, without a specific C wrapper written for each case.
With PROCEDURE DIVISION RETURNING OMITTED, this becomes unneccessary.
5.78.2 A GTK+ calendar¶
The above code was used as a generic wrapper for practising with GTK+ calendar features.
*> 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
.
and the handler entry point.
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.
which will come in handy as GTK features are extended, especially with the new Broadway backend to the GDK part of GTK+, which allows desktop GTK applications to be seamlessly integrated with a browser.
5.79 Can GnuCOBOL interface with Jim TCL?¶
Yes. One unsafe cheat in the prototype, assumes result is first element of the Jim Interp structure.
gnucobol-jim.cob
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.
with hello.tcl
return "S'up?"
and from the Jim TCL jimtcl-master/example directory, timedread.tcl (modified to return the count of bytes read in 0.5 seconds, which Jim does, as a string).
# 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
and a run sample of:
[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
Umm, reading a whole bunch of stuff off /dev/urandom is not the smartest of moves if the motherboard is also (or is about to be) executing code that requires system entropy.
Depletion of the system entropy pool can cause encryption systems to halt, waiting for enough mouse movement, or program runs, or other externally random events, that code breakers can’t predict or easily replicate.
So, fair warning, don’t run the above on systems that can’t risk depletion of the entropy pool. (If you ever do get stuck, wiggling the mouse can actually help, along with keyclicks, network activity and other signs of unpredictable seed values).
Not bad though, some 10 million bytes of encryption quality random numbers a second.
5.80 Can GnuCOBOL interface with RLIB?¶
Yes. RLIB version 1.3.7 hosted on SourceForge at http://sourceforge.net/projects/rlib/ (from 2006) builds from source, just fine on a recent Fedora 19 (2014) system.
Nice support for PDF and HTML report generation. XML control files, along with (among others) XML input sources.
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.
supporting files of data.xml as the aggregate data source, and graph.xml, a report definition file
<?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>
The fields, max and min are used in the report graphic, with the RLIB
team member first names being the x axis labels.
<?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>
with a run sample of
$ 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
producing a PDF containing a graph ala
Actually, the image was generated during an HTML output pass, the PDF is more PDFey
A made up and misleading graph by the way. Two scales, left and right Y-Axis, red and blue lines are not on the same scale. For instance; Eric has both a Min and Max of 5, but the Min line, right hand axis (in red, Small dollar day) is scaled from 1 to 6, differently than the range of the blue, Big dollar day line) That can easily be fixed, but is shown for that Wall Streeet flair of illusion and perception, wrapped in legally defensible numbers. a lorem ipsum graph.
5.81 Can GnuCOBOL interface with Perl?¶
Yes. With some caveats. The API for Perl 5 is heavily layered in macros. It is worth writing some wrapper code, for safety (and sanity).
A getting to grips sample, so, it might be wrong headed
/** 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));
}
and
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.
Gives:
$ 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
COBOL programmers will likely need to take notice of the rounding difference in the floating point data for 3.14 to the power of 20, just because.
5.82 Can GnuCOBOL interface with BASIC?¶
Yes, and no. At least two forms of BASIC have been proven, but there are other BASIC dialects and environments that won’t be suited for integration with GnuCOBOL. If a BASIC implementation plays well with the C ABI and/or link libraries, it will very likely play well with GnuCOBOL.
5.82.1 Gambas¶
Linking to Gambas is documented at Can GnuCOBOL interface with Gambas?
5.82.2 BaCon¶
The BASIC Converter. A shell script (yeah, shell) that converts BASIC to C, then compiles the C. A transcompiler, similar in nature to GnuCOBOL itself.
The author, Peter van Eerten has refined a reference implementation of
bacon.bac. The script runs in Bash, Ksh, PDKSH, MKSH, Zshell. This is only a
stepping stone now that the bacon.bac is compiled. BaCon installs both
bacon and bacon.sh.
During ./configure ; make, the bacon.sh shell program translates bacon.bac
to C and compiles the generated source. Providing a binary executable for
BaCon, written in BaCon that is tranlated by BaCon. Nicely done. Not a toy.
http://www.basic-converter.org/
Initial tests went very smoothly.
tar xvf bacon-3.0.1.tar.gz
cd bacon-3.0.1
./configure
make
sudo make install
With some BASIC
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
and then a library build, (and install, to help with later linkage)
$ 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
and some COBOL
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.
and putting it all together, calling BASIC library functions from GnuCOBOL:
$ cobc -x -g -debug callbacon.cob -ldemo
$ ./callbacon
Mortals are:
socrates
sappho
august
+0000000040 +000000040
Painless. BASIC from COBOL. BaCon seems like an easy to use programming system, with some surprising powers.
Here is a SQLite linkage sample, by Peter van Eerten. sqlite3.bac is some 100 lines of BaCon and the 20 odd lines to demo it.
'
' 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$
with a trial run of
$ 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.
5.83 Can GnuCOBOL interface with Nim?¶
Yes. Directly, with some complexity in tectonics.
Nim, once called Nimrod, is a trans-compiler, transpiler, as is GnuCOBOL.
Leveraging C as a step in the compile chain. This C can be included in
cobc command lines, from source or link library. Nim emits the equivalent
of libcob run-time in a system.c file for each compile. Nice.
The Makefile below, shows the sample, nicenim and then the two different
ways Nim code can be integrated. Directly with generated C sources, or through
linkage (static in this case) to Nim object files and libraries.
callnim was an original trial. It called an exponentially recursive Nim
fibonacci calculation. An expensive use of electricity for a proof of concept.
Replaced with nicenim, and a simple, not overly productive, loop.
ultimate.nim
# 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
nicenim.cob
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.
makefile (needs tabs)
# 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'
$ make:
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'
$ ./nicenim:
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
Based on samples from http://nim-lang.org/backends.html which is subject to change, as Nim approaches a 1.0 reference implementation.
Nim also outputs Javascript, C++ and Objective-C. GnuCOBOL developers can leverage just about all of these targets. C and js, or C++ with GnuCOBOL-CPP, and perhaps the Objective-C for the adventurous.
As mentioned, the fib.nim fibonacci function
# 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)
5.84 What is COBJAPI?¶
László Erdős wrapped the japi C library in User Define Functions.
http://sourceforge.net/p/open-cobol/contrib/HEAD/tree/trunk/tools/cobjapi/
What is japi? A java application programming interface
A C library interface to the Java Advanced Window Toolkit. Yes, Java. This library is a bridge to the Java AWT from the C ABI. With COBJAPI now providing a bridge from COBOL to the Java Virtual Machine space. The author of japi is Dr. Merten Joost (University of Koblenz-Landau). http://www.japi.de
László wanted to highlight the choice selector example. A worthy demonstration of how easy it can be to develop graphical user interface programs with COBJAPI and GnuCOBOL.
*>******************************************************************************
*> 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.
This puts up a color selector that modifies the example window background with each choice.
COBJAPI is one of the nicer entries in the contrib/ tree. A beautiful example of how function COBOL is good COBOL, and how function repositories can shorten procedure division source code burdens, by nearly an order of magnitude.
Some screen captures (all the COBJAPI samples, come with pictures).
| choice.jpg | mandelbrot2.jpg | |
|---|---|---|
 |
 |
|
| A simple, yet powerful choice selector | Resizeable, Mandelbrot set computed in GnuCOBOL |
Well documented, ready to go, as a work in progress, with plenty of practical examples. Check out the source tree, on the forge using the link at the top of the entry. Well worth the look. At a glance:
as of April 2015, there are 55 examples; (meaning a lot of boiler plate code is readily available, for a leg up on application development).
This quick list showing lines of comments, and lines of code.
$ 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
117 lines of COBOL for the animated video display example. Function repositories allow for very concise COBOL application listings. This will only get better, as more and more function libraries become available.
5.85 Does GnuCOBOL support source code macros?¶
GnuCOBOL supports nearly the full gamut of the COBOL 2014 Standard Text Manipulation, and Compiler Directive Facilities, with COPY REPLACING, REPLACE and the >> directives. Macros are a little bit different.
As of May 2015, GnuCOBOL can also be used with an actual macro preprocessor, supporting a syntax developed for HP COBOL II/XL for e3000 systems.
A contribution by Robert W. Mills, cobolmac
http://sourceforge.net/p/open-cobol/contrib/HEAD/tree/trunk/tools/cobolmac/
The program acts as stdin stdout filter, and supports
- $DEFINE
- $INCLUDE
- $PREPROCESSOR
along with
- $IF
- $SET
- $PAGE
- $TITLE
- $CONTROL
- $VERSION
- $COPYRIGHT
which are HPe3000 specific, and are currently removed during cobolmac
processing.
Defined macros support up to 9 parameters passed to each expansion.
Usage:
cobolmac [options] <input >output [2>messages]
options include:
--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.
By convention, Robert uses .cob for input names, and .cbl for the post
processed files that are passed to cobc. This is just a convention, and
developers can use any naming they feel comfortable with.
For example, one the sample macro definitions that ships with cobolmac; a
macro to assist in moving data to formatted numerics.
*> *************************************************************************
*> %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#
and used in an application with
%MoveNumber(123#, output-field#, 1#, 4v0#)
with cobolmac program.cob, the one line of source expands to
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
Building up a Macro include file, can reduce development efforts, ensure consistency, and perhaps remove some of the routine typing faced by many COBOL developers.
Some downsides of macro programming is the need for the cobolmac utility in
the compiler tool chain, and sources, as read, are not always the sources
passed to the compiler.
Robert’s macro preprocessor plays well with the cobc -Xref cross reference
feature (by Vince Coen), so that developers can read over nicely formatted
source listings from the post processed source files. See What is CobXRef?.
cobolmac also supports a --maclib command line option to display the
macros available during the preprocessing pass.
Another great option is now available for GnuCOBOL development.
5.86 What is the largest known prime number?¶
Not sure, but as of 2013, a Mersenne prime with 17,425,170 digits was registered at https://primes.utm.edu/largest.html#biggest
And now, thanks to László Erdős, there is a COBOL program to help in the search for large primes.
http://sourceforge.net/p/open-cobol/contrib/HEAD/tree/trunk/samples/prothsearch
As always with László’s code, prothsearch is a well documented
contribution. A large prime number search algorithm, implemented in COBOL. A
cash prize for finding verified large primes is still quite substantial. Large
primes are powerful and valuable seeds for many, many algorithms.
In May of 2015, it’s $100,000 for a ten million digit prime, and a cool
quarter million for 1 billion digits of prime number. The prothsearch
documentation explains it more, along with ways to set up check point runs.
Idle machine time can be put toward finding a huge Proth prime, with the chance
of reward a few years in the future, while still being able to be turned on and
off, without losing the algorithm state.
5.87 Is there an assembler interface to GnuCOBOL?¶
Yes. Almost directly, through the C ABI and the wonders of gcc
integration with the cobc compiler. Assembler, assembly, used
interchangeably here.
First a short diversion
WARNINGS AND DIRE CONSEQUENCES
Don’t ever name C source code or assembler .s files the same as GnuCOBOL source
code files. This is basename, without extension. Don’t write a hello.c or
hello.s file along with hello.cob, cobc may overwrite your .c and
.s files, break your heart and lose you time. Don’t ever. It’s heart
breaking. Seriously.
It is easy to avoid name collision, so back to the assembly.
This is chello, a C hello. COBOL gets hello, C gets a different first name.
#include <stdio.h>
int chello() {
printf("%s\n", "Whassup, earth, whatya lookin for?");
return 41;
}
Then generating assembly, from chello.c with gcc -S chello.c
.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
And some GnuCOBOL. cobc makes this pretty easy integration.
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
The .s gas file passed on to gcc as part of cobc processing.
And here’s the hand patch assembler file. 41 is not the correct value, and
needs to be fixed. The original chello.c has this bug, on purpose, the return 41;.
Around line 20 of the assembler source:
call puts
movl $41, %eax
popq %rbp
changes to:
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
Now, just happier, less whiny code, albeit a contrived, to be simple patch
example. The .s file is simply passed on to gcc as part of the cobc
compile tool chain.
prompt$ cobc -x hello.cob chello.s
prompt$ ./hello
Hello, world
Whassup, earth, whatya lookin for?
42
The sample COBOL program no longer complains about being unfulfilled with its galactic role in the universe.
If you are writing hand crafted assembly, and get stuck on how it interfaces
with your particular operating system, running some C code through gcc -S
can be a great way of getting some technical hints on how things work together.
5.87.1 cpuid¶
Ok, and now some handrolled x86_64 assembler, using the AT&T syntax supported
by the GNU compiler toolchain, as and gdb, in particular.
We’ll also leverage the ability to list .s filenames when invoking cobc.
There is an opcode in the x64_64 instruction set that provides access to chip
and hardware information, CPUID, and there is an excellent article on
Wikipedia, that is the root source for most of what follows.
https://en.wikipedia.org/wiki/CPUID
There are a ton of features in CPUID, but we’ll focus on two aspects, Vendor ID and Brand.
First some top level COBOL.
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
And some assembler, two useful functions, and one, hopefully temporary, fixer.
# 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
And a fairly straight forward Makefile
.RECIPEPREFIX = >
cpuid: cpuid.cob
> cobc -xjg -debug -A '-Wa\,--defsym,DEBUG=1' \
cpuid.cob vendor.s brand.s fix-unsign.s
cobc just does the right thing when given .s filenames, and passes them
through the C compile toolchain.
Running make -B or ./cpuid once compiled, and you’ll see details of the
machine, and a couple of debug lines from the fix-unsign.s file.
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
The argument following the ``-A cobc`` option is passed to ``gcc``, which then passes the ``-Wa`` option that follows it through to ``as``, and the DEBUG conditional assembly directive is set true.
Handrolled assembly might just get you out of a sticky situation someday, and cobc will be ready to assist. Thanks to the editors on Wikipedia for the code listings for CPUID. Gotta love CUPID, errm, CPUID.
There may not be many times that a GnuCOBOL programmer needs assembly, but it is pretty hard to get at opcodes like CPUID without it.
5.87.2 GNU lightning¶
Not only is cobc a very capable assembler front end, but with GNU lightning
https://www.gnu.org/software/lightning/manual/
GnuCOBOL can be used to dynamically generate assembled functions, at runtime.
Below is a port of the rpn calculator sample that is part of the GNU lightning documentation by Paulo Andrade.
This sample also puts Robert’s COBOLMAC to use.
See Does GnuCOBOL support source code macros? for more details on COBOLMAC.
As this is fairly heady build up, let’s start with the installs:
prompt$ sudo apt-get install libiberty-dev
Was the only pre-req that I required here, on a semi-loaded development Xubuntu box.
Then:
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
The default configuration prefix is /usr/local so things will get
installed in the same place as GnuCOBOL development versions, which is
awesome.
So, now we have /usr/local/lib/liblightning.so and
/usr/local/include/lightning.h. Good to go.
First up is a simple incrementor. A call frame is setup to pass an integer argument, and then return the value incremented by one.
This is the C code example, from the GNU Lightning docs.
#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;
}
Not too too bad, so let’s try that:
prompt$ gcc -o incr incr.c -llightning
prompt$ ./incr
5 + 1 = 6
prompt$
Yayy, 5 plus 1. But, let’s take a little closer look at what’s going on. GNU
Lightning has two features, jit_print and jit_disassemble for us to
try out, to get used to Lightning.
#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;
}
With a second build of:
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
Ok, so it took the function calls, and built up the Lightning instruction set. Cool, but this is a x86_64 processor, so now for the gravy.
#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;
}
And:
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
Yeah, now we’re talking. The Lightning instruction set mapped to the hardware
in play. movr %rax %rdi became the Intel instruction mov %rdi,%rax
and addi %rax %rax 0x1 mapped to add $0x01,%rax. Seems sane enough,
although I do like the Lightning form of source, dest more than the AT&T style
output of dest, source; but that is just syntax. And from the printf
statement incr(5) is displaying a 6 so it looks reasonable, and it
didn’t catch on fire. Always a good thing with initial testing.
Now for a COBOL layer.
First we need to initialize the engine and get a JIT state handle.
*> 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.
And trying that:
prompt$ export COB_LDFLAGS='-Wl,--no-as-needed'
prompt$ cobc -xjdg inc.cob -llightning
0x00000000015b2d80
Yayy, we got a pointer, and not a null. Good sign.
By the way, on Ubuntu, that first line setting COB_LDFLAGS is required, otherwise the object code will not know to look for ``liblightning.so``. All further cobc compiles in this entry will assume that setting is in the environment.
Next, we lay down a prolog, for Lightning to start in on doing its thing.
*> 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.
And:
prompt$ cobc -jxdg inc.cob -llightning
inc.cob: 17: libcob: Cannot find module 'jit_prolog'
Boo, jit_prolog is likely a macro. So, now over to the header file.
Instead of grep, I usually use ag the Silver Searcher.
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*);
Yeah, as expected. It bodes not well for an easy translation to COBOL for the rest of this code. All that C is likely more macro than function call, hidden under a convenience layer. Ok, been there, have to do that.
*> 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
Well, no fires, another step forward. Now for some actually reading...
prompt$ vi /usr/local/include/lightning.h
...
700 hours later
...
No, it wasn’t that bad, a few minutes. All the macros follow the same
pattern, starting with an underscore and with an implied _jit handle.
We use the more COBOL friendly jit pointer, but it’ll have to carry
through explicitly to all of the function calls. A worse fate is the enums;
all the instructions, registers and fiddly bits are integers, and we’ll need
those numbers to continue. One way of doing that is 700 hours of reading,
counting fingers, and hand translating the constants. Or, write a program.
/*
* 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);
}
And:
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.
Ok, cool, we have data for the working storage section.
And, 700 hours later, we have some better source code.
*> 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.
Add, drum roll:
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
The ball is rolling. 5+1 is 6, 41+1 is 42. But, it’s fairly labour
intensive, time for some COBOL convenience macros, and a Makefile to make the
iterations go a little faster.
The first one to look at is the whole _jit_new_node_www and instruction
data thing. The next example is a Reverse Polish Notation expression solver,
so there will likely be a few more instructions to laydown. One line of code
per instruction seems smarter than seven per.
*> 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
#
Now, laying down the addi instruction is just
%jit-code3i(addi, R0, R0, 1)
and Robert’s cobolmac can do some of the heavy lifting.
Now, with most of the preliminaries out of the way, some proof that things actually work, it’s time to worry about a more methodical development plan.
There are lot of details, so (being small brained) it seems wise to codify some of those details, and then forget them.
A Makefile:
# 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
That will build a copybook for all the pesky enums from
/usr/local/include/lightning.h that we are going to need, then run the
cobolmac preprocessor, and then run a compile pass; with or without
debug lines, depending on how make is invoked.
From looking over the RPN calculator sample, the symbols we’ll need are
put into find-jit-enums.c and that will pump out a copybook.
/*
* 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);
}
and finally, a testhead COBOL program.
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
Plus the generated lightning-enums.cpy file
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.
and a quick build and run. The run, on an AMD 64bit machine, includes calls
to lightning jit_print and jit_disassemble, and the output is coloured with
GNU as syntax highlighting:
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
Some Celcuis/Fahenheit conversion tables, a hardcode expression and a final piece of RPN assembly, from an expression passed in on the command line.
All in just under 9 1000ths of a second.
GNU lightning supports quite a few native chip backends, covering aarch64, alpha, arm, hppa, ia64, mips, powerpc, s390, sparc and x86 architectures.
So, we might be able to pester someone on bigiron to take a chance with some JIT assembly.
5.88 Can GnuCOBOL interface with D?¶
Yes. D supports the C ABI with a little care, and GnuCOBOL can call D, and be
called from D. extern(C) informs the D compiler to generate code for C
stack frames, with C naming conventions.
Originally intended to be named Mars by Walter Bright, early adopters
nicknamed it D, as a step up from C++, and the nickname stuck.
dmd uses Phobos for run-time support, and you will almost always need to
initialize the library space when calling D functions. From C with
rt_init() or from inside D, with no main, using initialize().
calld.cob
*> ***************************************************************
*> 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.
*>****
hellod.d
// 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;
}
}
Giving:
prompt$ dmd -c hellod.d
prompt$ cobc -x -g -debug calld.cob hellod.o -lphobos2
prompt$ ./calld
+0000000042
Hello, D
prompt$
The augend was never set in calld.cob, defaulting to 0, with the ans
returned from dadd being 42, as expected.
Proper D programming would have literate documentation as well as in source
unittests. Both features, and more, are natively supported by D compilers.
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
Walter and Andrei Alexandrescu are building up a nice programming language.
Here is a more complete version, with a failed unit test.
/// 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);
}
}
Due to the desire to run unit tests, a D main must be available, but then it
will attempt a link pass and will need to know about the hellogc function
defined in calld.cob, listed below. cobc is used to generate an
object file for D to link to. And the dmd linker is passed a hint to
link in the libcob run-time support.
A purposely failed dadd(0) unit test run sample (0 + 42 is not 41)
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$
So, now, let’s put that right. Asserting that 0 + 42 is indeed 42.
/// 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);
}
}
With a successful run, given that 0 + 42 asserts to be equal to 42. The
unittest pass also includes an automaically generated main function, and
the automatic documentation generation, as a bonus, to highlight the powers of
the dmd compiler:
prompt$ dmd -D hellod.d -unittest -main calld.o -L'-lcob'
prompt$ ./hellod
prompt$
And a fancy two step calld.cob run.
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.
With GnuCOBOL calling D, which turns around and invokes the hellogc COBOL
sub-progam:
prompt$ dmd -c hellod.d
prompt$ cobc -x -g -debug calld.cob hellod.o -lphobos2
prompt$ ./calld
+0000000042
Hello, D
Hello, GnuCOBOL
prompt$
The auto generated documentation, from dmd -D is linked at http://opencobol.add1tocobol.com/sources/hellod.html
Turns out D is quite the thing. Worthy of any developers attention. Along with GnuCOBOL, and both languages natively supporting the C ABI, it won’t take much to make sufficiently advanced programming magic.
5.89 Can you run GnuCOBOL programs from Node.js?¶
Yes. Ionică Bizău has written a bridging layer, node-cobol hosted at https://github.com/IonicaBizau/node-cobol that allows embedded COBOL sources to take part in Node.js socket ready applications.
Works best with a version of GnuCOBOL cobc that accepts dash (-) as an
input filename, allowing the compiler to read from standard input. Revision
632 or greater of gnu-cobol-2.0. But will also work with older releases,
reading the source from a filename. The COBOL npm package is also required.
npm i cobol.
From Ionică’s gihub page,
index.js
// 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"
args.cbl
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.
Just in case you are reading this quickly. What this means is that GnuCOBOL can now take part in Node.js socket ready applications, embedded as source code in Node.js programs. In 2015, that is pretty much leading edge modern. COBOL, modern, web ready, free. And it plays well with others.
See the node-cobol GitHub repository linked above for more samples and
examples.
The code for node-cobol made it into an Ars Technica article shortly after
it was published. By Sean Gallagher.
http://arstechnica.com/information-technology/2015/08/
calling-1959-from-your-web-code-a-cobol-bridge-for-node-js/
And yes, the article was soon riddled with comments from people that don’t understand the strengths of COBOL programming, but oh well, that would be their problem.
5.90 What is cobol-unit-test?¶
cobol-unit-test is a well documented, paragraph level unit testing program suite, written by Dave Nicolette, hosted on GitHub at https://github.com/neopragma/cobol-unit-test
See the complete documentation set at https://github.com/neopragma/cobol-unit-test/wiki
The goal of the cobol-unit-test project is to enable isolated unit testing of individual paragraphs in COBOL programs, in a standalone environment with no connection to a zOS system.
Dave set this up to give z/OS programmers a chance to unit test individual COBOL paragraphs on personal computers while off the mainframe. The system uses a very well thought out DSL, Domain Specific Language, reminiscent of COBOL itself, along with a preprocessor that generates a new source COBOL program, compiles it under controlled conditions and evaluates tests defined by the cobol-unit-test DSL.
All written in GnuCOBOL, the ZUTZCPC preprocessor program and DSL includes
- AFTER-EACH
- BEFORE-EACH
- EXPECT
- IGNORE
- MOCK
- TESTCASE
- TESTSUITE
- VERIFY
keywords. The DSL is very COBOL in nature, and should feel very comfortable for GnuCOBOL and z/OS mainframe programmers alike.
For example, the VERIFY keyword includes clauses such as
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
5.90.1 cobol-unit-test examples¶
There are multiple samples that ship with cobol-unit-test. Each test
definition is set up in a controlled directory tree, with compile and
run-ut scripts that manage the build and test run.
The introductory sample includes a purposely failed test, from a simple program.
src/test/resources/SAMPLEC, the unit test run and compile resource list
ZUTZCWS
SAMPLET
src/test/cobol/SAMPLET, unit test definition (the DSL)
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!'
and src/main/cobol/SAMPLE.CBL, the actual COBOL being tested
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.
.
src/main/cobol/copy/ZUTZCWS.CPY is a working-storage copy book included in the generated test COBOL program.
A sample run of
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
=================================================
Other examples that ship with cobol-unit-test demonstrate more of the DSL feature set.
Such as src/test/cobol/unit-tests/CICSDEMT which shows how to test mock up CICS commands, when no CICS engine actually exists.
The initial MOCKUP line was added solely for the benefit of the FAQ indent based source highlighter and is not part of the actual test definition file.
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
The full example script test runner script demonstrates the other features, with a run sample of:
$ ./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
=================================================
5.90.2 cobol-unit-test credits¶
cobol-unit-test, isolated paragraph testing with GnuCOBOL. Includes instructions and scripts to support moving source files from z/OS to and from a GnuCOBOL workstation, for unit testing mainframe programs.
A worthy addition to any GnuCOBOL developer’s arsenal.
Thanks to Dave Nicolette.
cobol-unit-test is licensed under a Creative Commons Attribution-ShareAlike 4.0 International license.
5.91 Does GnuCOBOL work with SWIG?¶
Yes, due to the intermediate C generation. SWIG, the Simplified Wrapper and
Interface Generator, does not directly support COBOL, but it is designed to
allow other languages to call into C functions. This means other languages can
easily call into GnuCOBOL subprograms and ENTRY points. There are caveats, as
some COBOL names are not valid C names, so there are some name transformations
that cobc performs that may need to be accounted for.
SWIG is a very well documented tool set, and has direct support for calling into GnuCOBOL from
- Allegro CL
- C#
- CFFI
- CLISP
- Chicken
- D
- Go
- Guile
- Java
- Javascript
- Lua
- Modula-3
- Mzscheme
- OCAML
- Octave
- Perl
- PHP
- Python
- R
- Ruby
- Scilab
- Tcl
- UFFI
And this support will work for both the C and C++ versions of the GnuCOBOL intermediates.
Most, if not all, of the SWIG interface definitions are normal and will not require modification to work with GnuCOBOL, aside from name compatibility issues. The major difference from the documented C interfaces will be in the tectonics, minor changes to how the wrapper code is linked.
For example, a small GnuCOBOL program, polyglot.cob, and calling polyglot
from Java, Perl, Python and Tcl. A single SWIG interface file and some make
rules.
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
The plan is to use the generated C files to facilitate a wrapper for each of the target languages.
/* Polyglot programming with GnuCOBOL and SWIG */
/* Brian Tiffin, 20150924 */
%module polyglot
%{
int polyglot();
%}
int polyglot();
Normally, SWIG interface files can have the same name as the program, but
seeing as GnuCOBOL may generate .i files for the internal preprocessor, with
cobc -E, it is safer to avoid any possible name collision, and this sample
is called, polyglot-swig.i.
And then, a suite of make rules. In particular, libcob is included in the linkage phase when generating the wrapped shared resources.
# 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)"
With make targets for Java, Perl, Python, Tcl, and one to demonstrate SWIG contract programming suppport.
The Java target also requires a small bit of Java for a main entry point, in
this case main.java.
/* 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();
}
}
main.java is slightly more complicated than it needs to be, as this sample
includes runtime code to override the default java.library.path system
variable, to include the current working directory, ”.”, when searching for the
polyglot shared library. This search path could have been set externally,
but was done at runtime in this small example.
5.91.1 Using SWIG¶
Taking the Perl sample, the first step is using SWIG to generate source code
for perl5 that wraps the GnuCOBOL polyglot entry point. The next step is
using cobc to generate C source code from the COBOL source, including code
that will initialize the GnuCOBOL run-time library. gcc is then used to
create object code from the COBOL generated C source, along with the SWIG
wrapper, with information on where to find the perl5 header file includes. A
final step is then using the object code to build a shared library that can be
imported into a Perl interpreter space.
Then it becomes a simple matter of:
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;
With a run test of:
prompt$ perl
use polyglot;
my $rc = polyglot::polyglot;
print($rc, "\n");
giving:
Hello from GnuCOBOL
It is now 2015/09/25 06:32:36
42
The $rc variable is set, by calling the GnuCOBOL polyglot function. The
Hello message is displayed (by COBOL), and the return value from the module is
placed in the Perl $rc scalar variable, which is then printed with a newline.
GnuCOBOL called from Perl, without knowing anything about the API details that would normally be required for this integration. An example of those details is listed in Can GnuCOBOL interface with Perl?. In this case, the SWIG development team filled in the nitty gritty details, and the application developer need only worry about creating an interface definition, and some build rules. The build rules are mostly boilerplate, with some site local information on where to find headers and support libraries.
Given the same COBOL source, and the same SWIG definition, the Makefile allows
for the polyglot COBOL subprogram to be called from Java:
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
From Python:
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
And from Tcl:
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
With some other build rules, the same code could be used from over 20 SWIG supported languages, listed at the top of this entry, and fully documented by the SWIG project at http://www.swig.org/doc.html. No change to the COBOL or the interface definition would be required for any of these integrations.
5.91.2 Contract programming with SWIG¶
SWIG supports more than simple wrappers. There are features included with SWIG that allow for contract style programming, where inputs and outputs can be validated on function entry and exit.
Given this GnuCOBOL program, contract.cob:
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
And this interface definition, contract-swig.i:
/* 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);
contract-swig.i includes a SWIG %contract clause, and builds code that
requires that the input argument is a number greater than 0, and ensures the
return value is the given number plus 42.
Demonstrated with this Python pass:
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
The interface definition caused code to be built that raised an exception in
Python when passed a negative value to the GnuCOBOL contract subprogram.
Once again, all the nitty gritty details handled by SWIG.
5.91.3 SWIG in summary¶
SWIG will allow just about any and all existing GnuCOBOL programs to be wrapped for use by a plethora of other programming languages. And that means GnuCOBOL can easily take part in “modernization” efforts, pretty much at whim, and without change to underlying COBOL sources.
There is a lot more to SWIG than what is shown here, a sufficiently advanced technology, indistinguishable from magic.
5.92 What is small s.c.r.i.p.t.?¶
small s.c.r.i.p.t. is a Single Character Read Interpret Programming Toyol.
- Toyol
- A toy programming tool; toil, for the fun of it.
Here is small s.c.r.i.p.t. program, called from the shell, that saves byte codes from 0 to 127, 7bit ASCII, as binary values in codes.txt
small '128[@.+]' >codes.txt
And one that saves byte values from 0 to 255, as binary, in allbytes.txt.
small '.+[.+]' >allbytes.txt
6 bytes of small s.c.r.i.p.t. source code.
To get a list of formatted values, from 0 to 15:
small '16[0@# +]'
000 001 002 003 004 005 006 007 008 009 010 011 012 013 014 015
Unformatted:
small '16[@# +]'
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
And a program to display all the words from 99 bottles of beer on the wall, including proper plurals and no for zero. Saved in file 99bottles.small
: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\.
Giving:
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.
182 bytes of source for 99 bottles, a correct version.
A little printable ASCII chart, as asciichart.small
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.
Invoked with
prompt$ small -f asciichart.small
Giving:
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
An interpreter, written in COBOL, using GO TO DEPENDING ON.
The small s.c.r.i.p.t. source code:
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 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 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 SMALL-BUFFER times
depending on colons.
01 colons usage index.
01 loop-stack.
05 loop-offsetlimits occurs 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.
Other examples of small s.c.r.i.p.t.s (the 10. operation means display newline, ASCII 10).
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
That last one calls the C puts function with Hello, world and displays the return value from puts. Avoiding all the shell quoting, the script is actually:
"Hello, world">0+01'puts'#
"Hello, wordd" lays down a string
>0+ advances the current cell and lays down a null byte
01 puts a "zeroed" 1 on the internal immediate value stack
'puts' calls puts with one argument (the count taken from the stack)
# displays the result as a numeric string.
small s.c.r.i.p.t. makes you think, but some nifty programs can be written, in just a few characters of source. As a bonus, it’s an esolang, written in COBOL.
5.92.1 deadfish¶
Another completely useless esoteric programming language is deadfish.
Four operators, single value.
- i increment
- d decrement
- s square
- o output
Most implementations add an h operator, for halt. A bug ridden reference
implementation now drives the design of most of the other deadfish
interpreters.
The spec asks for values from 0 to 256, but the reference only reset the value when it was explicitly -1 or 256, so large and negative numbers are actually prevalent. For example:
iissso
displays 0, but:
iissiso
displays 289. Here is a GnuCOBOL implementation, bugs and all.
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.
And here’s another, with a slightly less, but still nasty user interface.
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.
5.93 How do I determine the amount of memory available?¶
With modern operating systems, this can be a tricky business, fraught with complexities.
For GNU/Linux systems, the sysinfo function, and corresponding structures
is likely the best way.
#!/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
And an example run of:
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
5.94 What is CBL_OC_GETOPT?¶
CBL_OC_GETOPT is one of the stock library routines that ships with
GnuCOBOL. By Philipp Böhme, one of the contributing compiler authors.
It allows for complex command line option handling akin to POSIX getopt and
GNU getopt_long functions.
http://www.gnu.org/software/libc/manual/html_node/Getopt.html
These usage example are modified from the GnuCOBOL make check testsuite.
*> 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.
As this is from the testsuite, there is a very particular order expected:
prompt$ cobc -x getopt-test.cob
prompt$ ./getopt-test --version --verbose -jkl
Gives no output, all the tests pass. Other options will trigger error responses:
$ ./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: ?
As of December 2015, this library routine holds promise, but still needs some work.
5.95 Does GnuCOBOL work with shell scripting?¶
Yes, very well actually.
There is a wide selection of avaible POSIX shells. Bash likely being the most
common, but not in any way the only shell command processor. Other common
shells include csh, zsh, ksh, dash to name a few. But shells
can also get more exotic such as Zoidberg, a Perl based shell, IPython which
is an interactive Python shell, tclsh and wish for Tcl and Tk, amonfg others.
This entry will focus on bash.
POSIX shells allow for what is technically called an interpreter directive, commonly called a “shbang” or “hashbang” line.
#!/bin/bash
The octothorpe followed by exclamation mark is a special value that is used by
the program loader to decide what program is in charge of current command
processing. cobc can take part in this scheme.
#!/usr/local/bin/cobc -xjF
identification division.
program-id. hello.
procedure division.
display "Hello, shell"
goback.
That ‘script’ will cause POSIX to exec the cobc program and treat it as the
current interpreter. The lines that follow become the standard input to the
interpreter, in this case cobc. The current script filename is passed
to the new shell processor along with a single argument.
There can normally only be one space delimited argument passed to these shell programs, but with the smart option processor built into cobc, the single character command options can be merged into a single string and each option flag processed as if they were separate options.
So, back to the script. -x to generate an executable, -j to run job at end of compile, and -F to treat the source code as FREE format.
prompt$ chmod +x script-sample.cob
prompt$ ./script-sample.cob
Hello, shell
The script was marked as excutable with chmod +x and then evaluated. To
see what is going on, the verbose flag can be used.
#!/usr/local/bin/cobc -xjFv
identification division.
program-id. hello.
procedure division.
display "Hello, shell"
goback.
With another run sample of:
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
This sequence opens up a world of GnuCOBOL “scripts”. They are actually
compiled to binary and executed by cobc but still look and feel like
scripts.
The -j job run option was added to GnuCOBOL in October of 2015. Along
with another powerful option, compile from standard input when given - as
an input filename. These two cobc arguments can be used to great
effect with COBOL shell scripting.
#!/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
The script calls cobc and asks for a compile from standard input. That
standard input is actually from a shell here document which reads lines up
to (but not including the EOCode line). Note that this is not the same
as the cobc interpreter directive. In this case bash is the command
processor, and cobc is invoked as part of a “normal” shell script.
Without the -o fromhere option, compiling from standard in will default to
using an a.out destination name.
During the compile steps, the -j command line option runs the program,
with another here document used as the COBOL program standard input. The
ACCEPT verb reads this standard in data as if it were typed on the
CONSOLE device. To demonstrate the difference bewteen quoted and unquoted
here documents, the program is run twice; with unquoted and with quoted shell
provided standard input.
All of that together, gives:
$ ./fromhere.cob
Process 23135 running ./fromhere.cob with shell options hB
Process $$ running $0 with shell options $-
The first run passes a processed string where $$ is expanded to current
process id, $0 is expanded to current program name, and $- is expanded
to the current bash shell flag settings. Any and all shell expansion
features can be used here, including subshell replacement with $().
The second run passes the quoted here document without shell expansion and is passed literally to the COBOL program.
Not only can GnuCOBOL be scripted, it can be scripted along with sample data. Not only that, but sample data can be literal, or can include shell processing before it is passed on to a COBOL program.
Here is a program that reproduces itself. But it is not a Quine as this script accesses external data. That data being the disk copy of the script itself. See the Quine note for an actual Quine in GnuCOBOL.
#!/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
Giving:
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
And as a small proof that the reproduction matches the original:
prompt$ ./reproduce.cob | diff reproduce.cob -
prompt$
5.96 Can GnuCOBOL generate Postscript?¶
Yes. In two modes. Postscript is just text, a programming language. Simple DISPLAY or WRITE statements can generate Postscript lines and files.
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.
*> ***************************************************************
*>****
would output text lines suitable for pipeing to gs or gv, or other
Postscript interpreter.
prompt$ cobc -xj tops-1.cob producing:
%!PS
/Times-Roman 20 selectfont
72 396 moveto
(Hello, postscript) show
showpage
And with prompt$ cobc -xj tops-1.cob | gv -
Showing
1 inch (72 pts) in and 5.5 inches (396 pts) down an 8.5 by 11 inch page, in a 20pt Times-Roman font. It’s actually 5 1/2 inches “up” the page, as Postscript places the 0,0 origin at the bottom left corner of the page, just like the first quadrant of most math class graphs, y goes up, x goes across.
The image above would look much sharper with most modern printers, that copy has gone through some transforms getting into this manual, as an image file.
Adding a little COBOL programming, and this fills a page with “Times-Roman” at font sizes from 5pt to 36pt.
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.
*> ***************************************************************
*>****
And cobc -xj tops-2.cob producing:
%!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
And pretty much fills a page to look like:
Same note as before; that is a transformed image, .ps to .eps to .png for inclusion in this document. The real thing looks much sharper.
That’s one way GnuCOBOL can generate Postscript, simply as text.
GnuCOBOL can also leverage a Postscript interpreter. Ghostview ships with a
shared library, libgs.so (or gs.dll on Windows) for just this purpose.
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
Which doesn’t really generate any PS in this sample. Commands are sent to the
gs interpreter to show the default page dimensions, then add 40 and 2,
then display a version number, and finally list supported device names. All
that data normally goes to a GS console, but in tops.cob the standard out
of the engine is captured in a callback and displayed from COBOL. The sample
above even forces the device type to “nullpage” to avoid popping up the normal
Ghostscript viewer. Actual deployments would modify or remove that argument.
The same text that tops-1.cob and tops-2.cob produced could be used to
generate PS pages, but tops.cob can take any commands, and interact the
engine itself.
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]
|
- line 5 above is the output from PageSize get
- line 6 is the 40 2 add instruction output
- line 7 in the version display
- and the rest is the
devicenamesoutput
GnuCOBOL can drive Postscript, as external text, or as an embedded engine.
5.97 Can GnuCOBOL interface with Java?¶
Yes. In a multitude of ways.
First, there is COBJAPI. See What is COBJAPI? for the full description of this user defined function contribution.
Second, there is SWIG. SWIG is somewhat of a uni-directional tool, Java applications calling GnuCOBOL sub-programs. SWIG makes this type of interface very easy on the integrator. See Does GnuCOBOL work with SWIG? for an example of Java calling GnuCOBOL.
Next would be directly interfacing with the Java Native Interface, JNI, built by the Java core development teams for just this purpose. Low level details abound, and there is no sample here yet.
A slightly higher level abstraction than JNI is JNA, Java Native Access. Gary Cowell posted a quick sample to SourceForge, listed below. JNA builds on JNI to ease integrations.
Code by Gary Cowell, cobsubtest.cbl
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.
A second program cobsubtest2.cbl
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.
And the Java program jnacob.java.
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);
}
}
}
This needs to have jna-4.2.1.jar in current directory (or, elsewhere, modify classpath as appropriate).
And a build sample of:
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
giving:
Starting cobsubtest.cbl
Called With [We Did It! ]
COBOL Return Code 2
Starting cobsubtest2:
Called With [We changed it! ]
COBOL Return Code 8
And that’s pretty much all it takes to fully integrate Java with GnuCOBOL using JNA. https://en.wikipedia.org/wiki/Java_Native_Access
Many thanks to Gary for his posting.
5.98 Can GnuCOBOL interface with Icon?¶
Yes, by way of iconc the Icon compiler. Icon is a programming language designed by the late Ralph Griswold, as a descendant of his earlier work with SNOBOL.
The Icon Project is hosted by the University of Arizona, with sources and reference book materials dedicated to the public domain.
Icon dates back to 1978, with version 9.5.1 released in 2013.
A very high-level language (very high-level) Icon introduced goal directed evaluation, and generators to the world.
Here is a routine that computes a concordance of words read from stdin.
A concordance is similar to a cross-reference:
- concordance
- an alphabetical list of the words (especially the important ones) present in a text, usually with citations of the passages concerned.
concord.icn lists words and the line numbers in the file where they occur.
Icon excels at processing words. The version that ships with the Icon
Programming Library tests for words greater than or equal to 3 characers long,
it was changed here to take any word of 1 character or more, as the plan is to
scan computer source code. This isn’t a perfect use of concord, as the rules
are really meant for text words, not code, but it’s still pretty handy.
The iconc compiler generates intermediate C sources, much like GnuCOBOL,
and compilation can be told to leave the C source files on disk when given the
-c command option.
So:
prompt$ iconc -c concord.icn
produces concord.c and concord.h.
Getting at the C compile details is a little tricky with iconc as it
does not display the internal toolchain commands when given the verbose
option. But it does allow passing extra arguments to the C compiler, and with
gcc that means -v can be used to figure out how Icon is processing the
intermediate when building an executable. For Ubuntu and Icon 9.4.3 a
suitable Makefile looks like:
# 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
The second rule, produces concord.c and concord.h, then renames the
generated main function to imain so GnuCOBOL can be in charge of the
entry point. The recipe then continues and changes an Icon terminating call
of c_exit to a more GnuCOBOL CALL friendly return. Invoking
c_exit would be the equivalent of STOP RUN and would terminate the
running program and return to the operating system, not something you normally
want in a COBOL sub-program.
The primary rule, callicon produces the target executable, using cobc
to link in all the run-time support files required by Icon along with
compiling the COBOL program and the intermediate concord.c, generated with
icon -c
The sample COBOL callicon.cob:
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.
And finally a run, using the callicon.cob file as input by redirecting
standard in for Icon to read.
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
The most common word being “exception” which occurs at lines:
30 32 38 41 43 44 48(2) 49(2) 50(2) 51(2) 54 55 60
with 2 occurrences on lines 48, 49, 50, and 51.
GnuCOBOL calling Icon, with somewhat complex tectonics, but worth it.
Icon sources are public domain, the main (very well written) reference materials are public domain. Worth a read.
https://www.cs.arizona.edu/icon/
https://www.cs.arizona.edu/icon/books.htm
5.98.1 Unicon¶
Clint Jeffery and a small team of brilliant programmers out of the University of Idaho, have been extending Icon and creating Unicon. Unicon adds
- classes and packages
- exceptions
- loadable child programs
- monitoring
- dynamic C modules (on some platforms)
- ODBC database access
- dbm files as associative arrays
- a POSIX system interface
- networking
- 3D graphics
Out of great respect for Ralph Griswold, and his decision to freeze Icon features, Unicon is a separate project and is not officially a continuation of the Icon project. Well worth keeping an eye on, release 12 (January 2016) of Unicon is a formidable programming environment. Now with SNOBOL patterns built right in (as part of alpha release 13).
In the spirit of the Icon project, Unicon is free software, and the book,
Programing with Unicon is free to download and share, licensed under the GNU
FDL.
http://unicon.sourceforge.net/ and https://sourceforge.net/projects/unicon/
It is one of the hidden gems of the programming world.
A graphical Hello, world:
With:
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:
Unicon also supports the simpler Icon v9 version
Graphical programs in Icon allow ‘q’ to quit by default.
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:
And just a little more Unicon advertising:
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/
5.99 What is JRecord?¶
JRecord is a Java based utility that slices and dices COBOL data layouts; by Bruce Martin.
Hosted on SourceForge at http://jrecord.sourceforge.net/
Java you say? Why mention this in a COBOL document?
Well, just because it’s Java based doesn’t mean it doesn’t know COBOL formats. It knows them very well, as well as Java forms, which make it a mix and match porters dream tool. Free software, licensed under the same GPL and LGPL that GnuCOBOL enjoys.
- Read and write files of length based records (both fixed length records and Length field based records).
- Read and write CSV files.
- Read and Write Flat Fixed width files (Text and Binary) via either a Xml-Record-Layout or a Cobol Copybook..
- Read and write XML files (via StAX parser).
- Common IO routines across all File Types (XML, CSV, Fixed field Width).
- Support for various Flat file formats (Fixed, Delimited, Length based Files (i.e. Mainframe VB).
One small extract from the very well documented JRecord feature pages:
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="<Tab>"
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>
JRecord can do automated read/write conversion to and from COBOL in all sorts of production ready formats.
Visit the SourceForge project space for all the rich details. The entry here barely scratches the surface on what you will find on the JRecord utility belt.
Actively developed with a long history. JRecord is GnuCOBOL friendly, and GnuCOBOL is JRecord friendly. With an eye to mainframe data crunching.
5.99.1 cb2xml¶
Along with JRecord, Bruce helps with a project that translates COBOL copybook data layouts to XML and vice versa.
https://sourceforge.net/projects/cb2xml/
Visit the link, as it’ll tell you a lot more than what will fit here.
5.99.2 RecordEditor¶
Bruce and the small team have also put up a RecordEditor project:
https://sourceforge.net/projects/record-editor
This utility with a few simple steps allows one to go from this
*******************************
* 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.
to this
from inside the RecordEditor tool. (Assuming the AmsLocDataFile is populated).
See the project link above, and the nicely complete documentation and example listings provided with the website, at http://record-editor.sourceforge.net/
This a handy set of integrated tools; JRecord, RecordEditor, and cbxml (along with some other utilities) worthy of addition to any COBOL programmer’s toolbelt. And you might just pick up a few Java skills along the way.
There tends to be a friendly rivalry between Java and COBOL programmers, but knowing both puts a developer in a pretty sweet position.
5.100 Can GnuCOBOL interface with Piet?¶
Yes. As with the Shakespeare Programming Language, the simplest way is to just compile a Piet interepreter into a GnuCOBOL progam.
Like Shakespeare, Piet programs are of the esoteric variety. Piet sources are actually images. Pixel colours determine the operation to be performed.
And Piet programs are very likely the most beautiful programs on the planet.
Named after Piet Mondrian a pioneer in geometric abstract art, Piet was designed by David Morgan-Mar.
From Mondrian style art that says Hello, world or tests for numeric primality
to a full on Gnome Sort implementation, by Joshua Schulter, licensed under the GPL.
Please note: the above image is the runnable code used in the sample below.
And that first image is in what Piet calls codel format, large blocks of
colour that represent each pixel. The actual hello program is 481 bytes of
.png.
This GnuCOBOL example uses code from npiet-1.3d by Erik Schoenfelder for
the embedded interpreter and for example Piet program/images.
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.
callpiet.cob uses code from the npiet-1.3d interpreter, which reads
.ppm formatted graphics by default. npiet can be extended with PNG,
and GIF readers, and with GD, can produce graphical trace output. This sample
does not use those features. http://www.bertnase.de/npiet/ GPL 2.0.
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
If you are using a POSIX system, this version of callpiet.cob is much more
flexible.
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
5.101 Can GnuCOBOL be used with D-Bus?¶
Yes. GnuCOBOL can serve and call D-Bus with any of the C level bindings.
libdbus is the reference implementation, and is exercised below.
dbus-glib would also work, and it would likely be a little easier, as the
event loop management would then be part of the standard GLib mainloop.
The sample below is only an example. Changes to add application specific logic would be required before this would be anything more than a demo.
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
A small Makefile:
# 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
And a quick tour:
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$
Demonstrates a method listen loop and method call, and then a signal
catch loop and signal broadcast. The loops are forked out to a child
process for testing. The main module in the repository accepts quiet,
test and verbose command line arguments to run the demos with various
verbosity settings.
Most D-Bus supported data types should work, as the basic D-Bus get and set routines are indirect through pointers to working storage. This demo only touches on Boolean, C character string, 32 unsigned and 64 bit signed values.
Customize the dbus-identity block to use different method and signal names for
an application. The reply-to-method-call subprogram would be where most
of the custom logic would be placed, but all four User Defined Functions would
require some level of change to be useful in an actual application.
SYSTEM level bus services would require external configuration before most operating environments would permit access. This sample uses SESSION bus mechanisms, single user, and by nature, far less restrictive when it comes to permissions.
D-Bus is dual licensed. The GnuCOBOL project recommends the GPL choice, but AFL (Acedemic Free License) is another choice provided by the developers of the D-Bus reference implementation.
D-Bus: https://dbus.freedesktop.org
5.102 Can GnuCOBOL interface with Red?¶
Yes. Red is a programming language with design heavily influenced by REBOL.
First, some background, from a short article orginally titled
Expressiveness in programming, Red
There is a web page, a few years old now, that attempts to quantify the expressiveness of programming languages.
http://redmonk.com/dberkholz/2013/03/25/programming-languages-ranked-by-expressiveness/
Top three. Augeas, Puppet and REBOL. The graph is a box-whisker plot of lines of code per commit per month over a 20 year span. Augeas and Puppet are Domain Specific Languages, so yeah, a small number of lines of code to implement an idea (within the specialized domain) Augeas for configuration edits and Puppet for, hey, configuration management. Not for general purpose programming really.
REBOL marked as third, is a general purpose language, suitable for almost all tasks, including the network and graphics.
COBOL isn’t even on the list. I’m assuming the lack of publicly available sources is to blame, or the plot didn’t extend far enough to the right, as I’m sure COBOL can beat fixed form Fortran in lines of code per idea. :-)
But the reason for the mention, is REBOL. REBOL is grand. Can’t be beat in effective programming sans bloat. Well, that’s not really the reason. The real reason is Red. Red is based on REBOL, being developed by DocKimbel, but with the goal of being compiled as well as interpreted. Along with Carl Sassenrath (REBOL designer), Doc is one of my heroes, has been since the 2nd millennium.
What Nenad (Doc’s real name alias) is developing, is nothing short of extraordinary.
Red isn’t ready for public consumption just yet, but that day approaches. Perhaps within the year, Doc will check off the list of main features. Doc is a perfectionist, and brilliant. Red is usable, but only for the diehards at this point in time. I’d suggest REBOL 2.7 or some of the new REBOL/3 builds for most developers.
I got into OpenCOBOL as I was getting ansy waiting for REBOL/3 and bumped into Roger’s work by accident. So glad. REBOL/3 still isn’t “ready”, and that was 2007.
But now, Red. Red is way cool. It should be the future of computing. It likely won’t be, as it may be too different for most development shops. But it’s already an option for GnuCOBOL, Doc’s compiler in version 0.5.3 pumps out object (various forms, ELF being the one of interest here), and DSO libraries, but only IA32 format is emitted at this point in time
and CALL away.
For example: Given
Red/System [
Title: "hello red, callable"
]
hello: function [] [
print "Hello, world"
]
#export [hello]
hello-red.red
compiled with:
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
and some GnuCOBOL
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
callred.cob
and a compile pass of:
prompt$ cobc -x callred.cob hello-red.so
prompt$ ./callred
Hello, world
prompt$
Woohoo.
The future of computing. Mix the most expressive general purpose programming language with arguably the least expressive [see footnote 1], for the win.
I firmly believe that most COBOL falls in the least expressive camp, line counts per commit per month, but GnuCOBOL FUNCTION-ID is prepped to set that historical trend on it’s head. Take a peek at cobjapi, for instance. Once the REPOSITORY entries are coded up, function libraries make for very concise application level COBOL.
The future of computing. Expressively competitive COBOL. to infinity, and beyond.
Check out Red, the programming language at http://www.red-lang.org/
DocKimbel has grand plans. The first full-stack system level and general purpose programming language. I believe him. And GnuCOBOL will (and already can) benefit from the design and the efforts.
[footnote 1] Aside. The Shakespeare programming language is more verbose than COBOL, but I’m not sure it counts for real world programming.
One example listed here in the FAQ; 65 lines and some 2000 characters of Shakespeare source code to output DERP.
Oh, and one more aside. While setting up this post I needed to build a 32bit cobc on this 64bit system, as Red only emits IA32, for now, and 64bit applications don’t easily link to 32bit shared libraries, so, it was easier to just build a 32bit COBOL environment. All that was needed was:
export CFLAGS='-m32'
export LDFLAGS='-m32'
./configure
make
make check
source tests/atconfig
source tests/atlocal
And libcob and cobc are 32bit builds that compile and run 32bit applications, on a x86_64 base system.
Works the charm.
5.102.1 COBOLREBOL¶
Steve White has been writing up some articles that explain the REBOL/Red way of programming, from the point of view of a COBOL programmer. Worth a read.
5.103 Can GnuCOBOL catch POSIX signals?¶
Yes. GnuCOBOL installs default signal handlers as part of the libcob runtime.
Now that GnuCOBOL can produce subprograms with void returns, application
programs can also be used for signal handling.
The following code was written as a Rosetta Code entry.
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.
It installs a SIGINT (keyboard interrupt) handler and then loops, waiting for
^C from the keyboard.
Here is another cut that uses sigaction instead of signal.
signal has different behaviour on different systems; some may remove the
handler during exit, some don’t. sigaction gets around this by having
a stricter definition.
But, alas, this cut is specific to a 64 bit, GNU/Linux build. Other platforms
would need to synchronize the struct sigaction for correct alignment and
field sizes.
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.
And:
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$
Where the first run was terminated with a simple Enter, and the second with Ctrl-C, which was handled by the restored GnuCOBOL runtime setting.
5.104 Can GnuCOBOL interface with X11?¶
Yes.
The following code was posted to Rosetta Code for demonstration of the Window Creation/X11 task. http://rosettacode.org/wiki/Window_creation/X11#COBOL
Due to the macro heavy nature of X11 programming from C, some of the opaque X11 data structures need to be exposed for use in COBOL programs. These data structures may need tuning for some variants of X11 implementations.
More sophisticated X11 programming would likely require even more of these opaque data structures to be recoded as COBOL records. That is currently a manual operation, requiring translation from information in Xlib.h.
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.
Giving:
5.105 Can GnuCOBOL interface with PARI/GP?¶
Yes. The PARI library and the interactive gp linear algebra system works very well when called from GnuCOBOL.
First cut exploration example follows.
Requires:
apt-get install pari-gp pari-gp2c libpari-dev`
A quick intro:
prompt$ gp -q
? 123456! + 0.
2.6040699049291378729513930560926568818 E574964
? quit
prompt$
A fairly fat factorial, approaching 575000 digits
The pari-gp2c provides gp2c, a utility that ships with PARI/GP to
allow for complex equations to be imported into gp as C code.
prompt$ cat fact.gp
123456! + 0.
prompt$ gp2c fact.gp
Which outputs
/*-*- 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;
}
Note that the output from gp2c does not provide directly callable functions,
as it is designed for use with the gp import engine, but it does break
down the steps required for what library functions to CALL.
That, along with the sample program from the PARI library manual is enough to get started dealing with some algebra in GnuCOBOL.
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.
(The capture of the first pari_printf of pari-factorial, is excluded
as it is raw numeric data, 575,0000 digits worth)
prompt$ cobc -xj callgp.cob -lpari
...
2.6040699049291378729513930560926568818 E574964
pronpt$
Here is the first bit of the factorial 123456!
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
2 lines, 3 words, 575014 characters counted.
Fast too.
prompt$ time cobc -xj callgp.cob -lpari | tail -1
2.6040699049291378729513930560926568818 E574964
real 0m0.270s
user 0m0.228s
sys 0m0.024s
That’s with the compile step, IO streaming time and filtering through tail.
If you ever need to provide some numeric handling for prime numbers, or
sophisticated algebra, PARI/GP is worth a look. PARI/GP is big on prime
numbers. The para_init call takes an initial value of calculated primes to
include in an internal table. Even if you ask for none (this code requested 2
along with an 8meg stack), it guarantees the first 65000 ish primes all
prepped and ready for working with the big number library functions. There
are a LOT or algrebra functions included. A lot.
The PARI library also supports all kinds of data conversion routines, so getting some of the smaller scale values out of the PARI stack, into COBOL working store won’t be hard at all.
https://en.wikipedia.org/wiki/PARI/GP
PARI/GP Development Headquarters http://pari.math.u-bordeaux.fr/
Oh, and gp the interactive part of the PARI/GP is just fun.
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
Easy, peasy plot of two circles worth of sine, with X in Radians.
The gp calculator is feature rich.
To get a fairly close approximation equation for sin(X), more easy peasy.
? 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)
Fun with math.
The gp2c tool makes converting complex linear algebra equations into a
sequence of calls that can be made from GnuCOBOL, a very smooth experience.
Things can get orders of magnitude more sophisticated than the sample shown here, so when play time is over, PARI/GP is a very suitable engine for adding complex algebra features to GnuCOBOL programs.
5.106 Can GnuCOBOL interface with GRETL?¶
Yes. The C code that makes up the GNU Regression, Econometrics and
Time-series Library, gretl, can be used from GnuCOBOL. Some simple wrappers
are required for certain features of libgretl though, as some functions return
struct data, and GnuCOBOL currently has no way of specifying that in a
RETURNING clause.
The quick trial, given a sample listing from the libgretl API reference and
one of the sample native gretl data format files (in this case
/usr/share/gretal/data/data10-1.gdt copied to sample.gdt).
*> 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;
*> }
And the trial run:
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$
The data sample has 110 observations, from this XML source.
<?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>
A second example needs a little bit of C support code.
MODEL information is returned by struct so there needs to be a small piece
of middleware to fill in that data for use from COBOL.
*> 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.
And some C code to get around the struct return.
#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;
}
which complicates the tectonics a little bit, as cobc needs to pass some glib include path instructions for gretl.
Sample run with an ARMA (AutoRegressive Moving Average) model displayed for some 1975-1990 income data.
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
-----------------------------------------------------------
gretl ships with a scripting engine, HANSL; Hansl is A Nice Scripting Language. This pair seems like a very nice match up for GnuCOBOL.
gretl can read from quite a few different data source besides native .gdt XML
(and binary forms) and spreadsheet files, including plain text CSV, so it
won’t take much to produce datasets from COBOL data. There is a GUI, a
command line interface and hansl packages available. gretl also has very well
supported import and export of R data, and hansl can even handle interwoven R
scripts inside hansl scripts. gretl integration will provide a very nice
toolset for Econometric modelling, with easy steps to get at GNU R
sophisticated statistical analysis.
This is only step one and two in an integration effort, and there is much to leverage with the gretl library and associated utilities. Non-trivial use will require some level of expertise in Econometrics.
http://gretl.sourceforge.net/index.html
sudo apt-get install gretl libgretl1-dev
5.107 What is CBL_OC_SOCKET?¶
CBL_OC_SOCKET is an entry in the GnuCOBOL contrib/ tree. Resembling the C$SOCKET system call from other compilers.
Some of the base code is written in C++, so proper use will almost always
require -lstdc++ as part of the cobc command when compiling programs
that use CBL_OC_SOCKET.
Example server:
* 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
.
And the associated sample client:
* 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.
CBL_OC_SOCKET is a main callable that uses opcodes for each function.
- “00” Open
- “01” Accept
- “02” Connect
- “03” Write
- “04” Read
- “05” Read and Write
- “06” Close
- “07” Accept
- “08” Read
- “09” Next Read
- “10” Next Read
- “98” Show error
- “99” Show error
5.108 Can GnuCOBOL interface with Haxe/Neko?¶
Yes. One of the many Haxe output targets is Neko, a Virtual Machine system that is easily embedded in GnuCOBOL.
The Haxe platform/language also targets
- Flash
- ECMAScript
- ActionScript 3
- PHP
- C++
- Java
- C#
- Python
- Lua
Of those targets, only Flash, ActionScript 3 and C# have no working sample for integration with GnuCOBOL. But this entry is all about using the “native” NekoVM target of Haxe programs.
Starting with a small Neko test file
// 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");
And a quick test of that, first compiled to Neko bytecode, then making sure it works:
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
Ok, code seems functional, so now from GnuCOBOL
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
}
These 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
Please note that the code above is some what dual purpose. It can load and
run just about any Neko module, but it is also tuned to try and find a few
exports from Neko; var x, function f from Neko, and
function requestUrl inside a class Demonstration from haXe.
Use the above code as a starting point, not as an end.
The Demonstration haXe class
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());
}
}
And a sample Makefile
# 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"
And the flying carpet pass:
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
And the NekoVM is running inside GnuCOBOL, ready to load and run any (well
some) Haxe or Neko source that has been compiled down to Neko bytecode. This
early version of cobweb-neko version 0.3 only handles int, string
and function Neko data types.
http://nekovm.org/ for detals on Neko and NekoVM. There is a lot to this
little engine. Including a development web server built into the main
neko command, alond with XML generators, doc gen tools, and all sorts of
handy utilities for C layer integration. There is even a higher level meta
language, NekoML.
Even more power comes with Haxe, the cross-platorm toolkit. https://haxe.org/
High level Haxe code can generate all kinds of runtime output. Neko is highlighted here, but that is a small (but very useful) part of the Haxe ecosystem. Haxe is aiming to start modern, and stay modern. Web applications are a breeze, and output forms are flavoured to suit almost any taste. Python code output, Javascript, PHP, C++ and on and on, all from the same Haxe source file.
From the main Haxe site
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!');
}
}
}
With a sample Neko build:
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!
Or, if Python is more your style:
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
Giving:
prompt$ python3 testing.py
Elizabeth does Programming for a living!
Joel does Design for a living!
And that is just a small taste. There are lots of targets, lots of library features, and an entire web development layer in Haxe space. As mentioned before, Neko even ships with a small web development and test server.
The cobweb-neko GnuCOBOL sample just needs the neko file passed in as
testing.n and we get:
prompt$ ./cobweb-neko testing.n
Testing.hx:9: Elizabeth does Programming for a living!
Testing.hx:9: Joel does Design for a living!
Many thanks to Nicolas Cannasse and the Haxe Foundation. A handy toolkit.
While the Haxe and Neko systems are built along with other software, here is the main Neko license text:
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.
Please see the Haxe and Neko distribution files for the other licensing details.
6 GnuCOBOL in production¶
6.1 Is GnuCOBOL ready for production use?¶
Yes. For your particular application? Probably. GnuCOBOL has proven to be a very viable alternative to commercial COBOL offerings. GnuCOBOL supports most features of COBOL-85, almost all of the COBOL-89 Instrinsics, many features from COBOL-2002 and some from COBOL-2014. Bugs are fixed as they are found, the support community gets pretty good reviews, and is actively helpful. Very smart people are continually enhancing the product, both in terms of core support, and in support of extensions in use by other compilers. Freedom does that to people, they want more.
As listed in Does GnuCOBOL pass the NIST Test Suite?, the 2.0 reportwriter version of GnuCOBOL passes well over 9,700 tests, across 420 different modules. If you have never read the NIST COBOL-85 test validation suite, it was designed to torture test COBOL compilers. GnuCOBOL does a very admirable job. Although NIST no longer updates the test collection, when they did, it was treated very seriously. Validation test results were (and are) used by decision makers, in the highest levels of government, corporate enterprise, and educational sectors from around the world.
This question is also touched on in Can GnuCOBOL be used for production applications?, but this answer will try and go deeper, now that GnuCOBOL has matured as a product and there are more and more success (and some failure) stories.
Use of certain vendor extensions may mean there is more effort to port to GnuCOBOL, some may even put pause on a decision to port to GnuCOBOL at all. PowerCOBOL windowing support is one area that does not have good coverage in GnuCOBOL, yet.
6.2 What issues will I face when porting from a mainframe?¶
Depends on the work load. A small to midsize application, probably not that many issues to tackle, in terms of source code, but there will always be ENVIRONMENT DIVSION issues to work out. Along with the COBOL ENVIRONMENT there is the operating system enviroments to contend with. Are you porting COBOL to GnuCOBOL on Windows(tm) or GNU/Linux, or perhaps you are aiming for HP3000 or AIX? All of these platform changes will come with highly specific program build and maintainence issues.
GNU/Linux is likely the easiest to move to. As a GNU project, GnuCOBOL is built with GNU tools and targets POSIX standards. (Not claiming compliance, but built with POSIX features in mind.) The compiler is built around C and the C application binary interface, an environment best supported by POSIX biased operating systems. Unix(tm) and Linux, with the GNU userland is the reference implementation of GnuCOBOL.
Windows(tm), Apple OS/X, HP3000, AS/400, R/S600, are all options though, binaries exist for these, and other systems, including MVS.
GnuCOBOL supports a rich and detailed set of configuration options to help
manage cross platform issues, and this is likely where the first hurdles will
be faced when moving from the mainframe. As binary fields are “implementation
defined”, there are several data typing issues to manage. Starting with
big-endian and byte order, to position of numeric sign, to width of fields,
there are options available in GnuCOBOL .conf files.
- binary-size: (can be 1 thru 8 as needed for packing, limited to 1-2-4-8 or even 2-4-8)
6.2.1 Enterprise¶
Do you have a large enterprise scale system with 40 years of production tweaking and millions of expensive hours spent on its design, implementation and maintenance? You are looking at work, issues, and problems to overcome when porting to GnuCOBOL. Probably many. The same range of issues as you would have with any large system port, regardless of source and target COBOL compiler, or non COBOL environment.
GnuCOBOL offers the freedom to explore the system, from the inside, and to ponder on potential customizations that would strengthen trust, and usabilty.
It also offers another option to consider if pondering to leave COBOL due to dues and annual fees. Instead of porting from COBOL to less expensive non-COBOL, port from COBOL to less expensive COBOL.
The C ABI offers untold potential for system integrations, from the highest to lowest levels. Integrate R analysis, Java, add sensor monitors, web services, cloud, all mixed with heritage COBOL-85, COBOL-68, COBOL-2014, COBOL-anytime resources.
With care, the most esoteric COBOL data types can be safely managed with GnuCOBOL. But, for sophisticated data ports, an export to flat file, and import to higher level COBOL data forms is one of the easier ways to build trust in the internal workings of a corporate GnuCOBOL deployment. The data will then be synchronized according to local compiler sizings, endian order, sign extensions and other bit configuration optimizations available to PICTURE and USAGE.
6.3 What about GnuCOBOL in High Performance Computing?¶
Jim Currey, co-founder of Currey Adkins, recently set a note about GnuCOBOL 1.1 being put to use in an HPCC environment.
- HPCC
- High Performance Computing Cluster
From Jim:
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
And an update:
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
COBOL, computing in the quadrillions.
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.
And of of June 2016, just got a screen shot of the cluster working its way through 9,380,000,000,000,000 and verifying a little over 33,000,000 primes a second within that 9 quadrillion number range.
And in July, GnuCOBOL in this High Performance Computing Cluster starting in on the 11 quadrillion range. From the first set of a billion in that range:
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)
Another thanks goes out to Jim. Proving (over the long haul) that GnuCOBOL can stay up and keep up.
6.3.1 Chapel¶
GnuCOBOL has also been integrated with code written in the Chapel programming language being developed by Cray Inc.
Early draft as proof of concept.
extern proc SAMPLE(): int;
SAMPLE();
Calling into GnuCOBOL.
*> 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.
And a test of:
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
So there is a step missing in the chpl command line, as the external proc
doesn’t seem to be triggering the correct header definition. It works, but chapel is
still in early development, and this will only get better.
Chapel calling COBOL.
6.4 Mixed programming with GnuCOBOL?¶
GnuCOBOL excels at mixed language programming. Since GnuCOBOL uses C (or C++) intermediates during the compilation phase, and COBOL allows CALL, GnuCOBOL can be mixed with just about any other C based programming system. Once you look closely, the vast majority of program development systems are based on C, or C++. The next few paragraphs are a generalization, but a fair one.
C compilers are written in C. Fortran compilers are written in C. Java starts with C. Pascal compilers are written in C. Ruby, Python, Perl, Tcl/Tk, Ada, and Rexx all have C implementations. Assemblers are written in C. Operating systems are written in C. REBOL, Icon, the Internet, written in C. GnuCOBOL is written in C, and emits C on its way to producing applications. Name a language, and there are very high odds that there is a C implementation. Programming systems not developed in C are the outliers, and most of those provide a way to link to the C application binary interface.
PHP is written in C, SNOBOL has a C implementation. PostgreSQL, MariaDB are C applications. This list could go on, and on, and on. Then there is C++, slighly harder to directly link with the C ABI due to name mangling issues, but the language itself allows for
extern "C" {
wondertype awesomefunction(superdata input) {
earthshatteringcpluplus_code
}
}
Add two lines for wrapping and C++ is available. Install GnuCOBOL C++ and even those lines become unnecessary.
And now back to reality and less over generalizing.
GnuCOBOL, by its nature, can easily interface with C and C++. That means that large investments in COBOL may not need to be tossed and rewritten to keep up with the modern world, but only tweaked, leveraged and integrated.
7 Notes¶
7.1 big-endian¶
Binary values stored with the most significant byte at the lowest memory address. Mainframes and networks use this form, more often than not.
Big End First.
See https://en.wikipedia.org/wiki/Endianness for more details.
The GnuCOBOL compiler default storage format for USAGE BINARY and COMP.
A 32-bit unsigned integer value of 168496141, x”0A0B0C0D” would be:
Address: 00 01 02 03
value: 0A 0B 0C 0D
with the most significant byte stored at the lowest memory address. This is the TCP/IP network ready format for multi byte values.
7.2 little-endian¶
Binary values stored with the most significant byte at the highest memory address.
Little End First.
https://en.wikipedia.org/wiki/Endianness for more details.
A 32-bit unsigned integer value of 168496141, x”0A0B0C0D” would be:
Address: 00 01 02 03
value: 0D 0C 0B 0A
with the least significant byte stored at the lowest memory address.
This is the common Intel architecture form, and USAGE clauses of COMPUTATIONAL-5, BINARY-CHAR, BINARY-SHORT, BINARY-LONG, BINARY-DOUBLE are a true performance boost on this hardware, as GnuCOBOL defaults to big-endian internal storage, more in keeping with historical COBOL.
From Keisuke Nishida’e orginal notes:
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.
See What are the GnuCOBOL compile time configuration files? for more details on compile time settings.
7.3 ASCII notes¶
American Symbolic Code for Information Interchange.
The character encoding common to personal computers and the early Internet Age, therefore GnuCOBOL. GnuCOBOL also supports the EBCDIC character encoding so some data transfers and keyboard handling or console display programs may need programmer attention to detail. Although this is a rare case as GnuCOBOL operates using an intelligent choice of encoding for each platform build.
See
https://en.wikipedia.org/wiki/American_Standard_Code_for_Information_Interchange
for more info. If you are running GNU/Linux, use man ascii for quick
access to an ASCII table.
Note
Unicode? GnuCOBOL supports PIC N, a two-byte character field.
7.4 currency symbol¶
COBOL allows a SPECIAL-NAMES clause that determines the currency symbol. This effects both source codes and input/output PICTURE definitions.
CONFIGURATION SECTION.
SPECIAL-NAMES.
CURRENCY SIGN IS "#".
7.5 DSO¶
Dynamic Shared Objects.
Similar to, but conceptually different from shared libraries. A COBOL abstraction of .dll Dynamic Link Library and POSIX .so shared libraries along with other platform specific dynamic link and run-time catalog loader systems.
7.6 errno¶
GnuCOBOL and C are fairly closely related as GnuCOBOL produces intermediate C source code and passes this off to another compiler.
Some C functions had no easy way to report out-of-bound errors so a global int errno is defined in the standard C library as a thread safe variable. Conscientious programmers will reset and test this variable for any and all functions documented as setting errno.
This is not straight forward for GnuCOBOL, but a small wrapper along the lines of
/* set/get errno */
#include <errno.h>
int reset_errno() {
errno = 0;
return errno;
}
int get_errno() {
return errno;
}
/**/
exposes this critical run-time variable.
Usage:
$ cobc -c geterrno.c
$ cobc -x program.cob geterrno.o
and then something like
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
Outputs:
Numerical argument out of domain
Note: errno is a volatile system variable, any function can change the
value.
UPDATE: April 2016
GnuCOBOL now sports a stock system library call, CBL_OC_HOSTED that
provides access to some C hosted and GnuCOBOL internally hosted variables.
See CBL_OC_HOSTED for more details on this new feature in GnuCOBOL 2.0 and
getting at errno without need of external helper C source code.
7.7 gdb¶
The GNU symbolic debugger. Big, deep, wide.
$ info gdb for the details.
or visit http://www.gnu.org/software/gdb/documentation/
For effective use of gdb a developer will have to get used to reading some
of the emitted source code generated by cobc. Break points and line
stepping requires some knowledge of the C layer when dealing with the GNU
debugger. Don’t worry though, the generated C code actually contains comment
lines that allow for a fairly easy conversion from COBOL source line to C
source line, and from COBOL identifiers to the C data names.
7.8 GMP¶
GNU MultiPrecision library, libgmp. A GNU subsystem that is used in support of COBOL friendly decimal arithmetic. See https://gmplib.org/ for complete details on the library advertised as Arithmetic without limitations.
7.9 ISAM¶
Indexed Sequential Access Method. A system to allow a variety of access methods for data records in file storage.
As a term of art, this document is fairly loose on the use of the acronym,
ISAM. Within the FAQ, ISAM is used as a generic word for indexed files,
record and key management. Technically, there is a lot more to it, and there
are many engines that support record/key stores in a wide variety of
implementations using a variety of base algorithms. For this document a loose
umbrella term of ISAM is used throughout; less technically accurate than
the subject deserves perhaps.
See https://en.wikipedia.org/wiki/ISAM for more details.
7.10 line sequential¶
An access method for newline terminated files. GnuCOBOL reads each line and strips off carriage returns and line feeds. Filling the record buffer with the current line and padding with spaces. Spaces trimmed on write.
A handy trick with LINE SEQUENTIAL access for getting the actual read length back is a VARYING FD clause. The DEPENDING ON field is set to the count of bytes input after each read.
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 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.
*> ***************************************************************
*>****
and given a testfile.txt of
abcdefghijklmnopqrstuvwxyz
abc
abcde
abc
abcdefghijklmnopqrstuvwxyz
results in
prompt$ cobc -x -g -debug -W readlen.cob
prompt$ ./readlen
026: abcdefghijklmnopqrstuvwxyz
003: abc
005: abcde
000:
026: abc
026: abcdefghijklmnopqrstuvwxyz
The second last line is space filled in testfile.txt. Some care must be
taken to enure the depending on field is set to an appropriate value for
writes. The FD clause can also be shortened.
fd testfile record varying depending on tracking-field.
7.11 APT¶
Advanced Package Tool. One of the strengths of the Debian GNU/Linux system. Allows for dependency checked binary packages.
7.12 ROBODoc Support¶
Below is a sample of a configuration file for using ROBODoc with GnuCOBOL programs.
# 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
To be used with
$ robodoc --src program.cob --doc program --singlefile --rc robocob.rc
Producing a nice HTML file documenting the program using embedded ROBODoc comment line directives. See ROBODoc for more information.
See http://peoplecards.ca/cobweb/cobweb-gtk/ for the output generated
from the cobweb-gtk project sources using ROBODoc 4.99.42 and the
--cobol command line option.
7.13 cobol.vim¶
Many thanks to the good people at www.vim.org
" 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
7.14 make check listing¶
A make check from October 2013:
## --------------------------------------- ##
## 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
==================
7.15 ABI¶
Application Binary Interface. An acronym that covers the way object code is managed and the expectations of the run-time system. GnuCOBOL is at home in the “C” ABI.
- Link names are as expected.
- CALL arguments are stacked as expected for C programming.
- etc...
The C application binary interface allows GnuCOBOL to link with many, if not
all, existent C libraries. Defaulting to the C ABI does mean that small wrapper
source codes may be required for access to C++ runtimes, to inform the C++
linker to use extern "C" code handling.
7.16 Tectonics¶
I use the expression tectonics based on the definition below. It’s nerd slang, for describing the code building process. Using a lookup from the dict:// protocol bank of open servers:
"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]
Trying to infer that building with GnuCOBOL is rock solid and artistically pleasing. Ok fine, I mean wicked cool!.
7.17 Setting Locale¶
GnuCOBOL supports LC_ locale settings, during builds and with generated programs.
Languages are being translated, Dutch, French, German. Thanks to Jim Curry and Curry Adkins, (and Simon and others that worked hard on this), we have Spanish message support (along with English and Japanese)
Please note; this is compile and run-time messaging, not COBOL verb translation or change to COBOL syntax, just more inclusive human friendliness
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
7.18 GNU¶
GNU is Not Unix, one of the original recursive acronyms. GNU software leads the Free Software movement, and with the Linux kernel is a critical piece in the GNU/Linux operating system. See http://www.gnu.org/ for more details.
The developers of GnuCOBOL follow, as closely as possible, the GNU coding standards. http://www.gnu.org/prep/standards/
GnuCOBOL benefits greatly from integration with GNU tools, and the expression of freedoms within software development.
7.19 Performing FOREVER?¶
I asked on opencobol.org for some input, and an interesting conversation ensued. I’ve included most of the forum thread archive, to give a sense of various programmer styles and group thought processing. See FOREVER.
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
----------------------------------------------------------------
I found the thread a nice read. And to top it off, for me, Roger added a nice idiom in a separate thread for avoiding paragraphs and sections. Not FOREVER related, but a nice use for an “empty” inline PERFORM.
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
7.20 POSIX¶
An acronym first suggested by Richard Stallman for the IEEE specification for maintaining compatibility between operating systems. IEEE Std 1003.1-1988.
- POSIX
- Portable Operating System Interface
7.21 BITWISE¶
A COBOL source code solution to bit operations.
BITWISE.cbl
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.
and BWPARMS.cbl
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.
and a small demo program, with intentional errors.
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
Giving:
*
*** 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
*
This code has been in production use for a lot of years now; thanks to Paul for sharing.
7.22 Getting Started with esqlOC¶
By user ati on the SourceForge GnuCOBOL Discussion group:
We could successfully test esqlOC (by Sergey) for our system and would like to encourage others to give it a chance. So here it comes:
7.22.1 esqlOC example¶
The author of the system is Sergey Kashyrin: You can download it from: http://www.kiska.net/opencobol/esql/ It provides “Embedded SQL” for GnuCOBOL (formerly OpenCOBOL).
With Embedded SQL you can insert SQL commands into your COBOL program:
[...] *
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.
[...] *
7.22.2 What does this code do?¶
In a PERFORM-loop we count our iterations. For every iteration number hVar3=1,2,3 we try to select a row from the database table TestTab. If there was no error and if we found a row
- the value of column TestCol1 will be stored in the COBOL field hVar1
- the value of column TestCol2 will be stored in the COBOL field hVar2
and we can DISPLAY the values.
Your COBOL compiler won’t like the SQL part of the snippet. Therefore you need esqlOC, which translates code with “EXEC SQL” to “normal” COBOL code to make your compiler (GnuCOBOL of course) happy. This translation is called “precompilation”, so esqlOC is a precompiler for ESQL/COBOL. esqlOC comes with a runtime library (DLL) and needs the ODBC driver for your database of choice. It is programmed in C++ with MS Visual Studio but should be portable to other compilers.
7.22.3 And this works with which database systems?¶
This should work with every serious database system (Definition serious database system: One, which has an ODBC driver.)
It worked with MS-SQL, MySQL, IBM-DB2.
Sergey made some valuable choices:
First: Embedded SQL Embedded SQL is an ISO/IEC standard: If you have to change your precompiler, you can keep most of your ESQL/COBOL code. Besides: Existing ESQL/COBOL code can be ported to GnuCOBOL.
Second: ODBC ODBC is an ISO/IEC standard: If you have to change your database system, you can keep your precompiler esqlOC.
Yes, we COBOL programmers learned the hard way not to get too dependent...
7.22.4 Does it really work?¶
After our tests for our system: YES. As always with software: You have to test and decide for your system.
- We have tested esqlOC with Visual Studio-2010/WinXP/MySQL:
- Load with ESQL/COBOL OpenCOBOL-Sequential file with 500 MB of data into 14 Tables with 412 columns. One of the tables has 132 columns.
- Unload with ESQL/COBOL all the data to a new OpenCOBOL-Sequential file.
- File compare: OpenCOBOL-Sequential files are identical.
- Run different ESQL/COBOL programs with millions of DB interactions up to 50 Minutes: Identical output files, no exceptions, no problems with memory leaks.
- We have successfully migrated 7 of our programs from files to DB.
7.22.5 Features¶
- Connection strings with a ODBC data source name (DSN) are possible, e. g.:
'youruser/yourpasswd@yourODBC_DSN'. - Using Connection strings without DSN you can set database specific connection parameters (see example below).
- Arbitrary Statements can be send to the database.
- Host variables can also be declared in the
LINKAGE SECTION. You can hide all your esql/COBOL code in sub programs. - Indicator Variables (NULL values) are supported. They must be declared as
"PIC S9(4) COMP-5" - Dynamic SQL is partly supported (see example below).
"EXEC SQL PREPARE"and"EXEC SQL DESCRIBE"are not supported. If you lookup the complex usage of these in COBOL, you won’t miss them. If you always know at compile time the number, type and length of your IN and OUT parameters (host variables) you don’t need them. Other ways you are invited to contribute to esqlOC, but it will be some work to do.- There is no programmatic limition (except sizeof(int)?) to the number of columns, number of host variables, length of data exchanged with the database.
- Connection parameters set OFF:
SQL_ATTR_CONNECTION_TIMEOUT, SQL_ATTR_AUTOCOMMIT
7.22.6 Getting started with esqlOC (WinXP, MySQL, “OpenCOBOL 1.1” build by Sergey)¶
GnuCOBOL You can get Binaries from: http://www.kiska.net/opencobol/1.1/index.html We use this version: “Win32 Windows (32-bit) VS2008” We unzip to:
c:\OpenCobol_bin\esqlOC Download from: http://www.kiska.net/opencobol/esql/binaries.zip We unzip to:
c:\esqlOC\MySQL with ODBC drivers see: http://dev.mysql.com/doc/refman/5.6/en/windows-choosing-package.html
You can get an installer or a zip archive here: http://dev.mysql.com/downloads/mysql/
Using the installer server and ODBC driver can be installed. Using the zip archive you have to install die ODBC driver separately.
We install to:
%PROGRAMFILES%\MySQL5.6\ANSI-C Compiler We use Visual Studio 2010 Express (Visual Studio 2008 Express shoul also work). We install to the default path:
%PROGRAMFILES%\Microsoft Visual Studio 10.0\Save this example in a file: esqlOCGetStart1.sqb Look at the connection parameters and make changes.
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.
We store it in: c:\Temp\
- Precompile
c:\esqlOC\release\esqlOC.exe -static -o c:\Temp\esqlOCGetStart1.cob \
c:\Temp\esqlOCGetStart1.sqb
- Compile
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
- Execute
To create the schema “test”:
%PROGRAMFILES%\MySQL5.6\mysql-5.6.13-win32\bin\mysql -u youruser -p --host=localhost
--execute "CREATE DATABASE IF NOT EXISTS test;"
Execute program:
SET OC_RUNTIME=c:\OpenCobol_bin
SET esqlOC_RUNTIME=c:\esqlOC\release
set PATH=%OC_RUNTIME%;%esqlOC_RUNTIME%
c:\Temp\esqlOCGetStart1.exe
Output:
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:\~$
ati’s post modified for ReStructuredText
7.23 UDF¶
User Defined Function. See FUNCTION-ID for an example putting user defined functions to use.
This is a new paradigm in COBOL programming. It is now possible to deliver repositories of functions, that can provide code with less need to pre-allocate WORKING-STORAGE areas. For instance
ENVIRONMENT DIVISION.
configuration section.
repository.
function current-stock-price
function all intrinsic.
PROCEDURE DIVISION.
display current-stock-price("GOOG") end-display
doesn’t even need to know what type of data current-stock-price returns.
The result may be passed in a pipeline expressions, easing burdens on
application developers.
UDF will be a good thing for GnuCOBOL. cobc can include the
repositories from source code or DSO; let the sharing begin.
7.24 GUI¶
Graphical User Interface. GnuCOBOL is well suited to programming with GTK+, but more than capable of leveraging just about any GUI framework. Including the Java Advanced Window Toolkit through COBJAPI.
7.25 Elvis support for GnuCOBOL¶
Provides :display syntax mode support to the venerable, and feature rich,
elvis text editor.
# 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
7.26 FAQ¶
Frequently Asked Questions.
This file isn’t just a FAQ, it is more of a Stuff Some Guy Thinks You Should Know About GnuCOBOL document.
7.27 Hercules¶
A System/370, ESA/390 and z/Architecture emulator for personal computers.
Relevant to those wishing to practise mainframe skills at home. Due to changes in copyright laws of the time, there are versions of the MVS (and other) operating systems (circa 1970) available for personal use, as the code was deemed to have passed into the public domain. The public domain builds put together by enthusiasts include the UCOB COBOL compiler, and JCL engine for submitting COBOL jobs.
That, and much more, but mentioned here for the COBOL.
Windows users of Hercules will want to check out http://www.bsp-gmbh.com/hercules/index.shtml for operating system builds.
But I find http://www.jaymoseley.com/hercules/ a better place to start, when using Hercules with GNU/Linux, with instructions on bootstrapping MVS 3.8j. Jay’s tutorials are world class, and some of his code is used by permission in the entry for the REPORT reserved word.
See http://www.jaymoseley.com/hercules/compiling/cobolrw.htm when you want to come to grips with the GnuCOBOL ReportWriter features.
7.27.1 TK4-¶
Skipping ahead a little; Jay Moseley documented the steps for building up
functional operating systems for the Hercules emulator. A very nice Turnkey
system for MVS 3.8J was put togther by Volker Bandke, of BSP GmbH. 10 years
later Juergen Winkelmann put together OS/VS2 MVS 3.8j Service Level 8505,
Tur(n)key Level 4- Version 1.00, or TK4-, a new Turnkey system, but not a
continuation of TK#3 by Volker, so Juergen used TK4minus.
The JCL entry below documents a sample run through a sysgen’ed MVT 21.8; the listings here skip ahead to the later TK4- bundle from 2013, which built on the works of Turnkey #3 from 2002.
Starting TK4- is pretty straight forward.
cd to where the zip files were extracted, ~/tk4/, for
example.
Kick the system with
./mvs
and wait a little bit, until the console displays the TK4- banner page.
then
x3270 -model 3279-2-E -once 127.0.0.1 3270 &
to bring up a 3270 emulator. x3270 is pretty nice, but there are others.
You will likely need to send RESET, CLEAR when you first open the terminal. x3270 makes that easy with the little keyboard icon, and clearly labelled GUI buttons. The RESET, CLEAR clears the banner page and opens the LOGON screen.
The turnkey systems come loaded with
- IBMUSER (for emergency and recovery logins, password IBMPASS)
- HERC01 (system programmer access, password CUL8TR)
- HERC02 (another fully authorized user, password CUL8TR)
- HERCO3 (a regular user, password PASS4U)
- HERC04 (another user, password PASS4U)
After the logon, hit enter twice to get and then get passed the friendly fortune of the day message. Then a full blown TSO application layer is at the ready.
Using some of the features from Turnkey #3, the Jay Moseley tutorials, creating a batch job wasn’t too difficult.
Starting with a HELLO, WORLD COBOL example, then modifing some JCL
statements and using sub to netcat the file to the Hercules card
reader port, the following JCL stream was submitted:
//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
Which produced a printer listing (less the first line of First banner page info) ala:
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****
And Hercules console output of
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
And from what little I know of 1972 billing practises, I think that job
(without the printed paper) would have cost 0,16 charge units, converting
into some reasonable number of money units.
TK4- can be found at http://wotho.ethz.ch/tk4-/
7.28 JCL¶
Job Control Language
Batch job scripting, circa 1960, and still managing mainframes to this day.
https://en.wikipedia.org/wiki/Job_Control_Language
7.28.1 Hello, System/370 and MVT 21.8¶
The Hercules emulator, allows for practising JCL and ANS COBOL-68, UCOB, along with all the other nifty software that people have ported over to Hercules. The JCL below, from an era that pre-dates the tradition of Hello, world would have been punched on 80 column cards, and fed into to a card reader as a deck.
This is from Jay Moseley’s tutorial site, reprinted with permission.
//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
//
The // lines are Job Control Language statements, surrounding COBOL sequence numbered source code. The main step of the job is the ANS COBOL Compile, Link and Go module COBUCLG. HELLO, WORLD output would have been displayed on the operator’s console, and the system printer would detail the run. Lots of details. The summary output of this run is about 12 lines from the bottom of the listing.
//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
Produced using the Hercules emulator, running OS/360 MVT 21.8f, sourced at http://www.jaymoseley.com/hercules/install.htm
7.29 Kate¶
Kate is the KDE Advanced Text Editor and it has some nice features when it comes to GnuCOBOL development. Capable of a Vi input mode, this graphical based editor is a nice mix of modal editing power and gui.
Kate with a dark theme, using CTags to assist with a bulk change to a variable name.
7.29.1 cobol.xml¶
Here is a COBOL syntax highlighting file, posted to the OpenCOBOL mailing list
in 2007 by Bob Willan. Updated slightly for GnuCOBOL, and to be friendlier to
free format COBOL sources. This would be placed in
/usr/share/kde4/apps/katepart/syntax/cobol.xml (or similar directory,
depending on operating system setup). Then choose Tools->Mode->Sources->Cobol.
<?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="\*>" 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=""" context="double-Q-string"/>
<RegExpr attribute="String" String="z'"
context="single-Q-string"/>
<RegExpr attribute="String" String="z""
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]"[0-9a-fA-F]+""
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]"[0-9a-fA-F]+""
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="[\-+*/%\|\[\]\{\}=\!<>!^&~]"/>
<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="\*>" 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=""" 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;
-->
7.30 libpgsql.cob¶
Posted to opencobol.org back in 2009.
>>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.
And lsrecord.cpy
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).
7.31 Sample shortforms¶
Some of the samples in this FAQ use a short hand that places much of the COBOL boilerplate code in a copybook include file.
sample-template.cob
*> 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.
This sample replaces the :DATABOOK: and :CODEBOOK: pseudo-text with the actual working storage and procedure division lines required to make a working, compilable example.
#!/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
==
.
becomes the practical equivalent of
*> 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.
when passed to the compiler. The technical equivalent is quite a bit more complicated, as the GnuCOBOL text processing phase does more than a simple include, but there is an effective result equivalency.
The POSIX interpreter directive line:
#!/usr/local/bin/cobc -xj
invokes the compiler to produce a compiled binary and then execute the job. The
line is also effectively ignored by cobc. These samples can be processed
with either:
prompt$ cobc -xj tan-sample.cob
or:
prompt$ chmod +x tan-sample.cob
prompt$ ./tan-sample.cob
cobc and the POSIX shell are that smart.
The line-sequential-sample.cob template is used when samples require input
or/and output text files.
*> 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.
This template needs to be used with
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==
.
The data division has I/O fields for
- input-line and input-actual (for the length of the last read)
- output-line and output-actual (for setting a write length)
The procedure division has helper paragraphs for
- open-files (with status checks)
- close-files (with status checks)
- read-input (with status check)
- write-output (with status check)
- delete-output (as given by :OUTPUT-NAME:)
- soft-exception
- hard-exception
7.32 y2k¶
The Year 2000 problem.
Many COBOL programmers were tasked with scanning ALL source codes to ensure the calendar rollover from the second to third millennium (1999 to 2000) would not fail catastrophically, and result in fidiciary responsibilty claims against the individuals in charge of the world’s computer systems.
This was due to the common human practise of using two digit years, and assuming the current century. Computer programmers followed this same convention for many decades and financial (and other) digital records held that same shortform. Financial calculations would fail when the two digit year rolled past 99, back to 00. This became known as Y2K and it was a costly problem. Almost all source code had to be inventoried, and possibly corrected, to ensure compliance with safe rollover from 1999 to 2000.
A similar issue will reappear in 2038. This time C programmers will be tasked with looking though source codes, as the historical 4 byte “epoch” integer seconds rolls over, back to 0, from when it was set counting from January 1st, 1970. In this author’s opinion, this is likely a far more insidious problem. It will be much harder to pinpoint who to sue for fidiciary responsibility, so the epoch problem will likely have much less legal department pressure on ensuring fixes are in place before the clocks do hit the roll over condition. Instead of bank reports failing, it will be embedded computer clocks and timers failing. What may happen then, is up to the future.
This rollover issue occurs at 03:14:08 UTC on 19 January 2038. GnuCOBOL systems are potentially at risk of failure during this time interval if they are still using 32bit time fields in the C libraries underlying libcob run-time support, even if libcob.so itself looks correct. Where y2k was mostly an application problem, the year 2038 epoch problem starts much deeper in the software stack, at the operating system level, and then up into application programs. There will be money to be made for people that understand the epoch problem, and there will, sadly, be money to be fleeced from those that do not understand well enough to protect themselves from unscrupulous or ill-informed developers.
7.33 Quine¶
A quine is a non-empty computer program which takes no input and produces a copy of its own source code as its only output. The standard terms for these programs in the computability theory and computer science literature are “self-replicating programs”, “self-reproducing programs”, and “self-copying programs”.
For example:
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.
And a sample run
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.
And a small proof:
prompt$ cobc -xj quine.cob | diff quine.cob -
prompt$
There was no real attempt to make this sample as small as it could be. Free format source would help, as would removing the identification division comment words. Shortening some of the names would also lower the character count.
So, a challenge was posted to the SourceForge forums, and a much shorter verion came up as:
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).
Courtesy of Simon and Bill. Self referential COBOL programming.
And then they came up with a one liner, 150 bytes.
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.
Due to page width limitations, the listing is split here. To recreate the
real thing, there is one space between 78 c value and the second line
shown above. And a small proof:
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$
No diff output. And:
$ ./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.
Nice. And again, listing split into 2 lines.
See Does GnuCOBOL work with shell scripting? for an alernative sample that isn’t really a Quine, but is another form of self replicating code. The scripting sample breaks the rules of a true Quine: it uses more than one progamming language and reads external data to achieve the replication effect.
7.34 bubble-cobol.tcl¶
The changes made to bubble-generator.tcl used to produce the GnuCOBOL syntax diagrams:
--- bubble-generator.tcl
+++ 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>"
All credits due to Dr. Richard Hipp, from work he did to produce the diagrams used for the SQLite project.
And the data file:
# 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}
}
}
7.35 Rosetta Code¶
There is a programming chrestomathy web site, http://rosettacode.org, chock full of programming language solutions to many different problems. The site objective is to present many different solutions to many different tasks, to demonstrate how programming languages are similar and different. The site boasts close to 1,000 programming tasks, with solutions shown in many of the over 600 programming languages documented on the site (as of June 2016).
- chrestomathy
- a collection of choice literary passages, used especially as an aid in learning a subject.
COBOL has over 200 task solutions listed, in an ever growing list of entries.
http://rosettacode.org/wiki/Category:COBOL
The range of tasks can provide good hints on how to solve many different programming problems. As a generic site meant to cover as many languages and language features as possible, Rosetta Code tends to be more Computer Science than the stock and trade Computer Business that COBOL is famous for, but there is still a lot to learn when reading through the site pages.
Aside from tasks that demonstrate the basics (there are many of these on the Rosetta Code site; variables, loops, conditionals, literals, etc) examples include:
- Anagrams
- Playing Cards
- Sorting
- IBAN
- hundreds more
7.36 cobweb-periodic listing¶
Periodic table of the elements as GTK+ buttons. Old code, and it should be
rewritten to take advantage of the cobweb-gtk function repository, and
PROCEDURE DIVISION RETURNING OMITTED for the callback handlers.
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.
And the elements.txt data
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]
7.37 GnuCOBOL FAQ feedback¶
You are invited to make suggestions, point out mistakes, and add general comments regarding this document, in a special thread in the GnuCOBOL project space, set up for just that purpose, at
http://sourceforge.net/p/open-cobol/discussion/contrib/thread/c67ea739
You can also contact the author via email at btiffin@users.sourceforge.net
8 Authors¶
| [Keisuke] | (1, 2) Keisuke Nishida Initial developer and creator of OpenCOBOL. From the 1990s through 2004, and still active was the primary developer and GnuCOBOL project lead. His efforts are greatly appreciated by the userbase of GnuCOBOL. |
| [Roger] | (1, 2, 3, 4, 5, 6, 7, 8) Roger While (1950-2015) GnuCOBOL 2.0 is currently (January 2016) in development, based on Roger’s excellent work and leadership with releases up to 2.0. |
| [Ron] | (1, 2) Ron Norman Ron added Report Writer features to GnuCOBOL 2, under the branches/reportwriter SVN subdirectory. |
| [Joe] | Joe Robbins Joe is tweaking the fileio.c code base. |
| [Sergey] | (1, 2) Sergey Kashyrin Sergey supports many platform builds, authored esqlOC, and the C++ emitting version of GnuCOBOL 2.0. |
| [human] | (1, 2, 3) Simon Sobisch The GnuCOBOL project lead, officially as of 2014, though he had, for all intents and purposes, been filling the role admirably for some many years prior. Samples, style, manager of the SoureForge code repositories and a GNU maintainer responsible for the GnuCOBOL project. |
| [Philipp] | Philipp Böhme Source changes increasing Windows build support. |
| [Hart] | Edward Hart Patches filling out the feature set. |
| [vince] | Vincent Coen CobXRef author, an external source code cross reference utility accessible
via |
| [btiffin] | Brian Tiffin This FAQ. Sample programs for GnuCOBOL. Compiler patches. GNU Maintainer, along with Simon. |
8.1 Maintainers and Contributors¶
| [aoirthoir] | (1, 2) Joseph James Frantz Hosting, support |
| [woodger] | Bill Woodger Moderating the forge |
| [John] | (1, 2) John Ellis Samples, how-to’s and advice |
| [wmklein] | (1, 2, 3, 4) Bill Klein Keeper of the COBOL FAQ and all round COBOL myth buster |
Robert added macro processing, László added Java API and science, Steve adding general processing and nifty world data analysis. Paul contributed BITWISE, and a very nice Computus solution. James raised the issue of the IN ORDER default as something to be aware of when checking GnuCOBOL against other COBOL compiler SORT routines.
Arnold Trembley put together the MinGW installer.
Colin Duquesnoy writes the OpenCOBOLIDE interactive development environment.
Many names missing.
9 ChangeLog¶
- 03-Jul-2016, 05-Jul, 09-Jul, 11-Jul, 12-Jul, 17-Jul, 19-Jul, 20-Jul, 21-Jul
- Adding CBL_OC_SOCKET entry. Added Haxe/Neko entry. Updated haXe/Neko. Added cobweb-periodic listing. Updated Jim Currey’s prime search results, added -j blurb in the initial how does cobc work section. Re-ordered special-names before repository in all listings. Add details for COB_SYNC. Started adding a list of known bugs, touched on COPY REPLACING. Added sample of variable length sequential file processing, corrected code fragment in FROM entry that contained a missing scope terminator, added printable characters entry. Updated INTO, added card punch image, various tweaks. Updated GNU Lighting entry.
- 03-Jun-2016, 07-Jun, 14-Jun, 16-Jun, 17-Jun, 18-Jun, 28-Jun
- Added future of COBOL entry. Clarified need for smjs libraries and development headers for the spidermonkey javascript linkage sample. Expanded on FUNCTION RANDOM. Updated 2.0 –help and –info listings, added Rosetta Code blurb. Lots of small updates to reserved words. Added PARI/GP sample, added initial gretl integration example. Added FastCGI blurb, expanded on JRecord entry, added Unicon entry.
- 18-May-2016, 22-May
- Touch ups, ADD CORRESPONDING. lynda.com video tutorials by Peggy Fisher, jaymoseley.com.
- 03-Apr-2016, 07-Apr, 08-Apr, 13-Apr, 14-Apr, 15-Apr, 25-Apr, 29-Apr, 30-Apr
- Fixed missing ADDRESS OF in OMITTED word reference code example. Added Red integration entry, updated CBL_OC_HOSTED with timezone, updated entry on void returns with a yes answer, added signal handling entry. Updated signal entry with sigaction sample. Added link to feedback in the top sidebar, added X11 samples. Updated D-Bus entry, added details for the various computational data types. Continue comp data details. Add some performance analysis blurbs, added CDF ENDIAN and CHARSET. Added code sample to REWRITE, expanded on SEQUENTIAL.
- 12-Mar-2016, 15-Mar, 22-Mar, 24-Mar, 26-Mar, 27-Mar, 28-Mar
- Adding JRecord info, updated Python with proper DECREF. Added DB2sample by László. Updated out of tree build blurb with shell function. Clarify where split key isam support is available, add Piet. Added D-Bus. Added embedded TCC, and deadfish. Added mention of CBL_OC_HOSTED.
- 01-Feb-2016, 02-Feb, 06-Feb, 07-Feb, 08-Feb, 21-Feb
- More diagrams. Finished first pass of syntax diagrams, added motto.cob and suggested a new acronym in Common Objective Business Oriented Language. Added VBISAM blurb, finally moved FILE STATUS codes out of the ISAM note and into main FILE entry, added checkfilestatus callable by Steve Williams, tweaked FILLER entry, started hyping more Fossil, fixing up new version of highlighter, Roger passed away one year ago, today. Added Icon. SET ATTRIBUTE is supported. Started in on typo hunting.
- 14-Jan-2016, 19-Jan, 21-Jan, 29-Jan, 30-Jan, 31-Jan
- Move gcfaq.rst link to SourceForge. Added JNA Java entry by Gary Cowell. Added blurb from Steve’s Simple ODBC sample. Typo corrections, and JNA run sample. Started adding syntax diagrams (from http://wiki.tcl.tk/21708), update to Sphinx 1.3.5 to get PDf table of contents back, tweaks. Adding more syntax diagrams, filled out entries for ROUNDED MODEs, tweaks, fixed Tcl, Rexx and Makefile highlighters (added > recipe prefix to the highlighter for make), semi-colon to Rexx and hex numerics with octothorpe for Tcl, added some details to LINAGE reserved words.
- 16-Dec-2015, 17-Dec, 19-Dec, 23-Dec
- Expanded on some reserved words, added shell scripting entry, added Quine, expanded on ocesql entry. Added a shorter Quine, added mruby. Added some Mac/OS info from Martin. Expand on float-decimal-16 and -34, tweak some reserved word entries, add some commentary from users. Tweak decimal-34, added Ghostscript embedding. Update installing entry.
- 01-Dec-2015, 02-Dec, 04-Dec, 06-Dec, 08-Dec, 09-Dec, 10-Dec, 11-Dec, 13-Dec
- Adding news from Jim on the prime number scan, expanded on link module entry, expanded on FUNCTION STORED-CHAR-LENGTH. Updated FORMATTED-DATE and TIME function entries, fill in Falcon PL entry. Another linkcheck pass. Correction to CLASS and extend CHARACTERS, update Hercules url, Changed the Intrinsic function indexed table, added sample to SUBSTITUTE-CASE. Added TAN, TEST-DATE-YYYYMMDD, TEST-DAY-YYYYDDD sample, Samples shortform note, y2k and 2038 blurb. Expanded on ACOS, ASIN, ATAN, COS, SIN, DATE-OF-INTEGER. Added sysinfo. Expanded on TEST-NUMVAL-C and TEST-NUMVAL-F, started in on CBL_OC_GETOPT (the routine needs work), blurb on supported literals. Expanded on ZERO, YYYYMMDD.
- 02-Nov-2015, 10-Nov, 11-Nov, 13-Nov, 14-Nov, 15-Nov, 16-Nov, 24-Nov, 27-Nov
- Finding link modules entry and –no-as-needed. Added ESCDELAY blurb, added READY, TRACE, and expanded on RESET, added Bill’s aligning tip, and touched on 32 bit/64 bit determination. Rememberance Day in Canada, where we observe two minutes of silence on 11/11 at 11:00 to honour those that have fought, and those that have fallen; Lest we forget. Updating the overflowing.cob sample run. Explain -A cobc option, add cpuid.cob. Added .RECIPEPREFIX to Makefile listings, update SIZE, SENTENCE, and SEPARATE entries. Added raw latex code to resize code listings. Remove the line size debug paragraph. Fixed currency symbol link and added to PICTURE entry. Added GNU lightning to the assembler entry, update SQL entry with more Oracle 12.1 info thanks to Reinhard Prehofer, added HPCC entry by Jim Currey, fixing opencobol.org links, added libpgsql full listing.
- 03-Oct-2015, 10-Oct, 15-Oct, 17-Oct, 18-Oct, 21-Oct, 26-Oct, 28-Oct, 29-Oct
- Added SWIG. Updated assembler sample. Updated Can I help. Tweaked SMCUP/RMCUP entry, started adding Micro Focus port issues from James, corrected Makefile contract-swig.i in the SWIG entry, added ROUNDED MODE examples table, temporarily removed Micro Focus entry. Added >>DISPLAY to compiler directives blurb, added Open Object Rexx listing, added COB_MAX_FIELD_SIZE to run-time limits entry. Updated ooRexx listings to reflect new function rexx(), added sample to GLOBAL entry. Updated ACCESS, COLUMN, LINE, and WHEN-COMPILED entries, added entry for getting lengths with LINE SEQUENTIAL reads and writes, added samples to GO and ALTER, with some commentary from Bill. Add more commentary, some from Simon, added small s.c.r.i.p.t., start in on purging extraneous END-DISPLAY and some other explicit but cluttering END-words.
- 03-Sep-2015, 05-Sep, 06-Sep, 12-Sep, 22-Sep
- Clarified that STOP literal is a temporary stop. Fixed banner yellow with convert gcbanner.png -fuzz 5% -fill ‘#ffffee’ -opaque ‘#f2efc2’ new.png. convert new.png -bordercolor ‘#ddddbb’ newer.png. Started new Production chapter (mostly empty for now, will list details). Adding to reserved word samples. Added Kate.
- 15-Aug-2015, 18-Aug, 21-Aug, 22-Aug
- Added blurb about Ionică Bizău’s NodeJS bridge, tweaked some name indexes. Added a picture of Grace Hopper, linked an ARS Technica article about node-cobol, updated some jokes. Added László’s complete cgiform sample. Added cobol-unit-test blurb, by Dave Nicoletter, general cleanup of PDF by not putting in large index sidebars, vs.py types and colours tweaked, added some reserved words along with a list of words when generating Latex and PDF outputs.
- 04-Jul-2015, 07-Jul, 08-Jul, 09-Jul, 14-Jul, 18-Jul, 20-Jul, 24-Jul
- Update 3.20 to ACCEPT OMITTED, mention table sort when describing IN ORDER. Added a D interface blurb, Started in on data level numbers, corrected the wording of CONSTANT. CSS fix for toc, highlight colour updates in vs.py, added runtime.cfg notes, more debugging of business.py lexer, updated the dedication. Updated Intrinsic list, fixed highlighter, added links to tutotialspoint COBOL courseware, and more mention of the Hercules System/370 emulator. Added Bill’s warning about tutorialspoint and added the University of Limerick pages as a better learning option, more name dropping in the credits, updated MinGW and ROBODoc info. Added Hercules, JCL listings. Adding TK4- to the MVS 3.8J information. Corrected APL inventor as Ken Iverson, not Eric, his son. Added code sample to line sequential note. Added CBL_READ_FILE sample. Fleshed out VARYING and WAIT entries.
- 02-Jun-2015, 07-Jun, 16-Jun, 17-Jun, 23-Jun, 27-Jun
- Some clarifications and corrections regarding versions and build instructions, shortened some SWITCH and SW lists and indexes, corrected mismatch in cobolmac macro and the listed expansion. Added mention of OpenCOBOLIDE 4.6.2 and it including a MinGW 1.1 build Simon posted. Updated the COPY book search path entry, credits, and some cheerleading. Admit to the mythical Someday, added assembler linkage question, update FAQ banner to GnuCOBOL spelling, added Sire (unofficial fan art). Tweak banner and update credits. Added note about IN ORDER being a default in the SORT verb blurb.
- 22-May-2015, 28-May, 30-May
- Update CALL, minor spelling and wording corrections. Filled out COPY, added cobolmac macro preprocessor notes, added prime numbers with Proth, added split key listing in indexing.cob sample. Purged references to 2.1 in preference to reportwriter branch.
- 05-Apr-2015, 09-Apr, 10-Apr, 23-Apr, 25-Apr, 26-Apr
- Fixed some unicode for latexpdf build. Adding COBJAPI. Added elvis blurb and GnuCOBOL color syntax file, added cobweb-pipes. Still winter, April, winter. Corrected the OCSort entry. Added to OCSort entry from Bill Woodger, ran linkcheck and fixed some stales. Added some hyperlinks.
- 07-Mar-2015, 11-Mar
- Added the predefined >>IF ... IS SET directive conditionals, including OPENCOBOL, P64, EXECUTABLE, MODULE, more; added LC_MESSAGES blurb to the notes; expanded on GNU a little; marking more extensionsr; tweaked test suite entry. Update to translationproject.org link.
- 09-Feb-2015
Dedicated to Roger While (1950-2015). “The time has come”, dear friend.
The sea was wet as wet could be, The sands were dry as dry. You could not see a cloud, because No cloud was in the sky: No birds were flying overhead– There were no birds to fly.- 03-Feb-2015, 07-Feb, 10-Feb, 12-Feb
- Roger’s update to the telco billing module. Added Nim, tweaks to rmcup/smcup. Borked Sphinx and Pygments install, fixed. Added meta tags, corrected the 20xx draft references to proper 2014.
- 16-Jan-2015, 17-Jan, 18-Jan, 26-Jan, 29-Jan
- Added some run time environment variable blurbs, started genindex. Indexing, merged authors and contributors. More indexing. Typos. Simon’s awesome 1.1 delta lists. Added CentOS.
- 02-Dec-2014, 12-Dec, 16-Dec, 27-Dec
- Corrected slangkey; moved tty-reset to a proper procedure division, dropped hints in errorproc.cob. GNUCobol to GnuCOBOL. Added info to ALLOCATE and DELETE FILE, added libseed-gtk sample. Typo, added a personal blurb about production use, warning about abusing dev/urandom in Jim/TCL. Added to ACCEPT and PROHIBITED.
- 11-Nov-2014, 12-Nov, 18-Nov, 20-Nov
- Added the motto. New GnuCOBOL 1.1 MinGW installer. Added STDCALL. Added BaCon.
- 12-Oct-2014, 21-Oct
- Updated the Can I help out blurb, added a SourceForge six tilde markup example. Version 42, 2.1.42, on 1021 2014, 42, fixed some BINARY-LONG docs.
- 04-Sep-2014, 05-Sep, 10-Sep, 15-Sep, 22-Sep, 25-Sep
- Added some missing 2.0 intrinsic functions, and reserved words. List updates (system.def) and other misc 2.0 updates. Missing commas and more on ROUNDED, touched COMPUTE, CONTINUE, CGI entry, renamed voidcall, endiannes. Updated pgcob.cob for clarity. GNU Cobol is now GnuCOBOL. Fixed some links, MinGW installer and s-lang.
- 14-Aug-2014, 15-Aug, 16-Aug, 17-Aug, 23-Aug, 29-Aug
- Turn 51, remove the no commerical support available statement, fix some formatting, add a new FUNCTION-ID teaser for GTK+. Added the Common Object Business Oriented Language possiblilty, added some COBOL is dead anti-rhetoric. Touch ups. Added sample for EXTERNAL. Included gccurlsym.cpy in the read-url FUNCTION-ID sample. Changed some wording around ENTRY in the error proc sample. Added telco billing code listing, links to vc11 windows native, fixed some https forge links. No vc12.
- 10-Jul-2014, 12-Jul, 16-Jul, 22-Jul
- Removed target from banner image, updated CobXRef entry. Added Perl sample. Added the platform port story, put in the acknowledgment, many small tweaks to things like ocobol to gcobol. Added GTK periodic buttons. Added news about COBOL 2014 being published back in May.
- 10-Jun-2014, 11-Jun, 21-Jun
- Adding jQuery to AJAX sample, updated MERGE entry and PACKED-DECIMAL. Added RLIB. Tweaks.
- 03-May-2014, 07-May, 17-May, 20-May, 24-May, 31-May
- Addded a blurb about null terminated strings, added example for compiler directives, added blurb on UDF. Bragged about MathGL some more, added printenv.cob and voidcall.c. Enumerated the build time and run time environment variables tested by ./configure ; make, cobc and libcob, changed Hello World! to Hello, world just because, tweaks and new 5-7-5, added Jim TCL. Added limits, reformatted for Pandoc (no tabs, less unicode) sourcecode directive changed to code, modified /usr/lib/python2.7/site-packages/sphinx/directives/code.py. Tweaks and small adds. Added wget tip for getting source from the forge, TRANSFORM. Moved Broadway image below TOC index.
- 15-Apr-2014, 16-Apr, 20-Apr, 25-Apr, 26-Apr
- Added Arnold’s INNO installer link. Fleshed out some entries, added FUNCTION-ID sample. Typos, more color, libmicrohttpd sample. Updated NUMERIC entry, touched on ACCEPT. Odds and sods.
- 04-Mar-2014, 15-Mar, 29-Mar
- More typos. More typos. Still winter, updated development history blurb, added head-full.cob skeleton, added OpenCOBOLIDE link, March 29th and still winter.
- 28-Feb-2014
- Better credits and typo fixes.
- 04-Jan-2014, 28-Jan
- Added the DB2 link from Dick Rietveld. Updated the indexing.cob sample, updated docs on cobcrun.
- 04-Dec-2013
- Updated some credits. Added Ron as an author. More Simon credits.
- 13-Nov-2013, 23-Nov, 27-Nov
- Added esqlOC article by ati from SourceForge, more credits for Sergey. Clarified Rexx sample with a new variable instead of sharing. Added first hint of Report Writer support by Ron Norman. Example by Jay Moseley. Started mentioning reportwriter.
- 23-Oct-2013
- GnuCOBOL FAQ now. Updated CGI sample.
- 11-Oct-2013
- OpenCOBOL FAQ finalized at 1.1.
- 25-Aug-2013, 27-Aug
- Updated the EXEC SQL entry. Filled out FILLER, FILE, FILE-ID and FALSE.
- 03-Jul-2013, 19-Jul-2013
- Added Pure embedding sample. Cleaned up some sourcecode types, got rid of warnings. Wim’s stickleback project.
- 08-Jun-2013, 11-Jun-2013
- Added the missing tests blurb for NIST, some corrections. Added more open source COBOL project links. Added SMCUP, RMCUP terminfo blurb. Fixes.
- 15-May-2013, 29-May
- Added BITWISE from Paul Chandler. Started list of open source projects. Tweaked the development history, fixed Fossil image placement.
- 30-Mar-2013
- Added another haiku (using cbrain).
- 08-Feb-2013, 09-Feb, 25-Feb, 26-Feb
- Moving to Sphinx, started documenting new SourceForge project site. Fixed cobxref listing, no truncated lines. Added ‘nosidebar’ to the sphinx-doc theme settings in conf.py. Added some Computus, and Latin. Updating current version information. Added Python embedding. Added ficl Forth notes. Added Shakespeare. Touched on ocsort. Reversed the ChangeLog order with tac -r -s “^$”. Moved the Sphinx output to main. Added Ruby.
- 03-Jun-2012
- Added site favicon.ico from Silk/help.png, credited Mark James. Fleshed out telco benchmark entry.
- 27-May-2012
- Added LLVM and clang reference.
- 22-Apr-2012
- Typos. Added the size listing for hello.
- 07-Mar-2012, 19-Mar
- Added carpe diem farberistic joke.
- 05-Feb-2012, 29-Feb
- Added to DIVIDE, put in some lists in the RESERVED words. Added Public Accounting.
- 12-Jan-2012, 14-Jan, 15-Jan, 20-Jan
- Added a criticism of easter.cob. Updated CURSOR and FOREVER entries. Version to 1.1rc01. FOREVER thread listing moved. cupsPrintFile documented. Rid of the >< comment output. LOCALE-DATE update. Removed Organization from attributions, there is no official group.
- 06-Dec-2011, 26-Dec-2011
- Added Gambas interface link. Fixed INDEXED entry. Added INITIAL source sample.
- 03-Sep-2011, 25-Sep, 28-Sep
- Fixed the ocgtk.c files, getting rid of void returns. Updated list of platforms with 1.1pre-rel running. Added COBOLUnit.
- 26-Aug-2011
- Finished the last FUNCTION.
- 01-Aug-2011, 05-Aug, 06-Aug, 07-Aug, 08-Aug, 09-Aug, 13-Aug, 14-Aug, 22-Aug
- Done M, N. Done O. Fixed the colours after a Pygments update. P’s in. Q, R done. Doing S. Just passed 750000 bytes of FAQ. Done S to Z. Started documenting the GNU build tool options available. Fixed a DSO misnomer.
- 01-Jul-2011, 02-Jul, 10-Jul, 11-Jul, 12-Jul, 20-Jul, 23-Jul
- Updated CALL reserved word entry to show off ON EXCEPTION CONTINUE. Updated a few more reserved words; DATE, DAY, DEBUGGING. D’s are done. Fleshed out a few reserved words, E’s done. Added links to the Doxygen API passes. Started on some future 2.0 entries with the Directives. Added blurb about LD_RUN_PATH. Added initial entry on APL/J linkage. Into the Fs. Done A thru K. Done L.
- 25-Jun-2011, 26-Jun
- Added sourceforge link. Updated shortest program entries. Updated a few reserved words.
- 07-May-2011
- Added gfortran sample.
- 13-Feb-2011
- Fixed an unnecessary css import, small corrections. Added REPOSITORY, CYCLE and FOREVER entries.
- 02-Jan-2011, 23-Jan
- Added errorproc.cob sample. Added some vim and Fossil info.
- 12-Dec-2010, 31-Dec
- Added libsoup HTTP server sample. Changed EOP file status 52 copy sample. Updated Falcon entry.
- 01-Nov-2010, 06-Nov, 18-Nov, 20-Nov, 27-Nov
- Added a Genie sample. Some small touch-ups. Restored borked colouring. Added DECLARATIVES entry and a few small tweaks. Added a few RESERVED words entries. Added ROOT/CINT info. Expanded install instructions.
- 18-Oct-2010, 19-Oct, 24-Oct, 30-Oct, 31-Oct
- Added some working Vala code samples. Added DamonH’s AJAX code to the CGI section. Updated the CBL_OC_DUMP listings. Added a few minor reserved word entries. Added translation help request note. Added mkfifo sample. Added call Genie sample. Added CBL_OC_GTKHTML sample. Updated the PI and PRESENT-VALUE entries. Updated CHARACTERS entry.
- 13-Jun-2010
- Reorganized table of contents boxes. Split SEARCH sample source code.
- 05-May-2010, 06-May
- Added the SEARCH and SORT sample. Updated Rexx. Image for GNAT GPS.
- 04-Apr-2010, 05-Apr, 11-Apr, 15-Apr
- Fixed up the source code listings. Added telco benchmark. Added print to PDF. Added COB_LIBRARY_PATH info. Expanded the Tcl/Tk entry. Added Mac install instructions from Ganymede. Rexx.
- 01-Mar-2010, 28-Mar
- Added Oracle procob news. Added FILE STATUS codes to ISAM note. Mention TP-COBOL-DEBUGGER. Updated INSPECT sample and COB_SCREEN_ESC entry. Added ocgtk.c
- 15-Feb-2010, 20-Feb, 25-Feb, 27-Feb, 28-Feb
- Added advocacy, and a few tweaks. Added Jim’s PRTCBL. Added Angus’ ocsort. Added cobol.vim and Easter Day programs. Updated CBL_OC_DUMP source code listing. Added a REPLACE text preprocessor sample. Added pgcob.cob PostgreSQL sample.
- 12-Oct-2009
- Added some links, credits.
- 13-Sep-2009
- Some printing information.
- 29-Jul-2009
- more human assisted corrections.
- 01-Jun-2009, 03-Jun, 05-Jun, 28-Jun
- Added errno, makefile, a few samples and some reserved word explanations. Added filter.cob the stdin stdout sample. Added some reserved word blurbs and the message queue sample. human assisted corrections. Many thanks to human.
- 01-May-2009, 09-May, 28-May, 31-May
- Started a structural and TOC reorg. Mention S-Lang. Continue re-org. Added some FUNCTION samples. Getting close to a complete Intrinsic list.
- 17-Apr-2009, 18-Apr, 19-Apr
- Clarified -fsource-location option. Added a production use posting. Added START and ISAM sample.
- 09-Mar-2009, 31-Mar
- Added Vala and a few more RESERVED word entries. Added -ext clarification.
- 16-Feb-2009, 18-Feb
- Added JavaScript, Lua, Guile embedding samples and mention Tcl/Tk, GTK. Added CBL_OC_DUMP sample by Asger Kjelstrup and human
- 02-Feb-2009, 06-Feb, 09-Feb, 11-Feb
- Coloured Source codes. Added info on COB_PRE_LOAD, added LINAGE sample, fixed colours (kinda). Added Haiku, disclaimer about no claim to Standards conformance. Updated look.
- 01-Jan-2009, 10-Jan, 12-Jan, 22-Jan
- Lame attempt at clarifying (excusing) poor use of Standards references. Small corrections and additions to SQL entry. Added a few RESERVED entries and Vincent’s STOCK library expansion. Typos.
- 28-Dec-2008, 29-Dec, 30-Dec
- Added info on CobXRef, some debugging tricks and an entry on recursion.
- 12-Dec-2008, 16-Dec, 21-Dec
- Added new links to OpenCOBOL 1.1 binary builds by Sergey. Updated header templates. Added a few keywords.
- 28-Nov-2008
- OpenCOBOL passes the NIST test suite.
- 13-Oct-2008, 15-Oct,19-Oct, 22-Oct, 29-Oct
- Added a few samples. Added TABLE SORT sample. Added configure script information. Added dialect configuration information.
- 23-Sep-2008
- Adds and a trial skin
- 10-Aug-2008, 21-Aug, 28-Aug, 29-Aug, 30-Aug
- Started in on the intrinsic functions. Dropped the pre from the alpha designation. Still some Look into this entries. Move to add1tocobol.com Publish link to 1.0rc Skeleton of the reserved words list Let the tweaking begin
- 17-Jul-2008, 20-Jul, 24-Jul, 28-Jul
- Last-last-last 0.0 pre-alpha. Second DIFF. Corrections pass. Expanded the SCREEN SECTION questions. Another correction pass, with clarifications from Roger While
- 02-Jul-2008, 06-Jul, 07-Jul, 11-Jul, 13-Jul
- Experimental version for comment. First 0.0 pre-alpha release. Second 0.0 pre-alpha. Last 0.0 pre-alpha. Checked in for diffs. Last-last 0.0 pre-alpha. Verify DIFF functionality.