1
2
3
4
5
6
7
8
9
10
11 multics_emacs:
12 emacs:
13 procedure () options (variable);
14
15 go to emacs_start;
16
17
18
19
20
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
50
51
52
53
54
55
56 ^L
57
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
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
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
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
154 dcl (addr, clock, divide, hbound, index, length, null, rtrim, stackframeptr, substr)
155 builtin;
156
157
158 dcl cleanup condition;
159 dcl lisp_linkage_error condition;
160 dcl record_quota_overflow condition;
161
162
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
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
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
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
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
233
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
274 call hcs_$status_minf ((emacs_data.edir), rtrim (emacs_data.env_name) || ".sv.lisp", 1, 1 , (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;
300
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
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
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
381
382
383
384
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
396
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
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
419
420
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
428
429 get_version:
430 entry () returns (character (10));
431
432 return (emacs_data_$version);
433
434
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
458
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
468
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
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
492 p -> level_info.segment_ptrs (idx) = null ();
493 end;
494
495 free emacs_data.level_ptr -> level_info in (system_area);
496
497
498 emacs_data.level_ptr = p;
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
510
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
519 if emacs_data.level_ptr -> level_info.segment_ptrs (idx) = segment_ptr then go to found_release;
520 end;
521
522 return;
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;
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
539
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
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;
573
574 allocate level_info in (system_area) set (p);
575
576 p -> level_info.prev_level = emacs_data.level_ptr;
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;
584
585 end push_level;
586 ^L
587
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;
624
625 call release_temp_segments_ ("emacs", emacs_data.level_ptr -> level_info.segment_ptrs (*), (0));
626
627
628 call e_pl1_$set_multics_tty_modes ();
629
630 if emacs_data.flags.turned_on_video then call video_utils_$turn_off_login_channel ((0));
631
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;
642
643 end pop_level;
644
645 end emacs;