



		    c_compile.pl1                   10/17/90  0854.7rew 10/17/90  0844.9      392904



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-12-03,DGHowe), approve(86-12-03,MCR7592),
     audit(87-01-07,Martinson), install(87-01-07,MR12.0-1261):
     cc, is the command that puts a C source segment through the various passes
     of the c compiler. It can generate output files with suffixes of .cpp .alm
  2) change(88-08-30,DGHowe), approve(88-08-30,MCR7967),
     audit(88-09-09,RWaters), install(88-10-10,MR12.2-1157):
     Alter to use tssi_ interface to access alm segments. Use find_source_file_
     to find and access the alm source file.
  3) change(89-01-25,RWaters), approve(89-01-25,MCR8026),
     audit(89-02-06,DGHowe), install(89-03-01,MR12.3-1019):
     Added the -list control argument, and modified to use search rules to find
     the default library.
  4) change(90-07-31,DGHowe), approve(90-07-31,MCR8181), audit(90-10-11,Itani),
     install(90-10-17,MR12.4-1045):
     Changed to allow the use of referencing directory search rules.
                                                   END HISTORY COMMENTS */


/* format: ind3,ifthen,^ifthendo,^indnoniterdo,^indend,insnl,^inddcls,^elsestmt,indbegin,comcol68,ll80 */


/* cc
   is the command to run a c program through cpp, comp, alm and the
   linkage editor. It is dependant on the input arguments. It may
   also in the future run the alm output through the optimizer.
   Only programs named prefix.c are run through the compiler the
   rest are passed onto the linkage editor as input.

   all errors are reported via com_err_.

*/

c_compile:
cc:
c:
   procedure ();


/* external routines */

dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
dcl     alm_		 entry (pointer, pointer, fixed bin (35),
			 fixed bin (35));
dcl     com_err_		 entry () options (variable);
dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
dcl     cu_$arg_list_ptr	 entry (ptr);
dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21),
			 fixed bin (35), ptr);
dcl     cu_$cl		 entry ();
dcl     cu_$gen_call	 entry () options (variable);
dcl     delete_$path	 entry (char (*), char (*), bit (36) aligned,
			 char (*), fixed bin (35));
dcl     expand_pathname_	 entry (char (*), char (*), char (*),
			 fixed bin (35));
dcl     find_source_file_	 entry (char (*), char (*), char (*), ptr,
			 fixed bin (24), fixed bin (35));
dcl     get_pdir_		 entry () returns (char (168));
dcl     get_system_free_area_	 entry () returns (ptr);
dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin,
			 char (*), fixed bin (35));
dcl     hcs_$make_ptr	 entry (ptr, char(*), char(*), ptr, 
			 fixed bin(35));
dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*),
			 fixed bin (35));
dcl     tssi_$clean_up_segment entry (ptr);
dcl     tssi_$get_segment	 entry (char (*), char (*), ptr, ptr,
			 fixed bin (35));
dcl     tssi_$finish_segment	 entry (ptr, fixed bin (24), bit (36) aligned,
			 ptr, fixed bin (35));


dcl     ioa_		 entry () options (variable);


/* builtins */

dcl     (addr, after, before, index, length, null, reverse, rtrim,
        substr, unspec)
			 builtin;


/* conditions */

dcl     cleanup		 condition;

/* automatic */

dcl     arg_count		 fixed bin automatic;	       /* number of command line args */
dcl     arg_length		 fixed bin (21) automatic;	       /* length of current argument */
dcl     arglist_ptr		 pointer automatic;		       /* ptr to our arglist */
dcl     arg_list_arg_count	 fixed bin automatic;	       /* size of the arg lists to cpp and comp */
dcl     arg_ptr		 pointer automatic;		       /* ptr to our current argument */
dcl     call_arg_ptr	 pointer automatic;		       /* ptr to the arglsit for calls to cpp and comp */
dcl     current_file_name	 char (168) automatic;	       /* the current input file to this pass */
dcl     current_source_file	 char (168) automatic;	       /* the current file being compiled */
dcl     cpp_ptr		 pointer automatic;		       /* pointer to the cpp entry */
dcl     comp_ptr		 pointer automatic;		       /* pointer to the comp entry */
dcl     desc_ptr		 pointer automatic;		       /* pointer to the descriptor list for the call */
dcl     directory_name	 char (168) automatic;	       /* the directory portion of the filename */
dcl     error_code		 fixed bin (35) automatic;	       /* system error code */
dcl     error_occurred	 bit (1) automatic;		       /* specifies an error has occurred in one of the passes */
dcl     filename		 char (168) automatic;	       /* the current output filename for this pass */
dcl     (i, j)		 fixed bin automatic;	       /* loop counter */
dcl     le_ptr		 pointer automatic;		       /* ptr to the le command */
dcl     lib_dir		 char (168) automatic;	       /* directory name for the lib */
dcl     lib_dir_length	 fixed bin automatic;	       /* length of lib dir name */
dcl     lib_entry		 char (32) automatic;	       /* entry name for lib */
dcl     lib_full_path	 char (168) automatic;	       /* full path of lib */
dcl     lib_ptr		 pointer automatic;		       /* ptr to the runtime lib */
dcl     list		 bit (1) automatic;		       /* -ls specified */
dcl     long_sw		 bit (1) automatic;		       /* specifies if the -lg or -bf option were given */
dcl     main_dir		 char (168) automatic;	       /* directory name for main_ */
dcl     main_dir_length	 fixed bin automatic;	       /* length of main_ dir name */
dcl     main_entry		 char (32) automatic;	       /* entry name for main_ */
dcl     main_full_path	 char (168) automatic;	       /* full path of main_ */
dcl     main_ptr		 pointer automatic;		       /* a pointer to the main_ routine */
dcl     number_of_defines	 fixed bin automatic;	       /* number of deines to pass onto cpp */
dcl     number_of_files	 fixed bin automatic;	       /* the number of input files */
dcl     number_of_includes	 fixed bin automatic;	       /* the number of include dirs */
dcl     number_of_libraries	 fixed bin automatic;	       /* the number of libraries specified by the user */
dcl     number_of_undefines	 fixed bin automatic;	       /* the number of undefines to pass to cpp */
dcl     only_alm		 bit (1) automatic;		       /* -S specified. stop before alm */
dcl     only_compile	 bit (1) automatic;		       /* -c command line option stop after alm */
dcl     only_cpp		 bit (1) automatic;		       /* -E specified. run through cpp only */
dcl     only_le		 bit (1) automatic;		       /* specifies this file is only input to the le if .cob or not other suffixes */
dcl     optimize		 bit (1) automatic;		       /* -ot optimize not available */
dcl     output_file		 bit (1) automatic;		       /* -of specified output file name is next arg */
dcl     output_file_name	 char (168) automatic;	       /* the output_file_name if present */
dcl     profile		 bit (1) automatic;		       /* -p specified */
dcl     process_dir		 char (168) automatic;	       /* out process directory */
dcl     source_entry_name	 char (168) automatic;	       /* the entry name portio of the filename */
dcl     source_prefix	 char (168) automatic;	       /* the prefix of the source file name */
dcl     source_suffix	 char (168) automatic;	       /* the suffix of the source file name */
dcl     start_alm		 bit (1) automatic;		       /* start passes at alm if filename is .alm */
dcl     start_comp		 bit (1) automatic;		       /* start passes at comp if filename .cpp */
dcl     start_cpp		 bit (1) automatic;		       /* start passes at cpp if filename .c */
dcl     sys_area_ptr	 pointer automatic;		       /* pointer to the sys free area */
dcl     table		 bit (1) automatic;		       /* -tb specified */


