1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1983 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 /* format: off */
 10 
 11 /* bootload Multics qedx Editor command interface */
 12 
 13 /* Created:  April 1983 by Keith Loepere from
 14 January 1983 creation by G. Palter as part of implementation of qedx_ subroutine interface */
 15 
 16 /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */
 17 
 18 
 19 bootload_qedx:
 20      procedure (ss_info_ptr);
 21 
 22 
 23 dcl  argument character (argument_lth) unaligned based (argument_ptr);
 24 dcl  argument_ptr pointer;
 25 dcl  argument_lth fixed binary (21);
 26 dcl  (n_arguments, argument_idx) fixed binary;
 27 
 28 dcl  input_filename character (32);
 29 dcl  input_file_ptr pointer;
 30 
 31 dcl  exec_filename character (32);
 32 dcl  exec_buffer_lth fixed binary (21);
 33 dcl  exec_buffer_ptr pointer;
 34 
 35 dcl  args_buffer character (args_buffer_lth) based (args_buffer_ptr);
 36 dcl  args_buffer_lth fixed bin (21);
 37 dcl  args_buffer_used fixed binary (21);
 38 dcl  args_buffer_ptr ptr;
 39 
 40 dcl  1 local_qi aligned,                                    /* describes how we want the invocation setup */
 41        2 header like qedx_info.header,
 42        2 buffers (6) like qedx_info.buffers;                /* 0, 1, 2, 3, exec, args */
 43 
 44 dcl  ok_to_continue bit (1) aligned;
 45 
 46 dcl  (no_rw_path, have_pathname, have_macro_pathname, have_macro_arguments) bit (1) aligned;
 47 
 48 dcl  idx fixed binary;
 49 dcl  code fixed binary (35);
 50 
 51 dcl  invocation_level fixed binary static initial (0);      /* # of active invocations of qedx */
 52 
 53 dcl  NL character (1) static options (constant) initial ("
 54 ");
 55 
 56 dcl  QEDX character (32) static options (constant) initial ("bootload_qedx");
 57 
 58                                                             /* format: off */
 59 dcl (error_table_$badopt, error_table_$bigarg, error_table_$inconsistent, error_table_$noarg, error_table_$too_many_args)
 60           fixed binary (35) external;
 61 dcl  sys_info$max_seg_size fixed bin (18) static external;
 62 
 63 /* format: on */
 64 
 65 dcl  bootload_fs_$get_ptr entry (char (*), ptr, fixed bin (21), fixed bin (35));
 66 dcl  com_err_ entry () options (variable);
 67 dcl  cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35));
 68 dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
 69 dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
 70 dcl  qedx_ entry (pointer, fixed binary (35));
 71 dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
 72 dcl  (cleanup, request_abort_) condition;
 73 
 74 dcl  (divide, length, index, null, segno, substr, string) builtin;
 75 %page;
 76 /* bootload_qedx: procedure (ss_info_ptr); */
 77 
 78           call cu_$arg_count_rel (n_arguments, ss_info.arg_list_ptr, code);
 79           if code ^= 0 then do;
 80                call com_err_ (code, QEDX);
 81                signal request_abort_;
 82           end;
 83 
 84           if invocation_level > 0 then do;                  /* it would be nice to eliminate this... */
 85                call com_err_ (0, QEDX, "A suspended invocation is somehow on the stack.");
 86                return;
 87           end;
 88 
 89           invocation_level = invocation_level + 1;          /* another qedx */
 90 
 91           input_file_ptr,                                   /* for cleanup handler */
 92                exec_buffer_ptr, args_buffer_ptr = null ();
 93 
 94           on condition (cleanup) call cleanup_qedx_invocation ();
 95 
 96 
 97 /* format: off */
 98 
 99 /* Process arguments: syntax of the qedx command is --
100 
101       qedx {-control_args} {macro_path {macro_arguments}} */
102 
103 /* format: on */
104 
105           no_rw_path,                                       /* allow r/w with pathnames and R/W */
106                have_pathname,                               /* haven't seen -pathname yet */
107                have_macro_pathname,                         /* haven't seen first non-control argument yet */
108                have_macro_arguments = "0"b;                 /* haven't seen any macro arguments */
109 
110           do argument_idx = 1 to n_arguments;
111 
112                call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, ss_info.arg_list_ptr);
113                if code ^= 0 then do;                        /* sigh */
114                     call com_err_ (code, QEDX, "Fetching argument #^d.", argument_idx);
115                     go to RETURN_FROM_QEDX;
116                end;
117 
118                if ^have_macro_pathname then                 /* no non-control argument yet: can still accept -ca's */
119                     if index (argument, "-") = 1 then       /* ... a control argument */
120                          if argument = "-no_rw_path" then no_rw_path = "1"b;
121                          else if argument = "-rw_path" then no_rw_path = "0"b;
122 
123                          else if (argument = "-pathname") | (argument = "-pn") then
124                               if have_pathname then do;
125                                    call com_err_ (error_table_$too_many_args, QEDX,
126                                         """-pathname"" may only be specified once for this command.");
127                                    go to RETURN_FROM_QEDX;
128                               end;
129                               else do;                      /* initial contents for buffer 0 ... */
130                                    have_pathname = "1"b;
131                                    if argument_idx = n_arguments then do;
132                                         call com_err_ (error_table_$noarg, QEDX, "Pathname after ""^a"".", argument);
133                                         go to RETURN_FROM_QEDX;
134                                    end;
135                                    argument_idx = argument_idx + 1;
136                                    call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code,
137                                         ss_info.arg_list_ptr);
138                                    if code ^= 0 then do;
139                                         call com_err_ (code, QEDX, "Fetching argument #^d.", argument_idx);
140                                         go to RETURN_FROM_QEDX;
141                                    end;
142                                    input_filename = argument;
143                                    call bootload_fs_$get_ptr (argument, input_file_ptr, (0), code);
144                                    if code ^= 0 then do;    /* the file doesn't exist (sigh) */
145                                         call com_err_ (code, QEDX, "-pathname ^a", argument);
146                                         go to RETURN_FROM_QEDX;
147                                    end;
148                                    input_file_ptr = null ();
149                               end;
150 
151                          else do;
152                               call com_err_ (error_table_$badopt, QEDX, """^a""", argument);
153                               go to RETURN_FROM_QEDX;
154                          end;
155 
156                     else do;                                /* first non-control argument: macro pathname */
157                          have_macro_pathname = "1"b;
158                          if index (reverse (rtrim (argument)), "xdeq.") = 1 then
159                               exec_filename = argument;
160                          else exec_filename = rtrim (argument) || ".qedx";
161                          call bootload_fs_$get_ptr (exec_filename, exec_buffer_ptr, exec_buffer_lth, code);
162                          if code ^= 0 then do;              /* the file doesn't exist (sigh) */
163                               call com_err_ (code, QEDX, "Macro file: ^a", exec_filename);
164                               go to RETURN_FROM_QEDX;
165                          end;
166                     end;
167 
168                else do;                                     /* Nth non-control argument: a macro argument */
169                     if ^have_macro_arguments then do;       /* ... first macro argument */
170                          call get_temp_segment_ (QEDX, args_buffer_ptr, code);
171                          if code ^= 0 then do;
172                               call com_err_ (code, QEDX, "Obtaining buffer space for macro arguments");
173                               go to RETURN_FROM_QEDX;
174                          end;
175                          args_buffer_lth = sys_info$max_seg_size * 4;
176                          args_buffer_used = 0;
177                          have_macro_arguments = "1"b;
178                     end;
179                     call add_to_args_buffer (argument);
180                     call add_to_args_buffer (NL);
181                end;
182           end;
183 
184           if no_rw_path & ^have_pathname then do;
185                call com_err_ (error_table_$inconsistent, QEDX, """-no_rw_path"" must be used with ""-pathname"".");
186                go to RETURN_FROM_QEDX;
187           end;
188 
189 
190 /* Arguments have been validated: setup qedx_info data structure and invoke qedx_ */
191 
192           local_qi.header.version = QEDX_INFO_VERSION_1;
193           local_qi.header.editor_name = QEDX;
194 
195           string (local_qi.header.flags) = ""b;
196           local_qi.header.no_rw_path = no_rw_path;
197           local_qi.header.query_if_modified = "1"b;         /* finally after all these years ... */
198 
199           local_qi.header.n_buffers = 0;                    /* no initial buffers yet */
200 
201           if have_pathname then do;                         /* include a buffer 0 containing requested file ... */
202                local_qi.header.n_buffers, idx = 1;
203                local_qi.buffers (idx).buffer_name = "0";
204                local_qi.buffers (idx).buffer_pathname = input_filename;
205                string (local_qi.buffers (idx).flags) = ""b;
206           end;
207 
208           if have_macro_pathname then do;                   /* exec buffer containing a macro to execute ... */
209                local_qi.header.n_buffers, idx = local_qi.header.n_buffers + 1;
210                local_qi.buffers (idx).buffer_name = "exec";
211                local_qi.buffers (idx).buffer_pathname = ""; /* ... no pathname by default */
212                local_qi.buffers (idx).region_ptr = exec_buffer_ptr;
213                local_qi.buffers (idx).region_max_lth,       /* ... get size from the system */
214                     local_qi.buffers (idx).region_initial_lth = exec_buffer_lth;
215                string (local_qi.buffers (idx).flags) = ""b;
216                local_qi.buffers (idx).read_write_region, local_qi.buffers (idx).execute_buffer = "1"b;
217           end;                                              /* ... get initial content from us but can't write back */
218 
219           if have_macro_arguments then do;                  /* a "file" of arguments to the macro ... */
220                local_qi.header.n_buffers, idx = local_qi.header.n_buffers + 1;
221                local_qi.buffers (idx).buffer_name = "args";
222                local_qi.buffers (idx).buffer_pathname = ""; /* ... no pathname by default */
223                local_qi.buffers (idx).region_ptr = args_buffer_ptr;
224                local_qi.buffers (idx).region_max_lth, local_qi.buffers (idx).region_initial_lth = args_buffer_used;
225                string (local_qi.buffers (idx).flags) = ""b;
226                local_qi.buffers (idx).read_write_region = "1"b;
227           end;                                              /* ... get initial content from us but can't write back */
228 
229 
230           call qedx_ (addr (local_qi), code);               /* INVOKE THE EDITOR */
231 
232 
233 RETURN_FROM_QEDX:
234           call cleanup_qedx_invocation ();
235 
236           return;
237 %page;
238 /* Add a character string to the macro arguments buffer */
239 
240 add_to_args_buffer:
241      procedure (p_string);
242 
243 dcl  p_string character (*) parameter;
244 
245           if (args_buffer_used + length (p_string)) > length (args_buffer) then do;
246                call com_err_ (error_table_$bigarg, QEDX, "Too many macro arguments.  First failing argument: ""^a"".", argument);
247                go to RETURN_FROM_QEDX;
248           end;
249 
250           substr (args_buffer, (args_buffer_used + 1), length (p_string)) = p_string;
251           args_buffer_used = args_buffer_used + length (p_string);
252 
253           return;
254 
255      end add_to_args_buffer;
256 
257 
258 
259 /* Cleanup after an invocation of qedx */
260 
261 cleanup_qedx_invocation:
262      procedure ();
263 
264           if args_buffer_ptr ^= null () then do;
265                call release_temp_segment_ (QEDX, args_buffer_ptr, (0));
266                args_buffer_ptr = null ();
267           end;
268 
269           invocation_level = invocation_level - 1;          /* all gone */
270 
271           return;
272 
273      end cleanup_qedx_invocation;
274 %page;
275 %include qedx_info;
276 %page;
277 %include access_mode_values;
278 %page;
279 %include bce_subsystem_info_;
280 
281      end bootload_qedx;