We use this COBOL warning 400+lines follow
IDENTIFICATION DIVISION.
PROGRAM-ID. 'JLPFCALL'.
****************************************************************
* JLPFCALL JLP UTILITY REXX FUNCTION
****************************************************************
*
* THIS IS CALLED IN A REXX EXEC IN THE FOLLOWING
* WAY
* JLPFCALL(MODULENAME,N,PARM1,PARM2. . . .)
*
* WHERE MODULENAME IS A DEFINED SUBROUTINE AND N IS THE NUMBER OF
* THE PARM THAT WE WANT TO GO INTO THE RESULT
*
* E.G.
*
* INDATE = "12/12/12"
* JDCONTROL="ESCJDC "
*
* X = JLPFCALL("JDATE",JDCONTROL,INDATE,"")
*
* PUTS THE 80-BYTE JDATE FIELD INTO X
*
* PARAMETERS ARE PADDED TO 250 BYTES ON INPUT. THE RESULT FIELD
* IS PADDED TO 250 BYTES AND THEN HAS TRAILING BLANKS TRUNCATED.
* HOWEVER ITS LENGTH IS NEVER REDUCED TO LESS THAN ITS LENGTH ON
* INPUT
*
****************************************************************
* IT IS NECESSARY TO WRITE THIS IN COBOL BECAUSE THE COBOL DYNAMIC
* CALL IS THE ONLY AVAILABLE INTERFACE WHICH CAN HANDLE ALL
* POSSIBLE TYPES OF MODULE E.G.
* COBOL MODULES (24 AND 31)
* C MODULES (MUST BE 31) - NOT MAIN
* C MODULES (MUST BE 31) - MAIN
* ASS MODULES (24 AND 31) - NON-CONFORMING
* ASS MODULES (24 AND 31) - CONFORMING MAIN
* ASS MODULES (24 AND 31) - CONFORMING NOT MAIN
****************************************************************
*
* WARNING: WE DID ATTEMPT TO PUT THIS IN IRXFLOC, BUT FOUND IT
* NOT WORTH THE TROUBLE. SINCE YOU HAVE TO INITIALISE A LE/370
* ENCLAVE EVERY TIME THE OVERHEAD OF LOADING JLPFCALL IS SMALL
*
****************************************************************
*
* THIS JLPFCALL IS USED ON MVS AND VSE. OTHER ENVIRONMENTS NEED
* THEIR OWN INTERFACES.
*
****************************************************************
****************************************************************
* NOTE FOR USE UNDER OMVS. UNDER OMVS EXTERNAL FUNCTIONS ARE
* LOOKED FOR FIRST BY MVS LOAD. THUS THE "MVS BATCH" VERSION
* ON OPS.LIVE.LOADLIB (SYSTEM LINKLIB) IS USED UNDER OMVS.
****************************************************************
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 W-MAX-EVALBLOCK-EVDATA-LEN PIC S9(8) COMP.
01 W-ARG-COUNT PIC S9(8) COMP.
01 W-ARG-ENTRYS.
04 W-ARG OCCURS 11 INDEXED BY
W-ARG-ENTRY-X.
07 W-ARG-LEN PIC S9(8) COMP.
07 W-ARG-DATA PIC X(500).
01 W-REPLY.
07 W-REPLY-LEN PIC S9(8) COMP.
07 W-REPLY-DATA PIC X(500).
01 W-RESULT PIC X.
LINKAGE SECTION.
01 DUMMY1 PIC X.
01 DUMMY2 PIC X.
01 DUMMY3 PIC X.
01 DUMMY4 PIC X.
01 ARGTABLE.
04 ARGTABLE-ENTRY OCCURS 10 INDEXED BY
ARGTABLE-ENTRY-X.
07 ARGTABLE-ARGSTRING-POINTER USAGE POINTER.
07 ARGTABLE-ARGSTRING-LEN PIC S9(8) COMP.
01 ARGSTRING PIC X(9999).
01 EVALBLOCK-POINTER USAGE POINTER.
01 EVALBLOCK.
02 EVALBLOCK-PREFIX.
04 EVALBLOCK-EVPAD1 PIC S9(8) COMP.
04 EVALBLOCK-EVSIZE PIC S9(8) COMP.
04 EVALBLOCK-EVLEN PIC S9(8) COMP.
04 EVALBLOCK-EVPAD2 PIC S9(8) COMP.
02 EVALBLOCK-REST.
04 EVALBLOCK-EVDATA PIC X(9999).
PROCEDURE DIVISION USING DUMMY1 DUMMY2 DUMMY3 DUMMY4 ARGTABLE
EVALBLOCK-POINTER.
* COUNT ARGUMENT TABLE.
* MUST BE (2+1) AT LEAST, MAY NOT BE > (2+9)
* SET ADRESSABILITY OF EVALBLOCK
* SET MAX ALLOWABLE LENGTH TO SIZE AVAILABLE IN EVDATA
*
SET ADDRESS OF EVALBLOCK
TO EVALBLOCK-POINTER
COMPUTE W-MAX-EVALBLOCK-EVDATA-LEN
= (EVALBLOCK-EVSIZE * 8) - LENGTH OF EVALBLOCK-PREFIX
IF W-MAX-EVALBLOCK-EVDATA-LEN > 250
MOVE 250 TO W-MAX-EVALBLOCK-EVDATA-LEN
END-IF
MOVE 1 TO W-ARG-COUNT
PERFORM VARYING ARGTABLE-ENTRY-X FROM 1 BY 1 UNTIL
ARGTABLE-ENTRY(ARGTABLE-ENTRY-X) = HIGH-VALUES
ADD 1 TO W-ARG-COUNT
END-PERFORM
IF W-ARG-COUNT < 3 OR W-ARG-COUNT > 11
GO TO Z999-ERROR
END-IF
* MOVE ARGUMENTS TO WORKING-STORAGE
PERFORM VARYING W-ARG-ENTRY-X FROM 1 BY 1 UNTIL
W-ARG-ENTRY-X > 11
MOVE ' ' TO W-ARG-DATA(W-ARG-ENTRY-X)
MOVE 0 TO W-ARG-LEN(W-ARG-ENTRY-X)
END-PERFORM
SET W-ARG-ENTRY-X TO 1
PERFORM VARYING ARGTABLE-ENTRY-X FROM 1 BY 1 UNTIL
ARGTABLE-ENTRY(ARGTABLE-ENTRY-X) = HIGH-VALUES
IF ARGTABLE-ARGSTRING-LEN(ARGTABLE-ENTRY-X) >
W-MAX-EVALBLOCK-EVDATA-LEN
GO TO Z999-ERROR
END-IF
SET ADDRESS OF ARGSTRING TO ARGTABLE-ARGSTRING-POINTER
(ARGTABLE-ENTRY-X)
IF ARGTABLE-ARGSTRING-LEN(ARGTABLE-ENTRY-X) > 0
MOVE ARGSTRING
(1:ARGTABLE-ARGSTRING-LEN(ARGTABLE-ENTRY-X))
TO W-ARG-DATA(W-ARG-ENTRY-X)
END-IF
MOVE ARGTABLE-ARGSTRING-LEN(ARGTABLE-ENTRY-X)
TO W-ARG-LEN(W-ARG-ENTRY-X)
SET W-ARG-ENTRY-X UP BY 1
END-PERFORM
CALL 'JLPFCAL1' USING W-ARG-COUNT W-ARG-ENTRYS W-REPLY
W-RESULT
* DISPLAY 'JLPFCAL1 RC = ' RETURN-CODE
IF W-RESULT NOT = 'V'
GO TO Z999-ERROR
END-IF
MOVE W-REPLY-LEN TO EVALBLOCK-EVLEN
IF EVALBLOCK-EVLEN > W-MAX-EVALBLOCK-EVDATA-LEN
MOVE W-MAX-EVALBLOCK-EVDATA-LEN
TO EVALBLOCK-EVLEN
END-IF
MOVE W-REPLY-DATA TO EVALBLOCK-EVDATA(1:EVALBLOCK-EVLEN)
MOVE 0 TO RETURN-CODE
GOBACK.
Z999-ERROR.
MOVE 12 TO RETURN-CODE
GOBACK.
* COPY IN EXECUTION SUBROUTINE FOR FAST EXECUTION
000100 IDENTIFICATION DIVISION. 00010000
000200 00020000
000300 PROGRAM-ID. JLPFCAL1. 00030000
000400 00040000
000500**************************************************************** 00050000
000600* JLPFCALL SUBROUTINE FOR DOING ACTUAL CALL 00060000
000700**************************************************************** 00070000
000800* 00080000
002900* 00290000
003000**************************************************************** 00300000
003100* IT IS NECESSARY TO WRITE THIS IN COBOL BECAUSE THE COBOL DYNAMIC00310000
003200* CALL IS THE ONLY AVAILABLE INTERFACE WHICH CAN HANDLE ALL 00320000
003300* POSSIBLE TYPES OF MODULE ON MVS. THIS IS ALSO TRUE ON MANY 00330000
003400* OTHER OPERATING SYSTEMS 00340000
004000**************************************************************** 00400000
004700 00470000
004800 00480000
004900 ENVIRONMENT DIVISION. 00490000
005000 DATA DIVISION. 00500000
005100 WORKING-STORAGE SECTION. 00510000
005200 00520000
005300 01 W-MODULE-NAME PIC X(8). 00530000
005500 01 W-RETURN-CODE PIC S9(8) COMP. 00550000
006000 01 W-ARG-RETURNED-NO PIC S9(8) COMP. 00600000
006010 01 W-COUNT PIC S9(8) COMP. 00601005
006020 01 W-CHAR-X. 00602005
006030 04 W-CHAR PIC 9. 00603005
006100 00610000
007300 LINKAGE SECTION. 00730000
007400 00740000
007410 01 W-ARG-COUNT PIC S9(8) COMP. 00741000
007431 00743100
007432 01 W-ARG-ENTRYS. 00743200
007433 04 W-ARG OCCURS 11 INDEXED BY 00743300
007434 W-ARG-ENTRY-X. 00743400
007440 07 W-ARG-LEN PIC S9(8) COMP. 00744000
007450 07 W-ARG-DATA PIC X(500). 00745000
007460 00746000
007470 00747000
007480 01 W-REPLY. 00748000
007490 07 W-REPLY-LEN PIC S9(8) COMP. 00749000
007491 07 W-REPLY-DATA PIC X(500). 00749100
007492 00749200
007493 00749300
007494 01 W-RESULT PIC X. 00749400
010100 01010000
010200 PROCEDURE DIVISION USING W-ARG-COUNT W-ARG-ENTRYS W-REPLY 01020000
010400 W-RESULT. 01040000
010500 01050000
016500 01650000
016510 MOVE 'I' TO W-RESULT 01651000
016520 01652000
016600* GET NAME OF MODULE 01660000
016700 01670000
016800 IF W-ARG-LEN(1) > 8 01680000
016900 GO TO Z999-ERROR 01690000
017000 END-IF 01700000
017100* DISPLAY 'HI 01' 01710000
017110 01711000
017200 MOVE W-ARG-DATA(1) TO W-MODULE-NAME 01720008
017300 INSPECT W-MODULE-NAME 01730009
017301 CONVERTING 'abcdefghijklmnopqrstuvwxyz' 01730109
017302 TO 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 01730209
017320 01732008
017400* GET NUMBER OF PARM TO RETURN. DONE THIS WAY COS "NUMERIC" 01740005
017410* IS A BIT DICKY ON SOME COMPILERS 01741005
017500 01750000
017501 MOVE 0 TO W-ARG-RETURNED-NO 01750105
017510 PERFORM VARYING W-COUNT FROM 1 BY 1 UNTIL W-COUNT 01751005
017520 > W-ARG-LEN(2) 01752005
017521 COMPUTE W-ARG-RETURNED-NO = W-ARG-RETURNED-NO * 10 01752105
017530 MOVE W-ARG-DATA(2) (W-COUNT:1) TO W-CHAR-X 01753005
017531 IF W-CHAR-X = '0' 01753105
017532 OR W-CHAR-X = '1' 01753205
017533 OR W-CHAR-X = '2' 01753305
017534 OR W-CHAR-X = '3' 01753405
017535 OR W-CHAR-X = '4' 01753505
017536 OR W-CHAR-X = '5' 01753605
017537 OR W-CHAR-X = '6' 01753705
017538 OR W-CHAR-X = '7' 01753805
017539 OR W-CHAR-X = '8' 01753905
017540 OR W-CHAR-X = '9' 01754005
017557 COMPUTE W-ARG-RETURNED-NO 01755705
017558 = 01755805
017559 W-ARG-RETURNED-NO + W-CHAR 01755905
017560 ELSE 01756005
017561 GO TO Z999-ERROR 01756105
017562 END-IF 01756206
017569 01756905
017570 END-PERFORM 01757005
017580 01758005
017590 COMPUTE W-ARG-RETURNED-NO = W-ARG-RETURNED-NO + 2 01759007
018600 01860000
018700 IF W-ARG-RETURNED-NO < 3 OR W-ARG-RETURNED-NO > W-ARG-COUNT 01870000
018800 GO TO Z999-ERROR 01880000
018900 END-IF 01890000
018910* DISPLAY 'HI 03' 01891000
019000 01900000
019100 01910000
019200* CALL MODULE 01920000
019300 01930000
019400 MOVE 0 TO W-RETURN-CODE 01940000
019500 01950000
019600 EVALUATE W-ARG-COUNT 01960000
019700 01970000
019800 WHEN 3 01980000
019900 01990000
020000 CALL W-MODULE-NAME USING 02000000
020100 W-ARG-DATA(3) 02010000
020200 ON EXCEPTION GO TO Z999-ERROR 02020000
020300 END-CALL 02030000
020400 MOVE RETURN-CODE TO W-RETURN-CODE 02040000
020500 02050000
020600 WHEN 4 02060000
020700 02070000
020800 CALL W-MODULE-NAME USING 02080000
020900 W-ARG-DATA(3) 02090000
021000 W-ARG-DATA(4) 02100000
021100 ON EXCEPTION GO TO Z999-ERROR 02110000
021200 END-CALL 02120000
021300 MOVE RETURN-CODE TO W-RETURN-CODE 02130000
021400 02140000
021500 WHEN 5 02150000
021600 02160000
021700 CALL W-MODULE-NAME USING 02170000
021800 W-ARG-DATA(3) 02180000
021900 W-ARG-DATA(4) 02190000
022000 W-ARG-DATA(5) 02200000
022100 ON EXCEPTION GO TO Z999-ERROR 02210000
022200 END-CALL 02220000
022300 MOVE RETURN-CODE TO W-RETURN-CODE 02230000
022400 02240000
022500 WHEN 6 02250000
022600 02260000
022700 CALL W-MODULE-NAME USING 02270000
022800 W-ARG-DATA(3) 02280000
022900 W-ARG-DATA(4) 02290000
023000 W-ARG-DATA(5) 02300000
023100 W-ARG-DATA(6) 02310000
023200 ON EXCEPTION GO TO Z999-ERROR 02320000
023300 END-CALL 02330000
023400 MOVE RETURN-CODE TO W-RETURN-CODE 02340000
023500 02350000
023600 WHEN 7 02360000
023700 02370000
023800 CALL W-MODULE-NAME USING 02380000
023900 W-ARG-DATA(3) 02390000
024000 W-ARG-DATA(4) 02400000
024100 W-ARG-DATA(5) 02410000
024200 W-ARG-DATA(6) 02420000
024300 W-ARG-DATA(7) 02430000
024400 ON EXCEPTION GO TO Z999-ERROR 02440000
024500 END-CALL 02450000
024600 MOVE RETURN-CODE TO W-RETURN-CODE 02460000
024700 02470000
024800 WHEN 8 02480000
024900 02490000
025000 CALL W-MODULE-NAME USING 02500000
025100 W-ARG-DATA(3) 02510000
025200 W-ARG-DATA(4) 02520000
025300 W-ARG-DATA(5) 02530000
025400 W-ARG-DATA(6) 02540000
025500 W-ARG-DATA(7) 02550000
025600 W-ARG-DATA(8) 02560000
025700 ON EXCEPTION GO TO Z999-ERROR 02570000
025800 END-CALL 02580000
025900 MOVE RETURN-CODE TO W-RETURN-CODE 02590000
026000 02600000
026100 WHEN 9 02610000
026200 02620000
026300 CALL W-MODULE-NAME USING 02630000
026400 W-ARG-DATA(3) 02640000
026500 W-ARG-DATA(4) 02650000
026600 W-ARG-DATA(5) 02660000
026700 W-ARG-DATA(6) 02670000
026800 W-ARG-DATA(7) 02680000
026900 W-ARG-DATA(8) 02690000
027000 W-ARG-DATA(9) 02700000
027100 ON EXCEPTION GO TO Z999-ERROR 02710000
027200 END-CALL 02720000
027300 MOVE RETURN-CODE TO W-RETURN-CODE 02730000
027400 02740000
027500 WHEN 10 02750000
027600 02760000
027700 CALL W-MODULE-NAME USING 02770000
027800 W-ARG-DATA(3) 02780000
027900 W-ARG-DATA(4) 02790000
028000 W-ARG-DATA(5) 02800000
028100 W-ARG-DATA(6) 02810000
028200 W-ARG-DATA(7) 02820000
028300 W-ARG-DATA(8) 02830000
028400 W-ARG-DATA(9) 02840000
028500 W-ARG-DATA(10) 02850000
028600 ON EXCEPTION GO TO Z999-ERROR 02860000
028700 END-CALL 02870000
028800 MOVE RETURN-CODE TO W-RETURN-CODE 02880000
028900 02890000
029000 WHEN 11 02900000
029100 02910000
029200 CALL W-MODULE-NAME USING 02920000
029300 W-ARG-DATA(3) 02930000
029400 W-ARG-DATA(4) 02940000
029500 W-ARG-DATA(5) 02950000
029600 W-ARG-DATA(6) 02960000
029700 W-ARG-DATA(7) 02970000
029800 W-ARG-DATA(8) 02980000
029900 W-ARG-DATA(9) 02990000
030000 W-ARG-DATA(10) 03000000
030100 W-ARG-DATA(11) 03010000
030200 ON EXCEPTION GO TO Z999-ERROR 03020000
030300 END-CALL 03030000
030400 MOVE RETURN-CODE TO W-RETURN-CODE 03040000
030500 03050000
030600 END-EVALUATE 03060000
030610* DISPLAY 'HI 04' 03061000
030700 03070000
030800* MOVE RETURNED DATA BACK TO W-REPLY 03080000
030900 03090000
031000 SET W-ARG-ENTRY-X TO W-ARG-RETURNED-NO 03100000
031100 03110000
031200 MOVE W-ARG-DATA(W-ARG-ENTRY-X) TO W-REPLY-DATA 03120000
031300 03130000
031400* THE RETURNED PARAMETER MAY BE OF DIFFERENT LENGTH. 03140000
031500* WE TRIM OFF TRAILING BLANKS, BUT DO NOT LET THE LENGTH 03150000
031600* OF THE RETURNED PARAMETER FALL BELOW WHAT IT WAS ON INPUT 03160000
031700* EVEN IF THIS DOES LEAVE TRAILING BLANKS 03170000
031800* 03180000
031900 COMPUTE W-REPLY-LEN = (LENGTH OF W-REPLY-DATA) 03190000
032000 PERFORM UNTIL W-REPLY-LEN = 1 03200000
032100 OR W-REPLY-DATA(W-REPLY-LEN:1) NOT = ' ' 03210000
032200 SUBTRACT 1 FROM W-REPLY-LEN 03220000
032300 END-PERFORM 03230000
032400 03240000
032500* DO NOT REDUCE BELOW INPUT VALUE 03250000
032600 03260000
032610* DISPLAY 'HI 05' 03261000
032700 IF W-REPLY-LEN < W-ARG-LEN (W-ARG-ENTRY-X) 03270000
032800 MOVE W-ARG-LEN (W-ARG-ENTRY-X) TO W-REPLY-LEN 03280000
032900 END-IF 03290000
032910 03291000
033000 MOVE 'V' TO W-RESULT 03300000
033100 MOVE 0 TO RETURN-CODE 03310000
034200 03420000
034210* DISPLAY 'HI 06' 03421000
034300 GOBACK. 03430000
034400 03440000
034500 Z999-ERROR. 03450000
034600 03460000
034610* DISPLAY 'HI 07' 03461000
034700 MOVE 12 TO RETURN-CODE 03470000
034800 03480000
034900 GOBACK. 03490000
035000 03500000
035100 03510000
035200 03520000
035300 END PROGRAM JLPFCAL1. 03530000
END PROGRAM 'JLPFCALL'.
~~~~~~~~~~~~ Andy Robertson telephone mobile 0797 0005958 home 01308 420797
-----IBM Mainframe Discussion List <[email protected]> wrote: -----
To: [email protected]
From: Ed Jaffe
Sent by: IBM Mainframe Discussion List
Date: 03/29/2013 02:10PM
Subject: Re: Linking to MVS standard linkage function from Rexx
On 3/29/2013 5:19 AM, Lloyd Fuller wrote:
> ... unless things have changed, Metal C does not handle C++.
> C only. I have not looked specifically at z/OS 1.13, but I do know that in
> 1.12
> and earlier, C only.
True in z/OS 1.13 as well.
--
Edward E Jaffe
Phoenix Software International, Inc
831 Parkview Drive North
El Segundo, CA 90245
http://www.phoenixsoftware.com/
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to [email protected] with the message: INFO IBM-MAIN
**********************************************************************
This email is confidential and may contain copyright material of the John Lewis
Partnership.
If you are not the intended recipient, please notify us immediately and delete
all copies of this message.
(Please note that it is your responsibility to scan this message for viruses).
Email to and from the
John Lewis Partnership is automatically monitored for operational and lawful
business reasons.
**********************************************************************
John Lewis plc
Registered in England 233462
Registered office 171 Victoria Street London SW1E 5NN
Websites: http://www.johnlewis.com
http://www.waitrose.com
http://www.johnlewis.com/insurance
http://www.johnlewispartnership.co.uk
**********************************************************************
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to [email protected] with the message: INFO IBM-MAIN
