1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1986 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 /****^  HISTORY COMMENTS:
 10   1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
 11      audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
 12      Written to be a general subroutine level interface to ALM.
 13   2) change(86-11-24,JRGray), approve(86-11-24,MCR7507),
 14      audit(86-11-25,RWaters), install(86-11-26,MR12.0-1228):
 15      Changed (PBF) to properly return error_codes for various error conditions.
 16   3) change(2016-01-05,Swenson), approve(2016-01-05,MCR10002):
 17      Fixed ALM buffer overrun error (ticket #89) that occurs on long source
 18      pathnames.
 19                                                    END HISTORY COMMENTS */
 20 
 21 alm_:     proc(ALM_INFO_PTR, ALM_ARGS_PTR, severity, code);
 22 
 23 /*        This procedure was written to provide a generalized subroutine
 24           interface to ALM. This will allow various subsystems and compiler
 25           to utilize ALM.
 26 */
 27 
 28 /*        P A R A M E T E R S */
 29 dcl       (ALM_INFO_PTR, ALM_ARGS_PTR) ptr parameter;
 30 dcl       severity fixed bin parameter;
 31 dcl       code fixed bin(35) parameter;
 32 
 33 /*        S T A T I C   S E C T I O N   */
 34 dcl       recursive bit(1) static init("0"b);
 35 
 36 /*        A U T O M A T I C   S E C T I O N       */
 37 dcl       argument char(argument_len) based(argument_ptr);
 38 dcl       argument_len fixed bin(21);
 39 dcl       argument_ptr ptr;
 40 dcl       bit_count fixed bin(24);
 41 dcl       caller_ptr ptr;
 42 dcl       canonical_str char(24);
 43 dcl       date char(24) aligned;
 44 dcl       decor fixed bin(35);
 45 dcl       default_str char(24);
 46 dcl       first_time_thru bit(1);
 47 dcl       (i, n) fixed bin;
 48 dcl       no_target_given bit(1) init("0"b);
 49 dcl       target_value fixed bin;
 50 dcl       temp_ptrs(2) ptr init((2) null);
 51 dcl       trimmed_entryname char(32);
 52 ^L
 53 dcl       cleanup condition;
 54 dcl       null builtin;
 55 
 56 dcl       alm_cross_reference_ entry;
 57 dcl       alm_include_file_$first_file entry(char(*));
 58 dcl       alm_merge_$alm_merge_ entry;
 59 dcl       clock_ entry returns(fixed bin(71));
 60 dcl       com_err_ entry options(variable);
 61 dcl       cu_$caller_ptr entry returns(ptr);
 62 dcl       date_time_ entry(fixed bin(71), char(*) aligned);
 63 dcl       get_group_id_ entry returns(char(32) aligned);
 64 dcl       get_temp_segments_ entry(char(*), (*) ptr, fixed bin(35));
 65 dcl       glpl_$genlas entry;
 66 dcl       hcs_$get_max_length_seg entry(ptr, fixed bin(19), fixed bin(35));
 67 dcl       hcs_$status_mins entry(ptr, fixed bin(2), fixed bin(24), fixed bin(35));
 68 dcl       lstman_$blkasn entry(fixed bin(17), fixed bin(17), fixed bin(17), fixed bin(17)) returns(fixed bin(17));
 69 dcl       make_alm_object_map_ entry(fixed bin(26));
 70 dcl       make_object_map_ entry(ptr, fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(35));
 71 dcl       mexp_$cleanup entry;
 72 dcl       mexp_$init entry(fixed bin(35));
 73 dcl       object_info_$brief entry(ptr, fixed bin(24), ptr, fixed bin(35));
 74 dcl       pakbit_$pakbit_ entry;
 75 dcl       pass1_$pass1_ entry( fixed bin(35), fixed bin(17), bit(1), bit(1));
 76 dcl       pass2_$pass2_ entry( fixed bin(35), fixed bin(17), bit(1), bit(1));
 77 dcl       postp1_$postp1_ entry;
 78 dcl       postp2_$postp2_ entry;
 79 dcl       prlst_$prlst_ entry(char(*));
 80 dcl       prnter_$general_abort entry(char(*));
 81 dcl       release_temp_segments_ entry(char(*), (*) ptr, fixed bin(35));
 82 dcl       system_type_ entry(char(*), char(*), fixed bin(17), fixed bin(35));
 83 
 84 dcl       eb_data_$abort_assembly external static label;
 85 dcl       eb_data_$alm_arg_ptr ptr ext;
 86 dcl       eb_data_$alm_arg_count fixed bin ext;
 87 dcl       eb_data_$curr_char_no fixed bin(17) external;
 88 dcl       eb_data_$lavptr ptr ext;      /* ptr to ALM's scratch segment of list structures */
 89 dcl       eb_data_$list_component external fixed bin;
 90 dcl       eb_data_$listing_max_length fixed bin(19) ext;
 91 dcl       eb_data_$mexp_argno fixed bin ext;
 92 dcl       1 eb_data_$oulst external, 2 oulst char(680) aligned;
 93 dcl       eb_data_$per_process_static_sw fixed bin ext;
 94 dcl       eb_data_$varcom_size external fixed bin(17);
 95 dcl       eb_data_$who_am_I char(12) external;
 96 dcl       error_table_$null_info_ptr fixed bin(35) external;
 97 dcl       error_table_$request_pending fixed bin(35) external;
 98 dcl       error_table_$translation_aborted fixed bin(35) external;
 99 dcl       error_table_$translation_failed fixed bin(35) external;