/* constants */

dcl     ME		 char (2) init ("cc") static options (constant);
dcl     CPP_NAME		 char (3) init ("cpp") static options (constant);
dcl     COMP_NAME		 char (4) init ("ccom") static options (constant);

dcl     LIB_NAME		 char (16) init ("runtime.archive")
			 static options (constant);
dcl     DESC_BITS		 bit (12) unaligned init ("5260"b3) static
			 options (constant);
dcl     LE_NAME		 char (2) init ("le") static options (constant);
dcl     LIB		 char (3) init ("-lb") static options (constant);
dcl     LIST		 char (5) init ("-list") static
			 options (constant);
dcl     MAIN_		 char (5) init ("main_") static
			 options (constant);
dcl     NOVER		 char (6) init ("-nvers") static
			 options (constant);
dcl     OUTFILE		 char (3) init ("-of") static options (constant);


/* externals */

dcl     C_inter_level_value	 ext fixed bin (35);	       /* the variable C uses to pass values in between mains */


/* based */

dcl     argument		 char (arg_length) based (arg_ptr);
dcl     1 arglist		 like command_name_arglist based (call_arg_ptr);

dcl     1 descriptors	 unaligned based (desc_ptr),
	2 desc		 (arg_list_arg_count),
	  3 bits		 bit (12) unaligned,
	  3 size		 fixed bin (24) unsigned unaligned;

dcl     1 file_list_desc	 based,
	2 pathname	 (arg_count),
	  3 name		 char (168),
	  3 name_length	 fixed bin (21),
	  3 output_name	 char (168),
	  3 output_name_length
			 fixed bin (21);

dcl     sys_area		 area based (sys_area_ptr);

%page;

      call cu_$arg_count (arg_count, error_code);
      if (error_code ^= 0) | (arg_count ^> 0) then
         do;
         call com_err_ (error_code, ME,
	    "Syntax: cc [options] file1... fileN.");
         return;
      end;

      call cu_$arg_list_ptr (arglist_ptr);

      number_of_libraries, number_of_includes, number_of_defines,
	 number_of_undefines, number_of_files = 0;
      only_alm, only_compile, only_cpp, only_le, error_occurred = "0"b;
      optimize, output_file, long_sw, profile, table, list = "0"b;
      output_file_name = "a.out";

      sys_area_ptr = get_system_free_area_ ();

/* get pointers to all of the routines that we require to execute. */

      process_dir = get_pdir_ ();

/* set up a pointer to main_ */

      call hcs_$make_ptr (codeptr (c_compile), MAIN_, "", main_ptr, error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "Can not find main_.");
         goto ERROR;
      end;

/* get pathname for main_ */

      call hcs_$fs_get_path_name (main_ptr, main_dir, main_dir_length,
	 main_entry, error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "Finding pathname of main_.");
         goto ERROR;
      end;

      main_full_path = rtrim (main_dir, " >") || ">" || rtrim (main_entry);


/* set up a pointer to runtime library */

      call hcs_$make_ptr (codeptr(c_compile), LIB_NAME, "", lib_ptr, error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "While locating the Runtime Library.");
         call cu_$cl ();
         goto ERROR;
      end;

/* get pathname for library */

      call hcs_$fs_get_path_name (lib_ptr, lib_dir, lib_dir_length,
	 lib_entry, error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "Finding pathname of the Runtime Library.");
         goto ERROR;
      end;

      lib_full_path = rtrim (lib_dir, " >") || ">" || rtrim (lib_entry);


/* set up a pointer to cpp */

      call hcs_$make_ptr (codeptr (c_compile), CPP_NAME, "main_", cpp_ptr,
	 error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "Can not find cpp.");
         goto ERROR;
      end;


