1 /* Id: f77.c,v 1.22 2011/08/04 08:32:32 mickey Exp */ 2 /* $NetBSD: f77.c,v 1.1.1.4 2011/09/01 12:47:05 plunky Exp $ */ 3 /* 4 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved. 5 * 6 * Redistribution and use in source and binary forms, with or without 7 * modification, are permitted provided that the following conditions 8 * are met: 9 * 10 * Redistributions of source code and documentation must retain the above 11 * copyright notice, this list of conditions and the following disclaimer. 12 * Redistributions in binary form must reproduce the above copyright 13 * notice, this list of conditionsand the following disclaimer in the 14 * documentation and/or other materials provided with the distribution. 15 * All advertising materials mentioning features or use of this software 16 * must display the following acknowledgement: 17 * This product includes software developed or owned by Caldera 18 * International, Inc. 19 * Neither the name of Caldera International, Inc. nor the names of other 20 * contributors may be used to endorse or promote products derived from 21 * this software without specific prior written permission. 22 * 23 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA 24 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR 25 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 26 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 * DISCLAIMED. IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE 28 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 29 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 30 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 31 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT, 32 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 33 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 * POSSIBILITY OF SUCH DAMAGE. 35 */ 36 37 char xxxvers[] = "FORTRAN 77 DRIVER, VERSION 1.11, 28 JULY 1978\n"; 38 39 #include <sys/wait.h> 40 41 #include <stdio.h> 42 #include <ctype.h> 43 #include <signal.h> 44 #include <unistd.h> 45 #include <string.h> 46 #include <stdlib.h> 47 #include <stdarg.h> 48 #include <errno.h> 49 50 #include "ccconfig.h" 51 52 typedef FILE *FILEP; 53 typedef int flag; 54 #define YES 1 55 #define NO 0 56 57 FILEP diagfile; 58 59 static int pid; 60 static int sigivalue = 0; 61 static int sigqvalue = 0; 62 63 #ifndef FCOM 64 #define FCOM "fcom" 65 #endif 66 67 #ifndef ASSEMBLER 68 #define ASSEMBLER "as" 69 #endif 70 71 #ifndef LINKER 72 #define LINKER "ld" 73 #endif 74 75 static char *fcom = LIBEXECDIR "/" FCOM ; 76 static char *asmname = ASSEMBLER ; 77 static char *ldname = LINKER ; 78 static char *startfiles[] = STARTFILES; 79 static char *endfiles[] = ENDFILES; 80 static char *dynlinker[] = DYNLINKER; 81 static char *crt0file = CRT0FILE; 82 static char *macroname = "m4"; 83 static char *shellname = "/bin/sh"; 84 static char *aoutname = "a.out" ; 85 static char *libdir = LIBDIR ; 86 static char *liblist[] = F77LIBLIST; 87 88 static char *infname; 89 static char asmfname[15]; 90 static char prepfname[15]; 91 92 #define MAXARGS 100 93 int ffmax; 94 static char *ffary[MAXARGS]; 95 static char eflags[30] = ""; 96 static char rflags[30] = ""; 97 static char lflag[3] = "-x"; 98 static char *eflagp = eflags; 99 static char *rflagp = rflags; 100 static char **loadargs; 101 static char **loadp; 102 static int oflag; 103 104 static flag loadflag = YES; 105 static flag saveasmflag = NO; 106 static flag profileflag = NO; 107 static flag optimflag = NO; 108 static flag debugflag = NO; 109 static flag verbose = NO; 110 static flag fortonly = NO; 111 static flag macroflag = NO; 112 113 static char *setdoto(char *), *lastchar(char *), *lastfield(char *); 114 static void intrupt(int); 115 static void enbint(void (*)(int)); 116 static void crfnames(void); 117 static void fatal1(char *, ...); 118 static void done(int), texec(char *, char **); 119 static char *copyn(int, char *); 120 static int dotchar(char *), unreadable(char *), sys(char *), dofort(char *); 121 static int nodup(char *); 122 static int await(int); 123 static void rmf(char *), doload(char *[], char *[]), doasm(char *); 124 static int callsys(char *, char **); 125 static void errorx(char *, ...); 126 127 static void 128 addarg(char **ary, int *num, char *arg) 129 { 130 ary[(*num)++] = arg; 131 if ((*num) == MAXARGS) { 132 fprintf(stderr, "argument array too small\n"); 133 exit(1); 134 } 135 } 136 137 int 138 main(int argc, char **argv) 139 { 140 int i, c, status; 141 char *s; 142 char fortfile[20], *t; 143 char buff[100]; 144 145 diagfile = stderr; 146 147 sigivalue = (int) signal(SIGINT, SIG_IGN) & 01; 148 sigqvalue = (int) signal(SIGQUIT, SIG_IGN) & 01; 149 enbint(intrupt); 150 151 pid = getpid(); 152 crfnames(); 153 154 loadargs = (char **)calloc(1, (argc + 20) * sizeof(*loadargs)); 155 if (!loadargs) 156 fatal1("out of memory"); 157 loadp = loadargs; 158 159 --argc; 160 ++argv; 161 162 while(argc>0 && argv[0][0]=='-' && argv[0][1]!='\0') { 163 for(s = argv[0]+1 ; *s ; ++s) 164 switch(*s) { 165 case 'T': /* use special passes */ 166 switch(*++s) { 167 case '1': 168 fcom = s+1; goto endfor; 169 case 'a': 170 asmname = s+1; goto endfor; 171 case 'l': 172 ldname = s+1; goto endfor; 173 case 'm': 174 macroname = s+1; goto endfor; 175 default: 176 fatal1("bad option -T%c", *s); 177 } 178 break; 179 180 case 'w': /* F66 warn or no warn */ 181 addarg(ffary, &ffmax, s-1); 182 break; 183 184 case 'q': 185 /* 186 * Suppress printing of procedure names during 187 * compilation. 188 */ 189 addarg(ffary, &ffmax, s-1); 190 break; 191 192 copyfflag: 193 case 'u': 194 case 'U': 195 case 'M': 196 case '1': 197 case 'C': 198 addarg(ffary, &ffmax, s-1); 199 break; 200 201 case 'O': 202 optimflag = YES; 203 addarg(ffary, &ffmax, s-1); 204 break; 205 206 case 'm': 207 if(s[1] == '4') 208 ++s; 209 macroflag = YES; 210 break; 211 212 case 'S': 213 saveasmflag = YES; 214 215 case 'c': 216 loadflag = NO; 217 break; 218 219 case 'v': 220 verbose = YES; 221 break; 222 223 case 'd': 224 debugflag = YES; 225 goto copyfflag; 226 227 case 'p': 228 profileflag = YES; 229 goto copyfflag; 230 231 case 'o': 232 if(!strcmp(s, "onetrip")) { 233 addarg(ffary, &ffmax, s-1); 234 goto endfor; 235 } 236 oflag = 1; 237 aoutname = *++argv; 238 --argc; 239 break; 240 241 case 'F': 242 fortonly = YES; 243 loadflag = NO; 244 break; 245 246 case 'I': 247 if(s[1]=='2' || s[1]=='4' || s[1]=='s') 248 goto copyfflag; 249 fprintf(diagfile, "invalid flag -I%c\n", s[1]); 250 done(1); 251 252 case 'l': /* letter ell--library */ 253 s[-1] = '-'; 254 *loadp++ = s-1; 255 goto endfor; 256 257 case 'E': /* EFL flag argument */ 258 while(( *eflagp++ = *++s)) 259 ; 260 *eflagp++ = ' '; 261 goto endfor; 262 case 'R': 263 while(( *rflagp++ = *++s )) 264 ; 265 *rflagp++ = ' '; 266 goto endfor; 267 default: 268 lflag[1] = *s; 269 *loadp++ = copyn(strlen(lflag), lflag); 270 break; 271 } 272 endfor: 273 --argc; 274 ++argv; 275 } 276 277 if (verbose) 278 fprintf(stderr, xxxvers); 279 280 if (argc == 0) 281 errorx("No input files"); 282 283 #ifdef mach_pdp11 284 if(nofloating) 285 *loadp++ = (profileflag ? NOFLPROF : NOFLFOOT); 286 else 287 #endif 288 289 for(i = 0 ; i<argc ; ++i) 290 switch(c = dotchar(infname = argv[i]) ) { 291 case 'r': /* Ratfor file */ 292 case 'e': /* EFL file */ 293 if( unreadable(argv[i]) ) 294 break; 295 s = fortfile; 296 t = lastfield(argv[i]); 297 while(( *s++ = *t++)) 298 ; 299 s[-2] = 'f'; 300 301 if(macroflag) { 302 snprintf(buff, sizeof(buff), "%s %s >%s", 303 macroname, infname, prepfname); 304 if(sys(buff)) { 305 rmf(prepfname); 306 break; 307 } 308 infname = prepfname; 309 } 310 311 if(c == 'e') 312 snprintf(buff, sizeof(buff), "efl %s %s >%s", 313 eflags, infname, fortfile); 314 else 315 snprintf(buff, sizeof(buff), "ratfor %s %s >%s", 316 rflags, infname, fortfile); 317 status = sys(buff); 318 if(macroflag) 319 rmf(infname); 320 if(status) { 321 loadflag = NO; 322 rmf(fortfile); 323 break; 324 } 325 326 if( ! fortonly ) { 327 infname = argv[i] = lastfield(argv[i]); 328 *lastchar(infname) = 'f'; 329 330 if( dofort(argv[i]) ) 331 loadflag = NO; 332 else { 333 if( nodup(t = setdoto(argv[i])) ) 334 *loadp++ = t; 335 rmf(fortfile); 336 } 337 } 338 break; 339 340 case 'f': /* Fortran file */ 341 case 'F': 342 if( unreadable(argv[i]) ) 343 break; 344 if( dofort(argv[i]) ) 345 loadflag = NO; 346 else if( nodup(t=setdoto(argv[i])) ) 347 *loadp++ = t; 348 break; 349 350 case 'c': /* C file */ 351 case 's': /* Assembler file */ 352 if( unreadable(argv[i]) ) 353 break; 354 fprintf(diagfile, "%s:\n", argv[i]); 355 snprintf(buff, sizeof(buff), "cc -c %s", argv[i]); 356 if( sys(buff) ) 357 loadflag = NO; 358 else 359 if( nodup(t = setdoto(argv[i])) ) 360 *loadp++ = t; 361 break; 362 363 case 'o': 364 if( nodup(argv[i]) ) 365 *loadp++ = argv[i]; 366 break; 367 368 default: 369 if( ! strcmp(argv[i], "-o") ) 370 aoutname = argv[++i]; 371 else 372 *loadp++ = argv[i]; 373 break; 374 } 375 376 if(loadflag) 377 doload(loadargs, loadp); 378 done(0); 379 return 0; 380 } 381 382 #define ADD(x) addarg(params, &nparms, (x)) 383 384 static int 385 dofort(char *s) 386 { 387 int nparms, i; 388 char *params[MAXARGS]; 389 390 nparms = 0; 391 ADD(FCOM); 392 for (i = 0; i < ffmax; i++) 393 ADD(ffary[i]); 394 ADD(s); 395 ADD(asmfname); 396 ADD(NULL); 397 398 infname = s; 399 if (callsys(fcom, params)) 400 errorx("Error. No assembly."); 401 doasm(s); 402 403 if (saveasmflag == NO) 404 rmf(asmfname); 405 return(0); 406 } 407 408 409 static void 410 doasm(char *s) 411 { 412 char *obj; 413 char *params[MAXARGS]; 414 int nparms; 415 416 if (oflag && loadflag == NO) 417 obj = aoutname; 418 else 419 obj = setdoto(s); 420 421 nparms = 0; 422 ADD(asmname); 423 ADD("-o"); 424 ADD(obj); 425 ADD(asmfname); 426 ADD(NULL); 427 428 if (callsys(asmname, params)) 429 fatal1("assembler error"); 430 if(verbose) 431 fprintf(diagfile, "\n"); 432 } 433 434 435 static void 436 doload(char *v0[], char *v[]) 437 { 438 int nparms, i; 439 char *params[MAXARGS]; 440 char **p; 441 442 nparms = 0; 443 ADD(ldname); 444 ADD("-X"); 445 ADD("-d"); 446 for (i = 0; dynlinker[i]; i++) 447 ADD(dynlinker[i]); 448 ADD("-o"); 449 ADD(aoutname); 450 ADD(crt0file); 451 for (i = 0; startfiles[i]; i++) 452 ADD(startfiles[i]); 453 *v = NULL; 454 for(p = v0; *p ; p++) 455 ADD(*p); 456 if (libdir) 457 ADD(libdir); 458 for(p = liblist ; *p ; p++) 459 ADD(*p); 460 for (i = 0; endfiles[i]; i++) 461 ADD(endfiles[i]); 462 ADD(NULL); 463 464 if (callsys(ldname, params)) 465 fatal1("couldn't load %s", ldname); 466 467 if(verbose) 468 fprintf(diagfile, "\n"); 469 } 470 471 /* Process control and Shell-simulating routines */ 472 473 /* 474 * Execute f[] with parameter array v[]. 475 * Copied from cc. 476 */ 477 static int 478 callsys(char f[], char *v[]) 479 { 480 int t, status = 0; 481 pid_t p; 482 char *s; 483 484 if (debugflag || verbose) { 485 fprintf(stderr, "%s ", f); 486 for (t = 1; v[t]; t++) 487 fprintf(stderr, "%s ", v[t]); 488 fprintf(stderr, "\n"); 489 } 490 491 if ((p = fork()) == 0) { 492 #ifdef notyet 493 if (Bflag) { 494 size_t len = strlen(Bflag) + 8; 495 char *a = malloc(len); 496 if (a == NULL) { 497 error("callsys: malloc failed"); 498 exit(1); 499 } 500 if ((s = strrchr(f, '/'))) { 501 strlcpy(a, Bflag, len); 502 strlcat(a, s, len); 503 execv(a, v); 504 } 505 } 506 #endif 507 execvp(f, v); 508 if ((s = strrchr(f, '/'))) 509 execvp(s+1, v); 510 fprintf(stderr, "Can't find %s\n", f); 511 _exit(100); 512 } else { 513 if (p == -1) { 514 printf("Try again\n"); 515 return(100); 516 } 517 } 518 while (waitpid(p, &status, 0) == -1 && errno == EINTR) 519 ; 520 if (WIFEXITED(status)) 521 return (WEXITSTATUS(status)); 522 if (WIFSIGNALED(status)) 523 done(1); 524 fatal1("Fatal error in %s", f); 525 return 0; /* XXX */ 526 } 527 528 529 static int 530 sys(char *str) 531 { 532 char *s, *t; 533 char *argv[100], path[100]; 534 char *inname, *outname; 535 int append = 0; 536 int wait_pid; 537 int argc; 538 539 540 if(debugflag) 541 fprintf(diagfile, "%s\n", str); 542 inname = NULL; 543 outname = NULL; 544 argv[0] = shellname; 545 argc = 1; 546 547 t = str; 548 while( isspace((int)*t) ) 549 ++t; 550 while(*t) { 551 if(*t == '<') 552 inname = t+1; 553 else if(*t == '>') { 554 if(t[1] == '>') { 555 append = YES; 556 outname = t+2; 557 } else { 558 append = NO; 559 outname = t+1; 560 } 561 } else 562 argv[argc++] = t; 563 while( !isspace((int)*t) && *t!='\0' ) 564 ++t; 565 if(*t) { 566 *t++ = '\0'; 567 while( isspace((int)*t) ) 568 ++t; 569 } 570 } 571 572 if(argc == 1) /* no command */ 573 return(-1); 574 argv[argc] = 0; 575 576 s = path; 577 t = "/usr/bin/"; 578 while(*t) 579 *s++ = *t++; 580 for(t = argv[1] ; (*s++ = *t++) ; ) 581 ; 582 if((wait_pid = fork()) == 0) { 583 if(inname) 584 freopen(inname, "r", stdin); 585 if(outname) 586 freopen(outname, (append ? "a" : "w"), stdout); 587 enbint(SIG_DFL); 588 589 texec(path+9, argv); /* command */ 590 texec(path+4, argv); /* /bin/command */ 591 texec(path , argv); /* /usr/bin/command */ 592 593 fatal1("Cannot load %s",path+9); 594 } 595 596 return( await(wait_pid) ); 597 } 598 599 /* modified version from the Shell */ 600 static void 601 texec(char *f, char **av) 602 { 603 604 execv(f, av+1); 605 606 if (errno==ENOEXEC) { 607 av[1] = f; 608 execv(shellname, av); 609 fatal1("No shell!"); 610 } 611 if (errno==ENOMEM) 612 fatal1("%s: too large", f); 613 } 614 615 /* 616 * Cleanup and exit with value k. 617 */ 618 static void 619 done(int k) 620 { 621 static int recurs = NO; 622 623 if(recurs == NO) { 624 recurs = YES; 625 if (saveasmflag == NO) 626 rmf(asmfname); 627 } 628 exit(k); 629 } 630 631 632 static void 633 enbint(void (*k)(int)) 634 { 635 if(sigivalue == 0) 636 signal(SIGINT,k); 637 if(sigqvalue == 0) 638 signal(SIGQUIT,k); 639 } 640 641 642 643 static void 644 intrupt(int a) 645 { 646 done(2); 647 } 648 649 650 static int 651 await(int wait_pid) 652 { 653 int w, status; 654 655 enbint(SIG_IGN); 656 while ( (w = wait(&status)) != wait_pid) 657 if(w == -1) 658 fatal1("bad wait code"); 659 enbint(intrupt); 660 if(status & 0377) 661 { 662 if(status != SIGINT) 663 fprintf(diagfile, "Termination code %d", status); 664 done(3); 665 } 666 return(status>>8); 667 } 668 669 /* File Name and File Manipulation Routines */ 671 672 static int 673 unreadable(char *s) 674 { 675 FILE *fp; 676 677 if((fp = fopen(s, "r"))) { 678 fclose(fp); 679 return(NO); 680 } else { 681 fprintf(diagfile, "Error: Cannot read file %s\n", s); 682 loadflag = NO; 683 return(YES); 684 } 685 } 686 687 688 static void 689 crfnames(void) 690 { 691 snprintf(asmfname, sizeof(asmfname), "fort%d.%s", pid, "s"); 692 snprintf(prepfname, sizeof(prepfname), "fort%d.%s", pid, "p"); 693 } 694 695 696 697 static void 698 rmf(char *fn) 699 { 700 if(!debugflag && fn!=NULL && *fn!='\0') 701 unlink(fn); 702 } 703 704 705 static int 706 dotchar(char *s) 707 { 708 for( ; *s ; ++s) 709 if(s[0]=='.' && s[1]!='\0' && s[2]=='\0') 710 return( s[1] ); 711 return(NO); 712 } 713 714 715 static char * 716 lastfield(char *s) 717 { 718 char *t; 719 for(t = s; *s ; ++s) 720 if(*s == '/') 721 t = s+1; 722 return(t); 723 } 724 725 726 static char * 727 lastchar(char *s) 728 { 729 while(*s) 730 ++s; 731 return(s-1); 732 } 733 734 735 static char * 736 setdoto(char *s) 737 { 738 *lastchar(s) = 'o'; 739 return( lastfield(s) ); 740 } 741 742 743 static char * 744 copyn(int n, char *s) 745 { 746 char *p, *q; 747 748 p = q = (char *)calloc(1, (unsigned) n + 1); 749 if (!p) 750 fatal1("out of memory"); 751 752 while(n-- > 0) 753 *q++ = *s++; 754 return (p); 755 } 756 757 758 static int 759 nodup(char *s) 760 { 761 char **p; 762 763 for(p = loadargs ; p < loadp ; ++p) 764 if( !strcmp(*p, s) ) 765 return(NO); 766 767 return(YES); 768 } 769 770 771 static void 772 errorx(char *fmt, ...) 773 { 774 va_list ap; 775 776 va_start(ap, fmt); 777 vfprintf(diagfile, fmt, ap); 778 fprintf(diagfile, "\n"); 779 va_end(ap); 780 781 if (debugflag) 782 abort(); 783 done(1); 784 } 785 786 787 static void 788 fatal1(char *fmt, ...) 789 { 790 va_list ap; 791 792 va_start(ap, fmt); 793 fprintf(diagfile, "Compiler error in file %s: ", infname); 794 vfprintf(diagfile, fmt, ap); 795 fprintf(diagfile, "\n"); 796 va_end(ap); 797 798 if (debugflag) 799 abort(); 800 done(1); 801 } 802
Indexes created Mon Jul 20 00:27:07 UTC 2026