Inside COBOL #11
by
Shawn M. Gordon
President S.M.Gordon & Associates
We are in luck this month, I have gotten some more enticing tips from an avid COBOL fan, and reader of this column. Thanks to John Zoltak for providing some of this month’s tips. I spoke with John and he has many years of experience using many different languages. He was a great example of using the right language for the job, and not just the language of the month. His first tip concerns something we have talked about a couple of times, and that is how to call one macro from within another. I must admit to feeling a little foolish, because I have tried this in the past and it didn’t work. However this technique doesn’t work if you want to pass parameters, we went over the technique for doing that a few months ago.
Anyway, here is just a very simple example of non-parameter macros that can be called from within each other.
PROCEDURE DIVISION.
$DEFINE %M1=
DISPLAY "IN M1"#
$DEFINE %M2=
DISPLAY "IN M2"
%M1#
A1000-INIT.
%M2.
The output looks like this.
IN M2
IN M1
A few months ago I showed you how to do a little bubble sort in your program so you could sort tables or other small amounts of data easily. Well John has sent me a copy of a Shell Sort Macro that he has come up with that is a much quicker and more efficient sort. So it is with great pleasure I present it to you in all it’s glory, from here until further notice, all the text will be Johns.
COPY SORTDEF.
When I want to sort the array I use
MOVE number-of-elements to N-SUB.
%SORTTABLE(TABLE-NAME#, HOLD-AREA#).
It uses the shell sort, faster than a bubble. Also since it's a macro, I can sort on any table. The only real constraint is that it compares the whole table element, so you just have to arrange your table element so it sort's the way you want.
* SHELL SORT ROUTINE
*
* This macro expects parameter 1 to be the element of the
* table to be sorted. This sort compares the entire element.
* Parameter 2 is the element hold area. Can be a higher
* element of the table if you wish.
*
* To use this sort macro, you must COPY it into your program
* in the 77 LEVEL area. Four (4) variables will be declared
* and the $DEFINE for %SORTTABLE will be defined.
*
* Before invoking this macro you must set N-SUB to the
* highest table element to be sorted.
77 I-SUB PIC S9(4) COMP.
77 J-SUB PIC S9(4) COMP.
77 M-SUB PIC S9(4) COMP.
77 N-SUB PIC S9(4) COMP.
$DEFINE %SORTTABLE=
IF N-SUB <> 1
MOVE N-SUB TO M-SUB
PERFORM TEST AFTER UNTIL M-SUB = 1
DIVIDE 2 INTO M-SUB
ADD 1 TO M-SUB GIVING I-SUB
PERFORM UNTIL I-SUB <> N-SUB
MOVE !1(I-SUB) TO !2
MOVE I-SUB TO J-SUB
SUBTRACT M-SUB FROM J-SUB GIVING TALLY
PERFORM UNTIL J-SUB <= M-SUB OR
!1(TALLY) <= !2
MOVE !1(TALLY) TO !1(J-SUB)
SUBTRACT M-SUB FROM J-SUB
SUBTRACT M-SUB FROM J-SUB GIVING TALLY
END-PERFORM
MOVE !2 TO !1(J-SUB)
ADD 1 TO I-SUB
END-PERFORM
END-PERFORM
END-IF#
Also, on stripping leading spaces. An easy way is this
77 BUF PIC X(30).
MOVE " THIS IS SOME TEXT" TO BUF.
INSPECT BUF TALLYING TALLY FOR LEADING SPACE.
MOVE BUF(TALLY + 1:) TO BUF.
DISPLAY ">" BUF "<".
Output looks like this
>THIS IS SOME TEXT <
Ok, I'm back now. You know what is interesting about John's example of
stripping leading spaces? It works, and it taught me a couple of
interesting things. First off, the variable TALLY doesn't need to be
declared in WORKING-STORAGE. I didn't know that you could do this, but
I am excited to find it out. It's almost like creating local variables.
The second interesting thing here is the final MOVE statement. He is
doing byte referencing to move the subset of the variable back on itself from the point where the spaces end. What may at first look like a mistake actually works, and that is that no byte amount for the move is specified, there is just the TALLY + 1:. I have to assume that this will move the rest of the string if a length isn't specified. So if we want to macro that would strip leading spaces it would be like this.
$DEFINE %STRIP=
INSPECT !1 TALLYING TALLY FOR LEADING SPACE
MOVE !1(TALLY + 1:) TO !1#
John also had a suggestion about a slight ongoing debate about the virtue of 88 level items between myself and Tom Cabanski in Interact magazine. Basically Tom gave several examples of why 88 level items were evil and hard to follow, and given his example he was right (see example below):
01 EOF-SWITCH PIC X(01) 88 ITS-EOF VALUE 'Y' 88 NOT-EOF VALUE 'N' READ FILE AT END MOVE 'Y' TO EOF-SWITCH IF ITS-EOF statements
In this context you don't really know what it takes for ITS-EOF to be true and how it got that way in any reasonably sized program. I agree with Tom on this point, however my solution was to change the MOVE 'Y' TO EOF-SWITCH statement to SET ITS-EOF TO TRUE. This works quite nicely, but Tom didn't like it because you could move any other value to EOF-SWITCH that didn't match any of the 88 levels that were defined.
There are two arguments against that complaint. First, if the programmer is so bad that they are moving values willy nilly into a variable that is to be used for 88 level switches, then they have no business programming, or their programming manager needs to do some serious training and hand slapping.
The second argument is a solution that John provided, and that is to take off the name of the 01 level variable (see below for example). This makes it impossible to do anything but set an 88 level to true. What this does is give COBOL an expanded BOOLEAN type variable. PASCAL has BOOLEAN variable types, and C will let you fake a BOOLEAN by using constants, but COBOL doesn't have an explicit BOOLEAN TYPE. I want to thank John for his input once again.
01 PIC X(01) 88 ITS-EOF VALUE 'Y' 88 NOT-EOF VALUE 'N' READ FILE AT END SET ITS-EOF TO TRUE. IF ITS-EOF statements
All of this just reinforces my opinion that coding style is a very subjective thing, and discussions on it need to be grouped in with politics and religion.
Ok, now on to a couple of tips from me. I want to talk about the two Pseudo-Intrinsics that HP supplies with the COBOL compiler. They might seem a little strange at first, but they can be very useful. The first one I want to talk about is the .LEN. pseudo-intrinsic. This will return the length of a variable. This can be handy for using various file system intrinsics such as PRINT, and FWRITE, as well as VPLUS instrinsics like VPUTBUFFER. Since these intrinsics require that you pass the length of the variable, using .LEN. allows you to create a macro or generic routine to call these intrinsics. Here is an example of VPUTBUFFER.
01 V-REC.
03 FIELD-1 PIC X(02).
03 FIELD-2 PIC X(10).
01 V-REC-LEN PIC S9(4) COMP.
PROCEDURE DIVISION.
CALL INTRINSIC ".LEN." USING V-REC GIVING V-REC-LEN.
CALL INTRINSIC "VPUTBUFFER" USING COMAREA, V-REC, V-REC-LEN.
That one is pretty straight forward, the next one I am going to show is
not as straight forward, but in my opinion it is far more useful. This
pseudo-intrinsic is named .LOC. and it will return a pointer to a
string address. How is this useful you may ask? well, read on.
Certain intrinsics such as GENMESSAGE, CREATEPROCESS, and MYCOMMAND
have parameters that require a pointer address. COBOL does not allow
you to explicitly declare pointers (one of the very few things that COBOL won't allow). So the only way to do it is with the .LOC. pseudo-intrinsic.
I am going to show you a code example that will use the CREATEPROCESS
intrinsic to pass an INFO string, an ENTRY point, an XL, and redirect both STDIN, and STDLIST. This is probably overkill for you, but it is pretty common to want to create another program with an INFO string. So take what you need and ignore the rest. I also apologize in advance if I happen to leave anything out of this process, I am stripping code
from one of my programs. This example is based on the Spectrum machines, some of these variable declarations have a different size on the Classic. Make sure to check your intrinsics manual.
01 XL-STRING PIC X(80) VALUE SPACES.
01 INFO-STRING PIC X(80) VALUE SPACES.
01 STDLIST.
03 PIC X(16) VALUE
"BMOUT;DEV=LP,1,1".
03 PIC X VALUE %15.
*
01 STDIN.
03 PIC X(06) VALUE "XSTDIN".
03 X-SEQ PIC 99 VALUE ZEROES.
03 PIC X(10) VALUE ",OLDTEMP".
03 PIC X VALUE %15.
*
01 PROCESS-HANDELING-DATA.
03 PROG-NAME PIC X(28) VALUE SPACES.
03 ENTRY-NAME PIC X(20) VALUE SPACES.
03 PIN PIC S9(4) COMP VALUE 0.
03 ERRORS PIC S9(9) COMP VALUE 0.
01 ITEMNUMS.
03 PIC S9(9) COMP VALUE 1.
03 PIC S9(9) COMP VALUE 2.
03 PIC S9(9) COMP VALUE 3.
03 PIC S9(9) COMP VALUE 8.
03 PIC S9(9) COMP VALUE 9.
03 PIC S9(9) COMP VALUE 10.
03 PIC S9(9) COMP VALUE 11.
03 PIC S9(9) COMP VALUE 12.
03 PIC S9(9) COMP VALUE 19.
03 PIC S9(9) COMP VALUE 24.
03 PIC S9(9) COMP VALUE 0.
*
01 ITEMS.
03 ENTRY-ADDRESS PIC S9(9) COMP.
03 PARM PIC S9(9) COMP VALUE 0.
03 LIB-SEARCH PIC S9(9) COMP VALUE 0.
88 LIB-S VALUE 0.
88 LIB-P VALUE 20.
88 LIB-G VALUE 40.
03 STDIN-ADDRESS PIC S9(9) COMP.
03 STDLIST-ADDRESS PIC S9(9) COMP.
03 GOON-PARM PIC S9(9) COMP VALUE 0.
03 INFO-ADDRESS PIC S9(9) COMP.
03 INFO-LEN PIC S9(9) COMP VALUE 80.
03 XL-ADDRESS PIC S9(9) COMP.
03 XL-LEN PIC S9(9) COMP VALUE 80.
PROCEDURE DIVISION.
CALL INTRINSIC ".LOC." USING @STDIN
GIVING STDIN-ADDRESS.
CALL INTRINSIC ".LOC." USING @STDLIST
GIVING STDLIST-ADDRESS.
CALL INTRINSIC ".LOC." USING @ENTRY-NAME
GIVING ENTRY-ADDRESS.
CALL INTRINSIC ".LOC." USING @INFO-STRING
GIVING INFO-ADDRESS.
CALL INTRINSIC ".LOC." USING @XL-STRING
GIVING XL-ADDRESS.
CALL INTRINSIC "CREATEPROCESS" USING ERRORS
PIN
PROG-NAME
ITEMNUMS
ITEMS.
IF ERRORS <> 0
DISPLAY 'Failure to create: ' PROG-NAME
DISPLAY 'Error in CREATEPROCESS: ' ERRORS.
This isn't a lesson on how to use CREATEPROCESS, so if you have any questions that you can't answer by checking the manual, just get a hold of me some how and I will be happy to help you out.
Well I am starting to run low on ideas for this column, I appreciate
the input I have gotten so far, and I hope to get more so I can
continue to share information with everyone. I did get a demo of
that COBOL 4GL I talked about last month from the company SINC, so
I will be writing that up soon as well.