/* set up a pointer to comp */

      call hcs_$make_ptr (codeptr (c_compile), COMP_NAME, "main_", comp_ptr,
	 error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "Can not find ccom.");
         goto ERROR;
      end;

/* set up a pointer to le */

      call hcs_$make_ptr (codeptr(c_compile), LE_NAME, "le", le_ptr, error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "Can not find le.");
         goto ERROR;
      end;

%page;

/* we set up a begin block to allocate our file list for us as the
   maximum size is known from the number of args given to us.
*/

      begin;

dcl     1 file_list		 like file_list_desc automatic;


/* initialize the file list */

         do i = 1 to arg_count;
	  file_list.pathname (i).name = "";
	  file_list.pathname (i).name_length = 0;
	  file_list.pathname (i).output_name = "";
	  file_list.pathname (i).output_name_length = 0;
         end;


/* get our temp seg and set up a cleanup handler for it */

         cc_info_ptr = null ();

         on condition (cleanup)
	  begin;

	     call cleanup_objs (addr (file_list));

	     if cc_info_ptr ^= null () then
	        call release_temp_segment_ ("cc", cc_info_ptr, error_code);
	  end;


         call get_temp_segment_ ("cc", cc_info_ptr, error_code);
         if error_code ^= 0 then
	  do;
	  call com_err_ (error_code, ME,
	       "While obtaining the temporary segment for cc.");
	  goto ERROR;
         end;


/* parse the input arguments */

         call parse_args (addr (file_list), arglist_ptr);

         if number_of_files = 0 then
	  do;
	  call com_err_ (0, ME, "No input files specified.");
	  goto ERROR;
         end;


%page;

/* loop through all of the files generating the temporary files
   in the process dir unless otherwise specified
*/

         do i = 1 to number_of_files;

/* get the current file name */

	  current_file_name =
	       substr (file_list.pathname (i).name, 1,
	       file_list.pathname (i).name_length);
	  current_source_file = rtrim (current_file_name);
	  filename = rtrim (current_file_name);


	  call expand_pathname_ (substr (file_list.pathname (i).name, 1,
	       file_list.pathname (i).name_length),
	       directory_name, source_entry_name, error_code);
	  if error_code ^= 0 then
	     do;
	     call com_err_ (error_code, ME,
		"An error has occurred while locating ^a",
		current_file_name);
	     goto ERROR;
	  end;


/* get the prefix and suffix from the source file name entryname */

	  source_suffix =
	       rtrim (reverse (before (reverse (source_entry_name), ".")));
	  source_prefix =
	       rtrim (reverse (after (reverse (source_entry_name), ".")));


/* now check and see what passes the file has to go through by its 
   suffix name. ie. .c through all passes, .cpp through comp, .alm
   through alm and all the rest including .cob files go through the 
   le only.
*/

	  only_le, start_cpp, start_comp, start_alm = "0"b;

	  if source_suffix = "c" then
	     start_cpp, start_comp, start_alm = "1"b;
	  else if source_suffix = "cpp" then
	     start_alm, start_comp = "1"b;
	  else if source_suffix = "alm" then
	     start_alm = "1"b;

/* we have either a .cob file or some other suffix so it must be 
    input to the le 
*/
	  else
	     only_le = "1"b;


/* now call the various passes. C_inter_level_value is the only way
   we have of telling if an error has occured in compiler as it does an
   exit(0) if no errors and an exit(1|2) if an error occurs.
*/

	  if ^only_le then
	     do;

/*  set up for the call to cpp */

	     if start_cpp then
	        do;
	        if long_sw then
		 call ioa_ ("Preprocessing ^a.", source_entry_name);
	        call do_cpp ();
	        if C_inter_level_value ^= 0 then
		 do;
		 call com_err_ (0, ME,
		      "An error has occurred while Preprocessing ^a.",
		      current_source_file);
		 error_occurred = "1"b;
		 goto NEXT_FILE;
	        end;
	     end;

	     if only_cpp then
	        goto NEXT_FILE;


/* set up for call to comp input file name is the output filename from cpp */

	     if start_comp then
	        do;
	        if long_sw then
		 call ioa_ ("Compiling ^a.", source_entry_name);

	        call do_comp ();
	        if C_inter_level_value ^= 0 then
		 do;
		 call com_err_ (0, ME,
		      "An error has occurred while Compiling ^a.",
		      current_source_file);
		 error_occurred = "1"b;
		 goto NEXT_FILE;
	        end;
	     end;

	     if only_alm then
	        goto NEXT_FILE;


/* set for call to alm */

	     if start_alm then
	        do;
	        if long_sw then
		 call ioa_ ("Assembling ^a.", source_entry_name);
	        call do_alm ();
	     end;

	     if only_compile then
	        goto NEXT_FILE;

	  end;
						       /* we have the object name in filename so we store it in the filename list */

	  file_list.pathname (i).output_name = rtrim (filename);
	  file_list.pathname (i).output_name_length =
	       length (rtrim (filename));

NEXT_FILE:
         end;

/* we should be finished all of the files now so we can set up for the 
   linkage editor. 
*/

         if ^only_compile & ^only_alm & ^only_cpp & ^error_occurred then
	  do;
	  if long_sw then
	     call ioa_ ("Link Editing.");
	  call do_le (addr (file_list));
         end;

         call cleanup_objs (addr (file_list));

      end;


ERROR:
      if cc_info_ptr ^= null () then
         call release_temp_segment_ ("cc", cc_info_ptr, error_code);

      return;

%page;
/* cleanup_objs
   goes through the file name list and deletes any output file names
   in the process dir. As we would have created them in there we
   should be able to delete them.
*/

