lisp.pl1 07/06/83 0937.0r w 06/29/83 1542.1 157392 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp: proc; /* command interface to the Multics LISP subsystem. First coded for the second version of the Multics LISP implementation on 3/15/71. Modified for use of standard Multics linkage mechanism, 7/15/71. D. Reed Changed for new definition of (status toplevel) and to add cleanup handler for new I/O system, 24 Mar 1973, DAM Modified to allow recursive entry of the lisp subsystem, 6/2/73 by DAM Modified 74.11.01 by DAM to remove references to establish_cleanup_proc_ and default_handler_ Modified 74.12.09 by DAM for (sstatus cleanup) feature Modified 78.12.08 by BSG for (sstatus mulpi) feature */ dcl level static init(0) fixed bin; /* level of recursion */ dcl (lisp_static_vars_$template fixed bin, lisp_static_vars_$template_size fixed bin, lisp_static_vars_$cur_stat_seg ptr, lisp_static_vars_$cur_stat_pos fixed bin(19), lisp_static_vars_$subsys_recurse_save_size fixed bin) external static; dcl lisp_static_vars_$property_list_of_nil fixed bin(71) external, lisp_error_table_$bad_arg_correctable fixed bin external; dcl ioa_$ioa_switch external entry options(variable), iox_$error_output external ptr, lisp_static_vars_$ignore_faults bit(36) ext aligned, lisp_static_vars_$mulpi_state fixed bin (17) ext aligned, lisp_static_vars_$quit_handler_flag bit(1) external, lisp_static_vars_$gc_time fixed bin(71) ext aligned, lisp_static_vars_$emptying_buffers fixed bin external, lisp_static_vars_$hi_random bit(72) ext aligned, saved_ignore_faults bit(36) aligned; dcl cu_$arg_ptr_rel entry(fixed bin,ptr,fixed bin,fixed bin, ptr), lisp_fault_handler_$init entry, 1 unmask aligned like masked, lisp_segment_manager_$get_stack entry(ptr), lisp_segment_manager_$free_stack entry(ptr), lisp_segment_manager_$get_lists entry(ptr), lisp_segment_manager_$free_lists entry(ptr), arg_list_ptr ptr, cu_$arg_list_ptr entry(ptr), save_area_size fixed bin, foo fixed bin(71)aligned, tempp ptr, lisp_error_ entry, errcode(2) fixed bin based aligned, lisp_get_atom_ entry(char(*)aligned,fixed bin(71)aligned), condition_ entry (char(*), entry), reversion_ entry(char(*)), program_interrupt condition, lisp_default_handler_$program_interrupt entry, lisp_default_handler_ entry, lisp_io_control_$empty_all_buffers entry, lisp_io_control_$clear_input entry, lisp_io_control_$cleanup entry, lisp_io_control_$init entry, lisp_boot_ entry, lisp_save_$unsave entry(char(*),ptr,fixed bin(18),fixed bin), lisp_save_ entry(char(*) aligned), lisp_reader_$read entry, lisp_print_$type_nl entry, lisp_static_vars_$print_atom fixed bin(71) external, lisp_static_vars_$prin1 ptr external, lisp_special_fns_$ncons entry, lisp_$apply entry, lisp_$eval entry, our_stack ptr, stack ptr, i fixed bin, lisp_get_atom_$init_ht entry, subr_type fixed bin(2) aligned, lisp_static_man_$free_stat_segs entry, finishup label static, (null,ptr,addr,rel,bit,fixed,mod,substr,addrel,string) builtin; dcl lisp_static_vars_$evalhook_status bit(36) aligned external, lisp_static_vars_$evalhook_atom fixed bin(71) external, lisp_$evalhook_off_status bit(36) aligned external; dcl lisp_oprs_$init entry; dcl 1 cclist based, /* overlay for header of compiled constant list block which is a type of internal static storage known to the lisp garbage collector */ 2 next_ccl_entry ptr, 2 init_flag fixed bin; dcl lisp_static_vars_$cleanup_list_exists bit(1) aligned external, lisp_static_vars_$cleanup_list fixed bin(71) external, lisp_static_vars_$i_am_gcing bit(1) aligned external; /* The structure of the lisp stack segment -- as known only to this and one other program */ %include lisp_stack_seg; %include lisp_free_storage; %include lisp_io; %include lisp_stack_fmt; %include lisp_nums; %include lisp_initial_atoms; %include lisp_common_vars; %include lisp_faults; dcl unm pointer; /* useless */ %include lisp_name_codes; %include lisp_atom_fmt; %include lisp_cons_fmt; %include lisp_string_fmt; %include lisp_ptr_fmt; %include lisp_subr_fmt; /* */ /* for the benefit of losers who use uread, add the reference name lisp_old_io_ to us */ call hcs_$fs_get_path_name(addr(lisp$), xdn, 0, xen, 0); call hcs_$initiate(xdn, xen, "lisp_old_io_", 0, 0, null, 0); dcl xdn char(168), xen char(32), lisp$ external, hcs_$fs_get_path_name entry(pointer, char(*), fixed bin, char(*), fixed bin(5)), hcs_$initiate entry(char(*), char(*), char(*), fixed bin, fixed bin, pointer, fixed bin(35)); /* begin by getting arg list ptr and computing size of save area needed. Then enter begin block */ call cu_$arg_list_ptr(arg_list_ptr); level = level + 1; if level >= 2 then save_area_size = lisp_static_vars_$subsys_recurse_save_size; else save_area_size = 0; /* if first entry, no need to save anything */ first_stack_frame_for_lisp: begin; dcl arglen fixed bin, argptr ptr, argname char(arglen) based (argptr), code fixed bin, old_stat_size fixed bin(18), old_stat_ptr ptr, old_alloc_info bit(288) aligned, /* to save lisp_alloc_$allo_info in */ oldfinishup automatic label variable, our_stack pointer, stack pointer; dcl save_area bit(36) aligned dimension(save_area_size); dcl words_to_be_moved_sas bit(36) aligned based dimension (save_area_size), words_to_be_moved_ts bit(36) aligned based dimension(lisp_static_vars_$template_size); /* save lisp_static_vars_ in our stack frame */ if save_area_size ^= 0 then save_area = addr(lisp_static_vars_$lisp_static_vars_) -> words_to_be_moved_sas; /* init first part of lisp_static_vars_ from template */ addr(lisp_static_vars_$lisp_static_vars_) -> words_to_be_moved_ts = addr(lisp_static_vars_$template) -> words_to_be_moved_ts; /* make a segment for the push down list */ call lisp_segment_manager_$get_stack(our_stack); prog_frame, err_frame, catch_frame, unwp_frame, binding_top, err_recp, eval_frame = our_stack; unmkd_ptr = addr(our_stack->stack_seg.begin_unmkd_stack); call lisp_segment_manager_$get_stack(stack_ptr); stack_ptr = addrel(stack_ptr,2); /* kludge for pdl ptrs */ our_stack->stack_seg.marked_stack_bottom = stack_ptr; our_stack->stack_seg.stack_ptr_ptr = addr(stack_ptr); our_stack->stack_seg.unmkd_stack_bottom = addr(our_stack->begin_unmkd_stack); our_stack->stack_seg.in_pl1_code = "1"b; our_stack->stack_seg.unmkd_ptr_ptr = addrel(addr(unmkd_ptr),1); /* so can store only offset */ /* set addresses of lisp operators in the stack header */ call lisp_oprs_$init; old_alloc_info = lisp_alloc_$alloc_info; oldfinishup = finishup; /* just in case we quit out of an old lisp invocation */ finishup = done; /* return for top level return or go to, and return for cleanup handler is"done" */ lisp_static_vars_$top_level = top_level_err; /* error return */ /* save ptr to arg list for (status jcl), (status arg _n) */ dcl lisp_static_vars_$arg_list_ptr external pointer; lisp_static_vars_$arg_list_ptr = arg_list_ptr; /* now look at argument, and decide what is to be done about unsaving an environment */ call cu_$arg_ptr_rel(1,argptr,arglen,code, arg_list_ptr); if code = 0 then do; if argname = "-boot" then do; /* if we want bootstrap environment generate it */ lisp_static_vars_$cur_stat_seg = null; /* start with no static segs */ lisp_static_vars_$cur_stat_pos = 262144;/* causes immediate allocation of a static seg on first call to lisp_static_man_ */ call lisp_segment_manager_$get_lists(lisp_alloc_$cur_seg); /* get a free storage segment */ lisp_alloc_$cur_seg -> alloc_segment.next_seg = null(); lisp_alloc_$cur_seg -> alloc_segment.tally_word.seg_offset = "000000000000000100"b; lisp_alloc_$cur_seg -> alloc_segment.tally_word.tally = "111100000000"b; lisp_alloc_$cur_seg -> alloc_segment.tally_word.delta = 4; lisp_alloc_$consptr = addr(lisp_alloc_$cur_seg->alloc_segment.tally_word); consptr_ovly.mod = "101011"b; lisp_alloc_$gc_blk_cntr = -1; /* one 16k block before gc */ lisp_alloc_$seg_blk_cntr = -16; /* 16 16k blocks per segment */ /* make sure garbage collect doesn't occur until initialization done */ lisp_static_vars_$garbage_collect_inhibit = "1"b; call lisp_boot_; end; else do; call lisp_save_$unsave(argname,old_stat_ptr, old_stat_size, code); /* unsave indicated saved environment */ go to unsaved; end; end; else do; call lisp_save_$unsave("",old_stat_ptr,old_stat_size,code); /* unsave standard enviroment */ unsaved: if code ^= 0 then return; /* if error then return to caller */ lisp_static_vars_$cur_stat_seg = old_stat_ptr; /* tell lisp_static_man_ about the */ lisp_static_vars_$cur_stat_pos = old_stat_size; /* static segs what were just unsaved */ end; call condition_("cleanup", cleanup_handler); cleanup_handler: proc; if lisp_static_vars_$cleanup_list_exists then do; /* cleanup feature */ if lisp_static_vars_$i_am_gcing then call ioa_$ioa_switch(iox_$error_output, "lisp: Sorry, unable to execute (sstatus cleanup) list."); /* should have been done already by lisp_fault_handler_ and lisp_garbage_collector_ */ else do; dcl stack pointer; lisp_static_vars_$cleanup_list_exists = "0"b; /* once only */ stack = stack_ptr; stack_ptr = addr(stack -> temp(3)); do stack -> temp(1) = lisp_static_vars_$cleanup_list repeat (stack -> temp_ptr(1) -> cons.cdr) while (stack -> temp_type(1) = Cons); stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; call lisp_$eval; end; end; end; lisp_static_vars_$ignore_faults = "1"b; /* ignore while throwing away environment */ call lisp_io_control_$cleanup; call lisp_segment_manager_$free_stack(our_stack); /* free push down list segment */ stack = ptr(stack_ptr,0); call lisp_segment_manager_$free_stack(stack); finishup = oldfinishup; /* reset finishup to old value */ do while(lisp_alloc_$cur_seg ^= null()); stack = lisp_alloc_$cur_seg; lisp_alloc_$cur_seg = stack -> alloc_segment.next_seg; call lisp_segment_manager_$free_lists(stack); end; lisp_alloc_$alloc_info = old_alloc_info; call lisp_static_man_$free_stat_segs; /* free any static segs we were using */ if level >= 2 then /* this was recursive entry, restore contents of lisp_static_vars_ */ addr(lisp_static_vars_$lisp_static_vars_) -> words_to_be_moved_sas = save_area; level = level - 1; end cleanup_handler; our_stack -> stack_seg.true = t_atom; our_stack -> stack_seg.nil = nil; lisp_static_vars_$property_list_of_nil = nil; /* clear nil's strange property list */ lisp_static_vars_$cleanup_list = nil; /* clear cleanup list */ call lisp_io_control_$init; lisp_static_vars_$emptying_buffers = -1; /* init variable used by lisp_default_handler_ */ /* allow garbage collections and initialize the reader */ dcl lisp_static_vars_$garbage_collect_inhibit bit(1) aligned external, lisp_static_vars_$rdr_state fixed bin aligned external; lisp_static_vars_$garbage_collect_inhibit = "0"b; lisp_static_vars_$rdr_state = 0; /* initialize the random number memory */ lisp_static_vars_$hi_random = "010110111111110010001001011011011111001101101010101110000111001001001010"b; call lisp_fault_handler_$init; /* set up the fault and quit mechanism */ lisp_static_vars_$quit_handler_flag = "0"b; /* allow lisp to handle quits */ call condition_("any_other", lisp_default_handler_); addr(SLASH)->based_ptr -> atom.value = addr(errlist)->based_ptr -> atom.value; /* for auto-start */ lisp_static_vars_$ignore_faults = "0"b; /* establish pi handler */ on program_interrupt begin; dcl damage bit(1) aligned, lisp_fault_handler_$check_for_damage entry(bit(1)aligned); call lisp_fault_handler_$check_for_damage(damage); /* stacks may have been screwed, since we probably took a fault */ ask_ctrl: if lisp_static_vars_$masked.against.tty then if damage then call ioa_$ioa_switch(iox_$error_output, "Warning: was in (nointerrupt t) mode at the time"); else if lisp_static_vars_$mulpi_state ^= -1 then; /*Let it get queued */ else do; /* Don't allow pi here, especially since might have been collecting garbage */ call ioa_$ioa_switch(iox_$error_output, "lisp: (nointerrupt t) mode, unable to accept pi."); go to leave_pi; end; lisp_static_vars_$quit_handler_flag = "0"b; if ^lisp_static_vars_$masked.against.tty then string(lisp_static_vars_$masked.against) = ""b; /* so ctrl chars will be accepted */ call lisp_default_handler_$program_interrupt; /* ask for a ctrl char */ /* if fault handler returns, on unit returns and program will restart */ leave_pi: end; /* eval supervisor loop */ read_print_nl_sync = "1"b; stack = stack_ptr; addr(ctrlR)->based_ptr->atom.value = nil; enter_loop: lisp_static_vars_$evalhook_status = lisp_$evalhook_off_status; addr(lisp_static_vars_$evalhook_atom)->based_ptr->atom.value, addr(ctrlQ)->based_ptr->atom.value, addr(ctrlW)->based_ptr->atom.value = nil; /* set i/o switches */ stack_ptr = addr(stack->temp(3)); stack -> temp(1) = addr(SLASH)->based_ptr->atom.value; do while(stack->temp(1)^=nil); /* eval all errlist items */ stack->temp(2) = stack->temp_ptr(1)->cons.car; stack->temp(1) = stack->temp_ptr(1)->cons.cdr; call lisp_$eval; end; stack->temp(1) = STAR; loop: stack_ptr = addr(stack->temp(3)); addr(STAR)->based_ptr->atom.value = stack->temp(1); if toplevel ^= nil then stack->temp(1) = toplevel; else do; stack -> temp(2) = stack -> temp(1); /* apply print to it */ if lisp_static_vars_$prin1->atom.value = nil | lisp_static_vars_$prin1->atom.value = 0 then stack -> temp(1) = lisp_static_vars_$print_atom; else stack -> temp(1) = lisp_static_vars_$prin1->atom.value; call lisp_special_fns_$ncons; call lisp_$apply; if addr(ctrlQ) -> based_ptr -> atom.value = nil /* if input to be got from console */ then do; tty_loop: call lisp_print_$type_nl; /* so prompt the user */ stack_ptr = addr(stack -> temp(2)); stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = 0; /* tell reader its argcount */ call lisp_reader_$read; end; else do; /* input from file (unless near eof) */ uread_loop: stack_ptr = addr(stack -> temp(3)); addr(stack -> temp(2))->fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2))->fixedb = -2; /* giving reader one arg, which is */ stack -> flonum_fmt.type_info = flonum_type; stack -> fixedb = 0; /* an impossible flonum */ call lisp_reader_$read; if stack -> flonum_fmt.type_info = flonum_type then if stack -> fixedb = 0 /* this file has come to the end, switch */ then go to tty_loop; /* back to the tty. Prompt user then call read again to close the file, clear ^q, and switch to the tty */ end; addr(PLUS)->based_ptr -> atom.value = addr(MINUS)->based_ptr -> atom.value; addr(MINUS)->based_ptr -> atom.value = stack -> temp(1); end; stack_ptr = addr(stack -> temp(2)); call lisp_$eval; go to loop; /*** come here when err'ing all the way back to top level ***/ /*** resets the reader then re-enters the top-level loop ****/ top_level_err: stack = stack_ptr; stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = nil; call lisp_io_control_$clear_input; /* flush tty buffer & resetread the stream */ string(unmask.against) = ""b; if lisp_static_vars_$pending_ctrl then call lisp_fault_handler_$set_mask(unmask); go to enter_loop; done: call reversion_("cleanup"); /* don't want cleanup handler executed twice */ lisp_static_vars_$cleanup_list_exists = "0"b; /* don't do user cleanup handler */ call cleanup_handler; return; /* escape out of begin block and proc */ end first_stack_frame_for_lisp; /* end of big begin block */ save: entry; /* entry for "save" function, which saves environments */ call lisp_io_control_$empty_all_buffers; stack = addrel(stack_ptr,-2); stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* error trapped by fault here */ retry_save: /* come here to try with better arg */ if stack -> temp_type36(1) & String36 then call lisp_save_(stack -> temp_ptr(1) -> lisp_string.string); else if stack -> temp_type36(1) & Atsym36 then call lisp_save_(stack -> temp_ptr(1) -> atom.pname); else do; our_stack = unmkd_ptr; unmkd_ptr = addrel(our_stack,2); our_stack -> errcode(1) = lisp_error_table_$bad_arg_correctable; our_stack -> errcode(2) = fn_save; call lisp_error_; go to retry_save; end; if lisp_static_vars_$ignore_faults then; else return; /* save crapped out before munging environment, give loser another chance to save */ /* otherwise, save won so cleanup and quit */ lisp$quit: entry; /* this is the "quit" function, which causes a return out of the LISP subsystem */ call lisp_io_control_$empty_all_buffers; goto finishup; /* finishup is set to "done", via non-local go to */ end;  lisp_array_fcns_.pl1 07/06/83 0937.0r w 06/29/83 1542.2 396558 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_array_fcns_: procedure; /* This procedure implements all of the lisp sorting functions. The algorithm used is a slightly modified version of the algorithm "heapsort", as described in Knuth, Vol. III. In addition, several array utility functions are implemented here, as they use common code to handle array properties. In addition, various array manipulation functions are provided. Coded D. Reed, July 10, 1973. Modified 74.05.14 by DAM to: [1] move the sorting package to the end. [2] add the rest of the array manipulation functions (formerly in lisp_defsubr_) i.e. *array, array, arraydims, *rearray, bltarray. [3] implement the "new array" scheme. NOTE: this code frequently relies on the knowledge that fixnums and flonums are stored in an equivalent format, and that flonum assignment may be performed using a fixnum overlay. This is to eliminate extra unnecessary special cases. Modified 74.12.06 by DAM for changes in definition of listarray and fillarray and for external arrays, which are 1-dimensional fixnum arrays stored in external segments. */ dcl (stack, tstack, ustack ) ptr, lisp_property_fns_$get entry, lisp_error_ entry, lisp_alloc_$cons entry, lisp_alloc_$ncons entry, lisp_static_man_$allocate entry(pointer, fixed bin(18)), lisp_alloc_ entry(fixed bin(18), pointer), lisp_$eval entry, lisp_list_utils_$subst entry, lisp_property_fns_$putprop entry, lisp_$snapcaller entry, /* special entry to evaluator */ (lisp_static_vars_$alphalessp_atom, lisp_static_vars_$readtable, lisp_static_vars_$external, lisp_static_vars_$fixnum, lisp_static_vars_$flonum) fixed bin(71) external, L fixed bin, /* Knuth's losing 1 char variable names */ R fixed bin, arraydim fixed bin, 1 snapcall_args based aligned, 2 fn_offset fixed bin, 2 arg_length fixed bin, 1 error_args based aligned, 2 code fixed bin, 2 name fixed bin, myname fixed bin, temp_item fixed bin(71), special_action_flag bit(1), (addr, addrel, divide, unspec, null, substr, mod, min, ptr, size) builtin; dcl type_field bit(36) aligned, /* type field to fill in in number sort */ entry_id fixed bin; /* code for type of sort to do: 0 S-expression sort 1 S-expression sortcar 2 S-expression alphasort 3 S-expression alphasortcar -1 Number sort */ dcl ndims fixed bin, nargs fixed bin, star_rearray bit(1), other_array_type fixed bin, other_array_ptr pointer, other_array_size fixed bin(18), external_array bit(1), /* flag on if creating an external array */ array_type fixed bin, array_ptr pointer, array_size fixed bin(18), i fixed bin(18); dcl 1 packed_pointer_aligned aligned based, 2 packed_pointer unaligned pointer; dcl (fix1, fix2) fixed bin(35), (float1, float2) float bin(27); /* Error Codes */ dcl (lisp_error_table_$bad_argument, lisp_error_table_$wrong_external_array_ndims, lisp_error_table_$argument_must_be_array, lisp_error_table_$not_same_type, lisp_error_table_$special_array_type, lisp_error_table_$too_few_args, lisp_error_table_$too_many_args, lisp_error_table_$array_too_big, lisp_error_table_$store_not_allowed, lisp_error_table_$not_an_array, lisp_error_table_$not_alpha_array, lisp_error_table_$dead_array_reference) fixed bin external; dcl bad_argument fixed bin defined lisp_error_table_$bad_argument, wrong_external_array_ndims fixed bin defined lisp_error_table_$wrong_external_array_ndims, argument_must_be_array fixed bin defined lisp_error_table_$argument_must_be_array, not_same_type fixed bin defined lisp_error_table_$not_same_type, special_array_type fixed bin defined lisp_error_table_$special_array_type, too_few_args fixed bin defined lisp_error_table_$too_few_args, too_many_args fixed bin defined lisp_error_table_$too_many_args, array_too_big fixed bin defined lisp_error_table_$array_too_big, store_not_allowed fixed bin defined lisp_error_table_$store_not_allowed, not_an_array fixed bin defined lisp_error_table_$not_an_array, not_alpha_array fixed bin defined lisp_error_table_$not_alpha_array, dead_array_reference fixed bin defined lisp_error_table_$dead_array_reference; /* information used in constructing arrays */ dcl fault_tag_3_number_2 bit(72) static init("000000000000000010000000000000100111000000000000000000000000000000000000"b); dcl words_per_item (0:5) fixed bin static init(2,2,1,1,1,2); dcl 1 array_load_sequence(0:5) static aligned, /* instructions to load from array */ 2 inst(3) bit(36) initial( (2)("101000000000000000010011111001000110"b, "010000000000000000111001000001000000"b, ""b), /* S-expr, Un-gc: ldaq lb|0,ql tra bp|0 */ "000100000000100111010011101000000111"b, "101000000000000000010011110001000110"b, "010000000000000000111001000001000000"b, /* fixnum - lda 040047,dl ldq lb|0,ql tra bp|0 */ "000010000000100111010011101000000111"b, "101000000000000000010011110001000110"b, "010000000000000000111001000001000000"b, /* flonum - lda 020047,dl ldq lb|0,ql tra bp|0 */ "000100000000100111010011101000000111"b, "101000000000000000010011110001000110"b, "010000000000000000111001000001000000"b, /* readtable - lda 040047,dl ldq lb|0,ql tra bp|0 */ "101000000000000000010011111001000110"b, "010000000000000000111001000001000000"b, ""b); /* obarray - ldaq lb|0,ql tra bp|0 */ dcl fixed_data (0:array_size-1) fixed bin(35) aligned based, float_data (0:array_size-1) float bin(27) aligned based, array_element (0:array_size-1) fixed bin(71) aligned based, bounds (ndims) fixed bin(18) aligned based(ustack); /* vector of bounds in unmkd pdl */ %include lisp_array_fmt; %include lisp_stack_seg; %include lisp_nums; %include lisp_readtable; %include lisp_common_vars; %include lisp_cons_fmt; %include lisp_name_codes; %include lisp_stack_fmt; %include lisp_ptr_fmt; %include lisp_atom_fmt; %include lisp_string_fmt; star_array: entry; /* LISP *array function, create an array */ myname = fn_star_array; call lsubr_initialization; star_rearray = "0"b; call make_array; /* call common code for array and *array */ go to exit; make_array: procedure; special_action_flag = "0"b; external_array = "0"b; unspec(ptr(ustack, 0) -> stack_seg.array_info_for_store) = fault_tag_3_number_2; ndims = divide(nargs, -2, 17, 0)-2; /* number of dimensions in array */ /* identify type of array to be created */ if stack -> temp(2) = nil then array_type = Un_gc_array; else if stack -> temp(2) = t_atom then array_type = S_expr_array; else if stack -> temp(2) = lisp_static_vars_$fixnum then array_type = Fixnum_array; else if stack -> temp(2) = lisp_static_vars_$flonum then array_type = Flonum_array; else if stack -> temp(2) = lisp_static_vars_$obarray then array_type = Obarray_array; else if stack -> temp(2) = lisp_static_vars_$readtable then array_type = Readtable_array; else if stack -> temp(2) = lisp_static_vars_$external then do; external_array = "1"b; array_type = Fixnum_array; /* looks much like a fixnum array */ ndims = ndims - 1; /* First "dimension" is packed ptr */ if ndims ^= 1 then call reject_argument(1, wrong_external_array_ndims); end; else call reject_argument(2, bad_argument); /* first argument may be nil (generate array pointer), an array pointer (to be reused), or an atomic symbol (apply to array property) */ if stack -> temp(1) = nil then if ^ star_rearray then call make_array_pointer; else call reject_argument(1, bad_argument); else if stack -> temp_type36(1) & Atsym36 then do; call get_array_prop; if tstack -> temp(1) = nil then do; /* put on array property */ if star_rearray then call reject_argument(1, argument_must_be_array); tstack -> temp(1) = stack -> temp(1); /* symbol */ call make_array_pointer; stack_ptr = addr(tstack -> temp(4)); tstack -> temp(2) = stack -> temp(1); /* array ptr */ tstack -> temp(3) = lisp_static_vars_$array_atom; /* 'array */ call lisp_property_fns_$putprop; end; else stack -> temp(1) = tstack -> temp(1); /* prior array property */ end; if stack -> temp_type36(1) & Array36 then if ^ star_rearray then call kill_array; else; /* don't kill the array if *rearray */ else call reject_argument(1, bad_argument); /* special checks for *rearray - type must match and not be special */ if star_rearray then do; if array_type ^= stack -> temp_ptr(1) -> array_info.type then call reject_argument(2, not_same_type); if array_type >= Readtable_array then call reject_argument(1, special_array_type); other_array_size = 1; /* compute old size */ other_array_ptr = stack -> temp_ptr(1) -> array_info.array_data_ptr; do i = 1 to stack -> temp_ptr(1) -> array_info.ndims; other_array_size = other_array_size * other_array_ptr -> array_data.dope_vector(i - stack -> temp_ptr(1) -> array_info.ndims).bounds; end; end; /* at this point, stack -> temp(1) is an array pointer to an array info block, dead unless *rearray. Now fill in the info block */ if array_type >= Readtable_array then ndims = 1; /* args treated differently in these cases */ stack -> temp_ptr(1) -> array_info.ndims = ndims; stack -> temp_ptr(1) -> array_info.minus_2_times_ndims = -2*ndims; stack -> temp_ptr(1) -> array_info.gc_mark = ""b; stack -> temp_ptr(1) -> array_info.array_load_sequence = array_load_sequence(array_type).inst(*); if ^ external_array then do; /* following code omitted for ext arrays */ /* create copy of bounds vector in unmkd pdl, do error checking, and compute number of elements in the array (array_size) */ if ndims <= 0 then call reject_argument(1, too_few_args); else if ndims > 510 then call reject_argument(1, too_many_args); unmkd_ptr = addrel(ustack, ndims+mod(ndims,2)); /* room for bounds vector, even word alignment */ if array_type < Readtable_array then do; /* bounds come from arguments */ array_size = 1; do i = 1 to ndims; if stack -> temp_type36(i+2) & Fixed36 then do; bounds(i) = addr(stack -> temp(i+2)) -> fixedb; if bounds(i) < 0 then call reject_argument(i+2, bad_argument); else array_size = array_size * bounds(i); end; else call reject_argument(i+2, bad_argument); end; end; else if array_type = Readtable_array then do; /* Readtable */ array_size, bounds(1) = 290; end; else do; /* Obarray */ array_size, bounds(1) = 639; end; /* create data area */ i = words_per_item(array_type)*array_size + 2*ndims; if i > 50000 then call reject_argument(1, array_too_big); /* decide it is too big */ call lisp_alloc_(i, array_ptr); array_ptr = addrel(array_ptr, 2*ndims); /* -> after dope vector, before data */ other_array_ptr = stack -> temp_ptr(1) -> array_info.array_data_ptr; /* may have gc'ed */ /* initialize dope vector */ do i = 1 to ndims; array_ptr -> array_data.dope_vector(i-ndims).bounds = bounds(i); end; array_ptr -> array_data.dope_vector(ZERO).multiplier = words_per_item(array_type); do i = ndims-1 by -1 to 1; array_ptr -> array_data.dope_vector(i-ndims).multiplier = bounds(i+1); end; /* initialize the data area */ if ^ star_rearray then other_array_size = 0; /* if nothing to copy */ if array_type < Fixnum_array /* init to nil */ then do; do i = 0 by 1 to min(array_size, other_array_size)-1; array_ptr -> array_element(i) = other_array_ptr -> array_element(i); end; do i = i by 1 while (i < array_size); array_ptr -> array_element(i) = nil; end; end; else if array_type = Fixnum_array then do; do i = 0 by 1 to min(array_size, other_array_size)-1; array_ptr -> fixed_data(i) = other_array_ptr -> fixed_data(i); end; do i = i by 1 while (i < array_size); array_ptr -> fixed_data(i) = 0; end; end; else if array_type = Flonum_array then do; do i = 0 by 1 to min(array_size, other_array_size)-1; array_ptr -> float_data(i) = other_array_ptr -> float_data(i); end; do i = i by 1 while (i < array_size); array_ptr -> float_data(i) = 0.0; end; end; else if array_type = Obarray_array then do; if nargs > -6 then stack -> temp(3) = t_atom; /* default 3rd arg is t */ if stack -> temp(3) = nil /* leave completely empty */ then do i = 0 to 638; array_ptr -> array_data.data(i) = nil; end; else do; /* copy some existing obarray */ if stack -> temp(3) = t_atom then stack -> temp(3) = addr(lisp_static_vars_$obarray)->based_ptr -> atom.value; call get_array_prop_3; if tstack -> temp_type36(1) & Array36 then; else do; call reject_argument(3, argument_must_be_array); end; if tstack -> temp_ptr(1) -> array_info.type ^= Obarray_array then call reject_argument(3, not_same_type); array_ptr -> array_element(*) = tstack -> temp_ptr(1) -> array_info.array_data_ptr -> array_element(*); special_action_flag = "1"b; /* remember to copy the buckets */ end; end; else if array_type = Readtable_array then do; if nargs > -6 then stack -> temp(3) = nil; /* default 3rd arg is nil */ if stack -> temp(3) = nil then stack -> temp(3) = addr(lisp_static_vars_$readtable)->based_ptr -> atom.value; if stack -> temp(3) = t_atom /* copy initial readtable */ then call initialize_a_readtable; else do; /* copy other readtable */ call get_array_prop_3; if tstack -> temp_type36(1) & Array36 then; else do; call reject_argument(3, argument_must_be_array); end; if tstack -> temp_ptr(1) -> array_info.type ^= Readtable_array then call reject_argument(3, not_same_type); other_array_ptr = tstack -> temp_ptr(1) -> array_info.array_data_ptr; call copy_a_readtable; end; end; end; /* end of if ^ external_array */ else do; /* external array - pick up arguments & create array */ if stack -> temp_type36(3) & Fixed36 then do; /* pick up ptr */ array_ptr = addr(addr(stack -> temp(3))->fixedb)->packed_pointer; end; else call reject_argument(3, bad_argument); stack -> temp_ptr(1) -> array_info.minus_2_times_ndims = 0; /* ext array flag */ if stack -> temp_type36(4) & Fixed36 then do; /* pick up bound */ array_size = addr(stack -> temp(4))->fixedb; end; else call reject_argument(4, bad_argument); stack -> temp_ptr(1) -> array_info.array_load_sequence(1) = unspec(array_size); /* set up for bounds check (ecch) */ end; /* array initialization completed. make the array accessible */ stack -> temp_ptr(1) -> array_info.array_data_ptr = array_ptr; stack -> temp_ptr(1) -> array_info.type = array_type; if array_type ^= Readtable_array then stack -> temp_ptr(1) -> array_info.call_array_operator = call_array_operator; else stack -> temp_ptr(1) -> array_info.call_array_operator = call_dead_array_operator; /* readtable - can't subscript*/ /* perform any deferred consing. This is done down here because all the various array pointers have to get set up before we can allow a garbage collection. Yes, it's kludgey */ if special_action_flag then if array_type = Readtable_array /* copy more_macros list */ then call finish_copying_readtable; else if array_type = Obarray_array then do; /* copy the buckets */ call finish_copying_obarray; end; /* the return value from array or *array is in stack -> temp(1), so these functions will always return the array pointer */ end make_array; /* routines to initialize and copy readtables */ initialize_a_readtable: proc; /* array_ptr -> array_data block to init */ dcl lisp_static_vars_$quote_macro fixed bin(71) external, lisp_static_vars_$semicolon_macro fixed bin(71) external, lisp_static_vars_$vertical_bar_macro fixed bin(71) external, 1 lisp_reader_alm_$initial_readtable aligned external, 2 std_syntax(0:131) bit(18) aligned, 2 std_translation(0:131) fixed bin; array_ptr -> read_table.macro_table(1) = lisp_static_vars_$quote_macro; array_ptr -> read_table.macro_table(2) = lisp_static_vars_$semicolon_macro; array_ptr -> read_table.macro_table(3) = lisp_static_vars_$vertical_bar_macro; do i = 4 to num_macs; array_ptr -> read_table.macro_table(i) = nil; end; array_ptr -> read_table.more_macros = nil; array_ptr -> read_table.syntax = std_syntax; array_ptr -> read_table.translation = std_translation; array_ptr -> read_table.status_terpri = "0"b; array_ptr -> read_table.status_underline = "1"b; array_ptr -> read_table.status_ttyread = "1"b; array_ptr -> read_table.abbreviate_on_files = "0"b; array_ptr -> read_table.abbreviate_on_flat = "1"b; unspec(array_ptr -> read_table.words_not_used_yet) = ""b; end initialize_a_readtable; copy_a_readtable: proc; /* array_ptr -> new, other_array_ptr -> old */ array_ptr -> read_table = other_array_ptr -> read_table; /* copy whole thing */ special_action_flag = "1"b; /* remember to copy more_macros list (KLUDGE) */ end copy_a_readtable; finish_copying_readtable: proc; /* called to copy the more_macros list */ tstack = stack_ptr; stack_ptr = addr(tstack -> temp(4)); tstack -> temp(1), tstack -> temp(2) = nil; tstack -> temp(3) = array_ptr -> read_table.more_macros; call lisp_list_utils_$subst; stack -> temp_ptr(1) -> array_info.array_data_ptr -> read_table.more_macros = tstack -> temp(1); end finish_copying_readtable; finish_copying_obarray: proc; /* copy the buckets so can remob from old array without affecting the new one */ tstack = stack_ptr; do i = 0 to 638; stack_ptr = addr(tstack -> temp(4)); tstack -> temp(1), tstack -> temp(2) = nil; tstack -> temp(3) = stack -> temp_ptr(1) -> array_info.array_data_ptr -> array_data.data(i); call lisp_list_utils_$subst; stack -> temp_ptr(1) -> array_info.array_data_ptr -> array_data.data(i) = tstack -> temp(1); end; end finish_copying_obarray; array: entry; /* the LISP array function */ stack = addrel(stack_ptr, -2); do nargs = 0 repeat (nargs+1) while(stack -> temp_type(1) = Cons); stack_ptr = addr(stack -> temp(nargs+3)); stack -> temp(nargs+2) = stack -> temp_ptr(1) -> cons.car; stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; if nargs > 1 then call lisp_$eval; /* eval all but first two args */ end; nargs = -2*nargs; /* lsubr compatibility */ ustack = unmkd_ptr; myname = fn_array; star_rearray = "0"b; stack -> temp(1) = stack -> temp(2); /* copy the first argument so it can be returned */ stack = addr(stack -> temp(2)); /* -> arguments */ call make_array; /* call subroutine to do like *array */ stack = addrel(stack, -2); /* adjust for extra stack cell */ if stack -> temp(1) = nil /* return first argument, or array ptr if it was nil */ then stack -> temp(1) = stack -> temp(2); go to exit; star_rearray: entry; /* LISP *rearray function */ myname = fn_star_rearray; star_rearray = "1"b; call lsubr_initialization; if nargs >= -2 then do; /* kill existing array */ if stack -> temp_type36(1) & Array36 then call kill_array; else do; call get_array_prop; stack -> temp(1) = tstack -> temp(1); if stack -> temp_type36(1) & Array36 then call kill_array; end; if stack -> temp_type36(1) & Array36 /* actually killed it */ then stack -> temp(1) = t_atom; /* return result like remprop */ else stack -> temp(1) = nil; go to exit; end; /* *rearray with more than one argument - reformat the array */ call make_array; /* do all work in common code */ go to exit; /* useful routines used by the above */ reject_argument: proc(num, err); dcl num fixed bin, /* number of stack cell containing bad argument */ err fixed bin; /* error code to use */ dcl unm pointer, tstack pointer; dcl 1 args_to_lisp_error_on_unmarked_pdl aligned based, 2 errcode (2) fixed bin(35); tstack = stack_ptr; stack_ptr = addr(tstack -> temp(2)); tstack -> temp(1) = stack -> temp(num); unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = err; unm -> errcode(2) = myname; call lisp_error_; stack -> temp(num) = tstack -> temp(1); /* in case correctable error */ stack_ptr = tstack; end; kill_array: proc; /* kill array pointed at by stack -> temp(1) */ stack -> temp_ptr(1) -> array_info.type = Dead_array; stack -> temp_ptr(1) -> array_info.call_array_operator = call_dead_array_operator; stack -> temp_ptr(1) -> array_info.array_data_ptr = null; end; make_array_pointer: proc; /* set stack -> temp(1) to an array pointer + initialize array_info */ call lisp_static_man_$allocate(array_ptr, size(array_info)); unspec(stack -> temp(1)) = unspec(array_ptr) | Array36 | Subr36; /* turn on type bit */ call kill_array; /* do some initialization */ end; lsubr_initialization: proc; stack = addrel(stack_ptr, -2); nargs = stack -> fixedb; /* -2* # of args */ stack = addrel(stack, nargs); ustack = unmkd_ptr; end lsubr_initialization; get_array_prop_3: procedure; stack = addr(stack -> temp(3)); call get_array_prop; stack = addrel(stack, -4); end get_array_prop_3; get_array_prop: procedure; tstack = stack_ptr; stack_ptr = addr(tstack -> temp(2)); tstack -> temp(1) = stack -> temp(1); if tstack -> temp_type36(1) & Array36 then return; /* already an array pointer */ stack_ptr = addr(tstack -> temp(3)); tstack -> temp(2) = lisp_static_vars_$array_atom; call lisp_property_fns_$get; end get_array_prop; /* various array operations, converting from arrays to lists, and initting arrays */ fillarray: entry; /* fills an array from a list, replicating the last element as necessary */ myname = fn_fillarray; stack = addrel(stack_ptr, -4); if stack -> temp_type(2) ^= Cons /* allow (fillarray to-array from-array) */ then do; /* by interchanging args & using bltarray */ temp_item = stack -> temp(2); stack -> temp(2) = stack -> temp(1); stack -> temp(1) = temp_item; go to fillarray_bltarray_join; end; call get_array_property; if array_type >= Readtable_array then call reject_argument(1, store_not_allowed); L = 0; stack_ptr = addr(stack -> temp(4)); do while(stack -> temp(2) ^= nil); /* until the end of the list argument */ stack -> temp(3) = stack -> temp_ptr(2) -> cons.car; if array_type < Fixnum_array /* S-expression array */ then array_ptr -> array_element(L) = stack -> temp(3); else if array_type = Fixnum_array /* Fixnum array */ then if addr(stack -> temp(3))-> fixnum_fmt.type_info = fixnum_type then array_ptr -> fixed_data(L) = addr(stack -> temp(3))-> fixedb; else call reject_argument(3, store_not_allowed); else /* Flonum array */ if addr(stack -> temp(3))-> flonum_fmt.type_info = flonum_type then array_ptr -> float_data(L) = addr(stack -> temp(3))-> floatb; else call reject_argument(3, store_not_allowed); stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; L = L + 1; if L = array_size then go to done; end; if L = 0 then go to done; /* replicate last element */ if array_type < Fixnum_array then do; /* replicate S-expression */ stack -> temp(2) = array_ptr -> array_element(L-1); do L = L repeat (L+1) while (L < array_size); array_ptr -> array_element(L) = stack -> temp(2); end; end; else if array_type = Fixnum_array then do; /* replicate a fixnum */ fix1 = array_ptr -> fixed_data(L-1); do L = L repeat (L+1) while (L < array_size); array_ptr -> fixed_data(L) = fix1; end; end; else if array_type = Flonum_array then do; /* replicate a flonum */ float1 = array_ptr -> float_data(L-1); do L = L repeat (L+1) while (L < array_size); array_ptr -> float_data(L) = float1; end; end; done: stack_ptr = addr(stack -> temp(2)); return; listarray: entry; /* convert an array to a list */ myname = fn_listarray; call lsubr_initialization; /* extended to lsubr 74.12.06 */ call get_array_property; if nargs < -2 then array_size = min(array_size, /* argument - limit # elems returned */ addr(stack -> temp(2)) -> fixedb); if array_type = Readtable_array then call reject_argument(1, special_array_type); stack -> temp(1) = stack -> temp(3); /* save the array-pointer */ stack = addr(stack -> temp(2)); stack_ptr = addr(stack -> temp(3)); stack -> temp(1) = nil; do L = array_size - 1 to 0 by -1; /* start with last array element */ stack -> temp(2) = stack -> temp(1); if array_type < Fixnum_array then stack -> temp(1) = array_ptr -> array_element(L); else if array_type = Fixnum_array then do; stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = array_ptr -> fixed_data(L); end; else if array_type = Flonum_array then do; stack -> flonum_fmt.type_info = flonum_type; stack -> floatb = array_ptr -> float_data(L); end; else do; /* Obarray */ stack -> temp(1) = array_ptr -> array_element(L); end; /* ncons SCO buckets??? */ call lisp_alloc_$cons; array_ptr = stack -> temp_ptr(ZERO) -> array_info.array_data_ptr; /* in case GC */ stack_ptr = addr(stack -> temp(3)); /* readjust stack */ end; stack = addrel(stack, -2); /* recover hidden cell */ stack -> temp(1) = stack -> temp(2); /* move result down */ go to done; bltarray: entry; myname = fn_bltarray; stack = addrel(stack_ptr, -4); fillarray_bltarray_join: /* bltarray is obsolete except fillarray uses it */ call get_array_property; /* process 1st arg */ other_array_type = array_type; other_array_size = array_size; stack = addr(stack -> temp(2)); /* process 2nd arg */ call get_array_property; other_array_ptr = stack -> temp_ptr(2) -> array_info.array_data_ptr; /* have to do this because of GC */ if array_type ^= other_array_type then if array_type >= Fixnum_array | other_array_type >= Fixnum_array then do; /* types have to match, except can mix S-expr and un-gc */ stack_ptr = addr(stack -> temp(3)); call lisp_alloc_$ncons; call lisp_alloc_$cons; stack = stack_ptr; call reject_argument(0, not_same_type); end; /* checking is completed, now copy the data */ stack = addrel(stack, -2); /* -> args */ stack -> temp(1) = stack -> temp(4); /* array object to be written into. This is also return value */ array_size = min(array_size, other_array_size); /* how many elements to copy over */ if array_type = Readtable_array then do; call copy_a_readtable; call finish_copying_readtable; end; else if array_type = Obarray_array then do; array_ptr -> array_element(*) = other_array_ptr -> array_element(*); call finish_copying_obarray; /* make top-level copies of buckets */ end; else if array_type >= Fixnum_array /* copy number array */ then array_ptr -> fixed_data(*) = other_array_ptr -> fixed_data(*); else array_ptr -> array_element(*) = /* copy S-expr or un_gc array */ other_array_ptr -> array_element(*); go to done; arraydims: entry; /* arraydims subr, return list of array type and dimensions */ myname = fn_arraydims; stack = addrel(stack_ptr, -2); call get_array_property; ndims = stack -> temp_ptr(3) -> array_info.ndims; call lisp_alloc_(4*(ndims+1), stack -> temp_ptr(1)); /* create return list in one fell swoop. this is array won't move later */ array_ptr = stack -> temp_ptr(3) -> array_info.array_data_ptr; /* -> dope vector */ /* get type of array */ if array_type = S_expr_array then stack -> temp_ptr(1) -> temp(1) = t_atom; else if array_type = Un_gc_array then stack -> temp_ptr(1) -> temp(1) = nil; else if array_type = Fixnum_array then stack -> temp_ptr(1) -> temp(1) = lisp_static_vars_$fixnum; else if array_type = Flonum_array then stack -> temp_ptr(1) -> temp(1) = lisp_static_vars_$flonum; else if array_type = Readtable_array then stack -> temp_ptr(1) -> temp(1) = lisp_static_vars_$readtable; else if array_type = Obarray_array then stack -> temp_ptr(1) -> temp(1) = lisp_static_vars_$obarray; /* copy dimensions and link up the list */ if stack -> temp_ptr(3) -> array_info.minus_2_times_ndims ^= 0 /* normal array */ then do i = 1 by 1 while(i <= ndims); addr(stack -> temp_ptr(1) -> temp(2*i+1))-> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp_ptr(1) -> temp(2*i+1))-> fixedb = array_ptr -> array_data.dope_vector(i-ndims).bounds; stack -> temp_ptr(1) -> temp_ptr(2*i) = addr(stack -> temp_ptr(1) -> temp(2*i+1)); end; else do; /* external array */ stack -> temp_ptr(1) -> temp_ptr(2) = addr(stack -> temp_ptr(1) -> temp(3)); addr(stack -> temp_ptr(1) -> temp(3)) -> fixnum_fmt.type_info = fixnum_type; unspec(addr(stack -> temp_ptr(1) -> temp(3)) -> fixedb) = array_ptr -> array_info.array_load_sequence(1); end; stack -> temp_ptr(1) -> temp(2*ndims+2) = nil; /* end the list */ stack_ptr = addr(stack -> temp(2)); return; mapatoms: entry; myname = fn_mapatoms; call lsubr_initialization; if nargs = -2 then stack -> temp(2) = addr(lisp_static_vars_$obarray) -> based_ptr -> atom.value; stack_ptr = addr(stack-> temp(5)); unmkd_ptr = addrel(ustack,2); ustack-> snapcall_args.fn_offset = -8; ustack -> snapcall_args.arg_length = -2; do while((stack->temp_type36(2)&Array36) = "0"b); bad_mapa: call reject_argument(2,not_an_array); end; if stack->temp_ptr(2)->array_info.type ^= Obarray_array then go to bad_mapa; do i = 0 to 510; stack->temp(3) = stack->temp_ptr(2)->array_info.array_data_ptr -> array_element(i); do while(stack->temp(3) ^= nil); stack->temp(4) = stack->temp_ptr(3)-> cons.car; stack->temp(3) = stack->temp_ptr(3)->cons.cdr; call lisp_$snapcaller; end; end; do i = 511 to 638; stack->temp(4) = stack->temp_ptr(2)-> array_info.array_data_ptr-> array_element(i); if stack->temp(4) ^= nil then call lisp_$snapcaller; end; stack->temp(1) = t_atom; stack_ptr = addr(stack->temp(2)); unmkd_ptr = ustack; return; sort: entry; /* major sort entrypoint, taking two lisp args, first is array, second is < predicate */ myname = fn_sort; entry_id = 0; join_sort: stack = addrel(stack_ptr, -4); ustack = unmkd_ptr; if stack -> temp(2) = lisp_static_vars_$alphalessp_atom then go to alphasort; /* special alphbetic sorting feature for speed */ if stack -> temp(1) = nil then go to exit; if stack -> temp_type(1) then do; call get_array_property; if array_type < Fixnum_array then; /* regular old S-expression sort */ else if array_type = Fixnum_array then if entry_id = 0 then do; entry_id = -1; type_field = fixnum_type; end; else go to cant_sortcar_number_array; else if array_type = Flonum_array then if entry_id = 0 then do; entry_id = -1; type_field = flonum_type; end; else go to cant_sortcar_number_array; else go to cant_sort_special_array; call heapsort; end; else call merge_sort; exit: stack_ptr = addr(stack -> temp(2)); unmkd_ptr = ustack; return; /* Error exits */ cant_sort_special_array: cant_sortcar_number_array: cant_alphasort_number_array: call reject_argument(1, special_array_type); sortcar: entry; myname = fn_sortcar; entry_id = 1; go to join_sort; alphasort: entry_id = entry_id + 2; /* indicate special comparison technique */ alpha_retry: if stack -> temp(1) = nil then go to exit; if stack -> temp_type(1) then do; call get_array_property; /* get the array property, which we must verify as an aplhabetic array */ if array_type >= Fixnum_array then go to cant_alphasort_number_array; do L = array_size-1 by -1 to 0; /* check the whole array */ if entry_id = 2 then if addr(array_ptr -> array_element(L)) -> lisp_ptr_type & (Atsym36|String36) then; else do; alpha_loss: stack_ptr = addr(stack -> temp(2)); unmkd_ptr =addrel(ustack,2); ustack -> error_args.code = not_alpha_array; ustack -> error_args.name = myname; call lisp_error_; go to alpha_retry; end; else if addr(array_ptr -> array_element(L)) -> based_ptr -> lisp_ptr_type & (Atsym36|String36) then; else go to alpha_loss; end; call heapsort; end; else do; stack_ptr = addr(stack -> temp(3)); /* set up args for cons */ stack -> temp(2) = stack -> temp(1); do while(stack -> temp(2) ^= nil); if entry_id = 2 then if stack -> temp_ptr(2) -> lisp_ptr_type & (Atsym36|String36) then; else go to alpha_loss; else if stack -> temp_ptr(2) -> cons_ptrs.car -> lisp_ptr_type & (Atsym36|String36) then; else go to alpha_loss; stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; end; call merge_sort; end; go to exit; heapsort: proc; /* algorithm to implent Knuth's heapsort */ if array_size <= 1 then go to exit; stack_ptr = addr(stack->temp(5)); /* set up for siftup */ unmkd_ptr = addrel(ustack,2); ustack->snapcall_args.fn_offset = -10; /* offset of function from top of stack */ ustack->snapcall_args.arg_length = -4; /* -2 * nargs */ R = array_size - 1; /* Now we enter into Knuth's algorithm proper */ do L = divide(array_size,2,17,0)-1 to 0 by -1; if entry_id >= 0 then stack -> temp(4) = array_ptr -> array_element(L); /* set K */ else do; addr(stack -> temp(4)) -> fixnum_fmt.type_info = type_field; addr(stack -> temp(4)) -> fixedb = array_ptr -> fixed_data(L); end; call siftup; end; L = 0; /* make sure */ if entry_id < 0 then do; addr(stack -> temp(4)) -> fixnum_fmt.type_info = type_field; addr(stack -> temp(4)) -> fixedb = array_ptr -> fixed_data(R); array_ptr -> fixed_data(R) = array_ptr -> fixed_data(0); end; else do; stack -> temp(4) = array_ptr -> array_element(R); /* set K */ array_ptr -> array_element(R) = array_ptr -> array_element(0); /* move next element to final pos */ end; do R = R-1 to 1 by -1; call siftup; if entry_id >= 0 then do; stack -> temp(4) = array_ptr -> array_element(R); /* set K */ array_ptr -> array_element(R) = array_ptr -> array_element(0); /* move next element to final pos */ end; else do; addr(stack -> temp(4)) -> fixnum_fmt.type_info = type_field; addr(stack -> temp(4)) -> fixedb = array_ptr -> fixed_data(R); array_ptr -> fixed_data(R) = array_ptr -> fixed_data(0); end; end; if entry_id >= 0 then array_ptr -> array_element(0) = stack -> temp(4); else array_ptr -> fixed_data(0) = addr(stack -> temp(4)) -> fixedb; end heapsort; siftup: proc; /* the algorithm for ordering the binary tree correctly */ dcl (I, J) fixed bin; /* more Knuth variables */ do I = L repeat(J); J = 2*I+1; if J > R then do; pop_out: if entry_id >= 0 then array_ptr -> array_element(I) = stack -> temp(4); /* move K into proper place */ else array_ptr -> fixed_data(I) = addr(stack -> temp(4)) -> fixedb; return; end; if J < R /* I.E. there are two sons to node I in the heap, rather than 1. */ then do; stack_ptr = addr(stack->temp(7)); /* compare elements j and j+1 */ if entry_id >= 0 then do; stack -> temp(5) = array_ptr ->array_element(J); stack -> temp(6) = array_ptr -> array_element(J+1); end; else do; addr(stack -> temp(5)) -> fixnum_fmt.type_info, addr(stack -> temp(6)) -> fixnum_fmt.type_info = type_field; addr(stack -> temp(5)) -> fixedb = array_ptr -> fixed_data(J); addr(stack -> temp(6)) -> fixedb = array_ptr -> fixed_data(J+1); end; call compare; /* call the comparison function */ if stack -> temp(5) ^= nil then J = J+1; /* use the greater valued node */ end; stack_ptr = addr(stack -> temp(7)); stack -> temp(5) = stack -> temp(4); /* first arg to comparator is K */ if entry_id >= 0 then stack -> temp(6) = array_ptr -> array_element(J); /* second is the larger son of node I */ else do; addr(stack -> temp(6)) -> fixnum_fmt.type_info = type_field; addr(stack -> temp(6)) -> fixedb = array_ptr -> fixed_data(J); end; call compare; /* call function */ if stack -> temp(5) = nil then go to pop_out; /* if K larger or equal, we are done */ if entry_id >= 0 then array_ptr -> array_element(I) = array_ptr -> array_element(J); else array_ptr -> fixed_data(I) = array_ptr -> fixed_data(J); end; end siftup; compare: procedure; /* internal procedure for determining the ordering of two elements */ dcl j fixed bin, string_ptr(0:1) ptr; go to comparison(entry_id); /* branck on which type of sort */ comparison(1): /* sortcar */ comparison(3): /* sortcar (alphalessp) */ stack -> temp(5) = stack -> temp_ptr(5) -> cons.car; stack -> temp(6) = stack -> temp_ptr(6) -> cons.car; go to comparison(entry_id-1); comparison(-1): /* number sort */ comparison(0): /* sort */ call lisp_$snapcaller; /* call evaluator to apply the function, cleverly remembering the subr property for successive calls if possible! */ if array_ptr ^= null /* if array sort recompute ptr */ then array_ptr = stack -> temp_ptr(3) -> array_info.array_data_ptr; /* in case gc in predicate */ return; comparison(2): /* alphasort */ do j = 0 to 1; /* get two string pointers */ if stack -> temp_type36(5+j) & String36 then string_ptr(j) = stack -> temp_ptr(5+j); else string_ptr(j) = addr(stack -> temp_ptr(5+j) -> atom.pnamel); end; /* now compare the strings */ if string_ptr(0) -> lisp_string.string_length >= string_ptr(1) -> lisp_string.string_length then do; j = string_ptr(1) -> lisp_string.string_length; /* min of the lengths */ if substr(string_ptr(0) -> lisp_string.string,1, j) < substr(string_ptr(1) -> lisp_string.string,1,j) then stack -> temp(5) = t_atom; else stack -> temp(5) = nil; end; else do; j = string_ptr(0) -> lisp_string.string_length; /* min of the lengths */ if substr(string_ptr(0) -> lisp_string.string,1,j) <= substr(string_ptr(1) -> lisp_string.string,1,j) then stack -> temp(5) = t_atom; else stack -> temp(5) = nil; end; end compare; get_array_property: procedure; /* common code to get array property */ /* the following variables are set by this routine from the array in stack -> temp(1): array_ptr -> data area of array array_size number of elements in array array_type type of array stack -> temp(2) is undisturbed stack -> temp(3) is left with the array-pointer (-> array_info) */ stack_ptr = addr(stack -> temp(5)); retry: stack -> temp(3) = stack -> temp(1); /* get array property of first arg */ if stack -> temp_type36(3) & Array36 then; /* already got array pointer */ else do; /* get array pointer from array property */ stack -> temp(4) = lisp_static_vars_$array_atom; call lisp_property_fns_$get; if stack -> temp_type36(3) & Array36 then; else do; call reject_argument(1, not_an_array); /* signal correctable error */ go to retry; end; end; array_type = stack -> temp_ptr(3) -> array_info.type; if array_type = Dead_array then call reject_argument(1, dead_array_reference); array_ptr = stack -> temp_ptr(3) -> array_info.array_data_ptr; array_size = 1; if stack -> temp_ptr(3) -> array_info.minus_2_times_ndims ^= 0 /* normal array */ then do i = - stack -> temp_ptr(3) -> array_info.ndims repeat (i+1) while (i < 0); array_size = array_size * array_ptr -> array_data.dope_vector(i+1).bounds; end; else unspec(array_size) = stack -> temp_ptr(3) -> array_info.array_load_sequence(1); /* external array */ end get_array_property; merge: proc; /* procedure to merge two lists */ if stack -> temp(1) = nil then do; stack -> temp(1) = stack -> temp(2); return; end; if stack -> temp(2) = nil then return; stack_ptr = addr(stack -> temp(7)); /* for space we need */ stack -> temp(5) = stack -> temp_ptr(1) -> cons.car; stack -> temp(6) = stack -> temp_ptr(2) -> cons.car; call compare; /* compare heads of lists */ if stack -> temp(5) = nil then do; /* if first list >= second */ stack -> temp(3) = stack -> temp(1); stack -> temp(1) = stack -> temp(2); end; else do; stack -> temp(3) = stack -> temp(2); stack -> temp(2) = stack -> temp(1); end; stack -> temp(4) = stack -> temp(2); /* temp 4 points to cell to rplacd */ stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; /* temp 2 contains list we are merging into */ /* temp 3 contains list we are merging from */ do while(stack -> temp(2) ^= nil); stack_ptr = addr(stack->temp(7)); stack -> temp(5) = stack -> temp_ptr(2) -> cons.car; stack -> temp(6) = stack -> temp_ptr(3) -> cons.car; call compare; if stack -> temp(5) = nil /* if list we are merging into is >= than list merging from, exchange */ then do; stack -> temp_ptr(4) -> cons.cdr = stack -> temp(3); stack -> temp(3) = stack -> temp(2); stack -> temp(2) = stack -> temp_ptr(4) -> cons.cdr; end; stack -> temp(4) = stack -> temp(2); /* move down list */ stack -> temp(2) = stack -> temp_ptr(4) -> cons.cdr; end; stack -> temp_ptr(4) -> cons.cdr = stack -> temp(3); /* put remainder of list on end */ end merge; merge_sort:proc; /* procedure to merge sort a list in place */ dcl retv(0:99) fixed bin, /* return stack, of essentially infinite length */ sourcep ptr, depth fixed bin, list_size fixed bin; /* log of length of current lists */ array_ptr = null; /* see compare */ stack_ptr = addr(stack -> temp(4)); sourcep = stack; unmkd_ptr = addrel(ustack,2); ustack -> snapcall_args.fn_offset = -14; ustack -> snapcall_args.arg_length = -4; stack -> temp(3) = nil; /* initial result */ depth = 0; /* initial recursion depth */ retv(0) = 0; /* set return for call to pfx */ list_size = -1; stack = stack_ptr; go to pfx; pfxret(0): stack = addrel(stack,-2); /* get back to result, and merge in */ stack_ptr = addr(stack -> temp(3)); call merge; if sourcep -> temp(1) = nil then do; sourcep -> temp(1) = stack -> temp(1); stack = sourcep; goto exit; end; stack = addr(stack -> temp(2)); /* move up again */ list_size = list_size + 1; go to pfx; pfx: /* routine to obtain sorted prefix of source list */ stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = sourcep -> temp(1); /* get source list */ if stack -> temp(1) = nil /* if none left, */ then goto pfxret(retv(depth)); if list_size <= 0 then do; sourcep -> temp(1) = sourcep -> temp_ptr(1) -> cons.cdr; stack -> temp_ptr(1) -> cons.cdr = nil; /* get list of length 1 */ go to pfxret(retv(depth)); end; /* otherwise, call pfx recursiviely twice, and merge the two shorter lists */ list_size = list_size - 1; depth = depth + 1; retv(depth) = 1; /* set return address */ go to pfx; pfxret(1):retv(depth) = 2; /* set for next call */ stack = addr(stack -> temp(2)); ustack -> snapcall_args.fn_offset = ustack -> snapcall_args.fn_offset - 2; go to pfx; pfxret(2):stack = addrel(stack,-2); depth = depth - 1; list_size = list_size + 1; call merge; ustack -> snapcall_args.fn_offset = ustack -> snapcall_args.fn_offset + 2; go to pfxret(retv(depth)); /* return */ end merge_sort; end lisp_array_fcns_;  lisp_baktrace_.pl1 07/06/83 0937.0r w 06/29/83 1542.2 64107 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ /* lisp baktrace functions */ baktrace: proc; /* * this proc contains the type 2 lsubrs baktrace, baktrace1, baktrace2. * * these are the same except that baktrace lists only function names, * while baktrace1 also lists the a-list pdl ptr for bindings just * _b_e_f_o_r_e that function was invoked, and baktrace2 gives both the * a-list pdl ptr and the evalframe pdl ptr. * * these functions may be called with 0, 1, or 2 evaluated arguments. * 0 arguments is equivalent to 1 argument of nil. * the first argument is a pdl ptr, or else nil which means * start at the top of the pdl. If the pdl ptr is negative the search * for the first evalframe is down, if positive it is up, but in * either case the actual tracing is downwards in the pdl. * A pdl ptr argument of 0 is not supported. * If a second argument is given, it is a fixnum giving the * maximum number of lines to be typed out, i.e. the maximum depth * in the pdl to be traced. * * * Coded 2 Sept. 1972 by D. A. Moon */ dcl stack ptr, unm ptr, unm2 ptr, posf bit(1), esw fixed bin, nargs fixed bin, first bit(1), loc bit(18), kludge_fixed_bin fixed bin(18), 1 loc_ovly based (addr(loc)), 2 locfb fixed bin(17) unaligned, 2 unused_bits bit(18) unaligned, st ptr, lisp_static_vars_$print_atom fixed bin(71) external, lisp_print_$type_string entry (char(*)), lisp_static_vars_$prin1_atom fixed bin(71) external, lisp_$apply entry, lisp_special_fns_$ncons entry, count fixed bin, lisp_error_ entry, i fixed bin; dcl (lisp_error_table_$not_pdl_ptr, lisp_error_table_$bad_arg_correctable) fixed bin(35) external; %include lisp_atom_fmt; %include lisp_name_codes; %include lisp_stack_seg; %include lisp_ptr_fmt; %include lisp_cons_fmt; %include lisp_stack_fmt; %include lisp_common_vars; %include lisp_nums; %include lisp_unmkd_pdl; esw = 0; go to join; baktrace1: entry; esw = 1; go to join; baktrace2: entry; esw = 2; go to join; join: /* begin by analyzing arguments */ stack = addrel(stack_ptr, -2); /* -> -2*nargs */ nargs = stack -> fixedb; stack = addrel(stack, nargs); /* -> our first arg */ if nargs = 0 then do; /* no args, simulate 1 arg of nil */ stack -> temp(1) = nil; stack_ptr = addr(stack -> temp(3)); nargs = -2; end; if nargs = -2 then do; /* 1 arg, simulate second arg of very big number */ addr(stack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2)) -> fixedb = binary(999999999, 35); end; retry: stack_ptr = addr(stack -> temp(3)); /* just 2 args allowed */ posf = "0"b; if stack -> temp(1) = nil then do; loc = rel(eval_frame); if loc then locfb = locfb + 1; end; else if stack -> temp_type36(1) & Fixed36 then if stack -> fixedb < 0 then loc = substr(unspec(stack -> fixedb), 19, 18); else do; kludge_fixed_bin = -stack -> fixedb; loc = substr(unspec(kludge_fixed_bin), 19, 18); posf = "1"b; end; else do; /* not a fixnum, you lose */ baktrace_bad_pdl_ptr: unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = stack -> temp(1); /* move losing pdl ptr to top of marked pdl */ unm -> errcode(1) = lisp_error_table_$not_pdl_ptr; unm -> errcode(2) = fn_baktrace; call lisp_error_; stack -> temp(1) = stack -> temp(3); /* move replacement value back down */ go to retry; end; /* make sure pdl ptr lies in the stack */ if loc >= rel(unmkd_ptr) then go to baktrace_bad_pdl_ptr; if loc = ""b then if posf then go to baktrace_00; else go to baktrace_nothing; if loc < rel(ptr(unmkd_ptr,""b)->stack_seg.unmkd_stack_bottom) then go to baktrace_bad_pdl_ptr; /* make sure second arg was a fixnum */ if stack -> temp_type36(2) & Fixed36 then count = addr(stack -> temp(2)) -> fixedb; else do; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = lisp_error_table_$bad_arg_correctable; unm -> errcode(2) = fn_baktrace; call lisp_error_; go to retry; end; /* arguments have been validated, find first place to baktrace from */ if stack -> temp(1) = nil then if addr(lisp_static_vars_$star_rset) -> based_ptr -> atom.value ^= nil then first = "1"b; /* avoid listing ourselves in the baktrace */ else first = "0"b; baktrace_00: unm2 = null(); do unm = eval_frame repeat (ptr(unm, unm -> frame.prev_frame)) while (rel(unm)); if rel(unm) < loc then go to baktrace_01; if posf then if rel(unm) = loc then go to baktrace_01; unm2 = unm; end; if posf then go to baktrace_01; /* nothing there - just return nil */ baktrace_nothing: stack -> temp(1) = nil; stack_ptr = addr(stack -> temp(2)); return; baktrace_01: if posf then do; if unm2 = null then go to baktrace_nothing; unm = unm2; /* make it look like we did an upward search */ end; /* begin baktraceing, unm -> frame */ stack_ptr = addr(stack -> temp(3)); i = 0; do unm = unm repeat(ptr(unm, unm -> frame.prev_frame)) while (rel(unm)); if first then first = ""b; else do; st = ptr(stack_ptr, unm -> frame.stack_ptr); stack -> temp(2) = st -> temp(1); /* get form being evaled or function being applied or mapped. */ if (unm -> frame.dat1 & "000000000000000001"b) = ""b then /* if apply bit is off, */ stack -> temp(2) = stack -> temp_ptr(2) -> cons.car; /* is list of fcn . args */ if stack -> temp_type36(2) & Atsym36 then do; /* omit lambda expressions because they take too long to type out */ stack -> temp(1) = lisp_static_vars_$print_atom; call lisp_special_fns_$ncons; call lisp_$apply; stack_ptr = addr(stack -> temp(3)); if esw ^= 0 then do; call lisp_print_$type_string(" "); /* give a-list */ addr(stack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2)) -> fixedb = fixed("111111111111111110"b||unm -> frame.stack_ptr, 36); stack -> temp(1) = lisp_static_vars_$prin1_atom; call lisp_special_fns_$ncons; call lisp_$apply; stack_ptr = addr(stack -> temp(3)); if esw = 2 then do; call lisp_print_$type_string(" "); /* give pdl ptr */ addr(stack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2)) -> fixedb = fixed("111111111111111111"b||rel(unm), 36); stack -> temp(1) = lisp_static_vars_$prin1_atom; call lisp_special_fns_$ncons; call lisp_$apply; stack_ptr = addr(stack -> temp(3)); end; end; i = i + 1; if i >= count then go to baktrace_nothing; /* done, return nil */ end; end; end; go to baktrace_nothing; /* reached base of stack, return nil */ end;  lisp_boot_.pl1 07/06/83 0937.0r w 06/29/83 1542.2 31653 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_boot_: proc; /* Modified 10/14/82 by Richard Lamson to correct declaration of ACC string */ /* lisp bootstrap procedure */ dcl tempp ptr, i fixed bin, foo fixed bin(71) aligned, lisp_static_vars_$dollar_p_atom fixed bin(71) aligned external, dollar_p_atom fixed bin(71) aligned def (lisp_static_vars_$dollar_p_atom), make_lisp_subr_block_ entry(fixed bin(71)aligned,fixed bin(2)aligned, char(*) aligned, char(*) aligned, fixed bin(17)aligned,fixed bin(17)aligned), lisp_alloc_ entry (fixed bin(17), ptr), lisp_subroutine_maker_ entry, lisp_obarray_utils_$init_ht entry, lisp_reader_init_$reader_init entry, lisp_io_control_$boot entry, lisp_get_atom_ entry(char(*)aligned, fixed bin(71)aligned), (substr, divide, addr, addrel) builtin; dcl 1 acc aligned based(accptr), 2 len fixed bin(9) unaligned unsigned, 2 str char(0 refer (acc.len)) unaligned, accptr pointer, lisp_static_vars_$number_of_atomic_constants fixed bin external, lisp_static_vars_$atomic_constants fixed bin ext, /* dummy */ lisp_static_vars_$atomic_constants_names fixed bin ext, /* dummy */ number_of_atomic_constants fixed bin defined (lisp_static_vars_$number_of_atomic_constants), atomic_constants(1:number_of_atomic_constants) fixed bin(71) aligned based(addr(lisp_static_vars_$atomic_constants)); dcl (lisp_static_vars_$divov_flag, lisp_static_vars_$prinlevel, lisp_static_vars_$prinlength) fixed bin(71) external; /* atoms that must be inited to nil */ %include lisp_initial_atoms; %include lisp_nums; %include lisp_common_vars; %include lisp_atom_fmt; %include lisp_ptr_fmt; %include lisp_cons_fmt; %include lisp_io; /* clear hash table for atom lookup */ call lisp_obarray_utils_$init_ht(); call lisp_subroutine_maker_; /* initialize all subroutines */ /* set up pointers to atoms in lisp_static_vars_ */ accptr = addr(lisp_static_vars_$atomic_constants_names); do i = 1 to number_of_atomic_constants; call lisp_get_atom_((acc.str), atomic_constants(i)); accptr = addrel(accptr, divide(acc.len+4, 4, 17, 0)); end; addr(errlist)->based_ptr->atom.value, addr(ctrlD)->based_ptr->atom.value = nil; /* init values of atoms */ addr(t_atom)->based_ptr->atom.value = t_atom; addr(base)->based_ptr->fixnum_fmt.type_info, addr(ibase)->based_ptr->fixnum_fmt.type_info = fixnum_type; addr(base)->based_ptr->fixedb, addr(ibase)->based_ptr->fixedb = 8; /* default is octal */ addr(user_intr_array(20))->based_ptr->atom.value = nil; /* gc-daemon function */ plus_status, toplevel, lisp_static_vars_$divov_flag = nil; status_gctwa = nil; addr(star_rset) -> based_ptr -> atom.value, addr(lisp_static_vars_$prinlevel) -> based_ptr -> atom.value, addr(lisp_static_vars_$prinlength) -> based_ptr -> atom.value = nil; call lisp_get_atom_("*nopoint",stnopoint); addr(stnopoint)->based_ptr->atom.value = nil; call lisp_get_atom_("tty",tty_atom); addr(tty_atom)->based_ptr->fixedb = 0; /* type of tty */ addr(tty_atom)->based_ptr->fixnum_fmt.type_info = fixnum_type; call lisp_io_control_$boot; call lisp_reader_init_$reader_init(); end lisp_boot_;  lisp_char_fns_.pl1 07/06/83 0937.0r w 06/29/83 1542.2 69264 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_char_fns_: proc; /* LISP functions similar to the PL/I builtins for manipulating strings */ dcl stack ptr, nargs fixed bin, argno fixed bin, argp ptr, argp2 ptr, myname fixed bin(35), slen fixed bin, lisp_error_ entry, lisp_alloc_ entry(fixed bin, fixed bin(71)), lisp_get_atom_ entry(char(*)aligned, fixed bin(71)), unm ptr, ercode(2) fixed bin(35) aligned based(unm), num fixed bin; stringlength: entry; /* subr to get the length of a lisp string */ stack = addrel(stack_ptr, -2); /* subr 1 */ argno = 1; myname = fn_stringlength; call getstring; num = argp -> lisp_string.string_length; retnum: stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = num; exit: stack_ptr = addr(stack -> temp(2)); return; lsubr_prologue: proc; stack = addrel(stack_ptr, -2); nargs = stack -> fixedb; stack = addrel(stack, nargs); end; catenate: entry; /* lsubr to catenate together some strings */ call lsubr_prologue; slen = 0; nargs = divide(nargs, -2, 17, 0); /* = + number of args */ /* find out how long result will be */ myname = fn_catenate; do argno = 1 to nargs; call getstring; slen = slen + argp -> lisp_string.string_length; end; /* allocate space for the result */ call lisp_alloc_(divide(slen+7,4,17,0), stack -> temp(nargs+1)); stack -> temp_type(nargs+1) = String; stack -> temp_ptr(nargs+1) -> lisp_string.string_length = slen; /* now move the strings into the result */ num = 0; do argno = 1 to nargs; call getstring; slen = argp -> lisp_string.string_length; substr(stack -> temp_ptr(nargs+1) -> lisp_string.string, num+1, slen) = argp -> lisp_string.string; num = num + slen; end; /* move result down and return */ stack -> temp(1) = stack -> temp(nargs+1); go to exit; /* routine to fetch arguments, checking type */ getstring: proc; dcl st ptr; do while("1"b); /* loop until good arg seen */ if stack -> temp_type36(argno) & String36 then do; argp = stack -> temp_ptr(argno); return; end; else if stack -> temp_type36(argno) & Atsym36 then do; argp = addr(stack -> temp_ptr(argno) -> atom.pnamel); return; end; call barf; end; /* keep looping */ barf: proc; /* interface to lisp_error_ */ /* bad arg - barf */ st = stack_ptr; stack_ptr = addr(st -> temp(2)); st -> temp(1) = stack -> temp(argno); /* move losing arg to top of marked pdl */ unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); ercode(1) = bad_arg_correctable; ercode(2) = myname; call lisp_error_; stack -> temp(argno) = st -> temp(1); stack_ptr = st; end barf; getnum: entry; /* gets number into num */ do while("1"b); /* loop until good arg gotten */ if addr(stack -> temp(argno))->fixnum_fmt.type_info = fixnum_type then do; num = addr(stack -> temp(argno))->fixedb; return; end; else if addr(stack -> temp(argno))->flonum_fmt.type_info = flonum_type then do; num = fixed(addr(stack -> temp(argno))->floatb); return; end; call barf; end; /* keep looping */ end getstring; Substr2: entry; /* substring function of two arguments - obsoleted by substr lsubr but kept for compatibility */ stack = addrel(stack_ptr, -4); myname = fn_substr; substr2_joint: /* this is where (substr x y) comes */ argno = 2; call getnum; argno = 1; call getstring; slen = argp -> lisp_string.string_length - num + 1; /* length of result */ if slen < 0 then slen = 0; /* before allocating, must save ptr to first arg since may garbage collect */ stack -> temp(2) = stack -> temp(1); /* save while allocating */ call lisp_alloc_(divide(slen+7,4,17,0), stack -> temp(1)); argno = 2; /* get back string */ call getstring; stack -> temp_type(1) = String; stack -> temp_ptr(1) -> lisp_string.string_length = slen; stack -> temp_ptr(1) -> lisp_string.string = substr(argp -> lisp_string.string, num); go to exit; Substr: entry; /* the substr lsubr, which takes 2 or 3 args and works like the PL/I substr builtin */ call lsubr_prologue; myname = fn_substr; if nargs = -4 then go to substr2_joint; /* 2 args, do like substr2 */ argno = 3; call getnum; slen = num; /* length of result */ argno = 2; call getnum; argno = 1; call getstring; stack -> temp(2) = stack -> temp(1); /* save while allocating */ if slen < 0 then slen = 0; if num < 1 then num = 1; else if num > argp -> lisp_string.string_length then num = argp -> lisp_string.string_length; call lisp_alloc_(divide(slen+7,4,17,0), stack -> temp(1)); argno = 2; call getstring; /* restore argp after allocation possibly gc'ed*/ stack -> temp_ptr(1) -> lisp_string.string_length = slen; stack -> temp_type(1) = String; stack -> temp_ptr(1) -> lisp_string.string = substr(argp -> lisp_string.string, num, min(slen, argp -> lisp_string.string_length - num + 1)); go to exit; Index: entry; /* subr to find the first occurrence of the second string in the first; like the PL/I builtin index */ stack = addrel(stack_ptr, -4); myname = fn_index; argno = 1; call getstring; argno = 2; call getstring; argp2 = argp; argno = 1; call getstring; /* first time was to check arg, but may have gc'ed */ num = index(argp -> lisp_string.string, argp2 -> lisp_string.string); go to retnum; get_pname: entry; /* get the print-name of an atomic symbol as a string */ stack = addrel(stack_ptr, -2); myname = fn_get_pname; argno = 1; call getstring; /* convert pname to string */ slen = argp -> lisp_string.string_length; stack_ptr = addr(stack->temp(3)); /* get place to save arg */ stack -> temp(2) = stack -> temp(1); call lisp_alloc_(divide(slen+7,4,17,0), stack -> temp(1)); argno = 2; call getstring; stack -> temp_ptr(1) -> lisp_string.string_length = argp -> lisp_string.string_length; substr(stack->temp_ptr(1)->lisp_string.string,1,slen) = substr(argp->lisp_string.string,1,slen); stack -> lisp_ptr_type = stack -> lisp_ptr_type | String36; go to exit; make_atom: entry; /* subr to make an uninterned atom given its pname as a string */ stack = addrel(stack_ptr, -2); myname = fn_make_atom; argno = 1; call getstring; call lisp_get_atom_(argp -> lisp_string.string, stack -> temp(1)); /* gc prot since arg is "always" a string */ go to exit; ItoC: entry; /* convert an integer to a one character string*/ stack = addrel(stack_ptr, -2); myname = fn_ItoC; argno = 1; call getnum; call lisp_alloc_(2, stack -> temp(1)); stack -> temp_type(1) = String; stack -> temp_ptr(1) -> lisp_string.string_length = 1; unspec(substr(stack -> temp_ptr(1) -> lisp_string.string, 1, 1)) = bit(fixed(num, 9), 9); /* make character */ go to exit; CtoI: entry; /* convert the first character of a string to an integer */ stack = addrel(stack_ptr, -2); myname = fn_CtoI; argno = 1; call getstring; if argp -> lisp_string.string_length = 0 then num = 0; else num = fixed(unspec(substr(argp -> lisp_string.string, 1, 1))); go to retnum; %include lisp_string_fmt; %include lisp_atom_fmt; %include lisp_ptr_fmt; %include lisp_common_vars; %include lisp_stack_fmt; %include lisp_error_codes; %include lisp_name_codes; %include lisp_cons_fmt; %include lisp_nums; dcl (addr, addrel, length, index, substr, unspec, min, fixed, bit) builtin; end lisp_char_fns_;  lisp_command_caller_.pl1 07/06/83 0937.0r w 06/29/83 1542.2 17262 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ cline: proc; /*this is a procedure to pass a lisp string to the Multics command processor*/ %include lisp_stack_fmt; %include lisp_common_vars; %include lisp_ptr_fmt; %include lisp_string_fmt; %include lisp_atom_fmt; %include lisp_error_codes; %include lisp_unmkd_pdl; dcl (stack, unm) ptr, code fixed bin(35), lisp_static_vars_$ignore_faults ext bit(36) aligned, (addr, addrel) builtin, lisp_error_ entry, cu_$cl entry options(variable), cu_$cp entry(ptr, fixed bin, fixed bin(35)); /* */ stack = addrel(stack_ptr, -2); if stack -> temp_type36(1) & Atsym36 then call cucp ((stack->temp_ptr(1)->atom.pname)); else if stack ->temp_type36(1) &String36 then call cucp((stack->temp_ptr(1)->string)); else go to error_in_cline; cucp: proc(str); dcl str char(*) aligned; lisp_static_vars_$ignore_faults = "1"b; /*so that the lisp fault handler won't get faults during the command call*/ call cu_$cp (addr(str), length(str), code); /*call the command*/ lisp_static_vars_$ignore_faults = ""b; /*now lisp will handle them again*/ end; stack -> temp(1) = nil; /*the value of cline is nil*/ return; error_in_cline: unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); /*push it up to protect 2 words*/ unm -> errcode(1) = bad_argument; unm -> errcode(2) = fn_cline; call lisp_error_; return; %include lisp_name_codes; suspend: entry; lisp_static_vars_$ignore_faults = "1"b; call cu_$cl; lisp_static_vars_$ignore_faults = "0"b; stack = stack_ptr; stack_ptr = addr(stack->temp(2)); stack->temp(1) = nil; return; end cline;  lisp_default_handler_.pl1 07/06/83 0937.0r w 06/29/83 1542.2 162945 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_default_handler_: proc(a_mcp, cond_name, wcptr, infoptr, continue) options(support); /* This isn't actually a `support' procedure, but there is a bug in default_error_handler_... */ /* procedure for receiving most faults and signals * which occur during a lisp program execution. * Coded by DPR 8/14/72. * alarmclock bug fixed DAMoon 18 Aug 72 * changed 10 March 1973 by DAM to allow for case where a fault * has occurred while signalling a previous fault. The machine * conditions of the previous fault are used. * Modified 16 January 1974 by DAM to stop using find_fault_frame_ * and use find_condition_frame_ and find_condition_info_ instead. * Modified by DPR on 20 Feb. 1974 to fix problems in continuing signal introduced with * deletion of listener wall. Also fixed uninitialized vars in continue_signal_aa. * Modified 29 November 1979 to fix alarm clock bug while executing in * pl/1 code so timers will operate properly. -- Richard S. Lamson */ dcl (wcptr, infoptr) ptr, fault_type fixed bin, cond_name char(*), continue bit(1) aligned, lisp_static_vars_$ignore_faults bit(36) aligned ext, lisp_static_vars_$binding_reversal_flag bit(36) aligned external, signal_ entry(char(*), ptr, ptr), temp ptr, stack_base ptr, temp_rel bit(18), lisp_fault_handler_ entry(fixed bin, ptr, fixed bin), convert_status_code_ entry(fixed bin(35), char(8) aligned, char(100) aligned), brief_msg char(8) aligned, long_msg char(100) aligned, based_ptr pointer aligned based, based_lisp_data bit(72) aligned based, sp pointer, ioa_$ioa_switch entry options(variable), iox_$error_output ext ptr, nop_0_du bit(36) static init("000000000000000000000001001000000011"b), (null, hbound, lbound, baseno, baseptr, addr, addrel, substr, rel, ptr, bit, fixed, unspec, add) builtin, in_pl1_code_flag bit(36), fault_pbr ptr, action fixed bin, a_mcp ptr, find_condition_frame_ entry(pointer) returns(pointer), find_condition_info_ entry(pointer, pointer, fixed bin(35)), short_name(4:6) char(4) aligned static init("quit", "mme4", "faul"), full_names(4:6) char(12) aligned static init("quit", "mme4", "fault_tag_3"), insts(0:1) bit(36) aligned based; dcl flonum float bin(63), based_flonum_1 float bin(27) aligned based, based_flonum_2 float bin(63) aligned based, fixedb fixed bin aligned based, 1 instruction aligned, 2 address bit(18) unaligned, 2 opcode bit(10) unaligned, 2 modifiers bit(8) unaligned, 1 based_instruction based aligned structure like instruction, lisp_fault_handler_$wipe_stack entry, lisp_fault_handler_$stack_loss entry(fixed bin), which_stack fixed bin, lisp_segment_manager_$grow_stacks entry(fixed bin(35)), lisp_static_vars_$divov_flag fixed bin(71) external, lisp_static_vars_$zunderflow fixed bin(71) external, code fixed bin(35); dcl 1 fault_tag_3_pointer aligned based, 2 fault_code fixed bin(17) unaligned, 2 fault_tag_3 fixed bin(17) unaligned; dcl 1 cond_info automatic aligned structure, %include cond_info; %include lisp_free_storage; %include lisp_faults; dcl unm pointer; /* not actually used anywhere. This is just to keep the compiler happy */ %include mc; %include lisp_common_vars; %include lisp_stack_seg; %include lisp_atom_fmt; stack_base = ptr(unmkd_ptr, "0"b); in_pl1_code_flag = stack_base -> stack_seg.in_pl1_code; do fault_type = lbound(short_name, 1) to hbound(short_name, 1); if substr(cond_name,1,4) = short_name(fault_type) then if cond_name = full_names(fault_type) then go to is_ours; end; fault_type = -1; /* not found, not our fault */ is_ours: join: if lisp_static_vars_$binding_reversal_flag ^= ""b /* can't interrupt while reversing bindings */ then if fault_type >= 5 then go to continue_signal; /* but do allow bad faults through */ else do; if fault_type < 0 then go to check_mc; /* ?? */ lisp_static_vars_$binding_reversal_flag = lisp_static_vars_$binding_reversal_flag | bit(fixed(fault_type, 36), 36); return; end; if lisp_alloc_$alloc_fault_word ^= "0"b then if fault_type >= 5 then go to continue_signal; /* should never happen anyway */ else do; if fault_type < 0 then go to check_mc; call lisp_alloc_$set_fault(fault_type); dcl lisp_alloc_$set_fault entry(fixed bin); return; end; mcp = a_mcp; check_mc: scup = null; /* Just in case */ if mcp = null() then go to no_machine_conditions; sp = mcp -> mc.prs(spx); /* get sp at time of fault */ scup = addr(mcp -> mc.scu); if in_pl1_code_flag = "0"b /* we are executing with ap, and ab|0,x7 */ then do; if baseno(stack_ptr) ^= baseno(mcp->mc.prs(apx)) then go to something_fishy; if stack_base ^= mcp ->mc.prs(abx) then go to something_fishy; unmkd_ptr = addrel(stack_base, mcp -> mc.regs.x(7)); stack_ptr = mcp -> mc.prs(apx); end; no_machine_conditions: if lisp_static_vars_$ignore_faults then go to continue_signal; if fault_type ^= -1 then go to our_fault; /* if it really was ours */ /* if it wasn't, we wanted to go through the above code to update stack_ptr, unmkd_ptr before going to continue_signal and letting the fault out of lisp */ if mcp = null() then go to continue_signal; /* can't do this stuff without machine conditions */ /* check for zerodivide and stackoverflow */ if cond_name = "zerodivide" then if in_pl1_code_flag then go to continue_signal; /* not lisp */ else go to zerodivide_handler; else if cond_name = "underflow" then if in_pl1_code_flag then go to continue_signal; /* not lisp */ else go to underflow_handler; else if cond_name = "out_of_bounds" then if "000"b || scu.tpr.tsr = baseno(stack_ptr) then go to marked_stack_oob; else if "000"b || scu.tpr.tsr = baseno(unmkd_ptr) then go to unmarked_stack_oob; continue_signal: return_tv(2): if fault_type >= 0 then if fault_type < 4 /* can't set continue bit for timer faults */ then do; call ioa_$ioa_switch(iox_$error_output, "lisp: Timer ignored, no lisp environment was present."); /* let user know this happened */ return; end; continue_signal_aa: if lisp_static_vars_$ignore_faults then do; /* we must just pass things through */ /* set continue flag, and restore state, then return to signal_ */ continue = "1"b; stack_base -> stack_seg.in_pl1_code = in_pl1_code_flag; return; end; else do; /* we have to change lisp_static_vars_$ignore_faults, but have to have a stack frame around to to restore it if the ultimate handler chooses to return */ lisp_static_vars_$ignore_faults = (36) "1"b; /* now if we resignal the same thing, will get back past lisp's default handler */ call signal_ (cond_name, a_mcp, infoptr); lisp_static_vars_$ignore_faults = (36) "0"b; /* restore state back */ stack_base -> stack_seg.in_pl1_code = in_pl1_code_flag; return; end; our_fault: stack_base -> stack_seg.in_pl1_code = "1"b; /* set up for lisp_fault_handler_ call */ action = 0; if mcp ^= null() then fault_pbr = addrel(baseptr("000"b||scup->scu.ppr.psr), scup -> scu.ilc); else fault_pbr = null; /* Ah well */ /* for fault_tag_3 faults, the fault code comes from the segment number field of the faulted pointer */ if fault_type = Car_cdr_fault then do; code = addrel(baseptr("000"b||scup->scu.tpr.tsr), scup->scu.ca) -> fault_tag_3_pointer.fault_code; if code = 1 then fault_type = Old_store_fault; else if code = 2 then fault_type = Array_fault; end; call lisp_fault_handler_(fault_type, fault_pbr, action); stack_base -> stack_seg.in_pl1_code = in_pl1_code_flag; go to return_tv(action); return_tv(1): /* move to new address */ scup -> scu.ppr.psr = substr(baseno(fault_pbr),4,15); /* get seg # */ scup -> scu.ilc = rel(fault_pbr); /* force ilc to addr */ scup -> scu.cu.rfi = "1"b; return_tv(0): return; return_tv(3): /* old array store kludge - redo the store with new address */ fault_pbr -> based_lisp_data = mcp -> mc.a || mcp -> mc.q; /* store aq */ scup -> scu.ilc = bit(fixed(fixed(scup -> scu.ilc, 18)+1, 18), 18); /* skip over staq inst. */ scup -> scu.cu.rfi = "1"b; return; program_interrupt: entry; lisp_static_vars_$ignore_faults = "0"b; /* considered to be in lisp now */ action = 0; call lisp_fault_handler_ ((Pi_fault), null(), action); go to process_quit_return; deferred_quit: entry; dcl quit condition; handle_defer_quit: lisp_static_vars_$ignore_faults = "0"b; /* if pi, we're back in lisp now */ action = 0; call lisp_fault_handler_((Quit_fault), null(), action); process_quit_return: if action ^= 0 then do; dcl lisp_static_vars_$transparent bit(1) external; lisp_static_vars_$ignore_faults = "1"b; lisp_static_vars_$transparent = "1"b; /* to let this one quit get through */ signal quit; /* after a great struggle, this will get you out to command level */ lisp_static_vars_$ignore_faults = "0"b; end; return; alarm: entry(a_mcp, cond_name); /* called by timer_manager_ for lisp 'alarmclock' function */ mcp = a_mcp; stack_base = ptr(unmkd_ptr, "0"b); in_pl1_code_flag = stack_base -> stack_seg.in_pl1_code; if cond_name = "alrm" then fault_type = 2; else if cond_name = "cput" then fault_type = 1; else fault_type = 3; /* shouldn't happen, lisp_fault_handler_ will give the err msg */ go to join; alloc_fault: entry(fault_bits); dcl fault_bits bit(36) aligned; if fault_bits & alrm_fault then call lisp_fault_handler_(2, null, 0); if fault_bits & cput_fault then call lisp_fault_handler_(1, null, 0); if fault_bits & quit_fault then go to handle_defer_quit; return; /* There's something fishy going on here: in_pl1_code is zero, yet ab is not pointing at the stack. This could because no lisp is around, or because lisp has a bug in it and took some kind of fault and then a timer went off, or because a timer went off while some other fault was being signalled. In the latter case, we want to use the machine conditions of the original fault, i.e. lisp's machine conditions not signal_'s. In the other two cases we go to continue_signal to let default_error_handler_ handle it or else to ignore a timer fault that occurs at an inopportune time. */ something_fishy: sp = find_condition_frame_(sp); if sp = null then go to continue_signal; /* no fault frame was found */ cond_info.version = 1; /* varsion number of structure I allocate */ call find_condition_info_(sp, addr(cond_info), code); if code ^= 0 then go to continue_signal; /* not of interest */ mcp = cond_info.mcptr; /* machine conditions at previous fault */ if cond_info.condition_name ^= "quit" then if cond_info.condition_name ^= "cput" then if cond_info.condition_name ^= "alrm" then if cond_info.condition_name ^= "mme4" then if cond_info.condition_name ^= "fault_tag_3" then go to continue_signal; /* some bad fault happened - probably a bug in lisp so we don't want to reenter it because that might terminate the process. */ go to check_mc; /*** found a previous fault, so go look at its machine conditions (mcp has been changed) */ /* come here to see if we have a stack overflow (oob fault caused by setting max length) */ marked_stack_oob: which_stack = 2; go to stack_oob; unmarked_stack_oob: /* for now, assume any oob on these segments is an overflow */ which_stack = 3; stack_oob: stack_base -> stack_seg.in_pl1_code = "1"b; /* set up for lisp_fault_handler_ call */ call lisp_segment_manager_$grow_stacks(code); /* make stacks big enough to handle fail-act */ if code ^= 0 then do; call convert_status_code_(code, brief_msg, long_msg); call ioa_$ioa_switch(iox_$error_output, "lisp: Stack overflow. (^a)^/^-An automatic ctrl/g occurs.", long_msg); call lisp_fault_handler_$wipe_stack; end; /* take a fail-act. */ call lisp_fault_handler_$stack_loss(which_stack); /* come here attempting to restart program after stack overflow. assume that a simple rcu is sufficient because max length of stack segs has changed. */ stack_base -> stack_seg.in_pl1_code = in_pl1_code_flag; return; /* come here to do (status divov) hack when a zerodivide interrupt occurs */ zerodivide_handler: stack_base -> stack_seg.in_pl1_code = "1"b; /* set up for lisp_fault_handler_ call */ /* see if user has done (sstatus divov t), which turns on the hackery below */ if lisp_static_vars_$divov_flag = nil then go to zerodivide_fail_act; /* no special hackery desired */ zerodivide_hackery: /* first get the instruction being executed at the time. Because the 6180 carefully clobbers the instruction register on a zerodivide fault, we have to fetch it ourselves */ instruction = ptr(baseptr("000"b || scu.ppr.psr), scu.ilc) -> based_instruction; hack_instruction: /* now hack the registers to make the result of the divide be the numerator plus 1 */ if instruction.opcode = "1010001100"b /* div */ then do; addr(mc.q) -> fixedb = addr(mc.q) -> fixedb + 1; mc.a = (36)"0"b; end; else if instruction.opcode = "1011101010"b | instruction.opcode = "1011101110"b /* fdv, dfdv */ then do; unspec(flonum) = mc.e || mc.a || mc.q; /* more or less a double-precision floating point number */ hack_flonum: flonum = flonum + 1.0; mc.e = substr(unspec(flonum), 1, 8); mc.a = substr(unspec(flonum), 9, 36); mc.q = substr(unspec(flonum), 45, 28) || (8)"0"b; end; else if instruction.opcode = "1010101010"b /* fdi */ then do; flonum = ptr(baseptr("000"b || scu.tpr.tsr), scu.ca) -> based_flonum_1; go to hack_flonum; end; else if instruction.opcode = "1010101110"b /* dfdi */ then do; flonum = ptr(baseptr("000"b || scu.tpr.tsr), scu.ca) -> based_flonum_2; go to hack_flonum; end; else if instruction.opcode = "1110011100"b /* xec - used by lisp_utils_ */ then do; call compute_effective_address; instruction = temp -> based_instruction; go to hack_instruction; end; else if instruction.opcode = "111001111"b /* xed - used by lisp_utils_ */ then do; call compute_effective_address; if scu.cu.xdo then temp = addrel(temp, 1); /* divide was odd instruction */ else if scu.cu.xde then; /* divide was even instruction */ else go to continue_signal; /* not xed??? - something lost. */ instruction = temp -> based_instruction; go to hack_instruction; end; else go to continue_signal; /* some random instruction we don't know about, such as decimal divide. Let loser see error message */ /* resume processing with next instruction after divide, the registers have been hacked */ scu.ilc = bit(add(fixed(scu.ilc,18), 1, 18, 0), 18); /* resume with instruction after divide */ scu.cu.rfi = "1"b; stack_base -> stack_seg.in_pl1_code = in_pl1_code_flag; return; /* internal proc to compute effective address of instruction. this is simplified version which works with those cases that appear in the LISP arithmetic routines in connection with xec and xed instructions */ compute_effective_address: proc; dcl modif fixed bin(8); temp = baseptr("000"b || scu.ppr.psr); /* -> seg containing instruction */ modif = fixed(instruction.modifiers, 8); if modif >= 16 then go to continue_signal; /* unknown */ /* simple r or n modification, no abr */ if modif = 0 then temp = ptr(temp, instruction.address); else if modif >= 8 then temp = ptr(temp, fixed(instruction.address, 18) + fixed(mc.regs.x(modif-8), 18)); /* ,x_n */ else go to continue_signal; /* can't hack ,ic ,du etc. */ end; /* gve (quotient 0) fail-act for zerodivide */ zerodivide_fail_act: call lisp_fault_handler_(Zerodivide_fault, (null), (0)); go to zerodivide_hackery; /* if it returns, we are to hack the instruction even though (status divov) was nil */ /***** underflow handling - depends on value of zunderflow *****/ underflow_handler: stack_base -> stack_seg.in_pl1_code = "1"b; /* set up for lisp_fault_handler_ call */ if addr(lisp_static_vars_$zunderflow) -> based_ptr -> atom.value = nil then go to underflow_error; hack_underflow: /* magically change underflow into a non-error by setting the eaq to zero and proceeding with the next instruction. */ /* declare a name by which we can refer to the opcode field of the current instruction field in the scu data. Note: the name even is a misnomer left over from the 645 */ declare 1 current_instruction aligned based(addr(scup -> scu.even_inst)), 2 address_part bit(18) unaligned, 2 current_op_code bit(10) unaligned, 2 inhibit_bit bit(1) unaligned, 2 ptr_reg_tab bit(1) unaligned, 2 modifier bit(6) unaligned; mcp -> mc.regs.a, mcp -> mc.regs.q = (36)"0"b; /* actually the fim does this, but I'm */ mcp -> mc.regs.e = "10000000"b; /* not going to rely on anyone as untrustworthy */ /* as the fim! */ if current_op_code ^= "1001100000"b /* check for store instructions */ then if current_op_code ^= "1001110100"b /* which are retried. Other instructions */ then if current_op_code ^= "1001011010"b then if current_op_code ^= "1001011110"b then scup -> scu.ilc = bit(fixed(fixed(scup -> scu.ilc, 18) /* increment the ilc to skip over the */ + 1, 18), 18); /* instruction that underflew */ scup -> scu.cu.rfi = "1"b; /* set this bit and CPU does everything else */ stack_base -> stack_seg.in_pl1_code = in_pl1_code_flag; return; underflow_error: call lisp_fault_handler_(Underflow_fault, (null), (0)); go to hack_underflow; /* return indicates should go make result zero */ end lisp_default_handler_;  lisp_define_.pl1 07/06/83 0937.0r w 06/29/83 1542.2 63216 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ defun: proc; /* fsubr for defining functions */ /* * originally coded by David Reed * recoded by D. Moon 6-JUN-72, for v2pl1 and new lisp_ptr format * modified 7-JUN-72 for new stack discipline. DAM * converted to correctable error scheme; * constants moved to lisp_static_vars_ DAM 8 Aug 72 * Fixed defprop to return its first argument. AS 10/4/72 */ /* lisp constants */ dcl ( lisp_static_vars_$lambda, lisp_static_vars_$expr_hash, lisp_static_vars_$expr, lisp_static_vars_$fexpr, lisp_static_vars_$macro ) fixed bin(71) aligned external, lisp_static_vars_$defun external ptr, (lambda def (lisp_static_vars_$lambda), expr def (lisp_static_vars_$expr), fexpr def (lisp_static_vars_$fexpr), macro def (lisp_static_vars_$macro) ) fixed bin(71) aligned, /* temporaries on the stack -- used by define */ argl ptr, r_ptr ptr based (addr(stack -> temp(2))), Aptr ptr based (addr(stack -> temp(3))), Bptr ptr based (addr(stack -> temp(4))), Nptr ptr based (addr(stack -> temp(5))), A fixed bin (71) aligned based (addr(stack -> temp(3))), B fixed bin (71) aligned based (addr(stack -> temp(4))), N fixed bin (71) aligned based (addr(stack -> temp(5))), /* declarations for defun and defprop */ args ptr def (stack -> temp_ptr(1)), /* to list of args of fsubr */ stack ptr, /* copy of stack_ptr */ foo fixed bin(71) aligned; /* a lisp-object holder */ /* ENTRY POINTS CALLED */ dcl lisp_error_ ext entry, lisp_utils_$pl1_sxhash ext entry, unm ptr, ercode(2) fixed bin aligned based(unm); dcl lisp_alloc_ entry(fixed bin, ptr); dcl lisp_get_atom_ ext entry (char(*), fixed bin(71) aligned); dcl lisp_special_fns_$cons ext entry; dcl lisp_property_fns_$get ext entry; dcl lisp_property_fns_$putprop ext entry; dcl lisp_property_fns_$remprop ext entry; %include lisp_atom_fmt; %include lisp_error_codes; %include lisp_name_codes; %include lisp_common_vars; %include lisp_cons_fmt; %include lisp_ptr_fmt; %include lisp_stack_fmt; /* DEFUN FSUBR */ /* works by generating args on the stack for a call to putprop */ stack = addrel(stack_ptr, -2); /* for efficiency */ stack_ptr = addr(stack -> temp(6)); /* room for temp's */ if stack -> temp_type(1) then /* ensure there is a list of args */ too_few: do; /* too few args correctable error */ stack_ptr = stack; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> ercode(1) = too_few_args; unm -> ercode(2) = fn_defun; call lisp_error_; return; /* lisp_error_ pushes a suitable return value onto marked pdl */ end; stack -> temp(2) = args -> cons.car; /* atom to get fcn property */ /* see if there is a 2nd arg */ if args -> cons_types.cdr then go to too_few; /* check for indicator as first arg */ if stack -> temp(2) ^= expr then if stack -> temp(2) ^= fexpr then if stack -> temp(2) ^= macro then go to check_second; /* normal case */ stack -> temp(3) = stack -> temp(2); stack -> temp(2) = args -> cons_ptrs.cdr -> cons.car; go to get_body; check_second: /* see whether 2nd arg is lambda-list or a p-list indicator (expr, fexpr, macro) */ stack -> temp(3) = args -> cons_ptrs.cdr -> cons.car; if stack -> temp(3) ^= expr then if stack -> temp(3) ^= fexpr then if stack -> temp(3) ^= macro then do; stack -> temp(3) = expr; stack -> temp(5) = args -> cons.cdr; go to make_lambda_exp; end; get_body: stack -> temp(5) = args -> cons_ptrs.cdr -> cons.cdr; make_lambda_exp: stack -> temp(4) = lambda; /* cons up a lambda - expression */ call lisp_special_fns_$cons; if stack -> temp_type(2) = Cons /* (defun (foo bar baz) ...) */ then do; stack -> temp(3) = stack -> temp_ptr(2) -> cons_ptrs.cdr -> cons.car; stack -> temp(2) = stack -> temp_ptr(2) -> cons.car; end; /* do expr-hash feature */ if lisp_static_vars_$defun -> atom.value ^= 0 & lisp_static_vars_$defun -> atom.value ^= nil then do; stack_ptr = addr(stack->temp(7)); stack->temp(5) = stack->temp(2); stack->temp(6) = lisp_static_vars_$expr_hash; call lisp_property_fns_$get; if stack->temp(5) ^= nil then do; stack_ptr = addr(stack->temp(7)); stack -> temp(6) = stack -> temp(4); /* lambda expression */ call lisp_utils_$pl1_sxhash; if stack -> temp(6) = stack->temp(5) then go to done_defun; stack->temp(5) = stack->temp(2); stack->temp(6) = lisp_static_vars_$expr_hash; call lisp_property_fns_$remprop; end; end; /* put args in right order for putprop */ stack_ptr = addr(stack -> temp(8)); /* lisp_special_fns_$cons has randomized stack_ptr */ stack -> temp(5), stack -> temp(7) = stack -> temp(3); /* the indicator is third arg */ /* the property is second arg */ stack -> temp(3), stack -> temp(6) = stack -> temp(2); /* the atom is first arg */ dremprop: call lisp_property_fns_$remprop; if stack->temp(6) ^= nil /* more to remprop? */ then do; stack_ptr = addr(stack->temp(8)); stack -> temp(6) = stack->temp(2); stack -> temp(7) = stack->temp(3); go to dremprop; end; stack_ptr = addr(stack -> temp(6)); call lisp_property_fns_$putprop; done_defun: stack -> temp(1) = stack -> temp(2); /* return the atom that was defun'ed */ stack_ptr = addr(stack -> temp(2)); /* clear the stack - return the atom that was defun'ed */ return; /* defprop is unevaluated form of putprop. This is just an interface to putprop */ defprop: entry; stack = addrel(stack_ptr, -2);; stack_ptr = addr(stack -> temp(7)); /* so can pass 3 args to putprop, 2 to remprop. */ /* and also save the first argument */ if stack -> temp(1) = nil | stack -> temp_type(1) then go to too_few; if stack -> temp_ptr(1) -> cons.cdr = nil | stack -> temp_ptr(1) -> cons_types.cdr then go to too_few; if stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.cdr = nil | stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons_types.cdr then go to too_few; /* arguments validated (at least that there are 3 ), so set up call to putprop */ stack -> temp(4), stack -> temp(6) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons_ptrs.cdr -> cons.car; stack -> temp(3) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car; stack -> temp(1), stack -> temp(5), stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; dfremprop: call lisp_property_fns_$remprop; if stack->temp(5) ^= nil then do; stack_ptr =addr(stack->temp(7)); stack->temp(5) = stack->temp(2); stack->temp(6) = stack->temp(4); go to dfremprop; end; stack_ptr = addr(stack->temp(5)); call lisp_property_fns_$putprop; stack_ptr = addr(stack -> temp(2)); /* clear the stack */ return; end;  lisp_defsubr_.pl1 07/06/83 0937.0r w 06/29/83 1542.2 151587 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ defsubr: proc; /* LISP subroutine definition subroutine. Makes a SUBR block in the lisp environment. Modified by Alex Sunguroff, 6/21/72, to add the subr, store. Modified by Dave Reed, 6/13/72, for the new lisp environment structure Modified 10 AUG 72 by D. Moon for new lisp_error_ Modified 1 Dec 1973 by D. A. Moon to make stuff in lisp_old_io_ be sysp again Modified 74.05.17 by DAM to take out array stuff and obsolete defsubr type 3. Also make_lisp_subr_block_ was made an internal procedure since no one else uses it now. */ dcl stack ptr, (sw, lsubrsw, fsubrsw) bit(1), (pointer, baseno) builtin, arg_index fixed bin, number_args fixed bin, flags fixed bin aligned, type fixed bin(2) aligned, nargs fixed bin aligned, subr_offsets(-2:2) fixed bin static init(4,0,2,6,4), 1 subr_info_stuff based aligned, 2 nargs fixed bin(17) unal, 2 subr_type fixed bin(17) unal, lisp$ external fixed bin, lisp_linker_ entry(pointer), lisp_linkage_error condition, subr_ptr ptr, data_ptr ptr, link_ptr ptr, data_object based aligned fixed bin(71), /* lisp object for defsubr copy of type 3 data */ 1 lisp_fixnum_ovly_lk based aligned, 2 pad bit(45) unal, 2 lk_info bit(27) unal, /* stuff generated by lisp compiler */ 1 link_info based aligned, 2 base bit(3) unal, /* itp base */ 2 info bit(27) unal, /* from defsubr's arguments */ 2 mod bit(6) unal, 2 word2 bit(36), lisp_error_ entry, unm ptr, 1 args_to_lisp_error_ based (unm) aligned, 2 ercode fixed bin, 2 fcn_name fixed bin, myname fixed bin, /* copy of fcn_name */ err fixed bin, copy_block (nwords) based aligned fixed bin(35); dcl 1 subr_head based aligned, 2 maxnum bit(9) unaligned, 2 minnum bit(9) unaligned; dcl lisp_special_fns_$cons entry; dcl (lisp_static_vars_$subr, lisp_static_vars_$lsubr, lisp_static_vars_$fsubr, lisp_static_vars_$array) fixed bin(71) external, (array defined lisp_static_vars_$array, subr defined lisp_static_vars_$subr, lsubr defined lisp_static_vars_$lsubr, fsubr defined lisp_static_vars_$fsubr) fixed bin(71); %include lisp_error_codes; %include lisp_name_codes; %include lisp_stack_seg; %include lisp_cons_fmt; %include lisp_comp_subr_block; %include lisp_ptr_fmt; %include lisp_string_fmt; %include lisp_nums; %include lisp_common_vars; %include lisp_stack_fmt; %include lisp_atom_fmt; myname = fn_defsubr; /* in case of error */ stack = addrel(stack_ptr,-2); /* get addr of arg count */ number_args = -divide(stack -> fixedb,2,35,0); /* get real arg count */ stack = addrel(stack,stack->fixedb); /* make stack point at begin of args */ defsubr_5: if number_args < 5 then flags = 0; /* default flags */ else if stack -> temp_type(5) & Fixed then flags = addr(stack->temp(5))->fixedb; else go to bad_argument_5; defsubr_4: if number_args < 4 then type = 2; /* default type is PL/I */ else if stack -> temp_type(4) & Fixed then type = addr(stack -> temp(4))->fixedb; else go to bad_argument_4; if type ^= 2 then if type ^= -2 then go to bad_argument_4; /* only PL/I subrs still work here */ defsubr_3: if stack -> temp_type(3) & Fixed then nargs = addr(stack -> temp(3)) -> fixedb; else go to bad_argument_3; defsubr_2: if stack -> temp_type(2) & String then; else go to bad_argument_2; defsubr_1: if stack -> temp_type(1) & String then; else go to bad_argument_1; call make_lisp_subr_block_(stack->temp_ptr(1), type, stack->temp_ptr(1)->string, stack->temp_ptr(2)->string, nargs, flags); stack_ptr = addr(stack->temp(2)); return; /* error handlers */ too_few: err = too_few_args; go to fatal; too_many: err = too_many_args; fatal: stack_ptr = stack; call error; return; bad_argument_5: addrel(stack_ptr, -2) -> temp(1) = stack -> temp(5); err = bad_arg_correctable; call error; stack -> temp(5) = addrel(stack_ptr, -2) -> temp(1); go to defsubr_5; bad_argument_4: addrel(stack_ptr, -2) -> temp(1) = stack -> temp(4); err = bad_arg_correctable; call error; stack -> temp(4) = addrel(stack_ptr, -2) -> temp(1); go to defsubr_4; bad_argument_3: addrel(stack_ptr, -2) -> temp(1) = stack -> temp(3); err = bad_arg_correctable; call error; stack -> temp(3) = addrel(stack_ptr, -2) -> temp(1); go to defsubr_3; bad_argument_2: addrel(stack_ptr, -2) -> temp(1) = stack -> temp(2); err = bad_arg_correctable; call error; stack -> temp(2) = addrel(stack_ptr, -2) -> temp(1); go to defsubr_2; bad_argument_1: addrel(stack_ptr, -2) -> temp(1) = stack -> temp(1); err = bad_arg_correctable; call error; stack -> temp(1) = addrel(stack_ptr, -2) -> temp(1); go to defsubr_1; /* interface to lisp_error_, called with ercode in vraiable err */ error: proc; unm = unmkd_ptr; /* push err code onto unmkd pdl */ unmkd_ptr = addrel(unm, 2); unm -> ercode = err; unm -> fcn_name = myname; call lisp_error_; return; end; args: entry; /* lsubr to tell how many args a subr expects or to put that there*/ stack = addrel(stack_ptr,-2); if addr(stack -> temp(1)) -> fixedb = -2 then sw = "1"b; else sw = ""b; stack = addrel(stack, addr(stack -> temp(1)) -> fixedb); args_01: stack_ptr = addr(stack -> temp(5)); if stack -> temp_type36(1) & Atsym36 then; else do; err = bad_arg_correctable; myname = fn_args; stack_ptr = addr(stack -> temp(6)); stack -> temp(5) = stack -> temp(1); /* put losing arg at top of pdl */ call error; stack -> temp(1) = stack -> temp(5); /* put corrected value back */ go to args_01; /* reset stack_ptr & retry */ end; stack -> temp(3) = stack -> temp_ptr(1) -> atom.plist; do while (stack -> temp_type(3) = Cons); if stack -> temp_ptr(3) -> cons.car = lsubr then do; lsubrsw = "1"b; fsubrsw = "0"b; go to common_in_args; end; if stack -> temp_ptr(3) -> cons.car = fsubr then do; fsubrsw = "1"b; lsubrsw = "0"b; go to common_in_args; end; if stack -> temp_ptr(3) -> cons.car = subr then do; lsubrsw = ""b; fsubrsw = "0"b; common_in_args: stack -> temp(3) = stack -> temp_ptr(3) -> cons_ptrs.cdr -> cons.car; if stack -> temp_type36(3) & Subr36 then go to Subr_pointer_is_found; /* if not really a subr, skip to next property */ end; stack -> temp(3) = stack -> temp_ptr(3) -> cons.cdr; if stack -> temp_type(3) = Cons then stack -> temp(3) = stack -> temp_ptr(3) -> cons.cdr; end; stack -> temp(1) = nil; stack_ptr = addr(stack -> temp(2)); return; /*it could not filnd a function definition*/ Subr_pointer_is_found: subr_ptr = stack -> temp_ptr(3); if sw then do; /*if we're going to give back the value*/ if fsubrsw then do; stack -> temp(3) = nil; go to args_return; end; else if lsubrsw then do; addr(stack -> temp(3)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(3)) -> fixedb = binary(subr_ptr -> minnum, 9); addr(stack -> temp(4)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(4)) -> fixedb = binary(subr_ptr -> maxnum, 9); end; else do; stack -> temp(3) = nil; addr(stack -> temp(4)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(4)) -> fixedb = binary(subr_ptr -> minnum, 9); /* get nargs */ end; call lisp_special_fns_$cons; args_return: stack -> temp(1) = stack -> temp(3); stack_ptr = addr(stack -> temp(2)); return; /*and so we return*/ end; stack -> temp(3) = stack -> temp_ptr(2) -> cons.car; stack -> temp(4) = stack -> temp_ptr(2) -> cons.cdr; if stack -> temp(3) = nil then do; subr_ptr -> maxnum = bit(binary(0, 9)); subr_ptr -> minnum = bit(fixed(addr(stack -> temp(4)) -> fixedb,9)); end; else do; subr_ptr -> minnum = bit(fixed(addr(stack -> temp(3)) -> fixedb, 9)); subr_ptr -> maxnum = bit(fixed(addr(stack -> temp(4)) -> fixedb, 9)); end; stack -> temp(1) = stack -> temp(2); stack_ptr = addr(stack -> temp(2)); return; sysp: entry; /*subr predicate to tell if a subr is a system subr*/ stack = addrel(stack_ptr, -2); sysp_01: stack_ptr = addr(stack -> temp(4)); if stack -> temp_type36(1) & Atsym36 then; else do; /*must be an atom*/ sysp_bad_1: stack_ptr = addr(stack -> temp(2)); err = bad_arg_correctable; myname = fn_sysp; call error; go to sysp_01; end; stack -> temp(2) = stack -> temp_ptr(1) -> atom.plist; /*get the p-list*/ do while(stack -> temp_type(2) = Cons); /*search down the p-list*/ if stack -> temp_ptr(2) -> cons.car = lsubr | stack -> temp_ptr(2) -> cons.car = subr | stack -> temp_ptr(2) -> cons.car = fsubr then do; /*if the indicator is found then ...*/ stack -> temp(3) = stack -> temp_ptr(2) -> cons_ptrs.cdr -> cons.car; /*getptr*/ if stack -> temp_type36(3) & System_Subr36 then do; stack -> temp(1) = stack -> temp_ptr(2) -> cons.car; stack_ptr = addr(stack -> temp(2)); return; end; if stack -> temp_type36(3) & Subr36 then do; /*must be Subr ptr*/ data_ptr = stack -> temp_ptr(3); if data_ptr -> subr_entries(1).rest_of_tsx0 = tsx0_ic then go to new_type_subr; /* compiled subr */ if data_ptr -> subr_info_stuff.subr_type = 3 then do; data_ptr = addrel(data_ptr, 4); /* -> tsplp n,ic* instruction */ data_ptr = addrel(data_ptr, data_ptr -> subr_info_stuff.nargs); /* get addr of link */ end; else data_ptr = addrel(data_ptr, subr_offsets(data_ptr -> subr_info_stuff.subr_type)); number_args = data_ptr -> based_ptr -> fixedb; /* this is just a dummy operation to snap pointer_to_subr*/ if baseno(data_ptr -> based_ptr) = baseno(addr(lisp$)) then stack -> temp(1) = stack -> temp_ptr(2) -> cons.car;/*will return thee, indicator*/ else ret_nilll: stack -> temp(1) = nil; /*return nil*/ stack_ptr = addr(stack -> temp(2)); return; end; end; stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; if stack -> temp_type(2) = Cons then stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; /*cdr down farther*/ end; stack -> temp(1) = nil; /*return nil*/ stack_ptr = addr(stack -> temp(2)); return; /* come here for sysp of a new (fasload) subr */ new_type_subr: data_ptr = addrel(addr(data_ptr -> subr_entries(1).head_offset), data_ptr -> subr_entries(1).head_offset - 2); /* -> subr block */ /* the -2 is to allow for the fact that the instructions start 2 words into the subr block */ link_ptr = addrel(addr(data_ptr -> subr_block_head.subr_code_link_offset), data_ptr -> subr_block_head.subr_code_link_offset); if link_ptr -> link_info.mod ^= "100011"b then do; /* if necessary, snap link */ on condition(lisp_linkage_error) go to ret_nilll; call lisp_linker_(link_ptr); revert condition(lisp_linkage_error); end; if baseno(link_ptr -> based_ptr) ^= baseno(addr(lisp$)) then go to ret_nilll; /* yes, it really is bound in with us. Must be sysp */ stack -> temp(1) = stack -> temp_ptr(2) -> cons.car; /* will reeturn thee, indicator. */ stack_ptr = addr(stack -> temp(2)); return; /** internal procedure to generate a PL/I type subr for defsubr **/ make_lisp_subr_block_: proc(block_ptr, subr_type, seg_name, entrypoint, num_args, flags); /* Routine to make a standard form SUBR block in the lisp static data segment. Takes as arguments: block_ptr -- return pointer to allocated block. subr_type -- 0, fast call LISP subroutine which needs no save lp or bp. 1, fast call LISP subroutine which needs save of lp and bp 2, PL/I routine called with args on LISP stacks, through interface. 3, lisp compiled function, with static data in its block. seg_name -- name of segment containing code for SUBR entrypoint-- name of entry in segment. num_args -- number of args expected by SUBR flags -- number of words to be allocated for type 3 static data block. if not type 3 subr; should be zero! Coded by D. Reed 6/8/72 */ /* modified 6/2/73 by DAM for recursive lisp - stat_top and cur_stat_seg moved to lisp_static_vars_ */ dcl block_ptr ptr, subr_type fixed bin(2) aligned, seg_name char(*) aligned, entrypoint char(*) aligned, num_args fixed bin(17) aligned, flags fixed bin(17) aligned; dcl delta_size(-2:3) fixed bin(4) aligned static init(11,0,9,13,11,13), /* number words over space for strings needed by block */ space pointer, segnamel fixed bin, entryl fixed bin, 1 basic_block based aligned, 2 no_args fixed bin(17) unaligned, 2 stype fixed bin(17) unaligned, 2 entry_instructions(5) bit(36) aligned, tra_1_ic_ind bit(36) aligned static init("000000000000000001111001000000010100"b), eaplp_ab_sys_lp bit(36) aligned static init("001000000000100100011111000001010000"b), tsblp_ic_ind bit(18) aligned static init("110111000000010100"b), eax7_2 bit(36) aligned static init("000000000000000010110010111000001111"b), eax7_4 bit(36) aligned static init("000000000000000100110010111000001111"b), stpbp_ab_back_2 bit(36) aligned static init("001111111111111110010101010001001111"b), stplp_ab_back_4 bit(36) aligned static init("001111111111111100110101000001001111"b), tsbbp_ab_pl1_int bit(36) aligned static init("001000000000110110010111010001010000"b), tsbbp_ab_lsubr_int bit(36) aligned static init("001000000000111000010111010001010000"b), 1 linkage_block based aligned, /* appears after allocated space for random data */ 2 link, 3 header_rel fixed bin(17) unaligned, /* back offset to header at word 2 of segment */ 3 fault_tag fixed bin(17) unaligned, /* set to 100110b */ 3 exp_word bit(18) unaligned, 3 more_mod bit(18) unaligned, /* should be zero */ 2 exp_offset bit(18) unaligned, /* rel of next word in segment */ 2 expression bit(18) unaligned, /* zero this */ 2 class fixed bin(17) unaligned, /* should be 4 */ 2 trap fixed bin(17) unaligned, /* should be zero */ 2 segname_rel bit(18) unaligned, 2 entry_rel bit(18) unaligned, 2 start_of_strings fixed bin, /* where first string goes */ 1 acc based aligned, 2 len fixed bin(8) unaligned, /* just never greater than 32 */ 2 string char(262144) unaligned, /* filled in with len chars */ size fixed bin(18), lisp_static_man_$allocate entry(pointer, fixed bin(18)), (addrel,rel,addr,null,substr,length,divide) builtin; segnamel = length(seg_name); /* compute storage for acc strings */ entryl = length(entrypoint); size = divide(segnamel,4,17,0)+divide(entryl,4,17,0); /* the extra two words are in the deltas */ size = size + delta_size(subr_type) + flags; size = 2*divide(size+1,2,17,0); /* round to mod2 bound */ call lisp_static_man_$allocate(block_ptr, size); space = block_ptr; addr(block_ptr)->lisp_ptr.type = Subr; space -> basic_block.no_args = num_args;/* fill in block */ space -> basic_block.stype = subr_type; go to make_entry(subr_type); /* branch on type */ make_entry(-2): space -> basic_block.entry_instructions(3) = tsbbp_ab_lsubr_int; /* this is an LSUBR */ go to make_type_2; make_entry(2): space -> basic_block.entry_instructions(3) = tsbbp_ab_pl1_int; make_type_2: space -> basic_block.entry_instructions(1) = eax7_2; space -> basic_block.entry_instructions(2) = stpbp_ab_back_2; space = addrel(space,4); make_link: space -> linkage_block.header_rel = 2 - binary(rel(space),18,0); space -> linkage_block.fault_tag = 100110b; /* 46(8) */ space -> linkage_block.more_mod = "0"b; space -> linkage_block.link.exp_word = rel(addr(space->linkage_block.exp_offset)); space -> linkage_block.exp_offset = rel(addr(space->linkage_block.class)); space -> linkage_block.expression = "0"b; space -> linkage_block.class = 4; space -> linkage_block.trap = 0; space -> linkage_block.segname_rel = rel(addr(space->linkage_block.start_of_strings)); space -> linkage_block.entry_rel = rel(addrel(addr(space->linkage_block.start_of_strings),divide(segnamel,4,17,0)+1)); space = addr(space->linkage_block.start_of_strings); space -> acc.len = segnamel; substr(space->acc.string,1,segnamel) = substr(seg_name,1,segnamel); space = addrel(space,divide(segnamel,4,17,0)+1); space -> acc.len = entryl; substr(space->acc.string,1,entryl) = substr(entrypoint,1,entryl); return; end make_lisp_subr_block_; end defsubr;  lisp_error_.pl1 11/05/86 1612.2r w 11/04/86 1042.5 321120 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_error_: proc; /* * The new lisp error handler which supports user interrupts. * and uses lisp argument passing conventions instead of pl1 arguments. * Contains several associated lisp functions. * * arguments: * last two words on unmarked pdl are error code, code2 (file_system_error only) * If the error takes a lisp form to be printed out, it is on * the top of the marked pdl. * * lisp_error_ does all user interrupting and error recovery on * correctable errors. * * Written by David Moon, 3 July 1972 * reorganized 28 July 72 DAM * pdl ptr format changed to -#, +#, or nil. DAM 5-aug-72 * function names for bad_argument, bad_arg_correctable added 25 Aygust 1972 DAM * err function moved here from lisp_prog_fns_, DAM 15 October 1972 * err_op entry added, DAM 21 Oct 72 * error tables moved into seperate module lisp_error_table_.alm, DAM, 7 Jan 73 * freturn added, 23 Jan 73 by DAM * changed for new I/O system, 19 Mar 73 by DAM * entry point for the lsubr 'error' added 11 May 1973 by DAM * modified 73.10.25 by DAM to make evalframe smarter * modified 74.06.03 by DAM for new-arrays * modified 74.09.12 by DAM for cleaning up and new frame formats * * The data kept around by an error consists of: * * bits (some useful bits declared somewhere or other) * stack -> * temp(1) the message * temp(2) the datum (NotThere if none) * temp(3) the interrupt channel (atom whose value is handler, NotThere if not to interrupt) * * unm -> fault_save: * stack_ptr = rel(stack) * code1 a positive number * code2 bits (unspecly) */ dcl lisp_error_table_$hbound fixed bin aligned external, /* number of err codes */ lisp_error_table_$msgs aligned bit(36) external, msgs (100:lisp_error_table_$hbound) char(40) aligned based(addr(lisp_error_table_$msgs)), /* messages to be typed out */ msgbuf char(128) aligned automatic, /* buffer for constructed messages */ lisp_error_table_$uintnum aligned bit(36) external, uintnum (100:hbound(msgs,1)) fixed bin aligned based(addr(lisp_error_table_$uintnum)), /* user intr channel */ lisp_error_table_$bit_tbl aligned bit(36) external, bit_tbl(100:hbound(msgs,1)) bit(36) aligned based(addr(lisp_error_table_$bit_tbl)), /* action control bits */ lisp_error_table_$fnames_hbound fixed bin aligned external, lisp_error_table_$fnames aligned bit(36) external, fnames(10:lisp_error_table_$fnames_hbound) char(16) aligned based(addr(lisp_error_table_$fnames)); /* names of functions indi & ated by code2 */ /* table of bits to control action on interrupts */ dcl ( datf init("1"b), /* data on stack from our caller */ printf init("01"b), /* s-expression is to be printed in err msg */ nilconsf init("001"b), /* listify before passing to intr service routine */ spbeg init("0001"b), /* special action to be taken first thing */ uintf init("00001"b), /* cause user interrupt on channel uintnum(code) */ evalf init("000001"b), /* evaluate value returned by intr service function */ spint init("0000001"b), /* special action to be taken before giving interrupt */ spfin init("00000001"b), /* special action to be taken after interrupt */ fserr init("000000001"b), /* message comes from file system rather than msgs(code) */ err_recf init("0000000001"b), /* fault_save frame is created _b_e_f_o_r_e calling lisp_error_ */ sptrapf init("00000000001"b), /* *rset-trap or errset trap */ fnamef init("000000000001"b) /* code2 designates function name to be given */ ) bit(36) aligned static, bits bit(36) aligned automatic, /* buffer in which the above bits are held */ err_fcn_f bit(1) aligned init("0"b), errsw bit(1), /* errprint / errframe entry switch */ bfb fixed bin (35) aligned based, stack ptr, error_data ptr, argument_pointer pointer, evals_stack ptr, unm ptr, code fixed bin, code2 fixed bin, /* 2nd code, at present used only by file_system_error */ myname fixed bin, /* this is the other use for code2, fcn name codes. */ com_err_ ext entry options(variable), ioa_ ext entry options(variable), 1 label_overlay aligned based, 2 label_ptr_1 aligned ptr, 2 label_ptr_2 aligned ptr, dummy_aligned aligned fixed bin(35) based, (null, addr, addrel, fixed, bit, ptr, rel, size, min, length, divide, reverse, verify, lbound, hbound, unspec, substr) builtin, lisp_fault_handler_$nointerrupt entry, lisp_reader_$maknam entry, lisp_prog_fns_$lisp_unwinder entry, lisp_$freturn_real external, 1 label aligned automatic, 2 adr pointer, 2 sp pointer, label0 label aligned based(addr(label)), lisp_prog_fns_$lisp_err entry (bit(1) aligned), unm2 ptr, posf bit(1), /* "1"b if a + pdl ptr was used, "0"b if - */ loc bit(18) aligned, dbl_word fixed bin(71), (i, nargs, uint_ch_num_spec) fixed bin; dcl 1 call1_cruft aligned based, /* pushed on marked pdl by funcall and the call1 operator */ 2 form fixed bin(71), 2 fcn fixed bin(71), 2 argl structure, 3 arg_rel_ptr bit(18) unaligned, 3 uncollectable_bits bit(18) unaligned, 3 number_of_args fixed bin(17) unaligned, 3 number_of_args_times_minus_two fixed bin(17) unaligned, 2 plist fixed bin(71); dcl uncollectable_tag bit(18) static init("000110000000000000"b), apply_frame_bit bit(18) static init("000000000000000001"b), marked_stack_frame pointer; /* -> stuff pushed on as part of eval frame (see pdlframe:) */ dcl 1 loc_ovly aligned based(addr(loc)), /* so that we can add 1 to loc */ 2 locfb fixed bin(17) unaligned, 2 extrabits bit(18) unal; dcl lisp_special_fns_$cons ext entry, lisp_special_fns_$xcons entry, lisp_special_fns_$ncons entry, lisp_alloc_ ext entry (fixed bin, fixed bin(71) aligned), lisp_static_vars_$readeof_atom fixed bin(71) external, lisp_static_vars_$infile fixed bin(71) external, infile fixed bin(71) def (lisp_static_vars_$infile), lisp_static_vars_$outfiles fixed bin(71) external, outfiles fixed bin(71) def (lisp_static_vars_$outfiles), lisp_static_vars_$errlist external pointer, lisp_get_atom_ ext entry(char(*) aligned, fixed bin(71) aligned), lisp_$apply ext entry, lisp_$eval ext entry; dcl lisp_print_$type_nl entry, lisp_print_$type_string entry(char(*)), ioa_$rsnpnnl ext entry options(variable), retlen fixed bin, msgbufb char(retlen) aligned based(addr(msgbuf)), /* get significant portion of msgbuf */ convert_status_code_ ext entry(fixed bin, char(8) aligned) returns (char(100) aligned); dcl lisp_static_vars_$emptying_buffers fixed bin external, lisp_io_control_$empty_all_buffers entry; dcl NotThere fixed bin(71) static init(0); dcl (lisp_static_vars_$err_atom, lisp_static_vars_$eval_atom, lisp_static_vars_$apply_atom, lisp_static_vars_$princ_atom, lisp_static_vars_$prin1_atom) fixed bin(71) external; /* Error Codes */ dcl (lisp_error_table_$not_pdl_ptr, lisp_error_table_$stack_loss_error) fixed bin external, not_pdl_ptr fixed bin defined lisp_error_table_$not_pdl_ptr, stack_loss_error fixed bin defined lisp_error_table_$stack_loss_error; %include stack_frame; %include lisp_faults; %include lisp_string_fmt; %include lisp_unmkd_pdl; %include lisp_nums; %include lisp_atom_fmt; %include lisp_name_codes; %include lisp_stack_fmt; %include lisp_ptr_fmt; %include lisp_common_vars; %include lisp_io; /* for ctrlW */ %include lisp_cons_fmt; %include lisp_stack_seg; /*lisp_error_: entry; */ dcl (lisp_static_vars_$go_atom, lisp_static_vars_$return_atom, lisp_static_vars_$setq_atom) external fixed bin(71) aligned, setq_atom fixed bin(71) aligned defined(lisp_static_vars_$setq_atom), go_atom fixed bin(71) aligned defined (lisp_static_vars_$go_atom), return_atom fixed bin(71) aligned defined (lisp_static_vars_$return_atom); /* set up pointers to stack */ stack = stack_ptr; unm = addrel(unmkd_ptr, -2); /* points to error code */ code = unm -> errcode(1); /* pick up error code from unmarked pdl */ code2 = unm -> errcode(2); /* get 2nd code in case file_system_error */ if code < lbound(msgs, 1) | code > hbound(msgs, 1) then do; call ioa_("lisp_error_: undefined code ^d.", code); go to unwind; end; bits = bit_tbl(code); /* pick up controlling bits */ if ^ bits & datf then do; stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = NotThere; end; else stack = addrel(stack, -2); /* -> data on pdl */ stack_ptr = addr(stack -> temp(4)); stack -> temp(2) = stack -> temp(1); /* get the data */ /* get the message into lispish form */ if bits & fserr then call ioa_$rsnpnnl("lisp: ^a ", msgbuf, retlen, convert_status_code_(code2,"")); else if bits & fnamef then do; code2 = - code2; if code2 < lbound(fnames,1) then code2 = hbound(fnames,1); else if code2 > hbound(fnames,1) then code2 = hbound(fnames,1); call ioa_$rsnpnnl(substr(msgs(code), 1, index(msgs(code), "`")-1), /* control string so fcn name can be inserted */ msgbuf, retlen, fnames(code2)); code2 = -code2; end; else call ioa_$rsnpnnl("lisp: ^a ", msgbuf, retlen, (msgs(code)) ); call lisp_alloc_(divide(retlen+7,4,18,0), stack -> temp(1)); stack -> temp_type(1) = String; stack -> temp_ptr(1) -> lisp_string.string_length = retlen; stack -> temp_ptr(1) -> lisp_string.string = msgbuf; /* get the interrupt channel */ if ^bits & uintf then stack -> temp(3) = NotThere; /* none such */ else do; addr(stack -> temp(3)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(3)) -> fixedb = uintnum(code); end; if bits & spbeg then go to spbegtv(code); /* do special action */ spbegxx: /* ... and return here */ go to handle_error; /* the LISP lsubr 'error', which makes the error system extensible. */ error: entry; stack = addrel(stack_ptr, -2); nargs = stack -> fixedb; /* lsubr */ if nargs = 0 then do; /* with no args, is like (err) */ stack -> temp(1) = nil; err_fcn_f = "1"b; go to unwind; /* like err_aa */ end; stack = addrel(stack, nargs); stack_ptr = addr(stack -> temp(4)); /* change missing args to NotThere */ if nargs > -6 then stack -> temp(3) = NotThere; if nargs > -4 then stack -> temp(2) = NotThere; bits = ""b; code = 1; unm = unmkd_ptr; handle_error: /* All types of errors join in here */ /* canonicalize the interrupt handler */ if addr(stack -> temp(3)) -> fixnum_fmt.type_info = fixnum_type then do; uint_ch_num_spec = addr(stack -> temp(3)) -> fixedb; if uint_ch_num_spec >= 0 & uint_ch_num_spec < hbound(user_intr_array, 1) + 1 then stack -> temp(3) = user_intr_array(uint_ch_num_spec); else stack -> temp(3) = NotThere; end; else if stack -> temp_type36(3) & Atsym36 /* uint chn spec as atom */ then do; if stack -> temp(3) ^= nil then /* unused channel marker */ do uint_ch_num_spec = 0 to hbound(user_intr_array, 1); if user_intr_array(uint_ch_num_spec) = stack -> temp(3) then go to exitloop; end; stack -> temp(3) = NotThere; /* bad uint chn */ exitloop: end; else stack -> temp(3) = NotThere; /* bad uint chn */ /* do JONL's ncons hack on channels 5, 6, 7, and 8 */ do uint_ch_num_spec = 5 to 8; if stack -> temp(3) = user_intr_array(uint_ch_num_spec) then bits = bits | nilconsf; end; /* flush all output buffers */ lisp_static_vars_$emptying_buffers = lisp_static_vars_$emptying_buffers + 1; if lisp_static_vars_$emptying_buffers = 0 then call lisp_io_control_$empty_all_buffers; lisp_static_vars_$emptying_buffers = lisp_static_vars_$emptying_buffers - 1; /* Check for user interrupt action to be performed */ if stack -> temp(3) ^= NotThere then if rel(err_frame) then if addr(user_intr_array(4)) -> based_ptr -> atom.value ^= nil then go to user_interrupter; else; else go to user_interrupter; uintdis: /* come here when user interrupt is disabled */ if code = stack_loss_error then go to user_interrupter; /* in this case, always interrupt */ uintdis0: /* check if errset (...) nil has suppressed error messages */ if rel(err_frame) then if err_frame -> frame.dat1 then go to unwind; /* yes, skip msg */ /* no, print the error message */ call prmes_immediate; /* non user interrupt or suppressed by errset, just unwind the pdl */ unwind: /* check for the need to do a *rset-trap */ if rel(err_frame) = ""b then /* going to go all the way, take a *rset-trap first */ if addr(user_intr_array(19)) -> based_ptr -> atom.value = nil then; /* disabled */ else do; i = 19; uuint: stack_ptr = addr(stack -> temp(6)); bits = bits | sptrapf; stack -> temp(4) = user_intr_array(i); stack -> temp(5) = nil; /* call service fcn with no args */ go to uint0; end; else do; /* caught be errset, take user intr 4 */ if addr(user_intr_array(4)) -> based_ptr -> atom.value = nil then; /* disabled */ else do; i = 4; go to uuint; end; end; unwind1: stack_ptr = addr(stack -> temp(2)); call lisp_prog_fns_$lisp_err(err_fcn_f); /* never returns */ /* Routine to do user interrupts */ user_interrupter: stack_ptr = addr(stack -> temp(6)); stack -> temp(5) = stack -> temp(2); /* make copy of losing form */ if spint & bits then go to spinttv(code); /* if special action needed */ spintxx: if bits & nilconsf then do; stack_ptr = addr(stack -> temp(7)); stack -> temp(6) = nil; call lisp_special_fns_$cons; end; stack -> temp(4) = stack -> temp(3); /* pick up interrupt handler */ go to uint0; fs_err_com: call lisp_special_fns_$cons; go to spbegxx; /* for nihil_ex_nihile fail-act, make the list (setq (nil)) as arg to the interrupt service function */ spinttv(128): stack_ptr = addr(stack -> temp(8)); stack -> temp(6), stack -> temp(7) = nil; /* make (nil) */ call lisp_special_fns_$cons; stack_ptr = addr(stack -> temp(8)); stack -> temp(7) = nil; /* and listify it with setq */ stack -> temp(5) = setq_atom; call lisp_special_fns_$cons; call lisp_special_fns_$cons; go to spintxx; spinttv(121): /* bad_prog_op, construct list (go return) */ stack_ptr = addr(stack -> temp(8)); stack -> temp(7) = nil; stack -> temp(6) = lisp_static_vars_$return_atom; stack -> temp(5) = lisp_static_vars_$go_atom; call lisp_special_fns_$cons; call lisp_special_fns_$cons; go to spintxx; spinttv(124): /* bad ibase, construct list (ibase) */ stack -> temp(5) = lisp_static_vars_$ibase; go to spintxx; /* let nilconsf listify it */ spinttv(125): /* bad base, construct list (base) */ stack -> temp(5) = lisp_static_vars_$base; go to spintxx; /* and let nilcons listify it */ spinttv(145): /* eof_in_object : args -<- '(read-eof) */ stack -> temp(5) = lisp_static_vars_$readeof_atom; go to spintxx; /* and let nilconsf listify it */ spbegtv(124): /* bad ibase -- reset it to 8 */ addr(ibase)->based_ptr -> fixnum_fmt.type_info = fixnum_type; addr(ibase)->based_ptr -> fixedb = 8; go to spbegxx; spbegtv(125): /* bad base -- reset it to 8 */ addr(base)->based_ptr -> fixnum_fmt.type_info = fixnum_type; addr(base)->based_ptr -> fixedb = 8; go to spbegxx; uint0: unm = unmkd_ptr; /* make a fault_save frame for this error, unless one is already there */ if ^ bits & err_recf then do; unmkd_ptr = addrel(unm, size(fault_save)); fault_save.prev_frame = rel(err_recp); fault_save.stack_ptr = rel(stack); fault_save.sv_gc_inhibit = gc_inhibit; fault_save.sv_masked = masked; fault_save.code1 = code; unspec(fault_save.code2) = bits; unspec(fault_save.sv_array_info) = unspec(ptr(unm, ""b) -> stack_seg.array_info_for_store); fault_save.sv_array_offset = ptr(unm, ""b) -> stack_seg.array_offset_for_store; fault_save.sv_rdr_state = rdr_state; fault_save.sv_rdr_ptr = rdr_ptr; fault_save.sv_rdr_label = rdr_label; err_recp = unm; rdr_state = 0; /* reset rdr to normal */ /* leave gc_inhibit the same */ end; /* now call the user interrupt service function */ uint1: stack_ptr = addr(stack -> temp(6)); /* shouldn't be needed, but... */ call lisp_special_fns_$ncons; /* make arg list */ stack -> temp(4) = stack -> temp_ptr(4) -> atom.value; if stack -> temp(4) = nil then go to uintdis0; /* disabled...no intr */ call lisp_$apply; /* apply fcn to args */ /* special kludge for pdl-overflow - ignore returned value and go on. */ if user_intr_array(12) = stack -> temp(3) then go to popoff; /* error recovery code - if returned value is not a list, don't recover but error out */ if bits & sptrapf then go to unwind1; if stack -> temp_type(4) then do; /* if returned value is not a list. */ /* NB - nil is now an atomic symbol, not a list */ stack_ptr = addr(stack -> temp(2)); go to unwind; /* don't print dumb err msg twice. */ end; if bits & spfin then go to spfintv(code); stack -> temp(1) = stack -> temp_ptr(4) -> cons.car; /* service function returns list */ stack_ptr = addr(stack -> temp(2)); if bits & evalf then call lisp_$eval; /* ... if returned result is to be evaluated */ /* Since we have recovered from the error and are not going to unwind ... */ /* Now pop the err_record off of the unmarked pdl... */ if ^ bits & err_recf then /* ...but only if we made one */ do; unspec(ptr(unm, ""b) -> stack_seg.array_info_for_store) = unspec(fault_save.sv_array_info); ptr(unm, ""b) -> stack_seg.array_offset_for_store = fault_save.sv_array_offset; rdr_state = fault_save.sv_rdr_state; rdr_ptr = fault_save.sv_rdr_ptr; rdr_label = fault_save.sv_rdr_label; gc_inhibit = fault_save.sv_gc_inhibit; /* restore masked state */ stack_ptr = addr(stack -> temp(3)); if fault_save.sv_masked.against.alarm then stack -> temp(2) = t_atom; else if fault_save.sv_masked.against.tty then stack -> temp(2) = tty_atom; else stack -> temp(2) = nil; call lisp_fault_handler_$nointerrupt; err_recp = ptr(err_recp, fault_save.prev_frame); end; popoff: unmkd_ptr = addrel(unm, -2); /* popoff the frame and the error code */ stack_ptr = addr(stack -> temp(2)); return; /* return a value to our caller, who will correct the error */ /* special recovery from correctable error routines */ /* interrupts which cannot be corrected */ spfintv(121): /* bad prog op */ spfintv(122): /* bad lexpr tv */ spfintv(128): call lisp_print_$type_string("lisp: this fail-act is uncorrectable "); go to uintdis; /* interrupts which need to clear the stack before returning */ spfintv(124): /* bad ibase */ spfintv(125): /* bad base */ spfinclrpdl: if ^ bits & err_recf then err_recp = ptr(unm, unm -> frame.prev_frame); unmkd_ptr = addrel(unm, -2); /* pop code too */ stack_ptr = stack; return; /* err function, causes an error. Takes errset traps and *rset-traps where appropriate */ err: entry; stack = addrel(stack_ptr, -2); /* fsubr */ if stack -> temp_type(1) then stack -> temp(1) = nil; /* no args given, use nil */ else do; /* an arg was given, so eval it and return it to errset. but first check for a second arg, which if it is present and non-nil means don't eval the first arg until after unwinding back to the errset */ if stack -> temp_ptr(1) -> cons_types.cdr then; else if stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car = nil then; else do; /* yes, 2nd arg is non - nil */ if rel(err_frame) then err_frame -> frame.dat2 = "1"b; /* flag indicates that first arg has not yet been evaled. */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* get 1st arg */ go to err_aa; end; stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* eval 1st arg */ call lisp_$eval; end; /* at this point, stack->temp(1) contains the value to be returned to errset */ err_aa: err_fcn_f = "1"b; go to unwind; err_op: entry; /* from err operator in lisp_oprs_, for compiled version of err fcn */ stack = addrel(stack_ptr, -2); go to err_aa; errprint: entry; /* the lisp errprint function */ errsw = "0"b; myname = fn_errprint; errprint_retry: stack = addrel(stack_ptr, -2); /* take one arg which is a pdl ptr */ posf = "0"b; /* assume will not be a positive number */ if stack -> temp(1) = nil then do; /* use most recent */ loc = rel(err_recp); if loc then locfb = locfb+1; /* if -> real frame, skip past it */ end; else if stack -> temp_type36(1) & Fixed36 then if stack -> fixedb < 0 then /* get negative pdl ptr & simulate downward search */ loc = substr(unspec(stack->fixedb), 19, 18); else do; /* get positive pdl ptr & simulate upward search */ i = - stack->fixedb; /* mumble, mumble, can't take unspec of an expression any more */ loc = substr(unspec(i), 19, 18); /* change sign of pdl ptr */ posf = "1"b; /* but remember + */ end; else do; /* not a fixed number, correctable error */ errprint_bad_pdl_ptr: call badpdlptr; go to errprint_retry; end; /* check validity of pdl ptr - must lie in the stack */ if loc >= rel(unmkd_ptr) then go to errprint_bad_pdl_ptr; if loc = ""b then if posf then go to errprint0; else go to errmes_not_there; if loc < rel( ptr(unmkd_ptr, ""b) -> stack_seg.unmkd_stack_bottom ) then go to errprint_bad_pdl_ptr; /* search for the err_record that we want */ errprint0: unm2 = null; do unm = err_recp repeat (ptr(unm, unm -> fault_save.prev_frame)) while (rel(unm)); /* chase the threaded list of err_records */ if rel(unm) < loc then go to errprint1; if posf then if rel(unm) = loc then go to errprint1; unm2 = unm; end; if posf then go to errprint1a; /* in case of starting from 0 */ /* No error message was there, just return nil */ errmes_not_there: stack -> temp(1) = nil; return; errprint1: /* found a stacked up error, print message and return t */ if posf then do; /* special hac to make it look like an upward search */ errprint1a: if unm2 = null then go to errmes_not_there; unm = unm2; end; code = fault_save.code1; if code = 0 then /* not an errprintable error, skip it */ if posf then do; if unm = err_recp then go to errmes_not_there; loc = rel(unm); do unm = err_recp repeat(ptr(unm, unm -> fault_save.prev_frame)) while (unm -> fault_save.prev_frame ^= loc); /* find fault_save frame just above current one */ end; go to errprint1; end; else do; unm = ptr(unm, unm -> fault_save.prev_frame); if rel(unm) = ""b then go to errmes_not_there; go to errprint1; end; bits = unspec(fault_save.code2); if errsw then go to errframe_fin; /* if entered from errframe, don't prmes */ call prmes0; stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = t_atom; return; prmes: proc; /* Does the actual printing of an error msg */ /* bind ^w so that the message will be sure to go to the terminal */ /* also bind ^r so that the message does n_o_t_ go to the output file, since the s ser might want to read it back in */ dcl (mkp, unmkp, spmsgp) ptr; dcl esw fixed bin; esw = 1; go to bindings; prmes_immediate: entry; /* prmes with no err frame pushed */ esw = -1; bindings: mkp = stack_ptr; stack_ptr = addr(mkp -> temp(5)); unmkp = unmkd_ptr; unmkd_ptr = addrel(unmkp, 2); mkp -> temp(2) = ctrlW; mkp -> temp(1) = addr(ctrlW) -> based_ptr -> atom.value; mkp -> temp(4) = ctrlR; mkp -> temp(3) = addr(ctrlR) -> based_ptr -> atom.value; unmkp -> binding_block.bot_block = rel(mkp); unmkp -> binding_block.top_block = rel(stack_ptr); unmkp -> binding_block.back_ptr = rel(binding_top); binding_top = unmkp; addr(ctrlW)->based_ptr -> atom.value = nil; addr(ctrlR) -> based_ptr -> atom.value = nil; if esw < 0 then do; error_data = stack; go to JOIN2; end; JOIN: error_data = ptr(stack, unm -> fault_save.stack_ptr); JOIN2: spmsgp = stack_ptr; stack_ptr = addr(spmsgp -> temp(3)); spmsgp -> temp(2) = error_data -> temp(1); /* pick up message */ spmsgp -> temp(1) = lisp_static_vars_$princ_atom; /* and apply print to it */ call lisp_special_fns_$ncons; call lisp_print_$type_nl; call lisp_$apply; /* If there is a losing form to be printed, do so. */ if error_data -> temp(2) ^= NotThere then do; stack_ptr = addr(spmsgp -> temp(3)); spmsgp -> temp(2) = error_data -> temp(2); spmsgp -> temp(1) = lisp_static_vars_$prin1_atom; call lisp_special_fns_$ncons; call lisp_$apply; end; /* put out a newline to end the message */ call lisp_print_$type_nl; if esw = 0 then go to rtn_3; /* unbind ^w and ^r */ addr(ctrlW)->based_ptr -> atom.value = mkp -> temp(1); addr(ctrlR) -> based_ptr -> atom.value = mkp -> temp(3); binding_top = ptr(unmkp, unmkp -> binding_block.back_ptr); unmkd_ptr = unmkp; stack_ptr = mkp; return; /* entry to print message without binding ^w or ^r */ prmes0: entry; esw = 0; go to JOIN; rtn_3: return; end prmes; /* the errframe function takes the same input argument as errprint, but it returns the list: (pdlptr (message datum intr-chan) alist) */ errframe: entry; myname = fn_errframe; errsw = "1"b; go to errprint_retry; /* join with errprint to analyze the input pdl ptr */ /* comes back here with code, code2, bits, stack->temp(1), and unm set up */ errframe_fin: error_data = ptr(stack, unm -> fault_save.stack_ptr); stack_ptr = addr(stack -> temp(6)); stack -> temp(1) = lisp_static_vars_$err_atom; /* type of frame */ stack -> temp(2) = error_data -> temp(1); stack -> temp(3) = error_data -> temp(2); if stack -> temp(3) = NotThere then stack_ptr = addr(stack -> temp(4)); else do; stack -> temp(4) = error_data -> temp(3); if stack -> temp(4) = NotThere then stack_ptr = addr(stack -> temp(5)); end; addrel(stack_ptr, -2) -> temp(1) = nil; do while(stack_ptr ^= addr(stack -> temp(3))); call lisp_special_fns_$cons; end; go to return_a_frame; /* use pdlframe code to make the return list */ /* badpdlptr is an internal error recovery proc */ badpdlptr: proc; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = not_pdl_ptr; unm -> errcode(2) = myname; call lisp_error_; return; end; /* the lisp pdlframe function */ /* (has been renamed evalframe) */ pdlframe: entry; /* declare the two names by which this function can be referenced */ dcl lisp_static_vars_$evalframe_atom fixed bin(71) aligned external, evalframe_atom fixed bin(71) aligned defined (lisp_static_vars_$evalframe_atom); dcl lisp_static_vars_$pdlframe_atom fixed bin(71) aligned external, pdlframe_atom fixed bin(71) aligned defined (lisp_static_vars_$pdlframe_atom); stack = addrel(stack_ptr, -2); /* subr of one arg */ myname = fn_evalframe; pdl_frame_retry: posf = "0"b; /* assume will not be a positive number */ if stack -> temp(1) = nil then do; /* most recent */ loc = rel(eval_frame); if loc then locfb = locfb+1; /* if frame real, skip past it */ end; /* so that the code below will return it and not its sucessor */ else if stack -> temp_type36(1) & Fixed36 then if stack -> fixedb < 0 then do; /* get negative pdl ptr & simulate downward search */ loc = substr(unspec(stack -> fixedb), 19, 18); if myname = fn_freturn then locfb = locfb + 1; /* want the frame itself , not the next one down */ end; else do; /* get positive pdl ptr & simulate upward search */ i = - stack->fixedb; /* mumble, mumble, can't take unspec of an expression any more */ loc = substr(unspec(i), 19, 18); posf = "1"b; end; else do; pdlframe_bad_pdl_ptr: call badpdlptr; go to pdl_frame_retry; end; /* check validity - pdl ptr must lie in the unmarked stack */ if loc >= rel(unmkd_ptr) then go to pdlframe_bad_pdl_ptr; if loc = ""b then if posf then go to pdlframe0; else go to no_pdl_frame; if loc < rel( ptr(unmkd_ptr,""b) -> stack_seg.unmkd_stack_bottom ) then go to pdlframe_bad_pdl_ptr; /* search for the eval_frame that we want */ pdlframe0: unm2 = null; do unm = eval_frame repeat (ptr(unm, unm -> frame.prev_frame)) while (rel(unm)); if rel(unm) < loc then go to pdl_fr_0; if posf then if rel(unm) = loc then go to pdl_fr_0; /* (pdlframe -n) should not return (-n () -n), but the next lower frame */ unm2 = unm; end; if posf then go to pdlframe1a; /* in case searching from 0 */ /* no pdl frame found, return nil */ no_pdl_frame: if myname = fn_freturn then go to pdlframe_bad_pdl_ptr; /* freturn barfs if no frame found */ stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = nil; return; pdl_fr_0: if posf then do; /* special hac to make +# simulate upward scan */ pdlframe1a: if unm2 = null then go to no_pdl_frame; unm = unm2; end; pdl_fr_1: if myname = fn_freturn then go to freturn0; /* if freturn, unjoin back to it */ stack_ptr = addr(stack -> temp(5)); loc = unm -> frame.stack_ptr; stack -> temp(2) = ptr(stack, loc) -> temp(1); /* the form being evaled */ stack -> temp(1) = lisp_static_vars_$eval_atom; if unm -> frame.dat1 & apply_frame_bit /* special frame - do neat things */ then do; marked_stack_frame = ptr(stack, unm -> frame.stack_ptr); if marked_stack_frame -> call1_cruft.uncollectable_bits = uncollectable_tag then do; /* if looks like a call1 type eval frame */ /* call1 or funcall frame - cons up arg list */ stack_ptr = addr(stack -> temp(3)); call lisp_special_fns_$ncons; /* start list of pseudo-form being evaled */ stack -> temp(1) = stack -> temp(2); /* save start of list */ stack_ptr = addr(stack -> temp(4)); argument_pointer = ptr(marked_stack_frame, marked_stack_frame -> call1_cruft.arg_rel_ptr); do i = marked_stack_frame -> call1_cruft.number_of_args by -1 while(i > 0); stack -> temp(3) = argument_pointer -> temp(1); argument_pointer = addrel(argument_pointer, 2); call lisp_special_fns_$ncons; stack -> temp_ptr(2) -> cons.cdr = stack -> temp(3); stack -> temp(2) = stack -> temp(3); end; stack_ptr = addr(stack -> temp(5)); stack -> temp(2) = stack -> temp(1); /* recover start of list */ end; else do; /* apply or map, cons up pseudo-form */ stack -> temp(3) = marked_stack_frame -> temp(3); /* argl */ stack_ptr = addr(stack -> temp(4)); call lisp_special_fns_$cons; stack_ptr = addr(stack -> temp(5)); end; stack -> temp(1) = lisp_static_vars_$apply_atom; end; else if stack -> temp_ptr(2) -> cons.car = evalframe_atom then go to skip_this_pdlframe; else if stack -> temp_ptr(2) -> cons.car = pdlframe_atom then do; /* Woops, its ourself - skip it */ skip_this_pdlframe: if posf then do; /* positive pdl ptr was given -- have to get kludgy and up-scan */ if unm = eval_frame then go to no_pdl_frame; /* none above to get */ loc = rel(unm); do unm = eval_frame repeat ( ptr(unm, unm -> frame.prev_frame)) while ( unm -> frame.prev_frame ^= loc); /* this do-repeat scans down for the eval_frame just above the one we're currently at */ end; end; else do; unm = ptr(unm, unm -> frame.prev_frame); if rel(unm) = ""b then go to no_pdl_frame; end; go to pdl_fr_1; end; /* return a frame. stack -> temp(1) = frame type, stack -> temp(2) = middle part of frame, unm -> the stack loc */ return_a_frame: stack_ptr = addr(stack -> temp(6)); stack -> temp(5) = nil; stack -> temp(3) = stack -> temp(2); addr(stack -> temp(4)) -> fixnum_fmt.type_info, addr(stack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type; unspec( addr(stack->temp(4)) -> fixedb) = (17)"1"b || "0"b || rel(unm); unspec(addr(stack -> temp(2)) -> fixedb) = (18)"1"b || rel(unm); /* pdl ptr -> unmarked pdl */ do while(stack_ptr ^= addr(stack -> temp(2))); call lisp_special_fns_$cons; end; return; /* The freturn subr, which allows returning from an arbitrary evaluation Subr of 2 args: 1) pdl ptr, 2) return value */ freturn: entry; stack = addrel(stack_ptr, -4); /* 2 args */ myname = fn_freturn; dbl_word = stack -> temp(1); /* interchange arguments to be like pdlframe, */ stack -> temp(1) = stack -> temp(2); /* having the pdl ptr arg at top of stack */ stack -> temp(2) = dbl_word; stack = addr(stack -> temp(2)); go to pdl_frame_retry; /* go find frame corresponding to first arg */ freturn0: /* unm -> the frame, stack -> temp(1) = the value we want to make that frame return with */ /* make sure that this frame lies within the Multics stack properly - could be problem if unseen-go-tag on very non local go happens after the stack is unwound, then user tries to freturn into stack between the prog and the non local go - can't be done because stack frames (sp stack) for functions in that part of lisp stack no longer exist - since freturn is usually done from command level we want to say bad_pdl_ptr rather than wait and get unwinder_error */ label0 = freturn0; /* just a KLUDGE to do a sprisp instruction */ if rel(label.sp) <= eval_frame_part.dat1 then go to pdlframe_bad_pdl_ptr; /* check for a frame with screwed up registers in it, which indicates an undf fcntn or something occurred */ /* such frames may not be returned to because they lose!! */ if substr(unspec(saved_index_registers), 31, 6) = "100011"b /* its modifier, can never occur in a saved x2 from evaluator since would indicate applying a macro */ then go to pdlframe_bad_pdl_ptr; /* Go barf at user */ stack = addrel(stack, -2); /* declare the format of the evaluators unmarked pdl (lisp_.alm) */ dcl 1 the_eval_frame aligned based(unm), 2 eval_frame_part , 3 prev_frame bit(18) unal, 3 stack_ptr fixed bin (17) unal, 3 dat1 bit(18) unal, 3 dat2 bit(18) unal, 2 saved_index_registers fixed bin(71), 2 binding_frame_part fixed bin(71); /* unwind down to but not including the evalframe - unwind its binding block */ unm2 = unmkd_ptr; unmkd_ptr = addrel(unm2, 2); unm2 -> based_ptr = addr(binding_frame_part); /* unwinder takes arg on unmkd pdl */ evals_stack = ptr(stack, eval_frame_part.stack_ptr); /* -> eval's garbage on the marked pdl */ evals_stack -> temp(4) = stack -> temp(1); /* drop return value into ap|plist */ call lisp_prog_fns_$lisp_unwinder; /* unwind back to the point of evaluation */ /* Now go call the evaluator, and let it clean things up, since it alone knows how */ unmkd_ptr = addrel(unm, size(the_eval_frame)); /* make unmkd_ptr where eval expects it */ stack_ptr = addr(evals_stack -> temp(5)); /* in case was cruft on marked pdl below b.b. */ label.adr = addr(lisp_$freturn_real); /* make label variable to get to the evaluator */ label.sp = ptr(label.sp, eval_frame_part.dat1 & "111111111111111110"b); /* save return ptr in stack frame going to go to since goddamn unwinder_ wrecks it. */ unspec(binding_frame_part) /* use this double word since not in use right now */ = unspec(label.sp -> stack_frame.return_ptr); go to label0; end lisp_error_;  lisp_fault_handler_.pl1 11/05/86 1612.2r w 11/04/86 1042.5 358776 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_fault_handler_: procedure (a_fault_code, pbr, action); /* modified 14 Nov 73 by DAM to change ^h to ^b and get rid of echofiles cruft */ /* modified 74.06.03 by DAM for new arrays */ /* Modified 78.01.05 by BSG for mulquit/mulpi */ dcl a_fault_code fixed bin, fault_code fixed bin, pbr ptr, action fixed bin, /* what to do when we return */ chr char(1), lisp_static_vars_$ignore_faults bit(1) static external, lisp_static_vars_$space_names_atom external pointer, lisp_static_vars_$zunderflow fixed bin(71) external, lisp_static_vars_$quotient fixed bin(71) external, lisp_static_vars_$transparent bit(1) static external, transparent bit(1) def (lisp_static_vars_$transparent), /* "1"b makes lisp transparent to quits, for (ioc z) */ lisp_static_vars_$quit_handler_flag bit(1) external, qitf bit(1) def (lisp_static_vars_$quit_handler_flag), /* detects re-entrance of quit handler */ ctrls(100) char(4) aligned static, /* buffer for deferred ctrl chars */ (firstctrl, lastctrl) fixed bin static init(1), /* ptrs into the circular buffer ctrls */ deferred_alrm_timer bit(1) static init("0"b), /* buffer for deferred timer */ deferred_cput_timer bit(1) static init("0"b), /* .. */ inbuf char(132) aligned, nelemt fixed bin, ctlchars char(50) static varying init( /* defined ctrl chars */ "acdghqrstvwxz$.@\]^b?"), /* - z quits, $ calls db, others are standard */ /* 0,1,2 cause user interrupt on channel 0,1,2 respectively */ /* . is a no-op for quit-start-ing */ unm ptr, iog_unm ptr, errcode(2) fixed bin(35) aligned based(unm), unmtop ptr, ercode fixed bin aligned based, stack ptr, tstack ptr, 1 array_head based aligned, 2 ndims fixed bin(17) unaligned, 2 infop fixed bin(17) unaligned, 2 first_instr bit(36) aligned, ndims fixed bin, i fixed bin, argsp ptr, iocidx fixed bin, esw fixed bin, /* entry switch, 0 = quit, 1 = ioc/iog, 2 = from gc, -1 = ctrl_from_reader */ iogsw bit(1), /* 1 = iog, 0 = ioc */ intrp ptr, /* -> interrupt fcn for ctrl_b_break */ /* entry points called */ (ioa_$ioa_switch, ioa_$ioa_switch_nnl) ext entry options(variable), lisp_get_atom_ entry(char(*) aligned, fixed bin(71)), rdr_save_f bit(1), lisp_$eval entry, debug ext entry, lisp_prog_fns_$lisp_err entry(bit(1)aligned), /* direct interface to the unwinder */ iox_$control entry(ptr, char(*), ptr, fixed bin(35)), iox_$get_line entry(ptr, ptr, fixed bin, fixed bin, fixed bin(35)), iox_$put_chars entry(ptr, ptr, fixed bin, fixed bin(35)), iox_$user_io ptr external, iox_$error_output ptr external, io_status fixed bin(35), lisp_error_ entry, lisp_alloc_ entry(fixed bin, fixed bin(71)), lisp_$apply entry, lisp_segment_manager_$shrink_stacks entry, lisp_io_control_$opena entry, lisp_io_control_$close entry, lisp_special_fns_$xcons entry, lisp_special_fns_$ncons entry, lisp_special_fns_$cons entry, /* variables in lisp_static_vars_ */ lisp_static_vars_$question_mark fixed bin(71) aligned external, lisp_static_vars_$array fixed bin(71) aligned external, array fixed bin(71) aligned defined (lisp_static_vars_$array), lisp_static_vars_$arrayindex fixed bin(71) aligned external, arrayindex fixed bin(71) aligned defined(lisp_static_vars_$arrayindex), (lisp_static_vars_$mulquit_state, lisp_static_vars_$mulpi_state) fixed bin (17) external, /* obarray format */ htptr ptr, htpos fixed bin, 1 obarray_struct based(htptr)aligned, 2 array_accessing_code(14)bit(36)aligned, 2 ht (0:510) fixed bin(71), 2 char_objects (0:127) fixed bin(71); /* dcl for the CTRL/? feature */ dcl 1 v based aligned, 2 lngth fixed bin(21), 2 string char(36), lisp_static_vars_$i_am_gcing bit(1) external aligned, (ms_tti init(";waiting for input from terminal. "), ms_run init(";running. "), ms_gc init(";garbage collection. "), ms_masked init(";in (nointerrupt t) mode. ") ) static char(36) varying options (constant), NL char (1) static options (constant) init (" "); dcl (null, addr, addrel, ptr, index, substr, hbound, lbound, length, rel, size, binary, fixed, unspec, string) builtin; dcl conversion condition; /* Error Codes */ dcl (lisp_error_table_$bad_arg_correctable, lisp_error_table_$car_cdr_error, lisp_error_table_$stack_loss_error, lisp_error_table_$store_function_misused, lisp_error_table_$underflow_fault, lisp_error_table_$zerodivide_fault) fixed bin external, bad_arg_correctable fixed bin defined lisp_error_table_$bad_arg_correctable, car_cdr_error fixed bin defined lisp_error_table_$car_cdr_error, stack_loss_error fixed bin defined lisp_error_table_$stack_loss_error, store_function_misused fixed bin defined lisp_error_table_$store_function_misused, underflow_fault fixed bin defined lisp_error_table_$underflow_fault, zerodivide_fault fixed bin defined lisp_error_table_$zerodivide_fault; /* Declarations for cleanup feature */ dcl lisp_static_vars_$cleanup_list_exists bit(1) aligned external, lisp_static_vars_$gc_unwinder_kludge external label, lisp_static_vars_$activate_gc_unwinder_kludge bit(1) aligned external, 1 argument_list based aligned, 2 argument_count fixed bin(17) unaligned, 2 argument_list_format fixed bin(17) unaligned, 2 descriptor_count fixed bin(17) unaligned, 2 padding fixed bin(17) unaligned, 2 argument_pointer (1) pointer, cleanup condition, based_label_var based label variable, cu_$stack_frame_ptr entry () returns(pointer); %include stack_frame; %include lisp_faults; %include lisp_stack_seg; %include lisp_array_fmt; %include lisp_io; %include lisp_nums; %include lisp_name_codes; %include lisp_stack_fmt; %include lisp_common_vars; %include lisp_ptr_fmt; %include lisp_atom_fmt; %include lisp_string_fmt; %include lisp_cons_fmt; fault_code = a_fault_code; call save_state; save_state: proc; /* save status of key variables, rdr, ... */ stack = stack_ptr; call save_state_only; /* reset these statuses */ gc_inhibit = "1"b; /* shut off gc since the routine we interrupted might have a lisp object in the aq or bp or even a lisp object on the pdl without type bits */ lisp_static_vars_$rdr_state = 0; /* reset reader to normal state */ end save_state; save_state_only: procedure; unm = unmkd_ptr; unmkd_ptr = addrel(unm, size(fault_save)); fault_save.prev_frame = rel(err_recp); fault_save.stack_ptr = rel(stack); fault_save.sv_gc_inhibit = gc_inhibit; fault_save.sv_masked = masked; fault_save.code1 = 0; /* no err msg yet */ unspec(fault_save.sv_array_info) = unspec(ptr(unm, ""b) -> stack_seg.array_info_for_store); fault_save.sv_array_offset = ptr(unm, ""b) -> stack_seg.array_offset_for_store; fault_save.sv_rdr_label = rdr_label; fault_save.sv_rdr_ptr = rdr_ptr; fault_save.sv_rdr_state = rdr_state; err_recp = unm; end save_state_only; /* determine what kind of fault we took, and go handle it */ unmtop = unmkd_ptr; /* for pushing error codes */ if fault_code = Alarmclock_fault then go to alarm; else if fault_code = Cput_fault then go to alarm; else if fault_code = Car_cdr_fault then go to car_cdr_of_num; else if fault_code = Quit_fault then go to Quit; else if fault_code = Array_fault then go to array_lossage; else if fault_code = Old_store_fault then go to emulate_old_style_store; else if fault_code = Zerodivide_fault then go to handle_zerodivide; else if fault_code = Underflow_fault then go to handle_underflow; else if fault_code = Pi_fault then go to handle_pi; /* undefined fault code, barf and take as quit */ call ioa_$ioa_switch(iox_$user_io, "^/lisp_fault_handler_: undefined fault code ^d.", fault_code); /* quit handler, accepts 1 "control" character */ Quit: /* if this is 2nd quit, previous invocation of quit handler must have lost, so pass this quit on to standard system quit handler */ if transparent then do; /* transparent quit - pass it along & clear flag */ transparent = "0"b; action = 2; go to exit_nzq; end; if qitf then do; action = 2; go to exit_nzq; end; qitf = "1"b; /* remember that we are in lisp quit routine */ esw = 0; if masked.against.tty then go to masked_quit; /* check for user quit-control */ lisp_static_vars_$read_print_nl_sync = "1"b; /* Get newlines flushed */ if fault_code = Pi_fault then; /* program_interrupt falls through */ else if lisp_static_vars_$mulquit_state = -1 then; /* Fall through to ITS-like handling */ else if lisp_static_vars_$mulquit_state = -2 then go to ctrl_z_handler; /* Let it go through */ else do; /* Signal user interrupt */ i = lisp_static_vars_$mulquit_state; go to ioc_num_not_2; end; /* ask for a control character */ ask_for_ctrl: lisp_static_vars_$read_print_nl_sync = "1"b; /* user hit newline after typing the ctrl char */ call ioa_$ioa_switch_nnl(iox_$user_io, "CTRL/"); call iox_$get_line(iox_$user_io, addr(inbuf), length(inbuf), nelemt, io_status); ctrl_aa: chr = substr(inbuf, 1, 1); if nelemt < 2 then go to ask_for_ctrl; else if chr >= "0" & chr <= "9" then go to ctrl_num; else if nelemt > 2 then do; not_ctrl: call ioa_$ioa_switch(iox_$user_io, "lisp: ""^a"" is not a control character.", substr(inbuf, 1, nelemt-1)); go to ask_for_ctrl_0; /* reject it and try again */ /* this keeps the user from screwing himself by typing start */ end; dispatch: /* Make the character lower case if it as a letter */ if chr < "A" then go to dispatch_1; if chr > "Z" then go to dispatch_1; unspec(chr) = unspec(chr) | "000100000"b; /* or in 40 */ dispatch_1: go to proc(index(ctlchars, chr)); /* number entered -- is number of user interrupt to signal */ ctrl_num: on conversion go to not_ctrl; i = binary(substr(inbuf, 1, nelemt-1), 17); revert conversion; ioc_num: if i = 2 then go to proc(1); /* CTRL/2 handle specially as CTRL/a */ ioc_num_not_2: /* signal user interrupt on channel i with argument 'ioc */ stack_ptr = addr(stack -> temp(4)); if i < 0 then go to bad_int_num; else if i >= 21 then go to bad_int_num; stack -> temp(1) = user_intr_array(i); if stack -> temp(1) = nil then go to bad_int_num; stack -> temp(1) = stack -> temp_ptr(1) -> atom.value; qitf = "0"b; if stack -> temp(1) = nil then go to exit1; /* not anabled */ call lisp_get_atom_("ioc", stack -> temp(2)); stack -> temp(3) = nil; call lisp_special_fns_$cons; call lisp_$apply; bad_int_num: /* just ignore */ go to exit1; proc(0): if esw = 1 then go to ioc_retn; /* ignore unknown chars from ioc, since other sys might have */ call ioa_$ioa_switch(iox_$user_io, "lisp: undefined control character ""^1a""", chr); if esw < 0 then go to exitv(-1); /* ctrl_from_reader - that's all */ ask_for_ctrl_0: if esw = 2 then if firstctrl ^= lastctrl then go to exitv(2); /* for deferred chars from gc, allow retry only for last */ go to ask_for_ctrl; proc(2): /* CTRL/c gags the gc messages */ addr(ctrlD) -> based_ptr -> atom.value = nil; go to exit1; proc(3): /* CTRL/d turns on the gc messages */ addr(ctrlD) -> based_ptr -> atom.value = t_atom; go to exit1; proc(15): /* CTRL/. is a no-op which allows you to speed up a slow multics by causing fake interactions */ exit1: go to exitv(esw); exitv(0): action = 0; go to exit; proc(4): /* CTRL/g causes quit all the way up to top level */ ctrl_g_handler: call ioa_$ioa_switch(iox_$user_io, "Quit"); unwind_to_top_level: err_frame = ptr(unmkd_ptr, ""b); /* get rid of errsets so we can can unwind all the way up to top level */ quitter: tty_input_chan -> iochan.ioindex = 0; tty_input_chan -> iochan.iolength = 0; /* clear input buffer */ tty_output_chan -> iochan.ioindex = 0; /* clear the printer's output buffer */ qitf = "0"b; call lisp_prog_fns_$lisp_err("0"b); /* unwind */ proc(12): /* CTRL/x causes quit to first errset */ call ioa_$ioa_switch(iox_$user_io, "quit"); /* note difference between this and the ^g msg */ go to quitter; proc(13): /* CTRL/z causes standard Multics QUIT */ ctrl_z_handler: qitf = "0"b; /* allow pi'ing back in */ if esw ^= 0 then do; /* not already in a quit, must make one */ dcl quit condition; do_ctrl_z: transparent = "1"b; /* make the quit fall through lisp */ lisp_static_vars_$ignore_faults = "1"b; on cleanup transparent, lisp_static_vars_$ignore_faults = "0"b; signal quit; lisp_static_vars_$ignore_faults = "0"b; transparent = "0"b; go to exit1; end; action = 2; go to exit; /* action 2 is pass quit to next on-unit */ proc(14): /* CTRL/$ causes debug to be called */ lisp_static_vars_$ignore_faults = "1"b; call ioa_$ioa_switch(iox_$user_io, "db"); call debug; lisp_static_vars_$ignore_faults = "0"b; go to exit1; proc(5): /* CTRL/h causes user interrupt number 1 -- obsolete but keep around for a while */ proc(20): /* CTRL/b causes a break on user interrupt 1 */ intrp = addr(user_intr_array(1)) -> based_ptr; ctrl_b_break: tty_input_chan -> iochan.ioindex = 0; /* clear input buffer */ tty_input_chan -> iochan.iolength = 0; tty_output_chan -> iochan.ioindex = 0; /* clear printer buffer */ stack_ptr = addr(stack -> temp(4)); stack -> temp(1) = intrp -> atom.value; if stack -> temp(1) ^= nil then do; stack -> temp(2) = nil; stack -> temp(3) = nil; /* make the arg list */ call lisp_special_fns_$cons; qitf = "0"b; call lisp_$apply; end; go to exit1; /* control characters that change i/o switches -- q, r, s, t, w, v */ proc(6): /* CTRL/q switches the rdr to input from uread channel */ addr(ctrlQ) -> based_ptr -> atom.value = t_atom; go to exit1; /* make sure the rdr doesn't get stuck in tty input wait after ^q is issued */ /* this assurance is now done by people who unwind err asynchronously created fault_save's (i.e. our 'exit' routine) */ proc(8): /* CTRL/s switches the reader back to input from the tty */ addr(ctrlQ) -> based_ptr -> atom.value = nil; go to exit1; /* let the reader finish what it is doing before stopping since user won't notice delay anyway.... */ proc(7): /* CTRL/r activates output to uwrite channel from printer */ addr(ctrlR) -> based_ptr -> atom.value = t_atom; go to exit1; /* on next character output, printer will notice the switch */ proc(9): /* CTRL/t shuts off the uwrite channel */ addr(ctrlR) -> based_ptr -> atom.value = nil; go to exit1; /* the printer will soon gag itself */ proc(10): /* CTRL/v turns on output to the tty */ addr(ctrlW) -> based_ptr -> atom.value = nil; go to exit1; /* printer will start typing out on next char */ proc(11): /* CTRL/w turns off output to the tty */ addr(ctrlW) -> based_ptr -> atom.value = t_atom; if esw ^= 0 then go to exit1; /* suppress resetwrite unless entered by quit */ call iox_$control(iox_$user_io, "start", null(), io_status); call iox_$control(iox_$user_io, "resetwrite", null(), io_status); tty_output_chan -> iochan.ioindex = 0; /* if he quit in the middle of printing a long list, make sure it stops right away */ go to exit1; proc(1): /* CTRL/a updates the value of the atomic symbol ^a */ /* and causes an interrupt to channel 2 */ dcl lisp_static_vars_$ctrlA fixed bin(71) aligned external, ctrlA fixed bin(71) aligned defined (lisp_static_vars_$ctrlA); if addr( addr(ctrlA)->based_ptr->atom.value) -> lisp_ptr_type & Fixed36 then addr(ctrlA)->based_ptr->fixedb = addr(ctrlA) -> based_ptr->fixedb + 1; /* if its a number, add 1 to it */ else do; addr(ctrlA) -> based_ptr -> fixnum_fmt.type_info = fixnum_type; addr(ctrlA) -> based_ptr -> fixedb = 0; /* otherwise, set it to 0 */ end; intrp = addr(user_intr_array(2)) -> based_ptr; go to ctrl_b_break; proc(16): /* CTRL/@ causes user interrupt 0 */ intrp = addrel(addr(user_intr_array(1)),-2) -> based_ptr; /* user_intr_array(0) */ go to ctrl_b_break; proc(17): /* CTRL/\\ causes user interrupt 14. */ intrp = addr(user_intr_array(14)) -> based_ptr; go to ctrl_b_break; proc(18): /* CTRL/] causes user interrupt 15. */ intrp = addr(user_intr_array(15)) -> based_ptr; go to ctrl_b_break; proc(19): /* CTRL/^ causes user interrupt 16. */ intrp = addr(user_intr_array(16)) -> based_ptr; go to ctrl_b_break; proc(21): /* CTRL/? finds out what the hell is going on. */ /* If we get here, at least it wasn't garbage collection */ if esw = 0 then if fault_save.sv_rdr_state = 1 then go to proc_21_aa; else go to proc_21_bb; else if rdr_state = 1 then do; proc_21_aa: intrp = addr(ms_tti); nelemt = length(ms_tti); end; else do; proc_21_bb: intrp = addr(ms_run); nelemt = length(ms_run); end; whats_going_on: call iox_$put_chars(iox_$error_output, addr(intrp->v.string), nelemt, io_status); go to exit1; /* the lisp ioc fsubr */ ioc: entry; iogsw = "0"b; stack = addrel(stack_ptr, -2); stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* get argument */ iogjoin: esw = 1; if stack -> temp(1) = nil then /* special case nil */ go to ioc_exit; else if stack -> temp_type36(1) & Fixed36 then do; /* numeric arg, signal user interrupt */ iocidx = -1; i = stack -> fixedb; go to ioc_num; end; else if stack -> temp_type36(1) & Atsym36 then; else go to ioc_exit; /* invalid arg, just ignore since is fsubr */ /* split up pname of atom into characters, apply them as if typed in as ctrl characters */ iocidx = 1; exitv(1): ioc_retn: if iocidx < 0 then go to ioc_exit; /* return from ioc_num */ if iocidx > stack -> temp_ptr(1) -> atom.pnamel then go to ioc_exit; /* done the whole pname */ chr = substr(stack -> temp_ptr(1) -> atom.pname, iocidx, 1); iocidx = iocidx + 1; go to dispatch; ioc_exit: if iogsw then go to iog_aa; stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = t_atom; return; /* we just went into (nointerrupt nil) mode and there were deferred ctrl characters. We can now process them */ do_ctrl: esw = 2; exitv(2): if firstctrl = lastctrl then go to do_ctrl_ret; substr(inbuf, 1, 4) = ctrls(firstctrl); /* If we get interrupted here, the worst that can happen is a ctrl char will get done twice, which is not so bad. */ if firstctrl < hbound(ctrls, 1) then firstctrl = firstctrl + 1; else firstctrl = lbound(ctrls, 1); nelemt = index(substr(inbuf, 1, 4), NL); if nelemt = 0 then nelemt = 4; go to ctrl_aa; /* process this ctrl char & return to exitv(2) for next */ handle_zerodivide: stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = nil; stack -> temp(1) = lisp_static_vars_$quotient; addr(stack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2)) -> fixedb = 0; call lisp_special_fns_$cons; call lisp_special_fns_$cons; unmkd_ptr = addrel(unmtop, 2); fault_save.code1, unmtop -> ercode = zerodivide_fault; call lisp_error_; action = 0; /* return means hack like divov t mode */ go to exit_nzq; handle_underflow: stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = lisp_static_vars_$zunderflow; call lisp_special_fns_$ncons; unmkd_ptr = addrel(unmtop, 2); fault_save.code1, unmtop -> ercode = underflow_fault; call lisp_error_; action = 0; /* return means hack like zunderflow t mode */ go to exit_nzq; handle_pi: if lisp_static_vars_$mulpi_state = -1 then go to Quit; /* Normal ITS-like lisp */ if masked.against.tty then do; if lisp_static_vars_$mulpi_state = -2 then inbuf = "g" || NL; else inbuf = cv_interruptno (lisp_static_vars_$mulpi_state) || NL; go to masked_ctrl_save; end; if lisp_static_vars_$mulpi_state = -2 then go to unwind_to_top_level; /* Signal ^g */ /* Must be interrupt number */ i = lisp_static_vars_$mulpi_state; go to ioc_num; /* some code for handling stack overflows */ stack_loss: entry(which_stack); /* non-fatal stack overflow, give fail-act */ dcl which_stack fixed bin parameter; call save_state; /* push a fault frame */ on condition(cleanup) call lisp_segment_manager_$shrink_stacks; /* if guy (ioc g)'s out, set stacks back to norm size so can detect again */ unmtop = unmkd_ptr; unmkd_ptr = addrel(unmtop, 2); fault_save.code1, unmtop -> ercode = stack_loss_error; /* push name of pdl that overflew onto stack */ tstack = stack_ptr; stack_ptr = addr(tstack -> temp(2)); tstack -> temp(1) = lisp_static_vars_$space_names_atom -> atom.value; do while(which_stack > 1); tstack -> temp(1) = tstack -> temp_ptr(1) -> cons.cdr; which_stack = which_stack - 1; end; tstack -> temp(1) = tstack -> temp_ptr(1) -> cons.car; call lisp_error_; stack_ptr = tstack; go to exit_nzq; wipe_stack: entry; /* fatal stack overflow, cleanup as best we can and ctrl/g */ /* note that this routine is only called when the stack is so full that it cannot be expanded (i.e. several pdl-overflow's have occurred */ dcl damage bit(1) aligned; call undamage_the_stacks; undamage_the_stacks: proc; dcl stattic_ptr (0:6) ptr aligned based(addr(unmkd_ptr)), our_stack ptr, stattic_bound bit(18) static init("001111111111110011"b), /* 12 down from 64K */ /**** Note this kludgey stuff must be coordinated with lisp_segment_manager_ ****/ stack_ptr_max bit(18) static init("001111111111111110"b), /* 2 down from 64K */ stack_ptr_kludge bit(18) static init("001111111111111110"b); dcl ioa_$ioa_stream entry options (variable), hcs_$truncate_seg entry(pointer, fixed bin(18), fixed bin(35)), lisp_static_vars_$top_level external label; damage = "0"b; /* assume that we are winning */ do i = 0 to 6; /* check for fatal damage */ if rel(stattic_ptr(i)) > stattic_bound then damage = "1"b; /* this would be fatal damage */ end; if damage then do; call ioa_$ioa_switch(iox_$error_output, "lisp: Fatal stack damage. Major restart undertaken. Bindings will not be restored."); if string(masked.against) then call ioa_$ioa_switch(iox_$error_output, "Warning: Either a garbage collection was in progress or (nointerrupt t) mode was in effect."); our_stack = ptr(unmkd_ptr, 0); /* base of unmkd pdl */ prog_frame, err_frame, catch_frame, binding_top, /* "major restart" */ err_recp, eval_frame = our_stack; unmkd_ptr = addr(our_stack -> stack_seg.begin_unmkd_stack); stack_ptr = ptr(stack_ptr, 2); call hcs_$truncate_seg(unmkd_ptr, fixed(rel(unmkd_ptr), 18), 0); call hcs_$truncate_seg(stack_ptr, fixed(rel(stack_ptr), 18), 0); lisp_static_vars_$garbage_collect_inhibit = "0"b; lisp_static_vars_$rdr_state = 0; go to lisp_static_vars_$top_level; /* "major restart" */ end; /* now check for non fatal damage - stack_ptr or unmkd_ptr slightly out of bounds */ if rel(stack_ptr) >= stack_ptr_max then do; stack_ptr = ptr(stack_ptr, stack_ptr_kludge); damage = "1"b; end; if rel(unmkd_ptr) >= stack_ptr_max then do; unmkd_ptr = ptr(unmkd_ptr, stack_ptr_kludge); damage = "1"b; end; if damage then call ioa_$ioa_switch(iox_$error_output, "Warning: There was minor damage to the lisp stacks."); end undamage_the_stacks; /* attempt to ctrl/g. If we were in garbage collector, will lose big, but have already warned loser in that case so I guess it's all right */ err_frame = ptr(unmkd_ptr, ""b); go to quitter; check_for_damage: entry(a_damage); /* called by lisp pi handler */ dcl a_damage bit(1) aligned parameter; call undamage_the_stacks; a_damage = damage; return; /* The lisp iog fsubr: binds ^q, ^r, ^w then do first arg like ioc then eval remaining args then unbind & return value of last arg */ iog: entry; iogsw = "1"b; stack = addrel(stack_ptr, -2); /* -> arg list for fsubr */ stack_ptr = addr(stack -> temp(9)); /* room for binding block */ stack -> temp(8) = stack -> temp_ptr(1) -> cons.car; /* get 1st arg */ /* Make binding block for ^q, ^r, ^w */ stack -> temp(3) = ctrlQ; stack -> temp(2) = stack -> temp_ptr(3) -> atom.value; stack -> temp(5) = ctrlR; stack -> temp(4) = stack -> temp_ptr(5) -> atom.value; stack -> temp(7) = ctrlW; stack -> temp(6) = stack -> temp_ptr(7) -> atom.value; iog_unm = unmkd_ptr; unmkd_ptr = addrel(iog_unm, 2); iog_unm -> binding_block.bot_block = rel(addr(stack -> temp(2))); iog_unm -> binding_block.top_block = rel(addr(stack -> temp(8))); iog_unm -> binding_block.back_ptr = rel(binding_top); iog_unm -> binding_block.rev_ptr = ""b; binding_top = iog_unm; /* Now rebind them to nil */ stack -> temp_ptr(3) -> atom.value, stack -> temp_ptr(5) -> atom.value, stack -> temp_ptr(7) -> atom.value = nil; /* save reader status. If in a macro char function in readlist he says (iog s ...) we want to leave the readlist and get out to the tty */ if rdr_state = 2 then do; rdr_save_f = "1"b; /* so we can undo this later */ call save_state_only; rdr_state = 0; end; else rdr_save_f = "0"b; stack = addr(stack -> temp(8)); go to iogjoin; /* comes back here after doing ioc to our first arg */ iog_aa: stack = addrel(stack, -14); /* unbump ptr */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* is list of forms to eval */ do while (stack -> temp_type(1) = Cons); stack -> temp(8) = stack -> temp_ptr(1) -> cons.car; call lisp_$eval; stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; end; stack -> temp(1) = stack -> temp(8); /* value is value of last form evaled */ if rdr_save_f then do; /* restore the state of the reader */ rdr_label = fault_save.sv_rdr_label; rdr_ptr = fault_save.sv_rdr_ptr; rdr_state = fault_save.sv_rdr_state; err_recp = ptr(unm, fault_save.prev_frame); end; /* restore the bindings of ^q, ^r, ^w */ stack -> temp_ptr(7) -> atom.value = stack -> temp(6); stack -> temp_ptr(5) -> atom.value = stack -> temp(4); stack -> temp_ptr(3) -> atom.value = stack -> temp(2); /* get rid of the binding block */ binding_top = ptr(iog_unm, binding_top -> binding_block.back_ptr); unmkd_ptr = iog_unm; stack_ptr = addr(stack -> temp(2)); return; /* car or cdr of a number --- at present this is an uncorrectable error */ car_cdr_of_num: unmkd_ptr = addrel(unmtop, 2); fault_save.code1, unmtop -> ercode = car_cdr_error; call lisp_error_; /* never returns */ /* alarmclock interrupt, apply the alarmclock user inyerrupt service function to 'time or 'runtime */ alarm: if masked.against.alarm then go to masked_alarm; call alarm_proc; action = 0; go to exit_nzq; do_alarm: call alarm_proc; /* deferred alarm comes here when unmasked */ go to do_ctrl_ret; alarm_proc: proc; stack_ptr = addr(stack->temp(4)); string(new_mask.against) = copy("1"b,length(string(new_mask.against))); call lisp_fault_handler_$set_mask(new_mask); /* alarmclock interrupt handler is supposed to be run masked. this version of the code has a slight window. If it causes any problems it can be fixed by kludging around with inhibited alarm calls and ips masks */ stack -> temp(1) = addr(user_intr_array(3)) -> based_ptr -> atom.value; if stack -> temp(1) ^= nil then do; if fault_code = Alarmclock_fault then stack -> temp(2) = time; else /* if fault_code = Cput_fault then */ stack -> temp(2) = runtime; stack -> temp(3) = nil; /* make the arg list (nil) */ call lisp_special_fns_$cons; call lisp_$apply; end; end alarm_proc; /* routine to exit, action must be set before coming here */ exit: qitf = "0"b; call unsave_state; if action ^= 0 then return; /* if special action being taken, must go through lisp_default_handler_ */ if rdr_state = 1 then do; /* returning into an i/o wait, so wake up the reader and make it look at the ^q flag */ go to rdr_label; end; return; exit_nzq: call unsave_state; return; unsave_state: proc; /* unsave at any speed */ call iox_$control (iox_$user_io, "start", null(), io_status); /* restore the key variables that we saved */ gc_inhibit = fault_save.sv_gc_inhibit; stack_ptr = addr(stack -> temp(2)); call lisp_fault_handler_$set_mask((fault_save.sv_masked)); unspec(ptr(unm, ""b) -> stack_seg.array_info_for_store) = unspec(fault_save.sv_array_info); ptr(unm, ""b) -> stack_seg.array_offset_for_store = fault_save.sv_array_offset; rdr_label = fault_save.sv_rdr_label; rdr_ptr = fault_save.sv_rdr_ptr; rdr_state = fault_save.sv_rdr_state; err_recp = ptr(unm, fault_save.prev_frame); stack_ptr = stack; /* now clr pdl's */ unmkd_ptr = unm; end unsave_state; array_lossage: /* store was misused in such a way that the array moved between the time the subscripts were processed and the time the store was actually done */ unmkd_ptr = addrel(unmtop, 2); /* signal uncorrectable error */ fault_save.code1, unmtop -> ercode = store_function_misused; call lisp_error_; emulate_old_style_store: /* an old-arrays compiled program tried to store using in-line code */ dcl haventbarfedatthisyet bit(1) static init("1"b), patchingmode bit(1) static init("0"b), based_inst bit(36) aligned based, call_store_operator bit(36) static init("001000000001001110010111010001010000"b); if haventbarfedatthisyet then do; call ioa_$ioa_switch(iox_$error_output, "lisp: A program is being run which contains old compiled ""store""s. Execution will proceed, but slowly."); call ioa_$ioa_switch_nnl(iox_$user_io, "Do you want to go into patching mode? "); call iox_$get_line(iox_$user_io, addr(inbuf), length(inbuf), nelemt, io_status); if substr(inbuf, 1, nelemt-1) = "yes" then patchingmode = "1"b; haventbarfedatthisyet = "0"b; end; if patchingmode then do; /* patch it to call new array store op */ call ioa_$ioa_switch(iox_$error_output, "lisp_fault_handler_: Patching ^p to call new store operator.", pbr); pbr -> based_inst = call_store_operator; end; argsp = addrel(ptr(unm, ""b) -> stack_seg.array_info_for_store, -2) -> array_info.array_data_ptr; argsp = addrel(argsp, ptr(unm, ""b) -> stack_seg.array_offset_for_store); /* assume not a number array */ action = 3; /* force instruction to be retried with new address */ pbr = argsp; /* kludgily pass the address back */ call unsave_state; return; /***** the alarmclock subr, for setting and resetting timers *****/ alarmclock: entry; /* * function to implement the lisp alarmclock function, using timer_manager_ * coded by D. A. Moon, 18 Aug 72 * * changed to make alarmclock a cpu timer rather than an alarm timer, * for compatiblity with pdp-10 lisp, 9 Sep 72 by DAM * * Major Rewrite 1 Feb 1973 by DAM for new alrm system * * modified 17 Jan 74 by DAM to stop hacking ips masks */ dcl lisp_default_handler_$alarm entry(ptr, char(*)), /* handler for both types of timer intr */ lisp_static_vars_$time_atom fixed bin(71) external, time fixed bin(71) def (lisp_static_vars_$time_atom), lisp_static_vars_$runtime_atom fixed bin(71) external, runtime fixed bin(71) def (lisp_static_vars_$runtime_atom), 1 old_mask aligned like masked, 1 new_mask aligned like masked, timer_manager_$cpu_call ext entry(fixed bin(71), bit(2), entry), timer_manager_$alarm_call ext entry(fixed bin(71), bit(2), entry), timer_manager_$reset_cpu_call ext entry(entry), timer_manager_$reset_alarm_call ext entry(entry), stack2 ptr, alarm_time fixed bin(71); alarmclock0: stack = addrel(stack_ptr, -4); /* subr of 2 args */ stack2 = addr(stack -> temp(2)); if stack -> temp(1) = time then go to alrm; else if stack -> temp(1) = runtime then go to cput; else do; /*** ERROR ***/ unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = bad_arg_correctable; unm -> errcode(2) = fn_alarmclock; stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = stack -> temp(1); call lisp_error_; stack -> temp(1) = stack -> temp(3); go to alarmclock0; end; /*** real time interrupt, second arg is time in seconds */ alrm: call timer_manager_$reset_alarm_call(lisp_default_handler_$alarm); /* get rid of any pending interrupt */ if stack2 -> lisp_ptr_type & Fixed36 then alarm_time = stack2 -> fixedb*1000000; else if stack2 -> lisp_ptr_type & Float36 then alarm_time = stack2 -> floatb*1000000e0; else go to ret_nil; /** any other arg just shuts off timer and returns nil **/ if alarm_time < 0 then go to ret_nil; /** negative arg does too due to ITS kludgery **/ call timer_manager_$alarm_call(alarm_time, "10"b, /* relative microseconds */ lisp_default_handler_$alarm); ret_t: stack -> temp(1) = t_atom; ret: stack_ptr = addr(stack -> temp(2)); return; /*** cpu time interrupt, second arg is time in microseconds ***/ cput: call timer_manager_$reset_cpu_call(lisp_default_handler_$alarm); if stack2 -> lisp_ptr_type & Fixed36 then alarm_time = stack2 -> fixedb; else if stack2 -> lisp_ptr_type & Float36 then alarm_time = stack2 -> floatb; else go to ret_nil; if alarm_time < 0 then go to ret_nil; call timer_manager_$cpu_call(alarm_time, "10"b, /* relative usec */ lisp_default_handler_$alarm); go to ret_t; ret_nil: stack -> temp(1) = nil; go to ret; /*** The nointerrupt subr, which turns on or off cput and alrm timer interrupts and ctrl chars other than ., z, and $ ***/ nointerrupt: entry; stack = addrel(stack_ptr, -2); /* subr of one arg */ nointerrupt00: if stack -> temp(1) = nil then string(new_mask.against) = ""b; else if stack -> temp(1) = t_atom then string(new_mask.against) = copy("1"b,length(string(new_mask.against))); else if stack -> temp(1) = tty_atom then do; new_mask.against.alarm = "0"b; new_mask.against.tty = "1"b; end; else do; /* error */ unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = bad_arg_correctable; unm -> errcode(2) = fn_nointerrupt; call lisp_error_; go to nointerrupt00; end; /* encode old state of mask */ if masked.against.alarm then stack -> temp(1) = t_atom; else if masked.against.tty then stack -> temp(1) = tty_atom; else stack -> temp(1) = nil; go to nointr_join; interrupt_poll: entry (); new_mask = masked; go to nointr_join; set_mask: entry(a_new_mask); dcl 1 a_new_mask aligned like masked; new_mask = a_new_mask; nointr_join: stack = stack_ptr; old_mask = masked; /* going to return previous value of the mask */ /**** we assume anyone who interrupts us will restore this mask to its previous state before rtn ***/ if new_mask.against.tty = "0"b then do; /* UNMASK CTRL CHARS */ do_ctrl_ret: pending_ctrl = "1"b; /* so if we process a ctrl/g it doesn't screw us up */ if deferred_alrm_timer then do; fault_code = Alarmclock_fault; deferred_alrm_timer = "0"b; go to do_alarm; end; if deferred_cput_timer then do; fault_code = Cput_fault; deferred_cput_timer = "0"b; go to do_alarm; end; if lastctrl ^= firstctrl then go to do_ctrl; /* if there are chars in the circular buffer, go process them */ deferred_interrupt, /* no deferred interrupts left */ pending_ctrl = "0"b; /* ok, we processed all the stacked-up ctrl chars */ end; masked = new_mask; /* SET THE MASK */ stack_ptr = stack; /* either flush stack or leave argument */ return; /***** SPECIAL TIMER HANDLER USED WHEN MASKED *****/ masked_alarm: deferred_interrupt = "1"b; if fault_code = Alarmclock_fault then deferred_alrm_timer = "1"b; else if fault_code = Cput_fault then deferred_cput_timer = "1"b; action = 0; go to exit_nzq; /***** SPECIAL QUIT HANDLER USED WHEN MASKED *****/ masked_quit: if lisp_static_vars_$mulquit_state = -1 then; else if lisp_static_vars_$mulquit_state = -2 then go to do_ctrl_z; else do; inbuf = cv_interruptno (lisp_static_vars_$mulquit_state); go to masked_ctrl_save; end; if lisp_static_vars_$cleanup_list_exists /* cleanup feature */ then if lisp_static_vars_$i_am_gcing /* has to do strange things if gc in progress and unwind */ then on condition(cleanup) begin; dcl sp pointer; sp = cu_$stack_frame_ptr(); /* find target of unwindage */ g0001: sp = sp -> stack_frame.prev_sp; if sp -> stack_frame.arg_ptr -> argument_list.argument_count ^= 2 then go to g0001; /* 1 arg */ lisp_static_vars_$gc_unwinder_kludge = sp -> stack_frame.arg_ptr -> argument_list.argument_pointer(1) -> based_label_var; lisp_static_vars_$activate_gc_unwinder_kludge = "1"b; action = 0; /* restart fault */ go to exit; /* so finish gc and cleanup */ end; substr(inbuf, 1, 4) = " "; masked_ctrl_ask: call ioa_$ioa_switch_nnl(iox_$user_io, "CTRL/"); /* really should tell user is (nointerrupt t) mode right now */ lisp_static_vars_$read_print_nl_sync = "1"b; /* user will hit newline after the ctrl char */ call iox_$get_line(iox_$user_io, addr(inbuf), length(inbuf), nelemt , io_status); if nelemt < 2 then go to masked_ctrl_ask; /* check for control characters done immediately */ if substr(inbuf, 1, 1) = "Z" | substr(inbuf, 1, 1) = "z" then do; go to do_ctrl_z; end; else if substr(inbuf, 1, 1) = "$" then go to proc(14); else if substr(inbuf, 1, 1) = "." then go to proc(15); else if substr(inbuf, 1, 1) = "?" then /* user wants to know what's going on */ if lisp_static_vars_$i_am_gcing then do; intrp = addr(ms_gc); nelemt = length(ms_gc); go to whats_going_on; end; else do; intrp = addr(ms_masked); nelemt = length(ms_masked); go to whats_going_on; end; /* Can't be done immediately, save it up for when (nointerrupt nil) is done */ masked_ctrl_save: deferred_interrupt = "1"b; ctrls(lastctrl) = substr(inbuf, 1, 4); /* fortunately we can't get interrupted here since qitf is on */ if lastctrl < hbound(ctrls, 1) then lastctrl = lastctrl + 1; else lastctrl = lbound(ctrls, 1); if lastctrl = firstctrl then call ioa_$ioa_switch(iox_$user_io, "lisp: Control character buffer overflow. While in (nointerrupt t) mode. Oldest chars lost."); action = 0; go to exit; cv_interruptno: procedure (intno) returns (char (2)); dcl intno fixed binary; dcl intno_pic picture "99"; return (convert (intno_pic, intno)); end; init: entry; /* Called when the lisp command is entered */ pending_ctrl = "0"b; lisp_static_vars_$i_am_gcing = "0"b; firstctrl, lastctrl = 1; /* clear this stupid buffer, in case he quat out of a previous lisp at an awkward time */ deferred_alrm_timer, deferred_cput_timer = "0"b; ctrls = ". "; /* fill this up with nops */ string(masked.against) = ""b; /* unmask */ return; /* routine to process control characters noticed in the input stream by the reader. These are characters prefixed by \036 */ ctrl_from_reader: entry(ctrl_from_rdr); dcl ctrl_from_rdr char(1) aligned parameter; chr = ctrl_from_rdr; /* copy arg into same place as other entries */ esw = -1; stack = stack_ptr; go to dispatch; /* hence numbers don't work in this mode */ exitv(-1): stack_ptr = stack; return; ctrl_g_function: entry; /* ^g subr */ go to ctrl_g_handler; end;  lisp_garbage_collector_.pl1 07/06/83 0937.0r w 06/29/83 1542.3 334962 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_garbage_collector_: proc; dcl curtop fixed bin(18), total_allocation fixed bin(34), old_allocation fixed bin(34), lisp_gc_alm_$collect entry(bit(1)aligned) returns(ptr), lisp_io_control_$gc_flush entry(ptr), new_seg ptr, curseg ptr, segment_chain based ptr aligned, lisp_static_vars_$gc_mark_bits bit(18) aligned external, oldgcmark bit(18) aligned defined lisp_static_vars_$gc_mark_bits, curgcmark bit(18) aligned, chaser ptr, ungclist_ptr ptr init(null()), ungc_element fixed bin(71) aligned based, 1 ungclist_element based aligned like obarray_list_element, obarray_list ptr init(null()), obarray_list_end ptr init(null()), obarray_ptr ptr, last ptr, tempp ptr, copy_nil fixed bin(71), gcmode fixed bin init(-1), /* set to Obarray_array if in gctwa mode */ atptr ptr, lisp_static_vars_$status_gctwa external fixed bin(71) aligned, lisp_fault_handler_$nointerrupt entry, 1 obarray_list_element based aligned, 2 next ptr, 2 current ptr, old_array_stcd_instruction bit(36) static init("001000000000001000011101111001000000"b), 1 Obarray based aligned, 2 bucket(0:510) aligned pointer, 2 char_atom(0:127) fixed bin(71), 1 copied_string based aligned, 2 pad5050 fixed bin, 2 new_address ptr unaligned, reti fixed bin, arg fixed bin(71) aligned, 1 arg_ovly based (addr(arg)) aligned, 2 pad bit(53) unal, 2 arg_points_at_odd_addr bit(1) unal, 2 rest bit(18) unal, allocptr ptr, workptr ptr, lisp_static_vars_$garbage_collected_ptrs ext fixed bin(71), lisp_static_vars_$number_gc_ptrs ext fixed bin(17) aligned, bottom_ptr ptr, size fixed bin, stack ptr, gc_mark fixed bin(71) static init(-1), left fixed bin, idx fixed bin, copy_words (size) fixed bin(35) aligned based, hcs_$truncate_seg entry(ptr, fixed bin, fixed bin(35)), lisp_segment_manager_$get_lists entry(ptr), lisp_segment_manager_$free_lists entry(ptr), ioa_ entry options(variable), ioa_$ioa_stream_nnl entry options(variable), lisp_print_$type_string entry(char(*)), virtual_cpu_time_ entry returns(fixed bin(52)), start_time fixed bin(52), saved_alloc_fault_word bit(36), lisp_alloc_$get_fault_word entry(bit(36)), lisp_alloc_$rehash_maknum entry, lisp_default_handler_$deferred_quit entry, fault_bits bit(36) aligned, lisp_default_handler_$alloc_fault entry ( bit(36) aligned ), (lisp_special_fns_$cons, lisp_special_fns_$list, lisp_special_fns_$ncons, lisp_$apply, lisp_$eval) entry, lisp_static_vars_$garbage_collect_inhibit bit(36) aligned external, old_segs ptr, meter_time float bin(63), lisp_static_vars_$i_am_gcing bit(1) aligned external, lisp_static_vars_$gcmax fixed bin(35) external, lisp_static_vars_$space_names_atom external pointer, lisp_static_vars_$gc_time external static fixed bin(71), gc_time fixed bin(71), Maximum_Reasonable_Size fixed bin(18) static init(65000), /* no atom bigger than this */ com_err_ entry options(variable), (addr,addrel,ptr,divide,null,mod,hbound,baseno,binary,bit,float,rel,lbound,string,fixed) builtin; dcl lisp_static_vars_$cleanup_list fixed bin(71) external, lisp_static_vars_$cleanup_list_exists bit(1) aligned external, lisp_static_vars_$gc_unwinder_kludge label external, lisp_static_vars_$activate_gc_unwinder_kludge bit(1) aligned external; dcl 1 argo aligned based(addr(arg)->based_ptr), /* overlay for bug messages */ 2 (w1, w2, w3, w4, w5, w6) bit(36) aligned; %include lisp_free_storage; %include lisp_array_fmt; %include lisp_iochan; %include lisp_nums; %include lisp_ptr_fmt; %include lisp_stack_seg; %include lisp_string_fmt; %include lisp_bignum_fmt; %include lisp_stack_fmt; %include lisp_common_vars; %include lisp_atom_fmt; %include lisp_cons_fmt; %include lisp_control_chars; %include lisp_comp_subr_block; %include lisp_maknum_table; go to join; /* obsolete "FSUBR" entry point */ gcsubr: entry; stack = stack_ptr; stack_ptr = addr(stack->temp(2)); stack -> temp(1) = nil; join: if lisp_static_vars_$garbage_collect_inhibit then return; /* go into (nointerrupt t) mode */ lisp_static_vars_$i_am_gcing = "1"b; /* for CTRL/? */ stack = stack_ptr; stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = t_atom; call lisp_fault_handler_$nointerrupt; /* now the top of the stack has the previous status of the nointerrupt flag */ /* Now safely clear the alloc fault word */ call lisp_alloc_$get_fault_word(saved_alloc_fault_word); /* get fault word, make sure to zero it right. */ if saved_alloc_fault_word & quit_fault /* do quit now */ then do; saved_alloc_fault_word = saved_alloc_fault_word & ^quit_fault; call lisp_default_handler_$deferred_quit; /* but leave alarms for later */ end; start_time = virtual_cpu_time_(); /* curtop = 0;*/ call compute_total_allocation; old_allocation = total_allocation; /* total_allocation = 0;*/ /* curseg = null();*/ curgcmark = ^oldgcmark; oldgcmark = curgcmark; /* call new_segment_maker;*/ if lisp_static_vars_$status_gctwa ^= nil then do; gcmode = Obarray_array; /* control switch for checking array types for obarrays */ if addr(lisp_static_vars_$status_gctwa) -> lisp_ptr_type = fixnum_type then if addr(lisp_static_vars_$status_gctwa) -> fixedb = 1 then addr(lisp_static_vars_$status_gctwa) -> fixedb = 0; /* only gctwa this time */ else if addr(lisp_static_vars_$status_gctwa) -> fixedb = 0 then gcmode = -1; /* if switch is off, don't gctwa */ else addr(lisp_static_vars_$status_gctwa) -> fixedb = 8; end; old_segs = lisp_gc_alm_$collect(gcmode=Obarray_array); /* call whizzy new gcer */ /* copy_nil = nil; */ /* call lisp_segment_manager_$get_lists (stack); /* use a new segment for gc stack */ /* /* workptr = stack_ptr;*/ /* bottom_ptr = ptr(unmkd_ptr,0)->stack_seg.marked_stack_bottom; /* if baseno(bottom_ptr) ^= baseno(workptr) /* then do; /* call ioa_("Garbage collector: stack screwed up!!!! Entering debug."); /* call debug; /* dcl debug entry; /* end; /* /* do while(workptr ^= bottom_ptr); /* workptr = addrel(workptr,-2); /* arg = workptr -> temp(1); /* reti = 3; /* go to collect; /*ret(3): workptr -> temp(1) = arg; /* end;*/ /* idx = lisp_static_vars_$number_gc_ptrs; /* get number of ext ptrs */ /* workptr = addr(lisp_static_vars_$garbage_collected_ptrs);*/ /* do while (idx > 0); /* do until no more ptrs */ /* idx = idx -1; /* reti = 5;*/ /* /* arg = workptr -> temp(1); /* use this as based ptr (lisp type) */ /* go to collect; /*ret(5): workptr -> temp(1) = arg; /* workptr = addr(workptr->temp(2)); /* bump ptr address */ /* end; /* /* /* /* garbage collection of truly worthless atoms phase */ /* /* if gcmode < 0 then go to skip_gctwa; /* /* /* first pass over obarrays in obarray_list is for the purpose of garbage collecting */ /* /* all of the worthy atoms which have not yet been seen. */ /* /* for example, if the user had setq'ed a to b but no program or other list */ /* /* structure referenced the atom b, we must make sure b is picked up by this pass */ /* /* also, this handles difficulties with atoms whose values point into Obarray.buckets */ /* /* do chaser = obarray_list /* pass to collect worthy atoms and their plists and values */ /* repeat(chaser -> obarray_list_element.next) /* while(chaser ^= null()); /* /* obarray_ptr = chaser -> obarray_list_element.current -> array_info.array_data_ptr; /* /* do idx = 0 /* repeat(idx+1) /* while(idx <= 127); /* arg = obarray_ptr -> Obarray.char_atom(idx); /* these char_atoms are for single char atoms */ /* reti = 7; /* go to collect; /*ret(7): obarray_ptr -> Obarray.char_atom(idx) = arg; /* put result back */ /* end; /* /* do idx = 0 /* repeat(idx+1) /* while(idx <= 510); /* these are the hash buckets */ /* /* do tempp = obarray_ptr -> Obarray.bucket(idx) /* repeat (tempp -> cons_ptrs.cdr) /* while (tempp -> cons.car ^= gc_mark); /* don't go past point in list we have seen */ /* /* arg = tempp -> cons.car; /* atom is at car of list */ /* reti = 8; /* /* now check to see if atom was not seen , yet is worthy */ /* if addr(arg) -> based_ptr -> atom.value ^= gc_mark /* then if addr(arg) -> based_ptr -> atom.value ^= 0 then go to collect; /* else if addr(arg) -> based_ptr -> atom.plist ^= copy_nil then go to collect; /* /* go to no_check_car; /*ret(8): if tempp -> cons.car = gc_mark /* in following atom's value or plist, /* came to this part of bucket list */ /* then go to premature_end_of_bucket; /*no_check_car: end; /*premature_end_of_bucket: /* end; /* end; /* /* /* second phase of gctwa operation -- must go through and make Obarray.bucket lists /* from old bucket lists, preserving the worthy atoms, all of which have now /* been collected */ /* /* do chaser = obarray_list /* repeat (chaser -> obarray_list_element.next) /* while (chaser ^= null()); /* obarray_ptr = chaser -> obarray_list_element.current -> array_info.array_data_ptr; /* /* do idx = 0 /* repeat (idx + 1) /* while (idx <= 510); /* last = addr(obarray_ptr -> Obarray.bucket(idx)); /* last always point at place to splice next cons */ /* /* do tempp = obarray_ptr -> Obarray.bucket(idx) /* repeat (tempp -> cons_ptrs.cdr) /* while (tempp -> cons.car ^= gc_mark); /* stop at end of unseen bucket elements */ /* /* atptr = tempp -> cons_ptrs.car; /* get pointer to atom for worthiness check */ /* if atptr -> cons.car = gc_mark /* then it is worthy */ /* then do; /* if curtop > 261116 then call new_segment_maker; /* allocptr = addrel(curseg, curtop); /* allocate a cons */ /* curtop = curtop + 4; /* allocptr -> cons.car = atptr -> cons.cdr; /* the atom we are adding to bucket */ /* last -> based_ptr = allocptr; /* append to bucket list so far */ /* last = addr(allocptr -> cons.cdr); /* and remember where to append next */ /* end; /* end; /* /* last -> cons.car = tempp -> cons.cdr; /* terminate the list with the new location of the end */ /* end; /* end; /* /* /*skip_gctwa: /* /* now must scan over ungclist, and find all of those things which were not protected /* by the other list structure we have seen */ /* /* do chaser = ungclist_ptr /* repeat (chaser -> ungclist_element.next) /* while (chaser ^= null()); /* /* allocptr = chaser -> ungclist_element.current; /* get pointer to ungc'ed array */ /* call compute_array_size; /* allocptr = allocptr -> array_info.array_data_ptr; /* do left = size-2 by -2 to 0; /* allocptr = addrel(allocptr,2); /* if allocptr -> ungc_element = 0 then; /* else if allocptr -> lisp_ptr_type & Numeric36 then; /* else if allocptr -> lisp_ptr_type & String36 then go to make_fake; /* else if allocptr -> lisp_ptr_type & Subr36 then; /* else if allocptr -> based_ptr -> cons.car = gc_mark /* if already seen atom, cons or /* bignum, then get new address */ /* then allocptr -> ungc_element = allocptr -> based_ptr -> cons.cdr; /* else do; /*make_fake: if curtop > 261116 then call new_segment_maker; /* atptr = addrel(curseg, curtop); /* curtop = curtop + 4; /* /* replace current array element by cons of itself with itself */ /* atptr -> cons_ptrs.car = atptr; /* atptr -> cons_ptrs.cdr = atptr; /* allocptr -> based_ptr = atptr; /* end; /* /* end; /* end; /* /* /* /* /* now inform allocation routines of new segments */ /* /* curtop = divide(curtop + 3, 4, 17,0)*4; /* make curtop 0 (mod 4) */ /* if curtop = 261120 then call new_segment_maker; /* if at very end of seg, skip to new one */ /* /* total_allocation = total_allocation + curtop; /* get current wordage */ /* /* old_segs = lisp_alloc_$cur_seg; /* remember old seg for later flushing */ /* /* lisp_alloc_$cur_seg = curseg; /* now set up all the necessary data */ /* lisp_alloc_$consptr = addr(curseg->alloc_segment.tally_word); /* consptr_ovly.mod = "101011"b; /* ad modifier */ /* curseg -> alloc_segment.tally_word.seg_offset = bit(binary(curtop,18,0),18); /* curseg -> alloc_segment.tally_word.tally = bit(binary(divide(mod(-1020-curtop,16384),4,18,0),12,0),12); /* curseg -> alloc_segment.tally_word.delta = 4; /* lisp_alloc_$seg_blk_cntr = divide(curtop+1024,16384,35,0) - 16;*/ call compute_total_allocation; call set_gc_blk_cntr; /* now rehash the maknum table, after throwing away all old stuff not protected otherwise */ /* note - allocation performed below will not be accounted for in msgs, gcsize, etc. */ /* size = 0; /* see if there is any point to it */ /* /* if lisp_static_vars_$maknum_mask = -1 then goto norehash; /* /* /* do idx = lbound(maknum_table,1) to hbound(maknum_table,1); /* /* if string(maknum_table(idx).first) /* then do; /* /* if maknum_table(idx).first.type &(Subr|Numeric) /* then size = size + 1; /* else do; /* workptr = ptr(baseptr(maknum_table(idx).second.segno),maknum_table(idx).second.offset); /* if maknum_table(idx).first.type & String /* then if workptr -> string_length < 0 /* then maknum_table_ptrs(idx).second = workptr -> copied_string.new_address; /* else string(maknum_table(idx).first) = ""b; /* else if workptr -> cons.car = gc_mark /* then maknum_table_ptrs(idx).second = workptr -> cons_ptrs.cdr; /* else string(maknum_table(idx).first) = ""b; /* if string(maknum_table(idx).first) /* then size = size + 1; /* end; /* end; /* end; /* /* /* /* /* now rehash the table */ /* /* lisp_static_vars_$maknum_left = size; /* /* lisp_static_vars_$garbage_collect_inhibit = "1"b; /* call lisp_alloc_$rehash_maknum; /* lisp_static_vars_$garbage_collect_inhibit = "0"b; /*norehash:*/ /* final post-flushage */ workptr = ptr(unmkd_ptr,0); /* get ptr to base of stack */ workptr -> stack_seg.nil = nil; /* copy back two quantities */ workptr -> stack_seg.true = t_atom; workptr = ptr(stack_ptr, 0); /* segment of marked stack */ reti = binary(rel(stack_ptr),17,0); /* and current height */ call hcs_$truncate_seg(workptr, reti, (0)); /* make sure area above stack height is zero, as it might be pointing into garbage collected space which has just been moved! */ /* call lisp_segment_manager_$free_lists (stack);*/ do while(old_segs ^= null()); /* want to free all old segments */ workptr = old_segs; old_segs = workptr -> alloc_segment.next_seg; call lisp_segment_manager_$free_lists(workptr); end; /* Have to do a post-pass over all file objects because those which have not been seen are supposed to be automatically closed, since there is no longer any way to reference them. In addition, we have to clear the gc_mark bits */ do allocptr = lisp_static_vars_$iochan_list repeat (allocptr -> iochan.thread) while (allocptr ^= null); if allocptr -> iochan.gc_mark then allocptr -> iochan.gc_mark = "0"b; else call lisp_io_control_$gc_flush(allocptr); end; gc_time = virtual_cpu_time_()-start_time; lisp_static_vars_$gc_time = lisp_static_vars_$gc_time + gc_time; meter_time = float(gc_time,63)/1e3; if addr(ctrlD)->based_ptr->atom.value ^= nil /* want gc print */ then call ioa_("^/;gc done: ^.3f msec., ^d words compacted to ^d words.^/", meter_time, old_allocation, total_allocation); /* restore status of nointerrupt flag */ call lisp_fault_handler_$nointerrupt; lisp_static_vars_$i_am_gcing = "0"b; stack_ptr = addrel(stack_ptr, -2); /* cleanup feature gets done here if released through a gc */ if lisp_static_vars_$activate_gc_unwinder_kludge then do; stack = stack_ptr; stack_ptr = addr(stack -> temp(3)); lisp_static_vars_$activate_gc_unwinder_kludge = "0"b; do stack -> temp(1) = lisp_static_vars_$cleanup_list repeat stack -> temp_ptr(1) -> cons.cdr while (stack -> temp_type(1) = Cons); stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; call lisp_$eval; end; lisp_static_vars_$cleanup_list_exists = "0"b; /* do once-only */ go to lisp_static_vars_$gc_unwinder_kludge; /* resume unwindage */ end; fault_bits = saved_alloc_fault_word & fault_mask; /* check for interrupts while in allocator */ if fault_bits ^= ""b then call lisp_default_handler_$alloc_fault(fault_bits); saved_alloc_fault_word = saved_alloc_fault_word & ^fault_mask; if addr (user_intr_array(20)) -> based_ptr -> atom.value ^= nil then do; /* call gc-daemon function */ stack = stack_ptr; stack_ptr = addr(stack -> temp(5)); stack -> temp(1) = addr(user_intr_array(20)) -> based_ptr -> atom.value; stack -> temp(2) = lisp_static_vars_$space_names_atom -> atom_ptrs.value -> cons.car; /* list space */ addr(stack -> temp(3)) -> fixnum_fmt.type_info, addr(stack -> temp(4)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(3)) -> fixedb = lisp_static_vars_$gcmax - old_allocation; addr(stack -> temp(4)) -> fixedb = lisp_static_vars_$gcmax - total_allocation; call lisp_special_fns_$cons; call lisp_special_fns_$cons; call lisp_special_fns_$ncons; /* listify in case more than one space */ call lisp_special_fns_$ncons; /* make another level of list for apply call */ call lisp_$apply; stack_ptr = stack; end; lisp_alloc_$alloc_fault_word = saved_alloc_fault_word; /* restore fault word */ return; /* Pseudo-subroutine to collect a value, and return its new location */ /*collect: if arg = 0 then go to ret(reti); /* go to return if zero (uninit stack or atom value) */ /* if addr(arg) -> lisp_ptr.itsmod ^= "100011"b then go to ret(reti); /* not lisp value -- unsnapped link, /* perhaps, if o41 */ /* if addr(arg)->lisp_ptr_type & NotConsOrAtsym36 = "0"b then go to collect_atsym_or_cons; /* /* if addr(arg) -> lisp_ptr_type & Numeric36 then go to ret(reti); /* redundant, due to previous check since mod = 47 */ /* if arg_points_at_odd_addr /* odd address, must fix this */ /* then do; /* arg_points_at_odd_addr = "0"b; /* force even address */ /* stack -> gcinfo.reti = reti; /* reti = 6; /* return to place where odd address fixed */ /* stack = addrel(stack,4); /* end; /* /* if addr(arg)->lisp_ptr_type & File36 then go to collect_file; /* if addr(arg)->lisp_ptr_type & Array36 then go to collect_array; /* if addr(arg)->lisp_ptr_type & Subr36 then go to collect_subr; /* if addr(arg)->lisp_ptr_type & String36 then go to collect_string; /* /* /* check for big fixed point number */ /* /* if addr(arg) -> lisp_ptr_type & Bigfix36 then go to collect_bigfix; /* /*collect_atsym_or_cons: /* if addr(arg)->based_ptr->cons.car = gc_mark /* already got this atom or cons */ /* then do; /* arg = addr(arg)->based_ptr->cons.cdr; /* get its new location */ /* go to ret(reti); /* and return */ /* end; /* /* /* /* now it is known that some space is to be allocated, and the car and cdr are to be collected */ /* /* if addr(arg)->lisp_ptr_type & Atsym36 then do; /* size = divide(addr(arg)->based_ptr->atom.pnamel+27,8,17,0)*2; /* if size > Maximum_Reasonable_Size then do; /* that nasty bug is back */ /* size = 4; /* turn damn thing into a cons */ /* addr(arg) -> lisp_ptr.type = Cons; /* .. */ /* if curtop + size > 261120 /* this lack of modularity */ /* then call new_segment_maker; /* is for speed in the main path */ /* allocptr = addrel(curseg, curtop); /* call com_err_(0, "lisp_garbage_collector_", /* "Bad atom ^w ^w ^w ^w ^w ^w at ^p -> ^p^/^-Possible bug in lisp.", /* argo.w1, argo.w2, argo.w3, argo.w4, argo.w5, argo.w6, /* addr(arg)->based_ptr, allocptr); /* go to bad_atom_scrunched; /* end; /* end; /* else size = 4; /* /* if curtop + size > 261120 then call new_segment_maker; /* we need more room */ /* allocptr = addrel(curseg,curtop); /* allocate space */ /*bad_atom_scrunched: /* curtop = curtop+size; /* and indeed it is allocated */ /* allocptr -> copy_words = addr(arg)->based_ptr->copy_words; /* copy whole structure */ /* /* addr(arg)->based_ptr->cons_ptrs.cdr = allocptr; /* save where it was moved to */ /* addr(arg)->based_ptr->cons_types.cdr = addr(arg)->lisp_ptr.type; /* and save type */ /* addr(arg)->based_ptr->cons.car = gc_mark; /* remember we hit this object */ /* /* /* now build a stack block for this collection */ /* /* stack -> gcinfo.loc = allocptr; /* stack -> gcinfo.reti = reti; /* stack -> gcinfo.type = addr(arg)->lisp_ptr.type; /* /* /* stack = addrel(stack,4); /* bump stack ptr */ /* arg = allocptr -> cons.car; /* get argument */ /* reti = 0; /* cons first return */ /* go to collect; /* call collector recursively */ /*ret(0): allocptr = addrel(stack,-4)->gcinfo.loc; /* get cons addr into automatic ptr */ /* allocptr->cons.car = arg; /* set car to ne value */ /* arg = allocptr->cons.cdr; /* get new argument */ /* reti = 1; /* and call collector again */ /* go to collect; /*ret(1): stack = addrel(stack,-4); /* pop stack */ /* allocptr = stack -> gcinfo.loc; /* allocptr -> cons.cdr = arg; /* addr(arg)->based_ptr = allocptr; /* generate return of correct type */ /* addr(arg)->lisp_ptr.type = stack -> gcinfo.type; /* go to ret(stack->gcinfo.reti); /* and return to caller */ /* /* /*collect_string: /* size = addr(arg) -> based_ptr -> string_length; /* if size < 0 /* then addr(arg)->based_ptr = addr(arg) -> based_ptr -> copied_string.new_address; /* else do; /* size = divide(size+11,8,17,0)*2; /* even number of words to allocate */ /* if size > Maximum_Reasonable_Size then do; /* size = 4; /* punt */ /* if curtop + size > 261120 then call new_segment_maker; /* allocptr = addrel(curseg,curtop); /* call com_err_(0, "lisp_garbage_collector_", /* "Bad string ^w ^w ^w ^w at ^p -> ^p^/^-Possible bug in lisp.", /* argo.w1, argo.w2, argo.w3, argo.w4, addr(arg)->based_ptr, allocptr); /* end; /* else do; /* if curtop + size > 261120 then call new_segment_maker; /* allocptr = addrel(curseg,curtop); /* end; /* curtop = curtop + size; /* allocptr -> copy_words = addr(arg)->based_ptr->copy_words; /* addr(arg)->based_ptr -> string_length = -5050; /* mark string */ /* addr(arg) -> based_ptr -> copied_string.new_address = allocptr; /* addr(arg)->based_ptr=allocptr; /* end; /* addr(arg)->lisp_ptr_type = addr(arg)->lisp_ptr_type|String36; /* set type field */ /* go to ret(reti); /* return */ /* /*collect_bigfix: /* if addr(arg)->based_ptr->cons.car = gc_mark /* already got this bigfix */ /* then do; /* arg = addr(arg)->based_ptr->cons.cdr; /* get its new location */ /* go to ret(reti); /* and return */ /* end; /* size = divide(addr(arg)->based_ptr->lisp_bignum.prec+2,2,18,0)*2; /* if size > Maximum_Reasonable_Size then do; /* size = 4; /* punt */ /* if curtop+size > 261120 then call new_segment_maker; /* allocptr = addrel(curseg,curtop); /* call com_err_(0, "lisp_garbage_collector_", /* "Bad bignum ^w ^w ^w ^w at ^p -> ^p^/^-Possible bug in lisp.", /* argo.w1, argo.w2, argo.w3, argo.w4, addr(arg)->based_ptr, allocptr); /* end; /* else do; /* if curtop+size > 261120 then call new_segment_maker; /* allocptr = addrel(curseg,curtop); /* end; /* curtop = curtop+size; /* allocptr->copy_words = addr(arg)->based_ptr->copy_words; /* addr(arg)->based_ptr->cons.car = gc_mark; /* mark this as copied */ /* addr(arg)->based_ptr->cons_ptrs.cdr = allocptr; /* addr(addr(arg)->based_ptr->cons.cdr) -> lisp_ptr.type = Bigfix; /* arg = addr(arg)->based_ptr->cons.cdr; /* go to ret(reti); /* /* /* /*ret(6): /* fix up odd address item, such as snapped link */ /* stack = addrel(stack, -4); /* arg_points_at_odd_addr = "1"b; /* make odd address */ /* go to ret(stack -> gcinfo.reti); /* return */ /* /*collect_subr: /* if addr(arg) -> based_ptr -> subr_entries(1).rest_of_tsx0 = tsx0_ic then go to collect_compiled_subr; /* go to ret(reti); /* type 3 subrs no longer supported */ /* /*collect_compiled_subr: /* allocptr = addr(arg) -> based_ptr; /* size = allocptr->subr_entries(1).head_offset-1; /* allocptr = addrel(allocptr, size); /* if allocptr -> subr_block_head.gcmark & curgcmark then go to ret(reti); /* allocptr -> subr_block_head.gcmark = curgcmark; /* left = allocptr->subr_block_head.gc_length; /* size = size + 8; /* move down 8 words relative to arg */ /* allocptr = addr(allocptr->subr_block_head.constants); /* go to subr_join; /* /* /* /* * files are kept in static storage, but they do contain 2 garbage-collectbale /* * cells, the function and the namelist. /* */ /* /*collect_file: /* if addr(arg)->based_ptr -> iochan.gc_mark then go to ret(reti); /* already been collected */ /* else addr(arg)->based_ptr -> iochan.gc_mark = "1"b; /* turn on already-been-seen bit */ /* left = 2; /* now garbage-collect it as if it was an array */ /* size = 14; /* allocptr = addr(addr(arg)->based_ptr -> iochan.function); /* of just function and namelist */ /* go to subr_join; /* /*collect_array: /* /* allocptr = addr(arg) -> based_ptr; /* -> array_info block */ /* /* if allocptr -> array_info.call_array_operator = old_array_stcd_instruction /* then call convert_old_array; /* compatibility with old arrays */ /* /* if allocptr -> array_info.gc_mark&curgcmark then go to ret(reti); /* we have seen it this time */ /* else allocptr -> array_info.gc_mark = curgcmark; /* otherwise mark it as such */ /* if allocptr -> array_info.type = Dead_array then go to ret(reti); /* nothing more to do */ /* if allocptr -> array_info.type = Un_gc_array then go to put_this_array_on_a_list; /* if allocptr -> array_info.type = gcmode /* Obarray and in gctwa mode */ /* then do; /*put_this_array_on_a_list: /* if curtop > 261116 then call new_segment_maker; /* atptr = addrel(curseg,curtop); /* get space to add to list */ /* curtop = curtop + 4; /* allocate the space */ /* if allocptr -> array_info.type = Obarray_array /* then do; /* /* must append to _e_n_d of obarray list, /* since we may be running in gctwa phase /* already */ /* if obarray_list_end = null() /* have no elements yet */ /* then obarray_list, obarray_list_end = atptr; /* else do; /* obarray_list_end -> obarray_list_element.next = atptr; /* obarray_list_end = atptr; /* end; /* obarray_list_end -> obarray_list_element.next = null(); /* obarray_list_end -> obarray_list_element.current = addr(arg) -> based_ptr; /* end; /* else do; /* atptr -> ungclist_element.next = ungclist_ptr; /* atptr -> ungclist_element.current = addr(arg) -> based_ptr; /* ungclist_ptr = atptr; /* end; /* /* go to collect_number_array; /* don't mark contents, but do copy into /* new lists seg */ /* end; /* /* else if allocptr -> array_info.type = Readtable_array then do; /* readtables are strange */ /* left = 9; /* number of markable double words */ /* size = 145; /* total number of double words */ /* go to collect_readtable_join; /* end; /* /* else if allocptr -> array_info.type = Fixnum_array /* then if allocptr -> array_info.minus_2_times_ndims ^= 0 then go to collect_number_array; /* else go to ret(reti); /* external array - don't attempt to collect data area */ /* else if allocptr -> array_info.type = Flonum_array then do; /* number array */ /*collect_number_array: /* call compute_array_size; /* if allocptr -> array_info.type >= Fixnum_array /* then if allocptr -> array_info.type <= Flonum_array /* then size = divide(size+1, 2, 18, 0); /* convert to number of double words */ /* left = 0; /* no markable words in this type of array */ /* go to collect_readtable_join; /* end; /* /* come here to collect an ordinary S-expression array */ /* /* call compute_array_size; /* left = size; /* all words are markable */ /*collect_readtable_join: /* /* /* left = number of double words to mark. /* size = number of double words total. */ /* /* /* the body of an array is in lists space so it has to be copied */ /* /* size = 2*(size + allocptr -> array_info.ndims); /* allow for dope vector */ /* if curtop + size > 261120 then call new_segment_maker; /* atptr = addrel(curseg, curtop); /* curtop = curtop + size; /* tempp = addrel(allocptr -> array_info.array_data_ptr, /* allocptr -> array_info.minus_2_times_ndims); /* atptr -> copy_words = tempp -> copy_words; /* copy over the body of the array */ /* allocptr -> array_info.array_data_ptr = addrel(atptr, 2*allocptr -> array_info.ndims); /* /* allocptr = allocptr -> array_info.array_data_ptr; /* -> data to be marked */ /* /* /* now walk over the garbage-collectable portion of the array */ /* /*subr_join: /* if left = 0 then go to ret(reti); /* no data at all */ /* stack -> array_save.argument = arg; /* save argument */ /* stack -> array_save.reti = reti; /* do while(left > 0); /* stack -> array_save.allocptr = allocptr; /* stack -> array_save.left = left; /* stack = addrel(stack,4); /* size of array save */ /* reti = 2; /* arg = allocptr -> cons.car; /* get thing to gc */ /* go to collect; /*ret(2): stack = addrel(stack,-4); /* allocptr = stack -> array_save.allocptr; /* allocptr -> cons.car = arg; /* allocptr = addr(allocptr->cons.cdr); /* left = stack -> array_save.left-1; /* end; /* /* arg = stack -> array_save.argument; /* go to ret(stack -> array_save.reti); /* /* /* declarations of structures used above */ /* /*dcl 1 gcinfo based aligned, /* 2 loc ptr, /* 2 reti fixed bin, /* 2 type bit(9); /* /*dcl 1 subr_info based aligned, /* 2 nargs fixed bin(17) unal, /* 2 infop fixed bin(17) unal, /* 2 instructions(3) bit(36), /* 2 nwords fixed bin(17) unal, /* this is the address of a tsblp instruction */ /* 2 tsblp_inst bit(18) unal, /* 2 gcmark bit(18)aligned; /* /*dcl 1 array_save aligned based, /* 2 argument fixed bin(71), /* 2 reti fixed bin(17) unaligned, /* 2 left fixed bin(17) unaligned, /* 2 allocptr unaligned pointer; /* /* /* This routine converts an old array to a new array, for compatibility */ /* /* allocptr -> old array, which is clobbered by array_info for new array (always shorter) */ /* /*convert_old_array: proc; /* /*dcl ndims fixed bin init(old_array.ndims), /* (old_data_ptr, new_data_ptr) pointer, /* size fixed bin(18), /* bound_product fixed bin(18), /* number_of_double_words fixed bin(18), /* k fixed bin(18), /* i fixed bin, /* array_type fixed bin; /* /*dcl 1 old_array aligned based(allocptr), /* 2 ndims fixed bin(17) unaligned, /* 2 infop fixed bin(17) unaligned, /* 2 stcd_inst bit(36), /* 2 inst_pairs (ndims), /* 3 ldq_or_adq bit(36), /* 3 mpy_or_qls, /* 4 bound bit(18) unaligned, /* 4 rest_of_inst bit(18) unaligned, /* 2 tmi_error bit(36), /* 2 cmpq, /* 3 total_bound bit(18) unaligned, /* 3 rest_of_inst bit(18) unaligned, /* 2 more (6) bit(36), /* 2 gc_info, /* 3 (nw, gcm, at, pb) fixed bin(17) unaligned, /* 2 data (1000) fixed bin(71); /* /*dcl 1 dope_vector (ndims) aligned based(new_data_ptr), /* 2 bounds fixed bin(35), /* 2 multiplier fixed bin(35); /* /* /* instructions to be put into a new array. copied from lisp_array_fcns_ */ /* /*dcl array_instructions(0:5, 0:3) bit(36) static init( /* index by array_type, instx */ /* "001000000001001010010111011001010000"b, /* "101000000000000000010011111001000110"b, /* "010000000000000000111001000001000000"b, /* ""b, /* S-expr, Un-gc: ldaq lb|0,ql tra bp|0 */ /* /* "001000000001001010010111011001010000"b, /* "101000000000000000010011111001000110"b, /* "010000000000000000111001000001000000"b, /* ""b, /* S-expr, Un-gc: ldaq lb|0,ql tra bp|0 */ /* /* "001000000001001010010111011001010000"b, /* "000100000000100111010011101000000111"b, /* "101000000000000000010011110001000110"b, /* "010000000000000000111001000001000000"b, /* fixnum - lda 040047,dl ldq lb|0,ql tra bp|0 */ /* /* "001000000001001010010111011001010000"b, /* "000010000000100111010011101000000111"b, /* "101000000000000000010011110001000110"b, /* "010000000000000000111001000001000000"b, /* flonum - lda 020047,dl ldq lb|0,ql tra bp|0 */ /* /* "001000000001001100010111011001010000"b, /* "000100000000100111010011101000000111"b, /* "101000000000000000010011110001000110"b, /* "010000000000000000111001000001000000"b, /* readtable - lda 040047,dl ldq lb|0,ql tra bp|0 */ /* /* "001000000001001010010111011001010000"b, /* "101000000000000000010011111001000110"b, /* "010000000000000000111001000001000000"b, /* ""b); /* obarray - ldaq lb|0,ql tra bp|0 */ /* /* /* old_data_ptr = addr(old_array.data); /* number_of_double_words = divide(fixed(old_array.total_bound, 18), 2, 18, 0); /* size = 2*(ndims + number_of_double_words); /* number of words required for data area */ /* if curtop + size > 261120 then call new_segment_maker; /* allocate new data area */ /* new_data_ptr = addrel(curseg, curtop); /* curtop = curtop + size; /* /* size = size - 2*ndims; /* subtract dope vector */ /* addrel(new_data_ptr, 2*ndims) -> copy_words = /* move the data */ /* old_data_ptr -> copy_words; /* /* /* now fill in the dope vector */ /* /* bound_product = 1; /* do i = 1 by 1 while (i < ndims); /* k = fixed(old_array.bound(i)); /* pick up old multiplier */ /* dope_vector(i).multiplier, dope_vector(i+1).bounds = k; /* bound_product = bound_product * k; /* end; /* dope_vector(ndims).multiplier = 2; /* dope_vector(1).bounds = divide(number_of_double_words, bound_product, 18, 0); /* /* /* compute type of old array and convert to new type codes */ /* /* array_type = old_array.gc_info.at; /* if array_type = 2 then array_type = Obarray_array; /* else if array_type = 3 then array_type = Un_gc_array; /* else if array_type = 1 then array_type = Readtable_array; /* else array_type = S_expr_array; /* /* /* make an array info block, clobbering the old array */ /* /* allocptr -> array_info.ndims = ndims; /* allocptr -> array_info.array_data_ptr = addrel(new_data_ptr, 2*ndims); /* allocptr -> array_info.minus_2_times_ndims = -2*ndims; /* allocptr -> array_info.gc_mark = ""b; /* allocptr -> array_info.type = array_type; /* allocptr -> array_info.call_array_operator = array_instructions(array_type, 0); /* do i = 1 to 3; /* allocptr -> array_info.array_load_sequence(i) = array_instructions(array_type, i); /* end; /* /*end convert_old_array; /* /*new_segment_maker: proc; /* /* total_allocation = total_allocation + curtop; /* call lisp_segment_manager_$get_lists (new_seg); /* new_seg -> alloc_segment.next_seg = curseg; /* curseg = new_seg; /* curtop = 4; /* /*end new_segment_maker;*/ /* subroutine to set gc_blk_cntr according to the gcsize and gcmin parameters. total_allocation must be set to the total number of words in lists space */ set_gc_blk_cntr: proc; dcl num_words_to_gc_at fixed bin(35), lisp_static_vars_$gcsize fixed bin(35) external, lisp_static_vars_$gcmin external, lisp_static_vars_$gcmin_fraction bit(1) external, lisp_static_vars_$gcmin_fixed fixed bin(35) based(addr(lisp_static_vars_$gcmin)), lisp_static_vars_$gcmin_float float bin(27) based(addr(lisp_static_vars_$gcmin)); if lisp_static_vars_$gcmin_fraction then num_words_to_gc_at = fixed(float(total_allocation) / (1 - lisp_static_vars_$gcmin_float), 35); else num_words_to_gc_at = total_allocation + lisp_static_vars_$gcmin_fixed; if num_words_to_gc_at < lisp_static_vars_$gcsize then num_words_to_gc_at = lisp_static_vars_$gcsize; /* round up to next multiple of 16K */ lisp_alloc_$gc_blk_cntr = - divide(24 + divide(num_words_to_gc_at - total_allocation + 1023, 1024, 35, 0), 16, 35, 0); end set_gc_blk_cntr; /** entry to be called after the gc parameters have been changed **/ set_gc_params: entry; /* compute the value of total_allocation, then call above subroutine */ call compute_total_allocation; call set_gc_blk_cntr; return; compute_total_allocation: proc; total_allocation = 0; do curseg = lisp_alloc_$cur_seg repeat (curseg -> alloc_segment.next_seg) while (curseg ^= null); total_allocation = total_allocation + fixed(curseg -> alloc_segment.tally_word.seg_offset, 18); end; end compute_total_allocation; /*compute_array_size: procedure; /* /* size = 1; /* compute size of array */ /* do left = -(allocptr -> array_info.ndims) by 1 while(left < 0); /* size = size * allocptr -> array_info.array_data_ptr -> array_data.dope_vector(left+1).bounds; /* end; /*end compute_array_size;*/ end lisp_garbage_collector_;  lisp_io_control_.pl1 07/06/83 0937.0r w 06/29/83 1542.3 547182 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_io_control_: procedure; /* * This module contains the central core of the new LISP I/O System. * This includes the lisp functions openi, openo, close, rename, deletef, and mergef, * as well as several subroutines that are called by other lisp * functions and by the garbage collector, saver, booter, etc. * * Written March, 1973 by D.A.Moon * modified 73.10.25 by DAM for new iochan format * modified 74.05.14 by DAM for EIS, and to not suspend acl on output files. * instead, the fact that msf_manager_ gives access if it creates the file is relied upon * thus iochan.aclinfop is no longer used * modified 74.09.21 by DAM to accept t for tty as well as nil * modified 74.12.20 by DAM for new 'open' function * modified 78.05.18 by BSG for 256-char mode string * modified 81.02.25 by PCK to use mode_string_$get_mode to parse mode strings and for 512-char mode string * modified 1982.10.05 by Richard Lamson to add (includef ...) */ /********************************************** The i/o system operates with file objects, which are lisp objects pointed at by a pointer with the 'File' type bit turned on. The format of a file object is declared as the structure 'iochan.' An iochan is created when a file is "opened," and effectively destroyed when it is "closed." Some of the information in the iochan is used by this module to interface with the Multics file system, multi-segment file manager, and i/o switch. Other information is used by the other i/o modules to control formatting, e-o-f handling, etc. All files are divided into "blocks," which are either one segment of a multi-segment file or one buffer-load of a stream. The beginning of a block is pointed at by iochan.ioptr, and iochan.ioindex is used as the character position within the block. The length of the block, in characters is kept in iochan.iolength. When the end of a block is reached, lisp_io_control_$end_of_block is invoked by one of the lisp i/o functions to advance to the next block. The other entry points in this module are concerned with exceptional conditions such as creation and destruction of iochans (open/close), garbage collection, saving, and file system errors. **********************************************/ declare addr builtin, reverse builtin, addrel builtin, 1 amv like mode_value aligned, /* Automatic storage for mode_value structure */ bc fixed bin(24), /* bit count */ binary builtin, buffer_size fixed bin static init(256), /* number o chars in a stream buffer */ code fixed bin(35), /* status return code */ codde fixed bin, com_err_ ext entry options(variable), delete_$path ext entry (char(*), char(*), bit(6), char(*), fixed bin(35)), divide builtin, dname char(168), /* directory pathname of file being opened */ ename char(36) varying, /* place to suffix_cs up the entryname of the file being opened */ err fixed bin(35), /* lisp error code, used by int proc error */ error_table_$end_of_info ext fixed bin(35), error_table_$long_record ext fixed bin(35), error_table_$dirseg external fixed bin(35), error_table_$no_space external fixed bin(35), /* used when eof bit is lit up for output stream */ error_table_$entlong external fixed bin(35), error_table_$noentry external fixed bin(35), esw fixed bin, /* entry switch controls error proc: >0 = fcn, 0 = save, <0 = internal subroutine */ expand_path_ ext entry(ptr, fixed bin, ptr, ptr, fixed bin(35)), find_include_file_$initiate_count entry(char(*)aligned, pointer, char(*)aligned, fixed bin(24), pointer, fixed bin(35)), get_wdir_ ext entry returns(char(168)), hcs_$chname_file ext entry (char(*), char(*), char(*), char(*), fixed bin(35)), hcs_$fs_get_path_name ext entry (pointer, char(*), fixed bin, char(*), fixed bin(35)), hcs_$get_max_length_seg ext entry (pointer, fixed bin(19), fixed bin(35)), hcs_$status_minf ext entry (char(*), char(*), fixed bin, fixed bin, fixed bin(24), fixed bin(35)), i fixed bin, index builtin, infile fixed bin(71) def (lisp_static_vars_$infile), instack fixed bin(71) def (lisp_static_vars_$instack), iox_$modes entry(ptr, char(*), char(*), fixed bin(35)), iox_$get_line entry(ptr, ptr, fixed bin(24), fixed bin(24), fixed bin(35)), iox_$get_chars entry(ptr, ptr, fixed bin(24), fixed bin(24), fixed bin(35)), iox_$control entry(ptr, char(*), ptr, fixed bin(35)), iox_$put_chars entry(ptr, ptr, fixed bin(24), fixed bin(35)), iox_$look_iocb entry(char(*), ptr, fixed bin(35)), j fixed bin, length builtin, lisp_$apply entry, lisp_get_atom_ entry(char(*) aligned, fixed bin(71)), lisp_io_control_$close entry, /* recurse to close iochan on eof */ lisp_io_fns_$inpush entry, lisp_io_fns_$internal_namelist entry(fixed bin), lisp_list_utils_$nreverse entry, lisp_reader_$maknam entry, lisp_print_$exploden entry, lisp_special_fns_$cons entry, lisp_special_fns_$xcons entry, lisp_static_vars_$STAR fixed bin(71) external, lisp_static_vars_$close fixed bin(71) external, lisp_static_vars_$deletef fixed bin(71) external, lisp_static_vars_$infile fixed bin(71) external, lisp_static_vars_$instack fixed bin(71) external, lisp_static_vars_$mergef fixed bin(71) external, lisp_static_vars_$old_io_defaults external pointer, lisp_static_vars_$open fixed bin(71) external, lisp_static_vars_$outfile fixed bin(71) external, lisp_static_vars_$outfiles fixed bin(71) external, lisp_static_vars_$rdr_label external label, lisp_static_vars_$rdr_ptr external pointer, lisp_static_vars_$rdr_state external fixed binary, lisp_static_vars_$rename fixed bin(71) external, lisp_static_vars_$stream fixed bin(71) external, lisp_static_man_$allocate entry(pointer, fixed bin(18)), maxlen fixed bin(19), /* maximum - length attrib */ min builtin, mode_string_$get_mode entry (char(*), char(*), ptr, fixed bin(35)), msf_manager_$adjust ext entry (ptr, fixed bin, fixed bin(24), bit(3) aligned, fixed bin(35)), msf_manager_$get_ptr ext entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(24), fixed bin(35)), msf_manager_$open entry(char(*), char(*), pointer, fixed bin(35)), msf_manager_$close entry(pointer), myname fixed bin, /* fn_ code for function entry point */ nargs fixed bin, /* number of args to mergef */ null builtin, other_ename char(32), /* for rename */ outfiles fixed bin(71) def (lisp_static_vars_$outfiles), p ptr, /* points at iochan currently being processed */ p2 ptr, p_fb fixed bin(71) aligned based(addr(p)), ptr builtin, q ptr, rdr_label label def(lisp_static_vars_$rdr_label), rdr_ptr pointer def(lisp_static_vars_$rdr_ptr), rdr_state fixed bin def(lisp_static_vars_$rdr_state), rel builtin, rnstack ptr, /* orig value of 'stack,' used by rename */ size builtin, stack ptr, star fixed bin(71) def (lisp_static_vars_$STAR), status fixed bin(35) aligned, stream fixed bin(71) def (lisp_static_vars_$stream), string builtin, substr builtin, type fixed bin, /* return arg of hcs_$status_minf */ user_io_modes char(512), verify builtin; /* based overlay for setting the type bits of the pointer p so that it can be put in the marked pdl as a file object */ dcl 1 p_ aligned based(addr(p)) like lisp_ptr; /* Variables used by open */ dcl direction fixed bin, (In init(0), Out init(1), Append init(2)) fixed bin static; dcl data_mode fixed bin, (Ascii init(0), Fixnum init(1), Image init(2)) fixed bin static; dcl buffer_mode fixed bin, (Block init(0), Single init(1)) fixed bin static; dcl device_type fixed bin, (Ordinary init(0), Terminal init(1)) fixed bin static; dcl openx_sim_arg char(8) aligned; /* "read", "print", or "append" */ /* Error Codes */ dcl (lisp_error_table_$bad_item_in_modelist, lisp_error_table_$reopen_inconsistent, lisp_error_table_$io_wrong_direction, lisp_error_table_$file_is_closed, lisp_error_table_$file_sys_fun_err, lisp_error_table_$stars_left_in_name, lisp_error_table_$bad_arg_correctable, lisp_error_table_$bad_entry_name, lisp_error_table_$include_file_error) fixed bin external; %include lisp_common_vars; %include lisp_stack_fmt; %include lisp_io; %include lisp_name_codes; %include lisp_ptr_fmt; %include lisp_nums; %include lisp_cons_fmt; %include lisp_atom_fmt; %include lisp_string_fmt; %include mode_string_info; /* * The three lisp lsubrs for opening files (creating iochans). */ openi: entry; myname = fn_openi; openx_sim_arg = "read"; go to openx; openo: entry; myname = fn_openo; openx_sim_arg = "print"; go to openx; opena: entry; myname = fn_opena; openx_sim_arg = "append"; openx: esw = 1; stack = addrel(stack_ptr,-2); /* get argument */ call set_mode_defaults; call modelist_process(openx_sim_arg); /* get proper mode */ go to open_stuff; /* * General 'open' entry */ open: entry; myname = fn_open; esw = 2; stack = addrel(stack_ptr, -2); nargs = stack -> fixedb; /* lsubr */ stack = addrel(stack, nargs); if nargs = 0 then stack -> temp(1) = tty_output_chan -> iochan.namelist; /* default names */ else if nargs <= -4 then do; /* process modelist */ do while(stack -> temp_type(2) = Cons); call modelist_object(stack -> temp_ptr(2) -> cons.car); stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; end; if stack -> temp(2) ^= nil then call modelist_object(stack -> temp(2)); end; open_stuff: /* * create an iochan block in static storage, then initialize it from the defaults */ if stack -> temp_type36(1) & File36 then do; /* re-open file */ p = stack -> temp_ptr(1); go to gc_close; /* get the file closed */ open_close_ret: call init_an_iochan; end; else call make_an_iochan; stack_ptr = addr(stack -> temp(3)); stack -> temp(2) = tty_output_chan -> iochan.namelist; /* get the defaults */ nargs = 2; if stack -> temp_type36(1) & File36 /* if file passed in, now have it in p so */ then stack -> temp(1) = p -> iochan.namelist; /* substitute its namelist */ call umergef; /* merge arg with defaults, do err checking and all good things */ p -> iochan.charpos, p -> iochan.linenum, p -> iochan.pagenum = 0; /* set linel, pagel from device characteristics */ p -> iochan.pagel = 59; /* random constant for Multics */ p -> iochan.linel = 110; /* another random constant, for all but tty */ /* set eoffn or endpagefn from default */ if direction = In then p -> iochan.function = tty_input_chan -> iochan.function; /* default eoffn */ else p -> iochan.function = tty_output_chan -> iochan.function; /* default endpagefn */ p -> iochan.namelist = stack -> temp(1); /* namelist gotten by umergef */ if direction = In then p -> iochan.write = "1"b; /* input chan - leave .read 0 */ else p -> iochan.read = "1"b; /* output chan - leave .write 0 */ /* * decide whether this is a stream or a file, and apply appropriate special open code */ if stack -> temp_ptr(1) -> cons.car = stream then do; /* namelist specifies stream */ p -> iochan.name = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons_ptrs.car -> atom.pname; /* stream name is cadr of namelist */ call lisp_static_man_$allocate(p -> iochan.ioptr, divide(buffer_size, 4, 18, 0)); if direction = In then p -> iochan.iolength = 0; else if data_mode = Fixnum then p -> iochan.iolength = divide(buffer_size, 4, 24, 0); else p -> iochan.iolength = buffer_size; /* output or append */ p -> iochan.aclinfop = null; /* not used for stream */ call iox_$look_iocb(p->iochan.name, p -> iochan.fcbp, code); if code ^= 0 then go to file_sys_fun_err_; end; /* if stream not attached, we'll find out when we try to use it */ else do; /* it's a file (msf), get dname and ename and call msf_manager_ */ call get_path_name; if direction = In then /* input file, easiest to open */ call open_input_file; else if direction = Out then do; /* output file, open, create, set up first seg */ call open_output_file; opena_new: call get_output_seg_ptr; end; else do; /* opena - append output to prev existing seg */ call open_output_file; /* now find last seg */ call hcs_$status_minf(dname, p -> iochan.name, 1, type, bc, code); /* code must be 0!! */ if code ^= 0 then go to opena_new; /* it's not there yet */ if type = 2 then p -> iochan.component = bc-1; /* if msf, set to last component */ call get_output_seg_ptr; /* get ptr to and bc of last seg */ if data_mode = Fixnum then p -> iochan.ioindex = min(divide(bc, 36, 24, 0), /* and set posn to append to what is there */ p -> iochan.iolength); else p -> iochan.ioindex = min(divide(bc, 9, 24, 0), /* and set posn to append to what is there */ p -> iochan.iolength); end; end; /* * Set miscellaneous attributes in the iochan */ if data_mode = Fixnum then p -> iochan.fixnum_mode = "1"b; else if data_mode = Image then p -> iochan.image_mode = "1"b; if buffer_mode = Single then p -> iochan.charmode = "1"b; if device_type = Terminal then p -> iochan.interactive = "1"b; /* * iochan has been successfully created * so link it onto threaded list of all chans * if an interrupt occurs at the wrong time here, the lossage won't be * sufficiently bad to justify worrying */ p -> iochan.thread = lisp_static_vars_$iochan_list; lisp_static_vars_$iochan_list = p; /* * All done, turn on type bit for file and return */ p_.type = File; stack -> temp(1) = p_fb; exit: stack_ptr = addr(stack -> temp(2)); return; /* * Internal procedure to set defaults for modelist */ set_mode_defaults: procedure; dcl p pointer; if stack -> temp_type36(1) & File36 then do; /* use prior attributes of file */ p = stack -> temp_ptr(1); if p -> iochan.read then direction = Out; else direction = In; if p -> iochan.fixnum_mode then data_mode = Fixnum; else if p -> iochan.image_mode then data_mode = Image; else data_mode = Ascii; if p -> iochan.charmode then buffer_mode = Single; else buffer_mode = Block; if p -> iochan.interactive then device_type = Terminal; else device_type = Ordinary; end; else do; /* standard defaults */ direction = In; data_mode = Ascii; buffer_mode = Block; device_type = Ordinary; end; end; /* * Internal procedure to process one modelist entry */ modelist_process: procedure(item); dcl item char(*) aligned; if item = "in" then direction = In; else if item = "read" then direction = In; else if item = "out" then direction = Out; else if item = "print" then direction = Out; else if item = "append" then direction = Append; else if item = "ascii" then data_mode = Ascii; else if item = "fixnum" then data_mode = Fixnum; else if item = "image" then data_mode = Image; else if item = "dsk" then device_type = Ordinary; else if item = "tty" then device_type = Terminal; else if item = "block" then buffer_mode = Block; else if item = "single" then buffer_mode = Single; else err = lisp_error_table_$bad_item_in_modelist; /* caller sees */ end; /* * Internal procedure to process an object in the modelist */ modelist_object: procedure(a_object); dcl a_object fixed bin(71), object fixed bin(71) init(a_object), object_type bit(36) aligned based(addr(object)), tsp pointer; retry: err = 0; if object_type & Atsym36 then call modelist_process(addr(object)-> based_ptr -> atom.pname); else if object_type & String36 then call modelist_process(addr(object)-> based_ptr -> lisp_string.string); else err = lisp_error_table_$bad_item_in_modelist; if err = 0 then return; /* won */ tsp = stack_ptr; /* otherwise fail correctably */ stack_ptr = addr(tsp -> temp(2)); tsp -> temp(1) = object; call error; object = tsp -> temp(1); stack_ptr = tsp; go to retry; end; /* * Internal procedure to make an iochan block and do first initialization */ make_an_iochan: proc; call lisp_static_man_$allocate(p, size(iochan)); init_an_iochan: entry; p -> iochan.component, p -> iochan.ioindex = 0; string(p -> iochan.flags) = ""b; /* clear all flags in the iochan */ end; /* * Internal procedure to get dir path name and entry name from name list */ get_path_name: proc; p -> iochan.seg = "1"b; call get_path_name_0; p -> iochan.name = substr(ename, 1, length(ename)-1); /* drop last period */ return; end; get_path_name_0: proc; dcl tsp ptr; /* have to avoid munging stack -> temp(1) */ tsp = stack_ptr; stack_ptr = addr(tsp -> temp(2)); tsp -> temp(1) = stack -> temp(1); try_again: dname = tsp -> temp_ptr(1) -> cons_ptrs.car -> atom.pname; /* dir pn is car of namelist */ ename = ""; /* concatenate up ename from list of names, */ do /* in cdr of namelist */ tsp -> temp(1) = tsp -> temp_ptr(1) -> cons.cdr repeat (tsp -> temp_ptr(1) -> cons.cdr) while (tsp -> temp_type(1) = Cons); ename = ename || tsp -> temp_ptr(1) -> cons_ptrs.car -> atom.pname || "."; end; if length(ename) = 0 then go to bad_ename; /* lose if no names */ else if length(ename) >= 34 then go to bad_ename; /* or name longer than 32 chars (+1 for last ".") */ stack_ptr = tsp; return; bad_ename: /* give a wrng-type-arg on the name list if the entry name is no good (too long or short) */ err = lisp_error_table_$bad_entry_name; call error; go to try_again; end; /* * Internal procedure to open an input seg, set up iochan block to point to it */ open_input_file: proc; call msf_manager_$open(dname, p -> iochan.name, p -> iochan.fcbp, code); if code ^= 0 then do; /* file not found or other lossage */ fs_loss_close_maybe: if code ^= error_table_$dirseg then fs_loss_close_it: call close_msf; /* flush FCB */ go to file_sys_fun_err_; /* give a fail-act */ end; p -> iochan.aclinfop = null; /* set up ptr to first seg of file */ call msf_manager_$get_ptr(p -> iochan.fcbp, p -> iochan.component, /* or current comp if reopen */ "0"b, p -> iochan.ioptr, bc, code); if p -> iochan.ioptr = null then go to fs_loss_close_it; /* can't really open, we don't have access */ if data_mode = Fixnum then p -> iochan.iolength = divide(bc, 36, 24, 0); /* get word count from bit count */ else p -> iochan.iolength = divide(bc, 9, 24, 0); /* get char count from bit count */ return; /* * Internal procedure to open an output file, saving acl and setting access to rwa */ open_output_file: entry; call msf_manager_$open(dname, p -> iochan.name, p -> iochan.fcbp, code); if p -> iochan.fcbp = null then go to fs_loss_close_maybe; return; /* * Internal proc to get ptr to a component of an output msf */ get_output_seg_ptr: entry; /* now get ptr to first seg */ call msf_manager_$get_ptr(p -> iochan.fcbp, p -> iochan.component, "1"b, p -> iochan.ioptr, bc, code); if p -> iochan.ioptr = null then go to fs_loss_close_it; /* couldn't create the seg, go clean and barf */ /* set iochan.iolength from the maximum length attribute of the seg */ call hcs_$get_max_length_seg(p -> iochan.ioptr, maxlen, code); if code ^= 0 then go to fs_loss_close_it; /* !!! */ if data_mode = Fixnum then p -> iochan.iolength = maxlen; else p -> iochan.iolength = maxlen*4; /* number of chars before o.o.b. fault */ return; end open_input_file; /* * lisp close subr - closes the file and gets rid of the iochan * does not detach streams since open does not attach them */ close: entry; esw = 4; stack = addrel(stack_ptr, -2); /* get arg */ myname = fn_close; do while (^ stack -> temp_type36(1) & File36); err = lisp_error_table_$bad_arg_correctable; call error; end; /* garbage collector joins here */ p = stack -> temp_ptr(1); gc_close: if (string(p -> iochan.flags) & "011"b) ^= "011"b then do; /* if not already closed */ if p -> iochan.seg then if ^ p -> iochan.read then /* input file, just close the FCB */ call close_msf; else call close_output_file; else /* a stream: flush buffer if output, but don't have to do anything else */ if ^ p -> iochan.write then call dump_buffer; end; if esw < 0 then go to gc_close_1; /* skip this if gc_flush entry */ /* * as far as the Multics environment is concerned, the iochan is closed * but there are still some things left to do in the lisp environment */ /* (setq instack (delq p instack)) */ stack_ptr = addr(stack -> temp(5)); stack -> temp(2), stack -> temp(3) = addr(instack) -> based_ptr -> atom.value; do while (stack -> temp_type(3) = Cons); if stack -> temp_ptr(3) -> cons.car = stack -> temp(1) /* p appears in the list */ then if stack -> temp(2) = stack -> temp(3) /* first in list is special case */ then stack -> temp(2) = stack -> temp_ptr(3) -> cons.cdr; else stack -> temp_ptr(4) -> cons.cdr = /* if not first in list, rplacd it out */ stack -> temp_ptr(3) -> cons.cdr; stack -> temp(4) = stack -> temp(3); stack -> temp(3) = stack -> temp_ptr(3) -> cons.cdr; end; addr(instack) -> based_ptr -> atom.value = stack -> temp(2); /* (and (eq p infile) (inpush -1)) */ if stack -> temp(1) = addr(infile) -> based_ptr -> atom.value then do; /* if addr(instack)-> based_ptr -> atom_types.value = Cons */ if addr(instack)-> based_ptr -> lisp_ptr.type = Cons then addr(infile) -> based_ptr -> atom.value = addr(instack) -> based_ptr -> atom_ptrs.value -> cons.car; else addr(infile)-> based_ptr -> atom.value = t_atom; /* empty list -> tty */ if addr(instack) -> based_ptr -> atom.value ^= nil then addr(instack) -> based_ptr -> atom.value = addr(instack) -> based_ptr -> atom_ptrs.value -> cons.cdr; end; if addr(infile) -> based_ptr -> atom.value = nil | addr(infile) -> based_ptr -> atom.value = t_atom then addr(ctrlQ) -> based_ptr -> atom.value = nil; /* (setq outfiles (delq p outfiles)) */ stack -> temp(2), stack -> temp(3) = addr(outfiles) -> based_ptr -> atom.value; do while (stack -> temp_type(3) = Cons); if stack -> temp_ptr(3) -> cons.car = stack -> temp(1) /* p appears in the list */ then if stack -> temp(2) = stack -> temp(3) /* first in list is special case */ then stack -> temp(2) = stack -> temp_ptr(3) -> cons.cdr; else stack -> temp_ptr(4) -> cons.cdr = /* if not first in list, rplacd it out */ stack -> temp_ptr(3) -> cons.cdr; stack -> temp(4) = stack -> temp(3); stack -> temp(3) = stack -> temp_ptr(3) -> cons.cdr; end; addr(outfiles) -> based_ptr -> atom.value = stack -> temp(2); if stack -> temp(2) = nil then addr(ctrlR) -> based_ptr -> atom.value = nil; /* * Mark iochan closed by setting both read and write */ gc_close_1: p -> iochan.read, p -> iochan.write = "1"b; /* * unthread from system's iochan list */ errtn(-1): /* error return from lisp_io_control_$gc_flush -- unthread so error doesn't occur every gc */ if lisp_static_vars_$iochan_list = p then lisp_static_vars_$iochan_list = p -> iochan.thread; else do q = lisp_static_vars_$iochan_list repeat (q -> iochan.thread) while (q ^= null); if q -> iochan.thread = p then do; q -> iochan.thread = p -> iochan.thread; go to exit_t; end; end; /* if we normal-exit this loop, was weird err but who cares? */ /* * all done closing, so return * value of close is t instead of argument because argument is no longer a valid file object */ exit_t: if esw < 0 then do; /* return from gc_flush entry */ stack_ptr = stack; return; end; else if esw < 3 then go to open_close_ret; stack -> temp(1) = t_atom; go to exit; /* * garbage collector calls this entry when it finds an unreachable iochan * unless it is one of the tty iochans, it is automatically closed */ gc_flush: entry (a_iochan); esw = -1; myname = 0; stack = stack_ptr; p = a_iochan; if p -> iochan.seg then if p -> iochan.fcbp = null then return; /* already been flushed so don't try to flush it again - interaction with saver */ go to gc_close; close_msf: procedure; if p -> iochan.fcbp ^= null() then call msf_manager_$close(p -> iochan.fcbp); p -> iochan.fcbp = null(); end; close_output_file: procedure; /* Set bit count on output file and close fcb */ if p -> iochan.fcbp ^= null() then do; if p -> iochan.fixnum_mode /* cv words to chars */ then p -> iochan.ioindex = p -> iochan.ioindex*4; call msf_manager_$adjust(p -> iochan.fcbp, p -> iochan.component, p -> iochan.ioindex*9, "111"b, code); if code ^= 0 then go to file_sys_fun_err_; call msf_manager_$close (p -> iochan.fcbp); p->iochan.fcbp = null(); end; end close_output_file; /* * This entry is called by reader or printer when an iochan has flags that say it is not OK to use * * This could be due to: * 1) I/O in wrong direction * 2) iochan has been closed * 3) the lisp environment has been saved and this file needs to be re-opened * This routine identifies the cause of the problem and fixes it or signals a fail-act */ fix_not_ok_iochan: entry(a_iochan, intended_dir, fail_act_f); dcl intended_dir bit(1) aligned parameter, /* 1 = out, 0 = in */ fail_act_f bit(1) aligned parameter; /* returned 1 if fail-act occurred */ esw = -2; stack = stack_ptr; fail_act_f = "0"b; if intended_dir = "1"b then myname = fn_openo; else myname = fn_openi; p = a_iochan; if p -> iochan.fixnum_mode then data_mode = Fixnum; else data_mode = Ascii; /* may be needed below */ if p -> iochan.must_reopen then /* we unsave the iochan only now, not in lisp_unsave_, because it is only now that the use has demonstrated that he still wants to use this iochan. */ if p -> iochan.seg then do; stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = p -> iochan.namelist; /* re-open with same name as before */ call get_path_name; if ^ p -> iochan.read then call open_input_file; else do; call open_output_file; call msf_manager_$get_ptr(p -> iochan.fcbp, /* get seg to which we were last outputting */ p -> iochan.component, "0"b, /* but don't try to create it if it has gone */ p -> iochan.ioptr, 0, code); if p -> iochan.ioptr = null then go to file_sys_fun_err_; end; /* the component number and char position are set from before, just check that the file has not gotten shorter somehow */ if p -> iochan.ioindex > p -> iochan.iolength then do; call close_msf; go to reopen_inconsistent_; end; p -> iochan.must_reopen = "0"b; return; end; else do; /* reopening a stream, have to get a new buffer */ call lisp_static_man_$allocate(p -> iochan.ioptr, divide(buffer_size, 4, 18, 0)); p -> iochan.must_reopen = "0"b; return; end; else if (string(p -> iochan.flags) & "011"b) = "011"b then do; /* file has been closed! */ go to iochan_has_been_closed_; end; else do; go to io_wrong_direction_; end; /* * Entry to make all iochans saveable - called near the beginning of the save process */ set_for_save: entry; esw = 0; do p = lisp_static_vars_$iochan_list repeat (p -> iochan.thread) while (p ^= null); if p -> iochan.seg then /* streams are no problem since user has to reattach them */ if ^(p -> iochan.read & p -> iochan.write) /* if still open */ then if p -> iochan.must_reopen then; /* already saved from before */ else do; if ^p -> iochan.read then call close_msf; /* close input file */ else call close_output_file; set_for_save_err_ret: p -> iochan.ioptr, p -> iochan.fcbp, p -> iochan.aclinfop = null; end; else; /* already closed - no action */ else do; p -> iochan.ioptr = null; /* flush the buffer (completely) */ p -> iochan.ioindex = 0; p -> iochan.nlsync = "0"b; if ^p -> iochan.read then p -> iochan.iolength = 0; p->iochan.fcbp = null(); end; p -> iochan.must_reopen = "1"b; /* so fix_not_ok_iochan will get called on next reference */ end; return; /* * lisp_io_control_$boot called at environment-boot time to set up the two initial * files, tty_input_chan and tty_output_chan. These are handled slightly * differently from other files in some respets, so they have their * interactive flag turned on. Fortunately no errors can occur here. */ boot: entry; call make_an_iochan; /* tty_input_chan first */ tty_input_chan = p; p -> iochan.write = "1"b; /* input chan, leave flags.read = 0 */ p -> iochan.interactive = "1"b; p -> iochan.name = "user_input"; call lisp_static_man_$allocate(p -> iochan.ioptr, divide(buffer_size, 4, 18, 0)); p -> iochan.iolength = 0; call iox_$look_iocb(p->iochan.name, p->iochan.fcbp, code); p -> iochan.aclinfop, p -> iochan.thread = null; p -> iochan.function = nil; /* default eoffn */ p -> iochan.pagel = 0; /* page length for non-display tty's (no 'pl' mode) is infinite */ p -> iochan.linel = 70; /* default line length for tty's */ p -> iochan.charpos, p -> iochan.linenum, p -> iochan.pagenum = 0; p -> iochan.namelist = nil; /* not ever used */ q = p; call make_an_iochan; tty_output_chan = p; p -> iochan.read = "1"b; p -> iochan.interactive ="1"b; p -> iochan.charmode = "1"b; p -> iochan.name = "user_output"; call lisp_static_man_$allocate(p -> iochan.ioptr, divide(buffer_size, 4, 18, 0)); p -> iochan.iolength = buffer_size; p -> iochan.charpos, p -> iochan.linenum, p -> iochan.pagenum = 0; p -> iochan.pagel = q -> iochan.pagel; p -> iochan.linel = q -> iochan.linel; p -> iochan.function = nil; /* default endpagefn */ /* p -> iochan.namelist will get set soon by init entry */ call iox_$look_iocb(p->iochan.name, p->iochan.fcbp, code); p -> iochan.aclinfop = null; p -> iochan.thread = q; addr(p -> iochan.thread)->lisp_ptr.type = File; /* turn on type bit */ lisp_static_vars_$iochan_list = p; addr(lisp_static_vars_$iochan_list)->lisp_ptr.type, /* turn on type bits since these ptrs are gc'ed */ addr(lisp_static_vars_$tty_input_chan)->lisp_ptr.type, addr(lisp_static_vars_$tty_output_chan)->lisp_ptr.type = File; /* initialize the variables ^q, ^r, ^w, infile, outfiles */ addr(ctrlQ)->based_ptr -> atom.value, addr(ctrlR)->based_ptr -> atom.value, addr(ctrlW)->based_ptr -> atom.value, addr(instack)->based_ptr -> atom.value, addr(outfiles)->based_ptr -> atom.value = nil; addr(infile)->based_ptr -> atom.value = t_atom; return; /* * Routine to dump buffer of output stream. p -> iochan. */ dump_buffer: proc; if p->iochan.ioindex = 0 then do; p -> iochan.nlsync = "0"b; return; end; /* bugs in various io modules */ if p->iochan.fcbp = null() then call get_iocb; if p->iochan.fixnum_mode then p->iochan.ioindex = 4*p->iochan.ioindex; call iox_$put_chars(p->iochan.fcbp, p->iochan.ioptr, p->iochan.ioindex, code); if code ^= 0 then go to file_sys_fun_err_; p -> iochan.ioindex = 0; /* the buffer is now empty */ p -> iochan.nlsync = "0"b; /* .. */ end dump_buffer; get_iocb: procedure; call iox_$look_iocb(p -> iochan.name, p -> iochan.fcbp, status); if status ^= 0 then do; code = status; go to file_sys_fun_err_; end; end get_iocb; /* * Entry to empty all buffers of all output streams */ empty_all_buffers: entry; esw = -4; do p = lisp_static_vars_$iochan_list repeat (p -> iochan.thread) while (p ^= null); if ^ p -> iochan.seg then if ^ p -> iochan.write /* open output stream */ then call dump_buffer; empty_all_err_ret: end; return; /* * Initialize entry */ init: entry; /* initialize default namelist to (working-dir . *) */ dname = get_wdir_(); i = length(dname) + 1 - verify(reverse(dname), " "); stack = stack_ptr; stack_ptr = addr(stack -> temp(3)); call lisp_get_atom_(substr(dname, 1, i), stack -> temp(1)); stack -> temp(2) = star; call lisp_special_fns_$cons; tty_output_chan -> iochan.namelist = stack -> temp(1); stack_ptr = stack; /* get the real pagel and linel for the tty from the DIM */ tty_input_chan -> iochan.charpos, tty_output_chan -> iochan.charpos = 0; /* also resetting all this cruft */ tty_input_chan -> iochan.linenum, tty_output_chan -> iochan.linenum = 0; tty_input_chan -> iochan.pagenum, tty_output_chan -> iochan.pagenum = 0; tty_input_chan -> iochan.pagel, tty_output_chan -> iochan.pagel = 0; tty_input_chan -> iochan.linel, tty_output_chan -> iochan.linel = 80; /* default should be 0 but for sake of Macsyma, ... */ call iox_$look_iocb(tty_output_chan->iochan.name, tty_output_chan->iochan.fcbp, status); if status ^= 0 then go to no_modes_available; call iox_$modes(tty_output_chan->iochan.fcbp, "", user_io_modes, status); if status ^= 0 then go to no_modes_available; /* Extract line length and page length from mode string if possible */ mode_value_ptr = addr (amv); mode_value_ptr -> mode_value.version = mode_value_version_3; mode_value_ptr -> mode_value.flags = "0"b; call mode_string_$get_mode (user_io_modes,"ll",mode_value_ptr,status); if status = 0 then if mode_value_ptr -> mode_value.numeric_valuep then tty_input_chan -> iochan.linel,tty_output_chan -> iochan.linel = mode_value_ptr -> mode_value.numeric_value; mode_value_ptr -> mode_value.flags = "0"b; call mode_string_$get_mode (user_io_modes,"pl",mode_value_ptr,status); if status = 0 then if mode_value_ptr -> mode_value.numeric_valuep then tty_input_chan -> iochan.pagel,tty_output_chan -> iochan.pagel = mode_value_ptr -> mode_value.numeric_value; /* flush tty buffers */ no_modes_available: tty_input_chan -> iochan.ioindex, tty_input_chan -> iochan.iolength = 0; tty_output_chan -> iochan.ioindex = 0; /* make uread, etc. default to working dir */ lisp_static_vars_$old_io_defaults -> atom.value = nil; return; /* * Called by other i/o functions when the end of a block (stream buffer or m.s.f. segment) * is reached on either input or output. All good things are done, including handling * of end-of-file. A return code is passed to the caller to tell him what action was taken. */ end_of_block: entry (a_iochan, eofval, cde); dcl a_iochan ptr, eofval fixed bin(71) /* a lisp object */, cde fixed bin; /* cde = 0 --> OK 1 --> eof - continue reading 2 --> eof - return eofval immediately (used for fail-act's too) -1 --> select new input file -2 --> error - must select new file. bad_input_source or bad_output_dest err has been done */ esw = -3; cde = 0; /* assuming eof or err is not going to happen */ p = a_iochan; if ^ p -> iochan.write then if p -> iochan.seg then do; /* end of seg on output msf, call msf manager to get next seg */ p -> iochan.component = p -> iochan.component + 1; call get_output_seg_ptr; p -> iochan.ioindex = 0; /* start at beginning of this seg */ end; else call dump_buffer; /* Buffer full on stream - dump it */ else if p -> iochan.seg then do; /* End of input seg, try to get another one from msf manager */ p -> iochan.component = p -> iochan.component + 1; call msf_manager_$get_ptr(p -> iochan.fcbp, p -> iochan.component, "0"b, p -> iochan.ioptr, bc, code); p -> iochan.ioindex, p -> iochan.iolength = 0; if p -> iochan.ioptr = null /* Error return */ then if code = error_table_$noentry then go to E_O_F; else go to file_sys_fun_err_; /* LOSE!! */ if p -> iochan.fixnum_mode then p -> iochan.iolength = divide(bc, 36, 24, 0); else p -> iochan.iolength = divide(bc, 9, 24, 0); end; else do; /* End of stream buffer, call iox_$read */ p -> iochan.ioindex, p -> iochan.iolength = 0; if p->iochan.fcbp = null() then call get_iocb; if p -> iochan.interactive then do; /* tty_input_chan, flush tty_output_chan (before going blocked) */ q = p; p = tty_output_chan; call dump_buffer; p -> iochan.charpos = 0; /* tty is now at left margin */ p = q; /* fix up rdr state stuff so quit while blocked in iox_$read will work right */ rdr_label = input_wait_ab_exit; rdr_state = 1; end; if p->iochan.fixnum_mode then do; call iox_$get_chars(p->iochan.fcbp, p->iochan.ioptr, (buffer_size), p->iochan.iolength, code); p->iochan.iolength = divide(p->iochan.iolength+3,4,24,0); end; else call iox_$get_line(p->iochan.fcbp, p->iochan.ioptr, (buffer_size), p->iochan.iolength, code); rdr_state = 0; /* check status for eof, err */ if code ^= 0 then if code = error_table_$end_of_info then goto E_O_F; else if code = error_table_$long_record then return; else goto file_sys_fun_err_; else return; /* come here if some kind of quit while blocked on user_input. Return a code -1 to tell the caller to check whether he wants to input from a different file now */ input_wait_ab_exit: rdr_state = 0; cde = -1; return; end; return; /* successfully got next block, continue the i/o operation */ /* END OF FILE HANDLING * * come here with p -> iochan, eofval = nil or arg to read, cde will be set to 1 or 2 */ E_O_F: if eofval = t_atom then go to eof_imm_ret; /* this is tyipeek - don't use the eoffn */ if p -> iochan.function ^= nil then do; /* Call user's eof function, args = p, eofval */ stack = stack_ptr; stack_ptr = addr(stack -> temp(5)); stack -> temp(4) = nil; /* cons up arg list for apply */ stack -> temp(3) = eofval; p_.type = File; stack -> temp(2) = p_fb; stack -> temp(1) = p -> iochan.function; call lisp_special_fns_$cons; call lisp_special_fns_$cons; call lisp_$apply; /* check the value returned by the eoffn */ if stack -> temp(1) = nil then go to eof_nil_1; else if stack -> temp(1) = t_atom then do; stack_ptr = stack; cde = 1; /* proceed, eoffn has done insel */ return; end; eofval = stack -> temp(1); /* force read to return what the eoffn retturned */ stack_ptr = stack; go to eof_imm_ret; end; else do; /* No eoffn -- default handling directed by eofval */ if eofval ^= nil then go to eof_imm_ret; /* if eofval supplied on call to read, return it */ eof_nil: /* no eofval - close this file and continue reading from the one selected by close */ stack = stack_ptr; stack_ptr = addr(stack -> temp(2)); eof_nil_1: p_.type = File; stack -> temp(1) = p_fb; call lisp_io_control_$close; cde = 1; return; eof_imm_ret: /* force read to return eofval immediately */ cde = 2; return; end; /* * Error Handling * * all errors (almost) come to these routines. The stack is fiddled * and lisp_error_ is called. What happens when lisp_error_ returns * and what is put on the stack as an argument to the fail-act routine * is determined by esw, the entry switch. */ /* routine to call lisp_error_ */ error: proc; dcl unm ptr, ercode(2) aligned based(unm) fixed bin, lisp_error_ entry; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); ercode(1) = err; ercode(2) = myname; call lisp_error_; end; /* * Funny errors in fix_not_ok_iochan */ reopen_inconsistent_: err = lisp_error_table_$reopen_inconsistent; stack_ptr = stack; go to inouterr1; io_wrong_direction_: err = lisp_error_table_$io_wrong_direction; go to inouterr; iochan_has_been_closed_: err = lisp_error_table_$file_is_closed; go to inouterr; inouterr: /* make list (infile x) or (outfile x) as arg to fail-act */ stack = stack_ptr; inouterr1: stack_ptr = addr(stack -> temp(4)); if p -> iochan.write then stack -> temp(1) = lisp_static_vars_$infile; else stack -> temp(1) = lisp_static_vars_$outfile; errproc_aa: /** other errors join here **/ stack -> temp(3) = nil; p_.type = File; stack -> temp(2) = p_fb; errproc_cc: /** and here **/ call lisp_special_fns_$cons; call lisp_special_fns_$cons; if esw = 7 then do; /* special kludgery for rename because it moves 'stack.' */ rnstack -> temp(1) = stack -> temp(1); stack = rnstack; stack_ptr = addrel(stack, 2); end; myname = code; /* fake out 'error' proc in case of file_sys_fun_err */ call error; go to errtn(esw); /* crawl out in entry-dependent way */ /* error exit for lisp_io_control_$fix_not_ok_iochan -- reflect to caller */ errtn(-2): if intended_dir = "1"b then addr(ctrlR)->based_ptr -> atom.value = t_atom; else addr(ctrlQ)->based_ptr -> atom.value = t_atom; stack_ptr = stack; fail_act_f = "1"b; return; /* value of fail-act has been pushed onto marked pdl */ errtn(-4): /* lisp_io_control_$empty_all_buffers - just continue in do loop */ stack_ptr = stack; go to empty_all_err_ret; errtn(-3): /* lisp_io_control_$end_of_block -- tell caller and give him value of the fail-act */ cde = -2; if ^ p -> iochan.read then addr(ctrlQ)->based_ptr -> atom.value = t_atom; if ^ p -> iochan.write then addr(ctrlR)->based_ptr -> atom.value = t_atom; stack_ptr = stack; return; /* lisp fcn entry points just return value of fail-act as their value */ errtn(7): errtn(1): errtn(2): errtn(3): errtn(5): errtn(4): errtn(6): stack_ptr = addr(stack -> temp(2)); return; /* * General file system errors come here * * We take a fail-act with args = a list of some fcn name and the file object * the action on return from the fail-act is controlled by esw * 'code' contains a Multics status code, from which the error message will be derived * myname is not used */ file_sys_fun_err_: err = lisp_error_table_$file_sys_fun_err; go to errproc(esw); /* set up stack, get name of fcn */ errproc(1): errproc(2): errproc(3): errproc(4): errproc(5): stack_ptr = addr(stack -> temp(4)); call get_fname; go to errproc_aa; errproc(7): /* cons up list of 'rename and both (processed) args */ stack_ptr = addr(stack -> temp(5)); stack -> temp(4) = nil; stack -> temp(3) = stack -> temp(2); stack -> temp(2) = stack -> temp(1); call get_fname; call lisp_special_fns_$cons; go to errproc_cc; errproc(0): /* lisp_io_control_$set_for_save *** the lisp error mechanism is not in operation, *** so barf through com_err_ and continue with our do loop */ call com_err_(code, "lisp_io_control_", "^/^-Trying to close and save file object ""^a"" at ^p", p -> iochan.name /* don't bother with full path name */, p); go to set_for_save_err_ret; errproc(-1): /* lisp_io_control_$gc_flush -- failed trying to auto-close */ call com_err_(code, "lisp_io_control_", "^/^-Trying to auto-close file object ""^a"" at ^p", p -> iochan.name, p); go to gc_close_1; /* just ignore the error, except for now print kludgey message */ errproc(-2): /* lisp_io_control_$fix_not_ok_iochan -- fcn name is infile or outfile */ if intended_dir = "1"b then addr(ctrlR)->based_ptr -> atom.value = nil; else addr(ctrlQ)->based_ptr -> atom.value = nil; go to inouterr1; errproc(-3): /* lisp_io_control_$end_of_block -- fcn name is again infile or outfile (still a hack) */ if ^ p -> iochan.read then addr(ctrlQ)->based_ptr -> atom.value = nil; if ^ p -> iochan.write then addr(ctrlR)->based_ptr -> atom.value = nil; go to inouterr; errproc(-4): /* lisp_io_control_$empty_all_buffers -- lisp error mechanism may not be working (quit or save), so just ignore the error and go on to the next buffer */ go to empty_all_err_ret; errproc(-5): /* lisp_io_control_$cleanup -- ignore the error completely (what else would you do?) */ go to cleanup_err_ret; /* * routine to put lisp atom qhich is name of function selected by esw into stack -> temp(1) -- used for errors */ get_fname: proc; go to gfn(esw); gfn(1): gfn(2): gfn(3): stack -> temp(1) = lisp_static_vars_$open; return; gfn(4): stack -> temp(1) = lisp_static_vars_$close; return; gfn(5): stack -> temp(1) = lisp_static_vars_$mergef; return; gfn(6): stack -> temp(1) = lisp_static_vars_$deletef; return; gfn(7): stack -> temp(1) = lisp_static_vars_$rename; return; end; /* * cleanup entry called by lisp command cleanup handler * we close all files */ cleanup: entry; esw = -5; do p = lisp_static_vars_$iochan_list repeat (p -> iochan.thread) while (p ^= null); if (string(p -> iochan.flags) & "011"b) ^= "011"b then /* if still open */ if p -> iochan.seg then if p -> iochan.fcbp ^= null then if ^ p -> iochan.read then call close_msf; else call close_output_file; cleanup_err_ret: end; return; /* * lisp mergef lsubr * calls same internal routine umergef as the open functions */ mergef: entry; stack = addrel(stack_ptr, -2); /* get arg count */ nargs = stack -> fixedb; stack = addrel(stack, nargs); nargs = divide(nargs, -2, 17, 0); esw = 5; myname = fn_mergef; call umergef; go to exit; /* * Internal proc to perform application of defaults by mergeing of namelists * * called with stack -> array of namelists, nargs = how many * returns with stack -> one namelist result * also expands namestrings into namelists * in the case where this was called by a function other than * mergef itself, the result is checked for improper format. * otherwise no error checking is done; when you try to use * the result the presence of e.g. numbers will cause err msg */ umergef: proc; dcl sp ptr, /* -> arg being processed */ unm ptr, tp ptr; /* -> top of stack area for making arg lists to cons */ /* stack -> current result-list */ sp = stack; tp = stack_ptr; if stack -> temp_type(1) then /* convert to a list */ do; stack_ptr = addrel(tp, 2); tp -> temp(1) = stack -> temp(1); call lisp_io_fns_$internal_namelist(myname); stack -> temp(1) = tp -> temp(1); end; do while (nargs >= 2); /* go through arguments */ if stack -> temp_ptr(1) -> cons.car = stream then go to exitloop; /* streams don't need all this lossage, just fall right through */ sp = addrel(sp, 2); /* next arg... */ nargs = nargs-1; if sp -> temp(1) = nil then do; /* special kludge - drop last name */ if stack -> temp_ptr(1) -> cons_types.cdr = Cons then do; stack_ptr = addrel(tp, 2); tp -> temp(1) = nil; do sp -> temp(1) = stack -> temp(1) /* copy the arg, except for last cons */ repeat(sp -> temp_ptr(1) -> cons.cdr) while(sp -> temp_ptr(1) -> cons_types.cdr = Cons); stack_ptr = addrel(tp, 4); tp -> temp(2) = sp -> temp_ptr(1) -> cons.car; call lisp_special_fns_$xcons; end; call lisp_list_utils_$nreverse; stack -> temp(1) = tp -> temp(1); /* move result down */ stack_ptr = tp; end; end; else do; if sp -> temp_type(1) then do; /* convert to a list */ stack_ptr = addrel(tp, 2); tp -> temp(1) = sp -> temp(1); call lisp_io_fns_$internal_namelist(myname); sp -> temp(1) = tp -> temp(1); end; /* normal mergef case - (margef x y) where x and y are lists */ stack_ptr = addrel(tp, 2); tp -> temp(1) = nil; /* going to cons up reverse output list */ do while (stack -> temp_type(1) = Cons & sp -> temp_type(1) = Cons); /* do while both lists hold out */ stack_ptr = addrel(tp, 4); if stack -> temp_ptr(1) -> cons.car ^= star then tp -> temp(2) = stack -> temp_ptr(1) -> cons.car; else tp -> temp(2) = sp -> temp_ptr(1) -> cons.car; /* select from x unless *, in which case take from y */ call lisp_special_fns_$xcons; stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; sp -> temp(1) = sp -> temp_ptr(1) -> cons.cdr; end; /* one or both of the lists has come to an end */ if stack -> temp_type36(1) & Atsym36 then /* x has come to the end, */ if stack -> temp(1) ^= nil then do; /* x is dotted */ do while (sp -> temp_type(1) = Cons); /* copy rest of y over */ stack_ptr = addrel(tp, 4); tp -> temp(2) = sp -> temp_ptr(1) -> cons.car; call lisp_special_fns_$xcons; sp -> temp(1) = sp -> temp_ptr(1) -> cons.cdr; end; if stack -> temp(1) ^= star then /* x had dotted atom, make sure list ends with it */ if stack -> temp(1) ^= tp -> temp_ptr(1) -> cons.car then do; stack_ptr = addrel(tp, 4); tp -> temp(2) = stack -> temp(1); call lisp_special_fns_$xcons; end; go to x01; end; /* copy rest of names in x */ do while (stack -> temp_type(1) = Cons); stack_ptr = addrel(tp, 4); tp -> temp(2) = stack -> temp_ptr(1) -> cons.car; call lisp_special_fns_$xcons; stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; end; if sp -> temp(1) ^= nil then /* if there is more to the list, */ if sp -> temp_type(1) ^= Cons then /* y ends with a dotted atom */ if sp -> temp(1) ^= star then /* other than .*, which is ignored */ if tp -> temp_ptr(1) -> cons.car /* then make sure the list ends with this */ ^= sp -> temp(1) then do; stack_ptr = addrel(tp, 4); tp -> temp(2) = sp -> temp(1); call lisp_special_fns_$xcons; go to x01; end; x01: call lisp_list_utils_$nreverse; /* the list was consed up in the wrong order */ stack -> temp(1) = tp -> temp(1); /* move result down */ end; end; exitloop: /* all done processing args, maybe check for errors */ if myname ^= fn_mergef then do; /* if called internally, make sure args to openi, etc. are OK */ nargs = 0; do tp -> temp(1) = stack -> temp(1) repeat (tp -> temp_ptr(1) -> cons.cdr) while (tp -> temp_type(1) = Cons); nargs = nargs + 1; if tp -> temp_ptr(1) -> cons.car = star then go to stars_left; else if tp -> temp_ptr(1) -> cons_types36.car & String36 then do; /* string is ok */ call lisp_get_atom_(tp -> temp_ptr(1) -> cons_ptrs.car -> lisp_string.string, tp -> temp_ptr(1) -> cons.car); end; else if tp -> temp_ptr(1) -> cons_types36.car & Numeric36 then do; /* number is ok */ /* bind *nopoint to t */ unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); stack_ptr = addr(tp -> temp(5)); unm -> binding_block.bot_block = rel(addr(tp -> temp(2))); unm -> binding_block.top_block = rel(addr(tp -> temp(4))); unm -> binding_block.back_ptr = rel(binding_top); tp -> temp(3) = lisp_static_vars_$stnopoint; tp -> temp(2) = tp -> temp_ptr(3) -> atom.value; binding_top = unm; tp -> temp_ptr(3) -> atom.value = t_atom; /* call exploden on the number */ tp -> temp(4) = tp -> temp_ptr(1) -> cons.car; call lisp_print_$exploden; /* maknam the result */ call lisp_reader_$maknam; /* rplaca it back into the namelist */ tp -> temp_ptr(1) -> cons.car = tp -> temp(4); /* get rid of the binding */ tp -> temp_ptr(3) -> atom.value = tp -> temp(2); binding_top = ptr(binding_top, unm -> binding_block.back_ptr); unmkd_ptr = unm; stack_ptr = addr(tp -> temp(2)); end; else if tp -> temp_ptr(1) -> cons_types.car & ^Atsym then go to stars_left; /* random - barf */ end; if tp -> temp(1) ^= nil then go to stars_left; /* dotted list is NG */ /* expand the directory path name if necessary */ if stack -> temp_ptr(1) -> cons.car ^= stream then if substr(stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pname, 1, 1) ^= ">" then do; call expand_path_(addr(stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pname), stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pnamel, addr(dname), null, code); nargs = index(dname, " ")-1; if nargs < 0 then nargs = length(dname); if code = 0 then call lisp_get_atom_(substr(dname, 1, nargs), stack -> temp_ptr(1) -> cons.car); /* ok to rplaca since was copied */ end; end; stack_ptr = addrel(stack, 2); /* flush args & stuff from stack */ return; end; /* Error handling for umergef */ stars_left: err = lisp_error_table_$stars_left_in_name; /* or any namelist format error */ errproc_6_join: stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = nil; stack -> temp(2) = stack -> temp(1); call get_fname; go to errproc_cc; /* * Lisp file deletion function */ deletef: entry; stack = addrel(stack_ptr, -2); /* subr 1 arg */ myname = fn_deletef; esw = 6; stack_ptr = addr(stack -> temp(3)); stack -> temp(2) = tty_output_chan -> iochan.namelist; /* mergef arg with defaults */ nargs = 2; call umergef; call get_path_name_0; /* set dname, ename */ call delete_$path(dname, substr(ename, 1, length(ename)-1), "000110"b, /* no questions, df seg & msf, don't chase links, don't force if ssw on */ "", code); if code = 0 then go to exit; err = lisp_error_table_$file_sys_fun_err; errproc(6): go to errproc_6_join; /* previous page */ /* * Lisp file renaming function */ rename: entry; rnstack, stack = addrel(stack_ptr, -4); /* subr 2 args */ myname = fn_rename; esw = 7; stack_ptr = addr(stack -> temp(5)); stack -> temp(4) = tty_output_chan -> iochan.namelist; stack -> temp(3) = stack -> temp(1); /* put first arg over the defaults */ nargs = 2; stack = addr(stack -> temp(3)); call umergef; rnstack -> temp(1) = stack -> temp(1); /* save processed first arg */ stack = addrel(stack, -2); nargs = 2; call umergef; /* put second arg over (first arg over defaults) */ call get_path_name_0; /* get ename for second arg */ other_ename = substr(ename, 1, length(ename)-1); stack = rnstack; /* back where it was originally */ call get_path_name_0; /* get dname and ename for original name */ call hcs_$chname_file(dname, substr(ename, 1, length(ename)-1), substr(ename, 1, length(ename)-1), other_ename, code); if code ^= 0 then go to file_sys_fun_err_; stack -> temp(1) = stack -> temp(2); /* return value is processed second arg */ go to exit; force_output: entry; /* the force output function, which forces an output file to disgorge its buffer */ myname = fn_force_output; fo_ci_join: stack = addrel(stack_ptr, -2); /* subr, arg = file */ fo_ci_retry: if stack -> temp(1) = nil | stack -> temp(1) = t_atom then if myname = fn_force_output then p = tty_output_chan; else p = tty_input_chan; else if stack -> temp_type36(1) & File36 then p = stack -> temp_ptr(1); else do; fo_ci_barf: err = lisp_error_table_$bad_arg_correctable; call error; go to fo_ci_retry; end; if p -> iochan.seg then return; /* nugatory for files */ if p -> iochan.must_reopen then call lisp_io_control_$fix_not_ok_iochan(p, "1"b, ("0"b)); /* mung stream buffer if first use */ dcl lisp_io_control_$fix_not_ok_iochan entry(ptr, bit(1) aligned, bit(1) aligned); /* check direction */ if myname = fn_force_output then if p -> iochan.write then go to fo_ci_barf; else; else /* if myname = fn_clear_input then */ if p -> iochan.read then go to fo_ci_barf; else; /* p -> iochan to be munged */ if myname = fn_force_output then call dump_buffer; else do; /*(clear-input p)*/ p -> iochan.ioindex = 0; p -> iochan.iolength = 0; if p -> iochan.fcbp = null() then call get_iocb; call iox_$control (p->iochan.fcbp, "resetread", null(), status); end; return; clear_input: entry; myname = fn_clear_input; go to fo_ci_join; /* this is the lisp %include function, which works like %include in pl/1 */ percent_include: entry; stack = addrel(stack_ptr, -2); /* fsubr - pick up argument */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; go to include_common; includef: entry; /*** (includef, same as %include except subr ***/ stack = addrel (stack_ptr, -2); /* subr 1 arg */ include_common: if stack -> temp_type36(1) & String36 then ename = stack -> temp_ptr(1) -> lisp_string.string; else if stack -> temp_type36(1) & Atsym36 then ename = stack -> temp_ptr(1) -> atom.pname; else go to include_file_not_found; /* no numbers, etc. */ /* tack ".incl.lisp" on the end of ename */ if length(ename) > 22 then go to include_file_name_truncated; other_ename = ename || ".incl.lisp"; /* find the include file */ call find_include_file_$initiate_count("lisp", null, /* phooey on referencing_dir rule */ (other_ename), (0), q, code); if q = null then go to include_file_not_found_but_have_code; /* get the actual pathname of the include file (what a Kludge) */ call hcs_$fs_get_path_name(q, dname, (0), other_ename, code); if code ^= 0 then go to include_file_not_found_but_have_code; /* (??) */ /* create and initialize an iochan block (file object) */ call make_an_iochan; p -> iochan.charpos, p -> iochan.linenum, p -> iochan.pagenum = 0; p -> iochan.pagel = 59; /* random constant - see open */ p -> iochan.linel = 110; /* random constant - see open */ p -> iochan.function = tty_input_chan -> iochan.function; /* default eoffn */ p -> iochan.write = "1"b; /* input channel!! */ /* construct namelist - assume our argument contained no dots (Kludge?) */ stack_ptr = addr(stack -> temp(7)); stack -> temp(6) = nil; call lisp_get_atom_("lisp", stack -> temp(5)); call lisp_get_atom_("incl", stack -> temp(4)); call lisp_get_atom_((ename), stack -> temp(3)); i = verify(reverse(dname), " "); /* strip trailing blanks for directory path name */ /* i /= 0 is assumed since all blank dname would be wierd */ call lisp_get_atom_(substr(dname, 1, length(dname)-i+1), stack -> temp(2)); do i = 0 to 3; call lisp_special_fns_$cons; end; p -> iochan.namelist = stack -> temp(2); /*** Note: assume p survives through g.c. ***/ /* open the input file */ p -> iochan.seg = "1"b; p -> iochan.name = other_ename; esw = -6; /* prepare error return */ call open_input_file; /* all set, thread into iochan list */ p -> iochan.thread = lisp_static_vars_$iochan_list; lisp_static_vars_$iochan_list = p; /* turn on type bit and turn into lisp object in marked stack */ p_.type = File; stack -> temp(1) = p_fb; /* inpush it */ stack_ptr = addr(stack -> temp(2)); call lisp_io_fns_$inpush; /* turn on ^q flag so will start reading from this place (if %include from tty!!) */ addr(ctrlQ) -> based_ptr -> atom.value = t_atom; return; /* inpush has left right things on stack */ include_file_name_truncated: code = error_table_$entlong; go to include_file_not_found_but_have_code; include_file_not_found: code = error_table_$noentry; include_file_not_found_but_have_code: errproc(-6): /* error exit from open_input_file */ /* signal uncorrectable lisp error */ stack_ptr = addr(stack -> temp(4)); /* stack -> temp(1) = our arg */ stack -> temp(3) = nil; /* cons up kludgey error message */ stack -> temp(2) = stack -> temp(1); call lisp_get_atom_("%include", stack -> temp(1)); call lisp_special_fns_$cons; call lisp_special_fns_$cons; myname = code; /* Gag! pass error_table_ code to lisp_error_ */ err = lisp_error_table_$include_file_error; call error; /* never returns - uncorrectable error */ return; /* * Fixnum I/O Functions */ in: entry; dcl fail_flag bit(1) aligned, word fixed bin(35), words (0:1000) fixed bin(35) based; myname = fn_in; reget_in: stack = addrel(stack_ptr, -2); /* subr 1 arg */ do while((stack -> temp_type36(1) & File36) = ""b); err = lisp_error_table_$bad_arg_correctable; call error; end; p = stack -> temp_ptr(1); /* -> iochan */ if string(p -> iochan.flags) & not_ok_to_read_fixnum then go to in_loss; else if ^ p -> iochan.fixnum_mode then do; in_loss: call fix_not_ok_iochan(p, "0"b, fail_flag); if fail_flag then go to reget_in; end; if p -> iochan.ioindex >= p -> iochan.iolength then do; call end_of_block(p, (nil), codde); if codde ^= 0 then return; /* foo. shouldn't happen */ end; word = p -> iochan.ioptr -> words(p -> iochan.ioindex); in_out_ret: p -> iochan.ioindex = p -> iochan.ioindex + 1; stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = word; return; out: entry; myname = fn_out; reget_out:stack = addrel(stack_ptr, -4); /* subr 2 args */ do while((stack -> temp_type36(2) & Fixed36) = ""b); err = lisp_error_table_$bad_arg_correctable; call error; end; word = addr(stack -> temp(2)) -> fixedb; stack_ptr = addr(stack -> temp(2)); do while((stack -> temp_type36(1) & File36) = ""b); err = lisp_error_table_$bad_arg_correctable; call error; end; p = stack -> temp_ptr(1); if string(p -> iochan.flags) & not_ok_to_write_fixnum then go to out_loss; else if ^ p -> iochan.fixnum_mode then do; out_loss: call fix_not_ok_iochan(p, "1"b, fail_flag); if fail_flag then go to reget_out; end; if p -> iochan.ioindex >= p -> iochan.iolength then do; call end_of_block(p, (nil), codde); if codde ^= 0 then return; end; p -> iochan.ioptr -> words(p -> iochan.ioindex) = word; go to in_out_ret; end lisp_io_control_;  lisp_io_fns_.pl1 09/11/84 1519.3r w 09/04/84 1533.2 314325 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_io_fns_: procedure; /* * This module contains miscellaneous functions of the New I/O System. * * The lisp functions implemented by this module are: * allfiles, chrct, eoffn, filepos, inpush, linel, names, * namelist, namestring, shortnamestring. * * Coded 14 Mar 73 by DAM * ** kludges removed 5/9/80 by BSG, 'cause Multics does that right now. * Modified September 1982 by Richard Lamson to add cursorpos lsubr */ dcl esw fixed bin, myname fixed bin, stack ptr, nargs fixed bin, tsp ptr, /* top of stack ptr */ err fixed bin, n fixed bin, (m, i, len) fixed bin, vcs char(208) varying, /* big enough to hold largest imaginable pathname */ vcso char(length(vcs)) based(addrel(addr(vcs),1)), /* so vcs can be passed to a char(*) paraemeter */ p ptr; dcl (lisp_error_table_$bad_arg_correctable, lisp_error_table_$io_wrong_direction, lisp_error_table_$cant_filepos, lisp_error_table_$filepos_oob) fixed bin external, bad_arg_correctable fixed bin defined lisp_error_table_$bad_arg_correctable, io_wrong_direction fixed bin defined lisp_error_table_$io_wrong_direction, cant_filepos fixed bin defined lisp_error_table_$cant_filepos, filepos_oob fixed bin defined lisp_error_table_$filepos_oob; declare (addr, addrel, char, divide, fixed, index, length, null, search, size, string, substr, verify) builtin, V$infile fixed bin(71) aligned based(addr(addr(lisp_static_vars_$infile) -> based_ptr -> atom.value)), V$instack fixed bin(71) aligned based(addr(addr(lisp_static_vars_$instack) -> based_ptr -> atom.value)), Vp$instack pointer aligned based(addr(V$instack)), lisp_static_vars_$infile fixed bin(71) external, lisp_static_vars_$eof_atom fixed bin(71) external, lisp_static_vars_$instack fixed bin(71) external, (k, j) fixed bin, lisp_alloc_ entry(fixed bin, fixed bin(71)), lisp_io_control_$fix_not_ok_iochan entry(pointer, bit(1) aligned, bit(1) aligned), msf_manager_$get_ptr ext entry(pointer, fixed bin, bit(1) aligned, pointer, fixed bin, fixed bin(35)), hcs_$star_ ext entry(char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35)), code fixed bin(35), lisp_special_fns_$ncons entry, lisp_special_fns_$xcons entry, expand_path_ ext entry (pointer, fixed bin, pointer, pointer, fixed bin(35)), get_pdir_ ext entry (char(168)), dn char(168), en char(32), (get_default_wdir_, get_wdir_) ext entry (char(*)), blank char(3) static init(" "), /* NL, HT, SP - the 'blank' characters */ point_blank char(4) static init(". "), /* dot || blank */ get_at_entry_ ext entry (char(*) aligned, char(*), char(*), char(*), fixed bin(35)), enl fixed bin, lisp_get_atom_ entry(char(*), fixed bin(71)), star fixed bin(71) def (lisp_static_vars_$STAR), lisp_static_vars_$STAR fixed bin(71) external, stream fixed bin(71) def (lisp_static_vars_$stream), lisp_static_vars_$stream fixed bin(71) external, lisp_special_fns_$cons entry, lisp_static_vars_$filepos fixed bin(71) external, sgp pointer, fail_act_f bit(1) aligned; %include lisp_io; %include lisp_ptr_fmt; %include lisp_stack_fmt; %include lisp_atom_fmt; %include lisp_cons_fmt; %include lisp_nums; %include lisp_string_fmt; %include lisp_common_vars; %include lisp_name_codes; /* The trivial functions to access components of a file object -- also filepos since it has similar args */ chrct: entry; esw = 1; myname = fn_chrct; go to one_two_fns; eoffn: entry; esw = 2; myname = fn_eoffn; go to one_two_fns; filepos: entry; esw = 3; myname = fn_filepos; go to one_two_fns; linel: entry; esw = 4; myname = fn_linel; go to one_two_fns; names: entry; /* this entry is to be removed eventually - use namelist */ esw = 5; myname = fn_names; go to one_two_fns; charpos: entry; esw = 6; myname = fn_charpos; go to one_two_fns; pagel: entry; esw = 7; myname = fn_pagel; go to one_two_fns; linenum: entry; esw = 8; myname = fn_linenum; go to one_two_fns; pagenum: entry; esw = 9; myname = fn_pagenum; go to one_two_fns; endpagefn: entry; esw = 10; myname = fn_endpagefn; go to one_two_fns; /* * Common code for the functions which take 1 or 2 args. * The first arg is a file. If only one arg dispatch via transfer vector get, * if two args dispatch via transfer vector put */ one_two_fns: tsp = addrel(stack_ptr, -2); /* these are all lsubrs (1 . 2) */ nargs = tsp -> fixedb; stack = addrel(tsp, nargs); /* make sure first arg is a file */ agn12: if stack -> temp_type36(1) & File36 then; else if stack -> temp(1) = nil then do; /* nil means the defaults, kept on tty_output_chan */ if esw = 2 then p = tty_input_chan; /* exception for eoffn */ else p = tty_output_chan; go to defjoin; end; else do; file_arg_loss: call badarg(stack -> temp(1)); go to agn12; end; /* now dispatch through transfer vector selected by num of args */ p = stack -> temp_ptr(1); /* -> iochan block for file */ defjoin: if nargs = -2 then go to get(esw); /* one arg */ else go to put(esw); /* two args */ /* Error Routines */ badarg: proc(loser); dcl loser fixed bin(71); /* the stack cell containing the bad arg */ tsp -> temp(1) = loser; err = bad_arg_correctable; call error; loser = tsp -> temp(1); /* replacement value */ end; error: proc; dcl unm ptr, ercode(2) fixed bin aligned based(unm), lisp_error_ entry; unm = unmkd_ptr; unmkd_ptr = addrel(unm, size(ercode)); ercode(1) = err; ercode(2) = myname; call lisp_error_; end; wrong_direction_for_setting_iochan_function: stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = nil; call lisp_special_fns_$cons; call lisp_special_fns_$cons; stack_ptr = addr(stack -> temp(3)); if myname = fn_eoffn then call lisp_get_atom_("eoffn", stack -> temp(2)); else call lisp_get_atom_("endpagefn", stack -> temp(2)); call lisp_special_fns_$xcons; /* top of marked stack now has neat form to print out */ err = io_wrong_direction; call error; /* here are the routines for accessing components of files (or iochan blocks) */ get(1): n = p -> iochan.linel - p -> iochan.charpos; go to nexit; put(1): call get_numeric_arg; p -> iochan.charpos = p -> iochan.linel - n; go to nexit; get(2): if p -> iochan.read = "0"b then stack -> temp(1) = p -> iochan.function; else stack -> temp(1) = nil; go to exit; put(2): if p -> iochan.read = "0"b then p -> iochan.function = stack -> temp(2); else go to wrong_direction_for_setting_iochan_function; go to pexit; get(4): n = p -> iochan.linel; go to nexit; put(4): call get_numeric_arg; p -> iochan.linel = n; go to nexit; get(5): stack -> temp(1) = p -> iochan.namelist; go to exit; put(5): if stack -> temp(1) ^= nil then go to file_arg_loss; if stack -> temp_type(2) = Cons then if stack -> temp_ptr(2) -> cons_types.car = Atsym then go to put5ok; call badarg(stack -> temp(2)); /* the new default namelist had better look like a name list */ go to put(5); put5ok: p -> iochan.namelist = stack -> temp(2); /* can only change default name list */ go to pexit; get(6): n = p -> iochan.charpos; go to nexit; put(6): call get_numeric_arg; p -> iochan.charpos = n; go to nexit; get(7): n = p -> iochan.pagel; go to nexit; put(7): call get_numeric_arg; p -> iochan.pagel = n; go to nexit; get(8): n = p -> iochan.linenum; go to nexit; put(8): call get_numeric_arg; p -> iochan.linenum = n; go to nexit; get(9): n = p -> iochan.pagenum; go to nexit; put(9): call get_numeric_arg; p -> iochan.pagenum = n; go to nexit; get(10): if p -> iochan.write = "0"b then stack -> temp(1) = p -> iochan.function; else stack -> temp(1) = nil; go to exit; put(10): if p -> iochan.write = "0"b then p -> iochan.function = stack -> temp(2); else go to wrong_direction_for_setting_iochan_function; go to pexit; /* exit routines for the above */ exit: stack_ptr = addr(stack -> temp(2)); return; nexit: /* numberic exit */ stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = n; go to exit; pexit: /* exit, value in stack -> temp(2) */ stack -> temp(1) = stack -> temp(2); go to exit; /* Numeric argument getter - from 2nd arg */ get_numeric_arg: proc; do while("1"b); /* loop until valid arg received */ if addr(stack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type then do; n = addr(stack -> temp(2)) -> fixedb; return; end; else if addr(stack -> temp(2)) -> flonum_fmt.type_info = flonum_type then do; n = addr(stack -> temp(2)) -> floatb; return; end; call badarg(stack -> temp(2)); end; end; /* routines for random access input - filepos */ get(3): /* (filepos ff) gets current char position of file ff */ call filepos_ok; len = 0; do i = 0 by 1 while (i < p -> iochan.component); /* add up lengths of preceding components */ call getlength; if fail_act_f then go to filepos_loss_1; len = len + m; end; n = len + p -> iochan.ioindex; /* n := position in characters from beginning of file */ go to nexit; put(3): /* (filepos ff n) sets character position of file ff to n */ call filepos_ok; if stack -> temp(2) = lisp_static_vars_$eof_atom then do; /* 5/10/80 -BSG */ n = 0; do i = 0 by 1; call getlength; if fail_act_f then go to got_it; n = n + m; end; end; call get_numeric_arg; /* get n */ do i = 0 by 1; /* scan through components looking for right one */ call getlength; if fail_act_f then go to filepos_loss_2; /* must habe been o.o.b. (either minus or too big) */ if m < n then n = n - m; /* not right one */ else go to got_it; /* right one */ end; got_it: p -> iochan.component = i; p -> iochan.ioindex = n; p -> iochan.iolength = m; p -> iochan.ioptr = sgp; go to pexit; /* filepos error handling */ filepos_loss_1: /* this file can't filepos */ err = cant_filepos; stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = nil; filepos_loss: stack -> temp(2) = stack -> temp(1); stack -> temp(1) = lisp_static_vars_$filepos; call lisp_special_fns_$cons; call lisp_special_fns_$cons; if err = filepos_oob then call lisp_special_fns_$cons; call error; return; filepos_loss_2: /* (filepos ff n) -- n out of bounds */ err = filepos_oob; stack_ptr = addr(stack -> temp(5)); stack -> temp(4) = nil; stack -> temp(3) = stack -> temp(2); go to filepos_loss; /* int proc to make sure a file is really filepos'able */ filepos_ok: proc; if ^ p -> iochan.seg then go to filepos_loss_1; /* streams can't random access */ if string(p -> iochan.flags) & not_ok_to_read then do; /* and the file better be open */ call lisp_io_control_$fix_not_ok_iochan(p, "0"b, fail_act_f); if fail_act_f then do; stack -> temp(1) = addrel(stack_ptr, -2) -> temp(1); /* value of fail-act */ go to exit; end; end; end; /* int proc to get length in chars of component i of msf */ /* returns m = length, sgp = ptr, fail_act_f = "1"b if err */ getlength: proc; fail_act_f = "0"b; call msf_manager_$get_ptr(p -> iochan.fcbp, i, "0"b, sgp, m, 0); if sgp = null then fail_act_f = "1"b; /* err - probably ran off end of msf */ else m = divide(m, 9, 21, 0); /* bit count --> char count */ end; /* * subrs for conversion between namestrings and namelists */ truename: entry; myname = fn_truename; /* return actual pathname */ go to namstr_aa; namestring: entry; myname = fn_namestring; go to namstr_aa; /* join with shortnamestring */ shortnamestring: entry; myname = fn_shortnamestring; namstr_aa: stack = addrel(stack_ptr, -2); /* subr 1 */ do while (stack -> temp_type(1) ^= Cons); /* make sure arg is a list */ if stack -> temp_type36(1) & File36 then do; /* also accept files */ stack -> temp(1) = stack -> temp_ptr(1) -> iochan.namelist; go to take_namelist_of_file_arg; end; else if stack -> temp(1) = nil then do; /* default namestring */ stack -> temp(1) = tty_output_chan -> iochan.namelist; go to take_namelist_of_file_arg; end; namstr_wta: err = bad_arg_correctable; call error; end; if stack -> temp_ptr(1) -> cons_types36.car & Atsym36 then; /* whose car is an atom */ else if stack -> temp_ptr(1) -> cons_types36.car & String36 then do; /* or a string */ if myname = fn_shortnamestring then vcs = ""; /* this is all a bit gross */ else vcs = stack -> temp_ptr(1) -> cons_ptrs.car -> lisp_string.string || ">"; end; else go to namstr_wta; take_namelist_of_file_arg: if myname ^= fn_shortnamestring then /* look at car only if namestring entry */ if stack -> temp_ptr(1) -> cons.car = stream then vcs = "$"; /* stream marker */ else vcs = stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pname || ">"; /* directory, lose if root: OK */ else vcs = ""; call namestringer; namestringer: proc; /* so that allfiles can use it too */ fail_act_f = "0"b; do stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr repeat( stack -> temp_ptr(1) -> cons.cdr ) while( stack -> temp_type(1) = Cons ); if stack -> temp_ptr(1) -> cons_types36.car & Numeric36 then begin; /* convert number to atom */ dcl ts ptr, unm ptr, (lisp_reader_$maknam, lisp_print_$exploden) entry; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); ts = stack_ptr; stack_ptr = addr(ts -> temp(4)); /* bind *nopoint to t */ unm -> binding_block.bot_block = rel(addr(ts -> temp(1))); unm -> binding_block.top_block = rel(addr(ts -> temp(3))); unm -> binding_block.back_ptr = rel(binding_top); ts -> temp(2) = lisp_static_vars_$stnopoint; ts -> temp(1) = ts -> temp_ptr(2) -> atom.value; binding_top = unm; ts -> temp_ptr(2) -> atom.value = t_atom; /* call exploden on the number */ ts -> temp(3) = stack -> temp_ptr(1) -> cons.car; call lisp_print_$exploden; /* maknam up the result */ call lisp_reader_$maknam; /* catenate it onto vcs */ vcs = vcs || ts -> temp_ptr(3) -> atom.pname || "."; /* get rid of the binding */ ts -> temp_ptr(2) -> atom.value = ts -> temp(1); binding_top = ptr(binding_top, unm -> binding_block.back_ptr); unmkd_ptr = unm; stack_ptr = ts; end; else if stack -> temp_ptr(1) -> cons_types36.car & Atsym36 then vcs = vcs || stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pname || "."; else if stack -> temp_ptr(1) -> cons_types36.car & String36 then vcs = vcs || stack -> temp_ptr(1) -> cons_ptrs.car -> lisp_string.string || "."; end; if (stack -> temp(1) ^= nil) & (stack -> temp_type36(1) & Atsym36) ^= ""b then /* dotted list */ if stack -> temp(1) = star then vcs = vcs || "**"; /* .* */ else vcs = vcs || "**." || stack -> temp_ptr(1) -> atom.pname; /* (x>foo . bar) => x>foo.**.bar */ /* Multics does this now 5/9/80 - BSG */ else if substr(vcs, length(vcs), 1) = "." then vcs = substr(vcs, 1, length(vcs)-1); /* if not dotted, drop last dot */ return; end namestringer; /* for truename, get the actual path name */ if myname = fn_truename then call find_true_name(vcs); /* convert vcs to a lisp string & return it */ call make_a_string(vcso, stack -> temp(1)); go to exit; defaultf: entry; /**** function to set the default namelist - replaces (names nil f) ****/ call internal_namelist(fn_defaultf); /* get a namelist at the top of the stack, by hook or by crook */ tsp = addrel(stack_ptr, -2); /* subr 1*/ /* stash it away */ tty_output_chan -> iochan.namelist = tsp -> temp(1); /* where we keep the defaults */ return; /* value is argument */ namelist: entry; /**** convert a string specifying a file into a list ****/ myname = fn_namelist; go to namelist_join; internal_namelist: entry(a_myname); /* same as namelist, except different myname since called on behalf of some other function */ dcl a_myname fixed bin; myname = a_myname; namelist_join: stack = addrel(stack_ptr, -2); /* subr 1 */ namlstaa: if stack -> temp(1) = nil then do; /* get default namelist */ stack -> temp(1) = tty_output_chan -> iochan.namelist; go to exit; end; else if stack -> temp_type36(1) & String36 then p = stack -> temp_ptr(1); else if stack -> temp_type36(1) & Atsym36 then p = addr(stack -> temp_ptr(1) -> atom.pnamel); else if stack -> temp_type36(1) & File36 then do; /* namelist of a file */ stack -> temp(1) = stack -> temp_ptr(1) -> iochan.namelist; go to exit; end; else if stack -> temp_type(1) then do; namlsterr: err = bad_arg_correctable; call error; go to namlstaa; end; else if stack -> temp_ptr(1) -> cons_types36.car & Atsym36 then go to exit; /* legal name list */ else go to namlsterr; /* list, but car was not an atom */ /* parse string and cons up a list */ i = verify(p -> lisp_string.string, blank); /* skip leading blanks: NL, HT, SP */ if i = 0 then go to namlsterr; /* barf at all-blank string */ j = search(substr(p -> lisp_string.string, i), blank)-1; /* find end of non-blank part of string */ if j < 0 then j = p -> lisp_string.string_length - i + 1; if j > 208 then go to namlsterr; /* too long - barf at it */ vcs = substr(p -> lisp_string.string, i, j); /* copy non-blank portion of string */ if substr(vcs, 1, 1) = "$" then do; /* stream specifier */ stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = nil; stack -> temp(1) = stream; call lisp_get_atom_(substr(vcs, 2), stack -> temp(2)); call lisp_special_fns_$cons; call lisp_special_fns_$cons; go to exit; end; /* segment specifier - parse it up into dir>a.b.c and make list */ if length(vcs) > 5 /* this is for the benefit of lap, mostly */ then if substr(vcs, 1, 5) = "[pd]>" then do; call get_pdir_(dn); vcs = substr(dn, 1, index(dn, " ")-1) || substr(vcs, 5); end; call expand_path_(addr(vcso), /* boy, expand_path_ sure is a kludge! */ length(vcs), addr(dn), addr(en), code); if code ^= 0 then go to namlsterr; if search(vcs, "<>") = 0 then stack -> temp(1) = star; /* no dir specified, use * instead of wdir */ else do; j = search(dn, blank)-1; if j < 0 then j = length(dn); call lisp_get_atom_(char(dn, j), stack -> temp(1)); end; /* en has entry name, stack -> temp(1) has directory */ k = 1; tsp = stack; /* tsp will advance as name components are pushed onto stack */ entry_names_loop: tsp = addrel(tsp, 2); stack_ptr = addr(tsp -> temp(2)); j = search(substr(en, k), point_blank); /* find period, or else blank which ends name */ if j ^= 0 then /* get another entry name */ if substr(en, k+j-1, 1) ^= "." then; /* as j = 0, this is the end */ else if substr(en, k, j-1) = "**" then do; /* embedded ** special construction: foo.**.bar => (-- foo . bar) */ k = k + j; /* skip over the .**. */ j = search(en, blank)-1; if j < 0 then j = length(en); call lisp_get_atom_(substr(en, k, j-k+1), tsp -> temp(1)); /* get the rest (e.g. bar) */ go to cons_it_up; /* and this is the end */ end; else do; /* single dot, get preceding name, and continue */ call lisp_get_atom_(substr(en, k, j-1), tsp -> temp(1)); k = k + j; go to entry_names_loop; end; /* do final entry name component */ if j = 0 then j = length(en)-k+2; if substr(en, k, j-1) = "**" then do; /* ends with .**, put dotted star in namelist */ tsp -> temp(1) = star; go to cons_it_up; end; call lisp_get_atom_(substr(en, k, j-1), tsp -> temp(1)); stack_ptr = addr(tsp -> temp(3)); tsp -> temp(2) = nil; cons_it_up: /* Now make a list out of all this junk */ do while (stack_ptr ^= addr(stack -> temp(2))); call lisp_special_fns_$cons; end; go to exit; /* * Subr to manipulate the input-source stack */ inpush: entry; stack = addrel(stack_ptr, -2); /* subr 1 */ inpaa: if stack -> temp_type36(1) & File36 then do; /* (inpush file) */ stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = V$instack; stack -> temp(2) = V$infile; call lisp_special_fns_$cons; /* push infile onto instack */ V$instack = stack -> temp(2); V$infile = stack -> temp(1); end; else if stack -> flonum_fmt.type_info = flonum_type then do; stack -> fixedb = fixed(stack -> floatb); go to inpbb; end; else if stack -> fixnum_fmt.type_info = fixnum_type then inpbb: if stack -> fixedb = 0 then do; /* (inpush 0) */ stack -> temp(1) = V$infile; go to exit; end; else if stack -> fixedb < 0 then /* (inpush -n) */ do n = stack -> fixedb by 1 while(n < 0); if V$instack = nil then V$infile = t_atom; else do; V$infile = Vp$instack -> cons.car; V$instack = Vp$instack -> cons.cdr; end; end; else /* (inpush +n) */ do n = stack -> fixedb by -1 to 1; stack_ptr = addr(stack -> temp(3)); stack -> temp(1) = V$infile; stack -> temp(2) = V$instack; call lisp_special_fns_$cons; /* push infile onto instack */ V$instack = stack -> temp(1); end; else do; /*** wrng-type-arg error ***/ myname = fn_inpush; err = bad_arg_correctable; call error; go to inpaa; end; /* return the value of infile, and adjust ^q */ stack -> temp(1) = V$infile; if stack -> temp(1) = nil | stack -> temp(1) = t_atom then addr(ctrlQ) -> based_ptr -> atom.value = nil; go to exit; /* * The Allfiles subr, which returns a list of namelists for all the files which * match a given namelist. */ allfiles: entry; myname = fn_allfiles; stack = addrel(stack_ptr, -2); /* subr 1 */ allfiles_aa: if stack -> temp_type(1) ^= Cons then call internal_namelist(myname); if stack -> temp_ptr(1) -> cons_types36.car & (Atsym36 | String36) then;else allfiles_err: do; err = bad_arg_correctable; call error; go to allfiles_aa; end; stack_ptr = addr(stack -> temp(3)); stack -> temp(2) = nil; /* init result: consed-up list of namelists */ if stack -> temp_ptr(1) -> cons.car = star then do; /* * Starred Directory: use lisp search rules: * 1) working dir * 2) default wdir * 3) >lisp * * (these ought to be changeable by the user) * * The actual search is done in reverse order so that the car of the resulting * list will be the one that comes first in the search rules. */ dn = ">lisp"; call somefiles; call get_default_wdir_(dn); call somefiles; call get_wdir_(dn); call somefiles; end; else if stack -> temp_ptr(1) -> cons.car = stream then do; /* stream is nil, or list of it if attached */ call get_at_entry_(stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons_ptrs.car -> atom.pname, "", "", "", code); if code ^= 0 then go to pexit; /* not attached, return nil */ stack_ptr = addr(stack -> temp(2)); call lisp_special_fns_$ncons; /* attached, return list of argument */ go to exit; end; else if stack -> temp_ptr(1) -> cons_types36.car & String36 then do; dn = stack -> temp_ptr(1) -> cons_ptrs.car -> lisp_string.string; call somefiles; end; else do; dn = stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pname; /* use specified directory */ call somefiles; end; go to pexit; /* return the list in stack -> temp(2) */ /* * routine to do allfiles on one directory * * dn = pathname of the directory * stack -> temp(1) = namelist (pattern) * results are consed onto stack -> temp(2) */ somefiles: proc; dcl an_area area(4096); /* plenty big enough */ /* Made 4096 BSG 5/9/80 */ dcl dnl fixed bin; /* non-blank length of dn */ dcl ecount fixed bin, (eptr, nptr) ptr, 1 entries (ecount) based(eptr) aligned, 2 type bit(2) unaligned, 2 nname fixed bin(15) unaligned, 2 nindex fixed bin(17) unaligned, names_str (1) char(32) aligned based(nptr); stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = stack -> temp(1); stack = addr(stack -> temp(3)); dnl= length (rtrim (dn)); vcs = ""; call namestringer; /* get back the starred entry name in vcs */ stack = addrel(stack, -4); call hcs_$star_(dn, vcso, 2, addr(an_area), ecount, eptr, nptr, code); if code ^= 0 then return; /* some kind of lossage, assume not found */ do i = 1 to ecount; /* put all the entries on the list */ j = search(names_str(nindex(i)), " ")-1; if j < 0 then j = 32; dcl bug_fixer char(168), bug_fixer_aa based(addr(bug_fixer)) char(dnl+j+1); bug_fixer = char(names_str(nindex(i)), j); /* fix v2pl1 bug */ bug_fixer = char(dn, dnl) || ">" || bug_fixer; call make_a_string(bug_fixer_aa, stack -> temp(3)); call internal_namelist(myname); /* expand this string into a list */ call lisp_special_fns_$xcons; /* and cons onto the results list */ stack_ptr = addr(stack -> temp(4));/* and fix stack_ptr */ end; return; end; make_a_string: proc(the_string, where_to_put_it); dcl the_string char(*) unaligned, where_to_put_it fixed bin(71); call lisp_alloc_(divide(length(the_string)+7, 4, 17, 0), where_to_put_it); addr(where_to_put_it) -> lisp_ptr.type = String; addr(where_to_put_it)->based_ptr -> lisp_string.string_length = length(the_string); addr(where_to_put_it)->based_ptr -> lisp_string.string = the_string; end; cursorpos: entry; /* the LISP cussorpos lsubr, which sets or get the zero-origin (line . char) position of a display terminal. */ declare (X, Y) fixed binary; declare vcs_bit_bucket char (1) varying; %include window_control_info; declare 1 window_info auto aligned like window_position_info; declare iox_$control entry (ptr, char(*), ptr, fixed bin(35)); declare iox_$look_iocb entry (char(*), ptr, fixed bin(35)); declare window_$clear_region entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin(35)); declare window_$clear_to_end_of_line entry (ptr, fixed bin(35)); declare window_$clear_to_end_of_window entry (ptr, fixed bin(35)); declare window_$clear_window entry (ptr, fixed bin(35)); declare window_$delete_chars entry (ptr, fixed bin, fixed bin(35)); declare window_$get_cursor_position entry (ptr, fixed bin, fixed bin, fixed bin(35)); declare window_$get_one_unechoed_char entry (ptr, char(1) var, bit(1) aligned, fixed bin(35)); declare window_$insert_text entry (ptr, char(*), fixed bin(35)); declare window_$position_cursor entry (ptr, fixed bin, fixed bin, fixed bin(35)); declare window_$scroll_region entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin(35)); stack = addrel(stack_ptr, -2); nargs = stack -> fixedb; stack = addrel(stack, nargs); nargs = divide (nargs, -2, 17, 0); /* Get real number of args. */ if nargs = 0 then p = tty_output_chan; else do; nargs = nargs - 1; /* File argument omitted. */ if stack -> temp (nargs+1) = t_atom then p = tty_output_chan; else if stack -> temp_type36 (nargs+1) & File36 then p = stack -> temp_ptr (nargs+1); else do; nargs = nargs + 1; /* No file argument really present. */ p = tty_output_chan; end; end; if p -> iochan.seg then go to cursorpos_returns_nil; /* Can't do (cursorpos) to segment. */ if p -> iochan.fcbp = null () /* Must have an IOCB ptr to work with. */ then do; call iox_$look_iocb (p -> iochan.name, p -> iochan.fcbp, code); if code ^= 0 then go to cursorpos_returns_nil; end; p = p -> iochan.fcbp; /* Get iocb ptr */ call window_$get_cursor_position (p, Y, X, code); if code ^= 0 then go to cursorpos_returns_nil; if nargs = 0 then do; stack_ptr = addr (stack -> temp (3)); stack -> temp_type36 (1), stack -> temp_type36 (2) = fixnum_type; addr (stack -> temp (1)) -> fixedb = Y - 1; addr (stack -> temp (2)) -> fixedb = X - 1; call lisp_special_fns_$cons; /* return (LINE . COLUMN) */ go to exit; end; if nargs = 2 then do; if stack -> temp (1) = nil then; else if stack -> temp_type36 (1) & Fixed36 then Y = 1 + addr (stack -> temp (1)) -> fixedb; else go to cursorpos_arg_symbol; if stack -> temp (2) = nil then; else if stack -> temp_type36 (2) & Fixed36 then X = 1 + addr (stack -> temp (2)) -> fixedb; else go to cursorpos_returns_nil; position_cursor_bounded: call get_window_info; X = min (max (X, 1), window_info.extent.width); Y = min (max (Y, 1), window_info.extent.height); call window_$position_cursor (p, Y, X, code); go to cursorpos_check_code; end; cursorpos_arg_symbol: if stack -> temp_type36 (1) & Atsym36 then en = stack -> temp_ptr (1) -> atom.pname; else if stack -> temp_type36 (1) & String36 then en = stack -> temp_ptr (1) -> lisp_string.string; else go to cursorpos_returns_nil; go to cursorpos_function (index ("ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_", translate (substr (en, 1, 1), "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"))); cursorpos_function (1): /* A: fresh line */ if X = 1 then go to cursorpos_returns_t; X = 1; Y = Y + 1; position_cursor_wrap: call get_window_info; if X < 1 then X = window_info.extent.width; else if X > window_info.extent.width then X = 1; if Y < 1 then Y = window_info.extent.height; else if Y > window_info.extent.height then Y = 1; call window_$position_cursor (p, Y, X, code); cursorpos_check_code: if code ^= 0 then go to cursorpos_returns_nil; go to cursorpos_returns_t; cursorpos_function (2): /* B: cursor backspace */ X = X - 1; go to position_cursor_wrap; cursorpos_function (3): /* C: Home & clear */ call window_$clear_window (p, code); go to cursorpos_check_code; cursorpos_function (4): /* D: cursor Down */ Y = Y + 1; go to position_cursor_wrap; cursorpos_function (5): /* E: Clear to end of screen */ call window_$clear_to_end_of_window (p, code); go to cursorpos_check_code; cursorpos_function (6): /* F: cursor Forward */ X = X + 1; go to position_cursor_wrap; cursorpos_function (8): /* H: move to column (arg 2) */ if nargs < 2 then go to cursorpos_returns_nil; if stack -> temp_type36 (2) & Fixed36 then X = 1 + addr (stack -> temp (2)) -> fixedb; else go to cursorpos_returns_nil; go to position_cursor_bounded; cursorpos_function (11): /* K: Erase 1 character forward */ cursorpos_K: call window_$clear_region (p, Y, X, 1, 1, code); go to cursorpos_check_code; cursorpos_function (12): /* L: clear to end of line */ cursorpos_function (29): /* ]: same as L (obsolete) */ call window_$clear_to_end_of_line (p, code); go to cursorpos_check_code; cursorpos_function (13): /* M: More wait, then home up */ Y = 0; /* Go to row 1 */ cursorpos_function (14): /* N: More wait, then (TERPRI) */ X = 1; /* Go to left of column */ Y = Y + 1; /* In next row */ call window_$get_one_unechoed_char (p, vcs_bit_bucket, "1"b, code); if code ^= 0 then go to cursorpos_returns_nil; go to position_cursor_wrap; cursorpos_function (20): /* T: (also 'TOP) home cursor to (0 0) */ X, Y = 1; go to position_cursor_wrap; cursorpos_function (21): /* U: cursor Up */ Y = Y - 1; go to position_cursor_wrap; cursorpos_function (22): /* V: Move to line (arg 2) */ if nargs < 2 then go to cursorpos_returns_nil; if stack -> temp_type36 (2) & Fixed36 then Y = 1 + addr (stack -> temp (2)) -> fixedb; else go to cursorpos_returns_nil; go to position_cursor_bounded; cursorpos_function (24): /* X: (cursorpos B) (cursorpos K) */ if X = 1 then go to cursorpos_K; X = X - 1; call window_$position_cursor (p, Y, X, code); if code ^= 0 then go to cursorpos_returns_nil; go to cursorpos_K; cursorpos_function (26): /* Z: position to lower-left corner */ X = 1; Y = 100000; /* Make sure it's out of bounds */ go to position_cursor_bounded; cursorpos_function (27): /* [: insert line */ i = -1; go to idel_lines_common; cursorpos_function (28): /* \: delete line */ i = 1; idel_lines_common: call get_window_info; call window_$scroll_region (p, Y, (window_info.extent.height - Y + 1), i, code); go to cursorpos_check_code; cursorpos_function (30): /* ^: insert char */ call window_$insert_text (p, " ", code); if code ^= 0 then go to cursorpos_returns_nil; call window_$position_cursor (p, Y, X, code); go to cursorpos_check_code; cursorpos_function (31): /* _: delete char */ call window_$delete_chars (p, 1, code); go to cursorpos_check_code; cursorpos_function (0): /* Undefined cursorpos function */ cursorpos_function (7): /* G: unused */ cursorpos_function (9): /* I: outut character (arg 2) -- not implemented on Multics */ cursorpos_function (10): /* J: unused */ cursorpos_function (15): /* O: unused */ cursorpos_function (16): /* P: output ^P -- unused in Multics */ cursorpos_function (17): /* Q: output ^C -- unused in Multics */ cursorpos_function (18): /* R: unused */ cursorpos_function (19): /* S: unused */ cursorpos_function (23): /* W: unused */ cursorpos_function (25): /* Y: unused */ cursorpos_returns_nil: stack -> temp(1) = nil; /* indicate not display tty */ go to exit; cursorpos_returns_t: stack -> temp (1) = t_atom; /* It worked. */ go to exit; get_window_info: procedure; window_info.version = window_position_info_version_1; call iox_$control (p, "get_window_info", addr (window_info), code); if code ^= 0 then go to cursorpos_returns_nil; end; /* subroutine to find true pathname, clobber into arg */ find_true_name: procedure(vcs); dcl vcs char(*) varying parameter; dcl dn char(168), en char(32), fn char(168), rnl fixed bin, sgp pointer, code fixed bin(35), hcs_$fs_get_path_name entry(pointer, char(*), fixed bin, char(*), fixed bin(35)), hcs_$initiate entry(char(*), char(*), char(*), fixed bin, fixed bin, pointer, fixed bin(35)), expand_path_ entry(pointer, fixed bin, pointer, pointer, fixed bin(35)), hcs_$terminate_noname entry(pointer, fixed bin(35)); dcl (null, substr, length, verify, reverse) builtin; if substr(vcs, 1, 1) ^= ">" then return; fn = vcs; call expand_path_(addr(fn), 168, addr(dn), addr(en), code); if code ^= 0 then return; call hcs_$initiate(dn, en, "", 0, 0, sgp, code); if sgp = null then return; call hcs_$fs_get_path_name(sgp, dn, rnl, en, code); if code ^= 0 then return; call hcs_$terminate_noname(sgp, code); if rnl > 1 then do; rnl = rnl + 1; substr(dn, rnl, 1) = ">"; end; vcs = substr(dn, 1, rnl) || substr(en, 1, 1+length(en)-verify(reverse(en), " ")); end find_true_name; end;  lisp_linker_.pl1 07/06/83 0937.0r w 06/29/83 1542.3 33723 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_linker_: procedure(link_ptr); /* Routine to handle the process of locating a compiled object segment referenced by a lisp environment. D. Reed */ dcl link_ptr ptr, (error_table_$namedup, error_table_$noentry) fixed bin(35) external, hcs_$initiate entry(char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35)), hcs_$make_ptr entry (ptr, char(*), char(*), ptr, fixed bin(35)), code fixed bin(35), message char(200) varying, signal_ entry(char(*), pointer, pointer), convert_status_code_ entry(fixed bin(35), char(8) aligned, char(100) aligned), error_table_message char(100) aligned, (length, verify, substr, reverse) builtin, 1 condition_info_structure automatic aligned structure, %include cond_info_structure; null builtin, sblkp ptr; %include lisp_comp_subr_block; %include symbol_block; dcl lisp_static_vars_$saved_environment_dir char(168) ext; retry: if lisp_static_vars_$saved_environment_dir ^= "" /* using some saved environment */ then do; call hcs_$initiate (lisp_static_vars_$saved_environment_dir, /* act as if we look here first */ link_ptr -> link_to_subr_code.name, link_ptr -> link_to_subr_code.name, 0,0, sblkp, code); /* don't care if successful */ if sblkp = null then if code ^= error_table_$noentry then if code ^= error_table_$namedup then go to badcode; /* linker bug prevents noaccess msg */ end; call hcs_$make_ptr(null(), link_ptr -> link_to_subr_code.name, "symbol_table", sblkp, code); if code ^= 0 then do; badcode: message = "Searching for " || link_ptr -> link_to_subr_code.name || "$symbol_table"; go to lossage; end; if sblkp -> sb.obj_creation_time ^= link_ptr -> link_to_subr_code.compilation_time then do; message = "The " || link_ptr -> link_to_subr_code.name || " found by search rules is not the version that was loaded into this environment."; go to lossage; end; call hcs_$make_ptr(null(), link_ptr -> link_to_subr_code.name, "*segtop", link_ptr -> link_to_subr_code.itp_to_linker, code); if code ^= 0 then do; message = "Searching for " || link_ptr -> link_to_subr_code.name || "|*segtop definition."; go to lossage; end; link_ptr -> lisp_subr_links(1).further_mod = "001000"b; /* x0 modifier */ return; lossage: condition_info_structure.length = size(condition_info_structure); condition_info_structure.version = 5246; /* since none of the documentaton says what this is supposed to be */ condition_info_structure.action_flags.pad = ""b; condition_info_structure.cant_restart = "0"b; condition_info_structure.default_restart = "0"b; /* you'd think "1"b was right, but it wants "0"b */ /* put error table message corresponding to code in the message */ if code = 0 then do; info_string = message; end; else do; /* error code goes in message */ call convert_status_code_(code, "", error_table_message); info_string = substr(error_table_message, 1, length(error_table_message) - verify(reverse(error_table_message), " ")+1) || " "; info_string = info_string || message; end; info_string = info_string || " Fix it and type start."; condition_info_structure.status_code = 0; /* I don't need two messages, thank you */ call signal_("lisp_linkage_error", null, addr(condition_info_structure)); go to retry; end lisp_linker_;  lisp_load_.pl1 11/20/86 1413.9r w 11/20/86 1145.0 193905 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_load_: proc; /* MACLISP load subr...takes one arg, the name of segment to be loaded, and loads it, returning t */ /* hacked by BSG 5/14/80 to not namedup */ /* declarations */ dcl (pathptr, tempp, stack, unm, object_ptr, actionp, entrp, entryp, linkp, linksp, constp, blockp, sblkp, symrtp, defp) ptr; dcl (length, addr, addrel, null, rtrim, ptr) builtin; dcl array_links_blockp pointer, call_array_link_snap_opr bit(36) static init("001000000001010110010111010001010000"b), array_link_space fixed bin(18), array_linksp pointer, number_of_array_links fixed bin; dcl constant_index fixed bin(17) aligned, 1 constant_index_format aligned structure based(addr(constant_index)), 2 unused_bits bit(18) unaligned, 2 load_time bit(1) unaligned, 2 constant_x fixed bin(16) unaligned; dcl 1 oi aligned automatic structure like object_info; dcl 1 error_struc based aligned, 2 code1 fixed bin(35), 2 code2 fixed bin(35); dcl code fixed bin(35), ename char (32), objects(0:10000) fixed bin(71) based aligned, lisp_static_vars_$no_snapped_links bit(1) external aligned, lisp_static_vars_$infile ext fixed bin(71), infile fixed bin(71) defined(lisp_static_vars_$infile), lisp_static_vars_$instack ext fixed bin(71), instack fixed bin(71) defined(lisp_static_vars_$instack), ent_length fixed bin(24), alloc_size fixed bin(18), i fixed bin(18), offset_head fixed bin, bit_count fixed bin (24), uname char (32), lisp_error_ entry, lisp_linker_ entry(pointer), unique_chars_ entry (bit (*)) returns (char (15)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)), hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)), hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)), get_definition_ entry (ptr, char(*), char(*), ptr, fixed bin(35)), error_table_$segknown ext fixed bin(35), lisp_alloc_ entry(fixed bin(18), fixed bin(71)), lisp_alloc_$cons entry, lisp_io_control_$openi entry, lisp_io_control_$close entry, lisp_reader_$read entry, lisp_$eval entry, object_info_$brief entry(ptr, fixed bin(24), ptr, fixed bin(35)), lisp_property_fns_$putprop entry, lisp_property_fns_$remprop entry, lisp_static_vars_$defun ext ptr, lisp_static_vars_$expr_hash ext fixed bin(71), lisp_static_man_$allocate entry(ptr, fixed bin(18)), lisp_get_atom_ entry(char(*), fixed bin(71)); dcl lisp_static_vars_$subr ext fixed bin(71), lisp_static_vars_$lsubr ext fixed bin(71), lisp_static_vars_$fsubr ext fixed bin(71), subr fixed bin(71) defined(lisp_static_vars_$subr), lsubr fixed bin(71) defined(lisp_static_vars_$lsubr), fsubr fixed bin(71) defined(lisp_static_vars_$fsubr); dcl lisp_linkage_error condition, /* signalled by lisp_linker_ (kludge) */ lisp_static_vars_$subr_block_list external pointer; %include definition; %include lisp_iochan; %include lisp_error_codes; %include object_info; %include lisp_comp_subr_block; %include lisp_stack_fmt; %include lisp_symb_tree; %include symbol_block; %include lisp_nums; %include lisp_atom_fmt; %include lisp_common_vars; %include lisp_control_chars; %include lisp_ptr_fmt; %include lisp_bignum_fmt; %include lisp_string_fmt; %include lisp_cons_fmt; /* get argument and locate segment we are to load */ stack = addrel(stack_ptr, -2); stack_ptr = addr(stack -> temp(3)); stack -> temp(2) = stack -> temp(1); call lisp_io_control_$openi; /* open the file */ if ^ stack -> temp_ptr(2) -> iochan.flags.seg then go to load_ascii_file; /* validate files object segment-ness */ uname = unique_chars_ (""b); ename = stack -> temp_ptr(2) -> iochan.name; call hcs_$initiate_count ((addr (stack -> temp_ptr(2) -> iochan.namelist) -> based_ptr -> cons_ptrs.car -> atom.pname), ename, uname, bit_count, (0), tempp, code); if tempp = null then go to fserror; oi.version_number = object_info_version_2; call object_info_$brief(tempp, bit_count, addr (oi), code); if code ^= 0 then go to load_ascii_file; call hcs_$make_ptr (null (), ename, "symbol_table", sblkp, code); /* This croque gets the linkage section combined */ call get_definition_ (oi.defp, ename, "symbol_table", tempp, code); if code ^= 0 then do; fserror: unm = unmkd_ptr; unmkd_ptr = addrel(unm,2); unm -> error_struc.code1 = file_sys_fun_err; unm -> error_struc.code2 = code; stack_ptr = addr(stack->temp(5)); stack -> temp(4) = nil; stack -> temp(3) = stack -> temp(1); call lisp_get_atom_("load", stack -> temp(2)); call lisp_alloc_$cons; call lisp_alloc_$cons; call lisp_error_; call lisp_io_control_$close; stack -> temp(1) = stack -> temp(2); stack_ptr = addr(stack -> temp(2)); return; end; sblkp = addrel (oi.symbp, tempp -> definition.value); if sblkp -> sb.generator ^= "lisp" | /* make sure is lisp obj seg!! */ sblkp -> sb.gen_version_number ^= 2 then do; /* must be old defs file crock */ dcl 1 err_msg static aligned structure, /* make msg to type out */ 2 lth fixed bin(8) unaligned init(56), 2 msg char(56) unaligned init( "This format of object segment no longer supported - load"), packed_ptr unaligned pointer; packed_ptr = addr(err_msg); unspec(code) = unspec(packed_ptr); /* kludge it up for convert_status_code_ */ go to fserror; end; call bind_io_atoms; stack = addr(stack->temp(9)); /* protect the bindings carefully */ symrtp = addrel(sblkp, sblkp -> sb.area_ptr); /* get pointer to lisp's data */ /* we must now create the data which will be used in this loading phase */ stack_ptr = addr(stack -> temp(symrtp -> symbol_root.number_objects + 3)); stack -> temp(2) = nil; /* first object */ object_ptr = addr(stack -> temp(3)); /* now create all the fixnums needed in this phase */ blockp = addrel(symrtp, symrtp -> symbol_root.objects.fixnum_blockp); do i = 1 to blockp -> fixnum_block.count; object_ptr -> fixnum_fmt.type_info = fixnum_type; object_ptr -> fixnum_fmt.fixedb = blockp -> fixnum_block.fixnums(i); object_ptr = addr(object_ptr -> objects(1)); end; /* flonums */ blockp = addrel(symrtp, symrtp -> symbol_root.objects.flonum_blockp); do i = 1 to blockp -> flonum_block.count; object_ptr -> flonum_fmt.type_info = flonum_type; object_ptr -> flonum_fmt.floatb = blockp -> flonum_block.flonums(i); object_ptr = addr(object_ptr -> objects(1)); end; /* strings */ blockp = addrel(symrtp, symrtp -> symbol_root.objects.string_blockp); do i = 1 to blockp -> string_block.count; tempp = addrel(symrtp, blockp -> string_block.string_offset(i)); alloc_size = 2*divide(tempp -> string_chars.length+11,8,17,0); call lisp_alloc_(alloc_size, object_ptr -> objects(0)); object_ptr -> based_ptr -> lisp_string.string_length = tempp -> string_chars.length; object_ptr -> lisp_ptr_type = object_ptr -> lisp_ptr_type | String36; object_ptr -> based_ptr -> lisp_string.string = tempp -> string_chars.chars; object_ptr = addr(object_ptr -> objects(1)); end; /* bignums */ blockp = addrel(symrtp, symrtp -> symbol_root.objects.bignum_blockp); do i = 1 to blockp -> bignum_block.count; tempp = addrel (symrtp, blockp -> bignum_block.bignum_offsets(i)); alloc_size = 2*divide(1+tempp -> lisp_bignum.prec,2,17,0); call lisp_alloc_(alloc_size, object_ptr -> objects(0)); object_ptr -> based_ptr -> lisp_bignum.sign = tempp -> lisp_bignum.sign; object_ptr -> based_ptr -> lisp_bignum.prec = tempp -> lisp_bignum.prec; object_ptr -> based_ptr -> lisp_bignum.words = tempp -> lisp_bignum.words; object_ptr -> lisp_ptr_type = object_ptr -> lisp_ptr_type | Bignum36; object_ptr = addr(object_ptr -> objects(1)); end; /* atsyms */ blockp = addrel(symrtp, symrtp -> symbol_root.objects.atsym_blockp); do i = 1 to blockp -> atsym_block.count; tempp = addrel(symrtp, blockp -> atsym_block.atsym_offset(i)); if tempp->string_chars.flags.uninterned_atom then do; call lisp_alloc_(2*divide(tempp->string_chars.length+27,8,17,0), object_ptr->objects(0)); object_ptr -> lisp_ptr_type = object_ptr -> lisp_ptr_type | Atsym36; object_ptr -> based_ptr -> atom.value = 0; object_ptr -> based_ptr -> atom.plist = nil; object_ptr -> based_ptr -> atom.pnamel = tempp -> string_chars.length; object_ptr -> based_ptr -> atom.pname = tempp -> string_chars.chars; end; else call lisp_get_atom_(tempp -> string_chars.chars, object_ptr -> objects(0)); object_ptr = addr(object_ptr -> objects(1)); end; /* now make the conses of these items which are used in this loading phase */ blockp = addrel(symrtp, symrtp -> symbol_root.objects.cons_blockp); tempp = stack_ptr; do i = 1 to blockp -> cons_block.count; stack_ptr = addr(tempp -> temp(3)); /* room for args to cons */ tempp -> temp(1) = stack -> objects(blockp -> cons_block.conses(i).car+1); tempp -> temp(2) = stack -> objects(blockp -> cons_block.conses(i).cdr+1); call lisp_alloc_$cons; object_ptr -> objects(0) = tempp -> temp(1); object_ptr = addr(object_ptr -> objects(1)); end; object_ptr = addr(stack -> temp(2)); if symrtp -> symbol_root.version >= 2 then do; /* count array links */ array_links_blockp = addrel(symrtp, symrtp -> symbol_root.array_links_blockp); number_of_array_links = array_links_blockp -> array_links_block.count; if number_of_array_links ^= 0 then array_link_space = 4*number_of_array_links + 2; else array_link_space = 0; end; else number_of_array_links, array_link_space = 0; /* now create the subr block for this object segment */ if symrtp -> symbol_root.subr_block_size = 0 then go to no_subr_block; ent_length = length (rtrim (ename)); alloc_size = symrtp -> symbol_root.subr_block_size*2+13+divide(ent_length+3,4,17,0)+array_link_space; call lisp_static_man_$allocate (blockp, alloc_size); blockp -> subr_block_head.instructions = instructions_for_subr; blockp -> subr_block_head.subr_code_link_offset = 2*symrtp -> symbol_root.subr_block_size+2+array_link_space; blockp -> subr_block_head.gcmark = "0"b; blockp -> subr_block_head.rest_of_tsplp = tsplp_ic_ind; constp = addrel(symrtp, symrtp -> symbol_root.const_blockp); linksp = addrel(symrtp, symrtp -> symbol_root.links_blockp); entryp = addrel(symrtp, symrtp -> symbol_root.entry_blockp); blockp -> subr_block_head.gc_length = constp -> const_block.count + linksp -> links_block.count; /* now fill in constants to be placed in subr block for use of compiled code */ do i = 1 to constp -> const_block.count; constant_index = constp -> const_block.constants(i); blockp -> subr_block_head.constants(i) = object_ptr -> objects(constant_index_format.constant_x); if constant_index_format.load_time then do; /*load-time eval*/ tempp = stack_ptr; stack_ptr = addr(tempp -> temp(2)); tempp -> temp(1) = blockp -> subr_block_head.constants(i); call lisp_$eval; blockp -> subr_block_head.constants(i) = tempp -> temp(1); stack_ptr = tempp; end; end; /* now fill in the itp links to other subroutines */ call generate_links; generate_links: proc; linkp = addr(blockp -> subr_block_head.constants(constp -> const_block.count+1)); do i = 1 to linksp -> links_block.count; linkp -> lisp_subr_links(i).itp_base = "001"b; /* ab */ linkp -> lisp_subr_links(i).itp_info = linksp -> links_block.link_info(i); linkp -> lisp_subr_links(i).itp_mod = "100001"b; /* itp */ linkp -> lisp_subr_links(i).link_opr_tv_offset = "000000000000011010"b; /* 26 decimal */ linkp -> lisp_subr_links(i).mbz = "0"b; linkp -> lisp_subr_links(i).further_mod = "010000"b; /* indirect */ end; end generate_links; /* now fill in the entry point code for each subroutine */ entrp = addr(linkp -> lisp_subr_links(linksp -> links_block.count+1)); offset_head = -2*(linksp -> links_block.count+constp -> const_block.count)-7; do i = 1 to entryp -> entry_block.count; entrp -> subr_entries(i).nargs = entryp -> entry_block.entry_info(i).nargs; entrp -> subr_entries(i).code_offset = entryp -> entry_block.entry_info(i).entrypoint; entrp -> subr_entries(i).head_offset = offset_head; offset_head = offset_head - 2; entrp -> subr_entries(i).rest_of_tsx0 = tsx0_ic; end; array_linksp = addr(entrp -> subr_entries(entryp -> entry_block.count+1)); if number_of_array_links ^= 0 then call generate_array_links; tempp = array_linksp; /* next free doubleword */ generate_array_links: procedure; do i = 1 to number_of_array_links; array_linksp -> array_links(i).instruction = call_array_link_snap_opr; unspec(array_linksp -> array_links(i).control_word) = array_links_blockp -> array_links_block.control_word(i); array_linksp -> array_links(i).pointer = null; end; array_linksp = addr(array_linksp -> array_links(i)); array_linksp -> array_link_count.number_of_array_links = number_of_array_links; array_linksp -> array_link_count.must_be_zero = ""b; array_linksp = addrel(array_linksp, 2); end generate_array_links; call get_definition_ (oi.defp, ename, "*segtop", defp, code); if code ^= 0 then go to fserror; tempp -> link_to_subr_code.itp_to_linker = addrel (oi.textp, defp -> definition.value); tempp -> lisp_subr_links(1).further_mod = "001000"b; /* x0 */ tempp -> link_to_subr_code.compilation_time = sblkp -> sb.obj_creation_time; tempp -> link_to_subr_code.name_length = ent_length; tempp -> link_to_subr_code.name = ename; /* thread this block onto list of subr blocks */ blockp -> subr_block_head_overlay.no_links_are_snapped = "1"b; /**** CHANGE THIS IF PRE-LINKING IS IMPLEMENTED ****/ blockp -> subr_block_head.next_compiled_block = lisp_static_vars_$subr_block_list; lisp_static_vars_$subr_block_list = blockp; no_subr_block: /* now that we have completed the subr block, we must execute the action list */ tempp = stack_ptr; stack_ptr = addr(tempp -> temp(3)); if symrtp -> symbol_root.subr_block_size > 0 then alloc_size = entryp -> entry_block.count; /* how many entries are there to define */ else alloc_size = 0; if alloc_size ^= 0 then do; tempp -> temp_ptr(1) = entrp; tempp -> lisp_ptr_type = tempp -> lisp_ptr_type | Subr36; end; actionp = addrel(symrtp, symrtp -> symbol_root.action_blockp); do i = 1 to actionp -> action_block.count; tempp -> temp(2) = object_ptr -> objects(actionp->action_block.actions(i).operand); go to action(actionp -> action_block.actions(i).action_code); action(0): /* evaluate object operand */ call lisp_$eval; go to endaction; action(1): /* define operand as subr */ stack_ptr = addr(tempp -> temp(7)); tempp -> temp(4) = subr; go to putprop; action(2): /* define operand as lsubr */ stack_ptr = addr(tempp -> temp(7)); tempp ->temp(4) = lsubr; go to putprop; action(3): /* define operand as fsubr */ stack_ptr = addr(tempp -> temp(7)); tempp -> temp(4) = fsubr; putprop: tempp -> temp(3) = tempp -> temp(1); /* get next subr */ remloop: tempp -> temp(5) = tempp -> temp(2); tempp -> temp(6) = tempp -> temp(4); call lisp_property_fns_$remprop; if tempp -> temp(5) ^= nil then do; stack_ptr = addr(tempp->temp(7)); go to remloop; end; if lisp_static_vars_$defun->atom.value ^= 0 & lisp_static_vars_$defun -> atom.value ^= nil then do; stack_ptr = addr(tempp->temp(7)); tempp->temp(5) = tempp->temp(2); tempp->temp(6) = lisp_static_vars_$expr_hash; call lisp_property_fns_$remprop; end; stack_ptr = addr(tempp->temp(5)); call lisp_property_fns_$putprop; alloc_size = alloc_size - 1; if alloc_size > 0 then tempp -> lisp_ptr.offset = tempp->lisp_ptr.offset+2; else tempp -> temp(1) = nil; /* don't confuxe gc'er */ endaction: end; tempp -> temp(1) = nil; /* since this points to a nonno */ /* carefully undo what was done */ stack = addrel(stack,-16); call unbind_io_atoms; stack_ptr = addr(stack -> temp(3)); call lisp_io_control_$close; stack_ptr = addr(stack -> temp(2)); stack -> temp(1) = t_atom; return; /* part to cause ascii file to be loaded */ load_ascii_file: stack -> flonum_fmt.type_info = flonum_type; stack -> fixnum_fmt.fixedb = 0; /* illegal float number */ call bind_io_atoms; bind_io_atoms: proc; stack_ptr = addr(stack -> temp(9)); /* room for bindings */ unm = unmkd_ptr; unmkd_ptr = addrel(unm,2); stack -> bindings(2).atom = infile; stack -> bindings(3).atom = ctrlQ; stack -> bindings(4).atom = instack; stack -> bindings(2).old_val = addr(infile) -> based_ptr -> atom.value; stack -> bindings(3).old_val = addr(ctrlQ) -> based_ptr -> atom.value; stack -> bindings(4).old_val = addr(instack) -> based_ptr -> atom.value; unm -> binding_block.top_block = rel(addr(stack -> bindings(5))); unm -> binding_block.bot_block = rel(addr(stack -> bindings(2))); unm -> binding_block.back_ptr = rel(binding_top); binding_top = unm; addr(infile) -> based_ptr -> atom.value = stack -> temp(2); addr(ctrlQ) -> based_ptr -> atom.value = t_atom; addr(instack) -> based_ptr -> atom.value = nil; return; unbind_io_atoms: entry; addr(infile) -> based_ptr -> atom.value = stack -> bindings(2).old_val; addr(ctrlQ) -> based_ptr -> atom.value = stack -> bindings(3).old_val; addr(instack) -> based_ptr -> atom.value = stack -> bindings(4).old_val; binding_top = ptr(binding_top, unm -> binding_block.back_ptr); unmkd_ptr = unm; end bind_io_atoms; loop: stack_ptr = addr(stack -> temp(11)); stack -> temp(9) = stack -> temp(1); /* eof detector */ addr(stack -> temp(10)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(10)) -> fixedb = -2; call lisp_reader_$read; if stack -> temp(9) = stack -> temp(1) then do; stack -> temp(9) = addr(infile) -> based_ptr -> atom.value; if addr(instack) -> based_ptr -> atom.value ^= nil /* have inpushed, so keep going */ then do; call lisp_io_control_$close; go to loop; end; else call lisp_io_control_$close; call unbind_io_atoms; stack -> temp(1) = t_atom; stack_ptr = addr(stack ->temp(2)); return; end; call lisp_$eval; go to loop; /* entry to do the work of (sstatus uuolinks) */ unsnap_all_links: entry; do blockp = lisp_static_vars_$subr_block_list repeat (blockp -> subr_block_head.next_compiled_block) while (blockp ^= null); /* do loop for all subr blocks */ /* a great deal of time can be saved by first checking if there are any links in this subr block that need to be unsnapped */ if blockp -> subr_block_head_overlay.no_links_are_snapped then go to skip_this_block; if addrel(blockp, blockp -> subr_block_head.subr_code_link_offset + 6) -> lisp_ptr.itsmod ^= "100011"b /* if not its pointer */ then do; /* then must snap link to text section */ on condition(lisp_linkage_error) go to skip_this_block; call lisp_linker_(addrel(blockp, blockp -> subr_block_head.subr_code_link_offset + 6)); revert condition(lisp_linkage_error); end; /* Grab the symbol root pointer */ unspec (tempp) = unspec (addrel (blockp, blockp -> subr_block_head.subr_code_link_offset + 6) -> based_ptr) & "077777777777777777000000"b3; tempp = ptr (tempp, 0); /* object info seems to care */ call hcs_$status_mins (tempp, (0), bit_count, code); if code ^= 0 then go to skip_this_block; oi.version_number = object_info_version_2; call object_info_$brief (tempp, bit_count, addr (oi), code); if code ^= 0 then go to skip_this_block; call get_definition_ (oi.defp, addrel(blockp, blockp -> subr_code_link_offset + 6) -> link_to_subr_code.name, "symbol_table",tempp, code); if code ^= 0 then go to skip_this_block; sblkp = addrel (oi.symbp, tempp -> definition.value); symrtp = addrel(sblkp, sblkp -> sb.area_ptr); if symrtp -> symbol_root.subr_block_size = 0 then go to skip_this_block; linksp = addrel(symrtp, symrtp -> symbol_root.links_blockp); /* -> data to reinitialize links with */ constp = addrel(symrtp, symrtp -> symbol_root.const_blockp); call generate_links; if symrtp -> symbol_root.version >= 2 then do; /* unsnap array links too */ array_links_blockp = addrel(symrtp, symrtp -> symbol_root.array_links_blockp); number_of_array_links = array_links_blockp -> array_links_block.count; if number_of_array_links ^= 0 then do; array_linksp = addrel(blockp, blockp -> subr_code_link_offset+6-2); array_linksp = addrel(array_linksp, -4 * array_linksp -> array_link_count.number_of_array_links); call generate_array_links; end; end; skip_this_block: revert condition(lisp_linkage_error); /* may have been left enabled if it was signalled above - anyway doesn't cost anything */ blockp -> subr_block_head_overlay.no_links_are_snapped = "1"b; end; /* end of do loop for each subr block */ return; end lisp_load_;  lisp_loadumparrays_.pl1 07/06/83 0937.0r w 06/29/83 1542.3 112626 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ dumparrays: proc; /* lisp_loadumparrays_ * This modules contains the loadarrays and dumparrays subrs for LISP * Written 74.08.09 by DAM * do not compile with the optimize option */ /* Declarations for format of a dumped array file */ dcl 1 dumped_array_file based aligned, 2 type fixed bin(17) unaligned, /* negative for pdp-10, positive for Multics */ 2 count fixed bin(17) unaligned, /* number of words (10) or characters (Multics) in pname */ 2 pname char(p -> dumped_array_file.count) unaligned, 2 data; /* the above structure is followed by the below, and the pair is repeated once for each array dumped */ dcl 1 dumped_array_data based aligned, 2 word_count fixed bin(17) unaligned, /* minus number of words in array */ 2 array_type fixed bin(17) unaligned, /* 1=fixnum, 2=flonum */ 2 data(- p->dumped_array_data.word_count) bit(36); /* the following special mark falls after the last dumped array */ dcl end_of_file_mark bit(36) static init((5)"0000011"b), word bit(36) aligned based; /* pointer to current data in the file */ dcl p pointer; /* declarations for PDP-10 compatibility */ dcl byte7 (0:4) bit(7) unaligned based, 1 PDP10_flonum based aligned, 2 sign bit(1) unaligned, 2 exponent fixed bin(7) unaligned, 2 mantissa bit(27) unaligned, 1 H6180_flonum based aligned, 2 exponent fixed bin(7) unaligned, 2 mantissa fixed bin(27) unaligned, a_word fixed bin(35) aligned; /* flag for Multics format */ dcl Multics_flag fixed bin(17) static init(000001100000100100b); /* 014044 octal */ /* misc dcl */ dcl stack pointer, myname fixed bin(35), (i, j, n) fixed bin(18), ch char(1), words (n) bit(36) aligned based, pdp10_compatibility bit(1), convert_flonums bit(1), lisp_property_fns_$get entry, lisp_property_fns_$putprop entry, lisp_get_atom_ entry(char(*), fixed bin(71)), lisp_special_fns_$xcons entry, lisp_special_fns_$cons entry, lisp_array_fcns_$star_array entry, lisp_special_fns_$gensym entry; dcl unm pointer, pnamebuf char(i) based(unm); dcl hcs_$terminate_noname entry(pointer, fixed bin(35)), hcs_$truncate_seg entry(pointer, fixed bin(18), fixed bin(35)), hcs_$set_bc_seg entry(pointer, fixed bin(24), fixed bin(35)), hcs_$make_seg entry(char(*), char(*), char(*), fixed bin(5), pointer, fixed bin(35)), hcs_$initiate entry(char(*), char(*), char(*), fixed bin(1), fixed bin(2), pointer, fixed bin(35)), expand_path_ entry(pointer, fixed bin, pointer, pointer, fixed bin(35)), dn char(168), en char(32), code fixed bin(35); dcl fp pointer, bflonum float bin(27) aligned based, fsign float bin(1); /* LISP constants */ dcl (lisp_static_vars_$array, lisp_static_vars_$fixnum, lisp_static_vars_$flonum) fixed bin(71) external; /* error codes */ dcl (lisp_error_table_$bad_argument, lisp_error_table_$file_sys_fun_err, lisp_error_table_$argument_must_be_array, lisp_error_table_$special_array_type) fixed bin(35) external; /* Builtin */ dcl (addr, addrel, size, unspec, fixed, bit, substr, null, divide, rel, translate) builtin; /* include files */ %include lisp_common_vars; %include lisp_stack_fmt; %include lisp_cons_fmt; %include lisp_nums; %include lisp_ptr_fmt; %include lisp_array_fmt; %include lisp_atom_fmt; %include lisp_string_fmt; %include lisp_name_codes; /* dumparrays subr. first arg is list of arrays, second is pathname. if pathname is (pdp10 pathname), pdp10 format is used */ myname = fn_dumparrays; stack = addrel(stack_ptr, -4); /* 2 args */ if stack -> temp_type(2) = Cons then do; if stack -> temp_ptr(2) -> cons_ptrs.car -> atom.pname ^= "pdp10" then go to wta; pdp10_compatibility = "1"b; stack -> temp(2) = stack -> temp_ptr(2) -> cons_ptrs.cdr -> cons.car; end; else pdp10_compatibility = "0"b; /* create the output file */ if stack -> temp_type36(2) & Atsym36 then p = addr(stack -> temp_ptr(2) -> atom.pnamel); else if stack -> temp_type36(2) & String36 then p = stack -> temp_ptr(2); else go to wta; call expand_path_(addr(p -> lisp_string.string), p -> lisp_string.string_length, addr(dn), addr(en), code); if code ^= 0 then go to fserr; call hcs_$make_seg(dn, en, "", 1011b, p, code); if p = null then go to fserr; /* begin dumping arrays */ do while(stack -> temp(1) ^= nil); stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* an array */ /* put out the pname */ if ^ pdp10_compatibility then do; p -> dumped_array_file.type = Multics_flag; p -> dumped_array_file.count = stack -> temp_ptr(2) -> atom.pnamel; p -> dumped_array_file.pname = stack -> temp_ptr(2) -> atom.pname; p = addr(p -> dumped_array_file.data); end; else do; n = divide(4 + stack -> temp_ptr(2) -> atom.pnamel, 5, 17, 0); p -> dumped_array_file.type = -n; p -> dumped_array_file.count = n; p = addr(p -> dumped_array_file.pname); j = 0; do i = 1 by 1 while(i <= stack -> temp_ptr(2) -> atom.pnamel); ch = substr(stack -> temp_ptr(2) -> atom.pname, i, 1); ch = translate(ch, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"); p -> byte7(j) = substr(unspec(ch), 3, 7); j = j + 1; if j > 4 then do; j = 0; p = addrel(p, 1); end; end; end; /* put out the array data */ stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = lisp_static_vars_$array; call lisp_property_fns_$get; if stack -> temp(2) = nil then call err1(lisp_error_table_$argument_must_be_array); convert_flonums = "0"b; if stack -> temp_ptr(2) -> array_info.type = Fixnum_array then p -> dumped_array_data.array_type = 1; else if stack -> temp_ptr(2) -> array_info.type = Flonum_array then do; p -> dumped_array_data.array_type = 2; convert_flonums = pdp10_compatibility; end; else call err1(lisp_error_table_$special_array_type); /* compute array size */ n = 1; do i = 1-stack -> temp_ptr(2) -> array_info.ndims by 1 to 0; n = n * stack -> temp_ptr(2) -> array_info.array_data_ptr -> array_data.dope_vector(i).bounds; end; p -> dumped_array_data.word_count = -n; /* put it out */ /* p -> dumped_array_data.data = stack -> temp_ptr(2) -> array_info.array_data_ptr -> words; */ addr(p -> dumped_array_data.data)->words = stack -> temp_ptr(2) -> array_info.array_data_ptr -> words; if convert_flonums then do i = 1 by 1 while(i <= n); fp = addr(p -> dumped_array_data.data(i)); a_word = 0; if fp -> bflonum ^= 0.0 then do; addr(a_word) -> PDP10_flonum.exponent = fp -> H6180_flonum.exponent + 128; if fp -> H6180_flonum.mantissa >= 0 then addr(a_word) -> PDP10_flonum.mantissa = bit(fp -> H6180_flonum.mantissa, 27); else do; if substr(fp -> word, 9) = "1"b then do; addr(a_word)->PDP10_flonum.mantissa = "1"b; addr(a_word) -> PDP10_flonum.exponent = addr(a_word) -> PDP10_flonum.exponent + 1; end; else addr(a_word) -> PDP10_flonum.mantissa = bit(fixed(-fp -> H6180_flonum.mantissa,27),27); a_word = -a_word; end; end; fp -> word = unspec(a_word); end; /* advance pointer to after this array's stuff */ p = addrel(p, size(dumped_array_data)); stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; end; /* put end of file marker */ p -> word = end_of_file_mark; n = 1+fixed(rel(p),18); call hcs_$truncate_seg(p, n, code); call hcs_$set_bc_seg(p, 36*n, code); call hcs_$terminate_noname(p, code); exit: stack_ptr = addr(stack -> temp(2)); return; loadarrays: entry; /* loadarrays subr. arg is pathname. will load either a pdp10 or a Multics file. */ myname = fn_loadarrays; stack = addrel(stack_ptr, -2); /* 1 arg */ if stack -> temp_type36(1) & Atsym36 then p = addr(stack -> temp_ptr(1) -> atom.pnamel); else if stack -> temp_type36(1) & String36 then p = stack -> temp_ptr(1); else go to wta; /* open the file */ call expand_path_(addr(p -> lisp_string.string), p -> lisp_string.string_length, addr(dn), addr(en), code); if code ^= 0 then go to fserr; call hcs_$initiate(dn, en, "", 0, 0, p, code); if p = null then go to fserr; /* begin processing */ pdp10_compatibility = "0"b; if p -> dumped_array_file.type < 0 then pdp10_compatibility = "1"b; stack -> temp(1) = nil; /* initialize return list */ do while(p -> word ^= end_of_file_mark); /* get old pname */ stack_ptr = addr(stack -> temp(3)); addr(stack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2)) -> fixedb = 0; call lisp_special_fns_$gensym; stack_ptr = addr(stack -> temp(6)); if ^ pdp10_compatibility then do; call lisp_get_atom_(p -> dumped_array_file.pname, stack -> temp(3)); p = addr(p -> dumped_array_file.data); end; else do; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2*divide(7 + 5* p->dumped_array_file.count, 8, 18, 0)); fp = addr(p -> dumped_array_file.pname); i = 0; do j = 1 to p -> dumped_array_file.count; do n = 0 to 4; if fp -> byte7(n) then do; unspec(ch) = "00"b || fp -> byte7(n); ch = translate(ch, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ"); substr(unm -> pnamebuf, i+1, 1) = ch; i = i + 1; end; end; fp = addrel(fp, 1); end; p = addrel(p, j); call lisp_get_atom_(unm -> pnamebuf, stack -> temp(3)); unmkd_ptr = unm; end; stack_ptr = addr(stack -> temp(11)); /* compute size & type of array and create it */ if p -> dumped_array_data.array_type = 2 then do; convert_flonums = pdp10_compatibility; stack -> temp(8) = lisp_static_vars_$flonum; end; else do; convert_flonums = "0"b; stack -> temp(8) = lisp_static_vars_$fixnum; end; addr(stack -> temp(4)) -> fixnum_fmt.type_info, addr(stack -> temp(9)) -> fixnum_fmt.type_info, addr(stack -> temp(10)) -> fixnum_fmt.type_info = fixnum_type; n = - p -> dumped_array_data.word_count; addr(stack -> temp(4)) -> fixedb, addr(stack -> temp(9)) -> fixedb = n; addr(stack -> temp(10)) -> fixedb = -6; /* passing 3 args */ stack -> temp(7) = nil; call lisp_array_fcns_$star_array; /* stack -> temp_ptr(7) -> array_info.array_data_ptr -> words = p -> dumped_array_data.data; */ stack -> temp_ptr(7) -> array_info.array_data_ptr -> words = addr(p -> dumped_array_data.data)->words; if convert_flonums then do i = 1 by 1 while(i <= n); fp = addr(stack -> temp_ptr(7) -> array_info.array_data_ptr -> words(i)); unspec(a_word) = fp -> word; if a_word = 0 then fp -> bflonum = 0.0; else do; if a_word > 0 then do; fsign =1.0; end; else do; fsign = -1.0; a_word = -a_word; end; fp -> H6180_flonum.exponent = addr(a_word) -> PDP10_flonum.exponent - 128; fp -> H6180_flonum.mantissa = fixed(addr(a_word)->PDP10_flonum.mantissa, 27); fp -> bflonum = fp -> bflonum * fsign; end; end; p = addrel(p, size(dumped_array_data)); stack_ptr = addr(stack -> temp(9)); stack -> temp(6) = stack -> temp(2); stack -> temp(8) = lisp_static_vars_$array; call lisp_property_fns_$putprop; /* cons up return list */ stack_ptr = addr(stack -> temp(6)); stack -> temp(5) = nil; do i = 0 to 2; call lisp_special_fns_$cons; end; call lisp_special_fns_$xcons; end; call hcs_$terminate_noname(p, code); go to exit; /* error handlers */ dcl 1 error_push aligned based, 2 (code1, code2) fixed bin(35), lisp_error_ entry; wta: call err(lisp_error_table_$bad_argument); fserr: myname = code; call err(lisp_error_table_$file_sys_fun_err); err1: proc(ecode); stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* retrieve the bad array name */ err: entry(ecode); dcl ecode fixed bin(35); unm = unmkd_ptr; unmkd_ptr = addrel(unm, size(error_push)); unm -> code1 = ecode; unm -> code2 = myname; call lisp_error_; /* in case it returns, return what it returned */ stack -> temp(1) = addrel(stack_ptr, -2) -> temp(1); go to exit; end; end;  lisp_obarray_utils_.pl1 07/06/83 0937.0r w 06/29/83 1542.3 62217 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_obarray_utils_: proc; /* procedure to find an atom by name, and intern it on the current obarray. Redone completely for the unsharing of nil and the PL/I null pointer. Single character atoms put in obarray, 12 Nov 72, DAM New hash function, 12 Nov 72, DAM Modified 74.05.31 by DAM for new arrays. intern, remob, makoblist added. */ dcl htptr ptr, /* temp pointer to hash table */ 1 obarray_struct based(htptr) aligned, 2 hash_table(0:510) fixed bin(71), 2 char_objects(0:127) fixed bin(71), namelen fixed bin, indx fixed bin, lisp_get_atom_$hash_fcn entry(char(*) aligned, fixed bin), /* first arg better be padded with \000 to multiple of 4 characters */ lisp_alloc_ entry(fixed bin, fixed bin(71) aligned), lisp_array_fcns_$star_array entry, lisp_special_fns_$xcons entry, lisp_special_fns_$cons entry, lisp_list_utils_$subst entry, nargs fixed bin, stack ptr, (addr, divide, length, mod, substr) builtin; %include lisp_ptr_fmt; %include lisp_stack_fmt; %include lisp_cons_fmt; %include lisp_atom_fmt; %include lisp_nums; %include lisp_array_fmt; %include lisp_common_vars; init_ht: entry; stack = stack_ptr; stack_ptr = addr(stack -> temp(5)); call lisp_alloc_(6,stack->temp(1)); /* room for nil */ stack -> temp_type(1) = Atsym; stack -> temp_ptr(1) -> atom.value = stack -> temp(1); /* value (nil) = nil */ stack -> temp_ptr(1) ->atom.plist = stack -> temp(1); /* plist (nil) = nil */ stack -> temp_ptr(1) -> atom.pnamel = 3; substr(stack -> temp_ptr(1) -> atom.pname,1,3) = "nil"; nil = stack -> temp(1); call lisp_alloc_(8,stack->temp(1)); stack -> temp_type(1) = Atsym; stack -> temp_ptr(1) -> atom.pnamel = 7; substr(stack -> temp_ptr(1) ->atom.pname,1,7) = "obarray"; stack -> temp_ptr(1) -> atom.plist = nil; obarray = stack -> temp(1); /* use *array to create an initially empty obarray. it will look at the entries nil and obarray in lisp_static_vars_, only */ addr(stack -> temp(4)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(4)) -> fixedb = -6; stack -> temp(1) = nil; stack -> temp(2) = obarray; stack -> temp(3) = nil; call lisp_array_fcns_$star_array; /* create array pointer, make empty obarray, return array ptr */ addr(obarray) -> based_ptr -> atom.value = stack -> temp(1); htptr = stack -> temp_ptr(1) -> array_info.array_data_ptr; call lisp_get_atom_$hash_fcn("obarray", indx); stack_ptr = addr(stack -> temp(3)); stack -> temp(2) = nil; stack -> temp(1) = obarray; call lisp_special_fns_$cons; hash_table(indx) = stack -> temp(1); call lisp_get_atom_$hash_fcn("nil", indx); stack_ptr = addr(stack -> temp(3)); stack -> temp(2), stack -> temp(1) = nil; call lisp_special_fns_$cons; hash_table(indx) = stack -> temp(1); return; in: entry(atomic_object); in_out = 0; goto hashjoin; out: entry(atomic_object); dcl atomic_object fixed bin(71)aligned, in_out fixed bin(1); in_out = 1; hashjoin: if addr(atomic_object)->lisp_ptr_type & Atsym36 then; else return; htptr = addr(obarray)->based_ptr->atom_ptrs.value -> array_info.array_data_ptr; call lisp_get_atom_$hash_fcn(addr(atomic_object)->based_ptr -> atom.pname, indx); if indx >= 511 then go to sing_char(in_out); /* single char atom */ stack = stack_ptr ; stack_ptr = addr(stack -> temp(4)); stack -> temp(1) = hash_table(indx); stack -> temp_ptr(2) = addr(hash_table(indx-1)); stack -> temp_type(2) = Numeric; do while(stack->temp(1) ^= nil); stack -> temp(3) = stack -> temp_ptr(1) -> cons.car; go to case(in_out); case(0): if stack -> temp_ptr(3) -> atom.pname = addr(atomic_object) -> based_ptr -> atom.pname then do; atomic_object = stack -> temp(3); go to done_out; end; else go to endcase; case(1): if stack -> temp(3) = atomic_object then do; stack -> temp_ptr(2) -> cons.cdr = stack -> temp_ptr(1) -> cons.cdr; go to done_out; end; endcase: stack -> temp(2) = stack -> temp(1); stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; end; if in_out = 0 then do; stack -> temp(3) = hash_table(indx); stack -> temp(2) = atomic_object; call lisp_special_fns_$cons; htptr = addr(obarray)->based_ptr->atom_ptrs.value -> array_info.array_data_ptr; /* gc may have moved it or lost it */ hash_table(indx) = stack -> temp(2); end; done_out: stack_ptr = stack; return; sing_char(0): /* insert single char atom if not already there */ if hash_table(indx) ^= nil then atomic_object = hash_table(indx); else hash_table(indx) = atomic_object; return; sing_char(1): hash_table(indx) = nil; return; intern: entry; stack = addrel(stack_ptr, -2); call in(stack -> temp(1)); return; remob: entry; stack = addrel(stack_ptr, -2); call out(stack -> temp(1)); return; makoblist:entry; stack = addrel(stack_ptr,-2); if stack -> temp(1) = nil /* not to be made, just make a list of lists */ then do; stack_ptr = addr(stack -> temp(6)); stack -> temp(1), stack -> temp(2), stack -> temp(3), stack -> temp(4) = nil; do nargs = 0 to 509; /* scan over all obarray - except character objects */ stack -> temp(5) = addr(obarray)->based_ptr->atom_ptrs.value -> array_info.array_data_ptr-> array_data.data(nargs); call lisp_list_utils_$subst; /* copy list */ stack -> temp(1) = stack -> temp(3); /* get answer */ stack_ptr = addr(stack -> temp(3)); call lisp_special_fns_$cons; stack_ptr = addr(stack -> temp(6)); stack -> temp(2) = stack -> temp(1); stack -> temp(3),stack->temp(4) = nil; end; do nargs = 511 to 638; /* scan over character objects */ stack -> temp(5) = addr(obarray) -> based_ptr -> atom_ptrs.value -> array_info.array_data_ptr-> array_data.data(nargs); if stack -> temp(5) ^= nil then do; /* if this char object has been interned */ call lisp_special_fns_$xcons; stack_ptr = addr(stack -> temp(6)); end; end; stack -> temp(2) = stack -> temp(4); stack_ptr = addr(stack -> temp(3)); call lisp_special_fns_$xcons; return; end; else do; stack_ptr = addr(stack -> temp(6)); stack -> temp(2) = stack -> temp(1); /* atom to be made into obarray */ stack -> temp(3) = lisp_static_vars_$obarray; stack -> temp(4) = t_atom; /* copy existing obarray */ addr(stack -> temp(5)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(5)) -> fixedb = -6; call lisp_array_fcns_$star_array; stack_ptr = addr(stack -> temp(2)); return; end; end;  lisp_prelinker_.pl1 07/06/83 0937.0r w 06/29/83 1542.3 37962 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1974 * * * ************************************************************** */ lisp_prelinker_: procedure; /* This module is called by (sstatus uuolinks t) to cause pre-snapping of as many subr-links as possible. Written 74.07.07 by DAM */ dcl (lisp_static_vars_$subr, lisp_static_vars_$lsubr, lisp_static_vars_$fsubr, lisp_static_vars_$expr, lisp_static_vars_$fexpr) fixed bin(71) external, lisp_static_vars_$subr_block_list external pointer, (subr defined lisp_static_vars_$subr, lsubr defined lisp_static_vars_$lsubr, fsubr defined lisp_static_vars_$fsubr, expr defined lisp_static_vars_$expr, fexpr defined lisp_static_vars_$fexpr) fixed bin(71); dcl blockp pointer, i fixed bin, fcn fixed bin(71), fcnp pointer aligned based(addr(fcn)), type fixed bin, /* 0=not known yet, 1=subr, 2=lsubr, -1=fsubr */ (SUBR init(1), LSUBR init(2), FSUBR init(-1)) fixed bin static, plist fixed bin(71), plistp pointer aligned based(addr(plist)), linkp pointer; dcl (addr, null, divide) builtin; dcl ITP bit(6) static init("100001"b); /* hardware ITP modifier */ dcl 1 link_info unaligned, /* format of 27 info bits in an ITP link */ 2 fcn_offset fixed bin(14), /* signed offset from ap or lp of function */ 2 snap bit(1), /* 1 if link can (should) be snapped */ 2 constant bit(1), /* 1 if fcn_offset is offset from lp of atom */ 2 fsubr bit(1), /* 1 for fsubr, 0 for subr/lsubr */ 2 nargs bit(9); /* 777 if arg count is in x5, else arg count */ dcl 1 subr_info aligned based, 2 cruft bit(9) unaligned, 2 nargs bit(9) unaligned, 2 more_cruft bit(18) unaligned, 2 entry_point; %include lisp_comp_subr_block; %include lisp_ptr_fmt; %include lisp_atom_fmt; %include lisp_cons_fmt; %include lisp_common_vars; do blockp = lisp_static_vars_$subr_block_list repeat(blockp -> subr_block_head.next_compiled_block) while(blockp ^= null); /* look at all compiled subr blocks */ do i = 1 to blockp -> subr_block_head.gc_length; /* look at all constants and subr links */ linkp = addr(blockp -> subr_block_head.constants(i)); /* -> link or constant */ if linkp -> lisp_subr_links(1).itp_mod ^= ITP then go to cant_snap_this_link; /* not an unsnapped link */ unspec(link_info) = linkp -> lisp_subr_links(1).itp_info; if ^ link_info.snap then go to cant_snap_this_link; if ^ link_info.constant then go to cant_snap_this_link; fcn = blockp -> subr_block_head.constants(divide(link_info.fcn_offset+1,2,17,0)); if addr(fcn)->lisp_ptr_type & Atsym36 then; else go to cant_snap_this_link; /* found symbol to which to snap link. search its property list */ type = 0; do plist = fcnp -> atom.plist repeat(plistp -> cons_ptrs.cdr -> cons.cdr) while(addr(plist)->lisp_ptr.type = Cons); if plistp -> cons.car = subr then type = SUBR; else if plistp -> cons.car = lsubr then type = LSUBR; else if plistp -> cons.car = fsubr then type = FSUBR; else if plistp -> cons.car = expr then go to cant_snap_this_link; else if plistp -> cons.car = fexpr then go to cant_snap_this_link; if type ^= 0 then go to exitloop; end; go to cant_snap_this_link; /* no functional property */ exitloop: if type = FSUBR then if ^ link_info.fsubr then go to cant_snap_this_link; else; else if link_info.fsubr then go to cant_snap_this_link; else; if type = LSUBR then if link_info.nargs ^= "111111111"b then go to cant_snap_this_link; if type = SUBR then if link_info.nargs ^= plistp -> cons_ptrs.cdr -> cons_ptrs.car -> subr_info.nargs then go to cant_snap_this_link; /* have demonstrated that the link is snappable */ blockp -> subr_block_head_overlay.no_links_are_snapped = "0"b; blockp -> subr_block_head.constants(i) = plistp -> cons_ptrs.cdr -> cons.car + 262144; /* -> entry_point */ cant_snap_this_link: end; end; end lisp_prelinker_;  lisp_print_.pl1 07/06/83 0937.0r w 06/29/83 1542.4 416394 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ print: proc; /* This segment contains all of the LISP formatting and output routines. Coded 6/7/72, by D. Reed */ /* changed to detect ctrlr_no_uwrite error, 9 Sep 72 by DAM */ /* changed to not insert extra newlines on output to file, DAM 1 Nov 72 and to format floating point numbers using danb's convert_sfl_ instead of the char builtin */ /* bignums added, dam, 13 jan 73 */ /* changed for (status _) and (status terpri), dam, 12 FEB 1973 */ /* changed for new I/O system, 22 Mar 1973 by DAM */ /* status_terpri, status_underline moved into readtable, 7 Apr 73 by DAM */ /* modified for new syntax bits, new iochan format 73.10.24 by DAM */ /* Modified 74.03.16 by DAM to use EIS, to support abbreviation, and to be more efficient and easier to read */ /* modified 74.05.16 by DAM for new array stuff */ /* modified 74.09.21 by DAM to accept t for tty as well as nil */ /* modified 74.12.09 by DAM for external arrays */ /* FLAGS */ dcl (printing, /* 1 => output to files, 0 => explode */ slashing, /* 1 => slash special characters, 0 => output as is */ begin_with_nl, /* 1 => is print rather than prin1 or princ, need NL at beginning */ dest1, /* stack -> temp(2) is a file */ destl, /* stack -> temp(2) is a list of files */ explicit_tty, /* (print foo t) flag - ignore ^w */ send_to_tty, /* output should go to tty */ send_to_files, /* output should go to one or more files */ abbreving_flag, /* 1=> this buffer is sharp sign or dot dot dot */ abbreved_out_flag, /* 1=> this buffer shouldn't go to abbreving destinations */ someone_gets_abbreved, /* 1=> there is some abbreviated destination */ someone_gets_unabbreved, /* 1=> there is some unabbreviated destination */ abbrev_on_files, /* 1=> output to files should be abbreviated, 0=> only output to terminal should be abbreviated */ check_prinlevel, check_prinlength, explodensw, flatsw) bit(1) aligned, code fixed bin, nargs fixed bin, newline char(1) static init(" "), space char(1) static init(" "), quote char(1) static init(""""), left_paren char(1) static init("("), right_paren char(1) static init(")"), sharp_sign char(1) static init("#"), dot_dot_dot char(3) static init("..."), sharp_sign_buffer char(1) varying static init("#"), dot_dot_dot_buffer char(4) varying static init("...)"), dot char(1) static init("."), lisp_io_control_$end_of_block entry(ptr, fixed bin(71), fixed bin), lisp_io_control_$fix_not_ok_iochan entry(ptr, bit(1) aligned) returns (bit(1) aligned), lisp_io_fns_$namestring entry, i fixed bin, j fixed bin, idx fixed bin, Ch1 char(1) aligned, Ch2 char(1) aligned, Ch1_syntax bit(27) aligned, Ch2_syntax bit(27) aligned, nelemt fixed bin, cruft fixed bin(71), errcode(2) fixed bin based aligned, /* structure for lisp_error_ */ len fixed bin, lisp_static_vars_$outfiles fixed bin(71) aligned external, outfiles fixed bin(71) def (lisp_static_vars_$outfiles), lisp_error_ entry, lisp_get_atom_ entry(char(*) aligned, fixed bin(71)), lisp_$apply entry, lisp_property_fns_$get entry, io_buffer char(262143) based aligned; /* declarations for abbreviation feature */ dcl (prinlevel, prinlength) fixed bin(35), (lisp_static_vars_$prinlevel, lisp_static_vars_$prinlength) external pointer, curlevel fixed bin(35), curlength fixed bin(35); /* structure pushed on by pdl by recursion to print a list */ dcl 1 list_save aligned based structure, 2 saved_reti fixed bin, 2 saved_curlength fixed bin(35); /* SPECIAL CHARACTERS (format effectors) */ dcl backspace char(1) static init(""), tab char(1) static init(" "), carriage_return char(1) static init(" "), newpage char(1) static init(" "), format_effectors char(5) static init(" "); /* BS, HT, NL, CR, NP */ /* STUFF IN STACKS */ dcl stack ptr, /* -> lowest stuff in stack (initially args). stack -> temp(1) is data to output. later is explode list or flatsize count. stack -> temp(2) is file or list of files (see dest1, destl flags.) */ tstack ptr, /* -> top four cells in stack. tstack -> temp(1) = data being printed. tstack -> temp(2) = I/O temporary. tstack -> temp(3) = file outputting on (in I/O routine) */ the_array_pointer pointer, unm ptr, /* -> stuff on unmarked pdl */ unmp ptr, /* -> special stuff pushed on unmarked pdl for error */ bufp pointer, /* -> output buffer in unmarked pdl */ saved_bufp pointer, /* saved copy of bufp (used by abbrev hacks) */ buffer char(262143) varying based(bufp), /* output buffer */ /* note this can't be 262144 long or formline_ thinks it is zero */ bufmaxl fixed bin(18), /* number of chars in buffer protected by unmkd_ptr. must be an odd multiple of 4 (double word alignment) */ bufminl fixed bin(18) static init(76); /* minimum value of bufmaxl */ dcl type_field bit(36) aligned, reti fixed bin, /* return index */ radix fixed bin, /* output radix for fixed point numbers */ tempd fixed bin(40), /* enough precision to handle worst case */ numbuff(36) char(1) unaligned, /* char array for formatting numbers */ lisp_special_fns_$cons entry, lisp_list_utils_$nreverse entry, lisp_alloc_ entry(fixed bin, fixed bin(71) aligned), (null, addr, addrel, substr, collate, divide, hbound, lbound, mod, binary, char, length, unspec, size, string, before, search, index) builtin; dcl 1 a_lisp_datum aligned based structure, 2 (word1, word2) bit(36), 1 overlay_on_lisp_datum aligned based, 2 octal_byte(24) bit(3) unaligned; /* dcl for bignums */ dcl left_arrow fixed bin, /* for output of 4000000 in form 4_18. */ bit36 bit(36) aligned, DigitSet char(36) static init("0123456789abcdefghijklmnopqrstuvwxyz"), dpw fixed bin, wd fixed bin (35), lisp_bignums_$bnprint entry, 1 bnprintargs aligned based (unm), /* argument list for lisp_bignums_$bnprint, on unmkd pdl */ 2 array ptr, /* ptr to array of fixnums (return) */ 2 size fixed bin, /* size of array of fixnums (return) */ 2 rad fixed bin(35), /* big radix */ bndigs (1:bnprintargs.size) fixed bin(35) aligned based(bnprintargs.array); /* the array of digits in base bigradix */ %include lisp_bignum_fmt; %include lisp_bignum_io_data; %include lisp_ptr_fmt; %include lisp_name_codes; %include lisp_stack_fmt; %include lisp_common_vars; %include lisp_readtable; %include lisp_array_fmt; dcl slash_suppressors bit(27) static init( /* syntax that in 2nd char can suppress slashing of first char in pname */ "000000000000000000001001011"b); /* slash_if_not_first|plus_minus|extd_alpha|alpha */ %include lisp_nums; %include lisp_cons_fmt; %include lisp_atom_fmt; %include lisp_string_fmt; %include lisp_io; %include lisp_error_codes; /* print: proc; */ slashing, begin_with_nl = "1"b; /* options peculiar to print */ go to prin_com; prin1: entry; slashing = "1"b; /* formatted but no nl */ go to prin1_com; princ: entry; slashing = "0"b; /* no formatting other than whitespace */ prin1_com:begin_with_nl = "0"b; prin_com: printing = "1"b; /* actual output to be done */ flatsw = "0"b; /* not doing flatsize, flatc */ call get_dest_subr; /* find out where output is to be sent */ go to print_common; /* go join common code, stack already set */ /* * The above entries are the old subr versions retained because they are called internally. * The following entries are the new, lsubr versions. */ print_: entry; slashing, begin_with_nl = "1"b; go to prin_com_; prin1_: entry; slashing = "1"b; go to prin1_com_; princ_: entry; slashing = "0"b; prin1_com_: begin_with_nl = "0"b; prin_com_: printing = "1"b; flatsw = "0"b; call get_dest; go to print_common; explode: entry; slashing = "1"b; go to explodecom; explodec: entry; slashing = "0"b; /* no formatting */ explodecom: explodensw = "0"b; go to explode1; exploden: entry; explodensw = "1"b; slashing = "0"b; explode1: printing = "0"b; flatsw = "0"b; stack = addrel(stack_ptr, -2); call set_up_buffer; go to print_common; flatsize: entry; slashing = "1"b; go to flatcom; flatc: entry; slashing = "0"b; flatcom: flatsw = "1"b; printing = "0"b; stack = addrel(stack_ptr, -2); call set_up_buffer; go to print_common; tyo: entry; abbreving_flag, abbreved_out_flag, abbrev_on_files = "0"b; /* don't try to abbreviate */ call get_dest; tyo_restart: if stack -> fixnum_fmt.type_info ^= fixnum_type then go to bad_tyo; if stack -> fixedb > 511 then go to bad_tyo; if stack -> fixedb < 0 then go to bad_tyo; printing = "1"b; buffer = byte (stack -> fixedb); call send_the_buffer; call flush_buffers; go to exit; bad_tyo: unm = unmkd_ptr; /* get room on unmkd_stack for error info */ unmkd_ptr = addrel(unm,2); unm -> errcode(1) = bad_arg_correctable; unm -> errcode(2) = fn_tyo; tstack -> temp(3) = stack -> temp(1); call lisp_error_; stack -> temp(1) = tstack -> temp(3); go to tyo_restart; /* come back and try again */ type_string: entry(string_to_be_typed_out); dcl string_to_be_typed_out char(*) aligned; abbreving_flag, abbreved_out_flag, abbrev_on_files = "0"b; /* don't try to abbreviate */ call get_dest_non_lsubr; if length(string_to_be_typed_out) > bufmaxl then do; /* need bigger buffer */ bufmaxl = 8*divide(length(string_to_be_typed_out)+3, 8, 18, 0) + 4; /* double word alignment */ unmkd_ptr = addrel(bufp, divide(bufmaxl, 4, 18, 0)+1); end; buffer = string_to_be_typed_out; call send_the_buffer; call flush_buffers; stack_ptr = stack; unmkd_ptr = unm; return; terpri: entry; /* terpri as lsubr (0 . 1) */ abbreving_flag, abbreved_out_flag, abbrev_on_files = "0"b; /* don't try to abbreviate */ call get_dest_4_terpri; /* special variant of get_dest */ printing = "1"b; buffer = newline; call send_the_buffer; call flush_buffers; stack_ptr = addr(stack -> temp(2)); unmkd_ptr = unm; stack -> temp(1) = nil; /* return nil*/ return; type_nl: entry; abbreving_flag, abbreved_out_flag, abbrev_on_files = "0"b; /* don't try to abbreviate */ call get_dest_non_lsubr; buffer = newline; call send_the_buffer; call flush_buffers; stack_ptr = stack; unmkd_ptr = unm; return; print_common: /* all code for formatting lisp objects starts here */ /* Make sure the readtable has not been munged */ if addr( addr(readtable)->based_ptr -> atom.value) -> lisp_ptr_type & Array36 then; else go to bad_readtable; /* not an array */ /* its an array, make sure it was made by makreadtable */ if addr(readtable)->based_ptr -> atom_ptrs.value -> array_info.type ^= Readtable_array then go to bad_readtable; prinlevel = lisp_static_vars_$prinlevel -> fixedb; prinlength = lisp_static_vars_$prinlength -> fixedb; if lisp_static_vars_$prinlevel -> fixnum_fmt.type_info = fixnum_type then check_prinlevel = "1"b; else check_prinlevel = "0"b; if lisp_static_vars_$prinlength -> fixnum_fmt.type_info = fixnum_type then check_prinlength = "1"b; else check_prinlength = "0"b; curlevel = 0; abbreving_flag, abbreved_out_flag = "0"b; abbrev_on_files = abbreviate_on_files; if ^ printing then if abbreviate_on_flat then do; someone_gets_abbreved = "1"b; someone_gets_unabbreved = "0"b; end; else do; someone_gets_abbreved = "0"b; someone_gets_unabbreved = "1"b; end; else do; someone_gets_abbreved = "1"b; if ^ send_to_files then someone_gets_unabbreved = "0"b; else if abbrev_on_files then someone_gets_unabbreved = "0"b; else someone_gets_unabbreved = "1"b; end; if ^ someone_gets_abbreved then check_prinlevel, check_prinlength = "0"b; reti = 0; /* set transfer vector return index */ tstack -> temp(1) = stack -> temp(1); /* first argument to print loop */ if ^printing then if flatsw then do; /* set count of printable characters */ stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = 0; end; else stack -> temp(1) = nil; /* list of characters, later to be reversed */ else if begin_with_nl then do; buffer = newline; call send_the_buffer; end; print_loop: /* main printing loop, pseudo-recursive function */ type_field = tstack -> temp_type36(1); /* get type to branch on */ if type_field = fixnum_type then go to format_fixed; if type_field = flonum_type then go to format_float; if type_field & Bigfix36 then go to format_big; if type_field & Atsym36 then go to format_symbol; if type_field & String36 then go to format_string; if type_field & File36 then go to format_file_object; if type_field & Array36 then go to format_array_pointer; if tstack -> temp_type(1) then go to format_random; /* got screwed up type */ if tstack -> lisp_ptr.itsmod ^= "100011"b then go to format_random; if substr(tstack -> a_lisp_datum.word2, 19, 18) ^= ""b then go to format_random; /* not an atomic type, so print list format, by recursing */ /* have to move the buffer so can save return address */ bufp = addrel(unm, 2); bufmaxl = bufminl; unmkd_ptr = addrel(bufp, 1+divide(bufminl,4,18,0)); unm -> saved_reti = reti; unm -> saved_curlength = curlength; unm = bufp; curlength = 0; curlevel = curlevel + 1; if check_prinlevel then if curlevel > prinlevel then do; /* abbreviation hacks */ if ^ abbreved_out_flag then do; /* have to put a sharp sign */ abbreving_flag = "1"b; saved_bufp = bufp; bufp = addr(sharp_sign_buffer); call send_the_buffer; bufp = saved_bufp; abbreving_flag = "0"b; if ^ someone_gets_unabbreved then go to rest_of_list_suppressed; /* make explode work right */ end; abbreved_out_flag = "1"b; end; /* begin the list with a left parenthesis */ buffer = left_paren; call send_the_buffer; list_loop:tstack -> temp(2) = tstack -> temp_ptr(1) -> cons.car; tstack -> temp(1) = tstack -> temp_ptr(1) -> cons.cdr; /* next list element */ tstack = addr(tstack -> temp(2)); /* recursively print list item */ stack_ptr = addr(tstack -> temp(4)); reti = 1; /* return for list routine */ curlength = curlength + 1; if check_prinlength then if curlength > prinlength then do; /* abbreviation */ if ^ abbreved_out_flag then do; abbreving_flag = "1"b; /* have to put a dot dot dot */ saved_bufp = bufp; bufp = addr(dot_dot_dot_buffer); call send_the_buffer; bufp = saved_bufp; abbreving_flag = "0"b; abbreved_out_flag = "1"b; if ^ someone_gets_unabbreved /* try not to loop on circular lists */ then do; tstack = addrel(tstack, -2); go to rest_of_list_suppressed; end; end; end; if ^ abbreved_out_flag then go to print_loop; /* print car of list */ else if someone_gets_unabbreved then go to print_loop; else; /* no need to recurse because no one will see it anyway */ print_ret(1): /* return from printing one list element */ tstack = addrel(tstack,-2); /* back down stack */ if tstack -> temp(1) = nil then go to print_ret(2); /* end of list */ else if tstack -> temp_type(1) then do; non_nil_end: buffer = " . "; /* dotted pair dot */ call send_the_buffer; reti = 2; /* for end of list */ stack_ptr = addr (tstack -> temp (4)); go to print_loop; end; else if tstack -> lisp_ptr.itsmod ^= "100011"b then go to non_nil_end; else do; /* have another atom here */ buffer = space; call send_the_buffer; go to list_loop; end; print_ret(2): /* return from printing a list */ buffer = right_paren; call send_the_buffer; rest_of_list_suppressed: /* pop the stack. again, must re-allocate buffer slightly */ unm = addrel(unm,-2); bufp = unm; bufmaxl = bufmaxl + 8; /* 8 more chars are protected */ reti = unm -> saved_reti; curlength = unm -> saved_curlength; curlevel = curlevel - 1; /* turn off abbreved_out_flag if we are now back in un abbreved region */ if check_prinlevel then if curlevel > prinlevel then go to keep_on_abbreving; if check_prinlength then if curlength > prinlength then go to keep_on_abbreving; abbreved_out_flag = "0"b; keep_on_abbreving: go to print_ret(reti); print_ret(0): /* return from printing the whole thing */ if printing then do; if begin_with_nl then do; buffer = space; /* print, want space after the output */ call send_the_buffer; end; call flush_buffers; end; exit: stack_ptr = addr(stack -> temp(2)); unmkd_ptr = unm; /* pop back unmkd stack */ if ^printing then if ^flatsw then call lisp_list_utils_$nreverse; /* zap list to reverse of self */ else; else stack->temp(1) = t_atom; return; format_big: /* format a fixed point bignum */ call get_radix; /* convert the bignum to an array of small nums which are digits to some big radix, namely the largest possible power of the output radix that fits in 35 bits */ dpw = digsperwd(radix); unmkd_ptr = addrel(unm, size(bnprintargs)); /* make arg list for lisp_bignums_$bnprint */ tstack -> temp(3) = tstack -> temp(1); /* copy argument */ bnprintargs.rad = bigradix(radix); call lisp_bignums_$bnprint; stack_ptr = addr(tstack -> temp(4)); /* lisp_bignums_ mungs stack */ /* now put buffer above bnprintargs on stack */ bufp = unmkd_ptr; /* allocate buffer above bnprintargs and bndigs */ bufmaxl = bufminl; unmkd_ptr = addrel(bufp, 1+divide(bufminl,4,18,0)); /* set sign into buffer */ if tstack -> temp_ptr(1) -> lisp_bignum.sign then buffer = "-"; else if radix <= 10 then buffer = ""; /* omit + usually */ else buffer = "+"; /* but if wierd base indicate is number not atom */ /* expand each of these fixnums into digits */ do j = hbound(bndigs, 1) to lbound(bndigs, 1) by -1; wd = bndigs(j); /* next word to be expanded into digits */ do i = 35 by -1 to 36-dpw; idx = divide(wd, radix, 35, 0); code = binary(wd, 40) - binary(radix*idx, 40); numbuff(i+1) = substr(DigitSet, code+1, 1); if idx = 0 then if j = hbound(bndigs, 1) then go to done_bfx; /* suppress leading zeroes for first word only */ wd = idx; end; i = 36-dpw; done_bfx: if length(buffer) + 36 - i + 1 > bufmaxl then do; /* grow buffer */ /* extra +1 is for decimal point. */ bufmaxl = 4 + 8*divide(length(buffer) + 36 - i - 4 + 7, 8, 18, 0); unmkd_ptr = addrel(bufp, 1+divide(bufmaxl, 4, 18, 0)); end; buffer = buffer || substr(string(numbuff), i+1); end; left_arrow = 0; go to point; /* maybe add decimal point at end */ get_radix: proc; retry: if addr(base) -> based_ptr -> fixnum_fmt.type_info ^= fixnum_type then go to bad_radix; radix = addr(base) -> based_ptr -> fixedb; if radix < 2 then go to bad_radix; if radix > 36 then go to bad_radix; return; /* good radix */ bad_radix:unmp = unmkd_ptr; /* get room to pass error code */ unmkd_ptr = addrel(unmp, 2); unmp -> errcode(1) = bad_base; call lisp_error_; /* signal error */ go to retry; end get_radix; format_fixed: /* format a fixed point number */ buffer = ""; call get_radix; if tstack -> fixedb < 0 then buffer = "-"; /* put minus sign */ else do; tstack -> fixedb = - tstack -> fixedb; /* uniform negative conversion */ if radix > 10 then buffer = "+"; /* to indicate number in wierd base */ end; /* print numbers with 18, 24, or 30 trailing zeroes with the _ (left arrow) notation */ left_arrow = 0; if tstack -> fixedb ^= 0 then if radix = 8 then goto underline_hackery; /* only use this format for octal output */ else if ^ status_underline then underline_hackery: /* may be allowed to use the xx_yy. output format */ if read_table.syntax(95) = "000000000000110010"b then do; /* only if syntax of _ is standard */ bit36 = unspec(tstack -> fixedb); /* look at the number to be printed */ if substr(bit36, 2, 35) = ""b then do; left_arrow = 35; tstack -> fixedb = -1; /* must be 400000000000 */ end; else if substr(bit36, 7, 30) = ""b then do; left_arrow = 30; unspec(tstack -> fixedb) = (30)"1"b||bit36; /* qrs 30 */ end; else if substr(bit36, 13, 24) = ""b then do; left_arrow = 24; unspec(tstack -> fixedb) = (24)"1"b||bit36; /* qrs 24 */ end; else if substr(bit36, 19, 18) = ""b then do; left_arrow = 18; unspec(tstack -> fixedb) = (18)"1"b||bit36; /* qrs 18 */ end; end; pnum: do i = 35 by -1; /* convert number */ idx = divide(tstack->fixedb,radix,35,0); tempd = radix*idx; code = tempd - binary(tstack->fixedb,40,0); numbuff(i+1) = substr(DigitSet,code+1,1); if idx = 0 then go to done_num; tstack -> fixedb = idx; end; done_num: buffer = buffer || substr(string(numbuff), i+1); /* buffer contains number. append "." and "_" frobs if necessary, then output */ point: if radix = 10 /* add decimal point? */ then if addr(stnopoint)->based_ptr->atom.value = nil then buffer = buffer || "."; if left_arrow ^= 0 then do; /* print _ and the shift factor in decimal */ buffer = buffer || "_"; tstack -> fixedb = -left_arrow; /* = shift factor */ left_arrow = 0; /* prevent recursion */ if addr(stnopoint)->based_ptr -> atom.value = nil then radix = 10; /* put shift factor in decimal if possible */ go to pnum; end; /* whole number is now in buffer. put it out, empty the stack (in case of bignum), and return */ call send_the_buffer; bufp = unm; bufmaxl = bufminl; unmkd_ptr = addrel(bufp, 1+divide(bufminl,4,18,0)); go to print_ret(reti); format_float: /* format a floating point number */ /**dcl numeric_to_ascii_ entry(float decimal(59), fixed bin, char(262144) varying); /** /* note return parameter's length is misdeclared. This won't hurt anything because it is declared longer than it should be */ /** /** call numeric_to_ascii_((tstack -> floatb), 8, buffer); /* do the conversion */ /** if index(buffer, ".") = 0 then buffer = buffer || ".0"; /* disallow integer format */ /* above code replaced by the following */ dcl lisp_flonum_conversion_ entry(1 aligned structure like arg_str); dcl 1 arg_str aligned structure, 2 flonum float bin(27), 2 bufp unaligned pointer, 2 temps_for_the_alm_code, 3 mantissa fixed bin(27), 3 exponent fixed bin(8), 3 dec_temp float decimal(10), 3 dec_exp float decimal(10), 3 dbl_temp fixed bin(71); arg_str.flonum = tstack -> floatb; arg_str.bufp = bufp; call lisp_flonum_conversion_(arg_str); /* use eis instructions to convert nicely */ call send_the_buffer; go to print_ret(reti); /* format an array pointer giving type, bounds, and address */ dcl array_type fixed bin, array_type_name (0:6) char(12) varying static init( "array", "nil", "fixnum", "flonum", "readtable", "obarray", "dead-array"); format_array_pointer: buffer = sharp_sign; if tstack -> temp_ptr(1) -> array_info.minus_2_times_ndims = 0 then go to format_external_array_pointer_differently; array_type = tstack -> temp_ptr(1) -> array_info.type; if array_type < 0 then go to format_random; if array_type > 6 then go to format_random; buffer = buffer || array_type_name(array_type); if array_type ^= Dead_array then do; /* put bounds */ Ch1 = "-"; /* character to go before bound */ do i = 1 to tstack -> temp_ptr(1) -> array_info.ndims; buffer = buffer || Ch1; Ch1 = ":"; /* character to go before next bound */ tempd = tstack -> temp_ptr(1) -> array_info.array_data_ptr -> array_data.dope_vector(i-tstack -> temp_ptr(1) -> array_info.ndims).bounds; do idx = 36 repeat (idx-1); j = divide(tempd, 10, 35, 0); numbuff(idx) = substr(DigitSet, tempd-10*j+1, 1); tempd = j; if tempd = 0 then go to format_array_exitloop; end; format_array_exitloop: if length(buffer)+36-idx+1+15 > bufmaxl then do; /* get room for this number + all cruft after it */ bufmaxl = 4 + 8*divide(length(buffer)+36-idx+1+15-4+7, 8, 18, 0); unmkd_ptr = addrel(bufp, 1+divide(bufmaxl, 4, 18, 0)); end; buffer = buffer || substr(string(numbuff), idx, 36-idx+1); end; end; /* put address of array_info block */ the_array_pointer = tstack -> temp_ptr(1); buffer = buffer || "-"; format_array_pointer_address: j = fixed(baseno(the_array_pointer), 18); do idx = 36 by -1; /* until j=0 */ i = divide(j,8,17,0); numbuff(idx) = substr(DigitSet, j-8*i+1, 1); j = i; if j = 0 then go to endloop_0001; end; endloop_0001: buffer = buffer || substr(string(numbuff), idx, 36-idx+1); buffer = buffer || "|"; j = fixed(rel(the_array_pointer), 18); do idx = 36 by -1; /* until j=0 */ i = divide(j, 8, 17, 0); numbuff(idx) = substr(DigitSet, j-8*i+1, 1); j = i; if j = 0 then go to endloop_0002; end; endloop_0002: buffer = buffer || substr(string(numbuff), idx, 36-idx+1); call send_the_buffer; go to print_ret(reti); format_external_array_pointer_differently: buffer = buffer || "external@"; the_array_pointer = tstack -> temp_ptr(1) -> array_info.array_data_ptr; go to format_array_pointer_address; /* format a file object -- sharp sign and the path name */ format_file_object: if addr(tstack -> temp_ptr(1) -> iochan.namelist)->lisp_ptr.type ^= Cons then go to format_random; /* don't want a wta-barf here, since would loop! */ tstack -> temp(1) = tstack -> temp_ptr(1) -> iochan.namelist; /* get namelist, and make into a string */ stack_ptr = addr(tstack -> temp(2)); call lisp_io_fns_$namestring; /* get name of this file as a lisp string */ stack_ptr = addr(tstack -> temp(4)); if 1 + tstack -> temp_ptr(1) -> lisp_string.string_length > bufmaxl then do; /* allocate more buffer */ bufmaxl = 4 + 8*divide(tstack -> temp_ptr(1) -> lisp_string.string_length + 1 - 4 + 7, 8, 18, 0); unmkd_ptr = addrel(bufp, 1+divide(bufmaxl, 4, 18, 0)); end; buffer = sharp_sign; buffer = buffer || tstack -> temp_ptr(1) -> lisp_string.string; call send_the_buffer; go to print_ret(reti); format_string: /* print string value */ if ^slashing then do; /* easy case, just ship it out */ if tstack -> temp_ptr(1) -> lisp_string.string_length > bufmaxl then do; bufmaxl = 4 + 8*divide(tstack -> temp_ptr(1) -> lisp_string.string_length - 4 + 7, 8, 18, 0); unmkd_ptr = addrel(bufp, 1+divide(bufmaxl, 4, 18, 0)); end; buffer = tstack -> temp_ptr(1) -> lisp_string.string; end; else do; /* hard case, have to put in quotes */ buffer = quote; nelemt = tstack -> temp_ptr(1) -> lisp_string.string_length; i = 0; do while (nelemt > 0); /* push out sections not containing quotes */ /*** COMPILER BUG: j = length(before(substr(tstack -> temp_ptr(1) -> lisp_string.string, i+1), quote)); ***/ j = -1 + index(substr(tstack -> temp_ptr(1) -> lisp_string.string, i+1), quote); if j < 0 then j = length(substr(tstack -> temp_ptr(1) -> lisp_string.string, i+1)); if 2 + length(buffer) + j > bufmaxl then do; /* allocate more buffer */ /* note, the '2 + ' is for a possible quote */ bufmaxl = 4 + 8*divide(2 + length(buffer) + j - 4 + 7, 8, 18, 0); unmkd_ptr = addrel(bufp, 1+divide(bufmaxl, 4, 18, 0)); end; buffer = buffer || substr(tstack -> temp_ptr(1) -> lisp_string.string, i+1, j); i = i + j; nelemt = nelemt - j; /* now there may be a quote as the next character, or else we're done */ if nelemt > 0 then do; /* there is a quote */ buffer = buffer || (quote || quote); i = i + 1; nelemt = nelemt - 1; end; end; /* stick one more quote on the end */ if length(buffer) + 1 > bufmaxl then do; bufmaxl = 4 + 8*divide(length(buffer) + 1 - 4 + 7, 8, 18, 0); unmkd_ptr = addrel(bufp, 1+divide(bufmaxl, 4, 18, 0)); end; buffer = buffer || quote; end; /* string has been formatted into buffer, type it out and return */ call send_the_buffer; go to print_ret(reti); format_symbol: if tstack -> temp_ptr(1) -> atom.pnamel = 0 then go to print_ret(reti); Ch1 = substr(tstack -> temp_ptr(1) -> atom.pname,1,1); Ch1_syntax = read_table.syntax(binary(unspec(Ch1),9)); if tstack -> temp_ptr(1) -> atom.pnamel = 1 then Ch2_syntax = "0"b; /* cause code below to work */ else do; Ch2 = substr(tstack -> temp_ptr(1) -> atom.pname,2,1); Ch2_syntax = read_table.syntax(binary(unspec(Ch2),9)); end; if ^ slashing then do; /* no slashing, just copy out the pname */ if tstack -> temp_ptr(1) -> atom.pnamel > bufmaxl then do; /* allocate some more buffer */ bufmaxl = 4 + 8*divide(tstack -> temp_ptr(1) -> atom.pnamel - 4 + 7, 8, 18, 0); unmkd_ptr = addrel(bufp, 1+divide(bufmaxl, 4, 18, 0)); end; buffer = tstack -> temp_ptr(1) -> atom.pname; call send_the_buffer; go to print_ret(reti); end; /* slashing, see if first character should be slashed */ else if Ch1_syntax & single_char_object then if Ch2_syntax then go to slash_first_char; else go to dont_slash_first_char; /* suppress slash for lone sco */ else if Ch1_syntax & slash_if_first then if Ch1_syntax & slash_if_not_first then go to slash_first_char; else if Ch1_syntax & plus_minus then if Ch2_syntax = ""b then go to dont_slash_first_char; else if Ch2_syntax & slash_suppressors then go to dont_slash_first_char; else go to slash_first_char; else if Ch1_syntax & digit then if Ch2_syntax & shift_scale then go to slash_first_char; else if Ch2_syntax & slash_suppressors then go to dont_slash_first_char; else go to slash_first_char; else go to slash_first_char; /* something random, better slash it */ else go to dont_slash_first_char; /* slash bit not turned on */ dont_slash_first_char: buffer = Ch1; go to scan_pname; slash_first_char: buffer = "//"; substr(buffer, 2, 1) = Ch1; /* efficiency hack */ scan_pname: /* now scan through pname, putting out characters and slashes */ do i = 2 by 1 while( i <= tstack -> temp_ptr(1) -> atom.pnamel ); Ch1 = substr(tstack -> temp_ptr(1) -> atom.pname, i, 1); if read_table.syntax(binary(unspec(Ch1), 9)) & slash_if_not_first then do; /* put out a slash before this char. */ call ensure_room_in_buffer; buffer = buffer || "/"; end; call ensure_room_in_buffer; /* now put out the character */ buffer = buffer || Ch1; end; call send_the_buffer; go to print_ret(reti); ensure_room_in_buffer: procedure; if length(buffer) >= bufmaxl then do; bufmaxl = bufmaxl + 8; /* append two more words to buffer */ unmkd_ptr = addrel(unmkd_ptr, 2); end; end ensure_room_in_buffer; format_random: /* non-printable type */ /* format up as a sharp sign and 24 octal digits */ buffer = sharp_sign; do i = 1 to 24; buffer = buffer || substr(DigitSet, 1+binary(tstack -> octal_byte(i), 3), 1); end; call send_the_buffer; go to print_ret(reti); /*** internal procedures for sending characters out (the "I/O" routines) ***/ send_the_buffer: procedure; if printing then do; if send_to_tty then call send_buffer_to_tty; if send_to_files then call send_buffer_to_files; end; else if flatsw then stack -> fixedb = stack -> fixedb + length(buffer); else do; /* exploding */ do i = 1 to length(buffer); tstack -> temp(3) = stack -> temp(1); /* list so far */ Ch1 = substr(buffer, i, 1); idx = rank (Ch1); /* 511 chars BSG 10/13/80 */ if explodensw then do; addr(tstack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type; addr(tstack -> temp(2)) -> fixedb = idx; end; else do; dcl charobjp ptr, char_obj fixed bin(71) aligned based(charobjp), 1 obarray_structure based aligned, 2 hash_table(0:510) fixed bin(71), 2 char_objects(0:127) fixed bin(71); if idx > 127 then call lisp_get_atom_ (Ch1,tstack -> temp (2)); else do; charobjp=addr (addr(obarray)->based_ptr->atom_ptrs.value->array_info.array_data_ptr->char_objects(idx) ); if char_obj = nil then do; if idx = 0 then call lisp_get_atom_("", char_obj); else call lisp_get_atom_(Ch1, char_obj); end; tstack -> temp(2) = char_obj; end; end; stack_ptr = addr(tstack -> temp(4)); /* list printer screws this up */ call lisp_special_fns_$cons; stack -> temp(1) = tstack -> temp(2); stack_ptr = addr(tstack -> temp(4)); end; end; end send_the_buffer; send_buffer_to_files: proc; if destl then do; tstack -> temp(3) = stack -> temp(2); /* list of files */ do while(tstack -> temp_type(3) = Cons); tstack -> temp(2) = tstack -> temp_ptr(3) -> cons.car; tstack -> temp(3) = tstack -> temp_ptr(3) -> cons.cdr; call send_buffer_to_a_file; end; end; else if dest1 then do; tstack -> temp(2) = stack -> temp(2); /* a single file */ call send_buffer_to_a_file; end; end send_buffer_to_files; send_buffer_to_tty: proc; dcl outp pointer, /* -> iochan structure for file outputting on */ same_line bit(1), /* "1"b means could put auto newline, "0"b means already done */ invoke_endpagefn bit(1), /* flag that page broke in the middle of the buffer */ hpos fixed bin, /* horizontal position temp. during motion computation */ position fixed bin(18), /* position in buffer */ i fixed bin(18), /* temp. */ nelemt fixed bin(18), /* count of number of elements in various loops */ starting_index fixed bin(18), /* where to start outputting from */ Nelemt fixed bin(18), /* count of number of elements left to do in buffer */ saved_nelemt fixed bin(18), /* number of elements that were sent out */ amount fixed bin(18); /* number of characters that could be put out and fit */ if ^ explicit_tty /* if not (print foo t), look at ^w */ then if addr(ctrlW) -> based_ptr -> atom.value ^= nil then return; /* tty output suppressed */ tstack -> temp(2) = nil; send_buffer_to_a_file: entry; Nelemt = length(buffer); starting_index = 1; retry: if tstack -> temp(2) = nil then outp = lisp_static_vars_$tty_output_chan; else if tstack -> temp(2) = t_atom then outp = lisp_static_vars_$tty_output_chan; else if tstack -> temp_type36(2) & File36 then outp = tstack -> temp_ptr(2); else do; /* error */ unmp = unmkd_ptr; unmkd_ptr = addrel(unmp, 2); unmp -> errcode(1) = bad_output_dest; call lisp_error_; /* the losing file is on top of the stack */ go to retry; end; /* make sure abbreviation allows this buffer to go to this destination */ if (tstack -> temp_type36(2) & File36) = ""b then do; /* tty */ if abbreved_out_flag then return; end; else do; /* non-tty file */ if abbrev_on_files & abbreved_out_flag then return; if bool(abbrev_on_files, abbreving_flag, "0110"b) then return; end; /* check that this iochan is OK to use */ if string(outp -> iochan.flags) & not_ok_to_write then if lisp_io_control_$fix_not_ok_iochan(outp, "1"b) then return; string(outp -> iochan.flags) = string(outp -> iochan.flags) & flag_reset_mask; /* clear certain flags */ if Nelemt = 0 then return; /* seem to be all done */ invoke_endpagefn = "0"b; /* compute motion due to this string and do auto-terpri stuff */ same_line = "1"b; compute_motion: position = starting_index; nelemt = Nelemt; hpos = outp -> iochan.charpos; do while (nelemt > 0); i = search(substr(buffer, position, nelemt), format_effectors); if i = 0 then i = nelemt + 1; /* rest of string is normal characters */ if i > 1 then do; /* some normal chars to process */ hpos = hpos + (i - 1); /* compute horizonal motion */ position = position + (i - 1); nelemt = nelemt - (i - 1); check_hpos: if same_line /* do auto terpri stuff */ then if ^ status_terpri then if outp -> iochan.image_mode = "0"b then if outp -> iochan.linel ^= 0 then if outp -> iochan.linel < hpos then if hpos > i-1 then do; same_line = "0"b; /* now on new line, don't loop infinitely */ call send_out_newline; if substr(buffer, starting_index, 1) = space then do; starting_index = starting_index + 1; Nelemt = Nelemt - 1; end; go to compute_motion; end; end; else do; /* this character is a format effector */ Ch1 = substr(buffer, position, 1); position = position + 1; nelemt = nelemt - 1; if Ch1 = backspace then if hpos > 0 then hpos = hpos - 1; else; else if Ch1 = tab then do; hpos = 10 * divide(hpos + 10, 10, 17, 0); go to check_hpos; end; else if Ch1 = newline then do; hpos = 0; same_line = "0"b; /* no need for auto terpri now */ outp -> iochan.nlsync = "1"b; outp -> iochan.linenum = outp -> iochan.linenum + 1; if outp -> iochan.pagel ^= 0 then if outp -> iochan.pagel <= outp -> iochan.linenum then go to move_to_new_page; end; else if Ch1 = newpage then do; hpos = 0; same_line = "0"b; move_to_new_page: outp -> iochan.linenum = 0; outp -> iochan.pagenum = outp -> iochan.pagenum + 1; /* invoke the endpagefn if there is one - but first send buffer to devicee */ if ^ outp -> iochan.interactive then if outp -> iochan.function ^= nil then do; invoke_endpagefn = "1"b; nelemt = position - starting_index; go to exitloop; end; end; else if Ch1 = carriage_return then hpos = 0; end; end; exitloop: /* we have either processed it all or stopped because of end of page. update charpos from hpos then if endpagefn needs to be invoked, send partial buffer to device, invoke endpagefn, send rest of buffer */ outp -> iochan.charpos = hpos; if invoke_endpagefn then do; nelemt = position-1; /* up to and including NP char. */ go to send_to_device; end; /* special checks for tty: read_print_nl_sync and ^w */ if (tstack -> temp_type36(2) & File36) = ""b then do; if read_print_nl_sync then do; if substr(buffer, starting_index, 1) = newline then do; starting_index = starting_index + 1; Nelemt = Nelemt - 1; end; read_print_nl_sync = "0"b; end; end; /* send this buffer to this device */ nelemt = Nelemt; send_to_device: saved_nelemt = nelemt; do while(nelemt > 0); compute_amount: amount = outp -> iochan.iolength - outp -> iochan.ioindex; if amount = 0 then do; call lisp_io_control_$end_of_block(outp, cruft, code); if code = -2 then return; /* can't accept any more output */ go to compute_amount; end; if amount > nelemt then amount = nelemt; substr(outp -> ioptr -> io_buffer, outp -> ioindex+1, amount) = substr(buffer, starting_index, amount); /* move into buffer */ starting_index = starting_index + amount; nelemt = nelemt - amount; outp -> ioindex = outp -> ioindex + amount; end; /* now may need to invoke endpagefn */ if invoke_endpagefn then do; starting_index = starting_index + saved_nelemt; Nelemt = Nelemt - saved_nelemt; invoke_endpagefn = "0"b; call flush_buffers; stack_ptr = addr(tstack -> temp(7)); /* need 3 more cells */ tstack -> temp(4) = outp -> iochan.function; tstack -> temp(5) = tstack -> temp(2); /* file */ tstack -> temp(6) = nil; call lisp_special_fns_$cons; call lisp_$apply; go to retry; /* recompute outp (in case gc) and do rest of buffer */ end; send_out_newline: proc; /* needed since can't change the buffer */ dcl invoke_endpagefn bit(1) init("0"b); /* localized because means exit through routine that might set flag in outside world, not set flag in o.w. */ /* check that this iochan is OK to use */ if string(outp -> iochan.flags) & not_ok_to_write then if lisp_io_control_$fix_not_ok_iochan(outp, "1"b) then return; string(outp -> iochan.flags) = string(outp -> iochan.flags) & flag_reset_mask; /* clear certain flags */ outp -> iochan.charpos = 0; outp -> iochan.nlsync = "1"b; outp -> iochan.extra_nl_done = "1"b; outp -> iochan.linenum = outp -> iochan.linenum + 1; if outp -> iochan.pagel ^= 0 then if outp -> iochan.pagel <= outp -> iochan.linenum then invoke_endpagefn = "1"b; if outp -> iochan.iolength <= outp -> iochan.ioindex then do; call lisp_io_control_$end_of_block(outp, cruft, code); if code = -2 then return; end; substr(outp -> ioptr -> io_buffer, outp -> ioindex+1, 1) = newline; outp -> ioindex = outp -> ioindex + 1; if invoke_endpagefn then do; position = starting_index; go to move_to_new_page; /* GROSS: eventually will do the right thing though */ end; end send_out_newline; end send_buffer_to_tty; flush_buffers: proc; dcl tstack pointer, outp pointer; /* call end_of_block for any interactive output iochans */ if send_to_tty then do; outp = tty_output_chan; call flush2; end; if dest1 then do; if stack -> temp(2) = nil then outp = tty_output_chan; else if stack -> temp(2) = t_atom then outp = tty_output_chan; else if stack -> temp_type36(2) & File36 then outp = stack -> temp_ptr(2); else go to ng1; call flush2; ng1: end; else if destl then do; tstack = stack_ptr; stack_ptr = addrel(tstack, 2); do tstack -> temp(1) = stack -> temp(2) repeat (tstack -> temp_ptr(1) -> cons.cdr) while (tstack -> temp_type(1) = Cons); if tstack -> temp_ptr(1) -> cons.car = nil then outp = tty_output_chan; else if tstack -> temp_ptr(1) -> cons.car = t_atom then outp = tty_output_chan; else if tstack -> temp_ptr(1) -> cons_types36.car & File36 then outp = tstack -> temp_ptr(1) -> cons_ptrs.car; else go to ng2; call flush2; ng2: end; stack_ptr = tstack; end; flush2: proc; /* proc to maybe flush buffer of outp -> iochan */ if ^ outp -> iochan.seg then if outp -> iochan.charmode then go to flush3; else if outp -> iochan.interactive then if outp -> iochan.nlsync then flush3: if ^ outp -> iochan.write then if outp -> iochan.ioindex > 0 then do; if string(outp -> iochan.flags) & not_ok_to_write then if lisp_io_control_$fix_not_ok_iochan(outp, "1"b) then return; call lisp_io_control_$end_of_block(outp, stack -> temp(1), code); end; end flush2; end flush_buffers; bad_readtable: /* first attempt to fix the readtable so user can input */ stack = stack_ptr; stack_ptr = addr(stack -> temp(3)); stack -> temp(1) = readtable; /* get the array property, which should be original readtable */ stack -> temp(2) = array_atom; call lisp_property_fns_$get; addr(readtable)->based_ptr -> atom.value = stack -> temp(1); /* now signal the uncorrectable error */ unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = badreadtable; call lisp_error_; /*** internal procedures to prepare for printing. which procedure is called depends on what entry we came in on. these procedures set stack -> temp(2), set flags, and set up the buffer in the unmarked pdl ***/ get_dest: proc; /* for lsubrs */ stack = addrel(stack_ptr, -2); /* lsubr */ nargs = stack -> fixedb; stack = addrel(stack, nargs); join2: explicit_tty = "0"b; if nargs = -2 then go to joint; /* only 1 arg is like subr */ /* 2nd arg was given */ send_to_tty = "0"b; send_to_files = "1"b; /* stack -> temp(2) is file or list of files */ if stack -> temp_type(2) = Cons then do; destl = "1"b; dest1 = "0"b; end; else do; dest1 = "1"b; destl = "0"b; end; go to check_for_tty_as_file_and_set_up_the_buffer_then_return; get_dest_4_terpri: entry; /* special for terpri which has one less arg */ stack = addrel(stack_ptr, -2); nargs = stack -> fixedb; stack = addrel(stack, nargs); if nargs = 0 then /* simulate extra arg */ do; nargs = -2; stack_ptr = addr(stack -> temp(3)); end; else do; nargs = -4; stack -> temp(2) = stack -> temp(1); /* arg given, make look like 2nd */ end; go to join2; get_dest_non_lsubr: entry; stack = stack_ptr; printing = "1"b; stack_ptr = addr(stack -> temp(4)); go to joint; get_dest_subr: entry; stack = addrel(stack_ptr, -2); /* for subr 1 entry points */ joint: flatsw = "0"b; if addr(ctrlR)->based_ptr -> atom.value ^= nil then do; stack -> temp(2) = addr(outfiles)->based_ptr -> atom.value; if stack -> temp_type(2) then do; dest1 = "0"b; destl = "0"b; end; else do; destl = "1"b; dest1 = "0"b; end; end; else dest1, destl = "0"b; if (dest1 | destl) = ""b then send_to_files = "0"b; else send_to_files = "1"b; send_to_tty = "1"b; /* check ^w dynamically so user can turn off long output after it starts. */ check_for_tty_as_file_and_set_up_the_buffer_then_return: if send_to_files then if dest1 then if stack -> temp(2) = nil then go to not_really_to_files; else if stack -> temp(2) = t_atom then go to not_really_to_files; else; else if destl then if stack -> temp_type(2) then go to not_really_to_files; /* empty list */ else if stack -> temp_ptr(2) -> cons.car = nil | stack -> temp_ptr(2) -> cons.car = t_atom then if stack -> temp_ptr(2) -> cons.cdr = nil then go to not_really_to_files; go to really_to_files; not_really_to_files: explicit_tty = "1"b; send_to_files = "0"b; /* this hackery makes abbreviation work better */ send_to_tty = "1"b; really_to_files: call set_up_buffer; end get_dest; /* here is the routine that sets up all the cruft in the unmarked pdl */ set_up_buffer: proc; unm, bufp = unmkd_ptr; bufmaxl = bufminl; unmkd_ptr = addrel(bufp, divide(bufmaxl,4,18,0)+1); /* protect buffer */ buffer = ""; tstack = addr(stack -> temp(3)); stack_ptr = addr(tstack -> temp(4)); end; end print;  lisp_prog_fns_.pl1 07/06/83 0937.0r w 06/29/83 1542.4 354870 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ prog: proc; /* lisp functions that use hairy control structures - prog, errset, catch/throw, & c. */ /* * Gathered from other modules and recoded by D. Moon 8-JUN-72 * break added, 12-July-72 DAM * go changed to search for label instead of making * label-table array, DAM 5 Aug 72 * go, return, and xec_body moved into hand code in lisp_.alm, 19 AUG 72 DAM * err function moved to lisp_error_.pl1, DAM 15 OCT 1972 * Moby unwind_protect feature, after HIC dared me, BSG 09/09/78 */ /* INCLUDE FILES */ %include lisp_control_chars; %include lisp_stack_seg; %include lisp_nums; %include lisp_stack_fmt; %include lisp_faults; %include lisp_unmkd_pdl; %include lisp_ptr_fmt; %include lisp_initial_atoms; %include lisp_common_vars; %include lisp_cons_fmt; %include lisp_atom_fmt; %include lisp_error_codes; %include lisp_name_codes; /* declarations for lisp_unwinder */ dcl unwind_to bit(18), /* rel ptr to unmarked pdl, which tells lisp_unwinder how far to unwind the unmarked stack. */ where_to bit(18) aligned, frame_rels(0:6 /* nframeptrs - PL1 compiler bug */ ) bit(18) aligned; /* rel's of the frame_ptrs */ dcl (qt, qb) pointer; /* ENTRY POINTS CALLED */ dcl lisp_special_fns_$cons ext entry; dcl lisp_fault_handler_$interrupt_poll entry (); dcl lisp_oprs_$xec_unwprot_compiled_handler ext entry; dcl lisp_$eval entry; dcl lisp_$eval_list entry; dcl lisp_$unwind_reversal entry; dcl lisp_error_ entry, unmp ptr; dcl (addr, addrel, null, bit, fixed, ptr, rel) builtin; dcl lisp_static_vars_$eval_atom fixed bin (71) external; /* general variables */ dcl progsw bit(1); /* "1"b = prog, "0"b = do */ /* equivalent to: binding_block.top_block = prog_frame.dat1 + 6, approximately */ dcl p ptr; dcl 1 save_masked automatic like masked; dcl myname fixed bin; /* name code for too_few_args error signalled by need_arg */ dcl stack ptr; dcl top_of_stack ptr; dcl unm ptr; dcl (i, n) fixed bin; /* /* prog function for lisp */ /* prog: entry; */ myname = fn_prog; progsw = "1"b; stack = addrel(stack_ptr, -2); stack_ptr = addr(stack -> temp(4)); /* 3 temp cells */ /* make sure we have at least one arg - the local variable list */ call need_arg; /* save old bindings of the local variables */ stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* the local - variable list */ local_variables_loop: if stack -> temp(2) = nil then go to rebind; if stack -> temp_ptr(2) -> cons_types.car & Atsym then; /* OK to rebind */ else do; /* unrecoverable error */ stack -> temp(3) = stack -> temp_ptr(2) -> cons.car; unmp = unmkd_ptr; unmkd_ptr = addrel(unmp, 2); unmp -> errcode(1) = bad_bv; call lisp_error_; end; p = stack_ptr; stack_ptr = addrel(stack_ptr, 4); /* defend binding block against the vicious onslaught of the garbage collector */ p -> bindings(1).atom = stack -> temp_ptr(2) -> cons.car; p -> bindings(1).old_val = stack -> temp_ptr(2) -> cons_ptrs.car -> atom.value; stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; go to local_variables_loop; /* now set up a binding_block on the unmarked pdl */ rebind: p = unmkd_ptr; unmkd_ptr = addrel(unmkd_ptr, 2); p -> binding_block.bot_block = rel(addr(stack -> temp(4))); /* first binding */ p -> binding_block.top_block = rel(stack_ptr); /* just above last binding */ p -> binding_block.back_ptr = rel(binding_top); p -> binding_block.rev_ptr = ""b; binding_top = p; /* push onto the binding pseudo-pdl */ /******** It is now safe to rebind the local variables to nil ********/ stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* get local vars list again */ bind_local_vars_to_nil: if stack -> temp(2) = nil then go to mk_frame; stack -> temp_ptr(2) -> cons_ptrs.car -> atom.value = nil; stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; go to bind_local_vars_to_nil; mk_frame: call make_prog_frame; /* /* At long last, we are ready to execute the body of the prog */ stack -> temp(2), stack -> temp(3) = stack -> temp_ptr(1) -> cons.cdr; /* the body */ prog_ex: call xec_body; /* run the body of the prog */ prog_end: /* End of the prog reached uneventfully, return nil (unwinding the saved bindings) */ stack -> temp(1) = nil; go to prog_ret; /* go or return comes here with label name or return value and a go/return switch on the stack */ go_or_return: p = addrel(stack_ptr, -4); /* pick up stuff from stack frame of go or return */ stack = ptr(p, prog_frame -> frame.dat1); stack -> temp(1) = p -> temp(1); /* and copy it down so it won't go away */ if p -> temp(2) = nil then do; /* GO */ stack5 = ptr(stack_ptr, prog_frame -> frame.dat2); /* search prog body for label to go to */ go_once_more: do stack -> temp(2) = stack -> temp(3) /* scan whole prog body */ repeat(stack -> temp_ptr(2) -> cons.cdr) while (stack -> temp_type(2) = Cons); if stack -> temp_ptr(2) -> cons_types.car then /* found a label - see if it's the one we want */ if stack -> temp_ptr(2) -> cons.car = stack -> temp(1) then do; unwind_to = rel(addrel(prog_frame, 6)); /* unwind any nested stuff */ call lisp_unwinder; stack_ptr = addr(stack5 -> temp(2)); if progsw then go to prog_ex; /* YES - begin executing at label */ else go to do_ex; end; end; /* search failed - barf */ /*** NOTE that at this point the LISP evalframes are still there, for the benefit of clever unseen-go-tag handlers, but the associated Multics stack frames, if any, are not there. So beware - mostly of using freturn or throw. ***/ unmp = unmkd_ptr; unmkd_ptr = addrel(unmp, 2); unmp -> errcode(1) = unseen_go_tag; top_of_stack = stack_ptr; stack_ptr = addrel(top_of_stack, 2); top_of_stack -> temp(1) = stack -> temp(1); call lisp_error_; stack -> temp(1) = top_of_stack -> temp(1); /* recovery */ stack_ptr = top_of_stack; go to go_once_more; end; /* RETURN */ prog_ret: unwind_to = rel(addrel(prog_frame, -2)); /* unwind it all */ call lisp_unwinder; stack_ptr = addr(stack -> temp(2)); xretn: return; /* common code for do and prog */ /* create prog frame on the unmarked pdl */ make_prog_frame: proc; stack4, stack5 = stack_ptr; p = unmkd_ptr; unmkd_ptr = addrel(unmkd_ptr, 6); /***** size of a frame */ p -> frame.ret = go_or_return; p -> frame.prev_frame = rel(prog_frame); p -> frame.stack_ptr = rel(stack4); /* clear the stack if we get unwound */ /* also base of label table */ p -> frame.dat1 = rel(stack); p -> frame.dat2 = rel(stack5); prog_frame = p; /* push onto the stack */ stack_ptr = addr(stack5 -> temp(2)); /* make some room to call eval */ return; end; /* routine to execute the body of a prog or do*/ xec_body: proc; dcl unm ptr; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> based_ptr = addr(stack -> temp(2)); /* -> body */ call lisp_$eval_list; /* fast body evaluator */ return; end; /* /* entry point to allow outsiders to call lisp_unwinder. Called with top of unmarked pdl containing ptr to where to unwind to */ lisp_unwinder: entry; unwind_to = rel( addrel(unmkd_ptr,-2)->based_ptr ); call lisp_unwinder; return; /* Internal procedure to unwind the unmarked stack down to a specified point (specified by unwind_to) */ lisp_unwinder: proc; dcl st bit(18); /* rel of stack_ptr, for efficiency */ dcl relp bit(18) aligned; dcl temp_framep ptr; /* convert pointers to rel pointers for easy comparison */ set_rel: do i = 0 to nframeptrs; frame_rels(i) = rel(frame_ptrs(i)); end; unm = unmkd_ptr; /* copy this ext static variable */ st = rel(stack_ptr); /* set this in case we unwind nothing */ choose: /* find something to unwind */ where_to = ""b; /* the minimum number */ do i = 0 to nframeptrs; /* find max of the frame_rels */ if frame_rels(i) >= where_to then do; /* can't be = but generates better code than > */ where_to = frame_rels(i); n = i; end; end; if where_to = ""b then go to done_unw; /* no more to be unwound */ if where_to < unwind_to then done_unw: do; if unwind_to = ""b then do; unm = ptr(unm,""b); unwind_to = rel(unm->stack_seg.unmkd_stack_bottom); /* to bottom of unmkd_stack */ st = rel(unm->stack_seg.marked_stack_bottom); /* to bottom of marked_stack */ end; unmkd_ptr = ptr(unm, unwind_to); /* move unmkd_ptr down */ stack_ptr = ptr(stack_ptr, st); /* move stack_ptr down */ return; end; if n = 0 then go to unwind_bindings; /* this is harder to unwind than the others */ else if n = 1 then go to unwind_fault_save; /* .. */ else do; st = frame_ptrs(n) -> frame.stack_ptr; relp = frame_ptrs(n) -> frame.prev_frame; if n = 6 then do; /* Unwind protect */ stack_ptr = ptr (stack_ptr, st); /* Normalize pdls */ temp_framep = unwp_frame; /* Save pointer */ unmkd_ptr = addrel (frame_ptrs (6), size (frame)); if temp_framep -> frame.dat1 = "000000"b3 /* Interpreted unw_prot */ then do; save_masked = masked; string (masked.against) = copy ("1"b, length (string (masked.against))); unwp_frame = ptr (unm, relp); unmkd_ptr = addrel (temp_framep, size (based_ptr)); temp_framep -> based_ptr = addrel (stack_ptr, -2); call lisp_$eval_list; /* Do the exit forms */ masked = save_masked; if lisp_static_vars_$deferred_interrupt then call lisp_fault_handler_$interrupt_poll; end; else call lisp_oprs_$xec_unwprot_compiled_handler; frame_rels (6) = relp; go to choose; end; frame_ptrs(n) = ptr(unm, relp); frame_rels(n) = relp; go to choose; end; unwind_bindings: qt = ptr(stack_ptr, binding_top -> binding_block.top_block); st = binding_top -> binding_block.bot_block; /* put stack_ptr below the bindings */ if st then do; /* normal bb */ qb = ptr(qt, st); do while (qb ^= qt); /* restore bindings to their atoms */ qt = addrel(qt, -4); addr(qt -> bindings(1).atom) -> based_ptr -> atom.value = qt -> bindings(1).old_val; end; binding_top = ptr(binding_top, binding_top -> binding_block.back_ptr); end; else do; /* reversal bb */ call lisp_$unwind_reversal; end; frame_rels(0) = (rel(binding_top)); go to choose; /* routine to unwind through a user interrupt */ unwind_fault_save: st = err_recp -> fault_save.stack_ptr; gc_inhibit = err_recp -> fault_save.sv_gc_inhibit; call lisp_fault_handler_$set_mask((err_recp -> fault_save.sv_masked)); unspec(ptr(unmkd_ptr, ""b) -> stack_seg.array_info_for_store) = unspec(err_recp -> fault_save.sv_array_info); ptr(unmkd_ptr, ""b) -> stack_seg.array_offset_for_store = err_recp -> fault_save.sv_array_offset; rdr_label = err_recp -> fault_save.sv_rdr_label; rdr_state = err_recp -> fault_save.sv_rdr_state; rdr_ptr = err_recp -> fault_save.sv_rdr_ptr; err_recp = ptr(err_recp, err_recp -> fault_save.prev_frame); frame_rels(1) = rel(err_recp); go to choose; end lisp_unwinder; /* /* this is the lisp errset funtion, which traps errors */ errset: entry; stack = addrel(stack_ptr, -2); /* get our argument, which we will eval after setting up an err_frame */ myname = fn_errset; call need_arg; /* set up an err_frame in the unmarked pdl */ p = unmkd_ptr; unmkd_ptr = addrel(unmkd_ptr, 6); /***** size of a frame */ p -> frame.ret = error_return; /* where to come back to if error */ p -> frame.stack_ptr = rel(stack_ptr); p -> frame.prev_frame = rel(err_frame); p -> frame.dat2 = "0"b; /* "1"b means err with non-nil 2nd arg */ /* set frame.dat1 to reflect whether caller wants error messages suppressed */ p -> frame.dat1 = "0"b; /* assume he wants err msgs */ if stack -> temp_ptr(1) -> cons.cdr = nil | stack -> temp_ptr(1) -> cons_types.cdr then; else if stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car = nil then p -> frame.dat1 = "1"b; /* 2nd arg nil ---> suppress err msgs */ err_frame = p; /* NOW push frame onto pdl */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* arg is ready to give to eval */ call lisp_$eval; /* evaluate the arg */ /* if we get this far, there was no error */ err_frame = ptr(err_frame, p -> frame.prev_frame); /* particularly easy to unwind */ unmkd_ptr = p; stack_ptr = addrel(stack_ptr, 2); /* set up to call to cons */ addrel(stack_ptr, -2) -> temp(1) = nil; /* return list of result of our arg */ call lisp_special_fns_$cons; return; /* come here if an error occurs */ error_return: stack = addrel(ptr(stack_ptr, err_frame -> frame.stack_ptr), -2); stack -> temp(1) = addrel(stack_ptr, -2) -> temp(1); /* pick up value to return */ unwind_to = rel(err_frame); /* unwind back to & including our errset frame */ if err_frame -> frame.dat2 then do; /* unwind before eval -- err with non-nil 2nd arg */ call lisp_unwinder; call lisp_$eval; end; else call lisp_unwinder; /* already been evaled */ return; /* /* Catch and Throw */ /* Catch and throw have been extended to include "catch labels." * If they are called with a second argument, then the unevaluated * second argument, which is usually an atom, "labels" the catch * so that a throw with a second argument _e_q to the second argument * to that catch will throw back to that catch in spite of any * intervening catches. If the second argument is omitted, catch * catches any throw and throw throws to the most recent * catch. Catch evaluates its first argument, and if a throw * occurs, the evaluated first argument to throw is returned * as the result of the catch, otherwise the evaluated first * argument to catch is returned. Example of catch labels.: * (catch (progn (catch (throw 't foo) bar) (print 'foobar)) foo) * would not print foobar since the throw throws back through * the progn all the way out to the outer catch. The value * of the expression would be t. */ catch: entry; /* first find out how many args we have and make sure it is 1 or 2 */ stack = addrel(stack_ptr, -2); /* Is an fsubr */ myname = fn_catch; call need_arg; stack_ptr = addr(stack -> temp(3)); /* get 2 cells instead of one */ stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* save first arg */ /* check for a second arg */ if stack -> temp_ptr(1) -> cons.cdr = nil | stack -> temp_ptr(1) -> cons_types.cdr then stack -> temp_type36(1) = Numeric36; /* no second arg -- use this cruft */ /* which can "never" appear in a list but won't screw up the g.c. */ else stack -> temp(1) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car; /* use given 2nd arg */ /* set up a catch frame */ p = unmkd_ptr; unmkd_ptr = addrel(unmkd_ptr, 6); /***** size of a frame */ p -> frame.ret = catch_return; /* if we get thrown to */ p -> frame.prev_frame = rel(catch_frame); p -> frame.stack_ptr = rel(addr(stack -> temp(2))); /* leaving catch-label and junk on stack */ catch_frame = p; /* push onto pdl */ /* eval the first arg */ call lisp_$eval; /* normal return -- return (eval 1st_arg) */ stack -> temp(1) = stack -> temp(2); /* move down the value to be returned */ uncatch: unwind_to = rel(catch_frame); /* unwind back through our catch frame */ call lisp_unwinder; return; catch_return: /* unwind and return the evaluated first arg of throw */ addrel(ptr(stack_ptr, catch_frame -> frame.stack_ptr), -2) -> temp(1) = addrel(stack_ptr, -4) -> temp(2); /* move result down so we can return it */ go to uncatch; /* unwind & return */ /* /* the throw function throws its evaluated first arg back to the most recent catch whose second arg was _e_q to the second arg of throw */ throw: entry; stack = addrel(stack_ptr, -2); stack_ptr = addr(stack -> temp(3)); /* eval our first arg */ myname = fn_throw; call need_arg; stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* get first arg */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* save rest of arg-list */ call lisp_$eval; /* eval our first arg and leave it on the stack where catch_return can find it */ /* see if we have a second arg */ if stack -> temp(1) = nil | stack -> temp_type(1) then do; /* no, find most recent catch */ p = catch_frame; if rel(p) then go to throw1; else go to bad_throw_uu; /* error - no catch_frame */ end; else stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* yes -- use it as catch label */ /* search for a catch frame for this label */ throw_retry: p = catch_frame; catch_search: if rel(p) = "0"b then go to bad_throw; /* exhausted stack without finding place to throw to */ qb = addrel(ptr(stack_ptr, p -> frame.stack_ptr), -2); if qb -> temp(1) = stack -> temp(1) then go to throw1; if qb -> temp_type36(1) = Numeric36 then do; /* an unlabeled catch */ throw1: /* found the catch to throw back to */ catch_frame = p; /* discard any intervening catches */ go to p -> frame.ret; /* unwind pl1 stack back to catch_return, which will do the rest */ end; p = ptr(p, p -> frame.prev_frame); /* keep searching back */ go to catch_search; bad_throw_uu: unspec(stack -> temp(1)) = Undefined; /* inform lisp_error_ that there was no throw-label given */ bad_throw: /* tried to throw but there was no corresponding catch */ unmp = unmkd_ptr; unmkd_ptr = addrel(unmp, 2); unmp -> errcode(1) = throw_to_no_catch; stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = stack -> temp(1); /* throw tag */ call lisp_error_; stack -> temp(1) = stack -> temp(3); /* replacement value */ go to throw_retry; /* */ /* Lisp unwind-protect: borrowed from Lisp Machine, BSG 09/09/78 */ unwind_protect: entry; myname = fn_unwind_protect; stack = addrel (stack_ptr, -2); call need_arg; stack_ptr = addr (stack -> temp (4)); stack -> temp (3) = stack -> temp_ptr (1) -> cons.car; /* thing to eval */ stack -> temp (2) = stack -> temp_ptr (1) -> cons.cdr; /* exit list */ /* stack (1) is for return result */ /* Set up a unwp frame */ p = unmkd_ptr; unmkd_ptr = addrel (unmkd_ptr, 6); p -> frame.prev_frame = rel (unwp_frame); p -> frame.stack_ptr = rel (addr (stack -> temp (3))); p -> frame.dat1 = "000000"b3; /* No compiled exit. */ unwp_frame = p; /* Eval the first arg. */ call lisp_$eval; stack -> temp (1) = stack -> temp (3); /* Save the result */ unwind_to = rel (unwp_frame); /* Set unwind point */ call lisp_unwinder; /* Will eval the exit forms, pop the pdls */ stack_ptr = addr (stack -> temp (2)); /* Set to return result */ return; /* */ /* entry to unwind the stack following a call to lisp_err_ */ /* the stack is unwound until an errset is found. If there is none, return to top level */ lisp_err: entry(err_fcn_f); dcl err_fcn_f bit(1) aligned parameter; /* "1"b means errset value on stack */ if ^err_fcn_f then do; stack_ptr = addrel(stack_ptr, 2); /* force errset to return nil */ addrel(stack_ptr, -2) -> temp(1) = nil; end; process_error: if rel(err_frame) then /* there is an err_frame to return to */ go to err_frame -> frame.ret; /* the errset routine will do the rest */ else; /* no errset - unwind all the way and return to top level */ /* copy value of errlist before unbinding */ addr(lisp_static_vars_$SLASH) -> based_ptr -> atom.value = addr(lisp_static_vars_$errlist) -> based_ptr -> atom.value; unwind_to = ""b; call lisp_unwinder; go to lisp_static_vars_$top_level; /* return to the top-level read-eval-print loop */ /* /* lisp do function */ do: entry; progsw = "0"b; dcl (stack2, stack3, stack4, stack5) ptr, /* -> various places in marked stack */ prog_with_initial_values bit(1); /* flag for (do (...) nil ...) */ /* written by Alex Sunguroff 6/72 rewritten by David Moon 9-JUN-72 for new stack discipline, new pointer format, and v2pl1 compiler quick fix of bug introduced 9-JUN-72, made 17-MAY-73 by DAM. prog-with-initial-values feature put in 16 Oct 1973 by DAM */ /* a pictorial exposition of the data stored on the stacks by do */ /* MARKED PDL UNMARKED PDL ______________________________ ______________________________ | | | | stack -> | argument list | | | | | | | | scanning pointer | | | | | binding_top ->|-----------------------------| | body of the do | | rel(stack4) | rel(stack3) | - boundaries of saved bindings | | |-------------|---------------| | endtest | | thread | 0 | | | |-------------|---------------| | return value list | | | |-----------------------------| | | stack2 -> | (indices information) | prog_frame ->|-----------------------------| | | | | |- - - - - - - - - - - - - - -| | ret = do_control_return | | index atom | | | | initial value | | | | stepper | |-----------------------------| |- - - - - - - - - - - - - - -| | thread | rel(stack4) | - to wipe out the stack | . | |-----------------------------| | . | | rel(stack) | rel(stack5) | - boundary of label table | . | |-----------------------------| | | | | |-----------------------------| | | stack3 -> | (saved bindings of indices)| | | |- - - - - - - - - - - - - - -| | atom | | value | |- - - - - - - - - - - - - - -| | . | | . | | . | stack4 -> |-----------------------------| stack5 -> | -> thing being evaled | |-----------------------------| stack_ptr-> | | | | | */ myname = fn_do; stack = addrel(stack_ptr, -2); /* fsubr */ call need_arg; stack_ptr = addr(stack -> temp(6)); /* protect temp(1:5) */ stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* get the first element of the arg list */ stack2, stack3 = addr(stack -> temp(6)); /* initialize these pointers*/ if stack -> temp_type36(2) & Atsym36 then do; /* if the first element of the argument list is atomic, then this is an old style do group */ prog_with_initial_values = "0"b; /* clear flag for funny do */ if stack -> temp(2) = nil then go to new_type_do_join; /* nil is a list in this context */ stack_ptr,stack3 = addr(stack2 -> temp(4)); stack2 -> temp(1) = stack -> temp(2); /* remember the index atom */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* shorten the arg list */ call need_arg; stack2 -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* place the initial value here */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* shorten the arg list */ call need_arg; stack2 -> temp(3) = stack -> temp_ptr(1) -> cons.car; /*place the stepper function here */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /*shorten the arg list */ call need_arg; stack -> temp(4) = stack -> temp_ptr(1) -> cons.car; /*place the endtest here */ stack4, stack_ptr = addr(stack3 -> temp(3)); stack3 -> bindings(1).atom = stack2 -> temp(1); stack3 -> bindings(1).old_val = stack2 -> temp_ptr(1) -> atom.value; stack -> temp(5) = nil; /* return value is nil */ go to common_do_code; /*proceed to where both forms are handled similarly */ end; do while(stack -> temp(2) ^= nil); /* this do group takes the list of indeces where each element of the list has the form: (x xinit xstepper) and where xinit and xstepper may be ommitted and places those three elements on the stack and binds the oldvalue of x */ if stack -> temp_type(2) then go to bad_form_do; /*error if not a list */ stack_ptr = addr(stack3 -> temp(4)); /* get room for another index table entry */ stack3 -> temp(3) = stack -> temp_ptr(2) ->cons.car; /*place the list containing the information about the next index here */ if stack3 -> temp(3) = nil then go to bad_form_do; /* this requires that there be at least a list of x*/ if stack3 -> temp_type(3) then go to bad_form_do; stack3 -> temp(1) = stack3 -> temp_ptr(3) -> cons.car; /*place the index here*/ stack3 -> temp(3) = stack3 -> temp_ptr(3) -> cons.cdr; /*shorten the list */ if stack3 -> temp(3) = nil then do; /*if the xinit and xstepper have been ommited then initialze to nil and don't step it*/ stack3 -> temp(2) = nil; /*set to nil */ stack3 -> temp(3) = stack3 -> temp(1); /* make stepping be a no-op */ end; else do; /*if there is an xinit */ if stack3 -> temp_type(3) then go to bad_form_do; stack3 -> temp(2) = stack3 -> temp_ptr(3) -> cons.car; /*place the xinit here */ stack3 -> temp(3) = stack3 -> temp_ptr(3) -> cons.cdr; /*shorten the list*/ if stack3 -> temp(3) = nil then stack3 -> temp(3) = stack3 -> temp(1); /* keep it from stepping */ else do; if stack3 -> temp_type(3) then go to bad_form_do; stack3 -> temp(3) = stack3 -> temp_ptr(3) -> cons.car; /*place xstepper here */ end; end; stack3 = addr(stack3 -> temp(4)); /*move up 3 locations and look for another index*/ stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; /*shorten the index list*/ end; new_type_do_join: /* now save the bindings of the indices */ stack4 = stack3; stack5 = stack2; do while (stack5 ^= stack3); /* scan through the index table */ stack_ptr = addr(stack4 -> temp(3)); /* make room */ stack4 -> bindings(1).atom = stack5 -> temp(1); stack4 -> bindings(1).old_val = stack5 -> temp_ptr(1) -> atom.value; stack4 = stack_ptr; stack5 = addr(stack5 -> temp(4)); end; /* the following routine takes the endtest and the return value and puts them on the stack for later use */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* shorten the arg list */ call need_arg; stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /*place the list of endtest and return-value here */ if stack -> temp(2) = nil then /* we allow endtest,retval to be omitted */ prog_with_initial_values = "1"b; /* set flag to remember no endtest, do once only */ else if stack -> temp_type(2) then go to bad_form_do; else do; prog_with_initial_values = "0"b; /* not special funny do */ stack -> temp(4) = stack -> temp_ptr(2) -> cons.car; /*put the endtest here*/ stack -> temp(5) = stack -> temp_ptr(2) -> cons.cdr; /* save the list of retval forms */ end; common_do_code: /*from here both styles of do share the code*/ stack -> temp(1), stack -> temp(2), stack-> temp(3) = stack -> temp_ptr(1) -> cons.cdr; /*dobody*/ /* construct binding block */ p = unmkd_ptr; unmkd_ptr = addrel(unmkd_ptr, 2); p -> binding_block.bot_block = rel(stack3); p -> binding_block.top_block = rel(stack4); p -> binding_block.back_ptr = rel(binding_top); p -> binding_block.rev_ptr = ""b; binding_top = p; stack_ptr = addr(stack4 -> temp(2)); /* room to call eval */ stack5 = stack2; do while(stack5 ^= stack3); /*scan up the stack evaling the initial values*/ stack4 -> temp(1) = stack5 -> temp(2); /*put the initial value at top of stack*/ call lisp_$eval; /*and eval it*/ stack5 -> temp(2) = stack4 -> temp(1); /* save value of initial value */ stack5 = addr(stack5 -> temp(4)); end; stack_ptr = stack4; /* give back the one cell we took */ stack5 = stack2; do while(stack5 ^= stack3); /* rescan, set indices */ stack5 -> temp_ptr(1) -> atom.value = stack5 -> temp(2); stack5 = addr(stack5 -> temp(4)); end; call make_prog_frame; do_loop: /*this is the iteration of the execution of the do*/ if prog_with_initial_values then go to do_ex_0; /* if funny do, skip end test */ stack5 -> temp(1) = stack -> temp(4); /*pull in the endtest function*/ call lisp_$eval; /*and eval it*/ if stack5 -> temp(1) ^= nil then do; /*this detects if the predicate is true and terminates the the do. Note that an endtest function of nil won't stop*/ stack5 -> temp(1) = nil; /* in case this do-while gets done 0 times */ do while (stack -> temp_type(5) = Cons); /* evaluate the forms in the retval list */ stack5 -> temp(1) = stack -> temp_ptr(5) -> cons.car; call lisp_$eval; stack -> temp(5) = stack -> temp_ptr(5) -> cons.cdr; end; stack -> temp(1) = stack5 -> temp(1); /*put value of last one where it can be returned*/ go to prog_ret; /* unwind it all... */ end; do_ex_0: stack -> temp(2) = stack -> temp(3); /*get the complete do-body again*/ do_ex: call xec_body; /* execute the body of the do */ if prog_with_initial_values /* if no repeating, then we are done */ then go to prog_end; stack4 = stack2; do while(stack4 ^= stack3); /* eval the stepping functions */ stack5 -> temp(1) = stack4 -> temp(3); /*get the stepping function*/ call lisp_$eval; /*and eval it*/ stack4 -> temp(2) = stack5 -> temp(1); /* and save it */ stack4 = addr(stack4 -> temp(4)); end; /* scan through again giving the indices their new values */ stack4 = stack2; do while (stack4 ^= stack3); stack4 -> temp_ptr(1) -> atom.value = stack4 -> temp(2); /*give the new value*/ stack4 = addr(stack4 -> temp(4)); end; go to do_loop; bad_form_do: /* gi1e a wrong-type-arg uncorrectable error */ unmp = unmkd_ptr; unmkd_ptr = addrel(unmp, 2); unmp -> errcode(1) = bad_do_format; stack_ptr = addr(stack -> temp(2)); /* barf at original form */ call lisp_error_; /* never returns */ need_arg: proc; /* proc to make sure we have an arg */ if stack -> temp(1) = nil then go to no_arg; if stack -> temp_type(1) then go to no_arg; return; /* ...if no problems */ no_arg: unmp = unmkd_ptr; unmkd_ptr = addrel(unmp, 2); unmp -> errcode(1) = too_few_args; unmp -> errcode(2) = myname; stack_ptr = addr(stack -> temp(2)); /* unrecoverable */ call lisp_error_; /* requires replacement form to eval */ go to xretn; end; /* the lisp break function */ break: entry; dcl lisp_print_$type_string entry(char(*)aligned), lisp_print_$type_nl entry, iox_$user_output external ptr, iox_$put_chars entry(ptr, ptr, fixed bin(21), fixed bin(35)), iox_status fixed bin(35), lisp_static_vars_$dollar_p_atom fixed bin(71) aligned external, dollar_p_atom fixed bin(71) aligned def (lisp_static_vars_$dollar_p_atom), 1 unmask aligned like masked, lisp_static_vars_$return_atom external fixed binary (71) aligned, return_atom fixed bin(71) aligned def (lisp_static_vars_$return_atom), lisp_static_vars_$print_atom fixed bin(71) external, lisp_static_vars_$prin1_atom fixed bin(71) external, lisp_special_fns_$ncons entry, lisp_$apply entry, lisp_reader_$read entry; stack = addrel(stack_ptr, -2); /* fsubr */ stack_ptr = addr(stack -> temp(4)); stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* bkpt identifier */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; if stack->temp(1) = nil then go to break_for_sure; stack -> temp(3) = stack -> temp_ptr(1) -> cons.car; /* predicate */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; if stack -> temp(1) ^= nil then stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* return value */ call lisp_$eval; if stack -> temp(3) = nil then go to breakxe; /* don't break if predicate evals to nil */ break_for_sure: unm = unmkd_ptr; /* going to put a binding block and */ unmkd_ptr = addrel(unm, 8+size(fault_save)); /* an errset frame on the unmarked pdl */ /* and a fault_save to save rdr_state */ stack_ptr = addr(stack -> temp(11)); /* save ^q, ^r, and ^w and reset them to nil */ stack -> temp(4) = ctrlQ; stack -> temp(3) = stack -> temp_ptr(4) -> atom.value; stack -> temp(6) = ctrlW; stack -> temp(5) = stack -> temp_ptr(6) -> atom.value; stack -> temp(8) = ctrlR; stack -> temp(7) = stack -> temp_ptr(8) -> atom.value; unm -> binding_block.top_block = rel(addr(stack -> temp(9))); unm -> binding_block.bot_block = rel(addr(stack -> temp(3))); unm -> binding_block.rev_ptr = ""b; unm -> binding_block.back_ptr = rel(binding_top); binding_top = unm; unm = addrel(unm, 2); stack -> temp_ptr(4) -> atom.value , stack -> temp_ptr(6) -> atom.value , stack -> temp_ptr(8) -> atom.value = nil; /* construct an errset frame so errors won't leave our read-eval-print loop */ unm -> frame.ret = break_err; unm -> frame.stack_ptr = rel(addr(stack -> temp(9))); unm -> frame.prev_frame = rel(err_frame); unm -> frame.dat1, unm -> frame.dat2 = ""b; err_frame = unm; unm = addrel(unm, 6); /* save rdr_state */ unm -> fault_save.prev_frame = rel(err_recp); unm -> fault_save.stack_ptr = rel(stack_ptr); unm -> fault_save.sv_gc_inhibit = lisp_static_vars_$garbage_collect_inhibit; unm -> fault_save.sv_masked = lisp_static_vars_$masked; unm -> fault_save.code1 = 0; /* not due to an error */ unm -> fault_save.sv_array_info = null; unm -> fault_save.sv_array_offset = 0; unm -> fault_save.sv_rdr_label = rdr_label; unm -> fault_save.sv_rdr_ptr = rdr_ptr; unm -> fault_save.sv_rdr_state = rdr_state; err_recp = unm; rdr_state = 0; /* get to tty */ /* now identify the break */ call lisp_print_$type_string(" ;bkpt "); stack -> temp(10) = stack -> temp(2); /* our first arg */ if addr(lisp_static_vars_$prin1_atom) -> based_ptr->atom.value = 0 | addr(lisp_static_vars_$prin1_atom) -> based_ptr->atom.value = nil then stack -> temp(9) = lisp_static_vars_$prin1_atom; else stack -> temp(9) = addr(lisp_static_vars_$prin1_atom)->based_ptr->atom.value; call lisp_special_fns_$ncons; call lisp_$apply; call lisp_print_$type_nl; go to reset_read; /* read-eval-print loop */ break_rdnext: if pending_ctrl then do; string(unmask.against) = ""b; call lisp_fault_handler_$set_mask(unmask); /* if more ctrl chars stacked up, do them */ end; go to tty_join_in; r_e_p_loop: /* here is where the read-eval-print loop repeats */ addr(PLUS)->based_ptr -> atom.value = addr(MINUS)->based_ptr -> atom.value; if addr(ctrlQ)->based_ptr -> atom.value = nil then do; /* comments are in lisp.pl1 */ tty_loop: call lisp_print_$type_nl; tty_join_in: stack_ptr = addr(stack -> temp(10)); addr(stack -> temp(9)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(9)) -> fixedb = 0; call lisp_reader_$read; end; else do; uread_loop: stack_ptr = addr(stack -> temp(11)); addr(stack -> temp(10)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(10)) -> fixedb = -2; addr(stack -> temp(9)) -> flonum_fmt.type_info = flonum_type; addr(stack -> temp(9)) -> fixedb = 0; call lisp_reader_$read; if addr(stack->temp(9)) -> flonum_fmt.type_info = flonum_type then if addr(stack->temp(9)) -> fixedb = 0 then go to tty_loop; end; addr(MINUS)->based_ptr -> atom.value = stack -> temp(9); if stack -> temp(9) = dollar_p_atom then go to breakwxe; /* $p exits the break */ if stack -> temp_type(9) then; else if stack -> temp_ptr(9) -> cons.car = return_atom then do; /* (return val) exits the break with a value */ stack -> temp(1) = stack -> temp_ptr(9) -> cons_ptrs.cdr -> cons.car; /* get val */ go to breakwxe; end; call lisp_$eval; addr(STAR)->based_ptr -> atom.value = stack -> temp(9); stack_ptr = addr(stack -> temp(11)); stack -> temp(10) = stack -> temp(9); stack -> temp(9) = lisp_static_vars_$print_atom; call lisp_special_fns_$ncons; call lisp_$apply; go to r_e_p_loop; /* error caught by an errset - return to read-eval-print loop */ break_err: unwind_to = rel(addrel(err_frame, 6+size(fault_save))); call lisp_unwinder; stack_ptr = addr(stack -> temp(10)); call iox_$put_chars(iox_$user_output, addr(bell), 1, iox_status); dcl bell char(1) static options(constant) init(""); addr(ctrlQ) -> based_ptr -> atom.value = nil; /* get back to console input */ /* reset the reader's tty buffer */ dcl lisp_io_control_$clear_input entry, 1 iochan based aligned, 2 ioindex fixed bin(35), 2 iolength fixed bin (35); /* rest of structure not declared here since not needed */ reset_read: stack -> temp(9) = nil; /* flush buffered input from tty */ call lisp_io_control_$clear_input; /* = lisp (clear-input nil) */ rdr_state = 0; go to break_rdnext; breakwxe: unwind_to = rel(binding_top); /* unwind it all */ call lisp_unwinder; breakxe: stack_ptr = addr(stack -> temp(2)); call lisp_$eval; /* eval return value */ return; progv: entry; myname = fn_progv; stack = addrel(stack_ptr,-2); stack_ptr = addr(stack->temp(3)); stack->temp(2) = stack->temp_ptr(1)->cons.car; stack->temp(1) = stack->temp_ptr(1)->cons.cdr; call lisp_$eval; stack_ptr = addr(stack->temp(4)); stack->temp(3) = stack->temp_ptr(1)->cons.car; stack->temp(1) = stack->temp_ptr(1)->cons.cdr; call lisp_$eval; /* now build a binding block, saving all old values */ do while(stack->temp(2)^=nil); p = stack_ptr; stack_ptr = addrel(p,4); p->bindings(1).atom = stack->temp_ptr(2)->cons.car; p->bindings(1).old_val = stack->temp_ptr(2)->cons_ptrs.car->atom.value; stack->temp(2) = stack->temp_ptr(2)->cons.cdr; end; p = unmkd_ptr; unmkd_ptr = addrel(p,2); p->binding_block.bot_block = rel(addr(stack->temp(4))); p->binding_block.top_block = rel(stack_ptr); p->binding_block.back_ptr = rel(binding_top); p->binding_block.rev_ptr = ""b; binding_top = p; /* now binding block has been made, set atoms to new values */ p = addr(stack->temp(4)); do while(p^=stack_ptr & stack->temp(3)^=nil); /* scan supplied values */ addr(p->bindings(1).atom)->based_ptr->atom.value = stack->temp_ptr(3)->cons.car; stack->temp(3) = stack->temp_ptr(3)->cons.cdr; p = addrel(p,4); end; do while(p^=stack_ptr); /* fill in rest with nil */ addr(p->bindings(1).atom)->based_ptr->atom.value = nil; p = addrel(p,4); end; p = stack_ptr; stack_ptr = addr(p->temp(2)); do while(stack->temp(1)^=nil); /* evaluate body */ p->temp(1) = stack->temp_ptr(1)->cons.car; stack->temp(1) = stack->temp_ptr(1)->cons.cdr; call lisp_$eval; end; stack->temp(1) = p->temp(1); unwind_to = rel(binding_top); call lisp_unwinder; stack_ptr = addr(stack->temp(2)); return; /* eval-when -- BSG 4/26/80 */ eval_when: entry; myname = fn_eval_when; stack = addrel (stack_ptr, -2); /* fsubr, gets 1 arg */ call need_arg; stack_ptr = addrel (stack, 4); /* need a temp */ stack -> temp(2) = stack -> temp_ptr(1) -> cons.cdr; /* save forms */ do stack -> temp(1) = stack -> temp_ptr(1) -> cons.car /* get test list */ repeat (stack -> temp_ptr(1) -> cons.cdr) while (stack -> temp_type(1) = Cons); if stack -> temp_ptr(1) -> cons.car = lisp_static_vars_$eval_atom then do; call xec_body; stack -> temp(1) = lisp_static_vars_$t_atom; stack_ptr = addr (stack -> temp(2)); return; end; end; stack -> temp(1) = lisp_static_vars_$nil; stack_ptr = addr (stack -> temp(2)); return; end;  lisp_reader_.pl1 07/06/83 0937.0r w 06/29/83 1542.4 632556 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ read: proc; /* * lisp_reader_ which does all formatted input for lisp * written 20-JUNE-1972 by David Moon * modified 30 June 72 to make read, readch, and tyi lsubr's DAM * modified to allow quits while reading, * to allow macro characters in readlist -- D A Moon 14 Aug 72 * prologue interpreter added 17 Aug 72 D A Moon * eof_retn bug fixed, 7 Sep. 72 by DAM * Major revisions for increased speed and other good things, 27 Nov 1972, DAM * bignum reader added, 14 Jan 1972, dam * new (lsubr) version of tyipeek added, dam, 30 jan 73 * modified for new I/O system, 23 Mar 73 by DAM * changed to bind infile, ^q when a file arg is given, 10 June 1973 by dam. * modified 21 October 1973 by DAM for new syntax bits, new iochan format. * modified 18 February 1974 by DAM for the implode function * modified 15 April 1974 by DAM for EIS and to fix bugs in number reader * modified 74.05.30 by DAM for new arrays * modified 74.09.21 by DAM to accept t for the tty as well as nil * modified 28 November 1979 by BSG for top-level splicing macro hacks. * modified 5/2/80 by BSG for read_from_list * modified 08/20/82 by Richard Lamson to fix tyi EOF handling * modified 10/07/82 by Richard Lamson to fix previous fix for tyipeek */ dcl fb fixed bin aligned, /* ascii code for current character */ 1 kludge_structure aligned based(addr(fb)), /* to make b be right-aligned */ 2 random_garbage_bits bit(27) unaligned, 2 b char(1) unaligned, /* this is really the low 9 bits of fb */ lisp_static_vars_$infile external fixed bin(71), infile fixed bin(71) def (lisp_static_vars_$infile), bb bit(27), /* syntax bits for b */ unm ptr, /* -> unmarked pdl */ unm1 ptr, /* saved value of unm on entry, for eof_retn */ stack ptr, /* -> marked pdl */ errcode(2) fixed bin aligned based, /* for calls to lisp_error_ */ implode_sw bit(1), /* 1 => implode, 0 => maknam */ tyipeeksw bit(1), /* so tyipeek can return 3 (ETX or ^C) on EOF */ special_file bit(1), /* 1 => have binding block for infile, ^q */ eolhacksw bit(1), /* when readlisting, supplies space at end of list */ eofstack ptr, /* -> eofval,,special input file */ origb fixed bin, /* save untranslated char */ pnp ptr, /* -> pname buffer */ pnamelen fixed bin, /* number of chars in pname buffer */ pname_buffer char(pnamelen) aligned based(pnp), (real_io, readlistf, read_from_stringf) bit(1), /* distinguish between read and*/ /* readlist and read re-directed to a read list */ p ptr, inp ptr; /* -> iochan structure for current input channel */ dcl newline char(1) static init(" "); dcl (lisp_static_vars_$quote_macro, lisp_static_vars_$semicolon_macro, lisp_static_vars_$vertical_bar_macro) fixed bin (71) aligned external static; /* special macro indicators */ dcl (ptr, rel, size, null, substr, addr, addrel, fixed, bit, unspec, divide, string, add, hbound, lbound, length, max, mod, multiply, float) builtin, b2 bit(27), /* for saving bb */ bb_wanted bit(27), /* for tyipeek - matched against bb */ /* Number Accumulators */ (nn, n4f) fixed bin(35), bign fixed bin(71), bigdn fixed bin(71), n fixed bin(35), dn fixed bin(35), one_word_limit fixed bin(71) static init(11111111111111111111111111111111111b), nmargs fixed bin(35), fn float bin(50), ib fixed bin, ibv fixed bin aligned based(addr( addr(addr(ibase) -> based_ptr -> atom.value) -> fixedb)), /* value of ibase */ fpdigits fixed bin, /* number of digits in fracyion part */ (bit36, bit36a) bit(36) aligned; /* for simulated pdp-10 lsh instructions */ dcl i fixed bin, /* random do-loop index */ tblp ptr, /* calculate addr of read_table once only */ char1 char(1) aligned, bfb based fixed bin, inlist ptr, /* to input list for readlist */ iostatus bit(72) aligned; /* for calling ios_ */ dcl code fixed bin; /* implicit argument to internal procedure error */ dcl 1 readlist_data_struc based (readlist_data_strucp) aligned, /* for multi-frame readlist/readstringery */ 2 inlist ptr, /* ptr to marked pdl slot with readable Lisp object */ 2 stringf bit (1) aligned, /* 1 = read_from_string, 0 = readlist */ 2 chrct fixed bin (21); /* index of next char to be read */ dcl readlist_data_strucp ptr; dcl 1 auto_readlist_data_struc like readlist_data_struc automatic aligned; /* entry points called */ dcl lisp_$apply ext entry, lisp_property_fns_$putprop ext entry, lisp_list_utils_$subst ext entry, lisp_error_ ext entry, ios_$read ext entry(char(*) , ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned), ioa_ ext entry options(variable), lisp_alloc_$gensym ext entry, lisp_io_man_$free_uread_chan ext entry, make_lisp_subr_block_$make_array ext entry(fixed bin(71) aligned, fixed bin, dim(*) fixed bin, bit(1)), lisp_alloc_ ext entry (fixed bin, pointer), lisp_bignums_$bnread entry, lisp_property_fns_$get entry, lisp_special_fns_$ncons ext entry, lisp_special_fns_$cons ext entry, lisp_array_fcns_$star_array entry; /* dcl for bignums */ dcl 1 fnx aligned based(addr(fn)), /* structure of double floating number - for rou.nding */ 2 exp fixed bin(7) unal, 2 sign bit(1) unal, 2 mantissa bit(28) unal, /* first word + 1 bit for rounding */ 2 rest_of_mantissa bit(35) unal; dcl bnp ptr, bnct fixed bin, bnbp ptr, dpw fixed bin, bnsize fixed bin, bndigs(bnsize) fixed bin(35) aligned based(bnbp); /* array of digits, base bigradix(ib) */ /* nonstandard argument list for lisp_bignums_$bnread */ dcl 1 bnreadargs based aligned, 2 array ptr, /* -> bndigs array */ 2 size fixed bin(17) unal, /* size of array (in left half) */ 2 pad bit(18) unal, 2 radix fixed bin(35); /* radix of bndigs array */ %include lisp_bignum_io_data; %include lisp_bignum_fmt; /* Declaration of state variables */ dcl 1 stacked_variables aligned based(unm), /* stored on unmkd pdl, stacked by ( and ' */ 2 exitcode fixed bin, /* specifies where to return from rdobj */ 2 dotted_pair_flag bit(1), /* used by list reader to remember presence of dot */ 2 left_super fixed bin, 2 right_super fixed bin, (splice_dot_kludge init(0), topexit init(1), quotexit init(2), /* manifest values for exitcode */ listexit init(3), superexit init(4), /* superexit = listexit except indicates left super parenthesis */ list1exit init(5), /* same as listexit except is for first thing in list */ super1exit init(6)) fixed bin static, /* same as superexit except is for first thing in list */ got_splice bit(1), /* indicates splicing macro */ got_macro bit(1), /* indicates current object is result of a character macro */ got_something bit(1), /* indicates that some substantive object was read */ got_list bit(1), /* needed by top level newline kludge , means a list was read */ reading_atsym bit(1), /* for rdbk. */ reading_number bit(1), /* .. */ minus_flag bit(1), /* for number rdr */ forced_num bit(1), /* number introduced by +, containing letters as digits */ shiftscale_flag bit(1), /* indicates fixed point number modifier | or _ was seen */ expon_flag bit(1), /* indicates an exponent was seen */ float_flag bit(1), /* indicates an exponent or a decimal point */ dbnf bit(1), /* decimal overflow flag, make bignum if dot at end of number */ obnf bit(1), /* other base overflow flag, make bignum if no dot at end of number */ tyipeek_t bit(1), /* distinguish (tyipeek t) from other tyipeek */ in_middle bit(1), /* in middle of some objects, helps with eof handling */ dnum bit(1); /* indicates is a decimal number */ dcl prefsync static bit(1) init("0"b), /* "prefix sync:" see rdtvx: ff. */ lisp_fault_handler_$ctrl_from_reader entry(char(1)aligned); /* Declaration of stuff in lisp_reader_alm_ */ dcl ten_to_the(-38:38) float bin(50) aligned based(addr(lisp_reader_alm_$powers_of_ten)), lisp_reader_alm_$powers_of_ten external static, lisp_reader_alm_$left_shift entry(fixed bin(35), fixed bin(35)); %include lisp_name_codes; %include lisp_faults; %include lisp_io; %include lisp_array_fmt; %include lisp_readtable; /* declare combinations of syntax bits that will be needed. this has to be done because the v2pl1 code generator does not do logical-or's of manifest constants at compile time */ dcl (nspblnk init ("111111101010111111111111111"b), /* ^( special | blank | vertical_motion ) */ special_blank init ("000000000101000000000000000"b), /* special | blank */ alpha2 init ("000000000000000000000000011"b), /* alpha | extd_alpha */ realchar init ("000000001010110110000011111"b), /* single_char_object | lparn | dotted_pair_dot | macro | slashifier | string_quote_exp | shift_scale | plus_minus | digit | extd_alpha | alpha */ jwnumchar init ("000000000000000000000001111"b), /* plus_minus | digit | extd_alpha | alpha */ jwnumchar2 init ("000000000000000000000000101"b), /* digit | alpha */ bothdots init ("000000000000010000010000000"b), /* dotted_pair_dot | decimal_point */ goodbegin init ("000000001001100110000001111"b), /* blank | lparn | macro | slashifier | string_quote_exp | plus_minus | digit | extd_alpha | alpha */ brkchr1 init ("000000001011111100000000000"b), /* single_char_object | blank | lparn | dotted_pair_dot | rparn | macro | string_quote_exp */ nbrkchr init ("000000000000000010010011111"b) /* slashifier | shift_scale | plus_minus | digit | decimal_point | extd_alpha | alpha */ ) bit(27) static; %include lisp_stack_fmt; %include lisp_common_vars; %include lisp_nums; %include lisp_cons_fmt; %include lisp_ptr_fmt; %include lisp_atom_fmt; %include lisp_error_codes; %include lisp_string_fmt; /* fancy entry points to the reader */ /*read: entry; /* lisp read function */ tyipeeksw = "0"b; eolhacksw = "1"b; call eof_hack; readlistf = "0"b; call set_inp; /* find current input channel */ call set_tblp; readcom: unm = unmkd_ptr; unmkd_ptr = addrel(unm, 4); /* set up toplevel stacked variables */ /* Make sure the obarray is really an obarray, since much lossage could otherwise result */ call verify_obarray; exitcode = topexit; rdcom1: stack_ptr = addr(stack -> temp(2)); /* room in which to work */ go to rdobj0; /* go get something */ exit(1): if got_macro & got_splice /* top level splicing macro */ then if stack -> temp_type (1) = Cons /* Atoms mean naught */ then if stack -> temp_ptr (1) -> cons_types.cdr = Cons then do; code = badmacro; /* 2 or more objs at top level ng */ call error; end; else stack -> temp (1) = stack -> temp_ptr (1) -> cons.car; /* Take 1st elmt */ else go to rdobj0; /* "those nasty splicing read macros at top level " */ if ^got_something then go to rdobj0; /* ignore junk like extra right parens */ if readlistf then do; /* end of readlist/read-from-string */ inlist -> temp(1) = stack -> temp(1); /* move return value down */ stack_ptr = addr(inlist -> temp(2)); unm = err_recp; rdr_state = sv_rdr_state; rdr_label = sv_rdr_label; rdr_ptr = sv_rdr_ptr; err_recp = ptr(unm, fault_save.prev_frame); unmkd_ptr = unm; return; end; if got_list then if fb=10 then go to drop_nl; /* drop newline after list for MACLISP compatiblity -- unlike Multics, the PDP-10 needs no newline after ")" */ if bb & nspblnk /* nondisposable break char - save it */ then if real_io then inp -> iochan.ioindex = inp -> iochan.ioindex - 1; /* back up buffer */ else if readlist_data_struc.stringf then readlist_data_struc.chrct = readlist_data_struc.chrct - 1; else do; /* cons the character back onto the list */ stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = inlist -> temp(1); addr(stack -> temp(2))-> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2))-> fixedb = fb; call lisp_special_fns_$cons; inlist -> temp(1) = stack -> temp(2); end; drop_nl: eofstack -> temp(1) = stack -> temp(1); /* value to be returned */ eof_retn: if special_file then call eofhack_unbind; /* restore infile, ^q */ unmkd_ptr = unm1; stack_ptr = addr(eofstack -> temp(2)); return; read_from_string: entry; /* 5/2/80 BSG */ read_from_stringf = "1"b; go to readlist_join; readlist: entry; read_from_stringf = "0"b; readlist_join: tyipeeksw = "0"b; readlistf = "1"b; /* for return */ special_file = "0"b; call set_tblp; stack = stack_ptr; inlist = addrel(stack, -2); /* underneath the working stack is our arg */ rfs_retry: if read_from_stringf then if ^(inlist -> temp_type(1) = String | inlist -> temp_type(1) = Atsym) then do; unm = unmkd_ptr; /* bad_arg_correctable error */ unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = bad_arg_correctable; unm -> errcode(2) = fn_read_from_string; call lisp_error_; /* the bad arg is already on stack */ go to rfs_retry; /* Error Recovery -- new value for arg is on stack */ end; if ^read_from_stringf & inlist -> temp(1) = nil then do; /* special case (readlist nil) => (ascii 0) */ fb = 0; stack = inlist; call get_sing_char; return; end; /* save the state of the reader in case this readlist is in a macro-char function */ unm = unmkd_ptr; unmkd_ptr = addrel(unm, size(fault_save)); fault_save.prev_frame = rel(err_recp); fault_save.stack_ptr = rel(stack); fault_save.sv_gc_inhibit = gc_inhibit; fault_save.code1 = 0; /* indicate no error associated with this fault_save */ fault_save.sv_array_info = null(); /* we're not in the middle of an array opertaion */ sv_rdr_label = rdr_label; sv_rdr_ptr = rdr_ptr; sv_rdr_state = rdr_state; err_recp = unm; readlist_data_strucp = addr (auto_readlist_data_struc); readlist_data_struc.inlist = inlist; readlist_data_struc.stringf = read_from_stringf; readlist_data_struc.chrct = 1; rdr_ptr = addr (readlist_data_struc); rdr_state = 2; /* so that macros will read from the readlist */ real_io = "0"b; eolhacksw = "1"b; /* so no need be supplied to terminate an atom */ go to readcom; maknam: entry; implode_sw = "0"b; go to maknam_joint; implode: entry; implode_sw = "1"b; maknam_joint: stack = addrel(stack_ptr, -2); /* -> arg which is list of chars */ unm = unmkd_ptr; call pnamesetup; do while (stack -> temp_type(1) = Cons); if stack -> temp_ptr(1) -> cons_types36.car & Fixed36 then do; /* number is ascii code for char */ fb = addr(stack -> temp_ptr(1) -> cons.car) -> fixedb; if fb < 0 then go to maknamloss; if fb >= 128 then go to maknamloss; end; else if stack -> temp_ptr(1) -> cons_types36.car & Atsym36 then b = substr(stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pname, 1, 1); else go to maknamloss; call pnameput; /* deposit character into pname buffer */ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* advance input list */ end; if implode_sw then call get_atom; else call make_name; unmkd_ptr = pnp; /* clear unmkd pdl */ return; /* come here in the even of of an error while maknam'ing */ maknamloss: stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* the losing "character" */ go to err_2; readstring: entry; /* Here is the lisp 'readline' function, formerly called readstring */ tyipeeksw = "0"b; eolhacksw = "1"b; call eof_hack; call char_read_setup; call set_inp; call pnamesetup; rs_loop: call rdinch; if b = newline then do; call lisp_alloc_(divide(pnamelen+7, 4, 17, 0), stack -> temp_ptr(1)); stack -> temp_type(1) = String; stack -> temp_ptr(1) -> lisp_string.string_length = pnamelen; stack -> temp_ptr(1) -> lisp_string.string = pname_buffer; go to drop_nl; /* return it */ end; /* normal character, put it in */ in_middle = "1"b; /* we are now really reading something */ call pnameput; go to rs_loop; char_read_setup: proc; in_middle = "0"b; reading_atsym, reading_number = "0"b; unm = unmkd_ptr; unmkd_ptr = addrel(unm, size(stacked_variables)); exitcode = 1; /* necessary to make end of file in readline work properly */ call set_tblp; /* required by rdinch */ end; /* come here to read in one object */ rdobj0: /* reset all the state variables that need to be reset */ got_macro, got_something, got_list, reading_atsym, reading_number, minus_flag, forced_num, expon_flag, float_flag, in_middle, dnum, dotted_pair_flag, shiftscale_flag = "0"b; rdobj1: call rdchar; rdobj: if bb & blank then go to rdobj1; /* skip over blanks */ else if bb & alpha2 then do; /* atomic symbol */ call pnamesetup; obtain_pname: call pnameput; rdnumo_aa: reading_atsym = "1"b; /* so rdchar will know what to do with break char */ read_Atloop: call rdchar; call pnameput; go to read_Atloop; /* rdchar jumps to here when the break char is detected */ rdaend: got_something = "1"b; /* because of random 'goto rdaend' somewhere */ reading_atsym = "0"b; call get_atom; /* find the atom in hash table */ call reset_tblp; /* garbage collector may have moved readtable */ unmkd_ptr = pnp; /* flush the pname buffer */ go to exit(exitcode); /* come here when a number is discovered to be really an atomic symbol */ rdnumo: reading_number, minus_flag, expon_flag, float_flag, dnum = "0"b; go to rdnumo_aa; end; /* LIST READER */ else if bb & lparn then do; unm = unmkd_ptr; /* push stacked-variables */ unmkd_ptr = addrel(unm, 4); if bb & bit12 then do; left_super = origb; right_super = fb; /* expected matching right super parenthesis */ exitcode = super1exit; end; else exitcode = list1exit; dotted_pair_flag = "0"b; stack -> temp(1) = nil; /* initially no list has been read */ call rdchar; /* skip over the left parenthesis */ rdlst3x: stack_ptr = addr(stack -> temp(4)); /* stack contains: 1 -> list being read. 2 -> last cons in list being read, to be rplacd'ed 3 = temp storage for object being read in list */ stack = addr(stack -> temp(3)); rdlst3a: go to rdobj; /* come back here after reading an element of any kind of list */ exit(3): exit(4): exit(5): exit(6): if dotted_pair_flag then go to rdlst4; if got_macro then do; got_macro = "0"b; /* Turn off flag */ if ^got_splice then go to rdlst2; else do; /* ^splicing is regular stuff */ got_something = "0"b; /* in case it is nothing */ if stack -> temp_type(1) then go to rdlst3a; /* if it is nothing, go away */ /* copy the list to be spliced in and remember its ending cons */ /* only have to copy top level */ stack = addrel(stack, -4); stack_ptr = addr(stack -> temp(7)); stack -> temp(4) = nil; do while (stack -> temp_type(3) = Cons); stack -> temp(6) = stack -> temp_ptr(3) -> cons.car; stack -> temp(3) = stack -> temp_ptr(3) -> cons.cdr; call lisp_special_fns_$ncons; call reset_tblp; /* garbage collector may have moved readtable */ if stack -> temp(4) = nil then /* remember start of list */ stack -> temp(4) = stack -> temp(6); else stack -> temp_ptr(5) -> cons.cdr = stack -> temp(6); /* or chain list together */ stack -> temp(5) = stack -> temp(6); /* remember last cons in list */ end; stack -> temp(3) = stack -> temp(5); splice_it_in: /* 1 -> list being built up 2 -> last cons in that list, unless first time 3 -> new last cons 4 -> cons to be added to end of list (usually same as 3) */ if exitcode >= list1exit /* if first time */ then do; exitcode = exitcode - 2; /* is no longer first time */ stack -> temp(1) = stack -> temp(3); /* set ptr to 1st cons in list */ end; else stack -> temp_ptr(2) -> cons.cdr = stack -> temp(4); stack -> temp(2) = stack -> temp(3); /* new last cons in list */ got_something = "0"b; go to rdlst3x; /* keep on reading list */ end; end; else if got_something then do; rdlst2: stack = addrel(stack, -4); /* get back our own stack */ stack_ptr = addr(stack -> temp(4)); call lisp_special_fns_$ncons; call reset_tblp; /* garbage collector may have moved readtable */ stack_ptr = addr(stack -> temp(5)); stack -> temp(4) = stack -> temp(3); go to splice_it_in; end; else if bb & rparn then /* some kind of right parenthesis */ rparn_proc: if bb & bit12 then do; /* RIGHT SUPER-PARENTHESIS */ if exitcode = listexit then go to supply_right; if exitcode = list1exit then go to supply_right; if exitcode = superexit then go to check_super_match; if exitcode = super1exit then check_super_match: if right_super ^= fb then /* mismatched super parentheses -- barf! */ go to err_mmsp; else go to rdlst_r_p; /* matches left-super */ go to err_nlsp; /* matches quote or toplevel, error */ /* ignores leading ) but not leading ] */ /* (...] causes ) to be inserted before the ] */ supply_right: got_something = "1"b; stack = addrel(stack, -4); /* pop back */ stack_ptr = addr(stack -> temp(2)); unmkd_ptr = unm; unm = addrel(unm, -4); got_list = "1"b; if exitcode < listexit /* returning to toplevel or quote, enough )'s have been supplied */ then go to rdex; else go to exit(exitcode); /* returning to list, keep on supplying )'s */ end; else do; /* REGULAR RIGHT PARENTHESIS */ if exitcode = superexit then go to supply_left; if exitcode = super1exit then go to supply_left; rdlst_r_p: stack = addrel(stack, -4); /* pop back */ stack_ptr = addr(stack -> temp(2)); unmkd_ptr = unm; unm = addrel(unm, -4); /* put in a pseudo space as next char so no read off end of file */ rdex: bb = ^nspblnk; fb = 128; /* doesn't matter */ got_something = "1"b; got_list = "1"b; go to exit(exitcode); /* [ ... ) --> [(...) that is, a left super parenthesis may only match a right super parenthesis, not a ) */ supply_left: stack = addrel(stack , -4); stack_ptr = addr(stack -> temp(3)); stack -> temp(2) = nil; call lisp_special_fns_$cons; /* make list with present list as 1st elem */ call reset_tblp; /* garbage collector may have moved readtable */ exitcode = superexit; /* have read first thing now. */ call rdchar; /* skip over the right paren */ go to rdlst3x; /* keep reading looking for right super paren */ end; /* must be right paren missing */ parn_missing: code = parenmissing; call error; /* dotted pair processor */ rdlst4: if got_macro then if got_splice then if stack -> temp_type (1) = Cons then if stack -> temp_ptr (1) -> cons_types.cdr = Cons then go to dot_loses; /* no multi-lists */ else stack -> temp (1) = stack -> temp_ptr (1) -> cons.car; else do; /* Got nothing */ got_macro, got_something = "0"b; go to rdobj; end; got_macro = "0"b; if ^got_something then go to dot_loses; /* (a.) not allowed */ if exitcode >= list1exit then go to dot_loses; /* (. not allowed */ /* if exitcode = super1exit then go to dot_loses; /* [. not allowed */ /* OK, attach to end of list */ stack = addrel(stack, -4); rdlst39: stack -> temp_ptr(2) -> cons.cdr = stack -> temp(3); rdlst40: if bb & rparn then do; stack = addrel(stack, 4); /* put back where we found it */ go to rparn_proc; /* and go handle the right paren in the usual way */ end; if bb & realchar then; else do; call rdchar; go to rdlst40; end; /* check for splicing macro at end of dotted list, move it up to before the dot */ if bb & macro then if bb & splice then do; got_splice = "1"b; stack_ptr = addr(stack -> temp(5)); stack = addr(stack -> temp(4)); unm = unmkd_ptr; unmkd_ptr = addrel(unm, 4); /* push stacked-variables */ exitcode = splice_dot_kludge; /* set to come back after expanding macro */ go to proc_macro; exit(0): unmkd_ptr = unm; unm = addrel(unm, -4); stack = addrel(stack, -6); /* contents of stack: temp(1) - list being built (first) temp(2) - list being built (last) temp(3) - cdr of dotted pair temp(4) - value of splicing macro */ got_something, got_splice = "0"b; if stack -> temp_type(4) = Cons then do; /* really splice (if atom, dotted pair already set up on end of list) */ stack_ptr = addr(stack -> temp(4)); go to dot_loses; end; call reset_tblp; /* garbage collector may have moved readtable */ go to rdlst39; end; /* loser forgot to put right paren after dotted pair */ code = parenmissing; call error; end; else if bb & digit then go to rdnum; else if bb & plus_minus then do; /* object begins with a + or a - */ call pnamesetup; /* in case it turns out to be an atomic symbol */ call pnameput; /* save the + or the - */ if bb & bit12 then minus_flag = "1"b; in_middle = "1"b; call rdchar; in_middle = "0"b; /* if (status +) is t, use White's base>10 "+" hack */ if plus_status = nil then if bb & jwnumchar then if bb & digit then go to rdnum2; /* yes, it really seems to be a number */ else /* no, it's actually an atomic symbol */ do; minus_flag = "0"b; go to obtain_pname; /* so read rest of it */ end; else; else if bb & jwnumchar2 then do; /* White's + hack, forces it to be a number */ forced_num = "1"b; go to rdnum2; end; /* plus not followed by digit or letter */ if bb & decimal_point then do; in_middle = "1"b; call rdchar; in_middle = "0"b; if bb & digit then go to rdobj5; /* -.d floating point */ end; else if bb & special then /* just + by itself */ do; minus_flag = "0"b; /* turn off flag */ go to rdaend; end; /* not a recognizable form */ go to ill_obj; end; else if bb & dotted_pair_dot then do; b2 = bb; /* save the dot or decimal point */ in_middle = "1"b; call rdchar; /* and look ahead a little */ in_middle = "0"b; if bb & digit then if b2 & decimal_point then do; /* .d floating point */ rdobj5: dnum, float_flag = "1"b; n4f = 0; /* set up to get fraction part */ go to rdnum; end; /* OK, must be a dotted pair */ if dotted_pair_flag then go to dot_loses; /* can't have two dotted pairs in a row */ /* i.e a dotted triple */ dotted_pair_flag = "1"b; if bb & goodbegin then; else dot_loses: do; code = doterror; call error; end; go to rdobj; /* OK, go get second half of dotted pair */ end; else if bb & decimal_point /* period with syntax as decimal point but not dotted pair dot */ then go to rdnum; /* rdnum will decide if it is flonum or atomic symbol */ else if bb & string_quote_exp then if bb & bit12 then do; /* read a string */ in_middle = "1"b; call pnamesetup; /* make a buffer */ stringer: call rdinch; bb = tblp -> syntax(fb); /* We want to see slashes! */ if bb & string_quote_exp then if bb & bit12 then go to end_maybe; put_stringer: call pnameput; go to stringer; end_maybe: call rdinch; /* in case "" which means " inside string */ bb = tblp -> syntax(fb); if bb & string_quote_exp then if bb & bit12 then go to put_stringer; /* really end of string */ in_middle = "0"b; call lisp_alloc_(1+divide(pnamelen+3, 4, 17, 0), p); p -> string_length = pnamelen; p -> lisp_string.string = pnp -> pname_buffer; stack -> temp_ptr(1) = p; stack -> temp_type(1) = String; got_something = "1"b; /* we read something substantial */ unmkd_ptr = pnp; /* remove pname buffer from unmkd pdl */ call reset_tblp; /* garbage collector may have moved readtable */ /* pretend current char was read by rdchar instead of rdinch */ origb = fb; fb = tblp -> translation(fb); go to exit(exitcode); end; else; /* PROPER BALANCE OF IF CLAUSES IS IMPERATIVE */ else if bb & macro then do; /* macro character */ if bb & splice then got_splice = "1"b; else got_splice = "0"b; proc_macro: /* b=index in macro_table (unless someone clobbered it) */ if fb <= 0 then go to bad_mac; if fb <= num_macs then stack -> temp(1) = tblp -> macro_table(fb); else do; /* have to search list */ stack -> temp(1) = tblp -> more_macros; do fb = -fb by 1 to -10; /* take a sufficient number of cdrs */ if stack -> temp(1) = nil then go to bad_mac; if stack -> temp_type(1) then go to bad_mac; stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; end; if stack -> temp(1) = nil then go to bad_mac; if stack -> temp_type(1) then goto bad_mac; stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; end; stack_ptr = addr(stack -> temp(3)); if stack -> temp(1) = lisp_static_vars_$quote_macro /* check for internal macros */ then go to special_quote_macro; else if stack -> temp(1) = lisp_static_vars_$semicolon_macro then go to special_semicolon_macro; else if stack -> temp(1) = lisp_static_vars_$vertical_bar_macro then go to special_vertical_bar_macro; stack -> temp(2) = nil; call lisp_$apply; /* apply macro function to nil */ /* It's easy now that those delayed read macros have been flushed */ call set_inp; /* in case the macro fcn changed the input dev. on us */ call set_tblp; /* in case bastard changed readtable */ semicolon_macro_join: if tyipeeksw then go to tyipeek_proc_macro_ret; fb = 131; /* pseudo-space */ bb = special_blank; special_macro_join: got_macro, got_something = "1"b; /* got_splice already set */ go to exit(exitcode); bad_mac: fb = origb; call get_sing_char; /* convert to an atom with pname of the macro char */ do; code = badmacro; call error; end; end; else if bb & single_char_object then do; call get_sing_char; go to rdex; end; /* not good object begin char, just return it and let our caller figure it out */ go to exit(exitcode); rdchar: proc; /* get a char, return numeric code in fb, syntax bits in bb */ get_another: call rdinch; origb = fb; /* save untranslated char code */ fb = tblp -> translation(fb); /* translate char code */ if bb & special then; else return; /* ordinary char */ /* see if it's a break char */ if bb & brkchr1 then go to rdbk; /* Yes */ else if bb & nbrkchr then if bb & slashifier then do; /* slash - make next char look like extd_alpha */ call rdinch; bb = extd_alpha; return; end; else return; /* alpha or something with special somehow set */ else go to get_another; /* worthless - skip it */ rdbk: /* we read a break character - want to do something about it? */ if reading_atsym then go to rdaend; /* these tests _m_u_s_t be in this order */ else if reading_number then go to rdnum4; else return; end rdchar; /* all this proc does is get a char in fb and set bb to its syntax */ rdinch: proc; dcl unm ptr, sco char (1), cde fixed bin, lisp_io_control_$fix_not_ok_iochan entry(ptr, bit(1) aligned) returns(bit(1)aligned), lisp_io_control_$end_of_block entry (ptr, fixed bin(71), fixed bin), input_buffer_overlay char(inp -> iochan.iolength) aligned based(inp -> iochan.ioptr); rdinch_aa: fb = 0; /* clear bits in fb not set by setting b */ if real_io then do; if string(inp -> iochan.flags) & not_ok_to_read then if lisp_io_control_$fix_not_ok_iochan(inp, "0"b) then do; /* get new input source */ call set_inp; call reset_tblp; /* garbage collector may have moved readtable */ go to rdinch_aa; end; if inp -> iochan.ioindex >= inp -> iochan.iolength then do; /* ran out of chars, do something */ call lisp_io_control_$end_of_block(inp, eofstack -> temp(1), cde); call reset_tblp; /* garbage collector may have moved readtable */ go to tv(cde); /* action to take depends on what lisp_io_control_ did */ tv(2): if tyipeeksw then do; tyipeek_eof: fb = 3; go to tyicom; end; if eofstack -> temp_type36(1) & Float36 then /* top level loop - as a conveneneince, */ if eofstack -> fixedb = 0 then /* check for eof in middle of object even for cde=2 */ go to tv(1); go to eof_retn; tv(-1): call set_inp; go to rdinch_aa; tv(0): if inp -> iochan.interactive then read_print_nl_sync = "1"b; /* tty is at left margin now */ go to rdinch_aa; /* OK, process next block */ tv(1): /* err if in middle of object (EOF) */ if tyipeeksw then go to tyipeek_eof; if in_middle then go to g0001; else if exitcode ^= 1 then g0001: do; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = eof_in_object; call lisp_error_; call reset_tblp; /* garbage collector may have moved readtable */ go to tv1cont; /* user interrupt function said to continue anyway */ end; if cde = 1 then if reading_atsym | reading_number then do; fb = 131; /* pseudo-space - break out of this atom */ bb = special_blank; return; end; tv1cont: if cde = 2 then go to eof_retn; /* see tv(2): */ call set_inp; go to rdinch_aa; /* not in an object, continue reading */ end; inp -> iochan.ioindex = inp -> iochan.ioindex + 1; b = substr(input_buffer_overlay, inp -> iochan.ioindex, 1); if fb >= 128 then go to rdinch_aa; /*** ignore non-ascii characters */ /* this kludge is so that bsg's ec's can input control characters. If a \036=\r=^|^| is seen, it is taken as a prefix and the following char is a ctrl char unless it is 036 too. */ if fb = 030 /* 036 octal */ then if prefsync then prefsync = "0"b; /* double -- let it through */ else do; prefsync = "1"b; /* so come back here on next character */ go to rdinch_aa; end; else if prefsync then do; /* character following prefix = fb */ prefsync = "0"b; if b = "?" then /* handle this one specially */ if inp = tty_input_chan then call ioa_(";reading from terminal."); else call ioa_(";reading from file."); else call lisp_fault_handler_$ctrl_from_reader((b)); call set_inp; /* input source may have been changed */ call reset_tblp; /* garbage collector may have moved readtable */ go to rdinch_aa; end; /* vertical motion checking */ bb = tblp -> syntax(fb); /* get syntax for here and elsewhere's use */ if bb & vertical_motion then if ^ tyipeeksw then call proc_vertical_motion; return; end; else /* fake io */; if readlist_data_struc.stringf then do; /* read from string */ if inlist -> temp_type(1) & Atsym then do; if readlist_data_struc.chrct > inlist -> temp_ptr(1) -> atom.pnamel then go to readlist_eof; sco = substr (inlist -> temp_ptr(1) -> atom.pname, readlist_data_struc.chrct, 1); end; else do; if readlist_data_struc.chrct > inlist -> temp_ptr(1) -> lisp_string.string_length then go to readlist_eof; sco = substr (inlist -> temp_ptr(1) -> lisp_string.string, readlist_data_struc.chrct, 1); end; if ^tyipeeksw then readlist_data_struc.chrct = readlist_data_struc.chrct + 1; fb = fixed (unspec (sco), 9); bb = tblp -> syntax (fb); return; end; if inlist -> temp_type(1) then /* EOF */ readlist_eof: if tyipeeksw then do; /* could be tyipeek in readlist in char macro */ fb = 3; go to tyicom; end; else if eolhacksw then do; /* for readlist, supply one pseudo-space at end of list so atoms will terminate */ eolhacksw = "0"b; /* do this once only, in case parentheses mismatch */ supply_pseudo_space: fb = 131; bb = special_blank; return; end; else go to err_1; /* Mustn't call error except from immediately containing lexical block */ if inlist -> temp_ptr(1) -> cons_types.car & Fixed then do; fb = addr(inlist -> temp_ptr(1) -> cons.car) -> fixedb; if fb < 0 then go to readlistloses; else if fb > 131 then go to readlistloses; end; else if inlist -> temp_ptr(1) -> cons_types.car & Atsym then do; /*Atomic Symbol, use first char of pname */ b = substr(inlist -> temp_ptr(1) -> cons_ptrs.car -> atom.pname, 1, 1); end; else do; /* loser in input list */ readlistloses: inlist -> temp(1) = inlist -> temp_ptr(1) -> cons.car; /* the losing elem */ stack_ptr = addr(inlist -> temp(2)); go to err_2; end; /* set syntax for this character that we just read */ bb = tblp -> syntax(fb); /* read a char, so advance input list to next */ if ^tyipeeksw then inlist -> temp(1) = inlist -> temp_ptr(1) -> cons.cdr; return; end rdinch; set_inp: proc; /* to find the input file to be used and set the pointer inp to point to its iochan block. In the event of a re-entry to a readlist (e.g. because of a call to read from inside the function called by a macro character found in a readlist), real_io and inlist are set up */ if ^special_file then /* be sure to allow read macro fcn to escape to tty with (read nil) */ if rdr_state = 2 then do; /* re-entry to readlist */ real_io = "0"b; readlist_data_strucp = rdr_ptr; inlist = readlist_data_struc.inlist; /* -> stack cell containing ptr to list being read from */ return; end; if addr(ctrlQ)->based_ptr -> atom.value = nil then /* input from tty */ inp = tty_input_chan; else if addr(infile)->based_ptr -> atom.value = nil | /* input from tty anyway */ addr(infile)->based_ptr -> atom.value = t_atom then do; default_to_tty: inp = tty_input_chan; if ^special_file then addr(ctrlQ)->based_ptr -> atom.value = nil; /* make toplevel win */ end; else if addr( addr(infile)->based_ptr -> atom.value )->lisp_ptr_type & File36 then inp = addr(infile)->based_ptr -> atom_ptrs.value; /* take from file */ else go to default_to_tty; /* infile set bad, just take from tty */ real_io = "1"b; /* reading from iochan pointed at by inp */ return; end set_inp; increment_input_ptr: proc; if ^ real_io then if readlist_data_struc.stringf then readlist_data_struc.chrct = readlist_data_struc.chrct + 1; else inlist -> temp(1) = inlist -> temp_ptr(1) -> cons.cdr; else if bb & vertical_motion then call proc_vertical_motion; end increment_input_ptr; proc_vertical_motion: proc; /* character with vertical_motion syntax in fb, do all good things */ if ^ real_io then return; inp -> iochan.charpos = 0; /* NL and NP always cause return to left margin */ inp -> iochan.nlsync = "1"b; if fb = 12 then go to new_page; /* NP character */ inp -> iochan.linenum = inp -> iochan.linenum + 1; /* NL character */ if inp -> iochan.pagel = 0 then return; /* infinite pages */ if inp -> iochan.pagel > inp -> iochan.linenum /* or page not yet exceeded */ then return; new_page: inp -> iochan.linenum = 0; inp -> iochan.pagenum = inp -> iochan.pagenum + 1; /* advance to top of a new page */ return; /* no endpagefn's on input files */ end proc_vertical_motion; /* internal proc to get readtable, make tblp point at it */ set_tblp: proc; dcl stack ptr; /* make sure readtable is an array */ if addr( addr(readtable) -> based_ptr -> atom.value) -> lisp_ptr_type & Array36 then; else go to err; /* make sure it is a Readtable array */ if addr(readtable)-> based_ptr -> atom_ptrs.value -> array_info.type ^= Readtable_array then go to err; reset_tblp: entry; tblp = addr(read_table); /* set ptr to array structure for later use */ return; err: /* bad readtable, attempt to fix it then signal error */ stack = stack_ptr; stack_ptr = addr(stack -> temp(3)); stack -> temp(1) = readtable; /* get array property of readtable, */ stack -> temp(2) = array_atom; /* which should be the original readtable */ call lisp_property_fns_$get; if stack -> temp(1) ^= nil then addr(readtable) -> based_ptr -> atom.value = stack -> temp(1); code = badreadtable; call error; end set_tblp; /* declaration of obarray, and internal proc to make sure that the value of the atom obarray is really an obarray */ dcl htptr ptr, /* temp pointer to hash table */ 1 obarray_struct based(htptr) aligned, 2 hash_table(0:510) fixed bin(71), 2 char_objects(0:127) fixed bin(71); verify_obarray: proc; dcl stack ptr; if addr( addr(obarray)->based_ptr -> atom.value) -> lisp_ptr_type & Array36 then; else go to err; /* not an array, barf */ if addr(obarray)->based_ptr -> atom_ptrs.value -> array_info.type ^= Obarray_array then go to err; return; /* obarray is OK */ err: /* bad obarray, attempt to fix it then signal error */ stack = stack_ptr; stack_ptr = addr(stack -> temp(3)); stack -> temp(1) = obarray; /* get the array prop of obarray, which should be the initial obarray */ stack -> temp(2) = array_atom; call lisp_property_fns_$get; if stack -> temp(1) ^= nil then addr(obarray)->based_ptr -> atom.value = stack -> temp(1); code = badobarray; call error; /* uncorrectable error - for now */ end verify_obarray; /* Single - Character Readers */ real_tyi: entry; tyipeeksw = "0"b; eolhacksw = "0"b; call eof_hack; call char_read_setup; call set_inp; call rdinch; if special_file then call eofhack_unbind; tyicom: stack_ptr = addr(eofstack -> temp(2)); eofstack -> fixnum_fmt.type_info = fixnum_type; eofstack -> fixedb = fb; unmkd_ptr = unm1; return; real_tyipeek: entry; special_file = "0"b; /* fix a lotta things - BSG 5/4/80 */ tyipeek_t = "0"b; tyipeeksw = "1"b; eolhacksw = "0"b; unm1 = unmkd_ptr; /* We will need this later. */ call char_read_setup; stack = addrel(stack_ptr, -2); /* lsubr - get argcount */ nmargs = stack -> fixedb; eofstack = addrel(stack, nmargs); stack_ptr = addr(eofstack -> temp(4)); stack = addr(eofstack -> temp(3)); if nmargs = -2 then go to tyipeek_wierd; /* we have an argument, go do strange things */ eofstack -> temp(1) = t_atom; call set_inp; call rdinch; typk5: if real_io then inp -> iochan.ioindex = inp -> iochan.ioindex - 1; go to tyicom; tyipeek_wierd: stack -> temp(1) = eofstack -> temp(1); /* our arg */ eofstack -> temp(1) = t_atom; call set_inp; /* input from default input source, in tyipeek mode (eof sp.) */ tyipw_retry: if stack -> temp(1) = t_atom then do; nmargs = 177806848; /* 1246217000 octal */ tyipeek_t = "1"b; end; else do; if stack -> fixnum_fmt.type_info ^= fixnum_type then do; /* bad arg - barf */ unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = bad_arg_correctable; unm -> errcode(2) = fn_tyipeek; call lisp_error_; call reset_tblp; /* garbage collector may have moved readtable */ go to tyipw_retry; end; nmargs = stack -> fixedb; /* fetch argument */ end; if nmargs >= 512 /* "1000"b3 */ then go to tyipeek_really_wierd; /* search for the character n, position read ptr just before it */ tyipw_loop: call rdinch; /* get a character */ if fb = nmargs then go to typk5; /* if this is the one we want go finish up */ if ^real_io then if readlist_data_struc.stringf then readlist_data_struc.chrct = readlist_data_struc.chrct + 1; else inlist -> temp(1) = inlist -> temp_ptr(1) -> cons.cdr; /* patch up for readlist macro */ else if bb & vertical_motion then call proc_vertical_motion; go to tyipw_loop; tyipeek_really_wierd: /* searching for character of specified syntax */ bb_wanted = substr(unspec(nmargs), 1, 27); /* nmargs is syntax bits * 1000 octal */ /* align and change to a bit string */ tyipww_loop: call rdinch; /* get a character */ if tyipeek_t then if bb & macro then if bb & splice then do; call increment_input_ptr; got_splice = "1"b; fb = tblp -> translation(fb); go to proc_macro; tyipeek_proc_macro_ret: go to tyipww_loop; end; if bb & bb_wanted then go to typk5; /* found what we were looking for */ call increment_input_ptr; go to tyipww_loop; real_readch: entry; tyipeeksw = "0"b; eolhacksw = "0"b; call eof_hack; call char_read_setup; call set_inp; call rdinch; if special_file then call eofhack_unbind; stack = eofstack; stack_ptr = addr(stack -> temp(2)); call get_sing_char; unmkd_ptr = unm1; return; /* The lisp ascii function which converts a number to an atomic symbol */ ascii: entry; ascii_retry: call set_tblp; stack = addrel(stack_ptr, -2); if stack -> temp_type36(1) & Fixed36 then; /* winner */ else do; ascii_err: unm = unmkd_ptr; /* bad_arg_correctable error */ unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = bad_arg_correctable; unm -> errcode(2) = fn_ascii; call lisp_error_; /* the bad arg is already on stack */ go to ascii_retry; /* Error Recovery -- new value for arg is on stack */ end; fb = stack -> fixedb; if fb < 0 then go to ascii_err; else if fb > 511 then go to ascii_err; call get_sing_char; return; /* THE NUMBER READER */ rdnum: call pnamesetup; /* in case it's really an atomic symbol */ /* obtain value of ibase */ rdnum2: get_ibase: if addr(addr(ibase)->based_ptr -> atom.value) -> temp_type36(1) & Fixed36 then; else bad_ibase_: begin; dcl unmm ptr; unmm = unmkd_ptr; unmkd_ptr = addrel(unmm, 2); unmm -> errcode(1) = bad_ibase; call lisp_error_; call reset_tblp; /* garbage collector may have moved readtable */ go to get_ibase; end; ib = ibv; /* ... the value of ibase */ if ib < 2 then go to bad_ibase_; /* check range since going to use ib as index into arrays */ if ib >= 37 then go to bad_ibase_; /* bigradix and digsperwd */ call pnameput; n = 0; /* number to base ibase is accumulated here */ dn = 0; /* number to base 10 is accumulated here */ dbnf, obnf = "0"b; /* clear overflow flags */ fpdigits = 0; reading_number = "1"b; rdnum1a: if bb & digit then do; /* found a digit -- accumulate the number */ rdnum5: fb = fb - 48; bigdn = add(dn*10, fb, 71, 0); /* check for overflow */ if bigdn > one_word_limit then dbnf = "1"b; /* and if so, have decimal bignum */ else do; dn = bigdn; /* we can legally assign here */ fpdigits = fpdigits + 1; /* in case we are in a fraction part */ end; bign = add(n*ib, fb, 71, 0); /* check for overflow */ if bign > one_word_limit then obnf = "1"b; /* again check for legal assignment. */ else n = bign; /* Fall into rdnum1 */ rdnum1: call rdchar; call pnameput; go to rdnum1a; end; else if bb & decimal_point then proc_dec_point: if dnum then go to ill_obj; /* can't be a decimal point */ else if expon_flag then if shiftscale_flag then; /* allow . in fixed point scale, */ else go to ill_obj; /* but not in floating exponent */ else do; b2 = bb; dnum = "1"b; /* in case break char follows, will go to rdnum4 */ if ^ real_io then stack -> temp(1) = inlist -> temp(1); call rdchar; /* look ahead & find out what kind of decimal point */ call pnameput; /* don't lose the character */ if bb & digit then if shiftscale_flag then go to ill_obj; /* loser tried to shift fractional bits */ else do; float_flag, dnum = "1"b; /* make floating number of form ddd.ddd */ n4f = dn; /* save integer part */ dn = 0; fpdigits = 0; go to rdnum5; end; else if bb & string_quote_exp then if bb & bit12 then; else go to make_fake_mantissa; /* ddd.Ennn floating number */ else if bb & shift_scale then do; n = dn; /* shift or scale a decimal number */ go to rdnumss; end; /* randomness after a decimal point, might really be a dotted pair */ if b2 & dotted_pair_dot then do; dnum = "0"b; /* wasn't really a decimal point */ if real_io then inp -> iochan.ioindex = inp -> iochan.ioindex - 1; /* back up to the dot */ else if readlist_data_struc.stringf then readlist_data_struc.chrct = readlist_data_struc.chrct - 1; else inlist -> temp(1) = stack -> temp(1); /* This counteracts the lookahead */ /* that we did before */ bb = b2 & ^decimal_point; go to rdnum4; /* finish number, later dotted pair will be found */ end; else go to not_really_a_number; end; else if bb & string_quote_exp then if bb & bit12 then go to rdnumalph; else if forced_num then go to rdnumalph; /* in this case, e is digit not exponent mark */ else do; /* exponent marker */ if expon_flag then go to ill_obj; /* sorry, only one to a customer */ if shiftscale_flag then go to ill_obj; /* .. */ if ^float_flag then do; /* fake the fraction part */ make_fake_mantissa: n4f = dn; dn = 0; fpdigits = 0; end; if minus_flag then do; minus_flag = "0"b; n4f = -n4f; dn = -dn; end; float_flag, expon_flag, dnum = "1"b; if fpdigits < lbound(ten_to_the, 1) then go to flonum_out_of_range; if fpdigits >= 1+hbound(ten_to_the, 1) then go to flonum_out_of_range; fn = float(n4f, 50) + float(dn, 50) * ten_to_the(-fpdigits); n, dn = 0; go to rdnewnum; /* go get the exponent */ end; else rdnumalph: if bb & alpha then /* letter in a number */ if forced_num then do; /* The + hack, take it as a digit */ if fb < 96 then fb = fb - 7; /* so A comes out as 10 */ else fb = fb - 39; /* so a comes out as 10 */ go to rdnum5; /* just as if it were a digit */ end; else go to rdnumo; /* surprise, it really was an atomic symbol */ else if bb & shift_scale then do; if shiftscale_flag then go to ill_obj; rdnumss: shiftscale_flag = "1"b; /******** SHOULD DO BIGNUM SCALING HERE **********/ if minus_flag then do; minus_flag = "0"b; n = -n; end; if bb & bit12 then; else expon_flag = "1"b; /* scale */ if dnum then nn = dn; else nn = n; /* have the thing to be shifted or scaled */ dnum = "0"b; n, dn = 0; /* go read shift factor or scale factor */ go to rdnewnum; end; else /* some random crud in number */ not_really_a_number: if forced_num then go to ill_obj; else go to rdnumo; /* so make it an atomic symbol instead */ rdnewnum: call rdchar; call pnameput; if bb & plus_minus then do; if bb & bit12 then minus_flag = "1"b; go to rdnum1; end; go to rdnum1a; /* break char found */ rdnum4: if bb & decimal_point then go to proc_dec_point; /* don't want decimal points to be break characters when in a number */ if shiftscale_flag then do; /* perform a shift/scale operation that was requested earlier */ if dnum then n = dn; /* if decimal shift factor */ shiftscale_flag, dnum = "0"b; if minus_flag then go to ill_obj; /* It would be easy to do, but for some reason MACLISP doesn't allow it */ if expon_flag then do; /* SCALE */ expon_flag = "0"b; do i = 1 to n; /* fastest way since n is small unless the user is also a loser */ nn = nn * ib; end; end; else do; call lisp_reader_alm_$left_shift(nn, n); end; ret_fix: stack -> fixedb = nn; stack -> fixnum_fmt.type_info = fixnum_type; ret_num: forced_num = "0"b; got_something = "1"b; /* so they know we returned something */ unmkd_ptr = pnp; /* flush pname buffer */ reading_number = "0"b; go to exit(exitcode); end; else if expon_flag then do; /* the rest has already been floated and put in fn */ expon_flag, float_flag, dnum = "0"b; if minus_flag then do; minus_flag = "0"b; dn = -dn; end; if dn < lbound(ten_to_the, 1) then go to flonum_out_of_range_1; if dn >= 1+hbound(ten_to_the, 1) then go to flonum_out_of_range_1; fn = fn * ten_to_the(dn); ret_float: /* round the mantissa by using a based overlay on fn */ if fn >= 0 then do; nn = fixed(fnx.mantissa)+1; /* add 1 to first bit beyond first word of mantissa */ if substr(unspec(nn), 8, 1) then do; /* overflow, renormalize */ unspec(nn) = "0"b||unspec(nn); /* right shift mantissa 1 place */ n = fnx.exp + 1; /* and add one to exponent */ if n >= 128 then go to flonum_out_of_range; /* if exp overflows */ fnx.exp = n; /* if no overflow, put new exp back */ end; fnx.mantissa = substr(unspec(nn), 9, 28); /* put rounded mantissa back in fn */ end; else do; /* same code for negative number */ nn = fixed(fnx.mantissa)+1; if substr(unspec(nn), 9, 1) then do; /* must renormalize */ unspec(nn) = "0"b||unspec(nn); n = fnx.exp + 1; if n >= 128 then go to flonum_out_of_range; fnx.exp = n; end; fnx.mantissa = substr(unspec(nn), 9, 28); end; stack -> floatb = fn; stack -> flonum_fmt.type_info = flonum_type; go to ret_num; end; else if float_flag then do; /* ddd.ddd with no exponent */ float_flag, dnum = "0"b; if fpdigits < lbound(ten_to_the, 1) then go to flonum_out_of_range_2; if fpdigits >= 1+hbound(ten_to_the, 1) then go to flonum_out_of_range_2; fn = float(n4f, 50) + float(dn, 50) * ten_to_the(-fpdigits); if minus_flag then do; fn = -fn; minus_flag = "0"b; end; go to ret_float; end; else if dnum then do; dnum = "0"b; if dbnf then go to decimal_bignum; nn = dn; go to rfx; end; /* just an ordinary number */ if obnf then go to read_bignum; nn = n; rfx: if minus_flag then do; nn = -nn; minus_flag = "0"b; end; go to ret_fix; /* come here when floating number has exponent out of bounds */ flonum_out_of_range: flonum_out_of_range_1: flonum_out_of_range_2: code = flonum_too_big; call error; /* bignum reader */ /* extract the bignum from the pname buffer, convert it first to a larger base such that each digit almost fills up a word, then call the lisp_bignums_ module to convert the bignum to the proper internal form */ decimal_bignum: ib = 10; read_bignum: bnct = 0; bnp = pnp; /* check if there is a sign at the beginning that has to be dropped */ fb = 0; b = substr(pname_buffer, 1, 1); if b >= "a" then if b <= "z" then go to rdbn1; /* valid digit (in some bases) */ if b >= "A" then if b <= "Z" then go to rdbn1; /* .. */ if b >= "0" then if b <= "9" then go to rdbn1; /* .. */ call getbnc; /* random char at beginning, skip over it */ pnamelen = pnamelen - 1; /* set up array into which to put digits to base bigradix(ib) */ rdbn1: bnbp = unmkd_ptr; /* allocate the array on the unmkd pdl */ dpw = digsperwd(ib); bnsize = divide(pnamelen+dpw-1, dpw, 17, 0); /* size of array */ n = bnsize; if substr(unspec(n), 36, 1) then n=n+1; /* make even */ unmkd_ptr = addrel(bnbp, n); nn = (bnsize-1) * dpw; /* number of full words */ dn = 0; do i = 1 to pnamelen - nn; /* do the first word, which may contain less than dpw digits */ call getbnc; dn = dn*ib + fb; end; bndigs(1) = dn; /* put first word into array */ /* now do the rest of the digits */ do nn = 2 to bnsize; /* loop for each word in bndigs, except the first one */ dn = 0; do i = 1 to dpw; /* loop for each digit going to go into this word */ call getbnc; dn = dn*ib + fb; end; bndigs(nn) = dn; end; /* now call bignum module to add and multiply by bigradix to convert this to a real bignum */ stack_ptr = stack; /* the bignum will be pushed on */ bnp = unmkd_ptr; unmkd_ptr = addrel(bnp, size(bnreadargs)); bnp -> bnreadargs.array = bnbp; bnp -> bnreadargs.radix = bigradix(ib); bnp -> bnreadargs.size = bnsize; call lisp_bignums_$bnread; unmkd_ptr = pnp; /* clear all this garbage off the unmkd pdl */ if minus_flag then do; /* make the bignum negative if necc. */ minus_flag = "0"b; if stack -> temp_ptr(1) -> lisp_bignum.prec = 2 /* check for special case */ then if stack -> temp_ptr(1) -> lisp_bignum.words(1) = 0 then if stack -> temp_ptr(1) -> lisp_bignum.words(2) = 1 then do; stack -> fixnum_fmt.type_info = fixnum_type; unspec(stack -> fixedb) = "100000000000000000000000000000000000"b; go to done_negating; end; stack -> temp_ptr(1) -> lisp_bignum.sign = (18)"1"b; done_negating: end; else stack -> temp_ptr(1) -> lisp_bignum.sign = (18)"0"b; forced_num, reading_number = "0"b; got_something = "1"b; call reset_tblp; /* garbage collector may have moved readtable */ go to exit(exitcode); /* routine to get char from pname buffer for bignum. Returns digit value in fb */ getbnc: proc; fb = 0; bnct = bnct+1; b = substr(bnp -> pname_buffer, bnct, 1); if fb < 64 then fb = fb - 48; /* 0 to 9 */ else if fb < 96 then fb = fb - 55; /* A to Z */ else fb = fb - 87; /* a to z */ return; end getbnc; /* pname - buffer handlers */ pnamesetup: proc; /* init pname buffer */ pnamelen = 0; pnp = unmkd_ptr; /* put pname buffer in the unmarked pdl */ unmkd_ptr = addrel(pnp, 2); end; pnameput: proc; /* deposit byte into pname buffer */ pnamelen = pnamelen+1; substr(pname_buffer, pnamelen, 1) = b; if (unspec(pnamelen) & "000000000000000000000000000000000111"b) = (36)"0"b then do; /* need another double word */ unmkd_ptr = addrel(unmkd_ptr, 2); end; end; /* fast routines for the two builtin macro characters */ special_quote_macro: unm = unmkd_ptr; unmkd_ptr = addrel(unm, 4); exitcode = quotexit; go to rdcom1; /* read the S-expression to be quoted */ exit(2): if got_macro & got_splice then /* here we go again */ if stack -> temp_type (1) = Cons then if stack -> temp_ptr (1) -> cons_types.cdr = Cons then go to err_qm; else stack -> temp (1) = stack -> temp_ptr (1) -> cons.car; else do; got_something, got_macro = "0"b; go to rdobj; end; if ^ got_something then go to err_qm; /* ') is illegal */ /* and cons up a list of it */ stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = nil; stack -> temp(2) = stack -> temp(1); stack -> temp(1) = quote_atom; call lisp_special_fns_$cons; call lisp_special_fns_$cons; unmkd_ptr = unm; /* pop */ unm = addrel(unm, -4); got_splice = "0"b; /* bug... */ call reset_tblp; /* garbage collector may have moved readtable */ go to special_macro_join; special_semicolon_macro: read_1_line: call rdinch; if fb = 10 /* ascii newline */ then do; stack -> temp(1) = nil; /* splice () is a no-op */ stack_ptr = addr(stack -> temp(2)); go to semicolon_macro_join; end; else go to read_1_line; special_vertical_bar_macro: dcl firstfb fixed bin; firstfb = origb; in_middle = "1"b; call pnamesetup; call rdinch; do while(fb ^= firstfb); /* | */ if fb ^= 10 /* newline */ then do; if bb & slashifier then call rdinch; /* slash protects next char */ call pnameput; end; call rdinch; end; in_middle = "0"b; call get_atom; /* get an atom in */ unmkd_ptr = pnp; got_splice = "0"b; call reset_tblp; fb = 131; bb = special_blank; go to special_macro_join; eof_hack: proc; /* processes the arguments to read, etc lsubrs */ stack = addrel(stack_ptr, -2); /* -> argcount*-2 */ eofstack = addrel(stack, stack -> fixedb); /* -> args */ stack_ptr = addr(eofstack -> temp(4)); if stack -> fixedb = 0 then do; /* no args */ eofstack -> temp(1) = nil; /* no eofval */ special_file = "0"b; /* no bindings */ end; else if stack -> fixedb = -2 then /* 1 arg */ if eofstack -> temp_type36(1) & File36 then go to g0002; else if eofstack -> temp(1) = t_atom then go to g0002; else if eofstack -> temp(1) = nil then do; g0002: eofstack -> temp(2) = eofstack -> temp(1); /* special input source */ eofstack -> temp(1) = nil; /* no eofval */ go to special_inp; end; else special_file = "0"b; /* eofval given, but no special input source */ else /* 2 args */ if eofstack -> temp_type36(2) & File36 then go to special_inp; /* 1st arg is eofval, 2nd is file */ else if eofstack -> temp(2) = nil then go to special_inp; /* .. */ else if eofstack -> temp(2) = t_atom then go to special_inp; /* .. */ else do; /* interchange args */ eofstack -> temp(3) = eofstack -> temp(1); eofstack -> temp(1) = eofstack -> temp(2); eofstack -> temp(2) = eofstack -> temp(3); if eofstack -> temp(2) = nil then go to special_inp; /* yes, 2nd arg is file */ else if eofstack -> temp_type36(2) & File36 then go to special_inp; special_file = "0"b; /* no of those four goto's went, so ignore extra arg */ end; stack = addr(eofstack -> temp(3)); /* initial free slot */ unm1 = unmkd_ptr; /* save unmkd_ptr so can restore when done */ return; special_inp: /* bind infile to arg in eofstack -> temp(2), ^q to t */ special_file = "1"b; /* remember to get rid of binding block before returning */ stack_ptr = addr(eofstack -> temp(7)); /* room for binding block plus eofval cell plus temp(6) cell */ stack = addrel(eofstack, 2); /* -> bindings */ eofstack -> temp(6) = eofstack -> temp(2); /* save value to bind infile to */ stack -> bindings(1).atom = infile; stack -> bindings(2).atom = ctrlQ; stack -> bindings(1).old_val = addr(stack -> bindings(1).atom)->based_ptr -> atom.value; stack -> bindings(2).old_val = addr(stack -> bindings(2).atom)->based_ptr -> atom.value; unm1 = unmkd_ptr; unmkd_ptr = addrel(unm1, 2); unm1 -> binding_block.bot_block = rel(stack); unm1 -> binding_block.top_block = rel(addr(stack -> bindings(3))); unm1 -> binding_block.back_ptr = rel(binding_top); unm1 -> binding_block.rev_ptr = ""b; binding_top = unm1; addr(infile)->based_ptr -> atom.value = eofstack -> temp(6); /* specified input source */ addr(ctrlQ)->based_ptr -> atom.value = t_atom; /* enable it */ stack = addr(eofstack -> temp(6)); /* first cell available to program */ end; eofhack_unbind: proc; /* get rid of binding block created above */ /* called shortly before returning if special_file is found to be 1 */ stack = ptr(stack_ptr, binding_top -> binding_block.bot_block); /* -> bindings on marked pdl */ addr(stack -> bindings(1).atom)->based_ptr -> atom.value = stack -> bindings(1).old_val; addr(stack -> bindings(2).atom)->based_ptr -> atom.value = stack -> bindings(2).old_val; /* this better not be somebody else's bindings ! */ binding_top = ptr(binding_top, binding_top -> binding_block.back_ptr); end; /* caller will flush stacks */ err_1: code = shortreadlist; call error; err_2: code = badreadlist; call error; err_mmsp: code = mismatch_super_parens; call get_sing_char; /* actual right paren */ stack = addrel(stack, 2); stack_ptr = addr(stack -> temp(2)); fb = right_super; /* expected right paren */ call get_sing_char; call lisp_special_fns_$cons; /* so user can see them */ call error; err_nlsp: code = no_left_super_paren; call error; err_qm: code = quoterror; call error; ill_obj: code = illobj; call error; tma_err: code = too_many_args; call error; /* ERROR INTERFACE */ error: proc; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = code; call lisp_error_; end; /* The LISP makreadtable function, which copies the read table */ makreadtable: entry; /* just a write-around to *array now */ /* check for an arg of nil, which he have to replace with a gensym'ed atom */ stack = addrel(stack_ptr, -2); obnf = "0"b; if stack -> temp(1) = nil then do; makgensym: stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = 0; /* gensym is an lsubr */ call lisp_alloc_$gensym; end; else if stack -> temp(1) = t_atom then do; /* (makreadtable t) - copy initial onto a gensym */ obnf = "1"b; go to makgensym; end; stack_ptr = addr(stack -> temp(6)); stack -> temp(2) = stack -> temp(1); stack -> temp(3) = lisp_static_vars_$readtable; if obnf then stack -> temp(4) = t_atom; else stack -> temp(4) = nil; addr(stack -> temp(5)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(5)) -> fixedb = -6; call lisp_array_fcns_$star_array; stack_ptr = addr(stack -> temp(2)); /* return the atom which is still sitting under here */ return; lisp_get_atom_: entry (name, location); /* procedure to find an atom by name, and intern it on the current obarray. Redone completely for the unsharing of nil and the PL/I null pointer. New hash function, 16 Nov 1972, DAM */ dcl name char(*) aligned, extra_stuff bit(36) aligned based(addrel(pnp, namelen)), /* last word in pname */ kludgey_mask (1:4) static bit(36) aligned initial( /* for clearing extra bits at end of pname */ "777000000000"b3, /* 1 mod 4, 3 extra chars */ "777777000000"b3, /* 2 mod 4, 2 extra chars */ "777777777000"b3, /* 3 mod 4, 1 extra char */ "777777777777"b3), /* 4 chars in last word */ namelen fixed bin, location fixed bin(71) aligned, indx fixed bin, name_word fixed bin (35) aligned based, cnt fixed bin, stac ptr; call verify_obarray; /* make sure user hasn't bound obarray to nil or something */ pnamelen = length(name); pnp = addr(name); stack = addr(location); /* where to put the ptr to atom */ call get_atom; return; get_atom: proc; dcl esw fixed bin, maknamsw bit(1) init("0"b); /* gets an atom whose name is of length pnamelen beginning at loc pnp, a pointer to the resulting atom is put in stack -> temp(1) */ esw = 1; get_atom_join: /* hash code name */ /* add up all words in name, does not rely on knowing that unused chars are filled with \\000 */ /* NB: there is a copy of this algorithm 2 pages further on, under the entry hash_fcn. */ if pnamelen = 0 then indx = 511; /* ascii 0 is in char_objects(0) */ else if pnamelen = 1 & rank (substr(pname_buffer, 1, 1)) <= 127 then indx = 511 + rank (substr(pname_buffer, 1, 1)); /* char_objects(fb) */ else do; namelen = divide(pnamelen-1, 4, 17, 0); /* length of pname - 1 */ unspec(indx) = extra_stuff & kludgey_mask(pnamelen - 4*namelen); /* get last word */ do cnt = 0 to namelen-1; /* add up all words except last word */ indx = indx + addrel(pnp, cnt) -> name_word; end; indx = mod(indx, 509); end; /* get hash table pointer */ htptr = addr(obarray)->based_ptr->atom_ptrs.value -> array_info.array_data_ptr; /* now lookup in bucket */ if indx >= 511 then do; /* if in char_objects array, is not a bucket!! */ stack -> temp(1) = char_objects(indx-511); if stack -> temp(1) = nil then go to make_new; /* if no atom yet interned in this slot */ go to atom_rtn(esw); end; else do; /* in a bucket, have to go through the bucket - searching code */ stac = stack_ptr; stack_ptr = addr(stac -> temp(3)); do stac -> temp(1) = hash_table(indx) repeat stac -> temp_ptr(1) -> cons.cdr while(stac -> temp(1) ^= nil); stac -> temp(2) = stac -> temp_ptr(1) -> cons.car; if stac -> temp_ptr(2) -> atom.pnamel = pnamelen then if substr(stac->temp_ptr(2)->atom.pname,1,pnamelen) = substr(pname_buffer,1,pnamelen) then do; stack -> temp(1) = stac -> temp(2); stack_ptr = stac; go to atom_rtn(esw); end; end; end; /* not found, so make a new atom */ make_new: call lisp_alloc_(divide(pnamelen+23,4,17,0),stack->temp_ptr(1)); stack -> temp_type(1) = Atsym; stack -> temp_ptr(1) -> atom_double_words.value = Undefined; stack -> temp_ptr(1) -> atom.pnamel = pnamelen; substr(stack -> temp_ptr(1) -> atom.pname,1,pnamelen) = substr(pname_buffer,1,pnamelen); stack -> temp_ptr(1) -> atom.plist = nil; if maknamsw then return; /* if entered via make_name */ if indx >= 511 then char_objects(indx-511) = stack -> temp(1); /* put in proper place in obarray */ else do; stac -> temp(1) = stack -> temp(1); htptr = addr(obarray)->based_ptr->atom_ptrs.value -> array_info.array_data_ptr; stac -> temp(2) = hash_table(indx); call lisp_special_fns_$cons; htptr = addr(obarray)->based_ptr->atom_ptrs.value -> array_info.array_data_ptr; hash_table(indx) = stac -> temp(1); stack_ptr = stac; end; go to atom_rtn(esw); atom_rtn(1): return; get_sing_char: entry; dcl a_char char(1); dcl char_obj fixed bin(71) aligned based(charobjp), charobjp ptr; htptr = addr(obarray)->based_ptr->atom_ptrs.value -> array_info.array_data_ptr; if fb > 127 then go to make_new_sing_char; charobjp = addr(char_objects(fb)); if char_obj = nil then do; make_new_sing_char: if fb = 0 then pnamelen = 0; /* so (ascii 0) will be the null pname */ else pnamelen = 1; a_char = byte (fb); pnp = addr(a_char); esw = 2; go to get_atom_join; atom_rtn(2): if fb < 128 then char_obj = stack -> temp(1); /* save for later use */ end; else stack -> temp(1) = char_obj; call reset_tblp; /* garbage collector may have moved readtable */ return; make_name: entry; /* for maknam, make uninterned atomic symbol */ maknamsw = "1"b; go to make_new; end get_atom; /* ext entry to compute hash function - used by lisp_obarray_utils_ */ /****** KLUDGE: unlike lisp_get_atom_, this entry assumes that the extra bits in the last word of the pname have already been zeroed *******/ hash_fcn: entry(name, a_indx); dcl a_indx fixed bin; /* name char(*) aligned */ pnp = addr(name); if length(name) = 0 then indx = 511; else if length(name) = 1 & rank (substr (name, 1, 1)) <= 127 then indx = 511 + rank (substr (name, 1, 1)); else do; indx = 0; do cnt = 0 to divide(length(name)-1, 4, 17, 0); indx = indx + addrel(pnp, cnt) -> name_word; end; indx = mod(indx, 509); end; a_indx = indx; return; end;  lisp_reader_init_.pl1 07/06/83 0937.0r w 06/29/83 1542.4 12870 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1974 * * * ************************************************************** */ reader_init: proc; /* Initializes the read syntax table */ /* * D. A. Moon 27 June 1972 removed from lisp_reader_.pl1 * modified for new readtable format, 12 Nov 72, by DAM * changed to use lisp_reader_alm_$initial_readtable, 7 Apr 73 by DAM * modified 74.05.30 by DAM for new arrays */ %include lisp_stack_fmt; %include lisp_atom_fmt; %include lisp_common_vars; %include lisp_nums; dcl stack ptr, based_ptr pointer based aligned, addr builtin, lisp_static_vars_$readtable fixed bin(71) external, lisp_array_fcns_$star_array entry; /* The read table initializer */ stack = stack_ptr; stack_ptr = addr(stack -> temp(5)); addr(stack -> temp(4)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(4)) -> fixedb = -6; /* passing 3 arguments */ stack -> temp(1) = nil; /* create an array */ stack -> temp(2) = lisp_static_vars_$readtable; /* to be a readtable */ stack -> temp(3) = t_atom; /* and initialize it */ call lisp_array_fcns_$star_array; addr(lisp_static_vars_$readtable)->based_ptr -> atom.value = stack -> temp(1); stack_ptr = stack; end;  lisp_save_.pl1 07/06/83 0937.0r w 06/29/83 1542.5 463302 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_save_: proc(arg); /*** NOTE WELL: DUE TO A BUG IN THE PL1 COMPILER, THIS PROGRAM MUST ALWAYS BE COMPILED WITH -OPTIMIZE ***/ /* * changes made 3/20/73 by DAM: * changed the variable size to Size to allow use of the size BIF * added pointer overlays curptrp, newptrp, fakeptrp * added code to save file objects (iochans) * Modified 73.12.17 by DAM for a new format of saved environment header * Modified 74.06.03 by DAM for new-arrays and to save the gensym data * Modified 78.06.04 by BSG to put on Subr bit in snapped array links * Modified 82.10.14 by Richard Lamson to remove warning about up-to-date-ness */ /* D E C L A R A T I O N S */ /* P A R A M E T E R */ dcl arg char(*) parameter; /* name of env. to save */ /* A U T O M A T I C */ dcl current_save_seg bit(18) init(""b), /* baseno of last temp seg created, used for threading */ temp_ptr ptr, /* used to circomvent PL/I v2 bug */ temp_ptr_1 ptr, temp_ptr_0 ptr, first_save_seg bit(18) init(""b), /* baseno of first temp seg created, has thread to rest */ free_allocptr ptr init(null), /* -> next cell of lists space in temp seg to allocate */ stat_allocptr ptr init(null), /* -> next part of static temp seg to allocate */ dir char(168), /* directory pathname */ ent char(32), /* entryname of savefile */ ename char(32), segnumber fixed bin init(0), /* msf component number */ curptr fixed bin(71) aligned, /* current object */ curptrp ptr aligned based(addr(curptr)), /* and same as a pointer */ newptr fixed bin(71) aligned, /* copy */ newptrp ptr aligned based(addr(newptr)), /* and same as a pointer */ newsegptr ptr, fakeptr fixed bin(71) aligned, /* object stored in saved env - has fake segment number */ fakeptr2 fixed bin(71) aligned, newptr2 ptr, fake_lists_seg bit(18), /* segment index of current lists seg for making fakeptr */ fake_array_seg bit(18), /* segment index of current array seg for making fakeptr */ segptr ptr, acinfo ptr, /* make tssi_ happy */ number_of_array_links fixed bin, system_tv_segno bit(18) init(baseno(addr(lisp_subr_tv_$tv_begin))), /* segment number of lisp_subr_tv_ */ system_tv_offset fixed bin(17) init(binary(rel(addr(lisp_subr_tv_$tv_begin)))), segment_size fixed bin(19), this_seg_is_static bit(1), retad label local, /* return address from pseudo subroutine copy */ code fixed bin(35), /* Multics status code */ bucketx fixed bin, /* index into gc'ed stuff in lisp_static_vars_ */ bucketno fixed bin, /* which garbage-collected slot in lisp_static_vars_ */ /* is being saved/restored; or else how many of these */ Size fixed bin, /* size in words of data to copy */ switch fixed bin, /* type of subr object being saved */ to_be_copied fixed bin, /* total number words to move, may split across segments */ words_left fixed bin, /* number words left in segment currently moving into */ stack ptr init(null), /* -> our private stack used for recursion */ bit_length fixed bin(24), /* dummy argument for hcs_ calls */ defptr ptr, string_ptr ptr, list_of_iochans ptr, /* list of all iochans that have been saved */ list_of_subr_blocks ptr, /* list of all new-type subr blocks that have been saved */ file_control_ptr ptr; dcl new_format bit(1), /* 1 => saved_env structure, 0 => save_header structure */ atomic_constants_addr ptr, atomic_constants_count fixed bin(18), rest_of_gc_area_addr ptr, rest_of_gc_area_count fixed bin(18), first_seg_ptr ptr; dcl amount_of_gensym_data fixed bin, amount_of_maknum_data fixed bin, (array_data_size, dope_vector_size) fixed bin(18), must_convert_arrays bit(1), i fixed bin; /* B A S E D O V E R L A Y S */ dcl 1 curptr_ovly based(addr(curptr)) aligned, 2 filler bit(21)unaligned, 2 curptr_type bit(9) unaligned, /* */ 2 pad bit(23) unaligned, 2 curptr_odd bit(1) unaligned, /* */ 2 rest_of_curptr bit(18) unaligned, 1 fakeptr_ovly based(addr(fakeptr))aligned, 2 filler bit(21) unaligned, 2 fakeptr_type bit(9) unaligned, /* */ 2 pad bit(42) unaligned, Array_Data fixed bin(71) aligned based, /* just data */ temp (1000) fixed bin(71) aligned based, /* (like lisp_stack_fmt.incl.pl1) */ bit18unal bit(18) unaligned based, copy_mask (Size) based aligned bit(36), /* (mask?) used to copy_words */ transfer_location ptr based; /* used to save local label retad on stack */ /* O L D S A V E F I L E H E A D E R */ dcl 1 save_header based aligned, /* goes at word 0 of component 0 of msf */ 2 num_gc_ptrs fixed bin(17) unaligned, /* amount of cruft before first seg - from lisp_static_vars_ */ 2 seg_count fixed bin(17) unaligned, /* number of segments represented. /= number msf components */ 2 seg_size fixed bin, /* Size of saved segments */ 2 iochan_list ptr, /* list of saved iochans, here because not in the gc'able part of lisp_static_vars_ that is saved */ 2 next_dbl_word fixed bin(71); /* first free location after this structure */ /* N E W S A V E F I L E H E A D E R */ dcl 1 saved_env aligned based, 2 flag fixed bin(17) unaligned, /* -1 => this format */ 2 seg_count fixed bin(17) unaligned, /* number of segments represented. /= number of msf components */ 2 seg_size fixed bin, /* Size of saved segments */ 2 version_number fixed bin, /* 3 for this declaration */ 2 iochan_list ptr, /* pseudo ptr for list of all iochans */ 2 subr_block_list ptr, /* pseudo ptr for list of all new type subr blocks */ 2 offset_to_first_seg fixed bin(18), /* offset in first msf component of start of first saved segment */ 2 atomic_constants, /* saved lisp_static_vars_ atoms */ 3 offset fixed bin(18), /* offset in first msf component */ 3 length fixed bin(18), /* number of saved items */ 2 rest_of_gc_area, /* similar stuff for other part of lisp_static_vars_ that is saved */ 3 offset fixed bin(18), 3 length fixed bin(18), 2 gensym_data (amount_of_gensym_data) bit(36) aligned, /* either 0 words (v=1) or 2 words (v>_2) */ 2 maknum_data (amount_of_maknum_data) bit(36) aligned, /* either 0 words (v<_2) or 5 words (v > 2) */ 2 seg_type (0 refer (saved_env.seg_count)) bit(1) unaligned; /* table of segment types, 1 = static, 0 = lists */ /* S E G M E N T H E A D E R */ dcl 1 segment based aligned, /* appears before each segment represented in save msf */ 2 chain bit(18) unaligned, /* root of its-pair chain requiring fixing up */ 2 seg_type bit(18) unaligned, /* ""b = lists, "1"b = array = static */ 2 seg_chain bit(18) unaligned, /* segno of next seg in list of such */ 2 seg_size bit(18) unaligned; /* number of words (always even) that were saved in the msf */ /* S T A T I C S E G K L U D G E */ dcl 1 static_seg_kludge aligned based, /* header of saved static seg */ 2 link_block_chain_ptr ptr, /* overlaid by segment header */ 2 def_sect_ptr ptr, 2 saved_list_of_subr_blocks ptr, /* hidey-hole for list of comp subr blocks (Kludgey!!) */ 2 virgin_link_ptr ptr, 2 zeroes bit(72); /* S T A T I C S E G T E M P L A T E */ dcl 1 static_seg_template aligned static, /* initialization for static seg header */ 2 chain_pointer ptr init(null), 2 def_pointer ptr init(null), 2 thread_pointer ptr init(null), 2 virgin_link_pointer ptr init(null), 2 zeroes bit(72) init(""b); dcl 1 static_seg_header aligned based like static_seg_template; /* F O R M A T O F E N T R Y P O I N T I N S U B R B L O C K */ dcl 1 subr based aligned, 2 nargs fixed bin(17) unaligned, 2 infop fixed bin(17) unaligned, 2 entry_inst(3) bit(36) aligned, 2 stat_size fixed bin(17) unal, /* for type 3 subrs, static block Size */ 2 rest_of_word bit(18) unal, 2 gcmark bit(18) aligned; /* marker used by garbage collector for type 3 subrs */ /* F O R M A T O F A R R A Y S */ %include lisp_array_fmt; /* F O R M A T O F L I N K S */ dcl 1 acc based aligned, 2 len fixed bin(8) unaligned, /* "acc string" */ 2 string char(262144) unaligned, 1 link_info based aligned, 2 header_ptr fixed bin(17) unaligned, /* standard ft2 pair */ 2 ft2 fixed bin(17) unaligned, 2 def_offset bit(18) unaligned, 2 rest fixed bin(17) unaligned, 2 type_pair_ptr bit(18) unal, 2 exp_val bit(18) unal, 2 class bit(18) unal, 2 trap_off bit(18) unal, 2 seg_nam_ptr bit(18) unaligned, 2 ent_nam_ptr bit(18) unaligned; /* F O R M A T O F O U R R E C U R S I O N S T A C K */ dcl 1 stack_entry based(stack) aligned, 2 object fixed bin(71) aligned, 2 return ptr, /* saved copy of retad */ 1 array_save based(stack) aligned, 2 address ptr, 2 Size fixed bin, 2 pad fixed bin, 2 return_addr ptr; dcl 1 array_link_save based(stack) aligned, 2 save_temp_ptr pointer unaligned, 2 save_temp_ptr_1 pointer unaligned, 2 save_fakeptr fixed bin(71), 2 save_newptr fixed bin(71), 2 save_return unaligned pointer, 2 number_of_links_left fixed bin; /* E X T E R N A L S T A T I C */ dcl lisp_standard_environment_$ ext fixed bin, /* the default environment for unsave */ lisp_static_vars_$saved_environment_dir ext char(168), lisp_static_vars_$no_snapped_links bit(1) external aligned, lisp_static_vars_$maknum_data (5) bit(36) aligned ext, lisp_subr_tv_$tv_begin ext bit(36) aligned, lisp_static_vars_$number_gc_ptrs ext fixed bin(17) aligned, /* number of cells to save in lisp_static_vars_ */ lisp_static_vars_$number_of_atomic_constants ext fixed bin(17) aligned, lisp_static_vars_$garbage_collected_ptrs ext fixed bin(71) aligned, /* first cell to be saved */ lisp_static_vars_$garbage_collect_inhibit ext bit(36) aligned, lisp_static_vars_$subr_block_list external pointer, lisp_static_vars_$ignore_faults bit(1) aligned external; /* M A N I F E S T C O N S T A N T S */ dcl already_copied fixed bin(71) static init(-1) aligned, subr_size (-2:3) fixed bin static init(4,0,2,6,4,6), /* Size of blocks in subrs */ unsnapped_array_link_instruction bit(36) static init("001000000001010110010111010001010000"b); /* E X T E R N A L E N T R I E S C A L L E D */ dcl lisp_alloc_$init_alloc entry(ptr,fixed bin,ptr,fixed bin), cu_$cl entry, lisp_save_alm_ entry(pointer, pointer), /* fast chain chaser written in alm */ lisp_get_atom_ entry(char(*), fixed bin(71)), (lisp_io_control_$set_for_save, lisp_io_control_$empty_all_buffers) entry, lisp_garbage_collector_ entry, lisp_alloc_$rehash_maknum entry, lisp_garbage_collector_$set_gc_params entry, lisp_segment_manager_$get_lists entry(ptr), lisp_segment_manager_$free_lists entry(ptr), lisp_segment_manager_$get_array entry(ptr), lisp_segment_manager_$free_array entry(ptr), expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)), pathname_ entry (char(*), char(*)) returns(char(168)), com_err_ entry options(variable), msf_manager_$open entry (char (*), char(*), ptr, fixed bin(35)), hcs_$get_link_target entry (char(*), char(*), char(*), char(*), fixed bin(35)), msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35)), msf_manager_$close entry (ptr), hcs_$get_max_length_seg entry(pointer, fixed bin(19), fixed bin(35)), tssi_$get_file entry (char (*), char (*), ptr, ptr, ptr, fixed bin(35)), tssi_$finish_file entry (ptr, fixed bin, fixed bin(24), bit(36) aligned, ptr, fixed bin(35)); /* B U I L T I N */ dcl (addr,addrel,baseno,baseptr,binary,bit,divide,fixed,min,mod,null,size,ptr,rel,unspec,substr,string) builtin; %include lisp_stack_seg; %include lisp_bignum_fmt; %include lisp_free_storage; %include lisp_iochan; %include lisp_subr_fmt; %include lisp_string_fmt; %include lisp_cons_fmt; %include lisp_ptr_fmt; %include lisp_comp_subr_block; %include lisp_atom_fmt; %include lisp_common_vars; %include lisp_maknum_table; /* /* entry to save the current lisp environment at path specified by arg */ call expand_pathname_$add_suffix (arg, "sv.lisp", dir, ent, code); if code ^= 0 then go to crump; call tssi_$get_file(dir,ent,segptr,acinfo,file_control_ptr,code); /* get segment for result */ if code ^= 0 then go to crump; call hcs_$get_max_length_seg(segptr, segment_size, code); if code ^= 0 then go to crump; lisp_static_vars_$ignore_faults = "1"b; /* can't user interrupt, since we're going to destroy the env. */ call lisp_io_control_$empty_all_buffers; /* set up the I/O system for saving */ call lisp_io_control_$set_for_save; list_of_iochans = null; list_of_subr_blocks = null; stack = ptr(stack_ptr,0); bucketno = lisp_static_vars_$number_gc_ptrs; /* numbeer of things saved */ /* generate header for save file */ segptr -> saved_env.flag = -1; /* flag that this is new format */ segptr -> saved_env.version_number = 3; amount_of_maknum_data = 5; amount_of_gensym_data = 2; segptr -> saved_env.gensym_data(*) = ptr(unmkd_ptr, ""b) -> stack_seg.gensym_data(*); segptr -> saved_env.atomic_constants.length = lisp_static_vars_$number_of_atomic_constants + 1; /* allow for obarray */ segptr -> saved_env.atomic_constants.offset = fixed(rel(addr(segptr -> saved_env.seg_type(300))), 18); /* ?? */ if mod(segptr -> saved_env.atomic_constants.offset, 2) ^= 0 then segptr -> saved_env.atomic_constants.offset = segptr -> saved_env.atomic_constants.offset + 1; segptr -> saved_env.rest_of_gc_area.offset = segptr -> saved_env.atomic_constants.offset + 2 * segptr -> saved_env.atomic_constants.length; segptr -> saved_env.rest_of_gc_area.length = lisp_static_vars_$number_gc_ptrs - segptr -> saved_env.atomic_constants.length; segptr -> saved_env.offset_to_first_seg = segptr -> saved_env.rest_of_gc_area.offset + 2 * segptr -> saved_env.rest_of_gc_area.length; temp_ptr_0 = addr(lisp_static_vars_$garbage_collected_ptrs); newsegptr = addrel(segptr, segptr -> saved_env.atomic_constants.offset); words_left = segment_size - segptr -> saved_env.atomic_constants.offset; do while(bucketno > 0); bucketno = bucketno - 1; curptr = temp_ptr_0 -> Array_Data; /* next ptr */ retad = main_loop; go to copy; main_loop: newsegptr->Array_Data = curptr; newsegptr = addrel(newsegptr,2); words_left = words_left - 2; temp_ptr_0 = addrel(temp_ptr_0,2); end; if lisp_static_vars_$maknum_mask = -1 then go to stash_maknum_data; lisp_static_vars_$maknum_left = 0; do bucketno = lbound(maknum_table,1) to hbound(maknum_table,1); if string(maknum_table(bucketno).first) then if maknum_table(bucketno).first.type & Numeric then lisp_static_vars_$maknum_left = lisp_static_vars_$maknum_left+1; else do; curptrp = maknum_table_ptrs(bucketno).second; curptr_type = maknum_table(bucketno).first.type; retad = mak_loop; go to copy; mak_loop: maknum_table_ptrs(bucketno).second = curptrp; lisp_static_vars_$maknum_left = lisp_static_vars_$maknum_left+1; end; end; Size = size(maknum_table); call allocate; newptrp -> maknum_table(*) = maknum_table(*); lisp_static_vars_$maknum_table_ptr = addr(fakeptr) ->curptrp; /* fake up table ptr */ stash_maknum_data: segptr -> saved_env.maknum_data(*) = lisp_static_vars_$maknum_data(*); go to done; /* /* pseudo subroutine to do copying of lisp objects. It is recursive, so that arbitrary structures may be copied. recursion is implemented by using the push down stack segment. Note that a destructive copy is made, so lisp must be re-entered to get the resulting environment back */ copy: if curptr = 0 then go to retad; if curptr_type & Numeric then go to retad; /* if simple object (resides in pointer) then just return */ if curptr_type & String then go to copy_string; /* if string the go to string copy routine */ if curptr_odd /* if odd address, fix to even address...snapped link */ then do; curptr_odd = "0"b; /* make address even */ stack -> return = addr(retad) -> transfer_location; stack -> object = 0; /* just fill it in (?) */ stack = addrel(stack,4); retad = odd_address; end; if curptrp -> cons.car = already_copied then do; /* if atomic symbol or cons has been copied, then just return new address, stored in cdr */ curptr = curptrp -> cons.cdr; go to retad; end; if curptr_type & Bigfix then go to copy_bigfix; if curptr_type & File then go to copy_file; if curptr_type & Array then go to copy_array; if curptr_type & Subr then go to copy_subr; /* if subr then go to subr copy routine */ if curptr_type & Atsym then go to copy_atsym; /* if atomic symbol then go to routine to copy it */ /* do cons pointers */ Size = 4; call allocate; newptrp -> cons = curptrp -> cons; /* copy contents */ curptrp -> cons.car = already_copied; curptrp -> cons.cdr = fakeptr; copy_file_like_cons: stack -> return = addr(retad) -> transfer_location; stack -> object = newptr; common_collector: curptr = newptrp -> cons.car; newptrp -> cons.car = fakeptr; stack = addrel(stack,4); retad = cdr_next; go to copy; cdr_next: stack = addrel(stack,-4); newptr = stack -> object; fakeptr = newptrp -> cons.car; newptrp -> cons.car = curptr; if curptr_type & Numeric then go to do_cdr; addr(newptrp ->cons.car)-> lisp_ptr.chain = ptr(newptrp,0)-> segment.chain; ptr(newptrp,0)-> segment.chain = rel(addr(newptrp ->cons.car)); do_cdr: curptr = newptrp -> cons.cdr; newptrp -> cons.cdr = fakeptr; stack = addrel(stack,4); retad = cons_almost_done; goto copy; cons_almost_done: stack = addrel(stack,-4); newptr = stack -> object; fakeptr = newptrp-> cons.cdr; newptrp-> cons.cdr = curptr; if curptr_type & Numeric then go to cons_done; addr(newptrp->cons.cdr)-> lisp_ptr.chain = ptr(newptrp,0) -> segment.chain; ptr(newptrp,0) -> segment.chain = rel(addr(newptrp->cons.cdr)); cons_done: curptr = fakeptr; addr(retad) -> transfer_location = stack -> return; go to retad; /* routine to copy atomic symbol, and recursively copy its values */ copy_atsym: Size = divide(curptrp -> pnamel + 23,4,17,0); call allocate; newptrp-> copy_mask = curptrp -> copy_mask; fakeptr_type = Atsym; curptrp -> atom.value = already_copied; curptrp -> atom.plist = fakeptr; stack -> return = addr(retad) -> transfer_location; stack -> object = newptr; if newptrp -> atom_double_words.value = Undefined then go to do_cdr; go to common_collector; copy_string: /* copy a lisp format string */ Size = curptrp -> string_length; if Size < 0 then do; curptrp = curptrp -> copied_string.new_fake_address; curptr_type = String; go to retad; end; Size = divide(Size + 7,4,17,0); call allocate; newptrp-> copy_mask = curptrp -> copy_mask; curptrp -> string_length = -5050; /* mark as copied */ curptrp -> copied_string.new_fake_address = addr(fakeptr) -> based_ptr; dcl 1 copied_string based aligned, 2 paddup fixed bin, 2 new_fake_address ptr unaligned; curptr = fakeptr; curptr_type = String; goto retad; copy_bigfix: Size = divide(curptrp->lisp_bignum.prec+2,2,18,0)*2; call allocate; newptrp->copy_mask = curptrp->copy_mask; fakeptr_type = curptr_type; curptrp->cons.car = already_copied; curptrp->cons.cdr = fakeptr; curptr = fakeptr; go to retad; /* copy a subr value into static */ copy_subr: if curptr_type & System_Subr then do; addr(curptr)->lisp_ptr.segno = ""b; /* segno of 0 is relative to tv */ addr(curptr)->lisp_ptr.ringnum = ""b; /* unsave needs 0 ring fields */ addr(curptr)->lisp_ptr.offset = addr(curptr)->lisp_ptr.offset - system_tv_offset; go to retad; end; if curptrp -> subr_entries(1).rest_of_tsx0 = tsx0_ic then go to copy_comp_subr; switch = subr_size(curptrp->subr.infop); if curptrp->subr.infop = 3 then switch = switch + curptrp->subr.stat_size-2; defptr = addrel(curptrp,switch); /* get linker info address */ string_ptr = ptr(defptr,defptr->link_info.seg_nam_ptr); Size = divide(string_ptr->acc.len,4,17,0); string_ptr = ptr(defptr,defptr->link_info.ent_nam_ptr); Size = Size + divide(string_ptr->acc.len,4,17,0)+switch+7; /* get totoal Size fo subr block */ call allocate_static; newptrp->copy_mask = curptrp->copy_mask; fakeptr_type = curptr_type; /* get type info into symbolic pointer */ curptrp->cons.car = already_copied; curptrp->cons.cdr = fakeptr; /* save new location */ defptr = addrel(newptrp,switch); curptr = fakeptr; defptr->link_info.header_ptr = 2-binary(rel(defptr),18,0); defptr->link_info.ft2 = 100110b; defptr->link_info.def_offset = rel(addr(defptr->link_info.type_pair_ptr)); defptr->link_info.rest = 0; defptr -> link_info.type_pair_ptr = rel(addr(defptr->link_info.class)); defptr -> link_info.seg_nam_ptr = rel(addrel(defptr,5)); defptr -> link_info.ent_nam_ptr = rel(addrel(defptr,6+divide(addrel(defptr,5)->acc.len,4,17,0))); if newptrp->subr.infop ^= 3 then go to retad; /* return if no data to continue with */ newptrp -> subr.gcmark = "0"b; /* zero out word used by garbage collector */ stack -> array_save.Size = newptrp->subr.stat_size-2; stack -> array_save.return_addr = addr(retad)->transfer_location; stack -> array_save.address, defptr = addrel(newptrp,6); retad = array_loop; go to subr_join; copy_comp_subr: if curptrp -> subr_entries(1).head_offset = -1 /* means already copied */ then do; newptrp = ptr(baseptr(curptrp -> subr_entries(1).nargs), curptrp -> subr_entries(1).code_offset); addr(newptr) -> lisp_ptr_type = addr(newptr) -> lisp_ptr_type | Subr36; addr(newptr) -> lisp_ptr.ringnum = "000"b; curptr = newptr; go to retad; end; defptr = addrel(curptrp, curptrp -> subr_entries(1).head_offset-1); newptrp = addrel(defptr, defptr -> subr_block_head.subr_code_link_offset+6); newptrp -> lisp_subr_links(1).itp_base = "001"b; newptrp -> lisp_subr_links(1).itp_mod = "100001"b; newptrp -> lisp_subr_links(1).link_opr_tv_offset = "000000000001001000"b; newptrp -> lisp_subr_links(1).mbz = "0"b; newptrp -> lisp_subr_links(1).further_mod = "010000"b; newptrp -> lisp_subr_links(1).itp_info = "0"b; Size = defptr -> subr_block_head.subr_code_link_offset + divide(51+newptrp -> link_to_subr_code.name_length,4,35,0); newptrp = addrel(newptrp, -2); /* check for array links */ if newptrp -> array_link_count.must_be_zero = ""b then number_of_array_links = newptrp -> array_link_count.number_of_array_links; else number_of_array_links = -1; call allocate_static; newptrp -> copy_mask = defptr -> copy_mask; /* copy the "secret" bit used by (sstatus uuolinks) */ newptrp -> subr_block_head_overlay.no_links_are_snapped = defptr -> subr_block_head_overlay.no_links_are_snapped; /* thread into list of all the comp subr blocks in the world */ unspec (newptrp -> subr_block_head.next_compiled_block)= unspec (list_of_subr_blocks); if list_of_subr_blocks ^= null then do; addr(newptrp -> subr_block_head.next_compiled_block) -> lisp_ptr.chain = ptr(newptrp, 0) -> segment.chain; ptr(newptrp, 0) -> segment.chain = rel(addr(newptrp -> subr_block_head.next_compiled_block)); end; unspec(list_of_subr_blocks) = unspec(fakeptr); newptrp -> subr_block_head.gcmark = "0"b; addr(fakeptr) -> based_ptr = addr(addr(fakeptr)->based_ptr-> subr_block_head.constants(defptr->subr_block_head.gc_length+1)); temp_ptr = addr(defptr->subr_block_head.constants(defptr->subr_block_head.gc_length+1)); Size = divide(newptrp -> subr_block_head.subr_code_link_offset,2,35,0) - newptrp -> subr_block_head.gc_length -1; if number_of_array_links >= 0 then Size = Size - (2*number_of_array_links+1); do switch = 1 to Size; temp_ptr -> subr_entries(switch).nargs = substr(unspec(fakeptr),1,18); temp_ptr -> subr_entries(switch).code_offset = substr(unspec(fakeptr),37,18); temp_ptr -> subr_entries(switch).head_offset = -1; addr(fakeptr) -> based_ptr = addrel(addr(fakeptr) -> based_ptr, 2); end; unspec(fakeptr) = curptrp -> subr_entries(1).nargs || "000"b || Subr || "100011"b || curptrp -> subr_entries(1).code_offset; /* copy pointers in snapped array links */ if number_of_array_links >= 0 then do; temp_ptr = addrel(defptr, defptr -> subr_block_head.subr_code_link_offset+6-2-4*number_of_array_links); temp_ptr_1 = addrel(newptrp, defptr -> subr_block_head.subr_code_link_offset+6-2-4*number_of_array_links); stack -> array_link_save.save_newptr = newptr; stack -> array_link_save.save_fakeptr = fakeptr; stack -> array_link_save.save_return = addr(retad)->transfer_location; stack -> array_link_save.number_of_links_left = number_of_array_links; retad = array_link_loop; array_link_loop_0: stack -> array_link_save.number_of_links_left = stack -> array_link_save.number_of_links_left - 1; if stack -> array_link_save.number_of_links_left < 0 then go to array_link_loop_end; if temp_ptr -> array_links(1).instruction = unsnapped_array_link_instruction then do; temp_ptr = addrel(temp_ptr, 4); /* don't copy pointer since not set */ go to copy_unsnapped_array_link; end; curptrp = temp_ptr -> array_links(1).pointer; unspec(curptrp) = unspec(curptrp) | Array36 | Subr36; temp_ptr = addrel(temp_ptr, 4); stack -> array_link_save.save_temp_ptr = temp_ptr; stack -> array_link_save.save_temp_ptr_1 = temp_ptr_1; stack = addrel(stack, size(array_link_save)); go to copy; array_link_loop: stack = addrel(stack, -size(array_link_save)); temp_ptr = stack -> array_link_save.save_temp_ptr; temp_ptr_1 = stack -> array_link_save.save_temp_ptr_1; addr(fakeptr) -> lisp_ptr.chain = ptr(temp_ptr_1, 0) -> segment.chain; ptr(temp_ptr_1, 0) -> segment.chain = rel(addr(temp_ptr_1 -> array_links(1).pointer)); unspec(temp_ptr_1 -> array_links(1).pointer) = unspec(fakeptr); copy_unsnapped_array_link: temp_ptr_1 = addrel(temp_ptr_1, 4); go to array_link_loop_0; array_link_loop_end: newptr = stack -> array_link_save.save_newptr; fakeptr = stack -> array_link_save.save_fakeptr; addr(retad)->transfer_location = stack -> array_link_save.save_return; end; stack -> array_save.Size = 2* newptrp -> subr_block_head.gc_length; stack -> array_save.return_addr = addr(retad) -> transfer_location; stack -> array_save.address, defptr = addr(newptrp -> subr_block_head.constants(1)); retad = array_loop; go to subr_join; copy_file: /* copy an iochan. Has to recurse for the two garbage-collectable components function and namelist, and for the thread of all iochans */ if curptrp -> iochan.gc_mark then do; /* already been copied, ioptr -> the copy */ curptrp = curptrp -> iochan.ioptr; curptr_type = File; go to retad; end; Size = size(iochan); call allocate_static; /* make a copy of this iochan in save seg */ newptrp -> copy_mask = curptrp -> copy_mask; fakeptr_type = File; curptrp -> iochan.gc_mark = "1"b; unspec(curptrp -> iochan.ioptr) = unspec(fakeptr); /* maintain a new threaded list of iochans - in list_of_iochans this will replace lisp_static_vars_$iochan_list */ unspec (newptrp -> iochan.thread) = unspec (list_of_iochans); if list_of_iochans ^= null then do; addr(newptrp -> iochan.thread)->lisp_ptr.chain = ptr(newptrp, 0) -> segment.chain; ptr(newptrp, 0) -> segment.chain = rel(addr(newptrp -> iochan.thread)); end; unspec(list_of_iochans) = unspec(fakeptr); /* keep ring number in this pointer zero for unsave */ /* now collect the function and namelist as if they were a cons */ newptrp = addr(newptrp -> iochan.function); go to copy_file_like_cons; copy_array: /* copy a lisp array */ /* compute number of words in array */ if curptrp -> array_info.type < Fixnum_array then Size = 2; else if curptrp -> array_info.type < Obarray_array then Size = 1; else if curptrp -> array_info.type = Obarray_array then Size = 2; else go to copy_dead_array; if curptrp -> array_info.minus_2_times_ndims = 0 /* external array */ then do; curptrp -> array_info.array_data_ptr = null; /* won't work in new process probably */ go to copy_dead_array; end; defptr = curptrp -> array_info.array_data_ptr; do i = -(curptrp -> array_info.ndims) repeat (i+1) while (i < 0); Size = Size * defptr -> array_data.dope_vector(i+1).bounds; end; /* compute amount of garbage-collectable stuff */ if curptrp -> array_info.type < Fixnum_array then array_data_size = Size; else if curptrp -> array_info.type = Obarray_array then array_data_size = Size; else if curptrp -> array_info.type = Readtable_array then array_data_size = 18; else array_data_size = 0; /* numeric array */ dope_vector_size = 2*(curptrp -> array_info.ndims); Size = Size + dope_vector_size; /* allow for dope vector */ call allocate; newptrp->copy_mask = addrel(defptr, -dope_vector_size)->copy_mask; fakeptr2 = fakeptr + 262144*dope_vector_size; /* addrel fakeptr, -> array_data.data */ newptr2 = addrel(newptrp, dope_vector_size); Size = 8; /* create array_info */ call allocate_static; newptrp -> copy_mask = curptrp -> copy_mask; fakeptr_type = curptr_type; unspec(newptrp -> array_info.array_data_ptr) = unspec(fakeptr2); string_ptr = ptr(newptrp, 0); /* put on list of fakeptr's */ addr(newptrp -> array_info.array_data_ptr)-> lisp_ptr.chain = string_ptr -> segment.chain; string_ptr -> segment.chain = rel(addr(newptrp -> array_info.array_data_ptr)); newptrp -> array_info.gc_mark = (18)"0"b; /* zero out gc mark */ curptrp -> cons.car = already_copied; /* mark old object */ curptrp -> cons.cdr = fakeptr; /* and remember new loc */ stack -> array_save.Size = array_data_size; stack -> array_save.return_addr = addr(retad)->transfer_location; stack -> array_save.address, defptr = newptr2; /* data to be collected */ retad = array_loop; subr_join: do while(stack->array_save.Size > 0); curptr = defptr -> Array_Data; /* get next pointer */ if curptr = 0 then; else if curptr_type & Numeric then; else if addr(curptr)->lisp_ptr.itsmod ^= "100011"b then; else do; defptr -> Array_Data = fakeptr; /* save fakeptr */ stack = addrel(stack,6); go to copy; array_loop: stack = addrel(stack,-6); defptr = stack -> array_save.address; string_ptr = ptr(defptr,0); /* segment base ptr */ fakeptr = defptr -> Array_Data; /* restore fakeptr */ defptr -> Array_Data = curptr; /* store copied data */ addr(defptr -> Array_Data)->lisp_ptr.chain = string_ptr->segment.chain; string_ptr->segment.chain = rel(defptr); end; stack -> array_save.Size = stack ->array_save.Size - 2; stack -> array_save.address, defptr = addrel(defptr,2); end; addr(retad) -> transfer_location = stack -> array_save.return_addr; curptr = fakeptr; go to retad; copy_dead_array: Size = 8; call allocate_static; newptrp -> copy_mask = curptrp -> copy_mask; newptrp -> array_info.gc_mark = ""b; curptrp -> cons.car = already_copied; curptrp -> cons.cdr = fakeptr; curptr = fakeptr; go to retad; odd_address: /* fix up odd address pointer here --- array or subr link */ curptr_odd = "1"b; /* make it odd */ stack = addrel(stack,-4); /* pop stack */ addr(retad) -> transfer_location = stack -> return; go to retad; /* /* now to finish up, copy temporary segments into segments desired, compacting as you go, and clean up */ done: segptr -> saved_env.seg_count = segnumber; segptr -> saved_env.seg_size = segment_size; /* save the lists of iochans and new type (comp) subr blocks */ unspec (segptr -> saved_env.iochan_list) = unspec (list_of_iochans); unspec (segptr -> saved_env.subr_block_list) = unspec (list_of_subr_blocks); segnumber = 0; newsegptr = addrel(segptr, segptr -> saved_env.offset_to_first_seg); /* actually, should be pointing here right now anyway */ do while(first_save_seg ^= ""b); curptrp = baseptr(first_save_seg); first_save_seg = curptrp -> segment.seg_chain; curptrp -> segment.seg_chain = ""b; this_seg_is_static = curptrp -> segment.seg_type; to_be_copied = binary(curptrp -> segment.seg_size,18,0); copy_more: Size = min(to_be_copied,words_left); newsegptr-> copy_mask = curptrp -> copy_mask; words_left = words_left - Size; newsegptr = addrel(newsegptr,Size); to_be_copied = to_be_copied - Size; if to_be_copied > 0 | words_left = 0 then do; curptrp = addrel(curptrp,Size); segnumber = segnumber + 1; pm1: call msf_manager_$get_ptr (file_control_ptr, segnumber, "1"b, segptr, bit_length, code); if segptr = null then do; call com_err_(code, "lisp_save_", "Correct and type start."); call cu_$cl; go to pm1; end; words_left = segment_size; newsegptr = segptr; if to_be_copied > 0 then goto copy_more; end; if this_seg_is_static then call lisp_segment_manager_$free_array(curptrp); else call lisp_segment_manager_$free_lists(curptrp); end; call tssi_$finish_file(file_control_ptr, segnumber,binary(rel(newsegptr),18,0)*36,"1000"b,acinfo,code); return; crump: call com_err_(code,"lisp_save_","Can't save environment at ^a", pathname_ (dir, ent)); return; /* /* internal subroutine to allocate storage in temporary segments, and return "symbolc addresses" in fakeptr, as well as real addresses */ allocate: proc; /* allocate Size words, set newptr -> actual place allocated, fakeptr to fake pointer to that place which can be put in the saved environment */ dcl 1 allocation based aligned, 2 words(Size) bit(36), 2 dbl_word fixed bin(71); if free_allocptr = null then do; make_seg: segnumber = segnumber + 1; segptr -> saved_env.seg_type(segnumber) = "0"b; call lisp_segment_manager_$get_lists(free_allocptr); fake_lists_seg = bit(fixed(segnumber, 18), 18); if current_save_seg then do; temp_ptr = baseptr(current_save_seg); temp_ptr -> segment.seg_chain = baseno(free_allocptr); end; else first_save_seg = baseno(free_allocptr); current_save_seg = baseno(free_allocptr); free_allocptr -> segment.seg_chain = ""b; free_allocptr -> segment.seg_type = ""b; free_allocptr -> segment.chain = ""b; free_allocptr = addrel(free_allocptr,4); end; if binary(rel(free_allocptr),18,0) + Size > segment_size then go to make_seg; newptrp = free_allocptr; unspec(fakeptr) = fake_lists_seg || "000000000000100011"b || /* seg idx, its -- ring must be 0 for unsave */ rel(free_allocptr); free_allocptr = addr(free_allocptr -> allocation.dbl_word); ptr(free_allocptr,0) -> segment.seg_size = rel(free_allocptr); return; end; /* /* internal routine like "allocate", except that a temporary segment used for static is used for the allocation */ allocate_static: proc; dcl 1 allocation based aligned, 2 words(Size) bit(36), 2 dbl_word fixed bin(71); if stat_allocptr = null then do; make_seg: segnumber = segnumber + 1; segptr -> saved_env.seg_type(segnumber) = "1"b; call lisp_segment_manager_$get_array(stat_allocptr); fake_array_seg = bit(fixed(segnumber, 18), 18); if current_save_seg then do; temp_ptr = baseptr(current_save_seg); temp_ptr -> segment.seg_chain = baseno(stat_allocptr); end; else first_save_seg = baseno(stat_allocptr); current_save_seg = baseno(stat_allocptr); stat_allocptr -> static_seg_header = static_seg_template; stat_allocptr -> segment.seg_chain = ""b; stat_allocptr -> segment.seg_type = "1"b; stat_allocptr -> segment.chain = ""b; stat_allocptr = addrel(stat_allocptr, size(static_seg_header)+2); end; if binary(rel(stat_allocptr),18,0) + Size > segment_size then go to make_seg; newptrp = stat_allocptr; unspec(fakeptr) = fake_array_seg || "000000000000100011"b || /* seg idx, its, ring zero for unsave */ rel(stat_allocptr); stat_allocptr = addr(stat_allocptr -> allocation.dbl_word); ptr(stat_allocptr,0) -> segment.seg_size = rel(stat_allocptr); return; end; /* /* routine to unsave a lisp environment which has been saved by the above */ unsave: entry(arg,last_stat_seg,last_stat_off,error_code); dcl last_stat_seg ptr parameter, /* (output) used to tell make_lisp_subr_block_ about static segs */ last_stat_off fixed bin(18) parameter, /* (output) .. */ error_code fixed bin(35) parameter, /* (output) return code. non zero means couldn't unsave env. */ cur_ring bit(3) aligned, free_size fixed bin; error_code = 0; /* kludge to fill in validation level in pointer to current validation level */ segptr = addr(cur_ring); cur_ring = addr(segptr)->lisp_ptr.ringnum; bucketx = 0; /* assume no environment conversion will be necessary */ if arg = "" then do; segptr = addr(lisp_standard_environment_$); file_control_ptr = null(); /* remember we got this from special place */ ent = "lisp_standard_environment_"; end; else do; call expand_pathname_$add_suffix (arg, "sv.lisp", dir, ent, code); if code ^= 0 then go to crump_2; call msf_manager_$open (dir, ent, file_control_ptr, code); if code ^= 0 then go to crump_2; call msf_manager_$get_ptr (file_control_ptr, 0, "0"b, segptr, bit_length, code); if segptr = null then go to crump_2; call hcs_$get_link_target (dir, ent, lisp_static_vars_$saved_environment_dir, (32)" ", code); if code ^= 0 then go to crump_2; end; segnumber = segptr -> save_header.seg_count; /* works whether old or new format because first part of structure is the same */ segment_size = binary(segptr -> save_header.seg_size,18,0); bucketno = segptr -> save_header.num_gc_ptrs; /* lisp_static_vars_$number_gc_ptrs at time saved */ if bucketno >= 0 then do; /* old format */ new_format = "0"b; if bucketno ^= lisp_static_vars_$number_gc_ptrs then do; /* Barf! */ call com_err_(0, "lisp_save_", "^a is an old format saved environment. An attempt at conversion will be made.", ent); if bucketno = 0 then do; call com_err_(0, "lisp_save_", "^a is too inconsistent to be converted. Resave it.", ent); error_code = 1; /* Kludge */ return; end; if bucketno > lisp_static_vars_$number_gc_ptrs then do; call com_err_(0, "lisp_save_", "^a cannot be converted.", ent); error_code = 1; /* kludge */ return; end; if bucketno < lisp_static_vars_$number_gc_ptrs then bucketx = bucketno+1; /* excess cruft will have to be filled */ end; atomic_constants_addr = addr(segptr -> save_header.next_dbl_word); atomic_constants_count = 104; rest_of_gc_area_addr = addrel(atomic_constants_addr, 208); rest_of_gc_area_count = bucketno - 104; first_seg_ptr = addrel(addr(segptr -> save_header.next_dbl_word), 2 * bucketno); lisp_static_vars_$maknum_mask = -1; end; /* end of old format stuff */ else do; /* new format save header */ new_format = "1"b; bucketx = 0; /* see about 10 lines before crump_2: */ if segptr -> saved_env.version_number = 1 then do; /* old-arrays version */ amount_of_gensym_data, amount_of_maknum_data = 0; must_convert_arrays = "1"b; lisp_static_vars_$maknum_mask = -1; end; else if segptr -> saved_env.version_number <= 3 then do; /* new-arrays version */ amount_of_gensym_data = 2; if segptr -> saved_env.version_number = 2 then do; lisp_static_vars_$maknum_mask = -1; amount_of_maknum_data = 0; end; else do; amount_of_maknum_data = 5; lisp_static_vars_$maknum_data(*) = segptr -> saved_env.maknum_data(*); end; must_convert_arrays = "0"b; ptr(unmkd_ptr, ""b) -> stack_seg.gensym_data(*) = segptr -> saved_env.gensym_data(*); end; else do; /* unreckognized version */ call com_err_(0, "lisp_save_", "^a is in unknown format #^d; resave it.", ent, segptr -> saved_env.version_number); error_code = 1; return; end; atomic_constants_addr = addrel(segptr, segptr -> saved_env.atomic_constants.offset); atomic_constants_count = segptr -> saved_env.atomic_constants.length; rest_of_gc_area_addr = addrel(segptr, segptr -> saved_env.rest_of_gc_area.offset); rest_of_gc_area_count = segptr -> saved_env.rest_of_gc_area.length; first_seg_ptr = addrel(segptr, segptr -> saved_env.offset_to_first_seg); end; /* check for minor differences between saved lisp_static_vars_ and current lisp_static_vars_ */ if (atomic_constants_count > lisp_static_vars_$number_of_atomic_constants + 1) | (rest_of_gc_area_count + atomic_constants_count > lisp_static_vars_$number_gc_ptrs) then call com_err_(0, "lisp_save_", "^a was saved with a newer lisp than you are using.^/If you encounter mysterious errors, try re-saving it.", pathname_ (dir, ent)); /* begin block to allocate space for segment number translation table */ table_alloc: begin; dcl segno_table(segnumber) ptr; dcl new_chain bit(18), (cur_stat,cur_free) ptr init(null), no_segs fixed bin init(0), seg_offset bit(18), i fixed bin, j fixed bin, next_offset fixed bin(18), newptr ptr, curptr ptr, counter fixed bin(18), switch fixed bin; /* get all needed segments */ j = 0; /* msf component number taking from */ newptr = first_seg_ptr; if new_format = "0"b then do i = 1 to segnumber; if newptr -> segment.seg_type then call lisp_segment_manager_$get_array(segno_table(i)); /* get right type of segment */ else call lisp_segment_manager_$get_lists(segno_table(i)); /* now make newptr point at the next segment */ next_offset = fixed(rel(newptr), 18) + fixed(newptr -> segment.seg_size, 18); if next_offset + 2 > segment_size then do; /* advance segs */ next_offset = next_offset - segment_size; /* Note: all segs must be multiple of */ j = j + 1; /* two words in length or this loses */ call msf_manager_$get_ptr(file_control_ptr, j, "0"b, newptr, bit_length, code); if newptr = null() then go to crump_2; end; newptr = ptr(newptr, next_offset); end; else do i = 1 to segnumber; if segptr -> saved_env.seg_type(i) then call lisp_segment_manager_$get_array(segno_table(i)); else call lisp_segment_manager_$get_lists(segno_table(i)); end; /* set lisp_static_vars_$iochan_list from save_header */ if new_format = "0"b then if segptr -> save_header.iochan_list = null () then lisp_static_vars_$iochan_list = null (); else lisp_static_vars_$iochan_list = ptr(segno_table( fixed(baseno(segptr -> save_header.iochan_list), 18)), rel(segptr -> save_header.iochan_list)); else do; if segptr -> saved_env.iochan_list = null () then lisp_static_vars_$iochan_list = null (); else lisp_static_vars_$iochan_list = ptr(segno_table(fixed(baseno(segptr -> saved_env.iochan_list), 18)), rel(segptr -> saved_env.iochan_list)); if segptr -> saved_env.subr_block_list = null () then lisp_static_vars_$subr_block_list = null (); else lisp_static_vars_$subr_block_list = ptr(segno_table(fixed(baseno(segptr -> saved_env.subr_block_list), 18)), rel(segptr -> saved_env.subr_block_list)); end; /* unsave atomic_constants portion of lisp_static_vars_ */ temp_ptr_1 = addr(lisp_static_vars_$garbage_collected_ptrs); newptr = atomic_constants_addr; do counter = min(lisp_static_vars_$number_of_atomic_constants+1, atomic_constants_count) by -1 while (counter > 0); call copy_1_datum; end; copy_1_datum: proc; /* moves one double-word and hacks the segment number */ temp_ptr_1 -> Array_Data = newptr -> Array_Data; newptr = addrel(newptr,2); if temp_ptr_1->lisp_ptr.type & Numeric then; else do; if temp_ptr_1->lisp_ptr.segno then temp_ptr_1->lisp_ptr.segno = baseno(segno_table(binary(temp_ptr_1->lisp_ptr.segno,18,0))); else do; temp_ptr_1->lisp_ptr.segno = system_tv_segno; temp_ptr_1->lisp_ptr.offset = temp_ptr_1->lisp_ptr.offset + system_tv_offset; end; temp_ptr_1 -> lisp_ptr.ringnum = cur_ring; /* for 6180 validation info */ end; temp_ptr_1 = addrel(temp_ptr_1,2); end copy_1_datum; /* fill in any excess atomic constants that were added to lisp_static_vars_ since this environment was saved. This has to be done here so temp_ptr_1 will maintain correct values */ do counter = atomic_constants_count by 1 while (counter <= lisp_static_vars_$number_of_atomic_constants); /* Note - there are two +_ bugs which cancel */ temp_ptr_1 -> Array_Data = lisp_static_vars_$t_atom; /* almost but not quite right. However a warning has been typed out */ temp_ptr_1 = addrel(temp_ptr_1, 2); end; /* unsave the other S-expression data in lisp_static_vars_ */ newptr = rest_of_gc_area_addr; do counter = min(lisp_static_vars_$number_gc_ptrs - lisp_static_vars_$number_of_atomic_constants - 1, rest_of_gc_area_count) by -1 while (counter > 0); call copy_1_datum; end; /* fill in any excess stuff in rest_of_gc_area that was added after this environment was saved */ do counter = rest_of_gc_area_count by 1 while(counter < lisp_static_vars_$number_gc_ptrs - lisp_static_vars_$number_of_atomic_constants - 1); temp_ptr_1 -> Array_Data = nil; /* see comment on previous reference to t_atom */ temp_ptr_1 = addrel(temp_ptr_1, 2); end; /* unsave the storage segments */ newptr = first_seg_ptr; do i = 1 to segnumber; curptr = segno_table(i); seg_offset = newptr -> segment.seg_size; to_be_copied = binary(seg_offset,18,0); copy_unsave: Size = min(to_be_copied,segment_size-binary(rel(newptr),18,0)); curptr -> copy_mask = newptr -> copy_mask; newptr = addrel(newptr,Size); to_be_copied = to_be_copied - Size; if to_be_copied > 0 then do; curptr = addrel(curptr,Size); no_segs = no_segs + 1; call msf_manager_$get_ptr(file_control_ptr, no_segs, "0"b, segptr, bit_length, code); if segptr = null() then go to crump_2; newptr = segptr; go to copy_unsave; end; /* get chain, and chase down it, fixing up the ITS pointers in the chain */ curptr = segno_table(i); new_chain = curptr -> segment.chain; if curptr -> segment.seg_type = ""b then do; curptr -> alloc_segment.next_seg = cur_free; cur_free = curptr; free_size = binary(seg_offset,18,0); end; else do; if cur_stat = null then curptr -> static_seg_header.chain_pointer = null; else curptr -> static_seg_header.chain_pointer = ptr(cur_stat,0); curptr -> static_seg_header.def_pointer = curptr; /* set definitions pointer for links */ cur_stat = ptr(curptr,seg_offset); end; /***** Following 13 lines commented out and replaced by call to alm routine /* do while(new_chain); /* curptr = ptr(curptr,new_chain); /* new_chain = curptr -> lisp_ptr.chain; /* if curptr -> lisp_ptr.segno /* check for offset in tv */ /* then curptr -> lisp_ptr.segno = baseno(segno_table(binary(curptr->lisp_ptr.segno,18,0))); /* else do; /* curptr -> lisp_ptr.segno = system_tv_segno; /* curptr -> lisp_ptr.offset = curptr -> lisp_ptr.offset + system_tv_offset; /* end; /* curptr -> lisp_ptr.ringnum = cur_ring; /* make sure validation of indirection /* is for current ring! */ /* curptr -> lisp_ptr.chain = "0"b; /* end; /***** End of commented out section *****/ call lisp_save_alm_(ptr(curptr, new_chain), addr(segno_table)); /* fix all its pairs in this seg */ end; /* inform allocation routines of new environment */ free_size = 4*divide(free_size+3,4,17,0); lisp_alloc_$cur_seg = cur_free; lisp_alloc_$consptr = addr(cur_free -> alloc_segment.tally_word); consptr_ovly.mod = "101011"b; cur_free -> alloc_segment.tally_word.seg_offset = bit(binary(free_size,18,0),18); cur_free -> alloc_segment.tally_word.tally = bit(binary(divide(mod(-1020-free_size,16384),4,18,0),12,0),12); cur_free -> alloc_segment.tally_word.delta = 4; lisp_alloc_$seg_blk_cntr = divide(free_size+1024,16384,17,0) - 16; call lisp_garbage_collector_$set_gc_params; last_stat_seg = ptr(cur_stat,0); last_stat_off = binary(rel(cur_stat),18,0); if new_format = "0"b then do; /* pick up list of all subr blocks out of header of last static seg */ lisp_static_vars_$subr_block_list = last_stat_seg -> static_seg_kludge.saved_list_of_subr_blocks; last_stat_seg -> static_seg_kludge.saved_list_of_subr_blocks = null; end; /* put maknum stuff in */ if lisp_static_vars_$maknum_mask ^= -1 then do; lisp_static_vars_$maknum_table_ptr = ptr(segno_table( fixed(baseno(lisp_static_vars_$maknum_table_ptr),18)), rel(lisp_static_vars_$maknum_table_ptr)); do counter = lbound(maknum_table,1) to hbound(maknum_table,1); if string(maknum_table(counter).first) then if maknum_table(counter).first.type &Numeric then; else maknum_table(counter).second.segno = fixed(baseno(segno_table( maknum_table(counter).second.segno)),18); end; lisp_static_vars_$garbage_collect_inhibit = "1"b; call lisp_alloc_$rehash_maknum; lisp_static_vars_$garbage_collect_inhibit = "0"b; end; if file_control_ptr ^= null() /* check to see if we used not standard environment */ then call msf_manager_$close(file_control_ptr); end table_alloc; /* clear no snapped links flag since we're not sure if we just unsaved some snapped links */ lisp_static_vars_$no_snapped_links = "0"b; /* code to fill in slots in lisp_static_vars_ that weren't unsaved into - only when converting old environment */ if bucketx ^= 0 then do; /* need to fill in end of lisp_static_vars_ */ call lisp_get_atom_("++inserted-due-to-conversion-from-old-format++", curptr); /* KLUDGE, */ curptrp -> atom.value = nil; /* but seems best way to avoid lossage */ do while (bucketx ^= lisp_static_vars_$number_gc_ptrs); addr(lisp_static_vars_$garbage_collected_ptrs) -> temp(bucketx) = curptr; end; end; /* if necessary, do a garbage collection to convert from old arrays to new arrays */ if must_convert_arrays then do; call com_err_(0, "lisp_save_", "Converting from old arrays to new arrays."); call lisp_garbage_collector_; end; return; crump_2: call com_err_(code,"lisp_save_","Can't reload environment from ^a",ent); error_code = code; end;  lisp_segment_manager_.pl1 05/31/88 1525.1rew 05/31/88 1500.0 162054 /****^ ************************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ /* format: style3,^ifthenstmt,indthenelse,^indnoniterdo,^indprocbody,dclind5,idind32,ll130 */ /****^ HISTORY COMMENTS: 1) change(73-11-03,DAM), approve(), audit(), install(): This module (lisp_segment_manager_) manages all temporary segments used by LISP. Completely rewritten. 2) change(80-01-18,JSpencerLove), approve(), audit(), install(): For changes in the PL/1 compiler. 3) change(88-04-06,RBarstad), approve(88-04-17,MCR7874), audit(88-05-31,GWMay), install(88-05-31,MR12.2-1050): Standardize set_list_temp_dir entry for SCP6377. END HISTORY COMMENTS */ %page; get_lists: proc (sptr); /* entry to get a seg of lists space */ type = ListsSeg; mode = RWA; /*** search for pre-existing segment of correct type */ unallocated_entry = -1; do segx = lbound (lists_table, 1) to hbound (lists_table, 1); if lists_table (segx).segno = ""b then if unallocated_entry < 0 then unallocated_entry = segx; else ; else /* segno ^= ""b */ if ^lists_table (segx).allocated then do; /*** found segment that can be reused */ lists_table (segx).allocated = "1"b; sptr = baseptr (lists_table (segx).segno); return; end; end; if unallocated_entry < 0 then call table_full; /*** create new segment */ segx = unallocated_entry; call create_new_segment; lists_table (segx).segno = segno; lists_table (segx).allocated = "1"b; return; %page; free_lists: entry (sptr); /* entry to dispose of a seg of lists space */ type = ListsSeg; segno = baseno (sptr); do segx = lbound (lists_table, 1) to hbound (lists_table, 1); if lists_table (segx).segno = segno then do; /* found it - free it */ call flush_seg; lists_table (segx).allocated = "0"b; return; end; end; /*** not found in table ?? */ call internal_error; %page; get_stack: entry (sptr); /* entry to allocate a seg for stack purposes. the max length is set so stack overflow can be detected before it's too late */ type = StackSeg; mode = RWA; /*** search for pre-existing segment of correct type */ unallocated_entry = -1; do segx = lbound (stack_table, 1) to hbound (stack_table, 1); if stack_table (segx).segno = ""b then if unallocated_entry < 0 then unallocated_entry = segx; else ; else /* segno ^= ""b */ if ^stack_table (segx).allocated then do; /*** found segment that can be reused */ stack_table (segx).allocated = "1"b; sptr = baseptr (stack_table (segx).segno); if stack_table (segx).single_bound ^= InitialStackSize then call set_initial_max_length; return; end; end; if unallocated_entry < 0 then call table_full; /*** create new segment */ segx = unallocated_entry; call create_new_segment; call set_initial_max_length; stack_table (segx).segno = segno; stack_table (segx).allocated = "1"b; return; set_initial_max_length: proc; call hcs_$set_max_length_seg (sptr, InitialStackSize, 0); stack_table (segx).single_bound = InitialStackSize; end; %page; free_stack: entry (sptr); /* entry to dispose of a stack seg */ type = StackSeg; segno = baseno (sptr); do segx = lbound (stack_table, 1) to hbound (stack_table, 1); if stack_table (segx).segno = segno then do; /* found it - free it */ call flush_seg; stack_table (segx).allocated = "0"b; return; end; end; /*** not found in table ?? */ call internal_error; %page; get_array: entry (sptr); /* entry to get a segment of array space */ type = ArraySeg; mode = REWA; /* arrays and subr blocks contain executable code and go in this seg */ /*** search for pre-existing segment of correct type */ unallocated_entry = -1; do segx = lbound (array_table, 1) to hbound (array_table, 1); if array_table (segx).segno = ""b then if unallocated_entry < 0 then unallocated_entry = segx; else ; else /* segno ^= ""b */ if ^array_table (segx).allocated then do; /*** found segment that can be reused */ array_table (segx).allocated = "1"b; sptr = baseptr (array_table (segx).segno); return; end; end; if unallocated_entry < 0 then call table_full; /*** create new segment */ segx = unallocated_entry; call create_new_segment; array_table (segx).segno = segno; array_table (segx).allocated = "1"b; return; %page; free_array: entry (sptr); /* entry to dispose of a segment of arrays space */ type = ArraySeg; segno = baseno (sptr); do segx = lbound (array_table, 1) to hbound (array_table, 1); if array_table (segx).segno = segno then do; /* found it - free it */ call flush_seg; array_table (segx).allocated = "0"b; return; end; end; /*** not found in table ?? */ call internal_error; %page; /* subroutines used by the above */ flush_seg: proc; call hcs_$truncate_seg (sptr, 0, 0); /* next guy who uses seg wants it to be all 0, plus save space in process directory */ end; create_new_segment: proc; dcl 1 ename_struc automatic unaligned structure, /* construct entry name here */ 2 lisp char (5) init ("lisp."), 2 stype char (5), /* filled in with user-specified type */ 2 dot char (1) init ("."), 2 unique char (15), /* "!BBBsdhasfwhatever" */ ename char (26) unaligned def (ename_struc) pos (1); ename_struc.stype = TypeString (type); ename_struc.unique = unique_chars_ (unique_bits_ ()); if lisp_temp_dir = "" then lisp_temp_dir = get_pdir_ (); /* initialization/bug in make_seg */ call hcs_$make_seg (lisp_temp_dir, ename, "", mode, sptr, code); if sptr = null then call cannot_make_seg; segno = baseno (sptr); sptr = baseptr (segno); /* Goddamn hardcore does not set ring number in pointer */ end; %page; /* error routines */ table_full: proc; call ioa_$ioa_switch (iox_$error_output, "^/Error: ^a segment table full in lisp_segment_manager_", TypeString (type)); go to fatal_loss; internal_error: entry; call ioa_$ioa_switch (iox_$error_output, "^/Error: internal inconsistency in ^a segment table found by lisp_segment_manager_", TypeString (type)); go to fatal_loss; cannot_make_seg: entry; dcl long_msg char (100) aligned, brief_msg char (8) aligned; call convert_status_code_ (code, brief_msg, long_msg); call ioa_$ioa_switch (iox_$error_output, "^/Error: ^a Trying to create lisp ^a segment in ^a.", long_msg, TypeString (type), lisp_temp_dir); go to fatal_loss; fatal_loss: call cu_$cl ("1"b); call ioa_$ioa_switch (iox_$error_output, "lisp_segment_manager_: start after fatal error not allowed. Try pi."); go to fatal_loss; end; %page; /* entries to set and get the maxlength of a stack seg */ get_stack_size: entry (st_ptr, st_size); dcl st_ptr pointer parameter, st_size fixed bin (18) parameter; call find_this_stack; st_size = stack_table (segx).single_bound; return; set_stack_size: entry (st_ptr, st_size); call find_this_stack; cursize = divide (st_size + 1023, 1024, 18, 0) * 1024; /* must be in pages */ if cursize > MaximumStackSize then go to cant_set_stack_size; stptr = st_ptr; call adjust_max_len; if code ^= 0 then cant_set_stack_size: st_size = stack_table (segx).single_bound; /* lost - tell caller */ return; find_this_stack: proc; segno = baseno (st_ptr); do segx = lbound (stack_table, 1) to hbound (stack_table, 1) while (stack_table (segx).segno ^= segno); end; if segx > hbound (stack_table, 1) then do; type = StackSeg; call internal_error; end; end find_this_stack; adjust_max_len: proc; /* set max len of stack(segx). stptr ->, to cursize */ dcl truncsize fixed bin (18); if baseno (stptr) = baseno (lisp_static_vars_$stack_ptr) then truncsize = fixed (rel (lisp_static_vars_$stack_ptr), 18); else if baseno (stptr) = baseno (lisp_static_vars_$unmkd_ptr) then truncsize = fixed (rel (lisp_static_vars_$unmkd_ptr), 18); else go to notrunc; /* ?? */ call hcs_$truncate_seg (stptr, truncsize, code); /* needed before can decrease the max length */ notrunc: call hcs_$set_max_length_seg (stptr, cursize, code); if code = 0 then stack_table (segx).single_bound = cursize; end adjust_max_len; %page; grow_stacks: entry (a_code); /* this entry is called when a stack overflows. an attempt is made to grow the stacks so that a user interrupt may be taken. if the attempt fails, a non-zero code will be returned. */ do stptr = lisp_static_vars_$stack_ptr, lisp_static_vars_$unmkd_ptr; segno = baseno (stptr); cursize = fixed (rel (stptr), 18); do segx = lbound (stack_table, 1) to hbound (stack_table, 1) while (stack_table (segx).segno ^= segno); end; if segx > hbound (stack_table, 1) then do; type = StackSeg; call internal_error; end; if cursize > stack_table (segx).single_bound - StackSizeIncrement then do; /* this stack needs to be grown */ cursize = stack_table (segx).single_bound + StackSizeIncrement; if cursize > MaximumStackSize then do; /* barf!! we don't want stacks this big */ a_code = error_table_$stack_overflow; return; end; call adjust_max_len; a_code = code; if code ^= 0 then return; /* you have lost */ /* prob. up to max size */ end; end; a_code = 0; /* apparently we won */ return; %page; shrink_stacks: entry; /* this entry is called after a stack overflow has been processed to put the stacks back to normal max length so that stack overflow can be detected again */ do stptr = lisp_static_vars_$stack_ptr, lisp_static_vars_$unmkd_ptr; segno = baseno (stptr); do segx = lbound (stack_table, 1) to hbound (stack_table, 1) while (stack_table (segx).segno ^= segno); end; if segx > hbound (stack_table, 1) then return; /* Oh, well. catch error later if really error */ cursize = fixed (rel (stptr), 18); do while (stack_table (segx).single_bound > InitialStackSize & stack_table (segx).single_bound - StackSizeIncrement >= cursize); stack_table (segx).single_bound = stack_table (segx).single_bound - StackSizeIncrement; end; cursize = stack_table (segx).single_bound; call adjust_max_len; end; return; %page; set_lisp_temp_dir: entry; /* command to change the directory in which lisp temp segs are created. does not move any temp segs that already exist */ dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl error_table_$bad_arg fixed bin (35) ext static; dcl arg_length fixed bin (21); dcl arg_count fixed bin; dcl arg char (arg_length) based (arg_ptr); dcl arg_ptr ptr; dcl arg_dir char (168); dcl arg_entry char (32); /**** dcl ioa_ entry() options(variable); for debug ****/ arg_length = 0; arg_count = 0; arg_ptr = null; arg_dir = ""; arg_entry = ""; code = 0; call cu_$arg_count (arg_count, code); if (code ^= 0) | (arg_count > 1) then goto sltd_usage_error; if arg_count = 0 /* default to process dir */ then lisp_temp_dir = get_pdir_ (); else do; /* arg_count must be 1 now */ call cu_$arg_ptr (1, arg_ptr, arg_length, code); if code ^= 0 then goto sltd_usage_error; if (arg = "-pd") | (arg = "-process_dir") then lisp_temp_dir = get_pdir_ (); else if (arg = "-wd") | (arg = "-working_dir") then lisp_temp_dir = get_wdir_ (); /**** else if (arg = "-pr") | (arg = "-print") then call ioa_ ("lisp_temp_dir = ""^a"".", lisp_temp_dir); for debug ****/ else if substr (arg, 1, 1) = "-" then do; code = error_table_$bad_arg; goto sltd_usage_error; end; else do; call expand_pathname_ (arg, arg_dir, arg_entry, code); if code ^= 0 then goto sltd_arg_error; lisp_temp_dir = pathname_ (arg_dir, arg_entry); end; end; goto set_lisp_temp_dir_exit; sltd_usage_error: call com_err_ (code, "set_lisp_temp_dir", "^/Usage: set_lisp_temp_dir {PATHNAME | -working_dir | -process_dir}"); goto set_lisp_temp_dir_exit; sltd_arg_error: call com_err_ (code, "set_lisp_temp_dir", "^a", arg); set_lisp_temp_dir_exit: ; return; %page; /* D E C L A R A T I O N S */ /* Parameters */ dcl sptr aligned pointer parameter, /* may be (input) seg to free, or (output) seg that is allocated */ a_code fixed bin (35) parameter; /* (output) if non-zero, grow_stacks did not succeed */ /* Automatic Variables */ dcl type fixed bin, /* type of segment - StackSeg, ListsSeg, or ArraySeg */ mode fixed bin (5), /* desired access mode (when creating a segment) */ unallocated_entry fixed bin, /* used to remember first free slot in table when searching for new seg */ segno bit (18), /* segment number of segment being gotten or freed */ code fixed bin (35), /* Multics status code */ segx fixed bin, /* index in a segment table */ stptr pointer, /* a stack pointer (in grow_stacks) */ cursize fixed bin (18); /* current (or next) size of segment */ /* External Static */ dcl lisp_static_vars_$stack_ptr external static pointer, lisp_static_vars_$unmkd_ptr external static pointer; dcl error_table_$stack_overflow fixed bin (35) external; /* Manifest Constants */ dcl ( ListsSeg fixed bin init (1), /* code for list-space segment */ ArraySeg fixed bin init (2), /* code for array/subr-block space segment */ StackSeg fixed bin init (3), /* code for stack segment */ TypeString (3) char (5) init (/* printable strings corresponding to above codes */ "lists", "array", "stack"), InitialStackSize fixed bin (18) init (51200), /* 50K - initial max length for stack segments - should be plenty */ StackSizeIncrement fixed bin (18) init (2048), /* two pages should be enough to handle a stack overflow user intr */ MaximumStackSize fixed bin (18) init (65536), /* stack segs limited to this size so can detect oob errors even with 256K segs we don't need that much and this helps to find bugs */ RWA fixed bin (5) init (01011b), /* access mode for stack and lists segments */ REWA fixed bin (5) init (01111b) /* access mode for array segments */ ) internal static; /* Builtin Functions */ dcl (baseno, baseptr, divide, fixed, hbound, lbound, null, rel, substr) builtin; /* External Entries Called */ dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned), hcs_$truncate_seg entry (pointer, fixed bin (18), fixed bin (35)), hcs_$set_max_length_seg entry (pointer, fixed bin (18), fixed bin (35)), ioa_$ioa_switch entry options (variable), iox_$error_output ext ptr, unique_bits_ entry () returns (bit (70)), unique_chars_ entry (bit (*)) returns (char (15)), cu_$cl entry (bit (1) aligned), get_pdir_ entry () returns (char (168)), get_wdir_ entry () returns (char (168)), com_err_ entry options (variable), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), pointer, fixed bin (35)); /* Internal Static Data -- segment tables */ dcl 1 lists_table (0:395) aligned static,/* Enough for 100,000 records of lists */ 2 segno bit (18) unaligned init ((396) (""b)), /* segment number */ 2 allocated bit (1) unaligned init ((396) ("0"b)); /* "1"b if someone is using the segment */ dcl 1 array_table (0:60) aligned static, /* Enough for 10,000 records of arrays */ 2 segno bit (18) unaligned init ((61) (""b)), /* segment number */ 2 allocated bit (1) unaligned init ((61) ("0"b)); /* "1"b if someone is using the segment */ dcl 1 stack_table (0:11) aligned static, /* Enough for six lisps */ 2 segno bit (18) unaligned init ((12) (""b)), /* segment number */ 2 allocated bit (1) unaligned init ((12) ("0"b)), /* "1"b if someone is using the segment */ 2 single_bound fixed bin (16, -2) unaligned; /* the current setting of the maximum length of this segment */ dcl lisp_temp_dir char (168) static init (""); /* pathname of directory in which to keep temp segs. needed since process directory quota is non-negotiable. */ end;  lisp_static_man_.pl1 07/06/83 0937.0r w 06/29/83 1542.5 27846 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1974 * * * ************************************************************** */ lisp_static_man_: procedure; /* This module manages static space for LISP. It replaces make_lisp_subr_block_ Written 74.05.14 by DAM */ dcl cur_stat_seg pointer defined lisp_static_vars_$cur_stat_seg, stat_top fixed bin(18) defined lisp_static_vars_$cur_stat_pos, lisp_static_vars_$cur_stat_seg external pointer, lisp_static_vars_$cur_stat_pos fixed bin(18) external; dcl space pointer, Size fixed bin(18); dcl sys_info$max_seg_size fixed bin(18) external; dcl 1 static_seg aligned based, 2 chain pointer, 2 def_ptr pointer; dcl lisp_segment_manager_$free_array entry(pointer); dcl (addr, addrel, null, rel, divide, unspec, substr, size) builtin; %include lisp_common_vars; %include lisp_ptr_fmt; /* Entry to free all the static segments (when LISP is exited) */ free_stat_segs: entry; do while(cur_stat_seg ^= null); space = cur_stat_seg; cur_stat_seg = space -> static_seg.chain; call lisp_segment_manager_$free_array(space); end; return; /* Entry to allocate a block of static storage. It was always be aligned on a double-word boundary */ allocate: entry(block_ptr, block_size); dcl block_ptr pointer parameter, /* (Output) -> allocated block */ block_size fixed bin(18) parameter; /* (Input) number of words required */ Size = block_size; if substr(unspec(Size), 36, 1) then Size = Size + 1; /* make sure is even number of words */ call alloc_static; block_ptr = space; return; /* Internal procedure to allocate by appending to static segment */ alloc_static: proc; dcl new_top fixed bin(18), lisp_segment_manager_$get_array entry(pointer), new_stat_seg pointer; dcl 1 static_seg_header_template aligned static structure, /* initial value for header of static segment */ 2 chain pointer init(null), 2 link_header, 3 def_ptr pointer init(null), /* must point to base of segment */ 3 thread pointer init(null), 3 virgin_link_pointer pointer init(null), 3 must_be_zero fixed bin(71) init(0), 1 static_seg_header aligned based structure like static_seg_header_template; new_top = stat_top + Size; if new_top <= sys_info$max_seg_size /* fits in current segment */ then do; space = addrel(cur_stat_seg, stat_top); stat_top = new_top; return; end; /* new segment required */ call lisp_segment_manager_$get_array(new_stat_seg); new_stat_seg -> static_seg_header = static_seg_header_template; new_stat_seg -> static_seg_header.chain = cur_stat_seg; new_stat_seg -> static_seg_header.def_ptr = new_stat_seg; cur_stat_seg = new_stat_seg; stat_top = size(static_seg_header); space = addrel(new_stat_seg, stat_top); stat_top = stat_top + Size; return; end alloc_static; end lisp_static_man_;  lisp_status_fns_.pl1 07/06/83 0937.0r w 06/29/83 1542.6 498564 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ status: proc; /* * lisp_status_fns_ contains the MACLISP functions status, sstatus, gctwa, *rset * D. A. Moon 29-JUN-72 * lsubr versions status_, sstatus_ for compiled code added 1/17/72 DAM * modified for new I/O system, and new status fns charmode and system, 24 Mar 73, DAM * added tabsize, crfile, ttyread, newreadtable 7 Apr 73 DAM * new function setsyntax added 17 May 1973 by dam * (status features) added 7/12/73 by DAM * status functions uuolinks, divov, abbreviate, and dow added 16 Oct 1973 by DAM, and * tty, *nopoint, *rset, nouuo, noret, chrct, linel, and rct removed. * at the same time it was converted to use 27 syntax bits instead of 18. * modified 74.02.18 by DAM to add (status newline), (status status), * (status sstatus), and (status feature) * modified 74.05.31 by DAM for new arrays, (sstatus feature), (sstatus nofeature), * (status linmode), and (sstatus uuolinks t) * modified 74.12.06 by DAM for cleanup feature * modified 1/5/78 by B. Greenberg for status/sstatus mulquit/mulpi */ dcl stack ptr, lispversion fixed bin static init(3), unm ptr, pnamep ptr, 1 lisp_reader_alm_$initial_readtable external aligned, 2 std_syntax(0:131) bit(27), 2 std_translation(0:131) fixed bin, myname fixed bin, rdr_save_f bit(1), char4 char(4) aligned, char4b char(4) aligned based, char4a char(4) aligned, based_fxb17 fixed bin (17) aligned based, LOWER_CASES char (26) options (constant) static init ("abcdefghijklmnopqrstuvwxyz"), UPPER_CASES char (26) options (constant) static init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), NullChar char(1) static init(""), /* \000 character */ i fixed bin, j fixed bin, ssf bit(1), /* sstatus if 1, status if 0 */ lsubf bit(1), /* 1 if lsubr entry, 0 if fsubr entry */ nargs fixed bin, /* -2 times number of arguments */ sw bit(1), /* random switch */ switch fixed bin, /* transfer vector switch */ m fixed bin(35), mm fixed bin, n fixed bin(35), fn float bin, lisp_static_vars_$no_snapped_links bit(1) external aligned, (lisp_static_vars_$first_value_atom, lisp_static_vars_$value_atom, lisp_static_vars_$divov_flag, lisp_static_vars_$old_io_defaults, lisp_static_vars_$last_value_atom) fixed bin(71) ext, lisp_static_vars_$semicolon_macro fixed bin(71) external, /* has (status features) as its value */ lisp_static_vars_$cleanup_list fixed bin(71) external, lisp_static_vars_$cleanup_list_exists bit(1) aligned external, lisp_static_vars_$evalhook_status bit(36) aligned external, lisp_$evalhook_off_status bit(36) aligned external, lisp_$evalhook_on_status bit(36) aligned external, lisp_static_vars_$crunit_atom fixed bin(71) external, lisp_static_vars_$uread_atom external pointer, lisp_static_vars_$uwrite_atom external pointer, uread fixed bin(71) based(addr(lisp_static_vars_$uread_atom -> atom.value)), uwrite fixed bin(71) based(addr(lisp_static_vars_$uwrite_atom -> atom.value)), mulquit_mulpi_value_ptr ptr, arg2pn char(1) aligned; /* status/sstatus names table - first 4 chars of pname of first arg */ dcl nnames fixed bin static init(51), names(51) char(4) aligned internal static init( "chtr", "ioc", /* padded with an ascii 000 character */ "macr", "synt", "topl", "urea", "uwri", "+", /* padded with three ascii 000 characters */ "date", "dayt", "runt", "time", "inte", "spcn", /* spcnames - used to be tty */ "crun", "()()", /* used to be *nopoint - was flushed */ "()()", /* used to be *rset - was flushed */ "gcti", "spcs", /* spcsize - used to be nouuo */ "pdls", /* pdlsize - used to be noret */ "pdlr", /* pdlroom - used to be chrct */ "pdlm", /* pdlmax - used to be linel */ "lisp", /* lispversion */ "pagi", "unam", "jcl", /* padded with \000 */ "arg", /* padded with \000.*/ "terp", "_", /* padded with 3 \\000's */ "()()", /* used to be (status rct) but we flushed that */ "syst", "char", "tabs", "crfi", "ttyr", "udir", "feat", "()()", /* used to be breakloop - was flushed */ "uuol", "divo", "abbr", "dow", /* padded with \000 */ "stat", "ssta", "newl", "nofe", /* nofeature */ "linm", /* linmode */ "clea", /* cleanup */ "eval", /* evalhook */ "mulq", /* mulquit */ "mulp" /* mulpi */ ), /* action control bits */ ( illeg init("10000"b), /* can't be done */ eval2 init("01000"b), /* eval 2nd arg */ pname2 init("00100"b), /* get 1st char of pname of 2nd arg */ eval3 init("00010"b), /* eval 3rd arg */ stoval init("00001"b), /* store into ssatoms(i) */ t_or_nil init("000001"b) /* if non-nil, store t */ ) bit(6) aligned static, ssbit bit(6) aligned, /* copy of an elem from one of the arrays below */ ssbits(51) bit(6) aligned static init( /* for sstatus */ "001100"b, /* chtran */ "000000"b, /* ioc */ "001100"b, /* macro */ "001100"b, /* syntax */ "010010"b, /* toplevel */ "000000"b, /* uread */ "000000"b, /* uwrite */ "010011"b, /* + */ "100000"b, /* date */ "100000"b, /* daytime */ "100000"b, /* runtime */ "100000"b, /* time */ "010100"b, /* interrupt */ "1"b, /* spcnames - can't change */ "000000"b, /* crunit */ "1"b, /* *nopoint - flushed */ "1"b, /* *rset - flushed */ "010000"b, /* gctime */ "1"b, /* spcsize - can't change */ "1"b, /* pdlsize - can't change */ "1"b, /* pdlroom - can't set */ "010100"b, /* pdlmax */ "100000"b, /* lispversion - can't change */ "100000"b, /* pagin - can' change */ "100000"b, /* uname - can't change */ "1"b, /* jcl- read only */ "1"b, /* arg- read only */ "010001"b, /* terpri */ "010001"b, /* _ */ "1"b, /* rct - flushed */ "1"b, /* system - can't sstatus */ "010101"b, /* charmode */ "1"b, /* tabsize - can't be changed */ "000000"b, /* crfile */ "010001"b, /* ttyread */ "1"b, /* udir */ "000000"b, /* feature */ "1"b, /* was breakloop - flushed */ "010001"b, /* uuolinks */ "010011"b, /* divov */ "010000"b, /* abbreviate */ "1"b, /* dow */ "1"b, /* status */ "1"b, /* sstatus */ "1"b, /* newline */ "000000"b, /* nofeature */ "1"b, /* linmode */ "010000"b, /* cleanup */ "010000"b, /* evalhook */ "010000"b, /* mulquit */ "010000"b /* mulpi */ ), sbits(51) bit(6) aligned static init( /* for status */ "001000"b, /* chtran */ "001000"b, /* ioc */ "001000"b, /* macro */ "001000"b, /* syntax */ "000010"b, /* toplevel */ "000000"b, /* uread */ "000000"b, /* uwrite */ "000010"b, /* + */ "000000"b, /* date */ "000000"b, /* daytime */ "000000"b, /* runtime */ "000000"b, /* time */ "010000"b, /* interrupt */ "000000"b, /* spcnames */ "000000"b, /* crunit */ "1"b, /* *nopoint - flushed */ "1"b, /* *rset - flushed */ "000000"b, /* gctime */ "010000"b, /* spcsize */ "010000"b, /* pdlsize */ "010000"b, /* pdlroom */ "010000"b, /* pdlmax */ "000000"b, /* lispversion */ "000000"b, /* paging -> (list pf pp) */ "000000"b, /* uname -> interned atom person/.proj */ "000000"b, /* jcl - explode of 2nd arg to lisp cmd */ "010000"b, /* arg - list of 2nd - nth args to lisp cmd */ "000000"b, /* terpri */ "000000"b, /* _ */ "1"b, /* rct - flushed */ "010000"b, /* system */ "010000"b, /* charmode */ "000000"b, /* tabsize */ "000000"b, /* crfile */ "000000"b, /* ttyread */ "000000"b, /* udir */ "000000"b, /* feature */ "1"b, /* was breakloop - flushed */ "000000"b, /* uuolinks */ "000010"b, /* divov */ "000000"b, /* abbreviate */ "000000"b, /* dow */ "000000"b, /* status */ "000000"b, /* sstatus */ "000000"b, /* newline */ "1"b, /* nofeature */ "000000"b, /* linmode */ "000010"b, /* cleanup */ "000000"b, /* evalhook */ "000000"b, /* mulquit */ "000000"b /* mulpi */ ), /* atoms whose values are to be mainpulated */ ssatoms (51) pointer static init((51)null), initss bit(1) static init("1"b); /* signal for prologue to be executed to init ssatoms */ dcl errcode(2) fixed bin aligned based; dcl (addr, addrel, bit, divide, fixed, float, hbound, lbound, length, max, min, null, substr, index, reverse, verify, unspec) builtin; /* entry points called */ dcl lisp_$eval ext entry, lisp_load_$unsnap_all_links entry, lisp_prelinker_ entry, lisp_fault_handler_$ioc entry, lisp_prog_fns_$lisp_err entry(bit(1)aligned), lisp_$apply entry, lisp_io_fns_$names entry, lisp_defsubr_$sysp entry, lisp_special_fns_$cons entry, lisp_get_atom_ ext entry(char(*) aligned, fixed bin(71) aligned), lisp_list_utils_$nreverse entry, lisp_special_fns_$xcons entry, cu_$arg_ptr_rel ext entry(fixed bin, ptr, fixed bin, fixed bin, ptr), argptr ptr, arglen fixed bin, arg_buffer char(200) aligned, /* lisp_get_atom_ wants to see an aligned string */ aligned_arg char(arglen) based(addr(arg_buffer)) aligned, arg char(arglen) based(argptr) unaligned, code fixed bin, lisp_error_ ext entry; /* declare things in lisp_static_vars_ */ dcl ( lisp_static_vars_$nouuo_flag, lisp_static_vars_$dsk_atom, lisp_static_vars_$noret_flag ) fixed bin(71) aligned external, ( lisp_static_vars_$mulquit_state, lisp_static_vars_$mulpi_state ) fixed bin (17) external, lisp_static_vars_$arg_list_ptr external pointer; dcl 1 pointr aligned based, /* special kludge to set indir modifier in ssatoms that are pointers to pointers to atoms, instead of pointers to internal status flags */ 2 segment bit(18) unal, 2 junk bit(12) unal, 2 its bit(6) unal, 2 offset bit(18) unal, 2 junk2 bit(12) unal, 2 mod bit(6) unal; /* This is the crucial one. */ %include lisp_common_vars; %include lisp_initial_atoms; %include lisp_io; %include lisp_stack_fmt; %include lisp_cons_fmt; %include lisp_ptr_fmt; %include lisp_error_codes; %include lisp_name_codes; %include lisp_array_fmt; %include lisp_readtable; %include lisp_nums; %include lisp_atom_fmt; %include lisp_string_fmt; /* status: entry; /* lisp status function */ ssf = "0"b; lsubf = "0"b; go to JOIN; sstatus: entry; /* lisp sstatus function */ ssf = "1"b; lsubf = "0"b; go to JOIN; status_: entry; /* lsubr version of status, for compiled code only since some of the error checking is omitted */ ssf = "0"b; lsubf = "1"b; go to JOIN; sstatus_: entry; /* lsubr version of sstatus, .. */ ssf = "1"b; lsubf = "1"b; go to JOIN; JOIN: if initss then do; /* do this prologue once only */ ssatoms(5) = addr(toplevel); ssatoms(8) = addr(plus_status); ssatoms(40) = addr(lisp_static_vars_$divov_flag); ssatoms(48) = addr(lisp_static_vars_$cleanup_list); /* More will be added later */ initss = "0"b; end; stack = addrel(stack_ptr, -2); stack_ptr = addr(stack -> temp(6)); if lsubf then do; /* initial set up for lsubr ves sion. First arg is number which is index in names table of first arg for fsubr version */ nargs = stack -> fixedb; /* get arg count */ argptr = stack; stack = addrel(stack, nargs); /* -> arguments */ check_j: j = stack -> fixedb; /* first arg tells which function to do */ if j >= 1 then if j < nnames+1 then go to j_ok; /* Check bounds, shouldn't make dangerous assumptions */ i = 1; call bad_arg; go to check_j; j_ok: stack_ptr = addr(stack -> temp(6)); do while (argptr ^= stack_ptr); /* nil out any arguments which were not supplied */ argptr -> temp(1) = nil; argptr = addr(argptr -> temp(2)); end; if ssf then ssbit = ssbits(j); else ssbit = sbits(j); if ssbit & pname2 then do; /* make sure second arg is in bounds */ l_retry_2: if stack -> temp_type36(2) & Fixed36 then; else go to l_loss_2; m = addr(stack -> temp(2)) -> fixedb; if m < 0 then go to l_loss_2; if m >= 132 then go to l_loss_2; end; /* WIN */ if ssf then if ssbit & eval3 then do; if j = 1 then do; /* special hack for sstatus chtran */ n = m; ssbit = ssbit & ^eval3; stack -> temp(2) = stack -> temp(3); go to l_retry_2; end; end; go to lsub_join; /* args are already in proper slots on stack */ l_loss_2: i = 2; call bad_arg; go to l_retry_2; end; retry: /* error checking */ call check_arg; stack -> temp(2) = stack -> temp(5); /* get first arg */ retry_1: if stack -> temp_type36(2) & Atsym36 then; else do; loss_1: i = 2; /* first arg is here */ call bad_arg; go to retry_1; end; /* look up first 4 letters of pname of first arg in table */ char4 = addr(stack -> temp_ptr(2) -> atom.pname) -> char4b; do j = 1 to nnames; if char4 = names(j) then go to got_it; end; go to loss_1; got_it: if ssf then ssbit = ssbits(j); else ssbit = sbits(j); /* different bits for status & sstatus */ if ssbit & illeg then go to loss_1; if ssbit & (eval2 | pname2) then; /* a 2nd arg is wanted */ else go to no_2nd_arg; /* 2nd arg not wanted -- don't check for it */ call check_arg; /* get 2nd arg in stack -> temp(5) */ if ssbit & eval2 then do; call lisp_$eval; stack -> temp(2) = stack -> temp(5); end; else if ssbit & pname2 then retry_2: if stack -> temp_type36(5) & Atsym36 then /* winner! */ m = fixed(unspec(substr(stack -> temp_ptr(5) -> atom.pname, 1, 1)), 9); else do; /* allow a number in place of a character */ call lisp_$eval; /* eval 2nd arg which is in stack -> temp(5) */ if stack -> temp_type36(5) & Fixed36 then do; /* number, check range */ m = addr(stack -> temp(5)) -> fixedb; if m >= 0 & m < 132 then go to ok2; end; i = 5; call bad_arg; go to retry_2; end; ok2: if ssf then if ssbit & eval3 then do; call check_arg; /* make sure there is a 3rd arg to be evaled */ if j = 1 then do; /* sstatus chtran, we want to allow a pname atom as 3rd arg too */ ssbit = ssbit & ^eval3; /* avoid loop */ n = m; /* save 2nd arg -- NB: ssaction(1) hence gets its args backwards */ go to retry_2; /* go process pname arg, go to ssaction(1) with it in m */ end; call lisp_$eval; stack -> temp(3) = stack -> temp(5); end; lsub_join: if ssbit & t_or_nil then if stack -> temp(2) ^= nil then stack -> temp(2) = t_atom; /* use only nil or t */ no_2nd_arg: if ssbit & stoval then do; if ssf then ssatoms(j) -> temp(1) = stack -> temp(2); /* set new value */ stack -> temp(1) = ssatoms(j) -> temp(1); /* return value of the atom or internal flag */ go to exit; end; if ssf then go to ssaction(j); /* perform special action */ else go to saction(j); /* useful internal procs */ check_arg: proc; /* make sure there is one more arg */ if stack -> temp(1) = nil then go to too_few; else if stack -> temp_type(1) then too_few: stack -> temp(5) = nil; /* If no arg given, use nil. */ else do; stack -> temp(5) = stack -> temp_ptr(1) -> cons.car; stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; end; end check_arg; verify_num: proc; re_verify_num: if stack -> temp_type36(i) & Fixed36 then do; n = addr(stack -> temp(i)) -> fixedb; return; end; else /* error - wrong type arg */; call ill_arg; go to re_verify_num; end; bad_arg: /* Called when a bad arg is detected. It signals a correctable error and tries to get a replacement arg that is better. i is the loc on the stack of the bad arg */ ill_arg: proc; /* call lisp_error_ to get a better arg */ if ssf then if lsubf then myname = fn_star_sstatus; else myname = fn_sstatus; else if lsubf then myname = fn_star_status; else myname = fn_status; ill_arg_nsm: entry; /* myname is already set */ unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = bad_arg_correctable; unm -> errcode(2) = myname; stack_ptr = addr(stack -> temp(7)); stack -> temp(6) = stack -> temp(i); call lisp_error_; stack -> temp(i) = stack -> temp(6); /* move corrected arg back */ stack_ptr = addr(stack -> temp(6)); end; rset: entry; /* the lisp *rset function, which just does a (sstatus *rset arg) */ stack = addrel(stack_ptr, -2); if stack -> temp(1) ^= nil then stack -> temp(1) = t_atom; addr(star_rset) -> based_ptr -> atom.value = stack -> temp(1); return; noret: entry; /* the lisp noret function which is the same as (sstatus noret arg) */ stack = addrel(stack_ptr, -2); if stack -> temp(1) ^= nil then stack -> temp(1) = t_atom; addr(lisp_static_vars_$noret_flag)->based_ptr -> atom.value = stack -> temp(1); return; /* special action routines */ ssaction(1): /* sstatus chtran m n */ sw = "0"b; i = m; /* args are interchanged, so put them back the way */ m = n; /* rdtbl wants them to be */ n = i; go to rdtbl1; ssaction(4): /* sstatus syntax m n */ sw = "1"b; rdtbl: i = 3; call verify_num; rdtbl1: call del_macro; /* remove any previous macro property */ if sw then syntax(m) = bit(fixed(n, 27), 27); else translation(m) = n; go to ret_fix; saction(1): /* status chtran m */ if syntax(m) & macro then n = m; else n = translation(m); go to ret_fix; saction(4): /* status syntax m */ n = fixed(syntax(m), 27); /* and fall into ret_fix */ ret_fix: stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = n; go to exit; del_macro: proc; /* removes the macro property of the character m */ dcl newsyntax bit(27); /* temp reg */ if syntax(m) & macro then do; newsyntax = std_syntax(m); /* set back to original syntax */ mm = translation(m); /* remember which macro it was */ if newsyntax & macro then do; newsyntax = extd_alpha | slash_output; /* unless that was a macro too */ translation(m) = m; end; else translation(m) = std_translation(m); /* initial chtran too */ syntax(m) = newsyntax; end; else return; /* if not a macro, easy to unmacro it */ if mm <= num_macs then do; /* easy kind */ macro_table(mm) = nil; end; else do; /* hard kind - have to take off list & fake out other macros */ stack -> temp(4) = more_macros; stack -> temp(5) = nil; do i = num_macs+1 to mm; /* scan down the more_macros list */ stack -> temp(5) = stack -> temp(4); stack -> temp(4) = stack -> temp_ptr(4) -> cons.cdr; end; if stack -> temp(5) = nil then more_macros = stack -> temp_ptr(4) -> cons.cdr; else stack -> temp_ptr(5) -> cons.cdr = stack -> temp_ptr(4) -> cons.cdr; /* now fudge all macros greater than mm to move down one */ do i = 0 to 131; if syntax(i) & macro then if translation(i) > mm then translation(i) = translation(i) - 1; end; end; end; /*** the setsyntax subr for munging the readtable ***/ setsyntax: entry; stack = addrel(stack_ptr, -6); /* 3 args */ myname = fn_setsyntax; /* first arg specifies character, put ascii code in m */ snx1a: if stack -> fixnum_fmt.type_info = fixnum_type then if stack -> fixedb >= 0 then if stack -> fixedb < 128 then m = stack -> fixedb; else go to snx1; else go to snx1; else if stack -> temp_type36(1) & String36 then m = fixed(unspec(substr(stack -> temp_ptr(1) -> lisp_string.string, 1, 1)), 9); else if stack -> temp_type36(1) & Atsym36 then m = fixed(unspec(substr(stack -> temp_ptr(1) -> atom.pname, 1, 1)), 9); else do; snx1: i = 1; call ill_arg_nsm; go to snx1a; end; /* in any case, get rid of m's previous macro property */ call del_macro; /* second arg is nil or syntax specifier, put syntax bits in n or -1 or jump away */ snx2a: if addr(stack -> temp(2))->fixnum_fmt.type_info = fixnum_type then n = addr(stack -> temp(2))->fixedb; else if stack -> temp(2) = nil then n = -1; /* meaning no-change */ else if stack -> temp_type36(2) & String36 then do; pnamep = stack -> temp_ptr(2); snx2jsa: if pnamep -> lisp_string.string_length < 2 then do; /* 1 or 0 - for the null pname - is a character */ n = fixed(unspec(substr(pnamep -> lisp_string.string, 1, 1)), 9); if n < 0 then go to snx2; if n >= 128 then go to snx2; n = fixed(std_syntax(n)); /* pick up original syntax for char */ end; else do; /* decode special names here */ char4 = addrel(pnamep, 1) -> char4b; /* pick up first word of pname */ if char4 = "sing" then n = 110000000101000000b; /* single char obj -- 600500 octal */ else if char4 = "macr" then go to snxmacro; else if char4 = "spli" then go to snxsplice; else go to snx2; end; end; else if stack -> temp_type36(2) & Atsym36 then do; pnamep = addr(stack -> temp_ptr(2) -> atom.pnamel); go to snx2jsa; /* common code with strings */ end; else do; snx2: i = 2; call ill_arg_nsm; go to snx2a; end; /* third arg specifies chtran, ascii code (or -1 for no change) is put in mm */ snx3a: if addr(stack -> temp(3))->fixnum_fmt.type_info = fixnum_type then if addr(stack -> temp(3))->fixedb >= 0 then if addr(stack -> temp(3))->fixedb < 128 then mm = addr(stack -> temp(3))->fixedb; else go to snx3; else go to snx3; else if stack -> temp_type36(3) & String36 then mm = fixed(unspec(substr(stack -> temp_ptr(3) -> lisp_string.string, 1, 1)), 9); else if stack -> temp(3) = nil then mm = -1; /* no-change */ else if stack -> temp_type36(3) & Atsym36 then mm = fixed(unspec(substr(stack -> temp_ptr(3) -> atom.pname, 1, 1)), 9); else do; snx3: i = 3; call ill_arg_nsm; go to snx3a; end; /* at last, we're ready to actually do it - char = m, syntax = n, chtran = mm */ if n >= 0 then syntax(m) = bit(fixed(n, 27), 27); /* pack fx into bs */ if mm >= 0 then translation(m) = mm; return_t: stack -> temp(1) = t_atom; go to exit; /* special versions of setsyntax for macros - entered by goto from arg 2 decode above */ snxmacro: if stack -> temp(3) = nil then go to return_t; /* macro property has already been deleted */ syntax(m) = special | macro | slash_output; stack_ptr = addr(stack -> temp(6)); /* compat with old sstatus macro form */ go to ssa3a; /* go join with (sstatus macro) code */ snxsplice: if stack -> temp(3) = nil then go to return_t; /* same comments as above */ syntax(m) = special | macro | slash_output | splice; stack_ptr = addr(stack -> temp(6)); go to ssa3a; ssaction(3): /* sstatus macro c (form) [splicing] */ sw = "0"b; call del_macro; /* if already was a macro, get rid of old macro property */ if stack -> temp(3) = nil then go to return_nil; /* (sstatus macro c nil) just removes macro prop. */ if lsubf then if stack -> temp(4) = nil then go to reg_mac; else go to splice_mac; else if stack -> temp_type(1) | stack -> temp(1) = nil then; else if stack -> temp_ptr(1) -> cons_types36.car & Atsym36 then if substr(stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pname, 1, 1) = "s" then do; splice_mac: syntax(m) = special | macro | slash_output | splice; go to ssa3a; end; reg_mac: syntax(m) = special | macro | slash_output; myname = fn_sstatus; /* because setsyntax joins here but has to return a different value. */ ssa3a: do i = 1 to num_macs; if macro_table(i) = nil then do; /* grab this free slot */ macro_table(i) = stack -> temp(3); translation(m) = i; go to ssa3b; end; end; /* LOSER -- have to append to more_macros list */ sw = "1"b; stack -> temp(4) = more_macros; stack -> temp(5) = nil; do i = num_macs+1 by 1 while (stack -> temp(4) ^= nil); stack -> temp(5) = stack -> temp(4); stack -> temp(4) = stack -> temp_ptr(4) -> cons.cdr; end; stack -> temp(4) = stack -> temp(3); /* cons up a list node */ stack -> temp(3) = stack -> temp(5); /* saving this */ stack -> temp(5) = nil; call lisp_special_fns_$cons; stack_ptr = addr(stack -> temp(6)); /* because cons has changed it */ if stack -> temp(3) = nil then more_macros = stack -> temp(4); else stack -> temp_ptr(3) -> cons.cdr = stack -> temp(4); translation(m) = i; ssa3b: if myname = fn_setsyntax then go to return_t; else go to saction3a; saction(3): /* status macro c - returns list of the function and nil or s */ /* find the macro */ if syntax(m) & macro then; else do; /* not a macro char., return nil */ return_nil: stack -> temp(1) = nil; go to exit; end; i = translation(m); if i < num_macs then sw = "0"b; else do; /* hard case, have to get it off the list */ sw = "1"b; stack -> temp(4) = more_macros; stack -> temp(5) = nil; do i = num_macs+1 to i; stack -> temp(5) = stack -> temp(4); stack -> temp(4) = stack -> temp_ptr(4) -> cons.cdr; end; end; saction3a: /* cons up a list of the form and s or nil */ if sw then stack -> temp(3) = stack -> temp_ptr(4) -> cons.car; else stack -> temp(3) = macro_table(i); stack -> temp(5) = nil; if syntax(m) & splice then stack -> temp(4) = s_atom; else stack -> temp(4) = nil; call lisp_special_fns_$cons; call lisp_special_fns_$cons; stack -> temp(1) = stack -> temp(3); go to exit; ssaction(6): /* (sstatus uread -args-) */ switch = 0; go to ss67com; ssaction(15): /* (sstatus crunit -args-) */ switch = 1; go to ss67com; ssaction(7): /* (sstatus uwrite -args- ) */ switch = 2; ss67com: /* just call uread or uwrite with the given args */ /* How clever, stack -> temp(1) is currently list of rest of args to sstatus */ stack_ptr = addr(stack -> temp(3)); stack -> temp(2) = stack -> temp(1); /* have to use apply since uread is now in lisp code */ go to ssio(switch); ssiojn: call lisp_$apply; return; ssio(0): stack -> temp_ptr(1) = lisp_static_vars_$uread_atom; go to ssiojn; ssio(1): stack -> temp(1) = lisp_static_vars_$crunit_atom; go to ssiojn; ssio(2): stack -> temp_ptr(1) = lisp_static_vars_$uwrite_atom; go to ssiojn; exit: stack_ptr = addr(stack -> temp(2)); rtn: return; /* * status uread, uwrite, and crunit for the new I/O system */ saction(7): /* (status uwrite) */ stack -> temp(1) = uwrite; go to s_ur_uw; saction(6): /* (status uread) */ stack -> temp(1) = uread; s_ur_uw: if stack -> temp(1) = nil then go to exit; s_cr: stack_ptr = addr(stack -> temp(3)); addr(stack -> temp(2)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2)) -> fixedb = -2; call lisp_io_fns_$names; s_cr_reform: stack_ptr = addr(stack -> temp(6)); stack -> temp(5) = nil; stack -> temp(4) = stack -> temp_ptr(1) -> cons.car; stack -> temp(3) = lisp_static_vars_$dsk_atom; stack -> temp(2) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons_ptrs.cdr -> cons.car; stack -> temp(1) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car; call lisp_special_fns_$cons; call lisp_special_fns_$cons; if j ^= 6 then do; /* (status uwrite), (status crunit) take only last 2 things in list */ stack -> temp(1) = stack -> temp(3); go to exit; end; call lisp_special_fns_$cons; call lisp_special_fns_$cons; return; saction(15): /* (status crunit) */ stack -> temp(1) = addr(lisp_static_vars_$old_io_defaults)->based_ptr -> atom.value; if stack -> temp(1) = nil then go to s_cr; else go to s_cr_reform; /* (status features) and (status feature foo) are implemented here */ saction(37): /* Watch out for status feature NIL, as opposed to Multics. */ if stack -> temp(1) = nil then do; /* (status features) - return list */ stack -> temp(1) = addr(lisp_static_vars_$semicolon_macro) /* KLUDGE */ -> based_ptr -> atom.value; go to exit; end; call check_arg; if find_feature () then go to return_t; else go to return_nil; ssaction(37): /* (sstatus feature foo) - make foo a feature */ call check_arg; if find_feature () then go to return_t; /* Don't double them */ stack -> temp(4) = addr(lisp_static_vars_$semicolon_macro) -> based_ptr -> atom.value; stack_ptr = addr(stack -> temp(6)); call lisp_special_fns_$xcons; addr(lisp_static_vars_$semicolon_macro)-> based_ptr -> atom.value = stack -> temp(4); go to return_t; /* say we won */ ssaction(46): /* (sstatus nofeature foo) - cause foo to not be a feature */ call check_arg; stack -> temp_ptr(2) = addrel(addr(lisp_static_vars_$semicolon_macro)->based_ptr, -2); if find_feature () then stack -> temp_ptr(2) -> cons.cdr = stack -> temp_ptr(1) -> cons.cdr; go to return_t; saction(47): /* (status linmode) just return t because Multics always runs in line mode */ go to return_t; /* evalhook stuff */ saction(49): if lisp_static_vars_$evalhook_status = lisp_$evalhook_on_status then go to return_t; else go to return_nil; ssaction(49): stack -> temp(1) = stack -> temp(2); if stack -> temp(1) = nil then lisp_static_vars_$evalhook_status = lisp_$evalhook_off_status; else lisp_static_vars_$evalhook_status = lisp_$evalhook_on_status; go to exit; /* (status system 'atom) returns list of system properties of atom, i.e. value and fcnl properties */ saction(31): do while (^stack -> temp_type36(2) & Atsym36); /* make sure it has a property list */ i = 2; call bad_arg; end; stack -> temp(3) = nil; /* init return value */ do argptr = addr(lisp_static_vars_$first_value_atom) /* see if value cell is used by system */ repeat(addrel(argptr, 2)) while(argptr ^= addr(lisp_static_vars_$last_value_atom)); if argptr -> temp(1) = stack -> temp(2) then do; stack_ptr = addr(stack -> temp(5)); stack -> temp(4) = lisp_static_vars_$value_atom; call lisp_special_fns_$xcons; go to saction_31_a; /* escape from the loop */ end; end; saction_31_a: stack_ptr = addr(stack -> temp(5)); stack -> temp(4) = stack -> temp(2); call lisp_defsubr_$sysp; /* get indicator of system fcnl property, if there is one */ if stack -> temp(4) ^= nil then call lisp_special_fns_$xcons; stack -> temp(1) = stack -> temp(3); go to exit; /* (status charmode f), (sstatus charmode x f) -- fiddle iochan.interactive bit */ ssaction(32): stack -> temp(1) = stack -> temp(2); /* get file arg in temp(2) */ stack -> temp(2) = stack -> temp(3); saction(32): if stack -> temp(2) = nil then argptr = tty_output_chan; else if stack -> temp(2) = t_atom then argptr = tty_output_chan; else if stack -> temp_type36(2) & File36 then argptr = stack -> temp_ptr(2); else do; saction_32_loss: i = 2; call bad_arg; go to saction(32); end; if argptr -> iochan.write then go to saction_32_loss; /* must be output file */ if ssf then if stack -> temp(1) = nil then argptr -> iochan.charmode = "0"b; else argptr -> iochan.charmode = "1"b; else if argptr -> iochan.charmode then stack -> temp(1) = t_atom; else stack -> temp(1) = nil; go to exit; /* (sstatus cleanup a) sets cleanup list to a and also sets flag as to whether it is non-nil, since it cannot be looked at during a gc */ ssaction(48): lisp_static_vars_$cleanup_list = stack -> temp(2); if stack -> temp(2) = nil then lisp_static_vars_$cleanup_list_exists = "0"b; else lisp_static_vars_$cleanup_list_exists = "1"b; stack -> temp(1) = stack -> temp(2); go to exit; /* (sstatus gctime n) resets gc timer to n and returns old value (in usec) */ ssaction(18): i = 2; call verify_num; /* and fall into (status gctime) routine */ /* (status gctime) returns the number of usec spent collecting garbage */ dcl lisp_static_vars_$gc_time fixed bin(71) external; saction(18): stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = lisp_static_vars_$gc_time; if ssf then lisp_static_vars_$gc_time = n; /* if was sstatus fn, reset timer */ go to exit; /****** The gctwa fsubr sets and gets the control flags for the gctwa feature */ dcl gctwa_sts bit(36) aligned based(addr( addr(lisp_static_vars_$status_gctwa) -> fixedb)); gctwa: entry; if addr(lisp_static_vars_$status_gctwa) -> fixnum_fmt.type_info ^= fixnum_type then do; addr(lisp_static_vars_$status_gctwa) -> fixnum_fmt.type_info = fixnum_type; gctwa_sts = "0"b; end; stack = addrel(stack_ptr, -2); if stack -> temp(1) = nil then /* (gctwa) turns on temp-gctwa bit */ gctwa_sts = gctwa_sts | "000000000000000000000000000000000001"b; else if stack -> temp_ptr(1) -> cons.car = nil then /* (gctwa nil) turns off perm bit */ gctwa_sts = gctwa_sts & "111111111111111111111111111111110111"b; else /* (gctwa t) turns on both bits */ gctwa_sts = "000000000000000000000000000000001001"b; /* now return gctwa_sts as our value */ stack -> temp(1) = lisp_static_vars_$status_gctwa; go to exit; saction(14): /* status spcnames */ stack -> temp(1) = lisp_static_vars_$space_names_atom -> atom.value; go to exit; /*** status and sstatus functions for looking at various attributes of spaces ****/ dcl lisp_static_vars_$space_names_atom external static pointer, lisp_garbage_collector_$set_gc_params entry, ListSpace fixed bin static init(0), MarkedPdlSpace fixed bin static init(1), UnmarkedPdlSpace fixed bin static init(2), which_space fixed bin, lisp_segment_manager_$set_stack_size entry(pointer, fixed bin(35)), lisp_segment_manager_$get_stack_size entry(pointer, fixed bin(35)), st_ptr pointer, lisp_static_vars_$gcmax fixed bin(35) external, lisp_static_vars_$gcsize fixed bin(5) external, lisp_static_vars_$gcmin_fraction bit(1) external, lisp_static_vars_$gcmin external, lisp_static_vars_$gcmin_fixed fixed bin(35) based(addr(lisp_static_vars_$gcmin)), lisp_static_vars_$gcmin_float float bin(27) based(addr(lisp_static_vars_$gcmin)); decode_space_name: proc; retry: stack -> temp(1) = lisp_static_vars_$space_names_atom -> atom.value; do which_space = 0 by 1 to 2; if stack -> temp_ptr(1) -> cons.car = stack -> temp(2) then return; stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; end; /* erroneous space name */ i = 2; call bad_arg; go to retry; end decode_space_name; saction(19): /* status spcsize space */ call decode_space_name; if which_space ^= ListSpace then go to pdlsize; n = 0; do st_ptr = lisp_alloc_$cur_seg repeat (st_ptr -> alloc_segment.next_seg) while (st_ptr ^= null); n = n + fixed(st_ptr -> alloc_segment.tally_word.seg_offset, 18); end; go to ret_fix; %include lisp_free_storage; saction(20): /* (status pdlsize space) */ call decode_space_name; if which_space = ListSpace then n = 0; /* ?? */ else do; pdlsize: if which_space = MarkedPdlSpace then n = fixed(rel(stack_ptr), 18); else n = fixed(rel(unmkd_ptr), 18); end; go to ret_fix; saction(21): /* (status pdlroom space) */ call decode_space_name; if which_space = ListSpace then n = 0; /* ?? */ else n = 65536; go to ret_fix; saction(22): /* (status pdlmax space) */ call decode_space_name; if which_space = ListSpace then n = 0; /* ?? */ else do; if which_space = MarkedPdlSpace then st_ptr = stack_ptr; else st_ptr = unmkd_ptr; call lisp_segment_manager_$get_stack_size(st_ptr, n); end; go to ret_fix; ssaction(22): /* (sstatus pdlmax space n) */ call decode_space_name; i = 3; call verify_num; if which_space = ListSpace then go to return_nil; /* Oh, well, just ignore it */ else if which_space = MarkedPdlSpace then st_ptr = stack_ptr; else st_ptr = unmkd_ptr; call lisp_segment_manager_$set_stack_size(st_ptr, n); go to ret_fix; /***** An Emulation of the Bibop "alloc" function on the pdp-10 *****/ alloc: entry; stack = addrel(stack_ptr, -2); /* subr 1 arg*/ if stack -> temp_type(1) = Cons then go to realloc; /* (alloc t) returns current parametervalues */ stack_ptr = addr(stack -> temp(6)); stack -> temp(5) = nil; addr(stack -> temp(2)) -> fixnum_fmt.type_info, addr(stack -> temp(3)) -> fixnum_fmt.type_info, addr(stack -> temp(4)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2)) -> fixedb = lisp_static_vars_$gcsize; addr(stack -> temp(3)) -> fixedb = lisp_static_vars_$gcmax; if lisp_static_vars_$gcmin_fraction then do; addr(stack -> temp(4)) -> flonum_fmt.type_info = flonum_type; addr(stack -> temp(4)) -> floatb = lisp_static_vars_$gcmin_float; end; else addr(stack -> temp(4)) -> fixedb = lisp_static_vars_$gcmin_fixed; do i = 1 to 3; call lisp_special_fns_$cons; end; stack_ptr = addr(stack -> temp(8)); stack -> temp(7) = nil; addr(stack -> temp(6)) -> fixnum_fmt.type_info, addr(stack -> temp(4)) -> fixnum_fmt.type_info = fixnum_type; stack -> temp(1) = lisp_static_vars_$space_names_atom -> atom_ptrs.value -> cons.car; stack -> temp(3) = lisp_static_vars_$space_names_atom -> atom_ptrs.value -> cons_ptrs.cdr -> cons.car; stack -> temp(5) = lisp_static_vars_$space_names_atom -> atom_ptrs.value -> cons_ptrs.cdr -> cons_ptrs.cdr -> cons.car; call lisp_segment_manager_$get_stack_size(stack_ptr, n); addr(stack -> temp(4)) -> fixedb = n; call lisp_segment_manager_$get_stack_size(unmkd_ptr, n); addr(stack -> temp(6)) -> fixedb = n; do i = 1 to 6; call lisp_special_fns_$cons; end; return; realloc: /** analyze argument and set parameters */ stack_ptr = addr(stack -> temp(3)); do while(stack -> temp_type(1) = Cons); /* map down argument */ if stack -> temp_ptr(1) -> cons.car = lisp_static_vars_$space_names_atom -> atom_ptrs.value -> cons.car then do; /* list */ stack -> temp(2) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car; if stack -> temp_type(2) = Cons then do; /* list of size,max,min */ if stack -> temp_ptr(2) -> cons_types36.car & Fixed36 then lisp_static_vars_$gcsize = addr(stack -> temp_ptr(2) -> cons.car) -> fixedb; if stack -> temp_ptr(2) -> cons_ptrs.cdr -> cons_types36.car & Fixed36 then lisp_static_vars_$gcmax = addr(stack -> temp_ptr(2) -> cons_ptrs.cdr -> cons.car) -> fixedb; stack -> temp(2) = stack -> temp_ptr(2) -> cons_ptrs.cdr -> cons_ptrs.cdr -> cons.car; if stack -> temp_type36(2) & Fixed36 then do; lisp_static_vars_$gcmin_fixed = max(500, addr(stack -> temp(2)) -> fixedb); lisp_static_vars_$gcmin_fraction = "0"b; end; else if stack -> temp_type36(2) & Float36 then do; lisp_static_vars_$gcmin_float = min(0.85, max(0.15, addr(stack -> temp(2)) -> floatb)); lisp_static_vars_$gcmin_fraction = "1"b; end; else; end; else if stack -> temp_type36(2) & Fixed36 then do; /* number to set gcsize from */ lisp_static_vars_$gcsize = addr(stack -> temp(2)) -> fixedb; lisp_static_vars_$gcmax = max(lisp_static_vars_$gcsize, lisp_static_vars_$gcmax); end; else; call lisp_garbage_collector_$set_gc_params; end; else if stack -> temp_ptr(1) -> cons.car = lisp_static_vars_$space_names_atom -> atom_ptrs.value -> cons_ptrs.cdr -> cons.car then do; n = addr(stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car) -> fixedb; call lisp_segment_manager_$set_stack_size(stack_ptr, n); end; else if stack -> temp_ptr(1) -> cons.car = lisp_static_vars_$space_names_atom -> atom_ptrs.value -> cons_ptrs.cdr -> cons_ptrs.cdr -> cons.car then do; n = addr(stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car) -> fixedb; call lisp_segment_manager_$set_stack_size(unmkd_ptr, n); end; else; /* ignore random space names here */ stack -> temp(1) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.cdr; end; go to return_t; loss_13: i = 2; call bad_arg; /* fall back into status/sstatus interrupt routine */ /* status interrupt & sstatus interrupt */ ssaction(13): /* to set a user interrupt function */ saction(13): /* to get a user interrupt function */ i = 2; call verify_num; /* make sure is user interrupt _n_u_m_b_e_r */ if n ^= 0 then /* allow intr channel 0, which is out of subscript range but is stored at right place so that it works anyway. This is a kludge, but I didn't want to change the dcl of user_intr_array */ if n < lbound(user_intr_array, 1) then go to loss_13; if n > hbound(user_intr_array, 1) then go to loss_13; /* check for non-existent user interrupt channel */ if user_intr_array(n) = nil then go to loss_13; if ssf then addr(user_intr_array(n)) -> based_ptr -> atom.value = stack -> temp(3); /* if sstatus */ /* return the interrupt service function */ stack -> temp(1) = addr(user_intr_array(n)) -> based_ptr -> atom.value; go to exit; saction(28): /* (status terpri) - extract data from readtable */ if status_terpri then stack -> temp(1) = t_atom; else stack -> temp(1) = nil; go to exit; saction(29): /* (status _) - extract data from readtable */ if status_underline then stack -> temp(1) = t_atom; else stack -> temp(1) = nil; go to exit; saction(35): /* (status ttyread) - extract data from readtable */ if status_ttyread then stack -> temp(1) = t_atom; else stack -> temp(1) = nil; go to exit; ssaction(28): /* (sstatus terpri torn) */ if stack -> temp(2) = nil then status_terpri = "0"b; else status_terpri = "1"b; exit2: stack -> temp(1) = stack -> temp(2); go to exit; ssaction(29): /* (sstatus _ torn) */ if stack -> temp(2) = nil then status_underline = "0"b; else status_underline = "1"b; go to exit2; ssaction(35): /* (sstatus ttyread torn) - does nothing !! */ if stack -> temp(2) = nil then status_ttyread = "0"b; else status_ttyread = "1"b; go to exit2; saction(41): /* (status abbreviate) - pick up two bits from readtable and make number */ if abbreviate_on_files then n = 1; else n = 0; if abbreviate_on_flat then n = n + 2; go to ret_fix; ssaction(41): /* (sstatus abbreviate) - store into two bits in readtable */ if stack -> temp(2) = nil then abbreviate_on_files, abbreviate_on_flat = "0"b; else if stack -> temp(2) = t_atom then abbreviate_on_files, abbreviate_on_flat = "1"b; else do; i = 2; call verify_num; abbreviate_on_files = substr(unspec(n), 36, 1); abbreviate_on_flat = substr(unspec(n), 35, 1); end; go to saction(41); /* generate return value */ /* uuolinks stuff - used to mung the fast linkages between compiled/machine-coded functions */ saction(39): /* (status uuolinks) - number of unused link slots (just a big number) */ n = 32766; /* chosen more or less at random */ go to ret_fix; ssaction(39): if stack -> temp(2) = nil then do; /* (sstatus uuolinks) - unsnap all links */ if lisp_static_vars_$no_snapped_links then; /* don't have to do anything */ else call lisp_load_$unsnap_all_links; end; else do; /* (sstatus uuolinks t) - prelink all links */ call lisp_prelinker_; end; stack -> temp(1) = nil; /* random return value */ go to exit; saction(33): /* (status tabsize) */ n = 10; /* Multics tab spacing is 10. */ go to ret_fix; saction(45): /* (status newline) - returns 10. which is ascii code for newline */ n = 10; go to ret_fix; ssaction(34): /* (sstatus crfile foo bar) - set default file name pair for uread to (foo bar) */ call check_arg; stack -> temp(2) = stack -> temp(5); call check_arg; stack -> temp(3) = stack -> temp(5); stack -> temp(4) = nil; stack -> temp(1) = addr(lisp_static_vars_$old_io_defaults)->based_ptr -> atom_ptrs.value -> cons.car; /* car of nil is nil */ if stack -> temp(1) = nil then stack -> temp(1) = STAR; stack_ptr = addr(stack -> temp(5)); call lisp_special_fns_$cons; /* cons up new defaults list */ call lisp_special_fns_$cons; call lisp_special_fns_$cons; addr(lisp_static_vars_$old_io_defaults)->based_ptr -> atom.value = stack -> temp(1); stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; go to exit; saction(34): /* (status crfile) - returns current file name pair for uread */ stack -> temp(1) = addr(lisp_static_vars_$old_io_defaults)->based_ptr -> atom.value; if stack -> temp(1) = nil then go to exit; /* get list of default names for lisp_old_io_ module */ stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = nil; if stack -> temp_type(1) = Cons then if stack -> temp_ptr(1) -> cons_types.cdr = Cons then do; if stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons_types.cdr = Cons then stack -> temp(2) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons_ptrs.cdr -> cons.car; else do; stack -> temp(2) = nil; stack_ptr = addr(stack -> temp(3)); /* random. */ end; stack -> temp(1) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car; end; else go to return_nil; /* no names right now */ else go to return_nil; /* old_io_defaults is nil, there are no names */ do while(stack_ptr ^= addr(stack -> temp(2))); call lisp_special_fns_$cons; end; return; /* internal proc for getting date and time info */ dcl clock_ ext entry returns(fixed bin(71)), (year, hour def (year), mon, minute def (mon), day, sec def (day), week_day) fixed bin, tod fixed bin(71), decode_clock_value_ ext entry(fixed bin(71), fixed bin, fixed bin, fixed bin, fixed bin(71), fixed bin, char(3) aligned); gclock: proc; call decode_clock_value_((clock_()), mon, day, year, tod, week_day, ""); /* ignore last arg, which is timezone */ end gclock; saction(9): /* (status date) */ call gclock; /* cons up a list of y, m, d */ year = year - 1900; /* since MACLISP returns two digit year */ cons3n: addr(stack -> temp(3)) -> fixnum_fmt.type_info, addr(stack -> temp(2)) -> fixnum_fmt.type_info, addr(stack -> temp(1)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(1)) -> fixedb = year; addr(stack -> temp(2)) -> fixedb = mon; addr(stack -> temp(3)) -> fixedb = day; cons3x: stack -> temp(4) = nil; stack_ptr = addr(stack -> temp(5)); call lisp_special_fns_$cons; call lisp_special_fns_$cons; call lisp_special_fns_$cons; return; saction(42): /* (status dow) - day of week */ call gclock; call lisp_get_atom_((Atoms_for_day_of_the_week(week_day)), stack -> temp(1)); go to exit; /* Table of names of the days of the week */ dcl Atoms_for_day_of_the_week (1:7) char(9) varying static init( "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"); saction(10): /* (status daytime) */ call gclock; sec = divide(tod, 1000000, 17, 0); /* prec 17 is ok since max is about 86000 */ hour = divide(sec, 3600, 17, 0); sec = sec - 3600 * hour; minute = divide(sec, 60, 17, 0); sec = sec - 60 * minute; go to cons3n; /* works because h, m, s defined onto y, m, d */ saction(11): /* (status runtime) */ dcl virtual_cpu_time_ ext entry returns(fixed bin(52)); n = fixed(virtual_cpu_time_(), 35); go to ret_fix; saction(12): /* (status time) - system uptime */ if timeup = 0 then call system_info_$timeup(timeup); /* find out when the system came up */ fn = float(clock_() - timeup) / 1e6; /* time sys has been up in seconds, float bin */ ret_flo: stack -> flonum_fmt.type_info = flonum_type; stack -> floatb = fn; go to exit; time: entry; /*** the lisp time function, same as (status time) ***/ stack = stack_ptr; stack_ptr = addr(stack -> temp(2)); go to saction(12); dcl timeup fixed bin(71) static init(0), system_info_$timeup external entry (fixed bin(71)); /* (status ioc c) */ saction(2): if m = 100 then stack -> temp(1) = addr(ctrlD) -> based_ptr -> atom.value; else if m = 113 then stack -> temp(1) = addr(ctrlQ) -> based_ptr -> atom.value; else if m = 114 then stack -> temp(1) = addr(ctrlR) -> based_ptr -> atom.value; else if m = 119 then stack -> temp(1) = addr(ctrlW) -> based_ptr -> atom.value; else stack -> temp(1) = nil; /* if not implemented here, let it be nil */ go to exit; /* sstatus ioc ccccc */ ssaction(2): call check_arg; stack -> temp(1) = stack -> temp(5); stack_ptr = addr(stack -> temp(2)); call lisp_fault_handler_$ioc; /* go call the regular ioc function */ return; dcl user_info_$whoami ext entry(char(*), char(*)), personid char(22), projectid char(9), username char(32) aligned, ioa_$rsnpnnl ext entry options(variable), cpu_time_and_paging_ ext entry(fixed bin(35), fixed bin(71), fixed bin(35)); /* (status udir) gets user directory = default wdir */ saction(36): dcl get_default_wdir_ entry(char(*)aligned), udir char(168)aligned; call get_default_wdir_(udir); n = length(udir)+1 - verify(reverse(udir), " "); call lisp_get_atom_(substr(udir, 1, n), stack -> temp(1)); go to exit; /* (status uname) gets login id */ saction(25): call user_info_$whoami(personid, projectid); call ioa_$rsnpnnl("^a.^a", username, n, personid, projectid); call lisp_get_atom_(substr(username, 1, n), stack -> temp(1)); go to exit; /* (status paging) gets the list (pre-paging page-faults) */ saction(24): call cpu_time_and_paging_(n, 0, m); stack_ptr = addr(stack -> temp(4)); stack -> temp(3) = nil; addr(stack -> temp(2)) -> fixnum_fmt.type_info, addr(stack -> temp(1)) -> fixnum_fmt.type_info = fixnum_type; addr(stack -> temp(2)) -> fixedb = n; addr(stack -> temp(1)) -> fixedb = m; call lisp_special_fns_$cons; call lisp_special_fns_$cons; go to exit; /* status lispversion returns the value of the manifest constant lispversion [3] */ saction(23): stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = lispversion; go to exit; /* (status jcl) returns exploded 2nd arg of lisp command, nil if only 0 or 1 args */ saction(26): stack -> temp(1) = nil; /* clear return list */ call cu_$arg_ptr_rel(2, argptr, arglen, code, lisp_static_vars_$arg_list_ptr); if code ^= 0 then go to exit; /* arg not given, return nil */ do n = 1 to arglen; /* arg given, make list of the chars */ stack_ptr = addr(stack -> temp(3)); call lisp_get_atom_(substr(arg, n, 1), stack -> temp(2)); call lisp_special_fns_$xcons; end; stack_ptr = addr(stack -> temp(2)); call lisp_list_utils_$nreverse; go to exit; /* (status arg n) returns (n+1)th arg to lisp command as an atomic symbol, nil if <= n args only */ saction(27): i = 2; call verify_num; /* get n */ call cu_$arg_ptr_rel(n+1, argptr, arglen, code, lisp_static_vars_$arg_list_ptr); if code = 0 then do; if arglen > length(arg_buffer) then arglen = length(arg_buffer); /* truncate if too long */ aligned_arg = arg; /* make aligned copy */ call lisp_get_atom_(aligned_arg, stack -> temp(1)); end; else stack -> temp(1) = nil; go to exit; /* (status status foo) and (status status) are implemented here */ saction(43): call check_arg; if stack -> temp(5) = nil then go to return_list_of_status_functions; char4 = addr(stack -> temp_ptr(5) -> atom.pname) -> char4b; do j = 1 to nnames; if char4 = names(j) then go to got_it_43; end; go to return_nil; /* not valid */ got_it_43: if sbits(j) & illeg then go to return_nil; /* not valid */ else go to return_t; /* valid */ /* (status sstatus foo) and (status sstatus) */ saction(44): call check_arg; if stack -> temp(5) = nil then go to return_list_of_sstatus_functions; char4 = addr(stack -> temp_ptr(5) -> atom.pname) -> char4b; do j = 1 to nnames; if char4 = names(j) then go to got_it_44; end; go to return_nil; /* not valid */ got_it_44: if ssbits(j) & illeg then go to return_nil; /* not valid */ else go to return_t; /* valid */ return_list_of_status_functions: stack -> temp(1) = nil; do j = nnames repeat (j-1) while (j > 0); if sbits(j) & illeg then; else do; stack_ptr = addr(stack -> temp(3)); do i = 4 repeat (i-1) while(substr(names(j),i,1) = NullChar); /* flush \000's */ end; call lisp_get_atom_(char(names(j), i), stack -> temp(2)); call lisp_special_fns_$xcons; end; end; go to exit; return_list_of_sstatus_functions: stack -> temp(1) = nil; do j = nnames repeat (j-1) while (j > 0); if ssbits(j) & illeg then; else do; stack_ptr = addr(stack -> temp(3)); do i = 4 repeat (i-1) while(substr(names(j),i,1) = NullChar); /* flush \000's */ end; call lisp_get_atom_(char(names(j), i), stack -> temp(2)); call lisp_special_fns_$xcons; end; end; go to exit; /* (status mulquit n-t-nil) and (status mulpi n-t-nil) are implemented here */ saction (50): /* (status mulquit n-t-nil) */ mulquit_mulpi_value_ptr = addr (lisp_static_vars_$mulquit_state); go to status_mulxx_join; saction (51): /* (status mulpi n-t-nil) */ mulquit_mulpi_value_ptr = addr (lisp_static_vars_$mulpi_state); status_mulxx_join: if mulquit_mulpi_value_ptr -> based_fxb17 = -1 then stack -> temp (1) = lisp_static_vars_$nil; else if mulquit_mulpi_value_ptr -> based_fxb17 = -2 then stack -> temp (1) = lisp_static_vars_$t_atom; else do; addr (stack -> temp (1)) -> fixnum_fmt.type_info = fixnum_type; /* must do first, for gc reaasons */ addr (stack -> temp (1)) -> fixnum_fmt.fixedb = mulquit_mulpi_value_ptr -> based_fxb17; end; go to exit; ssaction (50): /* (sstatus mulquit n-t-nil) */ mulquit_mulpi_value_ptr = addr (lisp_static_vars_$mulquit_state); go to sstatus_mulxx_join; ssaction (51): /* (sstatus mulpi n-t-nil) */ mulquit_mulpi_value_ptr = addr (lisp_static_vars_$mulpi_state); sstatus_mulxx_join: i = 2; /* for error recovery */ sstatus_mulxx_retry: if stack -> temp (2) = lisp_static_vars_$t_atom then mulquit_mulpi_value_ptr -> based_fxb17 = -2; else if stack -> temp (2) = lisp_static_vars_$nil then mulquit_mulpi_value_ptr -> based_fxb17 = -1; else if addr (stack -> temp (2)) -> lisp_ptr.type & Fixed then do; /* A fixnum */ if (addr (stack -> temp (2)) -> fixnum_fmt.fixedb < lbound (user_intr_array, 1) & (addr (stack -> temp (2)) -> fixnum_fmt.fixedb ^= 0)) /* See comment at status interrupt */ | addr (stack -> temp (2)) -> fixnum_fmt.fixedb > hbound (user_intr_array, 1) then do; call ill_arg; go to sstatus_mulxx_retry; end; else mulquit_mulpi_value_ptr -> based_fxb17 = addr (stack -> temp (2)) -> fixnum_fmt.fixedb; end; else do; call ill_arg; go to sstatus_mulxx_retry; end; go to status_mulxx_join; /* Get the "status" looking answer */ /* Reimplementation of status/sstatus feature/nofeature -- BSG 4/26/80 */ find_feature: proc returns (bit (1) aligned); char4 = translate (stack -> temp_ptr(5) -> atom.pname, LOWER_CASES, UPPER_CASES); stack -> temp(1) = addr(lisp_static_vars_$semicolon_macro) -> based_ptr -> atom.value; do while(stack -> temp_type(1) = Cons); char4a = translate (stack -> temp_ptr(1) -> cons_ptrs.car -> atom.pname, LOWER_CASES, UPPER_CASES); if char4a = char4 then do; if translate (stack -> temp_ptr(5)->atom.pname, LOWER_CASES, UPPER_CASES) = translate (stack->temp_ptr(1) -> cons_ptrs.car -> atom.pname, LOWER_CASES, UPPER_CASES) then return ("1"b); end; stack -> temp(2) = stack -> temp(1); /* for deleter*/ stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; end; return ("0"b); /* must not be a feature */ end find_feature; end;  lisp_subroutine_maker_.pl1 07/06/83 0937.0r w 06/29/83 1542.6 28854 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_subroutine_maker_: procedure; /* Subroutines which belong to the lisp system proper are entered through a transfer vector in the segment lisp_subr_tv_. This routine is called in the lisp bootstrap phase to make the appropriate atom properties so that lisp subroutines are defined in the initial environment. */ /* Automatic variables */ dcl types(0:3) fixed bin(71) aligned, /* these are lisp objects for the atoms "subr", "lsubr", "fsubr" */ atomic_symbol fixed bin(71) aligned, /* lisp object to hold onto current atom to be defined */ atsym_ptr ptr based(addr(atomic_symbol)), /* overlay to treat the above as a pointer */ name_ptr ptr, /* pointer to acc string name of subr to be defined */ plist_ptr ptr, /* pointer to space allocated for atom property list */ plist_cdr_ptr ptr, /* pointer to cdr of that. */ tvidx fixed bin; /* index into transfer vector */ /* transfer vector structure */ dcl 1 lisp_subr_tv_$lisp_subr_tv_ (0 : 1000) ext aligned, 2 header_word, 3 n_args fixed bin(17) unal, 3 subr_type fixed bin(17) unal, 2 instructions(0:1) bit(36) aligned, 2 init_data, 3 name_offset fixed bin(17) unal, 3 type fixed bin(17) unal, lisp_subr_tv_$tv_entry_count fixed bin ext; dcl 1 name_string based(name_ptr) aligned, 2 namel fixed bin(8) unal, 2 name char(0 refer(name_string.namel)) unal; /* Subroutines called */ dcl lisp_alloc_ entry(fixed bin, ptr), /* subroutine to allocate space */ lisp_get_atom_ entry(char(*) aligned,fixed bin(71) aligned); /* Builtins */ dcl (addr, addrel, hbound) builtin; /* Include files */ %include lisp_ptr_fmt; %include lisp_cons_fmt; %include lisp_atom_fmt; %include lisp_common_vars; /* Initialize the type array */ call lisp_get_atom_("subr", types(0)); call lisp_get_atom_("lsubr",types(1)); call lisp_get_atom_("fsubr",types(2)); /* Loop through all of the entries in the transfer vector, initializing them */ do tvidx = 0 to lisp_subr_tv_$tv_entry_count; name_ptr = addrel(addr(lisp_subr_tv_$lisp_subr_tv_), init_data(tvidx).name_offset); call lisp_get_atom_((name_ptr -> name_string.name), atomic_symbol); /* get the atom */ call lisp_alloc_(8, plist_ptr); /* make space for a property list */ atsym_ptr -> atom_ptrs.plist = plist_ptr; /* remember, atsym_ptr is ptr part of atomic_symbol */ plist_cdr_ptr = addrel(plist_ptr,4); /* get ptr to cdr of plist */ plist_cdr_ptr-> cons.cdr = nil; plist_ptr -> cons_ptrs.cdr = plist_cdr_ptr; /* make up the property list */ plist_ptr -> cons.car = types(lisp_subr_tv_$lisp_subr_tv_.init_data(tvidx).type); plist_cdr_ptr -> cons_ptrs.car = addr(lisp_subr_tv_$lisp_subr_tv_(tvidx)); plist_cdr_ptr -> cons_types.car = Subr|System_Subr; end; end lisp_subroutine_maker_;  lisp_trig_.pl1 07/06/83 0937.0r w 06/29/83 1542.6 39798 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ lisp_trig_: procedure; /* miscellaneous trig and arith functions for lisp. 25 Jan 73, dam */ dcl (fn, fn2) float bin, n fixed bin(35), timeup fixed bin(71) static init(0), stack ptr, lisp_error_ entry, errcode(2) fixed bin(35) aligned based, myname fixed bin, timer_manager_$sleep ext entry (fixed bin(71), bit(2)), system_info_$timeup ext entry(fixed bin(71)), (addrel, float, fixed, null, multiply, atan, cos, exp, sqrt, log, sin) builtin; %include lisp_common_vars; %include lisp_stack_fmt; %include lisp_nums; %include lisp_name_codes; %include lisp_error_codes; /* * Internal proc to get flonum value from top word on stack */ floval: proc; stack = addrel(stack_ptr, -2); floval0: if stack -> flonum_fmt.type_info = flonum_type then fn = stack -> floatb; else if stack -> fixnum_fmt.type_info = fixnum_type then fn = float(stack -> fixedb); else do; call erro; go to floval0; end; end; /* * Internal proc to get fixnum value from top word on stack */ fixval: proc; stack = addrel(stack_ptr, -2); fixval0: if stack -> flonum_fmt.type_info = flonum_type then n = fixed(stack -> floatb); else if stack -> fixnum_fmt.type_info = fixnum_type then n = stack -> fixedb; else do; call erro; go to fixval0; end; end; /* Signal wrng-type-arg error */ erro: proc; dcl unm ptr; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = bad_arg_correctable; unm -> errcode(2) = myname; call lisp_error_; end; /*** One Argument Trig Subrs ***/ cos: entry; myname = fn_cos; call floval; fn = cos(fn); floret: stack -> flonum_fmt.type_info = flonum_type; stack -> floatb = fn; return; sin: entry; myname = fn_sin; call floval; fn = sin(fn); go to floret; exp: entry; myname = fn_exp; exp0: call floval; if fn > 88.028 then do; call erro; go to exp0; end; else if fn > -88.028 then fn = exp(fn); else fn = 0; go to floret; log: entry; myname = fn_log; log0: call floval; if fn <= 0 then do; call erro; go to log0; end; fn = log(fn); go to floret; sqrt: entry; myname = fn_sqrt; sqrt0: call floval; if fn < 0 then do; call erro; go to sqrt0; end; fn = sqrt(fn); go to floret; isqrt: entry; myname = fn_isqrt; isqrt0: call fixval; if n < 0 then do; call erro; go to isqrt0; end; n = sqrt(n); fixret: stack -> fixnum_fmt.type_info = fixnum_type; stack -> fixedb = n; return; /*** Arc Tangent Lsubr, allows 1 or 2 arguments ***/ atan: entry; myname = fn_atan; stack = addrel(stack_ptr, -2); n = stack -> fixedb; /* arg count */ stack_ptr = stack; if n = -2 then do; /* 1 arg */ call floval; fn = atan(fn); end; else if n = -4 then do; /* 2 args */ call floval; /* 2nd arg */ fn2 = fn; stack_ptr = stack; call floval; /* 1st arg */ if fn = 0 then if fn2 = 0 then do; /* (atan 0 0) is not allowed */ dcl unm ptr; unm = unmkd_ptr; unmkd_ptr = addrel(unm, 2); unm -> errcode(1) = atan_0_0_err; unm -> errcode(2) = fn_atan; call lisp_error_; /* this is fatal error for now */ end; fn = atan(fn, fn2); end; else stack_ptr = addrel(stack, 2+n); /* wna - just fiddle stack ptr so no lose */ go to floret; sleep: entry; /*** Subr to cause delay for specified length of time */ myname = fn_sleep; sleep0: call floval; if fn < 0 then go to abs_sleep; /* absolute time */ rel_sleep: /* relative time */ call timer_manager_$sleep(fixed(fn*1e6,71), "10"b); /* convert seconds (floating) to microseconds (fixed) */ return; abs_sleep: /* absolute time - in terms of (status time) */ if timeup = 0 then call system_info_$timeup(timeup); /* find out when the system came up */ call timer_manager_$sleep(timeup-fixed(fn*1e6,71), "00"b); /* sleep until system has been up for 'arg' number of microseconds */ return; expt_assistance: entry; /* do expt of a flonum and a flonum for lisp_bignums_ */ call floval; fn2 = fn; stack_ptr = stack; call floval; fn = fn ** fn2; go to floret; end lisp_trig_; */ ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved */