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 <IBM-MAIN@LISTSERV.UA.EDU> wrote: ----- To: IBM-MAIN@LISTSERV.UA.EDU 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 lists...@listserv.ua.edu 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 lists...@listserv.ua.edu with the message: INFO IBM-MAIN