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 initialize_peek_limits:  proc;
 12 
 13 /* Program to define regions of hardcore which can be accessed
 14    via metering_ring_zero_peek_.  The latter is a ring-1 gate
 15    which calls a routine to "filter" ring_zero_peek_ requests for
 16    users who do not have access to phcs_ (of course, such users must
 17    have access to metering_ring_zero_peek_).
 18 
 19    This program builds a table of accessible regions from an ASCII
 20    segment.  This table resides in >sl1>ring_zero_meter_limits.table.
 21    This program should be run as part of system_start_up.ec.  Until it
 22    runs, no hardcore area is available via metering_ring_zero_peek_.
 23 
 24    Command call sequence:
 25 
 26           initialize_peek_limits <pathname>
 27 
 28    where <pathname> is the path name of the ASCII segment.  Normally,
 29    <pathname> is >system_library_1>ring_zero_meter_limits.ascii, which
 30    is loaded from Collection 3; however, it can be site-supplied.
 31 
 32    The format of the ASCII segment is as follows.  There is a statement
 33    for each hardcore region, in one of the following forms:
 34 
 35      <segment> : <begin> <length>;
 36 
 37      <segment> : <begin> <end>;
 38 
 39      <segment> : <end>;
 40 
 41      <segment> : <length>;
 42 
 43      <segment> : ;
 44 
 45    where
 46 
 47           <segment> is either the name of a hardcore segment or a hardcore
 48                     segment number
 49           <begin>   is either an offset into the segment (decimal) which is
 50                     the first word of an accessible region, or the name of
 51                     an externally accessible symbol in the segment which
 52                     represents the first word of an accessible region
 53           <length>  is the length of the accessible region in words
 54           <end>     is the name of an externally accessible symbol in the segment which
 55                     represents the first word beyond the end of the accessible
 56                     region.
 57 
 58    If <begin> is not supplied, the accessible region is assumed to begin at offset
 59    0 within the segment.  If only <segment> is supplied, the accessible region is
 60    the entire segment.
 61 
 62    Written December 80 by J. Bongiovanni
 63 
 64 */
 65 
 66 /*^L*/
 67 
 68 /* Automatic */
 69 
 70 dcl abs_filename char (168);
 71 dcl any_parse bit (1);
 72 dcl bc fixed bin (24);
 73 dcl begin_offset fixed bin (18);
 74 dcl code fixed bin (35);
 75 dcl delim_type fixed bin;
 76 dcl dirname char (168);
 77 dcl end_offset fixed bin (18);
 78 dcl entryname char (32);
 79 dcl field_ptr ptr;
 80 dcl field_l fixed bin (21);
 81 dcl field_type fixed bin;
 82 dcl filename_l fixed bin (21);
 83 dcl filename_p ptr;
 84 dcl file_l fixed bin (21);
 85 dcl file_ptr ptr;
 86 dcl high_seg fixed bin;
 87 dcl ignore bit (1);
 88 dcl low_seg fixed bin;
 89 dcl marrayp ptr;
 90 dcl nargs fixed bin;
 91 dcl one_begin bit (1);
 92 dcl one_seg bit (1);
 93 dcl rcode fixed bin (35);
 94 dcl seg_no fixed bin;
 95 dcl seg_ptr ptr;
 96 dcl type fixed bin;
 97 
 98 /* Static */
 99 
