*====================================================================* * This file contains additional test programs. You may want to study * * them to get a better idea of how COBOLINT works. Many of these * * programs also appear in the documentation. In most cases, there * * are versions of the programs in multiple languages. * *====================================================================* * The CHANGE4 program is used to demonstrate how a program can be * * called to change the first four bytes of a character argument, * * and COBOLINT can ensure that the remaining bytes are blank-padded. * * This can only happen when an attribute table entry is provided. * *=====CHANGE4: COBOL=================================================* **************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. CHANGE4. **************************************************************** ENVIRONMENT DIVISION. **************************************************************** DATA DIVISION. LINKAGE SECTION. 01 CHRVALUE PIC X(4). **************************************************************** PROCEDURE DIVISION USING CHRVALUE. MOVE "WXYZ" TO CHRVALUE. GOBACK. END PROGRAM CHANGE4. *=====CHANGE4: C=====================================================* void CHANGE4(chrvalue) char *chrvalue; { memcpy(chrvalue,"WXYZ",4); } *====================================================================* * The CHRUP1 program is used to increment the 8 characters in each * * argument by one byte. This is used to demonstrate the potential * * of many character arguments being passed. * *=====CHRUP1: ASM======================================================* SASREGS USING CHRUP1,R15 CHRUP1 CSECT STM R14,R12,12(R13) SLR R4,R4 NEXTARG L R2,0(R1) LA R3,7 NEXTCHAR IC R4,0(R3,R2) LA R4,1(R4) STC R4,0(R3,R2) SH R3,=H'1' BNM NEXTCHAR TM 0(R1),X'80' BO RETURN LA R1,4(R1) B NEXTARG RETURN LM R14,R12,12(R13) BR R14 LTORG END *=====CHRUP1: C========================================================* #define NARGS 1 void CHRUP1(arg1) char *arg1; { char **plist; int i,j; char *p; for (plist = &arg1,j=0;jzd,&temp,'ZD'); temp++; convback(db->zd,temp,'ZD '); convbin(db->zdu,&temp,'ZDU'); temp++; convback(db->zdu,temp,'ZDU'); convbin(db->zdl,&temp,'ZDL'); temp++; convback(db->zdl,temp,'ZDL'); convbin(db->zdls,&temp,'ZDLS'); temp++; convback(db->zdls,temp,'ZDLS'); convbin(db->zdts,&temp,'ZDTS'); temp++; convback(db->zdts,temp,'ZDTS'); (*(db->ib))++; (*(db->ibu))++; convbin(db->pd,&temp,'PD'); temp++; convback(db->pd,temp,'PD'); convbin(db->pdu,&temp,'PDU'); temp++; convback(db->pdu,temp,'PDU'); (*(db->rb8))++; (*(db->rb4))++; memcpy(db->char_data,"1234567890",10); } *====================================================================* * CONVBACK is an assembler program to allow COBOL numeric types * * to be converted to native C representations. * *====================================================================* *=====CONVBACK: ASM====================================================* R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 CONVBACK CSECT USING CONVBACK,R10 STM R14,R12,12(R13) LR R10,R15 LM R1,R3,0(R1) L R0,0(R2) CVD R0,PDTEMP CLC 0(2+1,R3),LIT#ZD BE DO#ZD CLC 0(3+1,R3),LIT#ZDU BE DO#ZDU CLC 0(3+1,R3),LIT#ZDL BE DO#ZDL CLC 0(4+1,R3),LIT#ZDLS BE DO#ZDLS CLC 0(4+1,R3),LIT#ZDTS BE DO#ZDTS CLC 0(2+1,R3),LIT#PD BE DO#PD CLC 0(3+1,R3),LIT#PDU BE DO#PDU RETURN DS 0H LM R14,R12,12(R13) BR R14 DO#ZD DS 0H UNPK 0(4,R1),PDTEMP(8) B RETURN DO#ZDU DS 0H UNPK 0(4,R1),PDTEMP(8) NI 3(R1),X'F0' B RETURN DO#ZDL DS 0H UNPK 0(4,R1),PDTEMP(8) MVZ 0(1,R1),3(R1) OI 3(R1),X'F0' B RETURN DO#ZDLS DS 0H UNPK 1(3,R1),PDTEMP(8) MVI 0(R1),C' ' LTR R0,R0 BNM *+4+4 MVI 0(R1),C'-' B RETURN DO#ZDTS DS 0H UNPK 0(3,R1),PDTEMP(8) MVI 3(R1),C' ' LTR R0,R0 BNM *+4+4 MVI 3(R1),C'-' B RETURN DO#PD DS 0H MVC 0(4,R1),PDTEMP B RETURN DO#PDU DS 0H MVC 0(4,R1),PDTEMP NI 3(R1),X'FC' B RETURN * LIT#ZD DC C'ZD',X'00' LIT#ZDU DC C'ZDU',X'00' LIT#ZDL DC C'ZDL',X'00' LIT#ZDLS DC C'ZDLS',X'00' LIT#ZDTS DC C'ZDTS',X'00' LIT#PD DC C'PD',X'00' LIT#PDU DC C'PDU',X'00' PDTEMP DS D TEMP DS 0D,CL4 LTORG END *====================================================================* * CONVBIN is an assembler program to allow floating point values * * to be converted to certain COBOL representations. * *====================================================================* *=====CONVBIN: ASM=====================================================* R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 CONVBIN CSECT USING CONVBIN,R10 STM R14,R12,12(R13) LR R10,R15 LM R1,R3,0(R1) MVC TEMP(4),0(R1) L R0,0(R2) CLC 0(2+1,R3),LIT#ZD BE DO#ZD CLC 0(3+1,R3),LIT#ZDU BE DO#ZDU CLC 0(3+1,R3),LIT#ZDL BE DO#ZDL CLC 0(4+1,R3),LIT#ZDLS BE DO#ZDLS CLC 0(4+1,R3),LIT#ZDTS BE DO#ZDTS CLC 0(2+1,R3),LIT#PD BE DO#PD CLC 0(3+1,R3),LIT#PDU BE DO#PDU RETURN DS 0H CVB R0,PDTEMP ST R0,0(R2) LM R14,R12,12(R13) BR R14 DO#ZD DS 0H PACK PDTEMP(8),TEMP(4) CVB R0,PDTEMP B RETURN DO#ZDU DS 0H NI TEMP+3,X'CF' PACK PDTEMP(8),TEMP(4) B RETURN DO#ZDL DS 0H MVZ TEMP+3(1),TEMP OI TEMP,X'F0' PACK PDTEMP(8),TEMP(4) B RETURN DO#ZDLS DS 0H CLI TEMP,C'-' BNE *+4+4+4 NI TEMP+3,X'DF' B *+4+4 NI TEMP+3,X'CF' MVI TEMP,X'F0' B DO#ZD DO#ZDTS DS 0H MVC X1(1),TEMP+3 MVC PDTEMP(3),TEMP MVC TEMP+1(3),PDTEMP MVI TEMP,X'F0' CLI X1,C'-' BNE *+4+4+4 NI TEMP+3,X'DF' B *+4+4 NI TEMP+3,X'CF' B DO#ZD DO#PD DS 0H XC PDTEMP(4),PDTEMP MVC PDTEMP+4(4),TEMP B RETURN DO#PDU DS 0H NI TEMP+3,X'FC' B DO#PD * LIT#ZD DC C'ZD',X'00' LIT#ZDU DC C'ZDU',X'00' LIT#ZDL DC C'ZDL',X'00' LIT#ZDLS DC C'ZDLS',X'00' LIT#ZDTS DC C'ZDTS',X'00' LIT#PD DC C'PD',X'00' LIT#PDU DC C'PDU',X'00' PDTEMP DS D TEMP DS 0D,CL4 X1 DS C LTORG END *====================================================================* * DECUSED demonstrates how decimal places are handled. Each argument * * is incremented by 1. * *====================================================================* *=====DECUSED: COBOL===================================================* **************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. DECUSED. **************************************************************** ENVIRONMENT DIVISION. **************************************************************** DATA DIVISION. WORKING-STORAGE SECTION. LINKAGE SECTION. ****EXTERNAL DECIMAL 01 ZD4-1 PIC S999V9 DISPLAY. 01 PD4-1 PIC 99999V9 PACKED-DECIMAL. 01 IB2-1 PIC S999V9 BINARY. 01 PIC4-1 PIC 999V9. **************************************************************** PROCEDURE DIVISION USING ZD4-1, PD4-1, IB2-1, PIC4-1. ADD 1 TO ZD4-1 GIVING ZD4-1. ADD 1 TO PD4-1 GIVING PD4-1. ADD 1 TO IB2-1 GIVING IB2-1. ADD 1 TO PIC4-1 GIVING PIC4-1. GOBACK. END PROGRAM DECUSED. *=====DECUSED: C=======================================================* void DECUSED(zd4_1,pd4_1,ib2_1,pic4_1) char *zd4_1; char *pd4_1; char *ib2_1; char *pic4_1; { int temp; convbin(zd4_1,&temp,'ZD'); temp++; convback(zd4_1,temp,'ZD'); convbin(pd4_1,&temp,'PD'); temp++; convback(pd4_1,temp,'PD'); *ib2_1++; convbin(pic4_1,&temp,'ZDU'); temp++; convback(pic4_1,temp,'ZDU'); } *====================================================================* * FDTEST demonstrates the use of field definitions. * *====================================================================* *=====FDTEST: COBOL====================================================* **************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. FDTEST. **************************************************************** ENVIRONMENT DIVISION. **************************************************************** DATA DIVISION. LINKAGE SECTION. 01 FD-1. 10 KEY-1 PIC X(10). 10 AGE-1 PIC 999 DISPLAY. 10 NAME-1 PIC X(20). 01 FD-2. 10 SEX-1 PIC X. 10 BDATE-1 PIC X(6). 10 VALUE-1 PIC 9999 DISPLAY. **************************************************************** PROCEDURE DIVISION USING FD-1, FD-2. IF KEY-1 = "ABCDEFGHIJ" THEN PERFORM GET-ABCDEFGHIJ ELSE IF KEY-1 = "1234567890" THEN PERFORM GET-1234567890. GOBACK. GET-ABCDEFGHIJ. MOVE 25 TO AGE-1 MOVE "JANE JONES" TO NAME-1 MOVE "F" TO SEX-1 MOVE "102767" TO BDATE-1 MOVE 133 TO VALUE-1 GOBACK. GET-1234567890. MOVE 38 TO AGE-1 MOVE "RICK LANGSTON" TO NAME-1 MOVE "M" TO SEX-1 MOVE "031955" TO BDATE-1 MOVE 427 TO VALUE-1. GOBACK. END PROGRAM FDTEST. *=====FDTEST: C========================================================* void FDTEST(fd_1,fd_2) struct FD_1 { char key_1[10]; char age_1[3]; char name_1[20]; } *fd_1; struct FD_2 { char sex_1; char bdate_1[6]; char value_1[4]; } *fd_2; { if (memcmp(fd_1->key_1,"ABCDEFGHIJ",10) == 0) { memcpy(fd_1->age_1,"025",3); memcpy(fd_1->name_1,"JANE JONES ",10); fd_2->sex_1 = 'F'; memcpy(fd_2->bdate_1,"102767",6); memcpy(fd_2->value_1,"0133",4); } else if (memcmp(fd_1->key_1,"1234567890",10) == 0) { memcpy(fd_1->age_1,"038",3); memcpy(fd_1->name_1,"RICK LANGSTON ",10); fd_2->sex_1 = 'M'; memcpy(fd_2->bdate_1,"031955",6); memcpy(fd_2->value_1,"0427",6); } } *====================================================================* * NUMCHAR allows a test to show how to convert between numeric and * * character values. An attribute entry needs to accompany this * * routine. * *====================================================================* *=====NUMCHAR: COBOL===================================================* **************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. NUMCHAR. **************************************************************** ENVIRONMENT DIVISION. **************************************************************** DATA DIVISION. WORKING-STORAGE SECTION. 01 TMP PIC X. LINKAGE SECTION. 01 NUMVALUE PIC S9999 DISPLAY. 01 CHRVALUE PIC X(3). 01 CHRVALUEX REDEFINES CHRVALUE. 10 CHRVALUEY PIC X OCCURS 3 TIMES. **************************************************************** PROCEDURE DIVISION USING NUMVALUE, CHRVALUE. IF NUMVALUE = 1 THEN MOVE "123" TO CHRVALUE ELSE IF NUMVALUE = 2 THEN PERFORM SWAP-1-AND-3 ELSE MOVE "ABC" TO CHRVALUE. ADD 1 TO NUMVALUE GIVING NUMVALUE. GOBACK. SWAP-1-AND-3. MOVE CHRVALUEY(1) TO TMP MOVE CHRVALUEY(3) TO CHRVALUEY(1) MOVE TMP TO CHRVALUEY(3) GOBACK. END PROGRAM NUMCHAR. *=====NUMCHAR: C=======================================================* void NUMCHAR(numvalue,chrvalue) char *numvalue; char *chrvalue; { int number; char temp[5]; char tmp; sscanf(numvalue,"%d",&number); if (number == 4) { memcpy(chrvalue,"123",3); } else if (number == 2) { tmp = chrvalue[0]; chrvalue[0] = chrvalue[2]; chrvalue[2] = tmp; } else memcpy(chrvalue,"ABC",3); number++; sprintf(temp,"%04d",number); memcpy(numvalue,temp,4); *====================================================================* * OKNULL demonstrates the allowance of null arguments. * *====================================================================* *=====OKNULL: COBOL====================================================* **************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. OKNULL. **************************************************************** ENVIRONMENT DIVISION. **************************************************************** DATA DIVISION. LINKAGE SECTION. 01 KEY-1 PIC S9999 BINARY. 01 VALUE-1 PIC S9999 BINARY. 01 VALUE-2 PIC S9999 BINARY. **************************************************************** PROCEDURE DIVISION USING KEY-1, VALUE-1, VALUE-2. IF KEY-1 = 1 THEN MOVE 100 TO VALUE-1 ELSE IF KEY-1 = 2 THEN MOVE 200 TO VALUE-2. GOBACK. END PROGRAM OKNULL. *=====OKNULL: C========================================================* void OKNULL(key_1,value_1,value_2) short *key_1; short *value_1; short *value_2; { if (*key_1 == 1) *value_1 = 100; else if (*key_1 == 2) *value_2 = 200; } *====================================================================* * RECALL shows how a subroutine can be called multiple times to * * increment resident values. * *====================================================================* *=====RECALL: C========================================================* static double incremented_value; void RECALL(value) double *value; { if (*value == 0) incremented_value = 0; *value = ++incremented_value; } *=====RECALL: COBOL====================================================* **************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. RECALL. **************************************************************** ENVIRONMENT DIVISION. **************************************************************** DATA DIVISION. WORKING-STORAGE SECTION. 01 INCREMENTED-VALUE COMP-2. LINKAGE SECTION. 01 RB8 COMP-2. **************************************************************** PROCEDURE DIVISION USING RB8. IF RB8 = 0 THEN MOVE 0 TO INCREMENTED-VALUE. ADD 1 TO INCREMENTED-VALUE GIVING INCREMENTED-VALUE. MOVE INCREMENTED-VALUE TO RB8. GOBACK. END PROGRAM RECALL. *====================================================================* * This SAS program tests out the various test programs. * *====================================================================* *-----get temporary file names for SASCBTBL-----*; %macro setfile; %global tablname; %if &sysscp=OS %then %do; %let tablname='&&cbtbl'; %end; %else %if &sysscp=CMS %then %do; %let tablname='sascbtbl data'; %end; %else %if &sysscp=VMS %then %do; %let tablname='sascbtbl.dat'; %end; %mend; %setfile; filename sascbtbl &tablname; *-----I can be set to blank or to I to allow for extra log info-----*; %let I=; *-----get a help listing-----*; data _null_; one = 1; call cobolint('*H'); run; *-----create SASCBTBL file-----*; data _null_; file sascbtbl; input; put _infile_; cards4; routine change4 minarg=1 maxarg=1; arg 1 update format=$char4.; routine fdtest minarg=6 maxarg=6; arg 1 input char format=$10. fdstart; * key ; arg 2 output num format=3.; * age ; arg 3 output char format=20.; * name ; arg 4 output char format=1. fdstart; * sex ; arg 5 output num format=6.; * birthdate ; arg 6 output num format=zd4.; * value ; routine oknull minarg=2 maxarg=3; arg 1 input num format=ib2.; arg 2 output notreqd num format=ib2.; arg 3 output notreqd num format=ib2.; routine decused minarg=4 maxarg=4; arg 1 update format=zd4.1; arg 2 update format=pd4.1; arg 3 update format=ib2.1; arg 4 update format=4.1; routine numchar minarg=2 maxarg=2; arg 1 format=zd4.; arg 2 format=$char3.; routine coboltst minarg=1 maxarg=12; arg 1 format=zd4.; arg 2 format=s370fzdu4.; arg 3 format=s370fzdl4.; arg 4 format=s370fzds4.; arg 5 format=s370fzdt4.; arg 6 format=ib2.; arg 7 format=s370fibu2.; arg 8 format=pd3.; arg 9 format=s370fpdu3.; arg 10 format=rb8.; arg 11 format=rb4.; arg 12 format=$char10.; routine intup1 minarg=1 maxarg=1; arg 1 format=ib4.; routine dblup1 minarg=1 maxarg=1; arg 1 format=rb8.; routine chrup1 minarg=1 maxarg=1; arg 1 format=$char8.; ;;;; *-----print contents of attribute table-----*; data _null_; call cobolint('*T'); run; *-----ensure padding is done as needed-----*; data _null_; x='xxxxxxxx'; call cobolint("*&i.",'change4',x); put x= x=$hex16.; run; *-----ensure null argument OK, not using attr table-----*; data _null_; length key value1 value2 $2; key='0001'x; call cobolint("*a&i.",'oknull',key,value1,); /* null argument */ x=input(value1,ib2.); put x= ' (should be 100)'; value1='0000'x; call cobolint("*a&i.",'oknull',key,value1);/* omitted last arg */ x=input(value1,ib2.); put x= ' (should be 100)'; key=put(2,ib2.); call cobolint("*a&i.",'oknull',key,,value2); /* null argument */ x=input(value2,ib2.); put x= ' (should be 200)'; run; *-----ensure null argument OK, using attr table-----*; data _null_; length value1 value2 8; call cobolint("*&i.",'oknull',1,value1,); /* null argument */ put value1= ' (should be 100)'; value1=0; call cobolint("*&i.",'oknull',1,value1);/* omitted last arg */ put value1= ' (should be 100)'; key=put(2,ib2.); call cobolint("*&i",'oknull',2,,value2); /* null argument */ put value2= ' (should be 200)'; run; *-----ensure required argument not null-----*; data _null_; length value1 value2 8; call cobolint("*&i.",'oknull',,value1,value2); run; *-----ensure updated argument not passed as constant-----*; data _null_; length value1 8; call cobolint("*&i.",'oknull',1,10 ,20); value1 = 30; call cobolint("*&i.",'oknull',2,value1 ,40); run; *-----using less than minimum-----; data _null_; x1=1; call cobolint('decused',x1); run; *-----using more than maximum-----; data _null_; array x x1-x5; do over x; x=_i_; end; call cobolint('decused',of x1-x5); run; *-----repeat using e option to show message-----; data _null_; x1=1; call cobolint('*e','decused',x1); run; *-----using more than maximum-----; data _null_; array x x1-x5; do over x; x=_i_; end; call cobolint('*e','decused',of x1-x5); run; *-----use unknown module-----*; data _null_; call cobolint("*&i.",'notthere','xyz'); run; *-----test DECUSED without attribute table-----*; data _null_; length y1 $4 y2 $4 y3 $2 y4 $4; array x x1-x4; do over x; x=_i_; end; y1=put(x1,zd4.1); y2=put(x2,pd4.1); y3=put(x3,ib2.1); y4=put(x4*10,z4.); put 'BEFORE CALL: ' x1= x2= x3= x4=; put 'INTERMEDIATE VALUES: ' y1=$hex8. y2=$hex8. y3=$hex4. y4=$hex8.; call cobolint("*a&i.",'decused',of y1-y4); put 'INTERMEDIATE VALUES: ' y1=$hex8. y2=$hex8. y3=$hex4. y4=$hex8.; x1=input(y1,zd4.1); x2=input(y2,pd4.1); x3=input(y3,ib2.1); x4=input(y4,4.1); put 'AFTER CALL: ' x1= x2= x3= x4=; run; *-----test DECUSED with attribute table-----*; data _null_; array x x1-x4; do over x; x=_i_; end; put 'BEFORE CALL: ' x1= x2= x3= x4=; call cobolint("*&i.",'decused',of x1-x4); put 'AFTER CALL: ' x1= x2= x3= x4=; run; *-----test NUMCHAR-----*; data _null_; length x1 8 x2 $3 x3 $8 x4 8; x2='xyz'; do i=1 to 3; x1=i; link callit1; end; x2='xyz'; do x3='1','2','3','xxx'; link callit2; end; x4=1; do i=1 to 3; x1=i; link callit3; end; x4=1; do x3='1','2','3','xxx'; link callit4; end; return; callit1:; put 'both arguments have correct attributes'; put 'before call: ' x1= x2=; call cobolint("*&i.",'numchar',x1,x2); put 'after call: ' x1= x2=; return; callit2:; put 'arg 1 must be converted from char to num'; put 'before call: ' x3= x2=; call cobolint("*&i.",'numchar',x3,x2); put 'after call: ' x3= x3=$hex16. x2=; return; callit3:; put 'arg 2 must be converted num to char'; put 'before call: ' x1= x4=; call cobolint("*&i",'numchar',x1,x4); put 'after call: ' x1= x4=; return; callit4:; put 'arg 1 must be converted from char to num'; put 'arg 2 must be converted num to char'; put 'before call: ' x3= x4=; call cobolint("*&i.",'numchar',x3,x4); put 'after call: ' x3= x3=$hex16. x4=; return; run; *-----testing FDTEST-----*; data _null_; length key $10; length age 8 name $30 sex $1 bdate 8 value 8; input key $ @@; call cobolint("*&i",'fdtest',key,age,name,sex,bdate,value); put _all_; cards; ABCDEFGHIJ 1234567890 INVALIDKEY ABCDEFGHIJ 1234567890 ; *-----testing FDTEST not using attribute table-----*; data _null_; length key $10; length age $3 value $4 name $20 sex $1 bdate $6; input key $ @@; call cobolint("*&i.as/",'fdtest','/',key ,age,name, '/',sex,bdate,value ); valuex=input(value,zd4.); put _all_; cards; ABCDEFGHIJ 1234567890 INVALIDKEY ABCDEFGHIJ 1234567890 ; *-----testing xxxUP1 with attributes-----*; data _null_; x=1; call cobolint("*&i.",'intup1',x); put x= ' (should be 2)'; x=1; call cobolint("*&i.",'dblup1',x); put x= ' (should be 2)'; y='ABCDEFGH'; call cobolint("*&i.",'chrup1',y); put y= ' (should be BCDEFGHI)'; run; *-----testing xxxUP1 without attributes-----*; data _null_; x=put(1,ib4.); call cobolint("*&i.a",'intup1',x); x2=input(x,ib4.); put x2= ' (should be 2)'; x2=1; call cobolint("*&i.a",'dblup1',x2); put x2= ' (should be 2)'; y='ABCDEFGH'; call cobolint("*&i.a",'chrup1',y); put y= ' (should be BCDEFGHI)'; run; *-----testing RECALL (no attributes)-----*; data _null_; value=0; do i=1 to 10; call cobolint("*&i.",'recall',value); put i= value= ' (i and value should match each time)'; end; run; *-----testing COBOLTST and COBOLTS2 without attributes-----*; DATA _NULL_; LENGTH V1-V11 8 V12 $8 ; LENGTH X1 X2 X3 X4 X5 $4 X6 X7 $2 X8 X9 $3 X10 8 X11 $4 X12 $8 ; ARRAY V V1-V11; PUT 'TESTING COBOLTST...'; DO OVER V; V=1; END; V12='ABCDEFGH'; LINK SETARGS; CALL COBOLINT('*&I.A', 'COBOLTST',OF X1-X12); LINK GETARGS; PUT V1= V2= V3= V4= V5= V6= V7= V8= V9= V10= V11= V12=; PUT 'TESTING COBOLTS2...'; DO OVER V; V=1; END; V12='ABCDEFGH'; LINK SETARGS; CALL COBOLINT('*&I.AS', 'COBOLTS2',OF X1-X12); LINK GETARGS; PUT V1= V2= V3= V4= V5= V6= V7= V8= V9= V10= V11= V12=; RETURN; SETARGS:; X1 = PUT(V1 ,ZD4. ); X2 = PUT(V2 ,S370FZDU4.); X3 = PUT(V3 ,S370FZDL4.); X4 = PUT(V4 ,S370FZDS4.); X5 = PUT(V5 ,S370FZDT4.); X6 = PUT(V6 ,IB2. ); X7 = PUT(V7 ,S370FIBU2.); X8 = PUT(V8 ,PD3. ); X9 = PUT(V9 ,S370FPDU3.); X10 = V10 ; X11 = PUT(V11,RB4. ); X12 = V12; RETURN; GETARGS:; V1 = INPUT(X1 ,ZD4. ); V2 = INPUT(X2 ,S370FZDU4.); V3 = INPUT(X3 ,S370FZDL4.); V4 = INPUT(X4 ,S370FZDS4.); V5 = INPUT(X5 ,S370FZDT4.); V6 = INPUT(X6 ,IB2. ); V7 = INPUT(X7 ,S370FIBU2.); V8 = INPUT(X8 ,PD3. ); V9 = INPUT(X9 ,S370FPDU3.); V10 = X10 ; V11 = INPUT(X11,RB4. ); V12 = X12; RETURN; *-----testing COBOLTST with attributes-----*; DATA _NULL_; LENGTH V1-V11 8 V12 $8 ; ARRAY V V1-V11; DO OVER V; V=1; END; V12='ABCDEFGH'; CALL COBOLINT('*I','COBOLTST',OF V1-V12); PUT V1= V2= V3= V4= V5= V6= V7= V8= V9= V10= V11= V12=; RUN;