1 /* **************************************************************
  2    *                                                            *
  3    * Copyright, (C) Massachusetts Institute of Technology, 1973 *
  4    *                                                            *
  5    ************************************************************** */
  6 lisp:     proc;
  7 
  8 
  9 
 10 /* command interface to the Multics LISP subsystem.
 11    First coded for the second version of the Multics
 12    LISP implementation on 3/15/71.
 13    Modified for use of standard Multics linkage mechanism, 7/15/71.
 14    D. Reed
 15    Changed for new definition of (status toplevel) and to add cleanup
 16    handler for new I/O system, 24 Mar 1973, DAM
 17    Modified to allow recursive entry of the lisp subsystem, 6/2/73 by DAM
 18    Modified 74.11.01 by DAM to remove references to establish_cleanup_proc_ and default_handler_
 19    Modified 74.12.09 by DAM for (sstatus cleanup) feature
 20    Modified 78.12.08 by BSG for (sstatus mulpi) feature
 21  */
 22 
 23 
 24 dcl level static init(0) fixed bin;               /* level of recursion */
 25 
 26 dcl (lisp_static_vars_$template fixed bin,
 27     lisp_static_vars_$template_size fixed bin,
 28     lisp_static_vars_$cur_stat_seg ptr,
 29     lisp_static_vars_$cur_stat_pos fixed bin(19),
 30     lisp_static_vars_$subsys_recurse_save_size fixed bin) external static;
 31 
 32 dcl lisp_static_vars_$property_list_of_nil fixed bin(71) external,
 33     lisp_error_table_$bad_arg_correctable fixed bin external;
 34 
 35 dcl ioa_$ioa_switch external entry options(variable),
 36     iox_$error_output external ptr,
 37     lisp_static_vars_$ignore_faults bit(36) ext aligned,
 38     lisp_static_vars_$mulpi_state fixed bin (17) ext aligned,
 39     lisp_static_vars_$quit_handler_flag bit(1) external,
 40     lisp_static_vars_$gc_time fixed bin(71) ext aligned,
 41     lisp_static_vars_$emptying_buffers fixed bin external,
 42     lisp_static_vars_$hi_random bit(72) ext aligned,
 43     saved_ignore_faults bit(36) aligned;
 44 dcl cu_$arg_ptr_rel entry(fixed bin,ptr,fixed bin,fixed bin, ptr),
 45     lisp_fault_handler_$init entry,
 46     1 unmask aligned like masked,
 47     lisp_segment_manager_$get_stack entry(ptr),
 48     lisp_segment_manager_$free_stack entry(ptr),
 49     lisp_segment_manager_$get_lists entry(ptr),
 50     lisp_segment_manager_$free_lists entry(ptr),
 51     arg_list_ptr ptr,
 52     cu_$arg_list_ptr entry(ptr),
 53     save_area_size fixed bin,
 54     foo fixed bin(71)aligned,
 55     tempp ptr,
 56     lisp_error_ entry,
 57     errcode(2) fixed bin based aligned,
 58     lisp_get_atom_ entry(char(*)aligned,fixed bin(71)aligned),
 59     condition_ entry (char(*), entry),
 60     reversion_ entry(char(*)),
 61     program_interrupt condition,
 62     lisp_default_handler_$program_interrupt entry,
 63     lisp_default_handler_ entry,
 64     lisp_io_control_$empty_all_buffers entry,
 65     lisp_io_control_$clear_input entry,
 66     lisp_io_control_$cleanup entry,
 67     lisp_io_control_$init entry,
 68     lisp_boot_ entry,
 69     lisp_save_$unsave entry(char(*),ptr,fixed bin(18),fixed bin),
 70     lisp_save_ entry(char(*) aligned),
 71     lisp_reader_$read entry,
 72     lisp_print_$type_nl entry,
 73     lisp_static_vars_$print_atom fixed bin(71) external,
 74     lisp_static_vars_$prin1 ptr external,
 75     lisp_special_fns_$ncons entry,
 76     lisp_$apply entry,
 77     lisp_$eval entry,
 78     our_stack ptr,
 79     stack ptr,
 80     i fixed bin,
 81     lisp_get_atom_$init_ht entry,
 82     subr_type fixed bin(2) aligned,
 83     lisp_static_man_$free_stat_segs entry,
 84     finishup label static,
 85     (null,ptr,addr,rel,bit,fixed,mod,substr,addrel,string) builtin;
 86 
 87 dcl lisp_static_vars_$evalhook_status bit(36) aligned external,
 88     lisp_static_vars_$evalhook_atom fixed bin(71) external,
 89     lisp_$evalhook_off_status bit(36) aligned external;
 90 
 91           dcl lisp_oprs_$init entry;
 92 
 93 dcl 1 cclist based, /* overlay for header of compiled constant list block
 94                        which is a type of internal static storage known to the
 95                        lisp garbage collector */
 96       2 next_ccl_entry ptr,
 97       2 init_flag fixed bin;
 98 
 99 
100 
101 dcl lisp_static_vars_$cleanup_list_exists bit(1) aligned external,
102     lisp_static_vars_$cleanup_list fixed bin(71) external,
103     lisp_static_vars_$i_am_gcing bit(1) aligned external;
104 
105 /* The structure of the lisp stack segment -- as known only to this and one other program */
106 
107 %include lisp_stack_seg;
108 %include lisp_free_storage;
109 %include lisp_io;
110 
111 %include lisp_stack_fmt;
112 %include lisp_nums;
113 %include lisp_initial_atoms;
114 %include lisp_common_vars;
115 %include lisp_faults;
116 dcl unm pointer;              /* useless */
117 %include lisp_name_codes;
118 %include lisp_atom_fmt;
119 %include lisp_cons_fmt;
120 %include lisp_string_fmt;
121 %include lisp_ptr_fmt;
122 %include lisp_subr_fmt;
123 /*^L*/
124           /* for the benefit of losers who use uread, add the reference name lisp_old_io_ to us */
125 
126           call hcs_$fs_get_path_name(addr(lisp$), xdn, 0, xen, 0);
127           call hcs_$initiate(xdn, xen, "lisp_old_io_", 0, 0, null, 0);
128 
129                     dcl xdn char(168),
130                         xen char(32),
131                         lisp$ external,
132                         hcs_$fs_get_path_name entry(pointer, char(*), fixed bin, char(*), fixed bin(5)),
133                          hcs_$initiate entry(char(*), char(*), char(*), fixed bin, fixed bin, pointer, fixed bin(35));
134 
135 
136           /* begin by getting arg list ptr and computing size of save area
137              needed.  Then enter begin block */
138 
139           call cu_$arg_list_ptr(arg_list_ptr);
140           level = level + 1;
141           if level >= 2 then save_area_size = lisp_static_vars_$subsys_recurse_save_size;
142               else save_area_size = 0;  /* if first entry, no need to save anything */
143 
144 first_stack_frame_for_lisp: begin;
145 
146 dcl arglen fixed bin,
147     argptr ptr,
148     argname char(arglen) based (argptr),
149     code fixed bin,
150     old_stat_size fixed bin(18),
151     old_stat_ptr ptr,
152     old_alloc_info bit(288) aligned,                        /* to save lisp_alloc_$allo_info in */
153     oldfinishup automatic label variable,
154     our_stack pointer,
155     stack pointer;
156 
157 dcl save_area bit(36) aligned dimension(save_area_size);
158 dcl words_to_be_moved_sas bit(36) aligned based dimension (save_area_size),
159     words_to_be_moved_ts bit(36) aligned based dimension(lisp_static_vars_$template_size);
160 
161           /* save lisp_static_vars_ in our stack frame */
162 
163           if save_area_size ^= 0 then
164                save_area = addr(lisp_static_vars_$lisp_static_vars_) -> words_to_be_moved_sas;
165 
166           /* init first part of lisp_static_vars_ from template */
167 
168           addr(lisp_static_vars_$lisp_static_vars_) -> words_to_be_moved_ts =
169              addr(lisp_static_vars_$template) -> words_to_be_moved_ts;
170 
171 
172 /* make a segment for the push down list */
173 
174           call lisp_segment_manager_$get_stack(our_stack);
175           prog_frame, err_frame, catch_frame, unwp_frame, binding_top, err_recp, eval_frame = our_stack;
176           unmkd_ptr = addr(our_stack->stack_seg.begin_unmkd_stack);
177           call lisp_segment_manager_$get_stack(stack_ptr);
178           stack_ptr = addrel(stack_ptr,2);                            /* kludge for pdl ptrs */
179           our_stack->stack_seg.marked_stack_bottom = stack_ptr;
180           our_stack->stack_seg.stack_ptr_ptr = addr(stack_ptr);
181           our_stack->stack_seg.unmkd_stack_bottom = addr(our_stack->begin_unmkd_stack);
182           our_stack->stack_seg.in_pl1_code = "1"b;
183           our_stack->stack_seg.unmkd_ptr_ptr = addrel(addr(unmkd_ptr),1);       /* so can store only offset */
184 
185           /* set addresses of lisp operators in the stack header */
186 
187           call lisp_oprs_$init;
188 
189 
190           old_alloc_info = lisp_alloc_$alloc_info;
191           oldfinishup = finishup;       /* just in case we quit out of an old lisp invocation */
192           finishup = done;    /* return for top level return or go to, and return for cleanup handler is"done" */
193           lisp_static_vars_$top_level = top_level_err;      /* error return */
194 
195           /* save ptr to arg list for (status jcl), (status arg _^Hn) */
196 
197           dcl lisp_static_vars_$arg_list_ptr external pointer;
198 
199           lisp_static_vars_$arg_list_ptr = arg_list_ptr;
200 
201 /* now look at argument, and decide what is to be done about unsaving an environment */
202 
203           call cu_$arg_ptr_rel(1,argptr,arglen,code, arg_list_ptr);
204           if code = 0 then do;
205                if argname = "-boot" then do;      /* if we want bootstrap environment generate it */
206                     lisp_static_vars_$cur_stat_seg = null;  /* start with no static segs */
207                     lisp_static_vars_$cur_stat_pos = 262144;/* causes immediate allocation of a static seg
208                                                                on first call to lisp_static_man_ */
209                     call lisp_segment_manager_$get_lists(lisp_alloc_$cur_seg);  /* get a free storage segment */
210                     lisp_alloc_$cur_seg -> alloc_segment.next_seg = null();
211                     lisp_alloc_$cur_seg -> alloc_segment.tally_word.seg_offset = "000000000000000100"b;
212                     lisp_alloc_$cur_seg -> alloc_segment.tally_word.tally = "111100000000"b;
213                     lisp_alloc_$cur_seg -> alloc_segment.tally_word.delta = 4;
214                     lisp_alloc_$consptr = addr(lisp_alloc_$cur_seg->alloc_segment.tally_word);
215                     consptr_ovly.mod = "101011"b;
216                     lisp_alloc_$gc_blk_cntr = -1;                               /* one 16k block before gc */
217                     lisp_alloc_$seg_blk_cntr = -16;                             /* 16 16k blocks per segment */
218                     /* make sure garbage collect doesn't occur until initialization done */
219                     lisp_static_vars_$garbage_collect_inhibit = "1"b;
220                     call lisp_boot_;
221                end;
222                else do;
223                     call lisp_save_$unsave(argname,old_stat_ptr, old_stat_size, code);
224                                         /*      unsave indicated saved environment */
225                     go to unsaved;
226                end;
227           end;
228           else do;
229                     call lisp_save_$unsave("",old_stat_ptr,old_stat_size,code);
230                               /*        unsave standard enviroment */
231 unsaved:            if code ^= 0 then return;     /*        if error then return to caller */
232                     lisp_static_vars_$cur_stat_seg = old_stat_ptr;              /* tell lisp_static_man_ about the */
233                     lisp_static_vars_$cur_stat_pos = old_stat_size;             /* static segs what were just unsaved */
234                end;
235 
236           call condition_("cleanup", cleanup_handler);
237 
238 cleanup_handler: proc;
239 
240           if lisp_static_vars_$cleanup_list_exists then do; /* cleanup feature */
241              if lisp_static_vars_$i_am_gcing
242              then call ioa_$ioa_switch(iox_$error_output,
243                               "lisp:  Sorry, unable to execute (sstatus cleanup) list.");
244                                         /* should have been done already by lisp_fault_handler_ and lisp_garbage_collector_ */
245              else do;
246                     dcl stack pointer;
247                     lisp_static_vars_$cleanup_list_exists = "0"b;     /* once only */
248                     stack = stack_ptr;
249                     stack_ptr = addr(stack -> temp(3));
250                     do stack -> temp(1) = lisp_static_vars_$cleanup_list
251                          repeat (stack -> temp_ptr(1) -> cons.cdr)
252                          while (stack -> temp_type(1) = Cons);
253                        stack -> temp(2) = stack -> temp_ptr(1) -> cons.car;
254                        call lisp_$eval;
255                        end;
256                     end;
257              end;
258 
259           lisp_static_vars_$ignore_faults = "1"b;           /* ignore while throwing away environment */
260           call lisp_io_control_$cleanup;
261           call lisp_segment_manager_$free_stack(our_stack); /* free push down list segment */
262           stack = ptr(stack_ptr,0);
263           call lisp_segment_manager_$free_stack(stack);
264           finishup = oldfinishup;       /* reset finishup to old value */
265           do while(lisp_alloc_$cur_seg ^= null());
266                stack = lisp_alloc_$cur_seg;
267                lisp_alloc_$cur_seg = stack -> alloc_segment.next_seg;
268                call lisp_segment_manager_$free_lists(stack);
269           end;
270           lisp_alloc_$alloc_info = old_alloc_info;
271           call lisp_static_man_$free_stat_segs;             /* free any static segs we were using */
272           if level >= 2 then                      /* this was recursive entry, restore contents of lisp_static_vars_ */
273                     addr(lisp_static_vars_$lisp_static_vars_) -> words_to_be_moved_sas = save_area;
274           level = level - 1;
275   end cleanup_handler;
276           our_stack -> stack_seg.true = t_atom;
277           our_stack -> stack_seg.nil = nil;
278           lisp_static_vars_$property_list_of_nil = nil;     /* clear nil's strange property list */
279           lisp_static_vars_$cleanup_list = nil;             /* clear cleanup list */
280 
281           call lisp_io_control_$init;
282           lisp_static_vars_$emptying_buffers = -1;          /* init variable used by lisp_default_handler_ */
283 
284           /* allow garbage collections and initialize the reader */
285 
286           dcl lisp_static_vars_$garbage_collect_inhibit bit(1) aligned external,
287               lisp_static_vars_$rdr_state fixed bin aligned external;
288 
289           lisp_static_vars_$garbage_collect_inhibit = "0"b;
290           lisp_static_vars_$rdr_state = 0;
291 
292           /* initialize the random number memory */
293 
294           lisp_static_vars_$hi_random =
295                "010110111111110010001001011011011111001101101010101110000111001001001010"b;
296 
297           call lisp_fault_handler_$init;                    /* set up the fault and quit mechanism */
298           lisp_static_vars_$quit_handler_flag = "0"b;       /* allow lisp to handle quits */
299           call condition_("any_other", lisp_default_handler_);
300           addr(SLASH)->based_ptr -> atom.value = addr(errlist)->based_ptr -> atom.value;  /* for auto-start */
301           lisp_static_vars_$ignore_faults = "0"b;
302 
303           /* establish pi handler */
304 
305           on program_interrupt begin;
306                     dcl damage bit(1) aligned,
307                         lisp_fault_handler_$check_for_damage entry(bit(1)aligned);
308 
309                     call lisp_fault_handler_$check_for_damage(damage);          /* stacks may have been screwed,
310                                                                                    since we probably took a fault */
311 
312 ask_ctrl:           if lisp_static_vars_$masked.against.tty then
313                          if damage then call ioa_$ioa_switch(iox_$error_output, "Warning: was in (nointerrupt t) mode at the time");
314                               else if lisp_static_vars_$mulpi_state ^= -1 then; /*Let it get queued */
315                               else do;
316                               /* Don't allow pi here, especially since might have  been collecting garbage */
317                               call ioa_$ioa_switch(iox_$error_output, "lisp: (nointerrupt t) mode, unable to accept pi.");
318                               go to leave_pi;
319                               end;
320                     lisp_static_vars_$quit_handler_flag = "0"b;
321                     if ^lisp_static_vars_$masked.against.tty then
322                     string(lisp_static_vars_$masked.against) = ""b;   /* so ctrl chars will be accepted */
323                     call lisp_default_handler_$program_interrupt;     /* ask for a ctrl char */
324                     /* if fault handler returns, on unit returns and program will restart */
325 leave_pi:           end;
326 ^L
327 /* eval supervisor loop */
328 
329           read_print_nl_sync = "1"b;
330           stack = stack_ptr;
331           addr(ctrlR)->based_ptr->atom.value = nil;
332 
333 enter_loop:
334           lisp_static_vars_$evalhook_status = lisp_$evalhook_off_status;
335           addr(lisp_static_vars_$evalhook_atom)->based_ptr->atom.value,
336           addr(ctrlQ)->based_ptr->atom.value,
337           addr(ctrlW)->based_ptr->atom.value = nil;         /* set i/o switches */
338 
339           stack_ptr = addr(stack->temp(3));
340           stack -> temp(1) = addr(SLASH)->based_ptr->atom.value;
341           do while(stack->temp(1)^=nil);                    /* eval all errlist items */
342                stack->temp(2) = stack->temp_ptr(1)->cons.car;
343                stack->temp(1) = stack->temp_ptr(1)->cons.cdr;
344                call lisp_$eval;
345           end;
346           stack->temp(1) = STAR;
347 loop:     stack_ptr = addr(stack->temp(3));
348           addr(STAR)->based_ptr->atom.value = stack->temp(1);
349           if toplevel ^= nil
350           then stack->temp(1) = toplevel;
351           else do;
352                     stack -> temp(2) = stack -> temp(1);    /* apply print to it */
353                     if lisp_static_vars_$prin1->atom.value = nil | lisp_static_vars_$prin1->atom.value = 0
354                     then stack -> temp(1) = lisp_static_vars_$print_atom;
355                     else stack -> temp(1) = lisp_static_vars_$prin1->atom.value;
356                     call lisp_special_fns_$ncons;
357                     call lisp_$apply;
358                     if addr(ctrlQ) -> based_ptr -> atom.value = nil   /* if input to be got from console */
359                     then do;
360 tty_loop:                     call lisp_print_$type_nl;               /* so prompt the user */
361                               stack_ptr = addr(stack -> temp(2));
362                               stack -> fixnum_fmt.type_info = fixnum_type;
363                               stack -> fixedb = 0;                    /* tell reader its argcount */
364                               call lisp_reader_$read;
365                               end;
366                     else do;                                          /* input from file (unless near eof) */
367 uread_loop:                   stack_ptr = addr(stack -> temp(3));
368                               addr(stack -> temp(2))->fixnum_fmt.type_info = fixnum_type;
369                               addr(stack -> temp(2))->fixedb = -2;    /* giving reader one arg, which is */
370                               stack -> flonum_fmt.type_info = flonum_type;
371                               stack -> fixedb = 0;                    /* an impossible flonum */
372                               call lisp_reader_$read;
373                               if stack -> flonum_fmt.type_info = flonum_type
374                                then if stack -> fixedb = 0            /* this file has come to the end, switch */
375                                 then go to tty_loop;                  /* back to the tty. Prompt user then call
376                                                                          read again to close the file, clear ^q,
377                                                                          and switch to the tty */
378                               end;
379                     addr(PLUS)->based_ptr -> atom.value = addr(MINUS)->based_ptr -> atom.value;
380                     addr(MINUS)->based_ptr -> atom.value = stack -> temp(1);
381                end;
382           stack_ptr = addr(stack -> temp(2));
383           call lisp_$eval;
384           go to loop;
385 ^L
386           /*** come here when err'ing all the way back to top level ***/
387           /*** resets the reader then re-enters the top-level loop ****/
388 
389 top_level_err:
390           stack = stack_ptr;
391           stack_ptr = addr(stack -> temp(2));
392           stack -> temp(1) = nil;
393           call lisp_io_control_$clear_input;                /* flush tty buffer & resetread the stream */
394           string(unmask.against) = ""b;
395           if lisp_static_vars_$pending_ctrl then call lisp_fault_handler_$set_mask(unmask);
396           go to enter_loop;
397 
398 
399 
400 done:     call reversion_("cleanup");             /* don't want cleanup handler executed twice */
401           lisp_static_vars_$cleanup_list_exists = "0"b;     /* don't do user cleanup handler */
402           call cleanup_handler;
403           return;                       /* escape out of begin block and proc */
404 
405 
406 end first_stack_frame_for_lisp;                   /* end of big begin block */
407 ^L
408 save:     entry;
409 
410 /* entry for "save" function, which saves environments */
411 
412           call lisp_io_control_$empty_all_buffers;
413           stack = addrel(stack_ptr,-2);
414 
415           stack -> temp(1) = stack -> temp_ptr(1) -> cons.car;        /* error trapped by fault here */
416 retry_save:                                                           /* come here to try with better arg */
417           if stack -> temp_type36(1) & String36 then call lisp_save_(stack -> temp_ptr(1) -> lisp_string.string);
418           else if stack -> temp_type36(1) & Atsym36 then call lisp_save_(stack -> temp_ptr(1) -> atom.pname);
419           else do;
420                     our_stack = unmkd_ptr;
421                     unmkd_ptr = addrel(our_stack,2);
422                     our_stack -> errcode(1) = lisp_error_table_$bad_arg_correctable;
423                     our_stack -> errcode(2) = fn_save;
424                     call lisp_error_;
425                     go to retry_save;
426                end;
427           if lisp_static_vars_$ignore_faults then;
428                     else return;                                      /* save crapped out before munging environment,
429                                                                          give loser another chance to save */
430 
431           /* otherwise, save won so cleanup and quit */
432 
433 
434 lisp$quit:          entry;
435 
436 /* this is the "quit"  function, which causes a return out of the LISP subsystem */
437 
438 
439           call lisp_io_control_$empty_all_buffers;
440           goto finishup;      /* finishup is set to "done", via non-local go to */
441 
442 
443      end;