Subroutine Source Examples and Runtime Testing

In this section:

Below are select sample subroutines. All 3GL reference examples for subroutines (as well as Exit, RPC and API examples) are delivered within the etc/src3gl sub directory and z/OS PDS locations and names as noted in the reference samples below (and in other examples in this manual). One reference example is actual several different language implementations (C, C++, Fortran, Cobol, BAL, Basic, RPG, PL/1 and Pascal) of a fairly simple task, translate a number into a spelled out month name (mthname). The different language implementations allow one to focus on the implementation issues in a language they may be more familiar with. The other example is a string reversing example that accounts for how to handle Unicode UTF-8 (UREVERSE) which is strictly a C example. Each has been tested and works for its given target environment.

Note that some of the samples have comments within them about portions that need to be adjusted to account for known language implementation differences on some platforms. For example, IBM i COBOL requires a change in the PROGRAM-ID specification to force a lower case entry point name and OpenVMS doesn't support GOBACK. As stated earlier, in theory any compiled and linked languages that can create a DLL can be used to create subroutines. Once a program is built as a DLL, the loading and execution process is generally agnostic of the original language.

Please note that while VB is a popular language, VB does not have options for generating a true WIN32 Dynamic Link Library (DLLs with .dll extensions) and, as such, cannot be used for building subroutines because the loader process requires that only standard DLL objects be used. This is considered a Microsoft issue. Also note that an internet search for "build dll in vb" yields a number of sites that describe how to force VB to create DLLs. While such techniques seem promising for customers who want to use VB, and may very well execute properly, IBI cannot officially support unsupported techniques. However, we will work with customers to resolve problems within this scope.

Some language samples (Pascal for instance) may not be capable of being build by GENCPGM for a given platform (ie UNIX and Linux), but is still provided on the media for all platforms for reference purposes and for people that decide to create their own build scripts.

The disk locations below, use PDS notation for PDS Deployment and UNIX notation for "all other platforms" for the purpose of being brief. The locations for Windows would be the same except the slashes are back slashes. The locations for OpenVMS would be dots instead of slashes and the directory portion would be enclosed in square braces.

Any of the MTHNAME sample routines can be tested by creating a simple FOCEXEC and using the following sample steps:

Create FOCEXEC mthname.fex

-SET &MTHNAME = MTHNAME(&MTHNUMBER,'A12') ;
-TYPE Month &MTHNUMBER is &MTHNAME

Compile and set IBICPG (this is using the C example on UNIX):

export EDAHOME=/home/iadmin/ibi/srv76/home
gencpgm.sh -m cpgm mthname.c
export IBICPG=`pwd`

After restarting the server, execute an RPC like:

EX MTHNAME MTHNUMBER=4

And receive:

Month 4 is March


Top of page

x
MTHNAME C Implementation

Note:

Source:

/*                                                      */
/* MTHNAME: Sample User Written Routine in C            */
/*                                                      */
/* iWay/EDA refers to these as User Written Routines    */
/* and WebFOCUS/FOCUS refers to them as FUSELIBs        */
/* Routines. They are written in the same way for all   */
/* platforms and products, but the compilation and      */
/* link steps may differ depending on release and       */
/* product level. See appropriate platform/product      */
/* documentation for compilation and link instructions. */
/*                                                      */
 
void
mthname(double *mth, char *month)
{
static char *nmonth[13] = {"** Error **",
                           "January    ",
                           "February   ",
                           "March      ",
                           "April      ",
                           "May        ",
                           "June       ",
                           "July       ",
                           "August     ",
                           "September  ",
                           "October    ",
                           "November   ",
                           "December   ",};
int imth, loop;
imth = (int)*mth;
imth = (imth < 1 || imth > 12 ? 0:imth);
for (loop=0;loop < 12;++loop)
     month[loop] = nmonth[imth][loop];
return;
}

Top of page

x
MTHNAME C++ Implementation

Note:

Source:

// MTHNAME: Sample User Written Routine in C++
 
// Warning: Use on MVS OE requires extension to be renamed as .C
 
extern "C" int mthname(double* mth, char* month)
{
const char *nmonth[13] = {"** Error **",
                           "January   ",
                           "February  ",
                           "March     ",
                           "April     ",
                           "May       ",
                           "June      ",
                           "July      ",
                           "August    ",
                           "September ",
                           "October   ",
                           "November  ",
                           "December  ",};
int imth, loop;
imth = (int)*mth;
imth = (imth < 1 || imth > 12 ? 0:imth);
for (loop=0;loop < 12;++loop)
     month[loop] = nmonth[imth][loop];
return 0;
}

