1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4         *                                                         *
  5         * Copyright (c) 1978 by Massachusetts Institute of        *
  6         * Technology and Honeywell Information Systems, Inc.      *
  7         *                                                         *
  8         *********************************************************** */
  9 
 10 /* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */
 11 multics_emacs:
 12 emacs:
 13      procedure () options (variable);
 14 
 15           go to emacs_start;
 16 
 17 /* Command interface to Multics EMACS editor. */
 18 
 19 
 20 /****^  HISTORY COMMENTS:
 21   1) change(82-04-12,Margolin), approve(), audit(),
 22      install(86-11-03,MR12.0-1205):
 23      Pre-hcom comments:
 24      03/22/78 by BSG
 25      Last modified:      03/23/78 by GMP for temporary segment manager
 26      Last modified:      03/26/78 by GMP for debugging entries and to differentiate
 27      FNP and Network usage.
 28      Last modified:      21 April 1978 by RSL to restore modes after usage
 29      Last modified:27 August 1978 by GMP to remove FNP/Network differentiation,
 30      and put save/restore modes into push/pop level
 31      Last modified:      24 November 1978 by BSG to
 32      implement e_pl1_$push_pop_tbl_swap)
 33      Last Modified:      3 May 1979 by BIM for logging
 34      Last Modified:   7 May 1979 by BSG for lisp_linkage_error
 35      Last Modified:   9 May 1979 by BSG for integration with new_emacs,
 36      better logging
 37      Last Modified 28 Feb 1980 by BSG for >sc1>emacs_dir
 38      Last Modified 17 June 1981 by RMSoley for emacs$get_my_name and friends.
 39      Last Modified 7 July 1981 RMSoley for emacs$get_version and to use
 40      emacs_data_$version for saved environment name.
 41      Last Modified 10 July 1981 RMSoley for logging changes
 42      Last Modified 14 July 1981 RMSoley for info_ptr in emacs_ and
 43      emacs$get_info_ptr
 44      Last Modified 22 July 1981 RMSoley to move parsing to PL/1,
 45      fully use emacs_data_ static, add tasking, and clean up.
 46      Last Modified: August 1981 RMSoley: fix tasking, get rid
 47      of push_pop_tbl_swap technology, fix invocation workings.
 48      Modified: 3 April 1982 Richard Soley to fix lisp_save_ message
 49                   received during installation window.
 50      Modified: 12 April 1982 Richard Soley to remove site-dir dependence.
 51   2) change(86-07-17,Margolin), approve(86-07-17,MCR7452),
 52      audit(86-07-29,Coren), install(86-11-03,MR12.0-1205):
 53      Changed pop_level to turn off video if Emacs turned it on automatically.
 54                                                    END HISTORY COMMENTS */
 55 
 56 ^L
 57 /* System Entries */
 58           dcl     cu_$arg_ptr_rel       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
 59           dcl     cu_$cl                entry ();
 60           dcl     com_err_$suppress_name
 61                                         entry options (variable);
 62           dcl     cu_$arg_list_ptr      entry () returns (pointer);
 63           dcl     ioa_$ioa_switch       entry options (variable);
 64           dcl     e_argument_parse_     entry (ptr, char (*), fixed bin (35));
 65           dcl     e_argument_parse_$subroutine
 66                                         entry (ptr, char (*), char (*), ptr);
 67           dcl     e_pl1_$dump_out_console_messages
 68                                         entry ();
 69           dcl     e_pl1_$return_echo_meters
 70                                         entry (fixed bin, fixed bin, fixed bin, fixed bin);
 71           dcl     e_pl1_$set_multics_tty_modes
 72                                         entry ();
 73           dcl     e_pl1_$get_terminal_type
 74                                         entry (char (*) varying);
 75           dcl     e_tasking_            entry (pointer, fixed bin (35));
 76           dcl     expand_pathname_      entry (char (*), char (*), char (*), fixed bin (35));
 77           dcl     find_condition_info_  entry (ptr, ptr, fixed bin (35));
 78           dcl     forward_command_      entry (pointer, entry, character (*));
 79           dcl     get_group_id_         entry () returns (char (32));
 80           dcl     get_system_free_area_ entry () returns (pointer);
 81           dcl     get_temp_segment_     entry (character (*), pointer, fixed binary (35));
 82           dcl     hcs_$fs_get_path_name entry (entry, character (*), fixed binary, character (*), fixed binary (35));
 83           dcl     hcs_$initiate         entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
 84                                         fixed bin (35));
 85           dcl     hcs_$get_process_usage
 86                                         entry (ptr, fixed bin (35));
 87           dcl     hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin (3), fixed bin (5), fixed bin (35))
 88                                         ;
 89           dcl     hcs_$status_minf      entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
 90                                         fixed bin (35));
 91           dcl     ioa_$rsnnl            entry options (variable);
 92           dcl     iox_$modes            entry (pointer, character (*), character (*), fixed binary (35));
 93           dcl     lisp$lisp             entry () options (variable);
 94           dcl     user_info_$terminal_data
 95                                         entry (char (*), char (*), char (*), fixed bin, char (*));
 96           dcl     video_utils_$turn_off_login_channel
 97                                         entry (fixed bin (35));
 98           dcl     write_log_$write_log_test
 99                                         entry (char (*));
