1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 /* procedure to compile a statement
 12 
 13    Initial Version: 31 March 1971 by BLW for Version
 14    Modified:  6 February 1973 by BLW
 15    Modified: 28 February 1973 by RAB
 16    Modified: 12 June 1973 by RAB for EIS
 17    Modified: 1 November 1973 by RAB for snap & system
 18    Modified: 23 June 1975 by EEW for separate static
 19    Modified: 20 August 1975 by RAB to fix bug 1396
 20    Modified: 1 November 1975 by RAB to optimize if stmts
 21    Modified: 10 January 1976 by RAB for cg_stat$return_operator to fix 1453
 22    Modified: 1 July 1976 by RAB for label array improvements
 23    Modified: 27 Sept 1976 by RAB to fix 1523
 24    Modified: 1 Dec 1976 by RAB for -long_profile
 25    Modified: 23 Jan 1977 by RAB for combine_tests
 26    Modified: 10 Feb 1977 by RAB for multiple cond names in on stmt
 27    Modified: 9 Feb 1978 by RAB to check $agg_temps on end stmt
 28    Modified: 11 Feb 1978 by RAB to fix 1687
 29    Modified: 15 Feb 1978 by PCK to implement options(main) and the stop statement
 30    Modified 790807 by PG to remove jump_three_way.
 31    Modified: 16 Nov 1979 by PCK to fix 1858
 32    Modified: 9 November 1981 by M. N. Davidoff to fix bug 1931 in which return and stop statements
 33           have garbage long profile information.
 34    Modified: 4 January 1983 BIM to note statements that begin do loops.
 35 */
 36 /* format: style3 */
 37 compile_statement:
 38      proc (pt);
 39 
 40 dcl       pt                  ptr;                          /* points at statement node */
 41 
 42 /* external static */
 43 
 44 dcl       (
 45           cg_stat$cur_block,
 46           cg_stat$cur_statement,
 47           cg_stat$text_base,
 48           cg_stat$first_ref,
 49           cg_stat$m_s_p,
 50           cg_stat$agg_temps,
 51           cg_stat$text_reloc_base,
 52           cg_stat$sym_base,
 53           cg_stat$sym_reloc_base,
 54           cg_stat$next_ref,
 55           cg_stat$cur_tree,
 56           cg_stat$return_operator,
 57           cg_stat$profile_base,
 58           cg_stat$stop_operator,
 59           cg_stat$return_main_operator
 60           )                   ptr ext,
 61           cg_stat$star_symbol_up_zero
 62                               bit (18) ext,
 63           cg_stat$old_id      bit (27) ext,
 64           (
 65           cg_stat$text_pos,
 66           cg_stat$sym_pos,
 67           cg_stat$map_start,
 68           cg_stat$cur_level,
 69           cg_stat$profile_pos,
 70           cg_stat$profile_start
 71           )                   fixed bin (18) ext,
 72           (
 73           cg_stat$generate_symtab,
 74           cg_stat$table_option,
 75           cg_stat$skip_to_label,
 76           cg_stat$generate_map,
 77           cg_stat$separate_static,
 78           cg_stat$extended_stack,
 79           cg_stat$in_prologue,
 80           cg_stat$profile_option,
 81           cg_stat$support,
 82           cg_stat$long_profile,
 83           cg_stat$optimize,
 84           cg_stat$in_thunk
 85           )                   bit (1) ext;
 86 
 87 dcl       cg_stat$stop_id     aligned bit (27) ext;
 88 
 89 /* automatic */
 90 
 91 dcl       (
 92           cb,
 93           p,
 94           q,
 95           q1,
 96           q2,
 97           q3,
 98           q4,
 99           tree,
100           save_cb,
101           arg                 (4),
102           p1
103           )                   ptr,
104           (nargs, profile_pos)
105                               fixed bin,
106           macro               fixed bin (15),
107           save_label          label,
108           recovery_label      label int static,
109           (a1, a2, atomic, replace)
110                               bit (1) aligned,
111           on_options          bit (2) aligned,
112           (st_type, op)       bit (9) aligned,
113           (i, text_pos, n)    fixed bin (18);
114 
115 /* based */
116 
117 dcl       fix_bin             fixed bin based;
118 
119 dcl       1 eax_ins           aligned based,
120             2 offset          unal bit (18);
121 
122 dcl       (word, relocation)  bit (36) aligned based;
123 
124 /* internal static */
125 
126 dcl       (
127           reset_stack         init (194),
128           ret_chars           init (586),
129           ret_bits            init (590),
130           ret_words           init (480),
131           nop_mac             init (528),
132           aos_mac             init (309),
133           lxl0                init (64),
134           leave_begin_block   init (97),
135           tra                 init (169),
136           enable_mac          init (291),
137           enable_file         init (606),
138           enable_file_2       init (593),
139           ss_enter_begin_block
140                               init (512),
141           enter_begin_block   init (197),
142           return_mac          init (198),
143           support_mac         init (305),
144           long_profile_mac    init (699),
145           quick_return_mac    init (299),
146           set_stack           init (175),
147           begin_return_mac    init (288),
148           begin_return_main_mac
149                               init (729),
150           stop_mac            init (726),
151           return_main_mac     init (727)
152           )                   fixed bin (15) int static options (constant);
153 
154 /* builtins */
155 
156 dcl       (addr, addrel, bit, fixed, null, size, string, substr)
157                               builtin;
158 
159 /* entries */
160 
161 dcl       create_list         entry (fixed bin) returns (ptr);
162 dcl       create_label        entry (ptr, ptr, bit (3) aligned) returns (ptr);
163 dcl       decode_node_id      entry (ptr, bit (1) aligned) returns (char (120) varying),
164           error               entry (fixed bin, ptr, ptr),
165           xr_man$load_const   entry (fixed bin (31), fixed bin),
166           (
167           xr_man$super_lock,
168           xr_man$super_unlock
169           )                   entry (fixed bin),
170           expmac$many         entry (fixed bin (15), ptr, fixed bin),
171           (
172           stack_temp$free_aggregates,
173           state_man$flush,
174           state_man$discard_ms
175           )                   entry,
176           (adjust_ref_count, compile_entry)
177                               entry (ptr, fixed bin (18)),
178           state_man$merge_ms  entry (ptr),
179           state_man$create_ms entry returns (ptr),
180           state_man$erase_reg entry (bit (19) aligned),
181           (ioa_$nnl, debug)   entry options (variable),
182           expmac              entry (fixed bin (15), ptr),
183           c_a                 entry (fixed bin (18), fixed bin) returns (ptr),
184           copy_temp           entry (ptr) returns (ptr),
185           prepare_operand     entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
186           compile_exp         entry (ptr),
187           compile_exp$save_exp
188                               entry (ptr) returns (ptr),
189           base_man$load_var   entry (fixed bin, ptr, fixed bin),
190           long_op$no_size     entry (ptr, fixed bin (15)),
191           load_size           entry (ptr),
192           make_mod            entry (fixed bin (17), fixed bin) returns (fixed bin (18)),
193           expmac$fill_usage   entry (fixed bin (18), fixed bin (17)),
194           expmac$zero         entry (fixed bin (15)),
195           expmac$abs          entry (ptr, fixed bin),
196           optimize_if         entry (ptr),
197           combine_tests       entry (ptr, ptr),
198           compile_block$begin_block
199                               entry (ptr),
200           compile_tree        entry (ptr);
201 ^L
202 %include block;
203 %include reference;
204 %include symbol;
205 %include label;
206 %include statement;
207 %include operator;
208 %include list;
209 %include runtime_symbol;
210 %include nodes;
211 %include statement_types;
212 %include statement_map;
213 %include profile_entry;
214 %include long_profile;
215 %include op_codes;
216 %include block_types;
217 %include declare_type;
218 %include relbts;
219 %include data_types;
220 %include jump_complement;
221 ^L
222 /* program */
223 
224           p, cg_stat$cur_statement = pt;
225           cb = cg_stat$cur_block;
226 
227           profile_pos = 0;
228 
229           recovery_label = done;
230 
231           if cg_stat$stop_id = string (p -> statement.source_id)
232           then do;
233                     call ioa_$nnl ("Compiling ^p (^a).^/debug: ", pt, decode_node_id (p, "0"b));
234                     call debug;
235                end;
236 
237           st_type = p -> statement.statement_type;
238 
239           if st_type = format_statement
240           then return;
241 
242           text_pos, p -> statement.object.start, p -> statement.object.finish = cg_stat$text_pos;
243 
244           if st_type = entry_statement | st_type = procedure_statement
245           then do;
246                     q = create_list (2);
247                     q -> element (2) = p;
248                     q -> element (1) = cb -> block.entry_list;
249                     cb -> block.entry_list = q;
250 
251                     cg_stat$skip_to_label = "0"b;
252                     if cg_stat$m_s_p = null
253                     then cg_stat$m_s_p = state_man$create_ms ();
254 
255                     call compile_entry (pt, n);
256 
257                     if (cg_stat$table_option | cg_stat$generate_symtab) & ^cb -> block.no_stack
258                     then do;
259                               addrel (cg_stat$text_base, n) -> word =
260                                    cg_stat$star_symbol_up_zero || bit (fixed (cb -> block.symbol_block, 18), 18);
261                               addrel (cg_stat$text_reloc_base, n) -> relocation = rc_lp18 || rc_s;
262                          end;
263 
264                     if cg_stat$table_option
265                     then do;
266                               p1 = p -> statement.labels -> element (2) -> reference.symbol;
267                               addrel (cg_stat$sym_base, p1 -> symbol.runtime) -> runtime_symbol.location =
268                                    bit (fixed (p1 -> symbol.location, 18), 18);
269                          end;
270 
271                     if cg_stat$long_profile
272                     then if p -> statement.labels -> element (2) -> reference.symbol -> symbol.external
273                          then do;
274                                    call gen_long_profile (dummy_entry_offset);
275                                    call gen_long_profile (dummy_entry_offset);
276                                    call gen_long_profile (control_entry_offset);
277                                    call gen_long_profile (control_entry_offset);
278                                    call gen_long_profile (dummy_entry_offset);
279                               end;
280 
281                     goto done;
282                end;
283 
284           q = p -> statement.labels;
285           if q = null & cg_stat$skip_to_label
286           then return;
287 
288           if p -> statement.begins_loop
289           & mod (text_pos, 2) ^= 0
290                then do;
291                call expmac$zero (nop_mac);
292                text_pos = text_pos + 1; /* start on even boundary */
293           end;
294 
295           a1 = "0"b;
296           do while (q ^= null);
297                p -> statement.reference_count = p -> statement.reference_count - 1;
298                p1 = q -> element (2);
299 
300                if p1 -> node.type = reference_node
301                then do;
302                          n = p1 -> reference.symbol -> label.location + p1 -> reference.c_offset;
303                          if addrel (cg_stat$text_base, n) -> fix_bin ^= 0
304                          then call error (326, p, p1);
305                          else do;
306                                    cg_stat$text_pos = n;
307                                    call expmac ((tra), c_a (text_pos, 10));
308                                    cg_stat$text_pos = text_pos;
309                               end;
310                     end;
311                else do;
312                          call expmac$fill_usage (text_pos, (p1 -> label.location));
313                          p1 -> label.location = text_pos;
314                          p1 -> label.allocated = "1"b;
315 
316                          if cg_stat$table_option
317                          then addrel (cg_stat$sym_base, p1 -> label.symbol_table) -> runtime_symbol.location =
318                                    bit (text_pos, 18);
319                     end;
320 
321                q = q -> element (1);
322           end;
323 
324           if p -> statement.labels ^= null
325           then do;
326 
327 /* if there are no states attached to this statement and the reference
328    count is zero, there were no references to the statement.  If this is
329    an end statement and the root is null, this is the superfluous end
330    statement generated by if_parse or do_parse.  We will ignore the
331    statement in this case and avoid altering the machine state */
332 
333                     if p -> state_list = null
334                     then if p -> reference_count = 0
335                          then if p -> statement.root = null
336                               then if st_type = end_statement
337                                    then do;
338                                              if ^cg_stat$skip_to_label
339                                              then if cg_stat$extended_stack | cg_stat$agg_temps ^= null
340                                                        | cg_stat$profile_option | cg_stat$long_profile
341                                                   then goto free_temps;
342                                              goto done;
343                                         end;
344 
345                     cg_stat$skip_to_label = "0"b;
346 
347 /* merge together all of the possible machine states */
348 
349                     call state_man$merge_ms (pt);
350                end;
351 
352 free_temps:
353           if p -> statement.free_temps
354           then do;
355                     if cg_stat$extended_stack
356                     then call shorten_stack;
357 
358                     if cg_stat$agg_temps ^= null
359                     then call stack_temp$free_aggregates;
360                end;
361 
362           tree, cg_stat$cur_tree = p -> statement.root;
363 
364           if cg_stat$profile_option
365           then if p -> statement.put_in_profile & string (p -> statement.source_id) ^= "0"b
366                then do;
367                          profile_pos = cg_stat$profile_pos;
368                          call expmac ((aos_mac), c_a (profile_pos + 1, 13));
369                          cg_stat$profile_pos = cg_stat$profile_pos + size (p -> profile_entry);
370                     end;
371 
372           if cg_stat$long_profile
373           then if p -> statement.put_in_profile & string (p -> statement.source_id) ^= "0"b
374                then do;
375                          profile_pos = cg_stat$profile_pos;
376                          call gen_long_profile (profile_pos);
377                          cg_stat$profile_pos = cg_stat$profile_pos + size (long_profile_entry);
378                     end;
379 
380 /* ignore null statements except if they have nop operator */
381 
382           if st_type = null_statement
383           then do;
384                     if tree = null
385                     then goto done;
386                     if tree -> operator.op_code = nop
387                     then call expmac$zero ((nop_mac));
388                     goto done;
389                end;
390 
391           if st_type = if_statement
392           then do;
393 
394 /* following code looks for constructs:
395 
396    if <condition> then return; _^Ho_^Hr
397    if <condition> then stop;
398 
399    and compiles it as a conditional transfer to
400    the _^Hr_^He_^Ht_^Hu_^Hr_^Hn, _^Hr_^He_^Ht_^Hu_^Hr_^Hn__^Hm_^Ha_^Hi_^Hn, or _^Hs_^Ht_^Ho_^Hp label in the operator segment */
401 
402                     if tree -> op_code <= jump | tree -> op_code >= jump_if_ge
403                     then goto normal;
404 
405                     p1 = tree -> operand (1);
406                     if p1 -> node.type ^= label_node
407                     then goto check_if;
408 
409                     q1 = p -> statement.next;
410                     if q1 -> statement_type ^= return_statement & q1 -> statement_type ^= stop_statement
411                     then goto check_if;
412                     if q1 -> statement.labels ^= null
413                     then goto check_if;
414 
415                     q = q1 -> statement.root;
416                     if q ^= null
417                     then do;
418                               if q -> operator.number ^= 0
419                               then goto check_if;
420                               if q -> op_code ^= std_return & q -> op_code ^= stop
421                               then goto check_if;
422                          end;
423 
424                     if cb -> block.no_stack
425                     then goto check_if;
426                     if cb -> block.block_type = begin_block
427                     then goto check_if;
428 
429                     q2 = q1 -> statement.next;
430                     if p1 -> label.statement ^= q2
431                     then goto check_if;
432 
433 /* all our tests succeeded, complement the sense of the jump and replace its
434    operand(1) with a reference node having address ap|409, ap|801, or ap|802
435    (return_operator_loc, stop_operator_loc, return_main_operator_loc defined
436    in code_generator.pl1).  We don't use c_a because if stmt might be split. */
437 
438                     tree -> op_code = jump_complement (fixed (substr (tree -> op_code, 6, 4), 4));
439                     if q1 -> statement_type = return_statement
440                     then if cb -> block.options_main
441                          then tree -> operand (1) = cg_stat$return_main_operator;
442                          else tree -> operand (1) = cg_stat$return_operator;
443                     else tree -> operand (1) = cg_stat$stop_operator;
444 
445                     q1 -> statement_type = null_statement;
446                     q1 -> statement.root = null;
447 
448                     q2 -> statement.reference_count = q2 -> statement.reference_count - 1;
449 
450 /* following code checks for possibility of optimizing an
451    if statement with a logical operator at the top */
452 
453 check_if:
454                     if cg_stat$optimize
455                     then if ^p -> statement.irreducible & ^p -> statement.checked
456                          then if tree -> op_code = jump_true | tree -> op_code = jump_false
457                               then if tree -> operand (2) -> node.type = operator_node
458                                    then if ^tree -> operand (2) -> operand (1) -> reference.evaluated
459                                         then if tree -> operand (2) -> operand (1) -> reference.c_length = 1
460                                              then do;
461                                                        q1 = p -> statement.next;
462                                                        call optimize_if (pt);
463                                                        if q1 ^= p -> statement.next
464                                                        then call combine_tests (pt, (q1 -> statement.back));
465                                                        tree, cg_stat$cur_tree = p -> statement.root;
466                                                   end;
467 
468                     goto normal;
469                end;
470 
471           if st_type = begin_statement
472           then do;
473                     save_label = recovery_label;
474                     if ^tree -> block.no_stack
475                     then do;
476                               q = addrel (cg_stat$text_base, cg_stat$text_pos);
477                               tree -> block.entry_list = q;
478 
479                               if cg_stat$separate_static
480                               then macro = ss_enter_begin_block;
481                               else macro = enter_begin_block;
482                               call expmac$zero ((macro));
483 
484                               if (cg_stat$table_option | cg_stat$generate_symtab)
485                               then do;
486                                         addrel (cg_stat$text_base, cg_stat$text_pos) -> word =
487                                              cg_stat$star_symbol_up_zero
488                                              || bit (fixed (tree -> block.symbol_block, 18), 18);
489                                         addrel (cg_stat$text_reloc_base, cg_stat$text_pos) -> relocation =
490                                              rc_lp18 || rc_s;
491                                    end;
492 
493                               cg_stat$text_pos = cg_stat$text_pos + 1;
494 
495                               if cg_stat$support
496                               then call expmac$zero ((support_mac));
497                          end;
498 
499                     call make_map_entry;
500 
501                     call compile_block$begin_block ((tree));
502 
503                     if cg_stat$m_s_p = null
504                     then cg_stat$m_s_p = state_man$create_ms ();
505 
506                     cg_stat$cur_block = cb;
507                     cg_stat$skip_to_label = "0"b;
508                     cg_stat$cur_level = cb -> block.level;
509                     recovery_label = save_label;
510 
511                     if ^tree -> block.no_stack
512                     then q -> eax_ins.offset = bit (make_mod (tree -> block.last_auto_loc, 16), 18);
513                     return;
514                end;
515 
516           if st_type = on_statement
517           then do;
518                     nargs = 3;
519                     q1 = tree -> operand (1);
520                     arg (1) = prepare_operand ((q1 -> reference.symbol -> symbol.general), 1, atomic);
521                     on_options = p -> statement.snap || p -> statement.system;
522 
523                     q2 = tree -> operand (2);
524                     if q2 ^= null
525                     then do;
526                               arg (2) = prepare_operand (q2, 1, atomic);
527                               if on_options ^= ""b
528                               then do;
529                                         macro = enable_file_2;
530                                         nargs = 4;
531                                         arg (4) = c_a (fixed (bit (on_options, 18), 18), 2);
532                                    end;
533                               else macro = enable_file;
534                          end;
535                     else do;
536                               n = q1 -> reference.symbol -> symbol.location;
537                               arg (2) = c_a (n, 1);
538                               arg (2) -> reference.address.op = on_options;
539                               macro = enable_mac;
540                          end;
541 
542                     arg (3) =
543                          prepare_operand ((tree -> operand (3) -> block.main -> statement.labels -> element (2)), 1,
544                          atomic);
545 
546                     call xr_man$load_const ((arg (1) -> reference.c_length), 6);
547                     call xr_man$super_lock (6);
548 
549                     call expmac$many (macro, addr (arg), nargs);
550 
551                     call xr_man$super_unlock (6);
552 
553                     if ^arg (3) -> reference.symbol -> symbol.allocated
554                     then do;
555                               p1 = create_label (cg_stat$cur_block, null, by_compiler);
556                               call expmac ((tra), prepare_operand (p1, 1, atomic));
557 
558                               call make_map_entry;
559 
560                               save_cb = cb;
561                               call compile_block$begin_block ((tree -> operand (3)));
562                               cb, cg_stat$cur_block = save_cb;
563                               cg_stat$cur_level = cb -> block.level;
564 
565                               call expmac$fill_usage (cg_stat$text_pos, (p1 -> label.location));
566 
567                               if cg_stat$m_s_p = null
568                               then cg_stat$m_s_p = state_man$create_ms ();
569                               cg_stat$skip_to_label = "0"b;
570                          end;
571 
572                     else call make_map_entry;
573 
574                     call state_man$flush;
575                     return;
576                end;
577 
578           if st_type = end_statement
579           then do;
580                     if tree = null
581                     then goto done;
582 
583                     cg_stat$skip_to_label = cb -> block.block_type ^= begin_block;
584 
585                     if cb -> block.no_stack
586                     then if cb -> block.block_type ^= begin_block
587                          then call expmac ((quick_return_mac), c_a (cb -> block.entry_info, 4));
588                          else ;
589 
590                     else if cb -> block.block_type = begin_block
591                     then do;
592                               call state_man$flush;
593                               call expmac$zero (leave_begin_block);
594                          end;
595 
596                     else call return_from_nonquick_procedure (cb);
597 
598                     goto done;
599                end;
600 
601           if st_type = return_statement
602           then do;
603                     cg_stat$skip_to_label = "1"b;
604 
605                     if tree = null
606                     then goto nr;
607 
608                     op = tree -> operator.op_code;
609                     if op = std_return
610                     then goto nr;
611 
612 /* have return of something with * bound or length */
613 
614                     i = 0;
615                     if cb -> block.block_type = begin_block
616                     then do;
617 
618                               q = cb;
619                               do while (q -> block.block_type = begin_block);
620                                    if ^q -> block.no_stack
621                                    then i = i + 1;
622                                    q = q -> block.father;
623                               end;
624 
625                          end;
626 
627 /* we assume that we can't have a no stack procedure with returns(*) */
628 
629                     q3 = c_a (i, 2);
630 
631                     if op = return_string
632                     then do;
633                               replace = "0"b;
634                               q1 = prepare_operand ((tree -> operand (1)), 1, a1);
635 
636                               if ^a1
637                               then if q1 -> reference.long_ref
638                                    then do;
639                                              q2 = q1 -> reference.length;
640                                              if q2 ^= null
641                                              then do;
642                                                        if q2 -> node.type = operator_node
643                                                        then do;
644                                                                  q4 = q2 -> operand (1);
645                                                                  if q4 -> reference.shared
646                                                                  then do;
647                                                                            q2 -> operand (1) = copy_temp (q4);
648                                                                            replace = "1"b;
649                                                                       end;
650                                                             end;
651 
652                                                        call adjust_ref_count (q2, 1);
653                                                   end;
654 
655                                              call compile_exp ((tree -> operand (1)));
656                                         end;
657                                    else q1 = compile_exp$save_exp ((tree -> operand (1)));
658 
659                               call load_size (q1);
660 
661                               if replace
662                               then q2 -> operand (1) = q4;
663 
664                               if q1 -> reference.data_type = char_string
665                               then macro = ret_chars;
666                               else macro = ret_bits;
667 
668 l1:
669                               call gen_long_profile_for_last_statement;
670                               call expmac (lxl0, q3);
671                               call long_op$no_size (q1, macro);
672                               goto ret_done;
673                          end;
674 
675 /* must be return_words | return_bits operator */
676 
677                     q2 = prepare_operand ((tree -> operand (2)), 1, a2);
678                     q1 = prepare_operand ((tree -> operand (1)), -1, a1);
679 
680                     call compile_exp ((tree -> operand (2)));
681 
682                     if op = return_bits
683                     then do;
684                               macro = ret_bits;
685                               goto l1;
686                          end;
687 
688                     if q1 -> reference.varying_ref
689                     then q1 -> reference.c_offset = q1 -> reference.c_offset - 1;
690 
691                     call base_man$load_var (2, q1, 1);
692                     call gen_long_profile_for_last_statement;
693                     call expmac (ret_words, q3);
694 
695                     if q1 -> reference.varying_ref
696                     then q1 -> reference.c_offset = q1 -> reference.c_offset + 1;
697 
698                     goto ret_done;
699 
700 /* have normal return operator */
701 
702 nr:
703                     q = cb;
704                     if cb -> block.block_type ^= begin_block
705                     then if cb -> block.no_stack
706                          then do;
707 qr:
708                                    if cg_stat$extended_stack
709                                    then call shorten_stack;
710                                    call expmac (quick_return_mac, c_a (q -> block.entry_info, 4));
711                               end;
712                          else call return_from_nonquick_procedure (cb);
713 
714                     else do;
715                               i = 0;
716 
717                               do while (q -> block.block_type = begin_block);
718                                    if ^q -> block.no_stack
719                                    then i = i + 1;
720                                    q = q -> block.father;
721                               end;
722 
723                               if q -> block.no_stack
724                               then do;
725                                         if i ^= 0
726                                         then do;
727                                                   call expmac ((set_stack), c_a (i, 2));
728                                                   cg_stat$extended_stack = "0"b;
729                                              end;
730                                         goto qr;
731                                    end;
732 
733                               if q -> block.options_main
734                               then macro = begin_return_main_mac;
735                               else macro = begin_return_mac;
736 
737                               call gen_long_profile_for_last_statement;
738                               call expmac (macro, c_a (i, 2));
739                          end;
740 
741 ret_done:
742                     call state_man$discard_ms;
743                     cg_stat$extended_stack = "0"b;
744 
745                     goto done;
746                end;
747 
748 /* process stop statements */
749 
750           if st_type = stop_statement
751           then do;
752                     cg_stat$skip_to_label = "1"b;
753                     call gen_long_profile_for_last_statement;
754                     call expmac$zero (stop_mac);
755                     call state_man$discard_ms;
756                     goto done;
757                end;
758 
759 normal:
760           if tree ^= null
761           then call compile_tree (tree);
762 
763 done:
764           call make_map_entry;
765           return;
766 
767 recover:
768      entry;
769 
770 /* This entry causes compile_statement to return to the program
771    that call it, thus effecting an error recovery after a fault */
772 
773           goto recovery_label;
774 ^L
775 shorten_stack:
776      procedure;
777 
778           if st_type ^= procedure_statement
779           then do;
780                     call state_man$erase_reg ("0000000000000001000"b);
781                                                             /* ab */
782                     call expmac$zero ((reset_stack));
783                end;
784 
785           cg_stat$extended_stack = "0"b;
786      end shorten_stack;
787 
788 make_map_entry:
789      procedure;
790 
791 /* This procedure makes a statement_map entry for the statement if
792    one is needed and updates any necessary profile information */
793 
794 dcl       q                   ptr;
795 
796           p -> statement.object.finish = cg_stat$text_pos;
797 
798           if profile_pos ^= 0
799           then addrel (cg_stat$profile_base, profile_pos) -> profile_entry.map =
800                     bit (fixed (cg_stat$sym_pos - cg_stat$map_start, 18), 18);
801 
802           if ^cg_stat$generate_map
803           then goto reset;
804 
805           if cg_stat$in_thunk
806           then goto reset;                                  /* Protects runtime symbol table.  (1858) */
807 
808 /* make entry in map if we generated any code for this
809    statement and its statement id is different from that
810    of previous statement */
811 
812           if profile_pos = 0
813           then do;
814                     if cg_stat$in_prologue
815                     then goto reset;
816 
817                     if p -> statement.object.finish = text_pos
818                     then goto reset;
819 
820                     if cg_stat$old_id = string (p -> statement.source_id)
821                     then goto reset;
822 
823                     if p -> statement.source.length <= 0
824                     then goto reset;
825                end;
826 
827           cg_stat$old_id = string (p -> statement.source_id);
828 
829           q = addrel (cg_stat$sym_base, cg_stat$sym_pos);
830           q -> statement_map.location = bit (text_pos, 18);
831           string (q -> statement_map.source_id) = string (p -> statement.source_id);
832           q -> statement_map.source_info.start = bit (fixed (p -> statement.source.start, 18), 18);
833           q -> statement_map.source_info.length = bit (fixed (p -> statement.source.length, 9), 9);
834           addrel (cg_stat$sym_reloc_base, cg_stat$sym_pos) -> relocation = rc_t;
835           cg_stat$sym_pos = cg_stat$sym_pos + size (q -> statement_map);
836 
837 reset:
838           cg_stat$next_ref = cg_stat$first_ref;
839      end make_map_entry;
840 
841 return_from_nonquick_procedure:
842      procedure (cb);
843 
844 dcl       cb                  ptr;                          /* (Input) */
845 
846           call gen_long_profile_for_last_statement;
847 
848           if cb -> block.options_main
849           then call expmac$zero (return_main_mac);
850           else call expmac$zero (return_mac);
851      end return_from_nonquick_procedure;
852 
853 gen_long_profile_for_last_statement:
854      procedure;
855 
856           if cg_stat$long_profile
857           then call gen_long_profile (dummy_entry_offset);
858      end gen_long_profile_for_last_statement;
859 
860 gen_long_profile:
861      procedure (offset);
862 
863 dcl       offset              fixed bin;                    /* offset of profile entry */
864 
865 dcl       1 trailer           aligned,
866             2 header_relp     fixed bin (17) unal,
867             2 entry_offset    fixed bin (17) unal;
868 
869           call expmac$zero (long_profile_mac);
870 
871           addrel (cg_stat$text_reloc_base, cg_stat$text_pos) -> relocation = rc_is18;
872           trailer.header_relp = cg_stat$profile_start;
873           trailer.entry_offset = offset;
874           call expmac$abs (addr (trailer), size (trailer));
875      end gen_long_profile;
876 
877      end compile_statement;