Top of page

x
MTHNAME Fortran Implementation

Note:

Source:

      SUBROUTINE MTHNAME (MTH,MONTH)
      REAL*8     MTH
      INTEGER*4  MONTH(3),A(13,3),IMTH
      DATA
     +     A( 1,1)/'Janu'/, A( 1,2)/'ary '/, A( 1,3)/'    '/,
     +     A( 2,1)/'Febr'/, A( 2,2)/'uary'/, A( 2,3)/'    '/,
     +     A( 3,1)/'Marc'/, A( 3,2)/'h   '/, A( 3,3)/'    '/,
     +     A( 4,1)/'Apri'/, A( 4,2)/'l   '/, A( 4,3)/'    '/,
     +     A( 5,1)/'May '/, A( 5,2)/'    '/, A( 5,3)/'    '/,
     +     A( 6,1)/'June'/, A( 6,2)/'    '/, A( 6,3)/'    '/,
     +     A( 7,1)/'July'/, A( 7,2)/'    '/, A( 7,3)/'    '/,
     +     A( 8,1)/'Augu'/, A( 8,2)/'st  '/, A( 8,3)/'    '/,
     +     A( 9,1)/'Sept'/, A( 9,2)/'embe'/, A( 9,3)/'r   '/,
     +     A(10,1)/'Octo'/, A(10,2)/'ber '/, A(10,3)/'    '/,
     +     A(11,1)/'Nove'/, A(11,2)/'mber'/, A(11,3)/'    '/,
     +     A(12,1)/'Dece'/, A(12,2)/'mber'/, A(12,3)/'    '/,
     +     A(13,1)/'**ER'/, A(13,2)/'ROR*'/, A(13,3)/'*   '/
      IMTH=MTH+0.000001
      IF (IMTH .LT. 1 .OR. IMTH .GT. 12) IMTH=13
      DO 1 I=1,3
    1 MONTH(I)=A(IMTH,I)
      RETURN
      END

Note: Some Fortran compilers support character variables longer than 4 bytes and, in this case, the example’s array could be constructed as a CHARACTER*10 with A(1)/’January’/, ..., A(13)/’***ERROR**’/ syntax, but the split array syntax used in example above is known to work on all Fortran compilers.


Top of page

x
MTHNAME COBOL Implementation

Note:

Source:

000100*
000200 IDENTIFICATION DIVISION.
000300*
000400* MTHNAME: Sample User Written Routine in Cobol
000500*
000600* Notes:
000700*
000800*  1. This sample is based on the original mainframe
000900*     sample with a PROGRAM-ID of MTHNAM. This has been
001000*     changed to have a uniquely sourced version that
001100*     more closely matches the C version and has these
001200*     comments. The samples are otherwise the same.
001300*
001400*  2. Original mainframe sample had a GOBACK as the
001500*     last statement. OpenVMS Cobol seems to object
001600*     to this, so commented it out as noted below.
001700*     Unix compiler support for GOBACK may also vary
001800*     by vendor and untested at this time (5/1/2003).
001900*
002000*  3. OpenVMS compiled and was found, but initial
002100*     always returned the error case. This was
002200*     actually a GENCPGM.COM error that the Cobol
002300*     needed the /FLOAT=G_FLOAT switch, so be sure
002400*     that you are using a GENCPGM.COM from 5.2.3
002500*     or higher where this is fixed.
002600*
002700*  4. The PROGRAM-ID name may also needed some
002800*     special handling depending on the platform.
002900*     The reason for this is that iWay routines
003000*     are searched for in lower case and there
003100*     seems to be some case sensitivity problems
003200*     for the platforms tested so far. OpenVMS
003300*     doesn't seem to care if name is lower or
003400*     upper case.  i5/OS Cobol is not only case
003500*     sensitive but requires explicit lower case
003600*     values to be in single quotes, but also
003700*     needs the compiler option *NOMONOPRC to
003800*     respect the coded value. So, depending
003900*     on your platform, the PROGRAM-ID value may
004000*     need editing as per notes below.
004100*
004800*
004900* ID Usage for Mainframe and OpenVMS ...
005000*PROGRAM-ID. MTHNAME.
005100* ID Usage for Unix and Windows ...
005200*PROGRAM-ID. mthname.
005300* ID Usage for i5/OS ...
005400*PROGRAM-ID. 'mthname'.
005500*
005600* ID Usage for this run ...
005700 PROGRAM-ID. mthname.
005800*
005900 ENVIRONMENT DIVISION.
006000 CONFIGURATION SECTION.
006100 DATA DIVISION.
006200 WORKING-STORAGE SECTION.
006300    01 MONTH-TABLE.
006400      05 FILLER PIC X(9) VALUE 'January  '.
006500      05 FILLER PIC X(9) VALUE 'February '.
006600      05 FILLER PIC X(9) VALUE 'March    '.
006700      05 FILLER PIC X(9) VALUE 'April    '.
006800      05 FILLER PIC X(9) VALUE 'May      '.
006900      05 FILLER PIC X(9) VALUE 'June     '.
007000      05 FILLER PIC X(9) VALUE 'July     '.
007100      05 FILLER PIC X(9) VALUE 'August   '.
007200      05 FILLER PIC X(9) VALUE 'September'.
007300      05 FILLER PIC X(9) VALUE 'October  '.
007400      05 FILLER PIC X(9) VALUE 'November '.
007500      05 FILLER PIC X(9) VALUE 'December '.
007600      05 FILLER PIC X(9) VALUE '**ERROR**'.
007700    01  MLIST REDEFINES MONTH-TABLE.
007800      05  MLINE OCCURS 13 TIMES INDEXED BY IX.
007900          10 A  PIC X(9).
008000    01  IMTH    PIC S9(5) COMP.
008100 LINKAGE SECTION.
008200    01  MTH     COMP-2.
008300    01  MONTH   PIC X(9).
008400 PROCEDURE DIVISION USING MTH, MONTH.
008500 BEG-1.
008600       ADD 0.000001 TO MTH.
008700       MOVE MTH TO IMTH.
008800       IF IMTH < +1 OR > 12
008900         SET IX TO +13
009000       ELSE
009100         SET IX TO IMTH.
009200       MOVE A (IX) TO MONTH.
009300*
009400* On OpenVMS ... Comment out the GOBACK.
009500*
009600       GOBACK.

