1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 /* Command program for Version 2 APL
 11    Modified 19 January 1974 by PG to call apl_attach_streams_.
 12    Modified 740322 by PG to properly return code in subsystem entry.
 13    Modified in July 1974 by G. Gordon Benedict to remove change_ops call and to change call to
 14    create_apl_workspace_ to be a call to apl_create_workspace_.
 15    Modified 741017 by PG for -temp_dir option, and recursive capability.
 16    Modified 750904 by PG to make -terminal_type (-ttp) synonym for -device.
 17    Modified 761006 by PG to add -iip to aid Questa.
 18    Modified 780901 by PG to delete -iip (didn't really help), and fix bug 329.
 19    Modified 790110 by WMY to fix bug 363 (apl_subsystem_ dies if there is no continue workspace
 20           for the user).
 21    Modified 790213 by WMY to call file system to untie all files upon exiting APL.
 22    Modified 790322 by PG to update -ttp error message to include latest terminal types.
 23    Modified 791219 by PG to print version number before trying to autoload the ws.
 24    Modified 800411 by PG to say adieu!
 25    Modified 800814 by WMY to refuse gracefully when invoked as an active
 26           function (bug 464).
 27    Modified 811210 by TO to include CR in input prompt.
 28 */
 29 
 30 apl:
 31 v2apl:
 32      procedure ();
 33 
 34           /* Check for invocation as an active function and complain */
 35 
 36           call cu_$af_arg_count ((0), code);
 37           if code ^= error_table_$not_act_fnc
 38                then do;
 39                     call active_fnc_err_ (0, "apl", "Cannot be called as an active function.");
 40                     return;
 41                end;
 42 
 43           autoload_ws = "continue";
 44           autoload_lock = "";
 45           devicename = "";
 46           temporary_segments_dir = get_pdir_ ();
 47 
 48           string (command_options.flags) = ""b;
 49           command_options.user_number = 100;
 50 
 51           do argno = 1 to cu_$arg_count ();
 52 
 53                call cu_$arg_ptr (argno, argp, argl, code);
 54                if code ^= 0
 55                then go to nomoreargsIguess;
 56 
 57                if arg = "-db" | arg = "-debug"
 58                then flags.debug_mode = "1"b;
 59 
 60                else if arg = "-nqh" | arg = "-no_quit_handler"
 61                then flags.no_quit_handler = "1"b;
 62 
 63                else if arg = "-bfe" | arg = "-brief_errors" | arg = "-bf" | arg = "-brief"
 64                                                             /* -bf, -brief for compat. */
 65                then flags.long_error_mode = "0"b;
 66 
 67                else if arg = "-lge" | arg = "-long_errors" | arg = "-lg" | arg = "-long"
 68                                                             /* -lg, -long for compat. */
 69                then flags.long_error_mode = "1"b;
 70 
 71                else if arg = "-ck" | arg = "-check"
 72                then flags.compatibility_check_mode = "1"b;
 73 
 74                else if arg = "-meter"
 75                then flags.meter_mode = "1"b;
 76 
 77                else if arg = "-ttp" | arg = "-terminal_type"
 78                then do;
 79                          argno = argno + 1;
 80                          call cu_$arg_ptr (argno, argp, argl, code);
 81                          if code ^= 0
 82                          then do;
 83                                    call com_err_ (code, "apl", "-terminal_type must be followed by terminal name.
 84 Possible names are: 1050, 2741, CORR2741, 1030, TEK4013, TEK4015, TN300,
 85 ARDS, ASCII, TTY33, TTY38, TYPEPAIRED, BITPAIRED, TELERAY11, LA36.");
 86                                    return;
 87                               end;
 88 
 89                          devicename = arg;
 90                     end;
 91 
 92                else if arg = "-user_number"
 93                then do;
 94                          argno = argno + 1;
 95                          call cu_$arg_ptr (argno, argp, argl, code);
 96                          if code ^= 0
 97                          then do;
 98                                    call com_err_ (code, "apl", "-user_number must be followed by a decimal integer.");
 99                                    return;
100                               end;
101 
102                          command_options.user_number = cv_dec_check_ (arg, code);
103                          if code ^= 0 | command_options.user_number <= 0
104                          then do;
105                                    call com_err_ (0, "apl", "Invalid user number.  ^a", arg);
106                                    return;
107                               end;
108                     end;
109 
110                else if arg = "-temp_dir" | arg = "-td"
111                then do;
112                          argno = argno + 1;
113                          call cu_$arg_ptr (argno, argp, argl, code);
114                          if code ^= 0
115                          then do;
116                                    call com_err_ (code, "apl", "-temp_dir must be followed by directory pathname.");
117                                    return;
118                               end;
119 
120                          call absolute_pathname_ (arg, temporary_segments_dir, code);
121                          if code ^= 0
122                          then do;
123                                    call com_err_ (code, "apl", "^a", arg);
124                                    return;
125                               end;
126                     end;
127 
128                else if substr (arg, 1, 1) = "-"             /* must be misspelled control arg */
129                then do;
130                          call com_err_ (error_table_$badopt, "apl", "^a", arg);
131                          return;
132                     end;
133 
134                else do;
135                          autoload_ws = before (arg, ":");
136                          autoload_lock = after (arg, ":");
137                     end;
138           end;
139 
140 nomoreargsIguess:
141           save_ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr;
142                                                             /* copy old ws info ptr into our stack frame. */
143 
144           on cleanup
145                call clean_up;                               /* handler to revert I/O streams & throw away ws. */
146 
147           apl_static_$immediate_input_prompt = byte (13) || (6)" ";   /* kludge */
148 
149           call initialize_apl (temporary_segments_dir, devicename, code);
150                                                             /* create the workspace, attach the dim. */
151           if code ^= 0
152           then do;
153                     call com_err_ (code, "apl", "Unable to initialize apl.");
154                     apl_static_$ws_info_ptr.static_ws_info_ptr = save_ws_info_ptr;
155                                                             /* just in case */
156                     return;
157                end;
158 
159           ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr;
160                                                             /* refresh auto copy */
161           string (ws_info.switches) = string (command_options.flags);
162           ws_info.user_number = command_options.user_number;
163 
164           call ioa_$ioa_switch (apl_static_$apl_output, "apl ^a^/", apl_static_$version_number);
165 
166           call apl_load_command_$autoload (autoload_ws, autoload_lock, code);
167           if code ^= 0 & code ^= apl_error_table_$cant_autoload
168           then do;
169                     call com_err_ (code, "apl", "^a", autoload_ws);
170                     call clean_up;
171                     return;
172                end;
173 
174           call apl_parse_;
175 
176           if ws_info.signoff_lock ^= ""
177           then call ioa_$ioa_switch (apl_static_$apl_output, "apl: signoff lock ignored.");
178 
179           call clean_up;
180           return;
181 ^L
182 clean_up:
183      procedure ();
184 
185           call apl_file_system_$untie_all_files;
186 
187           if detach_streams                                 /* if we attached them, we detach them. */
188           then do;
189                     call apl_detach_streams_ (code);
190 
191                     if code ^= 0
192                     then call com_err_ (code, "apl", "While detaching apl I/O streams.");
193                end;
194 
195           if apl_static_$ws_info_ptr.static_ws_info_ptr ^= null
196           then call apl_dispose_of_storage_ ();
197 
198           apl_static_$ws_info_ptr.static_ws_info_ptr = save_ws_info_ptr;
199                                                             /* restore old ws info ptr. */
200      end;
201 ^L
202 initialize_apl:
203      procedure (a_temp_dir, a_devicename, a_code);
204 
205 declare   (
206           a_devicename        char (*),
207           a_temp_dir          char (*),
208           a_code              fixed bin (35)
209           )                   parameter;
210 
211 
212           call apl_segment_manager_$set_temp_dir (a_temp_dir);
213           call apl_attach_streams_ (a_devicename, a_code);
214           if a_code = error_table_$ionmat
215           then do;
216                     detach_streams = "0"b;
217                     a_code = 0;
218                end;
219           else detach_streams = "1"b;
220 
221           if a_code ^= 0                                    /* attach the streams now because apl_create_workspace_ will look */
222           then return;                                      /* at line length, etc. anyway, guy probably changed typeball before
223                                                       hitting return on the apl command */
224           call apl_create_workspace_ ();
225 
226      end initialize_apl;
227 ^L
228 /*** this entry is for use by the APL closed subsystem ***/
229 
230 apl_subsystem_:
231      entry (a_user_number, a_switches, a_initial_ws, a_initial_ws_lock, a_terminal_type, a_temporary_segments_dir,
232           a_signoff_lock, a_result);
233 
234 dcl       a_user_number       fixed bin (35) parameter,     /* .. */
235           a_switches          bit (*) aligned parameter,    /* = string(ws_info.switches) (Input) */
236           a_initial_ws        char (*) parameter,           /* workspace to load (Input) */
237           a_initial_ws_lock   char (*) parameter,           /* lock of workspace to load (Input) */
238           a_terminal_type     char (*) parameter,           /* terminal conversion table to use. (Input) */
239           a_temporary_segments_dir
240                               char (*) parameter,           /* directory in which to put workspace segments. */
241           a_signoff_lock      char (*) parameter,           /* user-specified signoff lock (Output) - "*" = nolock */
242           a_result            fixed bin parameter;          /* termination code  (Output)
243                                                      0 = normal termination
244                                                      apl_error_table_$cant_load_ws,
245                                                      apl_error_table_$off_hold
246                                                    */
247 
248 /* Note:  the following code is secure since no amount of fiddling with the quit button
249              can have any effect until apl is entered */
250 
251           save_ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr;
252 
253           on cleanup
254                call clean_up;
255 
256           if a_temporary_segments_dir = ""
257           then temporary_segments_dir = get_pdir_ ();
258           else temporary_segments_dir = a_temporary_segments_dir;
259 
260           apl_static_$immediate_input_prompt = (6)" ";
261 
262           call initialize_apl (temporary_segments_dir, a_terminal_type, code);
263           if code ^= 0
264           then do;
265                     a_result = code;
266                     return;                                 /* no clean_up necessary. */
267                end;
268 
269           ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr;
270                                                             /* refresh auto copy */
271           ws_info.user_number = a_user_number;
272           string (ws_info.switches) = a_switches;
273           ws_info.switches.transparent_to_signals = "0"b;   /* no you don't! */
274 
275           if a_initial_ws = ""
276           then autoload_ws = "continue";
277           else autoload_ws = a_initial_ws;
278 
279           call apl_load_command_$autoload (autoload_ws, a_initial_ws_lock, code);
280 
281 /* If the ws could not be loaded, it is a "security violation"
282              unless no ws was explicitly specified. */
283 
284           if code ^= 0
285           then if ^(code = apl_error_table_$cant_autoload & a_initial_ws = "")
286                then do;
287                          a_result = code;
288                          call clean_up;
289                          return;
290                     end;
291 
292           call ioa_$ioa_switch (apl_static_$apl_output, "apl ^a^/", apl_static_$version_number);
293 
294           call apl_parse_ ();
295 
296           a_signoff_lock = ws_info.signoff_lock;
297 
298           if ws_info.off_hold
299           then a_result = apl_error_table_$off_hold;
300           else a_result = 0;
301 
302           call clean_up;
303           return;
304 ^L
305 /* entries */
306 
307 declare   absolute_pathname_  entry (char (*), char (*), fixed bin (35)),
308           apl_create_workspace_
309                               entry (),
310           apl_load_command_$autoload
311                               entry (char (*), char (*), fixed bin (35)),
312           apl_segment_manager_$set_temp_dir
313                               entry (char (*)),
314           get_pdir_           entry () returns (char (168) aligned),
315           cv_dec_check_       entry (char (*), fixed bin (35)) returns (fixed bin),
316           cu_$af_arg_count    entry (fixed bin, fixed bin(35)),
317           cu_$arg_count       entry () returns (fixed bin),
318           cu_$arg_ptr         entry (fixed bin, ptr, fixed bin (24), fixed bin (35)),
319           active_fnc_err_     entry() options(variable),
320           com_err_            entry options (variable),
321           ioa_$ioa_switch     entry options (variable),
322           apl_file_system_$untie_all_files
323                               entry,
324           (apl_parse_, apl_dispose_of_storage_)
325                               entry (),
326           apl_attach_streams_ entry (char (*), fixed bin (35)),
327           apl_detach_streams_ entry (fixed bin (35));
328 
329 
330 /* conditions */
331 
332 declare   cleanup             condition;
333 
334 /* builtins */
335 
336 declare   (after, before, null, string, substr)
337                               builtin;
338 
339 /* automatic */
340 
341 declare   argno               fixed bin,
342           argp                ptr,
343           argl                fixed bin (24),
344           autoload_lock       char (32),
345           autoload_ws         char (168),
346           code                fixed bin (35),
347           detach_streams      bit (1) aligned initial ("1"b),
348           devicename          char (16),
349           save_ws_info_ptr    ptr unaligned,
350           temporary_segments_dir
351                               char (168),
352           1 command_options   aligned,
353             2 flags           unaligned like ws_info.switches,
354             2 user_number     fixed bin (35);
355 
356 /* based */
357 
358 declare   arg                 char (argl) unaligned based (argp);
359 
360 /* external static */
361 
362 declare   (
363           apl_error_table_$cant_autoload
364                               fixed bin (35),
365           apl_error_table_$off_hold
366                               fixed bin (35),
367           apl_static_$immediate_input_prompt
368                               char (32) varying,
369           error_table_$not_act_fnc fixed bin (35),
370           error_table_$badopt fixed bin (35),
371           error_table_$ionmat fixed bin (35),
372           apl_static_$version_number
373                               char (5),
374           apl_static_$apl_output
375                               pointer
376           )                   external static;
377 
378 /* include files */
379 
380 %include apl_number_data;
381 %include apl_ws_info;
382 
383      end;