cleanup_objs:
   procedure (filelist_ptr);

/* parameters */

dcl     filelist_ptr	 pointer parameter;

/* automatic */

dcl     entry_name		 char (168) automatic;
dcl     dir_name		 char (168) automatic;
dcl     i			 fixed bin automatic;

/* based */

dcl     1 file_list		 like file_list_desc based (filelist_ptr);


      if number_of_files = 0 then
         return;

      do i = 1 to number_of_files;

         call expand_pathname_ (file_list.pathname (i).output_name,
	    dir_name, entry_name, error_code);

         if dir_name = process_dir then
	  call delete_$path (dir_name, entry_name, "010100"b, "cc",
	       error_code);
      end;

   end cleanup_objs;
%page;

/* do_le
   sets and calls the linkage editor. Because of the amount of work
   involved in doing what le the command does we will set up a command
   argument list and call the le command.
*/

do_le:
   procedure (filelist_ptr);

/* parameters */

dcl     filelist_ptr	 pointer parameter;

/* automatic */

dcl     (j, k, l)		 fixed bin automatic;
dcl     have_default_lib	 bit (1) automatic;
dcl     default_lib		 char (168) automatic;
dcl     cur_lib_path	 char (168) automatic;

/* based */

dcl     1 file_list		 like file_list_desc based (filelist_ptr);

/* check if the user specified the default libary path */

      have_default_lib = "0"b;
      call absolute_pathname_ (lib_full_path, default_lib, error_code);

      do i = 1 to number_of_libraries;

         call absolute_pathname_ (cc_info.libraries (i).library_pathname,
	    cur_lib_path, error_code);

         if error_code ^= 0 then
	  do;
	  call com_err_ (error_code, ME, "Can not find library ^a.",
	       cc_info.libraries (i).library_pathname);
	  goto ERROR;
         end;

         if rtrim (default_lib) = rtrim (cur_lib_path) then
	  have_default_lib = "1"b;
      end;



/* times 2 for the -lib for each library + 4 for main_ , -lib 
    default lib and the -novers control arg.
*/
      arg_list_arg_count = number_of_files + 4 + (number_of_libraries * 2);

      if have_default_lib then
         arg_list_arg_count = arg_list_arg_count - 2;	       /* for -lib and path */


      if output_file then
         arg_list_arg_count = arg_list_arg_count + 2;	       /* + 2 for -of and filename */

      if list then
         arg_list_arg_count = arg_list_arg_count + 1;


      call_arg_ptr, desc_ptr = null ();


      on cleanup
         begin;

	  if call_arg_ptr ^= null () then
	     free arglist in (sys_area);
	  if desc_ptr ^= null () then
	     free descriptors in (sys_area);
         end;


      allocate arglist in (sys_area) set (call_arg_ptr);
      allocate descriptors in (sys_area) set (desc_ptr);

/* set up the argument list */

      arglist.arg_count = arg_list_arg_count;
      arglist.desc_count = arg_list_arg_count;
      arglist.call_type = Interseg_call_type;
      arglist.has_command_name = "1"b;
      arglist.mbz = "0"b;
      arglist.pad1 = "0"b;
      arglist.pad2 = "0"b;
      arglist.name.command_name_ptr = addr (LE_NAME);
      arglist.name.command_name_length = length (LE_NAME);

      k, l = 0;

      arglist.arg_ptrs (1) = addr (main_full_path);
      arglist.desc_ptrs (1) = addr (descriptors.desc (1));
      descriptors.desc (1).bits = DESC_BITS;
      descriptors.desc (1).size = length (rtrim (main_full_path));

      j = 2;					       /* next free position */
      l = 0;
      do j = 2 to (number_of_files + 1);
         l = l + 1;
         arglist.arg_ptrs (j) = addr (file_list.pathname (l).output_name);
         arglist.desc_ptrs (j) = addr (descriptors.desc (j));
         descriptors.desc (j).bits = DESC_BITS;
         descriptors.desc (j).size = file_list.pathname (l).output_name_length;
      end;

      k = j;					       /* have to set k in case we don't have any libs */

      l = 0;
      j = number_of_files + 1;			       /* +1 for main_ */
      if number_of_libraries > 0 then
         do k = (j + 1) to ((number_of_libraries * 2) + j);
	  l = l + 1;

	  arglist.arg_ptrs (k) = addr (LIB);
	  arglist.desc_ptrs (k) = addr (descriptors.desc (k));
	  descriptors.desc (k).bits = DESC_BITS;
	  descriptors.desc (k).size = length (rtrim (LIB));

	  k = k + 1;
	  arglist.arg_ptrs (k) =
	       addr (cc_info.libraries (l).library_pathname);
	  arglist.desc_ptrs (k) = addr (descriptors.desc (k));
	  descriptors.desc (k).bits = DESC_BITS;
	  descriptors.desc (k).size =
	       cc_info.libraries (l).library_pathname_length;

         end;

      if output_file then
         do;

         arglist.arg_ptrs (k) = addr (OUTFILE);
         arglist.desc_ptrs (k) = addr (descriptors.desc (k));
         descriptors.desc (k).bits = DESC_BITS;
         descriptors.desc (k).size = length (OUTFILE);

         k = k + 1;
         arglist.arg_ptrs (k) = addr (output_file_name);
         arglist.desc_ptrs (k) = addr (descriptors.desc (k));
         descriptors.desc (k).bits = DESC_BITS;
         descriptors.desc (k).size = length (rtrim (output_file_name));

         k = k + 1;					       /* so the next arg will be in the right place */
      end;

      if list then
         do;

         arglist.arg_ptrs (k) = addr (LIST);
         arglist.desc_ptrs (k) = addr (descriptors.desc (k));
         descriptors.desc (k).bits = DESC_BITS;
         descriptors.desc (k).size = length (LIST);

         k = k + 1;					       /* so the next arg will be in the right place */

      end;