Top of page

x
MTHNAME z/OS BAL Assembler Implementation

Note:

Source:

*
* MTHNAME: Sample User Written Routine in z/OS BAL Assembler
*
* If this is used as a source read directly from an HFS file
* system the extension must be .x for assembler files.
*
MTHNAME  CSECT
MTHNAME  AMODE 31
MTHNAME  RMODE ANY
         STM   14,12,12(13)        save registers
         BALR  12,0                load base reg
         USING *,12
*
         L     3,0(0,1)            load addr of first arg into R3
         LD    4,=D'0.0'           clear out FPR4 and FPR5
         LE    6,0(0,3)            FP number in FPR6
         LPER  4,6                 abs value in FPR4
         AW    4,=D'0.00001'       add rounding constant
         AW    4,DZERO             shift out fraction
         STD   4,FPNUM             move to memory
         L     2,FPNUM+4           integer part in R2
         TM    0(3),B'10000000'    check sign of original no
         BNO   POS                 branch if positive
         LCR   2,2                 complement if negative
*
POS      LR    3,2                 copy month number into R3
         C     2,=F'0'             is it zero or less?
         BNP   INVALID             yes. so invalid
         C     2,=F'12'            is it greater than 12?
         BNP   VALID               no. so valid
INVALID  LA    3,13(0,0)           set R3 to point to item @13 (error)
*
VALID    SR    2,2                 clear out R2
         M     2,=F'9'             multiply by shift in table
*
         LA    6,MTH(3)            get addr of item in R6
         L     4,4(0,1)            get addr of second arg in R4
         MVC   0(9,4),0(6)         move in text
*
         LM    14,12,12(13)        recover regs
         BR    14 return
*
         DS    0D                  alignment
FPNUM    DS    D                   floating point number
DZERO    DC    X'4E00000000000000' shift constant
MTH      DC    CL9'dummyitem'      month table
         DC    CL9'January'
         DC    CL9'February'
         DC    CL9'March'
         DC    CL9'April'
         DC    CL9'May'
         DC    CL9'June'
         DC    CL9'July'
         DC    CL9'August'
         DC    CL9'September'
         DC    CL9'October'
         DC    CL9'November'
         DC    CL9'December'
         DC    CL9'**ERROR**'
         END   MTHNAME

Top of page

x
MTHNAME Basic Implementation (Based on HP OpenVMS Basic 1.4)

Note:

Source:

