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 /*        This procedure and entries manage the multiple segments used for free
 12    storage by the pl1 and fortran compilers.                          */
 13 
 14 /*        Extensively rewritten to use standard no-free areas for the
 15 compiler's own storage and thus eliminate the compiler's use of
 16 the "rename" option in April,1976 by RHS.
 17 
 18           Modified: 4 May 1977 by RAB for new release_area_ protocol  */
 19 
 20 tree_manager$init: proc (abort_label_par);
 21 
 22 dcl  abort_label_par label;
 23 
 24 dcl  abort_label label internal static;
 25 
 26 dcl  pl1_stat_$condition_index fixed bin (31) ext static,
 27      pl1_stat_$root ptr ext static,
 28      pl1_stat_$free_ptr (18) ptr ext static;
 29 
 30 dcl  sys_info$max_seg_size ext static fixed bin (35);
 31 
 32 dcl  i fixed bin (17);
 33 dcl  code fixed bin (35);
 34 
 35 
 36 dcl  first_time bit (1) aligned internal static init ("1"b);
 37 
 38 dcl (null, addr, ptr, substr, unspec) builtin;
 39 
 40 
 41 dcl  define_area_ external entry (ptr, fixed bin (35)),
 42      release_area_ external entry (ptr),
 43      ioa_ entry options (variable);
 44 
 45 %include area_info;
 46 %include pl1_tree_areas;
 47 
 48 dcl 1 my_area_info like area_info internal static;
 49 
 50 
 51 %include token_list;
 52 %include source_list;
 53 
 54           abort_label = abort_label_par;                    /* Where to go if call to define or release_area fails. */
 55 
 56           if pl1_stat_$tree_area_ptr ^= null
 57           then call release_area_ (pl1_stat_$tree_area_ptr);
 58 
 59           if pl1_stat_$xeq_tree_area_ptr ^= null
 60           then call release_area_ (pl1_stat_$xeq_tree_area_ptr);
 61 
 62 
 63           if first_time
 64           then do;
 65                unspec (my_area_info) = "0"b;
 66                my_area_info.version = 1;
 67                my_area_info.extend = "1"b;
 68                my_area_info.no_freeing = "1"b;
 69                my_area_info.owner = "pl1";
 70                my_area_info.size = sys_info$max_seg_size;
 71                first_time = "0"b;
 72           end;
 73 
 74 
 75           my_area_info.areap = null;
 76 
 77           call define_area_ (addr (my_area_info), code);
 78 
 79           if code ^= 0
 80           then goto call_failed;
 81 
 82           pl1_stat_$tree_area_ptr = my_area_info.areap;
 83 
 84           allocate source_list in (tree_area) set (pl1_stat_$source_list_ptr);
 85 
 86           allocate token_list in (tree_area) set (pl1_stat_$token_list_ptr);
 87 
 88           my_area_info.areap = null;
 89 
 90           call define_area_ (addr (my_area_info), code);
 91 
 92           if code ^= 0
 93           then goto call_failed;
 94 
 95           pl1_stat_$xeq_tree_area_ptr = my_area_info.areap;
 96 
 97 tr:
 98           do i = 1 to 18;
 99                pl1_stat_$free_ptr (i) = null;
100           end;
101 
102           pl1_stat_$condition_index = 0;
103 
104           return;
105 
106 call_failed:
107           call ioa_ ("Compiler failed in allocating temporary storage.");
108           goto abort_label;
109 
110 tree_manager$truncate: entry;
111 
112           pl1_stat_$root = null;
113           if pl1_stat_$tree_area_ptr ^= null
114           then call release_area_ (pl1_stat_$tree_area_ptr);
115           if pl1_stat_$xeq_tree_area_ptr ^= null
116           then call release_area_ (pl1_stat_$xeq_tree_area_ptr);
117 
118           goto tr;
119 
120      end;