1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(88-04-05,Huen), approve(88-04-05,MCR7868), audit(88-04-13,RWaters),
 17      install(88-04-19,MR12.2-1040):
 18      The basic compiler can now associate severity levels with error messages.
 19      The severity command will now work with basic.
 20                                                    END HISTORY COMMENTS */
 21 
 22 
 23 /* Main program for basic compiler
 24 
 25    Initial Version: Spring 1973 by BLW
 26           Modified: 14 May 1974 by BLW to fix bug 030 */
 27 /*        Modified 1 November 1974 by MBW for extended precision */
 28 /*        Args made non-positional 11/08/79 S. Herbst */
 29 /*        Modified 31 July by M. Weaver to print full pathname in error message */
 30 /*        Modified 27 October 1980 by M. Weaver to treat zero length segments as an error */
 31 /*        Modified 8 March 1988 by S. Huen to implement SCP6356 basic severity  */
 32 
 33 /* format: style2 */
 34 
 35 basic:
 36      proc;
 37 
 38           dcl     (i, k, input_length, code, err_count, arglen, bitcnt, arg_count)
 39                                          fixed bin,
 40                   level                  fixed bin static init (0),
 41                   time_limit             fixed bin (71) init (0),
 42                   time1                  fixed bin (71),
 43                   (executing, got_path, had_bad_option)
 44                                          bit (1),
 45                   work_seg               ptr static init (null),
 46                   (source_info_pt, input_pt, output_pt)
 47                                          ptr init (null),
 48                   (argpt, object_hold, main_pt)
 49                                          ptr,
 50                   program_interrupt      condition,
 51                   cleanup                condition,
 52                   s                      char (1) varying,
 53                   arg                    char (arglen) based (argpt) unaligned,
 54                   my_name                char (5) static init ("basic"),
 55                   (ent, sourcename)      char (32),
 56                   (dir, wdir)            char (168);
 57 
 58           dcl     cu_$arg_ptr            entry (fixed bin, ptr, fixed bin, fixed bin),
 59                   cu_$af_return_arg      entry (fixed bin, ptr, fixed bin, fixed bin),
 60                   cu_$ptr_call           entry (ptr),
 61                   cv_dec_check_          entry (char (*) aligned, fixed bin) returns (fixed bin),
 62                   ioa_                   entry options (variable),
 63                   (
 64                   active_fnc_err_,
 65                   com_err_,
 66                   com_err_$suppress_name
 67                   )                      entry options (variable),
 68                   command_query_         entry options (variable),
 69                   expand_pathname_$add_suffix
 70                                          entry (char (*), char (*), char (*), char (*), fixed bin),
 71                   hcs_$initiate_count    entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin),
 72                   hcs_$terminate_noname  entry (ptr, fixed bin),
 73                   get_wdir_              entry (char (168)),
 74                   hcs_$delentry_seg      entry (ptr, fixed bin),
 75                   hcs_$make_seg          entry (char (*), char (*), char (*), fixed bin, ptr, fixed bin),
 76                   hcs_$status_long       entry options (variable),
 77                   tssi_$get_segment      entry (char (*), char (*), ptr, ptr, fixed bin),
 78                   tssi_$finish_segment   entry (ptr, fixed bin, bit (5), ptr, fixed bin),
 79                   hcs_$truncate_seg      entry (ptr, fixed bin, fixed bin),
 80                   virtual_cpu_time_      entry (fixed bin (71)),
 81                   timer_manager_$cpu_call
 82                                          entry (fixed bin (71), bit (2), entry),
 83                   timer_manager_$reset_cpu_call
 84                                          entry (entry),
 85                   basic_                 entry (ptr, fixed bin, ptr, ptr, ptr, fixed bin);
 86 
 87           dcl     (addr, divide, fixed, float, index, length, null, rtrim, search, substr)
 88                                          builtin;
 89 
 90           dcl     (
 91                   error_table_$bad_conversion,
 92                   error_table_$badopt,
 93                   error_table_$entlong,
 94                   error_table_$zero_length_seg
 95                   )                      fixed binary external;
 96           dcl     basic_data$precision_length
 97                                          fixed bin (35) ext static;
 98 
 99           dcl     1 basic_error_messages_$