/* default lib */

      if ^have_default_lib then
         do;

         arglist.arg_ptrs (k) = addr (LIB);
         arglist.desc_ptrs (k) = addr (descriptors.desc (k));
         descriptors.desc (k).bits = DESC_BITS;
         descriptors.desc (k).size = length (LIB);

         k = k + 1;
         arglist.arg_ptrs (k) = addr (default_lib);
         arglist.desc_ptrs (k) = addr (descriptors.desc (k));
         descriptors.desc (k).bits = DESC_BITS;
         descriptors.desc (k).size = length (rtrim (default_lib));

         k = k + 1;					       /* so next arg will be in the right place */

      end;



/* -novers */

      arglist.arg_ptrs (k) = addr (NOVER);
      arglist.desc_ptrs (k) = addr (descriptors.desc (k));
      descriptors.desc (k).bits = DESC_BITS;
      descriptors.desc (k).size = length (NOVER);

/* do the call */

      call cu_$gen_call (le_ptr, call_arg_ptr);


   end do_le;
%page;
/* do_alm
   creates the info for the call to alm and performs the call.
   the output file from the previous pass is in filename as a full
   pathname.
*/

do_alm:
   procedure ();


/* automatic */

dcl     entry_name		 char (168) automatic;
dcl     object_aclinfo_ptr	 pointer automatic;
dcl     output_directory	 char (168) automatic;
dcl     output_entry	 char (168) automatic;
dcl     severity		 fixed bin (35) automatic;


/* structures */

dcl     01 ai		 like alm_info automatic;
dcl     01 alm_args,
	02 version	 char (8),
	02 argcount	 fixed bin,
	02 args		 (1),
	  03 argptr	 pointer,
	  03 len		 fixed bin (21);



/* filename = our intput file name */

      current_file_name = rtrim (filename);

      if only_compile & output_file then
         filename = rtrim (output_file_name);
      else
         filename = rtrim (source_prefix) || ".cob";

      if ^only_compile & number_of_files = 1 then
         filename = rtrim (process_dir) || ">" || rtrim (filename);

/* split the input and output filenames into a pathname and an entry
   name.
*/

      call expand_pathname_ (filename,
	 output_directory, output_entry, error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME,
	    "An error has occurred while locating ^a", filename);
         goto ERROR;
      end;

/* initialize the alm_info structure */

      ai.version = ALM_INFO_V1;
      unspec (ai.flags) = "0"b;
      ai.flags.brief = "1"b;
      ai.target = "";
      ai.generator = "C";
      ai.gen_number = C_gen_number;
      ai.gen_version = C_version_info;
      ai.gen_created = 0;
      ai.option_string = "";
      ai.source_path = "";
      ai.source_entryname = "";
      ai.source_ptr = null ();
      ai.source_bc = 0;
      ai.object_ptr = null ();
      ai.object_bc = 0;
      ai.list_fcb_ptr = null ();
      ai.list_component_ptr = null ();
      ai.list_bc = 0;
      ai.list_component = 0;

      on condition (cleanup)
         begin;
	  if ai.source_ptr ^= null () then
	     do;
	     if (index (current_file_name, rtrim (process_dir)) = 1) then
	        call terminate_file_ (ai.source_ptr, 0, TERM_FILE_DELETE, 0);
	     else
	        call terminate_file_ (ai.source_ptr, 0, TERM_FILE_TERM, 0);
	  end;
	  if object_aclinfo_ptr ^= null () then
	     call tssi_$clean_up_segment (object_aclinfo_ptr);

         end;


RETRY_SRC:

      call find_source_file_ (current_file_name, "alm",
	 entry_name, ai.source_ptr, ai.source_bc, error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "While initiating alm source.");
         call cu_$cl ();
         goto RETRY_SRC;
      end;

RETRY_OBJ:
      call tssi_$get_segment (output_directory, output_entry,
	 ai.object_ptr, object_aclinfo_ptr, error_code);
      if error_code ^= 0 then
         do;
         call com_err_ (error_code, ME, "While creating ALM object.");
         call cu_$cl ();
         goto RETRY_OBJ;
      end;

      alm_args.version = ALM_ARGS_V1;
      alm_args.argcount = 0;

      call alm_ (addr (ai), addr (alm_args), severity, error_code);
      if (error_code ^= 0) | (severity > 2) then
         do;
         call com_err_ (error_code, ME, "^/While assembling: ^a.",
	    current_source_file);
         error_occurred = "1"b;
      end;

/* want to terminate_file_ on both files  and set bit count on object */

      if (index (current_file_name, rtrim (process_dir)) = 1) then
         call terminate_file_ (ai.source_ptr, 0, TERM_FILE_DELETE, 0);
      else do;
         call terminate_file_ (ai.source_ptr, ai.source_bc,
	    TERM_FILE_TERM, error_code);
         if error_code ^= 0 then
	  call com_err_ (error_code, ME,
	       "An error occurred while terminating the alm file.");
      end;

      if object_aclinfo_ptr ^= null () then
         call tssi_$finish_segment (ai.object_ptr, ai.object_bc,
	    "110"b, object_aclinfo_ptr, error_code);
      if (error_code ^= 0) & ^error_occurred then
         do;
         call com_err_ (error_code, ME,
	    "An error occured while terminating ^a.", filename);
         goto ERROR;
      end;



   end do_alm;
%page;
/* do_comp
   performs the call to the second pass comp.
*/

do_comp:
   procedure ();