100 dcl       error_table_$unimplemented_version fixed bin(35) external;
101 dcl       error_table_$zero_length_seg fixed bin(35) external;
102 dcl       new_sthedr_$generator external static char(8);
103 dcl       new_sthedr_$gen_number external static fixed bin;
104 
105 dcl       01 OBJECT_INFO like object_info;
106 ^L
107 %include alm_info;
108 %include alm_data;
109 %include alm_options;
110 %include concom;
111 %include erflgs;
112 %include lstcom;
113 %include object_info;
114 %include objnfo;
115 %include segnfo;
116 %include std_symbol_header;
117 %include sthedr;
118 %include system_types;
119 %include varcom;
120 ^L
121           severity = 5;
122           alm_info_ptr = ALM_INFO_PTR;
123           alm_args_ptr = ALM_ARGS_PTR;
124           if alm_info_ptr = null | alm_args_ptr = null then do;
125                     code = error_table_$null_info_ptr;
126                     return;
127             end;
128           if alm_info.version ^= ALM_INFO_V1 | alm_args.version ^= ALM_ARGS_V1 then do;
129                     code = error_table_$unimplemented_version;
130                     return;
131             end;
132           if recursive then do;
133                     code = error_table_$request_pending;
134                     return;
135             end;
136           if alm_info.source_ptr = null | alm_info.object_ptr = null then do;
137                     code = error_table_$null_info_ptr;
138                     return;
139             end;
140           if alm_info.source_bc = 0 then do;
141                     code = error_table_$zero_length_seg;
142                     return;
143             end;
144 
145           new_sthedr_$generator = alm_info.generator;
146           new_sthedr_$gen_number = alm_info.gen_number;
147           new_sthedr_$alm_version_name = alm_info.gen_version;
148           if alm_info.gen_created = 0 then do;
149                     caller_ptr = ptr(cu_$caller_ptr(), 0);
150                     call hcs_$status_mins(caller_ptr, (0), bit_count, code); /* get bit count for next call */
151                     if code ^= 0 then sthedr_$alm_creation_date = clock();
152                     else do;
153                                 OBJECT_INFO.version_number = object_info_version_2;
154                                 call object_info_$brief(caller_ptr, bit_count, addr(OBJECT_INFO), code); /* get creation date */
155                                 if code ^= 0 then sthedr_$alm_creation_date = clock();
156                                 else sthedr_$alm_creation_date = OBJECT_INFO.symbp -> std_symbol_header.object_created;
157                       end;
158             end;
159           else sthedr_$alm_creation_date = alm_info.gen_created;
160           new_sthedr_$alm_creation_date = sthedr_$alm_creation_date;
161 
162 on        cleanup call cleanup_handler;
163           recursive = "1"b;
164 
165           if alm_info.brief then tquietsw = 1;
166           else tquietsw = 0;
167 
168           if alm_info.list then do;
169                     tnolst = 0;
170                     call hcs_$get_max_length_seg(alm_info.list_component_ptr, eb_data_$listing_max_length, code);
171                     if code ^=0 then call complain("Unable to get max length of listing segment.");
172             end;
173           else tnolst = 1;
174 
175           if alm_info.symbols then tnoxref = tnolst;        /* only set when there is to be a list */
176           else tnoxref = 1;
177 
178           if alm_info.target = "" then target_value = L68_SYSTEM;
179           /* target = SYSTEM_TYPE_NAME(L68_SYSTEM); This did something once... */
180           else do;
181                     call system_type_((alm_info.target), canonical_str, target_value, code);
182                     if code ^= 0 then call complain(alm_info.target);
183             end;
184 
185 
186           tcheckcompatibility = 0;
187           tnewmachine, tnewcall, tnewobject = 1;
188 
189           trimmed_entryname = before(alm_info.source_entryname || " ", ".alm ");
190           trimmed_entryname = before(trimmed_entryname, ".ex ");
191 
192 ^L
193           call get_temp_segments_("alm_", temp_ptrs, code);
194           if code^=0 then call complain("Unable to get temp segments.");
195           eb_data_$lavptr = temp_ptrs(1);
196           eb_data_$segnfo.scrtch = temp_ptrs(2);
197           eb_data_$abort_assembly = abort;
198 
199           eb_data_$segnfo.text = alm_info.object_ptr;
200           eb_data_$segnfo.source = alm_info.source_ptr;
201           eb_data_$segnfo.list = alm_info.list_component_ptr;
202           eb_data_$segnfo.list_fcb = alm_info.list_fcb_ptr;
203           eb_data_$segnfo.srclen = divide(alm_info.source_bc, 9, 21, 0);
204           eb_data_$segnfo.lstlen = 0;
205           eb_data_$list_component = 0;
206           eb_data_$alm_arg_count = alm_args.arg_count;
207           eb_data_$alm_arg_ptr = addr(alm_args.arg);
208           eb_data_$mexp_argno = 0;
209           severity = 4;                 /* in case of aborts */
210 ^K
211 /* - - - - - - - - - Begin processing the assembly - - - - - - - - */
212           do i = 1 to eb_data_$varcom_size;       /* clear all of varcom */
213                     brk(i) = 0;
214             end;
215           brk(1), nbrk(1) = ibsp;       /* set the break characters */
216           stkc = 40;          /* set up the stack counter */
217           nboxes = 211;       /* set up the number of boxes */        /*THIS COULD BE DONE STATICALLY INSTAIN eb_data_ */
218           ndpcls = addr(pclst);         /* set up the ends of the lists */
219           ndltls = addr(litlst);        /* "            "             " */
220           ndlkls = addr(lnklst);        /* "            "             " */
221           ndtvls = addr(tvlst);         /* "            "             " */
222           do i = 1 to 36;               /* clear the error flags */
223                     flgvec(i) = 0;
224             end;
225           tfatal = 0;                   /* most severe error */
226           eb_data_$per_process_static_sw = 0;
227 
228           call glpl_$genlas;                      /* initialize free storage */
229 
230           sthedr_$seg_name = trimmed_entryname;
231           new_sthedr_$comment = alm_info.option_string;
232           new_sthedr_$user_id = get_group_id_();
233           sthedr_$time_of_translation, new_sthedr_$time_of_translation = clock_();
234 
235           call date_time_(sthedr_$time_of_translation, date);
236           call prlst_$prlst_("ASSEMBLY LISTING OF SEGMENT " || alm_info.source_path);
237           call prlst_$prlst_("ASSEMBLED ON:       " || date);
238           call prlst_$prlst_("OPTIONS USED:       " || alm_info.option_string);
239           call prlst_$prlst_("ASSEMBLED BY:       " || new_sthedr_$alm_version_name);
240           call date_time_(sthedr_$alm_creation_date, date);
241           call prlst_$prlst_("ASSEMBLER CREATED:  " || date);
242           call prlst_$prlst_("");                 /* add a blank line */
243 
244           txtlen, itxpc, ilkpc, istpc, idfpc, itxcnt, ilkcnt, istcnt, idfcnt = 0;
245           eb_data_$curr_char_no = 0;
246           myblk = lstman_$blkasn(1, 0, 0, 0);
247           tpass1 = 1;
248           call alm_include_file_$first_file(trimmed_entryname);
249           binlin = 0;
250           call mexp_$init(code);
251           if code ^= 0 then goto abort;
252 ^L
253           /* The next few lines initialize decor to the current system type.
254              The decor_name array(data1)is built by alm_table_tool, who checks
255              that decor names and system_type_ names are in correspondence */
256 
257           call system_type_("", default_str, (0), code);
258           do n = 1 to hbound(data1.decor, 1) while(rtrim(default_str) ^= data1.decor(n).name);
259             end;
260           if n > hbound(data1.decor, 1)
261               then call prnter_$general_abort("Assembler error. Please notify assembler maintanence personel.");
262           decor = data1.decor(n).number;
263 
264           call pass1_$pass1_(decor, target_value, no_target_given, first_time_thru);
265           call mexp_$cleanup;
266 
267           tpass1 = 0;
268           tpost1 = 1;
269           call postp1_$postp1_;
270 ^K
271           tpost1 = 0;
272           eb_data_$curr_char_no = 0;
273           tpass2 = 1;
274           source_printed = ""b;
275           call alm_include_file_$first_file(trimmed_entryname);
276           binlin = 0;
277           call mexp_$init(code);
278           if code ^= 0 then goto abort;
279           call pass2_$pass2_(decor, target_value, no_target_given, first_time_thru);
280           /* pass2_ will check each instruction for compatibility with the decor value */
281           call mexp_$cleanup;
282 
283           tpass2 = 0;
284           tpostp = 1;
285           source = addr(oulst); begin_line = 1; srclen = 680;         /*fudge the source pointer for prnam*/
286           call postp2_$postp2_;
287 
288           tpostp = 0;
289           call pakbit_$pakbit_;
290           call alm_merge_$alm_merge_;
291           if tnoxref = 0 then call alm_cross_reference_();
292           severity = tfatal;
293           if tfatal < 3 then call prlst_$prlst_("
294 
295 NO FATAL ERRORS");
296           else call prlst_$prlst_("
297 
298 FATAL ERRORS ENCOUNTERED");
299 ^L
300 abort:    if code=0 then call release_temp_segments_("alm_", temp_ptrs, code);
301           else call release_temp_segments_("alm_", temp_ptrs, 0);
302 
303           if tnewobject = 0 then do;
304                      call make_object_map_(text, itxpc, ilkpc, istpc, txtlen/* in bits */, code);
305                     if code^=0 then call complain("An error was encountered in completing the object segment" || alm_info.source_entryname);
306             end;
307           else call make_alm_object_map_(txtlen);
308           alm_info.object_bc = eb_data_$segnfo.txtlen;
309 
310           if tnolst = 0 then do;
311                     alm_info.list_bc = eb_data_$segnfo.lstlen * 9;
312                     alm_info.list_component = eb_data_$list_component;
313             end;
314           recursive = "0"b;
315           if code = 0 then
316                if severity = 3 then code = error_table_$translation_failed;
317                else if severity = 4 then code = error_table_$translation_aborted;
318           return;
319 ^K
320 abandon_assembly:
321           recursive = "0"b;
322           severity = 4;
323           return;
324 ^K
325 cleanup_handler:    proc;
326           if temp_ptrs(1) ^= null() then call release_temp_segments_("alm_", temp_ptrs, 0);
327           call mexp_$cleanup;
328           recursive = "0"b;
329 end cleanup_handler;
330 ^K
331 complain: proc(message);
332 dcl       message char(*);
333 
334           if tquietsw ^= 1 then call com_err_(code, eb_data_$who_am_I, message);
335           goto abandon_assembly;
336 end complain;
337 
338 end alm_;