100                                          aligned ext,
101                    2 index_block         (0:500),
102                      3 loc               fixed bin,
103                      3 sev               fixed bin,
104                      3 len               fixed bin,
105                    2 message_block       char (248000);
106 
107           dcl     basic_severity_       fixed bin ext static;
108 
109           dcl     1 branch               aligned automatic,
110                     2 type               bit (2) unaligned,
111                     2 nnames             bit (16) unaligned,
112                     2 nrp                bit (18) unaligned,
113                     2 dtm                bit (36) unaligned,
114                     2 dtu                bit (36) unaligned,
115                     2 mode               bit (5) unaligned,
116                     2 padding            bit (13) unaligned,
117                     2 records            bit (18) unaligned,
118                     2 dtd                bit (36) unaligned,
119                     2 dtem               bit (36) unaligned,
120                     2 acct               bit (36) unaligned,
121                     2 curlen             bit (12) unaligned,
122                     2 bitcnt             bit (24) unaligned,
123                     2 did                bit (4) unaligned,
124                     2 mdid               bit (4) unaligned,
125                     2 copysw             bit (1) unaligned,
126                     2 pad2               bit (9) unaligned,
127                     2 rbs                (0:2) bit (6) unaligned,
128                     2 uid                bit (36) unaligned;
129 
130           dcl     1 source_info          aligned,
131 %include basic_source_info;
132 
133 /* precision_length is not set here because this is the primary entry
134    for extended precision use as well */
135 
136 start:
137           word_count = 0;
138           basic_severity_ = 5;
139 
140           on program_interrupt goto done;
141 
142           got_path, had_bad_option = "0"b;
143 
144           call cu_$af_return_arg (arg_count, null, 0, code);/* make sure called as a command */
145           if code = 0
146           then do;
147                     call active_fnc_err_ (0, my_name, "Cannot be called as an active function.");
148                     return;
149                end;
150 
151           do i = 1 to arg_count;
152 
153                call cu_$arg_ptr (i, argpt, arglen, code);
154 
155                if substr (arg, 1, 1) ^= "-"
156                then do;
157                          if got_path
158                          then do;
159 USAGE:
160                                    call com_err_$suppress_name (0, my_name, "Usage:  ^a path {-control_args}", my_name);
161                                    return;
162                               end;
163                          got_path = "1"b;
164                          call expand_pathname_$add_suffix (arg, "basic", dir, sourcename, code);
165                          if code ^= 0
166                          then do;
167                                    if code = error_table_$entlong & substr (arg, arglen - 5, 6) ^= ".basic"
168                                    then call com_err_ (code, my_name, "^a.basic", arg);
169                                    else call com_err_ (code, my_name, "^a", arg);
170                                    return;
171                               end;
172                          ent = substr (sourcename, 1, length (rtrim (sourcename)) - length (".basic"));
173                     end;
174 
175                else if arg = "-time" | arg = "-tm"
176                then do;
177                          i = i + 1;
178                          if i > arg_count
179                          then time_limit = 1;
180                          else do;
181                                    call cu_$arg_ptr (i, argpt, arglen, code);
182                                    time_limit = cv_dec_check_ ((arg), code);
183                                    if code ^= 0
184                                    then do;
185                                              call com_err_ (error_table_$bad_conversion, my_name, "^a", arg);
186                                              return;
187                                         end;
188                               end;
189                     end;
190                else if arg = "-compile" | arg = "-cp"
191                then source_info_pt = addr (source_info);
192                else do;
193                          call com_err_ (error_table_$badopt, my_name, "^a", arg);
194                          had_bad_option = "1"b;
195                     end;
196           end;
197 
198           if ^got_path
199           then go to USAGE;
200           if had_bad_option
201           then return;
202 
203 have_source:
204           call hcs_$initiate_count (dir, sourcename, "", bitcnt, 1, input_pt, code);
205 
206           if input_pt = null
207           then do;
208 ent_err:
209                     call com_err_ (code, my_name, "^a>^a", dir, sourcename);
210                     return;
211                end;
212           if bitcnt = 0
213           then do;
214                     code = error_table_$zero_length_seg;
215                     go to ent_err;
216                end;
217 
218           input_length = divide (bitcnt, 9, 17, 0);
219 
220           on cleanup call clean_up;
221 
222           level = level + 1;
223 
224           if source_info_pt ^= null
225           then do;
226 
227 /* generate object segment */
228 
229                     source_info.segname = rtrim (ent);
230 
231                     source_info.dirname = rtrim (dir);
232 
233                     call hcs_$status_long (dir, sourcename, 0, addr (branch), null, code);
234 
235                     if code ^= 0
236                     then goto ent_err;
237 
238                     source_info.unique_id = branch.uid;
239                     source_info.date_time_modified = fixed (branch.dtm || (16)"0"b, 71);
240 
241                     call get_wdir_ (wdir);
242                     call tssi_$get_segment (wdir, ent, output_pt, object_hold, code);
243                end;
244           else if level = 1
245           then do;
246                     if work_seg = null
247                     then call hcs_$make_seg ("", "basic_temporary_", "", 01111b, work_seg, code);
248 
249                     output_pt = work_seg;
250                end;
251           else call hcs_$make_seg ("", "", "", 01111b, output_pt, code);
252 
253           if output_pt = null
254           then do;
255                     call com_err_ (code, my_name, "^a>^a", dir, sourcename);
256                     goto done;
257                end;
258 
259           basic_severity_ = 0;
260           call basic_ (input_pt, input_length, output_pt, source_info_pt, main_pt, err_count);
261 
262           if source_info_pt = null
263           then if err_count = 0
264                then if main_pt = null
265                     then call fatal_err (180);
266                     else if time_limit = 0
267                     then call cu_$ptr_call (main_pt);
268                     else do;
269                               call virtual_cpu_time_ (time1);
270 
271                               call timer_manager_$cpu_call (time_limit, "11"b, cpu_limit);
272 
273                               executing = "1"b;
274                               call cu_$ptr_call (main_pt);
275                               executing = "0"b;
276                          end;
277                else do;
278                          if err_count = 1
279                          then s = "";
280                          else s = "s";
281                          call ioa_ ("^d error^a found, no execution.", err_count, s);
282                          call ioa_ ("");
283                     end;
284 
285 done:
286           call clean_up;
287           return;
288 
289 
290 
291 
292 ep_basic:
293      entry;
294 
295           basic_data$precision_length = 2;                  /* make entry work as expected */
296           go to start;
297 ^L
298 clean_up:
299      proc;
300 
301           if input_pt ^= null
302           then call hcs_$terminate_noname (input_pt, code);
303 
304           if source_info_pt ^= null
305           then if output_pt ^= null
306                then do;
307                          call hcs_$truncate_seg (output_pt, word_count, code);
308 
309                          if code ^= 0
310                          then call com_err_ (code, my_name, "^a>^a", dir, sourcename);
311 
312                          call tssi_$finish_segment (output_pt, word_count * 36, "1100"b, object_hold, code);
313 
314                          if code ^= 0
315                          then call com_err_ (code, my_name, "^a>^a", dir, sourcename);
316                     end;
317                else ;
318           else if level > 1
319           then call hcs_$delentry_seg (output_pt, code);
320           else call hcs_$truncate_seg (output_pt, 0, code);
321 
322           level = level - 1;
323 
324           if time_limit ^= 0
325           then call timer_manager_$reset_cpu_call (cpu_limit);
326      end;
327 ^L
328 cpu_limit:
329      proc;
330 
331           dcl     answer                 char (3) varying,
332                   time2                  fixed bin (71);
333 
334           dcl     1 query_info           aligned,
335                     2 version            fixed bin init (2),
336                     2 yes_or_no          unaligned bit (1) init ("1"b),
337                     2 surpress_name      unaligned bit (1) init ("0"b),
338                     2 status_code        fixed bin init (0),
339                     2 query_code         fixed bin;
340 
341           if executing
342           then do;
343                     call virtual_cpu_time_ (time2);
344 
345                     call command_query_ (addr (query_info), answer, my_name,
346                          "^a has used ^.3f seconds of cpu time.  Do you want to continue?", ent,
347                          float (time2 - time1, 27) / 1.0e6);
348 
349                     if answer = "no"
350                     then goto done;
351 
352                     call timer_manager_$cpu_call (time_limit, "11"b, cpu_limit);
353                end;
354 
355      end;
356 
357 fatal_err:
358      proc (err_num);
359           dcl     err_num                         fixed bin;
360           dcl     (i, k)                          fixed bin;
361 
362           dcl     1 message_overlay      aligned based (addr (basic_error_messages_$)),
363                     2 index_block_skip   (0:500),
364                       3 (a, b, c)        fixed bin,
365                     2 skip               unal char (k),
366                     2 message            unal char (index_block (i).len - 1);
367 
368           i = abs (err_num);
369           call ioa_ ("");
370           call ioa_ ("FATAL ERROR - ^d", i);
371           k = index_block (i).loc;
372           if k ^= -1 then call ioa_ (message);;
373           call ioa_ ("");
374           basic_severity_ = 5;
375           return;
376      end;
377 end;