dcl     compiler_flags	 char (10) automatic;
dcl     dir_name		 char (168) automatic;
dcl     entry_name		 char (168) automatic;


      arg_list_arg_count = 2;				       /* input file and output file */

      if table | profile then
         do;
         arg_list_arg_count = 3;
         compiler_flags = "-X";

         if profile then
	  compiler_flags = rtrim (compiler_flags) || "p";

         if table then
	  compiler_flags = rtrim (compiler_flags) || "g";

      end;

/* filename = our intput file name */

      current_file_name = rtrim (filename);

      if only_alm & output_file then
         filename = rtrim (output_file_name);
      else
         filename = rtrim (source_prefix) || ".alm";

      if ^only_alm then
         filename = rtrim (process_dir) || ">" || 
	  rtrim (source_prefix) || ".alm";

      desc_ptr, call_arg_ptr = null ();

      on cleanup
         begin;

	  if call_arg_ptr ^= null () then
	     free arglist in (sys_area);
	  if desc_ptr ^= null () then
	     free descriptors in (sys_area);

/* delete our input and output file if they are in the process dir. */

	  if (index (filename, rtrim (process_dir)) = 1) then
	     do;
	     call expand_pathname_ (filename, dir_name, entry_name,
		error_code);
	     call delete_$path (dir_name, entry_name, "010100"b, "cc",
		error_code);
	  end;


	  if (index (current_file_name, rtrim (process_dir)) = 1) then
	     do;

	     call expand_pathname_ (current_file_name, dir_name,
		entry_name, error_code);
	     call delete_$path (dir_name, entry_name, "010100"b, "cc",
		error_code);
	  end;

         end;


      allocate arglist in (sys_area) set (call_arg_ptr);
      allocate descriptors in (sys_area) set (desc_ptr);

/* set up the argument list */

      arglist.arg_count = arg_list_arg_count;
      arglist.desc_count = arg_list_arg_count;
      arglist.call_type = Interseg_call_type;
      arglist.has_command_name = "1"b;
      arglist.mbz = "0"b;
      arglist.pad1 = "0"b;
      arglist.pad2 = "0"b;
      arglist.name.command_name_ptr = addr (COMP_NAME);
      arglist.name.command_name_length = length (COMP_NAME);

      j = 1;
      if table | profile then
         do;
         arglist.arg_ptrs (j) = addr (compiler_flags);
         arglist.desc_ptrs (j) = addr (descriptors.desc (j));
         descriptors.desc (j).bits = DESC_BITS;
         descriptors.desc (j).size = length (rtrim (compiler_flags));
         j = j + 1;
      end;

      arglist.arg_ptrs (j) = addr (current_file_name);
      arglist.desc_ptrs (j) = addr (descriptors.desc (j));
      descriptors.desc (j).bits = DESC_BITS;
      descriptors.desc (j).size = length (rtrim (current_file_name));

      j = j + 1;
      arglist.arg_ptrs (j) = addr (filename);
      arglist.desc_ptrs (j) = addr (descriptors.desc (j));
      descriptors.desc (j).bits = DESC_BITS;
      descriptors.desc (j).size = length (rtrim (filename));

      call cu_$gen_call (comp_ptr, call_arg_ptr);

      free arglist in (sys_area);
      free descriptors in (sys_area);


      if (index (current_file_name, rtrim (process_dir)) = 1) then
         do;

         call expand_pathname_ (current_file_name, dir_name,
	    entry_name, error_code);
         call delete_$path (dir_name, entry_name, "010100"b, "cc",
	    error_code);
      end;

   end do_comp;

%page;
/* do_cpp
   creates the argument list for cpp and performs the call.
*/

do_cpp:
   procedure ();

/* automatic */

dcl     (j, k, l)		 fixed bin automatic;
dcl     dir_name		 char (168) automatic;
dcl     entry_name		 char (168) automatic;
dcl     processor_flags	 char (10) automatic;


      arg_list_arg_count = number_of_defines +
	 number_of_undefines + number_of_includes + 2;

      if table then
         do;
         arg_list_arg_count = arg_list_arg_count + 1;
         processor_flags = "-P";
      end;


      call_arg_ptr = null ();
      desc_ptr = null ();

      on cleanup
         begin;

	  if call_arg_ptr ^= null () then
	     free arglist in (sys_area);
	  if desc_ptr ^= null () then
	     free descriptors in (sys_area);

/* delete our output file if it is in the process dir. */

	  if (index (filename, rtrim (process_dir)) = 1) then
	     do;
	     call expand_pathname_ (filename, dir_name, entry_name,
		error_code);
	     call delete_$path (dir_name, entry_name, "010100"b, "cc",
		error_code);
	  end;

         end;


      allocate arglist in (sys_area) set (call_arg_ptr);
      allocate descriptors in (sys_area) set (desc_ptr);



