1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Bull Inc., 1987                *
  6         *                                                         *
  7         * Copyright, (C) Honeywell Information Systems Inc., 1986 *
  8         *                                                         *
  9         *********************************************************** */
 10 
 11 
 12 /****^  HISTORY COMMENTS:
 13   1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
 14      audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
 15      Rewritten to use the new alm_ subroutine.
 16   2) change(86-11-14,JRGray), approve(86-11-14,MCR7568),
 17      audit(86-11-21,RWaters), install(86-11-26,MR12.0-1228):
 18      Also MCR7572. Modified to update the version field to 7.3 .
 19   3) change(87-04-22,JRGray), approve(87-07-03,MCR7689),
 20      audit(87-07-09,RWaters), install(87-11-02,MR12.2-1001):
 21      Modified for fix for alm 19: change version field to 7.4 .
 22   4) change(88-03-21,JRGray), approve(88-08-05,MCR7952),
 23      audit(88-09-30,WAAnderson), install(88-10-17,MR12.2-1169):
 24      Modified for Symbol Table support, updated version.
 25   5) change(89-04-17,JRGray), approve(89-04-17,MCR8078), audit(89-04-18,Huen),
 26      install(89-06-09,MR12.3-1055):
 27      Modified to allow for archive component pathnames.
 28                                                    END HISTORY COMMENTS */
 29 
 30 
 31 alm:     proc;
 32 /* Completely rewritten August 4 1985 by R. Gray to fix various bugs,
 33    and call the new alm_ subroutine.
 34 */
 35 
 36 dcl       usage_string char(31) int static options(constant) init("Usage: alm path {-control_args}");
 37 
 38 dcl       alm_ entry(ptr, ptr, fixed bin, fixed bin(35));
 39 dcl       com_err_ entry options(variable);
 40 dcl       cu_$arg_count entry(fixed bin, fixed bin(35));
 41 dcl       cu_$arg_ptr entry(fixed bin, ptr, fixed bin(21), fixed bin(35));
 42 dcl       expand_pathname_$component_add_suffix entry(char(*), char(*), char(*), char(*), char(*), fixed bin(35));
 43 dcl       find_source_file_ entry (char(*), char(*), char(*), ptr, fixed bin(24), fixed bin(35));
 44 dcl       get_wdir_ entry returns(char(168));
 45 dcl       ioa_ entry options(variable);
 46 dcl       terminate_file_ entry(ptr, fixed bin(24), bit(*), fixed bin(35));
 47 dcl       tssi_$clean_up_file entry(ptr, ptr);
 48 dcl       tssi_$clean_up_segment entry(ptr);
 49 dcl       tssi_$get_file entry(char(*), char(*), ptr, ptr, ptr, fixed bin(35));
 50 dcl       tssi_$get_segment entry(char(*), char(*), ptr, ptr, fixed bin(35));
 51 dcl       tssi_$finish_segment entry(ptr, fixed bin(24), bit(36) aligned, ptr, fixed bin(35));
 52 dcl       tssi_$finish_file entry(ptr, fixed bin, fixed bin(24), bit(36) aligned, ptr, fixed bin(35));
 53 
 54 dcl       (addr, after, before, char, hbound, ltrim, null, rtrim, substr) builtin;
 55 
 56 dcl       argument_ptr ptr;
 57 dcl       argument_len fixed bin(21);
 58 dcl       argument_count fixed bin;
 59 dcl       argument char(argument_len) based(argument_ptr);
 60 dcl       cleanup condition;
 61 
 62 dcl       error_table_$badopt external static fixed bin(35);
 63 dcl       error_table_$noarg external static fixed bin(35);
 64 dcl       error_table_$too_many_args external static fixed bin(35);
 65 
 66 dcl       alm_severity_ external static fixed bin;
 67 
 68 dcl       (dirname, working_dir) char(168);
 69 dcl       ec fixed bin(35);
 70 dcl       (entryname, compname) char(33);         /* length is 33 instead of 32 to insure trailing blank */
 71 dcl       (i, j) fixed bin;
 72 dcl       (object_aclinfo_ptr, list_aclinfo_ptr) ptr;
 73 dcl       objectname char(32);
 74 
 75 dcl       01 alm_arguments,   /* like alm_args */
 76             02 version char(8),
 77             02 arg_count fixed bin,
 78             02 arg(400),
 79               03 arg_ptr ptr,
 80               03 len fixed bin(21);
 81 
 82 dcl       01 global_info like alm_info;
 83 ^L
 84 %include alm_info;
 85 ^L
 86           /* initialization of alm_info structure */
 87           global_info.version = ALM_INFO_V1;
 88           global_info.symbols = "1"b;   /* default include symbols in list */
 89           global_info.brief = "0"b;
 90           global_info.list = "0"b;
 91           global_info.table = "0"b;
 92           global_info.brief_table = "0"b;
 93           global_info.target = "";
 94 
 95           global_info.generator = "alm";
 96           global_info.gen_number = 8;
 97           global_info.gen_version = "ALM Version 8.14 March 1989";
 98           global_info.gen_created = 0; /* alm_ will calculate this field */
 99 
