1## Copyright (C) 2003-2012, 2014-2020 Free Software Foundation, Inc. 2## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, 3## Ron Norman 4## 5## This file is part of GnuCOBOL. 6## 7## The GnuCOBOL compiler is free software: you can redistribute it 8## and/or modify it under the terms of the GNU General Public License 9## as published by the Free Software Foundation, either version 3 of the 10## License, or (at your option) any later version. 11## 12## GnuCOBOL is distributed in the hope that it will be useful, 13## but WITHOUT ANY WARRANTY; without even the implied warranty of 14## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15## GNU General Public License for more details. 16## 17## You should have received a copy of the GNU General Public License 18## along with GnuCOBOL. If not, see <https://www.gnu.org/licenses/>. 19 20### GnuCOBOL Test Suite 21 22 23AT_SETUP([Comma separator without space]) 24AT_KEYWORDS([runmisc]) 25 26AT_DATA([prog.cob], [ 27 IDENTIFICATION DIVISION. 28 PROGRAM-ID. prog. 29 PROCEDURE DIVISION. 30 DISPLAY 1,1,1 NO ADVANCING 31 END-DISPLAY. 32 STOP RUN. 33]) 34 35AT_CHECK([$COMPILE prog.cob], [0], [], []) 36AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [111]) 37 38AT_CLEANUP 39 40 41## TODO: Check if the following DECIMAL-POINT tests are really all extensions. 42 43 44AT_SETUP([DECIMAL-POINT is COMMA (1)]) 45AT_KEYWORDS([misc extensions]) 46 47AT_DATA([prog.cob], [ 48 IDENTIFICATION DIVISION. 49 PROGRAM-ID. prog. 50 ENVIRONMENT DIVISION. 51 CONFIGURATION SECTION. 52 SPECIAL-NAMES. 53 DECIMAL-POINT IS COMMA. 54 DATA DIVISION. 55 WORKING-STORAGE SECTION. 56 01 X PIC 99V99. 57 PROCEDURE DIVISION. 58 MOVE FUNCTION MIN (3,,,,,,5) TO X. 59 DISPLAY X 60 END-DISPLAY. 61 STOP RUN. 62]) 63 64AT_CHECK([$COMPILE prog.cob], [0], [], []) 65AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 66[00,50 67]) 68 69AT_CLEANUP 70 71 72AT_SETUP([DECIMAL-POINT is COMMA (2)]) 73AT_KEYWORDS([misc extensions]) 74 75AT_DATA([prog.cob], [ 76 IDENTIFICATION DIVISION. 77 PROGRAM-ID. prog. 78 ENVIRONMENT DIVISION. 79 CONFIGURATION SECTION. 80 SPECIAL-NAMES. 81 DECIMAL-POINT IS COMMA. 82 DATA DIVISION. 83 WORKING-STORAGE SECTION. 84 01 X PIC 99V99. 85 PROCEDURE DIVISION. 86 MOVE FUNCTION MIN (3,,,,,, 5) TO X. 87 DISPLAY X 88 END-DISPLAY. 89 STOP RUN. 90]) 91 92AT_CHECK([$COMPILE prog.cob], [0], [], []) 93AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 94[03,00 95]) 96 97AT_CLEANUP 98 99 100AT_SETUP([DECIMAL-POINT is COMMA (3)]) 101AT_KEYWORDS([misc extensions]) 102 103AT_DATA([prog.cob], [ 104 IDENTIFICATION DIVISION. 105 PROGRAM-ID. prog. 106 ENVIRONMENT DIVISION. 107 CONFIGURATION SECTION. 108 SPECIAL-NAMES. 109 DECIMAL-POINT IS COMMA. 110 DATA DIVISION. 111 WORKING-STORAGE SECTION. 112 01 X PIC 99V99. 113 PROCEDURE DIVISION. 114 MOVE FUNCTION MIN (3,,,,,, 1,5) TO X. 115 DISPLAY X 116 END-DISPLAY. 117 STOP RUN. 118]) 119 120AT_CHECK([$COMPILE prog.cob], [0], [], []) 121AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 122[01,50 123]) 124 125AT_CLEANUP 126 127 128AT_SETUP([DECIMAL-POINT is COMMA (4)]) 129AT_KEYWORDS([misc extensions]) 130 131AT_DATA([prog.cob], [ 132 IDENTIFICATION DIVISION. 133 PROGRAM-ID. prog. 134 ENVIRONMENT DIVISION. 135 CONFIGURATION SECTION. 136 SPECIAL-NAMES. 137 DECIMAL-POINT IS COMMA. 138 DATA DIVISION. 139 WORKING-STORAGE SECTION. 140 01 X PIC 99V99. 141 PROCEDURE DIVISION. 142 MOVE FUNCTION MIN (3,,,,,,1,5) TO X. 143 DISPLAY X 144 END-DISPLAY. 145 STOP RUN. 146]) 147 148AT_CHECK([$COMPILE prog.cob], [0], [], []) 149AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 150[00,10 151]) 152 153AT_CLEANUP 154 155 156AT_SETUP([DECIMAL-POINT is COMMA (5)]) 157AT_KEYWORDS([misc extensions]) 158 159AT_DATA([prog.cob], [ 160 IDENTIFICATION DIVISION. 161 PROGRAM-ID. prog. 162 ENVIRONMENT DIVISION. 163 CONFIGURATION SECTION. 164 SPECIAL-NAMES. 165 DECIMAL-POINT IS COMMA. 166 DATA DIVISION. 167 WORKING-STORAGE SECTION. 168 01 X PIC 99V99. 169 PROCEDURE DIVISION. 170 COMPUTE X=1 + ,1 171 END-COMPUTE 172 DISPLAY X 173 END-DISPLAY. 174 COMPUTE X=1*,1 175 END-COMPUTE 176 DISPLAY X 177 END-DISPLAY. 178 STOP RUN. 179]) 180 181AT_CHECK([$COMPILE prog.cob], [0], [], []) 182AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 183[01,10 18400,10 185]) 186 187AT_CLEANUP 188 189 190AT_SETUP([CURRENCY SIGN]) 191AT_KEYWORDS([misc fundamental]) 192 193AT_DATA([prog.cob], [ 194 PROGRAM-ID. prog. 195 196 ENVIRONMENT DIVISION. 197 CONFIGURATION SECTION. 198 SPECIAL-NAMES. 199 CURRENCY SIGN IS "Y". 200 201 DATA DIVISION. 202 WORKING-STORAGE SECTION. 203 77 amount pic Y(6)9.99. 204 205 PROCEDURE DIVISION. 206 Move 1512.34 to Amount 207 Display "Amount is #" Amount '#' with no advancing. 208 209 GOBACK 210 . 211 END PROGRAM prog. 212]) 213 214AT_CHECK([$COMPILE prog.cob], [0], [], []) 215AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 216[Amount is # Y1512.34#]) 217 218AT_CLEANUP 219 220 221AT_SETUP([CURRENCY SIGN WITH PICTURE SYMBOL]) 222AT_KEYWORDS([misc fundamental]) 223 224# FIXME - see FR #246 225AT_XFAIL_IF(true) 226 227AT_DATA([prog.cob], [ 228 PROGRAM-ID. prog. 229 230 ENVIRONMENT DIVISION. 231 CONFIGURATION SECTION. 232 SPECIAL-NAMES. 233 *> note the space after EUR / before ct. 234 CURRENCY SIGN IS "EUR " WITH PICTURE SYMBOL "U", 235 CURRENCY SIGN IS " ct (EUR)" WITH PICTURE SYMBOL "c", 236 Currency Sign is "$US" with Picture Symbol "$". 237 238 DATA DIVISION. 239 WORKING-STORAGE SECTION. 240 77 EUROS PIC U99v99. 241 77 cents PIC c9,999. 242 77 DOLLARS Pic $$,$$9.99. 243 244 PROCEDURE DIVISION. 245 MOVE 12.34 TO EUROS 246 MULTIPLY euros BY 1000 GIVING cents. 247 DISPLAY "#" EUROS "# equal #" cents '#'. 248 Move 1500 to Invoice-Amount 249 Display "Invoice amount #1 is " Invoice-Amount '.'. 250 Move 12.34 to Invoice-Amount 251 Display "Invoice amount #2 is " Invoice-Amount '.'. 252 253 GOBACK 254 . 255 END PROGRAM prog. 256]) 257 258AT_CHECK([$COMPILE prog.cob], [0], [], []) 259AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 260[#EUR 12.34# equal #1,234 ct (EUR)# 261Invoice amount #1 is $US1,500.00. 262Invoice amount #2 is $US12.34. 263]) 264 265AT_CLEANUP 266 267 268AT_SETUP([LOCAL-STORAGE (1)]) 269AT_KEYWORDS([runmisc]) 270 271AT_DATA([callee.cob], [ 272 IDENTIFICATION DIVISION. 273 PROGRAM-ID. callee. 274 DATA DIVISION. 275 WORKING-STORAGE SECTION. 276 01 WRK-X PIC XXX VALUE "abc". 277 LOCAL-STORAGE SECTION. 278 01 LCL-X PIC XXX VALUE "abc". 279 PROCEDURE DIVISION. 280 DISPLAY WRK-X LCL-X NO ADVANCING 281 END-DISPLAY. 282 MOVE ZERO TO WRK-X LCL-X. 283 EXIT PROGRAM. 284]) 285 286AT_DATA([caller.cob], [ 287 IDENTIFICATION DIVISION. 288 PROGRAM-ID. caller. 289 PROCEDURE DIVISION. 290 CALL "callee" 291 END-CALL. 292 CALL "callee" 293 END-CALL. 294 STOP RUN. 295]) 296 297AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 298AT_CHECK([$COMPILE -o prog caller.cob], [0], [], []) 299AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [abcabc000abc], []) 300 301AT_CLEANUP 302 303 304AT_SETUP([LOCAL-STORAGE (2)]) 305AT_KEYWORDS([runmisc]) 306 307AT_DATA([callee2.cob], [ 308 IDENTIFICATION DIVISION. 309 PROGRAM-ID. callee2. 310 DATA DIVISION. 311 LINKAGE SECTION. 312 01 LNK-X PIC XXX. 313 PROCEDURE DIVISION USING LNK-X. 314 DISPLAY LNK-X NO ADVANCING 315 END-DISPLAY. 316 EXIT PROGRAM. 317]) 318 319AT_DATA([callee.cob], [ 320 IDENTIFICATION DIVISION. 321 PROGRAM-ID. callee. 322 DATA DIVISION. 323 LOCAL-STORAGE SECTION. 324 01 LCL-X. 325 05 FILLER PIC XXX VALUE "abc". 326 PROCEDURE DIVISION. 327 CALL "callee2" USING LCL-X 328 END-CALL. 329 MOVE ZERO TO LCL-X. 330 CALL "callee2" USING LCL-X 331 END-CALL. 332 EXIT PROGRAM. 333]) 334 335AT_DATA([caller.cob], [ 336 IDENTIFICATION DIVISION. 337 PROGRAM-ID. caller. 338 PROCEDURE DIVISION. 339 CALL "callee" 340 END-CALL. 341 STOP RUN. 342]) 343 344AT_CHECK([$COMPILE_MODULE callee2.cob], [0], [], []) 345AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 346AT_CHECK([$COMPILE -o prog caller.cob], [0], [], []) 347AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [abc000], []) 348 349AT_CLEANUP 350 351 352AT_SETUP([EXTERNAL data item]) 353AT_KEYWORDS([runmisc]) 354 355AT_DATA([callee.cob], [ 356 IDENTIFICATION DIVISION. 357 PROGRAM-ID. callee. 358 DATA DIVISION. 359 WORKING-STORAGE SECTION. 360 01 EXT-VAR PIC X(5) EXTERNAL. 361 PROCEDURE DIVISION. 362 IF EXT-VAR NOT = "Hello" 363 DISPLAY EXT-VAR 364 END-DISPLAY 365 END-IF. 366 MOVE "World" TO EXT-VAR. 367 EXIT PROGRAM. 368]) 369 370AT_DATA([caller.cob], [ 371 IDENTIFICATION DIVISION. 372 PROGRAM-ID. caller. 373 DATA DIVISION. 374 WORKING-STORAGE SECTION. 375 01 EXT-VAR PIC X(5) EXTERNAL. 376 PROCEDURE DIVISION. 377 MOVE "Hello" TO EXT-VAR. 378 CALL "callee" 379 END-CALL. 380 IF EXT-VAR NOT = "World" 381 DISPLAY EXT-VAR 382 END-DISPLAY 383 END-IF. 384 STOP RUN. 385]) 386 387AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 388AT_CHECK([$COMPILE caller.cob], [0], [], []) 389AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) 390 391AT_CLEANUP 392 393 394AT_SETUP([EXTERNAL AS data item]) 395AT_KEYWORDS([runmisc]) 396 397AT_DATA([callee.cob], [ 398 IDENTIFICATION DIVISION. 399 PROGRAM-ID. callee. 400 DATA DIVISION. 401 WORKING-STORAGE SECTION. 402 01 PRG-VAR PIC X(5) EXTERNAL AS "WRK-VAR". 403 01 EXT-VAR PIC X(5) EXTERNAL. 404 PROCEDURE DIVISION. 405 IF PRG-VAR NOT = "Extrn" 406 DISPLAY PRG-VAR 407 END-DISPLAY 408 END-IF. 409 IF EXT-VAR NOT = "Hello" 410 DISPLAY EXT-VAR 411 END-DISPLAY 412 END-IF. 413 MOVE "World" TO EXT-VAR. 414 EXIT PROGRAM. 415]) 416 417AT_DATA([caller.cob], [ 418 IDENTIFICATION DIVISION. 419 PROGRAM-ID. caller. 420 DATA DIVISION. 421 WORKING-STORAGE SECTION. 422 01 MYVAR PIC X(5) EXTERNAL AS "EXT-VAR". 423 01 WRK-VAR PIC X(5) EXTERNAL. 424 PROCEDURE DIVISION. 425 MOVE "Extrn" TO WRK-VAR. 426 MOVE "Hello" TO MYVAR. 427 CALL "callee" 428 END-CALL. 429 IF MYVAR NOT = "World" 430 DISPLAY MYVAR 431 END-DISPLAY 432 END-IF. 433 STOP RUN. 434]) 435 436AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 437AT_CHECK([$COMPILE caller.cob], [0], [], []) 438AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) 439 440AT_CLEANUP 441 442 443AT_SETUP([EXTERNAL data item size mismatch]) 444AT_KEYWORDS([runmisc]) 445 446# FIXME - see Bug #445 447AT_XFAIL_IF(true) 448 449AT_DATA([callee.cob], [ 450 IDENTIFICATION DIVISION. 451 PROGRAM-ID. callee. 452 DATA DIVISION. 453 WORKING-STORAGE SECTION. 454 01 PRG-VAR PIC X(8) EXTERNAL AS "WRK-VAR". 455 01 COB-VAR PIC X(8) EXTERNAL. 456 01 EXT-VAR PIC X(8) EXTERNAL. 457 PROCEDURE DIVISION. 458 IF PRG-VAR NOT = "Extrn" 459 DISPLAY PRG-VAR 460 END-DISPLAY 461 END-IF. 462 IF EXT-VAR NOT = "Hello" 463 DISPLAY EXT-VAR 464 END-DISPLAY 465 END-IF. 466 MOVE "World" TO EXT-VAR. 467 EXIT PROGRAM. 468]) 469 470AT_DATA([bigger.cob], [ 471 IDENTIFICATION DIVISION. 472 PROGRAM-ID. error. 473 DATA DIVISION. 474 WORKING-STORAGE SECTION. 475 01 MYVAR PIC X(10) EXTERNAL AS "COB-VAR". 476 01 WRK-VAR PIC X(10) EXTERNAL. 477 01 EXT-VAR PIC X(10) EXTERNAL. 478 PROCEDURE DIVISION. 479 MOVE "Extrn" TO WRK-VAR. 480 MOVE "Hello" TO MYVAR. 481 CALL "callee" 482 END-CALL. 483 IF MYVAR NOT = "World" 484 DISPLAY MYVAR 485 END-DISPLAY 486 END-IF. 487 STOP RUN. 488]) 489 490AT_DATA([smaller.cob], [ 491 IDENTIFICATION DIVISION. 492 PROGRAM-ID. error. 493 DATA DIVISION. 494 WORKING-STORAGE SECTION. 495 01 MYVAR PIC X(5) EXTERNAL AS "COB-VAR". 496 01 WRK-VAR PIC X(5) EXTERNAL. 497 01 EXT-VAR PIC X(5) EXTERNAL. 498 PROCEDURE DIVISION. 499 MOVE "Extrn" TO WRK-VAR. 500 MOVE "Hello" TO MYVAR. 501 CALL "callee" 502 END-CALL. 503 IF MYVAR NOT = "World" 504 DISPLAY MYVAR 505 END-DISPLAY 506 END-IF. 507 STOP RUN. 508]) 509 510AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 511AT_CHECK([$COMPILE bigger.cob], [0], [], []) 512AT_CHECK([$COBCRUN_DIRECT ./bigger], [0], [], 513[libcob: callee.cob:6: warning: EXTERNAL item 'WRK-VAR' previously allocated with size 10, requested size is 8 514libcob: callee.cob:7: warning: EXTERNAL item 'EXT-VAR' previously allocated with size 10, requested size is 8 515libcob: callee.cob:8: warning: EXTERNAL item 'EXT-VAR' previously allocated with size 10, requested size is 8 516]) 517 518AT_CHECK([$COMPILE smaller.cob], [0], [], []) 519AT_CHECK([$COBCRUN_DIRECT ./smaller], [1], [], 520[libcob: callee.cob:6: error: EXTERNAL item 'WRK-VAR' previously allocated with size 5, requested size is 8 521]) 522 523AT_CLEANUP 524 525 526## MOVE statement 527 528AT_SETUP([MOVE to itself]) 529AT_KEYWORDS([runmisc]) 530 531AT_DATA([prog.cob], [ 532 IDENTIFICATION DIVISION. 533 PROGRAM-ID. prog. 534 DATA DIVISION. 535 WORKING-STORAGE SECTION. 536 01 X PIC 99 VALUE 12. 537 PROCEDURE DIVISION. 538 MOVE X TO X. 539 IF X NOT = 12 540 DISPLAY X NO ADVANCING 541 END-DISPLAY 542 END-IF. 543 STOP RUN. 544]) 545 546AT_CHECK([$COMPILE prog.cob], [0], [], 547[prog.cob:8: warning: overlapping MOVE may produce unpredictable results 548]) 549AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 550 551AT_CLEANUP 552 553 554AT_SETUP([MOVE with refmod]) 555AT_KEYWORDS([runmisc]) 556 557AT_DATA([prog.cob], [ 558 IDENTIFICATION DIVISION. 559 PROGRAM-ID. prog. 560 DATA DIVISION. 561 WORKING-STORAGE SECTION. 562 01 X PIC 9(4) VALUE 0. 563 PROCEDURE DIVISION. 564 MOVE "1" TO X(1:1). 565 IF X NOT = 1000 566 DISPLAY X NO ADVANCING 567 END-DISPLAY 568 END-IF. 569 STOP RUN. 570]) 571 572AT_CHECK([$COMPILE prog.cob], [0], [], []) 573AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 574 575AT_CLEANUP 576 577 578AT_SETUP([MOVE with refmod (variable)]) 579AT_KEYWORDS([runmisc]) 580 581AT_DATA([prog.cob], [ 582 IDENTIFICATION DIVISION. 583 PROGRAM-ID. prog. 584 DATA DIVISION. 585 WORKING-STORAGE SECTION. 586 01 X PIC X(4) VALUE "1234". 587 01 Y PIC X(4) VALUE "abcd". 588 01 I PIC 9 VALUE 1. 589 PROCEDURE DIVISION. 590 MOVE X(1:I) TO Y. 591 IF Y NOT = "1 " 592 DISPLAY Y NO ADVANCING 593 END-DISPLAY 594 END-IF. 595 STOP RUN. 596]) 597 598AT_CHECK([$COMPILE prog.cob], [0], [], []) 599AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 600 601AT_CLEANUP 602 603 604AT_SETUP([MOVE with group refmod]) 605AT_KEYWORDS([runmisc]) 606 607AT_DATA([prog.cob], [ 608 IDENTIFICATION DIVISION. 609 PROGRAM-ID. prog. 610 DATA DIVISION. 611 WORKING-STORAGE SECTION. 612 01 G. 613 02 X PIC 9999 VALUE 1234. 614 PROCEDURE DIVISION. 615 MOVE "99" TO G(3:2). 616 IF G NOT = "1299" 617 DISPLAY G NO ADVANCING 618 END-DISPLAY 619 END-IF. 620 STOP RUN. 621]) 622 623AT_CHECK([$COMPILE prog.cob], [0], [], []) 624AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 625 626AT_CLEANUP 627 628 629AT_SETUP([MOVE indexes]) 630AT_KEYWORDS([runmisc]) 631 632AT_DATA([prog.cob], [ 633 IDENTIFICATION DIVISION. 634 PROGRAM-ID. prog. 635 DATA DIVISION. 636 WORKING-STORAGE SECTION. 637 01 G. 638 02 X PIC X OCCURS 10 INDEXED I. 639 PROCEDURE DIVISION. 640 SET I TO ZERO. 641 MOVE I TO X(1). 642 IF X(1) NOT = "0" 643 DISPLAY X(1) NO ADVANCING 644 END-DISPLAY 645 END-IF. 646 STOP RUN. 647]) 648 649AT_CHECK([$COMPILE prog.cob], [0], [], []) 650AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 651 652AT_CLEANUP 653 654 655AT_SETUP([MOVE X'00']) 656AT_KEYWORDS([runmisc]) 657 658AT_DATA([dump.c], [ 659#include <stdio.h> 660#include <libcob.h> 661 662COB_EXT_EXPORT int 663dump (unsigned char *data) 664{ 665 printf ("%02x%02x%02x", data[[0]], data[[1]], data[[2]]); 666 return 0; 667} 668]) 669 670AT_DATA([prog.cob], [ 671 IDENTIFICATION DIVISION. 672 PROGRAM-ID. prog. 673 DATA DIVISION. 674 WORKING-STORAGE SECTION. 675 01 X PIC XXX. 676 PROCEDURE DIVISION. 677 MOVE X"000102" TO X. 678 CALL "dump" USING X 679 END-CALL. 680 STOP RUN. 681]) 682 683AT_CHECK([$COMPILE_MODULE dump.c], [0], [], []) 684AT_CHECK([$COMPILE prog.cob], [0], [], []) 685AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [000102]) 686 687AT_CLEANUP 688 689 690AT_SETUP([MOVE Z'literal']) 691AT_KEYWORDS([runmisc literal]) 692 693AT_DATA([prog.cob], [ 694 IDENTIFICATION DIVISION. 695 PROGRAM-ID. prog. 696 DATA DIVISION. 697 WORKING-STORAGE SECTION. 698 01 X PIC XXXX. 699 01 XRED REDEFINES X. 700 03 XBYTE1 PIC X. 701 03 XBYTE2 PIC X. 702 03 XBYTE3 PIC X. 703 03 XBYTE4 PIC X. 704 PROCEDURE DIVISION. 705 MOVE Z"012" TO X. 706 IF XBYTE1 = "0" AND 707 XBYTE2 = "1" AND 708 XBYTE3 = "2" AND 709 XBYTE4 = LOW-VALUE 710 DISPLAY "OK" NO ADVANCING 711 END-DISPLAY 712 ELSE 713 DISPLAY "X = " X (1:3) NO ADVANCING 714 END-DISPLAY 715 IF XBYTE4 = LOW-VALUE 716 DISPLAY " WITH LOW-VALUE" 717 END-DISPLAY 718 ELSE 719 DISPLAY " WITHOUT LOW-VALUE BUT '" XBYTE4 "'" 720 END-DISPLAY 721 END-IF 722 END-IF. 723 STOP RUN. 724]) 725 726AT_CHECK([$COMPILE prog.cob], [0], [], []) 727AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) 728 729AT_CLEANUP 730 731 732AT_SETUP([Floating continuation indicator]) 733AT_KEYWORDS([runmisc]) 734 735AT_DATA([prog.cob], [ 736 IDENTIFICATION DIVISION. 737 PROGRAM-ID. prog. 738 DATA DIVISION. 739 WORKING-STORAGE SECTION. 740 PROCEDURE DIVISION. 741 DISPLAY "OK"- 742 "OK" 743 NO ADVANCING 744 END-DISPLAY 745 STOP RUN. 746]) 747 748AT_CHECK([$COMPILE prog.cob], [0], [], []) 749AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKOK]) 750 751AT_CLEANUP 752 753 754AT_SETUP([Fixed continuation indicator]) 755 756AT_DATA([prog.cob], [ 757 IDENTIFICATION DIVISION. 758 PROGRAM-ID. prog. 759 DATA DIVISION. 760 WORKING-STORAGE SECTION. 761 01 X PIC X(333) VALUE 762 '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWX 763 - 'YZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUV 764 - 'WXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRST 765 - 'UVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQR 766 - 'STUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOP 767 - 'QRSTUVWXYZ'. 768 PROCEDURE DIVISION. 769 DISPLAY X NO ADVANCING 770 END-DISPLAY. 771 DISPLAY '_' 772 END-DISPLAY. 773 MOVE 774 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567 775 - "89abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345 776 - "6789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123 777 - "456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01 778 - "23456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXY 779 - "Z 780 - "0123456789" TO X. 781 DISPLAY X NO ADVANCING 782 END-DISPLAY. 783 DISPLAY '_' 784 END-DISPLAY. 785 STOP RUN. 786]) 787 788AT_CHECK([$COMPILE prog.cob], [0], [], []) 789AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ _ 790abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 _ 791]) 792 793AT_CLEANUP 794 795 796AT_SETUP([Concatenation operator]) 797AT_KEYWORDS([runmisc]) 798 799AT_DATA([prog.cob], [ 800 IDENTIFICATION DIVISION. 801 PROGRAM-ID. prog. 802 DATA DIVISION. 803 WORKING-STORAGE SECTION. 804 77 STR PIC X(05). 805 PROCEDURE DIVISION. 806 MOVE "OK" & " " 807 & "OK" 808 TO STR 809 DISPLAY STR NO ADVANCING 810 END-DISPLAY 811 STOP RUN. 812]) 813 814AT_CHECK([$COMPILE prog.cob], [0], [], []) 815AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK OK]) 816 817AT_CLEANUP 818 819 820AT_SETUP([SOURCE FIXED/FREE directives]) 821AT_KEYWORDS([runmisc SOURCEFORMAT FIXED FREE]) 822 823AT_DATA([prog.cob], [ 824 IDENTIFICATION DIVISION. 825 PROGRAM-ID. prog. 826 >>SOURCE FREE 827 DATA DIVISION. 828 WORKING-STORAGE SECTION. 829 >>SOURCE FIXED 830 PROCEDURE DIVISION. FIXED 831 DISPLAY "OK" NO ADVANCING 832 END-DISPLAY. 833 >>SOURCE FREE 834 DISPLAY 835 "OK" 836 NO ADVANCING 837 END-DISPLAY. 838 >>SET SOURCEFORMAT "FIXED" 839 DISPLAY "OK" NO ADVANCING FIXED 840 END-DISPLAY. 841 >>SET SOURCEFORMAT "FREE" 842 DISPLAY 843 "OK" 844 NO ADVANCING 845 END-DISPLAY. 846 STOP RUN. 847]) 848 849AT_CHECK([$COMPILE prog.cob], [0], [], []) 850AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 851[OKOKOKOK]) 852 853AT_CLEANUP 854 855 856AT_SETUP([TURN directive]) 857AT_KEYWORDS([runmisc BOUND NOBOUND directives]) 858 859# note: we only check here that the TURN directive applies 860# for more general tests, including command line options 861# and extension directives, see run_subscript.at, run_refmod.at 862 863AT_DATA([prog.cob], [ 864 >>TURN EC-BOUND-SUBSCRIPT CHECKING ON 865 IDENTIFICATION DIVISION. 866 PROGRAM-ID. prog. 867 868 DATA DIVISION. 869 WORKING-STORAGE SECTION. 870 01 x VALUE "12345!". 871 03 y PIC X OCCURS 5 TIMES. 872 03 z PIC X. 873 01 idx PIC 99 VALUE 6. 874 875 PROCEDURE DIVISION. 876 >>TURN EC-BOUND-SUBSCRIPT CHECKING OFF 877 DISPLAY y (idx) WITH NO ADVANCING 878 >>TURN EC-BOUND-SUBSCRIPT CHECKING ON WITH LOCATION 879 >>TURN EC-BOUND, EC-PROGRAM CHECKING OFF 880 DISPLAY y (idx) WITH NO ADVANCING 881 >>TURN EC-BOUND-SUBSCRIPT CHECKING ON 882 DISPLAY y (idx) WITH NO ADVANCING 883 . 884]) 885 886AT_CHECK([$COMPILE prog.cob], [0], [], []) 887AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [!!], 888[libcob: prog.cob:20: error: subscript of 'y' out of bounds: 6 889note: maximum subscript for 'y': 5 890]) 891 892AT_CLEANUP 893 894 895## OCCURS clause 896 897AT_SETUP([Level 01 subscripts]) 898AT_KEYWORDS([runmisc]) 899 900AT_DATA([prog.cob], [ 901 IDENTIFICATION DIVISION. 902 PROGRAM-ID. prog. 903 DATA DIVISION. 904 WORKING-STORAGE SECTION. 905 01 X PIC X OCCURS 10. 906 PROCEDURE DIVISION. 907 STOP RUN. 908]) 909 910AT_CHECK([$COMPILE_ONLY -std=cobol2014 prog.cob], [1], [], 911[prog.cob:6: error: level 01 item 'X' cannot have a OCCURS clause 912]) 913 914AT_CLEANUP 915 916 917## Expressions 918 919AT_SETUP([Class check with reference modification]) 920AT_KEYWORDS([runmisc]) 921 922AT_DATA([prog.cob], [ 923 IDENTIFICATION DIVISION. 924 PROGRAM-ID. prog. 925 DATA DIVISION. 926 WORKING-STORAGE SECTION. 927 01 X PIC X(6) VALUE "123 ". 928 PROCEDURE DIVISION. 929 IF X(1:3) NUMERIC 930 STOP RUN 931 END-IF. 932 DISPLAY "NG" NO ADVANCING 933 END-DISPLAY. 934 STOP RUN. 935]) 936 937AT_CHECK([$COMPILE prog.cob], [0], [], []) 938AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 939 940AT_CLEANUP 941 942 943AT_SETUP([Index and parenthesized expression]) 944AT_KEYWORDS([runmisc]) 945 946AT_DATA([prog.cob], [ 947 IDENTIFICATION DIVISION. 948 PROGRAM-ID. prog. 949 DATA DIVISION. 950 WORKING-STORAGE SECTION. 951 01 G. 952 02 X PIC X OCCURS 1 INDEXED BY I. 953 PROCEDURE DIVISION. 954 IF I < (I + 2) 955 DISPLAY "OK" NO ADVANCING 956 END-DISPLAY 957 END-IF. 958 STOP RUN. 959]) 960 961AT_CHECK([$COMPILE prog.cob], [0], [], []) 962AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) 963 964AT_CLEANUP 965 966 967AT_SETUP([Alphanumeric and binary numeric]) 968AT_KEYWORDS([runmisc]) 969 970AT_DATA([prog.cob], [ 971 IDENTIFICATION DIVISION. 972 PROGRAM-ID. prog. 973 DATA DIVISION. 974 WORKING-STORAGE SECTION. 975 01 X-X PIC XXXX VALUE "0001". 976 01 X-9 PIC 9999 COMP VALUE 1. 977 PROCEDURE DIVISION. 978 IF X-X = X-9 979 STOP RUN 980 END-IF. 981 DISPLAY "NG" NO ADVANCING 982 END-DISPLAY 983 STOP RUN. 984]) 985 986AT_CHECK([$COMPILE prog.cob], [0], [], []) 987AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 988 989AT_CLEANUP 990 991 992AT_SETUP([Non-numeric data in numeric items]) 993 994AT_KEYWORDS([runmisc]) 995 996AT_DATA([prog.cob], [ 997 IDENTIFICATION DIVISION. 998 PROGRAM-ID. prog. 999 DATA DIVISION. 1000 WORKING-STORAGE SECTION. 1001 01 X. 1002 03 X-NUM PIC 9(06) VALUE 123. 1003 77 NUM PIC 9(06). 1004 PROCEDURE DIVISION. 1005 MOVE x"0000" TO X (2:2) 1006 IF X-NUM NUMERIC 1007 DISPLAY "low-value is numeric" UPON SYSERR 1008 END-DISPLAY 1009 END-IF 1010 MOVE x"01" TO X (3:1) 1011 IF X-NUM NUMERIC 1012 DISPLAY "SOH is numeric" UPON SYSERR 1013 END-DISPLAY 1014 END-IF 1015 MOVE X-NUM TO NUM 1016 DISPLAY "test over" 1017 END-DISPLAY 1018 * 1019 GOBACK. 1020]) 1021 1022AT_DATA([prog2.cob], [ 1023 IDENTIFICATION DIVISION. 1024 PROGRAM-ID. prog2. 1025 DATA DIVISION. 1026 WORKING-STORAGE SECTION. 1027 01 X. 1028 03 X-NUM PIC 9(06) PACKED-DECIMAL VALUE 123. 1029 77 NUM PIC 9(06). 1030 PROCEDURE DIVISION. 1031 MOVE x"0A" TO X (2:1) 1032 IF X-NUM NUMERIC 1033 DISPLAY "bad prog" 1034 END-DISPLAY 1035 END-IF 1036 MOVE X-NUM TO NUM 1037 DISPLAY "test over" 1038 END-DISPLAY 1039 * 1040 GOBACK. 1041]) 1042 1043AT_CHECK([$COMPILE prog.cob], [0], [], []) 1044AT_CHECK([$COBC -x -o unchecked_prog prog.cob], [0], [], []) 1045AT_CHECK([$COBCRUN_DIRECT ./unchecked_prog], [0], 1046[test over 1047], []) 1048AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], 1049[libcob: prog.cob:20: error: 'X-NUM' (Type: NUMERIC DISPLAY) not numeric: '0\000\001123' 1050]) 1051 1052AT_CHECK([$COMPILE prog2.cob], [0], [], []) 1053AT_CHECK([$COBC -x -o unchecked_prog2 prog2.cob], [0], [], []) 1054AT_CHECK([$COBCRUN_DIRECT ./unchecked_prog2], [0], 1055[test over 1056], []) 1057AT_CHECK([$COBCRUN_DIRECT ./prog2], [1], [], 1058[libcob: prog2.cob:15: error: 'X-NUM' (Type: PACKED-DECIMAL) not numeric: '0x000a123f' 1059]) 1060 1061AT_CLEANUP 1062 1063 1064## CALL statement 1065 1066AT_SETUP([Dynamic call with static linking]) 1067AT_KEYWORDS([runmisc]) 1068 1069AT_DATA([callee.cob], [ 1070 IDENTIFICATION DIVISION. 1071 PROGRAM-ID. callee. 1072 PROCEDURE DIVISION. 1073 EXIT PROGRAM. 1074]) 1075 1076AT_DATA([caller.cob], [ 1077 IDENTIFICATION DIVISION. 1078 PROGRAM-ID. caller. 1079 PROCEDURE DIVISION. 1080 CALL "callee" 1081 END-CALL. 1082 STOP RUN. 1083]) 1084 1085AT_CHECK([$COMPILE_MODULE -c callee.cob], [0], [], []) 1086AT_CHECK([$COMPILE -c caller.cob], [0], [], []) 1087AT_CHECK([$COMPILE -o prog caller.$COB_OBJECT_EXT callee.$COB_OBJECT_EXT], [0], [], []) 1088AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1089AT_CHECK([$COMPILE -o prog2 caller.cob callee.cob], [0], [], []) 1090AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) 1091 1092AT_CLEANUP 1093 1094 1095AT_SETUP([Static call with static linking]) 1096AT_KEYWORDS([runmisc]) 1097 1098AT_DATA([callee.cob], [ 1099 IDENTIFICATION DIVISION. 1100 PROGRAM-ID. callee. 1101 PROCEDURE DIVISION. 1102 EXIT PROGRAM. 1103]) 1104 1105AT_DATA([caller.cob], [ 1106 IDENTIFICATION DIVISION. 1107 PROGRAM-ID. caller. 1108 PROCEDURE DIVISION. 1109 CALL STATIC "callee" 1110 END-CALL. 1111 STOP RUN. 1112]) 1113 1114AT_CHECK([$COMPILE_MODULE -c callee.cob], [0], [], []) 1115AT_CHECK([$COMPILE -c caller.cob], [0], [], []) 1116AT_CHECK([$COMPILE -o prog caller.$COB_OBJECT_EXT callee.$COB_OBJECT_EXT], [0], [], []) 1117AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1118AT_CHECK([$COMPILE -o prog2 -static caller.cob callee.cob], [0], [], []) 1119AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) 1120AT_CHECK([$COMPILE -o prog3 caller.cob callee.cob], [0], [], []) 1121AT_CHECK([$COBCRUN_DIRECT ./prog3], [0], [], []) 1122 1123AT_CLEANUP 1124 1125 1126AT_SETUP([Dynamic CALL with ON EXCEPTION]) 1127 1128AT_KEYWORDS([runmisc]) 1129 1130AT_DATA([caller.cob], [ 1131 IDENTIFICATION DIVISION. 1132 PROGRAM-ID. caller. 1133 PROCEDURE DIVISION. 1134 CALL "callee1" ON EXCEPTION 1135 CALL "callee2" ON EXCEPTION 1136 DISPLAY "neither calee1 nor callee2 found" 1137 END-CALL 1138 END-CALL 1139 GOBACK. 1140]) 1141 1142AT_DATA([callee2.cob], [ 1143 IDENTIFICATION DIVISION. 1144 PROGRAM-ID. callee2. 1145 PROCEDURE DIVISION. 1146 DISPLAY "this is callee2" NO ADVANCING 1147 GOBACK. 1148]) 1149 1150AT_CHECK([$COMPILE caller.cob], [0], [], []) 1151AT_CHECK([$COMPILE_MODULE callee2.cob], [0], [], []) 1152AT_CHECK([$COBCRUN_DIRECT ./caller], [0], 1153[this is callee2], []) 1154 1155AT_CLEANUP 1156 1157 1158AT_SETUP([Static CALL with ON EXCEPTION]) 1159 1160AT_KEYWORDS([runmisc]) 1161 1162AT_DATA([caller.cob], [ 1163 IDENTIFICATION DIVISION. 1164 PROGRAM-ID. caller. 1165 PROCEDURE DIVISION. 1166 CALL "callee1" ON EXCEPTION 1167 CALL "callee2" ON EXCEPTION 1168 DISPLAY "neither calee1 nor callee2 found" 1169 END-CALL 1170 END-CALL 1171 GOBACK. 1172]) 1173 1174AT_DATA([callee2.cob], [ 1175 IDENTIFICATION DIVISION. 1176 PROGRAM-ID. callee2. 1177 PROCEDURE DIVISION. 1178 DISPLAY "this is callee2" NO ADVANCING 1179 GOBACK. 1180]) 1181 1182 1183AT_CHECK([$COMPILE_MODULE -c callee2.cob], [0], [], []) 1184AT_CHECK([$COMPILE -c caller.cob], [0], [], []) 1185AT_CHECK([$COMPILE -o prog caller.$COB_OBJECT_EXT callee2.$COB_OBJECT_EXT], [0], [], []) 1186AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 1187[this is callee2], []) 1188AT_CHECK([$COMPILE -o prog2 -static caller.cob callee2.cob], [0], [], []) 1189AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], 1190[this is callee2], []) 1191AT_CHECK([$COMPILE -o prog3 caller.cob callee2.cob], [0], [], []) 1192AT_CHECK([$COBCRUN_DIRECT ./prog3], [0], 1193[this is callee2], []) 1194 1195AT_CLEANUP 1196 1197 1198AT_SETUP([CALL m1. CALL m2. CALL m1.]) 1199AT_KEYWORDS([runmisc]) 1200 1201AT_DATA([m1.cob], [ 1202 IDENTIFICATION DIVISION. 1203 PROGRAM-ID. m1. 1204 DATA DIVISION. 1205 WORKING-STORAGE SECTION. 1206 01 X PIC 9(4). 1207 PROCEDURE DIVISION. 1208 COMPUTE X = 1 + 2 1209 END-COMPUTE. 1210 IF X NOT = 3 1211 DISPLAY X 1212 END-DISPLAY 1213 END-IF. 1214]) 1215 1216AT_DATA([m2.cob], [ 1217 IDENTIFICATION DIVISION. 1218 PROGRAM-ID. m2. 1219 DATA DIVISION. 1220 WORKING-STORAGE SECTION. 1221 01 X PIC 9(4). 1222 PROCEDURE DIVISION. 1223 COMPUTE X = 3 + 4 1224 END-COMPUTE. 1225 IF X NOT = 7 1226 DISPLAY X 1227 END-DISPLAY 1228 END-IF. 1229]) 1230 1231AT_DATA([caller.cob], [ 1232 IDENTIFICATION DIVISION. 1233 PROGRAM-ID. caller. 1234 PROCEDURE DIVISION. 1235 CALL "m1" 1236 END-CALL. 1237 CALL "m2" 1238 END-CALL. 1239 CALL "m1" 1240 END-CALL. 1241 STOP RUN. 1242]) 1243 1244AT_CHECK([$COMPILE_MODULE m1.cob], [0], [], []) 1245AT_CHECK([$COMPILE_MODULE m2.cob], [0], [], []) 1246AT_CHECK([$COMPILE caller.cob], [0], [], []) 1247 1248AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) 1249 1250AT_CLEANUP 1251 1252 1253AT_SETUP([Recursive CALL of RECURSIVE program]) 1254AT_KEYWORDS([runmisc CANCEL EXTERNAL]) 1255 1256AT_DATA([caller.cob], [ 1257 IDENTIFICATION DIVISION. 1258 PROGRAM-ID. caller IS RECURSIVE. 1259 ENVIRONMENT DIVISION. 1260 CONFIGURATION SECTION. 1261 DATA DIVISION. 1262 WORKING-STORAGE SECTION. 1263 77 STOPPER PIC S9 EXTERNAL. 1264 PROCEDURE DIVISION. 1265 MOVE 0 TO STOPPER 1266 CALL "callee" 1267 DISPLAY 'OK' NO ADVANCING END-DISPLAY 1268 *> FIXME: CANCEL broken on special environments 1269 *> CANCEL "callee" , "callee2" 1270 DISPLAY ' + FINE' NO ADVANCING END-DISPLAY 1271 STOP RUN. 1272]) 1273 1274AT_DATA([callee.cob], [ 1275 IDENTIFICATION DIVISION. 1276 PROGRAM-ID. callee IS RECURSIVE. 1277 DATA DIVISION. 1278 WORKING-STORAGE SECTION. 1279 77 STOPPER PIC S9 EXTERNAL. 1280 PROCEDURE DIVISION. 1281 IF STOPPER = 9 1282 MOVE -1 TO STOPPER 1283 ELSE 1284 ADD 1 TO STOPPER 1285 CALL "callee2" 1286 END-IF 1287 GOBACK. 1288]) 1289 1290AT_DATA([callee2.cob], [ 1291 IDENTIFICATION DIVISION. 1292 PROGRAM-ID. callee2 IS RECURSIVE. 1293 DATA DIVISION. 1294 WORKING-STORAGE SECTION. 1295 77 STOPPER PIC S9 EXTERNAL. 1296 PROCEDURE DIVISION. 1297 IF STOPPER NOT EQUAL -1 1298 CALL "callee" 1299 END-IF 1300 GOBACK. 1301]) 1302 1303AT_CHECK([$COMPILE caller.cob], [0], [], []) 1304AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 1305AT_CHECK([$COMPILE_MODULE callee2.cob], [0], [], []) 1306AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK + FINE], []) 1307 1308AT_CLEANUP 1309 1310 1311AT_SETUP([Recursive CALL of INITIAL program]) 1312AT_KEYWORDS([runmisc]) 1313 1314AT_DATA([caller.cob], [ 1315 IDENTIFICATION DIVISION. 1316 PROGRAM-ID. caller. 1317 DATA DIVISION. 1318 WORKING-STORAGE SECTION. 1319 77 STOPPER PIC 9 EXTERNAL. 1320 PROCEDURE DIVISION. 1321 MOVE 0 TO STOPPER 1322 CALL "callee" END-CALL. 1323 GOBACK. 1324]) 1325 1326AT_DATA([callee.cob], [ 1327 IDENTIFICATION DIVISION. 1328 PROGRAM-ID. callee IS INITIAL. 1329 DATA DIVISION. 1330 WORKING-STORAGE SECTION. 1331 77 STOPPER PIC 9 EXTERNAL. 1332 PROCEDURE DIVISION. 1333 IF STOPPER = 1 1334 DISPLAY 'INITIAL prog was called RECURSIVE' 1335 END-DISPLAY 1336 STOP RUN RETURNING 1 1337 ELSE 1338 MOVE 1 TO STOPPER 1339 CALL "callee2" END-CALL 1340 END-IF. 1341 GOBACK. 1342]) 1343 1344AT_DATA([callee2.cob], [ 1345 IDENTIFICATION DIVISION. 1346 PROGRAM-ID. callee2. 1347 PROCEDURE DIVISION. 1348 CALL "callee" END-CALL. 1349 GOBACK. 1350]) 1351 1352AT_CHECK([$COMPILE caller.cob], [0], [], []) 1353AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 1354AT_CHECK([$COMPILE_MODULE callee2.cob], [0], [], []) 1355AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], 1356[libcob: callee2.cob:5: error: recursive CALL from 'callee2' to 'callee' which is NOT RECURSIVE 1357]) 1358 1359AT_CLEANUP 1360 1361 1362AT_SETUP([Recursive CALL with RECURSIVE assumed]) 1363AT_KEYWORDS([runmisc]) 1364 1365AT_DATA([caller.cob], [ 1366 IDENTIFICATION DIVISION. 1367 PROGRAM-ID. caller. 1368 DATA DIVISION. 1369 WORKING-STORAGE SECTION. 1370 77 STOPPER PIC 9 EXTERNAL. 1371 PROCEDURE DIVISION. 1372 MOVE 0 TO STOPPER 1373 CALL "callee" END-CALL. 1374 GOBACK. 1375]) 1376 1377AT_DATA([callee.cob], [ 1378 IDENTIFICATION DIVISION. 1379 PROGRAM-ID. callee IS INITIAL. 1380 DATA DIVISION. 1381 WORKING-STORAGE SECTION. 1382 77 STOPPER PIC 9 EXTERNAL. 1383 PROCEDURE DIVISION. 1384 IF STOPPER = 8 1385 DISPLAY 'OK' NO ADVANCING END-DISPLAY. 1386 IF STOPPER NOT = 9 1387 ADD 1 TO STOPPER END-ADD 1388 CALL "callee2" END-CALL. 1389 GOBACK. 1390]) 1391 1392AT_DATA([callee2.cob], [ 1393 IDENTIFICATION DIVISION. 1394 PROGRAM-ID. callee2. 1395 PROCEDURE DIVISION. 1396 CALL "callee" END-CALL. 1397 GOBACK. 1398]) 1399 1400AT_CHECK([$COMPILE caller.cob], [0], [], []) 1401AT_CHECK([$COMPILE_MODULE -fno-recursive-check callee.cob], [0], [], []) 1402AT_CHECK([$COMPILE_MODULE -fno-recursive-check callee2.cob], [0], [], []) 1403AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK], []) 1404 1405AT_CLEANUP 1406 1407 1408AT_SETUP([Recursive CALL with ON EXCEPTION]) 1409 1410AT_KEYWORDS([runmisc EXCEPTION-STATUS]) 1411 1412AT_DATA([caller.cob], [ 1413 IDENTIFICATION DIVISION. 1414 PROGRAM-ID. caller. 1415 DATA DIVISION. 1416 WORKING-STORAGE SECTION. 1417 77 STOPPER PIC 9 EXTERNAL. 1418 PROCEDURE DIVISION. 1419 MOVE 0 TO STOPPER 1420 CALL "callee" END-CALL. 1421 GOBACK. 1422]) 1423 1424AT_DATA([callee.cob], [ 1425 IDENTIFICATION DIVISION. 1426 PROGRAM-ID. callee IS INITIAL. 1427 DATA DIVISION. 1428 WORKING-STORAGE SECTION. 1429 77 STOPPER PIC 9 EXTERNAL. 1430 PROCEDURE DIVISION. 1431 IF STOPPER = 1 1432 DISPLAY 'INITIAL prog was called RECURSIVE' 1433 END-DISPLAY 1434 STOP RUN RETURNING 1 1435 ELSE 1436 MOVE 1 TO STOPPER 1437 CALL "callee2" END-CALL 1438 END-IF. 1439 GOBACK. 1440]) 1441 1442AT_DATA([callee2.cob], [ 1443 IDENTIFICATION DIVISION. 1444 PROGRAM-ID. callee2. 1445 PROCEDURE DIVISION. 1446 CALL "callee" 1447 ON EXCEPTION 1448 DISPLAY "Exception " FUNCTION EXCEPTION-STATUS ";" 1449 UPON SYSERR 1450 STOP RUN RETURNING 1 1451 END-CALL. 1452 GOBACK. 1453]) 1454 1455AT_CHECK([$COMPILE caller.cob], [0], [], []) 1456AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 1457AT_CHECK([$COMPILE_MODULE callee2.cob], [0], [], []) 1458AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], 1459[Exception EC-PROGRAM-RECURSIVE-CALL ; 1460]) 1461 1462AT_CLEANUP 1463 1464 1465AT_SETUP([Multiple calls of INITIAL program]) 1466AT_KEYWORDS([runmisc CALL]) 1467 1468AT_DATA([caller.cob], [ 1469 IDENTIFICATION DIVISION. 1470 PROGRAM-ID. caller. 1471 DATA DIVISION. 1472 WORKING-STORAGE SECTION. 1473 01 PARAM1 PIC X(08). 1474 01 PARAM2 PIC 9999 COMP VALUE 08. 1475 PROCEDURE DIVISION. 1476 MOVE ' PARAM 1' TO PARAM1 1477 PERFORM 10 TIMES 1478 CALL "callee" USING PARAM1 PARAM2 END-CALL 1479 END-PERFORM 1480 DISPLAY 'PARAM1 = ' PARAM1 1481 END-DISPLAY 1482 STOP RUN. 1483]) 1484 1485AT_DATA([callee.cob], [ 1486 IDENTIFICATION DIVISION. 1487 PROGRAM-ID. callee IS INITIAL. 1488 DATA DIVISION. 1489 WORKING-STORAGE SECTION. 1490 01 COUNTER PIC 999 VALUE ZERO. 1491 01 LPARAM PIC 9(8) COMP. 1492 LINKAGE SECTION. 1493 01 PARAM1 PIC X(08). 1494 01 PARAM2 PIC 9999 COMP. 1495 PROCEDURE DIVISION USING PARAM1 PARAM2. 1496 ADD 1 TO COUNTER END-ADD 1497 CALL 'C$PARAMSIZE' USING 1 GIVING LPARAM END-CALL 1498 DISPLAY 'COUNTER = ' COUNTER ' LPARAM1 = ' LPARAM 1499 ' PARAM1 = ' PARAM1 1500 END-DISPLAY 1501 GOBACK. 1502]) 1503 1504AT_CHECK([$COMPILE caller.cob], [0], [], []) 1505AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 1506AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1507COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1508COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1509COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1510COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1511COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1512COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1513COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1514COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1515COUNTER = 001 LPARAM1 = 00000008 PARAM1 = PARAM 1 1516PARAM1 = PARAM 1 1517]) 1518 1519AT_CLEANUP 1520 1521 1522AT_SETUP([CALL binary literal parameter/LENGTH OF]) 1523AT_KEYWORDS([runmisc]) 1524 1525AT_DATA([dump.c], [ 1526#include <stdio.h> 1527#include <libcob.h> 1528 1529COB_EXT_EXPORT int 1530dump (int *p) 1531{ 1532 printf ("%8.8d\n", *p); 1533 return 0; 1534} 1535]) 1536 1537AT_DATA([prog.cob], [ 1538 IDENTIFICATION DIVISION. 1539 PROGRAM-ID. prog. 1540 DATA DIVISION. 1541 WORKING-STORAGE SECTION. 1542 01 MYOCC PIC 9(8) COMP. 1543 01 MYTAB. 1544 03 MYBYTE PIC X OCCURS 1 TO 20 1545 DEPENDING ON MYOCC. 1546 PROCEDURE DIVISION. 1547 MOVE 9 TO MYOCC. 1548 CALL "dump" USING BY CONTENT 1 1549 END-CALL. 1550 CALL "dump" USING BY CONTENT LENGTH OF MYTAB 1551 END-CALL. 1552 CALL "dump" USING BY CONTENT LENGTH OF MYOCC 1553 END-CALL. 1554 STOP RUN. 1555]) 1556 1557AT_CHECK([$COMPILE_MODULE dump.c], [0], [], []) 1558AT_CHECK([$COMPILE prog.cob], [0], [], []) 1559AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 1560[00000001 156100000009 156200000004 1563]) 1564AT_CHECK([$COMPILE -fbinary-byteorder=native prog.cob -o prog2], [0], [], []) 1565AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], 1566[00000001 156700000009 156800000004 1569]) 1570 1571AT_CLEANUP 1572 1573 1574## INSPECT 1575 1576AT_SETUP([INSPECT REPLACING LEADING ZEROS BY SPACES]) 1577AT_KEYWORDS([runmisc]) 1578 1579AT_DATA([prog.cob], [ 1580 IDENTIFICATION DIVISION. 1581 PROGRAM-ID. prog. 1582 DATA DIVISION. 1583 WORKING-STORAGE SECTION. 1584 01 X PIC X(4) VALUE "0001". 1585 PROCEDURE DIVISION. 1586 INSPECT X REPLACING LEADING ZEROS BY SPACES. 1587 IF X NOT = " 1" 1588 DISPLAY "Should be ' 1' but is '" X "'". 1589 STOP RUN. 1590]) 1591 1592AT_CHECK([$COMPILE prog.cob], [0], [], []) 1593AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1594 1595AT_CLEANUP 1596 1597 1598AT_SETUP([INSPECT No repeat conversion check]) 1599AT_KEYWORDS([runmisc]) 1600 1601AT_DATA([prog.cob], [ 1602 IDENTIFICATION DIVISION. 1603 PROGRAM-ID. prog. 1604 DATA DIVISION. 1605 WORKING-STORAGE SECTION. 1606 01 X PIC X(3) VALUE "BCA". 1607 01 Y PIC X(6) VALUE " BCA". 1608 PROCEDURE DIVISION. 1609 INSPECT X CONVERTING "ABC" TO "BCD". 1610 IF X NOT = "CDB" 1611 DISPLAY "X: " X. 1612 INSPECT Y CONVERTING "ABC" TO "BCD". 1613 IF Y NOT = " CDB" 1614 DISPLAY "Y: " Y. 1615 STOP RUN. 1616]) 1617 1618AT_CHECK([$COMPILE prog.cob], [0], [], []) 1619AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1620 1621AT_CLEANUP 1622 1623 1624AT_SETUP([INSPECT CONVERTING alphabet]) 1625AT_KEYWORDS([runmisc ASCII EBCDIC]) 1626 1627AT_DATA([prog.cob], [ 1628 IDENTIFICATION DIVISION. 1629 PROGRAM-ID. charset. 1630 1631 ENVIRONMENT DIVISION. 1632 CONFIGURATION SECTION. 1633 SPECIAL-NAMES. 1634 ALPHABET ALPHA IS ASCII. 1635 ALPHABET BETA IS EBCDIC. 1636 1637 DATA DIVISION. 1638 WORKING-STORAGE SECTION. 1639 1640 01 TESTHEX PIC X(10) VALUE X'C17BD6F2F0F1F8404040'. 1641 1642 procedure division. 1643 sample-main. 1644 1645 INSPECT testhex CONVERTING BETA TO ALPHA 1646 DISPLAY 'Converted: "' TESTHEX '"' WITH NO ADVANCING 1647 1648 GOBACK. 1649 END PROGRAM charset. 1650]) 1651 1652AT_CHECK([$COMPILE prog.cob], [0], [], []) 1653AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 1654[Converted: "A#O2018 "], []) 1655 1656AT_CLEANUP 1657 1658 1659AT_SETUP([INSPECT CONVERTING TO figurative constant]) 1660AT_KEYWORDS([runmisc]) 1661 1662AT_DATA([prog.cob], [ 1663 IDENTIFICATION DIVISION. 1664 PROGRAM-ID. prog. 1665 DATA DIVISION. 1666 WORKING-STORAGE SECTION. 1667 01 X PIC X(3) VALUE "BCA". 1668 PROCEDURE DIVISION. 1669 INSPECT X CONVERTING "ABC" TO SPACES. 1670 IF X NOT = SPACES 1671 DISPLAY X NO ADVANCING 1672 END-DISPLAY 1673 END-IF. 1674 STOP RUN. 1675]) 1676 1677AT_CHECK([$COMPILE prog.cob], [0], [], []) 1678AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1679 1680AT_CLEANUP 1681 1682 1683AT_SETUP([INSPECT CONVERTING NULL]) 1684AT_KEYWORDS([runmisc]) 1685 1686AT_DATA([prog.cob], [ 1687 IDENTIFICATION DIVISION. 1688 PROGRAM-ID. prog. 1689 DATA DIVISION. 1690 WORKING-STORAGE SECTION. 1691 01 X PIC X(3) VALUE LOW-VALUES. 1692 PROCEDURE DIVISION. 1693 INSPECT X CONVERTING NULL TO "A". 1694 IF X NOT = "AAA" 1695 DISPLAY X NO ADVANCING 1696 END-DISPLAY 1697 END-IF. 1698 STOP RUN. 1699]) 1700 1701AT_CHECK([$COMPILE prog.cob], [0], [], []) 1702AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1703 1704AT_CLEANUP 1705 1706 1707AT_SETUP([INSPECT CONVERTING TO NULL]) 1708AT_KEYWORDS([runmisc]) 1709 1710AT_DATA([prog.cob], [ 1711 IDENTIFICATION DIVISION. 1712 PROGRAM-ID. prog. 1713 DATA DIVISION. 1714 WORKING-STORAGE SECTION. 1715 01 X PIC X(3) VALUE "AAA". 1716 PROCEDURE DIVISION. 1717 INSPECT X CONVERTING "A" TO NULL. 1718 IF X NOT = LOW-VALUES 1719 DISPLAY "NG" NO ADVANCING 1720 END-DISPLAY 1721 END-IF. 1722 STOP RUN. 1723]) 1724 1725AT_CHECK([$COMPILE prog.cob], [0], [], []) 1726AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1727 1728AT_CLEANUP 1729 1730 1731AT_SETUP([INSPECT REPLACING figurative constant]) 1732AT_KEYWORDS([runmisc]) 1733 1734AT_DATA([prog.cob], [ 1735 IDENTIFICATION DIVISION. 1736 PROGRAM-ID. prog. 1737 DATA DIVISION. 1738 WORKING-STORAGE SECTION. 1739 01 X PIC X(3) VALUE "BCA". 1740 PROCEDURE DIVISION. 1741 INSPECT X REPLACING ALL "BC" BY SPACE. 1742 IF X NOT = " A" 1743 DISPLAY X NO ADVANCING 1744 END-DISPLAY 1745 END-IF. 1746 STOP RUN. 1747]) 1748 1749AT_CHECK([$COMPILE prog.cob], [0], [], []) 1750AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1751 1752AT_CLEANUP 1753 1754 1755AT_SETUP([INSPECT TALLYING BEFORE]) 1756AT_KEYWORDS([runmisc]) 1757 1758AT_DATA([prog.cob], [ 1759 IDENTIFICATION DIVISION. 1760 PROGRAM-ID. prog. 1761 DATA DIVISION. 1762 WORKING-STORAGE SECTION. 1763 01 X PIC X(4) VALUE "ABC ". 1764 01 TAL PIC 999 VALUE 0. 1765 PROCEDURE DIVISION. 1766 MOVE 0 TO TAL. 1767 INSPECT X TALLYING TAL FOR CHARACTERS 1768 BEFORE INITIAL " ". 1769 IF TAL NOT = 3 1770 DISPLAY TAL NO ADVANCING 1771 END-DISPLAY 1772 END-IF. 1773 MOVE 0 TO TAL. 1774 MOVE " ABC" TO X. 1775 INSPECT X TALLYING TAL FOR CHARACTERS 1776 BEFORE INITIAL " ". 1777 IF TAL NOT = 0 1778 DISPLAY TAL NO ADVANCING 1779 END-DISPLAY 1780 END-IF. 1781 STOP RUN. 1782]) 1783 1784AT_CHECK([$COMPILE prog.cob], [0], [], []) 1785AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1786 1787AT_CLEANUP 1788 1789 1790AT_SETUP([INSPECT TALLYING AFTER]) 1791AT_KEYWORDS([runmisc]) 1792 1793AT_DATA([prog.cob], [ 1794 IDENTIFICATION DIVISION. 1795 PROGRAM-ID. prog. 1796 DATA DIVISION. 1797 WORKING-STORAGE SECTION. 1798 01 X PIC X(4) VALUE "ABC ". 1799 01 TAL PIC 999 VALUE 0. 1800 PROCEDURE DIVISION. 1801 MOVE 0 TO TAL. 1802 INSPECT X TALLYING TAL FOR CHARACTERS 1803 AFTER INITIAL " ". 1804 IF TAL NOT = 0 1805 DISPLAY TAL NO ADVANCING 1806 END-DISPLAY 1807 END-IF. 1808 MOVE 0 TO TAL. 1809 MOVE " ABC" TO X. 1810 INSPECT X TALLYING TAL FOR CHARACTERS 1811 AFTER INITIAL " ". 1812 IF TAL NOT = 3 1813 DISPLAY TAL NO ADVANCING 1814 END-DISPLAY 1815 END-IF. 1816 STOP RUN. 1817]) 1818 1819AT_CHECK([$COMPILE prog.cob], [0], [], []) 1820AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1821 1822AT_CLEANUP 1823 1824 1825AT_SETUP([INSPECT REPLACING TRAILING ZEROS BY SPACES]) 1826AT_KEYWORDS([runmisc]) 1827 1828AT_DATA([prog.cob], [ 1829 IDENTIFICATION DIVISION. 1830 PROGRAM-ID. prog. 1831 DATA DIVISION. 1832 WORKING-STORAGE SECTION. 1833 01 X PIC X(4) VALUE "1000". 1834 PROCEDURE DIVISION. 1835 INSPECT X REPLACING TRAILING ZEROS BY SPACES. 1836 IF X NOT = "1 " 1837 DISPLAY X NO ADVANCING 1838 END-DISPLAY 1839 END-IF. 1840 STOP RUN. 1841]) 1842 1843AT_CHECK([$COMPILE prog.cob], [0], [], []) 1844AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1845 1846AT_CLEANUP 1847 1848 1849AT_SETUP([INSPECT REPLACING complex]) 1850AT_KEYWORDS([runmisc]) 1851 1852AT_DATA([prog.cob], [ 1853 IDENTIFICATION DIVISION. 1854 PROGRAM-ID. prog. 1855 DATA DIVISION. 1856 WORKING-STORAGE SECTION. 1857 01 X PIC X(12) VALUE "AAABBCDCCCCC". 1858 PROCEDURE DIVISION. 1859 INSPECT X REPLACING 1860 ALL "A" BY "Z" 1861 "B" BY "Y" 1862 TRAILING "C" BY "X". 1863 IF X NOT = "ZZZYYCDXXXXX" 1864 DISPLAY X NO ADVANCING 1865 END-DISPLAY 1866 END-IF. 1867 STOP RUN. 1868]) 1869 1870AT_CHECK([$COMPILE prog.cob], [0], [], []) 1871AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 1872AT_CLEANUP 1873 1874 1875AT_SETUP([SWITCHES (environment COB_SWITCH_n and SET)]) 1876AT_KEYWORDS([runmisc]) 1877 1878AT_DATA([prog.cob], [ 1879 IDENTIFICATION DIVISION. 1880 PROGRAM-ID. prog. 1881 ENVIRONMENT DIVISION. 1882 CONFIGURATION SECTION. 1883 SPECIAL-NAMES. 1884 SWITCH-1 IS SWIT1 1885 ON IS SWIT1-ON 1886 OFF IS SWIT1-OFF 1887 SWITCH-2 IS SWIT2 1888 ON IS SWIT2-ON 1889 OFF IS SWIT2-OFF 1890 SWITCH-3 1891 ON IS SWIT3-ON 1892 OFF IS SWIT3-OFF 1893 SWITCH-4 IS SWIT4 1894 OFF IS SWIT4-OFF 1895 SWITCH-31 1896 ON IS SWIT31-ON 1897 SWITCH-36 IS SWIT36 1898 OFF IS SWIT36-OFF. 1899 DATA DIVISION. 1900 WORKING-STORAGE SECTION. 1901 PROCEDURE DIVISION. 1902 IF SWIT1-ON 1903 DISPLAY "ON" NO ADVANCING 1904 END-DISPLAY 1905 ELSE 1906 DISPLAY "OFF" NO ADVANCING 1907 END-DISPLAY 1908 END-IF. 1909 IF SWIT2-ON 1910 DISPLAY " ON" NO ADVANCING 1911 END-DISPLAY 1912 ELSE 1913 DISPLAY " OFF" NO ADVANCING 1914 END-DISPLAY 1915 END-IF. 1916 IF SWIT3-ON 1917 DISPLAY " ON" NO ADVANCING 1918 END-DISPLAY 1919 ELSE 1920 DISPLAY " OFF" NO ADVANCING 1921 END-DISPLAY 1922 END-IF. 1923 IF NOT SWIT4-OFF 1924 DISPLAY " ON" NO ADVANCING 1925 END-DISPLAY 1926 ELSE 1927 DISPLAY " OFF" NO ADVANCING 1928 END-DISPLAY 1929 END-IF. 1930 SET SWIT1 TO OFF. 1931 SET SWIT2 TO ON. 1932 IF SWIT1-ON 1933 DISPLAY " ON" NO ADVANCING 1934 END-DISPLAY 1935 ELSE 1936 DISPLAY " OFF" NO ADVANCING 1937 END-DISPLAY 1938 END-IF. 1939 IF SWIT2-ON 1940 DISPLAY " ON" NO ADVANCING 1941 END-DISPLAY 1942 ELSE 1943 DISPLAY " OFF" NO ADVANCING 1944 END-DISPLAY 1945 END-IF 1946 IF SWIT31-ON 1947 DISPLAY " ON" NO ADVANCING 1948 END-DISPLAY 1949 ELSE 1950 DISPLAY " OFF" NO ADVANCING 1951 END-DISPLAY 1952 END-IF. 1953 IF NOT SWIT36-OFF 1954 DISPLAY " ON" NO ADVANCING 1955 END-DISPLAY 1956 ELSE 1957 DISPLAY " OFF" NO ADVANCING 1958 END-DISPLAY 1959 END-IF. 1960 STOP RUN. 1961]) 1962 1963AT_CHECK([$COMPILE prog.cob], [0], [], []) 1964AT_CHECK([COB_SWITCH_1=1 COB_SWITCH_2=0 COB_SWITCH_3=OFF COB_SWITCH_4=ON COB_SWITCH_36=ON ./prog], [0], 1965[ON OFF OFF ON OFF ON OFF ON]) 1966 1967AT_CLEANUP 1968 1969 1970## PERFORM 1971 1972AT_SETUP([Nested PERFORM]) 1973AT_KEYWORDS([runmisc]) 1974 1975AT_DATA([prog.cob], [ 1976 IDENTIFICATION DIVISION. 1977 PROGRAM-ID. prog. 1978 PROCEDURE DIVISION. 1979 PERFORM 2 TIMES 1980 DISPLAY "X" NO ADVANCING 1981 END-DISPLAY 1982 PERFORM 2 TIMES 1983 DISPLAY "Y" NO ADVANCING 1984 END-DISPLAY 1985 END-PERFORM 1986 END-PERFORM. 1987 STOP RUN. 1988]) 1989 1990AT_CHECK([$COMPILE prog.cob], [0], [], []) 1991AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [XYYXYY]) 1992 1993AT_CLEANUP 1994 1995 1996AT_SETUP([PERFORM VARYING BY -0.2]) 1997AT_KEYWORDS([runmisc]) 1998 1999AT_DATA([prog.cob], [ 2000 IDENTIFICATION DIVISION. 2001 PROGRAM-ID. prog. 2002 DATA DIVISION. 2003 WORKING-STORAGE SECTION. 2004 77 X PIC 9v9. 2005 PROCEDURE DIVISION. 2006 PERFORM VARYING X FROM 0.8 BY -0.2 2007 UNTIL X < 0.4 2008 DISPLAY "X" NO ADVANCING 2009 END-DISPLAY 2010 END-PERFORM. 2011 IF X NOT = 0.2 2012 DISPLAY "WRONG X: " X END-DISPLAY 2013 END-IF 2014 STOP RUN. 2015]) 2016 2017AT_CHECK([$COMPILE prog.cob], [0], [], []) 2018AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [XXX]) 2019 2020AT_CLEANUP 2021 2022 2023AT_SETUP([PERFORM VARYING BY phrase omitted]) 2024AT_KEYWORDS([runmisc]) 2025 2026AT_DATA([prog.cob], [ 2027 IDENTIFICATION DIVISION. 2028 PROGRAM-ID. prog. 2029 DATA DIVISION. 2030 WORKING-STORAGE SECTION. 2031 77 X PIC 9. 2032 PROCEDURE DIVISION. 2033 PERFORM VARYING X FROM 4 2034 UNTIL X > 6 2035 DISPLAY "X" NO ADVANCING 2036 END-PERFORM. 2037 IF X NOT = 7 2038 DISPLAY "WRONG X: " X 2039 END-IF 2040 STOP RUN. 2041]) 2042 2043AT_CHECK([$COMPILE_ONLY -std=cobol85 prog.cob], [1], [], 2044[prog.cob:9: error: PERFORM VARYING without BY phrase does not conform to COBOL 85 2045]) 2046AT_CHECK([$COMPILE prog.cob], [0], [], []) 2047AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [XXX]) 2048 2049AT_CLEANUP 2050 2051 2052## EXIT PERFORM see ISO/IEC 1989:2002(E) 14.8.13 Format 5 2053 2054AT_SETUP([EXIT PERFORM]) 2055AT_KEYWORDS([runmisc]) 2056 2057AT_DATA([prog.cob], [ 2058 IDENTIFICATION DIVISION. 2059 PROGRAM-ID. prog. 2060 PROCEDURE DIVISION. 2061 PERFORM 2 TIMES 2062 DISPLAY "OK" NO ADVANCING 2063 END-DISPLAY 2064 EXIT PERFORM 2065 DISPLAY "NOT OK" 2066 END-DISPLAY 2067 END-PERFORM 2068 STOP RUN. 2069]) 2070 2071AT_CHECK([$COMPILE prog.cob], [0], [], []) 2072AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) 2073 2074AT_CLEANUP 2075 2076 2077## EXIT PERFORM see ISO/IEC 1989:2002(E) 14.8.13 Format 5 2078 2079AT_SETUP([EXIT PERFORM CYCLE]) 2080AT_KEYWORDS([runmisc]) 2081 2082AT_DATA([prog.cob], [ 2083 IDENTIFICATION DIVISION. 2084 PROGRAM-ID. prog. 2085 PROCEDURE DIVISION. 2086 PERFORM 2 TIMES 2087 DISPLAY "OK" NO ADVANCING 2088 END-DISPLAY 2089 EXIT PERFORM CYCLE 2090 DISPLAY "NOT OK" 2091 END-DISPLAY 2092 END-PERFORM 2093 STOP RUN. 2094]) 2095 2096AT_CHECK([$COMPILE prog.cob], [0], [], []) 2097AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKOK]) 2098 2099AT_CLEANUP 2100 2101 2102## EXIT PARAGRAPH see ISO/IEC 1989:2002(E) 14.8.13 Format 6 2103 2104AT_SETUP([EXIT PARAGRAPH]) 2105AT_KEYWORDS([runmisc]) 2106 2107AT_DATA([prog.cob], [ 2108 IDENTIFICATION DIVISION. 2109 PROGRAM-ID. prog. 2110 DATA DIVISION. 2111 WORKING-STORAGE SECTION. 2112 01 INDVAL PIC 9(4). 2113 PROCEDURE DIVISION. 2114 A01. 2115 PERFORM VARYING INDVAL FROM 1 BY 1 UNTIL INDVAL > 10 2116 IF INDVAL > 2 2117 EXIT PARAGRAPH 2118 END-IF 2119 END-PERFORM. 2120 A02. 2121 IF INDVAL NOT = 3 2122 DISPLAY INDVAL NO ADVANCING 2123 END-DISPLAY 2124 END-IF. 2125 STOP RUN. 2126]) 2127 2128AT_CHECK([$COMPILE prog.cob], [0], [], []) 2129AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2130 2131AT_CLEANUP 2132 2133 2134## EXIT SECTION see ISO/IEC 1989:2002(E) 14.8.13 Format 6 2135 2136AT_SETUP([EXIT SECTION]) 2137AT_KEYWORDS([runmisc]) 2138 2139AT_DATA([prog.cob], [ 2140 IDENTIFICATION DIVISION. 2141 PROGRAM-ID. prog. 2142 DATA DIVISION. 2143 WORKING-STORAGE SECTION. 2144 01 INDVAL PIC 9(4). 2145 PROCEDURE DIVISION. 2146 A01 SECTION. 2147 A011. 2148 PERFORM VARYING INDVAL FROM 1 BY 1 UNTIL INDVAL > 10 2149 IF INDVAL > 2 2150 EXIT SECTION 2151 END-IF 2152 END-PERFORM. 2153 A012. 2154 DISPLAY INDVAL NO ADVANCING 2155 END-DISPLAY. 2156 A02 SECTION. 2157 IF INDVAL NOT = 3 2158 DISPLAY INDVAL NO ADVANCING 2159 END-DISPLAY 2160 END-IF. 2161 STOP RUN. 2162]) 2163 2164AT_CHECK([$COMPILE prog.cob], [0], [], []) 2165AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2166 2167AT_CLEANUP 2168 2169 2170AT_SETUP([PERFORM FOREVER / PERFORM UNTIL EXIT]) 2171AT_KEYWORDS([runmisc extension]) 2172 2173AT_DATA([prog.cob], [ 2174 IDENTIFICATION DIVISION. 2175 PROGRAM-ID. prog. 2176 DATA DIVISION. 2177 WORKING-STORAGE SECTION. 2178 01 INDVAL PIC 9(4). 2179 PROCEDURE DIVISION. 2180 A01. 2181 MOVE 0 TO INDVAL 2182 PERFORM UNTIL EXIT 2183 ADD 1 TO INDVAL 2184 IF INDVAL > 2 2185 EXIT PERFORM 2186 END-IF 2187 END-PERFORM 2188 IF INDVAL NOT = 3 2189 DISPLAY "1: " INDVAL 2190 END-DISPLAY 2191 END-IF 2192 PERFORM FOREVER 2193 ADD 1 TO INDVAL 2194 IF INDVAL > 4 2195 EXIT PERFORM 2196 END-IF 2197 END-PERFORM 2198 IF INDVAL NOT = 5 2199 DISPLAY "2: " INDVAL 2200 END-DISPLAY 2201 END-IF 2202 STOP RUN. 2203]) 2204 2205AT_CHECK([$COMPILE prog.cob], [0], [], []) 2206AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2207 2208AT_CLEANUP 2209 2210 2211AT_SETUP([PERFORM inline (1)]) 2212AT_KEYWORDS([runmisc]) 2213 2214AT_DATA([prog.cob], [ 2215 IDENTIFICATION DIVISION. 2216 PROGRAM-ID. prog. 2217 DATA DIVISION. 2218 WORKING-STORAGE SECTION. 2219 01 INDVAL PIC 9(4). 2220 PROCEDURE DIVISION. 2221 PERFORM VARYING INDVAL FROM 1 2222 BY 1 UNTIL INDVAL > 2 2223 END-PERFORM 2224 IF INDVAL NOT = 3 2225 DISPLAY INDVAL NO ADVANCING 2226 END-DISPLAY 2227 END-IF 2228 STOP RUN 2229 . 2230]) 2231 2232AT_CHECK([$COMPILE -fmissing-statement=ok prog.cob], [0], [], []) 2233AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2234 2235AT_CLEANUP 2236 2237 2238AT_SETUP([PERFORM inline (2)]) 2239AT_KEYWORDS([runmisc]) 2240 2241AT_DATA([prog.cob], [ 2242 IDENTIFICATION DIVISION. 2243 PROGRAM-ID. prog. 2244 DATA DIVISION. 2245 WORKING-STORAGE SECTION. 2246 01 INDVAL PIC 9(4). 2247 PROCEDURE DIVISION. 2248 PERFORM VARYING INDVAL FROM 1 2249 BY 1 UNTIL INDVAL > 2. 2250 IF INDVAL NOT = 3 2251 DISPLAY INDVAL NO ADVANCING 2252 END-DISPLAY 2253 END-IF 2254 . 2255]) 2256 2257AT_CHECK([$COMPILE -frelax-syntax-checks -w prog.cob], [0], [], []) 2258AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2259 2260AT_CLEANUP 2261 2262 2263AT_SETUP([Non-overflow after overflow]) 2264AT_KEYWORDS([runmisc]) 2265 2266AT_DATA([prog.cob], [ 2267 IDENTIFICATION DIVISION. 2268 PROGRAM-ID. prog. 2269 DATA DIVISION. 2270 WORKING-STORAGE SECTION. 2271 01 X PIC 9(2) VALUE 0. 2272 01 Y PIC 9(2) VALUE 0. 2273 PROCEDURE DIVISION. 2274 COMPUTE X = 100 2275 END-COMPUTE. 2276 COMPUTE Y = 99 2277 END-COMPUTE. 2278 IF Y NOT = 99 2279 DISPLAY Y NO ADVANCING 2280 END-DISPLAY 2281 END-IF. 2282 STOP RUN. 2283]) 2284 2285AT_CHECK([$COMPILE prog.cob], [0], [], []) 2286AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2287 2288AT_CLEANUP 2289 2290 2291## PERFORM statement 2292 2293AT_SETUP([PERFORM ... CONTINUE]) 2294AT_KEYWORDS([runmisc]) 2295 2296AT_DATA([prog.cob], [ 2297 IDENTIFICATION DIVISION. 2298 PROGRAM-ID. prog. 2299 PROCEDURE DIVISION. 2300 PERFORM 2 TIMES 2301 CONTINUE 2302 END-PERFORM. 2303]) 2304 2305AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], []) 2306 2307AT_CLEANUP 2308 2309 2310AT_SETUP([STRING with subscript reference]) 2311AT_KEYWORDS([runmisc]) 2312 2313AT_DATA([prog.cob], [ 2314 IDENTIFICATION DIVISION. 2315 PROGRAM-ID. prog. 2316 DATA DIVISION. 2317 WORKING-STORAGE SECTION. 2318 01 G. 2319 02 X PIC X(3) OCCURS 3. 2320 PROCEDURE DIVISION. 2321 MOVE SPACES TO G. 2322 STRING "abc" INTO X(2) 2323 END-STRING. 2324 IF G NOT = " abc " 2325 DISPLAY X(1) NO ADVANCING 2326 END-DISPLAY 2327 END-IF. 2328 STOP RUN. 2329]) 2330 2331AT_CHECK([$COMPILE prog.cob], [0], [], []) 2332AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2333 2334AT_CLEANUP 2335 2336 2337AT_SETUP([STRING / UNSTRING [NOT] ON OVERFLOW]) 2338AT_KEYWORDS([runmisc exceptions]) 2339 2340AT_DATA([prog.cob], [ 2341 identification division. 2342 program-id. prog. 2343 data division. 2344 working-storage section. 2345 77 simple-str pic x(20). 2346 77 err-str pic x(50). 2347 *----------------------------------------------------------------- 2348 procedure division. 2349 * STRING test 2350 move spaces to simple-str 2351 string 'data' 2352 delimited by size 2353 into simple-str 2354 on overflow 2355 move spaces to err-str 2356 string 'STRING OVERFLOW' 2357 delimited by size 2358 into err-str 2359 end-string 2360 display err-str upon syserr 2361 end-display 2362 display '1 failed' 2363 end-display 2364 not on overflow 2365 display '1 passed' 2366 end-display 2367 end-string 2368 if simple-str not = 'data' 2369 display 'STRING ERROR (1): "' simple-str '"' 2370 end-display 2371 end-if 2372 * 2373 move spaces to simple-str 2374 string 'data is too big here...' 2375 delimited by size 2376 into simple-str 2377 on overflow 2378 display '2 passed' 2379 end-display 2380 not on overflow 2381 display '2 failed' 2382 end-display 2383 move spaces to err-str 2384 string 'missing OVERFLOW' 2385 delimited by size 2386 into err-str 2387 end-string 2388 display err-str upon syserr 2389 end-display 2390 end-string 2391 if simple-str not = 'data is too big here' 2392 display 'STRING ERROR (2): "' simple-str '"' 2393 end-display 2394 end-if 2395 * 2396 * UNSTRING test 2397 move spaces to simple-str 2398 unstring 'data' 2399 into simple-str 2400 on overflow 2401 move spaces to err-str 2402 unstring 'UNSTRING OVERFLOW' 2403 into err-str 2404 end-unstring 2405 display err-str upon syserr 2406 end-display 2407 display '3 failed' 2408 end-display 2409 not on overflow 2410 display '3 passed' 2411 end-display 2412 end-unstring 2413 if simple-str not = 'data' 2414 display 'UNSTRING ERROR (1): "' simple-str '"' 2415 end-display 2416 end-if 2417 * 2418 move spaces to simple-str 2419 unstring 'data is too big here...' 2420 into simple-str 2421 on overflow 2422 display '4 passed' 2423 end-display 2424 not on overflow 2425 display '4 failed' 2426 end-display 2427 move spaces to err-str 2428 string 'missing OVERFLOW' 2429 delimited by size 2430 into err-str 2431 end-string 2432 display err-str upon syserr 2433 end-display 2434 end-unstring 2435 if simple-str not = 'data is too big here' 2436 display 'UNSTRING ERROR (2): "' simple-str '"' 2437 end-display 2438 end-if 2439 * 2440 STOP RUN. 2441]) 2442 2443AT_CHECK([$COMPILE prog.cob], [0], [], []) 2444AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 2445[1 passed 24462 passed 24473 passed 24484 passed 2449], []) 2450 2451AT_CLEANUP 2452 2453 2454AT_SETUP([UNSTRING DELIMITED ALL LOW-VALUE]) 2455AT_KEYWORDS([runmisc]) 2456 2457AT_DATA([prog.cob], [ 2458 IDENTIFICATION DIVISION. 2459 PROGRAM-ID. prog. 2460 DATA DIVISION. 2461 WORKING-STORAGE SECTION. 2462 01 G. 2463 03 FILLER PIC XXX VALUE "ABC". 2464 03 FILLER PIC XX VALUE LOW-VALUES. 2465 03 FILLER PIC XXX VALUE "DEF". 2466 01 A PIC XXX. 2467 01 B PIC XXX. 2468 PROCEDURE DIVISION. 2469 UNSTRING G DELIMITED BY ALL LOW-VALUES 2470 INTO A B 2471 END-UNSTRING. 2472 IF A NOT = "ABC" 2473 DISPLAY A 2474 END-DISPLAY 2475 END-IF. 2476 IF B NOT = "DEF" 2477 DISPLAY B 2478 END-DISPLAY 2479 END-IF. 2480 STOP RUN. 2481]) 2482 2483AT_CHECK([$COMPILE prog.cob], [0], [], []) 2484AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2485 2486AT_CLEANUP 2487 2488 2489AT_SETUP([UNSTRING DELIMITED ALL SPACE-2]) 2490AT_KEYWORDS([runmisc]) 2491 2492AT_DATA([prog.cob], [ 2493 IDENTIFICATION DIVISION. 2494 PROGRAM-ID. prog. 2495 ENVIRONMENT DIVISION. 2496 DATA DIVISION. 2497 WORKING-STORAGE SECTION. 2498 01 WS-RECORD. 2499 02 VALUE SPACE PIC X(04). 2500 02 VALUE "ABC AND DE" PIC X(10). 2501 02 VALUE SPACE PIC X(07). 2502 02 VALUE "FG AND HIJ" PIC X(10). 2503 02 VALUE SPACE PIC X(08). 2504 01 SPACE-2 PIC X(02) VALUE SPACE. 2505 01 WS-DUMMY PIC X(15). 2506 01 WS-POINTER PIC 99. 2507 PROCEDURE DIVISION. 2508 MOVE 1 TO WS-POINTER. 2509 * 2510 PERFORM 0001-SUB. 2511 IF WS-DUMMY NOT = SPACE 2512 DISPLAY "Expected space - Got " WS-DUMMY 2513 END-DISPLAY 2514 END-IF. 2515 IF WS-POINTER NOT = 5 2516 DISPLAY "Expected 5 - Got " WS-POINTER 2517 END-DISPLAY 2518 END-IF. 2519 * 2520 PERFORM 0001-SUB. 2521 IF WS-DUMMY NOT = "ABC AND DE" 2522 DISPLAY "Expected ABC AND DE - Got " WS-DUMMY 2523 END-DISPLAY 2524 END-IF. 2525 IF WS-POINTER NOT = 21 2526 DISPLAY "Expected 21 - Got " WS-POINTER 2527 END-DISPLAY 2528 END-IF. 2529 * 2530 PERFORM 0001-SUB. 2531 IF WS-DUMMY NOT = " FG AND HIJ" 2532 DISPLAY "Expected FG AND HIJ - Got " WS-DUMMY 2533 END-DISPLAY 2534 END-IF. 2535 IF WS-POINTER NOT = 40 2536 DISPLAY "Expected 40 - Got " WS-POINTER 2537 END-DISPLAY 2538 END-IF. 2539 STOP RUN. 2540 0001-SUB. 2541 UNSTRING WS-RECORD 2542 DELIMITED BY ALL SPACE-2 2543 INTO WS-DUMMY 2544 POINTER WS-POINTER 2545 END-UNSTRING. 2546]) 2547 2548AT_CHECK([$COMPILE prog.cob], [0], [], []) 2549AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2550 2551AT_CLEANUP 2552 2553 2554AT_SETUP([UNSTRING DELIMITED POINTER]) 2555AT_KEYWORDS([runmisc]) 2556 2557AT_DATA([prog.cob], [ 2558 IDENTIFICATION DIVISION. 2559 PROGRAM-ID. prog. 2560 ENVIRONMENT DIVISION. 2561 DATA DIVISION. 2562 WORKING-STORAGE SECTION. 2563 01 WS-LAY-RECORD PIC X(66). 2564 01 WS-DUMMY PIC X(50). 2565 01 WS-KEYWORD PIC X(32). 2566 01 WS-POINTER PIC 99. 2567 PROCEDURE DIVISION. 2568 MOVE 2569 ' 10 AF-RECORD-TYPE-SEQUENCE-04 PIC 9(05) COMP-3.' 2570 TO WS-LAY-RECORD. 2571 MOVE 1 TO WS-POINTER. 2572 PERFORM 0001-SUB. 2573 IF WS-POINTER NOT = 48 2574 DISPLAY "Expected 48 - Got " WS-POINTER 2575 END-DISPLAY 2576 END-IF. 2577 ADD 7 TO WS-POINTER 2578 END-ADD. 2579 PERFORM 0001-SUB. 2580 IF WS-POINTER NOT = 62 2581 DISPLAY "Expected 62 - Got " WS-POINTER 2582 END-DISPLAY 2583 END-IF. 2584 PERFORM 0001-SUB. 2585 IF WS-POINTER NOT = 63 2586 DISPLAY "Expected 63 - Got " WS-POINTER 2587 END-DISPLAY 2588 END-IF. 2589 STOP RUN. 2590 0001-SUB. 2591 UNSTRING WS-LAY-RECORD 2592 DELIMITED 2593 BY ' PIC ' 2594 OR ' COMP-3' 2595 OR '.' 2596 INTO WS-DUMMY 2597 DELIMITER WS-KEYWORD 2598 POINTER WS-POINTER 2599 END-UNSTRING. 2600]) 2601 2602AT_CHECK([$COMPILE prog.cob], [0], [], []) 2603AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2604 2605AT_CLEANUP 2606 2607 2608AT_SETUP([UNSTRING DELIMITER IN]) 2609AT_KEYWORDS([runmisc]) 2610 2611AT_DATA([prog.cob], [ 2612 IDENTIFICATION DIVISION. 2613 PROGRAM-ID. prog. 2614 ENVIRONMENT DIVISION. 2615 DATA DIVISION. 2616 WORKING-STORAGE SECTION. 2617 01 WK-CMD PIC X(8) VALUE "WWADDBCC". 2618 01 WK-SIGNS PIC XX VALUE "AB". 2619 01 WKS REDEFINES WK-SIGNS. 2620 03 WK-SIGN PIC X OCCURS 2. 2621 01 WK-DELIM PIC X OCCURS 2. 2622 01 WK-DATA PIC X(2) OCCURS 3. 2623 PROCEDURE DIVISION. 2624 UNSTRING WK-CMD DELIMITED BY WK-SIGN(1) OR WK-SIGN(2) 2625 INTO WK-DATA(1) DELIMITER IN WK-DELIM(1) 2626 WK-DATA(2) DELIMITER IN WK-DELIM(2) 2627 WK-DATA(3) 2628 END-UNSTRING 2629 IF WK-DATA(1) NOT = "WW" 2630 OR WK-DATA(2) NOT = "DD" 2631 OR WK-DATA(3) NOT = "CC" 2632 OR WK-DELIM(1) NOT = "A" 2633 OR WK-DELIM(2) NOT = "B" 2634 DISPLAY WK-DATA(1) 2635 WK-DATA(2) 2636 WK-DATA(3) 2637 WK-DELIM(1) 2638 WK-DELIM(2) 2639 END-DISPLAY 2640 END-IF. 2641 STOP RUN. 2642]) 2643 2644AT_CHECK([$COMPILE -ftop-level-occurs-clause=ok prog.cob], [0], [], []) 2645AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2646 2647AT_CLEANUP 2648 2649 2650AT_SETUP([UNSTRING with FUNCTION / literal]) 2651AT_KEYWORDS([runmisc]) 2652 2653AT_DATA([prog.cob], [ 2654 IDENTIFICATION DIVISION. 2655 PROGRAM-ID. prog. 2656 DATA DIVISION. 2657 WORKING-STORAGE SECTION. 2658 01 FILLER. 2659 05 TSTUNS PIC X(479). 2660 05 PRM PIC X(16) OCCURS 4 TIMES. 2661 PROCEDURE DIVISION. 2662 MOVE "The,Quick,Brown,Fox" TO TSTUNS. 2663 UNSTRING TSTUNS DELIMITED BY ',' 2664 INTO PRM(1), PRM(2), PRM(3), PRM(4). 2665 DISPLAY "PRM(1) is " PRM(1) ":". 2666 DISPLAY "PRM(2) is " PRM(2) ":". 2667 DISPLAY "PRM(3) is " PRM(3) ":". 2668 DISPLAY "PRM(4) is " PRM(4) ":". 2669 UNSTRING FUNCTION UPPER-CASE(TSTUNS) DELIMITED BY ',' 2670 INTO PRM(1), PRM(2), PRM(3), PRM(4). 2671 DISPLAY "Now using UPPER-CASE" 2672 DISPLAY "PRM(1) is " PRM(1) ":". 2673 DISPLAY "PRM(2) is " PRM(2) ":". 2674 DISPLAY "PRM(3) is " PRM(3) ":". 2675 DISPLAY "PRM(4) is " PRM(4) ":". 2676 UNSTRING "Daddy,was,a,Rolling stone" DELIMITED BY ',' 2677 INTO PRM(1), PRM(2), PRM(3), PRM(4). 2678 DISPLAY "Now using Literal" 2679 DISPLAY "PRM(1) is " PRM(1) ":". 2680 DISPLAY "PRM(2) is " PRM(2) ":". 2681 DISPLAY "PRM(3) is " PRM(3) ":". 2682 DISPLAY "PRM(4) is " PRM(4) ":". 2683 UNSTRING FUNCTION LOWER-CASE("Daddy,was,a,Rolling stone") 2684 DELIMITED BY ',' 2685 INTO PRM(1), PRM(2), PRM(3), PRM(4). 2686 DISPLAY "Now using Literal + LOWER-CASE" 2687 DISPLAY "PRM(1) is " PRM(1) ":". 2688 DISPLAY "PRM(2) is " PRM(2) ":". 2689 DISPLAY "PRM(3) is " PRM(3) ":". 2690 DISPLAY "PRM(4) is " PRM(4) ":". 2691 STOP RUN. 2692]) 2693 2694AT_CHECK([$COMPILE prog.cob], [0], [], []) 2695AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 2696[PRM(1) is The : 2697PRM(2) is Quick : 2698PRM(3) is Brown : 2699PRM(4) is Fox : 2700Now using UPPER-CASE 2701PRM(1) is THE : 2702PRM(2) is QUICK : 2703PRM(3) is BROWN : 2704PRM(4) is FOX : 2705Now using Literal 2706PRM(1) is Daddy : 2707PRM(2) is was : 2708PRM(3) is a : 2709PRM(4) is Rolling stone : 2710Now using Literal + LOWER-CASE 2711PRM(1) is daddy : 2712PRM(2) is was : 2713PRM(3) is a : 2714PRM(4) is rolling stone : 2715], []) 2716 2717AT_CLEANUP 2718 2719 2720AT_SETUP([SORT: table sort]) 2721AT_KEYWORDS([runmisc]) 2722 2723AT_DATA([prog.cob], [ 2724 IDENTIFICATION DIVISION. 2725 PROGRAM-ID. prog. 2726 DATA DIVISION. 2727 WORKING-STORAGE SECTION. 2728 01 G VALUE "d4b2e1a3c5". 2729 02 TBL OCCURS 5. 2730 03 X PIC X. 2731 03 Y PIC 9. 2732 PROCEDURE DIVISION. 2733 SORT TBL ASCENDING KEY X. 2734 IF G NOT = "a3b2c5d4e1" 2735 DISPLAY G 2736 END-DISPLAY 2737 END-IF. 2738 SORT TBL DESCENDING KEY Y. 2739 IF G NOT = "c5d4a3b2e1" 2740 DISPLAY G 2741 END-DISPLAY 2742 END-IF. 2743 SORT TBL ASCENDING KEY TBL. 2744 IF G NOT = "a3b2c5d4e1" 2745 DISPLAY G 2746 END-DISPLAY 2747 END-IF. 2748 SORT TBL DESCENDING KEY. 2749 IF G NOT = "e1d4c5b2a3" 2750 DISPLAY G 2751 END-DISPLAY 2752 END-IF. 2753 STOP RUN. 2754]) 2755 2756AT_CHECK([$COMPILE prog.cob], [0], [], []) 2757AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 2758 2759AT_CLEANUP 2760 2761 2762AT_SETUP([SORT: table sort (2)]) 2763AT_KEYWORDS([runmisc]) 2764 2765AT_DATA([prog.cob], [ 2766 IDENTIFICATION DIVISION. 2767 PROGRAM-ID. prog. 2768 ENVIRONMENT DIVISION. 2769 DATA DIVISION. 2770 WORKING-STORAGE SECTION. 2771 01 K PIC 9(2). 2772 2773 01 CNT1 PIC 9(9) COMP-5 VALUE 4. 2774 01 TAB1. 2775 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 2776 DESCENDING TAB1-NR. 2777 10 TAB1-NR PIC 99. 2778 2779 01 TAB2. 2780 05 CNT2 PIC 9(9) COMP-5 VALUE 4. 2781 05 ROW2 OCCURS 1 TO 4 DEPENDING CNT2 2782 DESCENDING TAB2-NR. 2783 10 TAB2-NR PIC 99. 2784 2785 01 TAB3. 2786 05 CNT3 PIC 9(9) COMP-5 VALUE 10. 2787 05 ROW3 OCCURS 1 TO 10 DEPENDING CNT3 2788 DESCENDING TAB3-NR 2789 ASCENDING TAB3-DATA. 2790 10 TAB3-NR PIC 99. 2791 10 FILLER PIC X(2). 2792 10 TAB3-DATA PIC X(5). 2793 10 FILLER PIC X(2). 2794 10 TAB3-DATA2 PIC X(5). 2795 2796 2797 PROCEDURE DIVISION. 2798 A. 2799 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 2800 MOVE K TO TAB1-NR(K), TAB2-NR(K) 2801 END-PERFORM 2802 2803 MOVE 1 TO TAB3-NR(1). 2804 MOVE 1 TO TAB3-NR(8). 2805 MOVE 1 TO TAB3-NR(4). 2806 MOVE 6 TO TAB3-NR(2). 2807 MOVE 5 TO TAB3-NR(3). 2808 MOVE 5 TO TAB3-NR(9). 2809 MOVE 2 TO TAB3-NR(5). 2810 MOVE 2 TO TAB3-NR(10). 2811 MOVE 4 TO TAB3-NR(6). 2812 MOVE 3 TO TAB3-NR(7). 2813 2814 MOVE "abcde" TO TAB3-DATA(1). 2815 MOVE "AbCde" TO TAB3-DATA(2). 2816 MOVE "abcde" TO TAB3-DATA(3). 2817 MOVE "zyx" TO TAB3-DATA(4). 2818 MOVE "12345" TO TAB3-DATA(5). 2819 MOVE "zyx" TO TAB3-DATA(6). 2820 MOVE "abcde" TO TAB3-DATA(7). 2821 MOVE "AbCde" TO TAB3-DATA(8). 2822 MOVE "abc" TO TAB3-DATA(9). 2823 MOVE "12346" TO TAB3-DATA(10). 2824 2825 MOVE "day" TO TAB3-DATA2(1). 2826 MOVE "The" TO TAB3-DATA2(2). 2827 MOVE "eats" TO TAB3-DATA2(3). 2828 MOVE "." TO TAB3-DATA2(4). 2829 MOVE "mooos" TO TAB3-DATA2(5). 2830 MOVE "grass" TO TAB3-DATA2(6). 2831 MOVE "and" TO TAB3-DATA2(7). 2832 MOVE "whole" TO TAB3-DATA2(8). 2833 MOVE "cow" TO TAB3-DATA2(9). 2834 MOVE "the" TO TAB3-DATA2(10). 2835 2836 SORT ROW1 DESCENDING TAB1-NR 2837 SORT ROW2 DESCENDING TAB2-NR 2838 2839 DISPLAY "SINGLE TABLE" END-DISPLAY 2840 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 2841 DISPLAY FUNCTION TRIM(TAB1-NR(K)) END-DISPLAY 2842 END-PERFORM 2843 2844 DISPLAY "LOWER LEVEL TABLE" END-DISPLAY 2845 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 2846 DISPLAY FUNCTION TRIM(TAB2-NR(K)) END-DISPLAY 2847 END-PERFORM 2848 2849 SORT ROW3 DESCENDING TAB3-NR ASCENDING TAB3-DATA 2850 2851 DISPLAY "MULTY KEY SORT" END-DISPLAY 2852 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 10 2853 DISPLAY FUNCTION TRIM(ROW3(K)) 2854 END-DISPLAY 2855 END-PERFORM 2856 2857 STOP RUN. 2858]) 2859 2860AT_CHECK([$COMPILE prog.cob], [0], [], []) 2861AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [SINGLE TABLE 286204 286303 286402 286501 2866LOWER LEVEL TABLE 286704 286803 286902 287001 2871MULTY KEY SORT 287206 AbCde The 287305 abc cow 287405 abcde eats 287504 zyx grass 287603 abcde and 287702 12345 mooos 287802 12346 the 287901 AbCde whole 288001 abcde day 288101 zyx . 2882], []) 2883 2884AT_CLEANUP 2885 2886 2887AT_SETUP([SORT: table sort (3)]) 2888 2889AT_KEYWORDS([runmisc]) 2890 2891AT_DATA([prog.cob], [ 2892 IDENTIFICATION DIVISION. 2893 PROGRAM-ID. prog. 2894 ENVIRONMENT DIVISION. 2895 DATA DIVISION. 2896 WORKING-STORAGE SECTION. 2897 01 K PIC 9(2). 2898 2899 01 CNT1 PIC 9(9) COMP-5 VALUE 4. 2900 01 TAB1. 2901 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 2902 DESCENDING TAB1-NR. 2903 10 TAB1-NR PIC 99. 2904 10 TAB-DATA PIC X(5). 2905 01 TAB2. 2906 05 ROW2 OCCURS 1 TO 4 DEPENDING CNT1 2907 ASCENDING ROW2. 2908 10 TAB2-NR PIC 99. 2909 10 TAB2-DATA PIC X(5). 2910 2911 PROCEDURE DIVISION. 2912 A. 2913 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 2914 MOVE K TO TAB1-NR (K) 2915 MOVE 'BLA' TO TAB-DATA(K) 2916 END-PERFORM 2917 2918 SORT ROW1 2919 2920 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 2921 DISPLAY TAB1-NR(K) NO ADVANCING END-DISPLAY 2922 END-PERFORM 2923 2924 MOVE TAB1 TO TAB2 2925 SORT ROW2 2926 2927 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 2928 DISPLAY TAB2-NR(K) NO ADVANCING END-DISPLAY 2929 END-PERFORM 2930 2931 STOP RUN. 2932]) 2933 2934AT_DATA([prog2.cob], [ 2935 IDENTIFICATION DIVISION. 2936 PROGRAM-ID. prog2. 2937 ENVIRONMENT DIVISION. 2938 DATA DIVISION. 2939 WORKING-STORAGE SECTION. 2940 01 K PIC 9(2). 2941 2942 01 CNT1 PIC 9(9) COMP-5 VALUE 4. 2943 01 TAB1. 2944 05 ROW1 OCCURS 5 DESCENDING TAB1-NR. 2945 10 TAB1-NR PIC 99 VALUE ZERO. 2946 10 TAB-DATA PIC X(5). 2947 01 TAB2. 2948 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 2949 DESCENDING TAB1-NR. 2950 10 TAB1-NR PIC 99. 2951 10 TAB-DATA PIC X(5). 2952 2953 PROCEDURE DIVISION. 2954 A. 2955 DISPLAY TAB1-NR OF TAB1 (2) NO ADVANCING END-DISPLAY 2956 2957 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 2958 MOVE K TO TAB1-NR OF TAB2(K) 2959 MOVE 'BLA' TO TAB-DATA OF TAB2(K) 2960 END-PERFORM 2961 2962 SORT ROW1 OF TAB2. 2963 2964 PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 2965 DISPLAY TAB1-NR OF TAB2(K) NO ADVANCING END-DISPLAY 2966 END-PERFORM 2967 2968 STOP RUN. 2969]) 2970 2971AT_CHECK([$COMPILE prog.cob], [0], [], []) 2972AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [0403020101020304], []) 2973 2974AT_CHECK([$COMPILE prog2.cob], [0], [], []) 2975AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [0004030201], []) 2976 2977AT_CLEANUP 2978 2979 2980AT_SETUP([SORT: EBCDIC table sort]) 2981AT_KEYWORDS([runmisc ALPHABET OBJECT-COMPUTER]) 2982 2983AT_DATA([prog.cob], [ 2984 IDENTIFICATION DIVISION. 2985 PROGRAM-ID. prog. 2986 ENVIRONMENT DIVISION. 2987 CONFIGURATION SECTION. 2988 SPECIAL-NAMES. 2989 ALPHABET ALPHA IS EBCDIC. 2990 DATA DIVISION. 2991 WORKING-STORAGE SECTION. 2992 01 Z PIC X(10) VALUE "d4b2e1a3c5". 2993 01 G. 2994 02 TBL OCCURS 10. 2995 03 X PIC X. 2996 PROCEDURE DIVISION. 2997 MOVE Z TO G. 2998 SORT TBL ASCENDING KEY X SEQUENCE ALPHA. 2999 IF G NOT = "abcde12345" 3000 DISPLAY G 3001 END-DISPLAY 3002 END-IF. 3003 MOVE Z TO G. 3004 SORT TBL DESCENDING KEY X SEQUENCE ALPHA. 3005 IF G NOT = "54321edcba" 3006 DISPLAY G 3007 END-DISPLAY 3008 END-IF. 3009 STOP RUN. 3010]) 3011 3012AT_DATA([prog2.cob], [ 3013 IDENTIFICATION DIVISION. 3014 PROGRAM-ID. prog2. 3015 ENVIRONMENT DIVISION. 3016 CONFIGURATION SECTION. 3017 OBJECT-COMPUTER. 3018 x86 PROGRAM COLLATING SEQUENCE IS EBCDIC-CODE. 3019 SPECIAL-NAMES. 3020 ALPHABET EBCDIC-CODE IS EBCDIC. 3021 DATA DIVISION. 3022 WORKING-STORAGE SECTION. 3023 01 Z PIC X(10) VALUE "d4b2e1a3c5". 3024 01 G. 3025 02 TBL OCCURS 10. 3026 03 X PIC X. 3027 PROCEDURE DIVISION. 3028 MOVE Z TO G. 3029 SORT TBL ASCENDING KEY X. 3030 IF G NOT = "abcde12345" 3031 DISPLAY G. 3032 MOVE Z TO G. 3033 SORT TBL DESCENDING KEY X. 3034 IF G NOT = "54321edcba" 3035 DISPLAY G. 3036 STOP RUN. 3037]) 3038 3039AT_CHECK([$COMPILE prog.cob], [0], [], []) 3040AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3041AT_CHECK([$COMPILE prog2.cob], [0], [], []) 3042AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) 3043 3044AT_CLEANUP 3045 3046 3047AT_SETUP([PIC ZZZ-, ZZZ+]) 3048AT_KEYWORDS([runmisc editing]) 3049 3050AT_DATA([prog.cob], [ 3051 IDENTIFICATION DIVISION. 3052 PROGRAM-ID. prog. 3053 DATA DIVISION. 3054 WORKING-STORAGE SECTION. 3055 01 X-ZZZN PIC ZZZ-. 3056 01 XZN-RED REDEFINES X-ZZZN PIC X(4). 3057 01 X-ZZZP PIC ZZZ+. 3058 01 XZP-RED REDEFINES X-ZZZP PIC X(4). 3059 PROCEDURE DIVISION. 3060 MOVE -1 TO X-ZZZN. 3061 IF XZN-RED NOT = " 1-" 3062 DISPLAY "(" X-ZZZN ")" 3063 END-DISPLAY 3064 END-IF. 3065 MOVE 0 TO X-ZZZN. 3066 IF XZN-RED NOT = " " 3067 DISPLAY "(" X-ZZZN ")" 3068 END-DISPLAY 3069 END-IF. 3070 MOVE +1 TO X-ZZZN. 3071 IF XZN-RED NOT = " 1 " 3072 DISPLAY "(" X-ZZZN ")" 3073 END-DISPLAY 3074 END-IF. 3075 3076 MOVE -1 TO X-ZZZP. 3077 IF XZP-RED NOT = " 1-" 3078 DISPLAY "(" X-ZZZP ")" 3079 END-DISPLAY 3080 END-IF. 3081 MOVE 0 TO X-ZZZP. 3082 IF XZP-RED NOT = " " 3083 DISPLAY "(" X-ZZZP ")" 3084 END-DISPLAY 3085 END-IF. 3086 MOVE +1 TO X-ZZZP. 3087 IF XZP-RED NOT = " 1+" 3088 DISPLAY "(" X-ZZZP ")" 3089 END-DISPLAY 3090 END-IF. 3091 STOP RUN. 3092]) 3093 3094AT_CHECK([$COMPILE prog.cob], [0], [], []) 3095AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3096 3097AT_CLEANUP 3098 3099 3100AT_SETUP([PERFORM type OSVS]) 3101AT_KEYWORDS([runmisc]) 3102 3103AT_DATA([prog.cob], [ 3104 IDENTIFICATION DIVISION. 3105 PROGRAM-ID. prog. 3106 DATA DIVISION. 3107 WORKING-STORAGE SECTION. 3108 01 MYOCC PIC 9(8) COMP VALUE 0. 3109 PROCEDURE DIVISION. 3110 ASTART SECTION. 3111 A01. 3112 PERFORM BTEST. 3113 IF MYOCC NOT = 2 3114 DISPLAY MYOCC 3115 END-DISPLAY 3116 END-IF. 3117 STOP RUN. 3118 BTEST SECTION. 3119 B01. 3120 PERFORM B02 VARYING MYOCC FROM 1 BY 1 3121 UNTIL MYOCC > 5. 3122 GO TO B99. 3123 B02. 3124 IF MYOCC > 1 3125 GO TO B99 3126 END-IF. 3127 B99. 3128 EXIT. 3129]) 3130 3131AT_CHECK([$COMPILE -fperform-osvs prog.cob], [0], [], []) 3132AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3133 3134AT_CLEANUP 3135 3136 3137AT_SETUP([Sticky LINKAGE]) 3138AT_KEYWORDS([runmisc]) 3139 3140AT_DATA([callee.cob], [ 3141 IDENTIFICATION DIVISION. 3142 PROGRAM-ID. callee. 3143 DATA DIVISION. 3144 LINKAGE SECTION. 3145 01 P1 PIC X. 3146 01 P2 PIC X(6). 3147 01 P3 PIC X(6). 3148 PROCEDURE DIVISION USING P1 P2. 3149 IF P1 = "A" 3150 SET ADDRESS OF P3 TO ADDRESS OF P2 3151 ELSE 3152 IF P3 NOT = "OKOKOK" 3153 DISPLAY P3 3154 END-DISPLAY 3155 END-IF 3156 END-IF. 3157 EXIT PROGRAM. 3158]) 3159 3160AT_DATA([caller.cob], [ 3161 IDENTIFICATION DIVISION. 3162 PROGRAM-ID. caller. 3163 DATA DIVISION. 3164 WORKING-STORAGE SECTION. 3165 01 P1 PIC X VALUE "A". 3166 01 P2 PIC X(6) VALUE "NOT OK". 3167 PROCEDURE DIVISION. 3168 CALL "callee" USING P1 P2 3169 END-CALL. 3170 MOVE "B" TO P1. 3171 MOVE "OKOKOK" TO P2. 3172 CALL "callee" USING P1 3173 END-CALL. 3174 STOP RUN. 3175]) 3176 3177AT_CHECK([$COMPILE_MODULE -fsticky-linkage callee.cob], [0], [], []) 3178AT_CHECK([$COMPILE -fsticky-linkage caller.cob], [0], [], []) 3179AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) 3180 3181AT_CLEANUP 3182 3183 3184AT_SETUP([COB_PRE_LOAD]) 3185AT_KEYWORDS([runmisc]) 3186 3187AT_DATA([callee.cob], [ 3188 IDENTIFICATION DIVISION. 3189 PROGRAM-ID. callee2. 3190 PROCEDURE DIVISION. 3191 EXIT PROGRAM. 3192]) 3193 3194AT_DATA([caller.cob], [ 3195 IDENTIFICATION DIVISION. 3196 PROGRAM-ID. caller. 3197 PROCEDURE DIVISION. 3198 CALL "callee2" 3199 END-CALL. 3200 STOP RUN. 3201]) 3202 3203AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 3204AT_CHECK([$COMPILE caller.cob], [0], [], []) 3205AT_CHECK([COB_PRE_LOAD=callee $COBCRUN_DIRECT ./caller], [0], [], []) 3206 3207AT_CLEANUP 3208 3209 3210AT_SETUP([COB_PRE_LOAD with entry points]) 3211AT_KEYWORDS([runmisc]) 3212 3213AT_DATA([prog.cob], [ 3214 IDENTIFICATION DIVISION. 3215 PROGRAM-ID. prog. 3216 3217 DATA DIVISION. 3218 WORKING-STORAGE SECTION. 3219 3220 01 VAR1 PIC X(5) VALUE '12abc'. 3221 01 VAR2 PIC X(2) VALUE '11'. 3222 3223 PROCEDURE DIVISION. 3224 3225 ENTRY 'ent1'. 3226 DISPLAY VAR1 END-DISPLAY 3227 GOBACK. 3228 3229 ENTRY 'ent2'. 3230 DISPLAY VAR2 END-DISPLAY 3231 GOBACK. 3232]) 3233 3234AT_DATA([prog1.cob], [ 3235 IDENTIFICATION DIVISION. 3236 PROGRAM-ID. prog1. 3237 3238 DATA DIVISION. 3239 WORKING-STORAGE SECTION. 3240 3241 01 VAR2 PIC X(2) VALUE '55'. 3242 01 VAR3 PIC X(5) VALUE 'xxxxx'. 3243 3244 PROCEDURE DIVISION. 3245 3246 ENTRY 'ent2'. 3247 DISPLAY VAR2 END-DISPLAY 3248 GOBACK. 3249 3250 ENTRY 'ent3'. 3251 DISPLAY VAR3 END-DISPLAY 3252 GOBACK. 3253]) 3254 3255AT_DATA([main-prog.cob], [ 3256 IDENTIFICATION DIVISION. 3257 PROGRAM-ID. main-prog. 3258 DATA DIVISION. 3259 WORKING-STORAGE SECTION. 3260 PROCEDURE DIVISION. 3261 3262 CALL 'ent1' END-CALL 3263 CALL 'ent2' END-CALL 3264 CALL 'ent3' END-CALL 3265 3266 STOP RUN. 3267]) 3268 3269AT_CHECK([$COMPILE_MODULE prog.cob], [0], [], []) 3270AT_CHECK([$COMPILE_MODULE prog1.cob], [0], [], []) 3271AT_CHECK([$COMPILE main-prog.cob], [0], [], []) 3272AT_CHECK([COB_PRE_LOAD="prog"$PATHSEP"prog1" $COBCRUN_DIRECT ./main-prog], [0], 3273[12abc 327411 3275xxxxx 3276], []) 3277 3278AT_CLEANUP 3279 3280 3281AT_SETUP([Lookup ENTRY from main executable]) 3282AT_KEYWORDS([runmisc]) 3283 3284AT_DATA([prog.cob], [ 3285 IDENTIFICATION DIVISION. 3286 PROGRAM-ID. prog. 3287 3288 DATA DIVISION. 3289 WORKING-STORAGE SECTION. 3290 01 PROGRAM-LINK USAGE PROGRAM-POINTER. 3291 3292 PROCEDURE DIVISION. 3293 SET PROGRAM-LINK TO ENTRY "subprogram" 3294 IF PROGRAM-LINK EQUAL NULL THEN 3295 DISPLAY "error: no subprogram linkage" UPON SYSERR 3296 END-DISPLAY 3297 ELSE 3298 CALL PROGRAM-LINK 3299 ON EXCEPTION 3300 DISPLAY "hard error: unable to invoke subprogram" 3301 UPON SYSERR 3302 END-DISPLAY 3303 END-CALL 3304 DISPLAY RETURN-CODE WITH NO ADVANCING 3305 END-DISPLAY 3306 END-IF 3307 GOBACK. 3308 3309 ENTRY "subprogram". 3310 DISPLAY "subprogram" WITH NO ADVANCING 3311 END-DISPLAY 3312 SET RETURN-CODE TO 42 3313 . 3314]) 3315 3316AT_CHECK([$COMPILE prog.cob], [0], [], []) 3317AT_CHECK([$COBCRUN_DIRECT ./prog], [42], [subprogram+000000042], []) 3318 3319AT_CLEANUP 3320 3321 3322AT_SETUP([COB_LOAD_CASE=UPPER test]) 3323AT_KEYWORDS([runmisc]) 3324 3325AT_DATA([CALLEE.cob], [ 3326 IDENTIFICATION DIVISION. 3327 PROGRAM-ID. callee. 3328 PROCEDURE DIVISION. 3329 EXIT PROGRAM. 3330]) 3331 3332AT_DATA([caller.cob], [ 3333 IDENTIFICATION DIVISION. 3334 PROGRAM-ID. caller. 3335 PROCEDURE DIVISION. 3336 CALL "callee" 3337 END-CALL. 3338 STOP RUN. 3339]) 3340 3341AT_CHECK([$COMPILE_MODULE CALLEE.cob], [0], [], []) 3342AT_CHECK([$COMPILE caller.cob], [0], [], []) 3343AT_CHECK([COB_LOAD_CASE=UPPER ./caller], [0], [], []) 3344 3345AT_CLEANUP 3346 3347 3348AT_SETUP([ALLOCATE / FREE with BASED item (1)]) 3349AT_KEYWORDS([runmisc]) 3350 3351AT_DATA([prog.cob], [ 3352 IDENTIFICATION DIVISION. 3353 PROGRAM-ID. prog. 3354 DATA DIVISION. 3355 LINKAGE SECTION. 3356 01 MYFLD PIC X(6) BASED VALUE "ABCDEF". 3357 PROCEDURE DIVISION. 3358 ASTART SECTION. 3359 A01. 3360 ALLOCATE MYFLD INITIALIZED. 3361 IF MYFLD NOT = "ABCDEF" 3362 DISPLAY MYFLD 3363 END-DISPLAY 3364 END-IF. 3365 FREE ADDRESS OF MYFLD. 3366 STOP RUN. 3367]) 3368 3369AT_CHECK([$COMPILE prog.cob], [0], [], []) 3370AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3371 3372AT_CLEANUP 3373 3374 3375AT_SETUP([ALLOCATE / FREE with BASED item (2)]) 3376AT_KEYWORDS([runmisc]) 3377 3378AT_DATA([prog.cob], [ 3379 IDENTIFICATION DIVISION. 3380 PROGRAM-ID. prog. 3381 DATA DIVISION. 3382 WORKING-STORAGE SECTION. 3383 01 MYFLD BASED. 3384 03 MYFLDX PIC X. 3385 03 MYFLD9 PIC 9. 3386 PROCEDURE DIVISION. 3387 IF ADDRESS OF MYFLD NOT = NULL 3388 DISPLAY "BASED ITEM WITH ADDRESS ON START" 3389 END-DISPLAY 3390 END-IF. 3391 FREE MYFLD. 3392 ALLOCATE MYFLD. 3393 IF ADDRESS OF MYFLD = NULL 3394 DISPLAY "BASED ITEM WITHOUT ADDRESS AFTER ALLOCATE" 3395 END-DISPLAY 3396 END-IF. 3397 INITIALIZE MYFLD. 3398 IF MYFLD NOT = " 0" 3399 DISPLAY "BASED ITEM INITIALIZED WRONG: " 3400 WITH NO ADVANCING 3401 END-DISPLAY 3402 DISPLAY MYFLD 3403 END-DISPLAY 3404 END-IF. 3405 3406 FREE ADDRESS OF MYFLD. 3407 IF ADDRESS OF MYFLD NOT = NULL 3408 DISPLAY "BASED ITEM WITH ADDRESS AFTER FREE" 3409 END-DISPLAY 3410 END-IF. 3411]) 3412 3413AT_CHECK([$COMPILE prog.cob], [0], [], []) 3414AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3415# Run both executable and module as we have a different code generation here 3416AT_CHECK([$COMPILE_MODULE prog.cob], [0], [], []) 3417AT_CHECK([$COBCRUN prog], [0], [], []) 3418 3419AT_CLEANUP 3420 3421 3422AT_SETUP([ALLOCATE CHARACTERS INITIALIZED TO]) 3423AT_KEYWORDS([runmisc]) 3424 3425AT_DATA([prog.cob], [ 3426 IDENTIFICATION DIVISION. 3427 PROGRAM-ID. prog. 3428 DATA DIVISION. 3429 WORKING-STORAGE SECTION. 3430 01 MYPTR USAGE POINTER. 3431 LINKAGE SECTION. 3432 01 MYFLD PIC X(4). 3433 PROCEDURE DIVISION. 3434 ASTART SECTION. 3435 A01. 3436 ALLOCATE 4 CHARACTERS 3437 INITIALIZED TO "ABCD" 3438 RETURNING MYPTR. 3439 SET ADDRESS OF MYFLD TO MYPTR. 3440 IF MYFLD NOT = "ABCD" 3441 DISPLAY MYFLD 3442 END-DISPLAY 3443 END-IF. 3444 FREE MYPTR. 3445 ALLOCATE 4 CHARACTERS 3446 INITIALIZED TO ALL "Z" 3447 RETURNING MYPTR. 3448 SET ADDRESS OF MYFLD TO MYPTR. 3449 IF MYFLD NOT = "ZZZZ" 3450 DISPLAY MYFLD 3451 END-DISPLAY 3452 END-IF. 3453 FREE MYPTR. 3454 STOP RUN. 3455]) 3456 3457AT_CHECK([$COMPILE prog.cob], [0], [], []) 3458AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3459 3460AT_CLEANUP 3461 3462 3463AT_SETUP([Initialized value with defaultbyte]) 3464AT_KEYWORDS([runmisc]) 3465 3466AT_DATA([prog.cob], [ 3467 IDENTIFICATION DIVISION. 3468 PROGRAM-ID. prog. 3469 DATA DIVISION. 3470 WORKING-STORAGE SECTION. 3471 01 MYFLD PIC X(6). 3472 PROCEDURE DIVISION. 3473 ASTART SECTION. 3474 A01. 3475 IF MYFLD NOT = "AAAAAA" 3476 DISPLAY MYFLD 3477 END-DISPLAY 3478 END-IF. 3479 STOP RUN. 3480]) 3481 3482AT_CHECK([$COMPILE -fdefaultbyte=A prog.cob], [0], [], []) 3483AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3484 3485AT_CLEANUP 3486 3487 3488AT_SETUP([CALL with OMITTED parameter]) 3489AT_KEYWORDS([runmisc]) 3490 3491AT_DATA([callee.cob], [ 3492 IDENTIFICATION DIVISION. 3493 PROGRAM-ID. callee. 3494 DATA DIVISION. 3495 LINKAGE SECTION. 3496 01 P1 PIC X. 3497 01 P2 PIC X(6). 3498 PROCEDURE DIVISION USING P1 OPTIONAL P2. 3499 IF P2 NOT OMITTED 3500 DISPLAY P2 3501 END-DISPLAY 3502 END-IF. 3503 EXIT PROGRAM. 3504]) 3505 3506AT_DATA([caller.cob], [ 3507 IDENTIFICATION DIVISION. 3508 PROGRAM-ID. caller. 3509 DATA DIVISION. 3510 WORKING-STORAGE SECTION. 3511 01 P1 PIC X VALUE "A". 3512 PROCEDURE DIVISION. 3513 CALL "callee" USING P1 3514 END-CALL. 3515 CALL "callee" USING P1 OMITTED 3516 END-CALL. 3517 STOP RUN. 3518]) 3519 3520AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 3521AT_CHECK([$COMPILE caller.cob], [0], [], []) 3522AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) 3523 3524AT_CLEANUP 3525 3526 3527AT_SETUP([CALL in from C, cob_call_params explicitly set]) 3528AT_KEYWORDS([runmisc]) 3529 3530AT_DATA([callee.cob], [ 3531 IDENTIFICATION DIVISION. 3532 PROGRAM-ID. callee. 3533 DATA DIVISION. 3534 LINKAGE SECTION. 3535 01 P1 PIC X. 3536 01 P2 PIC X(6). 3537 PROCEDURE DIVISION USING P1 OPTIONAL P2. 3538 IF P2 NOT OMITTED 3539 DISPLAY 'UNEXPECTED P2: ' P2 3540 END-DISPLAY 3541 END-IF 3542 DISPLAY 'P1: ' P1 WITH NO ADVANCING 3543 END-DISPLAY. 3544 EXIT PROGRAM. 3545]) 3546 3547AT_DATA([caller.c], [[ 3548#include <stdio.h> 3549#include <libcob.h> 3550 3551int callee (char *, char *); 3552 3553#ifndef NULL 3554#define NULL (void*)0 3555#endif 3556 3557int 3558main (int argc, char **argv) 3559{ 3560 cob_global *cobol_global; 3561 /* for storing COBOL return code */ 3562 int cob_ret; 3563 3564 /* initialize parameters */ 3565 char *p1 = "A"; 3566 3567 /* initialize the COBOL run-time library */ 3568 cob_init(argc, argv); 3569 3570 /* setup for COBOL parameter handling */ 3571 cobol_global = cob_get_global_ptr (); 3572 cobol_global->cob_call_params = 1; 3573 3574 /* call COBOL program */ 3575 cob_ret = callee (p1, NULL); 3576 3577 /* Clean up and terminate - This does not return */ 3578 cob_stop_run (cob_ret); 3579} 3580]]) 3581 3582AT_CHECK([$COMPILE -o caller caller.c callee.cob], [0], [], []) 3583AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [P1: A], []) 3584 3585AT_CLEANUP 3586 3587 3588AT_SETUP([CALL in from C, cob_call_params unknown]) 3589AT_KEYWORDS([runmisc]) 3590 3591AT_DATA([callee.cob], [ 3592 IDENTIFICATION DIVISION. 3593 PROGRAM-ID. callee. 3594 DATA DIVISION. 3595 LINKAGE SECTION. 3596 01 P1 PIC X. 3597 01 P2 PIC X(6). 3598 PROCEDURE DIVISION USING P1 P2. 3599 IF P1 NOT EQUAL "A" 3600 DISPLAY P1 3601 END-DISPLAY 3602 END-IF. 3603 IF P2 NOT EQUAL "FROM C" 3604 DISPLAY P2 3605 END-DISPLAY 3606 ELSE 3607 DISPLAY "OK" WITH NO ADVANCING 3608 END-DISPLAY 3609 END-IF. 3610 EXIT PROGRAM. 3611]) 3612 3613AT_DATA([caller.c], [[ 3614#include <stdio.h> 3615#include <libcob.h> 3616 3617int callee (char *, char *); 3618 3619int 3620main (int argc, char **argv) 3621{ 3622 /* for storing COBOL return code */ 3623 int cob_ret; 3624 3625 /* initialize parameters */ 3626 char *p1 = "A"; 3627 char *p2 = "FROM C"; 3628 3629 /* initialize the COBOL run-time library */ 3630 cob_init (argc, argv); 3631 3632 /* call COBOL program */ 3633 cob_ret = callee (p1, p2); 3634 3635 /* Clean up and terminate - This does not return */ 3636 cob_stop_run (cob_ret); 3637} 3638]]) 3639 3640AT_CHECK([$COMPILE -o caller caller.c callee.cob], [0], [], []) 3641AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK], []) 3642 3643AT_CLEANUP 3644 3645 3646AT_SETUP([CALL C with callback, PROCEDURE DIVISION EXTERN]) 3647AT_KEYWORDS([runmisc extensions CALL-CONVENTION]) 3648 3649AT_DATA([prog.cob], [ 3650 IDENTIFICATION DIVISION. 3651 PROGRAM-ID. prog. 3652 DATA DIVISION. 3653 WORKING-STORAGE SECTION. 3654 01 CB USAGE PROGRAM-POINTER. 3655 PROCEDURE DIVISION. 3656 SET CB TO ENTRY "callback" 3657 CALL STATIC "cprog" USING BY VALUE CB 3658 END-CALL 3659 EXIT PROGRAM. 3660 END PROGRAM prog. 3661 3662 IDENTIFICATION DIVISION. 3663 PROGRAM-ID. callback. 3664 ENVIRONMENT DIVISION. 3665 CONFIGURATION SECTION. 3666 SPECIAL-NAMES. 3667 CALL-CONVENTION 0 IS EXTERN. 3668 DATA DIVISION. 3669 LINKAGE SECTION. 3670 01 P1 USAGE POINTER. 3671 01 P2 USAGE BINARY-LONG. 3672 01 P3 PIC X(8). 3673 PROCEDURE DIVISION EXTERN USING 3674 BY VALUE P1 P2 BY REFERENCE P3. 3675 IF P1 NOT EQUAL ADDRESS OF P3 3676 DISPLAY P1 3677 END-DISPLAY 3678 END-IF 3679 IF P2 NOT EQUAL 42 3680 DISPLAY P2 3681 END-DISPLAY 3682 END-IF 3683 IF P3 NOT EQUAL "CALLBACK" 3684 DISPLAY P3 3685 END-DISPLAY 3686 END-IF 3687 EXIT PROGRAM. 3688]) 3689 3690AT_DATA([cprog.c], [[ 3691#include <stdio.h> 3692#include <libcob.h> 3693 3694COB_EXT_EXPORT int 3695cprog (void *cb) 3696{ 3697 char *p1; 3698 int p2 = 42; 3699 char *p3 = "CALLBACK"; 3700 3701 p1 = p3; 3702 ((int (*)(char *, int, char *))cb)(p1, p2, p3); 3703 return 0; 3704} 3705]]) 3706 3707AT_CHECK([$COMPILE -Wno-unfinished -o prog prog.cob cprog.c], [0], [], []) 3708AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3709 3710AT_CLEANUP 3711 3712 3713AT_SETUP([CALL C with callback, ENTRY-CONVENTION EXTERN]) 3714AT_KEYWORDS([runmisc CALL-CONVENTION LINKAGE]) 3715 3716AT_DATA([prog.cob], [ 3717 IDENTIFICATION DIVISION. 3718 PROGRAM-ID. prog. 3719 OPTIONS. 3720 ENTRY-CONVENTION COBOL. 3721 DATA DIVISION. 3722 WORKING-STORAGE SECTION. 3723 01 CB USAGE PROGRAM-POINTER. 3724 PROCEDURE DIVISION. 3725 SET CB TO ENTRY "callback" 3726 CALL STATIC "cprog" USING BY VALUE CB 3727 END-CALL 3728 EXIT PROGRAM. 3729 END PROGRAM prog. 3730 3731 IDENTIFICATION DIVISION. 3732 PROGRAM-ID. callback. 3733 OPTIONS. 3734 ENTRY-CONVENTION EXTERN. 3735 DATA DIVISION. 3736 LINKAGE SECTION. 3737 01 P1 USAGE POINTER. 3738 01 P2 USAGE BINARY-LONG. 3739 01 P3 PIC X(8). 3740 PROCEDURE DIVISION USING 3741 BY VALUE P1 P2 BY REFERENCE P3. 3742 IF P1 NOT EQUAL ADDRESS OF P3 3743 DISPLAY P1 3744 END-DISPLAY 3745 END-IF 3746 IF P2 NOT EQUAL 42 3747 DISPLAY P2 3748 END-DISPLAY 3749 END-IF 3750 IF P3 NOT EQUAL "CALLBACK" 3751 DISPLAY P3 3752 END-DISPLAY 3753 END-IF 3754 EXIT PROGRAM. 3755]) 3756 3757AT_DATA([cprog.c], [[ 3758#include <stdio.h> 3759#include <libcob.h> 3760 3761COB_EXT_EXPORT int 3762cprog (void *cb) 3763{ 3764 char *p1; 3765 int p2 = 42; 3766 char *p3 = "CALLBACK"; 3767 3768 p1 = p3; 3769 ((int (*)(char *, int, char *))cb)(p1, p2, p3); 3770 return 0; 3771} 3772]]) 3773 3774AT_CHECK([$COMPILE -Wno-unfinished -o prog prog.cob cprog.c], [0], [], []) 3775AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3776 3777AT_DATA([prog2.cob], [ 3778 IDENTIFICATION DIVISION. 3779 PROGRAM-ID. prog. 3780 DATA DIVISION. 3781 WORKING-STORAGE SECTION. 3782 01 CB USAGE PROGRAM-POINTER. 3783 PROCEDURE DIVISION. 3784 SET CB TO ENTRY "callback" 3785 CALL STATIC "cprog" USING BY VALUE CB 3786 END-CALL 3787 EXIT PROGRAM. 3788 END PROGRAM prog. 3789 3790 IDENTIFICATION DIVISION. 3791 PROGRAM-ID. callback. 3792 DATA DIVISION. 3793 LINKAGE SECTION. 3794 01 P1 USAGE POINTER. 3795 01 P2 USAGE BINARY-LONG. 3796 01 P3 PIC X(8). 3797 PROCEDURE DIVISION WITH C LINKAGE 3798 USING BY VALUE P1 P2 BY REFERENCE P3. 3799 IF P1 NOT EQUAL ADDRESS OF P3 3800 DISPLAY P1 3801 END-DISPLAY 3802 END-IF 3803 IF P2 NOT EQUAL 42 3804 DISPLAY P2 3805 END-DISPLAY 3806 END-IF 3807 IF P3 NOT EQUAL "CALLBACK" 3808 DISPLAY P3 3809 END-DISPLAY 3810 END-IF 3811 EXIT PROGRAM. 3812]) 3813 3814AT_DATA([prog3.cob], [ 3815 IDENTIFICATION DIVISION. 3816 PROGRAM-ID. prog. 3817 DATA DIVISION. 3818 WORKING-STORAGE SECTION. 3819 01 CB USAGE PROGRAM-POINTER. 3820 PROCEDURE DIVISION. 3821 SET CB TO ENTRY "callback" 3822 CALL STATIC "cprog" USING BY VALUE CB 3823 END-CALL 3824 EXIT PROGRAM. 3825 END PROGRAM prog. 3826 3827 IDENTIFICATION DIVISION. 3828 PROGRAM-ID. callback. 3829 ENVIRONMENT DIVISION. 3830 CONFIGURATION SECTION. 3831 SPECIAL-NAMES. 3832 CALL-CONVENTION 0 IS EXTERN. 3833 DATA DIVISION. 3834 LINKAGE SECTION. 3835 01 P1 USAGE POINTER. 3836 01 P2 USAGE BINARY-LONG. 3837 01 P3 PIC X(8). 3838 PROCEDURE DIVISION EXTERN 3839 USING BY VALUE P1 P2 BY REFERENCE P3. 3840 IF P1 NOT EQUAL ADDRESS OF P3 3841 DISPLAY P1 3842 END-DISPLAY 3843 END-IF 3844 IF P2 NOT EQUAL 42 3845 DISPLAY P2 3846 END-DISPLAY 3847 END-IF 3848 IF P3 NOT EQUAL "CALLBACK" 3849 DISPLAY P3 3850 END-DISPLAY 3851 END-IF 3852 EXIT PROGRAM. 3853]) 3854 3855AT_CHECK([$COMPILE -Wno-unfinished -o prog prog2.cob cprog.c], [0], [], []) 3856AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3857 3858AT_CHECK([$COMPILE -Wno-unfinished -o prog prog3.cob cprog.c], [0], [], []) 3859AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 3860 3861AT_CLEANUP 3862 3863 3864AT_SETUP([CALL in from C with init missing / implicit]) 3865AT_KEYWORDS([runmisc implicit-init]) 3866 3867AT_DATA([callee.cob], [ 3868 IDENTIFICATION DIVISION. 3869 PROGRAM-ID. callee. 3870 DATA DIVISION. 3871 LINKAGE SECTION. 3872 01 P1 PIC X. 3873 01 P2 PIC X(6). 3874 PROCEDURE DIVISION USING P1 P2. 3875 IF P1 NOT EQUAL "A" 3876 DISPLAY P1 3877 END-DISPLAY 3878 END-IF. 3879 IF P2 NOT EQUAL "FROM C" 3880 DISPLAY P2 3881 END-DISPLAY 3882 ELSE 3883 DISPLAY "OK" WITH NO ADVANCING 3884 END-DISPLAY 3885 END-IF. 3886 STOP RUN. 3887]) 3888 3889AT_DATA([caller.c], [[ 3890int callee (char *, char *); 3891 3892int 3893main (int argc, char **argv) 3894{ 3895 /* initialize parameters */ 3896 char *p1 = "A"; 3897 char *p2 = "FROM C"; 3898 3899 /* call COBOL program (initialization missing) 3900 note: COBOL program terminates the program by STOP RUN */ 3901 (void)callee (p1, p2); 3902} 3903]]) 3904 3905AT_CHECK([$COMPILE -o caller caller.c callee.cob], [0], [], []) 3906AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], 3907[libcob: error: cob_init() has not been called 3908]) 3909 3910AT_CHECK([$COMPILE -fimplicit-init -o caller caller.c callee.cob], [0], [], []) 3911AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK], []) 3912 3913AT_CLEANUP 3914 3915 3916AT_SETUP([CALL STATIC C from COBOL]) 3917AT_KEYWORDS([runmisc]) 3918 3919AT_DATA([caller.cob], [ 3920 IDENTIFICATION DIVISION. 3921 PROGRAM-ID. caller. 3922 DATA DIVISION. 3923 WORKING-STORAGE SECTION. 3924 01 P1 PIC X VALUE "A". 3925 01 P2 PIC X(7). 3926 77 P2-COB PIC X(7). 3927 PROCEDURE DIVISION. 3928 CALL STATIC 'callee' USING P1 P2 3929 IF P1 NOT EQUAL "B" 3930 DISPLAY 'NOT A: ' P1 3931 END-DISPLAY 3932 END-IF 3933 UNSTRING P2 DELIMITED BY LOW-VALUE 3934 INTO P2-COB 3935 END-UNSTRING 3936 EVALUATE TRUE 3937 WHEN P2-COB NOT EQUAL "FROM C" 3938 DISPLAY P2-COB '-' P2 3939 END-DISPLAY 3940 WHEN RETURN-CODE NOT = 3 3941 DISPLAY RETURN-CODE 3942 END-DISPLAY 3943 WHEN OTHER 3944 DISPLAY 'OK' WITH NO ADVANCING 3945 END-DISPLAY 3946 MOVE 0 TO RETURN-CODE 3947 END-EVALUATE 3948 EXIT PROGRAM. 3949]) 3950 3951AT_DATA([callee.c], [[ 3952#include <string.h> 3953 3954int 3955callee (char *p1, char *p2) 3956{ 3957 if (p1[0] == 'A') { 3958 p1[0] = 'B'; 3959 } 3960 memcpy (p2, "FROM C", 6); 3961 3962 return 3; 3963} 3964]]) 3965 3966AT_CHECK([$COMPILE -o caller caller.cob callee.c], [0], [], []) 3967AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [OK], []) 3968 3969AT_CLEANUP 3970 3971 3972AT_SETUP([ANY LENGTH (1)]) 3973AT_KEYWORDS([runmisc CALL]) 3974 3975AT_DATA([callee.cob], [ 3976 IDENTIFICATION DIVISION. 3977 PROGRAM-ID. callee. 3978 DATA DIVISION. 3979 WORKING-STORAGE SECTION. 3980 01 P2 PIC 99. 3981 LINKAGE SECTION. 3982 01 P1 PIC X ANY LENGTH. 3983 PROCEDURE DIVISION USING P1. 3984 MOVE LENGTH OF P1 TO P2. 3985 IF P2 NOT = 6 3986 DISPLAY P2 3987 END-DISPLAY 3988 END-IF. 3989 IF P1 NOT = "OKOKOK" 3990 DISPLAY P1 3991 END-DISPLAY 3992 END-IF. 3993 EXIT PROGRAM. 3994]) 3995 3996AT_DATA([caller.cob], [ 3997 IDENTIFICATION DIVISION. 3998 PROGRAM-ID. caller. 3999 DATA DIVISION. 4000 WORKING-STORAGE SECTION. 4001 01 P1 PIC X(6) VALUE "OKOKOK". 4002 PROCEDURE DIVISION. 4003 CALL "callee" USING P1 4004 END-CALL. 4005 STOP RUN. 4006]) 4007 4008AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 4009AT_CHECK([$COMPILE caller.cob], [0], [], []) 4010AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) 4011 4012AT_CLEANUP 4013 4014 4015AT_SETUP([ANY LENGTH (2)]) 4016AT_KEYWORDS([runmisc CALL]) 4017 4018AT_DATA([callee.cob], [ 4019 IDENTIFICATION DIVISION. 4020 PROGRAM-ID. callee. 4021 DATA DIVISION. 4022 WORKING-STORAGE SECTION. 4023 01 P2 PIC XXX. 4024 LINKAGE SECTION. 4025 01 P1 PIC X ANY LENGTH. 4026 PROCEDURE DIVISION USING P1. 4027 MOVE P1 TO P2. 4028 IF P2 NOT = "OK " 4029 DISPLAY P2 4030 END-DISPLAY 4031 END-IF. 4032 MOVE SPACE TO P1. 4033 EXIT PROGRAM. 4034]) 4035 4036AT_DATA([caller.cob], [ 4037 IDENTIFICATION DIVISION. 4038 PROGRAM-ID. caller. 4039 DATA DIVISION. 4040 WORKING-STORAGE SECTION. 4041 01 P1 PIC X(2) VALUE "OK". 4042 PROCEDURE DIVISION. 4043 CALL "callee" USING P1 4044 END-CALL. 4045 IF P1 NOT = SPACE 4046 DISPLAY P1 4047 END-DISPLAY 4048 END-IF. 4049 STOP RUN. 4050]) 4051 4052AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 4053AT_CHECK([$COMPILE caller.cob], [0], [], []) 4054AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) 4055 4056AT_CLEANUP 4057 4058 4059AT_SETUP([ANY LENGTH (3)]) 4060AT_KEYWORDS([runmisc CALL]) 4061 4062AT_DATA([prog.cob], [ 4063 IDENTIFICATION DIVISION. 4064 PROGRAM-ID. prog. 4065 4066 DATA DIVISION. 4067 WORKING-STORAGE SECTION. 4068 01 str PIC X(20) VALUE ALL "X". 4069 4070 PROCEDURE DIVISION. 4071 CALL "subprog" USING str 4072 . 4073 END PROGRAM prog. 4074 4075 IDENTIFICATION DIVISION. 4076 PROGRAM-ID. subprog. 4077 4078 DATA DIVISION. 4079 LINKAGE SECTION. 4080 01 str PIC X ANY LENGTH. 4081 4082 PROCEDURE DIVISION USING str. 4083 MOVE "abcd" TO str 4084 DISPLAY FUNCTION TRIM (str) 4085 MOVE "abcd" TO str (5:) 4086 DISPLAY FUNCTION TRIM (str) 4087 MOVE ALL "a" TO str 4088 DISPLAY FUNCTION TRIM (str) 4089 . 4090 END PROGRAM subprog. 4091]) 4092 4093AT_CHECK([$COMPILE prog.cob], [0], [], []) 4094AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 4095[abcd 4096abcdabcd 4097aaaaaaaaaaaaaaaaaaaa 4098]) 4099AT_CLEANUP 4100 4101 4102AT_SETUP([ANY LENGTH (4)]) 4103AT_KEYWORDS([runmisc IF CALL]) 4104 4105# comparision of any length was done only for first character - see bug 511 4106 4107AT_DATA([prog.cob], [ 4108 IDENTIFICATION DIVISION. 4109 PROGRAM-ID. prog. 4110 4111 DATA DIVISION. 4112 WORKING-STORAGE SECTION. 4113 01 str PIC X(20) VALUE ALL "X". 4114 4115 PROCEDURE DIVISION. 4116 CALL "subprog" USING str 4117 move ' 45' to str 4118 CALL "subprog" USING str 4119 . 4120 END PROGRAM prog. 4121 4122 IDENTIFICATION DIVISION. 4123 PROGRAM-ID. subprog. 4124 4125 DATA DIVISION. 4126 LINKAGE SECTION. 4127 01 str PIC X ANY LENGTH. 4128 4129 PROCEDURE DIVISION USING str. 4130 IF str = 'X' 4131 DISPLAY 'X is X' 4132 END-IF 4133 IF str = space 4134 DISPLAY 'X is space' 4135 END-IF 4136 . 4137 END PROGRAM subprog. 4138]) 4139 4140AT_CHECK([$COMPILE prog.cob], [0], [], []) 4141AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 4142AT_CLEANUP 4143 4144 4145AT_SETUP([ANY LENGTH (5)]) 4146AT_KEYWORDS([runmisc]) 4147 4148# any length variables resulted in SIGSEGV when module was first program called 4149 4150AT_DATA([subprog.cob], [ 4151 IDENTIFICATION DIVISION. 4152 PROGRAM-ID. subprog. 4153 4154 DATA DIVISION. 4155 LINKAGE SECTION. 4156 01 str1 PIC X ANY LENGTH. 4157 01 str2 PIC X ANY LENGTH. 4158 4159 PROCEDURE DIVISION USING str1 str2. 4160 DISPLAY 'IN' WITH NO ADVANCING 4161 . 4162 END PROGRAM subprog. 4163]) 4164 4165AT_CHECK([$COMPILE_MODULE subprog.cob], [0], [], []) 4166AT_CHECK([$COBCRUN subprog some test stuff], [0], [IN], []) 4167AT_CLEANUP 4168 4169 4170AT_SETUP([access to BASED item without allocation]) 4171AT_KEYWORDS([runmisc]) 4172 4173AT_DATA([prog.cob], [ 4174 IDENTIFICATION DIVISION. 4175 PROGRAM-ID. prog. 4176 DATA DIVISION. 4177 WORKING-STORAGE SECTION. 4178 01 X PIC X(4) BASED. 4179 PROCEDURE DIVISION. 4180 DISPLAY X NO ADVANCING 4181 END-DISPLAY. 4182 STOP RUN. 4183]) 4184 4185AT_DATA([prog2.cob], [ 4186 IDENTIFICATION DIVISION. 4187 PROGRAM-ID. prog2. 4188 DATA DIVISION. 4189 WORKING-STORAGE SECTION. 4190 01 X BASED. 4191 05 Y PIC X(4). 4192 PROCEDURE DIVISION. 4193 DISPLAY Y NO ADVANCING 4194 END-DISPLAY. 4195 STOP RUN. 4196]) 4197 4198AT_CHECK([$COMPILE prog.cob], [0], [], []) 4199AT_CHECK([$COMPILE prog2.cob], [0], [], []) 4200 4201AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], 4202[libcob: prog.cob:8: error: BASED/LINKAGE item 'X' has NULL address 4203]) 4204AT_CHECK([$COBCRUN_DIRECT ./prog2], [1], [], 4205[libcob: prog2.cob:9: error: BASED/LINKAGE item 'X' (accessed by 'Y') has NULL address 4206]) 4207 4208AT_CLEANUP 4209 4210 4211AT_SETUP([access to OPTIONAL LINKAGE item not passed]) 4212AT_KEYWORDS([runmisc]) 4213 4214AT_DATA([caller.cob], [ 4215 IDENTIFICATION DIVISION. 4216 PROGRAM-ID. caller. 4217 DATA DIVISION. 4218 WORKING-STORAGE SECTION. 4219 01 X PIC X(4) VALUE '9876'. 4220 PROCEDURE DIVISION. 4221 CALL 'callee' USING X 4222 END-CALL 4223 CALL 'callee' USING OMITTED 4224 END-CALL 4225 STOP RUN. 4226]) 4227 4228AT_DATA([callee.cob], [ 4229 IDENTIFICATION DIVISION. 4230 PROGRAM-ID. callee. 4231 DATA DIVISION. 4232 LINKAGE SECTION. 4233 01 X. 4234 05 Y PIC X(4). 4235 PROCEDURE DIVISION USING OPTIONAL X. 4236 IF Y NOT = '9876' 4237 DISPLAY Y NO ADVANCING 4238 END-DISPLAY 4239 END-IF. 4240 GOBACK. 4241]) 4242 4243AT_CHECK([$COMPILE caller.cob], [0], [], []) 4244AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 4245 4246AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], 4247[libcob: callee.cob:9: error: LINKAGE item 'X' (accessed by 'Y') not passed by caller 4248]) 4249 4250AT_CLEANUP 4251 4252 4253AT_SETUP([STOP RUN WITH NORMAL STATUS]) 4254AT_KEYWORDS([runmisc]) 4255 4256AT_DATA([prog.cob], [ 4257 IDENTIFICATION DIVISION. 4258 PROGRAM-ID. prog. 4259 DATA DIVISION. 4260 WORKING-STORAGE SECTION. 4261 PROCEDURE DIVISION. 4262 STOP RUN WITH NORMAL STATUS. 4263]) 4264 4265AT_CHECK([$COMPILE prog.cob], [0], [], []) 4266AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 4267 4268AT_CLEANUP 4269 4270 4271AT_SETUP([STOP RUN WITH ERROR STATUS]) 4272AT_KEYWORDS([runmisc]) 4273 4274AT_DATA([prog.cob], [ 4275 IDENTIFICATION DIVISION. 4276 PROGRAM-ID. prog. 4277 DATA DIVISION. 4278 WORKING-STORAGE SECTION. 4279 PROCEDURE DIVISION. 4280 STOP RUN WITH ERROR STATUS. 4281]) 4282 4283AT_CHECK([$COMPILE prog.cob], [0], [], []) 4284AT_CHECK([$COBCRUN_DIRECT ./prog], [1]) 4285 4286AT_CLEANUP 4287 4288 4289AT_SETUP([SYMBOLIC clause]) 4290AT_KEYWORDS([runmisc ALPHABET]) 4291 4292AT_DATA([prog.cob], [ 4293 IDENTIFICATION DIVISION. 4294 PROGRAM-ID. prog. 4295 ENVIRONMENT DIVISION. 4296 CONFIGURATION SECTION. 4297 SPECIAL-NAMES. 4298 ALPHABET A-EBC IS EBCDIC 4299 ALPHABET A-ASC IS ASCII 4300 SYMBOLIC Z-EBC IS 241 IN A-EBC 4301 SYMBOLIC Z-ASC IS 49 IN A-ASC 4302 . 4303 DATA DIVISION. 4304 WORKING-STORAGE SECTION. 4305 01 Z PIC X. 4306 PROCEDURE DIVISION. 4307 MOVE Z-ASC TO Z. 4308 IF Z NOT = "0" 4309 DISPLAY Z 4310 END-DISPLAY 4311 END-IF. 4312 MOVE Z-EBC TO Z. 4313 IF Z NOT = "0" 4314 DISPLAY Z 4315 END-DISPLAY 4316 END-IF. 4317 STOP RUN. 4318]) 4319 4320AT_CHECK([$COMPILE prog.cob], [0], [], []) 4321AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 4322 4323AT_CLEANUP 4324 4325 4326AT_SETUP([OCCURS clause with 1 entry]) 4327AT_KEYWORDS([runmisc]) 4328 4329AT_DATA([prog.cob], [ 4330 IDENTIFICATION DIVISION. 4331 PROGRAM-ID. prog. 4332 DATA DIVISION. 4333 WORKING-STORAGE SECTION. 4334 01 D1. 4335 03 FILLER OCCURS 1. 4336 05 D1-ENTRY PIC X(03) value '123'. 4337 01 D2. 4338 03 D2-ENTRY PIC X(03) value 'ABC' OCCURS 1. 4339 01 D1TOR. 4340 03 FILLER PIC X(03) value '456'. 4341 01 D1-R REDEFINES D1TOR. 4342 03 FILLER OCCURS 1. 4343 05 D1-R-ENTRY PIC X(03). 4344 01 D2TOR. 4345 03 FILLER PIC X(03) value 'DEF'. 4346 01 D2-R REDEFINES D2TOR. 4347 03 D2-R-ENTRY PIC X(03) OCCURS 1. 4348 4349 PROCEDURE DIVISION. 4350 IF D1-ENTRY (1) NOT = "123" 4351 DISPLAY D1-ENTRY (1) 4352 END-DISPLAY 4353 END-IF. 4354 IF D2-ENTRY (1) NOT = "ABC" 4355 DISPLAY D2-ENTRY (1) 4356 END-DISPLAY 4357 END-IF. 4358 IF D1-R-ENTRY (1) NOT = "456" 4359 DISPLAY D1-R-ENTRY (1) 4360 END-DISPLAY 4361 END-IF. 4362 IF D2-R-ENTRY (1) NOT = "DEF" 4363 DISPLAY D2-R-ENTRY (1) 4364 END-DISPLAY 4365 END-IF. 4366 STOP RUN. 4367]) 4368 4369AT_CHECK([$COMPILE prog.cob], [0], [], []) 4370AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 4371 4372AT_CLEANUP 4373 4374 4375AT_SETUP([Computing of different USAGEs w/o decimal point]) 4376AT_KEYWORDS([runmisc 4377BINARY-C-LONG BINARY-CHAR BINARY-DOUBLE BINARY-LONG 4378COMP COMP-1 COMP-2 COMP-3 COMP-5 COMP-6 COMP-X COMP-N 4379FLOAT-DECIMAL-16 FLOAT-DECIMAL-34 FLOAT-LONG FLOAT-SHORT]) 4380 4381AT_DATA([prog.cob], [ 4382 IDENTIFICATION DIVISION. 4383 PROGRAM-ID. 'prog'. 4384 ENVIRONMENT DIVISION. 4385 DATA DIVISION. 4386 WORKING-STORAGE SECTION. 4387 4388 * 4389 77 BCL-A BINARY-C-LONG VALUE 1. 4390 77 BCL-B BINARY-C-LONG VALUE 10. 4391 77 BCL-RES BINARY-C-LONG. 4392 * 4393 77 BC-A BINARY-CHAR VALUE 1. 4394 77 BC-B BINARY-CHAR VALUE 10. 4395 77 BC-RES BINARY-CHAR. 4396 * 4397 77 BD-A BINARY-DOUBLE VALUE 1. 4398 77 BD-B BINARY-DOUBLE VALUE 10. 4399 77 BD-RES BINARY-DOUBLE. 4400 * 4401 77 BL-A BINARY-LONG VALUE 1. 4402 77 BL-B BINARY-LONG VALUE 10. 4403 77 BL-RES BINARY-LONG. 4404 * 4405 77 C-A PIC S99 COMP VALUE 1. 4406 77 C-B PIC S99 COMP VALUE 10. 4407 77 C-RES PIC S99 COMP. 4408 * 4409 77 C1-A COMP-1 VALUE 1. 4410 77 C1-B COMP-1 VALUE 10. 4411 77 C1-RES COMP-1. 4412 * 4413 77 C2-A COMP-2 VALUE 1. 4414 77 C2-B COMP-2 VALUE 10. 4415 77 C2-RES COMP-2. 4416 * 4417 77 C3-A PIC S99 COMP-3 VALUE 1. 4418 77 C3-B PIC S99 COMP-3 VALUE 10. 4419 77 C3-RES PIC S99 COMP-3. 4420 * 4421 77 C5-A PIC S99 COMP-5 VALUE 1. 4422 77 C5-B PIC S99 COMP-5 VALUE 10. 4423 77 C5-RES PIC S99 COMP-5. 4424 * 4425 77 C6-A PIC 99 COMP-6 VALUE 1. 4426 77 C6-B PIC 99 COMP-6 VALUE 10. 4427 77 C6-RES PIC 99 COMP-6. 4428 * 4429 77 CN9-A PIC 99 COMP-N VALUE 1. 4430 77 CN9-B PIC 99 COMP-N VALUE 10. 4431 77 CN9-RES PIC 99 COMP-N. 4432 * 4433 77 CNX-A PIC X COMP-N VALUE 1. 4434 77 CNX-B PIC X COMP-N VALUE 10. 4435 77 CNX-RES PIC X COMP-N. 4436 * 4437 77 CX9-A PIC 99 COMP-X VALUE 1. 4438 77 CX9-B PIC 99 COMP-X VALUE 10. 4439 77 CX9-RES PIC 99 COMP-X. 4440 * 4441 77 CXX-A PIC X COMP-X VALUE 1. 4442 77 CXX-B PIC X COMP-X VALUE 10. 4443 77 CXX-RES PIC X COMP-X. 4444 * 4445 77 D-A PIC S99 VALUE 1. 4446 77 D-B PIC S99 VALUE 10. 4447 77 D-RES PIC S99. 4448 * 4449 77 FD16-A FLOAT-DECIMAL-16 VALUE 1. 4450 77 FD16-B FLOAT-DECIMAL-16 VALUE 10. 4451 77 FD16-RES FLOAT-DECIMAL-16. 4452 * 4453 77 FD34-A FLOAT-DECIMAL-34 VALUE 1. 4454 77 FD34-B FLOAT-DECIMAL-34 VALUE 10. 4455 77 FD34-RES FLOAT-DECIMAL-34. 4456 * 4457 77 FL-A FLOAT-LONG VALUE 1. 4458 77 FL-B FLOAT-LONG VALUE 10. 4459 77 FL-RES FLOAT-LONG. 4460 * 4461 77 FS-A FLOAT-SHORT VALUE 1. 4462 77 FS-B FLOAT-SHORT VALUE 10. 4463 77 FS-RES FLOAT-SHORT. 4464 * 4465 PROCEDURE DIVISION. 4466 * 4467 ADD BCL-B TO BCL-A END-ADD. 4468 MOVE BCL-A TO BCL-RES. 4469 IF BCL-RES NOT = 11 4470 DISPLAY 'ERROR BINARY-C-LONG + BINARY-C-LONG' 4471 END-DISPLAY 4472 END-IF. 4473 MOVE 1 TO BCL-A. 4474 ADD 10 TO BCL-A END-ADD. 4475 MOVE BCL-A TO BCL-RES. 4476 IF BCL-RES NOT = 11 4477 DISPLAY 'ERROR BINARY-C-LONG + NUM' 4478 END-DISPLAY 4479 END-IF. 4480 MOVE 11 TO BCL-A. 4481 SUBTRACT BCL-B FROM BCL-A END-SUBTRACT. 4482 MOVE BCL-A TO BCL-RES. 4483 IF BCL-RES NOT = 1 4484 DISPLAY 'ERROR BINARY-C-LONG - BINARY-C-LONG' 4485 END-DISPLAY 4486 END-IF. 4487 MOVE 11 TO BCL-A. 4488 SUBTRACT 10 FROM BCL-A END-SUBTRACT. 4489 MOVE BCL-A TO BCL-RES. 4490 IF BCL-RES NOT = 1 4491 DISPLAY 'ERROR BINARY-C-LONG - NUM' 4492 END-DISPLAY 4493 END-IF. 4494 * 4495 ADD BC-B TO BC-A END-ADD. 4496 MOVE BC-A TO BC-RES. 4497 IF BC-RES NOT = 11 4498 DISPLAY 'ERROR BINARY-CHAR + BINARY-CHAR' 4499 END-DISPLAY 4500 END-IF. 4501 MOVE 1 TO BC-A. 4502 ADD 10 TO BC-A END-ADD. 4503 MOVE BC-A TO BC-RES. 4504 IF BC-RES NOT = 11 4505 DISPLAY 'ERROR BINARY-CHAR + NUM' 4506 END-DISPLAY 4507 END-IF. 4508 MOVE 11 TO BC-A. 4509 SUBTRACT BC-B FROM BC-A END-SUBTRACT. 4510 MOVE BC-A TO BC-RES. 4511 IF BC-RES NOT = 1 4512 DISPLAY 'ERROR BINARY-CHAR - BINARY-CHAR' 4513 END-DISPLAY 4514 END-IF. 4515 MOVE 11 TO BC-A. 4516 SUBTRACT 10 FROM BC-A END-SUBTRACT. 4517 MOVE BC-A TO BC-RES. 4518 IF BC-RES NOT = 1 4519 DISPLAY 'ERROR BINARY-CHAR - NUM' 4520 END-DISPLAY 4521 END-IF. 4522 * 4523 ADD BD-B TO BD-A END-ADD. 4524 MOVE BD-A TO BD-RES. 4525 IF BD-RES NOT = 11 4526 DISPLAY 'ERROR BINARY-DOUBLE + BINARY-DOUBLE' 4527 END-DISPLAY 4528 END-IF. 4529 MOVE 1 TO BD-A. 4530 ADD 10 TO BD-A END-ADD. 4531 MOVE BD-A TO BD-RES. 4532 IF BD-RES NOT = 11 4533 DISPLAY 'ERROR BINARY-DOUBLE + NUM' 4534 END-DISPLAY 4535 END-IF. 4536 MOVE 11 TO BD-A. 4537 SUBTRACT BD-B FROM BD-A END-SUBTRACT. 4538 MOVE BD-A TO BD-RES. 4539 IF BD-RES NOT = 1 4540 DISPLAY 'ERROR BINARY-DOUBLE - BINARY-DOUBLE' 4541 END-DISPLAY 4542 END-IF. 4543 MOVE 11 TO BD-A. 4544 SUBTRACT 10 FROM BD-A END-SUBTRACT. 4545 MOVE BD-A TO BD-RES. 4546 IF BD-RES NOT = 1 4547 DISPLAY 'ERROR BINARY-DOUBLE - NUM' 4548 END-DISPLAY 4549 END-IF. 4550 * 4551 ADD BL-B TO BL-A END-ADD. 4552 MOVE BL-A TO BL-RES. 4553 IF BL-RES NOT = 11 4554 DISPLAY 'ERROR BINARY-LONG + BINARY-LONG' 4555 END-DISPLAY 4556 END-IF. 4557 MOVE 1 TO BL-A. 4558 ADD 10 TO BL-A END-ADD. 4559 MOVE BL-A TO BL-RES. 4560 IF BL-RES NOT = 11 4561 DISPLAY 'ERROR BINARY-LONG + NUM' 4562 END-DISPLAY 4563 END-IF. 4564 MOVE 11 TO BL-A. 4565 SUBTRACT BL-B FROM BL-A END-SUBTRACT. 4566 MOVE BL-A TO BL-RES. 4567 IF BL-RES NOT = 1 4568 DISPLAY 'ERROR BINARY-LONG - BINARY-LONG' 4569 END-DISPLAY 4570 END-IF. 4571 MOVE 11 TO BL-A. 4572 SUBTRACT 10 FROM BL-A END-SUBTRACT. 4573 MOVE BL-A TO BL-RES. 4574 IF BL-RES NOT = 1 4575 DISPLAY 'ERROR BINARY-LONG - NUM' 4576 END-DISPLAY 4577 END-IF. 4578 * 4579 ADD C-B TO C-A END-ADD. 4580 MOVE C-A TO C-RES. 4581 IF C-RES NOT = 11 4582 DISPLAY 'ERROR COMP + COMP' 4583 END-DISPLAY 4584 END-IF. 4585 MOVE 1 TO C-A. 4586 ADD 10 TO C-A END-ADD. 4587 MOVE C-A TO C-RES. 4588 IF C-RES NOT = 11 4589 DISPLAY 'ERROR COMP + NUM' 4590 END-DISPLAY 4591 END-IF. 4592 MOVE 11 TO C-A. 4593 SUBTRACT C-B FROM C-A END-SUBTRACT. 4594 MOVE C-A TO C-RES. 4595 IF C-RES NOT = 1 4596 DISPLAY 'ERROR COMP - COMP' 4597 END-DISPLAY 4598 END-IF. 4599 MOVE 11 TO C-A. 4600 SUBTRACT 10 FROM C-A END-SUBTRACT. 4601 MOVE C-A TO C-RES. 4602 IF C-RES NOT = 1 4603 DISPLAY 'ERROR COMP - NUM' 4604 END-DISPLAY 4605 END-IF. 4606 * 4607 ADD C1-B TO C1-A END-ADD. 4608 MOVE C1-A TO C1-RES. 4609 IF C1-RES NOT = 11 4610 DISPLAY 'ERROR COMP-1 + COMP-1' 4611 END-DISPLAY 4612 END-IF. 4613 MOVE 1 TO C1-A. 4614 ADD 10 TO C1-A END-ADD. 4615 MOVE C1-A TO C1-RES. 4616 IF C1-RES NOT = 11 4617 DISPLAY 'ERROR COMP-1 + NUM' 4618 END-DISPLAY 4619 END-IF. 4620 MOVE 11 TO C1-A. 4621 SUBTRACT C1-B FROM C1-A END-SUBTRACT. 4622 MOVE C1-A TO C1-RES. 4623 IF C1-RES NOT = 1 4624 DISPLAY 'ERROR COMP-1 - COMP-1' 4625 END-DISPLAY 4626 END-IF. 4627 MOVE 11 TO C1-A. 4628 SUBTRACT 10 FROM C1-A END-SUBTRACT. 4629 MOVE C1-A TO C1-RES. 4630 IF C1-RES NOT = 1 4631 DISPLAY 'ERROR COMP-1 - NUM' 4632 END-DISPLAY 4633 END-IF. 4634 * 4635 ADD C2-B TO C2-A END-ADD. 4636 MOVE C2-A TO C2-RES. 4637 IF C2-RES NOT = 11 4638 DISPLAY 'ERROR COMP-2 + COMP-2' 4639 END-DISPLAY 4640 END-IF. 4641 MOVE 1 TO C2-A. 4642 ADD 10 TO C2-A END-ADD. 4643 MOVE C2-A TO C2-RES. 4644 IF C2-RES NOT = 11 4645 DISPLAY 'ERROR COMP-2 + NUM' 4646 END-DISPLAY 4647 END-IF. 4648 MOVE 11 TO C2-A. 4649 SUBTRACT C2-B FROM C2-A END-SUBTRACT. 4650 MOVE C2-A TO C2-RES. 4651 IF C2-RES NOT = 1 4652 DISPLAY 'ERROR COMP-2 - COMP-2' 4653 END-DISPLAY 4654 END-IF. 4655 MOVE 11 TO C2-A. 4656 SUBTRACT 10 FROM C2-A END-SUBTRACT. 4657 MOVE C2-A TO C2-RES. 4658 IF C2-RES NOT = 1 4659 DISPLAY 'ERROR COMP-2 - NUM' 4660 END-DISPLAY 4661 END-IF. 4662 * 4663 ADD C3-B TO C3-A END-ADD. 4664 MOVE C3-A TO C3-RES. 4665 IF C3-RES NOT = 11 4666 DISPLAY 'ERROR COMP-3 + COMP-3' 4667 END-DISPLAY 4668 END-IF. 4669 MOVE 1 TO C3-A. 4670 ADD 10 TO C3-A END-ADD. 4671 MOVE C3-A TO C3-RES. 4672 IF C3-RES NOT = 11 4673 DISPLAY 'ERROR COMP-3 + NUM' 4674 END-DISPLAY 4675 END-IF. 4676 MOVE 11 TO C3-A. 4677 SUBTRACT C3-B FROM C3-A END-SUBTRACT. 4678 MOVE C3-A TO C3-RES. 4679 IF C3-RES NOT = 1 4680 DISPLAY 'ERROR COMP-3 - COMP-3' 4681 END-DISPLAY 4682 END-IF. 4683 MOVE 11 TO C3-A. 4684 SUBTRACT 10 FROM C3-A END-SUBTRACT. 4685 MOVE C3-A TO C3-RES. 4686 IF C3-RES NOT = 1 4687 DISPLAY 'ERROR COMP-3 - NUM' 4688 END-DISPLAY 4689 END-IF. 4690 * 4691 ADD C5-B TO C5-A END-ADD. 4692 MOVE C5-A TO C5-RES. 4693 IF C5-RES NOT = 11 4694 DISPLAY 'ERROR COMP-5 + COMP-5' 4695 END-DISPLAY 4696 END-IF. 4697 MOVE 1 TO C5-A. 4698 ADD 10 TO C5-A END-ADD. 4699 MOVE C5-A TO C5-RES. 4700 IF C5-RES NOT = 11 4701 DISPLAY 'ERROR COMP-5 + NUM' 4702 END-DISPLAY 4703 END-IF. 4704 MOVE 11 TO C5-A. 4705 SUBTRACT C5-B FROM C5-A END-SUBTRACT. 4706 MOVE C5-A TO C5-RES. 4707 IF C5-RES NOT = 1 4708 DISPLAY 'ERROR COMP-5 - COMP-5' 4709 END-DISPLAY 4710 END-IF. 4711 MOVE 11 TO C5-A. 4712 SUBTRACT 10 FROM C5-A END-SUBTRACT. 4713 MOVE C5-A TO C5-RES. 4714 IF C5-RES NOT = 1 4715 DISPLAY 'ERROR COMP-5 - NUM' 4716 END-DISPLAY 4717 END-IF. 4718 * 4719 ADD C6-B TO C6-A END-ADD. 4720 MOVE C6-A TO C6-RES. 4721 IF C6-RES NOT = 11 4722 DISPLAY 'ERROR COMP-6 + COMP-6' 4723 END-DISPLAY 4724 END-IF. 4725 MOVE 1 TO C6-A. 4726 ADD 10 TO C6-A END-ADD. 4727 MOVE C6-A TO C6-RES. 4728 IF C6-RES NOT = 11 4729 DISPLAY 'ERROR COMP-6 + NUM' 4730 END-DISPLAY 4731 END-IF. 4732 MOVE 11 TO C6-A. 4733 SUBTRACT C6-B FROM C6-A END-SUBTRACT. 4734 MOVE C6-A TO C6-RES. 4735 IF C6-RES NOT = 1 4736 DISPLAY 'ERROR COMP-6 - COMP-6' 4737 END-DISPLAY 4738 END-IF. 4739 MOVE 11 TO C6-A. 4740 SUBTRACT 10 FROM C6-A END-SUBTRACT. 4741 MOVE C6-A TO C6-RES. 4742 IF C6-RES NOT = 1 4743 DISPLAY 'ERROR COMP-6 - NUM' 4744 END-DISPLAY 4745 END-IF. 4746 * 4747 ADD CN9-B TO CN9-A END-ADD. 4748 MOVE CN9-A TO CN9-RES. 4749 IF CN9-RES NOT = 11 4750 DISPLAY 'ERROR COMP-N + COMP-N' 4751 END-DISPLAY 4752 END-IF. 4753 MOVE 1 TO CN9-A. 4754 ADD 10 TO CN9-A END-ADD. 4755 MOVE CN9-A TO CN9-RES. 4756 IF CN9-RES NOT = 11 4757 DISPLAY 'ERROR COMP-N + NUM' 4758 END-DISPLAY 4759 END-IF. 4760 MOVE 11 TO CN9-A. 4761 SUBTRACT CN9-B FROM CN9-A END-SUBTRACT. 4762 MOVE CN9-A TO CN9-RES. 4763 IF CN9-RES NOT = 1 4764 DISPLAY 'ERROR COMP-N - COMP-N' 4765 END-DISPLAY 4766 END-IF. 4767 MOVE 11 TO CN9-A. 4768 SUBTRACT 10 FROM CN9-A END-SUBTRACT. 4769 MOVE CN9-A TO CN9-RES. 4770 IF CN9-RES NOT = 1 4771 DISPLAY 'ERROR COMP-N - NUM' 4772 END-DISPLAY 4773 END-IF. 4774 * 4775 ADD CNX-B TO CNX-A END-ADD. 4776 MOVE CNX-A TO CNX-RES. 4777 IF CNX-RES NOT = 11 4778 DISPLAY 'ERROR COMP-N + COMP-N' 4779 END-DISPLAY 4780 END-IF. 4781 MOVE 1 TO CNX-A. 4782 ADD 10 TO CNX-A END-ADD. 4783 MOVE CNX-A TO CNX-RES. 4784 IF CNX-RES NOT = 11 4785 DISPLAY 'ERROR COMP-N + NUM' 4786 END-DISPLAY 4787 END-IF. 4788 MOVE 11 TO CNX-A. 4789 SUBTRACT CNX-B FROM CNX-A END-SUBTRACT. 4790 MOVE CNX-A TO CNX-RES. 4791 IF CNX-RES NOT = 1 4792 DISPLAY 'ERROR COMP-N - COMP-N' 4793 END-DISPLAY 4794 END-IF. 4795 MOVE 11 TO CNX-A. 4796 SUBTRACT 10 FROM CNX-A END-SUBTRACT. 4797 MOVE CNX-A TO CNX-RES. 4798 IF CNX-RES NOT = 1 4799 DISPLAY 'ERROR COMP-N - NUM' 4800 END-DISPLAY 4801 END-IF. 4802 * 4803 ADD CX9-B TO CX9-A END-ADD. 4804 MOVE CX9-A TO CX9-RES. 4805 IF CX9-RES NOT = 11 4806 DISPLAY 'ERROR COMP-X + COMP-X' 4807 END-DISPLAY 4808 END-IF. 4809 MOVE 1 TO CX9-A. 4810 ADD 10 TO CX9-A END-ADD. 4811 MOVE CX9-A TO CX9-RES. 4812 IF CX9-RES NOT = 11 4813 DISPLAY 'ERROR COMP-X + NUM' 4814 END-DISPLAY 4815 END-IF. 4816 MOVE 11 TO CX9-A. 4817 SUBTRACT CX9-B FROM CX9-A END-SUBTRACT. 4818 MOVE CX9-A TO CX9-RES. 4819 IF CX9-RES NOT = 1 4820 DISPLAY 'ERROR COMP-X - COMP-X' 4821 END-DISPLAY 4822 END-IF. 4823 MOVE 11 TO CX9-A. 4824 SUBTRACT 10 FROM CX9-A END-SUBTRACT. 4825 MOVE CX9-A TO CX9-RES. 4826 IF CX9-RES NOT = 1 4827 DISPLAY 'ERROR COMP-X - NUM' 4828 END-DISPLAY 4829 END-IF. 4830 * 4831 ADD CXX-B TO CXX-A END-ADD. 4832 MOVE CXX-A TO CXX-RES. 4833 IF CXX-RES NOT = 11 4834 DISPLAY 'ERROR COMP-X + COMP-X' 4835 END-DISPLAY 4836 END-IF. 4837 MOVE 1 TO CXX-A. 4838 ADD 10 TO CXX-A END-ADD. 4839 MOVE CXX-A TO CXX-RES. 4840 IF CXX-RES NOT = 11 4841 DISPLAY 'ERROR COMP-X + NUM' 4842 END-DISPLAY 4843 END-IF. 4844 MOVE 11 TO CXX-A. 4845 SUBTRACT CXX-B FROM CXX-A END-SUBTRACT. 4846 MOVE CXX-A TO CXX-RES. 4847 IF CXX-RES NOT = 1 4848 DISPLAY 'ERROR COMP-X - COMP-X' 4849 END-DISPLAY 4850 END-IF. 4851 MOVE 11 TO CXX-A. 4852 SUBTRACT 10 FROM CXX-A END-SUBTRACT. 4853 MOVE CXX-A TO CXX-RES. 4854 IF CXX-RES NOT = 1 4855 DISPLAY 'ERROR COMP-X - NUM' 4856 END-DISPLAY 4857 END-IF. 4858 * 4859 ADD D-B TO D-A END-ADD. 4860 MOVE D-A TO D-RES. 4861 IF D-RES NOT = 11 4862 DISPLAY 'ERROR DISPLAY + DISPLAY' 4863 END-DISPLAY 4864 END-IF. 4865 MOVE 1 TO D-A. 4866 ADD 10 TO D-A END-ADD. 4867 MOVE D-A TO D-RES. 4868 IF D-RES NOT = 11 4869 DISPLAY 'ERROR DISPLAY + NUM' 4870 END-DISPLAY 4871 END-IF. 4872 MOVE 11 TO D-A. 4873 SUBTRACT D-B FROM D-A END-SUBTRACT. 4874 MOVE D-A TO D-RES. 4875 IF D-RES NOT = 1 4876 DISPLAY 'ERROR DISPLAY - DISPLAY' 4877 END-DISPLAY 4878 END-IF. 4879 MOVE 11 TO D-A. 4880 SUBTRACT 10 FROM D-A END-SUBTRACT. 4881 MOVE D-A TO D-RES. 4882 IF D-RES NOT = 1 4883 DISPLAY 'ERROR DISPLAY - NUM' 4884 END-DISPLAY 4885 END-IF. 4886 * 4887 ADD FD16-B TO FD16-A END-ADD. 4888 MOVE FD16-A TO FD16-RES. 4889 IF FD16-RES NOT = 11 4890 DISPLAY 'ERROR FLOAT-DECIMAL-16 + FLOAT-DECIMAL-16' 4891 END-DISPLAY 4892 END-IF. 4893 MOVE 1 TO FD16-A. 4894 ADD 10 TO FD16-A END-ADD. 4895 MOVE FD16-A TO FD16-RES. 4896 IF FD16-RES NOT = 11 4897 DISPLAY 'ERROR FLOAT-DECIMAL-16 + NUM' 4898 END-DISPLAY 4899 END-IF. 4900 MOVE 11 TO FD16-A. 4901 SUBTRACT FD16-B FROM FD16-A END-SUBTRACT. 4902 MOVE FD16-A TO FD16-RES. 4903 IF FD16-RES NOT = 1 4904 DISPLAY 'ERROR FLOAT-DECIMAL-16 - FLOAT-DECIMAL-16' 4905 END-DISPLAY 4906 END-IF. 4907 MOVE 11 TO FD16-A. 4908 SUBTRACT 10 FROM FD16-A END-SUBTRACT. 4909 MOVE FD16-A TO FD16-RES. 4910 IF FD16-RES NOT = 1 4911 DISPLAY 'ERROR FLOAT-DECIMAL-16 - NUM' 4912 END-DISPLAY 4913 END-IF. 4914 * 4915 ADD FD34-B TO FD34-A END-ADD. 4916 MOVE FD34-A TO FD34-RES. 4917 IF FD34-RES NOT = 11 4918 DISPLAY 'ERROR FLOAT-DECIMAL-34 + FLOAT-DECIMAL-34' 4919 END-DISPLAY 4920 END-IF. 4921 MOVE 1 TO FD34-A. 4922 ADD 10 TO FD34-A END-ADD. 4923 MOVE FD34-A TO FD34-RES. 4924 IF FD34-RES NOT = 11 4925 DISPLAY 'ERROR FLOAT-DECIMAL-34 + NUM' 4926 END-DISPLAY 4927 END-IF. 4928 MOVE 11 TO FD34-A. 4929 SUBTRACT FD34-B FROM FD34-A END-SUBTRACT. 4930 MOVE FD34-A TO FD34-RES. 4931 IF FD34-RES NOT = 1 4932 DISPLAY 'ERROR FLOAT-DECIMAL-34 - FLOAT-DECIMAL-34' 4933 END-DISPLAY 4934 END-IF. 4935 MOVE 11 TO FD34-A. 4936 SUBTRACT 10 FROM FD34-A END-SUBTRACT. 4937 MOVE FD34-A TO FD34-RES. 4938 IF FD34-RES NOT = 1 4939 DISPLAY 'ERROR FLOAT-DECIMAL-34 - NUM' 4940 END-DISPLAY 4941 END-IF. 4942 * 4943 ADD FL-B TO FL-A END-ADD. 4944 MOVE FL-A TO FL-RES. 4945 IF FL-RES NOT = 11 4946 DISPLAY 'ERROR FLOAT-LONG + FLOAT-LONG' 4947 END-DISPLAY 4948 END-IF. 4949 MOVE 1 TO FL-A. 4950 ADD 10 TO FL-A END-ADD. 4951 MOVE FL-A TO FL-RES. 4952 IF FL-RES NOT = 11 4953 DISPLAY 'ERROR FLOAT-LONG + NUM' 4954 END-DISPLAY 4955 END-IF. 4956 MOVE 11 TO FL-A. 4957 SUBTRACT FL-B FROM FL-A END-SUBTRACT. 4958 MOVE FL-A TO FL-RES. 4959 IF FL-RES NOT = 1 4960 DISPLAY 'ERROR FLOAT-LONG - FLOAT-LONG' 4961 END-DISPLAY 4962 END-IF. 4963 MOVE 11 TO FL-A. 4964 SUBTRACT 10 FROM FL-A END-SUBTRACT. 4965 MOVE FL-A TO FL-RES. 4966 IF FL-RES NOT = 1 4967 DISPLAY 'ERROR FLOAT-LONG - NUM' 4968 END-DISPLAY 4969 END-IF. 4970 * 4971 ADD FS-B TO FS-A END-ADD. 4972 MOVE FS-A TO FS-RES. 4973 IF FS-RES NOT = 11 4974 DISPLAY 'ERROR FLOAT-SHORT + FLOAT-SHORT' 4975 END-DISPLAY 4976 END-IF. 4977 MOVE 1 TO FS-A. 4978 ADD 10 TO FS-A END-ADD. 4979 MOVE FS-A TO FS-RES. 4980 IF FS-RES NOT = 11 4981 DISPLAY 'ERROR FLOAT-SHORT + NUM' 4982 END-DISPLAY 4983 END-IF. 4984 MOVE 11 TO FS-A. 4985 SUBTRACT FS-B FROM FS-A END-SUBTRACT. 4986 MOVE FS-A TO FS-RES. 4987 IF FS-RES NOT = 1 4988 DISPLAY 'ERROR FLOAT-SHORT - FLOAT-SHORT' 4989 END-DISPLAY 4990 END-IF. 4991 MOVE 11 TO FS-A. 4992 SUBTRACT 10 FROM FS-A END-SUBTRACT. 4993 MOVE FS-A TO FS-RES. 4994 IF FS-RES NOT = 1 4995 DISPLAY 'ERROR FLOAT-SHORT - NUM' 4996 END-DISPLAY 4997 END-IF. 4998 * 4999 STOP RUN. 5000]) 5001 5002AT_CHECK([$COMPILE prog.cob], [0], [], []) 5003AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 5004 5005AT_CHECK([$COMPILE -fnotrunc prog.cob], [0], [], []) 5006AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 5007 5008AT_CLEANUP 5009 5010 5011AT_SETUP([Computing of different USAGEs w/- decimal point]) 5012AT_KEYWORDS([runmisc 5013BINARY-C-LONG BINARY-CHAR BINARY-DOUBLE BINARY-LONG 5014COMP COMP-1 COMP-2 COMP-3 COMP-5 COMP-6 COMP-N COMP-X 5015FLOAT-DECIMAL-16 FLOAT-DECIMAL-34 FLOAT-LONG FLOAT-SHORT]) 5016 5017AT_DATA([prog.cob], [ 5018 IDENTIFICATION DIVISION. 5019 PROGRAM-ID. 'prog'. 5020 ENVIRONMENT DIVISION. 5021 DATA DIVISION. 5022 WORKING-STORAGE SECTION. 5023 * 5024 77 BCL-A BINARY-C-LONG VALUE 1.0. 5025 77 BCL-B BINARY-C-LONG VALUE 10.0. 5026 77 BCL-RES BINARY-C-LONG. 5027 * 5028 77 BC-A BINARY-CHAR VALUE 1.0. 5029 77 BC-B BINARY-CHAR VALUE 10.0. 5030 77 BC-RES BINARY-CHAR. 5031 * 5032 77 BD-A BINARY-DOUBLE VALUE 1.0. 5033 77 BD-B BINARY-DOUBLE VALUE 10.0. 5034 77 BD-RES BINARY-DOUBLE. 5035 * 5036 77 BL-A BINARY-LONG VALUE 1.0. 5037 77 BL-B BINARY-LONG VALUE 10.0. 5038 77 BL-RES BINARY-LONG. 5039 * 5040 77 C-A PIC S99 COMP VALUE 1.0. 5041 77 C-B PIC S99 COMP VALUE 10.0. 5042 77 C-RES PIC S99 COMP. 5043 * 5044 77 C1-A COMP-1 VALUE 1.0. 5045 77 C1-B COMP-1 VALUE 10.0. 5046 77 C1-RES COMP-1. 5047 * 5048 77 C2-A COMP-2 VALUE 1.0. 5049 77 C2-B COMP-2 VALUE 10.0. 5050 77 C2-RES COMP-2. 5051 * 5052 77 C3-A PIC S99 COMP-3 VALUE 1.0. 5053 77 C3-B PIC S99 COMP-3 VALUE 10.0. 5054 77 C3-RES PIC S99 COMP-3. 5055 * 5056 77 C5-A PIC S99 COMP-5 VALUE 1.0. 5057 77 C5-B PIC S99 COMP-5 VALUE 10.0. 5058 77 C5-RES PIC S99 COMP-5. 5059 * 5060 77 C6-A PIC 99 COMP-6 VALUE 1.0. 5061 77 C6-B PIC 99 COMP-6 VALUE 10.0. 5062 77 C6-RES PIC 99 COMP-6. 5063 * 5064 77 CN9-A PIC 99 COMP-N VALUE 1. 5065 77 CN9-B PIC 99 COMP-N VALUE 10. 5066 77 CN9-RES PIC 99 COMP-N. 5067 * 5068 77 CNX-A PIC X COMP-N VALUE 1. 5069 77 CNX-B PIC X COMP-N VALUE 10. 5070 77 CNX-RES PIC X COMP-N. 5071 * 5072 77 CX9-A PIC 99 COMP-X VALUE 1. 5073 77 CX9-B PIC 99 COMP-X VALUE 10. 5074 77 CX9-RES PIC 99 COMP-X. 5075 * 5076 77 CXX-A PIC X COMP-X VALUE 1. 5077 77 CXX-B PIC X COMP-X VALUE 10. 5078 77 CXX-RES PIC X COMP-X. 5079 * 5080 77 D-A PIC S99 VALUE 1.0. 5081 77 D-B PIC S99 VALUE 10.0. 5082 77 D-RES PIC S99. 5083 * 5084 77 FD16-A FLOAT-DECIMAL-16 VALUE 1.0. 5085 77 FD16-B FLOAT-DECIMAL-16 VALUE 10.0. 5086 77 FD16-RES FLOAT-DECIMAL-16. 5087 * 5088 77 FD34-A FLOAT-DECIMAL-34 VALUE 1.0. 5089 77 FD34-B FLOAT-DECIMAL-34 VALUE 10.0. 5090 77 FD34-RES FLOAT-DECIMAL-34. 5091 * 5092 77 FL-A FLOAT-LONG VALUE 1.0. 5093 77 FL-B FLOAT-LONG VALUE 10.0. 5094 77 FL-RES FLOAT-LONG. 5095 * 5096 77 FS-A FLOAT-SHORT VALUE 1.0. 5097 77 FS-B FLOAT-SHORT VALUE 10.0. 5098 77 FS-RES FLOAT-SHORT. 5099 * 5100 PROCEDURE DIVISION. 5101 * 5102 ADD BCL-B TO BCL-A END-ADD. 5103 MOVE BCL-A TO BCL-RES. 5104 IF BCL-RES NOT = 11.0 5105 DISPLAY 'ERROR BINARY-C-LONG + BINARY-C-LONG' 5106 END-DISPLAY 5107 END-IF. 5108 MOVE 1.0 TO BCL-A. 5109 ADD 10.0 TO BCL-A END-ADD. 5110 MOVE BCL-A TO BCL-RES. 5111 IF BCL-RES NOT = 11.0 5112 DISPLAY 'ERROR BINARY-C-LONG + NUM' 5113 END-DISPLAY 5114 END-IF. 5115 MOVE 11.0 TO BCL-A. 5116 SUBTRACT BCL-B FROM BCL-A END-SUBTRACT. 5117 MOVE BCL-A TO BCL-RES. 5118 IF BCL-RES NOT = 1.0 5119 DISPLAY 'ERROR BINARY-C-LONG - BINARY-C-LONG' 5120 END-DISPLAY 5121 END-IF. 5122 MOVE 11.0 TO BCL-A. 5123 SUBTRACT 10.0 FROM BCL-A END-SUBTRACT. 5124 MOVE BCL-A TO BCL-RES. 5125 IF BCL-RES NOT = 1.0 5126 DISPLAY 'ERROR BINARY-C-LONG - NUM' 5127 END-DISPLAY 5128 END-IF. 5129 * 5130 ADD BC-B TO BC-A END-ADD. 5131 MOVE BC-A TO BC-RES. 5132 IF BC-RES NOT = 11.0 5133 DISPLAY 'ERROR BINARY-CHAR + BINARY-CHAR' 5134 END-DISPLAY 5135 END-IF. 5136 MOVE 1.0 TO BC-A. 5137 ADD 10.0 TO BC-A END-ADD. 5138 MOVE BC-A TO BC-RES. 5139 IF BC-RES NOT = 11.0 5140 DISPLAY 'ERROR BINARY-CHAR + NUM' 5141 END-DISPLAY 5142 END-IF. 5143 MOVE 11.0 TO BC-A. 5144 SUBTRACT BC-B FROM BC-A END-SUBTRACT. 5145 MOVE BC-A TO BC-RES. 5146 IF BC-RES NOT = 1.0 5147 DISPLAY 'ERROR BINARY-CHAR - BINARY-CHAR' 5148 END-DISPLAY 5149 END-IF. 5150 MOVE 11.0 TO BC-A. 5151 SUBTRACT 10.0 FROM BC-A END-SUBTRACT. 5152 MOVE BC-A TO BC-RES. 5153 IF BC-RES NOT = 1.0 5154 DISPLAY 'ERROR BINARY-CHAR - NUM' 5155 END-DISPLAY 5156 END-IF. 5157 * 5158 ADD BD-B TO BD-A END-ADD. 5159 MOVE BD-A TO BD-RES. 5160 IF BD-RES NOT = 11.0 5161 DISPLAY 'ERROR BINARY-DOUBLE + BINARY-DOUBLE' 5162 END-DISPLAY 5163 END-IF. 5164 MOVE 1.0 TO BD-A. 5165 ADD 10.0 TO BD-A END-ADD. 5166 MOVE BD-A TO BD-RES. 5167 IF BD-RES NOT = 11.0 5168 DISPLAY 'ERROR BINARY-DOUBLE + NUM' 5169 END-DISPLAY 5170 END-IF. 5171 MOVE 11.0 TO BD-A. 5172 SUBTRACT BD-B FROM BD-A END-SUBTRACT. 5173 MOVE BD-A TO BD-RES. 5174 IF BD-RES NOT = 1.0 5175 DISPLAY 'ERROR BINARY-DOUBLE - BINARY-DOUBLE' 5176 END-DISPLAY 5177 END-IF. 5178 MOVE 11.0 TO BD-A. 5179 SUBTRACT 10.0 FROM BD-A END-SUBTRACT. 5180 MOVE BD-A TO BD-RES. 5181 IF BD-RES NOT = 1.0 5182 DISPLAY 'ERROR BINARY-DOUBLE - NUM' 5183 END-DISPLAY 5184 END-IF. 5185 * 5186 ADD BL-B TO BL-A END-ADD. 5187 MOVE BL-A TO BL-RES. 5188 IF BL-RES NOT = 11.0 5189 DISPLAY 'ERROR BINARY-LONG + BINARY-LONG' 5190 END-DISPLAY 5191 END-IF. 5192 MOVE 1.0 TO BL-A. 5193 ADD 10.0 TO BL-A END-ADD. 5194 MOVE BL-A TO BL-RES. 5195 IF BL-RES NOT = 11.0 5196 DISPLAY 'ERROR BINARY-LONG + NUM' 5197 END-DISPLAY 5198 END-IF. 5199 MOVE 11.0 TO BL-A. 5200 SUBTRACT BL-B FROM BL-A END-SUBTRACT. 5201 MOVE BL-A TO BL-RES. 5202 IF BL-RES NOT = 1.0 5203 DISPLAY 'ERROR BINARY-LONG - BINARY-LONG' 5204 END-DISPLAY 5205 END-IF. 5206 MOVE 11.0 TO BL-A. 5207 SUBTRACT 10.0 FROM BL-A END-SUBTRACT. 5208 MOVE BL-A TO BL-RES. 5209 IF BL-RES NOT = 1.0 5210 DISPLAY 'ERROR BINARY-LONG - NUM' 5211 END-DISPLAY 5212 END-IF. 5213 * 5214 ADD C-B TO C-A END-ADD. 5215 MOVE C-A TO C-RES. 5216 IF C-RES NOT = 11.0 5217 DISPLAY 'ERROR COMP + COMP' 5218 END-DISPLAY 5219 END-IF. 5220 MOVE 1.0 TO C-A. 5221 ADD 10.0 TO C-A END-ADD. 5222 MOVE C-A TO C-RES. 5223 IF C-RES NOT = 11.0 5224 DISPLAY 'ERROR COMP + NUM' 5225 END-DISPLAY 5226 END-IF. 5227 MOVE 11.0 TO C-A. 5228 SUBTRACT C-B FROM C-A END-SUBTRACT. 5229 MOVE C-A TO C-RES. 5230 IF C-RES NOT = 1.0 5231 DISPLAY 'ERROR COMP - COMP' 5232 END-DISPLAY 5233 END-IF. 5234 MOVE 11.0 TO C-A. 5235 SUBTRACT 10.0 FROM C-A END-SUBTRACT. 5236 MOVE C-A TO C-RES. 5237 IF C-RES NOT = 1.0 5238 DISPLAY 'ERROR COMP - NUM' 5239 END-DISPLAY 5240 END-IF. 5241 * 5242 ADD C1-B TO C1-A END-ADD. 5243 MOVE C1-A TO C1-RES. 5244 IF C1-RES NOT = 11.0 5245 DISPLAY 'ERROR COMP-1 + COMP-1' 5246 END-DISPLAY 5247 END-IF. 5248 MOVE 1.0 TO C1-A. 5249 ADD 10.0 TO C1-A END-ADD. 5250 MOVE C1-A TO C1-RES. 5251 IF C1-RES NOT = 11.0 5252 DISPLAY 'ERROR COMP-1 + NUM' 5253 END-DISPLAY 5254 END-IF. 5255 MOVE 11.0 TO C1-A. 5256 SUBTRACT C1-B FROM C1-A END-SUBTRACT. 5257 MOVE C1-A TO C1-RES. 5258 IF C1-RES NOT = 1.0 5259 DISPLAY 'ERROR COMP-1 - COMP-1' 5260 END-DISPLAY 5261 END-IF. 5262 MOVE 11.0 TO C1-A. 5263 SUBTRACT 10.0 FROM C1-A END-SUBTRACT. 5264 MOVE C1-A TO C1-RES. 5265 IF C1-RES NOT = 1.0 5266 DISPLAY 'ERROR COMP-1 - NUM' 5267 END-DISPLAY 5268 END-IF. 5269 * 5270 ADD C2-B TO C2-A END-ADD. 5271 MOVE C2-A TO C2-RES. 5272 IF C2-RES NOT = 11.0 5273 DISPLAY 'ERROR COMP-2 + COMP-2' 5274 END-DISPLAY 5275 END-IF. 5276 MOVE 1.0 TO C2-A. 5277 ADD 10.0 TO C2-A END-ADD. 5278 MOVE C2-A TO C2-RES. 5279 IF C2-RES NOT = 11.0 5280 DISPLAY 'ERROR COMP-2 + NUM' 5281 END-DISPLAY 5282 END-IF. 5283 MOVE 11.0 TO C2-A. 5284 SUBTRACT C2-B FROM C2-A END-SUBTRACT. 5285 MOVE C2-A TO C2-RES. 5286 IF C2-RES NOT = 1.0 5287 DISPLAY 'ERROR COMP-2 - COMP-2' 5288 END-DISPLAY 5289 END-IF. 5290 MOVE 11.0 TO C2-A. 5291 SUBTRACT 10.0 FROM C2-A END-SUBTRACT. 5292 MOVE C2-A TO C2-RES. 5293 IF C2-RES NOT = 1.0 5294 DISPLAY 'ERROR COMP-2 - NUM' 5295 END-DISPLAY 5296 END-IF. 5297 * 5298 ADD C3-B TO C3-A END-ADD. 5299 MOVE C3-A TO C3-RES. 5300 IF C3-RES NOT = 11.0 5301 DISPLAY 'ERROR COMP-3 + COMP-3' 5302 END-DISPLAY 5303 END-IF. 5304 MOVE 1.0 TO C3-A. 5305 ADD 10.0 TO C3-A END-ADD. 5306 MOVE C3-A TO C3-RES. 5307 IF C3-RES NOT = 11.0 5308 DISPLAY 'ERROR COMP-3 + NUM' 5309 END-DISPLAY 5310 END-IF. 5311 MOVE 11.0 TO C3-A. 5312 SUBTRACT C3-B FROM C3-A END-SUBTRACT. 5313 MOVE C3-A TO C3-RES. 5314 IF C3-RES NOT = 1.0 5315 DISPLAY 'ERROR COMP-3 - COMP-3' 5316 END-DISPLAY 5317 END-IF. 5318 MOVE 11.0 TO C3-A. 5319 SUBTRACT 10.0 FROM C3-A END-SUBTRACT. 5320 MOVE C3-A TO C3-RES. 5321 IF C3-RES NOT = 1.0 5322 DISPLAY 'ERROR COMP-3 - NUM' 5323 END-DISPLAY 5324 END-IF. 5325 * 5326 ADD C5-B TO C5-A END-ADD. 5327 MOVE C5-A TO C5-RES. 5328 IF C5-RES NOT = 11.0 5329 DISPLAY 'ERROR COMP-5 + COMP-5' 5330 END-DISPLAY 5331 END-IF. 5332 MOVE 1.0 TO C5-A. 5333 ADD 10.0 TO C5-A END-ADD. 5334 MOVE C5-A TO C5-RES. 5335 IF C5-RES NOT = 11.0 5336 DISPLAY 'ERROR COMP-5 + NUM' 5337 END-DISPLAY 5338 END-IF. 5339 MOVE 11.0 TO C5-A. 5340 SUBTRACT C5-B FROM C5-A END-SUBTRACT. 5341 MOVE C5-A TO C5-RES. 5342 IF C5-RES NOT = 1.0 5343 DISPLAY 'ERROR COMP-5 - COMP-5' 5344 END-DISPLAY 5345 END-IF. 5346 MOVE 11.0 TO C5-A. 5347 SUBTRACT 10.0 FROM C5-A END-SUBTRACT. 5348 MOVE C5-A TO C5-RES. 5349 IF C5-RES NOT = 1.0 5350 DISPLAY 'ERROR COMP-5 - NUM' 5351 END-DISPLAY 5352 END-IF. 5353 * 5354 ADD C6-B TO C6-A END-ADD. 5355 MOVE C6-A TO C6-RES. 5356 IF C6-RES NOT = 11.0 5357 DISPLAY 'ERROR COMP-6 + COMP-6' 5358 END-DISPLAY 5359 END-IF. 5360 MOVE 1.0 TO C6-A. 5361 ADD 10.0 TO C6-A END-ADD. 5362 MOVE C6-A TO C6-RES. 5363 IF C6-RES NOT = 11.0 5364 DISPLAY 'ERROR COMP-6 + NUM' 5365 END-DISPLAY 5366 END-IF. 5367 MOVE 11.0 TO C6-A. 5368 SUBTRACT C6-B FROM C6-A END-SUBTRACT. 5369 MOVE C6-A TO C6-RES. 5370 IF C6-RES NOT = 1.0 5371 DISPLAY 'ERROR COMP-6 - COMP-6' 5372 END-DISPLAY 5373 END-IF. 5374 MOVE 11.0 TO C6-A. 5375 SUBTRACT 10.0 FROM C6-A END-SUBTRACT. 5376 MOVE C6-A TO C6-RES. 5377 IF C6-RES NOT = 1.0 5378 DISPLAY 'ERROR COMP-6 - NUM' 5379 END-DISPLAY 5380 END-IF. 5381 * 5382 ADD CN9-B TO CN9-A END-ADD. 5383 MOVE CN9-A TO CN9-RES. 5384 IF CN9-RES NOT = 11.0 5385 DISPLAY 'ERROR COMP-N + COMP-N' 5386 END-DISPLAY 5387 END-IF. 5388 MOVE 1.0 TO CN9-A. 5389 ADD 10.0 TO CN9-A END-ADD. 5390 MOVE CN9-A TO CN9-RES. 5391 IF CN9-RES NOT = 11.0 5392 DISPLAY 'ERROR COMP-N + NUM' 5393 END-DISPLAY 5394 END-IF. 5395 MOVE 11.0 TO CN9-A. 5396 SUBTRACT CN9-B FROM CN9-A END-SUBTRACT. 5397 MOVE CN9-A TO CN9-RES. 5398 IF CN9-RES NOT = 1.0 5399 DISPLAY 'ERROR COMP-N - COMP-N' 5400 END-DISPLAY 5401 END-IF. 5402 MOVE 11.0 TO CN9-A. 5403 SUBTRACT 10.0 FROM CN9-A END-SUBTRACT. 5404 MOVE CN9-A TO CN9-RES. 5405 IF CN9-RES NOT = 1.0 5406 DISPLAY 'ERROR COMP-N - NUM' 5407 END-DISPLAY 5408 END-IF. 5409 * 5410 ADD CNX-B TO CNX-A END-ADD. 5411 MOVE CNX-A TO CNX-RES. 5412 IF CNX-RES NOT = 11.0 5413 DISPLAY 'ERROR COMP-N + COMP-N' 5414 END-DISPLAY 5415 END-IF. 5416 MOVE 1.0 TO CNX-A. 5417 ADD 10.0 TO CNX-A END-ADD. 5418 MOVE CNX-A TO CNX-RES. 5419 IF CNX-RES NOT = 11.0 5420 DISPLAY 'ERROR COMP-N + NUM' 5421 END-DISPLAY 5422 END-IF. 5423 MOVE 11.0 TO CNX-A. 5424 SUBTRACT CNX-B FROM CNX-A END-SUBTRACT. 5425 MOVE CNX-A TO CNX-RES. 5426 IF CNX-RES NOT = 1.0 5427 DISPLAY 'ERROR COMP-N - COMP-N' 5428 END-DISPLAY 5429 END-IF. 5430 MOVE 11.0 TO CNX-A. 5431 SUBTRACT 10.0 FROM CNX-A END-SUBTRACT. 5432 MOVE CNX-A TO CNX-RES. 5433 IF CNX-RES NOT = 1.0 5434 DISPLAY 'ERROR COMP-N - NUM' 5435 END-DISPLAY 5436 END-IF. 5437 * 5438 ADD CX9-B TO CX9-A END-ADD. 5439 MOVE CX9-A TO CX9-RES. 5440 IF CX9-RES NOT = 11.0 5441 DISPLAY 'ERROR COMP-X + COMP-X' 5442 END-DISPLAY 5443 END-IF. 5444 MOVE 1.0 TO CX9-A. 5445 ADD 10.0 TO CX9-A END-ADD. 5446 MOVE CX9-A TO CX9-RES. 5447 IF CX9-RES NOT = 11.0 5448 DISPLAY 'ERROR COMP-X + NUM' 5449 END-DISPLAY 5450 END-IF. 5451 MOVE 11.0 TO CX9-A. 5452 SUBTRACT CX9-B FROM CX9-A END-SUBTRACT. 5453 MOVE CX9-A TO CX9-RES. 5454 IF CX9-RES NOT = 1.0 5455 DISPLAY 'ERROR COMP-X - COMP-X' 5456 END-DISPLAY 5457 END-IF. 5458 MOVE 11.0 TO CX9-A. 5459 SUBTRACT 10.0 FROM CX9-A END-SUBTRACT. 5460 MOVE CX9-A TO CX9-RES. 5461 IF CX9-RES NOT = 1.0 5462 DISPLAY 'ERROR COMP-X - NUM' 5463 END-DISPLAY 5464 END-IF. 5465 * 5466 ADD CXX-B TO CXX-A END-ADD. 5467 MOVE CXX-A TO CXX-RES. 5468 IF CXX-RES NOT = 11.0 5469 DISPLAY 'ERROR COMP-X + COMP-X' 5470 END-DISPLAY 5471 END-IF. 5472 MOVE 1.0 TO CXX-A. 5473 ADD 10.0 TO CXX-A END-ADD. 5474 MOVE CXX-A TO CXX-RES. 5475 IF CXX-RES NOT = 11.0 5476 DISPLAY 'ERROR COMP-X + NUM' 5477 END-DISPLAY 5478 END-IF. 5479 MOVE 11.0 TO CXX-A. 5480 SUBTRACT CXX-B FROM CXX-A END-SUBTRACT. 5481 MOVE CXX-A TO CXX-RES. 5482 IF CXX-RES NOT = 1.0 5483 DISPLAY 'ERROR COMP-X - COMP-X' 5484 END-DISPLAY 5485 END-IF. 5486 MOVE 11.0 TO CXX-A. 5487 SUBTRACT 10.0 FROM CXX-A END-SUBTRACT. 5488 MOVE CXX-A TO CXX-RES. 5489 IF CXX-RES NOT = 1.0 5490 DISPLAY 'ERROR COMP-X - NUM' 5491 END-DISPLAY 5492 END-IF. 5493 * 5494 ADD D-B TO D-A END-ADD. 5495 MOVE D-A TO D-RES. 5496 IF D-RES NOT = 11.0 5497 DISPLAY 'ERROR DISPLAY + DISPLAY' 5498 END-DISPLAY 5499 END-IF. 5500 MOVE 1.0 TO D-A. 5501 ADD 10.0 TO D-A END-ADD. 5502 MOVE D-A TO D-RES. 5503 IF D-RES NOT = 11.0 5504 DISPLAY 'ERROR DISPLAY + NUM' 5505 END-DISPLAY 5506 END-IF. 5507 MOVE 11.0 TO D-A. 5508 SUBTRACT D-B FROM D-A END-SUBTRACT. 5509 MOVE D-A TO D-RES. 5510 IF D-RES NOT = 1.0 5511 DISPLAY 'ERROR DISPLAY - DISPLAY' 5512 END-DISPLAY 5513 END-IF. 5514 MOVE 11.0 TO D-A. 5515 SUBTRACT 10.0 FROM D-A END-SUBTRACT. 5516 MOVE D-A TO D-RES. 5517 IF D-RES NOT = 1.0 5518 DISPLAY 'ERROR DISPLAY - NUM' 5519 END-DISPLAY 5520 END-IF. 5521 * 5522 ADD FD16-B TO FD16-A END-ADD. 5523 MOVE FD16-A TO FD16-RES. 5524 IF FD16-RES NOT = 11.0 5525 DISPLAY 'ERROR FLOAT-DECIMAL-16 + FLOAT-DECIMAL-16' 5526 END-DISPLAY 5527 END-IF. 5528 MOVE 1.0 TO FD16-A. 5529 ADD 10.0 TO FD16-A END-ADD. 5530 MOVE FD16-A TO FD16-RES. 5531 IF FD16-RES NOT = 11.0 5532 DISPLAY 'ERROR FLOAT-DECIMAL-16 + NUM' 5533 END-DISPLAY 5534 END-IF. 5535 MOVE 11.0 TO FD16-A. 5536 SUBTRACT FD16-B FROM FD16-A END-SUBTRACT. 5537 MOVE FD16-A TO FD16-RES. 5538 IF FD16-RES NOT = 1.0 5539 DISPLAY 'ERROR FLOAT-DECIMAL-16 - FLOAT-DECIMAL-16' 5540 END-DISPLAY 5541 END-IF. 5542 MOVE 11.0 TO FD16-A. 5543 SUBTRACT 10.0 FROM FD16-A END-SUBTRACT. 5544 MOVE FD16-A TO FD16-RES. 5545 IF FD16-RES NOT = 1.0 5546 DISPLAY 'ERROR FLOAT-DECIMAL-16 - NUM' 5547 END-DISPLAY 5548 END-IF. 5549 * 5550 ADD FD34-B TO FD34-A END-ADD. 5551 MOVE FD34-A TO FD34-RES. 5552 IF FD34-RES NOT = 11.0 5553 DISPLAY 'ERROR FLOAT-DECIMAL-34 + FLOAT-DECIMAL-34' 5554 END-DISPLAY 5555 END-IF. 5556 MOVE 1.0 TO FD34-A. 5557 ADD 10.0 TO FD34-A END-ADD. 5558 MOVE FD34-A TO FD34-RES. 5559 IF FD34-RES NOT = 11.0 5560 DISPLAY 'ERROR FLOAT-DECIMAL-34 + NUM' 5561 END-DISPLAY 5562 END-IF. 5563 MOVE 11.0 TO FD34-A. 5564 SUBTRACT FD34-B FROM FD34-A END-SUBTRACT. 5565 MOVE FD34-A TO FD34-RES. 5566 IF FD34-RES NOT = 1.0 5567 DISPLAY 'ERROR FLOAT-DECIMAL-34 - FLOAT-DECIMAL-34' 5568 END-DISPLAY 5569 END-IF. 5570 MOVE 11.0 TO FD34-A. 5571 SUBTRACT 10.0 FROM FD34-A END-SUBTRACT. 5572 MOVE FD34-A TO FD34-RES. 5573 IF FD34-RES NOT = 1.0 5574 DISPLAY 'ERROR FLOAT-DECIMAL-34 - NUM' 5575 END-DISPLAY 5576 END-IF. 5577 * 5578 ADD FL-B TO FL-A END-ADD. 5579 MOVE FL-A TO FL-RES. 5580 IF FL-RES NOT = 11.0 5581 DISPLAY 'ERROR FLOAT-LONG + FLOAT-LONG' 5582 END-DISPLAY 5583 END-IF. 5584 MOVE 1.0 TO FL-A. 5585 ADD 10.0 TO FL-A END-ADD. 5586 MOVE FL-A TO FL-RES. 5587 IF FL-RES NOT = 11.0 5588 DISPLAY 'ERROR FLOAT-LONG + NUM' 5589 END-DISPLAY 5590 END-IF. 5591 MOVE 11.0 TO FL-A. 5592 SUBTRACT FL-B FROM FL-A END-SUBTRACT. 5593 MOVE FL-A TO FL-RES. 5594 IF FL-RES NOT = 1.0 5595 DISPLAY 'ERROR FLOAT-LONG - FLOAT-LONG' 5596 END-DISPLAY 5597 END-IF. 5598 MOVE 11.0 TO FL-A. 5599 SUBTRACT 10.0 FROM FL-A END-SUBTRACT. 5600 MOVE FL-A TO FL-RES. 5601 IF FL-RES NOT = 1.0 5602 DISPLAY 'ERROR FLOAT-LONG - NUM' 5603 END-DISPLAY 5604 END-IF. 5605 * 5606 ADD FS-B TO FS-A END-ADD. 5607 MOVE FS-A TO FS-RES. 5608 IF FS-RES NOT = 11.0 5609 DISPLAY 'ERROR FLOAT-SHORT + FLOAT-SHORT' 5610 END-DISPLAY 5611 END-IF. 5612 MOVE 1.0 TO FS-A. 5613 ADD 10.0 TO FS-A END-ADD. 5614 MOVE FS-A TO FS-RES. 5615 IF FS-RES NOT = 11.0 5616 DISPLAY 'ERROR FLOAT-SHORT + NUM' 5617 END-DISPLAY 5618 END-IF. 5619 MOVE 11.0 TO FS-A. 5620 SUBTRACT FS-B FROM FS-A END-SUBTRACT. 5621 MOVE FS-A TO FS-RES. 5622 IF FS-RES NOT = 1.0 5623 DISPLAY 'ERROR FLOAT-SHORT - FLOAT-SHORT' 5624 END-DISPLAY 5625 END-IF. 5626 MOVE 11.0 TO FS-A. 5627 SUBTRACT 10.0 FROM FS-A END-SUBTRACT. 5628 MOVE FS-A TO FS-RES. 5629 IF FS-RES NOT = 1.0 5630 DISPLAY 'ERROR FLOAT-SHORT - NUM' 5631 END-DISPLAY 5632 END-IF. 5633 * 5634 STOP RUN. 5635]) 5636 5637AT_CHECK([$COMPILE prog.cob], [0], [], []) 5638AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 5639 5640AT_CHECK([$COMPILE -fnotrunc prog.cob], [0], [], []) 5641AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 5642 5643AT_CLEANUP 5644 5645 5646AT_SETUP([C/C++ reserved words/predefined identifiers]) 5647AT_KEYWORDS([runmisc]) 5648 5649AT_DATA([caller.cob], [ 5650 IDENTIFICATION DIVISION. 5651 PROGRAM-ID. caller. 5652 DATA DIVISION. 5653 WORKING-STORAGE SECTION. 5654 * 5655 * Reserved Words in C (that aren't reserved in COBOL) 5656 * var names MUST BE IN LOWER CASE (!) 5657 * 5658 77 const PIC X VALUE "A". 5659 77 double PIC X VALUE "B". 5660 77 float PIC X VALUE "C". 5661 77 int PIC X VALUE "D". 5662 77 short PIC X VALUE "E". 5663 77 struct PIC X VALUE "F". 5664 77 break PIC X VALUE "G". 5665 77 long PIC X VALUE "H". 5666 77 switch PIC X VALUE "I". 5667 77 void PIC X VALUE "J". 5668 77 case PIC X VALUE "K". 5669 77 enum PIC X VALUE "L". 5670 77 goto PIC X VALUE "M". 5671 77 register PIC X VALUE "N". 5672 77 sizeof PIC X VALUE "O". 5673 77 volatile PIC X VALUE "P". 5674 77 char PIC X VALUE "Q". 5675 77 do PIC X VALUE "R". 5676 77 extern PIC X VALUE "S". 5677 77 static PIC X VALUE "T". 5678 77 union PIC X VALUE "U". 5679 77 while PIC X VALUE "V". 5680 * 5681 * More Reserved Words in C++ 5682 * var names MUST BE IN LOWER CASE (!) 5683 * 5684 77 asm PIC X VALUE "W". 5685 77 dynamic_cast PIC X VALUE "X". 5686 77 namespace PIC X VALUE "Y". 5687 77 reinterpret_cast PIC X VALUE "Z". 5688 77 try PIC X VALUE "a". 5689 77 bool PIC X VALUE "b". 5690 77 explicit PIC X VALUE "c". 5691 77 new PIC X VALUE "d". 5692 77 static_cast PIC X VALUE "e". 5693 77 typeid PIC X VALUE "f". 5694 77 catch PIC X VALUE "g". 5695 77 operator PIC X VALUE "h". 5696 77 template PIC X VALUE "i". 5697 77 typename PIC X VALUE "j". 5698 77 friend PIC X VALUE "k". 5699 77 private PIC X VALUE "l". 5700 77 this PIC X VALUE "m". 5701 77 const_cast PIC X VALUE "n". 5702 77 inline PIC X VALUE "o". 5703 77 public PIC X VALUE "p". 5704 77 throw PIC X VALUE "q". 5705 77 virtual PIC X VALUE "r". 5706 77 mutable PIC X VALUE "s". 5707 77 protected PIC X VALUE "t". 5708 77 wchar_t PIC X VALUE "u". 5709 * 5710 * More Reserved Words in C++ (not essential) 5711 * var names MUST BE IN LOWER CASE (!) 5712 * 5713 77 bitand PIC X VALUE "v". 5714 77 compl PIC X VALUE "w". 5715 77 not_eq PIC X VALUE "x". 5716 77 or_eq PIC X VALUE "y". 5717 77 xor_eq PIC X VALUE "z". 5718 77 and_eq PIC X VALUE "0". 5719 77 bitor PIC X VALUE "1". 5720 77 xor PIC X VALUE "2". 5721 * 5722 PROCEDURE DIVISION. 5723 CALL "callee" USING const 5724 double 5725 float 5726 int 5727 short 5728 struct 5729 break 5730 long 5731 switch 5732 void 5733 case 5734 enum 5735 goto 5736 register 5737 sizeof 5738 volatile 5739 char 5740 do 5741 *>extern 5742 *>static 5743 union 5744 while 5745 END-CALL. 5746 CALL "callee2" USING asm 5747 dynamic_cast 5748 namespace 5749 reinterpret_cast 5750 try 5751 bool 5752 explicit 5753 new 5754 static_cast 5755 typeid 5756 catch 5757 operator 5758 template 5759 typename 5760 friend 5761 private 5762 this 5763 const_cast 5764 inline 5765 public 5766 throw 5767 virtual 5768 mutable 5769 protected 5770 wchar_t 5771 bitand 5772 compl 5773 not_eq 5774 or_eq 5775 xor_eq 5776 and_eq 5777 bitor 5778 xor 5779 END-CALL. 5780 MOVE x'00' TO const 5781 double 5782 float 5783 int 5784 short 5785 struct 5786 break 5787 long 5788 switch 5789 void 5790 case 5791 enum 5792 goto 5793 register 5794 sizeof 5795 volatile 5796 char 5797 do 5798 extern 5799 static 5800 union 5801 while 5802 asm 5803 dynamic_cast 5804 namespace 5805 reinterpret_cast 5806 try 5807 bool 5808 explicit 5809 new 5810 static_cast 5811 typeid 5812 catch 5813 operator 5814 template 5815 typename 5816 friend 5817 private 5818 this 5819 const_cast 5820 inline 5821 public 5822 throw 5823 virtual 5824 mutable 5825 protected 5826 wchar_t 5827 bitand 5828 compl 5829 not_eq 5830 or_eq 5831 xor_eq 5832 and_eq 5833 bitor 5834 xor 5835 . 5836 STOP RUN. 5837]) 5838 5839AT_DATA([callee.cob], [ 5840 IDENTIFICATION DIVISION. 5841 PROGRAM-ID. callee. 5842 DATA DIVISION. 5843 LINKAGE SECTION. 5844 * 5845 * Reserved Words in C (that aren't reserved in COBOL) 5846 * var names MUST BE IN LOWER CASE (!) 5847 * 5848 77 const PIC X. 5849 77 double PIC X. 5850 77 float PIC X. 5851 77 int PIC X. 5852 77 short PIC X. 5853 77 struct PIC X. 5854 77 break PIC X. 5855 77 long PIC X. 5856 77 switch PIC X. 5857 77 void PIC X. 5858 77 case PIC X. 5859 77 enum PIC X. 5860 77 goto PIC X. 5861 77 register PIC X. 5862 77 sizeof PIC X. 5863 77 volatile PIC X. 5864 77 char PIC X. 5865 77 do PIC X. 5866 *77 extern PIC X. 5867 *77 static PIC X. 5868 77 union PIC X. 5869 77 while PIC X. 5870 PROCEDURE DIVISION USING 5871 const 5872 double 5873 float 5874 int 5875 short 5876 struct 5877 break 5878 long 5879 switch 5880 void 5881 case 5882 enum 5883 goto 5884 register 5885 sizeof 5886 volatile 5887 char 5888 do 5889 *>extern 5890 *>static 5891 union 5892 while 5893 . 5894 IF (const NOT = "A") OR 5895 (double NOT = "B") OR 5896 (float NOT = "C") OR 5897 (int NOT = "D") OR 5898 (short NOT = "E") OR 5899 (struct NOT = "F") OR 5900 (break NOT = "G") OR 5901 (long NOT = "H") OR 5902 (switch NOT = "I") OR 5903 (void NOT = "J") OR 5904 (case NOT = "K") OR 5905 (enum NOT = "L") OR 5906 (goto NOT = "M") OR 5907 (register NOT = "N") OR 5908 (sizeof NOT = "O") OR 5909 (volatile NOT = "P") OR 5910 (char NOT = "Q") OR 5911 (do NOT = "R") OR 5912 *>(extern NOT = "S") OR 5913 *>(static NOT = "T") OR 5914 (union NOT = "U") OR 5915 (while NOT = "V") 5916 DISPLAY "At least one var has wrong content!" 5917 END-DISPLAY 5918 END-IF. 5919 MOVE x'FF' TO const 5920 double 5921 float 5922 int 5923 short 5924 struct 5925 break 5926 long 5927 switch 5928 void 5929 case 5930 enum 5931 goto 5932 register 5933 sizeof 5934 volatile 5935 char 5936 do 5937 *>extern 5938 *>static 5939 union 5940 while 5941 . 5942 EXIT PROGRAM. 5943]) 5944 5945AT_DATA([callee2.cob], [ 5946 IDENTIFICATION DIVISION. 5947 PROGRAM-ID. callee2. 5948 DATA DIVISION. 5949 LINKAGE SECTION. 5950 * 5951 * More Reserved Words in C++ 5952 * var names MUST BE IN LOWER CASE (!) 5953 * 5954 77 asm PIC X. 5955 77 dynamic_cast PIC X. 5956 77 namespace PIC X. 5957 77 reinterpret_cast PIC X. 5958 77 try PIC X. 5959 77 bool PIC X. 5960 77 explicit PIC X. 5961 77 new PIC X. 5962 77 static_cast PIC X. 5963 77 typeid PIC X. 5964 77 catch PIC X. 5965 77 operator PIC X. 5966 77 template PIC X. 5967 77 typename PIC X. 5968 77 friend PIC X. 5969 77 private PIC X. 5970 77 this PIC X. 5971 77 const_cast PIC X. 5972 77 inline PIC X. 5973 77 public PIC X. 5974 77 throw PIC X. 5975 77 virtual PIC X. 5976 77 mutable PIC X. 5977 77 protected PIC X. 5978 77 wchar_t PIC X. 5979 * 5980 * More Reserved Words in C++ (not essential) 5981 * 5982 77 bitand PIC X. 5983 77 compl PIC X. 5984 77 not_eq PIC X. 5985 77 or_eq PIC X. 5986 77 xor_eq PIC X. 5987 77 and_eq PIC X. 5988 77 bitor PIC X. 5989 77 xor PIC X. 5990 PROCEDURE DIVISION USING 5991 asm 5992 dynamic_cast 5993 namespace 5994 reinterpret_cast 5995 try 5996 bool 5997 explicit 5998 new 5999 static_cast 6000 typeid 6001 catch 6002 operator 6003 template 6004 typename 6005 friend 6006 private 6007 this 6008 const_cast 6009 inline 6010 public 6011 throw 6012 virtual 6013 mutable 6014 protected 6015 wchar_t 6016 bitand 6017 compl 6018 not_eq 6019 or_eq 6020 xor_eq 6021 and_eq 6022 bitor 6023 xor 6024 . 6025 IF (asm NOT = "W") OR 6026 (dynamic_cast NOT = "X") OR 6027 (namespace NOT = "Y") OR 6028 (reinterpret_cast NOT = "Z") OR 6029 (try NOT = "a") OR 6030 (bool NOT = "b") OR 6031 (explicit NOT = "c") OR 6032 (new NOT = "d") OR 6033 (static_cast NOT = "e") OR 6034 (typeid NOT = "f") OR 6035 (catch NOT = "g") OR 6036 (operator NOT = "h") OR 6037 (template NOT = "i") OR 6038 (typename NOT = "j") OR 6039 (friend NOT = "k") OR 6040 (private NOT = "l") OR 6041 (this NOT = "m") OR 6042 (const_cast NOT = "n") OR 6043 (inline NOT = "o") OR 6044 (public NOT = "p") OR 6045 (throw NOT = "q") OR 6046 (virtual NOT = "r") OR 6047 (mutable NOT = "s") OR 6048 (protected NOT = "t") OR 6049 (wchar_t NOT = "u") OR 6050 (bitand NOT = "v") OR 6051 (compl NOT = "w") OR 6052 (not_eq NOT = "x") OR 6053 (or_eq NOT = "y") OR 6054 (xor_eq NOT = "z") OR 6055 (and_eq NOT = "0") OR 6056 (bitor NOT = "1") OR 6057 (xor NOT = "2") 6058 DISPLAY "At least one var has wrong content!" 6059 END-DISPLAY 6060 END-IF. 6061 MOVE x'FF' TO asm 6062 dynamic_cast 6063 namespace 6064 reinterpret_cast 6065 try 6066 bool 6067 explicit 6068 new 6069 static_cast 6070 typeid 6071 catch 6072 operator 6073 template 6074 typename 6075 friend 6076 private 6077 this 6078 const_cast 6079 inline 6080 public 6081 throw 6082 virtual 6083 mutable 6084 protected 6085 wchar_t 6086 bitand 6087 compl 6088 not_eq 6089 or_eq 6090 xor_eq 6091 and_eq 6092 bitor 6093 xor 6094 . 6095 EXIT PROGRAM. 6096]) 6097 6098AT_CHECK([$COMPILE_MODULE -fnot-reserved=double,float,new,volatile callee.cob], [0], [], []) 6099AT_CHECK([$COMPILE_MODULE -fnot-reserved=double,float,new,volatile callee2.cob], [0], [], []) 6100AT_CHECK([$COMPILE -fnot-reserved=double,float,new,volatile -o prog caller.cob], [0], [], []) 6101AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 6102 6103AT_CLEANUP 6104 6105 6106AT_SETUP([ON EXCEPTION clause of DISPLAY]) 6107AT_KEYWORDS([runmisc exceptions screen]) 6108 6109AT_CHECK([test "$COB_HAS_CURSES" = "yes" || exit 77]) 6110 6111AT_DATA([prog.cob], [ 6112 IDENTIFICATION DIVISION. 6113 PROGRAM-ID. prog. 6114 6115 PROCEDURE DIVISION. 6116 DISPLAY "hello" AT COLUMN 500 6117 ON EXCEPTION 6118 GOBACK RETURNING 0 6119 NOT ON EXCEPTION 6120 GOBACK RETURNING 1 6121 END-DISPLAY 6122 . 6123]) 6124 6125AT_CHECK([$COMPILE prog.cob], [0], [], []) 6126AT_CHECK([COB_EXIT_WAIT=0 ./prog], [0], ignore, []) 6127 6128AT_CLEANUP 6129 6130 6131AT_SETUP([EC-SCREEN-LINE-NUMBER and -STARTING-COLUMN]) 6132AT_KEYWORDS([runmisc exceptions screen]) 6133 6134AT_CHECK([test "$COB_HAS_CURSES" = "yes" || exit 77]) 6135 6136AT_DATA([prog.cob], [ 6137 IDENTIFICATION DIVISION. 6138 PROGRAM-ID. prog. 6139 6140 DATA DIVISION. 6141 SCREEN SECTION. 6142 01 invalid-line. 6143 03 a VALUE "a" LINE 99999999. 6144 01 invalid-col. 6145 03 c VALUE "c" COLUMN 99999999. 6146 6147 PROCEDURE DIVISION. 6148 DISPLAY invalid-line END-DISPLAY 6149 IF FUNCTION EXCEPTION-STATUS = "EC-SCREEN-LINE-NUMBER" 6150 CONTINUE 6151 ELSE 6152 GOBACK RETURNING 1 6153 END-IF 6154 6155 DISPLAY invalid-col END-DISPLAY 6156 IF FUNCTION EXCEPTION-STATUS = "EC-SCREEN-STARTING-COLUMN" 6157 CONTINUE 6158 ELSE 6159 GOBACK RETURNING 2 6160 END-IF 6161 6162 GOBACK RETURNING 0 6163 . 6164]) 6165 6166AT_CHECK([$COMPILE prog.cob], [0], [], []) 6167AT_CHECK([COB_EXIT_WAIT=0 ./prog], [0], ignore, []) 6168 6169AT_CLEANUP 6170 6171 6172AT_SETUP([LINE/COLUMN 0 exceptions]) 6173AT_KEYWORDS([LINE COLUMN runmisc exceptions extensions screen]) 6174 6175AT_CHECK([test "$COB_HAS_CURSES" = "yes" || exit 77]) 6176 6177AT_DATA([prog.cob], [ 6178 IDENTIFICATION DIVISION. 6179 PROGRAM-ID. prog. 6180 6181 DATA DIVISION. 6182 WORKING-STORAGE SECTION. 6183 01 zero-var PIC 9 VALUE 0. 6184 6185 SCREEN SECTION. 6186 01 scr. 6187 03 VALUE "a". 6188 6189 PROCEDURE DIVISION. 6190 DISPLAY scr AT LINE zero-var 6191 IF FUNCTION EXCEPTION-STATUS <> "EC-SCREEN-LINE-NUMBER" 6192 GOBACK RETURNING 1 6193 END-IF 6194 6195 DISPLAY scr AT COLUMN zero-var 6196 IF FUNCTION EXCEPTION-STATUS <> "EC-SCREEN-STARTING-COLUMN" 6197 GOBACK RETURNING 2 6198 END-IF 6199 6200 GOBACK RETURNING 0 6201 . 6202]) 6203 6204AT_CHECK([$COMPILE -faccept-display-extensions=error prog.cob], [0], [], []) 6205AT_CHECK([COB_EXIT_WAIT=0 ./prog], [0], ignore, []) 6206 6207AT_CLEANUP 6208 6209 6210AT_SETUP([SET LAST EXCEPTION TO OFF]) 6211AT_KEYWORDS([runmisc exceptions EXCEPTION-STATUS EXCEPTION-LOCATION]) 6212 6213AT_DATA([prog.cob], [ 6214 IDENTIFICATION DIVISION. 6215 PROGRAM-ID. prog. 6216 6217 DATA DIVISION. 6218 WORKING-STORAGE SECTION. 6219 01 x PIC 9. 6220 6221 PROCEDURE DIVISION. 6222 COMPUTE x = 10 6223 DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) 6224 DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-LOCATION) 6225 DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) 6226 DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-LOCATION) 6227 SET LAST EXCEPTION TO OFF 6228 DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) 6229 DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-LOCATION) 6230 . 6231]) 6232 6233AT_CHECK([$COMPILE prog.cob], [0], [], []) 6234AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 6235[EC-SIZE-OVERFLOW 6236prog; ; 10 6237EC-SIZE-OVERFLOW 6238prog; ; 10 6239 6240 6241]) 6242AT_CLEANUP 6243 6244 6245# PROCEDURE DIVISION RETURNING OMITTED 6246AT_SETUP([void PROCEDURE]) 6247AT_KEYWORDS([runmisc]) 6248 6249AT_DATA([callee.cob], [ 6250 IDENTIFICATION DIVISION. 6251 PROGRAM-ID. callee. 6252 DATA DIVISION. 6253 PROCEDURE DIVISION RETURNING OMITTED. 6254 MOVE 42 TO RETURN-CODE 6255 EXIT PROGRAM. 6256]) 6257 6258AT_DATA([caller.cob], [ 6259 IDENTIFICATION DIVISION. 6260 PROGRAM-ID. caller. 6261 PROCEDURE DIVISION. 6262 CALL "callee" RETURNING OMITTED 6263 END-CALL. 6264 DISPLAY RETURN-CODE WITH NO ADVANCING 6265 STOP RUN. 6266]) 6267 6268AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 6269AT_CHECK([$COMPILE caller.cob], [0], [], []) 6270AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [+000000000], []) 6271 6272AT_CLEANUP 6273 6274 6275AT_SETUP([Figurative constants to numeric field]) 6276AT_KEYWORDS([Numeric]) 6277 6278AT_DATA([prog.cob], [ 6279 IDENTIFICATION DIVISION. 6280 PROGRAM-ID. prog. 6281 DATA DIVISION. 6282 WORKING-STORAGE SECTION. 6283 01 NUM9 PIC 9(6). 6284 PROCEDURE DIVISION. 6285 MOVE SPACES TO NUM9 6286 DISPLAY "NUM9 value SPACES is " NUM9 "." UPON SYSOUT 6287 MOVE LOW-VALUES TO NUM9 6288 IF NUM9 = LOW-VALUES 6289 DISPLAY "9(6) tests OK for LOW-VALUES" UPON SYSOUT 6290 ELSE 6291 DISPLAY "9(6) Does NOT test OK for LOW-VALUES" 6292 UPON SYSOUT 6293 IF NUM9 = ZERO 6294 DISPLAY "9(6) tests as ZERO instead of LOW-VALUES" 6295 UPON SYSOUT 6296 END-IF 6297 END-IF. 6298 MOVE HIGH-VALUES TO NUM9 6299 IF NUM9 = HIGH-VALUES 6300 DISPLAY "9(6) tests OK for HIGH-VALUES" UPON SYSOUT 6301 ELSE 6302 DISPLAY "9(6) Does NOT test OK for HIGH-VALUES" 6303 UPON SYSOUT 6304 IF NUM9 = ZERO 6305 DISPLAY "9(6) tests as ZERO instead of HIGH-VALUES" 6306 UPON SYSOUT 6307 END-IF 6308 END-IF. 6309 STOP RUN. 6310]) 6311 6312AT_CHECK([$COMPILE -std=mf prog.cob], [0], [], 6313[prog.cob:8: warning: source is non-numeric - substituting zero 6314prog.cob:10: warning: source is non-numeric - substituting zero 6315prog.cob:21: warning: source is non-numeric - substituting zero 6316]) 6317 6318AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 6319[NUM9 value SPACES is 000000. 63209(6) Does NOT test OK for LOW-VALUES 63219(6) tests as ZERO instead of LOW-VALUES 63229(6) Does NOT test OK for HIGH-VALUES 63239(6) tests as ZERO instead of HIGH-VALUES 6324], []) 6325 6326AT_CHECK([$COMPILE -std=acu prog.cob -o aprog], [0], [], []) 6327 6328AT_CHECK([$COBCRUN_DIRECT ./aprog], [0], 6329[NUM9 value SPACES is . 63309(6) tests OK for LOW-VALUES 63319(6) tests OK for HIGH-VALUES 6332], []) 6333 6334AT_CLEANUP 6335 6336 6337AT_SETUP([MF FIGURATIVE to NUMERIC]) 6338AT_KEYWORDS([MOVE]) 6339 6340# FIXME: This test will NOT work on EBCDIC machines, 6341# either add it explicit here and split into two or add 6342# a pre-test and check the expected "native" result 6343 6344AT_DATA([prog.cob], [ 6345 IDENTIFICATION DIVISION. 6346 PROGRAM-ID. prog. 6347 DATA DIVISION. 6348 WORKING-STORAGE SECTION. 6349 01 MYFLD PIC 9(4) VALUE 96. 6350 01 BIGFLT COMP-1 VALUE 543.12345E10. 6351 PROCEDURE DIVISION. 6352 MAIN-1. 6353 DISPLAY "Initial value" 6354 PERFORM SHOW-IT. 6355 DISPLAY "MOVE BIGFLT" 6356 MOVE BIGFLT TO MYFLD. 6357 PERFORM SHOW-IT. 6358 DISPLAY "MOVE SPACES" 6359 MOVE SPACES TO MYFLD. 6360 PERFORM SHOW-IT. 6361 DISPLAY "MOVE LOW-VALUES" 6362 MOVE LOW-VALUES TO MYFLD. 6363 PERFORM SHOW-IT. 6364 DISPLAY "MOVE HIGH-VALUES" 6365 MOVE HIGH-VALUES TO MYFLD. 6366 PERFORM SHOW-IT. 6367 DISPLAY "MOVE QUOTE" 6368 MOVE QUOTE TO MYFLD. 6369 PERFORM SHOW-IT. 6370 DISPLAY "MOVE ALL *" 6371 MOVE ALL '*' TO MYFLD. 6372 PERFORM SHOW-IT. 6373 DISPLAY "MOVE ALL 0" 6374 MOVE ALL '0' TO MYFLD. 6375 PERFORM SHOW-IT. 6376 DISPLAY "MOVE ALL 'A1'" 6377 MOVE ALL 'A1' TO MYFLD. 6378 PERFORM SHOW-IT. 6379 DISPLAY "MOVE ALL '21'" 6380 MOVE ALL '21' TO MYFLD. 6381 PERFORM SHOW-IT. 6382 DISPLAY "MOVE HIGH-VALUES TO (1:)" 6383 MOVE HIGH-VALUES TO MYFLD (1:). 6384 PERFORM SHOW-IT. 6385 6386 DISPLAY "MOVE HIGH-VALUES TO BIGFLT" 6387 MOVE HIGH-VALUES TO BIGFLT. 6388 PERFORM SHOW-BIG. 6389 CALL "dump" USING BIGFLT. 6390 DISPLAY "MOVE QUOTE TO BIGFLT" 6391 MOVE QUOTE TO BIGFLT. 6392 PERFORM SHOW-BIG. 6393 CALL "dump" USING BIGFLT. 6394 DISPLAY "MOVE ALL * TO BIGFLT" 6395 MOVE ALL '*' TO BIGFLT. 6396 PERFORM SHOW-BIG. 6397 *> Note: the next results are dependant on endianess 6398 *> therefore no dump here 6399 DISPLAY "MOVE ALL '21' TO BIGFLT" 6400 MOVE ALL '21' TO BIGFLT. 6401 PERFORM SHOW-BIG. 6402 STOP RUN. 6403 SHOW-IT. 6404 CALL "dump" USING MYFLD. 6405 SHOW-BIG. 6406 DISPLAY "BIGFLT is " BIGFLT. 6407]) 6408 6409AT_DATA([cmod.c], [[ 6410#include <stdio.h> 6411#include <libcob.h> 6412 6413COB_EXT_EXPORT int 6414dump (unsigned char *data) 6415{ 6416 int i; 6417 for (i = 0; i < 4; i++) 6418 printf ("%02X", data[i]); 6419 puts (" ."); 6420 return 0; 6421} 6422]]) 6423 6424AT_CHECK([$COMPILE -std=mf -fno-move-non-numeric-lit-to-numeric-is-zero prog.cob cmod.c], [0], [], 6425[prog.cob: in paragraph 'MAIN-1': 6426prog.cob:28: warning: numeric value is expected 6427prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) 6428prog.cob:34: warning: numeric value is expected 6429prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) 6430prog.cob:52: warning: numeric value is expected 6431prog.cob:7: note: 'BIGFLT' defined here as USAGE FLOAT 6432]) 6433 6434AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 6435[Initial value 643630303936 . 6437MOVE BIGFLT 643838333034 . 6439MOVE SPACES 644020202020 . 6441MOVE LOW-VALUES 644200000000 . 6443MOVE HIGH-VALUES 6444FFFFFFFF . 6445MOVE QUOTE 644622222222 . 6447MOVE ALL * 64482A2A2A2A . 6449MOVE ALL 0 645030303030 . 6451MOVE ALL 'A1' 645241314131 . 6453MOVE ALL '21' 645432313231 . 6455MOVE HIGH-VALUES TO (1:) 6456FFFFFFFF . 6457MOVE HIGH-VALUES TO BIGFLT 6458BIGFLT is NaN 6459FFFFFFFF . 6460MOVE QUOTE TO BIGFLT 6461BIGFLT is 2.1973164E-18 646222222222 . 6463MOVE ALL * TO BIGFLT 6464BIGFLT is 5.4312347E+12 6465MOVE ALL '21' TO BIGFLT 6466BIGFLT is 2.1212121E+37 6467], []) 6468 6469AT_CLEANUP 6470 6471 6472AT_SETUP([CALL RETURNING]) 6473AT_KEYWORDS([runmisc GIVING RETURN-CODE]) 6474 6475AT_DATA([callee.cob], [ 6476 IDENTIFICATION DIVISION. 6477 PROGRAM-ID. callee. 6478 PROCEDURE DIVISION. 6479 MOVE 43 TO RETURN-CODE 6480 EXIT PROGRAM. 6481]) 6482 6483AT_DATA([caller.cob], [ 6484 IDENTIFICATION DIVISION. 6485 PROGRAM-ID. caller. 6486 DATA DIVISION. 6487 WORKING-STORAGE SECTION. 6488 77 my-display-return PIC 99. 6489 77 my-binary-return USAGE BINARY-LONG. 6490 PROCEDURE DIVISION. 6491 CALL "callee" RETURNING my-display-return 6492 END-CALL 6493 IF RETURN-CODE NOT = 0 6494 DISPLAY '1 - unexpected RETURN-CODE: ' RETURN-CODE. 6495 IF my-display-return NOT = 43 6496 DISPLAY '1- unexpected RETURNING: ' my-display-return. 6497 *> 6498 STOP RUN. 6499]) 6500 6501AT_CHECK([$COMPILE -static caller.cob callee.cob -o prog], [0], [], []) 6502#AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 6503AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 6504AT_CHECK([$COMPILE caller.cob], [0], [], []) 6505AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) 6506 6507AT_CLEANUP 6508 6509 6510# PROCEDURE DIVISION RETURNING OMITTED, CALL RETURNING NOTHING 6511AT_SETUP([void PROCEDURE, NOTHING return]) 6512AT_KEYWORDS([runmisc PROCEDURE USING RETURNING OMITTED CALL GIVING]) 6513 6514AT_DATA([callee.cob], [ 6515 IDENTIFICATION DIVISION. 6516 PROGRAM-ID. callee. 6517 DATA DIVISION. 6518 PROCEDURE DIVISION RETURNING OMITTED. 6519 MOVE 43 TO RETURN-CODE 6520 EXIT PROGRAM. 6521]) 6522 6523AT_DATA([caller.cob], [ 6524 IDENTIFICATION DIVISION. 6525 PROGRAM-ID. caller. 6526 PROCEDURE DIVISION. 6527 MOVE 42 TO RETURN-CODE 6528 CALL "callee" RETURNING NOTHING 6529 END-CALL. 6530 IF RETURN-CODE NOT = 42 6531 DISPLAY 'unexpected RETURN-CODE: ' RETURN-CODE. 6532 STOP RUN. 6533]) 6534 6535AT_CHECK([$COMPILE -static caller.cob callee.cob -o prog], [0], [], []) 6536AT_CHECK([$COBCRUN_DIRECT ./prog], [42], [], []) 6537AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) 6538AT_CHECK([$COMPILE caller.cob], [0], [], []) 6539AT_CHECK([$COBCRUN_DIRECT ./caller], [42], [], []) 6540 6541AT_CLEANUP 6542 6543 6544# Checks both -ftrace(all), which needs to be manually set 6545# and -fsource-location, which is implied by -debug/g 6546AT_SETUP([READY TRACE / RESET TRACE]) 6547AT_KEYWORDS([runmisc -ftrace -ftraceall -fsource-location 6548CALL RECURSIVE RETURN-CODE 6549COB_PHYSICAL_CANCEL COB_PRE_LOAD]) 6550 6551AT_DATA([caller.cob], [ 6552 IDENTIFICATION DIVISION. 6553 PROGRAM-ID. caller. 6554 * 6555 PROCEDURE DIVISION. 6556 READY TRACE 6557 MOVE 1 TO RETURN-CODE 6558 RESET TRACE 6559 CALL "callee1" 6560 END-CALL 6561 READY TRACE 6562 MOVE 2 TO RETURN-CODE 6563 CALL "callee1" 6564 END-CALL 6565 CALL "callee1" 6566 CANCEL "callee1" 6567 CALL "callrec" 6568 MOVE 0 TO RETURN-CODE 6569 STOP RUN. 6570]) 6571 6572AT_DATA([callee1.cob], [ 6573 IDENTIFICATION DIVISION. 6574 PROGRAM-ID. callee1. 6575 PROCEDURE DIVISION. 6576 ADD 1 TO RETURN-CODE 6577 NOT ON SIZE ERROR 6578 IF RETURN-CODE = 1 6579 CONTINUE 6580 ELSE IF RETURN-CODE = 2 6581 CONTINUE 6582 ELSE 6583 CONTINUE 6584 . 6585 EVALUATE RETURN-CODE 6586 WHEN 1 6587 CONTINUE 6588 WHEN 2 6589 WHEN 3 6590 CONTINUE 6591 WHEN OTHER 6592 CONTINUE 6593 END-EVALUATE 6594 EVALUATE TRUE 6595 WHEN RETURN-CODE = 1 6596 CONTINUE 6597 WHEN RETURN-CODE = 2 6598 WHEN RETURN-CODE = 3 6599 CONTINUE 6600 WHEN OTHER 6601 CONTINUE 6602 END-EVALUATE 6603 CALL "callee2" END-CALL 6604 CANCEL "callee2" CALL "callee2b" END-CALL CANCEL "callee2b" 6605 SUBTRACT 1 FROM RETURN-CODE END-SUBTRACT 6606 EXIT PROGRAM. 6607]) 6608 6609AT_DATA([callee2.cob], [ 6610 IDENTIFICATION DIVISION. 6611 PROGRAM-ID. callee2. 6612 PROCEDURE DIVISION. 6613 COMPUTE RETURN-CODE 6614 = 1 + 1 6615 ON SIZE ERROR 6616 MOVE -1 TO RETURN-CODE 6617 NOT ON SIZE ERROR 6618 COMPUTE RETURN-CODE 6619 = 1 + 1 6620 END-COMPUTE 6621 END-COMPUTE. 6622 CALL "callee2c" END-CALL 6623 CANCEL "callee2c" 6624 MOVE 0 TO RETURN-CODE. 6625 EXIT PROGRAM. 6626]) 6627 6628AT_DATA([preload.cob], [ 6629 IDENTIFICATION DIVISION. 6630 PROGRAM-ID. callee2b. 6631 PROCEDURE DIVISION. 6632 SOME-SEC SECTION. 6633 SOME-PAR. 6634 PERFORM OTHER-SEC 6635 MOVE 0 TO RETURN-CODE. 6636 ENTRY "LEAVE-ME". 6637 END-PAR. 6638 EXIT PROGRAM. 6639 OTHER-SEC SECTION. 6640 COMPUTE RETURN-CODE = 1 + 2 END-COMPUTE. 6641 EX. EXIT. 6642]) 6643 6644AT_DATA([preload2.cob], [ 6645 IDENTIFICATION DIVISION. 6646 PROGRAM-ID. callrec IS RECURSIVE. 6647 DATA DIVISION. 6648 WORKING-STORAGE SECTION. 6649 01 filler PIC 9 VALUE 0. 6650 88 first-call VALUE 0. 6651 88 called VALUE 1. 6652 PROCEDURE DIVISION. 6653 SOME-SEC SECTION. 6654 IF first-call 6655 SET called TO TRUE 6656 CALL 'callrec' 6657 END-IF 6658 GOBACK. 6659]) 6660 6661AT_DATA([callee2c.cob], [ 6662 IDENTIFICATION DIVISION. 6663 PROGRAM-ID. callee2c. 6664 PROCEDURE DIVISION. 6665 SOME-SEC SECTION. 6666 SOME-PAR. 6667 PERFORM OTHER-SEC 6668 MOVE 0 TO RETURN-CODE. 6669 END-PAR. 6670 EXIT PROGRAM. 6671 OTHER-SEC SECTION. 6672 COMPUTE RETURN-CODE = 1 + 2 END-COMPUTE. 6673 EX. EXIT. 6674]) 6675 6676AT_CHECK([COB_OLD_TRACE=y \ 6677$COBC -ftraceall callee1.cob], [0], [], []) 6678AT_CHECK([COB_OLD_TRACE=y \ 6679$COBC callee2.cob], [0], [], []) 6680AT_CHECK([COB_OLD_TRACE=y \ 6681$COBC -ftrace preload.cob], [0], [], []) 6682AT_CHECK([COB_OLD_TRACE=y \ 6683$COBC -ftraceall preload2.cob], [0], [], []) 6684AT_CHECK([COB_OLD_TRACE=y \ 6685$COBC -fsource-location callee2c.cob], [0], [], []) 6686AT_CHECK([COB_OLD_TRACE=y \ 6687$COBC -x -o prog -ftraceall caller.cob], [0], [], []) 6688AT_CHECK([COB_PHYSICAL_CANCEL=1 COB_PRE_LOAD="preload"$PATHSEP"preload2" $COBCRUN_DIRECT ./prog], [0], [], 6689[Source : 'caller.cob' 6690Program-Id: caller Statement: MOVE Line: 7 6691Program-Id: caller Statement: RESET TRACE Line: 8 6692Program-Id: caller Statement: MOVE Line: 12 6693Program-Id: caller Statement: CALL Line: 13 6694Source: 'callee1.cob' 6695Program-Id: callee1 Entry: callee1 Line: 4 6696Program-Id: callee1 Section: (None) Line: 5 6697Program-Id: callee1 Paragraph: (None) Line: 5 6698Program-Id: callee1 Statement: ADD Line: 5 6699Program-Id: callee1 Statement: IF Line: 7 6700Program-Id: callee1 Statement: IF Line: 9 6701Program-Id: callee1 Statement: CONTINUE Line: 12 6702Program-Id: callee1 Statement: EVALUATE Line: 14 6703Program-Id: callee1 Statement: WHEN Line: 15 6704Program-Id: callee1 Statement: CONTINUE Line: 21 6705Program-Id: callee1 Statement: EVALUATE Line: 23 6706Program-Id: callee1 Statement: WHEN Line: 24 6707Program-Id: callee1 Statement: WHEN Line: 27 6708Program-Id: callee1 Statement: CONTINUE Line: 30 6709Program-Id: callee1 Statement: CALL Line: 32 6710Source : 'callee2c.cob' 6711Program-Id: callee2c Statement: PERFORM Line: 7 6712Program-Id: callee2c Statement: COMPUTE Line: 12 6713Program-Id: callee2c Statement: EXIT Line: 13 6714Program-Id: callee2c Statement: MOVE Line: 8 6715Program-Id: callee2c Statement: EXIT PROGRAM Line: 10 6716Source : 'callee1.cob' 6717Program-Id: callee1 Statement: CANCEL Line: 33 6718Program-Id: callee1 Statement: CALL Line: 33 6719Source: 'preload.cob' 6720Program-Id: callee2b Entry: callee2b Line: 4 6721Program-Id: callee2b Section: SOME-SEC Line: 5 6722Program-Id: callee2b Paragraph: SOME-PAR Line: 6 6723Program-Id: callee2b Section: OTHER-SEC Line: 12 6724Program-Id: callee2b Paragraph: (None) Line: 12 6725Program-Id: callee2b Paragraph: EX Line: 14 6726Program-Id: callee2b Entry: LEAVE-ME Line: 9 6727Program-Id: callee2b Paragraph: END-PAR Line: 10 6728Program-Id: callee2b Exit: callee2b 6729Source : 'callee1.cob' 6730Program-Id: callee1 Statement: CANCEL Line: 33 6731Program-Id: callee1 Statement: SUBTRACT Line: 34 6732Program-Id: callee1 Statement: EXIT PROGRAM Line: 35 6733Program-Id: callee1 Exit: callee1 6734Source : 'caller.cob' 6735Program-Id: caller Statement: CALL Line: 15 6736Source: 'callee1.cob' 6737Program-Id: callee1 Entry: callee1 Line: 4 6738Program-Id: callee1 Section: (None) Line: 5 6739Program-Id: callee1 Paragraph: (None) Line: 5 6740Program-Id: callee1 Statement: ADD Line: 5 6741Program-Id: callee1 Statement: IF Line: 7 6742Program-Id: callee1 Statement: IF Line: 9 6743Program-Id: callee1 Statement: CONTINUE Line: 12 6744Program-Id: callee1 Statement: EVALUATE Line: 14 6745Program-Id: callee1 Statement: WHEN Line: 15 6746Program-Id: callee1 Statement: CONTINUE Line: 21 6747Program-Id: callee1 Statement: EVALUATE Line: 23 6748Program-Id: callee1 Statement: WHEN Line: 24 6749Program-Id: callee1 Statement: WHEN Line: 27 6750Program-Id: callee1 Statement: CONTINUE Line: 30 6751Program-Id: callee1 Statement: CALL Line: 32 6752Source : 'callee2c.cob' 6753Program-Id: callee2c Statement: PERFORM Line: 7 6754Program-Id: callee2c Statement: COMPUTE Line: 12 6755Program-Id: callee2c Statement: EXIT Line: 13 6756Program-Id: callee2c Statement: MOVE Line: 8 6757Program-Id: callee2c Statement: EXIT PROGRAM Line: 10 6758Source : 'callee1.cob' 6759Program-Id: callee1 Statement: CANCEL Line: 33 6760Program-Id: callee1 Statement: CALL Line: 33 6761Source: 'preload.cob' 6762Program-Id: callee2b Entry: callee2b Line: 4 6763Program-Id: callee2b Section: SOME-SEC Line: 5 6764Program-Id: callee2b Paragraph: SOME-PAR Line: 6 6765Program-Id: callee2b Section: OTHER-SEC Line: 12 6766Program-Id: callee2b Paragraph: (None) Line: 12 6767Program-Id: callee2b Paragraph: EX Line: 14 6768Program-Id: callee2b Entry: LEAVE-ME Line: 9 6769Program-Id: callee2b Paragraph: END-PAR Line: 10 6770Program-Id: callee2b Exit: callee2b 6771Source : 'callee1.cob' 6772Program-Id: callee1 Statement: CANCEL Line: 33 6773Program-Id: callee1 Statement: SUBTRACT Line: 34 6774Program-Id: callee1 Statement: EXIT PROGRAM Line: 35 6775Program-Id: callee1 Exit: callee1 6776Source : 'caller.cob' 6777Program-Id: caller Statement: CANCEL Line: 16 6778Program-Id: caller Statement: CALL Line: 17 6779Source: 'preload2.cob' 6780Program-Id: callrec Entry: callrec Line: 9 6781Program-Id: callrec Section: SOME-SEC Line: 10 6782Program-Id: callrec Paragraph: (None) Line: 10 6783Program-Id: callrec Statement: IF Line: 11 6784Program-Id: callrec Statement: SET Line: 12 6785Program-Id: callrec Statement: CALL Line: 13 6786Program-Id: callrec Entry: callrec Line: 9 6787Program-Id: callrec Section: SOME-SEC Line: 10 6788Program-Id: callrec Paragraph: (None) Line: 10 6789Program-Id: callrec Statement: IF Line: 11 6790Program-Id: callrec Statement: GOBACK Line: 15 6791Program-Id: callrec Exit: callrec 6792Program-Id: callrec Statement: GOBACK Line: 15 6793Program-Id: callrec Exit: callrec 6794Source : 'caller.cob' 6795Program-Id: caller Statement: MOVE Line: 18 6796Program-Id: caller Statement: STOP RUN Line: 19 6797]) 6798 6799AT_CHECK([$COBC -ftraceall callee1.cob], [0], [], []) 6800AT_CHECK([$COBC callee2.cob], [0], [], []) 6801AT_CHECK([$COBC -ftrace preload.cob], [0], [], []) 6802AT_CHECK([$COBC -ftraceall preload2.cob], [0], [], []) 6803AT_CHECK([$COBC -fsource-location callee2c.cob], [0], [], []) 6804AT_CHECK([$COBC -x -o prog -ftraceall caller.cob], [0], [], []) 6805AT_CHECK([COB_PHYSICAL_CANCEL=1 COB_PRE_LOAD="preload"$PATHSEP"preload2" $COBCRUN_DIRECT ./prog], [0], [], 6806[Source: 'caller.cob' 6807Program-Id: caller 6808Program-Id: caller MOVE Line: 7 6809Program-Id: caller RESET TRACE Line: 8 6810Program-Id: caller MOVE Line: 12 6811Program-Id: caller CALL Line: 13 6812Source: 'callee1.cob' 6813Program-Id: callee1 6814Program-Id: callee1 Entry: callee1 Line: 4 6815Program-Id: callee1 ADD Line: 5 6816Program-Id: callee1 IF Line: 7 6817Program-Id: callee1 IF Line: 9 6818Program-Id: callee1 CONTINUE Line: 12 6819Program-Id: callee1 EVALUATE Line: 14 6820Program-Id: callee1 WHEN Line: 15 6821Program-Id: callee1 CONTINUE Line: 21 6822Program-Id: callee1 EVALUATE Line: 23 6823Program-Id: callee1 WHEN Line: 24 6824Program-Id: callee1 WHEN Line: 27 6825Program-Id: callee1 CONTINUE Line: 30 6826Program-Id: callee1 CALL Line: 32 6827Program-Id: callee1 CANCEL Line: 33 6828Program-Id: callee1 CALL Line: 33 6829Source: 'preload.cob' 6830Program-Id: callee2b 6831Program-Id: callee2b Entry: callee2b Line: 4 6832Program-Id: callee2b Section: SOME-SEC Line: 5 6833Program-Id: callee2b Paragraph: SOME-PAR Line: 6 6834Program-Id: callee2b Section: OTHER-SEC Line: 12 6835Program-Id: callee2b Paragraph: EX Line: 14 6836Program-Id: callee2b Entry: LEAVE-ME Line: 14 6837Program-Id: callee2b Paragraph: END-PAR Line: 10 6838Program-Id: callee2b Exit: callee2b Line: 10 6839Source: 'callee1.cob' 6840Program-Id: callee1 6841Program-Id: callee1 CANCEL Line: 33 6842Program-Id: callee1 SUBTRACT Line: 34 6843Program-Id: callee1 EXIT PROGRAM Line: 35 6844Program-Id: callee1 Exit: callee1 Line: 35 6845Source: 'caller.cob' 6846Program-Id: caller 6847Program-Id: caller CALL Line: 15 6848Source: 'callee1.cob' 6849Program-Id: callee1 6850Program-Id: callee1 Entry: callee1 Line: 4 6851Program-Id: callee1 ADD Line: 5 6852Program-Id: callee1 IF Line: 7 6853Program-Id: callee1 IF Line: 9 6854Program-Id: callee1 CONTINUE Line: 12 6855Program-Id: callee1 EVALUATE Line: 14 6856Program-Id: callee1 WHEN Line: 15 6857Program-Id: callee1 CONTINUE Line: 21 6858Program-Id: callee1 EVALUATE Line: 23 6859Program-Id: callee1 WHEN Line: 24 6860Program-Id: callee1 WHEN Line: 27 6861Program-Id: callee1 CONTINUE Line: 30 6862Program-Id: callee1 CALL Line: 32 6863Program-Id: callee1 CANCEL Line: 33 6864Program-Id: callee1 CALL Line: 33 6865Source: 'preload.cob' 6866Program-Id: callee2b 6867Program-Id: callee2b Entry: callee2b Line: 4 6868Program-Id: callee2b Section: SOME-SEC Line: 5 6869Program-Id: callee2b Paragraph: SOME-PAR Line: 6 6870Program-Id: callee2b Section: OTHER-SEC Line: 12 6871Program-Id: callee2b Paragraph: EX Line: 14 6872Program-Id: callee2b Entry: LEAVE-ME Line: 14 6873Program-Id: callee2b Paragraph: END-PAR Line: 10 6874Program-Id: callee2b Exit: callee2b Line: 10 6875Source: 'callee1.cob' 6876Program-Id: callee1 6877Program-Id: callee1 CANCEL Line: 33 6878Program-Id: callee1 SUBTRACT Line: 34 6879Program-Id: callee1 EXIT PROGRAM Line: 35 6880Program-Id: callee1 Exit: callee1 Line: 35 6881Source: 'caller.cob' 6882Program-Id: caller 6883Program-Id: caller CANCEL Line: 16 6884Program-Id: caller CALL Line: 17 6885Source: 'preload2.cob' 6886Program-Id: callrec 6887Program-Id: callrec Entry: callrec Line: 9 6888Program-Id: callrec Section: SOME-SEC Line: 10 6889Program-Id: callrec IF Line: 11 6890Program-Id: callrec SET Line: 12 6891Program-Id: callrec CALL Line: 13 6892Program-Id: callrec Entry: callrec Line: 9 6893Program-Id: callrec Section: SOME-SEC Line: 10 6894Program-Id: callrec IF Line: 11 6895Program-Id: callrec GOBACK Line: 15 6896Program-Id: callrec Exit: callrec Line: 15 6897Program-Id: callrec GOBACK Line: 15 6898Program-Id: callrec Exit: callrec Line: 15 6899Source: 'caller.cob' 6900Program-Id: caller 6901Program-Id: caller MOVE Line: 18 6902Program-Id: caller STOP RUN Line: 19 6903]) 6904 6905AT_CLEANUP 6906 6907 6908AT_SETUP([Trace feature with subroutine]) 6909AT_KEYWORDS([Trace]) 6910 6911# FIXME: check if the one above is enough and either 6912# remove this test or exchange by a non-IDX version 6913AT_SKIP_IF([test "$COB_HAS_ISAM" = "no"]) 6914 6915AT_DATA([callsub.cob], [ 6916 IDENTIFICATION DIVISION. 6917 PROGRAM-ID. callsub. 6918 6919 DATA DIVISION. 6920 WORKING-STORAGE SECTION. 6921 01 NUM-A PIC 9(3) VALUE 399. 6922 01 NUM-B PIC 9(3) VALUE 211. 6923 01 RSLT PIC 9(5)V99. 6924 6925 LINKAGE SECTION. 6926 01 n PIC 99. 6927 6928 PROCEDURE DIVISION USING n. 6929 MAIN-10. 6930 ADD 1 TO n. 6931 COMPUTE RSLT = ((NUM-A / (100.55 + -0.550)) 6932 - (NUM-B / (10.11 * 10 - 1.1))) 6933 * (220 / 2.2) * n. 6934 END PROGRAM callsub. 6935]) 6936 6937AT_CHECK([$COMPILE_MODULE callsub.cob], [0], [], []) 6938 6939 6940AT_DATA([prog.cob], [ 6941 IDENTIFICATION DIVISION. 6942 PROGRAM-ID. prog. 6943 6944 ENVIRONMENT DIVISION. 6945 CONFIGURATION SECTION. 6946 6947 INPUT-OUTPUT SECTION. 6948 FILE-CONTROL. 6949 SELECT OPTIONAL TSPFILE 6950 ASSIGN TO "testisam" 6951 ORGANIZATION INDEXED ACCESS DYNAMIC 6952 RECORD KEY IS CM-CUST-NUM 6953 ALTERNATE RECORD KEY IS CM-TELEPHONE WITH DUPLICATES 6954 ALTERNATE RECORD KEY IS CM-DISK WITH DUPLICATES 6955 FILE STATUS IS CUST-STAT. 6956 6957 SELECT TSTFILE 6958 ASSIGN TO "testisam" 6959 ORGANIZATION INDEXED ACCESS DYNAMIC 6960 RECORD KEY IS TS-CUST-NUM 6961 ALTERNATE RECORD KEY IS TS-TELEPHONE WITH DUPLICATES 6962 ALTERNATE RECORD KEY IS TS-DISK WITH DUPLICATES 6963 FILE STATUS IS CUST-STAT. 6964 6965 SELECT FLATFILE 6966 ASSIGN EXTERNAL RELFIX 6967 ORGANIZATION RELATIVE 6968 ACCESS IS RANDOM RELATIVE KEY IS REC-NUM 6969 FILE STATUS IS CUST-STAT. 6970 6971 DATA DIVISION. 6972 FILE SECTION. 6973 FD TSPFILE 6974 BLOCK CONTAINS 5 RECORDS. 6975 6976 01 TSPFL-RECORD. 6977 05 TSPFL-REC. 6978 10 CM-CUST-NUM. 6979 15 CM-CUST-PRE PICTURE X(3). 6980 15 CM-CUST-NNN PICTURE X(5). 6981 10 CM-STATUS PICTURE X. 6982 10 CM-COMPANY PICTURE X(25). 6983 10 CM-ADDRESS-1 PICTURE X(25). 6984 10 CM-ADDRESS-2 PICTURE X(25). 6985 10 CM-ADDRESS-3 PICTURE X(25). 6986 10 CM-TELEPHONE PICTURE 9(10). 6987 10 CM-DP-MGR PICTURE X(25). 6988 10 CM-MACHINE PICTURE X(8). 6989 10 CM-MEMORY PICTURE X(4). 6990 10 CM-DISK PICTURE X(8). 6991 10 CM-TAPE PICTURE X(8). 6992 10 CM-NO-TERMINALS PICTURE 9(5). 6993 6994 FD TSTFILE 6995 BLOCK CONTAINS 5 RECORDS. 6996 6997 01 TSTFL-RECORD. 6998 05 TSTFL-REC. 6999 10 TS-CUST-NUM PICTURE X(8). 7000 10 TS-STATUS PICTURE X. 7001 10 TS-COMPANY PICTURE X(25). 7002 10 TS-ADDRESS-1 PICTURE X(25). 7003 10 TS-ADDRESS-2 PICTURE X(25). 7004 10 TS-ADDRESS-3 PICTURE X(25). 7005 10 TS-TELEPHONE PICTURE 9(10). 7006 10 TS-DP-MGR PICTURE X(25). 7007 10 TS-MACHINE PICTURE X(8). 7008 10 TS-MEMORY PICTURE X(4). 7009 10 TS-DISK PICTURE X(8). 7010 10 TS-TAPE PICTURE X(8). 7011 7012 FD FLATFILE 7013 BLOCK CONTAINS 5 RECORDS. 7014 7015 01 TSP2-RECORD. 7016 10 C2-CUST-NUM PICTURE X(8). 7017 10 C2-COMPANY PICTURE X(25). 7018 10 C2-DISK PICTURE X(8). 7019 10 C2-NO-TERMINALS PICTURE 9(4) COMP-4. 7020 10 C2-PK-DATE PICTURE S9(14) COMP-3. 7021 7022 WORKING-STORAGE SECTION. 7023 7024 01 CUST-STAT. 7025 05 FILLER PICTURE XX. 7026 77 MAX-SUB VALUE 16 PICTURE 9(5) COMP SYNC. 7027 77 CALL-NUM VALUE 00 PICTURE 99. 7028 7029 01 TEST-DATA. 7030 7031 02 DATA-CUST-NUM-TBL. 7032 7033 05 FILLER PIC X(8) VALUE "ALP00000". 7034 05 FILLER PIC X(8) VALUE "BET00000". 7035 05 FILLER PIC X(8) VALUE "GAM00000". 7036 05 FILLER PIC X(8) VALUE "DEL00000". 7037 05 FILLER PIC X(8) VALUE "EPS00000". 7038 05 FILLER PIC X(8) VALUE "FOR00000". 7039 05 FILLER PIC X(8) VALUE "GIB00000". 7040 05 FILLER PIC X(8) VALUE "H&J00000". 7041 05 FILLER PIC X(8) VALUE "INC00000". 7042 05 FILLER PIC X(8) VALUE "JOH00000". 7043 05 FILLER PIC X(8) VALUE "KON00000". 7044 05 FILLER PIC X(8) VALUE "LEW00000". 7045 05 FILLER PIC X(8) VALUE "MOR00000". 7046 05 FILLER PIC X(8) VALUE "NEW00000". 7047 05 FILLER PIC X(8) VALUE "OLD00000". 7048 05 FILLER PIC X(8) VALUE "PRE00000". 7049 7050 02 DATA-CUST-NUM REDEFINES DATA-CUST-NUM-TBL 7051 PIC X(8) OCCURS 16. 7052 02 DATA-COMPANY-TBL. 7053 7054 05 FILLER PIC X(25) VALUE "ALPHA ELECTRICAL CO. LTD.". 7055 05 FILLER PIC X(25) VALUE "BETA SHOE MFG. INC. ". 7056 05 FILLER PIC X(25) VALUE "GAMMA X-RAY TECHNOLOGY ". 7057 05 FILLER PIC X(25) VALUE "DELTA LUGGAGE REPAIRS ". 7058 05 FILLER PIC X(25) VALUE "EPSILON EQUIPMENT SUPPLY ". 7059 05 FILLER PIC X(25) VALUE "FORTUNE COOKIE COMPANY ". 7060 05 FILLER PIC X(25) VALUE "GIBRALTER LIFE INSURANCE ". 7061 05 FILLER PIC X(25) VALUE "H & J PLUMBING SUPPLIES ". 7062 05 FILLER PIC X(25) VALUE "INCREMENTAL BACKUP CORP. ". 7063 05 FILLER PIC X(25) VALUE "JOHNSON BOATING SUPPLIES ". 7064 05 FILLER PIC X(25) VALUE "KONFLAB PLASTIC PRODUCTS.". 7065 05 FILLER PIC X(25) VALUE "LEWISTON GRAPHICS LTD. ". 7066 05 FILLER PIC X(25) VALUE "MORNINGSIDE CARPENTRY. ". 7067 05 FILLER PIC X(25) VALUE "NEW WAVE SURF SHOPS INC. ". 7068 05 FILLER PIC X(25) VALUE "OLD TYME PIZZA MFG. CO. ". 7069 05 FILLER PIC X(25) VALUE "PRESTIGE OFFICE FURNITURE". 7070 7071 02 DATA-COMPANY REDEFINES DATA-COMPANY-TBL 7072 PIC X(25) OCCURS 16. 7073 02 DATA-ADDRESS-1-TBL. 7074 7075 05 FILLER PIC X(25) VALUE "123 MAIN STREET ". 7076 05 FILLER PIC X(25) VALUE "1090 2ND AVE. WEST ". 7077 05 FILLER PIC X(25) VALUE "1401 JEFFERSON BLVD. ". 7078 05 FILLER PIC X(25) VALUE "1620 ARIZONA WAY ". 7079 05 FILLER PIC X(25) VALUE "1184 EAST FIRST STREET ". 7080 05 FILLER PIC X(25) VALUE "114 JOHN F. KENNEDY AVE. ". 7081 05 FILLER PIC X(25) VALUE "650 LIBERTY CRESCENT ". 7082 05 FILLER PIC X(25) VALUE "77 SUNSET BLVD. ". 7083 05 FILLER PIC X(25) VALUE "10908 SANTA MONICA BLVD. ". 7084 05 FILLER PIC X(25) VALUE "1134 PARIS ROAD ". 7085 05 FILLER PIC X(25) VALUE "808 NORTHWEST MAIN ST. ". 7086 05 FILLER PIC X(25) VALUE "9904 QUEEN STREET ". 7087 05 FILLER PIC X(25) VALUE "1709 DUNDAS CRESCENT W. ". 7088 05 FILLER PIC X(25) VALUE "3240 MARIS AVENUE ". 7089 05 FILLER PIC X(25) VALUE "1705 WISCONSIN ROAD ". 7090 05 FILLER PIC X(25) VALUE "114A MAPLE GROVE ". 7091 7092 02 DATA-ADDRESS-1 REDEFINES DATA-ADDRESS-1-TBL 7093 PIC X(25) OCCURS 16. 7094 02 DATA-ADDRESS-2-TBL. 7095 7096 05 FILLER PIC X(10) VALUE "NEW YORK ". 7097 05 FILLER PIC X(10) VALUE "ATLANTA ". 7098 05 FILLER PIC X(10) VALUE "WASHINGTON". 7099 05 FILLER PIC X(10) VALUE "TORONTO ". 7100 05 FILLER PIC X(10) VALUE "CALGARY ". 7101 05 FILLER PIC X(10) VALUE "SAN DIEGO ". 7102 05 FILLER PIC X(10) VALUE "LOS RIOS ". 7103 05 FILLER PIC X(10) VALUE "MADISON ". 7104 05 FILLER PIC X(10) VALUE "WILBUR ". 7105 05 FILLER PIC X(10) VALUE "TOPEKA ". 7106 05 FILLER PIC X(10) VALUE "SEATTLE ". 7107 05 FILLER PIC X(10) VALUE "NEW JERSEY". 7108 05 FILLER PIC X(10) VALUE "FORT WAYNE". 7109 05 FILLER PIC X(10) VALUE "COLUMBUS ". 7110 05 FILLER PIC X(10) VALUE "RICHMOND ". 7111 05 FILLER PIC X(10) VALUE "WHITEPLAIN". 7112 7113 02 DATA-ADDRESS-2 REDEFINES DATA-ADDRESS-2-TBL 7114 PIC X(10) OCCURS 16. 7115 02 DATA-ADDRESS-3-TBL. 7116 7117 05 FILLER PIC X(10) VALUE "N.Y. ". 7118 05 FILLER PIC X(10) VALUE "GEORGIA ". 7119 05 FILLER PIC X(10) VALUE "D.C. ". 7120 05 FILLER PIC X(10) VALUE "CANADA ". 7121 05 FILLER PIC X(10) VALUE "CANADA ". 7122 05 FILLER PIC X(10) VALUE "CALIFORNIA". 7123 05 FILLER PIC X(10) VALUE "NEW MEXICO". 7124 05 FILLER PIC X(10) VALUE "WISCONSIN ". 7125 05 FILLER PIC X(10) VALUE "DELAWARE ". 7126 05 FILLER PIC X(10) VALUE "KANSAS ". 7127 05 FILLER PIC X(10) VALUE "WASHINGTON". 7128 05 FILLER PIC X(10) VALUE "N.J. ". 7129 05 FILLER PIC X(10) VALUE "COLORADO ". 7130 05 FILLER PIC X(10) VALUE "OHIO ". 7131 05 FILLER PIC X(10) VALUE "VIRGINIA ". 7132 05 FILLER PIC X(10) VALUE "N.Y. ". 7133 7134 02 DATA-ADDRESS-3 REDEFINES DATA-ADDRESS-3-TBL 7135 PIC X(10) OCCURS 16. 7136 02 DATA-TELEPHONE-TBL. 7137 7138 05 FILLER PIC 9(10) VALUE 3131234432. 7139 05 FILLER PIC 9(10) VALUE 4082938498. 7140 05 FILLER PIC 9(10) VALUE 8372487274. 7141 05 FILLER PIC 9(10) VALUE 4169898509. 7142 05 FILLER PIC 9(10) VALUE 5292398745. 7143 05 FILLER PIC 9(10) VALUE 8009329492. 7144 05 FILLER PIC 9(10) VALUE 6456445643. 7145 05 FILLER PIC 9(10) VALUE 6546456333. 7146 05 FILLER PIC 9(10) VALUE 3455445444. 7147 05 FILLER PIC 9(10) VALUE 6456445643. 7148 05 FILLER PIC 9(10) VALUE 7456434355. 7149 05 FILLER PIC 9(10) VALUE 6554456433. 7150 05 FILLER PIC 9(10) VALUE 4169898509. 7151 05 FILLER PIC 9(10) VALUE 7534587453. 7152 05 FILLER PIC 9(10) VALUE 8787458374. 7153 05 FILLER PIC 9(10) VALUE 4169898509. 7154 7155 02 DATA-TELEPHONE REDEFINES DATA-TELEPHONE-TBL 7156 PIC 9(10) OCCURS 16. 7157 02 DATA-DP-MGR-TBL. 7158 7159 05 FILLER PIC X(20) VALUE "MR. DAVE HARRIS ". 7160 05 FILLER PIC X(20) VALUE "MS. JANICE SILCOX ". 7161 05 FILLER PIC X(20) VALUE "MR. ALLAN JONES ". 7162 05 FILLER PIC X(20) VALUE "MR. PETER MACKAY ". 7163 05 FILLER PIC X(20) VALUE "MRS. DONNA BREWER ". 7164 05 FILLER PIC X(20) VALUE "MR. MICHAEL SMYTHE ". 7165 05 FILLER PIC X(20) VALUE "MR. D.A. MORRISON ". 7166 05 FILLER PIC X(20) VALUE "MR. BRIAN PATTERSON ". 7167 05 FILLER PIC X(20) VALUE "MR. DARRYL TOWNSEND ". 7168 05 FILLER PIC X(20) VALUE "MS. VALERIE HARPER ". 7169 05 FILLER PIC X(20) VALUE "MR. FRED MILLER ". 7170 05 FILLER PIC X(20) VALUE "MR. DONALD FISCHER ". 7171 05 FILLER PIC X(20) VALUE "MR. STEVEN YOURDIN ". 7172 05 FILLER PIC X(20) VALUE "MS. Goldie Hawn ". 7173 05 FILLER PIC X(20) VALUE "MS. ALICE WINSTON ". 7174 05 FILLER PIC X(20) VALUE "MR. THOMAS JEFFERSON". 7175 7176 02 DATA-DP-MGR REDEFINES DATA-DP-MGR-TBL 7177 PIC X(20) OCCURS 16. 7178 02 DATA-MACHINE-TBL. 7179 7180 05 FILLER PIC X(8) VALUE "UNI-9030". 7181 05 FILLER PIC X(8) VALUE "UNI-9040". 7182 05 FILLER PIC X(8) VALUE "UNI-80/3". 7183 05 FILLER PIC X(8) VALUE "UNI-80/5". 7184 05 FILLER PIC X(8) VALUE "UNI-80/6". 7185 05 FILLER PIC X(8) VALUE "UNI-80/6". 7186 05 FILLER PIC X(8) VALUE "UNI-80/6". 7187 05 FILLER PIC X(8) VALUE "UNI-80/8". 7188 05 FILLER PIC X(8) VALUE "UNI-80/8". 7189 05 FILLER PIC X(8) VALUE "UNI-80/8". 7190 05 FILLER PIC X(8) VALUE "UNI-80/8". 7191 05 FILLER PIC X(8) VALUE "UNI-80/8". 7192 05 FILLER PIC X(8) VALUE "UNI-80/8". 7193 05 FILLER PIC X(8) VALUE "UNI-80/8". 7194 05 FILLER PIC X(8) VALUE "UNI-9040". 7195 05 FILLER PIC X(8) VALUE "UNI-9040". 7196 7197 02 DATA-MACHINE REDEFINES DATA-MACHINE-TBL 7198 PIC X(8) OCCURS 16. 7199 02 DATA-NO-TERMINALS-TBL. 7200 7201 05 FILLER PIC 9(3) COMP-3 VALUE 85. 7202 05 FILLER PIC 9(3) COMP-3 VALUE 34. 7203 05 FILLER PIC 9(3) COMP-3 VALUE 75. 7204 05 FILLER PIC 9(3) COMP-3 VALUE 45. 7205 05 FILLER PIC 9(3) COMP-3 VALUE 90. 7206 05 FILLER PIC 9(3) COMP-3 VALUE 107. 7207 05 FILLER PIC 9(3) COMP-3 VALUE 67. 7208 05 FILLER PIC 9(3) COMP-3 VALUE 32. 7209 05 FILLER PIC 9(3) COMP-3 VALUE 16. 7210 05 FILLER PIC 9(3) COMP-3 VALUE 34. 7211 05 FILLER PIC 9(3) COMP-3 VALUE 128. 7212 05 FILLER PIC 9(3) COMP-3 VALUE 64. 7213 05 FILLER PIC 9(3) COMP-3 VALUE 110. 7214 05 FILLER PIC 9(3) COMP-3 VALUE 324. 7215 05 FILLER PIC 9(3) COMP-3 VALUE 124. 7216 05 FILLER PIC 9(3) COMP-3 VALUE 86. 7217 7218 02 DATA-NO-TERMINALS REDEFINES DATA-NO-TERMINALS-TBL 7219 PIC 9(3) COMP-3 OCCURS 16. 7220 7221 01 WORK-AREA. 7222 05 REC-NUM PICTURE 9(6) VALUE 0. 7223 05 REC-MAX PICTURE 9(6) VALUE 10. 7224 05 SUB PICTURE 9(4) COMP SYNC. 7225 88 ODD-RECORD VALUE 1 3 5 7 9 10 11. 7226 7227 05 TSPFL-KEY PICTURE X(8). 7228 7229 PROCEDURE DIVISION. 7230 7231 MAINFILE. 7232 OPEN OUTPUT TSPFILE 7233 CLOSE TSPFILE. 7234 7235 OPEN I-O TSPFILE 7236 MOVE '99' TO CUST-STAT 7237 READ TSPFILE NEXT RECORD WITH NO LOCK 7238 IF CUST-STAT NOT = "10" 7239 DISPLAY "Error " CUST-STAT " on read of empty file" 7240 UPON CONSOLE 7241 STOP RUN 7242 END-IF. 7243 MOVE LOW-VALUES TO TSPFL-RECORD. 7244 START TSPFILE KEY GREATER THAN CM-CUST-NUM 7245 IF CUST-STAT NOT = "23" 7246 DISPLAY "Error " CUST-STAT " starting empty file" 7247 UPON CONSOLE 7248 STOP RUN 7249 END-IF. 7250 READ TSPFILE NEXT RECORD WITH NO LOCK 7251 IF CUST-STAT NOT = "46" 7252 DISPLAY "Error " CUST-STAT " start/read of empty file" 7253 UPON CONSOLE 7254 STOP RUN 7255 END-IF. 7256 DISPLAY "OK: Operations on empty file" 7257 CLOSE TSPFILE. 7258 7259 PERFORM LOADFILE. 7260 PERFORM LISTFILE. 7261 7262 7263 7264 *> check that multiple empty lines are handled correctly 7265 7266 7267 7268 7269 7270 7271 7272 STOP RUN. 7273 7274 LOADFILE. 7275 DISPLAY "Loading sample data file." 7276 UPON CONSOLE. 7277 7278 OPEN OUTPUT TSPFILE 7279 IF CUST-STAT NOT = "00" 7280 DISPLAY "Error " CUST-STAT 7281 " opening 'testisam' file" UPON CONSOLE 7282 STOP RUN 7283 END-IF. 7284 7285 PERFORM 1000-LOAD-RECORD 7286 VARYING SUB FROM 1 BY 1 7287 UNTIL SUB > MAX-SUB. 7288 7289 DISPLAY "Sample data file load complete." 7290 UPON CONSOLE. 7291 CLOSE TSPFILE. 7292 7293 *---------------------------------------------------------------* 7294 * LOAD A RECORD FROM DATA TABLES * 7295 *---------------------------------------------------------------* 7296 7297 1000-LOAD-RECORD. 7298 7299 MOVE SPACES TO TSPFL-RECORD. 7300 MOVE DATA-CUST-NUM (SUB) TO CM-CUST-NUM. 7301 MOVE CM-CUST-NUM TO TSPFL-KEY. 7302 MOVE DATA-COMPANY (SUB) TO CM-COMPANY. 7303 MOVE DATA-ADDRESS-1 (SUB) TO CM-ADDRESS-1. 7304 MOVE DATA-ADDRESS-2 (SUB) TO CM-ADDRESS-2. 7305 MOVE DATA-ADDRESS-3 (SUB) TO CM-ADDRESS-3. 7306 MOVE DATA-TELEPHONE (SUB) TO CM-TELEPHONE. 7307 MOVE DATA-DP-MGR (SUB) TO CM-DP-MGR. 7308 MOVE DATA-MACHINE (SUB) TO CM-MACHINE. 7309 MOVE DATA-NO-TERMINALS (SUB) TO CM-NO-TERMINALS. 7310 7311 IF ODD-RECORD 7312 MOVE "8417" TO CM-DISK 7313 MOVE "1600 BPI" TO CM-TAPE 7314 MOVE "1MEG" TO CM-MEMORY 7315 ELSE 7316 MOVE "8470" TO CM-DISK 7317 MOVE "6250 BPI" TO CM-TAPE 7318 MOVE "3MEG" TO CM-MEMORY. 7319 7320 WRITE TSPFL-RECORD. 7321 IF CUST-STAT NOT = "00" 7322 AND CUST-STAT NOT = "02" 7323 DISPLAY "Load - Key: " TSPFL-KEY ", Status: " CUST-STAT 7324 UPON CONSOLE. 7325 7326 LISTFILE. 7327 DISPLAY "LIST SAMPLE FILE" UPON CONSOLE. 7328 OPEN INPUT TSTFILE 7329 MOVE SPACES TO TSTFL-RECORD. 7330 MOVE "PRE00000" TO CM-CUST-NUM. 7331 START TSTFILE KEY GREATER THAN OR EQUAL TO TS-CUST-NUM 7332 READ TSTFILE NEXT RECORD 7333 READ TSTFILE NEXT RECORD 7334 CLOSE TSTFILE. 7335 7336 MOVE ZERO TO REC-NUM 7337 OPEN INPUT TSPFILE 7338 IF CUST-STAT NOT = "00" 7339 DISPLAY "ERROR " CUST-STAT " OPENING INPUT FILE" 7340 UPON CONSOLE 7341 STOP RUN 7342 END-IF. 7343 MOVE SPACES TO TSPFL-RECORD. 7344 MOVE "PRE00000" TO CM-CUST-NUM. 7345 START TSPFILE KEY GREATER THAN OR EQUAL TO CM-CUST-NUM 7346 READ TSPFILE NEXT RECORD 7347 READ TSPFILE NEXT RECORD 7348 7349 MOVE SPACES TO TSPFL-RECORD. 7350 MOVE "DEL00000" TO CM-CUST-NUM. 7351 START TSPFILE KEY GREATER THAN CM-CUST-NUM 7352 IF CUST-STAT NOT = "00" 7353 DISPLAY "Error " CUST-STAT " starting file" 7354 UPON CONSOLE 7355 STOP RUN 7356 END-IF. 7357 READ TSPFILE NEXT RECORD WITH NO LOCK 7358 IF CUST-STAT NOT = "00" 7359 DISPLAY "Error " CUST-STAT " on 1st read of file" 7360 UPON CONSOLE 7361 STOP RUN 7362 END-IF. 7363 PERFORM UNTIL CUST-STAT NOT = "00" 7364 OR REC-NUM > REC-MAX 7365 DISPLAY "Key: " CM-CUST-NUM " is " CM-COMPANY 7366 " Disk=" CM-DISK "." 7367 UPON CONSOLE 7368 CALL "callsub" USING CALL-NUM 7369 READ TSPFILE NEXT RECORD 7370 AT END 7371 MOVE "99" TO CUST-STAT 7372 END-READ 7373 ADD 1 TO REC-NUM 7374 END-PERFORM 7375 IF CUST-STAT = "99" 7376 DISPLAY "Hit End of File: " CALL-NUM UPON CONSOLE 7377 ELSE 7378 DISPLAY "Stop read after: " CALL-NUM UPON CONSOLE 7379 END-IF. 7380 7381 DISPLAY "LIST SAMPLE FILE DESCENDING" UPON CONSOLE. 7382 MOVE ZERO TO REC-NUM 7383 START TSPFILE KEY LESS THAN CM-CUST-NUM 7384 IF CUST-STAT NOT = "00" 7385 DISPLAY "Error " CUST-STAT " starting file" 7386 UPON CONSOLE 7387 STOP RUN 7388 END-IF. 7389 READ TSPFILE PREVIOUS RECORD WITH NO LOCK 7390 IF CUST-STAT NOT = "00" 7391 DISPLAY "Error " CUST-STAT " on 1st read of file" 7392 UPON CONSOLE 7393 STOP RUN 7394 END-IF. 7395 PERFORM UNTIL CUST-STAT NOT = "00" 7396 OR REC-NUM > REC-MAX 7397 DISPLAY "Key: " CM-CUST-NUM " is " CM-COMPANY 7398 " Disk=" CM-DISK "." 7399 UPON CONSOLE 7400 READ TSPFILE PREVIOUS RECORD 7401 AT END 7402 MOVE "99" TO CUST-STAT 7403 END-READ 7404 ADD 1 TO REC-NUM 7405 END-PERFORM. 7406 7407 CLOSE TSPFILE. 7408 7409 OPEN I-O TSPFILE. 7410 MOVE SPACES TO TSPFL-RECORD. 7411 MOVE DATA-CUST-NUM (2) TO CM-CUST-NUM. 7412 MOVE 'X' TO CM-CUST-NUM (5:1). 7413 READ TSPFILE KEY IS CM-CUST-NUM 7414 IF CUST-STAT NOT = "23" 7415 DISPLAY "Error " CUST-STAT " instead of 23." 7416 UPON CONSOLE 7417 END-IF. 7418 MOVE DATA-CUST-NUM (2) TO CM-CUST-NUM. 7419 MOVE DATA-COMPANY (2) TO CM-COMPANY. 7420 READ TSPFILE KEY IS CM-CUST-NUM 7421 IF CUST-STAT NOT = "00" 7422 DISPLAY "Error " CUST-STAT " on primary read ." 7423 UPON CONSOLE 7424 ELSE 7425 DISPLAY "Got: " CM-CUST-NUM " is " CM-COMPANY 7426 " Disk=" CM-DISK "." 7427 UPON CONSOLE 7428 END-IF. 7429 READ TSPFILE NEXT RECORD 7430 IF CUST-STAT NOT = "00" 7431 DISPLAY "Error " CUST-STAT " on next read" 7432 UPON CONSOLE 7433 ELSE 7434 DISPLAY "Nxt: " CM-CUST-NUM " is " CM-COMPANY 7435 " Disk=" CM-DISK "." 7436 UPON CONSOLE 7437 END-IF. 7438 MOVE DATA-TELEPHONE (7) TO CM-TELEPHONE. 7439 MOVE DATA-MACHINE (7) TO CM-MACHINE. 7440 READ TSPFILE KEY IS CM-TELEPHONE 7441 IF CUST-STAT NOT = "00" 7442 DISPLAY "Error " CUST-STAT " instead of 23" 7443 UPON CONSOLE 7444 ELSE 7445 DISPLAY "Ky2: " CM-CUST-NUM " is " CM-COMPANY 7446 " Mach=" CM-MACHINE "." 7447 UPON CONSOLE 7448 END-IF. 7449 WRITE TSPFL-RECORD 7450 IF CUST-STAT NOT = "22" 7451 DISPLAY "Error " CUST-STAT " instead of 22" 7452 UPON CONSOLE 7453 ELSE 7454 DISPLAY " Write: " CM-CUST-NUM " got 22 as expected" 7455 UPON CONSOLE 7456 END-IF. 7457 MOVE DATA-CUST-NUM (3) TO CM-CUST-NUM. 7458 MOVE DATA-COMPANY (3) TO CM-COMPANY. 7459 READ TSPFILE KEY IS CM-CUST-NUM 7460 DISPLAY " Read: " CM-CUST-NUM " got " 7461 CUST-STAT " as expected " 7462 CM-NO-TERMINALS " terminals" 7463 UPON CONSOLE. 7464 ADD 5 TO CM-NO-TERMINALS 7465 REWRITE TSPFL-RECORD 7466 IF CUST-STAT NOT = "00" 7467 DISPLAY "Error " CUST-STAT " instead of 00" 7468 UPON CONSOLE 7469 ELSE 7470 7471 DISPLAY "ReWrite: " CM-CUST-NUM " got " 7472 CUST-STAT " as expected " 7473 CM-NO-TERMINALS " terminals" 7474 UPON CONSOLE 7475 END-IF. 7476 MOVE DATA-CUST-NUM (2) TO CM-CUST-NUM. 7477 MOVE DATA-COMPANY (2) TO CM-COMPANY. 7478 READ TSPFILE KEY IS CM-CUST-NUM 7479 DISPLAY " Read: " CM-CUST-NUM " got " 7480 CUST-STAT " as expected " 7481 CM-NO-TERMINALS " terminals" 7482 UPON CONSOLE. 7483 MOVE DATA-CUST-NUM (3) TO CM-CUST-NUM. 7484 MOVE DATA-COMPANY (3) TO CM-COMPANY. 7485 REWRITE TSPFL-RECORD 7486 IF CUST-STAT NOT = "02" 7487 AND CUST-STAT NOT = "00" 7488 DISPLAY "Error " CUST-STAT " instead of 00/02" 7489 UPON CONSOLE 7490 ELSE 7491 DISPLAY "ReWrite: " CM-CUST-NUM " got " 7492 "00/02 as expected" 7493 UPON CONSOLE 7494 END-IF 7495 MOVE DATA-CUST-NUM (6) TO CM-CUST-NUM. 7496 MOVE DATA-COMPANY (6) TO CM-COMPANY. 7497 READ TSPFILE KEY IS CM-CUST-NUM 7498 MOVE DATA-TELEPHONE (7) TO CM-TELEPHONE. 7499 MOVE DATA-MACHINE (7) TO CM-MACHINE. 7500 REWRITE TSPFL-RECORD 7501 IF CUST-STAT NOT = "02" 7502 AND CUST-STAT NOT = "00" 7503 DISPLAY "Error " CUST-STAT " instead of 00/02" 7504 UPON CONSOLE 7505 ELSE 7506 DISPLAY "ReWrite: " CM-CUST-NUM " got " 7507 "00/02 as expected" 7508 UPON CONSOLE 7509 END-IF 7510 DELETE TSPFILE 7511 CLOSE TSPFILE. 7512 7513 LOADFLAT. 7514 OPEN OUTPUT FLATFILE. 7515 PERFORM FLAT-RECORD 7516 VARYING SUB FROM 1 BY 1 7517 UNTIL SUB > MAX-SUB 7518 OR SUB > 5. 7519 CLOSE FLATFILE. 7520 OPEN INPUT FLATFILE. 7521 MOVE 3 TO REC-NUM 7522 READ FLATFILE 7523 MOVE 999 TO REC-NUM 7524 READ FLATFILE 7525 CLOSE FLATFILE. 7526 7527 FLAT-RECORD. 7528 7529 MOVE SPACES TO TSP2-RECORD. 7530 MOVE SUB TO REC-NUM. 7531 MOVE DATA-CUST-NUM (SUB) TO C2-CUST-NUM. 7532 MOVE DATA-COMPANY (SUB) TO C2-COMPANY. 7533 MOVE DATA-NO-TERMINALS (SUB) TO C2-NO-TERMINALS. 7534 MOVE 20070319 TO C2-PK-DATE. 7535 IF ODD-RECORD 7536 MOVE "8417" TO C2-DISK 7537 ELSE 7538 MOVE "8470" TO C2-DISK. 7539 WRITE TSP2-RECORD. 7540]) 7541 7542AT_CHECK([$COMPILE -ftraceall prog.cob], [0], [], []) 7543 7544# first run without runtime tracing 7545AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 7546[OK: Operations on empty file 7547Loading sample data file. 7548Sample data file load complete. 7549LIST SAMPLE FILE 7550Key: EPS00000 is EPSILON EQUIPMENT SUPPLY Disk=8417 . 7551Key: FOR00000 is FORTUNE COOKIE COMPANY Disk=8470 . 7552Key: GAM00000 is GAMMA X-RAY TECHNOLOGY Disk=8417 . 7553Key: GIB00000 is GIBRALTER LIFE INSURANCE Disk=8417 . 7554Key: H&J00000 is H & J PLUMBING SUPPLIES Disk=8470 . 7555Key: INC00000 is INCREMENTAL BACKUP CORP. Disk=8417 . 7556Key: JOH00000 is JOHNSON BOATING SUPPLIES Disk=8417 . 7557Key: KON00000 is KONFLAB PLASTIC PRODUCTS. Disk=8417 . 7558Key: LEW00000 is LEWISTON GRAPHICS LTD. Disk=8470 . 7559Key: MOR00000 is MORNINGSIDE CARPENTRY. Disk=8470 . 7560Key: NEW00000 is NEW WAVE SURF SHOPS INC. Disk=8470 . 7561Stop read after: 11 7562LIST SAMPLE FILE DESCENDING 7563Key: NEW00000 is NEW WAVE SURF SHOPS INC. Disk=8470 . 7564Key: MOR00000 is MORNINGSIDE CARPENTRY. Disk=8470 . 7565Key: LEW00000 is LEWISTON GRAPHICS LTD. Disk=8470 . 7566Key: KON00000 is KONFLAB PLASTIC PRODUCTS. Disk=8417 . 7567Key: JOH00000 is JOHNSON BOATING SUPPLIES Disk=8417 . 7568Key: INC00000 is INCREMENTAL BACKUP CORP. Disk=8417 . 7569Key: H&J00000 is H & J PLUMBING SUPPLIES Disk=8470 . 7570Key: GIB00000 is GIBRALTER LIFE INSURANCE Disk=8417 . 7571Key: GAM00000 is GAMMA X-RAY TECHNOLOGY Disk=8417 . 7572Key: FOR00000 is FORTUNE COOKIE COMPANY Disk=8470 . 7573Key: EPS00000 is EPSILON EQUIPMENT SUPPLY Disk=8417 . 7574Got: BET00000 is BETA SHOE MFG. INC. Disk=8470 . 7575Nxt: DEL00000 is DELTA LUGGAGE REPAIRS Disk=8470 . 7576Ky2: GIB00000 is GIBRALTER LIFE INSURANCE Mach=UNI-80/6. 7577 Write: GIB00000 got 22 as expected 7578 Read: GAM00000 got 00 as expected 00075 terminals 7579ReWrite: GAM00000 got 00 as expected 00080 terminals 7580 Read: BET00000 got 00 as expected 00034 terminals 7581ReWrite: GAM00000 got 00/02 as expected 7582ReWrite: FOR00000 got 00/02 as expected 7583], []) 7584 7585# not merged yet: 7586#export COB_TRACE_IO=Y 7587#export IO_TSPFILE=trace 7588#export IO_TSTFILE=no-trace 7589 7590AT_CHECK([COB_TRACE_FILE=trace.txt \ 7591COB_SET_TRACE=Y \ 7592COB_TRACE_FORMAT="Line: %L %S" \ 7593$COBCRUN_DIRECT ./prog], [0], 7594[OK: Operations on empty file 7595Loading sample data file. 7596Sample data file load complete. 7597LIST SAMPLE FILE 7598Key: EPS00000 is EPSILON EQUIPMENT SUPPLY Disk=8417 . 7599Key: FOR00000 is FORTUNE COOKIE COMPANY Disk=8470 . 7600Key: GAM00000 is GAMMA X-RAY TECHNOLOGY Disk=8417 . 7601Key: GIB00000 is GIBRALTER LIFE INSURANCE Disk=8417 . 7602Key: H&J00000 is H & J PLUMBING SUPPLIES Disk=8470 . 7603Key: INC00000 is INCREMENTAL BACKUP CORP. Disk=8417 . 7604Key: JOH00000 is JOHNSON BOATING SUPPLIES Disk=8417 . 7605Key: KON00000 is KONFLAB PLASTIC PRODUCTS. Disk=8417 . 7606Key: LEW00000 is LEWISTON GRAPHICS LTD. Disk=8470 . 7607Key: MOR00000 is MORNINGSIDE CARPENTRY. Disk=8470 . 7608Key: NEW00000 is NEW WAVE SURF SHOPS INC. Disk=8470 . 7609Stop read after: 11 7610LIST SAMPLE FILE DESCENDING 7611Key: NEW00000 is NEW WAVE SURF SHOPS INC. Disk=8470 . 7612Key: MOR00000 is MORNINGSIDE CARPENTRY. Disk=8470 . 7613Key: LEW00000 is LEWISTON GRAPHICS LTD. Disk=8470 . 7614Key: KON00000 is KONFLAB PLASTIC PRODUCTS. Disk=8417 . 7615Key: JOH00000 is JOHNSON BOATING SUPPLIES Disk=8417 . 7616Key: INC00000 is INCREMENTAL BACKUP CORP. Disk=8417 . 7617Key: H&J00000 is H & J PLUMBING SUPPLIES Disk=8470 . 7618Key: GIB00000 is GIBRALTER LIFE INSURANCE Disk=8417 . 7619Key: GAM00000 is GAMMA X-RAY TECHNOLOGY Disk=8417 . 7620Key: FOR00000 is FORTUNE COOKIE COMPANY Disk=8470 . 7621Key: EPS00000 is EPSILON EQUIPMENT SUPPLY Disk=8417 . 7622Got: BET00000 is BETA SHOE MFG. INC. Disk=8470 . 7623Nxt: DEL00000 is DELTA LUGGAGE REPAIRS Disk=8470 . 7624Ky2: GIB00000 is GIBRALTER LIFE INSURANCE Mach=UNI-80/6. 7625 Write: GIB00000 got 22 as expected 7626 Read: GAM00000 got 00 as expected 00075 terminals 7627ReWrite: GAM00000 got 00 as expected 00080 terminals 7628 Read: BET00000 got 00 as expected 00034 terminals 7629ReWrite: GAM00000 got 00/02 as expected 7630ReWrite: FOR00000 got 00/02 as expected 7631], []) 7632 7633 7634AT_CAPTURE_FILE(./trace.txt) 7635 7636# variant with file trace: 7637#AT_DATA([reference], 7638#[Source: 'prog.cob' 7639#Program-Id: prog 7640#Line: 292 Entry: prog 7641#Line: 292 Paragraph: MAINFILE 7642#Line: 293 OPEN 7643# OPEN OUTPUT TSPFILE -> 'testisam' Status: 00 7644#Line: 294 CLOSE 7645# CLOSE TSPFILE Status: 00 7646#Line: 296 OPEN 7647# OPEN I_O TSPFILE -> 'testisam' Status: 00 7648#Line: 297 MOVE 7649#Line: 298 READ 7650# READ Sequential TSPFILE Status: 10 7651#Line: 299 IF 7652#Line: 304 MOVE 7653#Line: 305 START 7654# START TSPFILE Status: 23 7655# Key : ALL LOW-VALUES 7656#Line: 306 IF 7657#Line: 311 READ 7658# READ Sequential TSPFILE Status: 46 7659#Line: 312 IF 7660#Line: 317 DISPLAY 7661#Line: 318 CLOSE 7662# CLOSE TSPFILE Status: 00 7663#Line: 320 PERFORM 7664#Line: 335 Paragraph: LOADFILE 7665#Line: 336 DISPLAY 7666#Line: 339 OPEN 7667# OPEN OUTPUT TSPFILE -> 'testisam' Status: 00 7668#Line: 340 IF 7669#Line: 346 PERFORM 7670#Line: 358 Paragraph: 1000-LOAD-RECORD 7671#Line: 360 MOVE 7672#Line: 361 MOVE 7673#Line: 362 MOVE 7674#Line: 363 MOVE 7675#Line: 364 MOVE 7676#Line: 365 MOVE 7677#Line: 366 MOVE 7678#Line: 367 MOVE 7679#Line: 368 MOVE 7680#Line: 369 MOVE 7681#Line: 370 MOVE 7682#Line: 372 IF 7683#Line: 373 MOVE 7684#Line: 374 MOVE 7685#Line: 375 MOVE 7686#Line: 381 WRITE 7687# WRITE TSPFILE Status: 00 7688# Record : 'ALP00000 ALPHA ELECTRICAL CO. LTD.123 MAIN STREET NEW YORK ' 7689# ' N.Y. 3131234432MR. DAVE HARRIS UNI-90301MEG8417' 7690# ' 1600 BPI00085' 7691#Line: 382 IF 7692#Line: 358 Paragraph: 1000-LOAD-RECORD 7693#Line: 360 MOVE 7694#Line: 361 MOVE 7695#Line: 362 MOVE 7696#Line: 363 MOVE 7697#Line: 364 MOVE 7698#Line: 365 MOVE 7699#Line: 366 MOVE 7700#Line: 367 MOVE 7701#Line: 368 MOVE 7702#Line: 369 MOVE 7703#Line: 370 MOVE 7704#Line: 372 IF 7705#Line: 377 MOVE 7706#Line: 378 MOVE 7707#Line: 379 MOVE 7708#Line: 381 WRITE 7709# WRITE TSPFILE Status: 00 7710# Record : 'BET00000 BETA SHOE MFG. INC. 1090 2ND AVE. WEST ATLANTA ' 7711# ' GEORGIA 4082938498MS. JANICE SILCOX UNI-90403MEG8470' 7712# ' 6250 BPI00034' 7713#Line: 382 IF 7714#Line: 358 Paragraph: 1000-LOAD-RECORD 7715#Line: 360 MOVE 7716#Line: 361 MOVE 7717#Line: 362 MOVE 7718#Line: 363 MOVE 7719#Line: 364 MOVE 7720#Line: 365 MOVE 7721#Line: 366 MOVE 7722#Line: 367 MOVE 7723#Line: 368 MOVE 7724#Line: 369 MOVE 7725#Line: 370 MOVE 7726#Line: 372 IF 7727#Line: 373 MOVE 7728#Line: 374 MOVE 7729#Line: 375 MOVE 7730#Line: 381 WRITE 7731# WRITE TSPFILE Status: 02 7732# Record : 'GAM00000 GAMMA X-RAY TECHNOLOGY 1401 JEFFERSON BLVD. WASHINGTON ' 7733# ' D.C. 8372487274MR. ALLAN JONES UNI-80/31MEG8417' 7734# ' 1600 BPI00075' 7735#Line: 382 IF 7736#Line: 358 Paragraph: 1000-LOAD-RECORD 7737#Line: 360 MOVE 7738#Line: 361 MOVE 7739#Line: 362 MOVE 7740#Line: 363 MOVE 7741#Line: 364 MOVE 7742#Line: 365 MOVE 7743#Line: 366 MOVE 7744#Line: 367 MOVE 7745#Line: 368 MOVE 7746#Line: 369 MOVE 7747#Line: 370 MOVE 7748#Line: 372 IF 7749#Line: 377 MOVE 7750#Line: 378 MOVE 7751#Line: 379 MOVE 7752#Line: 381 WRITE 7753# WRITE TSPFILE Status: 02 7754# Record : 'DEL00000 DELTA LUGGAGE REPAIRS 1620 ARIZONA WAY TORONTO ' 7755# ' CANADA 4169898509MR. PETER MACKAY UNI-80/53MEG8470' 7756# ' 6250 BPI00045' 7757#Line: 382 IF 7758#Line: 358 Paragraph: 1000-LOAD-RECORD 7759#Line: 360 MOVE 7760#Line: 361 MOVE 7761#Line: 362 MOVE 7762#Line: 363 MOVE 7763#Line: 364 MOVE 7764#Line: 365 MOVE 7765#Line: 366 MOVE 7766#Line: 367 MOVE 7767#Line: 368 MOVE 7768#Line: 369 MOVE 7769#Line: 370 MOVE 7770#Line: 372 IF 7771#Line: 373 MOVE 7772#Line: 374 MOVE 7773#Line: 375 MOVE 7774#Line: 381 WRITE 7775# WRITE TSPFILE Status: 02 7776# Record : 'EPS00000 EPSILON EQUIPMENT SUPPLY 1184 EAST FIRST STREET CALGARY ' 7777# ' CANADA 5292398745MRS. DONNA BREWER UNI-80/61MEG8417' 7778# ' 1600 BPI00090' 7779#Line: 382 IF 7780#Line: 358 Paragraph: 1000-LOAD-RECORD 7781#Line: 360 MOVE 7782#Line: 361 MOVE 7783#Line: 362 MOVE 7784#Line: 363 MOVE 7785#Line: 364 MOVE 7786#Line: 365 MOVE 7787#Line: 366 MOVE 7788#Line: 367 MOVE 7789#Line: 368 MOVE 7790#Line: 369 MOVE 7791#Line: 370 MOVE 7792#Line: 372 IF 7793#Line: 377 MOVE 7794#Line: 378 MOVE 7795#Line: 379 MOVE 7796#Line: 381 WRITE 7797# WRITE TSPFILE Status: 02 7798# Record : 'FOR00000 FORTUNE COOKIE COMPANY 114 JOHN F. KENNEDY AVE. SAN DIEGO ' 7799# ' CALIFORNIA 8009329492MR. MICHAEL SMYTHE UNI-80/63MEG8470' 7800# ' 6250 BPI00107' 7801#Line: 382 IF 7802#Line: 358 Paragraph: 1000-LOAD-RECORD 7803#Line: 360 MOVE 7804#Line: 361 MOVE 7805#Line: 362 MOVE 7806#Line: 363 MOVE 7807#Line: 364 MOVE 7808#Line: 365 MOVE 7809#Line: 366 MOVE 7810#Line: 367 MOVE 7811#Line: 368 MOVE 7812#Line: 369 MOVE 7813#Line: 370 MOVE 7814#Line: 372 IF 7815#Line: 373 MOVE 7816#Line: 374 MOVE 7817#Line: 375 MOVE 7818#Line: 381 WRITE 7819# WRITE TSPFILE Status: 02 7820# Record : 'GIB00000 GIBRALTER LIFE INSURANCE 650 LIBERTY CRESCENT LOS RIOS ' 7821# ' NEW MEXICO 6456445643MR. D.A. MORRISON UNI-80/61MEG8417' 7822# ' 1600 BPI00067' 7823#Line: 382 IF 7824#Line: 358 Paragraph: 1000-LOAD-RECORD 7825#Line: 360 MOVE 7826#Line: 361 MOVE 7827#Line: 362 MOVE 7828#Line: 363 MOVE 7829#Line: 364 MOVE 7830#Line: 365 MOVE 7831#Line: 366 MOVE 7832#Line: 367 MOVE 7833#Line: 368 MOVE 7834#Line: 369 MOVE 7835#Line: 370 MOVE 7836#Line: 372 IF 7837#Line: 377 MOVE 7838#Line: 378 MOVE 7839#Line: 379 MOVE 7840#Line: 381 WRITE 7841# WRITE TSPFILE Status: 02 7842# Record : 'H&J00000 H & J PLUMBING SUPPLIES 77 SUNSET BLVD. MADISON ' 7843# ' WISCONSIN 6546456333MR. BRIAN PATTERSON UNI-80/83MEG8470' 7844# ' 6250 BPI00032' 7845#Line: 382 IF 7846#Line: 358 Paragraph: 1000-LOAD-RECORD 7847#Line: 360 MOVE 7848#Line: 361 MOVE 7849#Line: 362 MOVE 7850#Line: 363 MOVE 7851#Line: 364 MOVE 7852#Line: 365 MOVE 7853#Line: 366 MOVE 7854#Line: 367 MOVE 7855#Line: 368 MOVE 7856#Line: 369 MOVE 7857#Line: 370 MOVE 7858#Line: 372 IF 7859#Line: 373 MOVE 7860#Line: 374 MOVE 7861#Line: 375 MOVE 7862#Line: 381 WRITE 7863# WRITE TSPFILE Status: 02 7864# Record : 'INC00000 INCREMENTAL BACKUP CORP. 10908 SANTA MONICA BLVD. WILBUR ' 7865# ' DELAWARE 3455445444MR. DARRYL TOWNSEND UNI-80/81MEG8417' 7866# ' 1600 BPI00016' 7867#Line: 382 IF 7868#Line: 358 Paragraph: 1000-LOAD-RECORD 7869#Line: 360 MOVE 7870#Line: 361 MOVE 7871#Line: 362 MOVE 7872#Line: 363 MOVE 7873#Line: 364 MOVE 7874#Line: 365 MOVE 7875#Line: 366 MOVE 7876#Line: 367 MOVE 7877#Line: 368 MOVE 7878#Line: 369 MOVE 7879#Line: 370 MOVE 7880#Line: 372 IF 7881#Line: 373 MOVE 7882#Line: 374 MOVE 7883#Line: 375 MOVE 7884#Line: 381 WRITE 7885# WRITE TSPFILE Status: 02 7886# Record : 'JOH00000 JOHNSON BOATING SUPPLIES 1134 PARIS ROAD TOPEKA ' 7887# ' KANSAS 6456445643MS. VALERIE HARPER UNI-80/81MEG8417' 7888# ' 1600 BPI00034' 7889#Line: 382 IF 7890#Line: 358 Paragraph: 1000-LOAD-RECORD 7891#Line: 360 MOVE 7892#Line: 361 MOVE 7893#Line: 362 MOVE 7894#Line: 363 MOVE 7895#Line: 364 MOVE 7896#Line: 365 MOVE 7897#Line: 366 MOVE 7898#Line: 367 MOVE 7899#Line: 368 MOVE 7900#Line: 369 MOVE 7901#Line: 370 MOVE 7902#Line: 372 IF 7903#Line: 373 MOVE 7904#Line: 374 MOVE 7905#Line: 375 MOVE 7906#Line: 381 WRITE 7907# WRITE TSPFILE Status: 02 7908# Record : 'KON00000 KONFLAB PLASTIC PRODUCTS.808 NORTHWEST MAIN ST. SEATTLE ' 7909# ' WASHINGTON 7456434355MR. FRED MILLER UNI-80/81MEG8417' 7910# ' 1600 BPI00128' 7911#Line: 382 IF 7912#Line: 358 Paragraph: 1000-LOAD-RECORD 7913#Line: 360 MOVE 7914#Line: 361 MOVE 7915#Line: 362 MOVE 7916#Line: 363 MOVE 7917#Line: 364 MOVE 7918#Line: 365 MOVE 7919#Line: 366 MOVE 7920#Line: 367 MOVE 7921#Line: 368 MOVE 7922#Line: 369 MOVE 7923#Line: 370 MOVE 7924#Line: 372 IF 7925#Line: 377 MOVE 7926#Line: 378 MOVE 7927#Line: 379 MOVE 7928#Line: 381 WRITE 7929# WRITE TSPFILE Status: 02 7930# Record : 'LEW00000 LEWISTON GRAPHICS LTD. 9904 QUEEN STREET NEW JERSEY ' 7931# ' N.J. 6554456433MR. DONALD FISCHER UNI-80/83MEG8470' 7932# ' 6250 BPI00064' 7933#Line: 382 IF 7934#Line: 358 Paragraph: 1000-LOAD-RECORD 7935#Line: 360 MOVE 7936#Line: 361 MOVE 7937#Line: 362 MOVE 7938#Line: 363 MOVE 7939#Line: 364 MOVE 7940#Line: 365 MOVE 7941#Line: 366 MOVE 7942#Line: 367 MOVE 7943#Line: 368 MOVE 7944#Line: 369 MOVE 7945#Line: 370 MOVE 7946#Line: 372 IF 7947#Line: 377 MOVE 7948#Line: 378 MOVE 7949#Line: 379 MOVE 7950#Line: 381 WRITE 7951# WRITE TSPFILE Status: 02 7952# Record : 'MOR00000 MORNINGSIDE CARPENTRY. 1709 DUNDAS CRESCENT W. FORT WAYNE ' 7953# ' COLORADO 4169898509MR. STEVEN YOURDIN UNI-80/83MEG8470' 7954# ' 6250 BPI00110' 7955#Line: 382 IF 7956#Line: 358 Paragraph: 1000-LOAD-RECORD 7957#Line: 360 MOVE 7958#Line: 361 MOVE 7959#Line: 362 MOVE 7960#Line: 363 MOVE 7961#Line: 364 MOVE 7962#Line: 365 MOVE 7963#Line: 366 MOVE 7964#Line: 367 MOVE 7965#Line: 368 MOVE 7966#Line: 369 MOVE 7967#Line: 370 MOVE 7968#Line: 372 IF 7969#Line: 377 MOVE 7970#Line: 378 MOVE 7971#Line: 379 MOVE 7972#Line: 381 WRITE 7973# WRITE TSPFILE Status: 02 7974# Record : 'NEW00000 NEW WAVE SURF SHOPS INC. 3240 MARIS AVENUE COLUMBUS ' 7975# ' OHIO 7534587453MS. Goldie Hawn UNI-80/83MEG8470' 7976# ' 6250 BPI00324' 7977#Line: 382 IF 7978#Line: 358 Paragraph: 1000-LOAD-RECORD 7979#Line: 360 MOVE 7980#Line: 361 MOVE 7981#Line: 362 MOVE 7982#Line: 363 MOVE 7983#Line: 364 MOVE 7984#Line: 365 MOVE 7985#Line: 366 MOVE 7986#Line: 367 MOVE 7987#Line: 368 MOVE 7988#Line: 369 MOVE 7989#Line: 370 MOVE 7990#Line: 372 IF 7991#Line: 377 MOVE 7992#Line: 378 MOVE 7993#Line: 379 MOVE 7994#Line: 381 WRITE 7995# WRITE TSPFILE Status: 02 7996# Record : 'OLD00000 OLD TYME PIZZA MFG. CO. 1705 WISCONSIN ROAD RICHMOND ' 7997# ' VIRGINIA 8787458374MS. ALICE WINSTON UNI-90403MEG8470' 7998# ' 6250 BPI00124' 7999#Line: 382 IF 8000#Line: 358 Paragraph: 1000-LOAD-RECORD 8001#Line: 360 MOVE 8002#Line: 361 MOVE 8003#Line: 362 MOVE 8004#Line: 363 MOVE 8005#Line: 364 MOVE 8006#Line: 365 MOVE 8007#Line: 366 MOVE 8008#Line: 367 MOVE 8009#Line: 368 MOVE 8010#Line: 369 MOVE 8011#Line: 370 MOVE 8012#Line: 372 IF 8013#Line: 377 MOVE 8014#Line: 378 MOVE 8015#Line: 379 MOVE 8016#Line: 381 WRITE 8017# WRITE TSPFILE Status: 02 8018# Record : 'PRE00000 PRESTIGE OFFICE FURNITURE114A MAPLE GROVE WHITEPLAIN ' 8019# ' N.Y. 4169898509MR. THOMAS JEFFERSON UNI-90403MEG8470' 8020# ' 6250 BPI00086' 8021#Line: 382 IF 8022#Line: 350 DISPLAY 8023#Line: 352 CLOSE 8024# CLOSE TSPFILE Status: 00 8025#Line: 321 PERFORM 8026#Line: 387 Paragraph: LISTFILE 8027#Line: 388 DISPLAY 8028#Line: 389 OPEN 8029#Line: 390 MOVE 8030#Line: 391 MOVE 8031#Line: 392 START 8032#Line: 393 READ 8033#Line: 394 READ 8034#Line: 395 CLOSE 8035#Line: 397 MOVE 8036#Line: 398 OPEN 8037# OPEN INPUT TSPFILE -> 'testisam' Status: 00 8038#Line: 399 IF 8039#Line: 404 MOVE 8040#Line: 405 MOVE 8041#Line: 406 START 8042# START TSPFILE Status: 00 8043# Key : 'PRE00000' 8044#Line: 407 READ 8045# READ Sequential TSPFILE Status: 00 8046# Record : 'PRE00000 PRESTIGE OFFICE FURNITURE114A MAPLE GROVE WHITEPLAIN ' 8047# ' N.Y. 4169898509MR. THOMAS JEFFERSON UNI-90403MEG8470' 8048# ' 6250 BPI00086' 8049#Line: 408 READ 8050# READ Sequential TSPFILE Status: 10 8051#Line: 410 MOVE 8052#Line: 411 MOVE 8053#Line: 412 START 8054# START TSPFILE Status: 00 8055# Key : 'DEL00000' 8056#Line: 413 IF 8057#Line: 418 READ 8058# READ Sequential TSPFILE Status: 00 8059# Record : 'EPS00000 EPSILON EQUIPMENT SUPPLY 1184 EAST FIRST STREET CALGARY ' 8060# ' CANADA 5292398745MRS. DONNA BREWER UNI-80/61MEG8417' 8061# ' 1600 BPI00090' 8062#Line: 419 IF 8063#Line: 424 PERFORM 8064#Line: 426 DISPLAY 8065#Line: 429 CALL 8066#Line: 430 READ 8067# READ Sequential TSPFILE Status: 00 8068# Record : 'FOR00000 FORTUNE COOKIE COMPANY 114 JOHN F. KENNEDY AVE. SAN DIEGO ' 8069# ' CALIFORNIA 8009329492MR. MICHAEL SMYTHE UNI-80/63MEG8470' 8070# ' 6250 BPI00107' 8071#Line: 434 ADD 8072#Line: 426 DISPLAY 8073#Line: 429 CALL 8074#Line: 430 READ 8075# READ Sequential TSPFILE Status: 00 8076# Record : 'GAM00000 GAMMA X-RAY TECHNOLOGY 1401 JEFFERSON BLVD. WASHINGTON ' 8077# ' D.C. 8372487274MR. ALLAN JONES UNI-80/31MEG8417' 8078# ' 1600 BPI00075' 8079#Line: 434 ADD 8080#Line: 426 DISPLAY 8081#Line: 429 CALL 8082#Line: 430 READ 8083# READ Sequential TSPFILE Status: 00 8084# Record : 'GIB00000 GIBRALTER LIFE INSURANCE 650 LIBERTY CRESCENT LOS RIOS ' 8085# ' NEW MEXICO 6456445643MR. D.A. MORRISON UNI-80/61MEG8417' 8086# ' 1600 BPI00067' 8087#Line: 434 ADD 8088#Line: 426 DISPLAY 8089#Line: 429 CALL 8090#Line: 430 READ 8091# READ Sequential TSPFILE Status: 00 8092# Record : 'H&J00000 H & J PLUMBING SUPPLIES 77 SUNSET BLVD. MADISON ' 8093# ' WISCONSIN 6546456333MR. BRIAN PATTERSON UNI-80/83MEG8470' 8094# ' 6250 BPI00032' 8095#Line: 434 ADD 8096#Line: 426 DISPLAY 8097#Line: 429 CALL 8098#Line: 430 READ 8099# READ Sequential TSPFILE Status: 00 8100# Record : 'INC00000 INCREMENTAL BACKUP CORP. 10908 SANTA MONICA BLVD. WILBUR ' 8101# ' DELAWARE 3455445444MR. DARRYL TOWNSEND UNI-80/81MEG8417' 8102# ' 1600 BPI00016' 8103#Line: 434 ADD 8104#Line: 426 DISPLAY 8105#Line: 429 CALL 8106#Line: 430 READ 8107# READ Sequential TSPFILE Status: 00 8108# Record : 'JOH00000 JOHNSON BOATING SUPPLIES 1134 PARIS ROAD TOPEKA ' 8109# ' KANSAS 6456445643MS. VALERIE HARPER UNI-80/81MEG8417' 8110# ' 1600 BPI00034' 8111#Line: 434 ADD 8112#Line: 426 DISPLAY 8113#Line: 429 CALL 8114#Line: 430 READ 8115# READ Sequential TSPFILE Status: 00 8116# Record : 'KON00000 KONFLAB PLASTIC PRODUCTS.808 NORTHWEST MAIN ST. SEATTLE ' 8117# ' WASHINGTON 7456434355MR. FRED MILLER UNI-80/81MEG8417' 8118# ' 1600 BPI00128' 8119#Line: 434 ADD 8120#Line: 426 DISPLAY 8121#Line: 429 CALL 8122#Line: 430 READ 8123# READ Sequential TSPFILE Status: 00 8124# Record : 'LEW00000 LEWISTON GRAPHICS LTD. 9904 QUEEN STREET NEW JERSEY ' 8125# ' N.J. 6554456433MR. DONALD FISCHER UNI-80/83MEG8470' 8126# ' 6250 BPI00064' 8127#Line: 434 ADD 8128#Line: 426 DISPLAY 8129#Line: 429 CALL 8130#Line: 430 READ 8131# READ Sequential TSPFILE Status: 00 8132# Record : 'MOR00000 MORNINGSIDE CARPENTRY. 1709 DUNDAS CRESCENT W. FORT WAYNE ' 8133# ' COLORADO 4169898509MR. STEVEN YOURDIN UNI-80/83MEG8470' 8134# ' 6250 BPI00110' 8135#Line: 434 ADD 8136#Line: 426 DISPLAY 8137#Line: 429 CALL 8138#Line: 430 READ 8139# READ Sequential TSPFILE Status: 00 8140# Record : 'NEW00000 NEW WAVE SURF SHOPS INC. 3240 MARIS AVENUE COLUMBUS ' 8141# ' OHIO 7534587453MS. Goldie Hawn UNI-80/83MEG8470' 8142# ' 6250 BPI00324' 8143#Line: 434 ADD 8144#Line: 426 DISPLAY 8145#Line: 429 CALL 8146#Line: 430 READ 8147# READ Sequential TSPFILE Status: 00 8148# Record : 'OLD00000 OLD TYME PIZZA MFG. CO. 1705 WISCONSIN ROAD RICHMOND ' 8149# ' VIRGINIA 8787458374MS. ALICE WINSTON UNI-90403MEG8470' 8150# ' 6250 BPI00124' 8151#Line: 434 ADD 8152#Line: 436 IF 8153#Line: 439 DISPLAY 8154#Line: 442 DISPLAY 8155#Line: 443 MOVE 8156#Line: 444 START 8157# START TSPFILE Status: 00 8158# Key : 'OLD00000' 8159#Line: 445 IF 8160#Line: 450 READ 8161# READ Sequential TSPFILE Status: 00 8162# Record : 'NEW00000 NEW WAVE SURF SHOPS INC. 3240 MARIS AVENUE COLUMBUS ' 8163# ' OHIO 7534587453MS. Goldie Hawn UNI-80/83MEG8470' 8164# ' 6250 BPI00324' 8165#Line: 451 IF 8166#Line: 456 PERFORM 8167#Line: 458 DISPLAY 8168#Line: 461 READ 8169# READ Sequential TSPFILE Status: 00 8170# Record : 'MOR00000 MORNINGSIDE CARPENTRY. 1709 DUNDAS CRESCENT W. FORT WAYNE ' 8171# ' COLORADO 4169898509MR. STEVEN YOURDIN UNI-80/83MEG8470' 8172# ' 6250 BPI00110' 8173#Line: 465 ADD 8174#Line: 458 DISPLAY 8175#Line: 461 READ 8176# READ Sequential TSPFILE Status: 00 8177# Record : 'LEW00000 LEWISTON GRAPHICS LTD. 9904 QUEEN STREET NEW JERSEY ' 8178# ' N.J. 6554456433MR. DONALD FISCHER UNI-80/83MEG8470' 8179# ' 6250 BPI00064' 8180#Line: 465 ADD 8181#Line: 458 DISPLAY 8182#Line: 461 READ 8183# READ Sequential TSPFILE Status: 00 8184# Record : 'KON00000 KONFLAB PLASTIC PRODUCTS.808 NORTHWEST MAIN ST. SEATTLE ' 8185# ' WASHINGTON 7456434355MR. FRED MILLER UNI-80/81MEG8417' 8186# ' 1600 BPI00128' 8187#Line: 465 ADD 8188#Line: 458 DISPLAY 8189#Line: 461 READ 8190# READ Sequential TSPFILE Status: 00 8191# Record : 'JOH00000 JOHNSON BOATING SUPPLIES 1134 PARIS ROAD TOPEKA ' 8192# ' KANSAS 6456445643MS. VALERIE HARPER UNI-80/81MEG8417' 8193# ' 1600 BPI00034' 8194#Line: 465 ADD 8195#Line: 458 DISPLAY 8196#Line: 461 READ 8197# READ Sequential TSPFILE Status: 00 8198# Record : 'INC00000 INCREMENTAL BACKUP CORP. 10908 SANTA MONICA BLVD. WILBUR ' 8199# ' DELAWARE 3455445444MR. DARRYL TOWNSEND UNI-80/81MEG8417' 8200# ' 1600 BPI00016' 8201#Line: 465 ADD 8202#Line: 458 DISPLAY 8203#Line: 461 READ 8204# READ Sequential TSPFILE Status: 00 8205# Record : 'H&J00000 H & J PLUMBING SUPPLIES 77 SUNSET BLVD. MADISON ' 8206# ' WISCONSIN 6546456333MR. BRIAN PATTERSON UNI-80/83MEG8470' 8207# ' 6250 BPI00032' 8208#Line: 465 ADD 8209#Line: 458 DISPLAY 8210#Line: 461 READ 8211# READ Sequential TSPFILE Status: 00 8212# Record : 'GIB00000 GIBRALTER LIFE INSURANCE 650 LIBERTY CRESCENT LOS RIOS ' 8213# ' NEW MEXICO 6456445643MR. D.A. MORRISON UNI-80/61MEG8417' 8214# ' 1600 BPI00067' 8215#Line: 465 ADD 8216#Line: 458 DISPLAY 8217#Line: 461 READ 8218# READ Sequential TSPFILE Status: 00 8219# Record : 'GAM00000 GAMMA X-RAY TECHNOLOGY 1401 JEFFERSON BLVD. WASHINGTON ' 8220# ' D.C. 8372487274MR. ALLAN JONES UNI-80/31MEG8417' 8221# ' 1600 BPI00075' 8222#Line: 465 ADD 8223#Line: 458 DISPLAY 8224#Line: 461 READ 8225# READ Sequential TSPFILE Status: 00 8226# Record : 'FOR00000 FORTUNE COOKIE COMPANY 114 JOHN F. KENNEDY AVE. SAN DIEGO ' 8227# ' CALIFORNIA 8009329492MR. MICHAEL SMYTHE UNI-80/63MEG8470' 8228# ' 6250 BPI00107' 8229#Line: 465 ADD 8230#Line: 458 DISPLAY 8231#Line: 461 READ 8232# READ Sequential TSPFILE Status: 00 8233# Record : 'EPS00000 EPSILON EQUIPMENT SUPPLY 1184 EAST FIRST STREET CALGARY ' 8234# ' CANADA 5292398745MRS. DONNA BREWER UNI-80/61MEG8417' 8235# ' 1600 BPI00090' 8236#Line: 465 ADD 8237#Line: 458 DISPLAY 8238#Line: 461 READ 8239# READ Sequential TSPFILE Status: 00 8240# Record : 'DEL00000 DELTA LUGGAGE REPAIRS 1620 ARIZONA WAY TORONTO ' 8241# ' CANADA 4169898509MR. PETER MACKAY UNI-80/53MEG8470' 8242# ' 6250 BPI00045' 8243#Line: 465 ADD 8244#Line: 468 CLOSE 8245# CLOSE TSPFILE Status: 00 8246#Line: 470 OPEN 8247# OPEN I_O TSPFILE -> 'testisam' Status: 00 8248#Line: 471 MOVE 8249#Line: 472 MOVE 8250#Line: 473 MOVE 8251#Line: 474 READ 8252# READ TSPFILE Status: 23 8253# Key : 'BET0X000' 8254#Line: 475 IF 8255#Line: 479 MOVE 8256#Line: 480 MOVE 8257#Line: 481 READ 8258# READ TSPFILE Status: 00 8259# Record : 'BET00000 BETA SHOE MFG. INC. 1090 2ND AVE. WEST ATLANTA ' 8260# ' GEORGIA 4082938498MS. JANICE SILCOX UNI-90403MEG8470' 8261# ' 6250 BPI00034' 8262# Key : 'BET00000' 8263#Line: 482 IF 8264#Line: 486 DISPLAY 8265#Line: 490 READ 8266# READ Sequential TSPFILE Status: 00 8267# Record : 'DEL00000 DELTA LUGGAGE REPAIRS 1620 ARIZONA WAY TORONTO ' 8268# ' CANADA 4169898509MR. PETER MACKAY UNI-80/53MEG8470' 8269# ' 6250 BPI00045' 8270#Line: 491 IF 8271#Line: 495 DISPLAY 8272#Line: 499 MOVE 8273#Line: 500 MOVE 8274#Line: 501 READ 8275# READ TSPFILE Status: 00 8276# Record : 'GIB00000 GIBRALTER LIFE INSURANCE 650 LIBERTY CRESCENT LOS RIOS ' 8277# ' NEW MEXICO 6456445643MR. D.A. MORRISON UNI-80/61MEG8417' 8278# ' 1600 BPI00067' 8279# Key : 6456445643 8280#Line: 502 IF 8281#Line: 506 DISPLAY 8282#Line: 510 WRITE 8283# WRITE TSPFILE Status: 22 8284# Record : 'GIB00000 GIBRALTER LIFE INSURANCE 650 LIBERTY CRESCENT LOS RIOS ' 8285# ' NEW MEXICO 6456445643MR. D.A. MORRISON UNI-80/61MEG8417' 8286# ' 1600 BPI00067' 8287#Line: 511 IF 8288#Line: 515 DISPLAY 8289#Line: 518 MOVE 8290#Line: 519 MOVE 8291#Line: 520 READ 8292# READ TSPFILE Status: 00 8293# Record : 'GAM00000 GAMMA X-RAY TECHNOLOGY 1401 JEFFERSON BLVD. WASHINGTON ' 8294# ' D.C. 8372487274MR. ALLAN JONES UNI-80/31MEG8417' 8295# ' 1600 BPI00075' 8296# Key : 'GAM00000' 8297#Line: 521 DISPLAY 8298#Line: 525 ADD 8299#Line: 526 REWRITE 8300# REWRITE TSPFILE Status: 00 8301# Record : 'GAM00000 GAMMA X-RAY TECHNOLOGY 1401 JEFFERSON BLVD. WASHINGTON ' 8302# ' D.C. 8372487274MR. ALLAN JONES UNI-80/31MEG8417' 8303# ' 1600 BPI00080' 8304#Line: 527 IF 8305#Line: 532 DISPLAY 8306#Line: 537 MOVE 8307#Line: 538 MOVE 8308#Line: 539 READ 8309# READ TSPFILE Status: 00 8310# Record : 'BET00000 BETA SHOE MFG. INC. 1090 2ND AVE. WEST ATLANTA ' 8311# ' GEORGIA 4082938498MS. JANICE SILCOX UNI-90403MEG8470' 8312# ' 6250 BPI00034' 8313# Key : 'BET00000' 8314#Line: 540 DISPLAY 8315#Line: 544 MOVE 8316#Line: 545 MOVE 8317#Line: 546 REWRITE 8318# REWRITE TSPFILE Status: 02 8319# Record : 'GAM00000 GAMMA X-RAY TECHNOLOGY 1090 2ND AVE. WEST ATLANTA ' 8320# ' GEORGIA 4082938498MS. JANICE SILCOX UNI-90403MEG8470' 8321# ' 6250 BPI00034' 8322#Line: 547 IF 8323#Line: 552 DISPLAY 8324#Line: 556 MOVE 8325#Line: 557 MOVE 8326#Line: 558 READ 8327# READ TSPFILE Status: 00 8328# Record : 'FOR00000 FORTUNE COOKIE COMPANY 114 JOHN F. KENNEDY AVE. SAN DIEGO ' 8329# ' CALIFORNIA 8009329492MR. MICHAEL SMYTHE UNI-80/63MEG8470' 8330# ' 6250 BPI00107' 8331# Key : 'FOR00000' 8332#Line: 559 MOVE 8333#Line: 560 MOVE 8334#Line: 561 REWRITE 8335# REWRITE TSPFILE Status: 02 8336# Record : 'FOR00000 FORTUNE COOKIE COMPANY 114 JOHN F. KENNEDY AVE. SAN DIEGO ' 8337# ' CALIFORNIA 6456445643MR. MICHAEL SMYTHE UNI-80/63MEG8470' 8338# ' 6250 BPI00107' 8339#Line: 562 IF 8340#Line: 567 DISPLAY 8341#Line: 571 DELETE 8342# DELETE TSPFILE Status: 00 8343# Record : 'FOR00000 FORTUNE COOKIE COMPANY 114 JOHN F. KENNEDY AVE. SAN DIEGO ' 8344# ' CALIFORNIA 6456445643MR. MICHAEL SMYTHE UNI-80/63MEG8470' 8345# ' 6250 BPI00107' 8346#Line: 572 CLOSE 8347# CLOSE TSPFILE Status: 00 8348#Line: 333 STOP RUN 8349#]) 8350 8351# variant without file trace 8352 8353 8354AT_DATA([reference], 8355[Source: 'prog.cob' 8356Program-Id: prog 8357Line: 290 Entry: prog 8358Line: 292 Paragraph: MAINFILE 8359Line: 293 OPEN 8360Line: 294 CLOSE 8361Line: 296 OPEN 8362Line: 297 MOVE 8363Line: 298 READ 8364Line: 299 IF 8365Line: 304 MOVE 8366Line: 305 START 8367Line: 306 IF 8368Line: 311 READ 8369Line: 312 IF 8370Line: 317 DISPLAY 8371Line: 318 CLOSE 8372Line: 320 PERFORM 8373Line: 335 Paragraph: LOADFILE 8374Line: 336 DISPLAY 8375Line: 339 OPEN 8376Line: 340 IF 8377Line: 346 PERFORM 8378Line: 358 Paragraph: 1000-LOAD-RECORD 8379Line: 360 MOVE 8380Line: 361 MOVE 8381Line: 362 MOVE 8382Line: 363 MOVE 8383Line: 364 MOVE 8384Line: 365 MOVE 8385Line: 366 MOVE 8386Line: 367 MOVE 8387Line: 368 MOVE 8388Line: 369 MOVE 8389Line: 370 MOVE 8390Line: 372 IF 8391Line: 373 MOVE 8392Line: 374 MOVE 8393Line: 375 MOVE 8394Line: 381 WRITE 8395Line: 382 IF 8396Line: 358 Paragraph: 1000-LOAD-RECORD 8397Line: 360 MOVE 8398Line: 361 MOVE 8399Line: 362 MOVE 8400Line: 363 MOVE 8401Line: 364 MOVE 8402Line: 365 MOVE 8403Line: 366 MOVE 8404Line: 367 MOVE 8405Line: 368 MOVE 8406Line: 369 MOVE 8407Line: 370 MOVE 8408Line: 372 IF 8409Line: 377 MOVE 8410Line: 378 MOVE 8411Line: 379 MOVE 8412Line: 381 WRITE 8413Line: 382 IF 8414Line: 358 Paragraph: 1000-LOAD-RECORD 8415Line: 360 MOVE 8416Line: 361 MOVE 8417Line: 362 MOVE 8418Line: 363 MOVE 8419Line: 364 MOVE 8420Line: 365 MOVE 8421Line: 366 MOVE 8422Line: 367 MOVE 8423Line: 368 MOVE 8424Line: 369 MOVE 8425Line: 370 MOVE 8426Line: 372 IF 8427Line: 373 MOVE 8428Line: 374 MOVE 8429Line: 375 MOVE 8430Line: 381 WRITE 8431Line: 382 IF 8432Line: 358 Paragraph: 1000-LOAD-RECORD 8433Line: 360 MOVE 8434Line: 361 MOVE 8435Line: 362 MOVE 8436Line: 363 MOVE 8437Line: 364 MOVE 8438Line: 365 MOVE 8439Line: 366 MOVE 8440Line: 367 MOVE 8441Line: 368 MOVE 8442Line: 369 MOVE 8443Line: 370 MOVE 8444Line: 372 IF 8445Line: 377 MOVE 8446Line: 378 MOVE 8447Line: 379 MOVE 8448Line: 381 WRITE 8449Line: 382 IF 8450Line: 358 Paragraph: 1000-LOAD-RECORD 8451Line: 360 MOVE 8452Line: 361 MOVE 8453Line: 362 MOVE 8454Line: 363 MOVE 8455Line: 364 MOVE 8456Line: 365 MOVE 8457Line: 366 MOVE 8458Line: 367 MOVE 8459Line: 368 MOVE 8460Line: 369 MOVE 8461Line: 370 MOVE 8462Line: 372 IF 8463Line: 373 MOVE 8464Line: 374 MOVE 8465Line: 375 MOVE 8466Line: 381 WRITE 8467Line: 382 IF 8468Line: 358 Paragraph: 1000-LOAD-RECORD 8469Line: 360 MOVE 8470Line: 361 MOVE 8471Line: 362 MOVE 8472Line: 363 MOVE 8473Line: 364 MOVE 8474Line: 365 MOVE 8475Line: 366 MOVE 8476Line: 367 MOVE 8477Line: 368 MOVE 8478Line: 369 MOVE 8479Line: 370 MOVE 8480Line: 372 IF 8481Line: 377 MOVE 8482Line: 378 MOVE 8483Line: 379 MOVE 8484Line: 381 WRITE 8485Line: 382 IF 8486Line: 358 Paragraph: 1000-LOAD-RECORD 8487Line: 360 MOVE 8488Line: 361 MOVE 8489Line: 362 MOVE 8490Line: 363 MOVE 8491Line: 364 MOVE 8492Line: 365 MOVE 8493Line: 366 MOVE 8494Line: 367 MOVE 8495Line: 368 MOVE 8496Line: 369 MOVE 8497Line: 370 MOVE 8498Line: 372 IF 8499Line: 373 MOVE 8500Line: 374 MOVE 8501Line: 375 MOVE 8502Line: 381 WRITE 8503Line: 382 IF 8504Line: 358 Paragraph: 1000-LOAD-RECORD 8505Line: 360 MOVE 8506Line: 361 MOVE 8507Line: 362 MOVE 8508Line: 363 MOVE 8509Line: 364 MOVE 8510Line: 365 MOVE 8511Line: 366 MOVE 8512Line: 367 MOVE 8513Line: 368 MOVE 8514Line: 369 MOVE 8515Line: 370 MOVE 8516Line: 372 IF 8517Line: 377 MOVE 8518Line: 378 MOVE 8519Line: 379 MOVE 8520Line: 381 WRITE 8521Line: 382 IF 8522Line: 358 Paragraph: 1000-LOAD-RECORD 8523Line: 360 MOVE 8524Line: 361 MOVE 8525Line: 362 MOVE 8526Line: 363 MOVE 8527Line: 364 MOVE 8528Line: 365 MOVE 8529Line: 366 MOVE 8530Line: 367 MOVE 8531Line: 368 MOVE 8532Line: 369 MOVE 8533Line: 370 MOVE 8534Line: 372 IF 8535Line: 373 MOVE 8536Line: 374 MOVE 8537Line: 375 MOVE 8538Line: 381 WRITE 8539Line: 382 IF 8540Line: 358 Paragraph: 1000-LOAD-RECORD 8541Line: 360 MOVE 8542Line: 361 MOVE 8543Line: 362 MOVE 8544Line: 363 MOVE 8545Line: 364 MOVE 8546Line: 365 MOVE 8547Line: 366 MOVE 8548Line: 367 MOVE 8549Line: 368 MOVE 8550Line: 369 MOVE 8551Line: 370 MOVE 8552Line: 372 IF 8553Line: 373 MOVE 8554Line: 374 MOVE 8555Line: 375 MOVE 8556Line: 381 WRITE 8557Line: 382 IF 8558Line: 358 Paragraph: 1000-LOAD-RECORD 8559Line: 360 MOVE 8560Line: 361 MOVE 8561Line: 362 MOVE 8562Line: 363 MOVE 8563Line: 364 MOVE 8564Line: 365 MOVE 8565Line: 366 MOVE 8566Line: 367 MOVE 8567Line: 368 MOVE 8568Line: 369 MOVE 8569Line: 370 MOVE 8570Line: 372 IF 8571Line: 373 MOVE 8572Line: 374 MOVE 8573Line: 375 MOVE 8574Line: 381 WRITE 8575Line: 382 IF 8576Line: 358 Paragraph: 1000-LOAD-RECORD 8577Line: 360 MOVE 8578Line: 361 MOVE 8579Line: 362 MOVE 8580Line: 363 MOVE 8581Line: 364 MOVE 8582Line: 365 MOVE 8583Line: 366 MOVE 8584Line: 367 MOVE 8585Line: 368 MOVE 8586Line: 369 MOVE 8587Line: 370 MOVE 8588Line: 372 IF 8589Line: 377 MOVE 8590Line: 378 MOVE 8591Line: 379 MOVE 8592Line: 381 WRITE 8593Line: 382 IF 8594Line: 358 Paragraph: 1000-LOAD-RECORD 8595Line: 360 MOVE 8596Line: 361 MOVE 8597Line: 362 MOVE 8598Line: 363 MOVE 8599Line: 364 MOVE 8600Line: 365 MOVE 8601Line: 366 MOVE 8602Line: 367 MOVE 8603Line: 368 MOVE 8604Line: 369 MOVE 8605Line: 370 MOVE 8606Line: 372 IF 8607Line: 377 MOVE 8608Line: 378 MOVE 8609Line: 379 MOVE 8610Line: 381 WRITE 8611Line: 382 IF 8612Line: 358 Paragraph: 1000-LOAD-RECORD 8613Line: 360 MOVE 8614Line: 361 MOVE 8615Line: 362 MOVE 8616Line: 363 MOVE 8617Line: 364 MOVE 8618Line: 365 MOVE 8619Line: 366 MOVE 8620Line: 367 MOVE 8621Line: 368 MOVE 8622Line: 369 MOVE 8623Line: 370 MOVE 8624Line: 372 IF 8625Line: 377 MOVE 8626Line: 378 MOVE 8627Line: 379 MOVE 8628Line: 381 WRITE 8629Line: 382 IF 8630Line: 358 Paragraph: 1000-LOAD-RECORD 8631Line: 360 MOVE 8632Line: 361 MOVE 8633Line: 362 MOVE 8634Line: 363 MOVE 8635Line: 364 MOVE 8636Line: 365 MOVE 8637Line: 366 MOVE 8638Line: 367 MOVE 8639Line: 368 MOVE 8640Line: 369 MOVE 8641Line: 370 MOVE 8642Line: 372 IF 8643Line: 377 MOVE 8644Line: 378 MOVE 8645Line: 379 MOVE 8646Line: 381 WRITE 8647Line: 382 IF 8648Line: 358 Paragraph: 1000-LOAD-RECORD 8649Line: 360 MOVE 8650Line: 361 MOVE 8651Line: 362 MOVE 8652Line: 363 MOVE 8653Line: 364 MOVE 8654Line: 365 MOVE 8655Line: 366 MOVE 8656Line: 367 MOVE 8657Line: 368 MOVE 8658Line: 369 MOVE 8659Line: 370 MOVE 8660Line: 372 IF 8661Line: 377 MOVE 8662Line: 378 MOVE 8663Line: 379 MOVE 8664Line: 381 WRITE 8665Line: 382 IF 8666Line: 350 DISPLAY 8667Line: 352 CLOSE 8668Line: 321 PERFORM 8669Line: 387 Paragraph: LISTFILE 8670Line: 388 DISPLAY 8671Line: 389 OPEN 8672Line: 390 MOVE 8673Line: 391 MOVE 8674Line: 392 START 8675Line: 393 READ 8676Line: 394 READ 8677Line: 395 CLOSE 8678Line: 397 MOVE 8679Line: 398 OPEN 8680Line: 399 IF 8681Line: 404 MOVE 8682Line: 405 MOVE 8683Line: 406 START 8684Line: 407 READ 8685Line: 408 READ 8686Line: 410 MOVE 8687Line: 411 MOVE 8688Line: 412 START 8689Line: 413 IF 8690Line: 418 READ 8691Line: 419 IF 8692Line: 424 PERFORM 8693Line: 426 DISPLAY 8694Line: 429 CALL 8695Line: 430 READ 8696Line: 434 ADD 8697Line: 426 DISPLAY 8698Line: 429 CALL 8699Line: 430 READ 8700Line: 434 ADD 8701Line: 426 DISPLAY 8702Line: 429 CALL 8703Line: 430 READ 8704Line: 434 ADD 8705Line: 426 DISPLAY 8706Line: 429 CALL 8707Line: 430 READ 8708Line: 434 ADD 8709Line: 426 DISPLAY 8710Line: 429 CALL 8711Line: 430 READ 8712Line: 434 ADD 8713Line: 426 DISPLAY 8714Line: 429 CALL 8715Line: 430 READ 8716Line: 434 ADD 8717Line: 426 DISPLAY 8718Line: 429 CALL 8719Line: 430 READ 8720Line: 434 ADD 8721Line: 426 DISPLAY 8722Line: 429 CALL 8723Line: 430 READ 8724Line: 434 ADD 8725Line: 426 DISPLAY 8726Line: 429 CALL 8727Line: 430 READ 8728Line: 434 ADD 8729Line: 426 DISPLAY 8730Line: 429 CALL 8731Line: 430 READ 8732Line: 434 ADD 8733Line: 426 DISPLAY 8734Line: 429 CALL 8735Line: 430 READ 8736Line: 434 ADD 8737Line: 436 IF 8738Line: 439 DISPLAY 8739Line: 442 DISPLAY 8740Line: 443 MOVE 8741Line: 444 START 8742Line: 445 IF 8743Line: 450 READ 8744Line: 451 IF 8745Line: 456 PERFORM 8746Line: 458 DISPLAY 8747Line: 461 READ 8748Line: 465 ADD 8749Line: 458 DISPLAY 8750Line: 461 READ 8751Line: 465 ADD 8752Line: 458 DISPLAY 8753Line: 461 READ 8754Line: 465 ADD 8755Line: 458 DISPLAY 8756Line: 461 READ 8757Line: 465 ADD 8758Line: 458 DISPLAY 8759Line: 461 READ 8760Line: 465 ADD 8761Line: 458 DISPLAY 8762Line: 461 READ 8763Line: 465 ADD 8764Line: 458 DISPLAY 8765Line: 461 READ 8766Line: 465 ADD 8767Line: 458 DISPLAY 8768Line: 461 READ 8769Line: 465 ADD 8770Line: 458 DISPLAY 8771Line: 461 READ 8772Line: 465 ADD 8773Line: 458 DISPLAY 8774Line: 461 READ 8775Line: 465 ADD 8776Line: 458 DISPLAY 8777Line: 461 READ 8778Line: 465 ADD 8779Line: 468 CLOSE 8780Line: 470 OPEN 8781Line: 471 MOVE 8782Line: 472 MOVE 8783Line: 473 MOVE 8784Line: 474 READ 8785Line: 475 IF 8786Line: 479 MOVE 8787Line: 480 MOVE 8788Line: 481 READ 8789Line: 482 IF 8790Line: 486 DISPLAY 8791Line: 490 READ 8792Line: 491 IF 8793Line: 495 DISPLAY 8794Line: 499 MOVE 8795Line: 500 MOVE 8796Line: 501 READ 8797Line: 502 IF 8798Line: 506 DISPLAY 8799Line: 510 WRITE 8800Line: 511 IF 8801Line: 515 DISPLAY 8802Line: 518 MOVE 8803Line: 519 MOVE 8804Line: 520 READ 8805Line: 521 DISPLAY 8806Line: 525 ADD 8807Line: 526 REWRITE 8808Line: 527 IF 8809Line: 532 DISPLAY 8810Line: 537 MOVE 8811Line: 538 MOVE 8812Line: 539 READ 8813Line: 540 DISPLAY 8814Line: 544 MOVE 8815Line: 545 MOVE 8816Line: 546 REWRITE 8817Line: 547 IF 8818Line: 552 DISPLAY 8819Line: 556 MOVE 8820Line: 557 MOVE 8821Line: 558 READ 8822Line: 559 MOVE 8823Line: 560 MOVE 8824Line: 561 REWRITE 8825Line: 562 IF 8826Line: 567 DISPLAY 8827Line: 571 DELETE 8828Line: 572 CLOSE 8829Line: 333 STOP RUN 8830]) 8831 8832AT_CHECK([diff reference trace.txt], [0], [], []) 8833 8834AT_CHECK([$COMPILE -ftrace prog.cob -o prog_s], [0], [], []) 8835 8836AT_CHECK([COB_TRACE_FILE=+trace_append.txt \ 8837COB_SET_TRACE=Y \ 8838COB_TRACE_FORMAT="%S and now ... %L" \ 8839$COBCRUN_DIRECT ./prog_s], [0], 8840[OK: Operations on empty file 8841Loading sample data file. 8842Sample data file load complete. 8843LIST SAMPLE FILE 8844Key: EPS00000 is EPSILON EQUIPMENT SUPPLY Disk=8417 . 8845Key: FOR00000 is FORTUNE COOKIE COMPANY Disk=8470 . 8846Key: GAM00000 is GAMMA X-RAY TECHNOLOGY Disk=8417 . 8847Key: GIB00000 is GIBRALTER LIFE INSURANCE Disk=8417 . 8848Key: H&J00000 is H & J PLUMBING SUPPLIES Disk=8470 . 8849Key: INC00000 is INCREMENTAL BACKUP CORP. Disk=8417 . 8850Key: JOH00000 is JOHNSON BOATING SUPPLIES Disk=8417 . 8851Key: KON00000 is KONFLAB PLASTIC PRODUCTS. Disk=8417 . 8852Key: LEW00000 is LEWISTON GRAPHICS LTD. Disk=8470 . 8853Key: MOR00000 is MORNINGSIDE CARPENTRY. Disk=8470 . 8854Key: NEW00000 is NEW WAVE SURF SHOPS INC. Disk=8470 . 8855Stop read after: 11 8856LIST SAMPLE FILE DESCENDING 8857Key: NEW00000 is NEW WAVE SURF SHOPS INC. Disk=8470 . 8858Key: MOR00000 is MORNINGSIDE CARPENTRY. Disk=8470 . 8859Key: LEW00000 is LEWISTON GRAPHICS LTD. Disk=8470 . 8860Key: KON00000 is KONFLAB PLASTIC PRODUCTS. Disk=8417 . 8861Key: JOH00000 is JOHNSON BOATING SUPPLIES Disk=8417 . 8862Key: INC00000 is INCREMENTAL BACKUP CORP. Disk=8417 . 8863Key: H&J00000 is H & J PLUMBING SUPPLIES Disk=8470 . 8864Key: GIB00000 is GIBRALTER LIFE INSURANCE Disk=8417 . 8865Key: GAM00000 is GAMMA X-RAY TECHNOLOGY Disk=8417 . 8866Key: FOR00000 is FORTUNE COOKIE COMPANY Disk=8470 . 8867Key: EPS00000 is EPSILON EQUIPMENT SUPPLY Disk=8417 . 8868Got: BET00000 is BETA SHOE MFG. INC. Disk=8470 . 8869Nxt: DEL00000 is DELTA LUGGAGE REPAIRS Disk=8470 . 8870Ky2: GIB00000 is GIBRALTER LIFE INSURANCE Mach=UNI-80/6. 8871 Write: GIB00000 got 22 as expected 8872 Read: GAM00000 got 00 as expected 00075 terminals 8873ReWrite: GAM00000 got 00 as expected 00080 terminals 8874 Read: BET00000 got 00 as expected 00034 terminals 8875ReWrite: GAM00000 got 00/02 as expected 8876ReWrite: FOR00000 got 00/02 as expected 8877], []) 8878 8879AT_CHECK([COB_TRACE_FILE=+trace_append.txt \ 8880COB_SET_TRACE=Y \ 8881COB_TRACE_FORMAT="%S - %L"\ 8882$COBCRUN_DIRECT ./prog_s], [0], 8883[OK: Operations on empty file 8884Loading sample data file. 8885Sample data file load complete. 8886LIST SAMPLE FILE 8887Key: EPS00000 is EPSILON EQUIPMENT SUPPLY Disk=8417 . 8888Key: FOR00000 is FORTUNE COOKIE COMPANY Disk=8470 . 8889Key: GAM00000 is GAMMA X-RAY TECHNOLOGY Disk=8417 . 8890Key: GIB00000 is GIBRALTER LIFE INSURANCE Disk=8417 . 8891Key: H&J00000 is H & J PLUMBING SUPPLIES Disk=8470 . 8892Key: INC00000 is INCREMENTAL BACKUP CORP. Disk=8417 . 8893Key: JOH00000 is JOHNSON BOATING SUPPLIES Disk=8417 . 8894Key: KON00000 is KONFLAB PLASTIC PRODUCTS. Disk=8417 . 8895Key: LEW00000 is LEWISTON GRAPHICS LTD. Disk=8470 . 8896Key: MOR00000 is MORNINGSIDE CARPENTRY. Disk=8470 . 8897Key: NEW00000 is NEW WAVE SURF SHOPS INC. Disk=8470 . 8898Stop read after: 11 8899LIST SAMPLE FILE DESCENDING 8900Key: NEW00000 is NEW WAVE SURF SHOPS INC. Disk=8470 . 8901Key: MOR00000 is MORNINGSIDE CARPENTRY. Disk=8470 . 8902Key: LEW00000 is LEWISTON GRAPHICS LTD. Disk=8470 . 8903Key: KON00000 is KONFLAB PLASTIC PRODUCTS. Disk=8417 . 8904Key: JOH00000 is JOHNSON BOATING SUPPLIES Disk=8417 . 8905Key: INC00000 is INCREMENTAL BACKUP CORP. Disk=8417 . 8906Key: H&J00000 is H & J PLUMBING SUPPLIES Disk=8470 . 8907Key: GIB00000 is GIBRALTER LIFE INSURANCE Disk=8417 . 8908Key: GAM00000 is GAMMA X-RAY TECHNOLOGY Disk=8417 . 8909Key: FOR00000 is FORTUNE COOKIE COMPANY Disk=8470 . 8910Key: EPS00000 is EPSILON EQUIPMENT SUPPLY Disk=8417 . 8911Got: BET00000 is BETA SHOE MFG. INC. Disk=8470 . 8912Nxt: DEL00000 is DELTA LUGGAGE REPAIRS Disk=8470 . 8913Ky2: GIB00000 is GIBRALTER LIFE INSURANCE Mach=UNI-80/6. 8914 Write: GIB00000 got 22 as expected 8915 Read: GAM00000 got 00 as expected 00075 terminals 8916ReWrite: GAM00000 got 00 as expected 00080 terminals 8917 Read: BET00000 got 00 as expected 00034 terminals 8918ReWrite: GAM00000 got 00/02 as expected 8919ReWrite: FOR00000 got 00/02 as expected 8920], []) 8921 8922 8923AT_DATA([reference_append], 8924[Source: 'prog.cob' 8925Program-Id: prog 8926 Entry: prog and now ... 290 8927Paragraph: MAINFILE and now ... 292 8928Paragraph: LOADFILE and now ... 335 8929Paragraph: 1000-LOAD-RECORD and now ... 358 8930Paragraph: 1000-LOAD-RECORD and now ... 358 8931Paragraph: 1000-LOAD-RECORD and now ... 358 8932Paragraph: 1000-LOAD-RECORD and now ... 358 8933Paragraph: 1000-LOAD-RECORD and now ... 358 8934Paragraph: 1000-LOAD-RECORD and now ... 358 8935Paragraph: 1000-LOAD-RECORD and now ... 358 8936Paragraph: 1000-LOAD-RECORD and now ... 358 8937Paragraph: 1000-LOAD-RECORD and now ... 358 8938Paragraph: 1000-LOAD-RECORD and now ... 358 8939Paragraph: 1000-LOAD-RECORD and now ... 358 8940Paragraph: 1000-LOAD-RECORD and now ... 358 8941Paragraph: 1000-LOAD-RECORD and now ... 358 8942Paragraph: 1000-LOAD-RECORD and now ... 358 8943Paragraph: 1000-LOAD-RECORD and now ... 358 8944Paragraph: 1000-LOAD-RECORD and now ... 358 8945Paragraph: LISTFILE and now ... 387 8946Source: 'prog.cob' 8947Program-Id: prog 8948 Entry: prog - 290 8949Paragraph: MAINFILE - 292 8950Paragraph: LOADFILE - 335 8951Paragraph: 1000-LOAD-RECORD - 358 8952Paragraph: 1000-LOAD-RECORD - 358 8953Paragraph: 1000-LOAD-RECORD - 358 8954Paragraph: 1000-LOAD-RECORD - 358 8955Paragraph: 1000-LOAD-RECORD - 358 8956Paragraph: 1000-LOAD-RECORD - 358 8957Paragraph: 1000-LOAD-RECORD - 358 8958Paragraph: 1000-LOAD-RECORD - 358 8959Paragraph: 1000-LOAD-RECORD - 358 8960Paragraph: 1000-LOAD-RECORD - 358 8961Paragraph: 1000-LOAD-RECORD - 358 8962Paragraph: 1000-LOAD-RECORD - 358 8963Paragraph: 1000-LOAD-RECORD - 358 8964Paragraph: 1000-LOAD-RECORD - 358 8965Paragraph: 1000-LOAD-RECORD - 358 8966Paragraph: 1000-LOAD-RECORD - 358 8967Paragraph: LISTFILE - 387 8968]) 8969 8970AT_CAPTURE_FILE(./trace_append.txt) 8971 8972AT_CHECK([diff reference_append trace_append.txt], [0], [], []) 8973 8974AT_CLEANUP 8975 8976 8977AT_SETUP([stack and dump feature]) 8978#AT_KEYWORDS([Dump]) 8979 8980AT_DATA([./cpyabrt], [ 8981 MOVE "Quick brown fox jumped over the dog" 8982 TO TSTTAILX (1:40). 8983 MOVE CM-COMPANY TO TSTTAILX (42:20). 8984 * DISPLAY ':' X ':'. 8985 * DISPLAY CM-COMPANY. 8986 * DISPLAY '>' CM-COMPANY '<'. 8987]) 8988 8989AT_DATA([prog.cob], [ 8990 IDENTIFICATION DIVISION. 8991 PROGRAM-ID. prog. 8992 ENVIRONMENT DIVISION. 8993 CONFIGURATION SECTION. 8994 8995 INPUT-OUTPUT SECTION. 8996 FILE-CONTROL. 8997 SELECT FLATFILE ASSIGN EXTERNAL RELFIX 8998 ORGANIZATION RELATIVE 8999 ACCESS IS SEQUENTIAL RELATIVE KEY IS REC-NUM 9000 FILE STATUS IS CUST-STAT. 9001 9002 DATA DIVISION. 9003 FILE SECTION. 9004 FD FLATFILE 9005 BLOCK CONTAINS 5 RECORDS. 9006 9007 01 TSPFL-RECORD. 9008 10 CM-CUST-NUM PICTURE X(8). 9009 10 CM-COMPANY PICTURE X(25). 9010 10 CM-DISK PICTURE X(8). 9011 10 CM-NO-TERMINALS PICTURE 9(4). 9012 9013 WORKING-STORAGE SECTION. 9014 77 MAX-SUB VALUE 6 PICTURE 9(4) COMP SYNC. 9015 77 CUST-STAT PICTURE X(2). 9016 77 REC-NUM VALUE 1 PICTURE 9(4). 9017 01 BIN PIC 9(9) BINARY VALUE 0. 9018 9019 01 TEST-DATA. 9020 02 DATA-CUST-NUM-TBL. 9021 05 FILLER PIC X(8) VALUE "ALP00000". 9022 05 FILLER PIC X(8) VALUE "BET00000". 9023 05 FILLER PIC X(8) VALUE "DEL00000". 9024 05 FILLER PIC X(8) VALUE "EPS00000". 9025 05 FILLER PIC X(8) VALUE "FOR00000". 9026 05 FILLER PIC X(8) VALUE "GAM00000". 9027 9028 02 DATA-CUST-NUM REDEFINES DATA-CUST-NUM-TBL 9029 PIC X(8) OCCURS 6. 9030 02 DATA-COMPANY-TBL. 9031 05 FILLER PIC X(25) VALUE "ALPHA ELECTRICAL CO. LTD.". 9032 05 FILLER PIC X(25) VALUE "BETA SHOE MFG. INC. ". 9033 05 FILLER PIC X(25) VALUE "DELTA LUGGAGE REPAIRS ". 9034 05 FILLER PIC X(25) VALUE "EPSILON EQUIPMENT SUPPLY ". 9035 05 FILLER PIC X(25) VALUE "FORTUNE COOKIE COMPANY ". 9036 05 FILLER PIC X(25) VALUE "GAMMA X-RAY TECHNOLOGY ". 9037 02 DATA-COMPANY REDEFINES DATA-COMPANY-TBL 9038 PIC X(25) OCCURS 6. 9039 02 DATA-ADDRESS-2-TBL. 9040 05 FILLER PIC X(10) VALUE "ATLANTA ". 9041 05 FILLER PIC X(10) VALUE "CALGARY ". 9042 05 FILLER PIC X(10) VALUE "NEW YORK ". 9043 05 FILLER PIC X(10) VALUE "TORONTO ". 9044 05 FILLER PIC X(10) VALUE "WASHINGTON". 9045 05 FILLER PIC X(10) VALUE "WHITEPLAIN". 9046 02 DATA-ADDRESS REDEFINES DATA-ADDRESS-2-TBL 9047 PIC X(10) OCCURS 6. 9048 9049 02 DATA-NO-TERMINALS-TBL. 9050 05 FILLER PIC 9(3) COMP-3 VALUE 10. 9051 05 FILLER PIC 9(3) COMP-3 VALUE 13. 9052 05 FILLER PIC 9(3) COMP-3 VALUE 75. 9053 05 FILLER PIC 9(3) COMP-3 VALUE 10. 9054 05 FILLER PIC 9(3) COMP-3 VALUE 90. 9055 05 FILLER PIC 9(3) COMP-3 VALUE 254. 9056 02 DATA-NO-TERMINALS REDEFINES DATA-NO-TERMINALS-TBL 9057 PIC 9(3) COMP-3 OCCURS 6. 9058 01 WORK-AREA IS EXTERNAL. 9059 05 SUB PICTURE 9(4) COMP SYNC. 9060 88 ODD-RECORD VALUE 1 3 5. 9061 01 SUMS-NON-STD-OCCURS PIC S9(15)V9(03) OCCURS 8 VALUE -42.345. 9062 9063 PROCEDURE DIVISION. 9064 9065 PERFORM LOADFILE. 9066 9067 OPEN INPUT FLATFILE. 9068 READ FLATFILE. 9069 9070 MAIN-100. 9071 PERFORM CALL-SUB-1. 9072 PERFORM CALL-SUB-2. 9073 PERFORM CALL-IT-OMIT. 9074 STOP RUN. 9075 9076 LOADFILE. 9077 OPEN OUTPUT FLATFILE. 9078 9079 PERFORM LOAD-RECORD 9080 VARYING SUB FROM 1 BY 1 9081 UNTIL SUB > MAX-SUB. 9082 9083 CLOSE FLATFILE. 9084 9085 LOAD-RECORD. 9086 9087 MOVE SPACES TO TSPFL-RECORD. 9088 MOVE DATA-CUST-NUM (SUB) TO CM-CUST-NUM. 9089 MOVE DATA-COMPANY (SUB) TO CM-COMPANY. 9090 MOVE DATA-NO-TERMINALS (SUB) TO CM-NO-TERMINALS. 9091 IF ODD-RECORD 9092 MOVE "8417" TO CM-DISK 9093 ELSE 9094 MOVE "8470" TO CM-DISK. 9095 WRITE TSPFL-RECORD. 9096 9097 CALL-SUB-1 SECTION. 9098 CALL "sub1" USING bin, TSPFL-RECORD. 9099 9100 CALL-SUB-2 SECTION. 9101 MOVE 4096 TO bin, SUMS-NON-STD-OCCURS (2) 9102 CALL "sub2" USING bin, TSPFL-RECORD. 9103 9104 CALL-IT-OMIT SECTION. 9105 MOVE 5440 TO bin, SUMS-NON-STD-OCCURS (3) 9106 CALL "sub2" USING bin, TSPFL-RECORD. 9107 9108 END PROGRAM prog. 9109 9110 IDENTIFICATION DIVISION. 9111 PROGRAM-ID. sub1. 9112 DATA DIVISION. 9113 WORKING-STORAGE SECTION. 9114 01 ZRO PIC 9(9) BINARY VALUE 0. 9115 01 HEXV PIC X COMP-X. 9116 01 HEXC REDEFINES HEXV PIC X. 9117 9118 01 TEST-BASED BASED. 9119 05 TEST-BASED-SUB PIC X(00000100000). 9120 9121 01 TEST-ALLOCED BASED. 9122 05 TEST-ALLOCED-SUB1 PIC X(010). 9123 05 TEST-ALLOCED-SUB2 PIC 9(006). 9124 9125 01 IDX PIC 9(9) BINARY VALUE 0. 9126 01 TSTREC. 9127 05 TSTDEP PIC XXX. 9128 05 TSTX OCCURS 4 TIMES. 9129 15 TSTG-1 PIC 99. 9130 15 TSTX-2 PIC XX OCCURS 4 TIMES. 9131 05 TSTTAIL1 PIC 99. 9132 05 TSTCOMP3 PIC 9(5) COMP-3. 9133 05 TSTLONG PIC X(100). 9134 05 TSTHEX PIC X(100). 9135 05 TSTHEX2 PIC X(60). 9136 05 TSTTAILX PIC X(80). 9137 9138 LINKAGE SECTION. 9139 01 X PIC 9(9) BINARY. 9140 01 TSPFL-RECORD. 9141 10 CM-CUST-NUM PICTURE X(8). 9142 10 CM-COMPANY PICTURE X(25). 9143 10 CM-DISK PICTURE X(8). 9144 10 CM-NO-TERMINALS PICTURE 9(4). 9145 9146 PROCEDURE DIVISION USING X, TSPFL-RECORD. 9147 MAIN-1 SECTION. 9148 MOVE ALL "X" TO TSTREC. 9149 MOVE 1 TO TSTG-1 (1). 9150 MOVE 2 TO TSTG-1 (2). 9151 MOVE 3 TO TSTG-1 (3). 9152 MOVE 'A' TO TSTX-2 (1,1). 9153 MOVE 'B' TO TSTX-2 (2,1). 9154 MOVE 'C' TO TSTX-2 (3,1). 9155 MOVE 'xx' TO TSTX-2 (1,4). 9156 MOVE 'yy' TO TSTX-2 (2,4). 9157 MOVE 'zz' TO TSTX-2 (3,4). 9158 MOVE SPACES TO TSTX-2 (1,3). 9159 MOVE HIGH-VALUES TO TSTX (4). 9160 MOVE LOW-VALUES TO TSTX-2 (2,3). 9161 MOVE HIGH-VALUES TO TSTX-2 (3,3). 9162 MOVE "Quick brown fox jumped over the dog" 9163 TO TSTLONG, TSTLONG (50:36). 9164 MOVE "Quicker grey fox jumped the cougar" 9165 TO TSTHEX (1:35). 9166 MAIN-2. 9167 MOVE 17 TO HEXV. 9168 MOVE HEXC TO TSTHEX (39:1). 9169 MOVE HEXC TO TSTTAIL1 (2:1). 9170 MOVE 7 TO HEXV. 9171 MOVE HEXC TO TSTHEX (47:1). 9172 MOVE 13 TO HEXV. 9173 MOVE HEXC TO TSTHEX (59:1). 9174 MOVE 0 TO HEXV. 9175 MOVE HEXC TO TSTHEX2 (39:1), TSTHEX2 (10:1). 9176 MOVE 9 TO HEXV. 9177 MOVE HEXC TO TSTHEX2 (47:1). 9178 MOVE '\' TO TSTHEX2 (32:1). 9179 MOVE 13 TO HEXV. 9180 MOVE HEXC TO TSTHEX2 (59:1). 9181 MOVE 'A' TO TSTHEX2 (54:1). 9182 MOVE LOW-VALUES TO TSTTAILX 9183 ADD 1 TO X. 9184 DISPLAY "X is " X. 9185 ALLOCATE TEST-ALLOCED INITIALIZED. 9186 COPY cpyabrt. 9187 IF ADDRESS OF TEST-BASED NOT = NULL 9188 DISPLAY TEST-BASED-SUB 9189 END-IF. 9190 GOBACK. 9191 END PROGRAM sub1. 9192 9193 IDENTIFICATION DIVISION. 9194 PROGRAM-ID. sub2. 9195 DATA DIVISION. 9196 WORKING-STORAGE SECTION. 9197 01 ZRO PIC 9(9) BINARY VALUE 0. 9198 01 HEXV PIC X COMP-X. 9199 01 HEXC REDEFINES HEXV PIC X. 9200 9201 01 IDX PIC 9(9) BINARY VALUE 0. 9202 01 TSTREC. 9203 05 TSTDEP PIC XXX. 9204 05 TSTX OCCURS 4 TIMES. 9205 15 TSTG-1 PIC 99. 9206 15 TSTX-2 PIC XX OCCURS 4 TIMES. 9207 05 TSTTAIL1 PIC 99. 9208 05 TSTCOMP3 PIC 9(5) COMP-3. 9209 05 TSTLONG PIC X(100). 9210 05 TSTHEX PIC X(100). 9211 05 TSTHEX2 PIC X(60). 9212 05 TSTTAILX PIC X(80). 9213 9214 01 BASED-RECORD BASED. 9215 10 B-NUM PICTURE 9(4) VALUE 123. 9216 10 B-DISK PICTURE X(8) VALUE "marvdisc". 9217 10 B-NO-TERMINALS PICTURE 9(4). 9218 77 BASED-NEVER-SET PIC X BASED. 9219 9220 LINKAGE SECTION. 9221 01 X PIC 9(9) BINARY. 9222 01 TSPFL-RECORD. 9223 10 CM-CUST-NUM PICTURE X(8). 9224 10 CM-COMPANY PICTURE X(25). 9225 10 CM-DISK PICTURE X(8). 9226 10 CM-NO-TERMINALS PICTURE 9(4). 9227 77 DYNAMIC-NUM PICTURE 9(4). 9228 9229 PROCEDURE DIVISION USING X, TSPFL-RECORD. 9230 9231 IF ADDRESS OF BASED-RECORD = NULL 9232 ALLOCATE BASED-RECORD INITIALIZED 9233 ELSE 9234 SET ADDRESS OF DYNAMIC-NUM TO ADDRESS OF BASED-RECORD 9235 ADD 1 TO B-NUM 9236 END-IF 9237 9238 IF X = 5440 9239 CALL "sub1" USING X, OMITTED. 9240 MOVE ALL "X" TO TSTREC. 9241 MOVE 1 TO TSTG-1 (1). 9242 MOVE 2 TO TSTG-1 (2). 9243 MOVE 3 TO TSTG-1 (3). 9244 MOVE 'A' TO TSTX-2 (1,1). 9245 MOVE 'B' TO TSTX-2 (2,1). 9246 MOVE 'C' TO TSTX-2 (3,1). 9247 MOVE 'xx' TO TSTX-2 (1,4). 9248 MOVE 'yy' TO TSTX-2 (2,4). 9249 MOVE 'zz' TO TSTX-2 (3,4). 9250 MOVE SPACES TO TSTX-2 (1,3). 9251 MOVE HIGH-VALUES TO TSTX (4). 9252 MOVE LOW-VALUES TO TSTX-2 (2,3). 9253 MOVE HIGH-VALUES TO TSTX-2 (3,3). 9254 MOVE "Quick brown fox jumped over the dog" 9255 TO TSTLONG, TSTLONG (50:36). 9256 MOVE "Quicker grey fox jumped the cougar" 9257 TO TSTHEX (1:35). 9258 MOVE 17 TO HEXV. 9259 MOVE HEXC TO TSTHEX (39:1). 9260 MOVE HEXC TO TSTTAIL1 (2:1). 9261 MOVE 7 TO HEXV. 9262 MOVE HEXC TO TSTHEX (47:1). 9263 MOVE 13 TO HEXV. 9264 MOVE HEXC TO TSTHEX (59:1). 9265 MOVE 0 TO HEXV. 9266 MOVE HEXC TO TSTHEX2 (39:1), TSTHEX2 (10:1). 9267 MOVE 9 TO HEXV. 9268 MOVE HEXC TO TSTHEX2 (47:1). 9269 MOVE '\' TO TSTHEX2 (32:1). 9270 MOVE 13 TO HEXV. 9271 MOVE HEXC TO TSTHEX2 (59:1). 9272 MOVE 'A' TO TSTHEX2 (54:1). 9273 MOVE LOW-VALUES TO TSTTAILX. 9274 * 9275 COPY cpyabrt. 9276 END PROGRAM sub2. 9277]) 9278 9279AT_CHECK([$COMPILE prog.cob], [0], [], []) 9280 9281AT_CAPTURE_FILE(./tstdump.dump) 9282 9283# also checking that a dump file without anything to dump does not do anything 9284AT_CHECK([COB_STACKTRACE=1 COB_DUMP_FILE=tstdump.dump \ 9285$COBCRUN_DIRECT ./prog], [1], 9286[X is 000000001 9287X is 000005441 9288], 9289[libcob: cpyabrt:4: error: LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9290libcob: cpyabrt:4: warning: implicit CLOSE of FLATFILE ('RELFIX') 9291 9292 Last statement of sub1 was at line 4 of cpyabrt 9293 Last statement of sub2 was at line 251 of prog.cob 9294 Last statement of prog was at line 118 of prog.cob 9295]) 9296 9297AT_CHECK([$COMPILE -fdump=ALL -fno-dump prog.cob], [0], [], []) 9298 9299# also checking that a dump file without anything to dump does not do anything 9300AT_CHECK([COB_STACKTRACE=1 COB_DUMP_FILE=tstdump.dump \ 9301$COBCRUN_DIRECT ./prog], [1], 9302[X is 000000001 9303X is 000005441 9304], 9305[libcob: cpyabrt:4: error: LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9306libcob: cpyabrt:4: warning: implicit CLOSE of FLATFILE ('RELFIX') 9307 9308 Last statement of sub1 was at line 4 of cpyabrt 9309 Last statement of sub2 was at line 251 of prog.cob 9310 Last statement of prog was at line 118 of prog.cob 9311]) 9312 9313AT_CHECK([$COMPILE -fdump=ALL prog.cob], [0], [], []) 9314 9315AT_CHECK([COB_DUMP_FILE=tstdump.dump \ 9316$COBCRUN_DIRECT ./prog], [1], 9317[X is 000000001 9318X is 000005441 9319], 9320[libcob: cpyabrt:4: error: LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9321libcob: cpyabrt:4: warning: implicit CLOSE of FLATFILE ('RELFIX') 9322 9323dump written to tstdump.dump 9324]) 9325 9326AT_DATA([reference_tmpl], [ 9327Module dump due to LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9328 9329 Last statement of sub1 was at line 4 of cpyabrt 9330 Last statement of sub2 was at line 251 of prog.cob 9331 Last statement of prog was at line 118 of prog.cob 9332 9333Dump Program-Id sub1 from prog.cob compiled MMM DD YYYY HH:MM:SS 9334 9335WORKING-STORAGE 9336********************** 933701 ZRO 000000000 933801 HEXV 13 933901 TEST-BASED. <NULL> address 934001 TEST-ALLOCED. 9341 05 TEST-ALLOCED-SUB1 ALL SPACES 9342 05 TEST-ALLOCED-SUB2 000000 934301 IDX 000000000 934401 TSTREC. 9345 05 TSTDEP 'XXX' 9346 05 TSTX (1). 9347 15 TSTG-1 (1) 01 9348 15 TSTX-2 (1,1) 'A' 9349 15 TSTX-2 (1,2) 'XX' 9350 15 TSTX-2 (1,3) ALL SPACES 9351 15 TSTX-2 (1,4) 'xx' 9352 05 TSTX (2). 9353 15 TSTG-1 (2) 02 9354 15 TSTX-2 (2,1) 'B' 9355 15 TSTX-2 (2,2) 'XX' 9356 15 TSTX-2 (2,3) ALL LOW-VALUES 9357 15 TSTX-2 (2,4) 'yy' 9358 05 TSTX (3). 9359 15 TSTG-1 (3) 03 9360 15 TSTX-2 (3,1) 'C' 9361 15 TSTX-2 (3,2) 'XX' 9362 15 TSTX-2 (3,3) ALL HIGH-VALUES 9363 15 TSTX-2 (3,4) 'zz' 9364 05 TSTX (4). 9365 15 TSTG-1 (4) ALL HIGH-VALUES 9366 15 TSTX-2 (4,1) ALL HIGH-VALUES 9367 15 TSTX-2 (4,2..4) same as (1) 9368 05 TSTTAIL1 X _ 9369 1 x 5811 9370 05 TSTCOMP3 58585 9371 05 TSTLONG 'Quick brown fox jumped over the dog Quick br' 9372 57:'own fox jumped over the dog' 9373 05 TSTHEX Q u i c k e r g r e y f o x j u m p e d _ 9374 1 x 51756963 6B657220 67726579 20666F78 206A756D 70656420 9375 t h e c o u g a r X X X X X X X X X X X 9376 25 x 74686520 636F7567 61722058 58581158 58585858 58580758 9377 X X X X X X X X X X X X X X X X X X X X X X X 9378 49 x 58585858 58585858 58580D58 58585858 58585858 58585858 9379 X X X X X X X X X X X X X X X X X X X X X X X X 9380 73 x 58585858 58585858 58585858 58585858 58585858 58585858 9381 X X X X 9382 97 x 58585858 9383 05 TSTHEX2 XXXXXXXXX\0XXXXXXXXXXXXXXXXXXXXX\\XXXXXX\0XXXXXXX\tXXXXXX 9384 54 : AXXXX\rX 9385 05 TSTTAILX 'Quick brown fox jumped over the dog ' 9386 trailing LOW-VALUES 9387 9388LINKAGE 9389********************** 939001 X 000005441 939101 TSPFL-RECORD. <NULL> address 9392 9393END OF DUMP - sub1 9394********************** 9395 9396Dump Program-Id sub2 from prog.cob compiled MMM DD YYYY HH:MM:SS 9397 9398WORKING-STORAGE 9399********************** 940001 ZRO 000000000 940101 HEXV 13 940201 IDX 000000000 940301 TSTREC. 9404 05 TSTDEP 'XXX' 9405 05 TSTX (1). 9406 15 TSTG-1 (1) 01 9407 15 TSTX-2 (1,1) 'A' 9408 15 TSTX-2 (1,2) 'XX' 9409 15 TSTX-2 (1,3) ALL SPACES 9410 15 TSTX-2 (1,4) 'xx' 9411 05 TSTX (2). 9412 15 TSTG-1 (2) 02 9413 15 TSTX-2 (2,1) 'B' 9414 15 TSTX-2 (2,2) 'XX' 9415 15 TSTX-2 (2,3) ALL LOW-VALUES 9416 15 TSTX-2 (2,4) 'yy' 9417 05 TSTX (3). 9418 15 TSTG-1 (3) 03 9419 15 TSTX-2 (3,1) 'C' 9420 15 TSTX-2 (3,2) 'XX' 9421 15 TSTX-2 (3,3) ALL HIGH-VALUES 9422 15 TSTX-2 (3,4) 'zz' 9423 05 TSTX (4). 9424 15 TSTG-1 (4) ALL HIGH-VALUES 9425 15 TSTX-2 (4,1) ALL HIGH-VALUES 9426 15 TSTX-2 (4,2..4) same as (1) 9427 05 TSTTAIL1 X _ 9428 1 x 5811 9429 05 TSTCOMP3 58585 9430 05 TSTLONG 'Quick brown fox jumped over the dog Quick br' 9431 57:'own fox jumped over the dog' 9432 05 TSTHEX Q u i c k e r g r e y f o x j u m p e d _ 9433 1 x 51756963 6B657220 67726579 20666F78 206A756D 70656420 9434 t h e c o u g a r X X X X X X X X X X X 9435 25 x 74686520 636F7567 61722058 58581158 58585858 58580758 9436 X X X X X X X X X X X X X X X X X X X X X X X 9437 49 x 58585858 58585858 58580D58 58585858 58585858 58585858 9438 X X X X X X X X X X X X X X X X X X X X X X X X 9439 73 x 58585858 58585858 58585858 58585858 58585858 58585858 9440 X X X X 9441 97 x 58585858 9442 05 TSTHEX2 XXXXXXXXX\0XXXXXXXXXXXXXXXXXXXXX\\XXXXXX\0XXXXXXX\tXXXXXX 9443 54 : AXXXX\rX 9444 05 TSTTAILX Quick brown fox jumped over the dog \0ALPHA ELECTRICA 9445 57 : L CO.\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0 944601 BASED-RECORD. 9447 10 B-NUM 0124 9448 10 B-DISK 'marvdisc' 9449 10 B-NO-TERMINALS 0000 945077 BASED-NEVER-SET <NULL> address 9451 9452LINKAGE 9453********************** 945401 X 000005441 945501 TSPFL-RECORD. 9456 10 CM-CUST-NUM 'ALP00000' 9457 10 CM-COMPANY 'ALPHA ELECTRICAL CO. LTD.' 9458 10 CM-DISK '8417' 9459 10 CM-NO-TERMINALS 0010 946077 DYNAMIC-NUM 0124 9461 9462END OF DUMP - sub2 9463********************** 9464 9465Dump Program-Id prog from prog.cob compiled MMM DD YYYY HH:MM:SS 9466 9467FD FLATFILE 9468********************** 9469 File is OPEN 9470 FILE STATUS '00' 947101 TSPFL-RECORD. 9472 10 CM-CUST-NUM 'ALP00000' 9473 10 CM-COMPANY 'ALPHA ELECTRICAL CO. LTD.' 9474 10 CM-DISK '8417' 9475 10 CM-NO-TERMINALS 0010 9476 9477WORKING-STORAGE 9478********************** 947977 MAX-SUB 0006 948077 CUST-STAT ALL ZEROES 948177 REC-NUM 0001 948201 BIN 000005441 948301 TEST-DATA. 9484 02 DATA-CUST-NUM-TBL. 9485 05 FILLER 'ALP00000' 9486 05 FILLER 'BET00000' 9487 05 FILLER 'DEL00000' 9488 05 FILLER 'EPS00000' 9489 05 FILLER 'FOR00000' 9490 05 FILLER 'GAM00000' 9491 02 DATA-COMPANY-TBL. 9492 05 FILLER 'ALPHA ELECTRICAL CO. LTD.' 9493 05 FILLER 'BETA SHOE MFG. INC.' 9494 05 FILLER 'DELTA LUGGAGE REPAIRS' 9495 05 FILLER 'EPSILON EQUIPMENT SUPPLY' 9496 05 FILLER 'FORTUNE COOKIE COMPANY' 9497 05 FILLER 'GAMMA X-RAY TECHNOLOGY' 9498 02 DATA-ADDRESS-2-TBL. 9499 05 FILLER 'ATLANTA' 9500 05 FILLER 'CALGARY' 9501 05 FILLER 'NEW YORK' 9502 05 FILLER 'TORONTO' 9503 05 FILLER 'WASHINGTON' 9504 05 FILLER 'WHITEPLAIN' 9505 02 DATA-NO-TERMINALS-TBL. 9506 05 FILLER 010 9507 05 FILLER 013 9508 05 FILLER 075 9509 05 FILLER 010 9510 05 FILLER 090 9511 05 FILLER 254 951201 WORK-AREA. 9513 05 SUB 0007 951401 SUMS-NON-STD-OCCURS (1) -000000000000042.345 951501 SUMS-NON-STD-OCCURS (2) +000000000004096.000 951601 SUMS-NON-STD-OCCURS (3) +000000000005440.000 951701 SUMS-NON-STD-OCCURS (4) -000000000000042.345 951801 SUMS-NON-STD-OCCURS (5..8) same as (4) 9519 9520END OF DUMP - prog 9521********************** 9522 9523]) 9524 9525# AT_DATA workaround via sed: 9526AT_CHECK([$SED -e 's/_$//' reference_tmpl > reference], [0], [], []) 9527AT_CHECK([$SED -e 's/compiled ... .. .... ..:..:../compiled MMM DD YYYY HH:MM:SS/g' \ 9528tstdump.dump > tstdump.sed], [0], [], []) 9529 9530AT_CHECK([diff reference tstdump.sed], [0], [], []) 9531 9532# using both 9533AT_CHECK([COB_STACKTRACE=1 COB_DUMP_FILE=tstdump.dump \ 9534$COBCRUN_DIRECT ./prog], [1], 9535[X is 000000001 9536X is 000005441 9537], 9538[libcob: cpyabrt:4: error: LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9539libcob: cpyabrt:4: warning: implicit CLOSE of FLATFILE ('RELFIX') 9540 9541 Last statement of sub1 was at line 4 of cpyabrt 9542 Last statement of sub2 was at line 251 of prog.cob 9543 Last statement of prog was at line 118 of prog.cob 9544 9545dump written to tstdump.dump 9546]) 9547 9548AT_CHECK([$SED -e 's/compiled ... .. .... ..:..:../compiled MMM DD YYYY HH:MM:SS/g' \ 9549tstdump.dump > tstdump.sed], [0], [], []) 9550 9551AT_CHECK([diff reference tstdump.sed], [0], [], []) 9552 9553AT_CHECK([$COMPILE -fdump=FD,LS prog.cob -o prog_fdls], [0], [], []) 9554 9555AT_CHECK([COB_DUMP_FILE=tstdump_fdls.dump \ 9556$COBCRUN_DIRECT ./prog_fdls], [1], 9557[X is 000000001 9558X is 000005441 9559], 9560[libcob: cpyabrt:4: error: LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9561libcob: cpyabrt:4: warning: implicit CLOSE of FLATFILE ('RELFIX') 9562 9563dump written to tstdump_fdls.dump 9564]) 9565 9566 9567AT_CAPTURE_FILE(./tstdump_fdls.dump) 9568 9569AT_DATA([reference_fdls_tmpl], [ 9570Module dump due to LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9571 9572 Last statement of sub1 was at line 4 of cpyabrt 9573 Last statement of sub2 was at line 251 of prog.cob 9574 Last statement of prog was at line 118 of prog.cob 9575 9576Dump Program-Id sub1 from prog.cob compiled MMM DD YYYY HH:MM:SS 9577 9578LINKAGE 9579********************** 958001 X 000005441 958101 TSPFL-RECORD. <NULL> address 9582 9583END OF DUMP - sub1 9584********************** 9585 9586Dump Program-Id sub2 from prog.cob compiled MMM DD YYYY HH:MM:SS 9587 9588LINKAGE 9589********************** 959001 X 000005441 959101 TSPFL-RECORD. 9592 10 CM-CUST-NUM 'ALP00000' 9593 10 CM-COMPANY 'ALPHA ELECTRICAL CO. LTD.' 9594 10 CM-DISK '8417' 9595 10 CM-NO-TERMINALS 0010 959677 DYNAMIC-NUM 0124 9597 9598END OF DUMP - sub2 9599********************** 9600 9601Dump Program-Id prog from prog.cob compiled MMM DD YYYY HH:MM:SS 9602 9603FD FLATFILE 9604********************** 9605 File is OPEN 9606 FILE STATUS '00' 960701 TSPFL-RECORD. 9608 10 CM-CUST-NUM 'ALP00000' 9609 10 CM-COMPANY 'ALPHA ELECTRICAL CO. LTD.' 9610 10 CM-DISK '8417' 9611 10 CM-NO-TERMINALS 0010 9612 9613END OF DUMP - prog 9614********************** 9615 9616]) 9617 9618# AT_DATA workaround via sed: 9619AT_CHECK([$SED -e 's/_$//' reference_fdls_tmpl > reference], [0], [], []) 9620AT_CHECK([$SED -e 's/compiled ... .. .... ..:..:../compiled MMM DD YYYY HH:MM:SS/g' \ 9621tstdump_fdls.dump > tstdump.sed], [0], [], []) 9622 9623AT_CHECK([diff reference tstdump.sed], [0], [], []) 9624 9625AT_CHECK([$COMPILE -fdump=ALL -fno-dump=LO,WS,SC prog.cob -o prog_allfdls], [0], [], []) 9626 9627AT_CHECK([COB_DUMP_FILE=tstdump_allfdls.dump \ 9628$COBCRUN_DIRECT ./prog_allfdls], [1], 9629[X is 000000001 9630X is 000005441 9631], 9632[libcob: cpyabrt:4: error: LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9633libcob: cpyabrt:4: warning: implicit CLOSE of FLATFILE ('RELFIX') 9634 9635dump written to tstdump_allfdls.dump 9636]) 9637 9638AT_CHECK([$SED -e 's/compiled ... .. .... ..:..:../compiled MMM DD YYYY HH:MM:SS/g' \ 9639tstdump_allfdls.dump > tstdump.sed], [0], [], []) 9640 9641AT_CHECK([diff reference tstdump.sed], [0], [], []) 9642 9643# CHECKME @ Ron: The result is likely wrong, please verify later 9644#AT_CHECK([$COMPILE -fdump=LS prog.cob -fsticky-linkage -o prog_ls_sticky], [0], [], []) 9645# 9646#AT_CHECK([COB_DUMP_FILE=tstdump_ls_sticky.dump \ 9647#$COBCRUN_DIRECT ./prog_ls_sticky], [1], 9648#[X is 000000001 9649#X is 000005441 9650#], 9651#[libcob: cpyabrt:4: error: LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9652#libcob: cpyabrt:4: warning: implicit CLOSE of FLATFILE ('RELFIX') 9653# 9654#dump written to tstdump_ls_sticky.dump 9655#]) 9656# 9657# 9658#AT_CAPTURE_FILE(./tstdump_ls_sticky.dump) 9659# 9660#AT_DATA([reference_ls_sticky_tmpl], [ 9661#Module dump due to LINKAGE item 'TSPFL-RECORD' (accessed by 'CM-COMPANY') not passed by caller 9662# 9663# Last statement of sub1 was at line 4 of cpyabrt 9664# Last statement of sub2 was at line 251 of prog.cob 9665# Last statement of prog was at line 118 of prog.cob 9666# 9667#Dump Program-Id sub1 from prog.cob compiled MMM DD YYYY HH:MM:SS 9668# 9669#LINKAGE 9670#********************** 9671#01 X 000005441 9672#01 TSPFL-RECORD. <NULL> address 9673# 9674#Dump Program-Id sub2 from prog.cob compiled MMM DD YYYY HH:MM:SS 9675# 9676#LINKAGE 9677#********************** 9678#01 X 000005441 9679#01 TSPFL-RECORD. 9680# 10 CM-CUST-NUM 'ALP00000' 9681# 10 CM-COMPANY 'ALPHA ELECTRICAL CO. LTD.' 9682# 10 CM-DISK '8417' 9683# 10 CM-NO-TERMINALS 0010 9684#77 DYNAMIC-NUM 0124 9685# 9686#Dump Program-Id prog from prog.cob compiled MMM DD YYYY HH:MM:SS 9687# 9688#]) 9689# 9690## AT_DATA workaround via sed: 9691#AT_CHECK([$SED -e 's/_$//' reference_ls_sticky_tmpl > reference], [0], [], []) 9692#AT_CHECK([$SED -e 's/compiled ... .. .... ..:..:../compiled MMM DD YYYY HH:MM:SS/g' \ 9693#tstdump_ls_sticky.dump > tstdump.sed], [0], [], []) 9694# 9695#AT_CHECK([diff reference tstdump.sed], [0], [], []) 9696 9697AT_CLEANUP 9698 9699 9700AT_SETUP([Test dump feature (2)]) 9701#AT_KEYWORDS([Dump]) 9702 9703AT_DATA([prog.cob], [ 9704 IDENTIFICATION DIVISION. 9705 PROGRAM-ID. prog. 9706 DATA DIVISION. 9707 WORKING-STORAGE SECTION. 9708 01 P2 USAGE POINTER. 9709 9710 01 TAB-ADR-COUNT PIC S9(4) VALUE 8. 9711 9712 01 TAB-ADR OCCURS 0 TO 1000 TIMES 9713 DEPENDING ON TAB-ADR-COUNT 9714 INDEXED BY TAB-ADR-IND. 9715 05 TAB-ADR-ELEMENT. 9716 10 TAB-ADR-PRGM PIC X(8). 9717 10 TAB-ADR-ID PIC X(2). 9718 10 TAB-ADR-ADR-64 PIC S9(16) COMP-5. 9719 10 TAB-ADR-LAST-ADR-64 PIC S9(16) COMP-5. 9720 9721 01 GRP-X BASED. 9722 05 FILLER PIC X(3). 9723 05 FLD-X OCCURS 10 TIMES. 9724 10 FLD-X-Y PIC 9999 VALUE 2020. 9725 10 FLD-X-M PIC 99 VALUE 11. 9726 10 FLD-X-X PIC X(128) VALUE "This is something ". 9727 05 FILLER PIC X(3). 9728 9729 01 GRP-1. 9730 05 FILLER PIC X(3). 9731 05 FLD-1 OCCURS 10 TIMES. 9732 10 FLD-1-Y PIC 9999 VALUE 2020. 9733 10 FLD-1-M PIC 99 VALUE 11. 9734 10 FLD-1-X PIC X(128) VALUE "This is something ". 9735 05 FILLER PIC X(3). 9736 9737 01 GRP-2. 9738 05 FILLER PIC X(3). 9739 05 FLD-2 PIC X(42) VALUE ALL "ABCD ". 9740 05 FILLER PIC X(3). 9741 01 GRP-2A. 9742 05 FILLER PIC X(2). 9743 05 FLD-2A PIC X(8) VALUE ALL "ABC". 9744 05 FILLER PIC X(1200) VALUE "X". 9745 01 GRP-3. 9746 05 FILLER PIC X(3). 9747 05 FLD-3 OCCURS 3 TIMES. 9748 15 FLD-3-2 PIC XXX VALUE "ABC". 9749 15 FLD-3-3 PIC 99 VALUE ZERO. 9750 15 OCCURS 4 VALUE ALL "D99". 9751 25 FLD-3O-1 PIC X. 9752 25 FLD-3O-2 PIC 99. 9753 15 FLD-3-4 PIC XX VALUE ALL "X". 9754 05 FILLER PIC X(3). 9755 9756 77 C5 PIC 9(03) VALUE 6. 9757 01 GRP-5. 9758 05 FILLER PIC X(3). 9759 05 FLD-5. 9760 10 FLD-5-1 OCCURS 0 TO 9 TIMES 9761 DEPENDING ON C5. 9762 15 FLD-5-2 PIC XXX VALUE "Mon". 9763 15 FLD-5-3 PIC 99 VALUE 49. 9764 15 FLD-5-4 PIC XX VALUE "ey". 9765 9766 LINKAGE SECTION. 9767 01 A-TABLE. 9768 03 prefix. 9769 05 n PIC 9(03) VALUE 123. 9770 03 table-data value all "ABCDE". 9771 04 rows OCCURS 0 TO UNBOUNDED TIMES 9772 DEPENDING ON n. 9773 05 col1 PIC X. 9774 05 col2 PIC X(02). 9775 9776 PROCEDURE DIVISION. 9777 MOVE ALL "*" TO GRP-2 9778 INITIALIZE FLD-2 ALL TO VALUE 9779 DISPLAY "GRP-2:" GRP-2. 9780 * 9781 MOVE ALL "*" TO GRP-3 9782 INITIALIZE GRP-3 NUMERIC TO VALUE 9783 INITIALIZE FLD-3 (1) ALL TO VALUE 9784 INITIALIZE FLD-3 (2) ALL TO VALUE 9785 INITIALIZE FLD-3 (3) ALL TO VALUE 9786 INITIALIZE FLD-3O-1 (3,2), FLD-3O-2 (3,2) 9787 DISPLAY "GRP-3:" GRP-3. 9788 * 9789 MOVE 7 TO c5 9790 MOVE ALL "*" TO GRP-5 9791 INITIALIZE FLD-5 ALL TO VALUE 9792 DISPLAY "GRP-5:" GRP-5. 9793 * 9794 MOVE SPACES TO GRP-2A 9795 MOVE "Peek" TO GRP-2A (510:4) 9796 MOVE "Boo" TO GRP-2A (910:3) 9797 MOVE X"FE99" TO GRP-2A (910:2) 9798 MOVE "You" TO GRP-2A (1010:3) 9799 MOVE "$$" TO FLD-5-4 (5) 9800 MOVE "Something else!" TO FLD-1-X (5). 9801 * 9802 SET P2 TO NULL 9803 SET ADDRESS OF A-TABLE TO NULL 9804 MOVE ALL ZEROES TO A-TABLE (1: (LENGTH OF A-TABLE)). 9805 * 9806 STOP RUN. 9807]) 9808 9809AT_CHECK([$COMPILE -fdump=ALL prog.cob], [0], [], []) 9810 9811AT_CHECK([export COB_DUMP_FILE=dumpall.txt 9812$COBCRUN_DIRECT ./prog], [1], 9813[GRP-2:***ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD AB*** 9814GRP-3:***ABC00D99D99D99D99XXABC00D99D99D99D99XXABC00D99 00D99D99XX*** 9815GRP-5:***Mon49eyMon49eyMon49eyMon49eyMon49eyMon49eyMon49ey 9816], 9817[libcob: prog.cob:102: error: BASED/LINKAGE item 'A-TABLE' has NULL address 9818 9819dump written to dumpall.txt 9820]) 9821 9822AT_CAPTURE_FILE(./dumpall.txt) 9823 9824AT_DATA([reference_tmpl], [ 9825Module dump due to BASED/LINKAGE item 'A-TABLE' has NULL address 9826 9827 Last statement of prog was at line 102 of prog.cob 9828 9829Dump Program-Id prog from prog.cob compiled MMM DD YYYY HH:MM:SS 9830 9831WORKING-STORAGE 9832********************** 983301 P2 0x0000000000000000 983401 TAB-ADR-COUNT +0008 9835 INDEX TAB-ADR-IND +000000001 983601 TAB-ADR (1). 9837 05 TAB-ADR-ELEMENT (1). 9838 10 TAB-ADR-PRGM (1) ALL SPACES 9839 10 TAB-ADR-ID (1) ALL SPACES 9840 10 TAB-ADR-ADR-64 (1) +00000000000000000000 9841 10 TAB-ADR-LAST-ADR-64 (1) +00000000000000000000 984201 TAB-ADR (2..8) same as (1) 984301 GRP-X. <NULL> address 984401 GRP-1. 9845 05 FILLER ALL SPACES 9846 05 FLD-1 (1). 9847 10 FLD-1-Y (1) 2020 9848 10 FLD-1-M (1) 11 9849 10 FLD-1-X (1) 'This is something' 9850 05 FLD-1 (2..4) same as (1) 9851 05 FLD-1 (5). 9852 10 FLD-1-Y (5) 2020 9853 10 FLD-1-M (5) 11 9854 10 FLD-1-X (5) 'Something else!' 9855 05 FLD-1 (6). 9856 10 FLD-1-Y (6) 2020 9857 10 FLD-1-M (6) 11 9858 10 FLD-1-X (6) 'This is something' 9859 05 FLD-1 (7..10) same as (6) 9860 05 FILLER ALL SPACES 986101 GRP-2. 9862 05 FILLER '***' 9863 05 FLD-2 'ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD AB' 9864 05 FILLER '***' 986501 GRP-2A. 9866 05 FILLER ALL SPACES 9867 05 FLD-2A ALL SPACES 9868 05 FILLER _ 9869 1 x 20202020 20202020 20202020 20202020 20202020 20202020 9870 --- 25 thru 492 same as above --- 9871 P e e k _ 9872 493 x 20202020 20202050 65656B20 20202020 20202020 20202020 9873 _ 9874 517 x 20202020 20202020 20202020 20202020 20202020 20202020 9875 --- 541 thru 878 same as above --- 9876 _ 9877 879 x 2020 20202020 20202020 20202020 20202020 202020FE 99 9878 o _ 9879 902 x 6F2020 20202020 20202020 20202020 20202020 20202020 _ 9880 _ 9881 925 x 20202020 20202020 20202020 20202020 20202020 20202020_ 9882 --- 949 thru 974 same as above --- 9883 _ 9884 975 x 2020 20202020 20202020 20202020 20202020 20202020 20 9885 Y o u _ 9886 998 x 202059 6F752020 20202020 20202020 20202020 20202020 _ 9887 _ 9888 1021 x 20202020 20202020 20202020 20202020 20202020 20202020 9889 --- 1045 thru 1174 same as above --- 9890 _ 9891 1175 x 2020 20202020 20202020 20202020 20202020 20202020 20 9892 _ 9893 1198 x 202020 989401 GRP-3. 9895 05 FILLER '***' 9896 05 FLD-3 (1). 9897 15 FLD-3-2 (1) 'ABC' 9898 15 FLD-3-3 (1) 00 9899 15 FILLER (1,1). 9900 25 FLD-3O-1 (1,1) 'D' 9901 25 FLD-3O-2 (1,1) 99 9902 15 FILLER (1,2..4) same as (1) 9903 15 FLD-3-4 (1) 'XX' 9904 05 FLD-3 (2) same as (1) 9905 05 FLD-3 (3). 9906 15 FLD-3-2 (3) 'ABC' 9907 15 FLD-3-3 (3) 00 9908 15 FILLER (3,1). 9909 25 FLD-3O-1 (3,1) 'D' 9910 25 FLD-3O-2 (3,1) 99 9911 15 FILLER (3,2). 9912 25 FLD-3O-1 (3,2) ALL SPACES 9913 25 FLD-3O-2 (3,2) 00 9914 15 FILLER (3,3). 9915 25 FLD-3O-1 (3,3) 'D' 9916 25 FLD-3O-2 (3,3) 99 9917 15 FILLER (3,4) same as (3) 9918 15 FLD-3-4 (3) 'XX' 9919 05 FILLER '***' 992077 C5 007 992101 GRP-5. 9922 05 FILLER '***' 9923 05 FLD-5. 9924 10 FLD-5-1 (1). 9925 15 FLD-5-2 (1) 'Mon' 9926 15 FLD-5-3 (1) 49 9927 15 FLD-5-4 (1) 'ey' 9928 10 FLD-5-1 (2..4) same as (1) 9929 10 FLD-5-1 (5). 9930 15 FLD-5-2 (5) 'Mon' 9931 15 FLD-5-3 (5) 49 9932 15 FLD-5-4 (5) '$$' 9933 10 FLD-5-1 (6). 9934 15 FLD-5-2 (6) 'Mon' 9935 15 FLD-5-3 (6) 49 9936 15 FLD-5-4 (6) 'ey' 9937 10 FLD-5-1 (7) same as (6) 9938 9939LINKAGE 9940********************** 994101 A-TABLE. <NULL> address 9942 9943END OF DUMP - prog 9944********************** 9945 9946]) 9947 9948# AT_DATA workaround via sed: 9949AT_CHECK([$SED -e 's/compiled ... .. .... ..:..:../compiled MMM DD YYYY HH:MM:SS/g' \ 9950dumpall.txt > dumpall.sed], [0], [], []) 9951 9952AT_CHECK([test "$COB_HAS_64_BIT_POINTER" = "yes"], [0], [], [], 9953# Previous test "failed" --> 32 bit 9954 AT_CHECK([$SED -e 's/_$//; s/0x0000000000000000/0x00000000/' reference_tmpl > reference], [0], [], []) 9955, 9956# Previous test "passed" --> 64 bit 9957 AT_CHECK([$SED -e 's/_$//' reference_tmpl > reference], [0], [], []) 9958) 9959 9960AT_CHECK([diff reference dumpall.sed], [0], [], []) 9961 9962AT_CLEANUP 9963 9964 9965AT_SETUP([CALL with program prototypes]) 9966AT_KEYWORDS([runmisc]) 9967 9968AT_DATA([prog.cob], [ 9969 IDENTIFICATION DIVISION. 9970 PROGRAM-ID. prog. 9971 9972 PROCEDURE DIVISION. 9973 CALL "c" 9974 . 9975 END PROGRAM prog. 9976 9977 9978 IDENTIFICATION DIVISION. 9979 PROGRAM-ID. a AS "blah?Sdk". 9980 9981 PROCEDURE DIVISION. 9982 DISPLAY "Hello!" 9983 . 9984 END PROGRAM a. 9985 9986 9987 IDENTIFICATION DIVISION. 9988 PROGRAM-ID. b. 9989 9990 PROCEDURE DIVISION. 9991 DISPLAY "Hello again!" 9992 . 9993 END PROGRAM b. 9994 9995 9996 IDENTIFICATION DIVISION. 9997 PROGRAM-ID. c. 9998 9999 ENVIRONMENT DIVISION. 10000 CONFIGURATION SECTION. 10001 REPOSITORY. 10002 PROGRAM d AS "blah?Sdk" 10003 PROGRAM b 10004 . 10005 10006 PROCEDURE DIVISION. 10007 CALL d 10008 CALL b 10009 . 10010 END PROGRAM c. 10011]) 10012 10013AT_CHECK([$COMPILE -o prog prog.cob], [0], [], []) 10014AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10015[Hello! 10016Hello again! 10017]) 10018AT_CLEANUP 10019 10020 10021AT_SETUP([REDEFINES values on FILLER and INITIALIZE]) 10022AT_KEYWORDS([runmisc INITIALIZE]) 10023 10024AT_DATA([prog.cob], [ 10025 IDENTIFICATION DIVISION. 10026 PROGRAM-ID. prog. 10027 DATA DIVISION. 10028 WORKING-STORAGE SECTION. 10029 01 TSRDF. 10030 05 WS-ASK-ID-DATE PIC X(10) VALUE ALL '*'. 10031 05 WS-ASK-ID-DATE-R REDEFINES WS-ASK-ID-DATE. 10032 10 WS-ASK-ID-DATE-YYYY PIC 9(4) VALUE 2017. 10033 10 FILLER PIC X VALUE '-'. 10034 10 WS-ASK-ID-DATE-MM PIC 9(2). 10035 10 FILLER PIC X VALUE '-'. 10036 10 WS-ASK-ID-DATE-DD PIC 9(2). 10037 PROCEDURE DIVISION. 10038 MOVE 2015 TO WS-ASK-ID-DATE-YYYY 10039 MOVE 08 TO WS-ASK-ID-DATE-MM 10040 MOVE 21 TO WS-ASK-ID-DATE-DD 10041 DISPLAY "The date is " WS-ASK-ID-DATE " Compiled". 10042 10043 INITIALIZE WS-ASK-ID-DATE-R. 10044 MOVE 08 TO WS-ASK-ID-DATE-MM 10045 MOVE 21 TO WS-ASK-ID-DATE-DD 10046 DISPLAY "The date is " WS-ASK-ID-DATE " INITIALIZE". 10047 10048 INITIALIZE WS-ASK-ID-DATE-R WITH FILLER. 10049 MOVE 08 TO WS-ASK-ID-DATE-MM 10050 MOVE 21 TO WS-ASK-ID-DATE-DD 10051 DISPLAY "The date is " WS-ASK-ID-DATE " WITH FILLER". 10052 10053 INITIALIZE WS-ASK-ID-DATE-R WITH FILLER ALL TO VALUE. 10054 MOVE 08 TO WS-ASK-ID-DATE-MM 10055 MOVE 21 TO WS-ASK-ID-DATE-DD 10056 DISPLAY "The date is " WS-ASK-ID-DATE " ALL TO VALUE". 10057 STOP RUN. 10058]) 10059 10060AT_CHECK([$COMPILE prog.cob], [0], [], 10061[prog.cob:9: warning: initial VALUE clause ignored for REDEFINES item 'WS-ASK-ID-DATE-YYYY' 10062prog.cob:10: warning: initial VALUE clause ignored for REDEFINES item 'FILLER' 10063prog.cob:12: warning: initial VALUE clause ignored for REDEFINES item 'FILLER' 10064]) 10065 10066AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10067[The date is 2015*08*21 Compiled 10068The date is 0000*08*21 INITIALIZE 10069The date is 0000 08 21 WITH FILLER 10070The date is 2017-08-21 ALL TO VALUE 10071], []) 10072 10073AT_CLEANUP 10074 10075 10076AT_SETUP([PICTURE with constant-name]) 10077AT_KEYWORDS([runmisc]) 10078 10079AT_DATA([prog.cob], [ 10080 IDENTIFICATION DIVISION. 10081 PROGRAM-ID. prog. 10082 10083 DATA DIVISION. 10084 WORKING-STORAGE SECTION. 10085 01 foo-bar CONSTANT 8. 10086 01 x PIC 9(foo-bar)9(foo-bar). 10087 10088 PROCEDURE DIVISION. 10089 IF FUNCTION LENGTH (x) <> 16 10090 DISPLAY FUNCTION LENGTH (x) 10091 END-IF 10092 . 10093 END PROGRAM prog. 10094]) 10095 10096AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], 10097[prog.cob:11: warning: expression '16' NOT EQUAL '16' is always FALSE 10098]) 10099AT_CHECK([$COMPILE -fno-constant-folding prog.cob], [0], [], []) 10100AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 10101AT_CLEANUP 10102 10103 10104AT_SETUP([Quote marks in comment paragraphs]) 10105AT_KEYWORDS([runmisc]) 10106 10107AT_DATA([prog.cob], [ 10108 IDENTIFICATION DIVISION. 10109 PROGRAM-ID. prog. 10110 DATE-written. hello'". 10111 *> Written is intentionally lowercase. 10112 *> extra " to fix syntax highlighting 10113 PROCEDURE DIVISION. 10114 DISPLAY "Hello, world!" 10115 . 10116]) 10117 10118AT_CHECK([$COMPILE -o prog prog.cob], [0], [], 10119[prog.cob:4: warning: DATE-WRITTEN is obsolete in GnuCOBOL 10120]) 10121AT_CHECK([$COMPILE -free -o prog prog.cob], [0], [], 10122[prog.cob:3: warning: DATE-WRITTEN is obsolete in GnuCOBOL 10123]) 10124AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10125[Hello, world! 10126]) 10127AT_CLEANUP 10128 10129 10130AT_SETUP([Numeric MOVE with/without -fbinary-truncate]) 10131AT_KEYWORDS([runmisc size]) 10132 10133AT_DATA([prog.cob], [ 10134 IDENTIFICATION DIVISION. 10135 PROGRAM-ID. prog. 10136 10137 DATA DIVISION. 10138 WORKING-STORAGE SECTION. 10139 01 x PIC 9(4) COMP. 10140 10141 PROCEDURE DIVISION. 10142 MOVE 30000 TO x 10143 PERFORM check-x-val 10144 10145 COMPUTE x = 30000 10146 PERFORM check-x-val 10147 10148 MOVE ZERO TO x 10149 ADD 30000 TO x 10150 PERFORM check-x-val 10151 10152 GOBACK 10153 . 10154 check-x-val SECTION. 10155 EVALUATE x 10156 WHEN >= 10000 10157 DISPLAY "x >= 10000" 10158 10159 WHEN ZERO 10160 DISPLAY "x IS ZERO" 10161 10162 WHEN OTHER 10163 CONTINUE 10164 END-EVALUATE 10165 . 10166 END PROGRAM prog. 10167]) 10168 10169AT_CHECK([$COMPILE prog.cob], [0], [], 10170[prog.cob:10: warning: value size exceeds data size 10171prog.cob:10: note: value is 30000 10172prog.cob:7: note: 'x' defined here as PIC 9(4) 10173]) 10174AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10175[x IS ZERO 10176x IS ZERO 10177x IS ZERO 10178]) 10179 10180AT_CHECK([$COMPILE -fno-binary-truncate prog.cob], [0], [], []) 10181AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10182[x >= 10000 10183x >= 10000 10184x >= 10000 10185]) 10186 10187AT_CLEANUP 10188 10189 10190AT_SETUP([Alphanumeric MOVE with truncation]) 10191AT_KEYWORDS([misc fundamental size]) 10192 10193AT_DATA([prog.cob], [ 10194 IDENTIFICATION DIVISION. 10195 PROGRAM-ID. prog. 10196 10197 DATA DIVISION. 10198 WORKING-STORAGE SECTION. 10199 01 x-left PIC X(03). 10200 01 x-right PIC X(03) JUSTIFIED RIGHT. 10201 10202 PROCEDURE DIVISION. 10203 MOVE '1234' TO x-left, x-right 10204 IF x-left not = '123' 10205 OR x-right not = '234' 10206 DISPLAY 'error with "1234":' 10207 END-DISPLAY 10208 DISPLAY x-left 10209 END-DISPLAY 10210 DISPLAY x-right 10211 END-DISPLAY 10212 END-IF 10213 MOVE ' 3' TO x-left, x-right 10214 IF x-left not = spaces 10215 OR x-right not = ' 3' 10216 DISPLAY 'error with " 3":' 10217 END-DISPLAY 10218 DISPLAY x-left 10219 END-DISPLAY 10220 DISPLAY x-right 10221 END-DISPLAY 10222 END-IF 10223 MOVE '3 ' TO x-left, x-right 10224 IF x-left not = '3' 10225 OR x-right not = spaces 10226 DISPLAY 'error with "3 ":' 10227 END-DISPLAY 10228 DISPLAY x-left 10229 END-DISPLAY 10230 DISPLAY x-right 10231 END-DISPLAY 10232 END-IF 10233 . 10234]) 10235 10236AT_CHECK([$COMPILE -Wno-truncate prog.cob], [0], [], []) 10237AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 10238AT_CLEANUP 10239 10240 10241AT_SETUP([PROGRAM-ID / CALL literal/variable with spaces]) 10242AT_KEYWORDS([CALL]) 10243 10244AT_DATA([prog.cob], [ 10245 IDENTIFICATION DIVISION. 10246 PROGRAM-ID. prog. 10247 10248 DATA DIVISION. 10249 WORKING-STORAGE SECTION. 10250 01 MYRTN PIC X(9) VALUE " SUB ". 10251 10252 PROCEDURE DIVISION. 10253 CALL " SUB " USING 'X'. 10254 MOVE x'00' TO MYRTN (6:1). 10255 CALL MYRTN USING 'Y'. 10256 CALL "SUB" USING 'Z'. 10257 CALL "S U B" USING 'A'. 10258 MOVE " S U B" TO MYRTN. 10259 CALL MYRTN USING 'B'. 10260 STOP RUN. 10261 END PROGRAM prog. 10262 10263 IDENTIFICATION DIVISION. 10264 PROGRAM-ID. "SUB ". 10265 10266 DATA DIVISION. 10267 LINKAGE SECTION. 10268 01 x PIC X. 10269 10270 PROCEDURE DIVISION USING x. 10271 DISPLAY "SUB GOT " X 10272 END-DISPLAY. 10273 END PROGRAM " SUB". 10274 10275 IDENTIFICATION DIVISION. 10276 PROGRAM-ID. "S U B". 10277 10278 DATA DIVISION. 10279 LINKAGE SECTION. 10280 01 x PIC X. 10281 10282 PROCEDURE DIVISION USING x. 10283 DISPLAY "S U B GOT " X 10284 END-DISPLAY. 10285 END PROGRAM "S U B". 10286]) 10287 10288AT_CHECK([$COMPILE prog.cob], [0], [], 10289[prog.cob:10: warning: ' SUB ' literal includes leading spaces which are omitted 10290prog.cob:10: warning: ' SUB ' literal includes trailing spaces which are omitted 10291prog.cob:21: warning: 'SUB ' literal includes trailing spaces which are omitted 10292prog.cob:30: warning: ' SUB' literal includes leading spaces which are omitted 10293]) 10294 10295AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10296[SUB GOT X 10297SUB GOT Y 10298SUB GOT Z 10299S U B GOT A 10300S U B GOT B 10301], 10302[libcob: prog.cob:12: warning: ' SUB' literal includes leading spaces which are omitted 10303libcob: prog.cob:16: warning: ' S U B' literal includes leading spaces which are omitted 10304]) 10305 10306AT_CLEANUP 10307 10308 10309AT_SETUP([C-API Test (param based)]) 10310AT_KEYWORDS([CALL api]) 10311 10312AT_DATA([prog.cob], [ 10313 IDENTIFICATION DIVISION. 10314 PROGRAM-ID. prog. 10315 10316 DATA DIVISION. 10317 WORKING-STORAGE SECTION. 10318 01 BINFLD5 PIC 9(5) COMP-5 VALUE 1280. 10319 01 BINFLD5S PIC S9(5) BINARY VALUE 1024. 10320 01 BINFLD9 PIC 9(9) BINARY VALUE 2560. 10321 01 COMP3 PIC 9(8) COMP-3 VALUE 4096. 10322 01 COMP3V99 PIC S9(7)V99 COMP-3 VALUE 12.50. 10323 01 PIC9 PIC S9(8) DISPLAY VALUE 8192. 10324 01 NE PIC Z(4)9.99-. 10325 01 CHRX PIC X(9) VALUE 'Hello'. 10326 *01 CHRN PIC N(9) VALUE N'Hello'. 10327 01 GRPX. 10328 05 FILLER PIC X(9) VALUE 'Hello'. 10329 05 FILLER PIC X(9) VALUE 'World'. 10330 PROCEDURE DIVISION. 10331 MOVE -512.77 TO NE. 10332 CALL "CAPI" USING 2560 BY VALUE 16. 10333 CALL "CAPI" USING BINFLD5, NE. 10334 CALL "CAPI" USING BINFLD5S. 10335 CALL "CAPI" USING BINFLD9. 10336 MOVE 512.77 TO NE. 10337 CALL "CAPI" USING COMP3, NE. 10338 CALL "CAPI" USING PIC9 BINFLD5S CHRX GRPX. 10339 CALL "CAPI" USING COMP3, NE, CHRX. 10340 CALL "CAPI" USING BINFLD5, NE. 10341 MOVE "Hello!" TO CHRX. 10342 CALL "CAPI" USING BY VALUE BINFLD5, CHRX. 10343 CALL "CAPI" USING BY VALUE BINFLD5, CHRX. 10344 CALL "CAPI" USING LENGTH OF GRPX. 10345 CALL "CAPI" USING BY VALUE GRPX LENGTH OF GRPX. 10346 CALL "CAPI" USING "Fred Fish", COMP3. 10347 CALL "CAPI" USING COMP3V99. 10348 * CALL "CAPI" USING CHRN. 10349 CALL "CAPI" . 10350 DISPLAY "COMP3 is now " COMP3 ";". 10351 DISPLAY "COMP4 is now " BINFLD5 ";". 10352 DISPLAY "BINFLD5S is now " BINFLD5S ";". 10353 DISPLAY "CHRX is now " CHRX ";". 10354 DISPLAY "NE is now " NE ";". 10355 STOP RUN. 10356]) 10357 10358AT_DATA([cmod.c], [[ 10359#include <stdio.h> 10360#include <string.h> 10361#include <libcob.h> 10362 10363static char * 10364getType (int type, int byvalue) 10365{ 10366 static char wrk[24]; 10367 switch (type) { 10368#if 1 10369 case COB_TYPE_GROUP: return "Group"; 10370 case COB_TYPE_NUMERIC_COMP5: 10371 /* fall through as the test will have different results 10372 on big endian systems otherwise 10373 return "COMP-5"; */ 10374 COB_UNUSED (byvalue); 10375 case COB_TYPE_NUMERIC_BINARY: return "BINARY"; 10376 case COB_TYPE_NUMERIC_PACKED: return "COMP-3"; 10377 case COB_TYPE_NUMERIC_FLOAT: return "COMP-1"; 10378 case COB_TYPE_NUMERIC_DOUBLE: return "COMP-2"; 10379 case COB_TYPE_NUMERIC_DISPLAY: return "DISPLAY"; 10380 case COB_TYPE_ALPHANUMERIC: return "X"; 10381 case COB_TYPE_NUMERIC_EDITED: return "EDITED"; 10382 case COB_TYPE_NATIONAL: return "N"; 10383#else 10384 case COB_TYPE_GROUP: return "Group"; 10385 case COB_TYPE_NUMERIC_COMP5: 10386 return byvalue == 2 ? "COMP-4" : "COMP-5"; 10387 case COB_TYPE_NUMERIC_BINARY: return "COMP-4"; 10388 case COB_TYPE_NUMERIC_PACKED: return "COMP-3"; 10389 case COB_TYPE_NUMERIC_FLOAT: return "COMP-1"; 10390 case COB_TYPE_NUMERIC_DOUBLE: return "COMP-2"; 10391 case COB_TYPE_NUMERIC_DISPLAY: return "DISPLAY"; 10392 case COB_TYPE_ALPHANUMERIC: return "X"; 10393 case COB_TYPE_NUMERIC_EDITED: return "EDITED"; 10394 case COB_TYPE_NATIONAL: return "N"; 10395#endif 10396 } 10397 sprintf (wrk,"Type %04X",type); 10398 return wrk; 10399} 10400 10401COB_EXT_EXPORT int 10402CAPI (void *p1, ...) 10403{ 10404 int k,nargs,type,digits,scale,size,sign,byvalue; 10405 cob_s64_t val; 10406 char *str; 10407 char wrk[80],pic[30]; /* note: maxium _theoretical_ size */ 10408 10409 nargs = cob_get_num_params(); 10410 printf ("CAPI called with %d parameters\n",nargs); 10411 for (k=1; k <= nargs; k++) { 10412 type = cob_get_param_type (k); 10413 digits = cob_get_param_digits (k); 10414 scale = cob_get_param_scale (k); 10415 size = cob_get_param_size (k); 10416 sign = cob_get_param_sign (k); 10417 byvalue = cob_get_param_constant(k); 10418 printf (" %d: %-8s ", k, getType (type, byvalue)); 10419 if (byvalue) { 10420 printf ("BY VALUE "); 10421 } else { 10422 printf ("BY REFERENCE "); 10423 } 10424 if (type == COB_TYPE_ALPHANUMERIC) { 10425 sprintf (pic, "X(%d)", size); 10426 str = cob_get_picx_param (k, NULL, 0); 10427 printf ("%-11s '%s'", pic, str); 10428 cob_free ((void*)str); 10429 cob_put_picx_param (k, "Bye!"); 10430 } else if (type == COB_TYPE_NATIONAL) { 10431 sprintf (pic, "N(%d)", size); /* FIXME */ 10432 printf ("exchange of national data is not supported yet"); 10433 } else if (type == COB_TYPE_GROUP) { 10434 sprintf (pic, "(%d)", size); 10435 str = cob_get_grp_param (k, NULL, 0); 10436 printf ("%-11s '%.*s'", pic, size, str); 10437 cob_free ((void*)str); 10438 memset (wrk,' ',sizeof(wrk)); 10439 memcpy (wrk,"Bye-Bye Birdie!",15); 10440 cob_put_grp_param (k, wrk, sizeof(wrk)); 10441 } else if (type == COB_TYPE_NUMERIC_EDITED) { 10442 if (scale > 0) { 10443 sprintf (pic,"%s9(%d)V9(%d)",sign?"S":"",digits-scale,scale); 10444 } else { 10445 sprintf (pic,"%s9(%d)",sign?"S":"",digits-scale); 10446 } 10447 val = cob_get_s64_param (k); 10448 printf ("%-11s %lld ",pic,val); 10449 val = val + 130; 10450 val = -val; 10451 cob_put_s64_param (k, val); 10452 cob_get_grp_param (k, wrk, sizeof(wrk)); 10453 printf (" to %.*s",size,wrk); 10454 } else { 10455 if(scale > 0) { 10456 sprintf (pic,"%s9(%d)V9(%d)",sign?"S":"",digits-scale,scale); 10457 } else { 10458 sprintf (pic,"%s9(%d)",sign?"S":"",digits-scale); 10459 } 10460 val = cob_get_s64_param (k); 10461 printf ("%-11s %lld", pic, val); 10462 cob_put_s64_param (k, val + 3); 10463 } 10464 printf (";\n"); 10465 fflush (stdout); 10466 } 10467 if (nargs > 2) { 10468 cob_put_s64_param (7, val + 3); 10469 } 10470 return 0; 10471} 10472]]) 10473 10474AT_CHECK([$COMPILE -Wno-unfinished prog.cob cmod.c], [0], [], 10475[prog.cob:31: warning: BY CONTENT assumed for alphanumeric item 'CHRX' 10476prog.cob:32: warning: BY CONTENT assumed for alphanumeric item 'CHRX' 10477prog.cob:34: warning: BY CONTENT assumed for alphanumeric item 'GRPX' 10478]) 10479 10480AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10481[CAPI called with 2 parameters 10482 1: BINARY BY VALUE S9(9) 2560; 10483 2: DISPLAY BY VALUE 9(2) 16; 10484CAPI called with 2 parameters 10485 1: BINARY BY REFERENCE 9(5) 1280; 10486 2: EDITED BY REFERENCE S9(5)V9(2) -51277 to 511.47 ; 10487CAPI called with 1 parameters 10488 1: BINARY BY REFERENCE S9(5) 1024; 10489CAPI called with 1 parameters 10490 1: BINARY BY REFERENCE 9(9) 2560; 10491CAPI called with 2 parameters 10492 1: COMP-3 BY REFERENCE 9(8) 4096; 10493 2: EDITED BY REFERENCE S9(5)V9(2) 51277 to 514.07-; 10494CAPI called with 4 parameters 10495 1: DISPLAY BY REFERENCE S9(8) 8192; 10496 2: BINARY BY REFERENCE S9(5) 1027; 10497 3: X BY REFERENCE X(9) 'Hello'; 10498 4: Group BY REFERENCE (18) 'Hello World '; 10499CAPI called with 3 parameters 10500 1: COMP-3 BY REFERENCE 9(8) 4099; 10501 2: EDITED BY REFERENCE S9(5)V9(2) -51407 to 512.77 ; 10502 3: X BY REFERENCE X(9) 'Bye!'; 10503CAPI called with 2 parameters 10504 1: BINARY BY REFERENCE 9(5) 1283; 10505 2: EDITED BY REFERENCE S9(5)V9(2) 51277 to 514.07-; 10506CAPI called with 2 parameters 10507 1: BINARY BY REFERENCE 9(5) 1286; 10508 2: X BY VALUE X(9) 'Hello!'; 10509CAPI called with 2 parameters 10510 1: BINARY BY REFERENCE 9(5) 1289; 10511 2: X BY VALUE X(9) 'Hello!'; 10512CAPI called with 1 parameters 10513 1: BINARY BY VALUE S9(9) 18; 10514CAPI called with 2 parameters 10515 1: Group BY VALUE (18) 'Bye-Bye Birdie! '; 10516 2: DISPLAY BY VALUE 9(2) 18; 10517CAPI called with 2 parameters 10518 1: X BY VALUE X(9) 'Fred Fish'; 10519 2: COMP-3 BY REFERENCE 9(8) 4102; 10520CAPI called with 1 parameters 10521 1: COMP-3 BY REFERENCE S9(7)V9(2) 1250; 10522CAPI called with 0 parameters 10523COMP3 is now 00004105; 10524COMP4 is now 0000001292; 10525BINFLD5S is now +01030; 10526CHRX is now Hello! ; 10527NE is now 514.07-; 10528], 10529[libcob: prog.cob:21: warning: cob_put_s64_param: attempt to over-write constant parameter 1 with 2563 10530libcob: prog.cob:21: warning: cob_put_s64_param: attempt to over-write constant parameter 2 with 19 10531libcob: prog.cob:27: warning: cob_put_s64_param: parameter 7 is not within range of 4 10532libcob: prog.cob:28: warning: cob_put_s64_param: parameter 7 is not within range of 3 10533libcob: prog.cob:31: warning: cob_put_picx_param: attempt to over-write constant parameter 2 with 'Bye!' 10534libcob: prog.cob:32: warning: cob_put_picx_param: attempt to over-write constant parameter 2 with 'Bye!' 10535libcob: prog.cob:33: warning: cob_put_s64_param: attempt to over-write constant parameter 1 with 21 10536libcob: prog.cob:34: warning: cob_put_grp_param: attempt to over-write constant parameter 1 10537libcob: prog.cob:34: warning: cob_put_s64_param: attempt to over-write constant parameter 2 with 21 10538libcob: prog.cob:35: warning: cob_put_picx_param: attempt to over-write constant parameter 1 with 'Bye!' 10539]) 10540 10541AT_CLEANUP 10542 10543 10544AT_SETUP([C-API Test (field based)]) 10545AT_KEYWORDS([CALL api]) 10546 10547AT_DATA([prog.cob], [ 10548 IDENTIFICATION DIVISION. 10549 PROGRAM-ID. prog. 10550 10551 DATA DIVISION. 10552 WORKING-STORAGE SECTION. 10553 01 BINFLD5 PIC 9(5) COMP-5 VALUE 1280. 10554 01 BINFLD5S PIC S9(5) BINARY VALUE 1024. 10555 01 BINFLD9 PIC 9(9) BINARY VALUE 2560. 10556 01 COMP3 PIC 9(8) COMP-3 VALUE 4096. 10557 01 COMP3V99 PIC S9(7)V99 COMP-3 VALUE 12.50. 10558 01 PIC9 PIC S9(8) DISPLAY VALUE 8192. 10559 01 NE PIC Z(4)9.99-. 10560 01 CHRX PIC X(9) VALUE 'Hello'. 10561 *01 CHRN PIC N(9) VALUE N'Hello'. 10562 01 GRPX. 10563 05 FILLER PIC X(9) VALUE 'Hello'. 10564 05 FILLER PIC X(9) VALUE 'World'. 10565 PROCEDURE DIVISION. 10566 MOVE -512.77 TO NE. 10567 CALL "CAPI" USING 2560 BY VALUE 16. 10568 CALL "CAPI" USING BINFLD5, NE. 10569 CALL "CAPI" USING BINFLD5S. 10570 CALL "CAPI" USING BINFLD9. 10571 MOVE 512.77 TO NE. 10572 CALL "CAPI" USING COMP3, NE. 10573 CALL "CAPI" USING PIC9 BINFLD5S CHRX GRPX. 10574 CALL "CAPI" USING COMP3, NE, CHRX. 10575 CALL "CAPI" USING BINFLD5, NE. 10576 MOVE "Hello!" TO CHRX. 10577 CALL "CAPI" USING BY VALUE BINFLD5, CHRX. 10578 CALL "CAPI" USING BY VALUE BINFLD5, CHRX. 10579 CALL "CAPI" USING LENGTH OF GRPX. 10580 CALL "CAPI" USING BY VALUE GRPX LENGTH OF GRPX. 10581 CALL "CAPI" USING "Fred Fish", COMP3. 10582 CALL "CAPI" USING COMP3V99. 10583 * CALL "CAPI" USING CHRN. 10584 CALL "CAPI" . 10585 DISPLAY "COMP3 is now " COMP3 ";". 10586 DISPLAY "COMP4 is now " BINFLD5 ";". 10587 DISPLAY "BINFLD5S is now " BINFLD5S ";". 10588 DISPLAY "CHRX is now " CHRX ";". 10589 DISPLAY "NE is now " NE ";". 10590 STOP RUN. 10591]) 10592 10593AT_DATA([cmod.c], [[ 10594#include <stdio.h> 10595#include <string.h> 10596#include <libcob.h> 10597 10598static char * 10599getType (int type, int byvalue) 10600{ 10601 static char wrk[24]; 10602 switch (type) { 10603#if 1 10604 case COB_TYPE_GROUP: return "Group"; 10605 case COB_TYPE_NUMERIC_COMP5: 10606 /* fall through as the test will have different results 10607 on big endian systems otherwise 10608 return "COMP-5"; */ 10609 COB_UNUSED (byvalue); 10610 case COB_TYPE_NUMERIC_BINARY: return "BINARY"; 10611 case COB_TYPE_NUMERIC_PACKED: return "COMP-3"; 10612 case COB_TYPE_NUMERIC_FLOAT: return "COMP-1"; 10613 case COB_TYPE_NUMERIC_DOUBLE: return "COMP-2"; 10614 case COB_TYPE_NUMERIC_DISPLAY: return "DISPLAY"; 10615 case COB_TYPE_ALPHANUMERIC: return "X"; 10616 case COB_TYPE_NUMERIC_EDITED: return "EDITED"; 10617 case COB_TYPE_NATIONAL: return "N"; 10618#else 10619 case COB_TYPE_GROUP: return "Group"; 10620 case COB_TYPE_NUMERIC_COMP5: 10621 return byvalue == 2 ? "COMP-4" : "COMP-5"; 10622 case COB_TYPE_NUMERIC_BINARY: return "COMP-4"; 10623 case COB_TYPE_NUMERIC_PACKED: return "COMP-3"; 10624 case COB_TYPE_NUMERIC_FLOAT: return "COMP-1"; 10625 case COB_TYPE_NUMERIC_DOUBLE: return "COMP-2"; 10626 case COB_TYPE_NUMERIC_DISPLAY: return "DISPLAY"; 10627 case COB_TYPE_ALPHANUMERIC: return "X"; 10628 case COB_TYPE_NUMERIC_EDITED: return "EDITED"; 10629 case COB_TYPE_NATIONAL: return "N"; 10630#endif 10631 } 10632 sprintf (wrk,"Type %04X",type); 10633 return wrk; 10634} 10635 10636COB_EXT_EXPORT int 10637CAPI (void *p1, ...) 10638{ 10639 int k,nargs,type,digits,scale,size,sign,byvalue; 10640 cob_s64_t val; 10641 char *str; 10642 char wrk[80],pic[30]; /* note: maxium _theoretical_ size */ 10643 10644 nargs = cob_get_num_params(); 10645 printf ("CAPI called with %d parameters\n",nargs); 10646 for (k=1; k <= nargs; k++) { 10647 cob_field *fld = cob_get_param_field (k, "CAPI"); 10648 type = cob_get_field_type (fld); 10649 digits = cob_get_field_digits (fld); 10650 scale = cob_get_field_scale (fld); 10651 size = cob_get_field_size (fld); 10652 sign = cob_get_field_sign (fld); 10653 byvalue = cob_get_field_constant (fld); 10654 printf (" %d: %-8s ", k, getType (type, byvalue)); 10655 if (byvalue) { 10656 printf ("BY VALUE "); 10657 } else { 10658 printf ("BY REFERENCE "); 10659 } 10660 str = (char *) cob_get_field_str_buffered (fld); 10661 if (type == COB_TYPE_ALPHANUMERIC) { 10662 sprintf (pic, "X(%d)", size); 10663 printf ("%-11s '%s'", pic, str); 10664 cob_put_field_str (fld, "Bye!"); 10665 } else if (type == COB_TYPE_NATIONAL) { 10666 sprintf (pic,"N(%d)",size); /* FIXME */ 10667 printf ("exchange of national data is not supported yet"); 10668 } else if (type == COB_TYPE_GROUP) { 10669 sprintf (pic,"(%d)",size); 10670 printf ("%-11s '%.*s'",pic,size,str); 10671 cob_put_field_str (fld, "Bye-Bye Birdie!"); 10672 } else if (type == COB_TYPE_NUMERIC_EDITED) { 10673 if (scale > 0) { 10674 sprintf (pic,"%s9(%d)V9(%d)",sign?"S":"",digits-scale,scale); 10675 } else { 10676 sprintf (pic,"%s9(%d)",sign?"S":"",digits-scale); 10677 } 10678 printf ("%-11s %s ",pic,str); 10679 val = cob_get_s64_param (k); 10680 val = val + 130; 10681 val = -val; 10682 cob_put_s64_param (k, val); 10683 str = (char *) cob_get_field_str (fld, wrk, 78); 10684 printf (" to %.*s",size,wrk); 10685 } else { 10686 if(scale > 0) { 10687 sprintf (pic,"%s9(%d)V9(%d)",sign?"S":"",digits-scale,scale); 10688 } else { 10689 sprintf (pic,"%s9(%d)",sign?"S":"",digits-scale); 10690 } 10691 printf ("%-11s %s", pic, str); 10692 val = cob_get_s64_param (k); 10693 sprintf (wrk, "%lld", val + 3); 10694 cob_put_field_str (fld, wrk); 10695 } 10696 printf (";\n"); 10697 fflush(stdout); 10698 } 10699 return 0; 10700} 10701]]) 10702 10703AT_CHECK([$COMPILE -Wno-unfinished prog.cob cmod.c], [0], [], 10704[prog.cob:31: warning: BY CONTENT assumed for alphanumeric item 'CHRX' 10705prog.cob:32: warning: BY CONTENT assumed for alphanumeric item 'CHRX' 10706prog.cob:34: warning: BY CONTENT assumed for alphanumeric item 'GRPX' 10707]) 10708 10709AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10710[CAPI called with 2 parameters 10711 1: BINARY BY VALUE S9(9) +000002560; 10712 2: DISPLAY BY VALUE 9(2) 16; 10713CAPI called with 2 parameters 10714 1: BINARY BY REFERENCE 9(5) 0000001280; 10715 2: EDITED BY REFERENCE S9(5)V9(2) 512.77- to 511.47 ; 10716CAPI called with 1 parameters 10717 1: BINARY BY REFERENCE S9(5) +01024; 10718CAPI called with 1 parameters 10719 1: BINARY BY REFERENCE 9(9) 000002560; 10720CAPI called with 2 parameters 10721 1: COMP-3 BY REFERENCE 9(8) 00004096; 10722 2: EDITED BY REFERENCE S9(5)V9(2) 512.77 to 514.07-; 10723CAPI called with 4 parameters 10724 1: DISPLAY BY REFERENCE S9(8) +00008192; 10725 2: BINARY BY REFERENCE S9(5) +01027; 10726 3: X BY REFERENCE X(9) 'Hello '; 10727 4: Group BY REFERENCE (18) 'Hello World '; 10728CAPI called with 3 parameters 10729 1: COMP-3 BY REFERENCE 9(8) 00004099; 10730 2: EDITED BY REFERENCE S9(5)V9(2) 514.07- to 512.77 ; 10731 3: X BY REFERENCE X(9) 'Bye! '; 10732CAPI called with 2 parameters 10733 1: BINARY BY REFERENCE 9(5) 0000001283; 10734 2: EDITED BY REFERENCE S9(5)V9(2) 512.77 to 514.07-; 10735CAPI called with 2 parameters 10736 1: BINARY BY REFERENCE 9(5) 0000001286; 10737 2: X BY VALUE X(9) 'Hello! '; 10738CAPI called with 2 parameters 10739 1: BINARY BY REFERENCE 9(5) 0000001289; 10740 2: X BY VALUE X(9) 'Hello! '; 10741CAPI called with 1 parameters 10742 1: BINARY BY VALUE S9(9) +000000018; 10743CAPI called with 2 parameters 10744 1: Group BY VALUE (18) 'Bye-Bye Birdie! '; 10745 2: DISPLAY BY VALUE 9(2) 18; 10746CAPI called with 2 parameters 10747 1: X BY VALUE X(9) 'Fred Fish'; 10748 2: COMP-3 BY REFERENCE 9(8) 00004102; 10749CAPI called with 1 parameters 10750 1: COMP-3 BY REFERENCE S9(7)V9(2) +0000012.50; 10751CAPI called with 0 parameters 10752COMP3 is now 00004105; 10753COMP4 is now 0000001292; 10754BINFLD5S is now +01030; 10755CHRX is now Hello! ; 10756NE is now 514.07-; 10757], 10758[libcob: warning: cob_put_field_str: attempt to over-write constant field with '2563' 10759libcob: warning: cob_put_field_str: attempt to over-write constant field with '19' 10760libcob: warning: cob_put_field_str: attempt to over-write constant field with 'Bye!' 10761libcob: warning: cob_put_field_str: attempt to over-write constant field with 'Bye!' 10762libcob: warning: cob_put_field_str: attempt to over-write constant field with '21' 10763libcob: warning: cob_put_field_str: attempt to over-write constant field with 'Bye-Bye Birdie!' 10764libcob: warning: cob_put_field_str: attempt to over-write constant field with '21' 10765libcob: warning: cob_put_field_str: attempt to over-write constant field with 'Bye!' 10766]) 10767 10768AT_CLEANUP 10769 10770 10771AT_SETUP([DEFAULT ROUNDED MODE]) 10772AT_KEYWORDS([runmisc]) 10773 10774AT_DATA([prog.cob], [ 10775 IDENTIFICATION DIVISION. 10776 PROGRAM-ID. prog. 10777 OPTIONS. 10778 DEFAULT ROUNDED NEAREST-EVEN. 10779 10780 DATA DIVISION. 10781 WORKING-STORAGE SECTION. 10782 01 x PIC 9. 10783 10784 PROCEDURE DIVISION. 10785 COMPUTE x ROUNDED = 1.5 10786 DISPLAY x 10787 COMPUTE x ROUNDED = 2.5 10788 DISPLAY x 10789 . 10790]) 10791 10792AT_CHECK([$COMPILE -o prog prog.cob], [0], [], []) 10793AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10794[2 107952 10796]) 10797 10798AT_CLEANUP 10799 10800 10801AT_SETUP([OCCURS INDEXED ASCENDING]) 10802AT_KEYWORDS([occurs extension]) 10803 10804AT_DATA([prog.cob], [ 10805 IDENTIFICATION DIVISION. 10806 PROGRAM-ID. prog. 10807 DATA DIVISION. 10808 WORKING-STORAGE SECTION. 10809 01 DBI-RECORD-NAMEST. 10810 05 FILLER. 10811 10 FILLER PIC X(35) 10812 VALUE 'A-F-GEN-LEDGER-ACM 0315 '. 10813 10 FILLER PIC X(35) 10814 VALUE 'A-F-GEN-LEDGER-MGL 0303 '. 10815 10 FILLER PIC X(35) 10816 VALUE 'A-F-GEN-LEDGER-ZBL 0304 '. 10817 10 FILLER PIC X(35) 10818 VALUE 'A-F-GEN-LEDGER-ZCC 0308 '. 10819 10 FILLER PIC X(35) 10820 VALUE 'A-F-GEN-LEDGER-ZGL 0305 '. 10821 10 FILLER PIC X(35) 10822 VALUE 'A-F-GEN-LEDGER-ZOO 0306 '. 10823 10 FILLER PIC X(35) 10824 VALUE 'A-F-GEN-LEDGER-ZTR 0307 '. 10825 01 DBI-RECORD-NAMESR REDEFINES DBI-RECORD-NAMEST. 10826 05 DBI-RECORD-NAMES 10827 OCCURS 7 TIMES 10828 INDEXED BY REC-NAME-IDX 10829 ASCENDING KEY IS DBI-RECORD-NAME 10830 . 10831 10 DBI-RECORD-NAME PIC X(30). 10832 10 DBI-RECORD-CODE PIC 9(4). 10833 10 DBI-RECORD-DIR PIC X. 10834 01 REC-NAME PIC X(30). 10835 01 DBX-RECORD-NAMEST. 10836 05 FILLER. 10837 10 FILLER PIC X(35) 10838 VALUE 'A-F-GEN-LEDGER-ACM 0315 '. 10839 10 FILLER PIC X(35) 10840 VALUE 'A-F-GEN-LEDGER-MGL 0303 '. 10841 10 FILLER PIC X(35) 10842 VALUE 'A-F-GEN-LEDGER-ZBL 0304 '. 10843 10 FILLER PIC X(35) 10844 VALUE 'A-F-GEN-LEDGER-ZCC 0308 '. 10845 10 FILLER PIC X(35) 10846 VALUE 'A-F-GEN-LEDGER-ZGL 0305 '. 10847 10 FILLER PIC X(35) 10848 VALUE 'A-F-GEN-LEDGER-ZOO 0306 '. 10849 10 FILLER PIC X(35) 10850 VALUE 'A-F-GEN-LEDGER-ZTR 0307 '. 10851 01 DBX-RECORD-NAMESR REDEFINES DBX-RECORD-NAMEST. 10852 05 DBX-RECORD-NAMES 10853 OCCURS 7 TIMES 10854 ASCENDING KEY IS DBX-RECORD-NAME 10855 INDEXED BY REC-NAME-DBX 10856 . 10857 10 DBX-RECORD-NAME PIC X(30). 10858 10 DBX-RECORD-CODE PIC 9(4). 10859 10 DBX-RECORD-DIR PIC X. 10860 10861 PROCEDURE DIVISION. 10862 MAIN. 10863 MOVE 'A-F-GEN-LEDGER-ZGL' TO REC-NAME. 10864 PERFORM FINDIT. 10865 MOVE 'JUNK' TO REC-NAME. 10866 PERFORM FINDIT. 10867 STOP RUN. 10868 10869 FINDIT. 10870 SEARCH DBI-RECORD-NAMES 10871 AT END 10872 DISPLAY 'A ' REC-NAME ' is invalid.' 10873 WHEN REC-NAME = DBI-RECORD-NAME (REC-NAME-IDX) 10874 DISPLAY 'A ' REC-NAME ' is code ' 10875 DBI-RECORD-CODE (REC-NAME-IDX) '.'. 10876 10877 SEARCH DBX-RECORD-NAMES 10878 AT END 10879 DISPLAY 'B ' REC-NAME ' is invalid.' 10880 WHEN REC-NAME = DBX-RECORD-NAME (REC-NAME-DBX) 10881 DISPLAY 'B ' REC-NAME ' is code ' 10882 DBX-RECORD-CODE (REC-NAME-DBX) '.'. 10883]) 10884 10885AT_CHECK([$COMPILE -frelax-syntax-checks prog.cob ], [0], [], 10886[prog.cob:26: warning: INDEXED should follow ASCENDING/DESCENDING 10887]) 10888 10889AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 10890[A A-F-GEN-LEDGER-ZGL is code 0305. 10891B A-F-GEN-LEDGER-ZGL is code 0305. 10892A JUNK is invalid. 10893B JUNK is invalid. 10894], []) 10895 10896AT_CLEANUP 10897 10898 10899AT_SETUP([ZERO unsigned and negative binary subscript]) 10900AT_KEYWORDS([runmisc]) 10901 10902AT_DATA([prog.cob], [ 10903 IDENTIFICATION DIVISION. 10904 PROGRAM-ID. prog. 10905 DATA DIVISION. 10906 WORKING-STORAGE SECTION. 10907 77 UBIN PIC 9(8) BINARY. 10908 77 SBIN PIC S9(8) BINARY. 10909 77 UNUP PIC 9(8). 10910 77 SNUP PIC S9(8). 10911 10912 01 TSTREC. 10913 05 TSTX PIC X(4) OCCURS 3 TIMES. 10914 05 TSTY PIC X(4) OCCURS 3 TIMES. 10915 10916 PROCEDURE DIVISION. 10917 MOVE ALL 'A' TO TSTX(1). 10918 MOVE ALL 'B' TO TSTX(2). 10919 MOVE ALL 'C' TO TSTX(3). 10920 MOVE ALL '1' TO TSTY(1). 10921 MOVE ALL '2' TO TSTY(2). 10922 MOVE ALL '3' TO TSTY(3). 10923 MOVE 0 TO UNUP. 10924 DISPLAY "UNUP: " UNUP " is :" TSTY(UNUP) ":" UPON CONSOLE. 10925 MOVE 0 TO SNUP. 10926 DISPLAY "SNUP: " SNUP " is :" TSTY(SNUP) ":" UPON CONSOLE. 10927 MOVE 0 TO SBIN. 10928 DISPLAY "SBIN: " SBIN " is :" TSTY(SBIN) ":" UPON CONSOLE. 10929 MOVE -1 TO SBIN. 10930 DISPLAY "SBIN: " SBIN " is :" TSTY(SBIN) ":" UPON CONSOLE. 10931 MOVE 'xxx' TO TSTY(SBIN). 10932 DISPLAY "SBIN: " SBIN " is :" TSTY(SBIN) ":" UPON CONSOLE. 10933 * The following would often core dump 10934 MOVE 0 TO UBIN. 10935 DISPLAY "UBIN: " UBIN " is :" TSTY(UBIN) ":" UPON CONSOLE. 10936 MOVE 'xxx' TO TSTY(UBIN). 10937 MOVE 1 TO UBIN. 10938 DISPLAY "UBIN: " UBIN " is :" TSTY(UBIN) ":" UPON CONSOLE. 10939 STOP RUN. 10940]) 10941 10942# Safe run with runtime checks 10943AT_CHECK([$COMPILE prog.cob], [0], [], []) 10944AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], 10945[libcob: prog.cob:23: error: subscript of 'TSTY' out of bounds: 0 10946]) 10947 10948# Runtime checks disable, subscript may be zero or even negative 10949AT_CHECK([$COBC -x prog.cob -o prog_unsafe], [0], [], []) 10950AT_CHECK([$COBCRUN_DIRECT ./prog_unsafe], [0], 10951[UNUP: 00000000 is :CCCC: 10952SNUP: +00000000 is :CCCC: 10953SBIN: +00000000 is :CCCC: 10954SBIN: -00000001 is :BBBB: 10955SBIN: -00000001 is :xxx : 10956UBIN: 00000000 is :CCCC: 10957UBIN: 00000001 is :1111: 10958], []) 10959 10960AT_CLEANUP 10961 10962 10963AT_SETUP([Default Arithmetic (1)]) 10964AT_KEYWORDS([runmisc]) 10965 10966AT_DATA([prog.cob], [ 10967 IDENTIFICATION DIVISION. 10968 PROGRAM-ID. prog. 10969 DATA DIVISION. 10970 WORKING-STORAGE SECTION. 10971 01 NUM-A PIC 9(3) VALUE 399. 10972 01 NUM-B PIC 9(3) VALUE 211. 10973 01 NUM-C PIC 9(3)V99 VALUE 212.34. 10974 01 NUMV1 PIC 9(3)V9. 10975 01 PICX PIC X VALUE 'A'. 10976 01 RSLT PIC 9(3). 10977 01 RSLTV1 PIC 9(3).9. 10978 01 RSLTV2 PIC 9(3).99. 10979 * 10980 PROCEDURE DIVISION. 10981 MAIN. 10982 COMPUTE RSLT = NUM-A + 1.1. 10983 DISPLAY 'Simple Compute RSLT IS ' RSLT 10984 COMPUTE RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 10985 DISPLAY 'Single Variable RSLT IS ' RSLT 10986 COMPUTE RSLTV2, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 10987 DISPLAY 'Compute RSLT IS ' RSLT 10988 DISPLAY 'Compute RSLTv99 IS ' RSLTV2 10989 COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 10990 DISPLAY 'Compute RSLT IS ' RSLT 10991 DISPLAY 'Compute RSLTv9 IS ' RSLTV1 10992 MOVE 0 TO RSLT 10993 ADD NUM-C TO RSLT. 10994 DISPLAY 'Add RSLT IS ' RSLT. 10995 MOVE 0 TO RSLT 10996 ADD NUM-A NUM-C 10 TO RSLT. 10997 DISPLAY 'Add RSLT IS ' RSLT. 10998 SUBTRACT NUM-C FROM RSLT. 10999 DISPLAY 'Subtract RSLT IS ' RSLT. 11000 SUBTRACT NUM-A -10 FROM RSLT. 11001 DISPLAY 'Subtract RSLT IS ' RSLT. 11002 MOVE 0 TO RSLT 11003 ADD NUM-A NUM-C TO RSLT GIVING RSLTV1. 11004 DISPLAY 'Add RSLTv9 IS ' RSLTV1 11005 MULTIPLY NUM-A BY NUM-C GIVING RSLT. 11006 DISPLAY 'Multiply RSLT IS ' RSLT. 11007 MULTIPLY RSLT BY NUM-C. 11008 DISPLAY 'Multiply RSLT IS ' RSLT. 11009 DIVIDE NUM-A BY 10 GIVING RSLT. 11010 DISPLAY 'Divide RSLT IS ' RSLT. 11011 DIVIDE RSLT BY 4 GIVING RSLTV1. 11012 DISPLAY 'Divide RSLTv9 IS ' RSLTV1. 11013 DIVIDE RSLT BY 4 GIVING RSLT. 11014 DISPLAY 'Divide RSLT IS ' RSLT. 11015 11016 COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 11017 DISPLAY 'Simple RSLT IS ' RSLT 11018 ' RSLTv9 IS ' RSLTV1. 11019 11020 COMPUTE RSLTV1, RSLT = ((NUM-A / (100.55 + -0.550)) 11021 - (NUM-B / (10.11 * 10 - 1.1))) 11022 * (220 / 2.2) 11023 DISPLAY 'Complex RSLT IS ' RSLT 11024 ' RSLTv9 IS ' RSLTV1. 11025 11026 COMPUTE RSLTV1, RSLT = ((NUM-A / (101 - 1)) 11027 - (NUM-B / (10 * 10))) * (200 / 2) 11028 DISPLAY 'Reduced RSLT IS ' RSLT 11029 ' RSLTv9 IS ' RSLTV1. 11030 MOVE NUM-A TO NUMV1. 11031 IF ((NUMV1 / (101 - 1)) 11032 - (NUM-B / (10 * 10))) * (200 / 2) EQUAL 188 11033 DISPLAY "Not Using ARITHMETIC-OSVS" 11034 ELSE 11035 DISPLAY "Using ARITHMETIC-OSVS" 11036 END-IF. 11037 STOP RUN. 11038]) 11039AT_CHECK([$COMPILE prog.cob], [0], [], []) 11040 11041AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11042[Simple Compute RSLT IS 400 11043Single Variable RSLT IS 188 11044Compute RSLT IS 188 11045Compute RSLTv99 IS 188.00 11046Compute RSLT IS 188 11047Compute RSLTv9 IS 188.0 11048Add RSLT IS 212 11049Add RSLT IS 621 11050Subtract RSLT IS 408 11051Subtract RSLT IS 019 11052Add RSLTv9 IS 611.3 11053Multiply RSLT IS 723 11054Multiply RSLT IS 723 11055Divide RSLT IS 039 11056Divide RSLTv9 IS 009.7 11057Divide RSLT IS 009 11058Simple RSLT IS 188 RSLTv9 IS 188.0 11059Complex RSLT IS 188 RSLTv9 IS 188.0 11060Reduced RSLT IS 188 RSLTv9 IS 188.0 11061Not Using ARITHMETIC-OSVS 11062], []) 11063 11064AT_CLEANUP 11065 11066 11067AT_SETUP([Default Arithmetic Test (2)]) 11068AT_KEYWORDS([runmisc]) 11069 11070AT_DATA([prog.cob], [ 11071 IDENTIFICATION DIVISION. 11072 PROGRAM-ID. prog. 11073 ENVIRONMENT DIVISION. 11074 DATA DIVISION. 11075 WORKING-STORAGE SECTION. 11076 01 VAL PIC S9(7)V99 COMP-3 VALUE 20500. 11077 01 DIV1 PIC S9(7)V99 COMP-3 VALUE 0.9. 11078 01 DIV2 PIC S9(7)V99 COMP-3 VALUE 33.45. 11079 01 DIV3 PIC S9(7)V99 COMP-3 VALUE 9. 11080 01 MUL1 PIC S9(7)V99 COMP-3 VALUE 10. 11081 01 MUL2 PIC S9(7)V99 COMP-3 VALUE 5. 11082 01 MUL3 PIC S9(7)V99 COMP-3 VALUE 2. 11083 01 RES PIC S9(7)V99 COMP-3. 11084 PROCEDURE DIVISION. 11085 COMPUTE RES = VAL / DIV1 / DIV2. 11086 DISPLAY 'RES = ' RES. 11087 COMPUTE RES ROUNDED = VAL / DIV1 / DIV2. 11088 DISPLAY 'RES ROUNDED = ' RES. 11089 COMPUTE RES = VAL * MUL1 / DIV3 / DIV2. 11090 DISPLAY 'RES MULT1 = ' RES. 11091 COMPUTE RES = VAL * MUL2 * MUL3 / DIV3 / DIV2. 11092 DISPLAY 'RES MULT2 = ' RES. 11093 COMPUTE RES = VAL / DIV1. 11094 DISPLAY 'RES 1 = ' RES. 11095 COMPUTE RES = RES / DIV2. 11096 DISPLAY 'RES F = ' RES. 11097 COMPUTE RES ROUNDED MODE AWAY-FROM-ZERO = 11098 VAL / DIV1 / DIV2. 11099 DISPLAY 'RES ROUNDED AWAY = ' RES. 11100 STOP RUN. 11101]) 11102 11103AT_CHECK([$COMPILE prog.cob], [0], [], []) 11104 11105AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11106[RES = +0000680.95 11107RES ROUNDED = +0000680.95 11108RES MULT1 = +0000680.95 11109RES MULT2 = +0000680.95 11110RES 1 = +0022777.77 11111RES F = +0000680.94 11112RES ROUNDED AWAY = +0000680.96 11113], []) 11114 11115AT_CLEANUP 11116 11117 11118AT_SETUP([OSVS Arithmetic (1)]) 11119AT_KEYWORDS([runmisc]) 11120 11121AT_DATA([prog.cob], [ 11122 IDENTIFICATION DIVISION. 11123 PROGRAM-ID. prog. 11124 DATA DIVISION. 11125 WORKING-STORAGE SECTION. 11126 01 NUM-A PIC 9(3) VALUE 399. 11127 01 NUM-B PIC 9(3) VALUE 211. 11128 01 NUM-C PIC 9(3)V99 VALUE 212.34. 11129 01 NUMV1 PIC 9(3)V9. 11130 01 PICX PIC X VALUE 'A'. 11131 01 RSLT PIC 9(3). 11132 01 RSLTV1 PIC 9(3).9. 11133 01 RSLTV2 PIC 9(3).99. 11134 * 11135 PROCEDURE DIVISION. 11136 MAIN. 11137 COMPUTE RSLT = NUM-A + 1.1. 11138 DISPLAY 'Simple Compute RSLT IS ' RSLT 11139 COMPUTE RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 11140 DISPLAY 'Single Variable RSLT IS ' RSLT 11141 COMPUTE RSLTV2, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 11142 DISPLAY 'Compute RSLT IS ' RSLT 11143 DISPLAY 'Compute RSLTv99 IS ' RSLTV2 11144 COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 11145 DISPLAY 'Compute RSLT IS ' RSLT 11146 DISPLAY 'Compute RSLTv9 IS ' RSLTV1 11147 MOVE 0 TO RSLT 11148 ADD NUM-C TO RSLT. 11149 DISPLAY 'Add RSLT IS ' RSLT. 11150 MOVE 0 TO RSLT 11151 ADD NUM-A NUM-C 10 TO RSLT. 11152 DISPLAY 'Add RSLT IS ' RSLT. 11153 SUBTRACT NUM-C FROM RSLT. 11154 DISPLAY 'Subtract RSLT IS ' RSLT. 11155 SUBTRACT NUM-A -10 FROM RSLT. 11156 DISPLAY 'Subtract RSLT IS ' RSLT. 11157 MOVE 0 TO RSLT 11158 ADD NUM-A NUM-C TO RSLT GIVING RSLTV1. 11159 DISPLAY 'Add RSLTv9 IS ' RSLTV1 11160 MULTIPLY NUM-A BY NUM-C GIVING RSLT. 11161 DISPLAY 'Multiply RSLT IS ' RSLT. 11162 MULTIPLY RSLT BY NUM-C. 11163 DISPLAY 'Multiply RSLT IS ' RSLT. 11164 DIVIDE NUM-A BY 10 GIVING RSLT. 11165 DISPLAY 'Divide RSLT IS ' RSLT. 11166 DIVIDE RSLT BY 4 GIVING RSLTV1. 11167 DISPLAY 'Divide RSLTv9 IS ' RSLTV1. 11168 DIVIDE RSLT BY 4 GIVING RSLT. 11169 DISPLAY 'Divide RSLT IS ' RSLT. 11170 11171 COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 11172 DISPLAY 'Simple RSLT IS ' RSLT 11173 ' RSLTv9 IS ' RSLTV1. 11174 11175 COMPUTE RSLTV1, RSLT = ((NUM-A / (100.55 + -0.550)) 11176 - (NUM-B / (10.11 * 10 - 1.1))) 11177 * (220 / 2.2) 11178 DISPLAY 'Complex RSLT IS ' RSLT 11179 ' RSLTv9 IS ' RSLTV1. 11180 11181 COMPUTE RSLTV1, RSLT = ((NUM-A / (101 - 1)) 11182 - (NUM-B / (10 * 10))) * (200 / 2) 11183 DISPLAY 'Reduced RSLT IS ' RSLT 11184 ' RSLTv9 IS ' RSLTV1. 11185 MOVE NUM-A TO NUMV1. 11186 IF ((NUMV1 / (101 - 1)) 11187 - (NUM-B / (10 * 10))) * (200 / 2) EQUAL 188 11188 DISPLAY "Not Using ARITHMETIC-OSVS" 11189 ELSE 11190 DISPLAY "Using ARITHMETIC-OSVS" 11191 END-IF. 11192 STOP RUN. 11193]) 11194 11195AT_CHECK([$COMPILE -farithmetic-osvs prog.cob], [0], [], 11196[prog.cob: in paragraph 'MAIN': 11197prog.cob:19: warning: precision of result may change with arithmetic-osvs 11198prog.cob:21: warning: precision of result may change with arithmetic-osvs 11199prog.cob:24: warning: precision of result may change with arithmetic-osvs 11200prog.cob:31: warning: precision of result may change with arithmetic-osvs 11201prog.cob:35: warning: precision of result may change with arithmetic-osvs 11202prog.cob:38: warning: precision of result may change with arithmetic-osvs 11203prog.cob:51: warning: precision of result may change with arithmetic-osvs 11204prog.cob:55: warning: precision of result may change with arithmetic-osvs 11205prog.cob:61: warning: precision of result may change with arithmetic-osvs 11206prog.cob:66: warning: precision of result may change with arithmetic-osvs 11207]) 11208 11209AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11210[Simple Compute RSLT IS 400 11211Single Variable RSLT IS 100 11212Compute RSLT IS 188 11213Compute RSLTv99 IS 188.00 11214Compute RSLT IS 180 11215Compute RSLTv9 IS 180.0 11216Add RSLT IS 212 11217Add RSLT IS 621 11218Subtract RSLT IS 408 11219Subtract RSLT IS 019 11220Add RSLTv9 IS 611.3 11221Multiply RSLT IS 723 11222Multiply RSLT IS 723 11223Divide RSLT IS 039 11224Divide RSLTv9 IS 009.7 11225Divide RSLT IS 009 11226Simple RSLT IS 180 RSLTv9 IS 180.0 11227Complex RSLT IS 188 RSLTv9 IS 188.0 11228Reduced RSLT IS 180 RSLTv9 IS 180.0 11229Using ARITHMETIC-OSVS 11230], []) 11231 11232AT_CLEANUP 11233 11234 11235AT_SETUP([OSVS Arithmetic Test (2)]) 11236AT_KEYWORDS([runmisc]) 11237 11238AT_DATA([prog.cob], [ 11239 IDENTIFICATION DIVISION. 11240 PROGRAM-ID. prog. 11241 ENVIRONMENT DIVISION. 11242 DATA DIVISION. 11243 WORKING-STORAGE SECTION. 11244 01 VAL PIC S9(7)V99 COMP-3 VALUE 20500. 11245 01 DIV1 PIC S9(7)V99 COMP-3 VALUE 0.9. 11246 01 DIV2 PIC S9(7)V99 COMP-3 VALUE 33.45. 11247 01 DIV3 PIC S9(7)V99 COMP-3 VALUE 9. 11248 01 MUL1 PIC S9(7)V99 COMP-3 VALUE 10. 11249 01 MUL2 PIC S9(7)V99 COMP-3 VALUE 5. 11250 01 MUL3 PIC S9(7)V99 COMP-3 VALUE 2. 11251 01 RES PIC S9(7)V99 COMP-3. 11252 PROCEDURE DIVISION. 11253 COMPUTE RES = VAL / DIV1 / DIV2. 11254 DISPLAY 'RES = ' RES. 11255 COMPUTE RES ROUNDED = VAL / DIV1 / DIV2. 11256 DISPLAY 'RES ROUNDED = ' RES. 11257 COMPUTE RES = VAL * MUL1 / DIV3 / DIV2. 11258 DISPLAY 'RES MULT1 = ' RES. 11259 COMPUTE RES = VAL * MUL2 * MUL3 / DIV3 / DIV2. 11260 DISPLAY 'RES MULT2 = ' RES. 11261 COMPUTE RES = VAL / DIV1. 11262 DISPLAY 'RES 1 = ' RES. 11263 COMPUTE RES = RES / DIV2. 11264 DISPLAY 'RES F = ' RES. 11265 COMPUTE RES ROUNDED MODE AWAY-FROM-ZERO = 11266 VAL / DIV1 / DIV2. 11267 DISPLAY 'RES ROUNDED AWAY = ' RES. 11268 STOP RUN. 11269]) 11270 11271AT_CHECK([$COMPILE -std=ibm prog.cob], [0], [], 11272[prog.cob:16: warning: precision of result may change with arithmetic-osvs 11273prog.cob:18: warning: precision of result may change with arithmetic-osvs 11274prog.cob:20: warning: precision of result may change with arithmetic-osvs 11275prog.cob:22: warning: precision of result may change with arithmetic-osvs 11276prog.cob:28: warning: precision of result may change with arithmetic-osvs 11277]) 11278 11279AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11280[RES = +000068094 11281RES ROUNDED = +000068095 11282RES MULT1 = +000068094 11283RES MULT2 = +000068095 11284RES 1 = +002277777 11285RES F = +000068094 11286RES ROUNDED AWAY = +000068095 11287], []) 11288 11289AT_CLEANUP 11290 11291 11292AT_SETUP([SET CONSTANT directive]) 11293AT_KEYWORDS([misc directives extensions]) 11294 11295# The SET CONSTANT directive defines a level78 variable 11296# for the current compilation unit 11297 11298# original MF extension: $SET CONSTANT 11299AT_DATA([prog.cob], [ 11300 $SET CONSTANT DOGGY "Barky" 11301 $SET CONSTANT PONY "Blacky" 11302 IDENTIFICATION DIVISION. 11303 PROGRAM-ID. prog. 11304 DATA DIVISION. 11305 WORKING-STORAGE SECTION. 11306 01 THEDOG PIC X(6) VALUE DOGGY. 11307 77 MYHORSE PIC X(7) VALUE PONY. 11308 $SET CONSTANT PONY "White" 11309 * 11310 PROCEDURE DIVISION. 11311 MAIN. 11312 DISPLAY "Your Dog's name is " DOGGY ";". 11313 DISPLAY "The Dog's name is " THEDOG ";". 11314 DISPLAY "My Horse is " MYHORSE ";". 11315 DISPLAY "My little pony is " PONY ".". 11316 STOP RUN. 11317]) 11318 11319# OpenCOBOL/GnuCOBOL extension: >>SET CONSTANT 11320AT_DATA([prog2.cob], [ 11321 >>SET CONSTANT DOGGY "Barky" 11322 >>SET CONSTANT PONY "Blacky" 11323 IDENTIFICATION DIVISION. 11324 PROGRAM-ID. prog2. 11325 DATA DIVISION. 11326 WORKING-STORAGE SECTION. 11327 01 THEDOG PIC X(6) VALUE DOGGY. 11328 77 MYHORSE PIC X(7) VALUE PONY. 11329 >>SET CONSTANT PONY "White" 11330 * 11331 PROCEDURE DIVISION. 11332 MAIN. 11333 DISPLAY "Your Dog's name is " DOGGY ";". 11334 DISPLAY "The Dog's name is " THEDOG ";". 11335 DISPLAY "My Horse is " MYHORSE ";". 11336 DISPLAY "My little pony is " PONY ".". 11337 STOP RUN. 11338]) 11339 11340# OpenCOBOL/GnuCOBOL extension: >>DEFINE CONSTANT 11341AT_DATA([prog3.cob], [ 11342 >>DEFINE CONSTANT DOGGY "Barky" 11343 >>DEFINE CONSTANT PONY "Blacky" 11344 IDENTIFICATION DIVISION. 11345 PROGRAM-ID. prog3. 11346 DATA DIVISION. 11347 WORKING-STORAGE SECTION. 11348 01 THEDOG PIC X(6) VALUE DOGGY. 11349 77 MYHORSE PIC X(7) VALUE PONY. 11350 >>DEFINE CONSTANT PONY "White" OVERRIDE 11351 * 11352 PROCEDURE DIVISION. 11353 MAIN. 11354 DISPLAY "Your Dog's name is " DOGGY ";". 11355 DISPLAY "The Dog's name is " THEDOG ";". 11356 DISPLAY "My Horse is " MYHORSE ";". 11357 DISPLAY "My little pony is " PONY ".". 11358 STOP RUN. 11359]) 11360 11361AT_CHECK([$COMPILE -std=mf prog.cob], [0], [], []) 11362 11363# Note: MF does not redefine a value via SET CONSTANT 11364# the first definitions wins (we should add a warning) 11365AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11366[Your Dog's name is Barky; 11367The Dog's name is Barky ; 11368My Horse is Blacky ; 11369My little pony is Blacky. 11370], []) 11371 11372AT_CHECK([$COMPILE prog2.cob], [0], [], []) 11373 11374# Note: MF does not redefine a value via SET CONSTANT 11375# the first definitions wins (we should add a warning) 11376AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], 11377[Your Dog's name is Barky; 11378The Dog's name is Barky ; 11379My Horse is Blacky ; 11380My little pony is Blacky. 11381], []) 11382 11383AT_CHECK([$COMPILE -fdefine-constant-directive=ok prog3.cob], [0], [], []) 11384 11385AT_CHECK([$COBCRUN_DIRECT ./prog3], [0], 11386[Your Dog's name is Barky; 11387The Dog's name is Barky ; 11388My Horse is Blacky ; 11389My little pony is White. 11390], []) 11391 11392AT_CLEANUP 11393 11394 11395AT_SETUP([DEFINE OVERRIDE]) 11396AT_KEYWORDS([CDF directive]) 11397 11398AT_DATA([prog.cob], [ 11399 IDENTIFICATION DIVISION. 11400 PROGRAM-ID. prog. 11401 DATA DIVISION. 11402 >>SET CONSTANT DOGGY "Pluto" 11403 >>SET CONSTANT PONY "Piper" 11404 WORKING-STORAGE SECTION. 11405 01 THEDOG PIC X(6) VALUE DOGGY. 11406 11407 >>DEFINE DPONY AS PARAMETER OVERRIDE 11408 >>IF DPONY IS NOT DEFINED 11409 >>DEFINE DPONY AS "No Dpony" 11410 >>END-IF 11411 01 CNSPONY CONSTANT FROM DPONY. 11412 11413 >>DEFINE ENVPONY AS PARAMETER OVERRIDE 11414 >>IF ENVPONY IS NOT DEFINED 11415 >>DEFINE ENVPONY AS "No EnvPony" 11416 >>END-IF 11417 01 HORSE CONSTANT FROM ENVPONY. 11418 77 MYHORSE PIC X(12) VALUE HORSE . 11419 77 MYPONYENV PIC X(12). 11420 * 11421 PROCEDURE DIVISION. 11422 MAIN. 11423 DISPLAY "ENVPONY" UPON ENVIRONMENT-NAME 11424 ACCEPT MYPONYENV FROM ENVIRONMENT-VALUE. 11425 DISPLAY "ENVPONY env var set to " MYPONYENV ";". 11426 DISPLAY "1st Dog's name is " DOGGY ";". 11427 DISPLAY "2nd Dog's name is " PONY ";". 11428 >>IF ENVPONY IS DEFINED 11429 DISPLAY "ENVPONY is DEFINED as " HORSE ";". 11430 >>ELSE 11431 DISPLAY "ENVPONY was NOT DEFINED;". 11432 >>END-IF 11433 DISPLAY "DPONY set to " CNSPONY ";". 11434 >>IF ENVPONY = "WHITE" 11435 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE 11436 >>ELSE 11437 >>DEFINE CONSTANT PONY AS "default Dirty" OVERRIDE 11438 >>END-IF 11439 DISPLAY "My pony is " PONY ";". 11440 >>IF DPONY IS DEFINED 11441 DISPLAY "DPONY is DEFINED as " CNSPONY ";". 11442 >>END-IF 11443 STOP RUN. 11444]) 11445 11446AT_CHECK([ENVPONY=WHITE $COMPILE prog.cob -fdefine-constant-directive=ok -DDPONY=Stallone], [0], [], []) 11447 11448AT_CHECK([ENVPONY=WHITE ./prog], [0], 11449[ENVPONY env var set to WHITE ; 114501st Dog's name is Pluto; 114512nd Dog's name is Piper; 11452ENVPONY is DEFINED as WHITE; 11453DPONY set to Stallone; 11454My pony is White Horse; 11455DPONY is DEFINED as Stallone; 11456], []) 11457 11458AT_CLEANUP 11459 11460 11461AT_SETUP([DEFINE Defaults]) 11462AT_KEYWORDS([CDF directive]) 11463 11464AT_DATA([prog.cob], [ 11465 IDENTIFICATION DIVISION. 11466 PROGRAM-ID. prog. 11467 DATA DIVISION. 11468 >>SET CONSTANT DOGGY "Pluto" 11469 >>SET CONSTANT PONY "Piper" 11470 WORKING-STORAGE SECTION. 11471 01 THEDOG PIC X(6) VALUE DOGGY. 11472 11473 >>DEFINE DPONY AS PARAMETER OVERRIDE 11474 >>IF DPONY IS NOT DEFINED 11475 >>DEFINE DPONY AS "No Dpony" 11476 >>END-IF 11477 01 CNSPONY CONSTANT FROM DPONY. 11478 11479 >>DEFINE ENVPONY AS PARAMETER OVERRIDE 11480 >>IF ENVPONY IS NOT DEFINED 11481 >>DEFINE ENVPONY AS "No EnvPony" 11482 >>END-IF 11483 01 HORSE CONSTANT FROM ENVPONY. 11484 77 MYHORSE PIC X(12) VALUE HORSE . 11485 77 MYPONYENV PIC X(12). 11486 * 11487 PROCEDURE DIVISION. 11488 MAIN. 11489 DISPLAY "ENVPONY" UPON ENVIRONMENT-NAME 11490 ACCEPT MYPONYENV FROM ENVIRONMENT-VALUE. 11491 DISPLAY "ENVPONY env var set to " MYPONYENV ";". 11492 DISPLAY "1st Dog's name is " DOGGY ";". 11493 DISPLAY "2nd Dog's name is " PONY ";". 11494 >>IF ENVPONY IS DEFINED 11495 DISPLAY "ENVPONY is DEFINED as " HORSE ";". 11496 >>ELSE 11497 DISPLAY "ENVPONY was NOT DEFINED;". 11498 >>END-IF 11499 DISPLAY "DPONY set to " CNSPONY ";". 11500 >>IF ENVPONY = "WHITE" 11501 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE 11502 >>ELSE 11503 >>DEFINE CONSTANT PONY AS "default Dirty" OVERRIDE 11504 >>END-IF 11505 DISPLAY "My pony is " PONY ";". 11506 >>IF DPONY IS DEFINED 11507 DISPLAY "DPONY is DEFINED as " CNSPONY ";". 11508 >>END-IF 11509 STOP RUN. 11510]) 11511 11512AT_CHECK([$COMPILE prog.cob -fdefine-constant-directive=ok], [0], [], []) 11513 11514AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11515[ENVPONY env var set to ; 115161st Dog's name is Pluto; 115172nd Dog's name is Piper; 11518ENVPONY is DEFINED as No EnvPony; 11519DPONY set to No Dpony; 11520My pony is default Dirty; 11521DPONY is DEFINED as No Dpony; 11522], []) 11523 11524AT_CLEANUP 11525 11526 11527AT_SETUP([78 VALUE]) 11528AT_KEYWORDS([CONSTANT misc]) 11529 11530AT_DATA([prog.cob], [ 11531 IDENTIFICATION DIVISION. 11532 PROGRAM-ID. prog. 11533 DATA DIVISION. 11534 WORKING-STORAGE SECTION. 11535 78 DOGGY VALUE "Barky". 11536 01 MYREC. 11537 05 FLD1 PIC 9(2). 11538 05 FLD2 PIC X(7). 11539 05 FLD3 PIC X(2) OCCURS 5 TIMES. 11540 05 FLD4 PIC X(4). 11541 05 FLD5 PIC X(4). 11542 01 PICX PIC XXX VALUE 'Abc'. 11543 78 HUN VALUE 10 * (10 + LENGTH OF PICX) + 12.35-2+3. 11544 78 HUN2 VALUE HUN * (10 + LENGTH OF PICX) -4. 11545 01 THEDOG PIC X(6) VALUE DOGGY. 11546 78 DIV1 VALUE 100 / 3. 11547 78 NUM2 VALUE 1 + 2 * 3. 11548 LINKAGE SECTION. 11549 01 XMYREC. 11550 05 XFLD1 PIC 9(2). 11551 05 XFLD2 PIC X(7). 11552 78 XPOS3 VALUE NEXT. 11553 05 XFLD3 PIC X(2) OCCURS 5 TIMES. 11554 78 XPOS4 VALUE NEXT. 11555 05 XFLD4 PIC X(4). 11556 05 XFLD5 PIC X(4). 11557 78 XSTRT4 VALUE START OF XFLD4. 11558 * 11559 PROCEDURE DIVISION. 11560 MAIN. 11561 DISPLAY "DIV1 is " DIV1. 11562 DISPLAY "HUN is " HUN. 11563 DISPLAY "HUN2 is " HUN2. 11564 MOVE NUM2 TO FLD1 11565 IF FLD1 = 9 11566 DISPLAY "NUM2 is " NUM2 " left to right precedence." 11567 ELSE 11568 DISPLAY "NUM2 is " NUM2 " normal precedence." 11569 END-IF. 11570 DISPLAY "XFLD3 starts at " XPOS3. 11571 DISPLAY "XFLD4 starts at " XSTRT4. 11572 DISPLAY "XFLD4 starts at " XPOS4. 11573 DISPLAY "Your Dog's name is " DOGGY ";". 11574 DISPLAY "The Dog's name is " THEDOG ";". 11575 STOP RUN. 11576]) 11577 11578AT_CHECK([$COMPILE prog.cob], [0], [], []) 11579 11580AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11581[DIV1 is 33 11582HUN is 143 11583HUN2 is 1855 11584NUM2 is 9 left to right precedence. 11585XFLD3 starts at 9 11586XFLD4 starts at 19 11587XFLD4 starts at 11 11588Your Dog's name is Barky; 11589The Dog's name is Barky ; 11590], []) 11591 11592AT_CLEANUP 11593 11594 11595AT_SETUP([01 CONSTANT]) 11596AT_KEYWORDS([misc]) 11597 11598AT_DATA([prog.cob], [ 11599 >>DEFINE MYDOG AS "Piper" 11600 >>DEFINE MYNUM1 AS 11 11601 IDENTIFICATION DIVISION. 11602 PROGRAM-ID. prog. 11603 DATA DIVISION. 11604 WORKING-STORAGE SECTION. 11605 01 MYREC. 11606 05 FLD1 PIC 9(2). 11607 05 FLD2 PIC X(7). 11608 05 FLD3 PIC X(2) OCCURS 5 TIMES. 11609 05 FLD4 PIC X(4). 11610 05 FLD5 PIC X(4). 11611 01 PICX PIC XXX VALUE 'Abc'. 11612 01 CAT CONSTANT 'Cat '. 11613 01 DOG CONSTANT 'Dog '. 11614 01 YARD CONSTANT CAT & "& " & DOG. 11615 78 HUN VALUE 10 * (10 + LENGTH OF PICX) + 12.35-2+3. 11616 78 HUN2 VALUE HUN * (10 + LENGTH OF PICX) -4. 11617 78 DIV1 VALUE 100 / 3. 11618 78 NUM2 VALUE 1 + 2 * 3. 11619 01 CON3 CONSTANT (((1 + 2) * NUM2) - 4). 11620 01 CON4 CONSTANT AS 3.1416 + CON3. 11621 01 CON5 CONSTANT 1 + 2 * 3. 11622 01 DOGNAME CONSTANT FROM MYDOG. 11623 01 NUM1 CONSTANT FROM MYNUM1. 11624 01 CON6 CONSTANT AS CON5 + NUM1. 11625 >> IF NUM2 DEFINED *> optional passed from command line 11626 01 NUM2 CONSTANT FROM MYNUM2. 11627 >> END-IF 11628 * 11629 PROCEDURE DIVISION. 11630 MAIN. 11631 DISPLAY "CAT is '" CAT "'". 11632 DISPLAY "Yard is '" YARD "'". 11633 DISPLAY "DIV1 is " DIV1. 11634 DISPLAY "HUN is " HUN. 11635 DISPLAY "HUN2 is " HUN2. 11636 MOVE NUM2 TO FLD1 11637 IF FLD1 = 9 11638 DISPLAY "78 VALUE has simple left to right precedence." 11639 ELSE 11640 DISPLAY "78 VALUE is " NUM2 " normal precedence." 11641 END-IF. 11642 MOVE CON5 TO FLD1 11643 IF FLD1 = 7 11644 DISPLAY "01 CONSTANT has normal operator precedence." 11645 ELSE 11646 DISPLAY "01 CONSTANT is " CON5 " left to right precedence." 11647 END-IF. 11648 DISPLAY "CON3 is " CON3. 11649 DISPLAY "CON4 is " CON4 " vs " 3.141596 11650 " & " -2.189 " & " +12. 11651 DISPLAY "CON6 is " CON6 "." 11652 DISPLAY "My Dog's name is " DOGNAME ";". 11653 STOP RUN. 11654]) 11655 11656AT_CHECK([$COMPILE prog.cob], [0], [], []) 11657 11658AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11659[CAT is 'Cat ' 11660Yard is 'Cat & Dog ' 11661DIV1 is 33 11662HUN is 143 11663HUN2 is 1855 1166478 VALUE has simple left to right precedence. 1166501 CONSTANT has normal operator precedence. 11666CON3 is 23 11667CON4 is 26 vs 3.141596 & -2.189 & +12 11668CON6 is 18. 11669My Dog's name is Piper; 11670], []) 11671 11672AT_CLEANUP 11673 11674 11675AT_SETUP([DISPLAY UPON]) 11676AT_KEYWORDS([CHAINING PRINTER PIPE CONSOLE SYSERR SYSPCH SYSPUNCH 11677COB_DISPLAY_PRINT_PIPE COB_DISPLAY_PRINT_FILE COB_DISPLAY_PUNCH_FILE]) 11678 11679AT_DATA([prog.cob], [ 11680 IDENTIFICATION DIVISION. 11681 PROGRAM-ID. prog. 11682 ENVIRONMENT DIVISION. 11683 CONFIGURATION SECTION. 11684 SPECIAL-NAMES. 11685 PRINTER IS PRINTER. 11686 DATA DIVISION. 11687 WORKING-STORAGE SECTION. 11688 77 note PIC X(05). 11689 PROCEDURE DIVISION CHAINING note. 11690 DISPLAY "This is sent to CONSOLE " note UPON CONSOLE. 11691 DISPLAY "This is sent to SYSERR " note UPON SYSERR. 11692 DISPLAY "This is sent to PRINTER " note UPON PRINTER. 11693 DISPLAY "This is also sent to CONSOLE " note UPON CONSOLE. 11694 DISPLAY "This is also sent to SYSERR " note UPON SYSERR. 11695 DISPLAY "This is also sent to PRINTER " note UPON PRINTER. 11696 DISPLAY "This is sent to SYSPUNCH " note UPON SYSPUNCH 11697 ON EXCEPTION DISPLAY 'NO ...' UPON SYSERR. 11698 DISPLAY "This is also sent to SYSPUNCH " note UPON SYSPCH 11699 ON EXCEPTION DISPLAY ' ... SYSPUNCH' UPON SYSERR. 11700 STOP RUN RETURNING 0. 11701]) 11702 11703AT_CHECK([$COMPILE -std=ibm prog.cob], [0], [], []) 11704 11705AT_CHECK([$COBCRUN_DIRECT ./prog PLAIN], [0], 11706[This is sent to CONSOLE PLAIN 11707This is sent to PRINTER PLAIN 11708This is also sent to CONSOLE PLAIN 11709This is also sent to PRINTER PLAIN 11710], 11711[This is sent to SYSERR PLAIN 11712This is also sent to SYSERR PLAIN 11713libcob: prog.cob:18: warning: COB_DISPLAY_PUNCH_FILE is invalid, output to SYSPUNCH skipped 11714NO ... 11715 ... SYSPUNCH 11716]) 11717 11718AT_CHECK([COB_DISPLAY_PRINT_PIPE='cat >>prt.log' \ 11719COB_DISPLAY_PUNCH_FILE='punch.out' \ 11720$COBCRUN_DIRECT ./prog PIPE.], [0], 11721[This is sent to CONSOLE PIPE. 11722This is also sent to CONSOLE PIPE. 11723], 11724[This is sent to SYSERR PIPE. 11725This is also sent to SYSERR PIPE. 11726]) 11727 11728AT_CHECK([COB_DISPLAY_PRINT_FILE='prt.log' \ 11729COB_DISPLAY_PUNCH_FILE='punch.out' \ 11730$COBCRUN_DIRECT ./prog PRINT], [0], 11731[This is sent to CONSOLE PRINT 11732This is also sent to CONSOLE PRINT 11733], 11734[This is sent to SYSERR PRINT 11735This is also sent to SYSERR PRINT 11736]) 11737 11738AT_CAPTURE_FILE(./prt.log) 11739 11740AT_DATA([reference], 11741[This is sent to PRINTER PIPE. 11742This is also sent to PRINTER PIPE. 11743This is sent to PRINTER PRINT 11744This is also sent to PRINTER PRINT 11745]) 11746 11747AT_CHECK([diff reference prt.log], [0], [], [], 11748 11749# Previous test "failed" --> check if EOL of PIPE is the issue 11750 11751AT_CHECK([$SED -e 's/PIPE.\r/PIPE./g' prt.log > prt2.log], [0], [], []) 11752AT_CHECK([diff reference prt2.log], [0], [], []) 11753) 11754 11755AT_CAPTURE_FILE(./punch.out) 11756 11757AT_DATA([reference], 11758[This is sent to SYSPUNCH PRINT 11759This is also sent to SYSPUNCH PRINT 11760]) 11761 11762AT_CHECK([diff reference punch.out], [0], [], []) 11763 11764AT_CLEANUP 11765 11766 11767AT_SETUP([FLOAT-DECIMAL w/o SIZE ERROR]) 11768AT_KEYWORDS([Numeric runmisc 11769FLOAT-DECIMAL-16 FLOAT-DECIMAL-34 11770DISPLAY COMPUTE]) 11771 11772AT_DATA([prog.cob], [ 11773 IDENTIFICATION DIVISION. 11774 PROGRAM-ID. prog. 11775 11776 DATA DIVISION. 11777 WORKING-STORAGE SECTION. 11778 01 FD16 USAGE FLOAT-DECIMAL-16. 11779 01 SV16 USAGE FLOAT-DECIMAL-16. 11780 01 FD34 USAGE FLOAT-DECIMAL-34. 11781 01 SV34 USAGE FLOAT-DECIMAL-34. 11782 11783 PROCEDURE DIVISION. 11784 CND-000. 11785 DISPLAY "--- FLOAT-DECIMAL-34 ---" 11786 COMPUTE FD34 = (((1.0E7 / 2.1E0) / 3.1E0) - 5.0E-1) * 6.0E0 11787 DISPLAY "A: " FD34 11788 11789 COMPUTE FD34 = (((1.0E7 / 2.9E0) / 3.9E0) - 5.0E-1) * 6.0E0 11790 DISPLAY "B: " FD34 11791 MOVE ZERO TO FD34. 11792 COMPUTE FD34 = 1.0E3 / 2.1E0 11793 ON SIZE ERROR DISPLAY "Z: " FD34 " SIZE ERROR" 11794 NOT ON SIZE ERROR DISPLAY "Z: " FD34 " IS OK" 11795 END-COMPUTE. 11796 11797 DISPLAY " ..." 11798 DISPLAY "--- FLOAT-DECIMAL-16 ---" 11799 COMPUTE FD16 = (((1.0E7 / 2.1E0) / 3.1E0) - 5.0E-1) * 6.0E0 11800 DISPLAY "A: " FD16 11801 11802 COMPUTE FD16 = (((1.0E7 / 2.9E0) / 3.9E0) - 5.0E-1) * 6.0E0 11803 DISPLAY "B: " FD16 11804 MOVE ZERO TO FD16. 11805 COMPUTE FD16 = 1.0E3 / 2.1E0 11806 ON SIZE ERROR DISPLAY "Z: " FD16 " SIZE ERROR" 11807 NOT ON SIZE ERROR DISPLAY "Z: " FD16 " IS OK" 11808 END-COMPUTE. 11809 11810 DISPLAY " ..." 11811 DISPLAY "--- 99 + 1 / 3 ---" 11812 MOVE -1 TO FD16, FD34. 11813 COMPUTE FD34 = 99 + 1 / 3 11814 ON SIZE ERROR DISPLAY "FD34: " FD34 " SIZE ERROR" 11815 NOT ON SIZE ERROR DISPLAY "FD34: " FD34 " IS OK" 11816 END-COMPUTE. 11817 COMPUTE FD16 = 99 + 1 / 3 11818 ON SIZE ERROR DISPLAY "FD16: " FD16 " SIZE ERROR" 11819 NOT ON SIZE ERROR DISPLAY "FD16: " FD16 " IS OK" 11820 END-COMPUTE. 11821 11822 DISPLAY " ..." 11823 DISPLAY "--- 99 ---" 11824 MOVE -1 TO FD16, FD34. 11825 COMPUTE FD34 = 99 11826 ON SIZE ERROR DISPLAY "FD34: " FD34 " SIZE ERROR" 11827 NOT ON SIZE ERROR DISPLAY "FD34: " FD34 " IS OK" 11828 END-COMPUTE. 11829 COMPUTE FD16 = 99 11830 ON SIZE ERROR DISPLAY "FD16: " FD16 " SIZE ERROR" 11831 NOT ON SIZE ERROR DISPLAY "FD16: " FD16 " IS OK" 11832 END-COMPUTE. 11833 11834 CND-100-OK. 11835 DISPLAY " ..." 11836 DISPLAY "--- Test overflow ---" 11837 MOVE 9900000000000 TO FD16, FD34. 11838 PERFORM 390 TIMES 11839 MOVE FD16 TO SV16 11840 COMPUTE FD16 = FD16 * 10 11841 ON SIZE ERROR GO TO CND-100-ERR 11842 END-COMPUTE 11843 IF FD16 < 9.0 11844 DISPLAY "FD16: " FD16 " IS Wrong" 11845 GO TO CND-100-ERR 11846 END-IF 11847 END-PERFORM. 11848 DISPLAY "FD16: " FD16 " IS OK". 11849 GO TO CND-200-OK. 11850 CND-100-ERR. 11851 DISPLAY "FD16: after " SV16 " SIZE ERROR". 11852 11853 CND-200-OK. 11854 MOVE 9900000000000 TO FD16, FD34. 11855 PERFORM 6500 TIMES 11856 MOVE FD34 TO SV34 11857 COMPUTE FD34 = FD34 * 10 11858 ON SIZE ERROR GO TO CND-200-ERR 11859 END-COMPUTE 11860 IF FD34 < 9.0 11861 GO TO CND-200-ERR 11862 END-IF 11863 END-PERFORM. 11864 DISPLAY "FD34: " FD34 " IS OK". 11865 GO TO CND-380-OK. 11866 CND-200-ERR. 11867 DISPLAY "FD34: after " SV34 " SIZE ERROR". 11868 11869 CND-380-OK. 11870 DISPLAY " ..." 11871 DISPLAY "--- Test underflow ---" 11872 MOVE 0.000000099 TO FD16, FD34. 11873 PERFORM 400 TIMES 11874 MOVE FD16 TO SV16 11875 COMPUTE FD16 = FD16 / 10 11876 ON SIZE ERROR GO TO CND-300-ERR 11877 END-COMPUTE 11878 IF FD16 = 0.0 11879 GO TO CND-300-ERR 11880 END-IF 11881 END-PERFORM. 11882 DISPLAY "FD16: " FD16 " IS OK". 11883 GO TO CND-400-OK. 11884 CND-300-ERR. 11885 DISPLAY "FD16: after " SV16 " SIZE ERROR". 11886 11887 CND-400-OK. 11888 MOVE 0.000000099 TO FD16, FD34. 11889 PERFORM 6600 TIMES 11890 MOVE FD34 TO SV34 11891 COMPUTE FD34 = FD34 / 10.0 11892 ON SIZE ERROR GO TO CND-400-ERR 11893 END-COMPUTE 11894 IF FD34 = 0.0 11895 GO TO CND-400-ERR 11896 END-IF 11897 END-PERFORM. 11898 DISPLAY "FD34: " FD34 " IS OK". 11899 GO TO CND-999. 11900 CND-400-ERR. 11901 DISPLAY "FD34: after " SV34 " SIZE ERROR". 11902 11903 CND-999. 11904 STOP RUN. 11905 END PROGRAM prog. 11906]) 11907 11908AT_CHECK([$COMPILE prog.cob], [0], [], []) 11909 11910AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 11911[--- FLOAT-DECIMAL-34 --- 11912A: 9216586.861751152073732718894009216 11913B: 5305036.78779840848806366047745358 11914Z: 476.1904761904761904761904761904761 IS OK 11915 ... 11916--- FLOAT-DECIMAL-16 --- 11917A: 9216586.861751152 11918B: 5305036.787798408 11919Z: 476.1904761904761 IS OK 11920 ... 11921--- 99 + 1 / 3 --- 11922FD34: 99.33333333333333333333333333333333 IS OK 11923FD16: 99.33333333333333 IS OK 11924 ... 11925--- 99 --- 11926FD34: 99 IS OK 11927FD16: 99 IS OK 11928 ... 11929--- Test overflow --- 11930FD16: after 99E369 SIZE ERROR 11931FD34: after 99E6111 SIZE ERROR 11932 ... 11933--- Test underflow --- 11934FD16: after 99E-398 SIZE ERROR 11935FD34: after 99E-6176 SIZE ERROR 11936], []) 11937 11938AT_CLEANUP 11939 11940 11941AT_SETUP([FLOAT-SHORT / FLOAT-LONG w/o SIZE ERROR]) 11942AT_KEYWORDS([Numeric runmisc 11943COMP-1 COMP-2 11944DISPLAY COMPUTE]) 11945 11946AT_DATA([prog.cob], [ 11947 IDENTIFICATION DIVISION. 11948 PROGRAM-ID. prog. 11949 11950 DATA DIVISION. 11951 WORKING-STORAGE SECTION. 11952 01 CMP1 COMP-1. 11953 01 SV1 COMP-1. 11954 01 CMP2 COMP-2. 11955 01 SV2 COMP-2. 11956 11957 PROCEDURE DIVISION. 11958 CND-000. 11959 11960 DISPLAY "--- COMP-1 ---" 11961 COMPUTE CMP1 = (((1.0E7 / 2.1E0) / 3.1E0) - 5.0E-1) * 6.0E0 11962 DISPLAY "A: " CMP1 11963 COMPUTE CMP1 = (((1.0E7 / 2.9E0) / 3.9E0) - 5.0E-1) * 6.0E0 11964 DISPLAY "B: " CMP1 11965 MOVE ZERO TO CMP1. 11966 COMPUTE CMP1 = 1.0E3 / 2.1E0 11967 ON SIZE ERROR DISPLAY "Z: " CMP1 " SIZE ERROR" 11968 NOT ON SIZE ERROR DISPLAY "Z: " CMP1 " IS OK" 11969 END-COMPUTE. 11970 11971 DISPLAY " ..." 11972 DISPLAY "--- COMP-2 ---" 11973 COMPUTE CMP2 = (((1.0E7 / 2.1E0) / 3.1E0) - 5.0E-1) * 6.0E0 11974 *> because of possible rounding of intermediates and different 11975 *> precision depending on math library / version: plain DISPLAY 11976 IF CMP2 >= 9216586.86175114 AND <= 9216586.86175116 11977 DISPLAY "A ~ 9216586.86175115" 11978 ELSE 11979 DISPLAY "A: " CMP2 11980 END-IF 11981 COMPUTE CMP2 = (((1.0E7 / 2.9E0) / 3.9E0) - 5.0E-1) * 6.0E0 11982 IF CMP2 >= 5305036.7877983 AND <= 5305036.7877985 11983 DISPLAY "B ~ 5305036.787798408" 11984 ELSE 11985 DISPLAY "B: " CMP2 11986 END-IF 11987 MOVE ZERO TO CMP2. 11988 COMPUTE CMP2 = 1.0E3 / 2.1E0 11989 ON SIZE ERROR DISPLAY "Z: " CMP2 " SIZE ERROR" 11990 NOT ON SIZE ERROR 11991 *> see note above 11992 IF CMP2 >= 476.1904761904760 AND <= 476.1904761904763 11993 DISPLAY "Z ~ 476.1904761904761 IS OK" 11994 ELSE 11995 DISPLAY "Z: " CMP2 " IS OK" 11996 END-IF 11997 END-COMPUTE. 11998 11999 DISPLAY " ..." 12000 DISPLAY "--- 99 + 1 / 3 ---" 12001 MOVE -1 TO CMP1, CMP2. 12002 COMPUTE CMP1 = 99 + 1 / 3 12003 ON SIZE ERROR DISPLAY "CMP1: " CMP1 " SIZE ERROR" 12004 NOT ON SIZE ERROR DISPLAY "CMP1: " CMP1 " IS OK" 12005 END-COMPUTE. 12006 COMPUTE CMP2 = 99 + 1 / 3 12007 ON SIZE ERROR DISPLAY "CMP2: " CMP2 " SIZE ERROR" 12008 NOT ON SIZE ERROR DISPLAY "CMP2: " CMP2 " IS OK" 12009 END-COMPUTE. 12010 12011 DISPLAY " ..." 12012 DISPLAY "--- 99 ---" 12013 MOVE -1 TO CMP1, CMP2. 12014 COMPUTE CMP1 = 99 12015 ON SIZE ERROR DISPLAY "CMP1: " CMP1 " SIZE ERROR" 12016 NOT ON SIZE ERROR DISPLAY "CMP1: " CMP1 " IS OK" 12017 END-COMPUTE. 12018 COMPUTE CMP2 = 99 12019 ON SIZE ERROR DISPLAY "CMP2: " CMP2 " SIZE ERROR" 12020 NOT ON SIZE ERROR DISPLAY "CMP2: " CMP2 " IS OK" 12021 END-COMPUTE. 12022 12023 CND-100-OK. 12024 DISPLAY " ..." 12025 DISPLAY "--- Test overflow ---" 12026 12027 MOVE 990000 TO CMP1. 12028 PERFORM 6500 TIMES 12029 MOVE CMP1 TO SV1 12030 COMPUTE CMP1 = CMP1 * 10 12031 ON SIZE ERROR GO TO CND-350-ERR 12032 END-COMPUTE 12033 IF CMP1 < 9.0 12034 GO TO CND-350-ERR 12035 END-IF 12036 END-PERFORM. 12037 DISPLAY "CMP1: " CMP1 " IS OK". 12038 GO TO CND-350-OK. 12039 CND-350-ERR. 12040 DISPLAY "CMP1: after " SV1 " SIZE ERROR". 12041 12042 CND-350-OK. 12043 MOVE 9900000000 TO CMP2. 12044 PERFORM 6500 TIMES 12045 MOVE CMP2 TO SV2 12046 COMPUTE CMP2 = CMP2 * 10 12047 ON SIZE ERROR GO TO CND-380-ERR 12048 END-COMPUTE 12049 IF CMP2 < 9.0 12050 GO TO CND-380-ERR 12051 END-IF 12052 END-PERFORM. 12053 DISPLAY "CMP2: " CMP2 " IS OK". 12054 GO TO CND-500-OK. 12055 CND-380-ERR. 12056 *> because of possible rounding of intermediates and different 12057 *> precision depending on math library / version: plain DISPLAY 12058 IF SV2 >= 9.899999999999E+307 AND 12059 <= 9.900000000001E+307 12060 DISPLAY "CMP2: after ~ 9.899999999999781E+307 SIZE ERROR" 12061 ELSE 12062 DISPLAY "CMP2: after " SV2 " SIZE ERROR" 12063 END-IF 12064 . 12065 12066 CND-500-OK. 12067 MOVE 0.000000099 TO CMP1. 12068 PERFORM 350 TIMES 12069 MOVE CMP1 TO SV1 12070 COMPUTE CMP1 = CMP1 / 10.0 12071 ON SIZE ERROR GO TO CND-500-ERR 12072 END-COMPUTE 12073 IF CMP1 = 0.0 12074 GO TO CND-500-ERR 12075 END-IF 12076 END-PERFORM. 12077 DISPLAY "CMP1: " CMP1 " IS OK". 12078 GO TO CND-600-OK. 12079 CND-500-ERR. 12080 DISPLAY "CMP1: after " SV1 " SIZE ERROR". 12081 12082 CND-600-OK. 12083 MOVE 0.000000099 TO CMP2. 12084 PERFORM 350 TIMES 12085 MOVE CMP2 TO SV2 12086 COMPUTE CMP2 = CMP2 / 10.0 12087 ON SIZE ERROR GO TO CND-600-ERR 12088 END-COMPUTE 12089 IF CMP2 = 0.0 12090 GO TO CND-600-ERR 12091 END-IF 12092 END-PERFORM. 12093 DISPLAY "CMP2: " CMP2 " IS OK". 12094 GO TO CND-600-XIT. 12095 CND-600-ERR. 12096 IF SV2 >= 9.8813129168249E-324 AND <= 9.881312916825E-324 12097 DISPLAY "CMP2: after ~ 9.881312916824931E-324 SIZE ERROR" 12098 ELSE 12099 DISPLAY "CMP2: after " SV2 " SIZE ERROR" 12100 END-IF 12101 . 12102 CND-600-XIT. 12103 12104 CND-999. 12105 STOP RUN. 12106 END PROGRAM prog. 12107]) 12108 12109AT_CHECK([$COMPILE prog.cob], [0], [], []) 12110 12111AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 12112[--- COMP-1 --- 12113A: 9216587 12114B: 5305037 12115Z: 476.19049 IS OK 12116 ... 12117--- COMP-2 --- 12118A ~ 9216586.86175115 12119B ~ 5305036.787798408 12120Z ~ 476.1904761904761 IS OK 12121 ... 12122--- 99 + 1 / 3 --- 12123CMP1: 99.333336 IS OK 12124CMP2: 99.33333333333333 IS OK 12125 ... 12126--- 99 --- 12127CMP1: 99 IS OK 12128CMP2: 99 IS OK 12129 ... 12130--- Test overflow --- 12131CMP1: after 9.8999983E+37 SIZE ERROR 12132CMP2: after ~ 9.899999999999781E+307 SIZE ERROR 12133CMP1: after 1.4012985E-45 SIZE ERROR 12134CMP2: after ~ 9.881312916824931E-324 SIZE ERROR 12135], []) 12136 12137AT_CLEANUP 12138 12139 12140AT_SETUP([FLOAT-SHORT with SIZE ERROR]) 12141AT_KEYWORDS([COMP-1]) 12142 12143AT_DATA([prog.cob], [ 12144 identification division. 12145 program-id. prog. 12146 12147 data division. 12148 working-storage section. 12149 *------------------------ 12150 77 counter pic s9(4) binary value zero. 12151 * FLOAT-SHORT (if binary-comp-1 is not active) 12152 77 floatValue COMP-1 value 2. 12153 77 lastFloatValue COMP-1. 12154 12155 ****************************************************************** 12156 procedure division. 12157 main section. 12158 perform varying counter from 1 by 1 until 12159 counter > 130 12160 *> display 'counter: ' counter ', value: ' floatValue 12161 compute floatValue = floatValue * 2 12162 ON SIZE ERROR 12163 display 'SIZE ERROR, last value = ' floatValue 12164 exit perform 12165 not ON SIZE ERROR 12166 if floatValue > lastFloatValue 12167 move floatValue to lastFloatValue 12168 else 12169 display 'math ERROR, last value > current: ' 12170 lastFloatValue ' > ' floatValue 12171 exit perform 12172 end-if 12173 end-compute 12174 end-perform 12175 if counter not = 127 12176 display 'counter is ' counter 12177 end-if 12178 12179 goback. 12180]) 12181 12182AT_CHECK([$COMPILE prog.cob], [0], [], []) 12183 12184AT_CHECK([./prog], [0], 12185[SIZE ERROR, last value = 1.7014118E+38 12186], []) 12187 12188AT_CLEANUP 12189 12190 12191AT_SETUP([FLOAT-LONG with SIZE ERROR]) 12192AT_KEYWORDS([COMP-2]) 12193 12194AT_DATA([prog.cob], [ 12195 identification division. 12196 program-id. prog. 12197 12198 data division. 12199 working-storage section. 12200 *------------------------ 12201 77 counter pic s9(4) binary value zero. 12202 * FLOAT-LONG 12203 77 doubleValue COMP-2 value 2. 12204 77 lastDoubleValue COMP-2. 12205 12206 ****************************************************************** 12207 procedure division. 12208 main section. 12209 perform varying counter from 1 by 1 until 12210 counter > 1060 12211 *> display 'counter: ' counter ', value: ' doubleValue 12212 compute doubleValue = doubleValue * 2 12213 ON SIZE ERROR 12214 display 'SIZE ERROR raised' 12215 with no advancing upon syserr 12216 end-display 12217 display 'SIZE ERROR, last value = ' doubleValue 12218 upon sysout 12219 end-display 12220 exit perform 12221 not ON SIZE ERROR 12222 if doubleValue > lastdoubleValue 12223 move doubleValue to lastdoubleValue 12224 else 12225 display 'math ERROR, last value > current: ' 12226 lastdoubleValue ' > ' doubleValue 12227 upon syserr 12228 end-display 12229 exit perform 12230 end-if 12231 end-compute 12232 end-perform 12233 if not (counter >= 1023 and <=1025) 12234 display ' ' upon syserr 12235 display 'counter is ' counter upon syserr 12236 end-if 12237 12238 goback. 12239]) 12240 12241AT_CHECK([$COMPILE prog.cob], [0], [], []) 12242# note: the actual value is not checked as this depends on intermediate rounding 12243AT_CHECK([./prog], [0], ignore, [SIZE ERROR raised]) 12244 12245AT_CLEANUP 12246 12247 12248AT_SETUP([EC-SIZE-ZERO-DIVIDE]) 12249AT_KEYWORDS([misc fundamental exceptions 12250DIVIDE COMPUTE EXCEPTION-STATUS]) 12251 12252AT_DATA([prog.cob], [ 12253 IDENTIFICATION DIVISION. 12254 PROGRAM-ID. prog. 12255 12256 DATA DIVISION. 12257 WORKING-STORAGE SECTION. 12258 01 x PIC 9 VALUE 0. 12259 01 y PIC 9 VALUE 0. 12260 12261 PROCEDURE DIVISION. 12262 DIVIDE x BY y GIVING y 12263 IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) 12264 NOT = 'EC-SIZE-ZERO-DIVIDE' 12265 DISPLAY 'Wrong/missing exception: ' 12266 FUNCTION EXCEPTION-STATUS 12267 END-DISPLAY 12268 END-IF 12269 SET LAST EXCEPTION TO OFF 12270 IF FUNCTION EXCEPTION-STATUS NOT = SPACES 12271 DISPLAY 'Exception is not empty after reset: ' 12272 FUNCTION EXCEPTION-STATUS 12273 END-DISPLAY 12274 END-IF 12275 MOVE 0 TO y 12276 COMPUTE y = x - 1 / y + 6.5 12277 IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) 12278 NOT = 'EC-SIZE-ZERO-DIVIDE' 12279 DISPLAY 'Wrong/missing exception: ' 12280 FUNCTION EXCEPTION-STATUS 12281 END-DISPLAY 12282 END-IF 12283 . 12284]) 12285 12286AT_CHECK([$COMPILE prog.cob], [0], [], []) 12287AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 12288AT_CLEANUP 12289 12290 12291AT_SETUP([EC-SIZE-OVERFLOW]) 12292AT_KEYWORDS([misc fundamental exceptions]) 12293 12294AT_DATA([prog.cob], [ 12295 IDENTIFICATION DIVISION. 12296 PROGRAM-ID. prog. 12297 12298 DATA DIVISION. 12299 WORKING-STORAGE SECTION. 12300 01 x PIC 9 VALUE 1. 12301 01 y PIC 9. 12302 12303 PROCEDURE DIVISION. 12304 * raise exception checked in previous test 12305 * as it may interfere with the expected exception 12306 DIVIDE x BY y GIVING y 12307 DIVIDE x BY 0.1 GIVING y 12308 IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) 12309 NOT = 'EC-SIZE-OVERFLOW' 12310 DISPLAY 'Wrong/missing exception: ' 12311 FUNCTION EXCEPTION-STATUS 12312 END-DISPLAY 12313 END-IF 12314 . 12315]) 12316 12317AT_CHECK([$COMPILE prog.cob], [0], [], []) 12318AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 12319AT_CLEANUP 12320 12321 12322AT_SETUP([Constant Expressions]) 12323AT_KEYWORDS([runmisc condition expression]) 12324 12325AT_DATA([prog.cob], [ 12326 IDENTIFICATION DIVISION. 12327 PROGRAM-ID. prog. 12328 DATA DIVISION. 12329 WORKING-STORAGE SECTION. 12330 01 VAR PIC X(200). 12331 01 OTHERVAR PIC X(115). 12332 78 VAR-LEN VALUE 115. 12333 12334 PROCEDURE DIVISION. 12335 MAIN-10. 12336 MOVE "Peek a boo" TO VAR. 12337 EVALUATE TRUE 12338 ALSO FALSE 12339 ALSO TRUE 12340 WHEN TRUE 12341 ALSO VAR-LEN > 16 AND VAR-LEN < 200 12342 ALSO TRUE 12343 MOVE OTHERVAR (1 : VAR-LEN - 9) 12344 TO VAR (16 - VAR-LEN : VAR-LEN - 9) 12345 DISPLAY "A: Should NOT be executed" 12346 WHEN TRUE 12347 ALSO VAR-LEN < 16 12348 ALSO TRUE 12349 MOVE OTHERVAR TO VAR 12350 DISPLAY "A: OK VAR-LEN > 16 AND VAR-LEN < 200" 12351 WHEN TRUE 12352 ALSO VAR = SPACES 12353 ALSO TRUE 12354 MOVE OTHERVAR TO VAR 12355 DISPLAY "A: OK VAR IS SPACES" 12356 END-EVALUATE. 12357 12358 MOVE "Peek a boo" TO VAR. 12359 EVALUATE 3 EQUALS 7 12360 WHEN VAR = SPACES 12361 DISPLAY "B: OK VAR IS NOT SPACES" 12362 WHEN VAR NOT = SPACES 12363 DISPLAY "B: FALSE VAR IS SPACES" 12364 END-EVALUATE. 12365 12366 MOVE SPACES TO VAR. 12367 EVALUATE FALSE 12368 WHEN VAR = SPACES 12369 DISPLAY "C: FALSE VAR IS SPACES" 12370 WHEN VAR NOT = SPACES 12371 DISPLAY "C: OK VAR IS SPACES" 12372 END-EVALUATE. 12373 12374 MOVE "Peek a boo" TO VAR. 12375 EVALUATE TRUE 12376 WHEN VAR = SPACES 12377 DISPLAY "D: BAD VAR IS SPACES" 12378 WHEN VAR NOT = SPACES 12379 DISPLAY "D: OK VAR IS NOT SPACES" 12380 END-EVALUATE. 12381 12382 MOVE SPACES TO VAR. 12383 EVALUATE VAR-LEN ALSO VAR 12384 WHEN < 32 ALSO SPACES 12385 DISPLAY "E: OK VAR IS SPACES" 12386 WHEN > 16 ALSO NOT SPACES 12387 DISPLAY "E: BAD VAR IS NOT SPACES" 12388 WHEN OTHER 12389 DISPLAY "E: OK OTHER option taken" 12390 END-EVALUATE. 12391 12392 STOP RUN. 12393]) 12394 12395AT_CHECK([$COMPILE prog.cob -w], [0], [], []) 12396 12397AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 12398[A: OK VAR-LEN > 16 AND VAR-LEN < 200 12399B: OK VAR IS NOT SPACES 12400C: OK VAR IS SPACES 12401D: OK VAR IS NOT SPACES 12402E: OK OTHER option taken 12403], []) 12404 12405AT_CLEANUP 12406 12407 12408AT_SETUP([ENTRY FOR GO TO / GO TO ENTRY]) 12409AT_KEYWORDS([runmisc condition expression]) 12410 12411AT_DATA([prog.cob], [ 12412 IDENTIFICATION DIVISION. 12413 PROGRAM-ID. prog. 12414 DATA DIVISION. 12415 WORKING-STORAGE SECTION. 12416 01 JUMP-ENTRY PIC 9 VALUE 6. 12417 88 EXT-MODUS VALUES 3, 4. 12418 LINKAGE SECTION. 12419 PROCEDURE DIVISION. 12420 GO TO ENTRY 'STMT05'. 12421 MAIN. 12422 GO TO ENTRY 'STMT01' 12423 'STMT02' 12424 'STMT03' 12425 'STMT04' 12426 'STMT05' 12427 DEPENDING ON JUMP-ENTRY 12428 DISPLAY 'NOT JUMPED' 12429 GOBACK. 12430 ENTRY FOR GO TO 'STMT01' 12431 DISPLAY 'STMT01' 12432 ENTRY FOR GO TO 'STMT02' 12433 PERFORM 3 TIMES 12434 ENTRY FOR GO TO 'STMT03' 12435 DISPLAY 'STMT03' 12436 ENTRY FOR GO TO 'STMT04' DISPLAY 'STMT04' 12437 IF EXT-MODUS EXIT PERFORM END-IF 12438 END-PERFORM 12439 ENTRY FOR GO TO 'STMT05' 12440 DISPLAY 'STMT05' 12441 SUBTRACT 1 FROM JUMP-ENTRY 12442 GO TO MAIN. 12443 12444]) 12445 12446# TODO: move to syntax checks, together with all expected error messages 12447AT_CHECK([$COMPILE -std=mf-strict prog.cob], [1], [], 12448[prog.cob:10: error: ENTRY FOR GO TO does not conform to Micro Focus COBOL 12449prog.cob: in paragraph 'MAIN': 12450prog.cob:18: error: ENTRY FOR GO TO does not conform to Micro Focus COBOL 12451prog.cob:20: error: ENTRY FOR GO TO does not conform to Micro Focus COBOL 12452prog.cob:22: error: ENTRY FOR GO TO does not conform to Micro Focus COBOL 12453prog.cob:24: error: ENTRY FOR GO TO does not conform to Micro Focus COBOL 12454prog.cob:26: error: ENTRY FOR GO TO does not conform to Micro Focus COBOL 12455prog.cob:29: error: ENTRY FOR GO TO does not conform to Micro Focus COBOL 12456]) 12457 12458AT_CHECK([$COMPILE prog.cob], [0], [], 12459[prog.cob:10: warning: ENTRY FOR GO TO used 12460prog.cob: in paragraph 'MAIN': 12461prog.cob:18: warning: ENTRY FOR GO TO used 12462prog.cob:20: warning: ENTRY FOR GO TO used 12463prog.cob:22: warning: ENTRY FOR GO TO used 12464prog.cob:24: warning: ENTRY FOR GO TO used 12465prog.cob:26: warning: ENTRY FOR GO TO used 12466prog.cob:29: warning: ENTRY FOR GO TO used 12467]) 12468 12469AT_CHECK([$COBCRUN_DIRECT ./prog], [0], 12470[STMT05 12471STMT05 12472STMT04 12473STMT05 12474STMT03 12475STMT04 12476STMT05 12477STMT03 12478STMT04 12479STMT03 12480STMT04 12481STMT03 12482STMT04 12483STMT05 12484STMT01 12485STMT03 12486STMT04 12487STMT03 12488STMT04 12489STMT03 12490STMT04 12491STMT05 12492NOT JUMPED 12493], []) 12494 12495AT_CLEANUP 12496 12497 12498AT_SETUP([runtime checks within conditions]) 12499AT_KEYWORDS([runmisc condition expression]) 12500 12501# this serves as a sample what was broken in the initial 12502# 3.1 release 12503 12504AT_DATA([prog.cob], [ 12505 IDENTIFICATION DIVISION. 12506 PROGRAM-ID. prog. 12507 12508 DATA DIVISION. 12509 WORKING-STORAGE SECTION. 12510 12511 01 mytab. 12512 03 VAR PIC 9(02) value 1. 12513 03 VAR2 PIC 9(02) value 2. 12514 03 OCCURS 2. 12515 05 T15-PRGM PIC X(08). 12516 05 T16-PRGM PIC X(08). 12517 03 OCCURS 2. 12518 05 T15-NRGM PIC 9(04). 12519 05 T16-NRGM USAGE BINARY-INT. 12520 12521 PROCEDURE DIVISION. 12522 * 12523 MOVE 'TESTME' TO T16-PRGM (VAR) (VAR2:) 12524 MOVE T16-PRGM (VAR) (1:VAR2) TO T15-PRGM (VAR) 12525 IF T16-PRGM(VAR) 12526 = T15-PRGM(VAR2) 12527 DISPLAY 'WRONG RESULT OCCURS'. 12528 12529 IF MYTAB(VAR:VAR2) 12530 = MYTAB(VAR2:VAR) 12531 DISPLAY 'WRONG RESULT REFMOD'. 12532 12533 INITIALIZE mytab 12534 12535 GOBACK. 12536]) 12537AT_CHECK([$COMPILE prog.cob], [0], [], []) 12538AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 12539# note: we mostly are interessted in a good codegen here... 12540 12541 12542AT_DATA([prog2.cob], [ 12543 IDENTIFICATION DIVISION. 12544 PROGRAM-ID. prog2. 12545 12546 DATA DIVISION. 12547 WORKING-STORAGE SECTION. 12548 12549 01 mytab. 12550 03 VAR PIC 9(02) value 1. 12551 03 VAR2 PIC 9(02) value 3. 12552 03 OCCURS 2. 12553 05 T15-PRGM PIC X(08). 12554 05 T16-PRGM PIC X(08). 12555 03 OCCURS 2. 12556 05 T15-NRGM PIC 9(04). 12557 05 T16-NRGM USAGE BINARY-INT. 12558 05 buffer PIC X(500). 12559 12560 PROCEDURE DIVISION. 12561 * 12562 IF T16-PRGM(VAR) 12563 = T15-PRGM(VAR2) 12564 DISPLAY 'WRONG RESULT OCCURS'. 12565 12566 GOBACK. 12567]) 12568AT_CHECK([$COBC -x prog2.cob], [0], [], []) 12569AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) 12570AT_CHECK([$COBC -x --debug -o prog2b prog2.cob], [0], [], []) 12571AT_CHECK([$COBCRUN_DIRECT ./prog2b], [1], [], 12572[libcob: prog2.cob:21: error: subscript of 'T15-PRGM' out of bounds: 3 12573note: maximum subscript for 'T15-PRGM': 2 12574]) 12575AT_DATA([prog3.cob], [ 12576 IDENTIFICATION DIVISION. 12577 PROGRAM-ID. prog3. 12578 12579 DATA DIVISION. 12580 WORKING-STORAGE SECTION. 12581 12582 01 mytab. 12583 03 VAR PIC 9(02) value 1. 12584 03 VAR2 PIC 9(02) value 99. 12585 03 OCCURS 2. 12586 05 T15-PRGM PIC X(08). 12587 05 T16-PRGM PIC X(08). 12588 03 OCCURS 2. 12589 05 T15-NRGM PIC 9(04). 12590 05 T16-NRGM USAGE BINARY-INT. 12591 12592 PROCEDURE DIVISION. 12593 12594 IF MYTAB(VAR:VAR2) 12595 *> = MYTAB(VAR2:VAR) that _should_ work but on x86_64 12596 *> the second line is evaluated first 12597 = MYTAB(VAR:VAR ) 12598 DISPLAY 'WRONG RESULT REFMOD'. 12599 12600 GOBACK. 12601]) 12602AT_CHECK([$COBC -x prog3.cob], [0], [], []) 12603AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 12604AT_CHECK([$COBC -x --debug -o prog3b prog3.cob], [0], [], []) 12605AT_CHECK([$COBCRUN_DIRECT ./prog3b], [1], [], 12606[libcob: prog3.cob:20: error: length of 'mytab' out of bounds: 99, maximum: 52 12607]) 12608 12609AT_CLEANUP 12610 12611 12612AT_SETUP([libcob version check]) 12613AT_KEYWORDS([runmisc]) 12614 12615# using a C program here, normally this would be called from old or newer modules 12616AT_DATA([prog.c], [[ 12617#include <stdio.h> 12618#include <libcob.h> 12619 12620#define COUNT_OF(x) (sizeof(x)/sizeof(x[0])) 12621 12622struct verify_t { 12623 char *prog, *packver_prog; 12624 int patchlev_prog; 12625} verify[] = { 12626#include "testdata.h" 12627}; 12628 12629int 12630main(int argc, char *argv[]) 12631{ 12632 struct verify_t *p; 12633 for( p=verify; p < verify + COUNT_OF(verify); p++ ) { 12634 cob_check_version(p->prog, p->packver_prog, p->patchlev_prog); 12635 } 12636 return 0; 12637} 12638]]) 12639 12640# good cases 12641AT_DATA([testdata.h], [[ 12642#define TST_STRINGIFY(s) #s 12643#define TST_XSTRINGIFY(s) TST_STRINGIFY (s) 12644 { "test22", "2.2", 0 }, 12645/* { "TestMatch1", 12646 TST_XSTRINGIFY (__LIBCOB_VERSION) "." 12647 TST_XSTRINGIFY (__LIBCOB_VERSION_MINOR) "." 12648 TST_XSTRINGIFY (__LIBCOB_VERSION_PATCHLEVEL), 12649 0}, */ 12650 { "TestMatch2", 12651 TST_XSTRINGIFY (__LIBCOB_VERSION) "." 12652 TST_XSTRINGIFY (__LIBCOB_VERSION_MINOR) "." 12653 "0", 12654 0}, 12655 { "TestMatch3", 12656 TST_XSTRINGIFY (__LIBCOB_VERSION) "." 12657 TST_XSTRINGIFY (__LIBCOB_VERSION_MINOR), 12658 0 } 12659]]) 12660 12661AT_CHECK([$COMPILE prog.c], [0], [], []) 12662AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) 12663 12664AT_DATA([testdata.h], [[ 12665 { "TooSmall1", "1.1", 0 } 12666]]) 12667AT_CHECK([$COMPILE -o small1 prog.c], [0], [], []) 12668AT_CHECK([$COBCRUN_DIRECT ./small1 2>small1.log], [1], [], []) 12669AT_CHECK([$GREP -v "libcob has" small1.log], [0], 12670[libcob: error: version mismatch 12671note: TooSmall1 has version 1.1.0 12672], []) 12673 12674AT_DATA([testdata.h], [[ 12675 { "TooSmall2", "2.0", 0 } 12676]]) 12677AT_CHECK([$COMPILE -o small2 prog.c], [0], [], []) 12678AT_CHECK([$COBCRUN_DIRECT ./small2 2>small2.log], [1], [], []) 12679AT_CHECK([$GREP -v "libcob has" small2.log], [0], 12680[libcob: error: version mismatch 12681note: TooSmall2 has version 2.0.0 12682], []) 12683 12684AT_DATA([testdata.h], [[ 12685 { "TooHigh1", "3.2", 0 }, 12686]]) 12687AT_CHECK([$COMPILE -o high1 prog.c], [0], [], []) 12688AT_CHECK([$COBCRUN_DIRECT ./high1 2>high1.log], [1], [], []) 12689AT_CHECK([$GREP -v "libcob has" high1.log], [0], 12690[libcob: error: version mismatch 12691note: TooHigh1 has version 3.2.0 12692], []) 12693 12694AT_DATA([testdata.h], [[ 12695 { "TooHigh2", "4.0", 0 } 12696]]) 12697AT_CHECK([$COMPILE -o high2 prog.c], [0], [], []) 12698AT_CHECK([$COBCRUN_DIRECT ./high2 2>high2.log], [1], [], []) 12699AT_CHECK([$GREP -v "libcob has" high2.log], [0], 12700[libcob: error: version mismatch 12701note: TooHigh2 has version 4.0.0 12702], []) 12703 12704AT_DATA([testdata.h], [[ 12705 { "TooHigh3", "4.0.1", 2 } 12706]]) 12707AT_CHECK([$COMPILE -o high3 prog.c], [0], [], []) 12708AT_CHECK([$COBCRUN_DIRECT ./high3 2>high3.log], [1], [], []) 12709AT_CHECK([$GREP -v "libcob has" high3.log], [0], 12710[libcob: error: version mismatch 12711note: TooHigh3 has version 4.0.1.2 12712], []) 12713 12714AT_CLEANUP 12715