home *** CD-ROM | disk | FTP | other *** search
/ Compendium Deluxe 1 / LSD Compendium Deluxe 1.iso / a / programming / misc / ada1110b.lha / AmigaSources / adacomp.c next >
Encoding:
C/C++ Source or Header  |  1993-07-10  |  24.4 KB  |  919 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include <stdlib.h>
  11. #include <stdio.h>
  12. #include <ctype.h>
  13. #include <string.h>
  14. #ifdef __GNUG__
  15. #define WAITPARM (int*)
  16. #else
  17. #define WAITPARM (union wait*)
  18. #endif
  19. #include "config.h"
  20. #include "adamrgprots.h"
  21. #include "miscprots.h"
  22.  
  23. #ifdef AMIGA
  24. #define fork vfork
  25. #endif
  26.  
  27. #ifdef vms
  28. /*  Temporary fix to avoid missing adacomp.h
  29. #define fork vfork
  30. #define unlink delete
  31. #include "adacomp.h"
  32. #include descrip
  33. #include <file.h>
  34. #include <types.h>
  35. #include <stat.h>
  36. */
  37. #else
  38. #include <sys/types.h>
  39. #ifdef IBM_PC
  40. #include <fcntl.h>
  41. #include <process.h>
  42. #else
  43. #include <sys/file.h>
  44. #endif
  45. #endif
  46.  
  47. #ifdef SYSTEM_V
  48. #include <fcntl.h>
  49. #endif
  50. #include <signal.h>
  51.  
  52. #ifdef BSD
  53. #include "time.h"
  54. #include <sys/resource.h>
  55. #endif
  56.  
  57. static int check_status(int, char *, char *);
  58. static char *getsym(char *, char *);
  59. static void arg_dump();
  60. static int run_prog(char *, char **);
  61. static void delete_file(char *);
  62. #ifdef SYSTEM_V
  63. static  int mkdir(char *, int);
  64. #endif
  65. #ifdef vms
  66. static void fold_upper(char *s)                                /*;fold_upper*/
  67. #endif
  68.  
  69. char   *argname;
  70. FILE *MALFILE; /* for use by misc malloc trace */
  71. int     opts_cnt;
  72. char   *other_opts[20];
  73. char   *interface_opts[20];
  74. int     interface_cnt = 0;
  75. int    maxstatus = RC_SUCCESS; /* maximum exit status from called programs */
  76. int     exec_trace = 0;    /* set to print generated command lines */
  77.  
  78. /* names of executables to use if not defined by environment */
  79. #define PRS_NAME "adaprs"
  80. #define SEM_NAME "adasem"
  81. #define GEN_NAME "adagen"
  82. #define BND_NAME "adabind"
  83.  
  84. /* status_get extracts program exit code */
  85. #ifdef IBM_PC
  86. #define status_get(s)        (s)
  87. #define system_status_get(s) (s)
  88. #else
  89. #ifdef vms
  90. #define status_get(s)        (s)
  91. #define system_status_get(s) (s)
  92. #else
  93. #define status_get(s)           ((s)>>8)
  94. #define system_status_get(s) ((s) & 0xff)
  95. #endif
  96. #endif
  97.  
  98. char   *base_name;
  99.  
  100. main(int argc, char **argv)
  101. {
  102.     int     c,fp;
  103.     int     status, ok = TRUE;
  104.     extern int  optind;
  105.     extern char *optarg;
  106. #ifdef vms
  107.     extern char *strjoin(); /* vms only */
  108.     char   *strchr();
  109.     char   *DIRECTORY_START = "[.";
  110. #endif
  111.     char   *PRS, *SEM, *GEN, *BND; 
  112.     char   *arg_name;
  113.     char   *lib_name;
  114.     char   *list_name;
  115.     char   *source_name;
  116.     char   *msg_name;
  117.     char   *tmp_name;
  118.     char   *s_temp;
  119.     char   *l_name;
  120.     char   *basep;
  121.     int       prefix_len, base_len, suffix_len;
  122.     char   *lib_opt_str, *main_unit_name;
  123.     char   *object_files = "";
  124.     char   *sem_options, *gen_options;
  125.     int     bind_opt = 0, main_opt = 0, save_msg_opt = 0 ;
  126.     int     list_opt = FALSE;   /* set to generate a listing */
  127.     char   *list_arg;        /* for passing list_opt to mrg */
  128.     int     lib_opt = FALSE;    /* set to TRUE if -l specified */
  129.     int     newlib_opt = FALSE; /* set to TRUE if -n specified */
  130.     int        time_limit = 15;    /* default time limit in minutes */
  131. #ifdef vms
  132.     char        buffer[50];
  133.     short       rlength;
  134.     struct      dsc$descriptor_s entity_desc;
  135.     struct      dsc$descriptor_s value_desc;
  136.     struct      dsc$descriptor_s string_desc;
  137.     struct      dsc$descriptor_s old_filespec;
  138.     struct      dsc$descriptor_s new_filespec;
  139. #endif
  140. #ifdef BSD
  141.     struct rlimit rlp;
  142. #endif
  143.  
  144. /* initializations */
  145.     arg_name = (char *) 0;
  146.     lib_name = (char *) 0;
  147.     sem_options = "";
  148.     gen_options = "";
  149.  
  150. #ifdef vms
  151.          entity_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  152.          entity_desc.dsc$b_class = DSC$K_CLASS_S;
  153.          value_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  154.          value_desc.dsc$b_class = DSC$K_CLASS_S;
  155.          value_desc.dsc$a_pointer = buffer;
  156.          value_desc.dsc$w_length = 50;
  157.  
  158.          entity_desc.dsc$a_pointer = "VERBOSE";
  159.          entity_desc.dsc$w_length = 7;
  160.          status = CLI$PRESENT(&entity_desc);
  161. #ifdef DEBUG
  162.          printf("VERBOSE status %d\n",status);
  163. #endif
  164.          exec_trace = status & 1;
  165.          if (exec_trace) fprintf(stderr,"Command line: ADACOMP /VERBOSE");
  166.  
  167.          entity_desc.dsc$a_pointer = "ADALINES";
  168.          entity_desc.dsc$w_length = 8;
  169.          status = CLI$PRESENT(&entity_desc);
  170. #ifdef DEBUG
  171.          printf("ADALINES status %d\n",status);
  172. #endif
  173.          if (status & 1) {
  174.              gen_options = strjoin(gen_options,"l");
  175.              if (exec_trace) fprintf(stderr,"/ADALINES");
  176.          }
  177.          
  178.          entity_desc.dsc$a_pointer = "BIND";
  179.          entity_desc.dsc$w_length = 4;
  180.          status = CLI$PRESENT(&entity_desc);
  181. #ifdef DEBUG
  182.          printf("BIND status %d\n",status);
  183. #endif
  184.          bind_opt = (status & 1);
  185.          if (bind_opt && exec_trace) fprintf(stderr,"/BIND");
  186.          
  187.          entity_desc.dsc$a_pointer = "FILE";
  188.          entity_desc.dsc$w_length = 4;
  189.          status = CLI$PRESENT(&entity_desc);
  190. #ifdef DEBUG
  191.          printf("FILE status %d\n",status);
  192. #endif
  193.          if (status & 1) {
  194.              status = CLI$GET_VALUE(&entity_desc, &value_desc, &rlength);
  195.              value_desc.dsc$a_pointer[rlength] = '\0';
  196.              arg_name = strjoin(value_desc.dsc$a_pointer,"");
  197.              if (exec_trace) fprintf(stderr," %s ",arg_name);
  198. #ifdef DEBUG
  199.              printf("FILE %s\n", arg_name);
  200. #endif
  201.          }
  202.          
  203.          entity_desc.dsc$a_pointer = "LIBRARY";
  204.          entity_desc.dsc$w_length = 7;
  205.          status = CLI$PRESENT(&entity_desc);
  206. #ifdef DEBUG
  207.          printf("LIBRARY status %d\n",status);
  208. #endif
  209.          lib_opt = status & 1;
  210.          if (lib_opt) {
  211.              status = CLI$GET_VALUE(&entity_desc, &value_desc, &rlength);
  212.              value_desc.dsc$a_pointer[rlength] = '\0';
  213.              lib_name = strjoin(value_desc.dsc$a_pointer,"");
  214.              if (exec_trace) fprintf(stderr,"/LIBRARY=%s",lib_name);
  215. #ifdef DEBUG
  216.              printf("LIBRARY %s\n", lib_name);
  217. #endif
  218.          }
  219.          
  220.          entity_desc.dsc$a_pointer = "NEWLIBRARY";
  221.          entity_desc.dsc$w_length = 10;
  222.          status = CLI$PRESENT(&entity_desc);
  223. #ifdef DEBUG
  224.          printf("NEWLIBRARY status %d\n",status);
  225. #endif
  226.          newlib_opt = status & 1;
  227.          if (newlib_opt && exec_trace) fprintf(stderr,"/NEWLIBRARY");
  228.  
  229.          entity_desc.dsc$a_pointer = "LISTING";
  230.          entity_desc.dsc$w_length = 7;
  231.          status = CLI$PRESENT(&entity_desc);
  232. #ifdef DEBUG
  233.          printf("LISTING status %d\n",status);
  234. #endif
  235.          list_opt = status & 1;
  236.          if (list_opt && exec_trace) fprintf(stderr,"/LISTING");
  237.  
  238.          entity_desc.dsc$a_pointer = "MAIN_UNIT";
  239.          entity_desc.dsc$w_length = 9;
  240.          status = CLI$PRESENT(&entity_desc);
  241. #ifdef DEBUG
  242.          printf("MAIN_UNIT status %d\n",status);
  243. #endif
  244.          main_opt = status & 1;
  245.          if (main_opt) {
  246.              status = CLI$GET_VALUE(&entity_desc, &value_desc, &rlength);
  247.              value_desc.dsc$a_pointer[rlength] = '\0';
  248.              main_unit_name = strjoin(value_desc.dsc$a_pointer,"");
  249.              fold_upper(main_unit_name);
  250.              if (exec_trace) fprintf(stderr,"/MAIN_UNIT=%s",main_unit_name);
  251. #ifdef DEBUG
  252.              printf("MAIN_UNIT %s\n", main_unit_name);
  253. #endif
  254.          }
  255.  
  256.          entity_desc.dsc$a_pointer = "MESSAGES";
  257.          entity_desc.dsc$w_length = 8;
  258.          status = CLI$PRESENT(&entity_desc);
  259. #ifdef DEBUG
  260.          printf("MESSAGES status %d\n",status);
  261. #endif
  262.          save_msg_opt = status & 1;
  263.          if (save_msg_opt && exec_trace) fprintf(stderr,"/MESSAGES");
  264.  
  265.          entity_desc.dsc$a_pointer = "MACHINE_CODE";
  266.          entity_desc.dsc$w_length = 12;
  267.          status = CLI$PRESENT(&entity_desc);
  268. #ifdef DEBUG
  269.          printf("MACHINE_CODE status %d\n",status);
  270. #endif
  271.          if (status & 1) {
  272.              gen_options = strjoin(gen_options,"g");
  273.              if (exec_trace) fprintf(stderr,"/MACHINE_CODE");
  274.          }
  275.          if (exec_trace) fprintf(stderr,"\n");
  276.  
  277.          entity_desc.dsc$a_pointer = "PREDEF";
  278.          entity_desc.dsc$w_length = 6;
  279.          status = CLI$PRESENT(&entity_desc);
  280. #ifdef DEBUG
  281.          printf("PREDEF status %d\n",status);
  282. #endif
  283.          if (status & 1) {
  284.              if (exec_trace) fprintf(stderr,"/PREDEF");
  285.          s_temp = emalloc(strlen(sem_options) + 2);
  286.            strcpy(s_temp, sem_options);
  287.              strcat(s_temp, "p");
  288.          sem_options = s_temp;
  289.          s_temp = emalloc(strlen(gen_options) + 2);
  290.          strcpy(s_temp, gen_options);
  291.              strcat(s_temp, "p");
  292.          gen_options = s_temp;
  293.      }
  294. #else
  295. /*
  296.  * command options
  297.  *    -a        generated line number instructions
  298.  *    -b         bind the unit specified by 'm' option
  299.  *    -g        insert generated code into listing
  300.  *      -i              specify object files and libraries for pragma interface
  301.  *    -l libname    (old) library libname
  302.  *    -m main unit      specify the main binding unit.
  303.  *            or use default main unit
  304.  *    -n libname    new library libname
  305.  *      -s        create source program listing
  306.  *    -v        trace executed commands and exit status
  307.  *      -M        save message files (for running B tests)
  308.  *      -P        compile predef
  309.  */
  310.  
  311.     while((c = getopt(argc, argv, "abgl:m:nsvMPi:")) != EOF) {
  312.  
  313.     switch(c) {
  314.         case 'a':
  315.         s_temp = emalloc(strlen(gen_options) + 2);
  316.         strcpy(s_temp, gen_options);
  317.             strcat(s_temp, "l");
  318.         gen_options = s_temp;
  319.         break;
  320.         case 'b':
  321.         bind_opt = 1;
  322.         break;
  323.         case 'g':
  324.         s_temp = emalloc(strlen(gen_options) + 2);
  325.         strcpy(s_temp, gen_options);
  326.             strcat(s_temp, "g");
  327.         gen_options = s_temp;
  328.         break;
  329.         case 'l':
  330.         lib_opt = TRUE;
  331.         lib_name = emalloc(strlen(optarg) + 1);
  332.         strcpy(lib_name, optarg);
  333.         break;
  334.         case 'm':    
  335.         main_opt = 1;
  336.         main_unit_name = emalloc(strlen(optarg) + 1);
  337.         strcpy(main_unit_name, optarg);
  338.         break;
  339.         case 'n':
  340.         newlib_opt = TRUE;
  341.         break;
  342.             case 'i':
  343.         s_temp = emalloc(strlen(optarg) + 1);
  344.         strcpy(s_temp, optarg);
  345.         interface_opts[interface_cnt++] = s_temp;
  346.                 break;
  347.         case 's':
  348.         list_opt++;
  349.         break;
  350.         case 'v':
  351.         exec_trace++;
  352.         break;
  353.         case 'M':
  354.         save_msg_opt = TRUE ;
  355.         break;
  356.         case 'P':
  357.         s_temp = emalloc(strlen(sem_options) + 2);
  358.         strcpy(s_temp, sem_options);
  359.             strcat(s_temp, "p");
  360.         sem_options = s_temp;
  361.         s_temp = emalloc(strlen(gen_options) + 2);
  362.         strcpy(s_temp, gen_options);
  363.             strcat(s_temp, "p");
  364.         gen_options = s_temp;
  365.         break;
  366.         case '?':
  367.         exit(RC_ABORT);
  368.         break;
  369.         default:
  370.         fprintf(stderr, "Unknown Option: %c\n", c);
  371.         exit(RC_ABORT);
  372.     }
  373.     }
  374.     if (optind < argc)
  375.     arg_name = argv[optind];
  376.     if (arg_name == (char *) 0) {
  377.     fprintf(stderr,"Invalid Usage: No ada file specified\n");
  378.     exit(RC_ABORT);
  379.     }
  380. #endif
  381.     if (!lib_opt) { /* if -l not specified, try to get from environment */
  382. #ifdef vms
  383.        lib_name = getenv("ADAEDLIB");
  384. #else
  385.        lib_name = getenv("ADALIB");
  386. #endif
  387.        if (lib_name!=(char *)0) {
  388.        lib_opt++;
  389.     }
  390.     if (lib_opt) {
  391. #ifdef vms
  392.         printf("library defined by ADAEDLIB: %s\n",lib_name);
  393. #else
  394.         printf("library defined by ADALIB: %s\n",lib_name);
  395. #endif
  396.     }
  397.     }
  398.     if (!lib_opt) {
  399. #ifdef vms
  400.        LIB$SIGNAL(MSG_USAGE);
  401. #else
  402.        fprintf(stderr,
  403.         "Invalid Usage: please specify a library\n");
  404.        exit(RC_ABORT);
  405. #endif
  406.     }
  407. #ifdef BSD
  408.     getrlimit(RLIMIT_CPU,&rlp);
  409.     (&rlp)->rlim_cur = time_limit*60;     /* limit to time_limit mins */
  410.     setrlimit(RLIMIT_CPU,&rlp);
  411. #endif
  412.  
  413.     basep = parsefile(arg_name, &prefix_len, &base_len, &suffix_len);
  414.     /* check for presence of ada file;  if none, make it ada */
  415.     if (suffix_len ==0) {
  416.     source_name = emalloc(strlen(arg_name) + 4 + 1);
  417.     strcpy(source_name, arg_name);
  418.     strcat(source_name, ".ada");
  419.     }
  420.     else {
  421.     source_name = arg_name;
  422.     }
  423.     base_name = emalloc(base_len + 1);
  424.     strncpy(base_name, basep, base_len);
  425.     if ((fp = open(source_name,O_RDONLY,0700)) < 0) {
  426. #ifdef vms
  427.         string_desc.dsc$w_length = strlen(source_name);
  428.         string_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  429.         string_desc.dsc$b_class = DSC$K_CLASS_S;
  430.         string_desc.dsc$a_pointer = source_name;
  431.         LIB$SIGNAL(MSG_ADAFILE,1,&string_desc);
  432.         exit();
  433. #else
  434.     fprintf(stderr,"Cannot access file %s\n",source_name);
  435.     exit(RC_ABORT);
  436. #endif
  437.     }
  438.     close(fp);
  439.  
  440.  
  441.     umask(0);
  442.     if (newlib_opt){
  443.         if (exec_trace) {
  444.         fprintf(stderr, "mkdir %s ", lib_name);
  445.         }
  446.         status = mkdir(lib_name, '\377');
  447.         if (exec_trace) {
  448.         fprintf(stderr, " ? %d\n", status);
  449.         }
  450.     }
  451.     status = 0;
  452.     if (status) {
  453. #ifdef vms
  454.         string_desc.dsc$w_length = strlen(lib_name);
  455.         string_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  456.         string_desc.dsc$b_class = DSC$K_CLASS_S;
  457.         string_desc.dsc$a_pointer = lib_name;
  458.         LIB$SIGNAL(MSG_NOLIBRARY,1,&string_desc);
  459.         exit();
  460. #else
  461.         fprintf(stderr,"%s cannot be used as a library\n", lib_name);
  462.         exit(RC_ABORT);
  463. #endif
  464.     }
  465.     if (!newlib_opt) {
  466.         /* check for presence of library file */
  467. #ifdef vms
  468.     l_name = emalloc(strlen(lib_name + strlen(LIBFILENAME) + 4));
  469.         if (strchr(lib_name,'[')) {
  470.        strcpy(l_name, lib_name);
  471.     }
  472.     else {
  473.        strcpy(l_name, DIRECTORY_START);
  474.            strcat(l_name, lib_name);
  475.     }
  476. #else
  477.     l_name = emalloc(strlen(lib_name) + strlen(LIBFILENAME) + 2);
  478.     strcpy(l_name, lib_name);
  479. #endif
  480.  
  481. #ifdef AMIGA
  482.     strcat(l_name, "/");
  483. #endif
  484. #ifdef BSD
  485.     strcat(l_name, "/");
  486. #endif
  487. #ifdef SYSTEM_V
  488.     strcat(l_name, "/");
  489. #endif
  490. #ifdef IBM_PC
  491.     strcat(l_name, "/");
  492. #endif
  493. #ifdef vms
  494.         if (!strchr(lib_name,'['))
  495.        strcat(l_name, "]");
  496. #endif
  497.     strcat(l_name, LIBFILENAME);
  498.  
  499.         if ((fp = open(l_name,O_RDONLY,0700)) < 0) {
  500. #ifdef vms
  501.             string_desc.dsc$w_length = strlen(lib_name);
  502.             string_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  503.             string_desc.dsc$b_class = DSC$K_CLASS_S;
  504.             string_desc.dsc$a_pointer = lib_name;
  505.             LIB$SIGNAL(MSG_NOLIBRARY,1,&string_desc);
  506.             exit();
  507. #else
  508.             fprintf(stderr,"%s cannot be used as a library\n", lib_name);
  509.             exit(RC_ABORT);
  510. #endif
  511.         }
  512.     efree(l_name);
  513.         close(fp);
  514.     }
  515.  
  516.     /* format library option as expected by adasem & adagen */
  517.     lib_opt_str = ((newlib_opt) ? "-nl" : "-l");
  518.  
  519.     PRS = getsym("PRS", PRS_NAME);
  520.     other_opts[opts_cnt = 0] = PRS;
  521.     other_opts[++opts_cnt] = lib_opt_str;
  522.     other_opts[++opts_cnt] = lib_name;
  523.     other_opts[++opts_cnt] = source_name;
  524.     other_opts[++opts_cnt] = (char *) 0;
  525.     if (exec_trace)
  526.         arg_dump();
  527.     status = run_prog(PRS, other_opts);
  528.  
  529.     if (exec_trace)
  530.         fprintf(stderr, " ? %d\n", status);
  531.     ok = check_status(status, "PRS", arg_name);
  532.     if (ok) {
  533.     SEM = getsym("SEM",SEM_NAME);
  534.     other_opts[opts_cnt = 0] = SEM;
  535.     /* check for parsing errors (adaprs exits with RC_ERRORS) */
  536.     if (status_get(status) == RC_ERRORS) {
  537.         s_temp = emalloc(strlen(sem_options) + 2);
  538.         strcpy(s_temp, sem_options);
  539.         strcat(s_temp, "e");
  540.         sem_options = s_temp;
  541.     }
  542.     if (strlen(sem_options) != 0) {
  543.         other_opts[++opts_cnt] = "-s";
  544.         other_opts[++opts_cnt] = sem_options;
  545.     }
  546.     other_opts[++opts_cnt] = lib_opt_str;
  547.     other_opts[++opts_cnt] = lib_name;
  548.     other_opts[++opts_cnt] = base_name;
  549.     other_opts[++opts_cnt] = (char *) 0;
  550.     if (exec_trace)
  551.         arg_dump();
  552.     status = run_prog(SEM, other_opts);
  553.     if (exec_trace)
  554.         fprintf(stderr, " ? %d\n", status);
  555.     ok = check_status(status, "SEM", arg_name);
  556.         /* check for semantic errors (adasem will exit with RC_ERRORS) */
  557.     if (status_get(status)== RC_ERRORS)
  558.         ok = FALSE;
  559.     }
  560.     /* once SEM run, can delete AST file */
  561.     tmp_name = emalloc(strlen(lib_name) + strlen(base_name) + 7);
  562. #ifdef vms
  563.     if (strchr(lib_name,'[')) {
  564.        strcpy(tmp_name, lib_name);
  565.     }
  566.     else {
  567.        strcpy(tmp_name, DIRECTORY_START);
  568.        strcat(tmp_name, lib_name);
  569.     }
  570. #else
  571.     strcpy(tmp_name, lib_name);
  572. #endif
  573.  
  574. #ifdef AMIGA
  575.     strcat(tmp_name,"/");
  576. #endif
  577. #ifdef BSD
  578.     strcat(tmp_name,"/");
  579. #endif
  580. #ifdef SYSTEM_V
  581.     strcat(tmp_name,"/");
  582. #endif
  583. #ifdef IBM_PC
  584.     strcat(tmp_name,"/");
  585. #endif
  586. #ifdef vms
  587.     if (!strchr(lib_name,'[')) 
  588.        strcat(tmp_name,"]");
  589. #endif
  590.     strcat(tmp_name, base_name);
  591.     strcat(tmp_name, ".ast");
  592.     delete_file(tmp_name);
  593.     efree(tmp_name);
  594.     if (ok) {
  595.     GEN = getsym("GEN", GEN_NAME);
  596.     other_opts[opts_cnt = 0] = GEN;
  597.     if (strlen(gen_options) != 0) {
  598.         other_opts[++opts_cnt] = "-g";
  599.         other_opts[++opts_cnt] = gen_options;
  600.     }
  601.     other_opts[++opts_cnt] = lib_opt_str;
  602.     other_opts[++opts_cnt] = lib_name;
  603.     other_opts[++opts_cnt] = base_name;
  604.     other_opts[++opts_cnt] = (char *) 0;
  605.     if (exec_trace)
  606.         arg_dump();
  607.     status =  run_prog(GEN, other_opts);
  608.     if (exec_trace)
  609.         fprintf(stderr, " ? %d\n", status);
  610.     ok = check_status(status, "GEN", arg_name);
  611.     }
  612.     if (ok && bind_opt) { /* run binder if desired */
  613.     BND = getsym("BND", BND_NAME);
  614.     other_opts[opts_cnt = 0] = BND;
  615.     other_opts[++opts_cnt] = "-c"; /* indicate errors in message form */
  616.     other_opts[++opts_cnt] = base_name; /* pass filename for msg listing */
  617.  
  618.     while(interface_cnt) {
  619.         other_opts[++opts_cnt] = "-i";
  620.         other_opts[++opts_cnt] = interface_opts[--interface_cnt];
  621.     }
  622.     if (main_opt) {
  623.         other_opts[++opts_cnt] = "-m";
  624.         other_opts[++opts_cnt] = main_unit_name;
  625.     }
  626.     other_opts[++opts_cnt] = lib_name; /* library is current directory */
  627.     other_opts[++opts_cnt] = (char *) 0;
  628.     if (exec_trace)
  629.         arg_dump();
  630.     status =  run_prog(BND, other_opts);
  631.     if (exec_trace)
  632.         fprintf(stderr, " ? %d\n", status);
  633.     ok = check_status(status, "BND", arg_name);
  634.     }
  635. #ifdef vms
  636. #ifdef SKIP
  637. /* this rename not needed if file generated in proper place
  638.  * ds 1-17-86
  639.  */
  640. struct      dsc$descriptor_s old_filespec;
  641. struct      dsc$descriptor_s new_filespec;
  642.     list_name = strjoin(base_name,".lis;");
  643. /*    tolist_name = strjoin(dir_name, list_name);*/
  644.         old_filespec.dsc$w_length = strlen(list_name);
  645.         old_filespec.dsc$b_dtype = DSC$K_DTYPE_T;
  646.         old_filespec.dsc$b_class = DSC$K_CLASS_S;
  647.         old_filespec.dsc$a_pointer = list_name;
  648.         new_filespec.dsc$w_length = strlen(tolist_name);
  649.         new_filespec.dsc$b_dtype = DSC$K_DTYPE_T;
  650.         new_filespec.dsc$b_class = DSC$K_CLASS_S;
  651.         new_filespec.dsc$a_pointer = tolist_name;
  652.     status = LIB$RENAME_FILE(&old_filespec, &new_filespec);
  653. #endif
  654. #endif
  655. #ifdef AMIGA
  656.     list_name = emalloc(strlen(base_name) + 4 + 1);
  657.     strcpy(list_name, base_name);
  658.     strcat(list_name, ".lis");
  659. #endif
  660. #ifdef IBM_PC
  661.     list_name = emalloc(strlen(base_name) + 4 + 1);
  662.     strcpy(list_name, base_name);
  663.     strcat(list_name, ".lis");
  664. #endif
  665. #ifdef SYSTEM_V
  666.     list_name = emalloc(strlen(base_name) + 4 + 1);
  667.     strcpy(list_name, base_name);
  668.     strcat(list_name, ".lis");
  669. #endif
  670. #ifdef BSD
  671.     list_name = emalloc(strlen(base_name) + 4 + 1);
  672.     strcpy(list_name, base_name);
  673.     strcat(list_name, ".lis");
  674. #endif
  675. #ifdef vms
  676.     list_name = emalloc(strlen(base_name) + 4 + 1);
  677.     strcpy(list_name, base_name);
  678.     strcat(list_name, ".lis");
  679. #endif
  680.     list_arg = (list_opt>0) ? "1" : "0";
  681.     msg_name = emalloc(strlen(lib_name) + strlen(base_name) + 7);
  682. #ifdef vms
  683.     if (strchr(lib_name,'[')) {
  684.        strcpy(msg_name, lib_name);
  685.     }
  686.     else {
  687.        strcpy(msg_name, DIRECTORY_START);
  688.        strcat(msg_name, lib_name);
  689.     }
  690. #else
  691.     strcpy(msg_name, lib_name);
  692. #endif
  693. #ifdef AMIGA
  694.     strcat(msg_name,"/");
  695. #endif
  696. #ifdef BSD
  697.     strcat(msg_name,"/");
  698. #endif
  699. #ifdef SYSTEM_V
  700.     strcat(msg_name,"/");
  701. #endif
  702. #ifdef IBM_PC
  703.     strcat(msg_name,"/");
  704. #endif
  705. #ifdef vms
  706.     if (!strchr(lib_name,'['))
  707.        strcat(msg_name,"]");
  708. #endif
  709.     strcat(msg_name, base_name);
  710.     strcat(msg_name, ".msg");
  711.     status = mrg(source_name,msg_name, list_name, list_arg);
  712.     efree(list_name);
  713.     if (!save_msg_opt) {
  714.         delete_file(msg_name);
  715.     efree(msg_name);
  716.     }
  717.  
  718. #ifdef vms
  719.     if (maxstatus == RC_ABORT || maxstatus == RC_INTERNAL_ERROR) {
  720.         string_desc.dsc$w_length = strlen(source_name);
  721.         string_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  722.         string_desc.dsc$b_class = DSC$K_CLASS_S;
  723.         string_desc.dsc$a_pointer = source_name;
  724.         LIB$SIGNAL(MSG_ABORT,1,&string_desc);
  725.     }
  726.     exit();
  727. #else
  728.     exit(maxstatus);
  729. #endif
  730. }
  731.  
  732. static char *getsym(char *env_name, char *def_value)        /*;getsym*/
  733. {
  734.   /* Retrieve environment variable designating the executable module for
  735.    * a given phase of the compiler.
  736.    * If the variable is not defined, a default is supplied for BSD systems,
  737.    * whereas on vms execution is aborted!
  738.    */
  739.     char   *s;
  740. #ifdef vms
  741.     struct dsc$descriptor_s phase_desc;
  742. #endif
  743.  
  744.     s = getenv(env_name);
  745.     if (s==(char *)0) {
  746.         char *t = get_libdir();
  747. #ifdef vms
  748.         phase_desc.dsc$w_length = strlen(env_name);
  749.         phase_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  750.         phase_desc.dsc$b_class = DSC$K_CLASS_S;
  751.         phase_desc.dsc$a_pointer = env_name;
  752.         LIB$SIGNAL(MSG_NOENVVAR,1,&phase_desc);
  753.         exit();
  754. #else
  755.         s = emalloc(strlen(t) + strlen(def_value) + 2);
  756.         sprintf(s,"%s/%s", t, def_value);
  757. #endif
  758.     }
  759.     return s;
  760. }
  761.  
  762. static int check_status(int pstatus, char *phase, char *filename)
  763.                                                             /*;check_status*/
  764. {
  765. #ifdef vms
  766.     struct dsc$descriptor_s err_desc ;
  767. #endif
  768.  
  769. #ifdef BSD
  770.     if (system_status_get(pstatus) == SIGXCPU) {
  771.         fprintf(stderr, "Ada/Ed cpu time limit exceeded for %s\n",phase);
  772.         return (FALSE);
  773.     }
  774. #endif
  775.  
  776. #ifdef vms
  777.     /* check for internal compiler error and a signal (system transmitted)
  778.      * that is not IGNORE (1) or BAD_SIGNAL (-1)
  779.      * Check first for user return codes since vms will give precedence
  780.      * toguarantee what will appear user return codes if there was no crash.
  781.      */
  782.     if (status_get(pstatus)  == RC_SUCCESS) {
  783.         return (TRUE);
  784.     }
  785.     if (status_get(pstatus) == RC_ERRORS){
  786.         maxstatus = RC_ERRORS;
  787.         return (TRUE);
  788.     }
  789.     if (status_get(pstatus)  == RC_ABORT) {
  790.         maxstatus = RC_ABORT;
  791.         return (FALSE);
  792.     }
  793.     if ( (status_get(pstatus)  == RC_INTERNAL_ERROR)
  794.       || (system_status_get(pstatus) > 1 && system_status_get(pstatus) < 255)) {
  795.         maxstatus = RC_INTERNAL_ERROR;
  796.         err_desc.dsc$w_length = strlen(phase);
  797.         err_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  798.         err_desc.dsc$b_class = DSC$K_CLASS_S;
  799.         err_desc.dsc$a_pointer = phase;
  800.         LIB$SIGNAL(MSG_BUGCHECK,1,&err_desc);
  801.         return (FALSE);
  802.      }
  803. #else
  804.     /* check for internal compiler error and a signal (system transmitted)
  805.      * that is not IGNORE (1) or BAD_SIGNAL (-1)
  806.      * Check first for crash, since have no guarantee what will appear
  807.      * in 'user' section of return code (status_get field)
  808.      */
  809.     if ( (status_get(pstatus)  == RC_INTERNAL_ERROR)
  810.       || (system_status_get(pstatus) > 1 && system_status_get(pstatus) < 255)) {
  811.         maxstatus = RC_INTERNAL_ERROR;
  812.         fprintf(stderr,"Ada/Ed Internal error(%s) for %s\n", phase, filename);
  813.         return (FALSE);
  814.     }
  815.     if (status_get(pstatus)  == RC_SUCCESS) {
  816.         return (TRUE);
  817.     }
  818.     if (status_get(pstatus) == RC_ERRORS){
  819.         maxstatus = RC_ERRORS;
  820.         return (TRUE);
  821.     }
  822.     if (status_get(pstatus)  == RC_ABORT) {
  823.         maxstatus = RC_ABORT;
  824.         return (FALSE);
  825.     }
  826. #endif
  827. }
  828.  
  829. static void arg_dump()                                            /*;arg_dump*/
  830. {
  831. /*list generated command*/
  832.     int     i;
  833.     fprintf(stderr, "%s ", other_opts[0]);
  834.     for (i = 1; i < opts_cnt; i++) {
  835.         fprintf(stderr, " %s", other_opts[i]);
  836.     }
  837.     fprintf(stderr,"\n");
  838. }
  839.  
  840. static int run_prog(char *prog, char **args)                    /*;run_prog*/
  841. {
  842.     int status;
  843. #ifdef vms
  844.    struct dsc$descriptor_s string_desc;
  845. #endif
  846.  
  847. #ifdef IBM_PC
  848.     status = spawnv(P_WAIT, prog, args);
  849. #else
  850.     if (fork() == 0)
  851. #ifdef vms
  852.         if (execv(prog,other_opts)) {
  853.             string_desc.dsc$w_length = strlen(prog);
  854.             string_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  855.             string_desc.dsc$b_class = DSC$K_CLASS_S;
  856.             string_desc.dsc$a_pointer = prog;
  857.             LIB$SIGNAL(MSG_NOEXECUTE,1,&string_desc);
  858.             exit();
  859.         }
  860. #else
  861.         if (execvp(prog , other_opts)) {
  862.             fprintf(stderr,"cannot execute %s\n", prog);
  863.             exit(RC_ABORT);
  864.         }
  865. #endif
  866.     wait( WAITPARM &status);
  867. #endif
  868.     return status;
  869. }
  870.  
  871. static void delete_file(char *file_name)                    /* ;delete_file */
  872. {
  873.     int status;
  874.  
  875. #ifdef vms
  876.     extern char *strjoin();
  877.  
  878.     file_name = strjoin(file_name,";");
  879. #endif
  880.     status = unlink(file_name);
  881.     if (exec_trace)
  882.         fprintf(stderr,"unlink %s ? %d\n",file_name, status);
  883. }
  884.  
  885. #ifdef SYSTEM_V
  886. #include <sys/stat.h>
  887. /* no mkdir available, mknod doesn't work, so use system */
  888. char syscommand[100];        /* argument for system() call */
  889. static  int mkdir(char *lib_name, int mode)                            /*;mkdir*/
  890. {
  891.     int status;
  892.     struct stat statrec;
  893.  
  894.     if (stat(lib_name,&statrec)) {
  895.        /* stat returns nonzero value if cannot find file. This check
  896.         * is to avoid calling mkdir on an existing directory (since
  897.         * SYSTEM_V complains)
  898.         */
  899.        sprintf(syscommand,"mkdir %s",lib_name);
  900.        system(syscommand);
  901.        return (0);
  902.     }
  903.     else return (-1);
  904. }
  905. #endif
  906.  
  907. #ifdef vms
  908. static void fold_upper(char *s)                                /*;fold_upper*/
  909. {
  910.     char c;
  911.  
  912.     while (*s) {
  913.          c = *s;
  914.     if (islower(c)) *s = toupper(c);
  915.     s++;
  916.     }
  917. }
  918. #endif
  919.