/* get output file name */

      if only_cpp & output_file then
         filename = rtrim (output_file_name);
      else
         filename = rtrim (source_prefix) || ".cpp";

      if ^only_cpp then
         filename = rtrim (process_dir) || ">" || rtrim (filename);

      arglist.arg_count = arg_list_arg_count;
      arglist.desc_count = arg_list_arg_count;
      arglist.call_type = Interseg_call_type;
      arglist.has_command_name = "1"b;
      arglist.mbz = "0"b;
      arglist.pad1 = "0"b;
      arglist.pad2 = "0"b;
      arglist.name.command_name_ptr = addr (CPP_NAME);
      arglist.name.command_name_length = length (CPP_NAME);

      j, k, l = 0;

      if number_of_defines > 0 then
         do j = 1 to number_of_defines;
	  arglist.arg_ptrs (j) = addr (cc_info.defines (j).define_name);
	  arglist.desc_ptrs (j) = addr (descriptors.desc (j));
	  descriptors.desc (j).bits = DESC_BITS;
	  descriptors.desc (j).size = cc_info.defines (j).define_name_length;
         end;

      l = 0;
      j = number_of_defines;
      if number_of_undefines > 0 then
         do k = (j + 1) to (number_of_undefines + j);
	  l = l + 1;
	  arglist.arg_ptrs (k) = addr (cc_info.undefines (l).undefine_name);
	  arglist.desc_ptrs (k) = addr (descriptors.desc (k));
	  descriptors.desc (k).bits = DESC_BITS;
	  descriptors.desc (k).size =
	       cc_info.undefines (l).undefine_name_length;
         end;

      l = 0;
      k = number_of_defines + number_of_undefines;
      if number_of_includes > 0 then
         do j = (k + 1) to (number_of_includes + k);
	  l = l + 1;
	  arglist.arg_ptrs (j) =
	       addr (cc_info.include_files (l).include_pathname);
	  arglist.desc_ptrs (j) = addr (descriptors.desc (j));
	  descriptors.desc (j).bits = DESC_BITS;
	  descriptors.desc (j).size =
	       cc_info.include_files (l).include_pathname_length;

         end;



/* input file */

      j = number_of_defines + number_of_undefines + number_of_includes + 1;

      arglist.arg_ptrs (j) = addr (current_file_name);
      arglist.desc_ptrs (j) = addr (descriptors.desc (j));
      descriptors.desc (j).bits = DESC_BITS;
      descriptors.desc (j).size = length (rtrim (current_file_name));

/* output_file */

      j = number_of_defines + number_of_undefines + number_of_includes + 2;

      if table then
         do;
         arglist.arg_ptrs (j) = addr (processor_flags);
         arglist.desc_ptrs (j) = addr (descriptors.desc (j));
         descriptors.desc (j).bits = DESC_BITS;
         descriptors.desc (j).size = length (rtrim (processor_flags));
         j = j + 1;
      end;


      arglist.arg_ptrs (j) = addr (filename);
      arglist.desc_ptrs (j) = addr (descriptors.desc (j));
      descriptors.desc (j).bits = DESC_BITS;
      descriptors.desc (j).size = length (rtrim (filename));

      call cu_$gen_call (cpp_ptr, call_arg_ptr);

      free arglist in (sys_area);
      free descriptors in (sys_area);

   end do_cpp;
%page;

/* parse the command line setting what options have been set by the user.
   Create a list of possible files to be compiled and/or linked.
*/

parse_args:
   procedure (filelist_ptr, arglist_ptr);

/* parameters */

dcl     filelist_ptr	 pointer parameter;
dcl     arglist_ptr		 pointer parameter;

/* automatic */

dcl     i			 fixed bin automatic;
dcl     coma_pos		 fixed bin automatic;
dcl     current_pos		 fixed bin automatic;
dcl     defname_len		 fixed bin automatic;
dcl     true		 bit (1) automatic;


/* based */

dcl     1 file_list		 like file_list_desc based (filelist_ptr);


/* step through the args */

      do i = 1 to arg_count;

         call cu_$arg_ptr_rel (i, arg_ptr, arg_length, error_code, arglist_ptr);
         if error_code ^= 0 then
	  do;
	  call com_err_ (error_code, ME);
	  goto ERROR;
         end;

/* see if we have an option specifier */

         if (index (argument, "-") = 1) then
	  do;

	  if (argument = "-table") | (argument = "-tb") then
	     table = "1"b;
	  else if (argument = "-list") | (argument = "-ls") then
	     list = "1"b;

	  else if (argument = "-stop_after") | (argument = "-spaf") then
	     do;

	     i = i + 1;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_length, error_code,
		arglist_ptr);

	     if (error_code ^= 0) | (arg_length ^> 0) then
	        do;
	        call com_err_ (error_code, ME, "Pass specifier is missing.");
	        goto ERROR;
	     end;

	     if (argument = "preprocessor") | (argument = "pp") then
	        only_cpp = "1"b;

	     else if (argument = "c") then
	        only_alm = "1"b;

	     else if (argument = "alm") then
	        only_compile = "1"b;

	     else
	        do;

	        call com_err_ (0, ME, "Invalid pass specifier ^a.", argument);
	        goto ERROR;
	     end;

	  end;

%page;

	  else if (argument = "-profile") | (argument = "-pf") then
	     profile = "1"b;

	  else if (argument = "-long") | (argument = "-lg") then
	     long_sw = "1"b;

	  else if (argument = "-brief") | (argument = "-bf") then
	     long_sw = "0"b;

	  else if (argument = "-optimize") | (argument = "-ot") then
	     optimize = "1"b;

	  else if (argument = "-output_file") | (argument = "-of") then
	     do;
	     output_file = "1"b;
	     i = i + 1;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_length, error_code,
		arglist_ptr);

	     if (error_code ^= 0) | (arg_length ^> 0) then
	        do;
	        call com_err_ (error_code, ME,
		   "Output file name missing with the -of option");
	        goto ERROR;
	     end;

	     output_file_name = rtrim (argument);

	  end;

