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 37char 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 52typedef FILE *FILEP; 53typedef int flag; 54#define YES 1 55#define NO 0 56 57FILEP diagfile; 58 59static int pid; 60static int sigivalue = 0; 61static 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 75static char *fcom = LIBEXECDIR "/" FCOM ; 76static char *asmname = ASSEMBLER ; 77static char *ldname = LINKER ; 78static char *startfiles[] = STARTFILES; 79static char *endfiles[] = ENDFILES; 80static char *dynlinker[] = DYNLINKER; 81static char *crt0file = CRT0FILE; 82static char *macroname = "m4"; 83static char *shellname = "/bin/sh"; 84static char *aoutname = "a.out" ; 85static char *libdir = LIBDIR ; 86static char *liblist[] = F77LIBLIST; 87 88static char *infname; 89static char asmfname[15]; 90static char prepfname[15]; 91 92#define MAXARGS 100 93int ffmax; 94static char *ffary[MAXARGS]; 95static char eflags[30] = ""; 96static char rflags[30] = ""; 97static char lflag[3] = "-x"; 98static char *eflagp = eflags; 99static char *rflagp = rflags; 100static char **loadargs; 101static char **loadp; 102static int oflag; 103 104static flag loadflag = YES; 105static flag saveasmflag = NO; 106static flag profileflag = NO; 107static flag optimflag = NO; 108static flag debugflag = NO; 109static flag verbose = NO; 110static flag fortonly = NO; 111static flag macroflag = NO; 112 113static char *setdoto(char *), *lastchar(char *), *lastfield(char *); 114static void intrupt(int); 115static void enbint(void (*)(int)); 116static void crfnames(void); 117static void fatal1(char *, ...); 118static void done(int), texec(char *, char **); 119static char *copyn(int, char *); 120static int dotchar(char *), unreadable(char *), sys(char *), dofort(char *); 121static int nodup(char *); 122static int await(int); 123static void rmf(char *), doload(char *[], char *[]), doasm(char *); 124static int callsys(char *, char **); 125static void errorx(char *, ...); 126 127static void 128addarg(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 137int 138main(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 } 272endfor: 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 384static int 385dofort(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 409static void 410doasm(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 435static void 436doload(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 */ 477static int 478callsys(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 529static int 530sys(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 */ 600static void 601texec(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 */ 618static void 619done(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 632static void 633enbint(void (*k)(int)) 634{ 635if(sigivalue == 0) 636 signal(SIGINT,k); 637if(sigqvalue == 0) 638 signal(SIGQUIT,k); 639} 640 641 642 643static void 644intrupt(int a) 645{ 646done(2); 647} 648 649 650static int 651await(int wait_pid) 652{ 653int w, status; 654 655enbint(SIG_IGN); 656while ( (w = wait(&status)) != wait_pid) 657 if(w == -1) 658 fatal1("bad wait code"); 659enbint(intrupt); 660if(status & 0377) 661 { 662 if(status != SIGINT) 663 fprintf(diagfile, "Termination code %d", status); 664 done(3); 665 } 666return(status>>8); 667} 668 669/* File Name and File Manipulation Routines */ 670 671static int 672unreadable(char *s) 673{ 674 FILE *fp; 675 676 if((fp = fopen(s, "r"))) { 677 fclose(fp); 678 return(NO); 679 } else { 680 fprintf(diagfile, "Error: Cannot read file %s\n", s); 681 loadflag = NO; 682 return(YES); 683 } 684} 685 686 687static void 688crfnames(void) 689{ 690 snprintf(asmfname, sizeof(asmfname), "fort%d.%s", pid, "s"); 691 snprintf(prepfname, sizeof(prepfname), "fort%d.%s", pid, "p"); 692} 693 694 695 696static void 697rmf(char *fn) 698{ 699if(!debugflag && fn!=NULL && *fn!='\0') 700 unlink(fn); 701} 702 703 704static int 705dotchar(char *s) 706{ 707for( ; *s ; ++s) 708 if(s[0]=='.' && s[1]!='\0' && s[2]=='\0') 709 return( s[1] ); 710return(NO); 711} 712 713 714static char * 715lastfield(char *s) 716{ 717char *t; 718for(t = s; *s ; ++s) 719 if(*s == '/') 720 t = s+1; 721return(t); 722} 723 724 725static char * 726lastchar(char *s) 727{ 728while(*s) 729 ++s; 730return(s-1); 731} 732 733 734static char * 735setdoto(char *s) 736{ 737*lastchar(s) = 'o'; 738return( lastfield(s) ); 739} 740 741 742static char * 743copyn(int n, char *s) 744{ 745 char *p, *q; 746 747 p = q = (char *)calloc(1, (unsigned) n + 1); 748 if (!p) 749 fatal1("out of memory"); 750 751 while(n-- > 0) 752 *q++ = *s++; 753 return (p); 754} 755 756 757static int 758nodup(char *s) 759{ 760char **p; 761 762for(p = loadargs ; p < loadp ; ++p) 763 if( !strcmp(*p, s) ) 764 return(NO); 765 766return(YES); 767} 768 769 770static void 771errorx(char *fmt, ...) 772{ 773 va_list ap; 774 775 va_start(ap, fmt); 776 vfprintf(diagfile, fmt, ap); 777 fprintf(diagfile, "\n"); 778 va_end(ap); 779 780 if (debugflag) 781 abort(); 782 done(1); 783} 784 785 786static void 787fatal1(char *fmt, ...) 788{ 789 va_list ap; 790 791 va_start(ap, fmt); 792 fprintf(diagfile, "Compiler error in file %s: ", infname); 793 vfprintf(diagfile, fmt, ap); 794 fprintf(diagfile, "\n"); 795 va_end(ap); 796 797 if (debugflag) 798 abort(); 799 done(1); 800} 801