100           dcl     write_log_$write_log_file
101                                         entry (fixed bin (71), fixed bin, char (*), char (*), ptr);
102           dcl     release_temp_segments_
103                                         entry (character (*), (*) pointer, fixed binary (35));
104           dcl     release_temp_segment_ entry (character (*), pointer, fixed binary (35));
105 ^L
106 /* Automatic */
107           dcl     cgmeter               fixed bin;
108           dcl     1 cinfo               like condition_info aligned automatic;
109           dcl     code                  fixed bin (35);
110           dcl     edirl                 fixed bin;
111           dcl     env_name              char (32);
112           dcl     groupid               character (32);
113           dcl     idx                   fixed bin;
114           dcl     line_type             fixed bin;
115           dcl     locemeter             fixed bin;
116           dcl     log_name              char (32);
117           dcl     log_ptr               pointer;
118           dcl     loser                 character (256) varying;
119           dcl     lstring               char (116);
120           dcl     mode                  fixed bin (5);
121           dcl     myname                char (32);
122           dcl     n_to_allocate         fixed bin;
123           dcl     netsw                 bit (1);
124           dcl     1 new_usage_info      automatic aligned like process_usage;
125           dcl     outmeter              fixed bin;
126           dcl     p                     pointer;
127           dcl     r0emeter              fixed bin;
128           dcl     temp_ptr              pointer;
129           dcl     temp_string           character (168);
130           dcl     termid                char (4);
131           dcl     time_in               fixed bin (71);
132           dcl     ttychan               character (32);
133           dcl     ttytype               character (32);
134           dcl     1 usage_info          automatic aligned like process_usage;
135           dcl     vtyp                  character (100) varying;
136 
137 /* External Static */
138           dcl     emacs_data_$invocation_list
139                                         pointer static external;
140           dcl     emacs_data_$log_dir   character (168) static external;
141           dcl     emacs_data_$status_code
142                                         fixed bin (35) static external;
143           dcl     emacs_data_$version   character (10) static external;
144           dcl     iox_$user_io          pointer external;
145 
146 /* Internal Static */
147           dcl     isw                   bit (1) static initial ("0"b);
148           dcl     log_subdir            char (32) static options (constant) init ("log_dir");
149           dcl     names                 (2) character (32) static options (constant)
150                                         initial ("lisp", "lisp_static_vars_");
151           dcl     system_area_ptr       pointer static internal initial (null ());
152 ^L
153 /* Builtin */
154           dcl     (addr, clock, divide, hbound, index, length, null, rtrim, stackframeptr, substr)
155                                         builtin;
156 
157 /* Conditions */
158           dcl     cleanup               condition;
159           dcl     lisp_linkage_error    condition;
160           dcl     record_quota_overflow condition;
161 
162 /* Based */
163           dcl     based_code            fixed bin (35) based;
164           dcl     1 cond_info           aligned based,
165                     2 lth               fixed bin,
166                     2 version           fixed bin,
167                     2 action_flags      aligned,
168                       3 cant_restart    bit (1) unal,
169                       3 default_restart bit (1) unal,
170                       3 pad             bit (34) unal,
171                     2 info_string       char (256) varying,
172                     2 status_code       fixed bin (35);
173           dcl     system_area           area based (system_area_ptr);
174 
175 /* Parameters */
176           dcl     segment_ptr           pointer parameter;
177           dcl     P_code                fixed bin (35);
178           dcl     P_environment         char (*) parameter;
179           dcl     P_info_ptr            pointer;
180           dcl     P_iocb_ptr            pointer;
181           dcl     P_pathname            char (*) parameter;
182 
183 /* Include Files */
184 %include condition_info;
185 %include emacs_data;
186 %include line_types;
187 %include process_usage;
188 ^L
189 emacs_start:
190           myname = "emacs";
191           env_name = "emacs";
192           log_name = "emacs_log";
193           goto e_ne_common;
194 
195 emacs_:
196      entry (P_iocb_ptr, P_pathname, P_environment, P_info_ptr, P_code);
197 
198           myname = "emacs_";
199           env_name = "emacs_";
200           log_name = "emacs_log";
201           go to e_ne_common;
202 
203 ne:
204 new_emacs:
205      entry options (variable);
206 
207           myname = "new_emacs";
208           env_name = "new-emacs";
209           log_name = "ne_log";
210 ^L
211 e_ne_common:
212           emacs_data_$status_code = 0;
213 
214 /* Push this invocation (it may be popped later.) */
215           system_area_ptr = get_system_free_area_ ();
216           allocate emacs_data in (system_area) set (emacs_data_ptr);
217           emacs_data.prev_invocation = null ();
218           emacs_data.next_invocation = emacs_data_$invocation_list;
219           if emacs_data_$invocation_list ^= null () then
220                emacs_data_$invocation_list -> emacs_data.prev_invocation = emacs_data_ptr;
221           emacs_data_$invocation_list = emacs_data_ptr;
222           emacs_data.frame_ptr = stackframeptr ();
223 
224 /* Parse argument list. */
225           emacs_data.arg_list_ptr = cu_$arg_list_ptr ();
226           code = 0;
227           if myname ^= "emacs_" then
228                call e_argument_parse_ (emacs_data.arg_list_ptr, myname, code);
229           else call e_argument_parse_$subroutine (P_iocb_ptr, P_pathname, P_environment, P_info_ptr);
230           if code ^= 0 then return;
231 
232 /* Now, if we are going to be tasking AND THERE IS A TASK AROUND,
233    pop invocation list (saving arguments). */
234           if emacs_data.arguments.no_task then go to escape_loop;
235 
236           do temp_ptr = emacs_data_$invocation_list repeat (temp_ptr -> emacs_data.next_invocation)
237                while (temp_ptr ^= null ());
238                if temp_ptr -> emacs_data.tasking.task_flags.in_task then do;
239                     temp_ptr -> emacs_data.arguments = emacs_data.arguments;
240                     emacs_data_ptr = temp_ptr;
241                     temp_ptr = emacs_data_$invocation_list -> emacs_data.next_invocation;
242                     free emacs_data_$invocation_list -> emacs_data in (system_area);
243                     emacs_data_$invocation_list = temp_ptr;
244                     emacs_data_$invocation_list -> emacs_data.prev_invocation = null ();
245                     go to escape_loop;
246                end;
247           end;
248 escape_loop:
249           if myname = "emacs_" then do;
250                emacs_data.info_ptr = P_info_ptr;
251                emacs_data.output_iocb, emacs_data.input_iocb = P_iocb_ptr;
252           end;
253 
254           emacs_data.flags.new_arguments = "1"b;
255           emacs_data.arg_list_ptr = cu_$arg_list_ptr ();
256           emacs_data.myname = myname;
257           emacs_data.env_name = rtrim (env_name) || "." || emacs_data_$version;
258           emacs_data.log_name = log_name;
259 ^L
260           call hcs_$fs_get_path_name (emacs, temp_string, edirl, (""), (0));
261           emacs_data.edir = temp_string;
262           if edirl < 168 then substr (emacs_data.edir, edirl + 1) = "";
263           if ^isw then do;
264                do idx = 1 to hbound (names, 1);
265                     call hcs_$initiate ((emacs_data.edir), names (idx), names (idx), (0), (0), p, (0));
266                end;
267           end;
268           isw = "1"b;
269           if emacs_data.myname = "emacs_" | emacs_data.myname = "emacs" then
270                emacs_data.ledir = emacs_data_$log_dir;
271           else emacs_data.ledir = emacs_data.edir;
272 
273 /* Check existence of lisp environment. */
274           call hcs_$status_minf ((emacs_data.edir), rtrim (emacs_data.env_name) || ".sv.lisp", 1, 1 /* seg */, (0), code);
275           if code ^= 0 then do;
276                call com_err_$suppress_name (0, emacs_data.myname,
277                     "A new version of emacs, version ^a, is being installed.", rtrim (emacs_data_$version));
278                call com_err_$suppress_name (0, emacs_data.myname, "Please wait 5 minutes and try again.");
279                return;
280           end;
281 
282           mode = 0;
283           call hcs_$get_user_effmode ((emacs_data.ledir), "metering.acs", "", 4, mode, code);
284           if mode > 01000b then do;
285                usage_info.number_wanted = 5;
286                log_ptr = null ();
287                call hcs_$get_process_usage (addr (usage_info), (0));
288                call write_log_$write_log_test (rtrim (emacs_data.ledir) || ">" || log_subdir);
289                call user_info_$terminal_data (termid, ttytype, ttychan, line_type, (""));
290                netsw = (line_type = LINE_TELNET);
291                call ioa_$rsnnl ("^a: Entering ^a (^a) on ^a ^a ^a", lstring, length (lstring), get_group_id_ (),
292                     emacs_data.myname, rtrim (emacs_data_$version), ttytype, termid, ttychan);
293                time_in = clock ();
294                call write_log_$write_log_file (time_in, 0, lstring, (emacs_data.log_name), log_ptr);
295           end;
296 
297           call push_level ();
298 
299           code = 0;                                         /* If this returns a non-zero code, then got error or already
300                                                                ran an Emacs, punt. */
301           call e_tasking_ (emacs_data_ptr, code);
302           if code ^= 0 then return;
303           go to not_tasking;
304 ^L
305 tasking_emacs:
306      entry ();
307 
308           emacs_data_ptr = emacs_data_$invocation_list;
309           emacs_data.frame_ptr = stackframeptr ();
310 
311 not_tasking:
312           on cleanup
313                begin;
314                     emacs_data_ptr = e_find_invocation_ ();
315                     call pop_level ();
316                     call unthread_invocation ();
317                end;
318 
319           on lisp_linkage_error call llerror ();
320 
321           on record_quota_overflow call rqoerror ();
322 
323 /* Now forward to Lisp. */
324           call forward_command_ (emacs_data.arg_list_ptr, lisp$lisp,
325                rtrim (emacs_data.edir) || ">" || rtrim (emacs_data.env_name));
326           call pop_level ();
327 
328           if emacs_data.myname = "emacs_" then P_code = emacs_data.status_code;
329           call unthread_invocation ();
330 returner:
331           return;
332 ^L
333 llerror:
334      procedure ();
335 
336           emacs_data_ptr = e_find_invocation_ ();
337           call pop_level;
338 
339 /* Figure out exactly what part of emacs failed. */
340           call find_condition_info_ (null (), addr (cinfo), code);
341           if code ^= 0 then
342                loser = rtrim (emacs_data.myname);
343           else do;
344                loser = cinfo.info_ptr -> cond_info.info_string;
345                if substr (loser, 1, 4) ^= "The " then
346                     loser = rtrim (emacs_data.myname);
347                else do;
348                     loser = substr (loser, 5);
349                     idx = index (loser, " ");
350                     loser = substr (loser, 1, idx - 1);
351                end;
352           end;
353 
354           call com_err_$suppress_name (0, emacs_data.myname, "A new version of ^a, a part of ^a, has been installed.",
355                loser, emacs_data.myname);
356           call com_err_$suppress_name (0, emacs_data.myname,
357                "Please issue the ""tmr ^a"" command in order to be able to use it.", loser);
358           call unthread_invocation ();
359           go to returner;
360      end;
361 ^L
362 rqoerror:
363      procedure ();
364           emacs_data_ptr = e_find_invocation_ ();
365           call e_pl1_$set_multics_tty_modes ();
366           call ioa_$ioa_switch (iox_$user_io,
367                "^/^a: There has been a record quota overflow.  Delete unnecessary segments", emacs_data.myname);
368           call ioa_$ioa_switch (iox_$user_io, "and issue the ""^[^a^;pi^s^]"" command to re-enter ^a.",
369                emacs_data.tasking.task_flags.in_task, emacs_data.myname, emacs_data.myname);
370 
371           revert record_quota_overflow;
372           call cu_$cl ();
373           on record_quota_overflow call rqoerror ();
374           return;
375      end rqoerror;
376 
377 unthread_invocation:
378      procedure ();
379 
380 /* Don't unthread if this is a tasking invocation, or
381    e_tasking_ won't be able to destroy.
382    16 April 1982 RMSoley: new way is to just release through
383    the entire stack, so DO unthread tasking invocations.
384    if emacs_data.tasking.task_flags.in_task then return; */
385 
386           if emacs_data_$invocation_list = emacs_data_ptr then emacs_data_$invocation_list = emacs_data.next_invocation;
387           if emacs_data.next_invocation ^= null () then
388                emacs_data.next_invocation -> emacs_data.prev_invocation = emacs_data.prev_invocation;
389           if emacs_data.prev_invocation ^= null () then
390                emacs_data.prev_invocation -> emacs_data.next_invocation = emacs_data.next_invocation;
391           free emacs_data;
392           return;
393      end unthread_invocation;
394 ^L
395 /* This entry allows the lisp side of emacs find out what name we were
396    called with, emacs/emacs_/new_emacs.    RMSoley 17 June 1981 */
397 
398 get_my_name:
399      entry () returns (char (32));
400 
401           emacs_data_ptr = e_find_invocation_ ();
402 
403           return (emacs_data.myname);
404 
405 /* This entry allows the lisp side to set a return code for emacs_ */
406 
407 set_emacs_return_code:
408      entry (P_return_code);
409           dcl     P_return_code         fixed bin (35);
410 
411           emacs_data_ptr = e_find_invocation_ ();
412 
413           emacs_data.status_code = P_return_code;
414           emacs_data_$status_code = P_return_code;
415 
416           if emacs_data.myname ^= "emacs_" then return;
417 
418 /* Now patch it into the argument list.
419    Have to go through this hair since the argument list
420    might be on another stack ! */
421 
422           call cu_$arg_ptr_rel (5, temp_ptr, (0), (0), emacs_data.arg_list_ptr);
423           temp_ptr -> based_code = P_return_code;
424 
425           return;
426 
427 /* This entry returns the current emacs version string. */
428 
429 get_version:
430      entry () returns (character (10));
431 
432           return (emacs_data_$version);
433 
434 /* This entry is called by the lisp side to set redisplay meters. */
435 
436 set_lisp_rdis_meters:
437      entry (P_1, P_2, P_3, P_4, P_5, P_6, P_7, P_8, P_9, P_10);
438 
439           declare (P_1, P_2, P_3, P_4, P_5, P_6, P_7, P_8, P_9, P_10)
440                                         fixed bin;
441           declare (static_rdis_1, static_rdis_2, static_rdis_3, static_rdis_4, static_rdis_5, static_rdis_6,
442                   static_rdis_7, static_rdis_8, static_rdis_9, static_rdis_10)
443                                         static internal fixed bin init (0);
444 
445           static_rdis_1 = P_1;
446           static_rdis_2 = P_2;
447           static_rdis_3 = P_3;
448           static_rdis_4 = P_4;
449           static_rdis_5 = P_5;
450           static_rdis_6 = P_6;
451           static_rdis_7 = P_7;
452           static_rdis_8 = P_8;
453           static_rdis_9 = P_9;
454           static_rdis_10 = P_10;
455           return;
456 
457 /* emacs$get_info_ptr -> get information pointer provided in emacs_
458    call.  14 July 1981 RMSoley */
459 
460 get_info_ptr:
461      entry () returns (pointer);
462 
463           emacs_data_ptr = e_find_invocation_ ();
464 
465           return (emacs_data.info_ptr);
466 ^L
467 /* This entry allocates a temporary segment for the editor.
468    It remembers all such segments allocated so that it can free them when done.
469 */
470 
471 
472 get_temporary_seg:
473      entry () returns (pointer);
474 
475           emacs_data_ptr = e_find_invocation_ ();
476 
477           if emacs_data.level_ptr -> level_info.n_used = emacs_data.level_ptr -> level_info.n_allocated then do;
478                                                             /* need more room in table */
479 
480                n_to_allocate = emacs_data.level_ptr -> level_info.n_allocated + 16;
481                allocate level_info in (system_area) set (p);
482 
483                p -> level_info.prev_level = emacs_data.level_ptr -> level_info.prev_level;
484 
485                p -> level_info.n_used = emacs_data.level_ptr -> level_info.n_used;
486                do idx = 1 to p -> level_info.n_used;
487                     p -> level_info.segment_ptrs (idx) = emacs_data.level_ptr -> level_info.segment_ptrs (idx);
488                end;
489 
490                do idx = p -> level_info.n_used + 1 to p -> level_info.n_allocated;
491                                                             /* and new ones */
492                     p -> level_info.segment_ptrs (idx) = null ();
493                end;
494 
495                free emacs_data.level_ptr -> level_info in (system_area);
496                                                             /* release old table */
497 
498                emacs_data.level_ptr = p;                    /* remember new table */
499           end;
500 
501 
502           idx, emacs_data.level_ptr -> level_info.n_used = emacs_data.level_ptr -> level_info.n_used + 1;
503 
504           call get_temp_segment_ ("emacs", emacs_data.level_ptr -> level_info.segment_ptrs (idx), (0));
505 
506           return (emacs_data.level_ptr -> level_info.segment_ptrs (idx));
507 ^L
508 
509 /* This entry releases a temporary segment previously allocated by this level
510    of the editor. */
511 
512 release_temporary_seg:
513      entry (segment_ptr);
514 
515           emacs_data_ptr = e_find_invocation_ ();
516 
517           do idx = 1 to emacs_data.level_ptr -> level_info.n_used;
518                                                             /* find it */
519                if emacs_data.level_ptr -> level_info.segment_ptrs (idx) = segment_ptr then go to found_release;
520           end;
521 
522           return;                                           /* not from this level, forget it */
523 
524 
525 found_release:
526           do idx = idx + 1 to emacs_data.level_ptr -> level_info.n_used;
527                emacs_data.level_ptr -> level_info.segment_ptrs (idx - 1) =
528                     emacs_data.level_ptr -> level_info.segment_ptrs (idx);
529           end;                                              /* remove from list */
530 
531           emacs_data.level_ptr -> level_info.n_used = emacs_data.level_ptr -> level_info.n_used - 1;
532 
533           call release_temp_segment_ ("emacs", segment_ptr, (0));
534 
535           return;
536 ^L
537 
538 /* These commands are for use when debugging EMACS.  They push and pop
539    editor levels to permit use of the editor fom free-standing LISP.
540 */
541 
542 debug_on:
543      entry () options (variable);
544 
545           emacs_data_ptr = e_find_invocation_ ();
546 
547           call push_level ();
548 
549           return;
550 
551 
552 
553 debug_off:
554      entry () options (variable);
555 
556           emacs_data_ptr = e_find_invocation_ ();
557 
558           mode = 0b;
559           call pop_level ();
560 
561           return;
562 ^L
563 
564 /* This internal procedure pushes a new editor level.
565 */
566 
567 push_level:
568      procedure ();
569 
570           if system_area_ptr = null () then system_area_ptr = get_system_free_area_ ();
571 
572           n_to_allocate = 16;                               /* good size for start */
573 
574           allocate level_info in (system_area) set (p);
575 
576           p -> level_info.prev_level = emacs_data.level_ptr;/* chain previous level */
577 
578           p -> level_info.n_used = 0;
579           p -> level_info.segment_ptrs (*) = null ();
580 
581           call iox_$modes (iox_$user_io, (""), p -> level_info.tty_modes, (0));
582 
583           emacs_data.level_ptr = p;                         /* push */
584 
585      end push_level;
586 ^L
587 /* This internal procedure pops an editor level. */
588 
589 pop_level:
590      procedure ();
591           if mode > 01000b then do;
592 
593                new_usage_info.number_wanted = 5;
594                call hcs_$get_process_usage (addr (new_usage_info), (0));
595                time_in = divide (clock () - time_in, 6000000, 35, 0);
596                call e_pl1_$return_echo_meters (cgmeter, r0emeter, locemeter, outmeter);
597                groupid = get_group_id_ ();
598                call e_pl1_$get_terminal_type (vtyp);
599                if vtyp = "" then
600                     if netsw then
601                          ttytype = "supdup output";
602                     else ;
603                else call expand_pathname_ ((vtyp), (168)" ", ttytype, 0);
604                if (substr (ttytype, length (rtrim (ttytype)) - 2, 3) = "ctl") then
605                     substr (ttytype, length (rtrim (ttytype)) - 2) = "";
606                call ioa_$rsnnl ("^a: (^a) in ^d, r0/r4 echo ^d/^d, out ^d.", lstring, length (lstring), groupid, ttytype,
607                     cgmeter, r0emeter, locemeter - r0emeter, outmeter);
608                call write_log_$write_log_test (rtrim (emacs_data.ledir) || ">" || log_subdir);
609                call write_log_$write_log_file (clock (), 0, lstring, (emacs_data.log_name), log_ptr);
610                call ioa_$rsnnl ("^a: lisp rdis: ^d ^d ^d ^d ^d ^d ^d ^d ^d ^d", lstring, length (lstring), groupid,
611                     static_rdis_1, static_rdis_2, static_rdis_3, static_rdis_4, static_rdis_5, static_rdis_6,
612                     static_rdis_7, static_rdis_8, static_rdis_9, static_rdis_10);
613                call write_log_$write_log_file (clock (), 0, lstring, (emacs_data.log_name), log_ptr);
614 
615                call ioa_$rsnnl ("^a: ^.1f min, v/cpu ^d/^d mem ^d paging ^d/^d", lstring, length (lstring), groupid,
616                     time_in / 10e0, (new_usage_info.virtual_cpu_time - usage_info.virtual_cpu_time) * 1e-6,
617                     (new_usage_info.cpu_time - usage_info.cpu_time) * 1e-6,
618                     divide (new_usage_info.paging_measure - usage_info.paging_measure, 1000, 35, 0),
619                     new_usage_info.pd_faults - usage_info.pd_faults, new_usage_info.page_faults - usage_info.page_faults);
620                call write_log_$write_log_file (clock (), 0, lstring, (emacs_data.log_name), log_ptr);
621           end;
622 
623           if emacs_data.level_ptr = null () then return;    /* nothing to do */
624 
625           call release_temp_segments_ ("emacs", emacs_data.level_ptr -> level_info.segment_ptrs (*), (0));
626                                                             /* release all temporary segments of this level */
627 
628           call e_pl1_$set_multics_tty_modes ();             /* renegotiate echoing */
629 
630           if emacs_data.flags.turned_on_video then call video_utils_$turn_off_login_channel ((0));
631                                                             /* we turned it on, we should turn it off */
632 
633           call iox_$modes (iox_$user_io, emacs_data.level_ptr -> level_info.tty_modes, (""), (0));
634 
635           call e_pl1_$dump_out_console_messages ();
636 
637           p = emacs_data.level_ptr -> level_info.prev_level;
638 
639           free emacs_data.level_ptr -> level_info in (system_area);
640 
641           emacs_data.level_ptr = p;                         /* pop */
642 
643      end pop_level;
644 
645      end emacs;