1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19 linus_invoke:
20 proc (sci_ptr, lcb_ptr);
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49 ^L
50 %include iocb;
51 %page;
52 %include linus_lcb;
53 %page;
54 %include linus_char_argl;
55 %page;
56 %include linus_invoc_stack;
57 %page;
58 %include ssu_prompt_modes;
59 ^L
60 dcl sci_ptr ptr;
61
62 dcl STREAM_INPUT fixed bin options (constant) int static init (1);
63
64 dcl path_name char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1));
65 dcl argument char (char_argl.arg.arg_len (l)) based (char_argl.arg.arg_ptr (l));
66 dcl lcbpa char (16);
67 dcl lcbpl fixed bin (21);
68 dcl macro_path char (168);
69 dcl macro_arg char (mac_len) based (mac_ptr);
70 dcl popped_on_pi bit (1);
71 dcl scipa char (16);
72 dcl scipl fixed bin (21);
73 dcl static_sci_ptr ptr int static;
74 dcl temp_lcb_ptr ptr;
75 dcl tmp_char char (char_argl.arg.arg_len (l + 1)) based (char_argl.arg.arg_ptr (l + 1));
76
77 dcl attach_description char (37);
78 dcl sw_name char (32);
79 dcl dot_linus char (6);
80 dcl (
81 iocb_ptr init (null),
82 ref_ptr init (null),
83 mac_ptr init (null),
84 env_ptr init (null),
85 tmp_ptr init (null)
86 ) ptr;
87 dcl (l, i) fixed bin;
88 dcl (addr, before, fixed, null, rel, substr) builtin;
89 dcl (icode, code, mac_len, out_code) fixed bin (35);
90 dcl (
91 error_table_$not_attached,
92 linus_error_$no_input_arg,
93 linus_error_$too_many_invocs,
94 sys_info$max_seg_size,
95 linus_data_$i_id,
96 linus_data_$max_invocs
97 ) fixed bin (35) ext;
98 dcl cleanup condition;
99 dcl unique_chars_ entry (bit (*)) returns (char (15));
100 dcl cu_$decode_entry_value entry (entry, ptr, ptr);
101 dcl ioa_$rsnnl entry () options (variable);
102 dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
103 dcl iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35));
104 dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
105 dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35));
106 dcl iox_$move_attach entry (ptr, ptr, fixed bin (35));
107 dcl iox_$detach_iocb entry (ptr, fixed bin (35));
108 dcl iox_$destroy_iocb entry (ptr, fixed bin (35));
109 dcl iox_$close entry (ptr, fixed bin (35));
110 dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35));
111 dcl ssu_$abort_line entry options (variable);
112 dcl ssu_$abort_subsystem entry options (variable);
113 dcl ssu_$arg_count entry (ptr, fixed bin);
114 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
115 dcl ssu_$get_info_ptr entry (ptr) returns (ptr);
116 dcl ssu_$set_prompt_mode entry (ptr, bit (*));
117 dcl iox_$user_input ext ptr;
118 ^L
119 ca_ptr = null;
120
121 mac_len, icode = 0;
122
123 on cleanup call clean_up;
124
125 static_sci_ptr = sci_ptr;
126
127 call ssu_$arg_count (sci_ptr, nargs_init);
128 if nargs_init = 0 then
129 call error (linus_error_$no_input_arg, "");
130 if lcb.ivs_ptr ^= null then do;
131 ivs_ptr = lcb.ivs_ptr;
132 if invoc_stack.ninvocs ^< linus_data_$max_invocs then
133 call error (linus_error_$too_many_invocs, "");
134 end;
135 else do;
136 allocate invoc_stack in (lcb.static_area);
137 lcb.ivs_ptr = ivs_ptr;
138 invoc_stack.ninvocs = 0;
139 end;
140 dot_linus = " ";
141 allocate char_argl in (lcb.static_area);
142 do i = 1 to nargs_init;
143 call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i));
144 end;
145 if char_argl.arg.arg_len (1) > 6 then
146 dot_linus = substr (path_name, char_argl.arg.arg_len (1) - 5);
147 if dot_linus ^= ".linus" then
148 macro_path = path_name || ".linus";
149 else macro_path = path_name;
150 call cu_$decode_entry_value (linus_invoke, ref_ptr, env_ptr);
151 sw_name = unique_chars_ ("0"b) || ".linus_invoke";
152 call ioa_$rsnnl ("^p", lcbpa, lcbpl, lcb_ptr);
153 call ioa_$rsnnl ("^p", scipa, scipl, sci_ptr);
154 call iox_$attach_name (sw_name, iocb_ptr,
155 "linus_invoke_ " || macro_path || " " || substr (lcbpa, 1, lcbpl) || " " || substr (scipa, 1, scipl),
156 ref_ptr, icode);
157 if icode ^= 0 then
158 call error (icode, before (macro_path, " "));
159 call iox_$open (iocb_ptr, STREAM_INPUT, "0"b, icode);
160 if icode ^= 0 then
161 call error (icode, before (macro_path, " "));
162
163 if invoc_stack.ninvocs = 0
164 then do;
165 sw_name = unique_chars_ ("0"b) || ".linus_input";
166
167 call iox_$find_iocb (sw_name, lcb.actual_input_iocbp, icode);
168 if icode ^= error_table_$not_attached & icode ^= 0
169 then call error (icode, "Creating IO control block.");
170 call iox_$move_attach (iox_$user_input, lcb.actual_input_iocbp, icode);
171 if icode ^= 0
172 then call error (icode, "Moving attachment of user input.");
173 end;
174 else do;
175 call iox_$detach_iocb (iox_$user_input, icode);
176 if icode ^= 0
177 then call error (icode, "Detaching user input.");
178 end;
179 attach_description = "syn_ " || iocb_ptr -> iocb.name;
180 call iox_$attach_ptr (iox_$user_input, attach_description, ref_ptr, icode);
181 if icode ^= 0
182 then call error (icode, "Attaching user input.");
183
184 invoc_stack.ninvocs = invoc_stack.ninvocs + 1;
185 invoc_stack.invoc.iocb_ptr (invoc_stack.ninvocs) = lcb.is_ptr;
186 lcb.is_ptr = iocb_ptr;
187 invoc_stack.invoc.arg_ptr (invoc_stack.ninvocs) = lcb.cal_ptr;
188 if char_argl.nargs = 1 then
189 lcb.cal_ptr = null;
190 else do;
191 nargs_init = char_argl.nargs - 1;
192 allocate char_argl in (lcb.static_area) set (tmp_ptr);
193 do l = 1 to nargs_init;
194 tmp_ptr -> char_argl.nargs = l;
195 mac_len, tmp_ptr -> char_argl.arg.arg_len (l) = char_argl.arg.arg_len (l + 1);
196 allocate macro_arg in (lcb.static_area);
197 macro_arg = tmp_char;
198 tmp_ptr -> char_argl.arg.arg_ptr (l) = mac_ptr;
199 mac_ptr = null;
200 end;
201 lcb.cal_ptr = tmp_ptr;
202 tmp_ptr = null;
203 end;
204
205 call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT);
206
207 if ca_ptr ^= null
208 then free char_argl;
209 return;
210 ^L
211 error:
212 proc (err_code, string);
213
214 dcl err_code fixed bin (35);
215 dcl string char (*);
216
217 call clean_up;
218 call linus_convert_code (err_code, out_code, linus_data_$i_id);
219 call ssu_$abort_line (sci_ptr, out_code, string);
220
221 end error;
222 ^L
223 clean_up:
224 proc;
225
226 dcl i fixed bin;
227
228 if mac_ptr ^= null then
229 free macro_arg;
230 if tmp_ptr ^= null then do;
231 do i = 1 to tmp_ptr -> char_argl.nargs;
232 mac_ptr = tmp_ptr -> char_argl.arg.arg_ptr (i);
233 mac_len = tmp_ptr -> char_argl.arg.arg_len (i);
234 free macro_arg;
235 end;
236 free tmp_ptr -> char_argl;
237 end;
238 if ca_ptr ^= null
239 then free char_argl;
240
241 end clean_up;
242 ^L
243 pop:
244 entry (lcb_ptr, code);
245
246 code = 0;
247 ivs_ptr = lcb.ivs_ptr;
248 if lcb.cal_ptr ^= null then do;
249 do i = 1 to lcb.cal_ptr -> char_argl.nargs;
250 mac_len = lcb.cal_ptr -> char_argl.arg.arg_len (i);
251 mac_ptr = lcb.cal_ptr -> char_argl.arg.arg_ptr (i);
252 free macro_arg;
253 end;
254 free lcb.cal_ptr -> char_argl;
255 end;
256 call iox_$close (lcb.is_ptr, icode);
257 if icode ^= 0 then
258 call error (icode, "");
259 else call iox_$detach_iocb (lcb.is_ptr, icode);
260 if icode ^= 0 then
261 call error (icode, "");
262 lcb.cal_ptr = invoc_stack.invoc.arg_ptr (invoc_stack.ninvocs);
263
264 lcb.is_ptr = invoc_stack.invoc.iocb_ptr (invoc_stack.ninvocs);
265
266 call iox_$detach_iocb (iox_$user_input, code);
267 if code = 0
268 then do;
269
270 if lcb.is_ptr ^= iox_$user_input
271 then do;
272 attach_description = "syn_ " || lcb.is_ptr -> iocb.name;
273 call iox_$attach_ptr (iox_$user_input, attach_description, ref_ptr, code);
274 end;
275 else do;
276 call iox_$move_attach (lcb.actual_input_iocbp, iox_$user_input, code);
277 if code = 0
278 then call iox_$destroy_iocb (lcb.actual_input_iocbp, code);
279 end;
280 end;
281 invoc_stack.ninvocs = invoc_stack.ninvocs - 1;
282 if invoc_stack.ninvocs = 0 then do;
283 free invoc_stack;
284 lcb.ivs_ptr = null;
285 end;
286 return;
287 ^L
288 pop_all_on_pi:
289 entry (sci_ptr);
290
291 temp_lcb_ptr = ssu_$get_info_ptr (sci_ptr);
292 popped_on_pi = "1"b;
293 goto common_pop_all;
294
295 pop_all:
296 entry (lcb_ptr, code);
297
298
299 code = 0;
300 temp_lcb_ptr = lcb_ptr;
301 popped_on_pi = "0"b;
302
303 common_pop_all:
304 if temp_lcb_ptr -> lcb.is_ptr ^= iox_$user_input then do;
305 call iox_$close (temp_lcb_ptr -> lcb.is_ptr, icode);
306 call iox_$detach_iocb (temp_lcb_ptr -> lcb.is_ptr, icode);
307 temp_lcb_ptr -> lcb.is_ptr = iox_$user_input;
308 if temp_lcb_ptr -> lcb.cal_ptr ^= null then do;
309 ca_ptr = temp_lcb_ptr -> lcb.cal_ptr;
310 do l = 1 to char_argl.nargs;
311 free argument;
312 end;
313 free char_argl;
314 temp_lcb_ptr -> lcb.cal_ptr = null;
315 end;
316 if temp_lcb_ptr -> lcb.ivs_ptr ^= null then do;
317 ivs_ptr = temp_lcb_ptr -> lcb.ivs_ptr;
318 do i = 2 to invoc_stack.ninvocs;
319 call iox_$close (invoc_stack.invoc.iocb_ptr (i), icode);
320 call iox_$detach_iocb (invoc_stack.iocb_ptr (i), icode);
321 if invoc_stack.invoc.arg_ptr (i) ^= null then do;
322 ca_ptr = invoc_stack.invoc.arg_ptr (i);
323 do l = 1 to char_argl.nargs;
324 free argument;
325 end;
326 free char_argl;
327 end;
328 end;
329 free invoc_stack;
330 temp_lcb_ptr -> lcb.ivs_ptr = null;
331 end;
332 call iox_$detach_iocb (iox_$user_input, icode);
333 if icode = 0
334 then call iox_$move_attach (temp_lcb_ptr -> lcb.actual_input_iocbp, iox_$user_input, icode);
335 if icode = 0
336 then call iox_$destroy_iocb (temp_lcb_ptr -> lcb.actual_input_iocbp, icode);
337 if icode = 0
338 then do;
339 if temp_lcb_ptr -> lcb.prompt_flag
340 then call ssu_$set_prompt_mode (static_sci_ptr, PROMPT | DONT_PROMPT_AFTER_NULL_LINES | PROMPT_IF_TYPEAHEAD);
341 end;
342 else if popped_on_pi
343 then call ssu_$abort_subsystem (sci_ptr, icode);
344 else code = icode;
345 end;
346
347
348 end linus_invoke;