1000 SUB mthname BY REF(REAL MTH, STRING MONTH = 12)
1001 REM
1002 REM MTHNAME: Sample User Written Routine in Basic
1003 REM This sample is based on FOCUS/VMS 6.x sample.
1004 REM
1005 REM Only changes were to make it more like the standard
1006 REM sample (entry point of lowercase mthname (vs. MTHNAM)
1007 REM datatype of REAL (vs. DOUBLE) and use mixed case 
1008 REM month names.
1009 REM
2000 ON INTEGER(MTH) GOTO 2001,2002,2003,2004,2005,2006, &
                          2007,2008,2009,2010,2011,2012 &
                          OTHERWISE 2013
2001 MONTH = "January" \ EXIT SUB
2002 MONTH = "February" \ EXIT SUB
2003 MONTH = "March" \ EXIT SUB
2004 MONTH = "April" \ EXIT SUB
2005 MONTH = "May" \ EXIT SUB
2006 MONTH = "June" \ EXIT SUB
2007 MONTH = "July" \ EXIT SUB
2008 MONTH = "August" \ EXIT SUB
2009 MONTH = "September" \ EXIT SUB
2010 MONTH = "October" \ EXIT SUB
2011 MONTH = "November" \ EXIT SUB
2012 MONTH = "December" \ EXIT SUB
2013 MONTH = "** Error **" \ EXIT SUB
3000 END SUB

Top of page

x
MTHNAME RPG IBM i ILE Implementation

Note:

Source:

HNOMAIN
 
* MTHNAME: Sample User Written Routine in RPG
*          Converts month number to month name
 
* This is an IBM i RPG version of the standard mthname.c
* sub routine supplied with IBI products.
* This a no main dll service type program with a lowercase
* exported symbol ... which is what is needed to integrate
* with programs that typically use lower or mixed case
* symbols in there dlls (ie. C).
* This routine is stored for z/OS PDS Deployment purposes
* as MTHNAMRP so it does not conflict with any of the
* other MTHNAME samples. Gencpgm on z/OS doesn't support
* RPG so building there is a non issue.
* Declare procedure parameter prototype.
* EXTPROC needed for lower case symbol ... very important!
 
D mthname         PR                    EXTPROC('mthname')
D   MTH                          8F
D   MTHNAME                     11A
* Procedure begin with external symbol export declaration.
P mthname         B                     EXPORT
* Declare procedure parameter interface.
D mthname         PI
D   MTH                          8F
D   MTHNAME                     11A
* Error Cases ... check if below 1 or above 12
C                   IF        MTH < 1 OR MTH > 12
C                   MOVE      '** Error **' MTHNAME
C                   ENDIF
* Look up by month ... 
* (Using LOOKUP would be better, but lets keep it simple)
C                   IF        MTH =  1
C                   MOVE      'January    ' MTHNAME
C                   ENDIF
C                   IF        MTH =  2
C                   MOVE      'February   ' MTHNAME
C                   ENDIF
C                   IF        MTH =  3
C                   MOVE      'March      ' MTHNAME
C                   ENDIF
C                   IF        MTH =  4
C                   MOVE      'April      ' MTHNAME
C                   ENDIF
C                   IF        MTH =  5
C                   MOVE      'May        ' MTHNAME
C                   ENDIF
C                   IF        MTH =  6
C                   MOVE      'June       ' MTHNAME
C                   ENDIF
C                   IF        MTH =  7
C                   MOVE      'July       ' MTHNAME
C                   ENDIF
C                   IF        MTH =  8
C                   MOVE      'August     ' MTHNAME
C                   ENDIF
C                   IF        MTH =  9
C                   MOVE      'September  ' MTHNAME
C                   ENDIF
C                   IF        MTH =  10
C                   MOVE      'October    ' MTHNAME
C                   ENDIF
C                   IF        MTH =  11
C                   MOVE      'November   ' MTHNAME
C                   ENDIF
C                   IF        MTH =  12
C                   MOVE      'December   ' MTHNAME
C                   ENDIF
 
* Done; return to caller.
C                   RETURN
* Procedure End
P                 E

Top of page

x
MTHNAME PL/1 Implementation

Note:

Source:

/* MTHNAME: Sample User Written Routine in PL/1 */
 
MTHNAME: PROC(MTHNUM,FULLMTH) OPTIONS(COBOL);
DECLARE MTHNUM DECIMAL FLOAT (16) ;
DECLARE FULLMTH CHARACTER (9) ;
DECLARE MONTHNUM FIXED BIN (15,0) STATIC ;
DECLARE MONTH_TABLE(13) CHARACTER (9) STATIC
                      INIT ('January',
                            'February',
                            'March',
                            'April',
                            'May',
                            'June',
                            'July',
                            'August',
                            'September',
                            'October',
                            'November',
                            'December',
                            '**ERROR**') ;
MONTHNUM = MTHNUM + 0.00001 ;
IF MONTHNUM < 1 | MONTHNUM > 12 THEN MONTHNUM = 13 ;
FULLMTH = MONTH_TABLE(MONTHNUM) ;
RETURN ;
END MTHNAME ;

Top of page

x
MTHNAME Pascal Implementation (Based on HP OpenVMS Pascal 5.8)

Note:

Source:

{
  MTHNAME: Sample User Written Routine in Pascal
  This sample is based on FOCUS/VMS 6.x sample.
  Only changes were to make it more like the standard
  C sample (entry point of lowercase mthname (vs. MTHNAM)
  and use mixed case month names).
}
MODULE MTH;
TYPE
  monthstring = packed array [1..12] OF CHAR;
[GLOBAL] PROCEDURE mthname(MTH:double ; var month : monthstring);
  VAR
IMONTH :INTEGER;
 BEGIN
   IMONTH:= ROUND(MTH);
   IF IMONTH IN [1..12] THEN
     CASE IMONTH OF
       1 : MONTH := 'January';
       2 : MONTH := 'February';
       3 : MONTH := 'March';
       4 : MONTH := 'April';
       5 : MONTH := 'May';
       6 : MONTH := 'June';
       7 : MONTH := 'July';
       8 : MONTH := 'August';
       9 : MONTH := 'September';
      10 : MONTH := 'October';
      11 : MONTH := 'November';
      12 : MONTH := 'December';
    END
  ELSE
    MONTH := '** Error **'
 END;
END.

Top of page

x
UREVERSE C Implementation

Note:

/*                                                                                 */
/* Sample User Written Routine in C ...                                            */
/* UREVERSE: Unicode UTF-8 capable string reversing routine                        */
/*                                                                                 */
/* Typical usage:                                                                  */
/* -SET &STRING = 'abcd' ;                                                         */
/* -SET &RSTRING = UREVERSE(&STRING,&STRING.LENGTH,&FOCCODEPAGE,A&STRING.LENGTH) ; */
/* -TYPE Reverse of &STRING is &RSTRING                                            */
/* Note: &FOCCODEPAGE is standard amper variable for server code page              */
/*                                                                                 */
/* Servers using the Unicode 65002 page are effectively UTF-EBCDIC and beyond      */
/* the scope of this simple sample. Customer implementations should follow the     */
/* information at http://www.unicode.org/reports/tr16 when using the 65002         */
/* UTF-EBCDIC code page.                                                           */
#include <stdio.h>
#include <stdlib.h>
void ureverse( char *instr, double *charsize, double *codepage, char *outstr )
{
  unsigned short codepg = (unsigned short)*codepage;
  int            csize = (int)*charsize;
  int            bsize, offset, clen, ccnt;
  unsigned char *cptr;
  char          *foccodepage;
  /* External var override, normally var is not set. If trying to make an       */
  /* existing routine Unicode compliant without passing an extra var, this      */
  /* method can be used to get a code page value if following is added to       */
  /* the server profile (edasprof) or other application code:                   */
  /* -SET &RC = FPUTENV(11,'FOCCODEPAGE',&FOCCODEPAGE.LENGTH,&FOCCODEPAGE,D8) ; */
  foccodepage = getenv("FOCCODEPAGE");
  if( foccodepage != NULL )
  {
    codepg = atoi( foccodepage );
  }
  if( codepg == 65001 ) /* Unicode reference number used by server for UTF-8 */
  {
    /* Unicode UTF-8 */
    /* Pass 1. Calculate the byte length of 'instr' in character length 'charsize' */
    /* Pass 2. Copy each character from 'instr' to 'outstr' in reverse             */
    bsize = csize * 3; /* maximum byte size */
    for( ccnt = offset = 0; ccnt < csize && offset < bsize; ccnt++, offset += clen )
    {
      cptr = (unsigned char *)&instr[offset];
      if(      *cptr < 0x80 )  clen = 1;
      else if( *cptr < 0xE0 )  clen = 2;
      else                     clen = 3;
    }
    bsize = offset; /* actual byte size in utf-8 for charsize */
    for( offset = 0; offset < bsize; offset += clen )
    {
      cptr = (unsigned char *)&instr[offset];
      if(      *cptr < 0x80 )  clen = 1;
      else if( *cptr < 0xE0 )  clen = 2;
      else                     clen = 3;
      memcpy( &outstr[bsize - offset - clen ], cptr, clen );
    }
  }
  else
  {
    /* Non-Unicode */
    /* Copy each character from 'instr' to 'outstr' in reverse */
    for( offset = 0; offset < csize; offset++ )
    {
      outstr[csize - offset - 1] = instr[offset];
    }
  }
}

iWay Software