100           global_info.option_string = "";
101           global_info.source_path = "";
102           global_info.source_entryname = "";
103           global_info.source_ptr = null();
104           global_info.source_bc = 0;
105           global_info.object_ptr = null();
106           global_info.object_bc = 0;
107           global_info.list_fcb_ptr = null();
108           global_info.list_component_ptr = null();
109           global_info.list_bc = 0;
110           global_info.list_component = 0;
111 
112           alm_arguments.version = ALM_ARGS_V1;
113           alm_arguments.arg_count = 0;
114 
115           alm_severity_ = 5;
116           object_aclinfo_ptr = null();
117           list_aclinfo_ptr = null();
118           call cu_$arg_count(argument_count, ec);
119           if ec ^= 0 then call error(ec, "");
120 
121 
122           do i = 1 to argument_count;
123                call cu_$arg_ptr(i, argument_ptr, argument_len, ec);
124                if ec ^= 0 then call error(ec, "Argument #" || ltrim(char(i)));
125                if substr(argument, 1, 1) ^= "-"
126                then if global_info.source_path = "" then global_info.source_path = argument;
127                else call error(0, "Only one pathname can be specified");
128                else if argument = "-list" | argument = "-ls" then global_info.list = "1"b;
129                else if argument = "-no_list" | argument = "-nls" then global_info.list = "0"b;
130                else if argument = "-symbols" | argument = "-sb" then global_info.symbols = "1"b;
131                else if argument = "-no_symbols" | argument = "-nsb" then global_info.symbols = "0"b;
132                else if argument = "-brief" | argument = "-bf" then global_info.brief = "1"b;
133                else if argument = "-no_brief" | argument = "-nbf" then global_info.brief = "0"b;
134                else if argument = "-table" | argument = "-tb" then global_info.table = "1"b;
135                else if argument = "-no_table" | argument = "-ntb" then global_info.table = "0"b;
136                else if argument = "-brief_table" | argument = "-bftb" then global_info.brief_table = "1"b;
137                else if argument = "-no_brief_table" | argument = "-nbftb" then global_info.brief_table = "0"b;
138                else if argument = "-arguments" | argument = "-ag" then do;
139                     alm_arguments.arg_count = argument_count - i;
140                     if alm_arguments.arg_count > hbound(alm_arguments.arg, 1) then call error(error_table_$too_many_args, char(alm_arguments.arg_count));
141                     do j = 1 to alm_arguments.arg_count;
142                          call cu_$arg_ptr(i + j, alm_arguments.arg_ptr(j), alm_arguments.len(j), ec);
143                          if ec ^= 0 then call error(ec, "Argument #" || ltrim(char(i + j)));
144                     end;
145                     i = argument_count;
146                end;
147                else if argument = "-target" | argument = "-tgt" then do;
148                     i = i + 1;
149                     call cu_$arg_ptr(i, argument_ptr, argument_len, ec);
150                     if ec ^= 0 then call error(ec, "Target value.");
151                     global_info.target = argument;
152                end;
153                else call error(error_table_$badopt, argument);
154           end;
155 
156           if global_info.source_path = "" then call error(error_table_$noarg, usage_string);
157           /* get absolute pathname. Can't use absolute_pathname_ cause it hates archives */
158           call expand_pathname_$component_add_suffix(global_info.source_path, "alm", dirname, entryname, compname, ec);
159           if ec ^= 0 then call error(ec, global_info.source_path);
160           if compname = "" then global_info.source_path = rtrim(dirname, "> ") || ">" || rtrim(entryname);
161           else global_info.source_path = rtrim(dirname, "> ") || ">" || before(entryname, ".archive ") || "::" || rtrim(compname);
162 
163           if global_info.target = "" then global_info.option_string = ""; else global_info.option_string = "-target " || global_info.target || " ";
164           if global_info.list then global_info.option_string = global_info.option_string || "list ";
165           if global_info.symbols then global_info.option_string = global_info.option_string || "symbols ";
166           if global_info.brief then global_info.option_string = global_info.option_string || "brief ";
167           if global_info.table then global_info.option_string = global_info.option_string || "table ";
168           if global_info.brief_table then global_info.option_string = global_info.option_string || "brief_table ";
169           if alm_arguments.arg_count > 0 then do;
170                     global_info.option_string = global_info.option_string || "-arguments ";
171                     do i = 1 to alm_arguments.arg_count;
172                               argument_ptr = alm_arguments.arg_ptr(i);
173                               argument_len = alm_arguments.len(i);
174                               global_info.option_string = global_info.option_string || argument || " ";
175                       end;
176             end;
177 
178 
179           call find_source_file_(global_info.source_path, "alm", global_info.source_entryname,
180             global_info.source_ptr, global_info.source_bc, ec);
181           if ec^=0 then call error(ec, global_info.source_path);
182 
183 on        cleanup call clean_up;
184 
185           working_dir = get_wdir_();
186           objectname = before(global_info.source_entryname || " ", ".alm ");
187           objectname = before(objectname, ".ex ");
188           call tssi_$get_segment(working_dir, objectname, global_info.object_ptr,  object_aclinfo_ptr, ec);
189           if ec^=0 then call error(ec, "While accessing object segment.");
190 
191           if global_info.list then do;
192                     call tssi_$get_file(working_dir, rtrim(objectname) || ".list",
193                       global_info.list_component_ptr, list_aclinfo_ptr, global_info.list_fcb_ptr, ec);
194                     if ec^=0 then call error(ec, "While accessing listing file.");
195             end;
196 
197           if ^global_info.brief then call ioa_("ALM "  ||
198             before(after(global_info.gen_version, "Version "), " "));
199 
200           call alm_(addr(global_info), addr(alm_arguments), alm_severity_, ec);
201           if ec ^= 0 then call com_err_(ec, "alm", global_info.source_path);
202 
203           if global_info.list_fcb_ptr ^= null() then do;
204                     call tssi_$finish_file(global_info.list_fcb_ptr, global_info.list_component,
205                       global_info.list_bc, "101"b, list_aclinfo_ptr, ec);
206                     if ec^=0 then call error(ec, "While finishing with listing file.");
207             end;
208 
209           call tssi_$finish_segment(global_info.object_ptr, global_info.object_bc,
210             "110"b, object_aclinfo_ptr, ec);
211           if ec^=0 then call error(ec, "While finishing with object segment.");
212 
213           call terminate_file_(global_info.source_ptr, global_info.source_bc, "001"b, ec);
214           if ec^=0 then call error(ec, "While terminating source segment.");
215 abort:    return;
216 
217 error:     proc(code, string);
218 dcl       code fixed bin(35);
219 dcl       string char(*);
220 
221           call com_err_(code, "alm", string);
222           call clean_up;
223           goto abort;
224 end error;
225 
226 clean_up: proc;
227           if list_aclinfo_ptr ^= null() then call tssi_$clean_up_file(global_info.list_fcb_ptr, list_aclinfo_ptr);
228           if object_aclinfo_ptr ^= null() then call tssi_$clean_up_segment(object_aclinfo_ptr);
229           if global_info.source_ptr ^= null() then call terminate_file_(global_info.source_ptr, 0, "001"b, 0);
230 end clean_up;
231 
232 end alm;