1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21 alm_: proc(ALM_INFO_PTR, ALM_ARGS_PTR, severity, code);
22
23
24
25
26
27
28
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
34 dcl recursive bit(1) static init("0"b);
35
36
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;
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);
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);
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;
176 else tnoxref = 1;
177
178 if alm_info.target = "" then target_value = L68_SYSTEM;
179
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;
210 ^K
211
212 do i = 1 to eb_data_$varcom_size;
213 brk(i) = 0;
214 end;
215 brk(1), nbrk(1) = ibsp;
216 stkc = 40;
217 nboxes = 211;
218 ndpcls = addr(pclst);
219 ndltls = addr(litlst);
220 ndlkls = addr(lnklst);
221 ndtvls = addr(tvlst);
222 do i = 1 to 36;
223 flgvec(i) = 0;
224 end;
225 tfatal = 0;
226 eb_data_$per_process_static_sw = 0;
227
228 call glpl_$genlas;
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_("");
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
254
255
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
281 call mexp_$cleanup;
282
283 tpass2 = 0;
284 tpostp = 1;
285 source = addr(oulst); begin_line = 1; srclen = 680;
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, 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_;