COMPILATION LISTING OF SEGMENT lisp_prog_fns_ Compiled by: Multics PL/I Compiler, Release 28b, of April 11, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 06/30/83 0848.9 mst Thu Options: map single_symbol_list 1 /* ************************************************************** 2* * * 3* * Copyright, (C) Massachusetts Institute of Technology, 1973 * 4* * * 5* ************************************************************** */ 6 prog: proc; 7 8 /* lisp functions that use hairy control structures - prog, errset, catch/throw, & c. */ 9 10 /* 11* * Gathered from other modules and recoded by D. Moon 8-JUN-72 12* * break added, 12-July-72 DAM 13* * go changed to search for label instead of making 14* * label-table array, DAM 5 Aug 72 15* * go, return, and xec_body moved into hand code in lisp_.alm, 19 AUG 72 DAM 16* * err function moved to lisp_error_.pl1, DAM 15 OCT 1972 17* * Moby unwind_protect feature, after HIC dared me, BSG 09/09/78 18* */ 19 20 /* INCLUDE FILES */ 21 1 1 /* BEGIN INCLUDE FILE lisp_control_chars.incl.pl1 */ 1 2 1 3 /* Last modified D. Reed 6/29/72 */ 1 4 1 5 dcl lisp_static_vars_$ctrlD ext fixed bin(71), 1 6 ctrlD fixed bin(71) defined (lisp_static_vars_$ctrlD); 1 7 1 8 dcl lisp_static_vars_$ctrlQ ext fixed bin(71), 1 9 ctrlQ fixed bin(71) defined (lisp_static_vars_$ctrlQ); 1 10 1 11 dcl lisp_static_vars_$ctrlR ext fixed bin(71), 1 12 ctrlR fixed bin(71) defined (lisp_static_vars_$ctrlR); 1 13 1 14 dcl lisp_static_vars_$ctrlW ext fixed bin(71), 1 15 ctrlW fixed bin(71) defined (lisp_static_vars_$ctrlW); 1 16 1 17 /* END INCLUDE FILE lisp_control_chars.incl.pl1 */ 1 18 22 2 1 /* lisp stack header format */ 2 2 /* Last modified 7/21/72 by Reed for in_pl1 flag */ 2 3 /* Modified 1978 by Greenberg for unwind-protect ops */ 2 4 2 5 declare 2 6 2 7 1 stack_seg based aligned, /* stored in base of unmkd_pdl segment */ 2 8 2 marked_stack_bottom ptr, /* where marked stack begins... */ 2 9 2 unmkd_stack_bottom ptr, /* where unmkd_ stack actually starts */ 2 10 2 stack_ptr_ptr ptr, /* points at lisp_static_vars_$stack_ptr */ 2 11 2 unmkd_ptr_ptr ptr, /* points at lisp_static_vars_$unmkd_ptr's offset word */ 2 12 2 array_pointer ptr, /* obsolete */ 2 13 2 nil fixed bin(71), /* object for nil */ 2 14 2 true fixed bin(71), /* object for t */ 2 15 2 in_pl1_code bit(36), /* flag indicating that we are in pl1 code if non-zero */ 2 16 2 padding0 bit(36), /* double word boundary preservation */ 2 17 2 bind_op ptr, /* pointers to operators for run-time support */ 2 18 2 unbind_op ptr, 2 19 2 errset1_op ptr, 2 20 2 errset2_op ptr, 2 21 2 unerrset_op ptr, 2 22 2 call_op ptr, 2 23 2 catch1_op ptr, 2 24 2 catch2_op ptr, 2 25 2 uncatch_op ptr, 2 26 2 gensym_data (2) bit(36) aligned, /* stuff used by the gensym function */ 2 27 2 system_lp ptr, /* pointer to the system's linkage section */ 2 28 2 iogbind_op ptr, 2 29 2 unseen_go_tag_op ptr, 2 30 2 throw1_op ptr, 2 31 2 throw2_op ptr, 2 32 2 signp_op ptr, 2 33 2 type_fields bit(72) aligned, /* fixnum, flonum type for compiled code */ 2 34 2 return_op ptr, 2 35 2 err_op ptr, 2 36 2 pl1_interface ptr, /* pointer to pl1 interface for type 2 subrs. */ 2 37 2 pl1_lsubr_interface ptr, /* same for type -2 subrs */ 2 38 2 cons_opr ptr, /* cons operator */ 2 39 2 ncons_opr ptr, /* ncons operator */ 2 40 2 xcons_opr ptr, /* xcons operator */ 2 41 2 begin_list_opr ptr, /* operator to make initial cell of list */ 2 42 2 append_list_opr ptr, /* operator to append to last-made cell of list */ 2 43 2 terminate_list_opr ptr, /* opeator to append last cell to next to last cell of list */ 2 44 2 compare_op ptr, /* fixnum/flonum comparison operator */ 2 45 2 link_op ptr, 2 46 2 array_operator pointer, /* accessing operator, invoked by arrays */ 2 47 2 dead_array_operator pointer, /* dead arrays invoke this operator instead */ 2 48 2 store_operator pointer, /* operator to do compiled store */ 2 49 2 floating_store_operator pointer, /* ditto, but operand is in EAQ */ 2 50 2 array_info_for_store pointer, /* -> array_info block of last array referenced */ 2 51 2 array_offset_for_store fixed bin(18), /* offset in array_data block of last array element referenced */ 2 52 2 padding bit(36), 2 53 2 array_link_snap_opr pointer, 2 54 2 create_string_desc_op ptr, 2 55 2 create_array_desc_op ptr, 2 56 2 pl1_call_op ptr, 2 57 2 cons_string_op ptr, 2 58 2 create_varying_string_op ptr, 2 59 2 unwp1_op ptr, 2 60 2 unwp2_op ptr, 2 61 2 ununwp_op ptr, 2 62 2 irest_return_op ptr, 2 63 2 pl1_call_nopop_op ptr, 2 64 2 rcv_char_star_op ptr, 2 65 2 spare2 (7) ptr, 2 66 2 begin_unmkd_stack(16325) fixed bin(71); /* rest of segment is the unmarked pdl */ 2 67 2 68 dcl call_array_operator bit(36) static init("100112273120"b3), /* tspbb ab|112,* */ 2 69 call_dead_array_operator bit(36) static init("100114273120"b3); /* tspbb ab|114,* */ 2 70 2 71 /* end stack segment format */ 23 3 1 /* lisp number format -- overlaid on standard its pointer. */ 3 2 3 3 3 4 dcl 1 fixnum_fmt based aligned, 3 5 2 type_info bit(36) aligned, 3 6 2 fixedb fixed bin, 3 7 3 8 1 flonum_fmt based aligned, 3 9 2 type_info bit(36) aligned, 3 10 2 floatb float bin, 3 11 3 12 fixnum_type bit(36) aligned static init("000000000000000000000100000000100111"b), 3 13 flonum_type bit(36) aligned static init("000000000000000000000010000000100111"b); 3 14 3 15 /* end of lisp number format */ 3 16 24 4 1 /* include file lisp_stack_fmt.incl.pl1 -- 4 2* describes the format of the pushdown list 4 3* used by the lisp evaluator and lisp subrs 4 4* for passing arguments, saving atom bindings, 4 5* and as temporaries */ 4 6 4 7 dcl 4 8 temp(10000) fixed bin(71) aligned based, 4 9 4 10 temp_ptr(10000) ptr aligned based, 4 11 1 push_down_list_ptr_types(10000) based aligned, 4 12 2 junk bit(21) unaligned, 4 13 2 temp_type bit(9) unaligned, 4 14 2 more_junk bit(42) unaligned, 4 15 4 16 1 pdl_ptr_types36(10000) based aligned, 4 17 2 temp_type36 bit(36), 4 18 2 junk bit(36), 4 19 4 20 1 binding_block aligned based, 4 21 2 top_block bit(18) unaligned, 4 22 2 bot_block bit(18) unaligned, /* these two are rel pointers into the marked PDL */ 4 23 2 back_ptr bit(18) unaligned, /* relative pointer into unmarked PDL for last binding block. */ 4 24 2 rev_ptr bit(18) unaligned, /* relative pointer to reversal bb which reversed this one, init to 0 */ 4 25 4 26 1 bindings(10000) based aligned, /* format fof bindings on stack */ 4 27 2 old_val fixed bin(71) aligned, 4 28 2 atom fixed bin(71) aligned; 4 29 4 30 4 31 4 32 /* end include file lisp_stack_fmt.incl.pl1 */ 25 5 1 /* BEGIN INCLUDE FILE lisp_faults.incl.pl1 */ 5 2 5 3 /* 5 4* * Written 14 Aug 72 by D A Moon 5 5* * Fault codes changed 4 Feb 73 by DAM, for user interrupt masking and new alarmclock facility 5 6* * Names changed 16 Dec 1973 by DAM because of a name conflict with lisp_free_storage.incl.pl1 5 7* * Modified 74.06.03 by DAM for new-arrays 5 8* * Modified 74.12.16 by DAM to change meaning of 'masked' 5 9* */ 5 10 dcl (Alarmclock_fault init(2), 5 11 Cput_fault init(1), 5 12 Car_cdr_fault init(6), 5 13 Quit_fault init(4), 5 14 Array_fault init(5), 5 15 Zerodivide_fault init(7), 5 16 Underflow_fault init(8), 5 17 Old_store_fault init(9), /* old/new array compatibility */ 5 18 Pi_fault init(10) /* program_interrupt signal */ 5 19 ) fixed bin static; 5 20 5 21 5 22 /* structure for saving info when a fault or an error ocuurs. 5 23* This structure gets pushed onto the unmkd pdl */ 5 24 5 25 dcl 1 fault_save aligned based (unm), 5 26 2 prev_frame bit(18)unaligned, /* thread */ 5 27 2 stack_ptr bit(18) unaligned, /* rel(stack_ptr) at time frame was created */ 5 28 2 sv_gc_inhibit bit(1) unaligned, /* save lisp_static_vars_$garbage_collect_inhibit */ 5 29 2 sv_masked like masked unaligned, /* save lisp_static_vars_$masked - for err breaks in (nointerrupt t) mode */ 5 30 2 code1 fixed bin, /* error code 1, 0 = not errprintable error */ 5 31 2 code2 fixed bin, /* error code 2, for file system errors */ 5 32 2 sv_array_info ptr, /* save array_info_for_store in stack header */ 5 33 2 sv_rdr_label label, /* -> abnormal return from call to ios_$read */ 5 34 2 sv_rdr_ptr ptr, /* datum used by reader for readlist control */ 5 35 2 sv_rdr_state fixed bin, /* 0=normal, 1=wait for input, 2=readlist */ 5 36 2 sv_array_offset fixed bin(18), /* save array_offset_for_store in stack header */ 5 37 2 padding bit(36), /* make structure an even number of words in size */ 5 38 2 dat_ptr bit(18); /* rel ptr to marked pdl slot containing losing form */ 5 39 /* needed by errprint */ 5 40 /* size(fault_save) must be even */ 5 41 5 42 5 43 /* declarations of the things that get saved here */ 5 44 5 45 dcl lisp_static_vars_$garbage_collect_inhibit bit(1) aligned external, 5 46 1 lisp_static_vars_$masked aligned external like masked, 5 47 lisp_static_vars_$pending_ctrl bit(1) aligned external, /* flag that we are doing stacked-up ctrl chars 5 48* right now, makes sure none get missed if ^G */ 5 49 lisp_static_vars_$deferred_interrupt bit(1) aligned external, /* when we unmask, we test this to */ 5 50 /* see if we must poll interrupts */ 5 51 lisp_static_vars_$rdr_label label external, 5 52 lisp_static_vars_$rdr_ptr ptr external, 5 53 lisp_static_vars_$rdr_state fixed bin external, 5 54 gc_inhibit bit(1) aligned defined(lisp_static_vars_$garbage_collect_inhibit), 5 55 deferred_interrupt bit (1) aligned defined (lisp_static_vars_$deferred_interrupt), 5 56 1 masked aligned based(addr(lisp_static_vars_$masked)), /* defined causes fault in compiler */ 5 57 2 against unaligned, /* things masked against: */ 5 58 3 tty bit(1), /* tty control characters */ 5 59 3 alarm bit(1), /* alarmclock interrupts */ 5 60 pending_ctrl bit(1) aligned defined (lisp_static_vars_$pending_ctrl), 5 61 lisp_fault_handler_$set_mask entry(1 aligned like masked), 5 62 rdr_label label defined (lisp_static_vars_$rdr_label), 5 63 rdr_ptr ptr defined (lisp_static_vars_$rdr_ptr), 5 64 rdr_state fixed bin defined (lisp_static_vars_$rdr_state); 5 65 5 66 5 67 /* END INCLUDE FILE lisp_faults.incl.pl1 */ 5 68 26 6 1 6 2 /* BEGIN INCLUDE FILE lisp_unmkd_pdl.incl.pl1 */ 6 3 6 4 /* which describes the format of information that gets 6 5* put on the unmarked pdl */ 6 6 6 7 dcl errcode(2) fixed bin aligned based, /* (1) is error code for lisp_error_ */ 6 8 /* (2) is file system code (if any) */ 6 9 6 10 1 frame aligned based, /* many types of frames are pushed */ 6 11 2 prev_frame bit(18) unaligned, /* rel ptr to previous frame same type, or 0 */ 6 12 2 stack_ptr bit(18) unaligned, /* rel(stack_ptr) when the frame was created */ 6 13 2 (dat1, dat2) bit(18) unaligned, /* available for any lawful purpose */ 6 14 2 ret label; /* where to return to */ 6 15 6 16 dcl nframeptrs fixed bin static init(6), /* in the following two declarations, 6 17* I used 6 where I meant nframeptrs because of compiler bug */ 6 18 lisp_static_vars_$frame_ptrs (0:6) ptr ext static, 6 19 frame_ptrs (0 : 6) pointer defined (lisp_static_vars_$frame_ptrs); /* prog_frame, err_frame, etc. */ 6 20 6 21 6 22 /* END INCLUDE FILE lisp_unmkd_pdl.incl.pl1 */ 6 23 27 7 1 /* Include file lisp_ptr_fmt.incl.pl1; 7 2* describes the format of lisp pointers as 7 3* a bit string overlay on the double word ITS pair 7 4* which allows lisp to access some unused bits in 7 5* the standard ITS pointer format. It should be noted that 7 6* this is somewhat of a kludge, since 7 7* it is quite machine dependent. However, to store type 7 8* fields in the pointer, saves 2 words in each cons, 7 9* plus some efficiency problems. 7 10* 7 11* D.Reed 4/1/71 */ 7 12 /* modified to move type field to other half of ptr */ 7 13 /* D.Reed 5/31/72 */ 7 14 7 15 7 16 dcl based_ptr ptr aligned based; /* for dealing with lisp values as pointers */ 7 17 dcl lisp_ptr_type bit(36) aligned based, /* for more efficient checking of type bits */ 7 18 1 lisp_ptr based aligned, /* structure of double word pointer in lisp */ 7 19 2 segno bit(18) unaligned, /* segment number pointed to by pointer */ 7 20 2 ringnum bit(3) unaligned, /* ring mumber for validation */ 7 21 2 type bit(9) unaligned, /* type field */ 7 22 2 itsmod bit(6) unaligned, 7 23 2 offset fixed bin(17) unaligned, /* offset in segment of object pointed to */ 7 24 2 chain bit(18) unaligned, /* normally 0, but may be set to chain pointers together */ 7 25 7 26 /* manifest constant strings for testing above type field */ 7 27 7 28 ( 7 29 Cons init("000000000"b), /* a pointer to a list has a zero type field */ 7 30 Fixed init("100000000"b), /* a fixed point number, stored in second word of the ptr */ 7 31 Float init("010000000"b), /* a floating number, also stored in the second word of the ptr */ 7 32 Atsym init("001000000"b), /* this bit on means a ptr to an atomic symbol */ 7 33 Atomic init("111111111"b), /* any bit on means an atomic data type */ 7 34 Bignum init("000001000"b), /* a multiple-precision number */ 7 35 Bigfix init("000001000"b), /* a fixed point bignum (only kind for now) */ 7 36 Numeric init("110000000"b), /* either type immediate number. Both bits on 7 37* means a special internal uncollectable weird object */ 7 38 Uncollectable init("110000000"b), /* not looked through by garbage collector */ 7 39 String init("000100000"b), /* pointer to lisp character string - length word, chars */ 7 40 Subr init("000010000"b), /* pointer to compiled (or builtin) subroutine (linkage) code */ 7 41 System_Subr init("000000100"b), /* Subr bit must be on too, indicates ptr into lisp_subr_tv_ */ 7 42 Array init("000000010"b), /* Subr bit must be on too, indicates ptr to a lisp array */ 7 43 File init("000000001"b) /* pointer to a file object (iochan block) */ 7 44 ) bit(9) static, 7 45 7 46 /* 36 bit manifest constant strings for testing lisp_ptr_type */ 7 47 7 48 7 49 ( 7 50 Cons36 init("000000000000000000000000000000"b), 7 51 Fixed36 init("000000000000000000000100000000"b), 7 52 Float36 init("000000000000000000000010000000"b), 7 53 Atsym36 init("000000000000000000000001000000"b), 7 54 Atomic36 init("000000000000000000000111111100"b), 7 55 Bignum36 init("000000000000000000000000001000"b), 7 56 System_Subr36 7 57 init("000000000000000000000000000100"b), 7 58 Bigfix36 init("000000000000000000000000001000"b), 7 59 Numeric36 init("000000000000000000000110000000"b), /* does not check for bignum */ 7 60 NotConsOrAtsym36 7 61 init("000000000000000000000110111111"b), 7 62 SubrNumeric36 7 63 init("000000000000000000000110010000"b), /* used in garbage collector, for quick check */ 7 64 String36 init("000000000000000000000000100000"b), 7 65 Subr36 init("000000000000000000000000010000"b), 7 66 File36 init("000000000000000000000000000001"b), 7 67 Array36 init("000000000000000000000000000010"b)) bit(36) aligned static, 7 68 7 69 /* undefined pointer value is double word of zeros */ 7 70 7 71 Undefined bit(72) static init(""b); 7 72 7 73 /* end of include file lisp_ptr_fmt.incl.pl1 */ 28 8 1 /* BEGIN INCLUDE FILE lisp_initial_atoms.incl.pl1 */ 8 2 8 3 dcl lisp_static_vars_$toplevel ext fixed bin(71), 8 4 toplevel fixed bin(71) defined (lisp_static_vars_$toplevel), 8 5 8 6 lisp_static_vars_$errlist ext fixed bin(71), 8 7 errlist fixed bin(71) defined (lisp_static_vars_$errlist), 8 8 8 9 lisp_static_vars_$STAR ext fixed bin(71), 8 10 STAR fixed bin(71) defined (lisp_static_vars_$STAR), 8 11 lisp_static_vars_$PLUS fixed bin(71) external, 8 12 PLUS fixed bin(71) defined (lisp_static_vars_$PLUS), 8 13 lisp_static_vars_$MINUS fixed bin(71) external, 8 14 MINUS fixed bin(71) defined (lisp_static_vars_$MINUS), 8 15 lisp_static_vars_$SLASH fixed bin(71) external, 8 16 SLASH fixed bin(71) defined (lisp_static_vars_$SLASH); 8 17 8 18 /* END INCLUDE FILE lisp_initial_atoms.incl.pl1 */ 29 9 1 /* Include file lisp_common_vars.incl.pl1; 9 2* describes the external static variables which may be referenced 9 3* by lisp routines. 9 4* D. Reed 4/1/71 */ 9 5 9 6 dcl 1 lisp_static_vars_$lisp_static_vars_ external, 9 7 2 cclist_ptr ptr, /* pointer to list of constants kept 9 8* by compiled programs */ 9 9 2 garbage_collect_soon bit(1) aligned, /* if this is on we should garbage collect soon */ 9 10 9 11 lisp_static_vars_$err_recp ptr ext aligned, /* pointer to error data */ 9 12 err_recp ptr defined (lisp_static_vars_$err_recp), 9 13 eval_frame ptr defined (lisp_static_vars_$eval_frame), /* info kept by eval if *rset t */ 9 14 lisp_static_vars_$eval_frame ptr ext static, 9 15 lisp_static_vars_$prog_frame ptr ext aligned, 9 16 lisp_static_vars_$err_frame ptr ext aligned, 9 17 lisp_static_vars_$catch_frame ptr ext aligned, 9 18 lisp_static_vars_$unwp_frame ptr ext aligned, 9 19 lisp_static_vars_$stack_ptr ptr ext aligned, 9 20 lisp_static_vars_$t_atom fixed bin(71) ext aligned, 9 21 lisp_static_vars_$top_level label ext, /* top level read_eval_print loop */ 9 22 lisp_static_vars_$unmkd_ptr ptr ext aligned, 9 23 lisp_static_vars_$binding_top ptr ext aligned, 9 24 lisp_static_vars_$obarray fixed bin(71) aligned ext, 9 25 obarray fixed bin(71) defined (lisp_static_vars_$obarray), 9 26 lisp_static_vars_$array_atom fixed bin(71) aligned ext, 9 27 array_atom fixed bin(71) defined (lisp_static_vars_$array_atom), 9 28 binding_top ptr defined (lisp_static_vars_$binding_top), 9 29 unmkd_ptr ptr defined (lisp_static_vars_$unmkd_ptr), 9 30 stack_ptr ptr defined (lisp_static_vars_$stack_ptr), 9 31 lisp_static_vars_$nil ext static fixed bin(71) aligned, 9 32 nil fixed bin(71) defined (lisp_static_vars_$nil), 9 33 lisp_static_vars_$tty_input_chan ext static ptr, /* used by the reader */ 9 34 lisp_static_vars_$tty_output_chan ext static ptr, /*used by print*/ 9 35 tty_input_chan ptr def (lisp_static_vars_$tty_input_chan), 9 36 tty_output_chan ptr def (lisp_static_vars_$tty_output_chan), 9 37 lisp_static_vars_$iochan_list external pointer, /* list of all open iochans */ 9 38 nil_ptr ptr based(addr(lisp_static_vars_$nil)) aligned, 9 39 prog_frame ptr def (lisp_static_vars_$prog_frame), /* 3 ptrs for use of lisp_prog_fns_ */ 9 40 err_frame ptr def (lisp_static_vars_$err_frame), /* they point out frames in unmkd pdl */ 9 41 catch_frame ptr def (lisp_static_vars_$catch_frame), 9 42 unwp_frame ptr def (lisp_static_vars_$unwp_frame), 9 43 t_atom_ptr ptr aligned based(addr(lisp_static_vars_$t_atom)), 9 44 t_atom fixed bin(71) defined (lisp_static_vars_$t_atom); /* pointer to atom t */ 9 45 dcl lisp_static_vars_$user_intr_array(20) fixed bin(71) aligned ext static, /* -> atoms whose values are intr service functions */ 9 46 user_intr_array (20) fixed bin(71) aligned def (lisp_static_vars_$user_intr_array), 9 47 lisp_static_vars_$star_rset fixed bin(71) aligned ext static, 9 48 star_rset fixed bin(71) aligned def (lisp_static_vars_$star_rset); 9 49 9 50 9 51 /* end include file lisp_common_vars.incl.pl1 */ 30 10 1 /* Include file lisp_cons_fmt.incl.pl1; 10 2* defines the format for a cons within the lisp system 10 3* D.Reed 4/1/71 */ 10 4 10 5 dcl consptr ptr, 10 6 1 cons aligned based (consptr), /* structure defining format for cons */ 10 7 2 car fixed bin(71), 10 8 2 cdr fixed bin(71), 10 9 10 10 1 cons_ptrs aligned based (consptr), /* for using car and cdr as pointers */ 10 11 2 car ptr, 10 12 2 cdr ptr, 10 13 10 14 10 15 1 cons_types aligned based (consptr), /* structure for extracting types out of cons */ 10 16 2 padding bit(21) unaligned, 10 17 2 car bit(9) unaligned, 10 18 2 padding2 bit(63) unaligned, 10 19 2 cdr bit(9) unaligned, 10 20 2 padend bit(42) unaligned; 10 21 10 22 dcl 1 cons_types36 aligned based, 10 23 2 car bit(36), 10 24 2 pada bit(36), 10 25 2 cdr bit(36), 10 26 2 padd bit(36); 10 27 10 28 10 29 /* end include file lisp_cons_fmt.incl.pl1 */ 31 11 1 /* Include file lisp_atom_fmt.incl.pl1; 11 2* describes internal format of atoms in the lisp system 11 3* D.Reed 4/1/71 */ 11 4 11 5 dcl 1 atom aligned based, /* overlay for atom fomat */ 11 6 2 value fixed bin(71), /* atom's value */ 11 7 2 plist fixed bin(71), /* property list */ 11 8 2 pnamel fixed bin, /* length of print name */ 11 9 2 pname char(1 refer(pnamel)), /* print name of atom */ 11 10 11 11 1 atom_ptrs based aligned, /* for use of plist and value of atom as ptrs */ 11 12 2 value ptr, 11 13 2 plist ptr, 11 14 11 15 1 atom_double_words based aligned, /* overlay for atom pointer checking */ 11 16 2 value bit(72), 11 17 2 plist bit(72); 11 18 11 19 /* end of include file lisp_atom_fmt.incl.pl1 */ 32 12 1 12 2 /* BEGIN INCLUDE FILE lisp_error_codes.incl.pl1 */ 12 3 12 4 /* This contains codes to be stored on the unmkd pdl before calling 12 5* lisp_error_. These codes, at ab|-2,x7, are used by lisp_error_ 12 6* as an index into lisp_error_table_. */ 12 7 12 8 dcl ( 12 9 undefined_atom init(100), /* - correctable */ 12 10 undefined_function init(101), /* - correctable */ 12 11 too_many_args init(102), /* uncorrectable */ 12 12 too_few_args init(103), /* .. */ 12 13 file_system_error init(104), /* (obsolete) */ 12 14 bad_argument init(105), /* uncorrectable arg reject */ 12 15 undefined_subr init(106), 12 16 bad_function init(107), /* "bad functional form" */ 12 17 bad_bv init(108), /* attempt to bind non-variable */ 12 18 unseen_go_tag init(109), /* correctable -> unevaled new tag */ 12 19 throw_to_no_catch init(110), /* .. */ 12 20 nonfixedarg init(111), /* correctable */ 12 21 parenmissing init(112), /* uncorr reader error */ 12 22 doterror init(113), /* .. */ 12 23 illobj init(114), /* .. */ 12 24 badmacro init(115), /* .. */ 12 25 shortreadlist init(116), /* .. */ 12 26 badreadlist init(117), /* .. */ 12 27 array_bound_error init(118), /* corr -> (array sub1 sub2...) */ 12 28 car_cdr_error init(119), /* uncorr - car or cdr of number */ 12 29 bad_arg_correctable init(120), /* correctable arg reject */ 12 30 bad_prog_op init(121), /* uncorr fail-act: go or return */ 12 31 no_lexpr init(122), /* uncorr fail-act: args or setarg */ 12 32 wrong_no_args init(123), /* correctable wna -> new expr value */ 12 33 bad_ibase init(124), /* corr */ 12 34 bad_base init(125), /* corr */ 12 35 bad_input_source init(126), /* corr - retry i/o */ 12 36 bad_output_dest init(127), /* .. */ 12 37 nihil_ex_nihile init(128), /* uncorr - attempt to setq nil */ 12 38 not_pdl_ptr init(131), /* corr arg reject - for pdl ptr args */ 12 39 bad_f_fcn init(134), /* compiled call to fsubr with evaled args */ 12 40 overflow_err init(135), /* arithmetic overflow. */ 12 41 mismatch_super_parens init(136), /* uncorr reader error */ 12 42 no_left_super_paren init(137), /* .. */ 12 43 flonum_too_big init(138), /* .. */ 12 44 quoterror init(139), /* .. */ 12 45 badreadtable init(140), /* .. */ 12 46 badobarray init(141), /* .. */ 12 47 atan_0_0_err init(142), /* (atan 0 0) doesn't work */ 12 48 unable_to_float init(143), /* corr arg reject - (float x) */ 12 49 division_by_zero init(144), /* uncorr (should really be corr) */ 12 50 eof_in_object init(145), /* corr fail-act -> keep reading anyway */ 12 51 cant_filepos init(146), /* corr fail-act -> new expr value */ 12 52 filepos_oob init(147), /* .. */ 12 53 file_sys_fun_err init(148), /* corr f.s. err -> new expr value */ 12 54 stars_left_in_name init(149), /* .. */ 12 55 io_wrong_direction init(150), /* .. */ 12 56 file_is_closed init(151), /* .. */ 12 57 reopen_inconsistent init(152), /* .. */ 12 58 bad_entry_name init(153), /* .. */ 12 59 bad_do_format init(154), /* bad do format in interp. */ 12 60 not_an_array init(155), /* bad array-type arg */ 12 61 not_alpha_array init(156), /* bad all-alphabetic array */ 12 62 include_file_error init(157), /* %include barfed */ 12 63 stack_loss_error init(158), /* stack overflew */ 12 64 underflow_fault init(159), 12 65 zerodivide_fault init(160), 12 66 bad_array_subscript init(161), 12 67 store_not_allowed init(162), 12 68 dead_array_reference init(163), 12 69 cant_subscript_readtable init(164), 12 70 not_same_type init(165), 12 71 special_array_type init(166), 12 72 array_too_big init(167), 12 73 argument_must_be_array init(168), 12 74 store_function_misused init(169) 12 75 ) fixed bin static; 12 76 12 77 /* END INCLUDE FILE lisp_error_codes.incl.pl1 */ 33 13 1 13 2 /* BEGIN INCLUDE FILE lisp_name_codes.incl.pl1 */ 13 3 13 4 /* These are codes for the names of functions which are stored into ab|-1,x7 before 13 5* calling lisp_error_ for a bad_argument or bad_arg_correctable error. They 13 6* are used so that the name of the function which is rejecting its argument 13 7* can be printed. Please note that all these codes are negative. */ 13 8 13 9 dcl ( 13 10 fn_do init (-10), 13 11 fn_arg init (-11), 13 12 fn_setarg init (-12), 13 13 fn_status init (-13), 13 14 fn_sstatus init (-14), 13 15 fn_errprint init (-15), 13 16 fn_errframe init (-16), 13 17 fn_evalframe init (-17), 13 18 fn_defaultf init (-18), 13 19 fn_tyo init (-22), 13 20 fn_ascii init (-23), 13 21 fn_rplaca init (-24), 13 22 fn_definedp init (-25), 13 23 fn_setq init (-26), 13 24 fn_set init (-27), 13 25 fn_delete init (-28), 13 26 fn_delq init (-29), 13 27 fn_stringlength init (-30), 13 28 fn_catenate init (-31), 13 29 fn_array init (-32), 13 30 fn_substr init (-33), 13 31 fn_index init (-34), 13 32 fn_get_pname init (-35), 13 33 fn_make_atom init (-36), 13 34 fn_ItoC init (-37), 13 35 fn_CtoI init (-38), 13 36 fn_defsubr init (-39), 13 37 fn_star_array init (-40), 13 38 fn_args init (-41), 13 39 fn_sysp init (-42), 13 40 fn_get init (-43), 13 41 fn_getl init (-44), 13 42 fn_putprop init (-45), 13 43 fn_remprop init (-46), 13 44 fn_save init (-47), 13 45 fn_add1 init (-48), 13 46 fn_sub1 init (-49), 13 47 fn_greaterp init (-50), 13 48 fn_lessp init (-51), 13 49 fn_minus init (-52), 13 50 fn_plus init (-53), 13 51 fn_times init (-54), 13 52 fn_difference init (-55), 13 53 fn_quotient init (-56), 13 54 fn_abs init (-57), 13 55 fn_expt init (-58), 13 56 fn_boole init (-59), 13 57 fn_rot init (-60), 13 58 fn_lsh init (-61), 13 59 fn_signp init (-62), 13 60 fn_fix init (-63), 13 61 fn_float init (-64), 13 62 fn_remainder init (-65), 13 63 fn_max init (-66), 13 64 fn_min init (-67), 13 65 fn_add1_fix init (-68), 13 66 fn_add1_flo init (-69), 13 67 fn_sub1_fix init (-70), 13 68 fn_sub1_flo init (-71), 13 69 fn_plus_fix init (-72), 13 70 fn_plus_flo init (-73), 13 71 fn_times_fix init (-74), 13 72 fn_times_flo init (-75), 13 73 fn_diff_fix init (-76), 13 74 fn_diff_flo init (-77), 13 75 fn_quot_fix init (-78), 13 76 fn_quot_flo init (-79), 13 77 fn_eval init (-80), 13 78 fn_apply init (-81), 13 79 fn_prog init (-82), 13 80 fn_errset init (-83), 13 81 fn_catch init (-84), 13 82 fn_throw init (-85), 13 83 fn_store init (-86), 13 84 fn_defun init (-87), 13 85 fn_baktrace init (-88), 13 86 fn_bltarray init (-89), 13 87 fn_star_rearray init (-90), 13 88 fn_gensym init (-91), 13 89 fn_makunbound init (-92), 13 90 fn_boundp init (-93), 13 91 fn_star_status init (-94), 13 92 fn_star_sstatus init (-95), 13 93 fn_freturn init (-96), 13 94 fn_cos init (-97), 13 95 fn_sin init (-98), 13 96 fn_exp init (-99), 13 97 fn_log init (-100), 13 98 fn_sqrt init (-101), 13 99 fn_isqrt init (-102), 13 100 fn_atan init (-103), 13 101 fn_sleep init (-104), 13 102 fn_oddp init (-105), 13 103 fn_tyipeek init (-106), 13 104 fn_alarmclock init (-107), 13 105 fn_plusp init (-108), 13 106 fn_minusp init (-109), 13 107 fn_ls init (-110), 13 108 fn_eql init (-111), 13 109 fn_gt init (-112), 13 110 fn_alphalessp init (-113), 13 111 fn_samepnamep init (-114), 13 112 fn_getchar init (-115), 13 113 fn_opena init (-116), 13 114 fn_sxhash init (-117), 13 115 fn_gcd init (-118), 13 116 fn_allfiles init (-119), 13 117 fn_chrct init (-120), 13 118 fn_close init (-121), 13 119 fn_deletef init (-122), 13 120 fn_eoffn init (-123), 13 121 fn_filepos init (-124), 13 122 fn_inpush init (-125), 13 123 fn_linel init (-126), 13 124 fn_mergef init (-127), 13 125 fn_namelist init (-128), 13 126 fn_names init (-129), 13 127 fn_namestring init (-130), 13 128 fn_openi init (-131), 13 129 fn_openo init (-132), 13 130 fn_prin1 init (-133), 13 131 fn_princ init (-134), 13 132 fn_print init (-135), 13 133 fn_read init (-136), 13 134 fn_readch init (-137), 13 135 fn_readstring init (-138), 13 136 fn_rename init (-139), 13 137 fn_shortnamestring init (-140), 13 138 fn_tyi init (-141), 13 139 fn_setsyntax init (-142), 13 140 fn_cursorpos init (-143), 13 141 fn_force_output init (-144), 13 142 fn_clear_input init (-145), 13 143 fn_random init (-146), 13 144 fn_haulong init (-147), 13 145 fn_haipart init (-148), 13 146 fn_cline init (-149), 13 147 fn_fillarray init (-150), 13 148 fn_listarray init (-151), 13 149 fn_sort init (-152), 13 150 fn_sortcar init (-153), 13 151 fn_zerop init (-154), 13 152 fn_listify init (-155), 13 153 fn_charpos init (-156), 13 154 fn_pagel init (-157), 13 155 fn_linenum init (-158), 13 156 fn_pagenum init (-159), 13 157 fn_endpagefn init (-160), 13 158 fn_arraydims init (-161), 13 159 fn_loadarrays init (-162), 13 160 fn_dumparrays init (-163), 13 161 fn_expt_fix init (-164), 13 162 fn_expt_flo init (-165), 13 163 fn_nointerrupt init (-166), 13 164 fn_open init (-167), 13 165 fn_in init (-168), 13 166 fn_out init (-169), 13 167 fn_truename init (-170), 13 168 fn_ifix init (-171), 13 169 fn_fsc init (-172), 13 170 fn_progv init (-173), 13 171 fn_mapatoms init (-174), 13 172 fn_unwind_protect init (-175), 13 173 fn_eval_when init (-176), 13 174 fn_read_from_string init (-177), 13 175 fn_displace init (-178), 13 176 fn_nth init (-179), 13 177 fn_nthcdr init (-180), 13 178 fn_includef init (-181) 13 179 ) fixed bin static; 13 180 13 181 /* END INCLUDE FILE lisp_name_codes.incl.pl1 */ 34 35 36 37 /* declarations for lisp_unwinder */ 38 39 dcl unwind_to bit(18), /* rel ptr to unmarked pdl, which tells lisp_unwinder 40* how far to unwind the unmarked stack. */ 41 where_to bit(18) aligned, 42 frame_rels(0:6 /* nframeptrs - PL1 compiler bug */ ) bit(18) aligned; /* rel's of the frame_ptrs */ 43 dcl (qt, qb) pointer; 44 45 /* ENTRY POINTS CALLED */ 46 47 dcl lisp_special_fns_$cons ext entry; 48 dcl lisp_fault_handler_$interrupt_poll entry (); 49 dcl lisp_oprs_$xec_unwprot_compiled_handler ext entry; 50 dcl lisp_$eval entry; 51 dcl lisp_$eval_list entry; 52 dcl lisp_$unwind_reversal entry; 53 dcl lisp_error_ entry, unmp ptr; 54 dcl (addr, addrel, null, bit, fixed, ptr, rel) builtin; 55 56 dcl lisp_static_vars_$eval_atom fixed bin (71) external; 57 58 /* general variables */ 59 60 dcl progsw bit(1); /* "1"b = prog, "0"b = do */ 61 /* equivalent to: binding_block.top_block = prog_frame.dat1 + 6, approximately */ 62 dcl p ptr; 63 64 dcl 1 save_masked automatic like masked; 65 66 dcl myname fixed bin; /* name code for too_few_args error signalled by need_arg */ 67 68 dcl stack ptr; 69 dcl top_of_stack ptr; 70 dcl unm ptr; 71 72 dcl (i, n) fixed bin; 73 74 /* 75*/* prog function for lisp */ 76 77 /* prog: entry; */ 78 79 myname = fn_prog; 80 progsw = "1"b; 81 stack = addrel(stack_ptr, -2); 82 stack_ptr = addr(stack -> temp(4)); /* 3 temp cells */ 83 84 /* make sure we have at least one arg - the local variable list */ 85 86 call need_arg; 87 88 /* save old bindings of the local variables */ 89 90 stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* the local - variable list */ 91 local_variables_loop: 92 if stack -> temp(2) = nil then go to rebind; 93 if stack -> temp_ptr(2) -> cons_types.car & Atsym then; /* OK to rebind */ 94 else do; /* unrecoverable error */ 95 stack -> temp(3) = stack -> temp_ptr(2) -> cons.car; 96 unmp = unmkd_ptr; 97 unmkd_ptr = addrel(unmp, 2); 98 unmp -> errcode(1) = bad_bv; 99 call lisp_error_; 100 end; 101 102 p = stack_ptr; 103 stack_ptr = addrel(stack_ptr, 4); /* defend binding block against the vicious 104* onslaught of the garbage collector */ 105 p -> bindings(1).atom = stack -> temp_ptr(2) -> cons.car; 106 p -> bindings(1).old_val = stack -> temp_ptr(2) -> cons_ptrs.car -> atom.value; 107 108 stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; 109 go to local_variables_loop; 110 111 /* now set up a binding_block on the unmarked pdl */ 112 113 rebind: 114 p = unmkd_ptr; 115 unmkd_ptr = addrel(unmkd_ptr, 2); 116 p -> binding_block.bot_block = rel(addr(stack -> temp(4))); /* first binding */ 117 p -> binding_block.top_block = rel(stack_ptr); /* just above last binding */ 118 p -> binding_block.back_ptr = rel(binding_top); 119 p -> binding_block.rev_ptr = ""b; 120 binding_top = p; /* push onto the binding pseudo-pdl */ 121 122 /******** It is now safe to rebind the local variables to nil ********/ 123 124 stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* get local vars list again */ 125 bind_local_vars_to_nil: 126 if stack -> temp(2) = nil then go to mk_frame; 127 stack -> temp_ptr(2) -> cons_ptrs.car -> atom.value = nil; 128 stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; 129 go to bind_local_vars_to_nil; 130 131 mk_frame: 132 call make_prog_frame; 133 /* 134*/* At long last, we are ready to execute the body of the prog */ 135 136 stack -> temp(2), 137 stack -> temp(3) = stack -> temp_ptr(1) -> cons.cdr; /* the body */ 138 139 prog_ex: call xec_body; /* run the body of the prog */ 140 141 prog_end: /* End of the prog reached uneventfully, return nil (unwinding the saved bindings) */ 142 143 stack -> temp(1) = nil; 144 go to prog_ret; 145 146 147 /* go or return comes here with label name or return value and a go/return switch on the stack */ 148 149 go_or_return: 150 151 p = addrel(stack_ptr, -4); /* pick up stuff from stack frame of go or return */ 152 stack = ptr(p, prog_frame -> frame.dat1); 153 stack -> temp(1) = p -> temp(1); /* and copy it down so it won't go away */ 154 155 if p -> temp(2) = nil then do; 156 157 /* GO */ 158 159 stack5 = ptr(stack_ptr, prog_frame -> frame.dat2); 160 161 /* search prog body for label to go to */ 162 163 go_once_more: 164 do stack -> temp(2) = stack -> temp(3) /* scan whole prog body */ 165 repeat(stack -> temp_ptr(2) -> cons.cdr) 166 while (stack -> temp_type(2) = Cons); 167 if stack -> temp_ptr(2) -> cons_types.car then 168 169 /* found a label - see if it's the one we want */ 170 171 if stack -> temp_ptr(2) -> cons.car = stack -> temp(1) then do; 172 unwind_to = rel(addrel(prog_frame, 6)); /* unwind any nested stuff */ 173 call lisp_unwinder; 174 stack_ptr = addr(stack5 -> temp(2)); 175 if progsw then go to prog_ex; /* YES - begin executing at label */ 176 else go to do_ex; 177 end; 178 end; 179 180 /* search failed - barf */ 181 /*** NOTE that at this point the LISP evalframes are still 182* there, for the benefit of clever unseen-go-tag handlers, 183* but the associated Multics stack frames, if any, are not 184* there. So beware - mostly of using freturn or throw. ***/ 185 186 unmp = unmkd_ptr; 187 unmkd_ptr = addrel(unmp, 2); 188 unmp -> errcode(1) = unseen_go_tag; 189 top_of_stack = stack_ptr; 190 stack_ptr = addrel(top_of_stack, 2); 191 top_of_stack -> temp(1) = stack -> temp(1); 192 call lisp_error_; 193 stack -> temp(1) = top_of_stack -> temp(1); /* recovery */ 194 stack_ptr = top_of_stack; 195 go to go_once_more; 196 end; 197 198 /* RETURN */ 199 200 prog_ret: 201 unwind_to = rel(addrel(prog_frame, -2)); /* unwind it all */ 202 call lisp_unwinder; 203 stack_ptr = addr(stack -> temp(2)); 204 xretn: return; 205 206 207 /* common code for do and prog */ 208 209 210 /* create prog frame on the unmarked pdl */ 211 212 make_prog_frame: proc; 213 214 stack4, stack5 = stack_ptr; 215 p = unmkd_ptr; 216 unmkd_ptr = addrel(unmkd_ptr, 6); /***** size of a frame */ 217 p -> frame.ret = go_or_return; 218 p -> frame.prev_frame = rel(prog_frame); 219 p -> frame.stack_ptr = rel(stack4); /* clear the stack if we get unwound */ 220 /* also base of label table */ 221 p -> frame.dat1 = rel(stack); 222 p -> frame.dat2 = rel(stack5); 223 prog_frame = p; /* push onto the stack */ 224 stack_ptr = addr(stack5 -> temp(2)); /* make some room to call eval */ 225 return; 226 end; 227 228 /* routine to execute the body of a prog or do*/ 229 230 xec_body: proc; 231 232 dcl unm ptr; 233 234 unm = unmkd_ptr; 235 unmkd_ptr = addrel(unm, 2); 236 unm -> based_ptr = addr(stack -> temp(2)); /* -> body */ 237 call lisp_$eval_list; /* fast body evaluator */ 238 return; 239 end; 240 /* 241*/* entry point to allow outsiders to call lisp_unwinder. 242* Called with top of unmarked pdl containing ptr to where to unwind to */ 243 244 lisp_unwinder: entry; 245 246 unwind_to = rel( addrel(unmkd_ptr,-2)->based_ptr ); 247 call lisp_unwinder; 248 return; 249 250 251 /* Internal procedure to unwind the unmarked stack down to a specified point (specified by unwind_to) */ 252 253 lisp_unwinder: proc; 254 255 dcl st bit(18); /* rel of stack_ptr, for efficiency */ 256 dcl relp bit(18) aligned; 257 dcl temp_framep ptr; 258 /* convert pointers to rel pointers for easy comparison */ 259 260 set_rel: do i = 0 to nframeptrs; 261 frame_rels(i) = rel(frame_ptrs(i)); 262 end; 263 unm = unmkd_ptr; /* copy this ext static variable */ 264 st = rel(stack_ptr); /* set this in case we unwind nothing */ 265 266 choose: /* find something to unwind */ 267 268 269 where_to = ""b; /* the minimum number */ 270 do i = 0 to nframeptrs; /* find max of the frame_rels */ 271 if frame_rels(i) >= where_to then do; /* can't be = but generates better code than > */ 272 where_to = frame_rels(i); 273 n = i; 274 end; 275 end; 276 277 if where_to = ""b then go to done_unw; /* no more to be unwound */ 278 if where_to < unwind_to 279 then 280 done_unw: do; 281 282 if unwind_to = ""b 283 then do; 284 unm = ptr(unm,""b); 285 unwind_to = rel(unm->stack_seg.unmkd_stack_bottom); /* to bottom of unmkd_stack */ 286 st = rel(unm->stack_seg.marked_stack_bottom); /* to bottom of marked_stack */ 287 end; 288 unmkd_ptr = ptr(unm, unwind_to); /* move unmkd_ptr down */ 289 stack_ptr = ptr(stack_ptr, st); /* move stack_ptr down */ 290 return; 291 end; 292 293 if n = 0 then go to unwind_bindings; /* this is harder to unwind than the others */ 294 else if n = 1 then go to unwind_fault_save; /* .. */ 295 else do; 296 st = frame_ptrs(n) -> frame.stack_ptr; 297 relp = frame_ptrs(n) -> frame.prev_frame; 298 if n = 6 then do; /* Unwind protect */ 299 stack_ptr = ptr (stack_ptr, st); /* Normalize pdls */ 300 temp_framep = unwp_frame; /* Save pointer */ 301 unmkd_ptr = addrel (frame_ptrs (6), size (frame)); 302 if temp_framep -> frame.dat1 = "000000"b3 /* Interpreted unw_prot */ 303 then do; 304 save_masked = masked; 305 string (masked.against) = copy ("1"b, length (string (masked.against))); 306 unwp_frame = ptr (unm, relp); 307 unmkd_ptr = addrel (temp_framep, size (based_ptr)); 308 temp_framep -> based_ptr = addrel (stack_ptr, -2); 309 call lisp_$eval_list; /* Do the exit forms */ 310 masked = save_masked; 311 if lisp_static_vars_$deferred_interrupt 312 then call lisp_fault_handler_$interrupt_poll; 313 end; 314 else call lisp_oprs_$xec_unwprot_compiled_handler; 315 frame_rels (6) = relp; 316 go to choose; 317 end; 318 frame_ptrs(n) = ptr(unm, relp); 319 frame_rels(n) = relp; 320 go to choose; 321 end; 322 323 324 325 unwind_bindings: 326 qt = ptr(stack_ptr, binding_top -> binding_block.top_block); 327 st = binding_top -> binding_block.bot_block; /* put stack_ptr below the bindings */ 328 if st then do; /* normal bb */ 329 qb = ptr(qt, st); 330 do while (qb ^= qt); /* restore bindings to their atoms */ 331 qt = addrel(qt, -4); 332 addr(qt -> bindings(1).atom) -> based_ptr -> atom.value = qt -> bindings(1).old_val; 333 end; 334 binding_top = ptr(binding_top, binding_top -> binding_block.back_ptr); 335 end; 336 else do; /* reversal bb */ 337 call lisp_$unwind_reversal; 338 end; 339 frame_rels(0) = (rel(binding_top)); 340 go to choose; 341 342 343 /* routine to unwind through a user interrupt */ 344 345 unwind_fault_save: 346 st = err_recp -> fault_save.stack_ptr; 347 gc_inhibit = err_recp -> fault_save.sv_gc_inhibit; 348 call lisp_fault_handler_$set_mask((err_recp -> fault_save.sv_masked)); 349 unspec(ptr(unmkd_ptr, ""b) -> stack_seg.array_info_for_store) = unspec(err_recp -> fault_save.sv_array_info); 350 ptr(unmkd_ptr, ""b) -> stack_seg.array_offset_for_store = err_recp -> fault_save.sv_array_offset; 351 rdr_label = err_recp -> fault_save.sv_rdr_label; 352 rdr_state = err_recp -> fault_save.sv_rdr_state; 353 rdr_ptr = err_recp -> fault_save.sv_rdr_ptr; 354 err_recp = ptr(err_recp, err_recp -> fault_save.prev_frame); 355 frame_rels(1) = rel(err_recp); 356 go to choose; 357 358 end lisp_unwinder; 359 /* 360*/* this is the lisp errset funtion, which traps errors */ 361 362 errset: entry; 363 364 stack = addrel(stack_ptr, -2); 365 366 /* get our argument, which we will eval after setting up an err_frame */ 367 368 myname = fn_errset; 369 call need_arg; 370 371 /* set up an err_frame in the unmarked pdl */ 372 373 p = unmkd_ptr; 374 unmkd_ptr = addrel(unmkd_ptr, 6); /***** size of a frame */ 375 p -> frame.ret = error_return; /* where to come back to if error */ 376 p -> frame.stack_ptr = rel(stack_ptr); 377 p -> frame.prev_frame = rel(err_frame); 378 p -> frame.dat2 = "0"b; /* "1"b means err with non-nil 2nd arg */ 379 380 /* set frame.dat1 to reflect whether caller wants error messages suppressed */ 381 382 p -> frame.dat1 = "0"b; /* assume he wants err msgs */ 383 if stack -> temp_ptr(1) -> cons.cdr = nil | stack -> temp_ptr(1) -> cons_types.cdr then; 384 else if stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car = nil 385 then p -> frame.dat1 = "1"b; /* 2nd arg nil ---> suppress err msgs */ 386 err_frame = p; /* NOW push frame onto pdl */ 387 388 stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* arg is ready to give to eval */ 389 call lisp_$eval; /* evaluate the arg */ 390 391 /* if we get this far, there was no error */ 392 393 err_frame = ptr(err_frame, p -> frame.prev_frame); /* particularly easy to unwind */ 394 unmkd_ptr = p; 395 stack_ptr = addrel(stack_ptr, 2); /* set up to call to cons */ 396 addrel(stack_ptr, -2) -> temp(1) = nil; /* return list of result of our arg */ 397 call lisp_special_fns_$cons; 398 return; 399 400 401 /* come here if an error occurs */ 402 403 error_return: 404 405 stack = addrel(ptr(stack_ptr, err_frame -> frame.stack_ptr), -2); 406 stack -> temp(1) = addrel(stack_ptr, -2) -> temp(1); /* pick up value to return */ 407 unwind_to = rel(err_frame); /* unwind back to & including our errset frame */ 408 if err_frame -> frame.dat2 then do; /* unwind before eval -- err with non-nil 2nd arg */ 409 call lisp_unwinder; 410 call lisp_$eval; 411 end; 412 else call lisp_unwinder; /* already been evaled */ 413 return; 414 415 416 /* 417* 418*/* Catch and Throw */ 419 420 /* Catch and throw have been extended to include "catch labels." 421* * If they are called with a second argument, then the unevaluated 422* * second argument, which is usually an atom, "labels" the catch 423* * so that a throw with a second argument _e_q to the second argument 424* * to that catch will throw back to that catch in spite of any 425* * intervening catches. If the second argument is omitted, catch 426* * catches any throw and throw throws to the most recent 427* * catch. Catch evaluates its first argument, and if a throw 428* * occurs, the evaluated first argument to throw is returned 429* * as the result of the catch, otherwise the evaluated first 430* * argument to catch is returned. Example of catch labels.: 431* * (catch (progn (catch (throw 't foo) bar) (print 'foobar)) foo) 432* * would not print foobar since the throw throws back through 433* * the progn all the way out to the outer catch. The value 434* * of the expression would be t. 435* */ 436 437 438 catch: entry; 439 440 /* first find out how many args we have and make sure it is 1 or 2 */ 441 442 stack = addrel(stack_ptr, -2); /* Is an fsubr */ 443 myname = fn_catch; 444 call need_arg; 445 stack_ptr = addr(stack -> temp(3)); /* get 2 cells instead of one */ 446 stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* save first arg */ 447 448 /* check for a second arg */ 449 450 if stack -> temp_ptr(1) -> cons.cdr = nil | stack -> temp_ptr(1) -> cons_types.cdr 451 then stack -> temp_type36(1) = Numeric36; /* no second arg -- use this cruft */ 452 /* which can "never" appear in a list 453* but won't screw up the g.c. */ 454 else stack -> temp(1) = stack -> temp_ptr(1) -> cons_ptrs.cdr -> cons.car; /* use given 2nd arg */ 455 456 /* set up a catch frame */ 457 458 p = unmkd_ptr; 459 unmkd_ptr = addrel(unmkd_ptr, 6); /***** size of a frame */ 460 p -> frame.ret = catch_return; /* if we get thrown to */ 461 p -> frame.prev_frame = rel(catch_frame); 462 p -> frame.stack_ptr = rel(addr(stack -> temp(2))); /* leaving catch-label and junk on stack */ 463 catch_frame = p; /* push onto pdl */ 464 465 /* eval the first arg */ 466 467 call lisp_$eval; 468 469 /* normal return -- return (eval 1st_arg) */ 470 471 stack -> temp(1) = stack -> temp(2); /* move down the value to be returned */ 472 473 uncatch: unwind_to = rel(catch_frame); /* unwind back through our catch frame */ 474 call lisp_unwinder; 475 return; 476 477 478 catch_return: 479 480 /* unwind and return the evaluated first arg of throw */ 481 482 addrel(ptr(stack_ptr, catch_frame -> frame.stack_ptr), -2) -> temp(1) = 483 addrel(stack_ptr, -4) -> temp(2); /* move result down so we can return it */ 484 go to uncatch; /* unwind & return */ 485 486 /* 487*/* the throw function throws its evaluated first arg back to the most recent catch whose 488* second arg was _e_q to the second arg of throw */ 489 490 throw: entry; 491 492 stack = addrel(stack_ptr, -2); 493 stack_ptr = addr(stack -> temp(3)); 494 495 /* eval our first arg */ 496 497 myname = fn_throw; 498 call need_arg; 499 stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* get first arg */ 500 stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* save rest of arg-list */ 501 call lisp_$eval; /* eval our first arg and leave it on 502* the stack where catch_return can find it */ 503 504 505 /* see if we have a second arg */ 506 507 if stack -> temp(1) = nil | stack -> temp_type(1) then do; 508 /* no, find most recent catch */ 509 p = catch_frame; 510 if rel(p) then go to throw1; 511 else go to bad_throw_uu; /* error - no catch_frame */ 512 end; 513 else stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* yes -- use it as catch label */ 514 515 /* search for a catch frame for this label */ 516 517 throw_retry: 518 p = catch_frame; 519 catch_search: 520 if rel(p) = "0"b then go to bad_throw; /* exhausted stack without finding place to throw to */ 521 522 qb = addrel(ptr(stack_ptr, p -> frame.stack_ptr), -2); 523 if qb -> temp(1) = stack -> temp(1) then go to throw1; 524 if qb -> temp_type36(1) = Numeric36 then do; /* an unlabeled catch */ 525 throw1: /* found the catch to throw back to */ 526 527 catch_frame = p; /* discard any intervening catches */ 528 go to p -> frame.ret; /* unwind pl1 stack back to catch_return, 529* which will do the rest */ 530 end; 531 p = ptr(p, p -> frame.prev_frame); /* keep searching back */ 532 go to catch_search; 533 534 535 bad_throw_uu: 536 unspec(stack -> temp(1)) = Undefined; 537 /* inform lisp_error_ that there was no throw-label given */ 538 539 bad_throw: /* tried to throw but there was no corresponding catch */ 540 541 unmp = unmkd_ptr; 542 unmkd_ptr = addrel(unmp, 2); 543 unmp -> errcode(1) = throw_to_no_catch; 544 stack_ptr = addr(stack -> temp(4)); 545 stack -> temp(3) = stack -> temp(1); /* throw tag */ 546 call lisp_error_; 547 stack -> temp(1) = stack -> temp(3); /* replacement value */ 548 go to throw_retry; 549 550 /* 551**/ 552 553 /* Lisp unwind-protect: borrowed from Lisp Machine, BSG 09/09/78 */ 554 555 unwind_protect: 556 entry; 557 558 559 myname = fn_unwind_protect; 560 stack = addrel (stack_ptr, -2); 561 call need_arg; 562 stack_ptr = addr (stack -> temp (4)); 563 stack -> temp (3) = stack -> temp_ptr (1) -> cons.car; /* thing to eval */ 564 stack -> temp (2) = stack -> temp_ptr (1) -> cons.cdr; /* exit list */ 565 566 /* stack (1) is for return result */ 567 /* Set up a unwp frame */ 568 569 p = unmkd_ptr; 570 unmkd_ptr = addrel (unmkd_ptr, 6); 571 p -> frame.prev_frame = rel (unwp_frame); 572 p -> frame.stack_ptr = rel (addr (stack -> temp (3))); 573 p -> frame.dat1 = "000000"b3; /* No compiled exit. */ 574 unwp_frame = p; 575 576 /* Eval the first arg. */ 577 578 call lisp_$eval; 579 580 stack -> temp (1) = stack -> temp (3); /* Save the result */ 581 unwind_to = rel (unwp_frame); /* Set unwind point */ 582 call lisp_unwinder; /* Will eval the exit forms, pop the pdls */ 583 stack_ptr = addr (stack -> temp (2)); /* Set to return result */ 584 return; 585 /* */ 586 /* entry to unwind the stack following a call to lisp_err_ */ 587 588 /* the stack is unwound until an errset is found. If there is none, return to top level */ 589 590 lisp_err: entry(err_fcn_f); 591 592 dcl err_fcn_f bit(1) aligned parameter; /* "1"b means errset value on stack */ 593 594 if ^err_fcn_f then do; 595 stack_ptr = addrel(stack_ptr, 2); /* force errset to return nil */ 596 addrel(stack_ptr, -2) -> temp(1) = nil; 597 end; 598 599 process_error: 600 601 if rel(err_frame) then 602 /* there is an err_frame to return to */ 603 go to err_frame -> frame.ret; /* the errset routine will do the rest */ 604 else; /* no errset - unwind all the way and return to top level */ 605 606 /* copy value of errlist before unbinding */ 607 addr(lisp_static_vars_$SLASH) -> based_ptr -> atom.value = addr(lisp_static_vars_$errlist) -> based_ptr -> atom.value; 608 unwind_to = ""b; 609 call lisp_unwinder; 610 go to lisp_static_vars_$top_level; /* return to the top-level read-eval-print loop */ 611 612 /* 613*/* lisp do function */ 614 615 do: entry; 616 617 progsw = "0"b; 618 dcl (stack2, stack3, stack4, stack5) ptr, /* -> various places in marked stack */ 619 prog_with_initial_values bit(1); /* flag for (do (...) nil ...) */ 620 621 /* 622* written by Alex Sunguroff 6/72 623* rewritten by David Moon 9-JUN-72 for new stack discipline, new pointer format, and v2pl1 compiler 624* quick fix of bug introduced 9-JUN-72, made 17-MAY-73 by DAM. 625* prog-with-initial-values feature put in 16 Oct 1973 by DAM 626**/ 627 /* a pictorial exposition of the data stored on the stacks by do */ 628 /* 629* MARKED PDL UNMARKED PDL 630* 631* ______________________________ ______________________________ 632* | | | | 633*stack -> | argument list | | | 634* | | | | 635* | scanning pointer | | | 636* | | binding_top ->|-----------------------------| 637* | body of the do | | rel(stack4) | rel(stack3) | - boundaries of saved bindings 638* | | |-------------|---------------| 639* | endtest | | thread | 0 | 640* | | |-------------|---------------| 641* | return value list | | | 642* |-----------------------------| | | 643*stack2 -> | (indices information) | prog_frame ->|-----------------------------| 644* | | | | 645* |- - - - - - - - - - - - - - -| | ret = do_control_return | 646* | index atom | | | 647* | initial value | | | 648* | stepper | |-----------------------------| 649* |- - - - - - - - - - - - - - -| | thread | rel(stack4) | - to wipe out the stack 650* | . | |-----------------------------| 651* | . | | rel(stack) | rel(stack5) | - boundary of label table 652* | . | |-----------------------------| 653* | | | | 654* |-----------------------------| | | 655*stack3 -> | (saved bindings of indices)| 656* | | 657* |- - - - - - - - - - - - - - -| 658* | atom | 659* | value | 660* |- - - - - - - - - - - - - - -| 661* | . | 662* | . | 663* | . | 664*stack4 -> |-----------------------------| 665*stack5 -> | -> thing being evaled | 666* |-----------------------------| 667*stack_ptr-> | 668* | | 669* | | 670**/ 671 672 673 674 675 676 677 myname = fn_do; 678 stack = addrel(stack_ptr, -2); /* fsubr */ 679 call need_arg; 680 stack_ptr = addr(stack -> temp(6)); /* protect temp(1:5) */ 681 682 stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* get the first element of the arg list */ 683 stack2, stack3 = addr(stack -> temp(6)); /* initialize these pointers*/ 684 685 686 if stack -> temp_type36(2) & Atsym36 then do; /* if the first element of the argument list is 687* atomic, then this is an old style do group */ 688 prog_with_initial_values = "0"b; /* clear flag for funny do */ 689 if stack -> temp(2) = nil then go to new_type_do_join; /* nil is a list in this context */ 690 stack_ptr,stack3 = addr(stack2 -> temp(4)); 691 stack2 -> temp(1) = stack -> temp(2); /* remember the index atom */ 692 693 stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* shorten the arg list */ 694 call need_arg; 695 696 stack2 -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* place the initial value here */ 697 698 stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* shorten the arg list */ 699 call need_arg; 700 701 stack2 -> temp(3) = stack -> temp_ptr(1) -> cons.car; /*place the stepper function here */ 702 703 stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /*shorten the arg list */ 704 call need_arg; 705 706 stack -> temp(4) = stack -> temp_ptr(1) -> cons.car; /*place the endtest here */ 707 stack4, stack_ptr = addr(stack3 -> temp(3)); 708 stack3 -> bindings(1).atom = stack2 -> temp(1); 709 stack3 -> bindings(1).old_val = stack2 -> temp_ptr(1) -> atom.value; 710 stack -> temp(5) = nil; /* return value is nil */ 711 go to common_do_code; /*proceed to where both forms are handled similarly */ 712 end; 713 714 715 do while(stack -> temp(2) ^= nil); /* this do group takes the list of indeces 716* where each element of the list has the form: (x xinit xstepper) 717* and where xinit and xstepper may be ommitted and places those 718* three elements on the stack and binds the oldvalue of x */ 719 if stack -> temp_type(2) then go to bad_form_do; /*error if not a list */ 720 stack_ptr = addr(stack3 -> temp(4)); /* get room for another index table entry */ 721 722 stack3 -> temp(3) = stack -> temp_ptr(2) ->cons.car; /*place the list containing the information 723* about the next index here */ 724 if stack3 -> temp(3) = nil then go to bad_form_do; /* this requires that there be at least a list of x*/ 725 if stack3 -> temp_type(3) then go to bad_form_do; 726 727 stack3 -> temp(1) = stack3 -> temp_ptr(3) -> cons.car; /*place the index here*/ 728 729 stack3 -> temp(3) = stack3 -> temp_ptr(3) -> cons.cdr; /*shorten the list */ 730 if stack3 -> temp(3) = nil then do; /*if the xinit and xstepper have been ommited then initialze 731* to nil and don't step it*/ 732 stack3 -> temp(2) = nil; /*set to nil */ 733 stack3 -> temp(3) = stack3 -> temp(1); /* make stepping be a no-op */ 734 end; 735 else do; /*if there is an xinit */ 736 if stack3 -> temp_type(3) then go to bad_form_do; 737 stack3 -> temp(2) = stack3 -> temp_ptr(3) -> cons.car; /*place the xinit here */ 738 stack3 -> temp(3) = stack3 -> temp_ptr(3) -> cons.cdr; /*shorten the list*/ 739 if stack3 -> temp(3) = nil then 740 stack3 -> temp(3) = stack3 -> temp(1); /* keep it from stepping */ 741 else do; 742 if stack3 -> temp_type(3) then go to bad_form_do; 743 stack3 -> temp(3) = stack3 -> temp_ptr(3) -> cons.car; /*place xstepper here */ 744 end; 745 end; 746 stack3 = addr(stack3 -> temp(4)); /*move up 3 locations and look for another index*/ 747 stack -> temp(2) = stack -> temp_ptr(2) -> cons.cdr; /*shorten the index list*/ 748 end; 749 750 new_type_do_join: 751 /* now save the bindings of the indices */ 752 753 stack4 = stack3; 754 stack5 = stack2; 755 do while (stack5 ^= stack3); 756 /* scan through the index table */ 757 stack_ptr = addr(stack4 -> temp(3)); /* make room */ 758 stack4 -> bindings(1).atom = stack5 -> temp(1); 759 stack4 -> bindings(1).old_val = stack5 -> temp_ptr(1) -> atom.value; 760 stack4 = stack_ptr; 761 stack5 = addr(stack5 -> temp(4)); 762 end; 763 764 765 /* the following routine takes the endtest and the return 766* value and puts them on the stack for later use */ 767 stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; /* shorten the arg list */ 768 call need_arg; 769 stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /*place the list of endtest and return-value here */ 770 if stack -> temp(2) = nil then /* we allow endtest,retval to be omitted */ 771 prog_with_initial_values = "1"b; /* set flag to remember no endtest, do once only */ 772 else if stack -> temp_type(2) then go to bad_form_do; 773 else do; 774 prog_with_initial_values = "0"b; /* not special funny do */ 775 stack -> temp(4) = stack -> temp_ptr(2) -> cons.car; /*put the endtest here*/ 776 stack -> temp(5) = stack -> temp_ptr(2) -> cons.cdr; /* save the list of retval forms */ 777 end; 778 779 common_do_code: /*from here both styles of do share the code*/ 780 stack -> temp(1), stack -> temp(2), stack-> temp(3) = stack -> temp_ptr(1) -> cons.cdr; /*dobody*/ 781 782 /* construct binding block */ 783 784 p = unmkd_ptr; 785 unmkd_ptr = addrel(unmkd_ptr, 2); 786 p -> binding_block.bot_block = rel(stack3); 787 p -> binding_block.top_block = rel(stack4); 788 p -> binding_block.back_ptr = rel(binding_top); 789 p -> binding_block.rev_ptr = ""b; 790 binding_top = p; 791 stack_ptr = addr(stack4 -> temp(2)); /* room to call eval */ 792 stack5 = stack2; 793 do while(stack5 ^= stack3); 794 /*scan up the stack evaling the initial values*/ 795 stack4 -> temp(1) = stack5 -> temp(2); /*put the initial value at top of stack*/ 796 call lisp_$eval; /*and eval it*/ 797 stack5 -> temp(2) = stack4 -> temp(1); /* save value of initial value */ 798 stack5 = addr(stack5 -> temp(4)); 799 end; 800 801 stack_ptr = stack4; /* give back the one cell we took */ 802 stack5 = stack2; 803 do while(stack5 ^= stack3); /* rescan, set indices */ 804 stack5 -> temp_ptr(1) -> atom.value = stack5 -> temp(2); 805 stack5 = addr(stack5 -> temp(4)); 806 end; 807 808 call make_prog_frame; 809 810 do_loop: /*this is the iteration of the execution of the do*/ 811 if prog_with_initial_values then go to do_ex_0; /* if funny do, skip end test */ 812 stack5 -> temp(1) = stack -> temp(4); /*pull in the endtest function*/ 813 call lisp_$eval; /*and eval it*/ 814 if stack5 -> temp(1) ^= nil then do; /*this detects if the predicate is true and terminates the 815* the do. Note that an endtest function of nil won't stop*/ 816 stack5 -> temp(1) = nil; /* in case this do-while gets done 0 times */ 817 do while (stack -> temp_type(5) = Cons); /* evaluate the forms in the retval list */ 818 stack5 -> temp(1) = stack -> temp_ptr(5) -> cons.car; 819 call lisp_$eval; 820 stack -> temp(5) = stack -> temp_ptr(5) -> cons.cdr; 821 end; 822 stack -> temp(1) = stack5 -> temp(1); /*put value of last one where it can be returned*/ 823 go to prog_ret; /* unwind it all... */ 824 end; 825 826 do_ex_0: stack -> temp(2) = stack -> temp(3); /*get the complete do-body again*/ 827 828 do_ex: call xec_body; /* execute the body of the do */ 829 if prog_with_initial_values /* if no repeating, then we are done */ 830 then go to prog_end; 831 832 stack4 = stack2; 833 do while(stack4 ^= stack3); 834 /* eval the stepping functions */ 835 stack5 -> temp(1) = stack4 -> temp(3); /*get the stepping function*/ 836 call lisp_$eval; /*and eval it*/ 837 stack4 -> temp(2) = stack5 -> temp(1); /* and save it */ 838 stack4 = addr(stack4 -> temp(4)); 839 end; 840 841 /* scan through again giving the indices their new values */ 842 843 stack4 = stack2; 844 do while (stack4 ^= stack3); 845 stack4 -> temp_ptr(1) -> atom.value = stack4 -> temp(2); /*give the new value*/ 846 stack4 = addr(stack4 -> temp(4)); 847 end; 848 849 go to do_loop; 850 851 bad_form_do: /* gi1e a wrong-type-arg uncorrectable error */ 852 unmp = unmkd_ptr; 853 unmkd_ptr = addrel(unmp, 2); 854 unmp -> errcode(1) = bad_do_format; 855 stack_ptr = addr(stack -> temp(2)); /* barf at original form */ 856 call lisp_error_; /* never returns */ 857 858 need_arg: proc; /* proc to make sure we have an arg */ 859 860 if stack -> temp(1) = nil then go to no_arg; 861 if stack -> temp_type(1) then go to no_arg; 862 return; /* ...if no problems */ 863 864 no_arg: unmp = unmkd_ptr; 865 unmkd_ptr = addrel(unmp, 2); 866 unmp -> errcode(1) = too_few_args; 867 unmp -> errcode(2) = myname; 868 stack_ptr = addr(stack -> temp(2)); /* unrecoverable */ 869 call lisp_error_; /* requires replacement form to eval */ 870 go to xretn; 871 end; 872 873 874 875 /* the lisp break function */ 876 877 break: entry; 878 879 dcl lisp_print_$type_string entry(char(*)aligned), 880 lisp_print_$type_nl entry, 881 iox_$user_output external ptr, 882 iox_$put_chars entry(ptr, ptr, fixed bin(21), fixed bin(35)), 883 iox_status fixed bin(35), 884 lisp_static_vars_$dollar_p_atom fixed bin(71) aligned external, 885 dollar_p_atom fixed bin(71) aligned def (lisp_static_vars_$dollar_p_atom), 886 1 unmask aligned like masked, 887 lisp_static_vars_$return_atom external fixed binary (71) aligned, 888 return_atom fixed bin(71) aligned def (lisp_static_vars_$return_atom), 889 lisp_static_vars_$print_atom fixed bin(71) external, 890 lisp_static_vars_$prin1_atom fixed bin(71) external, 891 lisp_special_fns_$ncons entry, 892 lisp_$apply entry, 893 lisp_reader_$read entry; 894 895 stack = addrel(stack_ptr, -2); /* fsubr */ 896 stack_ptr = addr(stack -> temp(4)); 897 stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; /* bkpt identifier */ 898 stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; 899 if stack->temp(1) = nil then go to break_for_sure; 900 stack -> temp(3) = stack -> temp_ptr(1) -> cons.car; /* predicate */ 901 stack -> temp(1) = stack -> temp_ptr(1) -> cons.cdr; 902 if stack -> temp(1) ^= nil then 903 stack -> temp(1) = stack -> temp_ptr(1) -> cons.car; /* return value */ 904 call lisp_$eval; 905 if stack -> temp(3) = nil then go to breakxe; /* don't break if predicate evals to nil */ 906 break_for_sure: 907 unm = unmkd_ptr; /* going to put a binding block and */ 908 unmkd_ptr = addrel(unm, 8+size(fault_save)); /* an errset frame on the unmarked pdl */ 909 /* and a fault_save to save rdr_state */ 910 stack_ptr = addr(stack -> temp(11)); 911 912 /* save ^q, ^r, and ^w and reset them to nil */ 913 914 stack -> temp(4) = ctrlQ; 915 stack -> temp(3) = stack -> temp_ptr(4) -> atom.value; 916 stack -> temp(6) = ctrlW; 917 stack -> temp(5) = stack -> temp_ptr(6) -> atom.value; 918 stack -> temp(8) = ctrlR; 919 stack -> temp(7) = stack -> temp_ptr(8) -> atom.value; 920 unm -> binding_block.top_block = rel(addr(stack -> temp(9))); 921 unm -> binding_block.bot_block = rel(addr(stack -> temp(3))); 922 unm -> binding_block.rev_ptr = ""b; 923 unm -> binding_block.back_ptr = rel(binding_top); 924 binding_top = unm; 925 unm = addrel(unm, 2); 926 stack -> temp_ptr(4) -> atom.value , 927 stack -> temp_ptr(6) -> atom.value , 928 stack -> temp_ptr(8) -> atom.value = nil; 929 930 /* construct an errset frame so errors won't leave our read-eval-print loop */ 931 932 unm -> frame.ret = break_err; 933 unm -> frame.stack_ptr = rel(addr(stack -> temp(9))); 934 unm -> frame.prev_frame = rel(err_frame); 935 unm -> frame.dat1, unm -> frame.dat2 = ""b; 936 err_frame = unm; 937 unm = addrel(unm, 6); 938 939 /* save rdr_state */ 940 941 unm -> fault_save.prev_frame = rel(err_recp); 942 unm -> fault_save.stack_ptr = rel(stack_ptr); 943 unm -> fault_save.sv_gc_inhibit = lisp_static_vars_$garbage_collect_inhibit; 944 unm -> fault_save.sv_masked = lisp_static_vars_$masked; 945 unm -> fault_save.code1 = 0; /* not due to an error */ 946 unm -> fault_save.sv_array_info = null; 947 unm -> fault_save.sv_array_offset = 0; 948 unm -> fault_save.sv_rdr_label = rdr_label; 949 unm -> fault_save.sv_rdr_ptr = rdr_ptr; 950 unm -> fault_save.sv_rdr_state = rdr_state; 951 err_recp = unm; 952 rdr_state = 0; /* get to tty */ 953 954 /* now identify the break */ 955 956 call lisp_print_$type_string(" 957 ;bkpt "); 958 stack -> temp(10) = stack -> temp(2); /* our first arg */ 959 if addr(lisp_static_vars_$prin1_atom) -> based_ptr->atom.value = 0 | addr(lisp_static_vars_$prin1_atom) -> based_ptr->atom.value = nil 960 then stack -> temp(9) = lisp_static_vars_$prin1_atom; 961 else stack -> temp(9) = addr(lisp_static_vars_$prin1_atom)->based_ptr->atom.value; 962 call lisp_special_fns_$ncons; 963 call lisp_$apply; 964 call lisp_print_$type_nl; 965 go to reset_read; 966 967 /* read-eval-print loop */ 968 969 break_rdnext: 970 if pending_ctrl then do; 971 string(unmask.against) = ""b; 972 call lisp_fault_handler_$set_mask(unmask); /* if more ctrl chars stacked up, do them */ 973 end; 974 go to tty_join_in; 975 976 r_e_p_loop: /* here is where the read-eval-print loop repeats */ 977 978 addr(PLUS)->based_ptr -> atom.value = addr(MINUS)->based_ptr -> atom.value; 979 if addr(ctrlQ)->based_ptr -> atom.value = nil 980 then do; /* comments are in lisp.pl1 */ 981 982 tty_loop: call lisp_print_$type_nl; 983 tty_join_in: stack_ptr = addr(stack -> temp(10)); 984 addr(stack -> temp(9)) -> fixnum_fmt.type_info = fixnum_type; 985 addr(stack -> temp(9)) -> fixedb = 0; 986 call lisp_reader_$read; 987 end; 988 else do; 989 990 uread_loop: stack_ptr = addr(stack -> temp(11)); 991 addr(stack -> temp(10)) -> fixnum_fmt.type_info = fixnum_type; 992 addr(stack -> temp(10)) -> fixedb = -2; 993 addr(stack -> temp(9)) -> flonum_fmt.type_info = flonum_type; 994 addr(stack -> temp(9)) -> fixedb = 0; 995 call lisp_reader_$read; 996 if addr(stack->temp(9)) -> flonum_fmt.type_info = flonum_type 997 then if addr(stack->temp(9)) -> fixedb = 0 998 then go to tty_loop; 999 end; 1000 addr(MINUS)->based_ptr -> atom.value = stack -> temp(9); 1001 if stack -> temp(9) = dollar_p_atom then go to breakwxe; /* $p exits the break */ 1002 if stack -> temp_type(9) then; 1003 else if stack -> temp_ptr(9) -> cons.car = return_atom then do; /* (return val) exits 1004* the break with a value */ 1005 stack -> temp(1) = stack -> temp_ptr(9) -> cons_ptrs.cdr -> cons.car; /* get val */ 1006 go to breakwxe; 1007 end; 1008 call lisp_$eval; 1009 addr(STAR)->based_ptr -> atom.value = stack -> temp(9); 1010 stack_ptr = addr(stack -> temp(11)); 1011 stack -> temp(10) = stack -> temp(9); 1012 stack -> temp(9) = lisp_static_vars_$print_atom; 1013 call lisp_special_fns_$ncons; 1014 call lisp_$apply; 1015 go to r_e_p_loop; 1016 1017 /* error caught by an errset - return to read-eval-print loop */ 1018 1019 break_err: 1020 unwind_to = rel(addrel(err_frame, 6+size(fault_save))); 1021 call lisp_unwinder; 1022 stack_ptr = addr(stack -> temp(10)); 1023 call iox_$put_chars(iox_$user_output, addr(bell), 1, iox_status); 1024 dcl bell char(1) static options(constant) init(""); 1025 addr(ctrlQ) -> based_ptr -> atom.value = nil; /* get back to console input */ 1026 1027 /* reset the reader's tty buffer */ 1028 dcl lisp_io_control_$clear_input entry, 1029 1 iochan based aligned, 1030 2 ioindex fixed bin(35), 1031 2 iolength fixed bin (35); /* rest of structure not declared here since not needed */ 1032 1033 reset_read: 1034 stack -> temp(9) = nil; /* flush buffered input from tty */ 1035 call lisp_io_control_$clear_input; /* = lisp (clear-input nil) */ 1036 rdr_state = 0; 1037 go to break_rdnext; 1038 1039 1040 breakwxe: unwind_to = rel(binding_top); /* unwind it all */ 1041 call lisp_unwinder; 1042 breakxe: stack_ptr = addr(stack -> temp(2)); 1043 call lisp_$eval; /* eval return value */ 1044 return; 1045 1046 1047 1048 progv: entry; 1049 1050 myname = fn_progv; 1051 stack = addrel(stack_ptr,-2); 1052 stack_ptr = addr(stack->temp(3)); 1053 stack->temp(2) = stack->temp_ptr(1)->cons.car; 1054 stack->temp(1) = stack->temp_ptr(1)->cons.cdr; 1055 call lisp_$eval; 1056 stack_ptr = addr(stack->temp(4)); 1057 stack->temp(3) = stack->temp_ptr(1)->cons.car; 1058 stack->temp(1) = stack->temp_ptr(1)->cons.cdr; 1059 call lisp_$eval; 1060 1061 /* now build a binding block, saving all old values */ 1062 1063 do while(stack->temp(2)^=nil); 1064 1065 p = stack_ptr; 1066 stack_ptr = addrel(p,4); 1067 p->bindings(1).atom = stack->temp_ptr(2)->cons.car; 1068 p->bindings(1).old_val = stack->temp_ptr(2)->cons_ptrs.car->atom.value; 1069 stack->temp(2) = stack->temp_ptr(2)->cons.cdr; 1070 end; 1071 1072 p = unmkd_ptr; 1073 unmkd_ptr = addrel(p,2); 1074 p->binding_block.bot_block = rel(addr(stack->temp(4))); 1075 p->binding_block.top_block = rel(stack_ptr); 1076 p->binding_block.back_ptr = rel(binding_top); 1077 p->binding_block.rev_ptr = ""b; 1078 binding_top = p; 1079 1080 /* now binding block has been made, set atoms to new values */ 1081 1082 p = addr(stack->temp(4)); 1083 do while(p^=stack_ptr & stack->temp(3)^=nil); /* scan supplied values */ 1084 addr(p->bindings(1).atom)->based_ptr->atom.value = stack->temp_ptr(3)->cons.car; 1085 stack->temp(3) = stack->temp_ptr(3)->cons.cdr; 1086 p = addrel(p,4); 1087 end; 1088 do while(p^=stack_ptr); /* fill in rest with nil */ 1089 addr(p->bindings(1).atom)->based_ptr->atom.value = nil; 1090 p = addrel(p,4); 1091 end; 1092 1093 p = stack_ptr; 1094 stack_ptr = addr(p->temp(2)); 1095 do while(stack->temp(1)^=nil); /* evaluate body */ 1096 p->temp(1) = stack->temp_ptr(1)->cons.car; 1097 stack->temp(1) = stack->temp_ptr(1)->cons.cdr; 1098 call lisp_$eval; 1099 end; 1100 stack->temp(1) = p->temp(1); 1101 unwind_to = rel(binding_top); 1102 call lisp_unwinder; 1103 stack_ptr = addr(stack->temp(2)); 1104 return; 1105 1106 /* eval-when -- BSG 4/26/80 */ 1107 1108 eval_when: 1109 entry; 1110 1111 myname = fn_eval_when; 1112 stack = addrel (stack_ptr, -2); /* fsubr, gets 1 arg */ 1113 call need_arg; 1114 stack_ptr = addrel (stack, 4); /* need a temp */ 1115 stack -> temp(2) = stack -> temp_ptr(1) -> cons.cdr; /* save forms */ 1116 do stack -> temp(1) = stack -> temp_ptr(1) -> cons.car /* get test list */ 1117 repeat (stack -> temp_ptr(1) -> cons.cdr) 1118 while (stack -> temp_type(1) = Cons); 1119 if stack -> temp_ptr(1) -> cons.car = lisp_static_vars_$eval_atom then do; 1120 call xec_body; 1121 stack -> temp(1) = lisp_static_vars_$t_atom; 1122 stack_ptr = addr (stack -> temp(2)); 1123 return; 1124 end; 1125 end; 1126 stack -> temp(1) = lisp_static_vars_$nil; 1127 stack_ptr = addr (stack -> temp(2)); 1128 return; 1129 end; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 06/29/83 1542.4 lisp_prog_fns_.pl1 >special_ldd>on>06/27/83>lisp_prog_fns_.pl1 22 1 03/27/82 0437.0 lisp_control_chars.incl.pl1 >ldd>include>lisp_control_chars.incl.pl1 23 2 06/29/83 1425.3 lisp_stack_seg.incl.pl1 >ldd>include>lisp_stack_seg.incl.pl1 24 3 03/27/82 0437.0 lisp_nums.incl.pl1 >ldd>include>lisp_nums.incl.pl1 25 4 03/27/82 0437.0 lisp_stack_fmt.incl.pl1 >ldd>include>lisp_stack_fmt.incl.pl1 26 5 03/27/82 0437.0 lisp_faults.incl.pl1 >ldd>include>lisp_faults.incl.pl1 27 6 03/27/82 0436.9 lisp_unmkd_pdl.incl.pl1 >ldd>include>lisp_unmkd_pdl.incl.pl1 28 7 03/27/82 0437.0 lisp_ptr_fmt.incl.pl1 >ldd>include>lisp_ptr_fmt.incl.pl1 29 8 03/27/82 0437.0 lisp_initial_atoms.incl.pl1 >ldd>include>lisp_initial_atoms.incl.pl1 30 9 03/27/82 0437.0 lisp_common_vars.incl.pl1 >ldd>include>lisp_common_vars.incl.pl1 31 10 03/27/82 0437.0 lisp_cons_fmt.incl.pl1 >ldd>include>lisp_cons_fmt.incl.pl1 32 11 03/27/82 0437.1 lisp_atom_fmt.incl.pl1 >ldd>include>lisp_atom_fmt.incl.pl1 33 12 03/27/82 0437.0 lisp_error_codes.incl.pl1 >ldd>include>lisp_error_codes.incl.pl1 34 13 06/29/83 1425.3 lisp_name_codes.incl.pl1 >ldd>include>lisp_name_codes.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) Alarmclock_fault internal static fixed bin(17,0) initial dcl 5-10 Array internal static bit(9) initial unaligned dcl 7-17 Array36 internal static bit(36) initial dcl 7-17 Array_fault internal static fixed bin(17,0) initial dcl 5-10 Atomic internal static bit(9) initial unaligned dcl 7-17 Atomic36 internal static bit(36) initial dcl 7-17 Atsym constant bit(9) initial unaligned dcl 7-17 ref 93 Atsym36 constant bit(36) initial dcl 7-17 ref 686 Bigfix internal static bit(9) initial unaligned dcl 7-17 Bigfix36 internal static bit(36) initial dcl 7-17 Bignum internal static bit(9) initial unaligned dcl 7-17 Bignum36 internal static bit(36) initial dcl 7-17 Car_cdr_fault internal static fixed bin(17,0) initial dcl 5-10 Cons constant bit(9) initial unaligned dcl 7-17 ref 163 817 1116 Cons36 internal static bit(36) initial dcl 7-17 Cput_fault internal static fixed bin(17,0) initial dcl 5-10 File internal static bit(9) initial unaligned dcl 7-17 File36 internal static bit(36) initial dcl 7-17 Fixed internal static bit(9) initial unaligned dcl 7-17 Fixed36 internal static bit(36) initial dcl 7-17 Float internal static bit(9) initial unaligned dcl 7-17 Float36 internal static bit(36) initial dcl 7-17 MINUS defined fixed bin(71,0) dcl 8-3 set ref 976 1000 NotConsOrAtsym36 internal static bit(36) initial dcl 7-17 Numeric internal static bit(9) initial unaligned dcl 7-17 Numeric36 constant bit(36) initial dcl 7-17 ref 450 524 Old_store_fault internal static fixed bin(17,0) initial dcl 5-10 PLUS defined fixed bin(71,0) dcl 8-3 set ref 976 Pi_fault internal static fixed bin(17,0) initial dcl 5-10 Quit_fault internal static fixed bin(17,0) initial dcl 5-10 SLASH defined fixed bin(71,0) dcl 8-3 STAR defined fixed bin(71,0) dcl 8-3 set ref 1009 String internal static bit(9) initial unaligned dcl 7-17 String36 internal static bit(36) initial dcl 7-17 Subr internal static bit(9) initial unaligned dcl 7-17 Subr36 internal static bit(36) initial dcl 7-17 SubrNumeric36 internal static bit(36) initial dcl 7-17 System_Subr internal static bit(9) initial unaligned dcl 7-17 System_Subr36 internal static bit(36) initial dcl 7-17 Uncollectable internal static bit(9) initial unaligned dcl 7-17 Undefined 000002 constant bit(72) initial unaligned dcl 7-17 ref 535 Underflow_fault internal static fixed bin(17,0) initial dcl 5-10 Zerodivide_fault internal static fixed bin(17,0) initial dcl 5-10 addr builtin function dcl 54 ref 82 116 174 203 224 236 304 305 305 310 332 445 462 493 544 562 572 583 607 607 680 683 690 707 720 746 757 761 791 798 805 838 846 855 868 896 910 920 921 933 959 959 961 976 976 979 983 984 985 990 991 992 993 994 996 996 1000 1009 1010 1022 1023 1023 1025 1042 1052 1056 1074 1082 1084 1089 1094 1103 1122 1127 addrel builtin function dcl 54 ref 81 97 103 115 149 172 187 190 200 216 235 246 301 307 308 331 364 374 395 396 403 406 442 459 478 478 492 522 542 560 570 595 596 678 785 853 865 895 908 925 937 1019 1051 1066 1073 1086 1090 1112 1114 against 000150 automatic structure level 2 in structure "unmask" packed unaligned dcl 879 in procedure "prog" set ref 971* against based structure level 2 in structure "masked" packed unaligned dcl 5-45 in procedure "prog" set ref 305* 305 argument_must_be_array internal static fixed bin(17,0) initial dcl 12-8 array_atom defined fixed bin(71,0) dcl 9-6 array_bound_error internal static fixed bin(17,0) initial dcl 12-8 array_info_for_store 122 based pointer level 2 dcl 2-5 set ref 349* array_offset_for_store 124 based fixed bin(18,0) level 2 dcl 2-5 set ref 350* array_too_big internal static fixed bin(17,0) initial dcl 12-8 atan_0_0_err internal static fixed bin(17,0) initial dcl 12-8 atom based structure level 1 dcl 11-5 in procedure "prog" atom 2 based fixed bin(71,0) array level 2 in structure "bindings" dcl 4-7 in procedure "prog" set ref 105* 332 708* 758* 1067* 1084 1089 atom_double_words based structure level 1 dcl 11-5 atom_ptrs based structure level 1 dcl 11-5 back_ptr 1 based bit(18) level 2 packed unaligned dcl 4-7 set ref 118* 334 788* 923* 1076* bad_arg_correctable internal static fixed bin(17,0) initial dcl 12-8 bad_argument internal static fixed bin(17,0) initial dcl 12-8 bad_array_subscript internal static fixed bin(17,0) initial dcl 12-8 bad_base internal static fixed bin(17,0) initial dcl 12-8 bad_bv constant fixed bin(17,0) initial dcl 12-8 ref 98 bad_do_format constant fixed bin(17,0) initial dcl 12-8 ref 854 bad_entry_name internal static fixed bin(17,0) initial dcl 12-8 bad_f_fcn internal static fixed bin(17,0) initial dcl 12-8 bad_form_do 001733 constant label dcl 851 ref 719 724 725 736 742 772 bad_function internal static fixed bin(17,0) initial dcl 12-8 bad_ibase internal static fixed bin(17,0) initial dcl 12-8 bad_input_source internal static fixed bin(17,0) initial dcl 12-8 bad_output_dest internal static fixed bin(17,0) initial dcl 12-8 bad_prog_op internal static fixed bin(17,0) initial dcl 12-8 bad_throw 001024 constant label dcl 539 ref 519 bad_throw_uu 001020 constant label dcl 535 set ref 511 badmacro internal static fixed bin(17,0) initial dcl 12-8 badobarray internal static fixed bin(17,0) initial dcl 12-8 badreadlist internal static fixed bin(17,0) initial dcl 12-8 badreadtable internal static fixed bin(17,0) initial dcl 12-8 based_ptr based pointer dcl 7-16 set ref 236* 246 307 308* 332 607 607 959 959 961 976 976 979 1000 1009 1025 1084 1089 bell 000000 constant char(1) initial unaligned dcl 1024 set ref 1023 1023 bind_local_vars_to_nil 000143 constant label dcl 125 ref 129 binding_block based structure level 1 dcl 4-7 binding_top defined pointer dcl 9-6 set ref 118 120* 325 327 334* 334 334 339 788 790* 923 924* 1040 1076 1078* 1101 bindings based structure array level 1 dcl 4-7 bit builtin function dcl 54 bot_block 0(18) based bit(18) level 2 packed unaligned dcl 4-7 set ref 116* 327 786* 921* 1074* break 001754 constant entry external dcl 877 break_err 002420 constant label dcl 1019 set ref 932 break_for_sure 002025 constant label dcl 906 ref 899 break_rdnext 002250 constant label dcl 969 ref 1037 breakwxe 002474 constant label dcl 1040 ref 1001 1006 breakxe 002501 constant label dcl 1042 ref 905 call_array_operator internal static bit(36) initial unaligned dcl 2-68 call_dead_array_operator internal static bit(36) initial unaligned dcl 2-68 cant_filepos internal static fixed bin(17,0) initial dcl 12-8 cant_subscript_readtable internal static fixed bin(17,0) initial dcl 12-8 car 0(21) based bit(9) level 2 in structure "cons_types" packed unaligned dcl 10-5 in procedure "prog" ref 93 167 car based pointer level 2 in structure "cons_ptrs" dcl 10-5 in procedure "prog" ref 106 127 1068 car based fixed bin(71,0) level 2 in structure "cons" dcl 10-5 in procedure "prog" ref 90 95 105 124 167 384 388 446 454 499 513 563 682 696 701 706 722 727 737 743 769 775 818 897 900 902 1003 1005 1053 1057 1067 1084 1096 1116 1119 car_cdr_error internal static fixed bin(17,0) initial dcl 12-8 catch 000554 constant entry external dcl 438 catch_frame defined pointer dcl 9-6 set ref 461 463* 473 478 509 517 525* catch_return 000662 constant label dcl 478 ref 460 catch_search 000764 constant label dcl 519 ref 532 cdr 2(21) based bit(9) level 2 in structure "cons_types" packed unaligned dcl 10-5 in procedure "prog" ref 383 450 cdr 2 based fixed bin(71,0) level 2 in structure "cons" dcl 10-5 in procedure "prog" ref 108 128 136 178 383 450 500 564 693 698 703 729 738 747 767 776 779 820 898 901 1054 1058 1069 1085 1097 1115 1125 cdr 2 based pointer level 2 in structure "cons_ptrs" dcl 10-5 in procedure "prog" ref 384 454 1005 choose 003134 constant label dcl 266 ref 316 320 340 356 code1 2 based fixed bin(17,0) level 2 dcl 5-25 set ref 945* common_do_code 001516 constant label dcl 779 ref 711 cons based structure level 1 dcl 10-5 cons_ptrs based structure level 1 dcl 10-5 cons_types based structure level 1 dcl 10-5 cons_types36 based structure level 1 dcl 10-22 consptr automatic pointer dcl 10-5 copy builtin function ref 305 ctrlD defined fixed bin(71,0) dcl 1-5 ctrlQ defined fixed bin(71,0) dcl 1-8 set ref 914 979 1025 ctrlR defined fixed bin(71,0) dcl 1-11 ref 918 ctrlW defined fixed bin(71,0) dcl 1-14 ref 916 dat1 1 based bit(18) level 2 packed unaligned dcl 6-7 set ref 152 221* 302 382* 384* 573* 935* dat2 1(18) based bit(18) level 2 packed unaligned dcl 6-7 set ref 159 222* 378* 408 935* dead_array_reference internal static fixed bin(17,0) initial dcl 12-8 deferred_interrupt defined bit(1) dcl 5-45 division_by_zero internal static fixed bin(17,0) initial dcl 12-8 do 001217 constant entry external dcl 615 do_ex 001666 constant label dcl 828 ref 176 do_ex_0 001663 constant label dcl 826 ref 810 do_loop 001617 constant label dcl 810 ref 849 dollar_p_atom defined fixed bin(71,0) dcl 879 ref 1001 done_unw 003160 constant label dcl 278 ref 277 doterror internal static fixed bin(17,0) initial dcl 12-8 eof_in_object internal static fixed bin(17,0) initial dcl 12-8 err_fcn_f parameter bit(1) dcl 592 ref 590 594 err_frame defined pointer dcl 9-6 set ref 377 386* 393* 393 403 407 408 599 599 934 936* 1019 err_recp defined pointer dcl 9-6 set ref 345 347 348 349 350 351 352 353 354* 354 354 355 941 951* errcode based fixed bin(17,0) array dcl 6-7 set ref 98* 188* 543* 854* 866* 867* errlist defined fixed bin(71,0) dcl 8-3 error_return 000513 constant label dcl 403 ref 375 errset 000362 constant entry external dcl 362 eval_frame defined pointer dcl 9-6 eval_when 002737 constant entry external dcl 1108 fault_save based structure level 1 dcl 5-25 set ref 908 1019 file_is_closed internal static fixed bin(17,0) initial dcl 12-8 file_sys_fun_err internal static fixed bin(17,0) initial dcl 12-8 file_system_error internal static fixed bin(17,0) initial dcl 12-8 filepos_oob internal static fixed bin(17,0) initial dcl 12-8 fixed builtin function dcl 54 fixedb 1 based fixed bin(17,0) level 2 dcl 3-4 set ref 985* 992* 994* 996 fixnum_fmt based structure level 1 dcl 3-4 fixnum_type constant bit(36) initial dcl 3-4 ref 984 991 flonum_fmt based structure level 1 dcl 3-4 flonum_too_big internal static fixed bin(17,0) initial dcl 12-8 flonum_type constant bit(36) initial dcl 3-4 ref 993 996 fn_CtoI internal static fixed bin(17,0) initial dcl 13-9 fn_ItoC internal static fixed bin(17,0) initial dcl 13-9 fn_abs internal static fixed bin(17,0) initial dcl 13-9 fn_add1 internal static fixed bin(17,0) initial dcl 13-9 fn_add1_fix internal static fixed bin(17,0) initial dcl 13-9 fn_add1_flo internal static fixed bin(17,0) initial dcl 13-9 fn_alarmclock internal static fixed bin(17,0) initial dcl 13-9 fn_allfiles internal static fixed bin(17,0) initial dcl 13-9 fn_alphalessp internal static fixed bin(17,0) initial dcl 13-9 fn_apply internal static fixed bin(17,0) initial dcl 13-9 fn_arg internal static fixed bin(17,0) initial dcl 13-9 fn_args internal static fixed bin(17,0) initial dcl 13-9 fn_array internal static fixed bin(17,0) initial dcl 13-9 fn_arraydims internal static fixed bin(17,0) initial dcl 13-9 fn_ascii internal static fixed bin(17,0) initial dcl 13-9 fn_atan internal static fixed bin(17,0) initial dcl 13-9 fn_baktrace internal static fixed bin(17,0) initial dcl 13-9 fn_bltarray internal static fixed bin(17,0) initial dcl 13-9 fn_boole internal static fixed bin(17,0) initial dcl 13-9 fn_boundp internal static fixed bin(17,0) initial dcl 13-9 fn_catch constant fixed bin(17,0) initial dcl 13-9 ref 443 fn_catenate internal static fixed bin(17,0) initial dcl 13-9 fn_charpos internal static fixed bin(17,0) initial dcl 13-9 fn_chrct internal static fixed bin(17,0) initial dcl 13-9 fn_clear_input internal static fixed bin(17,0) initial dcl 13-9 fn_cline internal static fixed bin(17,0) initial dcl 13-9 fn_close internal static fixed bin(17,0) initial dcl 13-9 fn_cos internal static fixed bin(17,0) initial dcl 13-9 fn_cursorpos internal static fixed bin(17,0) initial dcl 13-9 fn_defaultf internal static fixed bin(17,0) initial dcl 13-9 fn_definedp internal static fixed bin(17,0) initial dcl 13-9 fn_defsubr internal static fixed bin(17,0) initial dcl 13-9 fn_defun internal static fixed bin(17,0) initial dcl 13-9 fn_delete internal static fixed bin(17,0) initial dcl 13-9 fn_deletef internal static fixed bin(17,0) initial dcl 13-9 fn_delq internal static fixed bin(17,0) initial dcl 13-9 fn_diff_fix internal static fixed bin(17,0) initial dcl 13-9 fn_diff_flo internal static fixed bin(17,0) initial dcl 13-9 fn_difference internal static fixed bin(17,0) initial dcl 13-9 fn_displace internal static fixed bin(17,0) initial dcl 13-9 fn_do constant fixed bin(17,0) initial dcl 13-9 ref 677 fn_dumparrays internal static fixed bin(17,0) initial dcl 13-9 fn_endpagefn internal static fixed bin(17,0) initial dcl 13-9 fn_eoffn internal static fixed bin(17,0) initial dcl 13-9 fn_eql internal static fixed bin(17,0) initial dcl 13-9 fn_errframe internal static fixed bin(17,0) initial dcl 13-9 fn_errprint internal static fixed bin(17,0) initial dcl 13-9 fn_errset constant fixed bin(17,0) initial dcl 13-9 ref 368 fn_eval internal static fixed bin(17,0) initial dcl 13-9 fn_eval_when constant fixed bin(17,0) initial dcl 13-9 ref 1111 fn_evalframe internal static fixed bin(17,0) initial dcl 13-9 fn_exp internal static fixed bin(17,0) initial dcl 13-9 fn_expt internal static fixed bin(17,0) initial dcl 13-9 fn_expt_fix internal static fixed bin(17,0) initial dcl 13-9 fn_expt_flo internal static fixed bin(17,0) initial dcl 13-9 fn_filepos internal static fixed bin(17,0) initial dcl 13-9 fn_fillarray internal static fixed bin(17,0) initial dcl 13-9 fn_fix internal static fixed bin(17,0) initial dcl 13-9 fn_float internal static fixed bin(17,0) initial dcl 13-9 fn_force_output internal static fixed bin(17,0) initial dcl 13-9 fn_freturn internal static fixed bin(17,0) initial dcl 13-9 fn_fsc internal static fixed bin(17,0) initial dcl 13-9 fn_gcd internal static fixed bin(17,0) initial dcl 13-9 fn_gensym internal static fixed bin(17,0) initial dcl 13-9 fn_get internal static fixed bin(17,0) initial dcl 13-9 fn_get_pname internal static fixed bin(17,0) initial dcl 13-9 fn_getchar internal static fixed bin(17,0) initial dcl 13-9 fn_getl internal static fixed bin(17,0) initial dcl 13-9 fn_greaterp internal static fixed bin(17,0) initial dcl 13-9 fn_gt internal static fixed bin(17,0) initial dcl 13-9 fn_haipart internal static fixed bin(17,0) initial dcl 13-9 fn_haulong internal static fixed bin(17,0) initial dcl 13-9 fn_ifix internal static fixed bin(17,0) initial dcl 13-9 fn_in internal static fixed bin(17,0) initial dcl 13-9 fn_includef internal static fixed bin(17,0) initial dcl 13-9 fn_index internal static fixed bin(17,0) initial dcl 13-9 fn_inpush internal static fixed bin(17,0) initial dcl 13-9 fn_isqrt internal static fixed bin(17,0) initial dcl 13-9 fn_lessp internal static fixed bin(17,0) initial dcl 13-9 fn_linel internal static fixed bin(17,0) initial dcl 13-9 fn_linenum internal static fixed bin(17,0) initial dcl 13-9 fn_listarray internal static fixed bin(17,0) initial dcl 13-9 fn_listify internal static fixed bin(17,0) initial dcl 13-9 fn_loadarrays internal static fixed bin(17,0) initial dcl 13-9 fn_log internal static fixed bin(17,0) initial dcl 13-9 fn_ls internal static fixed bin(17,0) initial dcl 13-9 fn_lsh internal static fixed bin(17,0) initial dcl 13-9 fn_make_atom internal static fixed bin(17,0) initial dcl 13-9 fn_makunbound internal static fixed bin(17,0) initial dcl 13-9 fn_mapatoms internal static fixed bin(17,0) initial dcl 13-9 fn_max internal static fixed bin(17,0) initial dcl 13-9 fn_mergef internal static fixed bin(17,0) initial dcl 13-9 fn_min internal static fixed bin(17,0) initial dcl 13-9 fn_minus internal static fixed bin(17,0) initial dcl 13-9 fn_minusp internal static fixed bin(17,0) initial dcl 13-9 fn_namelist internal static fixed bin(17,0) initial dcl 13-9 fn_names internal static fixed bin(17,0) initial dcl 13-9 fn_namestring internal static fixed bin(17,0) initial dcl 13-9 fn_nointerrupt internal static fixed bin(17,0) initial dcl 13-9 fn_nth internal static fixed bin(17,0) initial dcl 13-9 fn_nthcdr internal static fixed bin(17,0) initial dcl 13-9 fn_oddp internal static fixed bin(17,0) initial dcl 13-9 fn_open internal static fixed bin(17,0) initial dcl 13-9 fn_opena internal static fixed bin(17,0) initial dcl 13-9 fn_openi internal static fixed bin(17,0) initial dcl 13-9 fn_openo internal static fixed bin(17,0) initial dcl 13-9 fn_out internal static fixed bin(17,0) initial dcl 13-9 fn_pagel internal static fixed bin(17,0) initial dcl 13-9 fn_pagenum internal static fixed bin(17,0) initial dcl 13-9 fn_plus internal static fixed bin(17,0) initial dcl 13-9 fn_plus_fix internal static fixed bin(17,0) initial dcl 13-9 fn_plus_flo internal static fixed bin(17,0) initial dcl 13-9 fn_plusp internal static fixed bin(17,0) initial dcl 13-9 fn_prin1 internal static fixed bin(17,0) initial dcl 13-9 fn_princ internal static fixed bin(17,0) initial dcl 13-9 fn_print internal static fixed bin(17,0) initial dcl 13-9 fn_prog constant fixed bin(17,0) initial dcl 13-9 ref 79 fn_progv constant fixed bin(17,0) initial dcl 13-9 ref 1050 fn_putprop internal static fixed bin(17,0) initial dcl 13-9 fn_quot_fix internal static fixed bin(17,0) initial dcl 13-9 fn_quot_flo internal static fixed bin(17,0) initial dcl 13-9 fn_quotient internal static fixed bin(17,0) initial dcl 13-9 fn_random internal static fixed bin(17,0) initial dcl 13-9 fn_read internal static fixed bin(17,0) initial dcl 13-9 fn_read_from_string internal static fixed bin(17,0) initial dcl 13-9 fn_readch internal static fixed bin(17,0) initial dcl 13-9 fn_readstring internal static fixed bin(17,0) initial dcl 13-9 fn_remainder internal static fixed bin(17,0) initial dcl 13-9 fn_remprop internal static fixed bin(17,0) initial dcl 13-9 fn_rename internal static fixed bin(17,0) initial dcl 13-9 fn_rot internal static fixed bin(17,0) initial dcl 13-9 fn_rplaca internal static fixed bin(17,0) initial dcl 13-9 fn_samepnamep internal static fixed bin(17,0) initial dcl 13-9 fn_save internal static fixed bin(17,0) initial dcl 13-9 fn_set internal static fixed bin(17,0) initial dcl 13-9 fn_setarg internal static fixed bin(17,0) initial dcl 13-9 fn_setq internal static fixed bin(17,0) initial dcl 13-9 fn_setsyntax internal static fixed bin(17,0) initial dcl 13-9 fn_shortnamestring internal static fixed bin(17,0) initial dcl 13-9 fn_signp internal static fixed bin(17,0) initial dcl 13-9 fn_sin internal static fixed bin(17,0) initial dcl 13-9 fn_sleep internal static fixed bin(17,0) initial dcl 13-9 fn_sort internal static fixed bin(17,0) initial dcl 13-9 fn_sortcar internal static fixed bin(17,0) initial dcl 13-9 fn_sqrt internal static fixed bin(17,0) initial dcl 13-9 fn_sstatus internal static fixed bin(17,0) initial dcl 13-9 fn_star_array internal static fixed bin(17,0) initial dcl 13-9 fn_star_rearray internal static fixed bin(17,0) initial dcl 13-9 fn_star_sstatus internal static fixed bin(17,0) initial dcl 13-9 fn_star_status internal static fixed bin(17,0) initial dcl 13-9 fn_status internal static fixed bin(17,0) initial dcl 13-9 fn_store internal static fixed bin(17,0) initial dcl 13-9 fn_stringlength internal static fixed bin(17,0) initial dcl 13-9 fn_sub1 internal static fixed bin(17,0) initial dcl 13-9 fn_sub1_fix internal static fixed bin(17,0) initial dcl 13-9 fn_sub1_flo internal static fixed bin(17,0) initial dcl 13-9 fn_substr internal static fixed bin(17,0) initial dcl 13-9 fn_sxhash internal static fixed bin(17,0) initial dcl 13-9 fn_sysp internal static fixed bin(17,0) initial dcl 13-9 fn_throw constant fixed bin(17,0) initial dcl 13-9 ref 497 fn_times internal static fixed bin(17,0) initial dcl 13-9 fn_times_fix internal static fixed bin(17,0) initial dcl 13-9 fn_times_flo internal static fixed bin(17,0) initial dcl 13-9 fn_truename internal static fixed bin(17,0) initial dcl 13-9 fn_tyi internal static fixed bin(17,0) initial dcl 13-9 fn_tyipeek internal static fixed bin(17,0) initial dcl 13-9 fn_tyo internal static fixed bin(17,0) initial dcl 13-9 fn_unwind_protect constant fixed bin(17,0) initial dcl 13-9 ref 559 fn_zerop internal static fixed bin(17,0) initial dcl 13-9 frame based structure level 1 dcl 6-7 set ref 301 frame_ptrs defined pointer array dcl 6-16 set ref 261 296 297 301 318* frame_rels 000102 automatic bit(18) array dcl 39 set ref 261* 271 272 315* 319* 339* 355* gc_inhibit defined bit(1) dcl 5-45 set ref 347* go_once_more 000226 constant label dcl 163 ref 195 go_or_return 000175 constant label dcl 149 ref 217 i 000134 automatic fixed bin(17,0) dcl 72 set ref 260* 261 261* 270* 271 272 273* illobj internal static fixed bin(17,0) initial dcl 12-8 include_file_error internal static fixed bin(17,0) initial dcl 12-8 io_wrong_direction internal static fixed bin(17,0) initial dcl 12-8 iochan based structure level 1 dcl 1028 iox_$put_chars 000126 constant entry external dcl 879 ref 1023 iox_$user_output 000124 external static pointer dcl 879 set ref 1023* iox_status 000147 automatic fixed bin(35,0) dcl 879 set ref 1023* length builtin function ref 305 lisp_$apply 000142 constant entry external dcl 879 ref 963 1014 lisp_$eval 000106 constant entry external dcl 50 ref 389 410 467 501 578 796 813 819 836 904 1008 1043 1055 1059 1098 lisp_$eval_list 000110 constant entry external dcl 51 ref 237 309 lisp_$unwind_reversal 000112 constant entry external dcl 52 ref 337 lisp_err 001151 constant entry external dcl 590 lisp_error_ 000114 constant entry external dcl 53 ref 99 192 546 856 869 lisp_fault_handler_$interrupt_poll 000102 constant entry external dcl 48 ref 311 lisp_fault_handler_$set_mask 000034 constant entry external dcl 5-45 ref 348 972 lisp_io_control_$clear_input 000146 constant entry external dcl 1028 ref 1035 lisp_oprs_$xec_unwprot_compiled_handler 000104 constant entry external dcl 49 ref 314 lisp_print_$type_nl 000122 constant entry external dcl 879 ref 964 982 lisp_print_$type_string 000120 constant entry external dcl 879 ref 956 lisp_ptr based structure level 1 dcl 7-17 lisp_ptr_type based bit(36) dcl 7-17 lisp_reader_$read 000144 constant entry external dcl 879 ref 986 995 lisp_special_fns_$cons 000100 constant entry external dcl 47 ref 397 lisp_special_fns_$ncons 000140 constant entry external dcl 879 ref 962 1013 lisp_static_vars_$MINUS 000046 external static fixed bin(71,0) dcl 8-3 ref 976 976 1000 1000 lisp_static_vars_$PLUS 000044 external static fixed bin(71,0) dcl 8-3 ref 976 976 lisp_static_vars_$SLASH 000050 external static fixed bin(71,0) dcl 8-3 set ref 607 lisp_static_vars_$STAR 000042 external static fixed bin(71,0) dcl 8-3 ref 1009 1009 lisp_static_vars_$array_atom external static fixed bin(71,0) dcl 9-6 lisp_static_vars_$binding_top 000074 external static pointer dcl 9-6 set ref 118 118 120* 120 325 325 327 327 334* 334 334 334 334 334 339 339 788 788 790* 790 923 923 924* 924 1040 1040 1076 1076 1078* 1078 1101 1101 lisp_static_vars_$catch_frame 000060 external static pointer dcl 9-6 set ref 461 461 463* 463 473 473 478 478 509 509 517 517 525* 525 lisp_static_vars_$ctrlD external static fixed bin(71,0) dcl 1-5 lisp_static_vars_$ctrlQ 000010 external static fixed bin(71,0) dcl 1-8 ref 914 914 979 979 1025 1025 lisp_static_vars_$ctrlR 000012 external static fixed bin(71,0) dcl 1-11 ref 918 918 lisp_static_vars_$ctrlW 000014 external static fixed bin(71,0) dcl 1-14 ref 916 916 lisp_static_vars_$deferred_interrupt 000024 external static bit(1) dcl 5-45 ref 311 lisp_static_vars_$dollar_p_atom 000130 external static fixed bin(71,0) dcl 879 ref 1001 1001 lisp_static_vars_$err_frame 000056 external static pointer dcl 9-6 set ref 377 377 386* 386 393* 393 393 393 403 403 407 407 408 408 599 599 599 599 934 934 936* 936 1019 1019 lisp_static_vars_$err_recp 000052 external static pointer dcl 9-6 set ref 345 345 347 347 348 348 349 349 350 350 351 351 352 352 353 353 354* 354 354 354 354 354 355 355 941 941 951* 951 lisp_static_vars_$errlist 000040 external static fixed bin(71,0) dcl 8-3 set ref 607 lisp_static_vars_$eval_atom 000116 external static fixed bin(71,0) dcl 56 ref 1119 lisp_static_vars_$eval_frame external static pointer dcl 9-6 lisp_static_vars_$frame_ptrs 000036 external static pointer array dcl 6-16 set ref 261 261 296 296 297 297 301 301 318* 318 lisp_static_vars_$garbage_collect_inhibit 000016 external static bit(1) dcl 5-45 set ref 347* 347 943 lisp_static_vars_$iochan_list external static pointer dcl 9-6 lisp_static_vars_$lisp_static_vars_ external static structure level 1 unaligned dcl 9-6 lisp_static_vars_$masked 000020 external static structure level 1 dcl 5-45 set ref 304 305 305 310 944 lisp_static_vars_$nil 000076 external static fixed bin(71,0) dcl 9-6 ref 91 91 125 125 127 127 141 141 155 155 383 383 384 384 396 396 450 450 507 507 596 596 689 689 710 710 715 715 724 724 730 730 732 732 739 739 770 770 814 814 816 816 860 860 899 899 902 902 905 905 926 926 959 959 979 979 1025 1025 1033 1033 1063 1063 1083 1083 1089 1089 1095 1095 1126 lisp_static_vars_$obarray external static fixed bin(71,0) dcl 9-6 lisp_static_vars_$pending_ctrl 000022 external static bit(1) dcl 5-45 ref 969 969 lisp_static_vars_$prin1_atom 000136 external static fixed bin(71,0) dcl 879 set ref 959 959 959 961 lisp_static_vars_$print_atom 000134 external static fixed bin(71,0) dcl 879 ref 1012 lisp_static_vars_$prog_frame 000054 external static pointer dcl 9-6 set ref 152 152 159 159 172 172 200 200 218 218 223* 223 lisp_static_vars_$rdr_label 000026 external static label variable dcl 5-45 set ref 351* 351 948 948 lisp_static_vars_$rdr_ptr 000030 external static pointer dcl 5-45 set ref 353* 353 949 949 lisp_static_vars_$rdr_state 000032 external static fixed bin(17,0) dcl 5-45 set ref 352* 352 950 950 952* 952 1036* 1036 lisp_static_vars_$return_atom 000132 external static fixed bin(71,0) dcl 879 ref 1003 1003 lisp_static_vars_$stack_ptr 000064 external static pointer dcl 9-6 set ref 81 81 82* 82 102 102 103* 103 103 103 117 117 149 149 159 159 174* 174 189 189 190* 190 194* 194 203* 203 214 214 224* 224 264 264 289* 289 289 289 299* 299 299 299 308 308 325 325 364 364 376 376 395* 395 395 395 396 396 403 403 406 406 442 442 445* 445 478 478 478 478 492 492 493* 493 522 522 544* 544 560 560 562* 562 583* 583 595* 595 595 595 596 596 678 678 680* 680 690* 690 707* 707 720* 720 757* 757 760 760 791* 791 801* 801 855* 855 868* 868 895 895 896* 896 910* 910 942 942 983* 983 990* 990 1010* 1010 1022* 1022 1042* 1042 1051 1051 1052* 1052 1056* 1056 1065 1065 1066* 1066 1075 1075 1083 1083 1088 1088 1093 1093 1094* 1094 1103* 1103 1112 1112 1114* 1114 1122* 1122 1127* 1127 lisp_static_vars_$star_rset external static fixed bin(71,0) dcl 9-45 lisp_static_vars_$t_atom 000066 external static fixed bin(71,0) dcl 9-6 ref 1121 lisp_static_vars_$top_level 000070 external static label variable dcl 9-6 ref 610 lisp_static_vars_$toplevel external static fixed bin(71,0) dcl 8-3 lisp_static_vars_$tty_input_chan external static pointer dcl 9-6 lisp_static_vars_$tty_output_chan external static pointer dcl 9-6 lisp_static_vars_$unmkd_ptr 000072 external static pointer dcl 9-6 set ref 96 96 97* 97 113 113 115* 115 115 115 186 186 187* 187 215 215 216* 216 216 216 234 234 235* 235 246 246 263 263 288* 288 301* 301 307* 307 349 349 350 350 373 373 374* 374 374 374 394* 394 458 458 459* 459 459 459 539 539 542* 542 569 569 570* 570 570 570 784 784 785* 785 785 785 851 851 853* 853 864 864 865* 865 906 906 908* 908 1072 1072 1073* 1073 lisp_static_vars_$unwp_frame 000062 external static pointer dcl 9-6 set ref 300 300 306* 306 571 571 574* 574 581 581 lisp_static_vars_$user_intr_array external static fixed bin(71,0) array dcl 9-45 lisp_unwinder 003104 constant entry internal dcl 253 in procedure "prog" ref 173 202 247 409 412 474 582 609 1021 1041 1102 lisp_unwinder 000344 constant entry external dcl 244 local_variables_loop 000037 constant label dcl 91 ref 109 make_prog_frame 003024 constant entry internal dcl 212 ref 131 808 marked_stack_bottom based pointer level 2 dcl 2-5 ref 286 masked based structure level 1 dcl 5-45 set ref 304 310* mismatch_super_parens internal static fixed bin(17,0) initial dcl 12-8 mk_frame 000161 constant label dcl 131 ref 125 myname 000125 automatic fixed bin(17,0) dcl 66 set ref 79* 368* 443* 497* 559* 677* 867 1050* 1111* n 000135 automatic fixed bin(17,0) dcl 72 set ref 273* 293 294 296 297 298 318 319 need_arg 003532 constant entry internal dcl 858 ref 86 369 444 498 561 679 694 699 704 768 1113 new_type_do_join 001434 constant label dcl 750 ref 689 nframeptrs constant fixed bin(17,0) initial dcl 6-16 ref 260 270 nihil_ex_nihile internal static fixed bin(17,0) initial dcl 12-8 nil defined fixed bin(71,0) dcl 9-6 ref 91 125 127 141 155 383 384 396 450 507 596 689 710 715 724 730 732 739 770 814 816 860 899 902 905 926 959 979 1025 1033 1063 1083 1089 1095 nil_ptr based pointer dcl 9-6 no_arg 003545 constant label dcl 864 ref 860 861 no_left_super_paren internal static fixed bin(17,0) initial dcl 12-8 no_lexpr internal static fixed bin(17,0) initial dcl 12-8 nonfixedarg internal static fixed bin(17,0) initial dcl 12-8 not_alpha_array internal static fixed bin(17,0) initial dcl 12-8 not_an_array internal static fixed bin(17,0) initial dcl 12-8 not_pdl_ptr internal static fixed bin(17,0) initial dcl 12-8 not_same_type internal static fixed bin(17,0) initial dcl 12-8 null builtin function dcl 54 ref 946 obarray defined fixed bin(71,0) dcl 9-6 old_val based fixed bin(71,0) array level 2 dcl 4-7 set ref 106* 332 709* 759* 1068* overflow_err internal static fixed bin(17,0) initial dcl 12-8 p 000122 automatic pointer dcl 62 set ref 102* 105 106 113* 116 117 118 119 120 149* 152 153 155 215* 217 218 219 221 222 223 373* 375 376 377 378 382 384 386 393 394 458* 460 461 462 463 509* 510 517* 519 522 525 528 531* 531 531 569* 571 572 573 574 784* 786 787 788 789 790 1065* 1066 1067 1068 1072* 1073 1074 1075 1076 1077 1078 1082* 1083 1084 1086* 1086 1088 1089 1090* 1090 1093* 1094 1096 1100 parenmissing internal static fixed bin(17,0) initial dcl 12-8 pdl_ptr_types36 based structure array level 1 dcl 4-7 pending_ctrl defined bit(1) dcl 5-45 ref 969 prev_frame based bit(18) level 2 in structure "fault_save" packed unaligned dcl 5-25 in procedure "prog" set ref 354 941* prev_frame based bit(18) level 2 in structure "frame" packed unaligned dcl 6-7 in procedure "prog" set ref 218* 297 377* 393 461* 531 571* 934* process_error 001174 constant label dcl 599 prog 000013 constant entry external dcl 6 prog_end 000171 constant label dcl 141 ref 829 prog_ex 000170 constant label dcl 139 ref 175 prog_frame defined pointer dcl 9-6 set ref 152 159 172 200 218 223* prog_ret 000326 constant label dcl 200 ref 144 823 prog_with_initial_values 000146 automatic bit(1) unaligned dcl 618 set ref 688* 770* 774* 810 829 progsw 000120 automatic bit(1) unaligned dcl 60 set ref 80* 175 617* progv 002513 constant entry external dcl 1048 ptr builtin function dcl 54 ref 152 159 284 288 289 299 306 318 325 329 334 349 350 354 393 403 478 522 531 push_down_list_ptr_types based structure array level 1 dcl 4-7 qb 000114 automatic pointer dcl 43 set ref 329* 330 522* 523 524 qt 000112 automatic pointer dcl 43 set ref 325* 329 330 331* 331 332 332 quoterror internal static fixed bin(17,0) initial dcl 12-8 r_e_p_loop 002264 constant label dcl 976 ref 1015 rdr_label defined label variable dcl 5-45 set ref 351* 948 rdr_ptr defined pointer dcl 5-45 set ref 353* 949 rdr_state defined fixed bin(17,0) dcl 5-45 set ref 352* 950 952* 1036* rebind 000113 constant label dcl 113 ref 91 rel builtin function dcl 54 ref 116 117 118 172 200 218 219 221 222 246 261 264 285 286 339 355 376 377 407 461 462 473 510 519 571 572 581 599 786 787 788 920 921 923 933 934 941 942 1019 1040 1074 1075 1076 1101 relp 000203 automatic bit(18) dcl 256 set ref 297* 306 315 318 319 reopen_inconsistent internal static fixed bin(17,0) initial dcl 12-8 reset_read 002461 constant label dcl 1033 ref 965 ret 2 based label variable level 2 dcl 6-7 set ref 217* 375* 460* 528 599 932* return_atom defined fixed bin(71,0) dcl 879 ref 1003 rev_ptr 1(18) based bit(18) level 2 packed unaligned dcl 4-7 set ref 119* 789* 922* 1077* save_masked 000124 automatic structure level 1 packed unaligned dcl 64 set ref 304* 310 set_rel 003105 constant label dcl 260 shortreadlist internal static fixed bin(17,0) initial dcl 12-8 size builtin function ref 301 307 908 1019 special_array_type internal static fixed bin(17,0) initial dcl 12-8 st 000202 automatic bit(18) unaligned dcl 255 set ref 264* 286* 289 296* 299 327* 328 329 345* stack 000126 automatic pointer dcl 68 set ref 81* 82 90 90 91 93 95 95 105 106 108 108 116 124 124 125 127 128 128 136 136 136 141 152* 153 163 163 163 167 167 167 178 191 193 203 221 236 364* 383 383 384 388 388 403* 406 442* 445 446 446 450 450 450 454 454 462 471 471 492* 493 499 499 500 500 507 507 513 513 523 535 544 545 545 547 547 560* 562 563 563 564 564 572 580 580 583 678* 680 682 682 683 686 689 691 693 693 696 698 698 701 703 703 706 706 710 715 719 722 747 747 767 767 769 769 770 772 775 775 776 776 779 779 779 779 812 817 818 820 820 822 826 826 855 860 861 868 895* 896 897 897 898 898 899 900 900 901 901 902 902 902 905 910 914 915 915 916 917 917 918 919 919 920 921 926 926 926 933 958 958 959 961 983 984 985 990 991 992 993 994 996 996 1000 1001 1002 1003 1005 1005 1009 1010 1011 1011 1012 1022 1033 1042 1051* 1052 1053 1053 1054 1054 1056 1057 1057 1058 1058 1063 1067 1068 1069 1069 1074 1082 1083 1084 1085 1085 1095 1096 1097 1097 1100 1103 1112* 1114 1115 1115 1116 1116 1116 1119 1121 1122 1125 1126 1127 stack2 000136 automatic pointer dcl 618 set ref 683* 690 691 696 701 708 709 754 792 802 832 843 stack3 000140 automatic pointer dcl 618 set ref 683* 690* 707 708 709 720 722 724 725 727 727 729 729 730 732 733 733 736 737 737 738 738 739 739 739 742 743 743 746* 746 750 755 786 793 803 833 844 stack4 000142 automatic pointer dcl 618 set ref 214* 219 707* 750* 757 758 759 760* 787 791 795 797 801 832* 833 835 837 838* 838 843* 844 845 845 846* 846 stack5 000144 automatic pointer dcl 618 set ref 159* 174 214* 222 224 754* 755 758 759 761* 761 792* 793 795 797 798* 798 802* 803 804 804 805* 805 812 814 816 818 822 835 837 stack_loss_error internal static fixed bin(17,0) initial dcl 12-8 stack_ptr defined pointer dcl 9-6 in procedure "prog" set ref 81 82* 102 103* 103 117 149 159 174* 189 190* 194* 203* 214 224* 264 289* 289 299* 299 308 325 364 376 395* 395 396 403 406 442 445* 478 478 492 493* 522 544* 560 562* 583* 595* 595 596 678 680* 690* 707* 720* 757* 760 791* 801* 855* 868* 895 896* 910* 942 983* 990* 1010* 1022* 1042* 1051 1052* 1056* 1065 1066* 1075 1083 1088 1093 1094* 1103* 1112 1114* 1122* 1127* stack_ptr 0(18) based bit(18) level 2 in structure "frame" packed unaligned dcl 6-7 in procedure "prog" set ref 219* 296 376* 403 462* 478 522 572* 933* stack_ptr 0(18) based bit(18) level 2 in structure "fault_save" packed unaligned dcl 5-25 in procedure "prog" set ref 345 942* stack_seg based structure level 1 dcl 2-5 star_rset defined fixed bin(71,0) dcl 9-45 stars_left_in_name internal static fixed bin(17,0) initial dcl 12-8 store_function_misused internal static fixed bin(17,0) initial dcl 12-8 store_not_allowed internal static fixed bin(17,0) initial dcl 12-8 string builtin function set ref 305* 305 971 sv_array_info 4 based pointer level 2 dcl 5-25 set ref 349 946* sv_array_offset 15 based fixed bin(18,0) level 2 dcl 5-25 set ref 350 947* sv_gc_inhibit 1 based bit(1) level 2 packed unaligned dcl 5-25 set ref 347 943* sv_masked 1(01) based structure level 2 packed unaligned dcl 5-25 set ref 348 944* sv_rdr_label 6 based label variable level 2 dcl 5-25 set ref 351 948* sv_rdr_ptr 12 based pointer level 2 dcl 5-25 set ref 353 949* sv_rdr_state 14 based fixed bin(17,0) level 2 dcl 5-25 set ref 352 950* t_atom defined fixed bin(71,0) dcl 9-6 t_atom_ptr based pointer dcl 9-6 temp based fixed bin(71,0) array dcl 4-7 set ref 82 90* 91 95* 108* 116 124* 125 128* 136* 136* 141* 153* 153 155 163* 163* 167 174* 191* 191 193* 193 203 224 236 388* 396* 406* 406 445 446* 454* 462 471* 471 478* 478 493 499* 500* 507 513* 523 523 535* 544 545* 545 547* 547 562 563* 564* 572 580* 580 583 596* 680 682* 683 689 690 691* 691 693* 696* 698* 701* 703* 706* 707 708 710* 715 720 722* 724 727* 729* 730 732* 733* 733 737* 738* 739 739* 739 743* 746 747* 757 758 761 767* 769* 770 775* 776* 779* 779* 779* 791 795* 795 797* 797 798 804 805 812* 812 814 816* 818* 820* 822* 822 826* 826 835* 835 837* 837 838 845 846 855 860 868 896 897* 898* 899 900* 901* 902 902* 905 910 914* 915* 916* 917* 918* 919* 920 921 933 958* 958 959* 961* 983 984 985 990 991 992 993 994 996 996 1000 1001 1005* 1009 1010 1011* 1011 1012* 1022 1033* 1042 1052 1053* 1054* 1056 1057* 1058* 1063 1069* 1074 1082 1083 1085* 1094 1095 1096* 1097* 1100* 1100 1103 1115* 1116* 1121* 1122* 1126* 1127 temp_framep 000204 automatic pointer dcl 257 set ref 300* 302 307 308 temp_ptr based pointer array dcl 4-7 ref 90 93 95 105 106 108 124 127 128 136 167 167 178 383 383 384 388 446 450 450 454 499 500 513 563 564 682 693 696 698 701 703 706 709 722 727 729 737 738 743 747 759 767 769 775 776 779 804 818 820 845 897 898 900 901 902 915 917 919 926 926 926 1003 1005 1053 1054 1057 1058 1067 1068 1069 1084 1085 1096 1097 1115 1116 1119 1125 temp_type 0(21) based bit(9) array level 2 packed unaligned dcl 4-7 ref 163 507 719 725 736 742 772 817 861 1002 1116 temp_type36 based bit(36) array level 2 dcl 4-7 set ref 450* 524 686 throw 000701 constant entry external dcl 490 throw1 001006 constant label dcl 525 ref 510 523 throw_retry 000760 constant label dcl 517 ref 548 throw_to_no_catch constant fixed bin(17,0) initial dcl 12-8 ref 543 too_few_args constant fixed bin(17,0) initial dcl 12-8 ref 866 too_many_args internal static fixed bin(17,0) initial dcl 12-8 top_block based bit(18) level 2 packed unaligned dcl 4-7 set ref 117* 325 787* 920* 1075* top_of_stack 000130 automatic pointer dcl 69 set ref 189* 190 191 193 194 toplevel defined fixed bin(71,0) dcl 8-3 tty_input_chan defined pointer dcl 9-6 tty_join_in 002302 constant label dcl 983 ref 974 tty_loop 002275 constant label dcl 982 ref 996 tty_output_chan defined pointer dcl 9-6 type_info based bit(36) level 2 in structure "fixnum_fmt" dcl 3-4 in procedure "prog" set ref 984* 991* type_info based bit(36) level 2 in structure "flonum_fmt" dcl 3-4 in procedure "prog" set ref 993* 996 unable_to_float internal static fixed bin(17,0) initial dcl 12-8 uncatch 000653 constant label dcl 473 ref 484 undefined_atom internal static fixed bin(17,0) initial dcl 12-8 undefined_function internal static fixed bin(17,0) initial dcl 12-8 undefined_subr internal static fixed bin(17,0) initial dcl 12-8 underflow_fault internal static fixed bin(17,0) initial dcl 12-8 unm 000132 automatic pointer dcl 70 in procedure "prog" set ref 263* 284* 284 285 286 288 306 318 906* 908 908 920 921 922 923 924 925* 925 932 933 934 935 935 936 937* 937 941 942 943 944 945 946 947 948 949 950 951 1019 unm 000172 automatic pointer dcl 232 in procedure "xec_body" set ref 234* 235 236 unmask 000150 automatic structure level 1 dcl 879 set ref 972* unmkd_ptr defined pointer dcl 9-6 set ref 96 97* 113 115* 115 186 187* 215 216* 216 234 235* 246 263 288* 301* 307* 349 350 373 374* 374 394* 458 459* 459 539 542* 569 570* 570 784 785* 785 851 853* 864 865* 906 908* 1072 1073* unmkd_stack_bottom 2 based pointer level 2 dcl 2-5 ref 285 unmp 000116 automatic pointer dcl 53 set ref 96* 97 98 186* 187 188 539* 542 543 851* 853 854 864* 865 866 867 unseen_go_tag constant fixed bin(17,0) initial dcl 12-8 ref 188 unspec builtin function set ref 349* 349 535 unwind_bindings 003345 constant label dcl 325 ref 293 unwind_fault_save 003424 constant label dcl 345 ref 294 unwind_protect 001053 constant entry external dcl 555 unwind_to 000100 automatic bit(18) unaligned dcl 39 set ref 172* 200* 246* 278 282 285* 288 407* 473* 581* 608* 1019* 1040* 1101* unwp_frame defined pointer dcl 9-6 set ref 300 306* 571 574* 581 uread_loop 002316 constant label dcl 990 user_intr_array defined fixed bin(71,0) array dcl 9-45 value based fixed bin(71,0) level 2 dcl 11-5 set ref 106 127* 332* 607* 607 709 759 804* 845* 915 917 919 926* 926* 926* 959 959 961 976* 976 979 1000* 1009* 1025* 1068 1084* 1089* where_to 000101 automatic bit(18) dcl 39 set ref 266* 271 272* 277 278 wrong_no_args internal static fixed bin(17,0) initial dcl 12-8 xec_body 003064 constant entry internal dcl 230 ref 139 828 1120 xretn 000342 constant label dcl 204 ref 870 zerodivide_fault internal static fixed bin(17,0) initial dcl 12-8 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 4404 4554 3570 4414 Length 5462 3570 150 672 613 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME prog 188 external procedure is an external procedure. make_prog_frame internal procedure shares stack frame of external procedure prog. xec_body internal procedure shares stack frame of external procedure prog. lisp_unwinder internal procedure shares stack frame of external procedure prog. need_arg internal procedure shares stack frame of external procedure prog. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME prog 000100 unwind_to prog 000101 where_to prog 000102 frame_rels prog 000112 qt prog 000114 qb prog 000116 unmp prog 000120 progsw prog 000122 p prog 000124 save_masked prog 000125 myname prog 000126 stack prog 000130 top_of_stack prog 000132 unm prog 000134 i prog 000135 n prog 000136 stack2 prog 000140 stack3 prog 000142 stack4 prog 000144 stack5 prog 000146 prog_with_initial_values prog 000147 iox_status prog 000150 unmask prog 000172 unm xec_body 000202 st lisp_unwinder 000203 relp lisp_unwinder 000204 temp_framep lisp_unwinder THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as r_ne_as call_ext_out_desc call_ext_out return tra_label_var ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. iox_$put_chars lisp_$apply lisp_$eval lisp_$eval_list lisp_$unwind_reversal lisp_error_ lisp_fault_handler_$interrupt_poll lisp_fault_handler_$set_mask lisp_io_control_$clear_input lisp_oprs_$xec_unwprot_compiled_handler lisp_print_$type_nl lisp_print_$type_string lisp_reader_$read lisp_special_fns_$cons lisp_special_fns_$ncons THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. iox_$user_output lisp_static_vars_$MINUS lisp_static_vars_$PLUS lisp_static_vars_$SLASH lisp_static_vars_$STAR lisp_static_vars_$binding_top lisp_static_vars_$catch_frame lisp_static_vars_$ctrlQ lisp_static_vars_$ctrlR lisp_static_vars_$ctrlW lisp_static_vars_$deferred_interrupt lisp_static_vars_$dollar_p_atom lisp_static_vars_$err_frame lisp_static_vars_$err_recp lisp_static_vars_$errlist lisp_static_vars_$eval_atom lisp_static_vars_$frame_ptrs lisp_static_vars_$garbage_collect_inhibit lisp_static_vars_$masked lisp_static_vars_$nil lisp_static_vars_$pending_ctrl lisp_static_vars_$prin1_atom lisp_static_vars_$print_atom lisp_static_vars_$prog_frame lisp_static_vars_$rdr_label lisp_static_vars_$rdr_ptr lisp_static_vars_$rdr_state lisp_static_vars_$return_atom lisp_static_vars_$stack_ptr lisp_static_vars_$t_atom lisp_static_vars_$top_level lisp_static_vars_$unmkd_ptr lisp_static_vars_$unwp_frame LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 6 000012 79 000020 80 000022 81 000024 82 000030 86 000032 90 000033 91 000037 93 000045 95 000053 96 000055 97 000060 98 000063 99 000065 102 000071 103 000075 105 000101 106 000104 108 000107 109 000112 113 000113 115 000116 116 000122 117 000126 118 000132 119 000136 120 000140 124 000141 125 000143 127 000152 128 000155 129 000160 131 000161 136 000162 139 000170 141 000171 144 000174 149 000175 152 000202 153 000211 155 000213 159 000216 163 000226 167 000240 172 000246 173 000254 174 000256 175 000262 176 000265 178 000266 186 000273 187 000277 188 000302 189 000304 190 000307 191 000312 192 000314 193 000320 194 000322 195 000325 200 000326 202 000334 203 000336 204 000342 244 000343 246 000351 247 000357 248 000360 362 000361 364 000367 368 000374 369 000376 373 000377 374 000403 375 000407 376 000412 377 000417 378 000423 382 000425 383 000427 384 000445 386 000454 388 000455 389 000460 393 000464 394 000473 395 000475 396 000501 397 000506 398 000512 403 000513 406 000524 407 000531 408 000535 409 000542 410 000543 411 000550 412 000551 413 000552 438 000553 442 000561 443 000566 444 000570 445 000571 446 000575 450 000577 454 000615 458 000620 459 000623 460 000627 461 000632 462 000636 463 000642 467 000643 471 000650 473 000653 474 000660 475 000661 478 000662 484 000677 490 000700 492 000706 493 000713 497 000715 498 000717 499 000720 500 000724 501 000727 507 000734 509 000746 510 000751 511 000754 513 000755 517 000760 519 000764 522 000767 523 000777 524 001003 525 001006 528 001010 531 001012 532 001017 535 001020 539 001024 542 001030 543 001033 544 001035 545 001040 546 001042 547 001046 548 001051 555 001052 559 001060 560 001062 561 001067 562 001070 563 001074 564 001076 569 001101 570 001104 571 001110 572 001114 573 001120 574 001122 578 001123 580 001130 581 001133 582 001140 583 001141 584 001145 590 001146 594 001156 595 001162 596 001167 599 001174 607 001205 608 001211 609 001212 610 001213 615 001216 617 001224 677 001225 678 001227 679 001234 680 001235 682 001241 683 001243 686 001247 688 001252 689 001253 690 001257 691 001264 693 001266 694 001271 696 001272 698 001276 699 001302 701 001303 703 001307 704 001313 706 001314 707 001320 708 001326 709 001330 710 001333 711 001335 715 001336 719 001343 720 001347 722 001352 724 001354 725 001360 727 001364 729 001366 730 001371 732 001374 733 001376 734 001400 736 001401 737 001405 738 001407 739 001412 742 001420 743 001424 746 001426 747 001430 748 001433 750 001434 754 001436 755 001440 757 001444 758 001450 759 001452 760 001455 761 001460 762 001463 767 001464 768 001470 769 001471 770 001475 772 001504 774 001510 775 001511 776 001513 779 001516 784 001523 785 001526 786 001532 787 001535 788 001537 789 001543 790 001545 791 001546 792 001551 793 001553 795 001560 796 001563 797 001570 798 001573 799 001575 801 001576 802 001601 803 001603 804 001610 805 001613 806 001615 808 001616 810 001617 812 001622 813 001625 814 001632 816 001636 817 001640 818 001644 819 001646 820 001653 821 001657 822 001660 823 001662 826 001663 828 001666 829 001667 832 001672 833 001674 835 001700 836 001703 837 001710 838 001713 839 001715 843 001716 844 001720 845 001724 846 001727 847 001731 849 001732 851 001733 853 001736 854 001741 855 001743 856 001746 877 001752 895 001761 896 001766 897 001770 898 001772 899 001775 900 002001 901 002003 902 002006 904 002013 905 002017 906 002025 908 002030 910 002034 914 002037 915 002041 916 002043 917 002045 918 002047 919 002051 920 002053 921 002056 922 002062 923 002064 924 002070 925 002071 926 002073 932 002077 933 002103 934 002107 935 002113 936 002117 937 002120 941 002122 942 002126 943 002133 944 002137 945 002151 946 002152 947 002154 948 002155 949 002163 950 002166 951 002170 952 002171 956 002172 958 002205 959 002210 961 002226 962 002231 963 002235 964 002242 965 002247 969 002250 971 002253 972 002255 974 002263 976 002264 979 002271 982 002275 983 002302 984 002306 985 002310 986 002311 987 002315 990 002316 991 002321 992 002323 993 002325 994 002327 995 002330 996 002334 1000 002343 1001 002350 1002 002354 1003 002360 1005 002363 1006 002366 1008 002367 1009 002373 1010 002400 1011 002402 1012 002404 1013 002406 1014 002412 1015 002417 1019 002420 1021 002427 1022 002431 1023 002435 1025 002455 1033 002461 1035 002465 1036 002471 1037 002473 1040 002474 1041 002500 1042 002501 1043 002505 1044 002511 1048 002512 1050 002520 1051 002522 1052 002527 1053 002531 1054 002533 1055 002536 1056 002542 1057 002546 1058 002550 1059 002553 1063 002557 1065 002565 1066 002570 1067 002573 1068 002575 1069 002600 1070 002603 1072 002604 1073 002607 1074 002612 1075 002616 1076 002622 1077 002626 1078 002630 1082 002631 1083 002633 1084 002651 1085 002654 1086 002657 1087 002661 1088 002662 1089 002667 1090 002672 1091 002674 1093 002675 1094 002700 1095 002702 1096 002706 1097 002711 1098 002715 1099 002721 1100 002722 1101 002724 1102 002730 1103 002731 1104 002735 1108 002736 1111 002744 1112 002746 1113 002753 1114 002754 1115 002760 1116 002765 1119 002773 1120 003000 1121 003001 1122 003004 1123 003007 1125 003010 1126 003015 1127 003020 1128 003023 212 003024 214 003025 215 003032 216 003035 217 003041 218 003044 219 003050 221 003053 222 003055 223 003060 224 003061 225 003063 230 003064 234 003065 235 003071 236 003074 237 003077 238 003103 253 003104 260 003105 261 003113 262 003122 263 003124 264 003130 266 003134 270 003135 271 003143 272 003146 273 003150 275 003151 277 003153 278 003156 282 003160 284 003162 285 003164 286 003166 288 003170 289 003175 290 003202 293 003203 294 003206 296 003211 297 003217 298 003225 299 003230 300 003235 301 003240 302 003244 304 003247 305 003257 306 003267 307 003273 308 003276 309 003302 310 003306 311 003317 313 003325 314 003326 315 003332 316 003334 318 003335 319 003342 320 003344 325 003345 327 003355 328 003361 329 003362 330 003365 331 003372 332 003375 333 003377 334 003400 335 003411 337 003412 339 003416 340 003423 345 003424 347 003431 348 003436 349 003460 350 003471 351 003477 352 003506 353 003512 354 003516 355 003525 356 003531 858 003532 860 003533 861 003540 862 003544 864 003545 865 003550 866 003553 867 003555 868 003557 869 003562 870 003566 ----------------------------------------------------------- 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