%page;

	  else if (argument = "-library") | (argument = "-lb") then
	     do;

	     true = "1"b;
	     i = i + 1;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_length, error_code,
		arglist_ptr);

	     if (error_code ^= 0) | (arg_length ^> 0) |
		(index (argument, "-") = 1) then
	        do;
	        call com_err_ (error_code, ME,
		   "Library pathname missing with the -library option");
	        goto ERROR;
	     end;

	     do while (true);

	        if number_of_libraries = MAX_LIB_INCL then
		 do;
		 call com_err_ (0, ME, "Too many library paths specified.");
		 goto ERROR;

	        end;


	        number_of_libraries = number_of_libraries + 1;

	        cc_info.libraries (number_of_libraries)
		   .library_pathname_length = arg_length;
	        cc_info.libraries (number_of_libraries).library_pathname =
		   argument;
	        i = i + 1;
	        if (i > arg_count) then
		 true = "0"b;
	        else
		 do;
		 call cu_$arg_ptr_rel (i, arg_ptr, arg_length, error_code,
		      arglist_ptr);

		 if (error_code ^= 0) | (arg_length ^> 0) then
		    do;
		    call com_err_ (error_code, ME,
		         "Include directory pathname missing with the -include option"
		         );
		    goto ERROR;
		 end;

		 if (index (argument, "-") = 1) then
		    do;
		    true = "0"b;
		    i = i - 1;
		 end;
	        end;

	     end;
	  end;

%page;


	  else if (argument = "-include") | (argument = "-incl") then
	     do;
	     true = "1"b;

	     i = i + 1;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_length, error_code,
		arglist_ptr);

	     if (error_code ^= 0) | (arg_length ^> 0) |
		(index (argument, "-") = 1) then
	        do;
	        call com_err_ (error_code, ME,
		   "Include directory pathname missing with the -include option"
		   );
	        goto ERROR;
	     end;

	     do while (true);


	        if number_of_includes = MAX_LIB_INCL then
		 do;
		 call com_err_ (0, ME,
		      "Too many include directory paths specified.");
		 goto ERROR;
	        end;

	        number_of_includes = number_of_includes + 1;

	        cc_info.include_files (number_of_includes)
		   .include_pathname_length = arg_length + 2;
	        cc_info.include_files (number_of_includes).include_pathname =
		   "-I" || argument;

	        i = i + 1;
	        if (i > arg_count) then
		 true = "0"b;
	        else
		 do;
		 call cu_$arg_ptr_rel (i, arg_ptr, arg_length, error_code,
		      arglist_ptr);

		 if (error_code ^= 0) | (arg_length ^> 0) then
		    do;
		    call com_err_ (error_code, ME,
		         "Include directory pathname missing with the -include option"
		         );
		    goto ERROR;
		 end;

		 if (index (argument, "-") = 1) then
		    do;
		    true = "0"b;
		    i = i - 1;
		 end;
	        end;


	     end;
	  end;

%page;

	  else if (argument = "-definition") | (argument = "-def") then
	     do;

/* get next arg which specifes what is to be defined and undefined 
*/

	     i = i + 1;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_length,
		error_code, arglist_ptr);

	     if (error_code ^= 0) | (arg_length ^> 0) then
	        do;
	        call com_err_ (error_code, ME,
		   "Definition string missing with the -definition option");
	        goto ERROR;
	     end;

/* check for spaces in the next arg ie. a user typed -def "v, y, etc" */

	     if index (argument, " ") ^= 0 then
	        do;
	        call com_err_ (0, ME, "An argument to -def has spaces. ^a",
		   argument);
	        goto ERROR;
	     end;


/* parse the arg for coma seperators */

	     current_pos = 1;
	     do while (current_pos ^> arg_length);

	        coma_pos = index (substr (argument, current_pos), ",");
	        if coma_pos = 0 then
		 defname_len = arg_length - current_pos + 1;
	        else
		 defname_len = coma_pos - 1;


	        if index (substr (argument, current_pos, defname_len), "^")
		   = 1 then
		 do;				       /* we have a -U option */

		 if number_of_undefines = MAX_LIB_INCL then
		    do;
		    call com_err_ (0, ME,
		         "Too many undefine names specified.");
		    goto ERROR;
		 end;


		 current_pos = current_pos + 1;	       /* skip the ^ */
		 defname_len = defname_len - 1;
		 number_of_undefines = number_of_undefines + 1;

		 cc_info.undefines (number_of_undefines)
		      .undefine_name_length = defname_len + 2;
		 cc_info.undefines (number_of_undefines).undefine_name =
		      "-U" || substr (argument, current_pos, defname_len);

	        end;


	        else
		 do;				       /* we have a -D option */

		 if number_of_defines = MAX_LIB_INCL then
		    do;
		    call com_err_ (0, ME,
		         "Too many define names specified.");
		    goto ERROR;
		 end;


		 number_of_defines = number_of_defines + 1;
		 cc_info.defines (number_of_defines).define_name_length =
		      defname_len + 2;
		 cc_info.defines (number_of_defines).define_name = "-D" ||
		      substr (argument, current_pos, defname_len);

	        end;

	        current_pos = current_pos + defname_len + 1;

	     end;
	  end;

	  else
	     do;
	     call com_err_ (0, ME, "Invalid option specified to cc. ^a",
		argument);
	     goto ERROR;
	  end;

         end;

/* must be a file name */

         else
	  do;
	  number_of_files = number_of_files + 1;
	  file_list.pathname (number_of_files).name = argument;
	  file_list.pathname (number_of_files).name_length = arg_length;
         end;
      end;

   end parse_args;

%page;
/* Include Files */
%include arg_list;
%page;

%include alm_info;
%page;

%include terminate_file;
%page;

%include cc_info;


   end c_compile;




		    PNOTICE_c_compiler.alm          01/04/89  1024.3r w 01/04/89  1020.6        2880



	dec	1			"version 1 structure
	dec	2			"no. of pnotices
	dec	3			"no. of STIs
	dec	82			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1989"
          acc       "Copyright, (C) AT&T, 1989"

	aci	"C1CCCM0E0000"
	aci	"C2CCCM0E0000"
	aci	"C3CCCM0E0000"
	end