100 dcl LIMITSEG_DIR char (17) init (">system_library_1") int static options (constant);
101 dcl LIMITSEG_NAME char (28) init ("ring_zero_meter_limits.table");
102 dcl MAX_OFFSET fixed bin (19) init (262143) int static options (constant);
103 dcl my_name char (22) init ("initialize_peek_limits") int static options (constant);
104 dcl (NUMERIC init (0), NON_NUMERIC init (1)) fixed bin int static options (constant);
105 dcl (SEMI init (1), COLON init (2), WHITE_SPACE init (3),
106           END_OF_SCAN init (4)) fixed bin int static options (constant);
107 
108 /* Based */
109 
110 dcl field char (field_l) based (field_ptr);
111 dcl filename char (filename_l) based (filename_p);
112 
113 %include meter_limits;
114 
115 dcl 1 meter_limits_array (0:1) aligned based (marrayp) like meter_limits_entry;
116 
117 /* Entry */
118 
119 dcl com_err_ entry options (variable);
120 dcl cu_$arg_count entry (fixed bin);
121 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
122 dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
123 dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35));
124 dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin);
125 dcl hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35));
126 dcl hcs_$terminate_noname entry (ptr, fixed bin(35));
127 dcl installation_tools_$patch_path entry (char(*), char(*), fixed bin (18),
128      ptr, fixed bin (18), fixed bin (35));
129 dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35));
130 dcl ring0_get_$definition entry (ptr, char(*), char(*), fixed bin(18), fixed bin, fixed bin (35));
131 dcl ring0_get_$segptr entry (char(*), char(*), ptr, fixed bin (35));
132 
133 
134 /* External */
135 
136 dcl error_table_$badsyntax fixed bin (35) external;
137 dcl error_table_$segknown fixed bin (35) external;
138 dcl error_table_$zero_length_seg fixed bin (35) external;
139 
140 /* Condition */
141 
142 dcl cleanup condition;
143 dcl size condition;
144 
145 /* Builtin */
146 
147 dcl addr builtin;
148 dcl baseno builtin;
149 dcl baseptr builtin;
150 dcl bin builtin;
151 dcl currentsize builtin;
152 dcl divide builtin;
153 dcl fixed builtin;
154 dcl index builtin;
155 dcl null builtin;
156 dcl ptr builtin;
157 dcl rel builtin;
158 dcl rtrim builtin;
159 dcl search builtin;
160 dcl verify builtin;
161 
162 
163 /*^L*/
164 code = 0;
165 file_ptr, mtablep = null();
166 
167 on cleanup call Mr_Clean;
168 
169 call get_temp_segment_ (my_name, mtablep, code);
170 if code^=0 then call Complain ("Cannot get temp segment");
171 meter_limits_table.initialized = "1"b;
172 
173 call hcs_$high_low_seg_count (high_seg, low_seg);
174 meter_limits_table.high_seg_no = low_seg - 1;               /* highest supervisor seg number                  */
175 marrayp = ptr (mtablep, currentsize (meter_limits_table));  /* first allocatable entry                        */
176 
177 
178 call cu_$arg_count (nargs);
179 if nargs^=1 then
180      call Complain ("Usage is:   initialize_peek_limits <pathname of source>");
181 call cu_$arg_ptr (1, filename_p, filename_l, code);
182 
183 call expand_pathname_ (filename, dirname, entryname, code);
184 if code^=0 then call Complain (filename);
185 abs_filename = rtrim (dirname) || ">" || rtrim (entryname);
186 
187 call hcs_$initiate_count (dirname, entryname, "", bc, 0, file_ptr, code);
188 if code^=0&code^=error_table_$segknown
189      then call Complain (abs_filename);
190 if bc=0 then do;
191      code = error_table_$zero_length_seg;
192      call Complain (abs_filename);
193 end;
194 
195 file_l = divide (bc, 9, 21);
196 
197 /* ^L */
198 /* romp through input file and build table of allowable peek regions                                          */
199 
200 delim_type = 0;
201 seg_no = -1;
202 begin_offset = 0;
203 end_offset = MAX_OFFSET;
204 any_parse, one_seg, one_begin, ignore = "0"b;
205 on size goto syntax_error;
206 
207 do while (delim_type^=END_OF_SCAN);
208      call next_field (file_ptr, file_l, field_ptr, field_l, delim_type, field_type);
209      if delim_type = COLON then do;                         /* field is segment name or number                */
210           if^ignore then do;
211                any_parse = "1"b;
212                if one_seg then do;                          /* already have segment name or number            */
213 syntax_error:       code = error_table_$badsyntax;
214                     call Complain (abs_filename);
215                end;
216                if field_type = NUMERIC
217                     then seg_no = fixed (field, 17);
218                else do;
219                     call ring0_get_$segptr ("", field, seg_ptr, rcode);
220                     if rcode^=0 then do;
221                          call com_err_ (0, my_name, "Segment ^a not found.", field);
222                          ignore = "1"b;
223                     end;
224                     seg_no = bin (baseno (seg_ptr), 17);
225                end;
226                one_seg = "1"b;
227           end;
228      end;
229      else if delim_type = WHITE_SPACE then do;    /* begin offset or symbol                         */
230           if ^ignore then do;
231                any_parse = "1"b;
232                if one_begin then goto syntax_error;
233                if seg_no = -1 then goto syntax_error;
234                if field_type = NUMERIC then begin_offset = fixed (field, 18);
235                else do;
236                     call ring0_get_$definition (baseptr (seg_no), "",
237                          field, begin_offset, type, rcode);
238                     if rcode^=0 then do;
239                          call com_err_ (0, my_name, "Symbol ^a not found.",
240                               field);
241                          ignore = "1"b;
242                     end;
243                end;
244                one_begin = "1"b;
245           end;
246      end;
247      else if delim_type = SEMI then do;           /* end symbol or length                           */
248           if ^ignore then do;
249                if seg_no = -1 then goto syntax_error;
250                if field^="" then do;              /* no end or length => whole segment accessible   */
251                     if field_type=NUMERIC then do;
252                          if fixed (field, 18)>= MAX_OFFSET+1 then goto syntax_error;
253                          end_offset = begin_offset + fixed (field) -1;
254                     end;
255                     else do;
256                          call ring0_get_$definition (baseptr (seg_no),
257                               "", field, end_offset, type, rcode);
258                          if rcode^=0 then do;
259                               call com_err_ (0, my_name, "Symbol ^a not found.",
260                                    field);
261                               ignore = "1"b;
262                          end;
263                          end_offset = end_offset - 1;
264                     end;
265                end;
266           end;
267           if ^ignore then do;
268                if seg_no<0 | seg_no>meter_limits_table.high_seg_no
269                     then goto syntax_error;
270                if begin_offset>end_offset then goto syntax_error;
271                mentryp = marrayp;
272                meter_limits_entry.thread = meter_limits_table.thread_head (seg_no);
273                meter_limits_entry.begin_offset = begin_offset;
274                meter_limits_entry.end_offset = end_offset;
275                meter_limits_table.thread_head (seg_no) = fixed (rel (mentryp));
276                marrayp = addr (meter_limits_array (1));/* point to next free                        */
277           end;
278 
279           ignore, any_parse, one_seg, one_begin = "0"b;
280           begin_offset = 0;
281           end_offset = MAX_OFFSET;
282      end;
283      else if any_parse then goto syntax_error;    /* end of text in middle of statement             */
284 end;
285 
286 revert size;
287 
288 call installation_tools_$patch_path (LIMITSEG_DIR, LIMITSEG_NAME, 0,
289      mtablep, bin (rel (marrayp), 18), code);
290 if code^=0 then call Complain ("Cannot copy into " || rtrim (LIMITSEG_DIR)
291      || ">" || rtrim (LIMITSEG_NAME));
292 
293 call Mr_Clean;
294 
295 
296 EXIT:
297 return;
298 
299 /*^L*/
300 /* Internal procedure to print an error message and terminate */
301 
302 Complain:
303      proc (why);
304 
305 
306 dcl why char (*);
307 
308 call com_err_ (code, my_name, why);
309 goto EXIT;
310 
311 end Complain;
312 
313 
314 /* Internal procedure to clean up before quitting (normal or otherwise */
315 
316 Mr_Clean:
317      proc;
318 
319 dcl acode fixed bin (35);
320 
321 if file_ptr^=null()
322      then call hcs_$terminate_noname (file_ptr, acode);
323 if mtablep^=null()
324      then call release_temp_segment_ (my_name, mtablep, acode);
325 
326 
327 end Mr_Clean;
328 
329 
330 /* ^L*/
331 /* Internal procedure to scan a text for the next field, return
332    that field, and an indication of the delimeter following
333    the field.  Additionally, the text pointers are updated
334    for the next call.  In this scan, PL1-type comments
335    are bypassed                                                                                               */
336 
337 next_field:
338           proc (scan_ptr, scan_len, field_ptr, field_len, del_type, field_type);
339 
340 dcl scan_ptr ptr;                                           /* pointer to start of text                       */
341 dcl scan_len fixed bin (21);                                /* length of text                                 */
342 dcl field_ptr ptr;                                          /* pointer to start of field                      */
343 dcl field_len fixed bin (21);                               /* length of field                                */
344 dcl del_type fixed bin;                                     /* indicates delimeter following field            */
345 dcl field_type fixed bin;                                   /* indicates numeric or non-numeric               */
346 
347 
348 
349 dcl l fixed bin;
350 
351 dcl DELIM char (5) init ("
352           :;") int static options (constant);               /* space, NL, TAB, :, ;                           */
353 dcl WS_DELIM char (3) init ("
354           ") int static options (constant);                 /* space, NL, TAB                                 */
355 
356 dcl field char (field_len) based (field_ptr);
357 dcl next_1 char (1) based (scan_ptr);
358 dcl next_2 char (2) based (scan_ptr);
359 dcl scan char (scan_len) based (scan_ptr);
360 dcl scan_array (scan_len) char (1) based (scan_ptr);
361 
362 
363 if scan_len<=0 then do;
364 zero_length:
365      delim_type = END_OF_SCAN;
366      return;
367 end;
368 if ^remove_white_space() then goto zero_length;             /* ran out of text                                */
369 
370 field_ptr = scan_ptr;
371 l = search (scan, DELIM);                                   /* look for delimeter after field                 */
372 if l=0 then field_len = scan_len;                           /* text ends with this field                      */
373 else field_len = l-1;
374 scan_ptr = addr (scan_array (field_len+1));                 /* next place to look for field                   */
375 scan_len = scan_len - field_len;                            /* remaining chars in text                        */
376 
377 if ^remove_white_space()                                    /* only white space remaining in text             */
378      then del_type = WHITE_SPACE;
379 else if next_1=";" then del_type = SEMI;
380 else if next_1=":" then del_type = COLON;
381 else del_type = WHITE_SPACE;
382 
383 if del_type^=WHITE_SPACE then do;                                     /* bump pointer past delimeter                    */
384      scan_ptr = addr (scan_array (2));
385      scan_len = scan_len - 1;
386 end;
387 
388 if verify (field, "0123456789") = 0
389      then field_type = NUMERIC;
390 else field_type = NON_NUMERIC;
391 
392 
393 return;
394 
395 
396 
397 /* Internal procedure to next_field which removes white space
398    by adjusting scan_ptr and scan_len to skip over such.
399    PL1-type comments are also bypassed here.  A bit(1) value
400    is returned to indicate end of text - "0"b for end-of-text,
401    "1"b otherwise                                                                                             */
402 
403 remove_white_space:
404           proc returns (bit (1));
405 
406 dcl l fixed bin (21);
407 
408 
409 
410 do while ("1"b);
411      if scan_len<=0 then do;                                /* no text left--easy case                        */
412 return_empty:
413           scan_ptr = addr (scan_array (scan_len + 1));
414           scan_len = 0;                                     /* set end of text                                */
415           return ("0"b);
416      end;
417 
418      l = verify (scan, WS_DELIM);
419      if l=0 then goto return_empty;                         /* ran out of text                                */
420      scan_ptr = addr (scan_array (l));                      /* point to first non-delimeter                   */
421      scan_len = scan_len-l+1;
422      if next_2="/*" then do;                               /* PL1-type comment                                */
423           l = index (scan, "*/");                           /* end of comment                                 */
424           if l=0 then return ("0"b);                        /* no end of comment                              */
425           scan_ptr = addr (scan_array (l+2));               /* point to 1st character past end of comment     */
426           scan_len = scan_len-l-1;
427      end;
428      else return ("1"b);
429 end;
430 
431 end remove_white_space;
432 
433 
434 end next_field;
435 
436 end initialize_peek_limits;