lisp_.alm 11/05/86 1612.7r w 11/04/86 1039.0 810711 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " lisp_.alm -- evaluator for Multics MACLISP " " David Moon, 17 July 1972 " cleaned up and "map" functions added, 1 Aug 72 DAM " pdl ptr format changed for pdp-10 compatible, 5 Aug 72 DAM " bug in evaluated functions fixed, 7 Aug 72, DPR " bug in eval_funarg fixed, 7 Aug 72, DPR " go, return, eval_list (for prog) added 19 Aug 72, DAM " call1, callf added 22 Aug 1972 DAM " nouuo function added 24 Aug 72 DAM " freturn_real added, meaning of frame.dat1 changed, 24 Jan 73 DAM " changed to make *rset a variable, 24 May 1973 " " modified 74.2.07 by DAM to fix bugs in apply of 3 args " modified 74.04.15 by DAM to make an evalframe for an unbnd vrbl and to ignore " macro properties when snapping subr links. " Modified 74.09.18 by DAM to use the new binding-reversal scheme for funargs and " calls to eval or apply with a binding-context-pointer " Modified 75.03.31 by DAM for evalhook + bug fixes " Modified 78.09.12 by BSG for "let" fsubr. "flag bits in x2 equ macrobit,1 distinguish macros from fexprs equ exprbit,4 distinguish expr/lexpr from subr/lsubr equ framebit,8 an evalframe was created and must be destroyed equ lsubrbit,16 distinguish lexpr/lsubr from expr/subr equ noteval,32 spread_args should not evaluate args (for apply) equ already_spread,1024 args are already spread, beginning at ap|qsrac+2,x4 equ applybit,2 entered by apply rather than eval equ bbf,64 pseudo-binding-block exists because of label or funarg equ fbb,128 flag for a reversal block needed " used by eval_funarg equ ignore_macros,256 find_type should ignore macro properties equ went_through_value_cell,512 equ already_autoloaded_once,2048 equ entered_by_funcall,4096 " to distinguish between funcall and call1 " temporaries on marked pdl equ form,-8 form being evaled. Inviolable since pdlframe uses it. " for apply, is name of fcn being applied equ fcn,-6 function being applied equ argl,-4 argument list. Inviolable since used to construct "form" "also handy temporary, contains result of fcn, etc. " in case of error during apply equ qsrac,-2 all kinds of random things go here " temporaries on unmarked pdl " -2, -1 regular binding block equ pdlptr,-4 a temporary equ svx5u,-4 register save area equ svx2l,-4 .. equ svx0u,-3 .. equ svx4l,-3 .. equ svx3l,-5 since no one uses frame.dat2, save a reg here equ funarg_pdlptr,-7 holds pdl ptr for a funarg " -6, -5 evalframe goes here " -8, -7 if a funarg is used, its reversal bb is put here " -10, -9 random cruft is put here by map, if not map these don't exist "use of index registers " x0 calls to recurse,error,... " x1 scan through stack during binding, random data " x2 flag bits escribed above) " x3 number of arguments " x4 offset from top of marked pdl to get to above-mentioned temporaries, "sometimes random data preserved through a recursion. " x5 call evalu by tsx5 " x6 random data " x7 unmarked pdl pointer "use of base registers " ab points to stack header, together with x7 points to unmarked pdl " ap points to marked pdl " bp random pointer " bb temporary " lp untouchable " lb temporary " sp sacred " sb sacred " " Use of pdls " the unmarked pdl contains space for an eval frame (2 words), " a register save area for recursing and random temps (2 words), " 2 words for a funarg binding block, 2 words that only exist for map, " and a binding_block (2 words). The binding block starts out " containing no bindings and grows whenever an atom needs to be " bound. Since the binding block is created and then added to, the " same atom may appear more than once and all routines that can unwind " eval - created binding blocks _m_u_s_t do so from the top down. " The eval frame is only created in *rset-t mode, but the space for " it is always allocated since that is easier. The contents of " the eval frame are: " frame.prev_frame thread " frame.stack_ptr -> form being evaled (on marked pdl) " frame.dat1 rel(sp) at time frame was created. Low order " bit is 1 if this frame is due to apply or map, " in which case form is really = fcn, you can cons " on argl if you want. " frame.dat2 no useful information. recurse saves x3 here " the marked pdl: " ap|form form being evaled or function being applied " ap|fcn functional property of function being applied/evaluated " ap|argl argument list " ap|qsrac temp., holds property lits amung other things " the above 4 are often referenced with the aid of x4, since the binding block " is above them on the marked pdl. x4 contains (almost always) the negative size " of the binding block (and any other cruft that may be there) so that"ap|form,x4" works. """ FORMAT OF BINDING BLOCKS " Normal Binding Block " top_block bot_block -> top & bottom of marked pdl cells " containing atom,value pairs " back_ptr rev_ptr --- points at reversal block which reversed this one. " A " points at previous b.b. " Reversal Binding Block (set up when a binding-context-pointer is used) " PDLP 0 -> lowest b.b. in range, flag for this type " back_ptr rev_ptr same back_ptr, pointer to reversal " block whose range overlaps this one " in such a way as to require re-reversing " part of the range of this one. " " use of "pseudo-binding-blocks" " a pseudo binding block is a record that at some later time bindings " are to be made. labels and funargs create pseudo-binding-blocks " because they can't do their binding until after the arguments " have been evaluated, and you can't evaluate the arguments until " the real functional property being applied is found. " a pseudo-binding-block exists on the marked pdl above " the regular binding block. It has the same format, except that " where a binding block would have "saved old value", in the " pseudo binding block a new value is saved. After the args " have been evaluated, the pseudo binding block is converted " into a regular binding block (actually the one just below it " on the pdl is extended, since they are always contiguous) " The old value of the atom is put in the binding block, and the " new-value that was saved in the pseudo binding block is assigned " to the atomic symbol. " expr's and lexpr's use variants of the " pseudo binding block: they can't bind their lambda atoms until " after the args have been evaluated, since one of the args " might be a setq, so they just figure out how much pdl space it " will take to bind their lambda atoms and leave room for " that before evaluating the args. " include lisp_unmkd_pdl include lisp_iochan include lisp_stack_seg include lisp_object_types include lisp_name_codes " " entry point for calling eval by pl1 subrs entry eval eval: tsx0 pl1_entry-*,ic tsx5 evalu-*,ic enter common code pl1_return: staq ap|form eppap ap|form+2 pl1_exit: spriap lisp_static_vars_$stack_ptr stx7 lisp_static_vars_$unmkd_ptr+1 stc1 ab|in_pl1_code short_return " routine to set up ap, ab, x7 on entry from pl1 code pl1_entry: epbpab lisp_static_vars_$unmkd_ptr,* eppap lisp_static_vars_$stack_ptr,* ldx7 lisp_static_vars_$unmkd_ptr+1 stz ab|in_pl1_code tra 0,0 " entry point for the lisp lsubr "eval" Fast call but with lp segdef eval_ & no prologue eval_: cmpx5 -2,du 1 argument? tnz eval_with_2_args-*,ic no, go do a-list hack. tsx5 evalu-*,ic yes, so enter common code. lisp_retn: " deliver us from eval. eppap ap|form lisp_rtn_1: eppbp ab|-2,x7* epplp ab|-4,x7* eax7 -4,x7 (popj) tra bp|0 " Routine called by lisp_prog_fns_ to unwind a reversal bb segdef unwind_reversal unwind_reversal: tsx0 pl1_entry-*,ic epplb lisp_static_vars_$binding_top,* -> bb to unwind tsx3 unwind_reversal_bb-*,ic tra pl1_exit-*,ic " " internal entry point for recursive calls to eval (by tsx0) " on entry object to be evaluated is at ap|-2 " if the object is not a list, its value is immediately found. " if it is a list, registers are saved on the unmkd pdl " and evalu is called. " on return, x4,x2,x5,x3 are undisturbed, " aq = ap|-2 = evaluated object, and ap and x7 are unchanged. tra 0,0 exit used by evalhook recurse: xec lisp_static_vars_$evalhook_status ldaq ap|-2 check for easy cases and do them quickly cana Unevalable,dl tnz 0,0 cmpaq ab|nil tze 0,0 cana Atsym,dl tze full_recurse-*,ic list -- hard case -- have to really recurse ldaq ap|-2,* atomic symbol -- get its value tze 3,ic undefined? staq ap|-2 no, return it. tra 0,0 undefined_atom_error: " undefined atomic symbol -- error " atomic symbol which was undef is at ap|-2 " returns by tra 0,0 with new value in aq and ap|-2 " if necessary, pushes an evalframe ldaq lisp_static_vars_$star_rset,* cmpaq ab|nil tnz undefined_atom_error_hard-*,ic lda lisp_error_table_$undefined_atom tra error-*,ic error must return value in aq and ap|-2 undefined_atom_error_hard: " push evalframe eax7 8,x7 eppap ap|2 copy atom to avoid destroying evalframe during error proc ldaq ap|-4 staq ap|-2 eax6 ap|-4 sxl6 ab|frame.stack_ptr-6,x7 eax6 sp|0 stx6 ab|frame.dat1-6,x7 ldx6 lisp_static_vars_$eval_frame+1 stx6 ab|frame.prev_frame-6,x7 eax6 ab|-6,x7 stx6 lisp_static_vars_$eval_frame+1 stx0 ab|frame.ret-6,x7 save return address lda lisp_error_table_$undefined_atom tsx0 error-*,ic go signal the error " now pop this evalframe ldx6 ab|frame.prev_frame-6,x7 stx6 lisp_static_vars_$eval_frame+1 ldx0 ab|frame.ret-6,x7 return addr saved eax7 -8,x7 ldaq ap|-2 eppap ap|-2 undo push above staq ap|-2 some callers want it in stack tra 0,0 full_recurse: stx5 ab|svx5u,x7 sxl2 ab|svx2l,x7 sxl4 ab|svx4l,x7 stx0 ab|svx0u,x7 sxl3 ab|svx3l,x7 eppap ap|6 get new work area on marked pdl tsx5 eval_fcn-*,ic lxl4 ab|svx4l,x7 ldx0 ab|svx0u,x7 lxl2 ab|svx2l,x7 ldx5 ab|svx5u,x7 lxl3 ab|svx3l,x7 staq ap|form return result in both aq and stack eppap ap|form+2 restore caller's ap tra 0,0 return to caller of recurse " symeval SUBR 1 arg - evaluate a symbol. used for compiled efficiency segdef symeval symeval: ldaq ap|-2 fetch argument cana Atsym,dl is it an atomic symbol? tze symeval_loss-*,ic no, error (if compiled, would be bug) ldaq ap|-2,* yes, get its value tze symeval_loss-*,ic and err if unbound symeval_ret: eppap ap|-2 pop argument tra lisp_rtn_1-*,ic and return symeval_loss: tsx0 undefined_atom_error-*,ic tra symeval_ret-*,ic " "pl1 - callable apply function entry apply apply: tsx0 pl1_entry-*,ic tsx5 apply_com-*,ic tra pl1_return-*,ic "lisp - callable apply lsubr segdef apply_ apply_: cmpx5 -4,du 2 args? tnz apply_with_3_args-*,ic eax5 lisp_retn-*,ic " set up the pdl with form, fcn, argl as when evaling a fcn. " set applybit to indicate that ap|form = fcn instead of full form " go to common code with eval apply_com: eax2 noteval+applybit ldaq ap|-2 eppap ap|4 staq ap|argl ldaq ap|form staq ap|fcn tra evaler-*,ic return addr is in x5 " " interface to lisp_error_ " called by tsx0, preserves x0,x5,x2,x4 " error code must be in the a. error: eax7 2,x7 going to push error code onto unmkd pdl staq ab|-2,x7 errcode(1) from a, errcode(2) from q. tsx6 call_ext_out-*,ic -- now call lisp_error_, which eppbp lisp_error_$lisp_error_ will clear the unmkd pdl for us " come here to call out to a pl1 program. " x6 -> an eppbp instruction to get address of entry being called " x0 = return address " x1,x2,x3,x4,x5 are saved (by the call macro) " " on return aq is loaded with value on top of marked pdl " on entry, a is zeroed unless from error, where it is pushed onto unmkd pdl " " this code just saves things, updates the pl1 copies of " the two stack pointers, and builds a stack frame from which to call out " " ***** this piece of code relies on the knowledge that the save macro does " ***** not change any index registers except x7 call_ext_out: spriap lisp_static_vars_$stack_ptr stx7 lisp_static_vars_$unmkd_ptr+1 stc1 ab|in_pl1_code push " ** this is where x6 must not change xec 0,x6 an eppbp instruction. " *** here we rely on the new call macro doing an sreg and an lreg to save x0,x2,x4,x5 call bp|0(=v18/0,18/4,18/0,18/0) no args arg list eaa sp|16,* pop stack frame sprisp sb|stack_header.stack_end_ptr eppsp sb|0,au eppap lisp_static_vars_$stack_ptr,* epbpab lisp_static_vars_$unmkd_ptr,* ldx7 lisp_static_vars_$unmkd_ptr+1 stz ab|in_pl1_code ldaq ap|-2 needed when unbnd-vrbl in recurse. tra 0,0 " " eval with an a-list 2nd argument (actually a pdl pointer) eval_with_2_args: eax7 2,x7 tsx3 fetch_binding_context_ptr-*,ic sets x4 to bcp to a bb epplb ab|-2,x7 set up ptr to bb tsx3 reverse_binding_context-*,ic reverse context to there tsx5 evalu-*,ic now eval 1st arg in that context staq ap|form save result epplb ab|-2,x7 set up ptr to bb tsx3 unwind_reversal_bb-*,ic restore to calling context eax7 -2,x7 restore unmarked pdl ldaq ap|form put result in AQ tra lisp_retn-*,ic and return from type 1 subr " hack for apply with 3rd arg a pseudo-a-list (pdl ptr) " have to neutralize all the binding blocks between the top of " the pdl and the pdl ptr. apply_with_3_args: eax7 2,x7 apply_tsx3: tsx3 fetch_binding_context_ptr-*,ic epplb ab|-2,x7 tsx3 reverse_binding_context-*,ic tsx5 apply_com-*,ic now do the apply staq ap|form epplb ab|-2,x7 tsx3 unwind_reversal_bb-*,ic ldaq ap|form eax7 -2,x7 tra lisp_retn-*,ic " Routine to accept a lisp a-list-ptr (or binding-context-ptr), and " convert it into a pointer to the lowest binding block on the unmarked " pdl which is affected. the input is in ap|-2 and is popped. " the output is in x4. " called by tsx3 " the pointer input to this routine has -2 in its left half and " a pointer to the unmarked pdl in its right half. NOTE that this " is a change from the previous version in which it pointed at the marked pdl. " The pointer to the unmarked pdl need not point exactly at a bb. " ab|-2,x7 and ab|-1,x7 are used for temporary storage. fetch_binding_context_ptr: ldaq ap|-2 cmpaq ab|nil nil means zero level context tze fetch_bcp_nil-*,ic which has to be special cased cana Fixed,dl make sure it is a fixnum tze fetch_bcp_error-*,ic eax1 0,qu make sure left half is -2 cmpx1 -2,du tnz fetch_bcp_error-*,ic eax4 0,ql make a few other useless checks stx7 ab|-2,x7 cmpx4 ab|-2,x7 trc fetch_bcp_error-*,ic too high cmpx4 ab|marked_stack_bottom+1 tnc fetch_bcp_error-*,ic too low fetch_bcp_ret: eppap ap|-2 pop argument tra 0,x3 and return fetch_bcp_error: lcq -fn_eval,dl assume called by eval cmpx3 apply_tsx3+1,du tnz 2,ic lcq -fn_apply,dl no, called by apply lda lisp_error_table_$not_pdl_ptr stx3 ab|-2,x7 tsx0 error-*,ic call error routine ldx3 ab|-2,x7 which returns with new data in ap|-2 tra fetch_binding_context_ptr-*,ic so retry fetch_bcp_nil: ldx4 ab|unmkd_stack_bottom+1 tra fetch_bcp_ret-*,ic " " reverse one binding block " x6 -> block to be reversed " x5 what to set its rev_ptr to " x0 calling reg " lp -> lisp static " aq, x1, all pointers are clobbered except lb reversal: stc1 lisp_static_vars_$binding_reversal_flag lock interrupts epbpbb ap|0 -> marked pdl eppap ap|2 get temp on stack lxl1 ab|0,x6 pick up binding_block.bot_block reverse_1_binding: cmpx1 ab|0,x6 reached top of block? tze reverse_1_binding_aa-*,ic yes, stop ldaq bb|0,x1 pick up saved value staq ap|-2 save it for a moment ldaq bb|2,x1* pick up current value of symbol bound staq bb|0,x1 set as saved value ldaq ap|-2 and set saved value as current value staq bb|2,x1* .. eax1 4,x1 proceed to the next binding in this block tra reverse_1_binding-*,ic reverse_1_binding_aa: sxl5 ab|1,x6 yes, set this block's rev_ptr eppap ap|-2 police area ldac lisp_static_vars_$binding_reversal_flag test & clear intr lock ana =o7,dl mask to just interrupt bits tze 0,x0 none set, return " interrupt happened and was deferred - signal it now. " the following code is copied from lisp_alloc_ eax7 2,x7 store interrupt bits sta ab|-2,x7 spriap lisp_static_vars_$stack_ptr save environment stx7 lisp_static_vars_$unmkd_ptr+1 stc1 ab|in_pl1_code tempd arglist(4) push eppbp lisp_static_vars_$unmkd_ptr,* get address of intr code eppbp bp|-2 spribp arglist+2 ldaq arg_list_1_hdr-*,ic staq arglist call lisp_default_handler_$alloc_fault(arglist) saves all xr's, lb eaa sp|16,* now pop back to lisp sprisp sb|20 eppsp sb|0,au epbpab lisp_static_vars_$unmkd_ptr,* eppap lisp_static_vars_$stack_ptr,* ldx7 lisp_static_vars_$unmkd_ptr+1 stz ab|in_pl1_code eax7 -2,x7 flush arg loc pushed earlier tra 0,x0 now return from reversal " Procedure to reverse binding context down to a specified binding context pointer " x4 -> the bb which is last to reverse down to " x3 call reg " lp -> lisp static " lb -> 2 words on unmkd pdl to put the bb in " uses " x6 -> current binding block " x5 -> newly-constructed reversal bb, (used to set rev_ptr's) " x1 temp " aq, bb, bp clobbered " x2 is guaranteed untouched " NOTE: the 2 words on unmkd pdl for the bb constructed are assumed already pushed reverse_binding_context: eax5 lb|0 -> reversal bb to construct eax6 0,x5 init scan ptr stz lb|0 set reversal-bb flag in dl " stx4 lb|0 set PDLP in du ldq lisp_static_vars_$binding_top+1 set thread, clearing rev_ptr stq lb|1 stx5 lisp_static_vars_$binding_top+1 thread into bindings list rbc00: " trace thread of binding blocks until the pdl ptr is reached... cmpx4 ab|1,x6 gone down far enough? tpnz rbc_ret-*,ic yes, return (RELIES ON STACK = 64K) ldx6 ab|1,x6 no - chase thread to a block lxl1 ab|0,x6 check type of block tze rbc01-*,ic tra if a reversal block tsx0 reversal-*,ic normal block - reverse it and set rev_ptr tra rbc00-*,ic and continue scanning pdl rbc01: cmpx4 ab|0,x6 reversal block - compare its PDLP to ours tpnz rbc02-*,ic *** KLUDGE *** relies on lisp stacks limited to 64K "its range is contained in ours. skip over it since it has already "done the reversals that we want ldx6 ab|0,x6 skip down to its PDLP tra rbc00-*,ic and look at next block below that rbc02: "its range exceeds ours - take the part of its range we want, and "reverse the rest, because it did the opposite of what we want. "this is referred to as the "extended range." sxl5 ab|1,x6 set rev_ptr to us to mark end of range eax1 0,x4 ldx4 ab|0,x6 set scan limit to its PDLP rbc03a: cmpx1 ab|1,x6 set scan position to our PDLP, also tpnz rbc03b-*,ic setting our PDLP to really point at a bb ldx6 ab|1,x6 tra rbc03a-*,ic rbc03b: stx6 lb|0 set our pdlp rbc03: ldx6 ab|1,x6 and go down one more block tze 0,x3 return if no more lxl1 ab|0,x6 what type BB is this? tze rbc04-*,ic reversal - skip it lxl5 ab|1,x6 normal - reverse it but tsx0 reversal-*,ic don't change its rev_ptr rbc04: cmpx4 ab|1,x6 done? tpnz 0,x3 *** KLUDGE *** relies on lisp stacks 64K tra rbc03-*,ic " come here to return from reverse_binding_context. " the PDLP field is changed to be an accurate pointer to a binding block rbc_ret: stx6 lb|0 bb.pdlp := addr of lowest bb in range tra 0,x3 " Procedure to unwind a reversal bb " called by tsx3 with the reversal bb at lb|0 " uses all the registers unwind_reversal_bb: eax5 0 for clearing rev_ptr's eax6 lb|0 and begin scanning down stack ldx4 lb|0 pick up pdl ptr of this reversal bb urbre: eaa lb|0 prepare to do r-r arithmetic in pointer register neg 0 eppbb 0,au urb00: cmpx4 ab|1,x6 done? tpnz urbxx-*,ic yes (RELIES ON STACK BEING 64K) ldx6 ab|1,x6 no, thread through back_ptr lxl1 ab|1,x6 pick up its rev_ptr eax1 bb|0,x1 does it point at the block being reversed? tnz urb00-*,ic no - this block didn't change it so don't change back lxl1 ab|0,x6 yes - check type tze urb01-*,ic reversal bb - tra tsx0 reversal-*,ic normal - reverse it and zero its rev_ptr tra urbre-*,ic and chain to next, fixing bb " here the extended range begins, reverse everything without touching its rev_ptr urb01: ldx4 ab|0,x6 pick up its PDLP hwich limits our range urb02: cmpx4 ab|1,x6 done? tpnz urbxx-*,ic yes ldx6 ab|1,x6 no, thread through back_ptr lxl1 ab|0,x6 check its type tze urb02-*,ic ignore reversal bb's lxl5 ab|1,x6 normal bb's get reversed but rev_ptr left alone tsx0 reversal-*,ic tra urb02-*,ic urbxx: ldx1 lb|1 now unthread this bb from bindings list stx1 lisp_static_vars_$binding_top+1 tra 0,x3 and return " " this is the actual evaluator " it is called by tsx5 with ap|-2 the object to be evaled. " it returns with ap bumped by 6, the result in the aq, " x7 the same, and the contents of the other regs randomized. tra evalu_exit-*,ic used by evalhook evalu: xec lisp_static_vars_$evalhook_status eppap ap|6 room to work ldaq ap|form object to be evaled cana Unevalable,dl tnz 0,5 if number or string, just return it cana Atsym,dl tze eval_fcn-*,ic "Atomic symbol. Return its value. Error if undefined ldaq ap|form,* get value of atom tnz 0,5 eppap ap|form+2 undefined - give correctable error tsx0 undefined_atom_error-*,ic eppap ap|-form-2 "ldaq ap|form replacement value.(already in aq) tra 0,5 evalu_exit: eppap ap|6 exit routine for evalhook tra 0,5 " evaluate a non-atomic expression eval_fcn: eax2 0 clear all flags eppbp ap|form,* ldaq bp|2 cdr = args staq ap|argl ldaq bp|0 car = fcn staq ap|fcn " apply, label, and funarg join us here. (by tsx5, with " x2, ap|form, ap|fcn, ap|argl properly set up.) evaler: eax3 find_type_tv-*,ic evaler1: " set up the unified binding block, initially empty of bindings eax7 8,x7 eax6 ap|0 = bot_block, for now = top_block too stx6 ab|-2,x7 sxl6 ab|-2,x7 eax4 0 -- binding block takes 0 words right now " in *rset t mode, make an evalframe for baktrace & pdlframe set_eval_frame: set_eval_frame_1: ldaq lisp_static_vars_$star_rset,* cmpaq ab|nil tze make_no_frame-*,ic eppbp ab|-6,x7 eax6 sp|0 make frame.dat1, which = rel(sp), canx2 applybit,du tze 2,ic orx6 1,du +1 if in apply or map stx6 bp|frame.dat1 eax6 ap|form,x4 -> form for pdlframe to get sxl6 bp|frame.stack_ptr ldx6 lisp_static_vars_$eval_frame+1 stx6 bp|frame.prev_frame spribp lisp_static_vars_$eval_frame orx2 framebit,du make_no_frame: tra find_type-*,ic find_type_tv: "return transfer vector for find_type tra eval_subrs_and_arrays-*,ic "array tra eval_subrs_and_arrays-*,ic "subr tra eval_lsubr-*,ic tra eval_expr-*,ic tra eval_fexpr-*,ic tra eval_fsubr-*,ic tra eval_lexpr-*,ic " " routine to bind all the atomic symbols in a lambda list " ap|fcn,x4 is cons lambdalist body, as returned by find_type " uses pre-existing binding_block " called by tsx0. Uses x1, bb. " updates x4, ap, returns number of variables bound in x6 " just binds the variables - does not assign them to new values. lambda_bind: eax6 0 init counter ldaq ap|fcn,x4* lambda_bind_1: cana lisp_ptr.type,dl tnz 0,0 ... end of the lambda - list eppap ap|4 eax4 -4,x4 eax6 1,x6 staq ap|-2 eppbp ap|-2,* ldaq bp|0 a lambda var staq ap|-2 cana Atsym,dl ok to bind? tze bad_bound_var-*,ic nope. cmpaq ab|nil tze loser_binding_nil-*,ic ldaq ap|-2,* yes, ok to bind. staq ap|-4 eax1 ap|0 stx1 ab|-2,x7 update binding_block.top_block ldaq bp|2 (cdr of the lambda list) tra lambda_bind_1-*,ic " " evaluator of fexpr's and macros " " binds the lambda-atom to the argument list. " if a second lambda atom is present, binds it to a pdl ptr " so that it can be used with eval or apply as an a-list. " then joins with expr code to eval lambda body. eval_fexpr: canx2 bbf,du tze 3,ic no pseudo bb, skip... eax1 ap|0 tsx0 finish_bindings-*,ic tsx0 lambda_bind-*,ic cmpx6 1,du just 1 lambda variable? tnc bad_fcnl-*,ic "fexpr (lambda nil ... tze fexpr_1_arg-*,ic yes, easy. eaq ab|-2,x7 -> binding block qrl 18 orq -2,du lda fixnum_type,dl staq ap|-2,* rebind 2nd arg ldaq ap|argl,x4 staq ap|-6,* rebind 1st arg tra eval_lambda_body-*,ic fexpr_1_arg: ldaq ap|argl,x4 staq ap|-2,* rebind 1st (only) arg tra eval_lambda_body-*,ic " eval_lexpr: orx2 exprbit+lsubrbit,du eppap ap|8 reserve space for binding block eax4 -8,x4 but don't update binding_block.top_block yet. tra arg_spreader-*,ic comes back to args_spread_for_lexpr eval_expr: orx2 exprbit,du " before spreading args, allocate enough space to bind " the lambda variables, but don't bind them until " after the args are spread because one of the args " might be a setq or something ldaq ap|fcn,x4* eax1 ap|0 where first lambda var will be bound stx4 ab|-4,x7 expr_bb_alloc: cana lisp_ptr.type,dl end of lambda-list? tnz expr_bb_fin-*,ic yes. eppap ap|4 no, 1 more binding (at least) eax4 -4,x4 staq ap|-2 eppbp ap|-2,* ldaq bp|2 cdr lambda-list tra expr_bb_alloc-*,ic expr_bb_fin: " in last binding slot, save addr of first binding slot for lambda vars " (because there might be a label pseudo bb too) cmpx4 ab|-4,x7 anything in lambda list? tze expr_nil-*,ic no. eaq 0,x1 yes, save ptr to first lda Uncollectable,dl staq ap|-4 tra arg_spreader-*,ic " expr with no lambda vars - still have to use arg_spreader for wrong_no_args check expr_nil: tra arg_spreader-*,ic args_spread_for_expr: canx2 lsubrbit,du tnz args_spread_for_lexpr-*,ic ldaq ap|fcn,x4* which kind of expr? cana lisp_ptr.type,dl tze expr_bind-*,ic the kind with args canx2 bbf,du the kind with no args. tze 3,ic eax1 ap|0 if necc., do pseudo-bb stuff tsx0 finish_bindings-*,ic cmpx3 0,du we want no args. have we none? tnz too_many_args_expr-*,ic no, barf. tra eval_lambda_body-*,ic yes, go eval fcn expr_bind: "ok, bind the lambda variables... " " finish making the binding block then pop the args off of the marked " pdl and assign them to the lambda variables. epbpbb ap|0 canx2 already_spread,du tze expr_bind_1-*,ic " args are at bottom of pdl, pseudo binding block is at top ldx0 ap|argl,x4 eax1 ap|0 tra expr_bind_0-*,ic " args are at top of pdl, pseudo binding block is right below them. expr_bind_1: tsx0 set_x1_args-*,ic eax0 0,x1 top of pseudo bb = base of args expr_bind_0: sxl1 ab|-4,x7 save top of pseudo bb for later ldx1 bb|-3,x1 -> start of lambda var bindings " at this point x0 -> args and x1 -> top of future binding block of lambda vars (pseudo bb) ldaq ap|fcn,x4* scan through lambda-list again eax6 0 init counter expr_binder: cana lisp_ptr.type,dl done? tnz expr_assign_0-*,ic yes staq bb|0,x1 epplb bb|0,x1* ldaq lb|0 = the lambda-atom staq bb|2,x1 cana Atsym,dl make sure it is bindable tze bad_bound_var_sp-*,ic cmpaq ab|nil tze loser_bind_nil-*,ic ldaq bb|0,x0 get value of arg staq bb|0,x1 store into pseudo binding block " lambda var will be bound to it later eax0 2,x0 eax6 1,x6 count lambda vars eax1 4,x1 ldaq lb|2 cdr lamda-list tra expr_binder-*,ic loser_bind_nil: tra loser_binding_nil-*,ic expr_assign_0: stx6 ab|pdlptr,x7 check for right number of args cmpx3 ab|pdlptr,x7 tze 3,ic tmi too_few_args_expr-*,ic tra too_many_args_expr-*,ic " now that we have made a pseudo binding block out of the " lambda variables and the values of the arguments, pop the args " (no longer needed) off the pdl and call finish_bindings which " will change the pseudo bb into a real bb bind thr lambda " vars to the args. lxl1 ab|-4,x7 saved top of pseudo bb tsx0 finish_bindings-*,ic ldx1 ab|-2,x7 = binding_block.top_block eax0 ap|0,x4 so can adjust x4 stx0 ab|-4,x7 eppap bb|0,x1 clear the spread args off the pdl " (finish_bindings sets bb) ldx4 ab|-4,x7 adjust x4 sbx4 ab|-2,x7 "tra eval_lambda_body-*,ic *** fall into eval_lambda_body " " come here to evaluate a lambda body which is the cdr of ap|fcn, " and consists of a list of 0 or more objects to be evaluated, " the value of the last of which is returned as the value of the lambda. " After evaluating the lambda body, the topmost binding block is " unwound, restoring the lambda atoms to thwir former values. eval_lambda_body: eppap ap|2 place for return value eax4 -2,x4 ldaq ab|nil staq ap|-2 initial value nil in case empty body eval_lambda_body_loop: eppbp ap|fcn,x4* cdr down lambda body, first time is list of " lambda list and lambda body ldaq bp|2 staq ap|fcn,x4 cana lisp_ptr.type,dl tnz end_eval_lambda_body-*,ic ldaq ap|fcn,x4* staq ap|-2 thing to pass to eval tsx0 recurse-*,ic tra eval_lambda_body_loop-*,ic end_eval_lambda_body: ldaq ap|-2 move result down eppap ap|-2 eax4 2,x4 " come here to unwind & exit fcn_fin: staq ap|qsrac,x4 save result of fcn canx2 mapf,du from a map fcn? tnz map_fcn_fin-*,ic yes, go loop. tsx0 unbinder-*,ic " if macro bit is set, send the macro around for another evaluation " else return freturn_join: ldaq ap|qsrac get result canx2 macrobit,du tze 0,5 return with result in aq, " and our 4 temp.'s on stack staq ap|form allowed since frame has been destroyed eppap ap|form+2 tra evalu-*,ic ...and go around again " this is code to finish up an freturn " entered with the binding block already unwound, but the eval_frame still present " there is nothing on either pdl except the usual 3 unmkd and 4 marked words - huh? " we restore the index registers, get rid of the eval frame, and join up with fcn_fin segdef freturn_real freturn_real: getlp epbpab lisp_static_vars_$unmkd_ptr,* switch to lisp mode from pl1 mode eppap lisp_static_vars_$stack_ptr,* ldx7 lisp_static_vars_$unmkd_ptr+1 stz ab|in_pl1_code " back in lisp mode -- restore index regs ldx5 ab|svx5u,x7 lxl2 ab|svx2l,x7 " ap|qsrac has the return value in it ldaq ab|-2,x7 restore return_ptr in our caller's stack frame staq sp|20 ***** stack_frame.return_ptr canx2 mapf,du tnz map_freturn freturn to mapped fcn - go fix it up. " get rid of the stupid eval_frame canx2 framebit,du tze 3,ic ldx1 ab|frame.prev_frame-6,x7 stx1 lisp_static_vars_$eval_frame+1 eax7 -8,x7 flush the unmkd pdl tra freturn_join go join in with fcn_fin " " this routine is called to unwind the binding block, " and the eval frame (if there is one). It clears " the unmarked pdl and clears the binding block off " of the marked pdl. It must not change x3 (for map). " also unwinds the funarg reversal binding block if fbb flag is on unbinder: " called by tsx0 lxl1 ab|-2,x7 binding_block.bot_block cmpx1 ab|-2,x7 binding_block.top_block tze lambda_completion no bindings at all epbpbp ap|0 adwpbp ab|-2,x7 binding_block.top_block " used to scan top - down unwind_bindings: eppbp bp|-4 -> next binding ldaq bp|0 old value staq bp|2,* put back in atom.value eax1 4,x1 next binding cmpx1 ab|-2,x7 done? - check with binding_block.top_block tnz unwind_bindings-*,ic lambda_completion: eax1 ab|-2,x7 this bb may not have been threaded in (subr) cmpx1 lisp_static_vars_$binding_top+1 tnz 3,ic ldx1 ab|-1,x7 binding_block.back_ptr stx1 lisp_static_vars_$binding_top+1 "if an evalframe was made, destroy it canx2 framebit,du tnz destroy_evalframe lambda_completion_1: canx2 fbb,du funarg bb? tze lambda_completion_2-*,ic no, don't have to unwind it stx5 ab|svx5u,x7 stash registers stx0 ab|svx0u,x7 sxl3 ab|svx3l,x7 sxl4 ab|svx4l,x7 epplb ab|-8,x7 and unwind the funarg reversal bb tsx3 unwind_reversal_bb-*,ic lxl4 ab|svx4l,x7 now reload the regs lxl3 ab|svx3l,x7 ldx0 ab|svx0u,x7 ldx5 ab|svx5u,x7 lambda_completion_2: eppap ap|0,x4 remove cruft from marked pdl eax7 -8,x7 remove cruft from unmarked pdl tra 0,0 & return. destroy_evalframe: ldx1 ab|frame.prev_frame-6,x7 stx1 lisp_static_vars_$eval_frame+1 tra lambda_completion_1 " " the arguments are spread on the marked pdl where the arg function " can get at them. The atomic symbol that was used as a lambda-list " is assigned to the number of arguments. The pseudo-atom "argatom" " in lisp_static_vars_ is assigned to an uncollectable structure " representing the location and number of the stacked up args. " then common code with expr is entered to eval the lambda " body, unwind the bindings, and return. args_spread_for_lexpr: epbpbb ap|0 eax1 ap|0 canx2 already_spread,du args not at top of pdl? tnz 2,ic yes, leave x1 = ap tsx0 set_x1_args-*,ic -> spread arguments ldaq ap|fcn,x4* bind the atomic lambda list staq bb|-2,x1 eppbp lisp_static_vars_$argatom and the "argatom" used by arg function spribp ab|-4,x7 - not really an atom, so have to set ldaq ab|-4,x7 Uncollectable type-bits. ora Uncollectable,dl staq bb|-6,x1 ldq ap|argl,x4 find args. canx2 already_spread,du are they below binding block? tnz 2,ic yes eaq 0,x1 no, args are above binding block eaa 0,x3 number of arguments ora Uncollectable,dl staq bb|-8,x1 lrl 54 shift number of args into ql lda fixnum_type,dl staq bb|-4,x1 tsx0 finish_bindings-*,ic tra eval_lambda_body-*,ic " eval_lsubr: orx2 lsubrbit,du " and fall into eval_subrs_and_arrays eval_subrs_and_arrays: tra arg_spreader-*,ic args_spread_for_subr: canx2 lsubrbit,du tnz args_spread_for_lsubr-*,ic " subr - check arg count cmpx3 ap|fcn,x4* compare number args to number in subr pointer tze 3,ic tnc too_few_args_subr-*,ic trc too_many_args_subr-*,ic call_subr_bbf: canx2 bbf,du tze call_subroutine-*,ic tsx0 set_x1_args-*,ic do funarg stuff before calling subr tsx0 finish_bindings-*,ic " to call a subr, etc. " with the args spread on the marked pdl. " For lsubrs, x6 contains -2*the number of arguments, " which is moved into x5 just before the call. " ap|fcn,x4 points to the subr-link block which contains " a Multics dynamic link to the subr and an interface procedure. call_subroutine: eppbp ap|fcn,x4* -> subr pointer stx5 ab|svx5u,x7 save regs through the call sxl2 ab|svx2l,x7 eax5 0,x6 in case of lsubr, get arg count into x5 tspbp bp|1 returned_from_subroutine: ldx5 ab|svx5u,x7 lxl2 ab|svx2l,x7 lxl4 ab|-2,x7 since only the binding blocks is there now (the subr sbx4 ab|-2,x7 has popped its args), restore proper x4 tra fcn_fin-*,ic go finish up " " args are spread out on stack just like for subr, " but -2 * argcount is passed in x5 so that first arg will be at ap|0,x5 args_spread_for_lsubr: canx2 bbf,du tze 3,ic tsx0 set_x1_args-*,ic tsx0 finish_bindings-*,ic tsx0 ck_lsubr_nargs-*,ic eaq 0,x3 get arg count... qrl 17 ...times -2 negl 0,du eax6 0,ql will be moved into x5 ... tra call_subroutine-*,ic and go call it. " like a subr with one argument, which is the unevaluated list of args eval_fsubr: ldaq ap|argl,x4 move arg list up to 1st arg position eppap ap|2 eax4 -2,x4 staq ap|-2 tra call_subr_bbf-*,ic and go call it. " routine to check number of arguments on an lsubr " called with x3 containing number of args " and ap|fcn,x4 being the subr ptr " called by tsx0. Does not return if number of args is wrong ck_lsubr_nargs: " only check number of arguments in *rset t mode ldaq lisp_static_vars_$star_rset,* cmpaq ab|nil tze 0,0 " check against max & min number of args stored in subr ptr lda ap|fcn,x4* first word of subr pointer has max,min ana =o000777,du get min sta ab|-4,x7 lda ap|fcn,x4* ana =o777000,du get max arl 9 tnz 2,ic lda =o777777,du if 0, substitute a big number sta ab|-3,x7 cmpx3 ab|-4,x7 tnc too_few_args_lsubr-*,ic cmpx3 ab|-3,x7 tze 2,ic trc too_many_args_lsubr-*,ic tra 0,0 " " routine to spread arguments " entered with ap|argl,x4 pointing to argument list " returns with arguments spread out on marked pdl " x3 number of arguments " x4 offset from new top of marked pdl to old top of marked pdl " action is controlled by bits in x2 " noteval 0 - arguments are evaluated " 1 - arguments not evaluated " exprbit controls where arg_spreader returns to " (NB: arg_spreader is called by tra, not tsx) " on return, ap|argl,x4 is unchanged " uses ap|qsrac,x4 to avoid modifying ap|argl,x4 arg_spreader: eax3 0 start with no args canx2 already_spread,du tnz spread_adj-*,ic ldaq ap|argl,x4 copy arg list staq ap|qsrac,x4 spread1: cana lisp_ptr.type,dl any arguments left? tnz spread_no_more-*,ic no. ldaq ap|qsrac,x4* yes, get one eppap ap|2 room to eval it staq ap|-2 eax3 1,x3 count arguments eax4 -2,x4 keep x4 pointing back below arguments canx2 noteval,du should it be evaled? tnz 2,ic no. tsx0 recurse-*,ic yes, so do it. eppbp ap|qsrac,x4* cdr-ize argument list ldaq bp|2 staq ap|qsrac,x4 tra spread1-*,ic spread_no_more: canx2 exprbit,du tnz args_spread_for_expr-*,ic tze args_spread_for_subr-*,ic " come here when spreading args that are already spread " for subr, lsubr have to move them to top of pdl " for expr, lexpr, can leave them where they are spread_adj: ldx3 ap|argl+1,x4 get number of args canx2 exprbit,du expr or subr? tnz args_spread_for_expr-*,ic expr, no problem " subr, make sure args are at top of pdl " they will be unless we had to create a binding block cmpx4 0,du is there a binding block? tze spread_adj_aa-*,ic no, can use args where they stand " have to move args up to top of pdl spread_adj_0: lda ap|argl,x4 au -> start of args epbpbb ap|0 eppbp bb|0,au bp -> start of args eax0 0,x3 number of args spread_up: tze args_spread_for_subr-*,ic all done when x0 = 0 eppap ap|2 eax4 -2,x4 ldaq bp|0 staq ap|-2 eppbp bp|2 eax0 -1,x0 tra spread_up-*,ic " nothing above the args but this ap|form, etc. " so we can remove the eval frame and call the " subr with the args in place spread_adj_aa: canx2 fbb,du can't do this if a funarg tnz spread_adj_0-*,ic ldaq lisp_static_vars_$star_rset,* cmpaq ab|nil - in *rset t mode must keep eval frame for baktrace tnz spread_adj_0-*,ic canx2 framebit,du tze 3,ic ldx1 ab|frame.prev_frame-6,x7 stx1 lisp_static_vars_$eval_frame+1 canx2 lsubrbit,du tnz spread_for_lsubr-*,ic cmpx3 ap|fcn,* check number of args tze 3,ic tnc too_few_args_subr-*,ic trc too_many_args_subr-*,ic call1_call: eppbp ap|fcn,* eppap ap|form eax7 -8,x7 get rid of junk on unmkd pdl tspbp bp|1 tra call1_rtn_1-*,ic spread_for_lsubr: tsx0 ck_lsubr_nargs-*,ic lxl5 ap|argl+1 tra call1_call-*,ic " " routine to determine type of function being used. " on entry ap|fcn,x4 is original function -- usually atom. " on exit, ap|fcn,x4 is function actually to be used, ass follows: " subr,array,fsubr,lsubr: pointer to subr-link block " expr,fexpr,lexpr,macro,lambda: " cdr of lambda-expression, " i.e. cons of lambda-list and body " register usage " ap|qsrac,x4 points to property list " ap|fcn,x4 comes in with function, returns with real function, dep on type " ap|argl,x4 comes in with args, is reset to ap|form if macro " bp " " x3 points to return transfer vector " x6 temporary, + fexpr indicator in ck_lambda " aq in property - list searching loop, contains current " indicator (= bp|0). " x4 offset from top of marked pdl of ap|form, etc. " the bits in x2 exprbit,lsubrbit are NOT set by find_type. " however, macrobit is set (a macro looks like a fexpr " except that this bit is turned on, causing re-evaluation later) find_type: " x3 points to return transfer vector, entries in the following order: " array,subr,lsubr,expr,fexpr,fsubr,lexpr equ array_offset,0 equ subr_offset,1 equ lsubr_offset,2 equ expr_offset,3 equ fexpr_offset,4 equ fsubr_offset,5 equ lexpr_offset,6 " NOTE: nil can never be a function because this code doesn't " know how to get at the property list of nil. anx2 -already_autoloaded_once-1,du " turn off the already autoloaded bit find_type_reenter: ldaq ap|fcn,x4 cana Atsym,dl check for symbol...most common case tze unsymbolic_function eppbp ap|fcn,x4* epplb lisp_static_vars_$function_properties for rpt loop. find_type_1: ldaq bp|2 -> plist cana lisp_ptr.type,dl tnz end_of_plist-*,ic eppbp bp|2,* ldaq bp|0 get the indicator eax6 0 free index register used in rpt loop rpt 8,2,tze scan all 8 indicators, and skip if equal cmpaq lb|0,x6 ttf fn_checks-2,x6 rpt leaves x6 2 too high. skip_autoload: eppbp bp|2,* " try again on next property. tra find_type_1 fn_checks: eax0 subr_offset,x3 tra cksubr " subr eax0 lsubr_offset,x3 tra cksubr " lsubr eax0 fsubr_offset,x3 tra cksubr " fsubr eax6 0 " set x6 0 for ck_lambda tra ck_lambda " expr .. doesn't return tsx6 ck_lambda " fexpr .. doesn't return(sets x6 non-zero too) drl 0 eax0 array_offset,x3 " return for array tra cksubr " array tra ck_macro " macro drl 0 " doesn't return tra ck_autoload " autoload drl 0 " doesn't return " Routine to check for lambda forms (or symbols - synonym hack) " Exits to appropriate transfer vector entry " called with x6 non zero for fexprs and macros. ck_lambda: ldaq bp|2,* make sure is lambda expression staq ap|fcn,x4 cana Atsym,dl Atomic symbol instead of list as fcnl property tnz find_type-*,ic eppbp ap|fcn,x4* lambda expression, get cdr which is lambda-list & body ldaq bp|0 cmpaq lisp_static_vars_$lambda tnz bad_fcnl_form-*,ic ldaq bp|2 xx_lambda: staq ap|fcn,x4 cmpx6 0,du fexpr or macro? tnz fexpr_offset,x3 yes, appropriate exit canx2 macrobit,du Is this a linked macro def? tnz fexpr_offset,x3 Yup, fexpr/macroize it. ldaq ap|fcn,x4* check for lexpr cmpaq ab|nil tze expr_offset,x3 cana Atsym,dl tnz lexpr_offset,x3 yes. tra expr_offset,x3 ck_macro: canx2 applybit,du macros may not be applied! tnz illegal_use_of_a_macro-*,ic orx2 macrobit,du ldaq ap|form,x4 arg to macro is whole body staq ap|argl,x4 tsx6 ck_lambda-*,ic illegal_use_of_a_macro: canx2 ignore_macros,du is this an error? tnz skip_autoload-*,ic no, just ignore the macro prop tra bad_fcnl_form-*,ic yes, barf ck_autoload: canx2 already_autoloaded_once,du tnz skip_autoload " if already autoloaded, try next indicator orx2 already_autoloaded_once,du remember that we did ldaq lisp_static_vars_$user_intr_array+2*(18-1),* user interrupt 18. cmpaq ab|nil tze skip_autoload if autoload interrupt not enabled. eppap ap|6 staq ap|-6 ldaq bp|2,* load value under property staq ap|-2 ldaq ap|fcn-6,x4 " remember we have pushed 6 words on staq ap|-4 " pass cons of name and autoload prop. tsx0 call_cons eax7 10,x7 stx1 ab|-10,x7 stx2 ab|-9,x7 stx3 ab|-8,x7 stx4 ab|-7,x7 stx5 ab|-6,x7 eax5 -4 sprilp ab|-4,x7 stcd ab|-2,x7 tra funcall ldx1 ab|-6,x7 ldx2 ab|-5,x7 ldx3 ab|-4,x7 ldx4 ab|-3,x7 ldx5 ab|-2,x7 eax7 -6,x7 tra find_type_reenter and try again to get function end_of_plist: " atom has no functional properties, eval its value orx2 went_through_value_cell,du ldaq ap|fcn,x4* atom.value tze undef_fcn-*,ic if undefined. cmpaq ap|fcn,x4 Is it bound to itself (e.g. nil)? tze undef_fcn-*,ic yes, avoid embarrassing loop. staq ap|fcn,x4 tra find_type-*,ic unsymbolic_function: cana lisp_ptr.type,dl tze non_atom_fcn cana Subr,dl tnz subr_offset,x3 a direct subr pointer. tra undef_fcn non_atom_fcn: " non-functional function, so eval it. " check for lambda expression or label expression, since we now know it's a list eppbp ap|fcn,x4* ldaq bp|0 car of the list eax6 0 epplb lisp_static_vars_$lambda rpt 3,2,tze cmpaq lb|0,x6 " lambda, label, and funarg are together. ttn x13 ldaq bp|2 tra *+1-2,x6 x6 is set 2 too high on successful compare eax6 0 tra xx_lambda jump to lambda code staq ap|fcn,x4 set fcn tra eval_label staq ap|fcn,x4 tra eval_funarg " just a random list, eval it and use its value as the function x13: ldaq ap|fcn,x4 orx2 went_through_value_cell,du eppap ap|2 staq ap|-2 tsx0 recurse-*,ic "ldaq ap|-2 (the result is really already in aq, also) eppap ap|-2 back up ap, from call. staq ap|fcn,x4 and restore new function. tra find_type-*,ic cksubr: ldaq bp|2,* get the supposed subr pointer cana Subr,dl tze undef_fcn-*,ic not a subr ptr -- barf. staq ap|fcn,x4 yes, subr ptr is fcn we are applying canx2 macrobit,du Is this a subr-macro? tnz fsubr_offset,x3 Treat like fsubr tra 0,0 ck_bound_var: " procedure to check if aq contains " something that can legally be bound. " the object being checked must be in both aq & ap|-2 cana Atsym,dl tze bad_bound_var-*,ic if not even an atomic symbol, barf. cmpaq ab|nil tnz 0,0 ok. " loser trying to bind nil. Give him a nihil ex nihile message loser_binding_nil: lda lisp_error_table_$nihil_ex_nihile tra error-*,ic ...never returns " eval a funarg, which is generated by *function " and looks like: (funarg . ) " stashes the pdl_ptr and sets bbf and fbb flags " so that finish_bindings will reverse context back to this pdl ptr, " after the arguments have been evaled. " substitutes the function from the funarg for the funarg and goes " back into find_type to handle the substituted fnction eval_funarg: eppbp ap|fcn,x4* -> cdr of the funarg list ldaq bp|0 ... the function staq ap|fcn,x4 orx2 bbf+fbb+went_through_value_cell,du lxl1 bp|3 assume proper pdl ptr put by *function tnz 2,ic 0 cuases lossage so check... eax1 1 stx1 ab|funarg_pdlptr,x7 tra find_type-*,ic " " routine to make a pseudo binding block into a real binding block " this is called after argument evaluation, when it safe to make bindings " for funarg, label. " called by tsx0 " changes only registers x0, x1, x6, aq, lb, bb " sets bb to segment number of marked pdl " when called by tsx0, pseudo bb extends from binding_block.top_block to bb|0,x1 finish_bindings: canx2 fbb,du need a reversal bb? tze finish_bindings_aa-*,ic no stx5 ab|svx5u,x7 save registers stx0 ab|svx0u,x7 sxl3 ab|svx3l,x7 sxl4 ab|svx4l,x7 sxl1 ab|svx2l,x7 ldx4 ab|funarg_pdlptr,x7 pick up pdl ptr to be used epplb ab|-8,x7 set ptr to where to put bb tsx3 reverse_binding_context-*,ic switch worlds lxl1 ab|svx2l,x7 lxl4 ab|svx4l,x7 and get registers back lxl3 ab|svx3l,x7 ldx0 ab|svx0u,x7 ldx5 ab|svx5u,x7 finish_bindings_aa: stx1 ab|pdlptr,x7 save top of pseudo bb for compare ldx1 ab|-2,x7 binding_block.top_block, = bottom of pseudo bb epbpbb ap|0 eppap ap|2 temp. "that gets garbage collected ldq lisp_static_vars_$binding_top+1 stq ab|-1,x7 now thread in this block eaq ab|-2,x7 stq lisp_static_vars_$binding_top+1 fin_loop: cmpx1 ab|pdlptr,x7 done whole pseudo bb? tze fin_xx-*,ic yes, return. ldaq bb|0,x1 no, get new value staq ap|-2 save it ldaq bb|2,x1* get old value staq bb|0,x1 put it in binding block eax1 4,x1 stx1 ab|-2,x7 update binding_block.top_block ldaq ap|-2 assign new value to the atom staq bb|2-4,x1* tra fin_loop-*,ic fin_xx: eppap ap|-2 pop off our temp tra 0,0 " proc to set x1 and bb to point at the spread args " called by tsx0 " uses the arg count in x3 " also sets au to offset from top of pdl to 1st arg " thus return values are bb|,x1=abs loc, au=rel loc set_x1_args: epbpbb ap|0 eaa 0,x3 get arg count als 1 - each arg takes 2 words neg 0 eax1 ap|0,au tra 0,0 " segdef stfunction - the lisp *function fsubr, which makes funargs stfunction: " on entry ap|-2 is arg list, i.e. ( . nil) " we want to return the list (funarg . ) " this function is equivalent to: " (defun *function fexpr (x y) (cons 'funarg (cons (car x) y))) " modified 73.11.02 by DAM to get rid of bug of assuming that there is a binding " block for our own invocation eppap ap|4 room for 3 things ldaq ap|-6,* get our first (and only) arg - the function staq ap|-4 ldx1 lisp_static_vars_$binding_top+1 -> most recent binding_block tze stfunction_00-*,ic if no bb at all, don't give 0 pdl ptr lxl0 ab|0,x1 Kludgey way to check if we have own binding block. cmpx0 ab|0,x1 empty binding blocks are only generated by evaluator, tnz 2,ic plus it doesn't hurt to skip over an empty b.b. ldx1 ab|1,x1 this is empty, prob. our own - skip over it eaq 0,x1 -> binding block itself tnz 2,ic stfunction_00: eaq ab|unmkd_stack_bottom,* no binding_blocks, use stack base addr qrl 18 orq -2,du lda fixnum_type,dl staq ap|-2 ldaq lisp_static_vars_$funarg staq ap|-6 eax7 6,x7 tsx0 call_cons-*,ic tsx0 call_cons-*,ic eax7 -6,x7 ldaq ap|-2 eppap ap|-2 tra lisp_rtn_1-*,ic " " handle functional forms such as (label foo (cruft)) " pseudo binds the function name to the function, then substitutes " the new function for the label-expression and goes back to find_type. " NB: atoms with functional properties cannot be successfully " labelled to a recursive function since the property list " is checked before the value. However, this is compatible " since MACLISP has this same bug (or feature). eval_label: eppbp ap|fcn,x4* ldaq bp|0 function name eppap ap|4 eax4 -4,x4 staq ap|-2 tsx0 ck_bound_var-*,ic orx2 bbf+went_through_value_cell,du set flag for pseudo bb existence ldaq bp|2,* 2nd arg to label is function staq ap|-4 rebind it. staq ap|fcn,x4 tra find_type-*,ic now proceed with the labelled function " " Evalhook stuff " lisp_static_vars_$evalhook_status contains one " of the following two instructions: segdef evalhook_on_status,evalhook_off_status evalhook_off_status: nop 0 evalhook checking disabled evalhook_on_status: tsx6 evalhook_check " Come here if evalhook checking is enabled. " ap|-2 contains the item being evaluated. " x1 and x6 are usable but all other registers are to be preserved " if the value of evalhook is non-null it is applied " in place of the evaluation that was to be done evalhook_check: ldaq lisp_static_vars_$evalhook_atom,* cmpaq ab|nil evalhook on? tze 0,x6 no, go on evaling evalhook_trap: eax1 0,x7 eax7 15+32,x7 anx7 -16,du spri ab|-32,x7 sreg ab|-16,x7 eppap ap|8 generate call to apply staq ap|-8 saved value of evalhook staq ap|-4 function to be applied ldaq lisp_static_vars_$evalhook_atom staq ap|-6 atom to be bound ldaq ap|-10 form being evaled staq ap|-2 eax1 ap|-4 top stx1 ab|-12,x7 eax1 ap|-8 bottom sxl1 ab|-12,x7 lda lisp_static_vars_$binding_top+1 sta ab|-11,x7 eax1 ab|-12,x7 stx1 lisp_static_vars_$binding_top+1 ldaq ab|nil evalhook is bound, turn off staq ap|-6,* sprilp ab|-8,x7 prime return blocks sprilp ab|-4,x7 stcd ab|-2,x7 ncons the 2nd arg to apply tra lisp_alloc_$ncons_ eppap ap|2 push result back on stack staq ap|-2 eax5 -4 stcd ab|-2,x7 now apply the evalhooker tra apply_-*,ic staq ap|-6 returned value is new form to eval ldaq ap|-4 restore evalhook value staq ap|-2,* ldx1 ab|-3,x7 unbind stx1 lisp_static_vars_$binding_top+1 lreg ab|-8,x7 restore state lpri ab|-24,x7 eax7 0,x1 ldaq ap|-2 get result in aq tra -2,x6 and return from the evaluation " The evalhook function segdef evalhook evalhook: eax7 4,x7 save evalhook_status, bind evalhook_atom lda lisp_static_vars_$evalhook_status sta ab|-4,x7 lda evalhook_on_status-*,ic sta lisp_static_vars_$evalhook_status eppap ap|6 ldaq lisp_static_vars_$evalhook_atom staq ap|-4 ldaq ap|-4,* staq ap|-6 eax1 ap|-2 stx1 ab|-2,x7 eax1 ap|-6 sxl1 ab|-2,x7 lda lisp_static_vars_$binding_top+1 sta ab|-1,x7 eax1 ab|-2,x7 stx1 lisp_static_vars_$binding_top+1 ldaq ap|-8 bind evalhook to 2nd arg staq ap|-4,* ldaq ap|-10 eval first arg staq ap|-2 tsx5 evalu+1-*,ic go join evaluator after evalhook test eppap ap|-6 staq ap|-8 store result back over first arg ldaq ap|-4 unbind evalhook staq ap|-2,* ldx1 ab|-1,x7 undo binding block stx1 lisp_static_vars_$binding_top+1 lda ab|-4,x7 restore evalhook_status sta lisp_static_vars_$evalhook_status eax7 ab|-4,x7 clear one pdl ldaq ap|-8 get return value eppap ap|-8 clear other pdl tra lisp_rtn_1-*,ic and return " error handlers. bad_fcnl_form: " uncorrectable error! ldaq ap|fcn,x4 eppap ap|2 staq ap|-2 lda lisp_error_table_$bad_function tsx0 error-*,ic bad_fcnl: ldaq ap|form,x4* the fnc name staq ap|fcn,x4 tra bad_fcnl_form-*,ic undef_fcn: ldaq ap|fcn,x4 eppap ap|2 staq ap|-2 lda lisp_error_table_$undefined_function tsx0 error-*,ic "ldaq ap|-2 eppap ap|-2 staq ap|fcn,x4 tra find_type-*,ic subrcall_error: tsx0 foocall_error-*,ic lda lisp_error_table_$subrcall_bad_ptr lsubrcall_error: tsx0 foocall_error-*,ic lda lisp_error_table_$lsubrcall_bad_ptr arraycall_error: tsx0 foocall_error-*,ic lda lisp_error_table_$arraycall_bad_ptr arraycall_mismatch: tsx0 foocall_error-*,ic lda lisp_error_table_$arraycall_wrong_type foocall_error: ldaq ap|fcn the faulty argument staq ap|-2 error is uncorrectable xec 0,x0 lda the error code tsx0 error-*,ic never returns. illegal_f_fcn: " call from compiled code to fsubr/fexpr with args already evaled eppap ap|2 ldaq ap|form-2,x4 staq ap|-2 lda lisp_error_table_$bad_f_fcn tsx0 error-*,ic never returns - uncorrectable bad_bound_var_sp: epplp ab|-4,x7* get back our lp eppap bb|4,x1 from expr_binder, make sure that bad bv " is really located at ap|-2 bad_bound_var: " uncorrectable " the non-atomic symbol trying to be bound is in ap|-2 " callers of ck_bound_var, be sure of this!!!! lda lisp_error_table_$bad_bv tsx0 error-*,ic wrong_no_args_expr: too_many_args_expr: " correctable - by substituting a whole new form too_few_args_expr: ldaq ap|fcn,x4* -> the lambda list eppap ap|4 staq ap|-2 and fall into wna_com " make list of form and its lambda list wna_com: eppap ap|2 total of 6. up ldaq ap|form-6,x4 canx2 applybit,du need to construct fake form? tze wna_com_1-*,ic no. canx2 already_spread,du is there an argl? tnz wna_com_1-*,ic no, can't make fake form so use(atomic) " function name in place of form. staq ap|-2 eppap ap|2 ldaq ap|argl-8,x4 staq ap|-2 tsx0 call_cons-*,ic ldaq ap|-2 wna_com_1: staq ap|-6 ldaq ab|nil staq ap|-2 tsx0 call_cons-*,ic tsx0 call_cons-*,ic lda lisp_error_table_$wrong_no_args tsx0 error-*,ic "ldaq ap|-2 eppap ap|-2 anx2 -macrobit-1,du clear macrobit canx2 mapf,du from map? tnz map_abending-*,ic yes. tra fcn_fin-*,ic wrong_no_args_subr: too_many_args_subr: too_few_args_subr: " make list of form and fake args property (nil.nargs) ldq ap|fcn,x4* qrl 18 lda fixnum_type,dl eppap ap|6 staq ap|-2 ldaq ab|nil cons2zz: staq ap|-4 tsx0 call_cons-*,ic tra wna_com-*,ic wrong_no_args_lsubr: too_many_args_lsubr: too_few_args_lsubr: " make list of form and fake args property (min.max) ldq ap|fcn,x4* qrl 27 max lda fixnum_type,dl eppap ap|6 staq ap|-2 ldq ap|fcn-6,x4* qrl 18 anq =o777,dl min " lda fixnum_type,dl tra cons2zz-*,ic " " " "let" fsubr BSG 09/12/78 " segdef let let: eppap ap|6 Allocate marked PDL work area. eax7 8,x7 Allocate binding block eax6 ap|0 = bot block, now also top. stx6 ab|-2,x7 Init binding block ctrs. sxl6 ab|-2,x7 eax4 0 Current size (-) of binding blk. " " Dredge out the vars for the binding block " ldaq ap|form (let . foo)? cana lisp_ptr.type,dl tnz bad_fcnl-*,ic eppbp ap|form,* bp -> (((var1 val1).... ldaq bp|0 s/b let list cmpaq ab|nil special case this atomic l.l. tze let_ll_done cana lisp_ptr.type,dl Is it atomic, not nil? tnz bad_fcnl-*,ic Yes, (let foo ..) Barf loudly. let_bind_1: "Scan let list. "Rest of let list is in AQ, x4 is -4* nargs processed. cana lisp_ptr.type,dl Done? tnz let_ll_done All done. eppap ap|4 Push marked pdl eax4 -4,x4 staq ap|argl,x4 Set for indirect eppbp ap|argl,x4* bp -> letlist ldaq bp|0 Letlist element cana lisp_ptr.type,dl Atomic, i.e. (let (foo ... tnz bad_fcnl-*,ic This is what interpreters are for. ldaq bp|0,* car of letlist = symbol staq ap|-2 Save lambda var cana Atsym,dl Make lambda var checks. tze bad_bound_var-*,ic cmpaq ab|nil tze loser_binding_nil-*,ic ldaq ap|-2,* Get current val staq ap|-4 Save in binding block. eppbp ap|argl,x4* Point to "rest" of letlist ldaq bp|2 Get that cdr. tra let_bind_1-*,ic let_ll_done: eax1 ap|0 stx1 ab|-2,x7 set binding_block.topblock. ldq lisp_static_vars_$binding_top+1 Avoid fbb hackery for let. stq ab|-1,x7 eaq ab|-2,x7 stq lisp_static_vars_$binding_top+1 " Now eval the things to be assigned. ldaq ap|form,x4* Point at cons which heads let cdr. staq ap|argl,x4 Now have let list. eax3 0,x4 Duplicate x4. eppap ap|2 Push work var. let_bind_2: cana lisp_ptr.type,dl Is it done? tnz let_bind_2_done yes. eppbp ap|argl-2,x4* Point at current letlist head. eppbp bp|0,* Point at car, guaranteed non-atomic ldaq bp|2 Is there a cadr? cana lisp_ptr.type,dl ... tnz let_bind_2_gets_nil no ldaq bp|2,* Get the cadr. staq ap|-2 tsx0 recurse-*,ic Get the result of evalling it. tra *+2-*,ic let_bind_2_gets_nil: ldaq ab|nil staq ap|2-2,3* -2 for atsym, 2 for work temp. eax3 4,3 Account for one var. eppbp ap|argl-2,x4* Point a letlist cons. ldaq bp|2 Get cdr. staq ap|argl-2,x4 Cdr down list. tra let_bind_2 Loop some more. " " Now make like we were a real lambda. " let_bind_2_done: eax2 0 Zero all of Moon's flags. eppap ap|-2 Drop the work temp. ldaq ap|form,x4 Get letlist and body. staq ap|fcn,x4 Put where eval_lambda_body wants it. tsx5 eval_lambda_body-*,ic tra lisp_retn-*,ic " " arg & setarg subrs for lisp segdef arg,setarg,listify argcom: ldaq ap|-2 argument which is arg number. cmpa fixnum_type,dl tze 5,ic wta_arg: lda lisp_error_table_$meaningless_argument_number ldq -1,x2 get fcn name code. tsx0 error-*,ic tra argcom-*,ic cmpx2 qqlistify,du see if called by listify. tnz not_listify-*,ic eax1 0,ql tpl argcom1-*,ic if positive or zero, ok. ldaq lisp_static_vars_$argatom check for lexpr tze bad_use_arg-*,ic adx1 lisp_static_vars_$argatom tmi wta_arg-*,ic if want more args than we got, error. ldx1 lisp_static_vars_$argatom now get last arg addr. tra argcom2-*,ic not_listify: cmpq 1,dl tmi wta_arg-*,ic argcom1: eax1 0,ql " is there really an arg atom? ldaq lisp_static_vars_$argatom tze bad_use_arg-*,ic ****** argatom inited to 0 ****** argcom2: cmpx1 lisp_static_vars_$argatom check against arg count tze 2,ic tpl wta_arg-*,ic epbpbb ap|0 eppbp bb|0,qu start of arguments on stack eppbp bp|-1,x1 eppbp bp|-1,x1 (twice because args are double-words tra 0,5 arg: eax2 qqarg-*,ic ldaq ap|-2 get argument cmpaq ab|nil if nil, get arg count! tnz arg_non_nil ldaq lisp_static_vars_$argatom tze bad_use_arg-*,ic lrl 54 move arg count to q lda fixnum_type,dl tra arg_return arg_non_nil: tsx5 argcom-*,ic ldaq bp|0 the arg arg_return: eppap ap|-2 tra lisp_rtn_1-*,ic listify: eax2 qqlistify-*,ic to get right name for wta message. tsx5 argcom-*,ic go to common code for arg and setarg, " which will get address of last arg to be in list into bp, lda ap|-1 load number of things to be consed. tpl 2,ic neg 0,du " make sure positive. eax1 0,al and put into x1. ldaq ab|nil get nil result. eax7 2,x7 lstfy_loop:eax1 -1,x1 decrement count of things to be consed. tmi lstfy_end sprpbp ab|-2,x7 save ptr to arg. stx1 ab|-1,x7 and number of args. eppap ap|4 get room for args to cons. staq ap|-2 store previous result ldaq bp|0 get next most recent argument from bp staq ap|-4 and make first arg to cons. eax7 4,x7 now call cons sprilp ab|-4,x7 save lp stcd ab|-2,x7 and return addr. tra lisp_alloc_$cons_ and jump. lprpbp ab|-2,x7 get back the ptr to args, ldx1 ab|-1,x7 and count. eppbp bp|-2 move back one arg tra lstfy_loop-*,ic and loop if more args. lstfy_end: eax7 -2,x7 pop off save space eppap ap|-2 and argument tra lisp_rtn_1-*,ic and return. vfd 18/-1,18/fn_listify qqlistify: ldaq ab|nil staq ap|-2 ldaq lisp_static_vars_$qlstfy tra b_u_a_com setarg: eax2 qqsetarg-*,ic ldaq ap|-4 move first arg up eppap ap|2 staq ap|-2 tsx5 argcom-*,ic ldaq ap|-4 get 2nd arg staq bp|0 store into stacked args eppap ap|-6 clear stack tra lisp_rtn_1-*,ic " arg or setarg with no lexpr in process bad_use_arg: eppap ap|4 ldaq ap|-6 staq ap|-4 tra 0,x2 vfd 18/-1,18/fn_arg qqarg: ldaq ab|nil staq ap|-2 ldaq lisp_static_vars_$qarg tra b_u_a_com-*,ic vfd 18/-1,18/fn_setarg qqsetarg: eppap ap|2 this one has two args, have to make list of them ldaq ap|-10 get 2nd arg to setarg staq ap|-4 ldaq ab|nil staq ap|-2 tsx0 call_cons-*,ic ldaq lisp_static_vars_$qsetarg b_u_a_com: staq ap|-6 tsx0 call_cons-*,ic make list of fcn-name and arg list eppap ap|2 ldaq ab|nil staq ap|-2 tsx0 call_cons-*,ic tsx0 call_cons-*,ic lda lisp_error_table_$no_lexpr tsx0 error-*,ic " never returns call_cons: eax7 10,x7 save registers stx0 ab|-5,x7 stx1 ab|-10,x7 stx2 ab|-9,x7 stx3 ab|-8,x7 stx4 ab|-7,x7 stx5 ab|-6,x7 sprilp ab|-4,x7 stcd ab|-2,x7 tra lisp_alloc_$cons_ eppap ap|2 staq ap|-2 ldx1 ab|-6,x7 ldx2 ab|-5,x7 ldx3 ab|-4,x7 ldx4 ab|-3,x7 ldx5 ab|-2,x7 ldx0 ab|-1,x7 eax7 -6,x7 tra 0,x0 " " map functions " written by D. Moon, 3 Aug 72 " the function being mapped is checked first (by find_type) " to see what kind it is. As much of the work of making " binding_blocks, etc. as possible is done once only, instead " of each time the function is called. Then a quick loop is " entered: the arguments are spread out on the pdl, and in the " case of a fsubr or fexpr they are consed up again. The " function is executed, the result it returns is taken care of, " and the loop repeats. When one (or more) of the map lists is " exhausted, control passes to map_ending which cleans up and " returns. Note that becuase of this, if one of the map lists " is initially nil (or atomic) the number-of-arguments " checking may never get done. " use of the marked pdl. " " there is some stuff peculiar to map, and above that " the standard junk used by eval: " " bb|0,x3 " mapfcn function being mapped, as " returned by find_type " firstlist first list being mapped over " . " . " . " firstlist+2n-2 last list being mapped over "(the above are initially the args to 'map', later " cdr-ized or whatever) " mapresult accumulates result of map. " form as in apply " fcn " " argl " " qsrac " "ap|0,x4 " " " - pieces of the lists being mapped over "ap|0 " use of the unmarked pdl " (much same as in apply) " " save x3 and x5 (2 words, peculiar to map) " funarg binding block (2 words) " eval-frame (2 words) " reg save area (2 words) - also handy non-gc temporaries " binding_block (2 words) "ab|0,x7 " " register usage - registers not listed are temp's " " x0 calling (tsx0) " x2 control flags as in eval & apply " x3 -> original args to map, on marked pdl " x4 -size of binding block, as in eval & apply " x5 number of lists being mapped over. " ( = number of args to map-1) " x7 unmarked pdl ptr (with ab) " ap marked pdl ptr " bb marked pdl base, used with x3 to get to mapfcn, map lists " ab unmarked pdl base " define bits in x2 specifically for map bool mapcarf,400000 mapc,mapcar,mapcan if 1 "map,maplist,mapcon if 0 bool mapretf,200000 cons up list of return values bool mapconf,100000 nconc up list of return values bool listargs,40000 fsubr or fexpr bool mapf,20000 so fcn_fin knows where to return to " equ mapfcn,0 equ firstlist,2 equ mapresult,form-2 " equ mapsvx3,-10 equ mapsvx5,-9 PROBABLY NOT USED segdef map,mapc,mapcar,maplist,mapcan,mapcon " " entry points - just set x2 bits & enter common code " these are type 1 lsubr's. " the args property should be (2 . 777) or 777002 map: eax2 applybit+mapf tra mapcom-*,ic mapc: eax2 applybit+mapf+mapcarf tra mapcom-*,ic mapcar: eax2 applybit+mapf+mapcarf+mapretf tra mapcom-*,ic maplist: eax2 applybit+mapf+mapretf tra mapcom-*,ic mapcan: eax2 applybit+mapf+mapcarf+mapconf tra mapcom-*,ic mapcon: eax2 applybit+mapf+mapconf "tra mapcom-*,ic " mapcom: epbpbb ap|0 eax3 ap|0,x5 points to our args (lsubt) eaa 0,x5 get number of lists being ars 19 mapped over in x5 neg 0 eax5 -1,al " if map or mapc, have to save first list so we can return it canx2 mapretf+mapconf,du tnz mapc_klg_xx-*,ic not map or mapc, skip it eppap ap|2 sanwich in between map lists and mapresult,etc. ldaq bb|firstlist,x3 staq ap|-2 mapc_klg_xx: eppap ap|-mapresult get room to work eax7 10,x7 .. eax6 ap|0 stx6 ab|-2,x7 binding_block.top_block sxl6 ab|-2,x7 binding_block.bot_block eax4 0 ...binding block is empty (now) ldaq ab|nil staq ap|mapresult init. ldaq bb|mapfcn,x3 staq ap|form staq ap|fcn - as in apply stx3 ab|mapsvx3,x7 save ptr to our arguments " in *rset t mode, make eval_frame ldaq lisp_static_vars_$star_rset,* cmpaq ab|nil tze map_mnf-*,ic eax6 sp|1 apply-type frame stx6 ab|frame.dat1-6,x7 eax6 ap|form fcn being mapped sxl6 ab|frame.stack_ptr-6,x7 ldx6 lisp_static_vars_$eval_frame+1 stx6 ab|frame.prev_frame-6,x7 eax6 ab|-6,x7 stx6 lisp_static_vars_$eval_frame+1 orx2 framebit,du map_mnf: tsx3 find_type-*,ic go analyze the fcn being mapped " return transfer vector for find_type tra map_subr-*,ic array tra map_subr-*,ic subr tra map_lsubr-*,ic tra map_expr-*,ic tra map_fexpr-*,ic tra map_fsubr-*,ic tra map_lexpr-*,ic " " set up various things on return from find_type " called by tsx0 map_set_up: ldx3 ab|mapsvx3,x7 restore x3 epbpbb ap|0 base of marked pdl ldaq ap|fcn,x4 save fcn for multiple applications staq bb|mapfcn,x3 eax1 ap|0 since mapped fcns never eval their args, tra finish_bindings-*,ic it is safe to make the pseudo bb a real bb now " " set up to map a fexpr map_fexpr: tsx0 map_set_up-*,ic orx2 listargs+exprbit,du tsx0 lambda_bind-*,ic cmpx6 1,du how many lambda variables? tnc bad_fcnl-*,ic 0 -- lose. tze map_go-*,ic 1 -- easy. " 2 -- bind 2nd to pdl ptr eaq ab|-2,x7 make pdl ptr -> binding block qrl 18 orq -2,du lda fixnum_type,dl staq ap|-2,* tra map_go-*,ic " set up to map an expr -- or '(lambda ( ) ...) map_expr: tsx0 map_set_up-*,ic orx2 exprbit,du tsx0 lambda_bind-*,ic stx5 ab|svx5u,x7 cmpx6 ab|svx5u,x7 right number of args? tze map_go-*,ic yes. tsx6 make_argl-*,ic no, give error tra wrong_no_args_expr-*,ic " set up to map a lexpr " we can bind both the lambda atom and the argatom now, " since we know how many args and where they will be. map_lexpr: tsx0 map_set_up-*,ic orx2 exprbit+lsubrbit,du eppap ap|8 going to bind two things eax4 -8,x4 ldaq ap|fcn,x4* get the lambda - atom staq ap|-2 tsx0 ck_bound_var-*,ic ldaq ap|-2,* staq ap|-4 eppbp lisp_static_vars_$argatom spribp ab|-4,x7 save area is not in use right now ldaq ab|-4,x7 ora Uncollectable,dl not really an atom staq ap|-6 ldaq ap|-6,* staq ap|-8 eax1 ap|0 stx1 ab|-2,x7 update binding_block.top_block eaq ap|0 loc. of spread args eaa 0,x5 number of args ora Uncollectable,dl staq ap|-6,* bind "argatom" lrl 54 lda fixnum_type,dl staq ap|-2,* bind lambda-atom tra map_go-*,ic " " set up to map a subr - check number of args map_subr: tsx0 map_set_up-*,ic cmpx5 ap|fcn,x4* check number of args tze map_go-*,ic ok. tsx6 make_argl-*,ic no, error tra wrong_no_args_subr-*,ic " set up to map an fsubr - not hard map_fsubr: tsx0 map_set_up-*,ic orx2 listargs,du tra map_go-*,ic " set up to map an lsubr - check number of args map_lsubr: tsx0 map_set_up-*,ic orx2 lsubrbit,du ldaq lisp_static_vars_$star_rset,* cmpaq ab|nil - only check # args in *rset t mode tze map_go-*,ic lda ap|fcn,x4* ana =o000777,du min sta ab|-4,x7 lda ap|fcn,x4* ana =o777000,du max arl 9 tnz 2,ic lda =o777777,du if max=0, use big number sta ab|-3,x7 cmpx5 ab|-4,x7 tnc map_tfa_lsubr-*,ic cmpx5 ab|-3,x7 tze map_go-*,ic tnc map_go-*,ic map_tma_lsubr: tsx6 make_argl-*,ic tra too_many_args_lsubr-*,ic map_tfa_lsubr: tsx6 make_argl-*,ic tra too_few_args_lsubr-*,ic " " routine to put arguments up on top of marked pdl " this is the map version of arg_spreader " requires bb,x3 set up to get to map lists " requires x5 to contain arg count " updates x4 " uses x1,aq " Doesn't change x6 or bb " called by tsx0 mv_args: eax1 bb|firstlist,x3 eaa 0,x5 get number of lists times 2 als 1 sta ab|svx5u,x7 asx1 ab|svx5u,x7 used by cmpx1 to end the loop mv_args_loop: cmpx1 ab|svx5u,x7 done all map lists? tze 0,0 yes. ldaq bb|0,x1 no, get one. cana lisp_ptr.type,dl end? tnz map_ending-*,ic yes, go clean up canx2 mapcarf,du tze 2,ic ldaq bb|0,x1* eppap ap|2 eax4 -2,x4 staq ap|-2 put an arg on pdl eax1 2,x1 ..and advance to next list tra mv_args_loop-*,ic " " routine to cons up an argument list " used by fsubr, fexpr, and wrong_no_args " called by tsx6 (yes 6, not 0) " bb,x3 must be set up to get to map lists " x5 must contain number of map lists " uses x1 " destroys bb " leaves x4, ap unchanged " returns the argument list in ap|argl,x4 " this routine operates by calling mv_args to spread them out, " then it pushes a nil on top of pdl to end the list, " and calls cons enough times to bring them all down " into a list. " the entry point make_argl_nmv is for when mv_args " has already been called make_argl: tsx0 mv_args-*,ic first spread them out... make_argl_nmv: eppap ap|2 then put a nil at the end ldaq ab|nil staq ap|-2 eax7 4,x7 -- extra save area stx5 ab|-1,x7 adx4 ab|-1,x7 adjust x4 back to what it should be, adx4 ab|-1,x7 after all the consing is done stx6 ab|-2,x7 save our return addr tsx0 call_cons-*,ic -- known to be at least 1 arg sbx5 1,du tnz -2,ic ldx6 ab|-2,x7 ldx5 ab|-1,x7 "ldaq ap|-2 eppap ap|-2 eax7 -4,x7 staq ap|argl,x4 tra 0,6 " " here we have the routine to actually apply the function map_go3: ldx3 ab|mapsvx3,x7 restore x3 after function call map_go: epbpbb ap|0 bb may have been munged tsx0 mv_args-*,ic spread out the args ldaq bb|mapfcn,x3 get the fcn staq ap|fcn,x4 where eval wants it canx2 exprbit,du expr type or subr type? tnz map_do_expr-*,ic " subr type canx2 listargs,du fsubr? tnz map_do_fsubr-*,ic yes. canx2 lsubrbit,du lsubr? tze call_subroutine-*,ic no, subr is simple eaa 0,x5 yes, make argcount als 1 neg 0 eax6 0,au tra call_subroutine-*,ic map_do_fsubr: tsx6 make_argl_nmv-*,ic ldaq ap|argl,x4 eppap ap|2 pass arg list on top of marked pdl eax4 -2,x4 staq ap|-2 tra call_subroutine-*,ic " expr type map_do_expr: canx2 listargs,du fexpr? tnz map_do_fexpr-*,ic yes. " do any necc bindings then go to eval_lambda_body canx2 lsubrbit,du lexpr? tnz map_do_lexpr-*,ic yes - go reassign nargs to lambda atom " bind lambda variables for expr - args are on marked pdl ldaq ap|fcn,x4* = lambda list ldx1 ab|-2,x7 binding_block.top_block = base of args map_expr_bind_loop: cana lisp_ptr.type,dl end? tnz map_expr_bind_end-*,ic yes... staq ap|qsrac,x4 no. epplb ap|qsrac,x4* ldaq bb|0,x1 get an arg staq lb|0,* assign a var eax1 2,x1 ldaq lb|2 tra map_expr_bind_loop-*,ic map_expr_bind_end: ldx1 ab|-2,x7 remove spread args from pdl eppap bb|0,x1 lxl4 ab|-2,x7 reset x4 sbx4 ab|-2,x7 tra eval_lambda_body-*,ic " bind 1 lambda variable of fexpr map_do_fexpr: tsx6 make_argl_nmv-*,ic eppbp ap|fcn,x4* cons lambdalist body eppbp bp|0,* cons firstlambdavar restoflambdalist ldaq ap|argl,x4 get argument list staq bp|0,* assign it to first lambda-var tra eval_lambda_body-*,ic " for a lexpr, reset the lambda atom to the number of args " each time in case loser clobbers it: " (map '(lambda y (setq y 'foo)) '(1 23) '(4 5)) map_do_lexpr: eaq 0,x5 get nargs qrl 18 lda fixnum_type,dl convert to lisp-number eppbp ap|fcn,x4* -> atom_ptr -> atom.value staq bp|0,* store into atom's value cell tra eval_lambda_body-*,ic now go eval fcn " " come here after one evaluation by map " causes cleanup, resultmunging, and around again going " NB: x3 doesn't get restored until we go back to map_go3 map_fcn_fin: ldx1 ab|-2,x7 remove spread args from pdl if still there epbpbb ap|0 (lexpr) eppap bb|0,x1 lxl4 ab|-2,x7 reset x4 sbx4 ab|-2,x7 "" Now (after calling the fcn) cdr-ize all the lists " at this point we assume x5 has arg count and x3 can be loaded to point at lists ldx3 ab|mapsvx3,x7 eax1 bb|firstlist,x3 eax6 0,x5 x1 -> list, x6 = counter tze map_cdr_loop_end-*,ic map_cdr_loop: eppbp bb|0,x1* -> cons whose car has been done. ldaq bp|2 cdr of that cons staq bb|0,x1 eax1 2,x1 eax6 -1,x6 count the lists tnz map_cdr_loop-*,ic map_cdr_loop_end: canx2 mapretf,du tnz map_ret_er-*,ic canx2 mapconf,du tnz map_con_er-*,ic tra map_go3-*,ic -- go around again map_ret_er: eax1 map_go3 eppap ap|4 ldaq ap|qsrac-4,x4 current result staq ap|-4 ldaq ap|mapresult-4,x4 last cons in list of previous results, cdr = first cons cmpaq ab|nil first time? tze map_ret_1st-*,ic eppbp ap|mapresult-4,x4* no, get cdr ldaq bp|2 staq ap|-2 tsx0 call_cons-*,ic ldaq ap|-2 eppbp ap|mapresult-2,x4* staq bp|2 staq ap|mapresult-2,x4 eppap ap|-2 tra 0,x1 map_ret_1st: staq ap|-2 tsx0 call_cons-*,ic ldaq ap|-2 eppap ap|-2 staq ap|mapresult,x4 eppbp ap|mapresult,x4* staq bp|2 set cdr back to start of list tra 0,x1 " map_con_er: eax0 map_go3 ldaq ap|mapresult,x4 eppap ap|4 staq ap|-4 ldaq ap|qsrac-4,x4 staq ap|-2 eax7 6,x7 get space to save regs, make call. stx2 ab|-6,x7 store registers we still need stx5 ab|-5,x7 save x5, since we will clobber it. sxl0 ab|-5,x7 save x0, our return ptr sxl4 ab|-6,x7 also save x4. eax5 -4 nconc gets 2 args, lsubr convention. sprilp ab|-4,x7 save our lp... stcd ab|-2,x7 save return address. tra lisp_alloc_$nconc ldx2 ab|-2,x7 reload registers. ldx5 ab|-1,x7 lxl0 ab|-1,x7 lxl4 ab|-2,x7 eax7 -2,x7 and pop off stack staq ap|mapresult,x4 save result of nconc. tra 0,0 " come here when freturn returns from a function being mapped " have to re-establish binding block, & c. " and restart the mapping process all over again. map_freturn: eax4 0 the binding block is all gone canx2 mapretf,du tnz map_ret_er_freturn canx2 mapconf,du " and fall into map_freturn_restart map_freturn_restart: " re-make binding block eax6 ap|0 stx6 ab|-2,x7 sxl6 ab|-2,x7 ldaq ap|form the fcn being mapped staq ap|fcn put it back tra map_mnf map_ret_er_freturn: eax1 map_freturn_restart tra map_ret_er+1 map_con_er_freturn: eax0 map_freturn_restart tra map_con_er+1 tra map_freturn_restart " " "come here when map is done. map_ending: " first get the result into proper form canx2 mapretf,du tze map_ending_aa-*,ic ldaq ap|mapresult,x4 check for nil cmpaq ab|nil tze map_ending_2-*,ic nil => don't rplacd eppbp ap|mapresult,x4* mapcar, uncircularize return list ldaq bp|2 staq ap|qsrac,x4 ldaq ab|nil - put nil at end of list staq bp|2 ldaq ap|qsrac,x4 get back ptr to start of list tra map_ending_2-*,ic map_ending_aa: canx2 mapconf,du tnz map_ending_1-*,ic mapresult already ok if mapconf " map or mapc, return first map list as result ldaq ap|mapresult-2,x4 was saved here on entry tra map_ending_2-*,ic map_abending: map_ending_2: staq ap|mapresult,x4 map_ending_1: ldx3 ab|mapsvx3,x7 get back x3 tsx0 unbinder-*,ic eax7 -2,x7 pop map's extra 2 words ldaq ap|mapresult = out return value awdx ap|0,x3 clear rest of marked pdl tra lisp_rtn_1-*,ic " routine to evaluate the bodies of prog's and do's " called with a pointer to the stack cell containing the " body of the prog or do on top of unmarked pdl. Pops it off, " evaluates the nonatomic elements of the body, ignoring the " values, and returns when it gets to the end. entry eval_list eval_list: tsx0 pl1_entry-*,ic eppap ap|10 room to eval in eppbp ab|-2,x7* -> stack temp containing body eax7 -2,x7 eppbp bp|-2 look like a cons " cdr-ize the list and eval next element ev_list_1: ldaq bp|2 is cdr atomic? cana lisp_ptr.type,dl .. tnz ev_list_end-*,ic yes. eppbp bp|2,* no, point bp at cdr spribp ap|-10 and save it (no type bits since is list) ldaq bp|0 get cadd...ddr of body cana lisp_ptr.type,dl tnz ev_list_2-*,ic skip over it if it is atomic staq ap|form otherwise, evaluate it tsx5 eval_fcn-*,ic ev_list_2: eppbp ap|-10,* get back a ptr to current cons of list tra ev_list_1-*,ic and go eval next elem ev_list_end: eppap ap|-4 clear the pdl tra pl1_return-*,ic and return. " the return function, a type 1 subr segdef return return: eppap ap|2 put 2 things at top of pdl: lda Uncollectable,dl 1) the return value staq ap|-2 2) a non_nil value to distinguish from go tra go_ret-*,ic and return to prog " the go function, a type 1 fsubr segdef go go: ldaq ap|-2,* get our arg eppap ap|6 room to eval in " keep evaling the arg until it is atomic re_go: cana lisp_ptr.type,dl tnz go_1-*,ic staq ap|form tsx5 eval_fcn-*,ic tra re_go-*,ic go_1: staq ap|form save label on marked pdl for prog ldaq ab|nil and put nil to mark this as a go staq ap|form+2 eppap ap|form+4 go_ret: " now do a non-local goto to the most recent prog (or do) ldx1 lisp_static_vars_$prog_frame+1 tze bad_go-*,ic err if no prog active " prog is a pl1 program, so return to pl1_code mode spriap ab|stack_ptr_ptr,* stx7 ab|unmkd_ptr_ptr,* stc1 ab|in_pl1_code eax2 sp|0 are we in same stack frame as prog? cmpx2 ab|frame.ret+3,x1 (this is the usual case) tze go_ret_same_sp-*,ic yes, go without changing sp " check if there possibly could be cleanup handlers in the stack cmpx1 lisp_static_vars_$err_recp+1 tnc go_ret_full_unwind might be cleanup handlers, have to go call unwinder_ eppbp ab|frame.ret+2,x1* no, get ptr to stack frame of prog spribp sp|16 delete intervening frames. (allowed since " there are no cleanup handlers in lisp) eax2 bp|0 eppbp ab|frame.ret,x1* get return address spribp sb|20,x2 set call out return addr in prog's frame return " quickly return to prog go_ret_same_sp: eppbp ab|frame.ret,x1* spribp sp|20 short_return " come here when go or return is done with no prog active bad_go: lda lisp_error_table_$bad_prog_op tsx0 error-*,ic arg 0 uncorrectable fail-act, should never return " have to do the go by calling unwinder. go_ret_full_unwind: push "must save ab, x1 - get ready to call unwinder_ tempd Argl(2) arg list of one arg ldaq arg_list_1_hdr staq Argl eppbp ab|frame.ret,x1 -> label to return to spribp Argl+2 eppap Argl short_call unwinder_$unwinder_ even arg_list_1_hdr: zero 2,4 zero 0,0 negative_4: zero 0,fixnum_type dec -4 " come here to call a function with unevaluated arguments from " lisp-compiled code. ap|form=ap|fcn=function, ap|argl = arg list, " unmkd pdl has: ptr to link, caller's lp, return addr(bp) " we find the type of the function and if its an fsubr link directly " to it, otherwise go through regular apply. segdef callf callf: eax2 applybit eax5 callf_rtn-*,ic tsx3 evaler1-*,ic " return transfer vector for find_type tra eval_subrs_and_arrays-*,ic array tra eval_subrs_and_arrays-*,ic subr tra eval_lsubr-*,ic lsubr tra eval_expr-*,ic expr tra eval_fexpr-*,ic fexpr tra callf_fsubr-*,ic fsubr - special case tra eval_lexpr-*,ic lexpr " callf to an fsubr -- attempt to direct-link it callf_fsubr: tsx0 snappable_p-*,ic snappable? tra eval_fsubr-*,ic no. " yes, so do it. ldaq ap|fcn,x4 get subr ptr adq 1,du place to tspbp to stz lisp_static_vars_$no_snapped_links eppbb ab|-12,x7* caller's lp eax0 -1 ansx0 bb|-6 clear low half - clears no snapped links bit staq ab|-14,x7* store over link tsx0 unbinder-*,ic get rid of binding block, eval frame ldaq ap|argl put argl back where it was when we were called staq ap|form eppap ap|form+2 epplp ab|-4,x7* restore caller's lp eppbp ab|-2,x7* eax7 -6,x7 pop off our temps tra bp|-1 return to the tspbp which now goes " direct to the subr " come here when done with a callf. This routine packs up and goes home. callf_rtn: eppap ap|form epplp ab|-4,x7* eppbp ab|-2,x7* eax7 -6,x7 tra bp|0 return with result in aq " routine to apply subr's to arguments which are already separated by lisp code. entry pl1_callable_funcall_ pl1_callable_funcall_: tsx0 pl1_entry Establish ALM environment lxl5 ap|-1 Get # of args eppap ap|-2 Pop arg count tsx0 funcall0 eppap lp|2 Pop stack, leave ret loc. staq ap|-2 getlp tra pl1_exit segdef funcall funcall: tsx0 funcall0 eppap lp|0 pop stack tra lisp_rtn_1 and return to caller funcall0: eax5 2,x5 tpnz fc_0_args eppap ap|-form ldaq ap|form-2,x5 staq ap|form staq ap|fcn eax2 applybit+already_spread+entered_by_funcall eax7 6,x7 ldaq negative_4 for causing fault if used! staq ab|-6,x7 eppbp ap|form-2,x5 we want to sve location to which to pop spribp ab|-4,x7 which will come back in lp eppbp 0,x0 Set exit spribp ab|-2,x7 tra fc_join fc_0_args: drl 0 """ fsubr's arraycall, subrcall, lsubrcall. segdef arraycall,subrcall,lsubrcall subrcall: tsx4 foocall-*,ic tra subrcall_error-*,ic lda ap|fcn,* make sure it really is a subr. cana =o777000,du tnz subrcall_error-*,ic looks more like an lsubr, barf. tra evaler-*,ic OK, go apply it. lsubrcall:tsx4 foocall-*,ic tra lsubrcall_error-*,ic lda ap|fcn,* make sure it really is an lsubr cana =o777000,du tze lsubrcall_error-*,ic looks more like a subr. orx2 lsubrbit,du tra evaler-*,ic OK, go apply it. arraycall:eppap ap|2 ldaq ap|-4 staq ap|-2 ldaq ap|-2,* get car of arglist, which is type staq ap|-4 save it. tsx4 foocall-*,ic tra arraycall_error-*,ic cana Array,dl make sure it really is an array. tze arraycall_error-*,ic no, barf. eppbp ap|fcn,* pick up array pointer ldx0 bp|7 pick up type off array ldaq ap|form-2 pick up type in other form xec array_test,x0 see if it is right type tnz arraycall_mismatch-*,ic type mismatch, loser. tsx5 evaler-*,ic OK, go call the array. eppap ap|form-2 clear all stuff from stack tra lisp_rtn_1-*,ic array_test: cmpaq lisp_static_vars_$t_atom cmpaq lisp_static_vars_$nil cmpaq lisp_static_vars_$fixnum cmpaq lisp_static_vars_$flonum cmpaq lisp_static_vars_$readtable cmpaq lisp_static_vars_$obarray tra arraycall_mismatch foocall: eppap ap|-form-2 eppbp ap|form,* -> arg list eppbp bp|2,* discard the type. eax2 applybit no form available, but arguments are to be evaluated. ldaq bp|0 get the alleged subr pointer. staq ap|-2 which has to be evaluated ldaq bp|2 get list of arguments to be passed staq ap|argl eax7 8,x7 tsx0 recurse-*,ic evaluate the subr pointer eax7 -8,x7 staq ap|form and put it away staq ap|fcn cana Subr,dl is it at least a subr pointer? tze 0,x4 no, couldn't possibly win eax5 lisp_retn-*,ic set exit going to use. tra 1,x4 " come here to call a function with already evaluated arguments from " lisp - compiled code. ap|form = fcn, x5 = -2*nargs, unmkd pdl " has: ptr to link, caller's lp, return addr (bp) " underneath ap|form on the marked pdl we have the args " we first call find_type and then if possible " change the link to point directly to the function, otherwise " call it in the usual way and then return the result. segdef call1 call1: eax2 applybit+already_spread ldaq ap|form staq ap|fcn needs to be in both places " set ap|argl to an Uncollectable object containing " nargs in qu and -2*nargs in ql and ptr to args in au " the already_spread bit in x2 indicates that this is not an argl fc_join: "funcall joins here. eaa 0,x5 ars 19 neg 0 al has nargs eaq 0,x5 lrl 18 qu has nargs, ql has -2*nargs eaa ap|form,x5 ptr to args ora Uncollectable,dl staq ap|argl eax5 call1_rtn-*,ic where to come back to after applying tsx3 evaler1-*,ic go to find_type " return transfer vector for find_type tra cc_subr-*,ic array tra cc_subr-*,ic subr tra cc_lsubr-*,ic lsubr tra eval_expr-*,ic expr - same as usual tra call1_fexpr_check-*,ic fexpr - lose, args already evaled tra call1_fsubr_check-*,ic fsubr - lose, args already evaled tra eval_lexpr-*,ic lexpr - same as usual call1_fexpr_check: eax0 eval_fexpr fc_f_fcn_check: canx2 entered_by_funcall,du tze illegal_f_fcn ldx3 ap|argl+1,x4 check n args cmpx3 1,du tpnz too_many_args_subr tmi too_few_args_subr ldaq ap|form-2,x4 staq ap|argl,x4 tra 0,x0 call1_fsubr_check: tsx0 fc_f_fcn_check tra eval_fsubr " routines for lsubr's and subr's which check to see if direct linking can " be used. If so they change the link and then return to the tspbp, " otherwise they go through the regular cruft cc_lsubr: orx2 lsubrbit,du canx2 entered_by_funcall,du tnz eval_lsubr lda ab|-14,x7* get first word of link ana =o77700,dl cmpa =o77700,dl was x5 loaded by caller? tnz eval_lsubr-*,ic if not, must interpret call. cc_subr: tsx0 snappable_p-*,ic snappable? tra cant_snap-*,ic no. " yes, so do it. " seems to be snappable, check the number of args ldx3 ap|argl+1 get number of args called with canx2 lsubrbit,du tnz cc_lsubr_ckna-*,ic cmpx3 ap|fcn,* tze 3,ic tnc too_few_args_subr-*,ic trc too_many_args_subr-*,ic cc_lsubr_ck_ret: " snappable, so change the link to point directly at the function instead of at us ldaq ap|fcn,x4 get subr ptr adq 1,du -> place to tspbp to stz lisp_static_vars_$no_snapped_links eppbb ab|-12,x7* caller's lp staq ab|-14,x7* store over link eaa -1 now clear his no snapped links bit ansa bb|-6 can_snap: tsx0 unbinder-*,ic get rid of binding block, eval frame lxl5 ap|argl+1 get back caller's x5 eppap ap|form set ap back to caller">'s value epplp ab|-4,x7* restore caller's lp eppbp ab|-2,x7* eax7 -6,x7 set x7 back to caller's value tra bp|-1 return to the tspbp, which now goes " direct to the subr. " unspappable, do it the regular way cant_snap: canx2 lsubrbit,du tnz eval_lsubr-*,ic tra eval_subrs_and_arrays-*,ic cc_lsubr_ckna: tsx0 ck_lsubr_nargs-*,ic tra cc_lsubr_ck_ret-*,ic " " routine to see if this call can be snapped, i.e. if the " itb link through which we were called can be changed " to point directly at the function. " called by tsx0, skip return if snappable snappable_p: canx2 entered_by_funcall+went_through_value_cell,du tnz 0,0 cmpx4 0,du tnz 0,0 lxl6 ab|-14,x7* test snap bit in calling link tpl 0,0 ldaq lisp_static_vars_$nouuo_flag,* cmpaq ab|nil tnz 0,0 suppressed by user tra 1,0 - can snap, skip return. " the lisp nouuo function, which is a type 1 subr of one arg " If the arg is nil, snapping is allowed. If anything else (t), " snapping is disallowed. segdef nouuo nouuo: ldaq ap|-2 get arg eppap ap|-2 cmpaq ab|nil is it nil? tze 2,ic ldaq ab|true no, assume t. staq lisp_static_vars_$nouuo_flag,* tra lisp_rtn_1-*,ic " come here when done evaling from a call1 call1_rtn: lxl5 ap|argl+1 eppap ap|form,x5 call1_rtn_1: epplp ab|-4,x7* eppbp ab|-2,x7* eax7 -6,x7 tra bp|0 return with result in aq " " snapcaller -- entry for pl1 subrs with function args that are " called repeatedly to use for applying the " function arg to its arguments. It acts " quite similarly to callf and call1, since " it takes a function to be called, and replaces " that function with a pointer to the subroutine " entry if the number args match. " " called with ab|-2,x7 containing offset of " function from stack top, and ab|-1,x7 " containing -2*nargs, and with the arguments " on the top of the marked pdl. " Last modified by D Reed, 7/7/73 entry snapcaller snapcaller: tsx0 pl1_entry lxl0 ab|-2,x7 get offset of fcn from stack top lxl5 ab|-1,x7 and -2*nargs into x5. ldaq ap|0,x0 load function cana Subr,dl if function is a subr object tze chk_snapper canq 1,du and points at odd address, tze chk_snapper call_snapped: tspbp ap|0,x0* call the subr. eppap ap|2 get room to return result staq ap|-2 and do it. tra pl1_exit return to caller chk_snapper: eax2 applybit+already_spread eppap ap|-form get save area staq ap|form and initialize it staq ap|fcn eaa 0,x5 put special object in ap|argl neg 0 ars 19 eaq 0,x5 lrl 18 eaa ap|form,x5 address of args. ora Uncollectable,dl staq ap|argl ... eax5 snapcall_rtn-*,ic set return for snapcall resulting in apply tsx3 evaler1 tra sn_subr tra sn_subr subrs and arrays tra sn_lsubr tra eval_expr tra illegal_f_fcn bad function tra illegal_f_fcn tra eval_lexpr interpret lexpr sn_lsubr: orx2 lsubrbit,du note that lsubr is slightly different. sn_subr: canx2 went_through_value_cell,du check for snappability. tnz sn_cant cmpx4 0,du if bindings made, cant dnap tnz sn_cant ldx3 ap|argl+1 get number of args canx2 lsubrbit,du tnz sn_lsubr_ckna cmpx3 ap|fcn,* (check number of args, note x4 = 0) tze 3,ic tnc too_few_args_subr-*,ic tra too_many_args_subr-*,ic sn_lsubr_chk_ret: tsx0 unbinder-*,ic get rid of junk lxl5 ap|argl+1 reload x5 for call lxl0 ab|-2,x7 reload offset of function ldaq ap|fcn adq 1,du make address odd. staq ap|form,x0 snap link eppap ap|form tra call_snapped and do the call sn_lsubr_ckna: tsx0 ck_lsubr_nargs tra sn_lsubr_chk_ret sn_cant: canx2 lsubrbit,du if cant snap, then apply function tnz eval_lsubr tra eval_subrs_and_arrays snapcall_rtn: lxl5 ap|argl+1 eppap ap|form+2,x5 get place to store argument staq ap|-2 tra pl1_exit include stack_header end  lisp_alloc_.alm 11/05/86 1612.7r w 11/04/86 1039.1 305631 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** name lisp_alloc_ " lisp allocator. use static " static variables. join /link/static segdef alloc_info alloc_info: segdef alloc_fault_word alloc_fault_word: dec 0 " this word is non-zero to indicate that interrupts " must be masked temporarily, while data is inconsistent. " upper half is set to non-zero, lower two bits recor " quit and alarm faults as they happen, for later signalling. segdef gc_blk_cntr gc_blk_cntr: dec 0 " this word counts the number of blocks to garbage collection. " if negative, that many more 16K blocks will be allocated. segdef seg_blk_cntr seg_blk_cntr: dec 0 " this word counts the number of blocks left before the " end of the current segment. even segdef consptr consptr: its -1,1,ad " this pointer points at the segment's ad indirect word. segdef cur_seg cur_seg: its -1,1 " this pointer points at the current segment's base. " use program join /text/program " subroutines to go from lisp calling discipline to PL/I and back. " tempd arglist(4),new_seg_ptr even noargs: oct 4 oct 0 header_for_1_arg: oct 2000004 " pl1 arg header, 1 argument. oct 0 save_for_pl1_call: " routine to switch to PL/I conventions, and get a stack " frame to call out from. spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code " remember we are using these conventions now. push eppbp |[lisp_alloc_] set entry pointer spribp sp|stack_frame.entry_ptr tra 0,x6 " return. x6 is not used by save macro. pop_back_to_lisp: " routine to get rid of stack frame, " and re-enter lisp code. sprisp sb|stack_header.stack_end_ptr eppsp sp|16,* " get back to prev stack frame. switch_to_lisp: " alternate entry for entering lisp conventions. epbpab |[unmkd_ptr],* eppap |[stack_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code tra 0,x6 " return to caller. " " Subroutine to allocate 4 words for a cons. called with a tsx6. cons_alloc: stc1 lp|alloc_fault_word " inhibit interrupts. eppbp lp|consptr,* " use pointer with ad modifier to do work. ttn tally_out ret_alloc: ldac lp|alloc_fault_word ana =o7,dl " mask out low order bits. tze 0,x6 " return if no interrupts. " " code to handle faults in alloc here. " alloc_got_fault: " operators for allocation join here after saving other things. eax7 4,x7 " get space to save useful regs. spribp ab|-4,x7 " bp points to space we just allocated. sta ab|-2,x7 " a contains argument for fault decoding. stx6 ab|-1,x7 " x6 contains eventual return address. sxl5 ab|-1,x7 tsx6 save_for_pl1_call-*,ic " save, and switch to pl1 conventions. eppbp |[unmkd_ptr],* eppbp bp|-2 " get address of saved fault bits. spribp arglist+2 " and set as first arg to handler ldaq header_for_1_arg-*,ic " get arglist header for 1 arg. staq arglist eppap arglist short_call |[alloc_fault] tsx6 pop_back_to_lisp-*,ic " remove stack frame, and reload ap,ab,x7. ldx6 ab|-1,x7 " reload return address. lxl5 ab|-1,x7 "reload saved x5. eppbp ab|-4,x7* " reload pointer to space allocated. eax7 -4,x7 tra 0,x6 tally_out: aos lp|gc_blk_cntr " one less block remains till gc. tmi 2,ic " if more before gc, continue. tsx4 must_gc-*,ic " if no more, go gc. aos lp|seg_blk_cntr " one less block in segment, too. tze get_new_seg-*,ic " get new segment if needed. " otherwise, check for interrupt, and return. tra ret_alloc " " Subroutine to allocate words (multiple of 4) in q. Called with tsx6. segdef words_alloc words_alloc: stc1 lp|alloc_fault_word " inhibit interrupts. eax0 -4,ql " number of words to allocate. eppbp lp|consptr,* " let the ad modifier do the work. " if no tally out, keep going. ttn tally_done-*,ic " otherwise, end of core block. alloc_loop: eax0 -4,x0 " 4 more words gotten by ad modifier, tmi ret_alloc-*,ic " if no more, then we can return! eax1 lp|consptr,* " ad modifier gets more space, as side effect. ttf alloc_loop-*,ic " and if not at end of block, keep going. tally_done: aos lp|gc_blk_cntr " reduce number of blocks before next gc. tmi 2,ic " if more before gc, continue. tsx4 must_gc-*,ic " if no more, garbage collect now. aos lp|seg_blk_cntr " reduce number of blocks to seg end. tmi alloc_loop-*,ic " if still more in segment, just continue. tra get_new_seg-*,ic locked_alloc: " routine to alloc words when already locked, and no gc allowed eax1 *+2 "simulate stc1 effect. stx1 lp|alloc_fault_word eax0 -4,ql eppbp lp|consptr,* ttn lock_tally_done lock_alloc_loop: eax0 -4,x0 tmi 0,x6 eax1 lp|consptr,* ttf lock_alloc_loop lock_tally_done: aos lp|gc_blk_cntr " caller's responsibility to check gc_blk_cntr. aos lp|seg_blk_cntr tmi lock_alloc_loop tra get_new_seg " " Subroutine to get a new allocation segment. lp|alloc_fault_word is set, " so a ret instruction will go back and redo allocation. get_new_seg: eax7 2,x7 " get room for save of caller's return address stx6 ab|-2,x7 sxl5 ab|-2,x7 " save x5 for lsubr callers. stq ab|-1,x7 " and num words to allocate. tsx6 save_for_pl1_call-*,ic " go to PL/I calling conventions. eppbp new_seg_ptr " get address of pointer arg. spribp arglist+2 ldaq header_for_1_arg-*,ic staq arglist call |[get_lists](arglist) ldaq lp|cur_seg " get cur segment ptr eppbp new_seg_ptr,* " get pointer to new seg base. staq bp|0 " thread in old segment. spribp lp|cur_seg " and make new segment the current segment. eppbp bp|2 " get pointer to ad tally word. spribp lp|consptr " store it away. lda =o53,dl " load ad modifier value orsa lp|consptr+1 " and put in the further modification " part of its pointer. lda =o4740004 " load actual tally word initial value sta bp|0 " and store it in segment's tally word. lca 16,dl " load minus number of 16K blocks in segment. sta lp|seg_blk_cntr " so the end of segment will be caught. tsx6 pop_back_to_lisp-*,ic ldq ab|-1,x7 " reload saved registers. ldx6 ab|-2,x7 lxl5 ab|-2,x7 " reload x5 for lsubr callers. eax7 -2,x7 " pop back unmarked stack, ldx0 lp|alloc_fault_word " and return to restart point of allocation routine. tra 0,x0 " " Subroutine which calls the garbage collector, and reinitializes data " before restarting allocation again. " called with a tsx4, returns to just after tsx4 if gc inhibited, otherwise, " returns to restart address in alloc_fault_word, as old allocation meaningless. " must_gc: szn |[garbage_collect_inhibit] tnz 0,x4 " return if gc inhibited, and don't gc until next block done. " and don't gc till next block done. eax7 2,x7 " get space to save registers. stx6 ab|-2,x7 sxl5 ab|-2,x7 " save x5 for lsubr callers stq ab|-1,x7 tsx6 save_for_pl1_call-*,ic eppap noargs-*,ic short_call |[lisp_garbage_collector_] tsx6 pop_back_to_lisp-*,ic ldq ab|-1,x7 " reload saved registers. ldx6 ab|-2,x7 " .. lxl5 ab|-2,x7 eax7 -2,x7 ldx0 lp|alloc_fault_word " restart allocation again. tra 0,x0 " "operators for compiled code to allocate conses. " by using these operators, compiled code is made more compact " and locally more efficient. segdef cons_opr cons_opr: tsx6 opr_cons cons_opr_com0: staq bb|0 store aq into car of allocated cons cons_opr_com1: tsx6 opr_ck_fault check for faults in cons ldaq bb|0 reload aq from car tra bp|0 return to caller segdef ncons_opr ncons_opr:tsx6 opr_cons ncons_opr_com: staq bb|0 store arg into car of allocated cons ldaq ab|nil staq bb|2 store nil into cdr of allocated cons tra cons_opr_com1 segdef xcons_opr xcons_opr:tsx6 opr_cons staq bb|2 tsx6 opr_ck_fault ldaq bb|2 reload aq from cdr of cons tra bp|0 segdef begin_list_opr operator to get the first element of a list begin_list_opr: tsx6 opr_cons eppap ap|2 push result on stack for later list oprs. spribb ap|-2 tra cons_opr_com0 segdef append_list_opr append_list_opr: tsx6 opr_cons eax6 2 to save a register spribb ap|-2,*x6 rplacd onto old list spribb ap|-2 and store in old list place. tra cons_opr_com0 segdef terminate_list_opr terminate_list_opr: tsx6 opr_cons eax6 2 spribb ap|-2,*x6 rplacd onto end of list eppap ap|-2 wipe temp off stack tra ncons_opr_com and set portions of new cons. " Operator to cons up a string " called by tspbp with length (in characters) in q " returns pointer to string in both bb and aq. stringlength is stored segdef cons_string cons_string: eax5 0,ql save length adq 15+4,dl allow for length word + 4-word blocks qrs 4 divide by 4 chars/wd + 4 wds/block qls 2 then allow for words_alloc strangeness eax7 2,x7 save caller's lp and address sprplp ab|-2,x7 sprpbp ab|-1,x7 epplp ab|system_lp,* tsx6 words_alloc get space for the string eppbb bp|0 and move pointer into proper register lprplp ab|-2,x7 restore regs lprpbp ab|-1,x7 stz bb|0 set length word sxl5 bb|0 .. spribb ab|-2,x7 move bb into aq ldaq ab|-2,x7 ora String,dl eax7 -2,x7 tra bp|0 " " common routine to allocate a cons for the operators " " uses lb to point to linkage section, " returns result in bb, " saves aq, bp, lp, x6. opr_cons: epplb ab|system_lp,* get our lp into lb register stc1 lb|alloc_fault_word lock out interrupts eppbb lb|consptr,* allocate a cons ttf 0,x6 and if no tally runout, return aos lb|gc_blk_cntr check for gc. tmi no_opr_gc tsx4 save_regs_call save regs and execute next instruction. tra must_gc tsx4 unsave_regs no_opr_gc:aos lb|seg_blk_cntr check if out of segment room tmi 0,x6 if not, can return tsx4 save_regs_call tra get_new_seg div 0,dl get_new_seg returns to reallocate " never to here (hopefully) save_regs_call: eppap ap|2 eax7 2,x7 staq ap|-2 save aq on marked stack sprplp ab|-2,x7 save lp sprpbp ab|-1,x7 and bp epplp lb|0 get lb into lp. ldx5 lb|alloc_fault_word kludge saving restart address in x5 eax3 unsave_retry and storing addr of unsaver in restart address stx3 lb|alloc_fault_word eax4 1,x4 get real return address xec -1,x4 and execute instruction after call unsave_retry: eax4 0,x5 restart at allocation point unsave_regs: ldaq ap|-2 reload aq epplb lp|0 move lp into lb again lprplp ab|-2,x7 reload caller's lp lprpbp ab|-1,x7 and bp stx5 lb|alloc_fault_word restore stc1 word to original state eppap ap|-2 pop off stack eax7 -2,x7 tra 0,x4 and return " " routine used by oprs to check for faults while allocating " " clobbers a register. opr_ck_fault: ldac lb|alloc_fault_word unit operation ana =o7,dl mask out fault bits tze 0,x6 if no fault, return eax5 0,x6 save x6 in x5 eax7 4,x7 spribb ab|-4,x7 save registers not saved in other allocator fault checker sprilp ab|-2,x7 epplp lb|0 tsx6 alloc_got_fault epplb lp|0 unsave stuff epplp ab|-2,x7* eppbb ab|-4,x7* eax7 -4,x7 tra 0,x5 return to caller " entry lisp_alloc_ " pl1 callable allocation routine. lisp_alloc_: eppbp ap|0 " get pointer to arg list. tsx6 switch_to_lisp-*,ic " load ab, ap, x7 etc. eax7 2,x7 " get some space for second arg pointer save. ldaq bp|4 " load pointer to second arg. staq ab|-2,x7 " and save it. ldq bp|2,* " load first arg, number of words needed. adq 3,dl " round it to mod 4. anq =o777774,dl " and ignore high order bits too. tsx6 words_alloc-*,ic " allocate number of words in q, return in bp. spribp ab|-2,x7* " save in second argument. eax7 -2,x7 ret_to_pl1: " return to pl1 conventions. spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code short_return " return to caller, no stack frame exists. " " Entries called from pl1 programs in the lisp system. " called as lisp_special_fns_$xxxx. entry cons cons: tsx6 switch_to_lisp-*,ic " switch to lisp calling conventions. eax7 4,x7 " get room to do a lisp call to cons_ sprilp ab|-4,x7 " store lp stcd ab|-2,x7 " store return address. tra cons_-*,ic pl1_ret: eppap ap|2 " get room to push result on stack. staq ap|-2 " and push it. tra ret_to_pl1-*,ic " return and switch back to pl1 conventions. entry xcons xcons: tsx6 switch_to_lisp-*,ic eax7 4,x7 sprilp ab|-4,x7 " call to xcons_ via lisp call. stcd ab|-2,x7 tra xcons_-*,ic tra pl1_ret-*,ic entry ncons ncons: tsx6 switch_to_lisp-*,ic " switch to lisp calling conventions. eax7 4,x7 sprilp ab|-4,x7 stcd ab|-2,x7 tra ncons_-*,ic tra pl1_ret-*,ic entry list list: tsx6 switch_to_lisp-*,ic lxl5 ap|-1 " laod number of args * -2 eppap ap|-2 " pop off stack. eax7 4,x7 sprilp ab|-4,x7 stcd ab|-2,x7 tra list_-*,ic tra pl1_ret-*,ic entry list_star list_star: tsx6 switch_to_lisp lxl5 ap|-1 " laod number of args * -2 eppap ap|-2 " pop off stack. eax7 4,x7 sprilp ab|-4,x7 stcd ab|-2,x7 tra list_star_ tra pl1_ret entry gensym gensym: tsx6 switch_to_lisp-*,ic lxl5 ap|-1 get number args into x5 eppap ap|-2 pop off stack eax7 4,x7 get room to save lp and return link sprilp ab|-4,x7 stcd ab|-2,x7 tra gensym_-*,ic and call lisp gensym function. tra pl1_ret-*,ic then return entry subst subst: tsx6 switch_to_lisp eax7 4,x7 sprilp ab|-4,x7 stcd ab|-2,x7 tra subst_ tra pl1_ret entry nreverse nreverse: tsx6 switch_to_lisp eax7 4,x7 sprilp ab|-4,x7 stcd ab|-2,x7 tra nreverse_ tra pl1_ret entry get_fault_word get_fault_word: " subroutine to get a copy of alloc_fault_word, and zero it at the same time. " must be done in a way such that interrupts don't foul it up. " interrupts can or new things into the fault word... stz ap|2,* " zero result. gfw_lp: lda lp|alloc_fault_word " get fault word. orsa ap|2,* " or bits gotten into result. ersa lp|alloc_fault_word " and clear those bits in the fault word. tnz gfw_lp-*,ic " if more bits turned on since two insts. ago, get them. short_return entry set_fault set_fault: lda ap|2,* orsa lp|alloc_fault_word " set fault on. short_return " segdef cons_ cons_: tsx6 cons_alloc-*,ic "allocate 4 words for cons ldaq ap|-4 "load soon-to-be car staq bp|0 "make it car. ldaq ap|-2 "load soon-to-be cdr xcret: staq bp|2 spribp ap|-2 ldaq ap|-2 "get result in aq eppap ap|-4 "pop back stack retrn: epplp ab|-4,x7* "reload caller's lp eppbp ab|-2,x7* "and bp eax7 -4,x7 tra bp|0 return segdef xcons_ xcons_: tsx6 cons_alloc-*,ic "get 4 words ldaq ap|-2 "load car staq bp|0 ldaq ap|-4 "load cdr tra xcret-*,ic "and join with cons code. segdef ncons_ ncons_: tsx6 cons_alloc-*,ic "get 4 words ldaq ab|nil staq bp|2 ldaq ap|-2 staq bp|0 spribp ap|-2 ldaq ap|-2 eppap ap|-2 tra retrn-*,ic segdef list_star_ list_star_: eax5 2,x5 "we need one fewer cons than list_ does "Avoid ap push. Our 'cddddddr' tail is "already same place as list's running tail. tnz list_lp "so skip nil and make list tra ret_list "one arg, we are noop, pop and return arg segdef list_ list_: eppap ap|2 "get room for tail of list ldaq ab|nil "load initial tail. staq ap|-2 cmpx5 0,du "check x5 for no args. tze ret_list-*,ic list_lp: tsx6 cons_alloc-*,ic ldaq ap|-2 "load tail of list staq bp|2 "and make it cdr ldaq ap|-4 staq bp|0 "make next last thing car. spribp ap|-4 eppap ap|-2 "pop off old tail. eax5 2,x5 "one less arg. tnz list_lp-*,ic ret_list: ldaq ap|-2 "load last result. eppap ap|-2 "pop off stack tra retrn-*,ic " gensym function...coded in alm for speed. segdef gensym_ " regular lisp subr entry point. gensym_: cmpx5 0,du " check for any arguments tmi set_gensym_data-*,ic " and jump to special routine if so. gensym_begin: ldq 8,dl " need 8 words for the atom. tsx6 words_alloc-*,ic lda 5,dl " put 5 in name length field. sta bp|4 ldaq ab|nil " and nil in property list. staq bp|2 aos ab|gensym_data+1 increment the counter lda ab|gensym_data+1 check for wrap-around cmg 9999,dl tmoz 2,ic stz ab|gensym_data+1 wraps around to 0 instead of 1. OK? btd (pr),(pr) now convert to decimal and stick into pname desc9a ab|gensym_data+1,4 desc9ns bp|5(1),4 mlr (pr),(pr) don't forget the "g" desc9a ab|gensym_data,1 desc9a bp|5,1 epaq bp|0 get atomic symbol as lisp object in aq eaa 0,au clear out ring number ora Atsym+35,dl turn on type bit and 043 modifier tra retrn-*,ic set_gensym_data: ldaq ap|-2 cmpa fixnum_type,dl " check for new index tnz chk_prefix-*,ic stq ab|gensym_data+1 store new index in binary tra set_gensym_loop-*,ic chk_prefix: cana Atsym,dl " prefix set from atomic symbol tze gensym_err-*,ic eppbp ap|-2,* lda bp|5 " get prefix, sta ab|gensym_data "and save it. set_gensym_loop: eppap ap|-2 eax5 2,x5 " bump back pointers, tpl gensym_begin-*,ic " and start if done with arguments. tra set_gensym_data-*,ic gensym_err: eax7 4,x7 " get room for error data and save area. lda bad_arg_correctable,dl lcq -fn_gensym,dl staq ab|-2,x7 stx5 ab|-4,x7 tsx6 save_for_pl1_call-*,ic eppap noargs-*,ic short_call |[lisp_error_] tsx6 pop_back_to_lisp-*,ic ldx5 ab|-2,x7 eax7 -2,x7 tra set_gensym_data-*,ic " try again if error returns. " copysymbol function. takes two args, first is atsym, second flag. " makes new atom with same pname as first, if flag is nil, it is otherwise unsharing. " if flag is t, will put copy of prop list on as its prop list, and copy the value. segdef copysymbol copysymbol: ldaq ap|-4 "get arg. cana Atsym,dl tnz copysym eppap ap|-4 " should be error? we just return arg. tra retrn copysym: eppap ap|2 " get working space. eppbp ap|-6,* ldq bp|4 " get length of pname adq 35,dl " round to 4 word multiple qrs 4 " .. qls 2 " .. tsx6 words_alloc " allocate new atom. spribp ap|-2 lda Atsym,dl orsa ap|-2 eppbb ap|-6,* " get pointer to original atom. ldq bb|4 " get length stq bp|4 " and set length of new atom mlr (pr,rl),(pr,rl) " move in name. desc9a bb|5,ql desc9a bp|5,ql " done move ldaq ap|-4 " check falg. cmpaq ab|nil tnz copypropl staq bp|2 nullify prop list tra return_copy copypropl: ldaq bb|0 " get value staq bp|0 eppap ap|4 " args for append ldaq ap|-10 " see if symbol being copied is nil cmpaq ab|nil tze copypropl_nil-*,ic " yes, get property list from different place. ldaq bb|2 " get old prop list copypropl_0: staq ap|-4 ldaq ab|nil staq ap|-2 eax5 -4 eax7 4,x7 " get room for push of return addr sprilp ab|-4,x7 stcd ab|-2,x7 tra append " call append eppbb ap|-2,* " get poiner to new atom staq bb|2 " and store new prop list return_copy: ldaq ap|-2 eppap ap|-6 tra retrn copypropl_nil: ldaq |[property_list_of_nil] tra copypropl_0-*,ic " append and nconc subroutines. both are lsubrs with any number of args. segdef append append: cmpx5 0,du " check for no args tze ret_nil-*,ic " return nil in this case. eppap ap|4 " get room for result, and scanning pointer. eax7 2,x7 " also, save stack popping point, stx5 ab|-2,x7 " so x5 can be changed.... skip_atoms: " first skip leading atomic arguments. ldaq ap|-4,x5 " load next arg, eax5 2,x5 " and move up stack, tze ret_arg-*,ic " but if last arg, just return. cana Atomic,dl " check for atom tnz skip_atoms-*,ic " and skip if so. tsx6 cons_alloc-*,ic " allocate initial cons, and make it the result. ldaq ap|-6,x5* " copy car of current list in... staq bp|0 " .... spribp ap|-4 " make this the result. aplp: spribp ap|-2 " make allocated cons the scan pointer. eppbp ap|-6,x5* " move to next list cell of argument. ldaq bp|2 " ... staq ap|-6,x5 " ... chk_list: cana Atomic,dl " check to see if we are still following a list. tnz end_list-*,ic tsx6 cons_alloc-*,ic " allocate another cell. ldaq ap|-6,x5* " copy car of this list cell in. staq bp|0 " ... eax2 2 " set cdr of scan pointer to new cell spribp ap|-2,*x2 " ... tra aplp-*,ic " and continue, updating scan pointer. end_list: ldaq ap|-4,x5 " load next argument. eax5 2,x5 " and move up arg list. tmi chk_list-*,ic " if not last arg, continue. eppbp ap|-2,* " otherwise, make last arg cdr of final list. staq bp|2 " ... ldaq ap|-4 " load result. ret_arg: ldx5 ab|-2,x7 " reload x5. eax7 -2,x7 " pop stack. eppap ap|-4,x5 " ... tra retrn-*,ic segdef nconc nconc: eax4 0,x5 " save height of stack to restore to. tze ret_nil-*,ic " if no args, nil is the result. eax5 2,x5 tze retn-*,ic " if one arg, just return it. eppbp ap|-4,x5 " bp points so that bp|2 is replaced " by next arg, always. nclp: lxl0 bp|2 " load type field of cdr. canx0 Atomic,du " check for atom. tnz zap-*,ic eppbp bp|2,* " go to cdr otherwise. tra nclp-*,ic " and continue looking for end. zap: ldaq ap|0,x5 " load next arg. staq bp|2 " zap it in cdr of list. eax5 2,x5 " bump number of args. tnz nclp-*,ic " if more, continue down new list. retn: ldaq ap|0,x4 " load first arg, eppap ap|0,x4 " and return it. tra retrn-*,ic ret_nil: ldaq ab|nil " load nil tra retrn-*,ic " and return it. " lisp reverse and nreverse functions... " they reverse a list argument by copying in the first instance, " or by rplacd's in the second instance. " both are type 1 subrs. " segdef reverse reverse: ldaq ap|-2 load argument. cana Atomic,dl and check for atom tze not_atom_reverse eppap ap|-2 tra retrn return directly if not list. not_atom_reverse: eppap ap|2 get storage to play with. ldaq ab|nil init result to nil. staq ap|-2 rev_loop: tsx6 cons_alloc get a cons cell ldaq ap|-2 and move previous result into its cdr. staq bp|2 .. spribp ap|-2 make this cons the new result. eppbp ap|-4,* load the car of the remainder of the argument ldaq bp|0 staq ap|-2,* and move it into the car of the new result. ldaq bp|2 now load the cdr of the argument staq ap|-4 and make it the new argument. cana Atomic,dl check to see if more to reverse. tze rev_loop if more, continue.... ldaq ap|-2 load up the result eppap ap|-4 tra retrn and return. segdef nreverse_ nreverse subr...pl1-callable version also in this module. nreverse_:eppap ap|2 get a temporary ldaq ab|nil staq ap|-2 ldaq ap|-4 unshare nreconc at this point 6/11/80 cana Atomic,dl atoms lose here tnz nrev_ret nrev_loop:eppbp ap|-4,* get pointer to cons... ldaq bp|2 staq ap|-4 move its cdr to the result location. ldaq ap|-2 load previous result pointer. staq bp|2 and make it the cdr of the result. spribp ap|-2 now the back pointer points at the current cell. ldaq ap|-4 load the next result. cana Atomic,dl check for atom, which would lose.... tze nrev_loop ldaq ap|-2 load up the back pointer. nrev_ret: eppap ap|-4 tra retrn return result. segdef nreconc_ nreconc subr...nreverse followed by nconc...joins here nreconc_: ldaq ap|-4 cana Atomic,dl check for atom which terminates list. tze nrev_loop fixed nreconc 6/11/80 BSG ldaq ap|-2 tra nrev_ret " lisp subst subroutine...copies a list, making substitutions. segdef subst_ there is also a pl1-callable entry point. subst_: eax5 -6 note the stack depth at entry time. ldaq ap|-2 tsx6 subst_loop call the right subroutine to do the job. eppap ap|-6 pop stack tra retrn and return. subst_loop: cmpaq ap|2,x5 compare current lisp value with second arg. tze ret_1st_arg if same, replace with first arg. cana Atomic,dl check to see if a leaf of the tree. tnz 0,x6 and return if so. eax5 -2,x5 add to the depth of the args. eppap ap|2 get room for recursion eax7 2,x7 on both stacks. staq ap|-2 save argument. stx6 ab|-2,x7 save return address ldaq ap|-2,* load car of argument. tsx6 subst_loop call subst recursively. eppbp ap|-2,* staq ap|-2 store result of subst on car, ldaq bp|2 and load the cdr. tsx6 subst_loop call subst again. eppap ap|2 get room to save aq staq ap|-2 tsx6 cons_alloc call the allocator. ldaq ap|-4 now fill in cons pointed at by bp. staq bp|0 ldaq ap|-2 staq bp|2 spribp ap|-2 move bp to aq ldaq ap|-2 eppap ap|-4 and pop stack. eax5 2,x5 ldx6 ab|-2,x7 reload return address. eax7 -2,x7 pop unmarked stack tra 0,x6 and return. ret_1st_arg: ldaq ap|0,x5 load 1st arg to top call. tra 0,x6 and return it. """ sublis hacked to use rpt instruction """ 74.04.27 by DAM " Register conventions " " aq passing arguments in and out of sublis1 " x7 unmkd pdl ptr as usual " x6 subroutine calling. note sublis1 skip returns if it was unchanged. " x5 value to go in x0 for rpt to scan table. " x4 number of 256 - item table portions " x3 temp. " x2 always contains 2, for cdr'ing " x1 temp " x0 temp " bp cons ptr " lb temp " bb -> array of atoms and substitute expressions in stack " " stack conventions " " ab|-2,x7 register save area for sublis_cons " ab|-1,x7 LH - save x6 for recursive calls. " RH - register save area for sublis_cons segdef sublis bool rpt_tze,100 sublis: "" first step - construct a table from the first argument. eppbb ap|0 -> table eax5 0 number of entries in table eax2 2 ldaq bb|-4 get list of dotted pairs sublis0: cana lisp_ptr.type,dl tnz got_sublis_table epplb bb|-4,* get cons of list ldaq lb|0,* get atomic symbol eppap ap|4 append to table eax5 1,x5 increase count staq ap|-4 ldaq lb|0,*2 get expression to substitute for symbol staq ap|-2 ldaq lb|2 cdr the first argument staq bb|-4 tra sublis0 got_sublis_table: eaa 0 eaq 0,x5 set up registers for rpt later lls 10 qls 0 tnz 2,ic sba 1,dl 0=256. eax5 rpt_tze,qu value to go in x0 (first rpt count) eax4 1,al value to go in x1 (number of repetitions) tmoz no_sublis nothing to do. "" second stage - begin scanning argument. ldaq bb|-2 second argument tsx6 sublis1 nop 0 in case it skip returns. eppap bb|-4 pop stack and return the result tra retrn no_sublis: ldaq bb|-2 eppap bb|-4 tra retrn sublis1: "" sublis the form in aq - return addr is at ab|-2,x7 cana lisp_ptr.type,dl atom? tze sublis2 no, cdr down it. " this is an atom, so look it up in the table. " HERE IS THE GROSSNESS: eax1 0,x4 eax3 0 eax0 0,x5 sublis_rpt: rptx ,4 cmpaq bb|0,x3 ttf sublis_substitute_here eax0 rpt_tze repetitions after first are 256. at a time eax1 -1,x1 tnz sublis_rpt tra 1,x6 not found, leave it the same. sublis_substitute_here: ldaq bb|-2,x3 x3 4 too high. Pick up thing to be substituted. tra 0,x6 return non-skipping to indicate change. sublis2: "" sublis of a cons. do car and cdr eax7 2,x7 eppap ap|2 staq ap|-2 stx6 ab|-1,x7 save previous return address ldaq ap|-2,* car tsx6 sublis1 tra sublis_car_changed changed, have to make a new cons. ldaq ap|-2,*2 no, get cdr tsx6 sublis1 tra sublis_cdr_changed changed, have to make a new cons. ldaq ap|-2 no change, return same old cons. eppap ap|-2 ldx6 ab|-1,x7 eax7 -2,x7 tra 1,x6 sublis_cdr_changed: tsx6 sublis_cons staq bp|2 store new cdr ldaq ap|-2,* staq bp|0 store new car spribp ap|-2 store back new cons sublis_change_exit: ldaq ap|-2 eppap ap|-2 ldx6 ab|-1,x7 eax7 -2,x7 tra 0,x6 it changed sublis_car_changed: tsx6 sublis_cons make new cons staq bp|0 save car ldaq ap|-2,*2 get old cdr spribp ap|-2 store back new cons tsx6 sublis1 sublis the cdr nop 0 doesn't matter whether it changed staq ap|-2,*2 store cdr tra sublis_change_exit sublis_cons: " special cons routine for sublis, avoids munging aq, bb, x5,x4, " returns cons ptr in bp. " called by tsx6 eppap ap|2 got to save aq across ldac, gc staq ap|-2 save regs sarbb ab|-2,x7 KLUDGE sxl4 ab|-2,x7 sxl6 ab|-1,x7 tsx6 cons_alloc lxl6 ab|-1,x7 lxl4 ab|-2,x7 ldaq ap|-2 eppap ap|-2 now how am I going to get out of this one? epbpbb ap|0 KLUDGE adwpbb ab|-2,x7 .. (note - due to hardware bug must be even address) eax2 2 x2 has to always have 2 in it. tra 0,x6 " functions to deal with value cells. " boundp returns t if bound, nil if not (changed 9/12/74) " makunbound makes an atom unbound at this binding level -- usually top level. " segdef boundp boundp: eax4 0,ic " remember retry address. ldaq ap|-2 " load argument. cana Atsym,dl tze not_atsym-*,ic " signal error. ldaq ap|-2,* " load value cell. tze not_bound-*,ic " return nil if not bound. ldaq ab|true eppap ap|-2 " pop off argument tra retrn-*,ic " else return t not_bound: eppap ap|-2 " pop off argument. tra ret_nil-*,ic segdef makunbound makunbound: eax4 0,ic " remember retry address. ldaq ap|-2 cana Atsym,dl tze not_atsym-*,ic fld 0,du " zero is the unbound marker. staq ap|-2,* ldaq ap|-2 eppap ap|-2 tra retrn-*,ic not_atsym:lda bad_arg_correctable,dl cmpx4 boundp,du " determine which function got error. tze 3,ic lcq -fn_makunbound,dl " and load correct error code tra 2,ic " .. lcq -fn_boundp,dl " .. eax7 4,x7 stx4 ab|-4,x7 "save return address. staq ab|-2,x7 tsx6 save_for_pl1_call-*,ic eppap noargs-*,ic short_call |[lisp_error_] tsx6 pop_back_to_lisp-*,ic ldx4 ab|-2,x7 " get back retry address. eax7 -2,x7 tra 0,x4 " and retry. " " maknum function, returns unique number. segdef maknum equ prime,338417659 " or maybe 2796203 equ maknum_initial,32 maknum: eax7 2,x7 stc1 lp|alloc_fault_word szn |[maknum_mask] tpl maknum1 ldq maknum_initial*2,dl tsx6 locked_alloc spribp |[maknum_table_ptr] lcq maknum_initial/2,dl stq |[maknum_left] stz |[maknum_next] ldq maknum_initial*8-1,dl stq |[maknum_mask] maknum1: ldaq ap|-2 cana Fixed+Float,dl tnz maknumber alr 18 " move seg number to Q... lrs 18 maknumber: ars 6 " type field to low char of A staq ab|-2,x7 mpy =v36/prime qrs 18 qls 3 eppbp |[maknum_table_ptr],* epplb ab|-2,x7 loopmake: anq |[maknum_mask] cmpc (pr,ql),(pr) desc9a bp|0(3),5 desc9a lb|0(3),5 tze found_maknum cmpc (pr,ql) desc9a bp|0,4 desc9a 0,0 tze maknewnum adq 8,dl tra loopmake found_maknum: qrs 2 ldq bp|0,ql lda fixnum_type,dl staq ab|-2,x7 ldac lp|alloc_fault_word ana =o7,dl tze nomakfault tsx6 alloc_got_fault nomakfault: ldaq ab|-2,x7 eax7 -2,x7 eppap ap|-2 tra retrn maknewnum: aos |[maknum_left] tpl rehash eppbb |[maknum_next] aos bb|0 mlr (pr),(pr,ql) desc9a bb|0(1),3 desc9a bp|0,3 mlr (pr),(pr,ql) desc9a lb|0(3),5 desc9a bp|0(3),5 tra found_maknum rehash: ldq |[maknum_mask] qls 1 "double table size orq 1,dl stq |[maknum_mask] adq 1,dl qls 18-3 stq ab|-2,x7 qrs 18-1 tsx6 locked_alloc "alloc while already locked. tsx6 maknum_rehash szn lp|gc_blk_cntr tmi maknum1 " if overflowed gc limit, go to must_gc. eax0 maknum1 stx0 lp|alloc_fault_word tsx4 must_gc tra maknum1 " subroutine to rehash a maknum table into another. " args: bp -> new table space. " |[maknum_table_ptr] -> old table space. " ab|-2,x7 (DU) has size of old table in words. " |[maknum_mask] has new table size in chars (-1) " sets: maknum_table_ptr to point to new table. " maknum_left to trigger next rehash. maknum_rehash: eppbb |[maknum_table_ptr],* spribp |[maknum_table_ptr] stz ab|-1,x7 "count moves. eax0 0 rhsh_loop:cmpx0 ab|-2,x7 tze done_rhsh ldq bb|0,x0 "check for stuff tze skip_rhsh ldq bb|1,x0 mpy =v36/prime qrs 18 qls 3 rhshlp1: anq |[maknum_mask] cmpc (pr,ql) "check for enpty slot desc9a bp|0,4 desc9a 0,0 tze insrt adq 8,dl tra rhshlp1 insrt: qrs 2 eax1 0,ql ldaq bb|0,x0 staq bp|0,x1 aos ab|-1,x7 skip_rhsh:eax0 2,x0 tra rhsh_loop done_rhsh: lda |[maknum_mask] ada 1,dl ars 3 sba ab|-1,x7 neg 0 ars 1 sta |[maknum_left] tra 0,x6 " pl1-callable subroutine to rehash maknum table. called by " garbage collector and saver. doesn't expect table to be hashed. " args: |[maknum_table_ptr] -> source table. " |[maknum_mask] is old size in chars -1. " |[maknum_left] is number of entries used in old table. " sets: the above, so that maknum will work. entry rehash_maknum rehash_maknum: tsx6 switch_to_lisp eax7 2,x7 ldq |[maknum_mask] adq 1,dl qls 18-2 " move to upper half, dividing by 4. stq ab|-2,x7 " and put where rehash_maknum expects it. ldq |[maknum_left] " compute necessary ht size. qrs 4 " need next largest power of 2 > 32 and > number entries. eax0 4 nlgp2: eax0 1,x0 qrs 1 tnz nlgp2 ldq 1,dl qls 4,x0 " (chars/word)*4*old_min_table_size sbq 1,dl stq |[maknum_mask] adq 1,dl qrs 2 tsx6 words_alloc tsx6 maknum_rehash eax7 -2,x7 tra ret_to_pl1 segdef munkam munkam: lda ap|-2 " get type. cmpa fixnum_type,dl tnz munfound lda ap|-1 ldq |[maknum_mask] tmi munfound qrs 2 eppbp |[maknum_table_ptr],* mnkamlp: cmpa bp|-1,ql tze mfound sbq 2,dl tpl mnkamlp munfound: ldaq ab|nil tra retrnmun "should probably err out here. mfound: als 6 ana lisp_ptr.type,dl cana Fixed+Float,dl tnz munnum eax7 2,x7 lprpbp bp|0,ql spribp ab|-2,x7 ora ab|-2,x7 ldq ab|-1,x7 eax7 -2,x7 tra retrnmun munnum: ora =o47,dl ldq bp|0,ql retrnmun: eppap ap|-2 tra retrn " include lisp_object_types include lisp_stack_seg include lisp_error_codes include lisp_name_codes include stack_header include stack_frame end  lisp_bignums_.alm 11/05/86 1612.7r w 11/04/86 1039.1 638136 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " " lisp_bignums_ " " N.B. The algorithms presented herein are either from " Knuth's Art of Computer Programming, vol 2 (notation " is saved once in a while), or are obvious (hopefully) " and commented. " Large sections of uncommented code (such as in div_bb) will " be easier to read with Knuth's book beside you. " " The format of this set of routines is internal subroutines " first, in alphabetic order, followed by code that is referenced " from outside. " " Initially coded late 1972 and early 1973 by Dan Bricklin " Modified 75.04.17 by DAM to fix bug in haipart and convert for 6180 a little " Last modified Christmas Eve, 1980 by Richard Lamson to fix interaction " between call_alloc_bfx and garbage collector. " segdef convert_bfx_to_sfl segdef plus segdef difference segdef times segdef quotient segdef fix segdef float segdef add1 segdef sub1 segdef minus segdef abs segdef minusp segdef plusp segdef max segdef min segdef lessp segdef greaterp segdef remainder segdef expt segdef haulong segdef haipart segdef gcd " include stack_header include lisp_object_types include lisp_stack_seg include lisp_name_codes " bool nooverflow,004000 "inhibits overflow and sets carry to zero " " these values are used to access the AUTOMATIC VARIABLES " equ old_lp,-4 "old lp - saved by caller equ bn_pl1_ptr,-4 "ptr to array equ return_point,-2 "return point, saved by caller equ bn_pl1_length,-2 "size of array equ bn_pl1_radix,-1 "arg from pl1 caller equ num_of_args,0 "what x5 contained on entry, in upper 18 bits equ saved_indicators,1 "what the indicator register was, saved with an sti equ initial_value,2 "used by expt and gcd to keep umkdpdl at minimum equ resultp,4 "ptr to result equ biggerp,6 "ptr to bigger of the two equ smallerp,8 "ptr to smaller of the two equ divisor,8 "place to hold sfx divisor equ multiplier,8 "place to hold sfx multiplier equ addend,8 "place to hold sfx addend equ big_limit,10 "length of bigger of the two equ small_limit,11 "length of smaller equ temp,12 "temporary double word equ op_table,14 "needed to decide if add or subtract is needed equ carry,15 "holds carry in multiply equ carrya,16 "another carry equ shift_value,17 "number of bits to shift equ shiftp,18 "where to put shifted result equ divisorp,20 "ptr to divisor equ dividendp,22 "ptr to dividend in bfx divide equ answerp,24 "ptr to quotient in bfx divide equ v1p,26 equ presultp,26 equ v2p,28 equ powerp,28 equ n,30 equ m,31 equ j,32 equ qhat,33 equ rhat,34 equ div_bb_ret,35 equ div_bb_temp,36 equ div_bb_lsh_ret,38 equ switched,39 equ function_name,40 "function name code for error equ q,41 equ up,42 equ vp,44 equ ptemp1,46 equ ptemp2,48 equ ptemp3,50 equ ptemp4,52 equ uh,54 equ vh,55 equ A,56 equ B,57 equ C,58 equ D,59 equ auto_block_size,60 "size, in words, of the automatic block " " " " abs_sfx_a_to_q: "this routine puts the abs of the a into the q. "if still an sfx, then it skips one on return. "if too big, then it doesn't skip, and returns ptr to "bfx version in lp. " lrs 36 "get into aq tpl 1,x0 "positive is ok - so skip negl 0 "do the abs cmpaq =v36/0,o36/400000000000 "is it too big? tnz 1,x0 "no, so skip tra convert_aq_to_bfx "yes, so convert, and conversion routine will tra 0,x0 " " add_bb: "this routine adds bigger and smaller, and "puts result in result (already alloced). It takes "care of sign problems. " stx0 bp|n "save return point eax4 add_opcode "remember that we want to add stx4 bp|op_table stz bp|switched lxl2 bp|biggerp,* "set up limits stx2 bp|big_limit lxl2 bp|smallerp,* stx2 bp|small_limit tsx0 compare_bfx "bigger better be bigger tsx0 switch_bfx nop 0,dl nop 0,dl ldx2 bp|biggerp,* "if signs are different, subtract erx2 bp|smallerp,* adx2 bp|op_table epplp 1,x2* "exop wants info in lp ldx2 bp|biggerp,* "set result sign xec 3,x4 stx2 bp|resultp,* ldx0 bp|n "restore return point tra exop_bfx "do the add " " add_bs: "this routine adds addend to bignum bigger. " lxl2 bp|biggerp,* "set big_limit stx2 bp|big_limit eax2 1 "get ptr to first word epplp add_structure "get ready to go to exop later ldq bp|biggerp,*x2 "load first word of bignum adlq bp|addend "add the sfx lda 0,du "clear the a lls 1 "get the carry there qrl 1 stq bp|resultp,*x2 "store the result tra exop_bfx_ripple "ripple the carry " " alloc_bfx6: "this routine allocs a bignum of length x6 on "the unmarked stack, and returns a ptr in lp " epplp ab|0,x7 "get the ptr eax6 2,x6 "add 1 for header word, and 1 for 2 rounding anx6 -2,du "make even stx6 bp|temp "add to x7 adx7 bp|temp stz lp|0 "certain routines assume sign is set "+" tra 0,x0 "return " " bad_error: "recoverable, but only by giving value for function eax7 8,x7 "get some space spribp ab|-6,x7 "save bp ldq bp|function_name "get who we are, along with error (in aq) staq ab|-2,x7 "give to lisp_error_ tsx6 call_lisp_error_ "call the error printer eppbp ab|-4,x7* "get bp back ldaq ap|-2 "get value to return to caller eppap ap|-2 "pop it off the mkd stack eax7 -6,x7 "get rid of our temp storage tra return "return to caller " " badarg: "recoverable error - input wrong type eax7 8,x7 "get some space on unmkd pdl staq ab|-8,x7 "save the aq spribp ab|-6,x7 "save the bp (ptr to auto vars) lda |[bad_arg_correctable] ldq bp|function_name "also the name of the function causing err staq ab|-2,x7 epplp ap|0,x5 "get ptr to offending arg sprilp ab|-4,x7 "remember where it was, for reseting ldaq lp|0 "give it to lisp_error_ eppap ap|2 "bump marked pdl staq ap|-2 "store it tsx6 call_lisp_error_ "call lisp_error_ ldaq ap|-2 "get corrected arg eppap ap|-2 "pop mrkd pdl staq ab|-2,x7* "store over old, bad arg ldaq ab|-6,x7 "restore aq eppbp ab|-4,x7* "restore bp eax7 -6,x7 "free this temp space (lisp_error_ frees 2) tra numval "go back and test type again " " call_alloc_bfx: "this routine replaces result with same bignum, "but allocated in lisp space. " stx0 bp|temp "save return point sxl3 bp|temp "save x3 " " Now, we need to check to see if the bignum is in the heap. " If it is, the pointer to it has to be in the heap during the " call to lisp_alloc_, because otherwise the GC could smash it. " stz bp|temp+1 "set flag epaq bp|0 "get segno of unmarked pdl eax3 0,au "into x3 cmpx3 bp|resultp "is resultp in unmkd pdl? tze do_call_alloc_bfx "yes -- go do it stc1 bp|temp+1 "we need to copy resultp ldaq bp|resultp ora Big_fixed,dl "make it a bignum for gc staq ap|0 "put onto marked stack eppap ap|2 do_call_alloc_bfx: epplp ab|system_lp,* "get ptr to linkage for call eax5 0,x1 "alloc routine preserves x5, and we "need x1 saved to get our auto vars back ldq bp|resultp,* "get number of words needed, on 4 boundary adq 4,dl anq =o777774,dl tsx6 |[words_alloc] "make the call to the alloc routine eax1 0,x5 "reload x1 epplp bp|0 "save ptr to alloced area in lp eppbp ab|0,x1 "reload ptr to auto area szn bp|temp+1 "did we copy pointer? tze finish_call_alloc_bfx "no -- done ldaq ap|-2 "yes -- get it from stack eppap ap|-2 "reset stack ptr staq bp|resultp "and put it back where it's expected finish_call_alloc_bfx: tsx6 move_bfx "move the result into new place sprilp bp|resultp "put ptr to result in resultp lxl3 bp|temp ldx0 bp|temp "reload return point tra 0,x0 "return " " call_lisp_error_: "this routine calls lisp_error_ "it is called by a tsx6 " epplp ab|system_lp,* "get ptr to linkage spriap |[stack_ptr]" save interesting ptrs stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code "say we are in pl1 push "get place to save all registers call |[lisp_error_] eaa sp|16,* sprisp sb|stack_header.stack_end_ptr eppsp sb|0,au epbpab |[unmkd_ptr],* eppap |[stack_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code tra 0,x6 "return to caller " " check_aq: "this routine skips if aq is an sfx. " cmpaq =v36/0,o36/400000000000 tpl 0,x0 "no cmpaq =v36/-1,o36/400000000000 tpl 1,x0 "yes tra 0,x0 "no " " compare_bfx: "this routine compares bigger and smaller. "it skips 0, 1, or 2 for <, =, >. "it ignores the signs, and uses the limits for sizes " ldx2 bp|big_limit "load size of bigger cmpx2 bp|small_limit "compare with smaller tmi 0,x0 "if smaller bigger, then bs, so skip 2 eax2 1,x2 "add one to size, then start checking compare_bfx_loop: eax2 -1,x2 "look at next lower order word tze 1,x0 "done - all equal => a=b so skip 1 ldq bp|biggerp,*x2 "load bigger number cmpq bp|smallerp,*x2 "compare with smaller one tmi 0,x0 "smaller is bigger, so return no skip (bs, so skip 2 " " compare_signed_bfx: "this routine compares bigger and smaller "taking into account the signs. " ldx2 bp|biggerp,* "compare signs cmpx2 bp|smallerp,* tmi 0,x0 "return with < tze 2,ic "since we don't have a tpnz on 645 tpl 2,x0 "return with > lxl3 bp|biggerp,* "set up lengths stx3 bp|big_limit lxl3 bp|smallerp,* stx3 bp|small_limit eax2 0,x2 "check sign tmi 2,ic tra compare_bfx "for + it's the normal compare and return eax3 0,x0 "save return point tsx0 compare_bfx "do a compare, and translate results for neg tra 2,x3 " > tra 1,x3 " = tra 0,x3 " < " " convert_aq_to_bfx: "this routine converts the aq to a bfx. "returns ptr to it in lp, and gives a bfx "of three words. Won't work with -4000... "since it has to negate the aq " epplp ab|0,x7 "get ptr to bfx to be allocated eax7 4,x7 "alloc the bfx cmpaq =0 "check sign tpl 4,ic "skip around negate if plus negl 0 "do the negate eax2 -1 "load sign of result tra 2,ic eax2 0 "positive sign stx2 lp|0 "store the sign lls 1 "store each of the words qrl 1 stq lp|1 eax2 2 "load the tentative length lrl 35 cmpa 0,dl tze 3,ic "is the a zero? if so - length = 2 sta lp|3 "store the a if something there eax2 3 "length is 3 qrl 1 "shift q to proper place stq lp|2 "store the q sxl2 lp|0 "store the length tra 0,x0 "return " " convert_bfx_to_sfl: "this routine converts the bfx->by lp to an "sfl in the EAQ. It is called by tsx6, "and only modifies x2. It is an external entry. "It skips on return if conversion is ok, and "does not skip if there was an overflow " lxl2 lp|0 "get length cmpx2 4,du tze convert_bfx_to_sfl_check4 "4 is a special case - not all fit tpl 0,x6 "return if too big - no skip=>overflow lda lp|0,x2 "load last (most sig.) word ldq lp|-1,x2 "and next to last qls 1 "make one bit string (remove empty bit) convert_bfx_to_sfl_l: lde convert_bfx_to_sfl_tab,x2 "load an exponent fad =0.0 "normalize ldx2 lp|0 "load the sign xec convert_bfx_to_sfl_tab+1,x2 "perhaps negate tra 1,x6 "return with skip convert_bfx_to_sfl_check4: lda lp|0,x2 "load high order word cana =vo14/37777,o22/0 "check if too big tnz 0,x6 "too big - don't skip ldq lp|-1,x2 "load next word qls 1 lls 14 "make so exponent isn't too big tra convert_bfx_to_sfl_l "join other code convert_bfx_to_sfl_tab: fneg 0 nop 0,dl vfd 8/70 vfd 8/105 vfd 8/127 " " convert_bfx_to_sfx: "this routine converts result to an sfx - "if does not check to see if possible " lxl2 bp|resultp,* "load length cmpx2 2,du "if length 2 then must be -400000000000 tze convert_bfx_to_sfx_2 "separate code for that lda 0,du "clear a ldx2 1,du "get address of low order word ldq bp|resultp,*x2 "put it in q szn bp|resultp,* "do we need to negate it? tpl 2,ic "no, skip neg instruction negl 0 "negate the aq lda fixnum_type,dl "add type bits tra 0,x0 "return convert_bfx_to_sfx_2: ldq =o400000000000 "load the value lda fixnum_type,dl "add type bits tra 0,x0 "return " " convert_q_to_bfx: "this routine returns in the lp a ptr "to the q in bfx format - length 2 words " epplp ab|0,x7 "get ptr to area to be allocated eax7 4,x7 "alloc 4 words cmpq 0,dl "find out sign of number tmi 6,ic "neg - have to negate for abs value stq lp|1 "positive - just store as is stz lp|2 "high order word is zero ldq 2,dl "put in sign and length stq lp|0 tra 0,x0 "return lls 36 "bring into a lrs 36 "back to q, extending sign bit negl 0 "negate it lls 1 "bring high order bit into a qrl 1 "bring rest back without it stq lp|1 "store double word result sta lp|2 ldq =v18/-1,18/2 "load neg sign and length 2 stq lp|0 "store in bfx tra 0,x0 "return " " convert_q_to_sfl: "this routine converts the sfx in the q into an sfl "in the EAQ. " lls 36 lde =35b25,du fad =0.0,du tra 0,x0 "return " " div_bb: "this routine divides bfx bigger by bfx smaller, "and places the result in answer. " stx0 bp|div_bb_ret "save return address lxl2 bp|smallerp,* "get high order word ldq 0,dl "clear q lda bp|smallerp,*x2 "get into EAQ lde 0,du fad =0 "normalize (find # of leading zeroes) ste bp|temp lda bp|temp "make it a number (it is negative) ars 28 neg 0 "make it positive sta bp|shift_value "save as shift value epplp bp|smallerp,* "get ptr to value to be copied and shifted tsx0 div_bb_lsh "do it sprilp bp|divisorp "store ptr to result epplp bp|biggerp,* "do same for other number tsx0 div_bb_lsh sprilp bp|dividendp lxl2 bp|smallerp,* "get len of divisor epplp bp|divisorp,*x2 "get ptr to end of divisor sprilp bp|v1p "save for future reference epplp lp|-1 sprilp bp|v2p stx2 bp|n lxl6 bp|biggerp,* "get len of other adx6 1,du "it is one greater than divisor stx6 bp|j "save sbx6 bp|n "calc length of result tmi div_bb_zero "divisor is bigger than dividend tze div_bb_zero stx6 bp|m tsx0 alloc_bfx6 "alloc result sprilp bp|answerp "save ptr to it ldx6 bp|m "store length sxl6 lp|0 ldx6 bp|smallerp,* erx6 bp|biggerp,* stx6 bp|answerp,* "store sign " get_qhat: ldx2 bp|j "set lp->dividend epplp bp|dividendp,*x2 lda lp|0 "calc quotient digit guess, a la Knuth. cmpa bp|v1p,* tmi div_bb_less ldq =o377777777777 lda lp|-1 tra l3h dec_qhat: ldq bp|qhat sbq 1,dl lda bp|rhat l3h: stq bp|qhat adla bp|v1p,* tmi got_qhat sta bp|rhat tra got_rhat div_bb_less: ldq lp|-1 qls 1 dvf bp|v1p,* sta bp|qhat stq bp|rhat got_rhat: ldq bp|qhat mpy bp|v2p,* lls 1 cmpa bp|rhat tmi got_qhat tnz dec_qhat qrl 1 cmpq lp|-2 tmi got_qhat tnz dec_qhat " got_qhat: eax3 0 stz bp|carry "do multiply and subtract stz bp|carrya sbx2 bp|n epplp bp|dividendp,*x2 div_bb_loop: eax3 1,x3 ldq bp|divisorp,*x3 mpy bp|qhat adl bp|carry lls 1 qrl 1 stq bp|temp sta bp|carry ldq lp|-1,x3 sblq bp|carrya sblq bp|temp lda 0,dl lls 1 qrl 1 stq lp|-1,x3 sta bp|carrya cmpx3 bp|n tnz div_bb_loop eax3 1,x3 ldq lp|-1,x3 sblq bp|carrya sblq bp|carry lda 0,dl lls 1 qrl 1 stq lp|-1,x3 cmpa 0,dl tze store_q ldq bp|qhat "qhat too big, so dec by one sbq 1,dl stq bp|qhat eax3 0 lda 0,dl "add back in div_bb_loop1: eax3 1,x3 ldq lp|-1,x3 adlq add_structure+1,al adlq bp|divisorp,*x3 lda 0,du lls 1 qrl 1 stq lp|-1,x3 cmpx3 bp|n tnz div_bb_loop1 eax3 1,x3 ldq lp|-1,x3 adlq add_structure+1,al lls 1 qrl 1 stq lp|-1,x3 " store_q: ldx2 bp|m lda bp|qhat sta bp|answerp,*x2 ldx3 bp|j eax3 -1,x3 stx3 bp|j eax2 -1,x2 stx2 bp|m tnz get_qhat ldx0 bp|div_bb_ret tra 0,x0 div_bb_zero: eax6 1 "result is zero tsx0 alloc_bfx6 sprilp bp|answerp eax2 1 sxl2 lp|0 "store vital statistics ldx2 bp|smallerp,* erx2 bp|biggerp,* stx2 lp|0 stz lp|1 ldx0 bp|div_bb_ret "return tra 0,x0 " " div_bb_lsh: stx0 bp|div_bb_lsh_ret lxl6 lp|0 sprilp bp|div_bb_temp adx6 3,du tsx0 alloc_bfx6 sprilp bp|shiftp lxl2 bp|div_bb_temp,* stz lp|0 stz lp|2,x2 epplp bp|div_bb_temp,* tsx0 lsh_bfx epplp bp|shiftp,* ldx0 bp|div_bb_lsh_ret tra 0,x0 " " div_bs: "this routine divides bfx bigger by divisor, "putting the quotient in result, and the "remainder is left in the q. " lxl2 bp|biggerp,* "load the offset of last (m.sig.) element sxl2 bp|resultp,* "it is also the length of result lda 0,dl "clear the remainder div_bs_loop: ldq bp|biggerp,*x2 "get next word to divide qls 1 "dvf needs this shift dvf bp|divisor "do the divide of aq sta bp|resultp,*x2 "store the quotient eax2 -1,x2 "go to next word tze 0,x0 "done - return llr 36 "move remainder to above next word tra div_bs_loop "get next word " " div_by_zero: lda |[division_by_zero] "load error code tra bad_error "join error code " " enter: "this routine does the stuff for entry " eax1 0,x7 "save where x7 was in x1 eax7 auto_block_size,x7 "alloc the automatic variables eppbp ab|0,x1 "get ptr to them in bp stx5 bp|num_of_args "save x5 (number of args * -2) sti bp|saved_indicators "save the indicators stq bp|function_name "remember who we are for errors tra 0,x0 "return " " exop_bfx: "this routine does bfx adds and subtracts "lp should point to a structure in the "correct format. " ldx2 0,du lda 0,du exop_bfx_loop: eax2 1,x2 "get next set of words ldq bp|biggerp,*x2 "get bigger one adlq lp|1,al "add carry into it (0,+1,-1) xec lp|0 "do add or subtract lda 0,du "clear a lls 1 "shift high bit into a qrl 1 "leave it there stq bp|resultp,*x2 "store q as result cmpx2 bp|small_limit "are we done this loop? tnz exop_bfx_loop "no - do next higher word tra exop_bfx_check "join ripple code at check point exop_bfx_ripple: eax2 1,x2 "get next word ldq bp|biggerp,*x2 "load into q adlq lp|1,al "add in carry factor lda 0,du "move high bit into a lls 1 qrl 1 stq bp|resultp,*x2 "store result exop_bfx_check: cmpx2 bp|big_limit "are we done? tnz exop_bfx_ripple "no eax2 1,x2 "get room for last carry sta bp|resultp,*x2 "store it sxl2 bp|resultp,* "store size tra 0,x0 " " float_error: sprilp bp|temp "put value in error in mkd pdl ldaq bp|temp ora Big_fixed,dl eppap ap|2 "make room on mkd pdl staq ap|-2 "put value there lda |[unable_to_float] "load error code tra bad_error "join error code " " force_q_to_bfx: "this routine converts the q to a bfx. "it assumes that it is invoked after an "overflow and uses the carry indicator "to know more about the result "it returns a ptr to the bfx in lp " epplp ab|0,x7 "load ptr to area to be alloced eax7 4,x7 "alloc the area trc force_q_to_bfx_neg "transfer if carry -> negative result lda 0,du "move high order bit into a lls 1 qrl 1 stq lp|1 "store result sta lp|2 ldq 2,dl "set length and sign (pos) stq lp|0 tra 0,x0 force_q_to_bfx_neg: lda =v36/-1 "its a large negative number negl 0 "get abs lls 1 "get second word qrl 1 stq lp|1 "store result sta lp|2 ldq =v18/-1,18/2 "get length and sign (neg) stq lp|0 "store it tra 0,x0 " " load_arg_bfx: "this routine moves result and arg into big and small " epplp bp|resultp,* sprilp bp|biggerp lxl2 lp|0 stx2 bp|big_limit epplp ap|0,x5* sprilp bp|smallerp lxl2 lp|0 stx2 bp|small_limit tra 0,x0 " " lsh_bfx: "this routine shifts left bfx->lp shift_value places "and puts the answer in shiftp->bfx. X2 says how many words. " lxl3 bp|shift_value eppbp bp|shiftp,* stz bp|1,x2 lsh_bfx_loop: lda 0,dl ldq lp|0,x2 lls 1,x3 qrl 1 orsa bp|1,x2 stq bp|0,x2 eax2 -1,x2 tnz lsh_bfx_loop eppbp ab|0,x1 tra 0,x0 " " move_bfx: "moves resulp->bfx to lp->bfx "called with tsx6, and clobbers x4, a, q " eppbb bp|resultp,* "get pointer to bfx to be moved in bb ldq bb|0 "get length qls 2 "convert to number of characters eax4 4,ql "add allow for header. (assume not ridiculously huge) mlr (pr,rl),(pr,rl) "move the stuff desc9a bb|0,x4 desc9a lp|0,x4 tra 0,x6 "return " " mpy_bfx: "this routine multiplies bigger by smaller " eax2 1 "load ptrs, 2 -> bigger (multiplicandd) eax3 1 " 3 -> smaller(multiplier) eax4 1 " 4 -> result (product) stz bp|carry "zero the carry mpy_bfx_loop1: ldq bp|biggerp,*x2 "load next word of multiplicand mpy bp|smallerp,*x3 "do the multiply adl bp|carry "add the single word carry to the aq lls 1 "store the lower word qrl 1 stq bp|resultp,*x4 eax4 1,x4 "go to next word of result sta bp|carry "store the new carry cmpx2 bp|big_limit "are we done the first pass? tze mpy_bfx_join "yes eax2 1,x2 "no - get next word of bigger tra mpy_bfx_loop1 "continue multiplying mpy_bfx_loop2: ldq bp|biggerp,*x2 "load next word of bigger mpy bp|smallerp,*x3 "do mult adl bp|carry "add carry adl bp|resultp,*x4 "add to result lls 1 qrl 1 stq bp|resultp,*x4 "store low word eax4 1,x4 "now add high word to result sta bp|carry "store the new carry cmpx2 bp|big_limit "are we done with multiplicand? tze 3,ic "yes - check multiplier eax2 1,x2 "bump x2 tra mpy_bfx_loop2 "continue mpy_bfx_join: lda bp|carry "store the carry in next word sta bp|resultp,*x4 eax4 1,x4 "bump x4 incase next x3 ->val is zero stz bp|carry "clear the carry eax2 1 "reset multiplicand ptr cmpx3 bp|small_limit "are we done with multiplier? tze mpy_bfx_done "yes eax3 1,x3 "bump x3 szn bp|smallerp,*x3 "is multiplier zero? tze mpy_bfx_join "yes - skip the multiply eax4 0,x3 "product ptr starts where multiplier's is tra mpy_bfx_loop2 "continue mpy_bfx_done: eax4 -1,x4 "x4 is one too far sxl4 bp|resultp,* "done - store length tra 0,x0 "return " " mpy_bs: "this routine multiplies bigger by sfx multiplier " epplp bp|biggerp,* "get ptr to bfx lxl2 lp|0 "get length of bfx stx2 bp|big_limit "store as loop terminater. eax2 0 "initialize counter stz bp|carry "clear carry mpy_bs_loop: eax2 1,x2 "get next word ldq lp|0,x2 "load next word mpy bp|multiplier "do the multiply adl bp|carry "add the carry lls 1 "get new carry qrl 1 stq bp|resultp,*x2 "store the result sta bp|carry "store the carry cmpx2 bp|big_limit "are we done? tmi mpy_bs_loop "no eax2 1,x2 "get next result word sta bp|resultp,*x2 "store the last carry sxl2 bp|resultp,* "store the length tra 0,x0 "return " " norm_a: " normalizes A reg., returns number of significant " bits in Q. ldq 0,dl lde =o106000,du " 35.<-28. cmpa 0,dl " get sign of arg tze 0,x0 " return if zero. tpl norm_ge0 " if A < 0 cmpa =o400000,du " check for bad case. tnz 3,ic " and return 36 ldq 36,dl " in this case tra 0,x0 sba 1,dl norm_ge0: fad =0.0,du " normalize. ste bp|temp " get the exponent register ldq bp|temp " into the Q qrs 36-8 " shift it to correct place, tra 0,x0 " " numval: "checks type of arg -> by x5, skipping: " 0 if sfx " 1 if sfl " 2 if bfx " 3 if bfl " error otherwise " "uses x2. " lxl2 ap|0,x5 "load the type bits into x2 canx2 Fixed,du "check with all numeric types and skip tnz 0,x0 canx2 Float,du tnz 1,x0 canx2 Big_fixed,du tnz 2,x0 tra badarg "ERROR " " ret_to_pl1: "this routine returns to a pl1 program - "it needs to have the lp set. " spriap |[stack_ptr] "let pl1 prog know about stack changes stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code "indicate that we aren't in non-pl1 short_return " " return: "this routine is the opposite of enter "returned values should be in aq " ldi bp|saved_indicators "restore the indicators ldx5 bp|num_of_args "restore x5 for the next instruction eppap ap|0,x5 "pop the marked stack epplp bp|old_lp,* "restore the caller's lp eppbp bp|return_point,* "get ptr to return point eax7 -4,x1 "pop the unmarked stack tra bp|0 "return " " return_0: "returns with a zero value " lda fixnum_type,dl "put type bits in the a ldq 0,dl "load a value of zero tra return "return " " return_0.0: "returns a floating zero lda flonum_type,dl ldq =0.0 tra return " " return_1: lda fixnum_type,dl ldq 1,dl tra return " " return_1.0: "returns a floating one lda flonum_type,dl ldq =1.0 tra return " " return_bfx: "gets a place for result, then returns " tsx0 call_alloc_bfx "allocate the bfx ldaq bp|resultp "get ptr to it ora Big_fixed,dl "make bignum ptr tra return "do a return " " return_minus1: "returns a minus one lda fixnum_type,dl "load type bits lcq 1,dl "load the value tra return "return " " return_nil: "returns the value nil ldaq ab|nil tra return " " return_sfl: "returns q as an sfl fst bp|temp "store EAQ in sfl ldq bp|temp "load as one number (one word) lda flonum_type,dl "load type bits tra return " " return_sfx: "returns q as an sfx lda fixnum_type,dl "load type bits tra return " " return_true: "returns the value t ldaq ab|true tra return " " rsh_bfx: "shifts lp->bfx right shift_value "places, in place. " lxl3 bp|shift_value "get value to shift lxl2 lp|0 "get length stx2 bp|big_limit "save it cmpx2 1,du "rsh_bfx (1)? tze rsh_bfx_1 eax2 1 "initialize x2, word counter ldq lp|0,x2 "get first word qls 1 "move up to block sign rsh_bfx_loop: lda lp|1,x2 "get next word lrl 0,x3 "do the shift qrl 1 "make a sign bit stq lp|0,x2 "store the result llr 37,x3 "move what's left to the q in position eax2 1,x2 "get next word cmpx2 bp|big_limit "are we done? tmi rsh_bfx_loop "no qrl 1,x3 "store last word stq lp|0,x2 tra 0,x0 "return rsh_bfx_1:ldq lp|1 qrl 0,x3 stq lp|1 tra 0,x0 " " setup_mpy_bfx: "this routine takes bigger and smaller and sets "the proper variables for a mpy_bfx - "including allocing the result and setting "sign. " lxl2 bp|biggerp,* "set limits stx2 bp|big_limit lxl2 bp|smallerp,* stx2 bp|small_limit epplp ab|0,x7 "alloc correct size result sprilp bp|resultp eax2 2,x7 adx2 bp|big_limit adx2 bp|small_limit anx2 -2,du eax7 0,x2 ldx2 bp|biggerp,* erx2 bp|smallerp,* stx2 bp|resultp,* tra 0,x0 " " switch_bfx: "switches bigger and smaller " ldaq bp|biggerp "switch the ptrs staq bp|temp ldaq bp|smallerp staq bp|biggerp ldaq bp|temp staq bp|smallerp ldaq bp|big_limit "load big and small limits as a unit "this requires them to be 2 word aligned llr 36 "switch their positions staq bp|big_limit "store the switched values lda -1,du "indicate that a swich was performed ersa bp|switched tra 0,x0 "return " " switch_to_lisp: "loads registers to make a lisp environment " epbpab |[unmkd_ptr],* eppap |[stack_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code tra 0,x0 " " truncate_bfx: "this routine sets the length of result "to the smallest value possible, stripping "off leading zeroes. It will skip on return "if the result could be an sfx. " lxl2 bp|resultp,* "get length eax2 1,x2 "start out one ahead truncate_bfx_loop: eax2 -1,x2 "go back one word tze truncate_bfx_small "all zero -> small szn bp|resultp,*x2 "see if word is zero tze truncate_bfx_loop "yes, look at word before it sxl2 bp|resultp,* "store new length cmpx2 1,du "are we now an sfx? tze 1,x0 "yes cmpx2 2,du "now check for -400000000000 tnz 0,x0 szn bp|resultp,* tpl 0,x0 lda bp|resultp,*x2 eax2 -1,x2 ldq bp|resultp,*x2 cmpaq =v36/1,36/0 tze 1,x0 "skip on return if could be sfx tra 0,x0 truncate_bfx_small: ldx2 1,du "get length of one sxl2 bp|resultp,* "store it tra 1,x0 "skip on return " " plus: "This is the plus lsubr lcq -fn_plus,dl "remember who we are (incase of error) eax4 add_opcode "since this op is table driven, load the table plus_start: tsx0 enter "set up the automatic variables stx4 bp|op_table "save what type of op we are eax5 0,x5 "are there any arguments? tze return_0 "no - return a zero tsx0 numval "branch on type of first arg tra plus_sfx tra plus_sfl tra plus_bfx " plus_sfx: ldi nooverflow,dl "inhibit overflow ldaq ap|0,x5 "load first arg and its type bits plus_sfx_loop: eax5 2,x5 "get next arg tze return "no more - return what we have in the aq tsx0 numval "branch on type tra plus_sfx_add tra plus_sfx_sfl tra plus_sfx_make_big " plus_sfx_add: xec 2,x4 "do the operation - add or subtract tov 2,ic "if overflow, then switch to bignum tra plus_sfx_loop "get next arg and add it tsx0 force_q_to_bfx "get ptr to q in bfx form sprilp bp|resultp "store it in resultp tra plus_bfx_loop "join bfx code plus_sfx_make_big: tsx0 convert_q_to_bfx "change to bfx sprilp bp|resultp tra plus_bfx_add "join bfx code " plus_sfx_sfl: tsx0 convert_q_to_sfl "convert the sfx to sfl tra plus_sfl_add "and join the sfl code " plus_sfl: fld ap|1,x5 "load first arg plus_sfl_loop: eax5 2,x5 "get next arg tze return_sfl "no more - return tsx0 numval "branch on arg type tra plus_sfl_sfx tra plus_sfl_add tra plus_sfl_bfx plus_sfl_add: xec 6,x4 "do add or subtract tra plus_sfl_loop "get next arg plus_sfl_sfx: fst bp|temp "save what we have ldq ap|1,x5 "convert arg to sfl tsx0 convert_q_to_sfl xed 4,x4 "do operation, with optional negate tra plus_sfl_loop plus_sfl_bfx: fst bp|temp "save q epplp ap|0,x5* "get ptr to bfx tsx6 convert_bfx_to_sfl "do convert tra float_error "no skip means a conversion error xed 4,x4 "do operation tra plus_sfl_loop "get next arg " plus_bfx: ldaq ap|0,x5 "move ptr to 1st arg to resultp staq bp|resultp plus_bfx_loop: eax5 2,x5 "get next arg tze return_bfx "no more - alloc result and return tsx0 numval "branch on arg type tra plus_bfx_make_big tra plus_bfx_sfl tra plus_bfx_add plus_bfx_add: stz bp|switched "reset check for switching (subtract needs) tsx0 load_arg_bfx "move result and arg into big and small tsx0 compare_bfx "compare them tsx0 switch_bfx "switch if b overflow tra plus_sfl_add "join sfl code " " difference: lcq -fn_difference,dl "remember who we are eax4 sub_opcode "indicate that we are subtract tra plus_start "and then join the plus code " " even add_opcode: arg sub_structure arg add_structure adq ap|1,x5 nop 0,du fad bp|temp nop 0,dl fad ap|1,x5 adq 1,dl " even sub_opcode: arg add_structure arg sub_structure sbq ap|1,x5 erx2 bp|switched fsb bp|temp fneg 0 fsb ap|1,x5 sbq 1,dl add_structure: adlq bp|smallerp,*x2 dec 0 dec 1 sub_structure: sblq bp|smallerp,*x2 dec 0 dec -1 " " times: lcq -fn_times,dl "remember who we are tsx0 enter "set up the auto vars eax5 0,x5 "are there any args? tze return_1 "no - return a one tsx0 numval "branch on arg type tra times_sfx tra times_sfl tra times_bfx times_sfx: ldq ap|1,x5 "load the first arg times_sfx_loop: eax5 2,x5 "get next arg tze return_sfx "no more - done tsx0 numval "branch on type of next arg tra times_sfx_mpy tra times_sfx_sfl tra times_sfx_bfx times_sfx_mpy: mpy ap|1,x5 "do the multiply cmpaq =v36/0,o36/400000000000 "check that the product is still sfx tpl 3,ic "no cmpaq =v36/-1,o36/400000000000 tpl times_sfx_loop "ok - still sfx so continue times_sfx_gets_big: tsx0 convert_aq_to_bfx "convert result to bfx sprilp bp|resultp "store ptr to it tra times_bfx_loop "join bfx code times_sfx_sfl: tsx0 convert_q_to_sfl "convert to sfl and join them tra times_sfl_mpy times_sfx_bfx: epplp ap|0,x5* "set up for big times small sprilp bp|biggerp "move in ptr to bfx tra times_bs_join "small num is in q, so just join " times_sfl: fld ap|1,x5 "load first arg times_sfl_loop: eax5 2,x5 "get next arg tze return_sfl tsx0 numval "branch on arg type tra times_sfl_sfx tra times_sfl_mpy tra times_sfl_bfx times_sfl_mpy: fmp ap|1,x5 "do the mpy tra times_sfl_loop "get next arg times_sfl_sfx: fst bp|temp "save EAQ ldq ap|1,x5 "get sfx to be made into sfl tsx0 convert_q_to_sfl fmp bp|temp "do the mpy tra times_sfl_loop "do again times_sfl_bfx: fst bp|temp "save epplp ap|0,x5* "convert bfx arg to sfl tsx6 convert_bfx_to_sfl tra float_error "no skip - overflow fmp bp|temp "do the mpy tra times_sfl_loop "and get next arg " times_bfx: ldaq ap|0,x5 "make first arg old result staq bp|resultp times_bfx_loop: eax5 2,x5 "get next arg tze return_bfx "no more - done tsx0 numval "branch on type of next arg tra times_bfx_sfx tra times_bfx_sfl tra times_bfx_mpy times_bfx_mpy: tsx0 load_arg_bfx "load result and arg into big and small times_bfx_common: epplp ab|0,x7 "get ptr to result (to be allocated) sprilp bp|resultp "store in resultp eax2 2,x7 "calc EVEN(x7 + big_limit + small_limit + 2) adx2 bp|big_limit adx2 bp|small_limit anx2 -2,du eax7 0,x2 "alloc the appropriate number of words ldx2 bp|biggerp,* "calc sign of result erx2 bp|smallerp,* stx2 bp|resultp,* "store it tsx0 mpy_bfx "do the multiply tsx0 truncate_bfx "truncate it tra times_bfx_loop "get next arg tsx0 convert_bfx_to_sfx "truncate skipped => make small tra times_sfx_loop "join sfx code times_bfx_sfx: ldaq bp|resultp "move in bignum staq bp|biggerp ldq ap|1,x5 "get small num times_bs_join: ldx2 bp|biggerp,* "get sign of bfx lls 36 "xor with sign of sfx (put in a) tpl times_bs_pos "sfx positive=> don't negate value and bfx sign cmpa =o400000000000 "see if we can't negate it tze times_bs_make_bb "can't negate - go to bfx times bfx neg 0 "negate the number - need abs erx2 -1,du "change sign of result times_bs_pos: sta bp|multiplier "save abs of sfx as multiplier lxl6 bp|biggerp,* "get length of bfx eax6 1,x6 "add one for length of sfx = len result tsx0 alloc_bfx6 "alloc the result sprilp bp|resultp "save ptr to it stx2 lp|0 "save the sign tsx0 mpy_bs "do the multiply tsx0 truncate_bfx "try to make smaller tra times_bfx_loop "get next arg tsx0 convert_bfx_to_sfx "skip => make small tra times_sfx_loop times_bs_make_bb: lrs 36 "put in q tsx0 convert_q_to_bfx "change the sfx to a bfx sprilp bp|smallerp "setup for bfx times bfx lxl2 lp|0 stx2 bp|small_limit lxl2 bp|biggerp,* stx2 bp|big_limit tra times_bfx_common "join bfx bfx code " times_bfx_sfl: epplp bp|resultp,* "get ptr to result to convert tsx6 convert_bfx_to_sfl tra float_error "error in conversion tra times_sfl_mpy "no error - join sfl code " " quotient: lcq -fn_quotient,dl "remember who we are tsx0 enter "set up the auto vars, etc. eax5 0,x5 "any args? tze return_1 "no - return the identity - 1 tsx0 numval "branch on arg type tra quot_sfx tra quot_sfl tra quot_bfx " quot_sfx: ldq ap|1,x5 "pick up first arg quot_sfx_loop: eax5 2,x5 "get next arg (in sfx mode) tze return_sfx "no more - done tsx0 numval "branch on arg type tra quot_sfx_div tra quot_sfx_sfl tra quot_sfx_bfx quot_sfx_div: cmpq =o400000000000 "check that won't overflow tnz 4,ic lda =-1 "-4000000.../-1 will do that cmpa ap|1,x5 tze quot_sfx_make_big "go to bfx mode div ap|1,x5 "do the divide tra quot_sfx_loop "get next arg quot_sfx_make_big: tsx0 convert_q_to_bfx "do the conversion sprilp bp|resultp tra quot_bs "join the other code quot_sfx_bfx: cmpq =o400000000000 "are we -400.../400...? tnz quot_sfx_zero "no epplp ap|0,x5* lda lp|0 ldq lp|1 cmpaq =v18/0,18/2,36/0 tnz quot_sfx_zero lda lp|2 cmpa 1,dl tnz quot_sfx_zero ldq =-1 tra quot_sfx_loop quot_sfx_zero: ldq 0,dl tra quot_sfx_loop "get next quot_sfx_sfl: tsx0 convert_q_to_sfl "change to sfl mode tra quot_sfl_div " quot_sfl: fld ap|1,x5 "load first arg quot_sfl_loop: eax5 2,x5 "get next arg tze return_sfl "no more - return tsx0 numval "what type is arg? tra quot_sfl_sfx tra quot_sfl_div tra quot_sfl_bfx quot_sfl_div: fdv ap|1,x5 "do the divide tra quot_sfl_loop "get next arg quot_sfl_sfx: fst bp|temp "save the EAQ ldq ap|1,x5 "load the sfx and convert tsx0 convert_q_to_sfl fdi bp|temp "do the divide tra quot_sfl_loop "get next arg quot_sfl_bfx: fst bp|temp "save epplp ap|0,x5* "get ptr to arg tsx6 convert_bfx_to_sfl "and convert it to sfl tra quot_sfl_bfx_overflow "overflow fdi bp|temp "do the divide tra quot_sfl_loop "and get the next arg quot_sfl_bfx_overflow: epplb ab|system_lp,* link zunderflow,|[zunderflow],* zunderflow=t? ldaq lb|zunderflow,* cmpaq ab|nil tze float_error no, error. fld =0.0,du yes, return 0.0 tra return_sfl " quot_bfx: ldaq ap|0,x5 "make first arg old result staq bp|resultp quot_bfx_loop: eax5 2,x5 "get next arg tze return_bfx "no more - return tsx0 numval "branch on type tra quot_bs tra quot_bfx_sfl tra quot_bb quot_bs: ldaq bp|resultp "divide bfx by sfx, move result to bigger staq bp|biggerp ldx2 bp|biggerp,* "load sign of dividend lda ap|1,x5 "load divisor value tpl quot_bs_join "don't do anything if non-negative cmpa =o400000000000 "see if can't take negative tze quot_bs_make_bb neg 0 "get abs value erx2 -1,du "get sign of result quot_bs_join: sta bp|divisor "store divisor epplp ab|0,x7 "get ptr to result (to be alloced) sprilp bp|resultp "store in resultp stx2 bp|resultp,* "store sign lxl2 bp|biggerp,* "get length of dividend adx2 2,du "add one for header, and 1 to round anx2 -2,du "round down to even stx2 bp|temp adx7 bp|temp "bump x7 tsx0 div_bs "do the divide tsx0 truncate_bfx "try to truncate tra quot_bfx_loop "get next arg tsx0 convert_bfx_to_sfx "skipped, so convert to sfx tra quot_sfx_loop quot_bs_make_bb: lrs 36 "move into q tsx0 convert_q_to_bfx "do conversion sprilp bp|smallerp tra quot_bb_div "join bfx code quot_bfx_sfl: epplp bp|resultp,* "get ptr to bfx so far tsx6 convert_bfx_to_sfl "convert it tra float_error "error tra quot_sfl_div "join other code quot_bb: tsx0 load_arg_bfx quot_bb_div: tsx0 div_bb ldaq bp|answerp staq bp|resultp tsx0 truncate_bfx tra quot_bfx_loop tsx0 convert_bfx_to_sfx tra quot_sfx_loop " " entry bnprint bnprint: tsx0 switch_to_lisp "setup lisp environment tsx0 enter "get auto vars ldaq ap|-2 "get ptr to bignum to be broken up staq bp|biggerp "store it where it can be used " lda bp|bn_pl1_radix "load radix sta bp|divisor "store where it will be needed lxl6 bp|biggerp,* "alloc result - about twice bigger in size stx6 bp|temp adx6 bp|temp tsx0 alloc_bfx6 sprilp bp|resultp stz lp|0 "make sign positive epplp ab|0,x7 "get ptr to array of results sprilp bp|bn_pl1_ptr eax7 2,x7 "bump x7 eax3 0 "x3 is index into this array bnprint_loop: tsx0 div_bs "do the divide stq bp|bn_pl1_ptr,*x3 "store the remainder eax3 1,x3 "bump the pointer canx3 1,du "check if time to bumb x7 tnz 2,ic eax7 2,x7 "bump it tsx0 truncate_bfx "truncate result tra bnprint_still_big "still bignum eax2 1 "could be small, so are we done? lda bp|resultp,*x2 "done if quotient is < radix cmpa bp|bn_pl1_radix "do the compare tmi bnprint_done "if radix>quot, then done bnprint_still_big: ldaq bp|resultp "move result into bigger staq bp|biggerp tra bnprint_loop "do again bnprint_done: tsx0 convert_bfx_to_sfx "get last word stq bp|bn_pl1_ptr,*x3 "store it eax3 1,x3 "make x3 be length stz bp|bn_pl1_length "clear high bits sxl3 bp|bn_pl1_length "store array length eppap ap|-2 "clear arg epplp ab|system_lp,* "load lp tra ret_to_pl1 "return " " fix: lcq -fn_fix,dl eax5 -2 "indicate that we have one arg tsx0 enter "set up auto vars tsx0 numval "check type of arg tra fix_sfx tra fix_sfl tra fix_bfx fix_sfx: ldaq ap|-2 "just a straight copy tra return fix_sfl: fld ap|-1 "load the value tmi fix_sfl_neg "test sign fcmp =1.0 "see if it is greater than 1 tmi return_0 "smaller => 0 tze return_1 "equal => 1 fcmp =1.0e10 "are we sure that it can be sfx tmi 3,ic "yes eax4 0 "load sign (0 => +) tra fix_sfl_bfx "go do bfx conversion ufa =71b25,du "convert to sfx tra return_sfx fix_sfl_neg: fcmg =1.0 "see if fraction tze return_minus1 "equal -1 tmi return_0 "is fraction fcmg =1.0e10 "can it be an sfx? tmi 4,ic "yes eax4 -1 "no, so set sign, and go to bfx fneg 0 tra fix_sfl_bfx ufa =71b25,du "do the conversion to sfx tra return_sfx "and return fix_sfl_bfx: fst bp|temp+1 "save the floating value eax6 5 "alloc bfx of 5 words tsx0 alloc_bfx6 sprilp bp|resultp ldaq =v36/0,36/0 "load a zero staq lp|0 "zero out bfx staq lp|2 staq lp|4 lda bp|temp+1 "load sfl as word, to get exp lrl 64 "put exp as value in q div 35,dl "find how many words result will be eax2 0,ql "put value in x2 neg 0 "negate remainder eax3 35,al "add to 35 fld bp|temp+1 "load number lrl 0,x3 "do the shift qrl 1 sta lp|1,x2 "store the result stq lp|0,x2 eax2 1,x2 "get bfx length sxl2 lp|0 "store it in bfx stx4 lp|0 "store sign tsx0 truncate_bfx "can we be an sfx? tra return_bfx "no - return tsx0 convert_bfx_to_sfx "convert tra return_sfx "return fix_bfx: ldaq ap|-2 "just return bfx given staq bp|resultp tra return_bfx " " float: lcq -fn_float,dl eax5 -2 "indicate that we take one arg tsx0 enter "setup the bignums environment tsx0 numval "branch on type tra float_sfx tra float_sfl tra float_bfx float_sfx: ldq ap|-1 "get arg tsx0 convert_q_to_sfl "do the conversion tra return_sfl float_sfl: ldaq ap|-2 "just return the arg tra return float_bfx: epplp ap|-2,* "get ptr to value tsx6 convert_bfx_to_sfl "do the conversion tra float_error "overflow tra return_sfl "do the return " " entry bnread bnread: tsx0 switch_to_lisp "get lisp environment tsx0 enter "get this set of routine's environment ldx6 bp|bn_pl1_length "alloc bfx at least as big as array length stx6 bp|small_limit "save for loop test tsx0 alloc_bfx6 sprilp bp|resultp "store ptr in resultp ldq bp|bn_pl1_ptr,* "load first word tsx0 convert_q_to_bfx "make it a bfx for rest of routine sprilp bp|biggerp eax3 1 "init counter bnread_loop: lda bp|bn_pl1_radix "load radix sta bp|multiplier "store as multiplier tsx0 mpy_bs "mult times the accumulated result epplp bp|resultp,* "move result to bigger sprilp bp|biggerp lda bp|bn_pl1_ptr,*x3 "load next number to be added sta bp|addend "it is put in addend tsx0 add_bs "do the add tsx0 truncate_bfx "truncate result for neatness nop 0 "don't care if can be sfx epplp bp|resultp,* "move sprilp bp|biggerp eax3 1,x3 "get next word cmpx3 bp|small_limit "are we done? tnz bnread_loop "no tsx0 call_alloc_bfx "put result into lisp space eppap ap|2 "get place on mrkd stack for result ldaq bp|resultp "put bignum ptr there ora Big_fixed,dl staq ap|-2 epplp ab|system_lp,* "get ready to return tra ret_to_pl1 "do it " " add1: lcq -fn_add1,dl eax4 add_opcode "indicate that we will do adds add1_enter: eax5 -2 "we are called with one arg tsx0 enter "set up auto vars tsx0 numval "check type of arg tra add1_sfx tra add1_sfl tra add1_bfx add1_sfx: ldi nooverflow,dl "mask overflows ldq ap|-1 "load value xec 7,x4 "add or subtract one tov 2,ic "check for overflow tra return_sfx "done tsx0 force_q_to_bfx "change to bfx sprilp bp|resultp tra return_bfx "done add1_sfl: fld =1.0 "get the one to add or subtract fst bp|temp "save it fld ap|-1 "load value to be add/sub to xec 4,x4 "do the operation tra return_sfl "done add1_bfx: stx4 bp|op_table "we will use the code of plus_bfx epplp ap|-2,* "get bfx value setup like plus sprilp bp|biggerp stz bp|switched lxl2 bp|biggerp,* stx2 bp|big_limit epplp bfx_one sprilp bp|smallerp eax2 1 stx2 bp|small_limit tra plus_bfx_common " even bfx_one: vfd 18/0,18/1 dec 1 " " sub1: lcq -fn_sub1,dl eax4 sub_opcode tra add1_enter " " minus: lcq -fn_minus,dl eax5 -2 "we have one arg tsx0 enter "start tsx0 numval "branch on type tra minus_sfx tra minus_sfl tra minus_bfx minus_sfx: lda ap|-1 "load value lrs 36 "put into AQ negl 0 "do tbe minus cmpaq =v36/0,o36/400000000000 "check that it hasn't become a bfx tnz return_sfx tsx0 convert_aq_to_bfx "it has - change sprilp bp|resultp tra return_bfx minus_sfl: fld ap|-1 "load the value fneg 0 "negate it tra return_sfl minus_bfx: ldaq ap|-2 "copy bfx staq bp|resultp tsx0 call_alloc_bfx eax2 -1 "negate it ersx2 bp|resultp,* tsx0 truncate_bfx "check for -400000000000 tra minus_bfx_big tsx0 convert_bfx_to_sfx "convert to sfx tra return_sfx minus_bfx_big: ldaq bp|resultp "setup return ora Big_fixed,dl tra return " " abs: lcq -fn_abs,dl eax5 -2 "we have one arg tsx0 enter "get environment tsx0 numval "branch on arg type tra abs_sfx tra abs_sfl tra abs_bfx abs_sfx: lda ap|-1 "get arg lrs 36 "make 2 words tpl return_sfx "do abs operation negl 0 cmpaq =v36/0,o36/400000000000 tnz return_sfx tsx0 convert_aq_to_bfx sprilp bp|resultp tra return_bfx abs_sfl: fld ap|-1 "load value tpl return_sfl "do abs operation fneg 0 tra return_sfl abs_bfx: szn ap|-2,* "check sign tmi abs_bfx_minus "branch if negative ldaq ap|-2 "return argument as is tra return abs_bfx_minus: ldaq ap|-2 staq bp|resultp "copy and change sign tsx0 call_alloc_bfx eax2 0 ansx2 bp|resultp,* ldaq bp|resultp ora Big_fixed,dl tra return "return " " minusp: lcq -fn_minusp,dl eax5 -2 "we have one arg tsx0 enter "do entry sequence tsx0 numval "branch to code suitable for arg type tra minusp_sfx tra minusp_sfl tra minusp_bfx minusp_sfx: szn ap|-1 "test sign tmi return_true "return verdict tra return_nil minusp_sfl: fszn ap|-1 tmi return_true tra return_nil minusp_bfx: szn ap|-2,* tmi return_true tra return_nil " " plusp: lcq -fn_plusp,dl eax5 -2 "we have 2 args tsx0 enter "enter tsx0 numval "dispatch tra plusp_sfx tra plusp_sfl tra plusp_bfx plusp_sfx: szn ap|-1 tmi return_nil "tell verdict tze return_nil tra return_true plusp_sfl: fszn ap|-1 tmi return_nil tze return_nil tra return_true plusp_bfx: szn ap|-2,* tmi return_nil tra return_true "can't have zero bfx " " max: lcq -fn_max,dl eax4 max_table "set up max xec table max_start: tsx0 enter "set up environment tsx0 numval "branch on arg type tra max_sfx tra max_sfl tra max_bfx max_sfx: ldaq ap|0,x5 "load first arg max_sfx_loop: eax5 2,x5 "get next arg xec 1,x4 tsx0 numval "branch on type of next arg tra max_sfx_sfx tra max_sfx_sfl tra max_sfx_bfx max_sfx_sfx: cmpq ap|1,x5 "do the comparison xec 0,x4 "what to do is table driven ldq ap|1,x5 "load other value tra max_sfx_loop max_sfx_sfl: tsx0 convert_q_to_sfl "convert to sfl tra max_sfl_sfl "join that code max_sfx_bfx: tsx0 convert_q_to_bfx "go to bfx mode sprilp bp|biggerp tra max_bfx_bfx max_sfl: fld ap|1,x5 "load initial value max_sfl_loop: eax5 2,x5 "get next arg xec 5,x4 tsx0 numval "branch on type tra max_sfl_sfx tra max_sfl_sfl tra max_sfl_bfx max_sfl_sfx: fst bp|temp "save old value ldq ap|1,x5 "get sfx value to be made sfl tsx0 convert_q_to_sfl "convert it max_sfl_sfx_cmp: fcmp bp|temp "compare with old value xec 2,x4 fld bp|temp "switch to old value xec 3,x4 max_sfl_sfl: fcmp ap|1,x5 "do the compare xec 4,x4 fld ap|1,x5 tra max_sfl_loop max_sfl_bfx: fst bp|temp "save old value epplp ap|0,x5* "try to convert new value to sfl tsx6 convert_bfx_to_sfl tra float_error tra max_sfl_sfx_cmp "do the compare max_bfx: ldaq ap|0,x5 "get initial value staq bp|biggerp max_bfx_loop: ldaq bp|biggerp staq bp|resultp eax5 2,x5 "get next arg xec 9,x4 tsx0 numval "check type tra max_bfx_sfx tra max_bfx_sfl tra max_bfx_bfx max_bfx_sfx: ldq ap|1,x5 "get value tsx0 convert_q_to_bfx "make it big sprilp bp|smallerp tra max_bfx_bfx_cmp max_bfx_sfl: epplp bp|biggerp,* "get value so far tsx6 convert_bfx_to_sfl "convert to sfl tra float_error tra max_sfl_sfl "join sfl code max_bfx_bfx: ldaq ap|0,x5 "get new value staq bp|smallerp max_bfx_bfx_cmp: tsx0 compare_signed_bfx xec 6,x4 xec 7,x4 xec 8,x4 max_bfx_bfx_switch: tsx0 switch_bfx "change bigger and smaller tra max_bfx_loop "continue " max_table: tpl max_sfx_loop " 0 tze return_sfx " 1 tpl max_sfl_loop " 2 tra max_sfl_loop " 3 tpl max_sfl_loop " 4 tze return_sfl " 5 tra max_bfx_bfx_switch " 6 tra max_bfx_loop " 7 tra max_bfx_loop " 8 tze return_bfx " 9 " " min: lcq -fn_min,dl eax4 min_table tra max_start "set up and join max " min_table: tmi max_sfx_loop " 0 tze return_sfx " 1 tmi max_sfl_loop " 2 tra max_sfl_loop " 3 tmi max_sfl_loop " 4 tze return_sfl " 5 tra max_bfx_loop " 6 tra max_bfx_loop " 7 tra max_bfx_bfx_switch " 8 tze return_bfx " 9 " " lessp: lcq -fn_lessp,dl eax4 lessp_table tra max_start " lessp_table: tpl return_nil " 0 tze return_true " 1 xed lessp_table_2 " 2 tra return_nil " 3 tpl return_nil " 4 tze return_true " 5 tra max_bfx_bfx_switch " 6 tra return_nil " 7 tra return_nil " 8 tze return_true " 9 even lessp_table_2: tze return_nil tpl max_sfl_loop " " greaterp: lcq -fn_greaterp,dl eax4 greaterp_table "load table ptr and join max tra max_start " greaterp_table: xed greaterp_table_0 " 0 tze return_true " 1 tmi max_sfl_loop " 2 tra return_nil " 3 xed greaterp_table_4 " 4 tze return_true " 5 tra return_nil " 6 tra return_nil " 7 tra max_bfx_bfx_switch " 8 tze return_true " 9 even greaterp_table_0: tmi return_nil tze return_nil greaterp_table_4: tmi return_nil tze return_nil " " remainder: lcq -fn_remainder,dl eax5 -4 "we have 2 args tsx0 enter "set up environment tsx0 numval "test type of first arg tra rem_sfx tra badarg tra rem_bfx rem_sfx: eax5 -2 "check second arg tsx0 numval tra rem_sfx_sfx tra badarg tra rem_sfx_bfx rem_sfx_sfx: ldq ap|-3 "get first number cmpq =o400000000000 "check for -400.../-1 tnz 4,ic lda =-1 cmpa ap|-1 tze rem_sfx_make_big "need bfx arith. div ap|-1 "do the division lrs 36 "get the remainder in proper place tra return_sfx "return rem_sfx_make_big: tsx0 convert_q_to_bfx tra rem_bfx_sfx_start "join bfx code rem_sfx_bfx: ldq ap|-3 "check for -400.../400... cmpq =o400000000000 tnz rem_sfx_bfx_rem epplp ap|-2,* lda lp|0 ldq lp|1 cmpaq =v18/0,18/2,36/0 tnz rem_sfx_bfx_rem lda lp|2 cmpa 1,dl tnz rem_sfx_bfx_rem tra return_0 "rem(-400.../400...) = 0 rem_sfx_bfx_rem: ldq ap|-3 "the dividend is the remainder tra return_sfx rem_bfx: eax5 -2 "look at second arg tsx0 numval tra rem_bfx_sfx tra badarg tra rem_bfx_bfx rem_bfx_sfx: epplp ap|-4,* "get ptr to first arg rem_bfx_sfx_start: sprilp bp|biggerp "store it lda ap|-1 "get divisor tpl rem_bfx_sfx_join "get abs cmpa =o400000000000 "is it too big? tze rem_bfx_sfx_expand neg 0 rem_bfx_sfx_join: sta bp|divisor "store as divisor lxl6 lp|0 "quotient is of the size of the dividend tsx0 alloc_bfx6 "alloc the result sprilp bp|resultp tsx0 div_bs "do the division lda 0 "remainder is in q szn bp|biggerp,* "sgn(rem) = sgn(dividend) tpl 2,ic negl 0 tra return_sfx "return rem_bfx_sfx_expand: lrs 36 "put it in the q tsx0 convert_q_to_bfx "convert to bfx tra rem_bfx_bfx_start "join bfx bfx code rem_bfx_bfx: epplp ap|-2,* "get ptr to second arg rem_bfx_bfx_start: sprilp bp|smallerp "store it epplp ap|-4,* "get ptr to first sprilp bp|biggerp "store it, too tsx0 div_bb "do the divide ldx2 bp|n "get length of divisor sxl2 bp|dividendp,* "store as length of remainder ldx2 bp|biggerp,* "get sign of dividend stx2 bp|dividendp,* "it is sign of remainder epplp bp|dividendp,* "get ptr to it sprilp bp|resultp "store in result tsx0 rsh_bfx "shift right to normalize result tsx0 truncate_bfx "make as small as possible tra return_bfx "that's it tsx0 convert_bfx_to_sfx "skip => can be sfx tra return_sfx " " expt: lcq -fn_expt,dl eax5 -4 "we have two args tsx0 enter "enter eax5 -2 "look at second arg tsx0 numval tra expt_x_sfx tra expt_x_sfl tra expt_x_bfx expt_x_sfx: eax5 -4 "look at other arg tsx0 numval tra expt_sfx_sfx tra expt_sfl_sfx tra expt_bfx_sfx expt_sfx_sfx: szn ap|-1 "to what are we raising it? tze return_1 "x**0 is 1 tmi badarg "only positive exponents allowed ldq ap|-3 "get base tze return_0 "zero to anything but zer o is zero cmpq 1,dl "one to anything but zero is one tze return_1 cmpq =-1 "minus one is almost as easy tnz expt_sfx_sfx_nmo "nmo => not minus one lda ap|-1 "load power cana 1,dl "test for even/odd tnz 2,ic "transfer if odd (leaving -1 in q) ldq 1,dl tra return_sfx expt_sfx_sfx_nmo: lda ap|-1 "load power cmpa 1,dl "special cas e one tze return_sfx sta bp|n "save exponent stq bp|m "save base as initial value to be squared ldq 1,dl "initial result stq bp|j " j is the partial result expt_sfx_sfx_loop: lda bp|n "get the exponent cana 1,dl "is it odd? tze expt_sfx_sfx_even ldq bp|j mpy bp|m "multiply accumulated power * partial result tsx0 check_aq "is it still small? tra expt_sfx_sfx_big1 "no stq bp|j "store as new partial result expt_sfx_sfx_even: lda bp|n "ge t the exponent ars 1 "get next bit tze expt_sfx_sfx_done "zero - done sta bp|n "save it ldq bp|m "get next power mpy bp|m tsx0 check_aq tra expt_sfx_sfx_big2 stq bp|m tra expt_sfx_sfx_loop "do next expt_sfx_sfx_done: ldq bp|j "get result tra return_sfx "return expt_sfx_sfx_big1: stx7 bp|initial_value "need to remember where stack was tsx0 convert_aq_to_bfx "change j and m to bfx and join bfx sprilp bp|presultp ldq bp|m tsx0 convert_q_to_bfx sprilp bp|powerp tra expt_bfx_sfx_even expt_sfx_sfx_big2: stx7 bp|initial_value "remember where stack was staq bp|temp "want j stored before m ldq bp|j tsx0 convert_q_to_bfx sprilp bp|presultp ldaq bp|temp tsx0 convert_aq_to_bfx sprilp bp|powerp tra expt_bfx_sfx_loop expt_sfl_sfx: lda ap|-1 "to what are we raising it? tze return_1.0 "x**0 is one, floating point sta bp|n tpl expt_sfl_sfx_plus handle negative powers here neg 0 sta bp|n fld =1.0,du "get inverse of base fdv ap|-3 tra 2,ic "and store as base expt_sfl_sfx_plus: fld ap|-3 "get base fst bp|m "save as multiplier fld =1.0,du "get initial partial result fst bp|j "save it expt_sfl_sfx_loop: lda bp|n "is the current power value even? cana 1,dl tze expt_sfl_sfx_even "yes fld bp|j "odd => p. res. <- p. res. * multiplier fmp bp|m fst bp|j expt_sfl_sfx_even: lda bp|n "get next bit of power ars 1 tze expt_sfl_sfx_done "no more one bits => done sta bp|n "save power fld bp|m "square multiplier fmp bp|m fst bp|m tra expt_sfl_sfx_loop "do again expt_sfl_sfx_done: fld bp|j tra return_sfl expt_x_sfl: eax5 -4 "look at other arg tsx0 numval tra expt_sfx_sfl tra expt_sfl_sfl tra badarg "bignum to float power not supported expt_sfx_sfl: expt_sfl_sfl: "hard cases - call PL/I support procedure ldi bp|saved_indicators flush ourselves ldx5 bp|num_of_args eppap ap|4,x5 leave just our 2 args on stack eax7 0,x1 flush all but caller's lp and bp spriap |[stack_ptr] now enter PL/I mode stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code push eppap |[..lisp..] spriap sp|22 eppap null_arg_list short_call |[expt_assistance] eppbp sp|16,* pop stack sprisp sb|20 eppsp bp|0 eppap |[stack_ptr],* epbpab |[unmkd_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code ldaq ap|-2 eppap ap|-2 epplp ab|old_lp,x7* eppbp ab|return_point,x7* eax7 -4,x7 tra bp|0 even null_arg_list: oct 4,0 expt_bfx_sfx: szn ap|-1 "to what are we raising it? tze return_1 "x**0 is 1 tmi badarg "only positive exponents allowed lda ap|-1 "check if x**1 cmpa 1,dl tnz 3,ic ldaq ap|-4 "identity tra return sta bp|n "save exponent stx7 bp|initial_value "remember where umstk was ldq 1,dl "initial partial result is one tsx0 convert_q_to_bfx sprilp bp|presultp "move base to power ldaq ap|-4 staq bp|resultp lxl6 bp|resultp,* tsx0 alloc_bfx6 sprilp bp|powerp tsx6 move_bfx expt_bfx_sfx_loop: lda bp|n "get exponent cana 1,dl "was it odd or even? tze expt_bfx_sfx_even "no ldaq bp|presultp "presult <= presult * power staq bp|smallerp ldaq bp|powerp staq bp|biggerp tsx0 setup_mpy_bfx tsx0 mpy_bfx tsx0 truncate_bfx nop 0,dl ldaq bp|resultp staq bp|presultp expt_bfx_sfx_even: lda bp|n "get exponent ars 1 "get next bit tze expt_bfx_sfx_done "zero - done sta bp|n "save exponent ldaq bp|powerp "square power staq bp|smallerp staq bp|biggerp tsx0 setup_mpy_bfx tsx0 mpy_bfx tsx0 truncate_bfx nop 0,dl ldaq bp|resultp staq bp|powerp ldx2 bp|initial_value "is presult at the lowest place in umstk? cmpx2 bp|presultp+1 tze expt_bfx_sfx_copy_p "yes ldaq bp|presultp "move it to lowest place staq bp|resultp epplp ab|0,x2 sprilp bp|presultp tsx6 move_bfx expt_bfx_sfx_copy_p: lxl2 bp|presultp,* "how low can we move power? eax2 2,x2 adx2 bp|initial_value anx2 -2,du epplp ab|0,x2 ldaq bp|powerp staq bp|resultp "move it sprilp bp|powerp tsx6 move_bfx lxl2 bp|powerp,* "truncate stack eax2 2,x2 anx2 -2,du adx2 bp|powerp+1 eax7 0,x2 tra expt_bfx_sfx_loop expt_bfx_sfx_done: ldaq bp|presultp "done - get result staq bp|resultp tra return_bfx "done expt_x_bfx: eax5 -4 "look at first arg tsx0 numval tra expt_sfx_bfx tra expt_sfl_bfx tra badarg expt_sfx_bfx: eax5 -2 "checking second arg's applicability to first - so err on 2nd ldq ap|-3 "get the base tze return_0 "0**x is zero (x bfx) cmpq 1,dl "1**x is 1 tze return_1 cmpq =-1 "is it -1? tnz badarg "that's the last legal one eax2 1 "check for even odd lda ap|-2,*x2 cana 1,dl tze return_1 tra return_sfx "-1 left in q expt_sfl_bfx: eax5 -2 "similar to sfx_bfx fld ap|-3 tze return_0.0 fcmp =1.0,du tze return_1.0 fcmp =-1.0,du tnz badarg eax2 1 lda ap|-2,*x2 cana 1,dl tze return_1.0 fld =-1.0,du tra return_sfl " " haipart: lcq -fn_haipart,dl eax5 -4 tsx0 enter eax5 -2 tsx0 numval " check second arg type. tra haipart_ok tra badarg tra badarg haipart_ok: eax5 -4 tsx0 numval " branck on first arg type. tra haipart_sfx tra badarg tra haipart_bfx haipart_sfx: lda ap|1,x5 " get first argument into A tsx0 norm_a " and get number of significant bits in it. lls 36 " move length to A, ldq ap|1,x5 " and get argument 1. tpl 3,ic " if negative, make positive erq =-1 " avoiding fixedoverflow adlq 1,dl " by negating with two instructions. cmg ap|3,x5 " compare length to |arg 2| tze simple_haipart_sfx " if length <= |arg 2| tmi simple_haipart_sfx szn ap|3,x5 " get sign of second arg. tze return_0 " if second arg 0, the result is 0. tmi haipart_sfx_rem " if negative, do remainder sba ap|3,x5 " get power of 2 to divide by qrl 0,al " shift down top part of word. tra return_sfx haipart_sfx_rem: lda 36,dl " get amount to delete from front ada ap|3,x5 " which is 36-number of bits wanted. qls 0,al qrl 0,al tra return_sfx simple_haipart_sfx: " return absolute value, which is in q. cmpq =o400000,du " check for screw case, which is bignum. tnz return_sfx " otherwise return small number. epplp ab|0,x7 " get space for bignum. eax7 4,x7 " on unmarked stack lda 2,dl " 2 words long, sta lp|0 stz lp|1 " a zero word, and lda 1,dl " a one word sta lp|2 sprilp bp|resultp " set result tra return_bfx " and return bignum. " " " haipart_bfx: epplp ap|0,x5* " get pointer to first argument. lxl2 lp|0 " and length. lda lp|0,x2 " get last word tsx0 norm_a " count number of bits in it stq bp|temp " and save the count eaq -1,x2 " get number of whole words in argument qrs 18 mpy 35,dl " get length in bits adq bp|temp " ... lls 36 " compare bit length cmg ap|3,x5 " with secons argument. tmi simple_haipart_bfx " if second arg specifies more bits, tze simple_haipart_bfx " just do the right thing szn ap|3,x5 " check whether to do remainder tze return_0 " return zero if no bits asked for tpl 3,ic " if remainder, lca ap|3,x5 " get number of bits. tra 2,ic sba ap|3,x5 " else subtract 2nd arg. lrl 36 " determine how many bits are to be divided off the right div 35,dl " A contains number of bits, " Q contains number of whole words. szn ap|3,x5 " check again whether to remainder tmi haipart_bfx_rem sta bp|shift_value qls 18 stq bp|temp " savenumber of words to truncate from right. lxl6 lp|0 " compute length of result sbx6 bp|temp " by subtracting off number of words truncated. stx6 bp|temp+1 " save size in words of result ldx3 bp|temp " get offset for mlr below tsx0 alloc_bfx6 " allocate result on stack sprilp bp|resultp " and save location. ldx2 bp|temp+1 " set the length of the result. sxl2 lp|0 " note that the sign is zero. eppbb ap|0,x5* " bb -> place copied from. eppbb bb|0,x3 " offset by number of words dropped eaq 0,x2 " qu := # words to copy (not header) qls 2 " convert # words to # characters mlr (pr,rl),(pr,rl) desc9a bb|1,qu desc9a lp|1,qu tsx0 rsh_bfx " shift bfx right by amount required. tsx0 truncate_bfx tra return_bfx tsx0 convert_bfx_to_sfx " truncate skipped, so make sfx tra return haipart_bfx_rem: " remainder operation. sba 36,dl neg 0 " get amount to delete from high order word. sta bp|shift_value eax6 1,ql " allocate this many words. stx6 bp|temp+1 tsx0 alloc_bfx6 " allocate the bfx on stack. sprilp bp|resultp ldx2 bp|temp+1 sxl2 lp|0 " set length of result. eppbb ap|0,x5* " get pointer to argument. eaq 0,x2 " compute length of stuff after header, in characters mpy 4,dl mlr (pr,rl),(pr,rl) desc9a bb|1,qu desc9a lp|1,qu lda lp|0,x2 " get high order word lxl3 bp|shift_value " get amount to delete als 0,x3 arl 0,x3 sta lp|0,x2 " put back word after deleteion. tsx0 truncate_bfx tra return_bfx tsx0 convert_bfx_to_sfx tra return simple_haipart_bfx: ldaq ap|0,x5 " get first arg. szn lp|0 " check its sign, tpl return " return the arg as result. staq bp|resultp " set up to cpy to result tsx0 call_alloc_bfx eax2 0 " to set sign. stx2 bp|resultp,* ldaq bp|resultp " load the name of the result ora Big_fixed,dl tra return " and return " " " " " gcd: lcq -fn_gcd,dl "load type code of gcd eax5 -4 "we are a subr with 2 args tsx0 enter "set up environment tsx0 numval "look at first arg tra gcd_sfx tra badarg tra gcd_bfx gcd_sfx: lda ap|-3 "look at first arg tsx0 abs_sfx_a_to_q "get abs of first arg tra gcd_bfx_join "if too big, join big code stq bp|divisor "save it eax5 -2 "check second arg tsx0 numval tra gcd_ss tra badarg tra gcd_sb gcd_ss: lda ap|-1 "load second arg tsx0 abs_sfx_a_to_q "get abs tra gcd_sb_join "too big szn bp|divisor "test for zero operands => return abs of other tze return_sfx "answer is in q already cmpq 0,dl "test other one tnz gcd_ss_loop ldq bp|divisor tra return_sfx gcd_ss_loop: div bp|divisor "get remainder of (q) and divisor gcd_ss_loop1: ldq bp|divisor "replace (q) with other value sta bp|divisor "replace other with remainder cmpa 0,dl "if remainder was zero, done, otherwise, loop tnz gcd_ss_loop tra return_sfx "old other value (in q now) is result gcd_sb: epplp ap|-2,* "get ptr to big arg gcd_sb_join: sprilp bp|biggerp "save it gcd_sb_do: szn bp|divisor "test smallnum for 0 (big can't be zero) tze gcd_bs0 lxl6 bp|biggerp,* "alloc space for quotient, which we ignore tsx0 alloc_bfx6 sprilp bp|resultp tsx0 div_bs "do a divide lls 36 "put in the a the remainder (now in q) tra gcd_ss_loop1 "join other code gcd_bfx: epplp ap|-4,* "get ptr to big num gcd_bfx_join: sprilp bp|biggerp "store the ptr to big num eax5 -2 "look at second arg tsx0 numval tra gcd_bs tra badarg tra gcd_bb gcd_bs: lda ap|-1 "get small num tsx0 abs_sfx_a_to_q tra gcd_bb_join stq bp|divisor "save it tra gcd_sb_do "join other big/small code gcd_bs0: epplp bp|biggerp,* "get copy of big arg, and abs of it sprilp bp|resultp tsx0 call_alloc_bfx "get copy into lisp space eax2 0 "set sign to plus stx2 bp|resultp,* ldaq bp|resultp "set up return ora Big_fixed,dl tra return gcd_bb: epplp ap|-2,* "get ptr to second arg gcd_bb_join: sprilp bp|smallerp "save it lxl2 lp|0 "make sure bigger is bigger stx2 bp|small_limit lxl2 bp|biggerp,* stx2 bp|big_limit tsx0 compare_bfx tsx0 switch_bfx nop 0,dl nop 0,dl ldx6 bp|big_limit "put bigger of two in u, smaller in v tsx0 alloc_bfx6 sprilp bp|up ldaq bp|biggerp staq bp|resultp tsx6 move_bfx ldx6 bp|small_limit tsx0 alloc_bfx6 sprilp bp|vp ldaq bp|smallerp staq bp|resultp tsx6 move_bfx eax2 0 "set signs to zero - i.e. get abs stx2 bp|up,* stx2 bp|vp,* stx7 bp|initial_value "save stack end - so we can truncate garbage gcd_bb_l1: lda bp|vp,* "check that we don't have to go to gcd_bs cmpa 1,dl "is length 1? tze gcd_bb_to_bs cmpa bp|up,* "make sure lengths are same (sign is 0, so lda) tnz gcd_bb_doremain "if not equal, then make like Euclid ldq bp|up,*al "high order word is used for quicky calculation stq bp|uh "u hat ldq bp|vp,*al stq bp|vh "v hat ldq 1,dl "set A,D = 1 stq bp|A stq bp|D stz bp|B "and B, C = 0 stz bp|C gcd_bb_l2: ldq bp|vh "follow Lehmer's alg in Knuth adlq bp|C tze gcd_bb_l4 stq bp|temp ldq bp|uh adlq bp|A tmi gcd_bb_l4 "overflow div bp|temp stq bp|q ldq bp|vh adlq bp|D tze gcd_bb_l4 tmi gcd_bb_l4 stq bp|temp ldq bp|uh adlq bp|B div bp|temp cmpq bp|q tnz gcd_bb_l4 gcd_bb_l3: mpy bp|C negl 0 adl bp|A lda bp|C sta bp|A stq bp|C ldq bp|q mpy bp|D negl 0 adl bp|B lda bp|D sta bp|B stq bp|D ldq bp|q mpy bp|vh negl 0 adl bp|uh lda bp|vh sta bp|uh stq bp|vh tra gcd_bb_l2 gcd_bb_l4: szn bp|B tze gcd_bb_doremain epplp bp|up,* "calc Au, Bv, Cu, and Dv, then combine sprilp bp|biggerp lxl6 lp|0 eax6 1,x6 tsx0 alloc_bfx6 sprilp bp|resultp sprilp bp|ptemp1 eax2 0 lda bp|A tpl 3,ic "set sign of result neg 0 eax2 -1 stx2 lp|0 sta bp|multiplier tsx0 mpy_bs epplp bp|vp,* sprilp bp|biggerp lxl6 lp|0 eax6 1,x6 tsx0 alloc_bfx6 sprilp bp|resultp sprilp bp|ptemp2 eax2 0 lda bp|B tpl 3,ic neg 0 eax2 -1 stx2 lp|0 sta bp|multiplier tsx0 mpy_bs epplp bp|up,* sprilp bp|biggerp lxl6 lp|0 eax6 1,x6 tsx0 alloc_bfx6 sprilp bp|resultp sprilp bp|ptemp3 eax2 0 lda bp|C tpl 3,ic neg 0 eax2 -1 stx2 lp|0 sta bp|multiplier tsx0 mpy_bs epplp bp|vp,* sprilp bp|biggerp lxl6 lp|0 eax6 1,x6 tsx0 alloc_bfx6 sprilp bp|resultp sprilp bp|ptemp4 eax2 0 lda bp|D tpl 3,ic neg 0 eax2 -1 stx2 lp|0 sta bp|multiplier tsx0 mpy_bs ldaq bp|ptemp1 "do the combining staq bp|biggerp ldaq bp|ptemp2 staq bp|smallerp ldaq bp|up staq bp|resultp tsx0 add_bb tsx0 truncate_bfx nop 0,dl ldaq bp|ptemp3 staq bp|biggerp ldaq bp|ptemp4 staq bp|smallerp ldaq bp|vp staq bp|resultp tsx0 add_bb tsx0 truncate_bfx nop 0,dl ldx7 bp|initial_value "release all scratch space used above tra gcd_bb_l1 "go around again gcd_bb_doremain: ldaq bp|up staq bp|biggerp ldaq bp|vp staq bp|smallerp "do normal remainder way tsx0 div_bb epplp bp|vp,* sprilp bp|resultp epplp bp|up,* tsx6 move_bfx "move v to u ldx2 bp|n "normalize remainder, and put in v epplp bp|dividendp,* stz lp|0 "make positive sxl2 lp|0 "store size sprilp bp|resultp tsx0 rsh_bfx tsx0 truncate_bfx nop 0,dl epplp bp|vp,* tsx6 move_bfx ldx7 bp|initial_value "clean up mess tra gcd_bb_l1 gcd_bb_to_bs: epplp bp|vp,* "set up for bs sprilp bp|resultp tsx0 convert_bfx_to_sfx "make the smaller one an sfx stq bp|divisor epplp bp|up,* tra gcd_sb_join " " haulong: lcq -fn_haulong,dl " function to count significant bits in a number. eax5 -2 tsx0 enter " set up. tsx0 numval " check argument type. tra haulong_sfx tra badarg tra haulong_bfx haulong_sfx: " single precision haulong. lda ap|1,x5 " load argument. tsx0 norm_a " normalize it tra return_sfx " return Q, which contains number of significant bits. haulong_bfx: epplp ap|0,x5* " get pointer to bignum lxl2 lp|0 " get number words in bignum lda lp|0,x2 " load the most significant word. tsx0 norm_a " get number of significant bits in Q. stq bp|temp " and remember for later. eaq -1,x2 " get number of words in bignum in Q. qrs 18 mpy 35,dl " 35 bits per word. adq bp|temp tra return_sfx end fld ap|-3 "get base tze return_0.0 "0**x is zero, floating point fcmp =1.0,du "special case 1**x, -1**x tze return_1.0 fcmp =-1.0,du tnz expt_sfl_sfx_nmo lda ap|-1 cana 1,dl "test power for odd/even tze return_1.0 fld =-1.0,du tra return_sfl expt_sfl_sfx_nmo:  lisp_car_cdrs_.alm 07/06/83 0937.8r w 06/29/83 1542.7 32769 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " " lisp_car_cdrs_ - contains all the car's and cdr's of lisp.... " " " Modified 1982.10.06 by Richard Lamson to add nth and nthcdr " include lisp_object_types segdef car segdef quote segdef cdr " The fast two... quote: car: ldaq ap|-2,* tra zap_out-*,ic cdr: eax0 2 for post index ldaq ap|-2,*0 zap_out: eppap ap|-2 pop stack back tra bp|0 and return " " Now the slightly slower ones, entered with a save lp... " segdef cddddr segdef cadddr segdef cdaddr segdef caaddr segdef cddadr segdef cadadr segdef cdaadr segdef caaadr segdef cdddar segdef caddar segdef cdadar segdef caadar segdef cddaar segdef cadaar segdef cdaaar segdef caaaar segdef cdddr segdef caddr segdef cdadr segdef caadr segdef cddar segdef cadar segdef cdaar segdef caaar segdef cddr segdef cadr segdef cdar segdef caar cddddr: eppbp ap|-2,* eppbp bp|2,* cddd: eppbp bp|2,* cdd: eppbp bp|2,* cd: ldaq bp|2 c: eppap ap|-2 epplp ab|-4,7* eppbp ab|-2,7* eax7 -4,7 tra bp|0 cadddr: eppbp ap|-2,* eppbp bp|2,* cadd: eppbp bp|2,* cad: ldaq bp|2,* tra c-*,ic cdaddr: eppbp ap|-2,* eppbp bp|2,* cdad: eppbp bp|2,* cda: eppbp bp|0,* tra cd-*,ic caaddr: eppbp ap|-2,* eppbp bp|2,* caad: eppbp bp|2,* caa: ldaq bp|0,* tra c-*,ic cddadr: eppbp ap|-2,* eppbp bp|2,* cdda: eppbp bp|0,* tra cdd-*,ic cadadr: eppbp ap|-2,* eppbp bp|2,* cada: eppbp bp|0,* tra cad-*,ic cdaadr: eppbp ap|-2,* eppbp bp|2,* cdaa: eppbp bp|0,* tra cda-*,ic caaadr: eppbp ap|-2,* eppbp bp|2,* caaa: eppbp bp|0,* tra caa-*,ic cdddar: eppbp ap|-2,* eppbp bp|0,* tra cddd-*,ic caddar: eppbp ap|-2,* eppbp bp|0,* tra cadd-*,ic cdadar: eppbp ap|-2,* eppbp bp|0,* tra cdad-*,ic caadar: eppbp ap|-2,* eppbp bp|0,* tra caad-*,ic cddaar: eppbp ap|-2,* eppbp bp|0,* tra cdda-*,ic cadaar: eppbp ap|-2,* eppbp bp|0,* tra cada-*,ic cdaaar: eppbp ap|-2,* eppbp bp|0,* tra cdaa-*,ic caaaar: eppbp ap|-2,* eppbp bp|0,* tra caaa-*,ic cdddr: eppbp ap|-2,* tra cddd-*,ic caddr: eppbp ap|-2,* tra cadd-*,ic cdadr: eppbp ap|-2,* tra cdad-*,ic caadr: eppbp ap|-2,* tra caad-*,ic cddar: eppbp ap|-2,* tra cdda-*,ic cadar: eppbp ap|-2,* tra cada-*,ic cdaar: eppbp ap|-2,* tra cdaa-*,ic caaar: eppbp ap|-2,* tra caaa-*,ic cddr: eppbp ap|-2,* tra cdd-*,ic cadr: eppbp ap|-2,* tra cad-*,ic cdar: eppbp ap|-2,* tra cda-*,ic caar: eppbp ap|-2,* tra caa-*,ic " nth: (nth n list): returns (ca(d**n)r list) segdef nth nth: lxl0 ap|-3 get n in x0 eppbp ap|-2,* and the list in bp nthloop: eax0 -1,x0 count tmi nthreturns-*,ic eppbp bp|2,* cdr tra nthloop-*,ic nthreturns: ldaq bp|0 return car eppap ap|-4 pop our args. tra c+1-*,ic " nthcdr: (nthcdr n list) returns (c(d**n)r list) segdef nthcdr nthcdr: lxl0 ap|-3 get n in x0 eax7 2,x7 sprilp ab|-2,x7 epplp ap|-2 get address first cons in lp eppbp lp|0,* and the cons in bp lda Atomic,dl nthcdrloop: cana lp|0 test to see if end of list tnz nthcdrreturnsnil-*,ic eax0 -1,x0 count tmi nthcdrreturns-*,ic epplp bp|2 pointer to next cons eppbp lp|0,* cdr tra nthcdrloop-*,ic nthcdrreturns: epplp ab|-2,x7* eax7 -2,x7 spribp ap|-4 we need to return this cdr ldaq ap|-4 get it into AQ eppap ap|-4 pop our args tra c+1-*,ic return nthcdrreturnsnil: epplp ab|-2,x7* eax7 -2,x7 ldaq lisp_static_vars_$nil eppap ap|-4 tra c+1-*,ic end  lisp_error_table_.alm 07/06/83 0937.8r w 06/29/83 1542.7 100953 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " " lisp_error_table_: October 1982 by Richard Lamson " " This version written in October 1982, with messages cribbed from " lisp_error_table_.macro. Converted from macro form to alm by " Richard Lamson " bool data,400000 bool print,200000 bool listify,100000 bool special_begin,040000 bool user_interrupt_present,020000 bool eval,010000 bool special_interrupt,004000 bool special_finish,002000 bool status_code,001000 bool has_fault_save_frame,000400 bool sptrapf,000200 " Not used in this program. bool function_name,000100 use Messages segdef msgs msgs: use Interrupt_numbers segdef uintnum: uintnum: use Attributes segdef bit_tbl bit_tbl: set NEXT_ERROR_CODE,100 macro error_code use Codes segdef &1 &1: vfd 36/NEXT_ERROR_CODE set NEXT_ERROR_CODE,NEXT_ERROR_CODE+1 use Messages aci "&2",40 use Interrupt_numbers &=&4.,.&[ dec 0 &; dec &4 &] use Attributes &=&4.,.&[ vfd 18/&3 &; vfd 18/&3+user_interrupt_present &] &end error_code undefined_atom,(undefined atomic symbol),listify+data+print+eval,6 error_code undefined_function,(undefined function),listify+data+print,5 error_code too_many_args,(lisp: ^a called with too many arguments`),function_name+eval,9 error_code too_few_args,(lisp: ^a called with too few arguments`),function_name+eval,9 error_code file_system_error,([Obsolete Error]),status_code error_code bad_argument,(lisp: function ^a rejected argument `),function_name+print+data error_code undefined_subr,(attempt to link to subr failed!),() error_code bad_function,(invalid functional form),print+data error_code bad_bv,(attempt to bind non-variable),print+data error_code unseen_go_tag,(go to an undefined tag),listify+print+data,8 error_code throw_to_no_catch,(throw can't find a catch),listify+print+data,8 error_code non_fixed_arg,(lisp: argument must be fixnum - ^a on `),function_name+print+listify+data,7 error_code parenmissing,(parenthesis missing - read),() error_code doterror,(dot context error - read),() error_code illobj,(unreckognizable object - read),() error_code badmacro,(read macro character lost:),print+data error_code shortreadlist,(list too short - readlist),() error_code badreadlist,(invalid character object),print+data error_code array_bound_error,([Obsolete Error]),has_fault_save_frame+print+data,11 error_code car_cdr_error,(car or cdr of number),has_fault_save_frame error_code bad_arg_correctable,(lisp: function ^a rejected argument `),listify+print+data+function_name,7 error_code bad_prog_op,(no prog - go or return),special_interrupt+special_finish,11 error_code no_lexpr,(no lexpr - arg or setarg),print+data+special_finish,11 error_code wrong_no_args,(wrong number of arguments - eval),print+data+eval,9 error_code bad_ibase,(improper ibase, changed to 8),listify+special_begin+special_interrupt+special_finish,11 error_code bad_base,(improper base, changed to 8),listify+special_begin+special_interrupt+special_finish,11 error_code bad_input_source,(bad input source),print+data,7 error_code bad_output_dest,(bad output destination),print+data,7 error_code nihil_ex_nihile,(nihil ex nihil - don't setq or bind nil),special_interrupt+special_finish,11 error_code obsolete_131,([Obsolete Error]),() error_code obsolete_132,([Obsolete Error]),() error_code not_pdl_ptr,(lisp: ^a wanted a pdl pointer, but got `),function_name+listify+print+data,7 error_code obsolete_134,([Obsolete Error]),() error_code obsolete_135,([Obsolete Error]),() error_code bad_f_fcn,(call to unexpected fsubr or fexpr),print+data error_code overflow_err,(lisp: overflow while ^a was acting on `),function_name+print+data error_code mismatch_super_parens,(mismatched super-parentheses:),print+data error_code no_left_super_paren,(missing left super-parenthesis),() error_code flonum_too_big,(flonum out of range - read),() error_code quoterror,(illegal format - ' macro),() error_code badreadtable,(bad readtable),() error_code badobarray,(bad obarray),() error_code atan_0_0_err,(atan 0 0 is not allowed),() error_code unable_to_float,(this bignum is too big to be floated:),listify+print+data+eval,7 error_code division_by_zero,(division by zero),() error_code eof_in_object,(end of file in the middle of an object),listify+special_interrupt,11 error_code cant_filepos,(filepos doesn't work on streams),print+data+eval,11 error_code filepos_oob,(attempt to filepos past end of file),print+data+eval,11 error_code file_sys_fun_err,(),status_code+print+data+eval,11 error_code stars_left_in_name,(imprecise namelist),print+data+eval,11 error_code io_wrong_direction,(not opended for I/O in this direction),print+data,11 error_code file_is_closed,(a closed file cannot do I/O),print+data,11 error_code reopen_inconsistent,(unable to re-open saved file),print+data,11 error_code bad_entry_name,(entryname too long or missing),print+data+eval,7 error_code bad_do_format,(improper format - do),print+data error_code not_an_array,(lisp: ^a rejected non-array argument `),function_name+print+data+eval,7 error_code not_alpha_array,(lisp: ^a found non-alpha elements of `),function_name+print+data+eval,7 error_code include_file_error,(),status_code+print+data error_code stack_loss_error,(pdl overflow - infinite recursion?),has_fault_save_frame+data+special_finish,12 error_code underflow_fault,(arithmetic underflow),has_fault_save_frame+data,11 error_code zerodivide_fault,(attempt to divide by zero),has_fault_save_frame+data,11 error_code bad_array_subscript,(bad array subscript),print+data error_code store_not_allowed,(lisp: can't store into this array - ^a `),function_name+print+data error_code dead_array_reference,(attempt to reference a dead array),print+data error_code cant_subscript_readtable,(subscripted reference to a readtable),print+data error_code not_same_type,(lisp: arrays not of same type - ^a `),function_name+print+data error_code special_array_type,(lisp: illegal type of array for ^a `),function_name+print+data error_code array_too_big,(attempt to create an overly-large array),print+data error_code argument_must_be_array,(lisp: ^a wants an array, not `),function_name+print+data error_code store_function_misused,(the 'store' function was misused),has_fault_save_frame error_code meaningless_argument_number,(lisp: meaningless argument number - ^a `),data+print+listify+function_name,7 error_code subrcall_bad_ptr,(not a subr pointer - subrcall),print+data error_code lsubrcall_bad_ptr,(not an lsubr pointer - lsubrcall),print+data error_code arraycall_bad_ptr,(not an array pointer - arraycall),print+data error_code arraycall_wrong_type,(array not of specified type - arraycall),print+data error_code csd_op_barf,(illegal string argument to a defpl1 subr),() error_code cad_op_barf,(improper array argument to a defpl1 subr),() error_code wrong_external_array_ndims,(an external array must have 1 dimension),print+data error_code cant_set_plist,(illegal attempt to setplist),listify+print+data,7 error_code bad_item_in_modelist,(unrecognized item in modelist),listify+print+data,7 use Codes segdef hbound hbound: vfd 36/NEXT_ERROR_CODE-1 macro function_name aci "&1",16 &end segdef fnames fnames: function_name do function_name arg function_name setarg function_name status function_name sstatus function_name errprint function_name errframe function_name evalframe function_name defaultf function_name ??unused19?? function_name ??unused20?? function_name crunit function_name tyo function_name ascii function_name rplaca function_name definedp function_name setq function_name set function_name delete function_name delq function_name stringlength function_name catenate function_name array function_name substr function_name index function_name get_pname function_name make_atom function_name ItoC function_name CtoI function_name defsubr function_name *array function_name args function_name sysp function_name get function_name getl function_name putprop function_name remprop function_name save function_name add1 function_name sub1 function_name greaterp function_name lessp function_name minus function_name plus function_name times function_name difference function_name quotient function_name abs function_name expt function_name boole function_name rot function_name lsh function_name signp function_name fix function_name float function_name remainder function_name max function_name min function_name 1+ function_name 1+$ function_name 1- function_name 1-$ function_name + function_name +$ function_name * function_name *$ function_name - function_name -$ function_name / function_name /$ function_name eval function_name apply function_name prog function_name errset function_name catch function_name throw function_name store function_name defun function_name baktrace function_name bltarray function_name *rearray function_name gensym function_name makunbound function_name boundp function_name *status function_name *sstatus function_name freturn function_name cos function_name sin function_name exp function_name log function_name sqrt function_name isqrt function_name atan function_name sleep function_name oddp function_name tyipeek function_name alarmclock function_name plusp function_name minusp function_name < function_name = function_name > function_name alphalessp function_name samepnamep function_name getchar function_name opena function_name sxhash function_name gcd function_name allfiles function_name chrct function_name close function_name deletef function_name eoffn function_name filepos function_name inpush function_name linel function_name mergef function_name namelist function_name names function_name namestring function_name openi function_name openo function_name prin1 function_name princ function_name print function_name read function_name readch function_name readline function_name rename function_name shortnamestring function_name tyi function_name setsyntax function_name cursorpos function_name force-output function_name clear-input function_name random function_name haulong function_name haipart function_name cline function_name fillarray function_name listarray function_name sort function_name sortcar function_name zerop function_name listify function_name charpos function_name pagel function_name linenum function_name pagenum function_name endpagefn function_name arraydims function_name loadarrays function_name dumparrays function_name ^ function_name ^$ function_name nointerrupt function_name open function_name in function_name out function_name truename function_name ifix function_name fsc function_name progv function_name mapatoms function_name unwind-protect function_name eval-when function_name read-from-string function_name displace function_name nth function_name nthcdr function_name includef function_name ? segdef fnames_hbound fnames_hbound: vfd 36/(*-fnames)/4+9 " The nine is a fudge factor, " because fn_do starts at -10 join /text/Codes,Messages,Interrupt_numbers,Attributes end  lisp_flonum_conversion_.alm 07/06/83 0937.8r w 06/29/83 1542.7 64926 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1974 * " * * " ************************************************************** name lisp_flonum_conversion_ " This routine converts flonums to character string s for the benefit of lisp_print_ " It can probably be replaced by numeric_to_ascii_ when that routine is installed. " Written 74.03.18 by DAM " This routine is called with one argument, as follows " 1 argument_structure aligned, " 2 flonum float bin(27) number to be converted " 2 bufp pointer unaligned -> char(76) varying string " 2 temps_for_this_routine, " 3 mantissa fixed bin(27) " 3 exponent fixed bin(8) " 3 dec_temp float decimal(10) " 3 dec_exp float decimal(10) " 3 dbl_temp fixed bin(71) equ flonum,0 equ bufp,1 equ mantissa,2 equ exponent,3 equ dec_temp,4 equ dec_exp,7 equ dbl_temp,10 equ varying_string_length,0 equ varying_string_chars,1 zero_table: " TCT table for looking for zeroes vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 9/0,27/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 vfd 36/-1 minus_sign: aci /-/ zero_point_zero: aci /0.0/ a_zero: aci /0/ a_dot: aci /./ e_plus_e_minus: aci /e+e-/ two_to_the_64: aci /18446744073709551616/ 20. characters segdef lisp_flonum_conversion_ lisp_flonum_conversion_: eppap ap|2,* -> argument structure fld ap|flonum pick up argument tze special_case_zero only needed because of bug in MVN instruction ars 8 explode the flonum sta ap|mantissa ste ap|exponent btd (pr),(pr) convert mantissa to decimal desc9a ap|mantissa,4 desc9ls ap|dec_temp,11 mvn (pr),(pr) better float it right away desc9ls ap|dec_temp,11 desc9fl ap|dec_temp,12 lda ap|exponent ars 36-8 sba 27,dl sta ap|exponent save sign tpl 2,ic neg 0 g0001: cmpa 64,dl too big to shift? tmi g0002 no, go ahead sba 64,dl yes, do 64 powers sperately szn ap|exponent tmi g0003 mp2d (),(pr),round desc9ns two_to_the_64,20,0 desc9fl ap|dec_temp,12 tra g0001 g0003: dv2d (),(pr),round desc9ns two_to_the_64,20,0 desc9fl ap|dec_temp,12 tra g0001 g0002: eax1 0,al lda 0,dl ldq 1,dl lls 0,x1 staq ap|dbl_temp btd (pr),(pr) desc9a ap|dbl_temp,8 desc4ns ap|dec_exp,40 clobber 5 words, 3 of which are dec_exp, 2 dbl_temp mvn (pr),(pr),round desc4ns ap|dec_exp,40 desc9fl ap|dec_exp,12 szn ap|exponent tmi neg_exponent pos_exponent: mp2d (pr),(pr),round desc9fl ap|dec_exp,12 desc9fl ap|dec_temp,12 tra got_dec_num neg_exponent: dv2d (pr),(pr),round desc9fl ap|dec_exp,12 desc9fl ap|dec_temp,12 got_dec_num: """ Now round to 8 digits and decide whether it needs E format or will fit in F format mvn (pr),(pr),round desc9fl ap|dec_temp,12 desc9fl ap|dec_temp,10 " scan out leading zeroes, if any tct (pr),() desc9a ap|dec_temp(1),8 arg zero_table arg ap|dbl_temp lda ap|dbl_temp ana -1,dl ttf 2,ic lda 7,dl if all zero, only flush first 7 zeroes sta ap|dbl_temp ldq 8,dl sbq ap|dbl_temp mlr (pr,al,rl),(pr),fill(060) desc9a ap|dec_temp(1),ql desc9a ap|dec_temp(1),8 lprpbp ap|bufp set up to emit stuff eax7 0 offset in varying string of next char szn ap|mantissa tpl it_is_positive mlr (),(pr,x7) put out minus sign desc9a minus_sign,1 desc9a bp|varying_string_chars,1 eax7 1,x7 it_is_positive: lda ap|dec_temp+2 get decimal exponent als 10 ars 36-8 cmpa =-8 tmi small_exponent cmpa ap|dbl_temp exponent too large? tpnz E_format F_format: ada ap|dbl_temp - number of digits to right of decimal point sta ap|exponent lda 8,dl get number digits to left of point ada ap|exponent tze f3 mlr (pr,rl),(pr,x7,rl) desc9a ap|dec_temp(1),al desc9a bp|varying_string_chars,al eaa 0,al := adx7 a sta ap|dbl_temp adx7 ap|dbl_temp tra f2 f3: mlr (),(pr,x7) no digits to left, supply a zero desc9a a_zero,1 desc9a bp|varying_string_chars,1 eax7 1,x7 f2: mlr (),(pr,x7) desc9a a_dot,1 put decimal point desc9a bp|varying_string_chars,1 eax7 1,x7 lca ap|exponent digits to right of point tze f4 none, supply a zero. eax1 0,al lda 8,dl ada ap|exponent number digits need to be skipped. tctr (pr,al,rl),() truncate trailing zeroes desc9a ap|dec_temp(1),x1 arg zero_table arg ap|dbl_temp lxl2 ap|dbl_temp ttf 2,ic eax2 -1,x1 leave at least one zero stx2 ap|dbl_temp x2 = number tr z's to suppress sbx1 ap|dbl_temp mlr (pr,al,rl),(pr,x7,rl) desc9a ap|dec_temp(1),x1 desc9a bp|varying_string_chars,x1 stx1 ap|dbl_temp adx7 ap|dbl_temp = adx7 x1 tra f5 f4: mlr (),(pr,x7) desc9a a_zero,1 desc9a bp|varying_string_chars,1 eax7 1,x7 f5: done_update_string_length: stz bp|varying_string_length sxl7 bp|varying_string_length short_return small_exponent: " probably has to go in E format, but could use F format if trailing zeroes tctr (pr),() desc9a ap|dec_temp(2),7 arg zero_table arg ap|dbl_temp+1 sta ap|exponent present exponent ada 8,dl - number of leading zroes must have eax2 0 stx2 ap|dbl_temp+1 := number leading zeroes can get asa ap|dbl_temp+1 set indicators from sum then throw away. tmi E_format_after_all need more than can have " we can use F format just by putting in some leading zeroes instead of trailing zeroes eax2 8,al := number of non-lz characters mrl (pr,rl),(pr),fill(060) insert leading zeroes desc9a ap|dec_temp(1),x2 desc9a ap|dec_temp(1),8 neg 0 ada ap|exponent offset exponent by amount of shift tra F_format E_format_after_all: lda ap|exponent E_format: " a contains decimal exponent. ap|dbl_temp contains count of leading zeroes sba ap|dbl_temp correct decimal exponent from lz suppr ada 7,dl allow for decimal point being after first digit. " a now has the exponent we want to print after the number sta ap|exponent tctr (pr),() desc9a ap|dec_temp(1),8 arg zero_table arg ap|dbl_temp lda ap|dbl_temp ana -1,dl ttf 2,ic lda 7,dl if all zero, only use 7 zeroes. mlr (pr),(pr,x7),fill(056) move first digit and decimal point out desc9a ap|dec_temp(1),1 desc9a bp|varying_string_chars,2 eax7 2,x7 neg 0 put number of trailing non-zeroes in au eaa 7,al tze e2 mlr (pr,rl),(pr,x7,rl) desc9a ap|dec_temp(2),au desc9a bp|varying_string_chars,au sta ap|dbl_temp adx7 ap|dbl_temp tra e3 e2: mlr (),(pr,x7) desc9a a_zero,1 desc9a bp|varying_string_chars,1 eax7 1,x7 e3: """ Now put out the exponent. eax2 0 szn ap|exponent tpl 2,ic eax2 2 mlr (x2),(pr,x7) desc9a e_plus_e_minus,2 desc9a bp|varying_string_chars,2 eax7 2,x7 btd (pr),(pr,x7) desc9a ap|exponent,4 desc9ns bp|varying_string_chars,2 2 digits of exponent. eax7 2,x7 tra done_update_string_length special_case_zero: lprpbp ap|bufp mlr (),(pr) desc9a zero_point_zero,3 desc9a bp|varying_string_chars,3 ldq 3,dl stq bp|varying_string_length short_return end  lisp_gc_alm_.alm 07/06/83 0937.8r w 06/29/83 1542.7 153720 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " " lisp_gc_alm_: ALM portion of lisp garbage collector " Its history is unknown by the current maintainers. " tempd args(2) tempd save_pr2 tempd array_data_ptr_ptr tempd new_seg_ptr tempd vector_ret tempd cur_atom tempd cur_bucket_cell tempd old_nil temp vector_left temp cur_vec_entry temp dope_vec_size temp mark_size temp copy_size temp vector_thread temp gctwa_flag temp gctwa_thread temp gctwa_final include lisp_iochan include lisp_object_types even noargs: zero 0,4 zero 0,0 onearg: zero 2,4 zero 0,0 nullptr: its -1,1 entry collect collect: push lda pr0|2,* " test for gctwa mode. sta gctwa_flag ldaq |[nil] staq old_nil " copy for later use epp5 |[cur_seg],* spri5 pr0|4,* " return value is list of old segment. epp5 nullptr,* tsx5 get_initial_segment " this entry skips nop epp7 =0 sprp7 vector_thread sprp7 gctwa_thread sprp7 gctwa_final lda |[number_gc_ptrs] neg 0 sta vector_left epp1 |[garbage_collected_ptrs] stcd vector_ret tra vector_loop epp1 |[stack_ptr],* eaa pr1|0 arl 18+1 "divide by 2 neg 0 sta vector_left epbp1 pr1|0 " start at base of stack stcd vector_ret tra vector_loop handle_vectors_encountered: " this is now in vector_ret. lprp0 vector_thread szn pr0|0 " end of vector thread is a zero word. tze gctwa_phs1 lda pr0|1 neg sta vector_left lda pr0|2 sta vector_thread lprp1 pr0|0 " stcd vector_ret " tra vector_loop " tra handle_vectors_encountered vector_loop: sprp1 cur_vec_entry "pr1 points to current slot in vector to ahndle. tsx4 copylist lprp1 cur_vec_entry epp1 pr1|2 " move to next entry aos vector_left tmi vector_loop rtcd vector_ret gctwa_phs1: " see if anything is on gctwa thread, " process first element, then go back to " handle any vectors encountered. " this phase just collects all worthy atoms -- " those that have a value or non-nil plist. lprp1 gctwa_thread szn pr1|0 " test for empty thread tze gctwa_phs2 " if no elements on list, handle rest of gctwa. lprp0 pr1|0 " get pointer to obarray. lda pr1|1 " and number of elements in it (buckets) neg sta vector_left ldq pr1|2 " move down gctwa_thread stq gctwa_thread ldq gctwa_final " thread block onto phase 2 thread stq pr1|2 sprp1 gctwa_final ph1_vec_loop: " loop over all buckets. sprp0 cur_vec_entry epp1 pr0|0,* " get first bucket ptr. ph1_lst_loop: " loop over list, until a cell already seen is encountered. ldaq pr1|0 " get car of first cell. tmi ph1_next_bucket staq cur_atom " if not marked, must be atom (maybe worthwhile) ldaq pr1|2 " get ptr to next cell staq cur_bucket_cell epp0 cur_atom,* " get ptr to atom ldaq pr0|0 " and test its car. tmi ph1_next_atom " already seen and marked, tpnz worthy_atom " this is a worthy atom because it has a value. ldaq pr0|2 " load plist ptr cmpaq old_nil " nil should have been collected already! tze ph1_next_atom worthy_atom: epp1 cur_atom " collect the atom. We know it has not already been seen. tsx4 cplistlp " SO, we call past the already_seen check. ph1_next_atom: epp1 cur_bucket_cell,* " get ptr to next bucket cell. tra ph1_lst_loop ph1_next_bucket: lprp0 cur_vec_entry epp0 pr0|2 " move to next bucket aos vector_left tmi ph1_vec_loop tra handle_vectors_encountered " may have found new vectors or obarrays to collect. gctwa_phs2: lprp1 gctwa_final szn pr1|0 tze scan_maknum lprp0 pr1|0 " get next element. lda pr1|1 neg sta vector_left ldq pr1|2 stq gctwa_final " thread off list. ph2_vec_loop: epp3 pr0|0 " keep ptr to place to patch in next bucket cell epp1 pr0|0,* " get ptr to first cell in bucket. ph2_lst_loop: ldaq pr1|0 " check for end (a marked cell) tmi ph2_end_list ldaq pr1|0,* " load car of atom to test if marked. tpl ph2_worthless " if not seen yet, worthless. era =o400000,du " clear mark bit, to get new location ph2_make_cell: epp2 pr5|2,ad " allocate a cons cell to append to bucket ttf ph2_made_cell tsx5 tally_ran_out " handle tally runout tra ph2_made_cell tra ph2_make_cell ph2_made_cell: staq pr2|0 " store worthy atom in car of cell spri2 pr3|0 " patch new cell in at end of list epp3 pr2|2 " and new place to patch is cdr of new cell. ph2_worthless: epp1 pr1|2,* " get ptr to next cell tra ph2_lst_loop ph2_end_list: era =o400000,du " turn off mark bit to get ptr to tail of bucket list staq pr3|0 " patch it into end of new list. epp0 pr0|2 " move to next bucket aos vector_left tmi ph2_vec_loop tra gctwa_phs2 " and go handle next obarray scan_maknum: epp1 |[maknum_table_ptr],* ldq |[maknum_mask] adq 1,dl tze retrn stz |[maknum_left] lls 36 divide by 8 and shift to negate arl 3 neg sta vector_left " number of entries in maknum hash table. maknum_scan_loop: ldq pr1|0 " type is in low-order 9 bits. tze next_entry canq (Fixed+Float)/64,dl tnz ok_entry lprp0 pr1|1 canq (Subr+File)/64,dl " check for subrs arrays and files. tnz ck_saf_maknum_entry ldaq pr0|0 " load word with mark bit. tpl not_ok_entry " entry not otherwise protected. cana =o200000,du " for bignums, have to check second bit, tnz not_ok_entry " which should be off for ptrs, but may be on in negative bignums. era =o400000,du " turn off mark bit. sta pr1|1 " store new address (segno part) qrl 18 stbq pr1|1,14 " and word part in lower two bytes. ok_entry:aos |[maknum_left] tra next_entry ck_saf_maknum_entry: canq File/64,dl tnz file_maknum_entry canq Array/64,dl tnz array_maknum_entry lxl0 pr0|1 " check array type. cmpx0 =o700004,du " should be tsx0 ,ic if compiled subr. tnz ok_entry " if not compiled, ok to keep in maknum table ldx0 pr0|1 " otherwise check to see if already seen epp0 pr0|-2,x0 " get subr header ldx0 pr0|7 " get gc_mark halfword test_maknum_gc_mark: canx0 |[gc_mark_bits] tnz ok_entry tra not_ok_entry array_maknum_entry: lxl0 pr0|0 " load gc_mark_ bits tra test_maknum_gc_mark file_maknum_entry: ldx0 pr0|iochan.flags canx0 iochan.gc_mark,du tnz ok_entry tra not_ok_entry not_ok_entry: stz pr1|0 " clear type and uid word of maknum table entry next_entry: epp1 pr1|2 aos vector_left tmi maknum_scan_loop done_maknum_scan: lda =o400000,du sta |[garbage_collect_inhibit] epp0 noargs epbp7 pr6|0 " find stack base. short_call |[rehash_maknum] stz |[garbage_collect_inhibit] retrn: epbp7 pr6|0 " make return know where stack base is. return already_seen: " called with pr1 pointing at object. " call is tsx7. routine returns to next " instruction, having patched doubleword " at pr1 if object has been moved already. " if an Atsym or Cons, and not yet moved, " then routine skips on return. ldaq pr1|0 " load object to test for 0 tze 0,x7 " (uninitialized atsym or stack entry) ana =o060077,dl " mask out modifier "exit on non-gc'able strings, too. cmpa =o43,dl " and check for its. tnz 0,x7 " must be number or error. lda pr1|0 " load type field again. cana Atomic-Atsym,dl " see if atomic. (atsym is treated like cons) tnz seen_atoms test_cons: ldaq pr1|0,* " load car of cons. tpl 1,x7 " mark bit not set, so not seen yet. unmark_return: era =o400000,du " clear mark bit. staq pr1|0 " store new location in argument. tra 0,x7 " return as already seen. seen_atoms: cana Subr,dl tnz test_subr cana File,dl tnz test_file cana Bignum,dl tnz test_bignum cana String,dl tnz test_string "ERROR IF GET HERE. tra 0,x7 test_string: ldaq pr1|0,* tmi unmark_return lrl 36 adq 3,dl " extra cells of 4 words (16 bytes to allocate) qrl 4 tsx6 allocate_cells spri2 save_pr2 epp2 pr1|0,* ldq pr2|0 "get length. adq 4,dl mlr (pr,rl),(pr,rl) desc9a pr2|0,ql desc9a pr0|0,ql spri0 pr1|0 " now store new address back. ldaq pr1|0 " and set type ora String,dl staq pr1|0 ora =o400000,du " and set mark bit. staq pr2|0 epp2 save_pr2,* " get back pr2 tra 0,x7 test_bignum: " a bignum is marked by having the mark bit on, and the second " bit off (normally the two high-order bits are on or off together). ldaq pr1|0,* " load first double-word tpl unseen_bignum cana =o200000,du " test second bit. tze unmark_return unseen_bignum: lrl 36 anq -1,dl " mask out length. qrl 2 " divide by 4 (alloc multiple of 4) tsx6 allocate_cells spri2 save_pr2 epp2 pr1|0,* ldq pr2|0 anq -1,dl qls 2 adq 4,dl mlr (pr,rl),(pr,rl) desc9a pr2|0,ql desc9a pr0|0,ql spri0 pr1|0 ldaq pr1|0 ora Bignum,dl staq pr1|0 ora =o400000,du staq pr2|0 epp2 save_pr2,* tra 0,x7 test_file: epp0 pr1|0,* get address of file block. lda pr0|iochan.flags cana iochan.gc_mark,du tnz 0,x7 " return if marked already. ora iochan.gc_mark,du sta pr0|iochan.flags epp0 pr0|iochan.function spri2 save_pr2 allocate_file_thread_block: epp2 pr5|2,ad ttf file_thread_block_made tsx5 tally_ran_out tra file_thread_block_made tra allocate_file_thread_block file_thread_block_made: sprp0 pr2|0 ldq 2,dl stq pr2|1 ldq vector_thread stq pr2|2 sprp2 vector_thread epp2 save_pr2,* tra 0,x7 test_subr: epp0 pr1|0,* " get what subr object points at. canq 1,du " fix odd address, which arises in subr links to subrs and arrays. tze 2,ic epp0 pr0|-1 cana Array,dl " screen out arrays. tnz test_array lxl0 pr0|1 " load 2nd word of subr entry. cmpx0 =o700004,du " tsx0 ..,ic tnz 0,x7 " if not this value, then nothing to do. ldx0 pr0|1 " to get to header. epp0 pr0|-1,x0 ldx0 pr0|7 " gc mark. canx0 |[gc_mark_bits] tnz 0,x7 " THREAD SUBR ONTO VECTOR THREAD " AND MARK. ldx0 |[gc_mark_bits] stx0 pr0|7 spri2 save_pr2 retry_subr_block_thread: epp2 pr5|2,ad ttf subr_thread_block_made tsx5 tally_ran_out tra subr_thread_block_made tra retry_subr_block_thread subr_thread_block_made: ldq vector_thread stq pr2|2 lxl0 pr0|7 sxl0 pr2|1 epp0 pr0|8 sprp0 pr2|0 sprp2 vector_thread epp2 save_pr2,* tra 0,x7 test_array: lxl0 pr0|0 "gc mark. canx0 |[gc_mark_bits] tnz 0,x7 " NOW COPY ARRAY BODY, PYT ARRAY ON LIST, AND MARK. ldx0 |[gc_mark_bits] sxl0 pr0|0 "mark array. ldx0 pr0|7 " get type. tra array_handlers,x0 array_handlers: tra S_expr_array tra Un_gc_array tra number_array tra number_array tra readtable_array tra obarray_array tra 0,x7 " dead array, nothing to do. compute_size: lxl2 pr0|7 " offset to bounds array. eaa 0,x2 " get size of dope vector in words. neg arl 18 sta dope_vec_size spri2 save_pr2 epp2 pr0|2 " get ptr to array_data_ptr spri2 array_data_ptr_ptr epp2 pr2|0,* ldq 1,dl csizelp: epp2 pr2|-2 mpy pr2|0 eax2 2,x2 tmi csizelp tra 0,x6 number_array: lxl2 pr0|7 Check for external array tze 0,7 Leave alone if so. tsx6 compute_size adq dope_vec_size stq copy_size sbq 1,dl " to get number of additional blocks to allocate. arl 2 " divide by 4. tsx6 allocate_cells ldq copy_size qls 2 " 4 bytes per word. mlr (pr,rl),(pr,rl) desc9a pr2|0,ql desc9a pr0|0,ql ldq dope_vec_size epp0 pr0|0,ql spri0 array_data_ptr_ptr,* epp2 save_pr2,* tra 0,x7 readtable_array: spri2 save_pr2 epp2 pr0|2,* epp2 pr2|-2 epp0 pr0|2 spri0 array_data_ptr_ptr ldq 72,dl " readtable size in 4 word blocks - 1 tsx6 allocate_cells ldq 73*16,dl " number of bytes to move. mlr (pr,rl),(pr,rl) desc9a pr2|0,ql desc9a pr0|0,ql epp0 pr0|2 " offset of data part spri0 array_data_ptr_ptr,* sprp0 pr2|0 " thread of gc'able vectors. ldq 9,dl " number of markable-from words. stq pr2|1 ldq vector_thread stq pr2|2 " thread in to vector list sprp2 vector_thread epp2 save_pr2,* tra 0,x7 copy_array: " called with tsx3. tsx6 compute_size stq mark_size qls 1 adq dope_vec_size stq copy_size sbq 1,dl qrl 2 " q now has 1 less than number of 4word blocks. tsx6 allocate_cells ldq copy_size qls 2 mlr (pr,rl),(pr,rl) desc9a pr2|0,ql desc9a pr0|0,ql ldq dope_vec_size epp0 pr0|0,ql spri0 array_data_ptr_ptr,* tra 0,x3 obarray_array: szn gctwa_flag tze S_expr_array " if not doing gctwa, treat as ordinary array tsx3 copy_array " now thread hash table part onto gctwa_thread, and single char atoms " on vector_thread sprp0 pr2|0 ldq 511,dl stq pr2|1 ldq gctwa_thread stq pr2|2 sprp2 gctwa_thread epp0 pr0|511*2 epp2 pr2|3 " gctwa list cell uses 3 words, get vector list cell sprp0 pr2|0 " store ptr to singl char atom table. ldq 128,dl " size of single char atom table stq pr2|1 ldq vector_thread stq pr2|2 sprp2 vector_thread epp2 save_pr2,* tra 0,x7 Un_gc_array: S_expr_array: tsx3 copy_array sprp0 pr2|0 ldq mark_size stq pr2|1 ldq vector_thread stq pr2|2 sprp2 vector_thread epp2 save_pr2,* tra 0,x7 " copylist is called by a tsx4, with pr1 pointing at a double-word containing " some lisp object. " copylist implements a modified version of Douglas Clark's linearizing " garbage collection algorithm. " Atomic symbols are treated as list cells for this algorithm. " Other types, such as arrays, files, subr blocks, etc. are copied " into the new segments, marked, and threaded onto a list called " "vector thread". The lisp objects they contain are not " processed by copylist. copylist: tsx7 already_seen tra 0,x4 cplistlp: tsx7 copycell epp1 pr3|2 "check cdr of currently copied cell. tsx7 already_seen tra cdr_already_seen epp1 pr3|0 tsx7 already_seen tra car_seen_but_not_cdr " both car and cdr not seen yet. so thread old cell onto " continuation list. spri7 pr2|2 epp7 pr2|0 car_seen_but_not_cdr: epp1 pr3|2 " proceed with cdr. tra cplistlp cdr_already_seen: epp1 pr3|0 tsx7 already_seen "check car. tra ck_continuation " both car and cdr have been seen, so stop with current list. " epp1 pr3|0 not needed because done just above. tra cplistlp ck_continuation: szn pr7|0 " pr7 starts out pointing to a zero word. tze 0,x4 " NOTE: following depends on hardware not looking at high order bits " in indirecting through a double-word. epp1 pr7|0,* epp7 pr7|2,* " advance through continuation list. tsx7 test_cons " we know it is a cons or atsym here. tra ck_continuation tra cplistlp copycell: " Input: pr1 -> cons or atsym ptr to copy. " Output: pr2 = old address from object. " pr3 = new object address. " new object's car and cdr have been copied from old. " pr1 -> copied address (new form of input object). " old object's car points to new object, and mark bit (sign bit) " is turned on. epp2 pr1|0,* lxl6 pr1|0 "check type (cons or atsym). canx6 Atsym,du tnz copyatsym copycons: epp3 pr5|2,ad " allocate a cons cell. ttn tally_out_on_cons consalloc:spri3 pr1|0 ldaq pr2|0 staq pr3|0 ldaq pr2|2 staq pr3|2 ldaq pr1|0 "store new address with mark bit on. ora =o400000,du staq pr2|0 " in old cell. tra 0,x7 copyatsym: ldq pr2|4 " get atsym pname length. adq 19,dl " 15+4 (number of bytes to allocate in addition to cons part) qrl 4 "16 bytes per 4 words. epp3 pr5|2,ad ttn tally_out_on_atsym atsymalloc: eax0 pr5|2,ad " NOTE: all atsyms require at least one loop. ttn tally_out_on_atsym_lp atsymalloc_lp: sbq 1,dl tpnz atsymalloc ldq pr2|4 " determine size to copy. adq 20,dl " 20 bytes of stuff precede name. mlr (pr,rl),(pr,rl) desc9a pr2|0,ql desc9a pr3|0,ql spri3 pr1|0 ldaq pr1|0 ora Atsym,dl staq pr1|0 ora =o400000,du staq pr2|0 tra 0,x7 allocate_cells: "called with tsx6, ql contains number cells -1, returns with pr0 " pointing at allocated block. eax0 0,ql epp0 pr5|2,ad ttn tally_out_on_allocate alcellp: eax0 -1,x0 tmi 0,x6 eax1 pr5|2,ad ttf alcellp tally_out_on_allocate: tsx5 tally_ran_out tra alcellp tra allocate_cells tally_out_on_cons: tsx5 tally_ran_out tra consalloc tra copycons tally_out_on_atsym: tsx5 tally_ran_out tra atsymalloc tra copyatsym tally_out_on_atsym_lp: tsx5 tally_ran_out tra atsymalloc_lp tra copyatsym tally_ran_out: " skips if a new segment had to be made. aos |[seg_blk_cntr] tmi 0,x5 get_initial_segment: spri pr6|0 sreg pr6|32 epp0 new_seg_ptr spri0 args+2 ldaq onearg staq args epp0 args epbp7 pr6|0 short_call |[get_lists] lpri pr6|0 spri5 new_seg_ptr,* epp5 new_seg_ptr,* spri5 |[cur_seg] " store away new allocation segment addresses. spri5 |[consptr] lda =o2000053 " make consptr point up 2, and add in ad modifier. sta |[consptr]+1 lda =o4740004 sta pr5|2 lca 16,dl sta |[seg_blk_cntr] lreg pr6|32 tra 1,x5 end  lisp_old_io_.lisp 07/06/83 0937.8r w 06/29/83 1542.7 31518 ;;; ************************************************************** ;;; * * ;;; * Copyright, (C) Massachusetts Institute of Technology, 1973 * ;;; * * ;;; ************************************************************** ;;; lisp_old_io_.lisp ;;; This module provides the lisp functions uread, uwrite, ufile, ukill, and crunit ;;; It is written in terms of the new I/O system. ;;; coded 27-MAR-73 by DAM ;;; fasload added 14 Nov 73 by DAM ;;; Modified 17 Sep 74 by DAM to not use fremob, add uprobe, uappend, uclose functions (declare (system-file t)) (declare (special old-io-defaults uread uwrite infile outfiles)) (setq uread nil uwrite nil old-io-defaults nil) (defun uread fexpr (x) (setq uread (openi (fetch-uread-names x))) (setq old-io-defaults (namelist uread)) (eoffn uread (function (lambda (x y) x (setq uread nil) y))) ;provide for clearing of (status uread) on EOF (setq infile uread) ;make ^Q cause input from here (status crunit)) (defun fetch-uread-names (x) (mergef (cond ((null x) '(*.*)) ((or (null (cdr x)) (null (cddr x))) (cons '* x)) ((list (cadddr x) (car x) (cadr x))) ) (or old-io-defaults (namelist nil)) )) (defun fasload fexpr (x) (setq x (fetch-uread-names x)) (and (eq (car (last x)) 'fasl) ;drop fasl suffix (setq x (nreverse (cdr (reverse x)))) ) (load x)) (defun uwrite fexpr (x) (and uwrite (setq outfiles (delq uwrite outfiles 1))) (or x (setq x (status crunit))) (setq uwrite (openo (mergef (list (cadr x) '!lisp 'output) ;temp file name !lisp.output until ufiled (or old-io-defaults (namelist nil)) ))) (apply 'crunit x) ;kludgey way to set the defaults (setq outfiles (cons uwrite outfiles)) ;make this where output goes (status crunit)) (defun crunit fexpr (x) (or x (setq x (status crunit))) (setq old-io-defaults (mergef (cons (cadr x) '*) (or old-io-defaults (namelist nil)))) x) (defun ufile fexpr (x) (setq x (cond (x (list (car x) (cadr x))) (old-io-defaults (cdr old-io-defaults)) )) (setq old-io-defaults (mergef (cons '* x) (or (namelist uwrite) old-io-defaults (namelist nil)) )) (errset (deletef old-io-defaults) nil) ;delete old copy if there (rename uwrite old-io-defaults) ;and rename to new copy (close uwrite) (setq uwrite nil) (status crunit)) (defun ukill fexpr (x) (setq x (cond ((null x) '(* . *)) ((null (cddr x)) (cons '* x)) ((list (cadddr x) (car x) (cadr x))) )) (setq old-io-defaults (setq x (mergef x (or old-io-defaults (namelist nil)) ))) (setq x (deletef x)) (list (cadr x) (caddr x))) (defun uappend fexpr (x) (setq x (fetch-uread-names x)) (and uwrite (setq outfiles (delq uwrite outfiles 1))) (setq old-io-defaults x) (setq x (rename x '(* !lisp !append))) (setq uwrite (opena x)) (setq outfiles (cons uwrite outfiles)) (status crunit)) (defun uprobe fexpr (x) (setq old-io-defaults (mergef (setq x (fetch-uread-names x)) (or old-io-defaults (namelist nil)))) (not (not (allfiles x)))) (defun uclose nil (and uread (close uread)) (setq uread nil)) ;;;remob old-io_defaults because user must not play with it, and ;;;the compiler generated function !g1 that we happen to know is generated. (remob 'old-io-defaults)(remob '!g1)(remob 'fetch-uread-names) ;;;end  lisp_oprs_.alm 11/05/86 1612.7r w 11/04/86 1039.2 382023 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " LISP Operators " these operators provide run time support for compiled lisp functions " they are called by tspbp through pointers in the lisp stack header " Written by D A Moon 21 Aug 72 " modified 15 Oct 72 by DAM for some evidently secret reason " modified 74.05.17 by DAM for "new" arrays and to speed up some oprs by using more pointer regs " modified 74.12.06 by DAM for external arrays macro enter_pl1_code epplp ab|system_lp,* stx7 lisp_static_vars_$unmkd_ptr+1 spriap lisp_static_vars_$stack_ptr stc1 ab|in_pl1_code ife &1,push push &2 eppbp lisp_subr_tv_$..lisp.. spribp sp|stack_frame.entry_ptr ifend &end macro exit_pl1_code ife &1,pop eppbp sp|0 inhibit on spribp sb|stack_header.stack_end_ptr eppsp sp|stack_frame.prev_sp,* inhibit off ifend epbpab lisp_static_vars_$unmkd_ptr,* eppap lisp_static_vars_$stack_ptr,* ldx7 lisp_static_vars_$unmkd_ptr+1 stz ab|in_pl1_code &end equ his_lp,-4 where on unmkd pdl caller's lp kept equ his_bp,-2 where on unmkd pdl caller's " bp (= return addr) is kept equ form,-8 dcl from lisp_ equ fcn,-6 equ argl,-4 equ plist,-2 include lisp_unmkd_pdl include lisp_stack_seg include lisp_array_fmt include lisp_name_codes include lisp_object_types include stack_header include stack_frame " routine to set up operator pointers in the stack header " called during initialization of the lisp environment, " every time the 'lisp' command is issued. entry init init: getlp epbpab |[unmkd_ptr],* -> stack header ldaq gensym_init-*,ic staq ab|gensym_data " initialize data for gensym function. ldaq fault_tag_3_number_1-*,ic kill old array store pointer staq ab|array_pointer eppbp array_reference_op-*,ic spribp ab|array_operator eppbp dead_array_reference_op-*,ic spribp ab|dead_array_operator eppbp array_link_snap_op-*,ic spribp ab|array_link_snap_opr eppbp store_op-*,ic spribp ab|store_operator eppbp floating_store_op-*,ic spribp ab|floating_store_operator ldaq fault_tag_3_number_2-*,ic staq ab|array_info_for_store eppbp bind-*,ic spribp ab|bind_op eppbp unbind-*,ic spribp ab|unbind_op eppbp errset1-*,ic spribp ab|errset1_op eppbp errset2-*,ic spribp ab|errset2_op eppbp unerrset-*,ic spribp ab|unerrset_op eppbp call-*,ic spribp ab|call_op eppbp catch1-*,ic spribp ab|catch1_op eppbp catch2-*,ic spribp ab|catch2_op eppbp uncatch-*,ic spribp ab|uncatch_op eppbp iogbind-*,ic spribp ab|iogbind_op eppbp obscene_go_tag-*,ic spribp ab|unseen_go_tag_op eppbp throw1-*,ic spribp ab|throw1_op eppbp throw2-*,ic spribp ab|throw2_op eppbp signp-*,ic spribp ab|signp_op eppbp return-*,ic spribp ab|return_op eppbp err-*,ic spribp ab|err_op sprilp ab|system_lp set up for later use. eppbp pl1_interfacer-*,ic spribp ab|pl1_interface eppbp pl1_lsubr_interfacer-*,ic spribp ab|pl1_lsubr_interface eppbp |[cons_opr] spribp ab|cons_op eppbp |[ncons_opr] spribp ab|ncons_op eppbp |[xcons_opr] spribp ab|xcons_op eppbp |[begin_list_opr] spribp ab|begin_list_op eppbp |[append_list_opr] spribp ab|append_list_op eppbp |[terminate_list_opr] spribp ab|terminate_list_op eppbp compare spribp ab|compare_op eppbp link_operator spribp ab|link_opr lda fixnum_type,dl ldq flonum_type,dl staq ab|type_fields eppbp |[cons_string] spribp ab|cons_string_op eppbp pl1_call_operator spribp ab|pl1_call_op eppbp create_string_descriptor spribp ab|create_string_desc_op eppbp create_varying_string spribp ab|create_varying_string_op eppbp create_array_descriptor spribp ab|create_array_desc_op eppbp unwind_protect-*,ic spribp ab|unwp1_op spribp ab|unwp2_op eppbp unwind_protect_end spribp ab|ununwp_op eppbp irest_return spribp ab|irest_return_op eppbp pl1_call_nopop spribp ab|pl1_call_nopop_op eppbp rcv_char_star spribp ab|rcv_char_star_op short_return patch_instruction: tra ab|call_op,* even gensym_init: aci "g" dec 0 """ Operators having to do with arrays. even fault_tag_3_number_1: arg 1,f3 arg 0 fault_tag_3_number_2: arg 2,f3 arg 0 array_reference_op: epplb ab|system_lp,* check for *rset t mode link star_rset,|[star_rset],* ldaq lb|star_rset,* epplb bb|array_data_ptr-2,* -> array_data block (dope vector) lxl4 bb|array_info.2ndims-2 number of subscripts * -2 tze external_array_reference-*,ic tra if ext array flag set cmpaq ab|nil tnz array_ref_with_full_checking-*,ic array_ref_without_checking: eaq 0 compute offset in q adq ap|1,x4 add in a subscript mpy lb|1,x4 multiply by multiplier eax4 2,x4 tnz -3,ic lxl4 bb|array_info.2ndims-2 pop subscripts off stack eppap ap|0,x4 .. spribb ab|array_info_for_store save data for store stq ab|array_offset_for_store tra bb|array_load_sequence-2 use code in array to load and return array_ref_with_full_checking: array_checking_loop: ldaq ap|0,x4 get a subscript cmpa fixnum_type,dl fixnum? tnz bad_subscript-*,ic no, barf cmpq lb|0,x4 compare against bounds trc bad_subscript-*,ic out of bounds or negative eax4 2,x4 tnz array_checking_loop-*,ic lxl4 bb|array_info.2ndims-2 number of subscripts * -2 tra array_ref_without_checking-*,ic reference is OK, proceed. external_array_reference: cmpaq ab|nil tze ext_array_ref_no_check-*,ic ldaq ap|-2 check bound cmpa fixnum_type,dl tnz bad_subscript-*,ic cmpq bb|array_load_sequence-2 which is stored in kludgey way trc bad_subscript-*,ic out of bounds or negative ext_array_ref_no_check: ldq ap|-1 get subscript eppap ap|-2 pop subscript spribb ab|array_info_for_store save data for store stq ab|array_offset_for_store lda fixnum_type,dl ext arrays are always fixnum tra bb|array_load_sequence-2+1 use code in array to load and return bad_subscript: lxl1 |[bad_array_subscript] better not need lp array_reference_err: eppap ap|4 get set to push args to lisp_error_ staq ap|-2 the bad subscript eppbb bb|-2 the array pointer spribb sb|stack_header.stack_end_ptr,* ldaq sb|stack_header.stack_end_ptr,* ora Array+35,dl turn on array type bit and its tag staq ap|-4 ldaq ap|-2 make list of array pointer and subscript tspbp ab|ncons_op,* spribb ap|-2 ldaq ap|-4 tspbp ab|cons_op,* ldaq ap|-2 staq bb|2 eppap ap|-2 spribb ap|-2 eaa 0,x1 get error code. arl 18 lcq -fn_store,dl if fn code requuired, was store tsx0 Lisp_Error-*,ic go signal uncorrectable error. dead_array_reference_op: eppap ap|2 will pass array pointer to lisp_error_ eppbb bb|-2 the array pointer spribb sb|stack_header.stack_end_ptr,* ldaq sb|stack_header.stack_end_ptr,* ora Array+35,dl staq ap|-2 lda |[dead_array_reference] better not need lp ldx1 bb|array_info.type-2 perhaps is really a readtable cmpx1 Readtable_array,du tnz 2,ic lda |[cant_subscript_readtable] better not need lp tsx0 Lisp_Error-*,ic go signal uncorrectable error. """ compiled store comes here. locations in stack header have been set up """ by a previous array reference. value to store is in aq. (or just q if """ compiler knows it to be a fixnum or flonum array) store_op: eppbb ab|array_info_for_store,* -> array_info, fault if bad. lxl1 ab|array_offset_for_store get index value ldx0 bb|array_info.type-2 get array type xec store_table,x0 do store seq. depending on type tra bp|0 and return. aq is unchanged. store_table: staq bb|array_data_ptr-2,*x1 S-expr array staq bb|array_data_ptr-2,*x1 Un-gc array stq bb|array_data_ptr-2,*x1 fixnum array stq bb|array_data_ptr-2,*x1 flonum array tra not_allowed_to_store readtable tra not_allowed_to_store obarray tra store_into_dead_array dead. " operator similar to store_op but value to be stored is in EAQ. " type checking is performed. floating_store_op: eppbb ab|array_info_for_store,* lxl1 ab|array_offset_for_store ldx0 bb|array_info.type-2 xec floating_store_table,x0 tra bp|0 floating_store_table: tra move_EAQ_to_Q_then_store tra move_EAQ_to_Q_then_store tra not_allowed_to_store_f flonum -> fixnum array fstr bb|array_data_ptr-2,*x1 flonum -> flonum array tra not_allowed_to_store_f tra not_allowed_to_store_f tra not_allowed_to_store_f not_allowed_to_store_f: eax7 2,x7 fstr ab|-1,x7 ldq ab|-1,x7 lda flonum_type,dl tra not_allowed_to_store-*,ic move_EAQ_to_Q_then_store: eax7 2,x7 fstr ab|-1,x7 ldq ab|-1,x7 lda flonum_type,dl eax7 -2,x7 staq bb|array_data_ptr-2,*x1 tra bp|0 not_allowed_to_store: store_into_dead_array: lxl1 |[store_not_allowed] better not need lp tra array_reference_err-*,ic """ This operator is used by compiled code to get an array pointer """ from an atomic symbol which is alleged to be the name of an array """ It is called by xec'ing a 4-word block in the comp_subr_block, """ which contains a tspbp to this operator """ and a word in the form vfd 9/type,9/ndims,18/constant """ constant is the offset relative to lp (in the constants area) """ of the atomic symbol which names the array. """ The first word in the block is changed to eppbb *+2,* """ and the last words are changed to point to the array_info block. """ Registers: """ lp = caller's lp """ bp -> calling xec instruction + 1 """ lb = system lp """ bb = clobberable, set on return to -> array_info """ aq and x5 are unchanged. link array_atom,|[array_atom] link no_snapped_links_flag,|[no_snapped_links] array_link_snap_op: epplb ab|system_lp,* eppap ap|2 save aq staq ap|-2 ldx1 bp|-1 -> array_link block (relative to lp) anx1 =o077777,du lxl0 lp|1,x1 offset from lp to symbol naming array eppbb lp|0,x0* -> symbol continue_array_search: ldaq bb|2 cana lisp_ptr.type,dl end? tnz couldnt_snap_array_link-*,ic eppbb bb|2,* next piece of property list ldaq bb|0 cmpaq lb|array_atom,* tnz continue_array_search-*,ic eppbb bb|2,* eppbb bb|0,* array pointer ldx0 lp|1,x1 ndims anx0 =o000777,du cmpx0 bb|array_info.ndims tnz couldnt_snap_array_link-*,ic lda lp|1,x1 get required type arl 27 tze check_for_Sexpr_array-*,ic eax0 0,al cmpx0 bb|array_info.type check against actual type tnz couldnt_snap_array_link-*,ic could_snap_array_link: spribb lp|2,x1 snap the link stz lb|no_snapped_links_flag eaa -1 ansa lp|-6 turn off flags for unlinker eaa 2,x1 ora link_snap_instruction-*,ic sta lp|0,x1 put in eppbb instruction ldaq ap|-2 restore aq eppap ap|-2 tra bp|0 exit. bb has been set. link_snap_instruction: eppbb lp|0,* check_for_Sexpr_array: ldx0 bb|array_info.type szn ok_to_link_table,x0 tnz could_snap_array_link-*,ic couldnt_snap_array_link: lxl0 lp|1,x1 ldaq lp|0,x0 name of array eppap ap|2 staq ap|-2 lda |[not_an_array] better not need lp eaq 0 "function ? wanted an array, not foo" tra Lisp_Error-*,ic ok_to_link_table: vfd 36/1,36/1,36/0,36/0,36/0,36/1,36/0 """ Interpreted store function. similar to store operator """ but makes more checks. segdef store store: eppap ap|4 extract args from arglist (fsubr) eppbb ap|-6,* -> arglist ldaq bb|2,* cadr is 2nd arg staq ap|-2 ldaq bb|0 car is 1st arg staq ap|-4 eax7 8,x7 going to make two calls to eval sprilp ab|his_lp,x7 eax5 -2 stcd ab|his_bp,x7 tra |[eval_] evaluate 2nd arg staq ap|-4 save the value to be stored sprilp ab|his_lp,x7 eax5 -2 stcd ab|his_bp,x7 tra |[eval_] evaluate first arg (array reference) ldaq ap|-2 pick up value to be stored eppap ap|-2 clear the stack eppbb ab|array_info_for_store,* get ptr to array_info block lxl1 ab|array_offset_for_store get subscript ldx0 bb|array_info.type-2 check type of array and of value to store xec store_test,x0 tnz not_allowed_to_store-*,ic type mismatch xec store_table,x0 OK to store, do so. tra return-*,ic store_test: eax2 0 S-expr - can always store eax2 0 Un-gc - can always store cmpa fixnum_type,dl Fixnum cmpa flonum_type,dl Flonum tra not_allowed_to_store Readtable tra not_allowed_to_store Obarray tra store_into_dead_array Dead """ Routine to signal a LISP error Lisp_Error: eax7 8,x7 save bp, lp, bb, lb, x0, and room to push error code. sprpbp ab|-8,x7 sprplp ab|-7,x7 sprpbb ab|-6,x7 sprplb ab|-5,x7 stx0 ab|-4,x7 staq ab|-2,x7 error code, fn code " prepare to call pl1 program enter_pl1_code push eppap null_argl-*,ic pass no args to pl1 error routine. short_call lisp_error_$lisp_error_ exit_pl1_code pop ldx0 ab|-2,x7 restore saved registers lprplb ab|-3,x7 lprpbb ab|-4,x7 lprplp ab|-5,x7 lprpbp ab|-6,x7 eax7 -6,x7 tra 0,x0 return from call to Lisp_Error " two routines which are the operators for pl1 compiled subrs. " These routines generate a standard Multics call, and keep track " of the lisp stacks so that interrupts can be handled correctly. " The calling sequence, which appears in the subr block in the lisp " static storage segment, is: " " eax7 2,x7 " spribp ab|-2,x7 " tspbp ab|pl1_interface_op,* for the appropiate interface.... " its link to routine.... " pl1_lsubr_interfacer: eppap ap|2 get room for saving x5. eaq 0,x5 qrs 18 lda fixnum_type,dl staq ap|-2 pl1_interfacer: eax7 4,x7 get room to save lp sprilp ab|-4,x7 save callers lp epplp bp|0,* get pointer to pl1 entry to call. sprilp ab|-2,x7 and save through the save sequence. enter_pl1_code push eppbp |[unmkd_ptr],* eppap null_argl-*,ic must set up arg list. short_call bp|-2,* call the target fo the call. exit_pl1_code pop epplp ab|-4,x7* eppbp ab|-6,x7* eax7 -6,x7 ldaq ap|-2 eppap ap|-2 tra bp|0 even null_argl:oct 4,0 " link opertor for compiled code link_operator: eax7 8,x7 sprplp ab|-8,x7 stx0 ab|-7,x7 sxl5 ab|-7,x7 eppbp lp|-1 adwpbp bp|0 " get pointer to itp. spribp ab|-6,x7 eppbp ab|-6,x7 spribp ab|-2,x7 ldaq one_arg staq ab|-4,x7 enter_pl1_code push eppap lisp_static_vars_$unmkd_ptr,* eppap ap|-4 short_call lisp_linker_$lisp_linker_ exit_pl1_code pop lprplp ab|-8,x7 ldx0 ab|-7,x7 lxl5 ab|-7,x7 eppbp ab|-6,x7* eax7 -8,x7 tra bp|0,* one_arg: zero 2,4 zero 0,0 " bind operator. " the calling tspbp is followed by a word with 4*number bindings in " left half " Following this is one word for each binding, in the form: " vfd 3/flags, 15/atom_loc, 18/value_loc " where atom_loc is offset from lp of ptr to atom, value_loc is " offset of new value to be given it, flags tells where value_loc " is offset from: 0=ab, 1=ap, 2=lp, 3=addr of this word (bp) " If flags is >3, means one of these special cases: " 4 bind the argatom according to x5 (for compiled lexpr's) " (atom_loc better be 0!!!) " 5 obtain value from x5 (for compiled lexpr's) " 6 same as 1 except take the car of the value " 7 same as 2 except take the car of the value " " NB: offset from ap is from ap after 4*number_bindings " has been added to it. " The marked pdl portion of the binding block is allocated " by this operator, and the unmarked pdl portion " must be allocated here. " this operator destroys the contents of aq and all the index registers " " Usage of index registers in this operator: " " x0 not used " x1 temp. " x2 saves value of ap when operator was called " x3 counts number of bindings to be done " x4 points at current 4-word slot in binding block " x5 not changed, for flags = 4 or 5, should be -2*#args to lsubr " x6 temp " x7 unmarked pdl ptr, as usual " " Pointer Registers " " bp -> control words in caller " lp left as caller's lp " lb system lp " bb temporary link binding_top_plus_1,|[binding_top]+1 link argatom,|[argatom] bind: eax7 2,x7 room for binding block epplb ab|system_lp,* ldx3 bp|0 4*number_bindings lcx4 bp|0 offset of first binding from top of stack eax2 ap|0 save ap in case of flags=4 eppap ap|0,x3 make room for binding block. ldq lb|binding_top_plus_1,* make binding block stq ab|-1,x7 binding_block.back_ptr (clear rev_ptr) stx2 ab|-2,x7 set binding_block.top_block sxl2 ab|-2,x7 set binding_block.bot_block eax1 ab|-2,x7 and thread onto list of binding blocks stx1 lb|binding_top_plus_1,* bind_loop: eppbp bp|1 -> next binding descrip word ldx1 bp|0 get atom to be bound anx1 =o077777,du tze flags4-*,ic not an atom (for flags=4) ldaq lp|0,x1 staq ap|2,x4 ldaq ap|2,x4* staq ap|0,x4 save old value eax4 4,x4 -> next slot in binding block eax1 ap|0,x4 update binding_block.top_block stx1 ab|-2,x7 lxl1 bp|0 get new value to give to atom lda bp|0 use 'flags' as xec vector index arl 15 xec bind_vec,au get new value in aq xec_ret: staq ap|2-4,x4* eax3 -4,x3 count bindings tnz bind_loop-*,ic tra bp|1 all done bind_vec: ldaq ab|0,x1 ldaq ap|0,x1 ldaq lp|0,x1 ldaq bp|0,x1 tra flags4 4 - special case tra flags5 5 - get value from x5 reg. ldaq ap|0,x1* ldaq lp|0,x1* flags5: eaa 0,x5 get -2*nargs neg 0 lrs 19+36 c(q) = nargs lda fixnum_type,dl tra xec_ret-*,ic flags4: eax4 4,x4 adjust x4 for next binding epaq lb|argatom,* -> argatom eaa 0,au clear ring number ora Uncollectable+35,dl type bit and its tag staq ap|2-4,x4 put in binding block ldaq ap|2-4,x4* save old value staq ap|0-4,x4 eax6 ap|0,x4 update binding_block.top_block stx6 ab|-2,x7 eaa 0,x5 -2 * nargs neg 0 ars 1 nargs to au ora Uncollectable,dl special kludge thing argatom is bound to eppbb ap|2-4,x4* -> value cell of argatom sta bb|0 store first word lxl1 bp|0 stack offset due to compiled code stx1 bb|1 build up second word. asx2 bb|1 stack pointer when operator called asx5 bb|1 stack offset to get to arguments tra xec_ret+1-*,ic and return to normal sequence " unbind operator. " unbinds the binding block which must be located at top of unmkd pdl "preserves aq but " changes index registers, decrements x7 by 2, " de-allocates the binding block allocated by bind operator, hence changes ap unbind: eax7 4,x7 save aq + temp. staq ab|-4,x7 epplb ab|system_lp,* lxl1 ab|-6,x7 binding_block.bot_block stx1 ab|-1,x7 save for cmpx1 eax6 0,x1 save base of binding block for eppap below. epbpbb ap|0 baseptr of marked pdl ldx1 ab|-6,x7 binding_block.top_block " now proceed to unbind top down unbind_loop: cmpx1 ab|-1,x7 reached bottom? tze unbind_end-*,ic yes. eax1 -4,x1 no, do next. ldaq bb|0,x1 get old value staq bb|2,x1* put back on atom tra unbind_loop-*,ic and keep it up. unbind_end: ldx1 ab|-5,x7 unthread this binding block stx1 lb|binding_top_plus_1,* eppap bb|0,x6 pop binding block storage off of marked pdl ldaq ab|-4,x7 restore aq eax7 -6,x7 clear save area and binding_block from pdl tra bp|0 & return " errset1 operator. " sets up an errset with no suppression of error messages " destroys contents of x0-x6 and aq. x7 is bumped by 12, " ap is bumped by 2. " *** 22 SEP 72 - DAM -- no longer makes a stack frame, " just saves the rtcd loc in the stack frame, which is destroyed " by the Multics non local go to mechanism. " call is: " tspbp ab|errset1,* " tra eob return here if error occurs " "with nil or value of err in aq " - compiled first arg to errset - " eob: tspbp ab|unerrset,* errset1: eppap ap|2 temp for use if error occurs eax2 0 this is not errset with nil 2nd arg tra errset_com-*,ic " errset2 operator. " sets up an errset with 2nd arg to errset determining " suppression of error messages. destroys contents of aq " and x0-x6, x7 is bumped by 12, ap is unchanged. Call is " same as errset1 except that top of marked pdl " contains evaluated second arg to errset. errset2: ldaq ap|-2 get 2nd arg to errset cmpaq ab|nil if nil, suppress error msgs tnz errset1+1-*,ic not nil, allow msgs ldx2 =o400000,du nil, set x2 to "1"b errset_com: eax7 12,x7 size(frame)+save lp,bp,sp|20 sprilp ab|his_lp,x7 spribp ab|his_bp,x7 save caller's stuff for return epplp ab|system_lp,* ldaq sp|20 save ret addr in stack frame we are sharing staq ab|-6,x7 " set up errset frame on unmarked pdl " above errset frame our caller's lp, bp will be " saved so that error routine can return to him. eax1 ap|0 sxl1 ab|frame.stack_ptr-12,x7 ldx1 |[err_frame]+1 stx1 ab|frame.prev_frame-12,x7 stz ab|frame.dat2-12,x7 set to "1"b by err if eval needed stx2 ab|frame.dat1-12,x7 set suppress-msgs flag eppbp err_return-*,ic spribp ab|frame.ret-12,x7 sprisp ab|frame.ret+2-12,x7 eax1 ab|-12,x7 stx1 |[err_frame]+1 " return to compiled first arg to errset epplp ab|his_lp,x7* eppbp ab|his_bp,x7* tra bp|1 " come here if error occurs, value to return is on top of " marked pdl, frame.dat2 is "1"b if it hasn't been evaled yet (from fcn 'err') err_return: getlp " in pl1 code mode, must get lp from lot. push "stack frame to call out with eppbp |[unmkd_ptr],* push onto unmkd pdl... eppbp bp|2 spribp |[unmkd_ptr] eppap |[err_frame],* eppap ap|12 ... the addr to unwind to spriap bp|-2 which is just above our errset frame eppbp |[stack_ptr],* copy value to be returned down lxl1 ap|frame.stack_ptr-12 ldaq bp|-2 epbpbb bp|0 staq bb|-2,x1 eppap null_argl-*,ic get null arg list for call. short_call |[lisp_unwinder] eppbp |[err_frame],* should we eval the returned value? lxl1 bp|frame.stack_ptr epbpab |[stack_ptr],* eppap ab|0,x1 spriap |[stack_ptr] lxl0 bp|frame.dat2 tze err_ret_0-*,ic eppap null_argl-*,ic get null arg list for call to pl1 entry in eval. short_call |[eval] err_ret_0: " now go from pl1_code mode to lisp_code mode, and " return to error return loc in errset caller, with errset frame still around exit_pl1_code pop ldaq ab|-6,x7 restore ret addr in stack frame staq sp|20 epplp ab|his_lp,x7* eppbp ab|his_bp,x7* ldaq ap|-2 value of the errset tra bp|0 return to caller, who will do an unerrset. " unerrset operator. " this operator removes the errset frame which must be at the top of " the unmarked pdl. It does not disturb the aq or the ap, it " decrements x7 by 12, and the other index registers are destroyed. " doesn't have to restore sp|20 since that is only " destroyed by a non-local goto and our non-local-goto reciever has " already fixed it. link err_frame_plus_1,|[err_frame]+1 unerrset: epplb ab|system_lp,* get lp for this program. ldx1 ab|frame.prev_frame-12,x7 remove err frame from pdl stx1 lb|err_frame_plus_1,* eax7 -12,x7 eppap ap|-2 get rid of value pushed on by caller. tra bp|0 " call operator. " this operator is used to provide call_outs from lisp-compiled " code to external functions. It is called by tspbp lp|link,* " where the doubleword link in the linkage section is: " link: vfd 3/ab, 15/fcn_offset, 1/snap, 1/constant, 1/fsubr, 9/nargs, 6/itb " vfd 18/call_oper, 12/0, 6/20 " where fcn_offset is offset from ap (constant = 0) " or from lp (constant = 1) " snap is 1 if the link is to be changed to point directly " at the function if possible " fsubr is 1 if the top of the pdl contains the unevaluated " list of args, 0 if top of pdl contains spread, evaluated args " nargs is o777 if arg count times -2 is in x5, otherwise is arg count " the remaining fields look like itb ab,call_oper,* " so that the tspbp has the effect of tspbp ab|call_oper,* " this operator destroys all the index registers, it returns " with x7 unchanged, result of function in aq, and the " args or arglist popped off the marked pdl. call: eax7 6,x7 push lp, bp, addr of link sprilp ab|his_lp,x7 spribp ab|his_bp,x7 ldx0 bp|-1 get addr of link anx0 =o077777,du eppbp lp|0,x0 spribp ab|-6,x7 lda bp|0 get the function into aq als 3 spread sign bit (3) into (0-2) ars 3 cana =o200000,dl test constant bit tnz 3,ic ldaq ap|0,au not constant, get from stack tra 2,ic ldaq lp|0,au constant, get from linkage section eppap ap|-form staq ap|form lda bp|0 check for f_type function cana =o100000,dl tnz call_2_f-*,ic epplp ab|system_lp,* " set x5 to number of args if not already so set lda ab|-6,x7* ana =o77700,dl cmpa =o77700,dl tze already_got_x5-*,ic ars 5 neg 0 eax5 0,al already_got_x5: " go to routine in lisp_ to do rest of work tra |[call1] " call with unevaled arg list call_2_f: ldaq ap|form-2 arg list eppap ap|-2 staq ap|argl ldaq ap|fcn staq ap|form epplp ab|system_lp,* tra |[callf] " catch1 operator. " is the compiled form of a catch with one argument " destroys contents of aq and x0-x6, x7 is bumped by 12, " ap is bumped by 2. " call is: " tspbp ab|catch1,* " tra eoc return here if throw occurs " with the value thrown in aq " - compiled first arg to catch - " eoc: tspbp ab|uncatch,* " "result of catch is now in aq " " also saves sp|20 and restores it if it gets destroyed " by unwinder_ catch1: eppap ap|2 make fake catch tag ldaq nultag-*,ic staq ap|-2 " fall into catch2 " catch2 operator. " is compiled form of catch with a second arg, which is the catch tag. " call is same as catch1 except ap is not bumped and top of marked pdl " contains the unevaluated second arg to catch. catch2: eax7 12,x7 sprilp ab|his_lp,x7 spribp ab|his_bp,x7 epplp ab|system_lp,* ldaq sp|20 save ret addr in stack frame we are sharing staq ab|-6,x7 " set up catch frame on unmarked pdl. Above the " catch frame our caller's lp, bp will be saved " so that we can return to him if a throw occurs. eax1 ap|0 -> just above catch label (for throw) sxl1 ab|frame.stack_ptr-12,x7 ldx1 |[catch_frame]+1 stx1 ab|frame.prev_frame-12,x7 eppbp throw_ret-*,ic spribp ab|frame.ret-12,x7 sprisp ab|frame.ret+2-12,x7 eax1 ab|-12,x7 stx1 |[catch_frame]+1 " go elaborate the compiled first arg to catch epplp ab|his_lp,x7* eppbp ab|his_bp,x7* tra bp|1 " come here (in pl1_code mode) if a throw occurs. The value " thrown is at top of marked pdl. The unmarked pdl has not " yet been unwound. " We move the thrown value down, unwind the unmarked pdl to " just above our catch_frame, put the thrown value " in aq, and return to the location after " the call to catch1 or catch2. The caller will do an uncatch. throw_ret: getlp " get lp from lot, as we are in pl1 code mode here. push eppbp |[unmkd_ptr],* eppbp bp|2 push onto unmarked pdl... spribp |[unmkd_ptr] eppap |[catch_frame],* eppap ap|12 ...the addr to unwind to... spriap bp|-2 ...which is just above our catch frame eppbp |[stack_ptr],* ldaq bp|-2 get the thrown value lxl1 ap|frame.stack_ptr-12 epbpbb bp|0 staq bb|-2,x1 and put it into our part of marked pdl eppap null_argl-*,ic call the unwinder with no pl1 arguments. short_call |[lisp_unwinder] " switch to lisp_code mode (ptrs in ap, x7) exit_pl1_code pop epbpbb ap|0 adjust stack_ptr to value when catch wsa done lxl1 ab|frame.stack_ptr-12,x7 eppap bb|0,x1 ldaq ab|-6,x7 restore sp|20 staq sp|20 ldaq ap|-2 return thrown value in aq epplp ab|his_lp,x7* eppbp ab|his_bp,x7* tra bp|0 return to caller who will do an uncatch " uncatch operator. " this operator removes the catch frame which must be at the top " of the unmarked pdl. It does not disturb the aq or the ap, " it decrements x7 by 12, and the other index registers are " destroyed. link catch_frame_plus_1,|[catch_frame]+1 uncatch: epplb ab|system_lp,* ldx1 ab|frame.prev_frame-12,x7 unthread this catch_frame stx1 lb|catch_frame_plus_1,* eax7 -12,x7 eppap ap|-2 get rid of value pushed by caller. tra bp|0 " operator to bind for iog. Allows iog to be compiled as " tspbp ab|iogbind_op,* " " 2nd arg to iog " tspbp ab|unbind_op,* " " binds ^q, ^r, ^w to nil. " destroys the contents of aq and all the index registers, bumps x7 by 2 " bumps ap by 16, but only 12 of those words are currently used. iogbind: eax7 6,x7 room for binding block, save lp,bp sprilp ab|his_lp,x7 spribp ab|his_bp,x7 epplp ab|system_lp,* eppap ap|16 make room for binding block ldaq ab|true " KLUDGE to take up space...rebind t to t. staq ap|-14 staq ap|-16 " END KLUDGE ldaq |[ctrlQ] put ^q in binding block staq ap|-10 ldaq |[ctrlR] put ^r in binding block staq ap|-6 ldaq |[ctrlW] put ^w in binding block staq ap|-2 ldaq ap|-10,* now save old values. staq ap|-12 ldaq ap|-6,* staq ap|-8 ldaq ap|-2,* staq ap|-4 ldq |[binding_top]+1 stq ab|-5,x7 make binding_block in unmkd pdl eax1 ap|-16 sxl1 ab|-6,x7 binding_block.bot_block eax1 ap|0 stx1 ab|-6,x7 binding_block.top_block eax1 ab|-6,x7 and thread onto list of b.b.'s stx1 |[binding_top]+1 ldaq ab|nil now reset ^q, ^r, ^w to nil staq |[ctrlQ],* staq |[ctrlR],* staq |[ctrlW],* tra return-*,ic " unseen_go_tag operator " this operator is called by the compiled form of the go function " when the argument is non-atomic and, having been evaled, is not " found in the table of known tags. " Called by tspbp with the losing tag in the aq. Returns with " ap, x7 unchanged, better tag in the aq, index regs destroyed. " " If the aq contains an atom, it is really a losing tag " and a call to lisp_error_ is constructed. " If the aq contains a list, then it is evaluated and returned " to caller, just like the interpreted go function. obscene_go_tag: eax7 4,x7 save caller's lp,bp spribp ab|his_bp,x7 sprilp ab|his_lp,x7 eppap ap|2 save tag on pdl for lisp_error_ or eval staq ap|-2 cana lisp_ptr.type,dl atomic tag? tze re_eval_tag-*,ic no, eval it again. lda |[unseen_go_tag] tsx0 Lisp_Error-*,ic ldaq ap|-2 get replacement tag eppap ap|-2 tra return-*,ic " come here to eval the tag again re_eval_tag: eax5 -2 calling eval with 1 arg epplp ab|system_lp,* get right lp for eval tra |[eval_] eval the tag and return to our caller. (clever) " return operator. " called by tra ab|return_op,* " This operator is used to return from a type 1 subr " after the unmkd pdl has been cleared, and the args, temps, " and local variables have been removed from the marked pdl. " the value to be returned should be in the aq. return: epplp ab|his_lp,x7* eppbp ab|his_bp,x7* eax7 -4,x7 tra bp|0 " signp operator. " called by tspbp ab|signp_op,* " This operator sets the indicators from the number in the aq. " If C(aq) is not a number, indicators are set randomly. " Changes no registers except aq. signp: cana Float,dl flonum? tnz signp_fl-*,ic yes. cana Big_fixed,dl bignum? tnz signp_big-*,ic " fixnum - set indicators from q<0:35> cmpq 0,du set indicators for fixnum in q. tra bp|0 " flonum - set indicators from fraction, q<8:35> signp_fl: canq =o1000,du set zero indicator from sign bit of float. tnz set_minus_indicator-*,ic and if negative float, set negative indicator. cmpq =0.0,du otherwise, compare with floating point zero (= least fixed number) tra bp|0 set_minus_indicator: szn =o777777,du turn on minus indicator. tra bp|0 return. signp_big: easpbb 0,au move pointer from AQ to BB eawpbb 0,qu .. szn bb|0 get sign from bignum. works because " no bignum is zero, and RH of header is nonzero tra bp|0 " compare operator. " takes arg in AQ, bb points at thing to be compared with. " sets indicators, returns. compare: cmpa fixnum_type,dl tnz floatcomp cmpq bb|1 tra bp|0 return floatcomp:eppap ap|2 staq ap|-2 fld ap|-1 eax0 1 fcmp bb|1 tpnz 4,ic tze 2,ic eax0 -1,x0 eax0 -1,x0 ldaq ap|-2 " reload the aq. eppap ap|-2 cmpx0 0,du tra bp|0 " err operator. " (err x) compiles into: " ldaq (eval x) " tra ab|err_op,* " -- never returns -- " " err with no args is the same as (err nil) " err with 2 args cannot be compiled!! err: eppap ap|2 push value of err onto pdl staq ap|-2 for use of lisp_error_$err_op enter_pl1_code tra lisp_error_$err_op go join interpreter's err fcn. " throw operators. " these operators execute those cases of the compiled throw " function that cannot be done in-line. " throw1 operator. " takes value to be thrown in aq. There is no tag. " called by tra ab|throw1_op,* throw1: eppap ap|4 get room to store value being thrown staq ap|-2 ldaq nultag-*,ic get null tag and fall into throw2 operator " throw2 operator. " takes value to be thrown on top of marked pdl, " with an empty slot beneath it, tag in aq. " Called by tra ab|throw2_op,* " the unmarked pdl is searched for catches using the same " algorithm as the throw function in the interpreter. When the catch " to be thrown to is found, control is transferred to it. The catch " has the responsiblity of unwinding the pdl's and resuming execution " at the point where catch was called. throw2: epplp ab|system_lp,* ldx1 |[catch_frame]+1 catch_search: tze bad_throw-*,ic tra if no more catch frames epbplb ap|0 get pointer to base of marked stack lxl6 ab|frame.stack_ptr,x1 get pdl area of catch cmpaq lb|-2,x6 is our tag = tag of catch? tze throw_1-*,ic yes, win. cmpaq nultag-*,ic if null tag in throw, any catch will do. tze throw_1-*,ic so go there. lxl2 lb|-2,x6 no, check for nultag cmpx2 nulfu,du tze throw_1-*,ic this is unlabeled catch, it catches us. ldx1 ab|frame.prev_frame,x1 not our catch, keep looking. tra catch_search-*,ic " come here with x1 pointing at catch frame of catch that catches us. throw_1: stx1 lisp_static_vars_$catch_frame+1 discard any intervening catches enter_pl1_code eax2 sp|0 which is the catch. cmpx2 ab|frame.ret+3,x1 tze throw_to_same_sp-*,ic " " Build arglist to call the Multics unwinder " (Started using Multics unwinder 12/6/78 -BSG) " eppbp ab|frame.ret,x1 Point at label var spribp sp|2 ldaq argl_h_of_1 staq sp|0 eppap sp|0 short_call unwinder_$unwinder_ even argl_h_of_1: zero 2,0 zero 0,04 throw_to_same_sp: eppbp ab|frame.ret,x1* spribp sp|20 short_return " come here when an unseen throw tag condition occurrs. bad_throw: eppap ap|2 place to store bad tag staq ap|-2 lda |[throw_to_no_catch] tsx0 Lisp_Error-*,ic ldaq ap|-2 get replacement tag eppap ap|-2 tra throw2+1-*,ic and go try again equ nulfu,Numeric = type field of nultag even nultag: zero 0,nulfu tag used by catch/throw with no tag. dec 0 tag is two words.... " Operator to create a string descriptor for PL/I calls " bb -> place to put descriptor " aq has the string (or atomic symbol) " returns with lb the appropriate argument ptr to store " clobbers regs create_string_descriptor: easplb 0,au move aq to lb and eawplb 1,qu make it point at first char cana String,dl check type tnz csd00-*,ic cana Atsym,dl tze csd_barf-*,ic bad type epplb lb|4 symbol - skip header csd00: lda lb|-1 pick up length ora =o524000,du set type in desc sta bb|0 store descriptor tra bp|0 return csd_barf: epplp ab|system_lp,* lda |[csd_op_barf] tra Lisp_Error-*,ic " create_varying_string: " aq contains the symbol or string to initialize it with " bb -> where to put the descriptor " word after call contains the declared length of the string " return with aq containing the new string as a lisp object, and " return with lb -> the data portion of the string. due to " a pl1 crock this points at the chars rather than the length eppap ap|4 save stuff so can cons string staq ap|-2 eax7 2,x7 ldq bp|0 pick up length eppbp bp|1 spribp ab|-2,x7 orq =o530000,du make varying string descrip stq bb|0 put in user's descriptor anq -1,dl clear qu again tspbp ab|cons_string_op,* epplb bb|1 set up return addr of string eppbp ab|-2,x7* eax7 -2,x7 staq ap|-4 save value we want to return in aq ldaq ap|-2 easpbb 0,au copy au to bb eawpbb 1,qu cana Atsym,dl tze cvs00-*,ic eppbb bb|4 tra cvs01-*,ic cvs00: cana String,dl tze csd_barf-*,ic cvs01: lxl2 bb|-1 sxl2 lb|-1 set current length of varying string mlr (pr,rl),(pr,rl) desc9a bb|0,x2 desc9a lb|0,x2 ldaq ap|-4 pick up the string into aq eppap ap|-4 for benefit of caller tra bp|0 done " " create an array descriptor for a PL/I call " bb -> the place to put it. Sufficient words must have been allocated " aq contains the array (as an array-ptr or a symbol) " word following the call has type in left half, ndims in right half " returns with lb -> the data " clobbers regs create_array_descriptor: easplb 0,au move aq into lb eawplb 0,qu cana Array,dl got array-ptr? tze cadget-*,ic no, go get one cad00: lxl0 bp|0 get number of dimensions cmpx0 lb|array_info.ndims check it tnz cad_barf-*,ic ldx1 lb|array_info.type check type of array cmpx1 bp|0 tnz cad_barf-*,ic eaa 0,x0 put ndims in descriptor als 6 ora type_table,x1 and type bits sta bb|0 stor first descriptor word eax1 0 the array descriptor is stored backwards! epplb lb|array_data_ptr,* cad01: eax1 -2,x1 scan lisp dope vector backwards stz bb|1 lower bound ldq lb|0,x1 upper bound sbq 1,dl stq bb|2 ldq lb|1,x1 multiplier stq bb|3 eppbb bb|3 advance to next dimension eax0 -1,x0 count dimensions tnz cad01-*,ic tra bp|1 done, return " do a get cadget: cana Atsym,dl better be a symbol tze cad_barf-*,ic eppsb ab|system_lp,* link array_atom,|[array_atom] ldaq sb|array_atom,* epbpsb sp|0 cadget0: lxl0 lb|2 check for end canx0 lisp_ptr.type,du tnz cad_barf-*,ic reached end - no array property epplb lb|2,* -> next plist cell cmpaq lb|0 array property? tze cadget1-*,ic yes -use it epplb lb|2,* no - take next property tra cadget0-*,ic cadget1: epplb lb|2,* -> plist value epplb lb|0,* get the array pointer tra cad00-*,ic and resume normal operation cad_barf: epplp ab|system_lp,* lda |[cad_op_barf] tra Lisp_Error-*,ic type_table: oct 410000000107 Sexpr oct 410000000107 Sexpr oct 404000000043 fixnum oct 414000000033 flonum " " PL/I call operator " bb -> arg list " a contains argcount*2 in left half " bp is return address " instruction following tspbp is callsp indirect through link. " At first I had this an epplb that was xec'ed, " but the crufty hardware then goes to the wrong segment if it is bound pl1_call_operator: eax7 4,x7 save caller's lp and address stcd ab|-4,x7 save ingenious internal return pt tra pl1_call_common exit_pl1_code pop pl1_call_ret_common: lprpbp ab|-1,x7 lprplp ab|-2,x7 eax7 -4,x7 tra bp|1 return skipping callsp inst pl1_call_nopop: eax7 4,x7 stcd ab|-4,x7 tra pl1_call_common exit_pl1_code "nopop tra pl1_call_ret_common rcv_char_star: ldq bb|0 get length from lisp string mlr (pr,rl),(pr,rl) move from bp to bb desc9a lb|0,ql desc9a bb|1,ql body of lisp code " Now pop PL/I stack epbpsb sp|0 epplb sp|0 even inhibit on eppsp sp|stack_frame.prev_sp,* sprilb sb|stack_header.stack_end_ptr inhibit off tra bp|0 pl1_call_common: eaq 0,au set descriptor counter ora 4,dl and arglist type staq bb|0 and finish arg list sprplp ab|-2,x7 sprpbp ab|-1,x7 enter_pl1_code push,64 "for pl1 vars eppap bb|0 make the call eppbp lisp_static_vars_$unmkd_ptr,* get back return address lprpbp bp|-1 epaq bp|0 get caller's linkage lprplp sb|stack_header.lot_ptr,*au stcd sp|stack_frame.return_ptr callsp bp|0 call to caller's callsp " can't use short_call, clobbers pr4 epplp sp|stack_frame.lp_ptr,* eppbp lisp_static_vars_$unmkd_ptr,* rtcd bp|-4 " " " Unwind Protect Feature " Greenberg, 9/10/78 " "Called as follows: " tspbp ab|unwp1,* " tra cleanup_handler " code...... unwind_protect: eax7 6,7 Push unmarked frame eax1 -6,7 Get pointer to it. sprilp ab|frame.ret+2,1 Save LP for both us and handler. epplp ab|system_lp,* ldx6 lisp_static_vars_$unwp_frame+1 Get thread. stx6 ab|frame.prev_frame,1 eax6 ap|0 Save marked pdl. sxl6 ab|frame.stack_ptr,1 stc1 ab|frame.dat1,1 Let interpreter know we are compiled. spribp ab|frame.ret,1 Fake lisp PL/I environment closure. stx1 lisp_static_vars_$unwp_frame+1 Now we're official. epplp ab|frame.ret+2,1* Restore his Lisp LP. tra bp|1 Execute protected code. "Un-unwind-protect operator. Assumes top unwp frame is the right one. "Called as: " tspbp ab|ununwp,* unwind_protect_end: epplb lp|0 Save his Lisp LP epplp ab|system_lp,* ldx1 lisp_static_vars_$unwp_frame+1 ldx6 ab|frame.prev_frame,1 Get last frame, this MUST be unm top. stx6 lisp_static_vars_$unwp_frame+1 ldq lisp_static_vars_$masked Save interrupt state lca 1,dl Mask all interrupts sta lisp_static_vars_$masked epplp ab|frame.ret+2,1* Get Handler's Lisp LP. eppbb ab|frame.ret,1* BB = handler address eax7 6,1 Pop unwp frame, set ret block, intsav spribp ab|his_bp-2,7 Save return address. sprilb ab|his_lp-2,7 Save his LP, too. stq ab|-2,7 Store the interrupt system state. tra bb|0 Go execute the handler. "This next guy is called by the end of interrupt-inhibited handlers. " As: " tspbp ab|irest_return_op,* irest_return: epplp ab|system_lp,* Restore linkage ldq ab|-2,7 Get old interrupt state eax7 -2,7 Get PDL back. stq lisp_static_vars_$masked szn lisp_static_vars_$deferred_interrupt Any? tze return Finish normal return enter_pl1_code push eppap null_argl short_call lisp_fault_handler_$interrupt_poll exit_pl1_code pop tra return "This next character is called by lisp_prog_fns_, to accomplish quite "the same when the interpreter unwinds an unwp frame. We are coming "from the PL/I environment, and we must pop the unm frame as well. segdef xec_unwprot_compiled_handler xec_unwprot_compiled_handler: getlp exit_pl1_code tspbp unwind_protect_end Hah, hah hah. enter_pl1_code short_return end  lisp_property_fns_.alm 11/05/86 1612.7r w 11/04/86 1039.2 74331 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " " lisp_property_fns_ -- those primitives used by lisp programs " to manipulate property lists. " Also handles lists which are structured as " property lists, even if not associated with atoms. " get_plist: " this routine sets bp to point at the plist of something. " call by tsx0, following word has pdl cell number in du " skip returns if this thing has a plist, else doesn't skip. " caller may signal an error if he wants. " NOTE: this perhaps should be changed to try a user " interrupt if the thing does not have a plist, or otherwise " be user-replaceable so that numbers and lists can have " properties associated with them in some strange way. ldx1 0,x0 " pick up pdl cell number of arg ldaq ap|0,x1 " get thing whose plist is needed cmpaq ab|nil tze get_plist_of_nil-*,ic cana Unevalable,dl " have a plist? tnz 1,x0 " no, non_skip return eppbp ap|0,x1* " yes, bp|2 contains it tra 2,x0 " and skip return get_plist_of_nil: eppbp |[property_list_of_nil]-2 " bp|2 contains plist tra 2,x0 segdef get_ get_: tsx0 get_plist-*,ic " get the property list of first argument arg -4 tra retrn_nil-*,ic " if has no plist, don't err, just return nil get_loop: ldaq bp|2 " see if there is any more property list left. cmpaq ab|nil tze retrn_aq-*,ic " if not, return nil. eppbp bp|2,* " get next indicator cell. ldaq bp|0 " load the indicator. eppbp bp|2,* " and get pointer to value cell for that indicator. cmpaq ap|-2 " see if desired indicator. tnz get_loop-*,ic " if not, try next indicator on list. ldaq bp|0 " load value to return. retrn_aq: eppap ap|-4 " pop off two args retrn: epplp ab|-4,x7* eppbp ab|-2,x7* eax7 -4,x7 " pop off save stuff. tra bp|0 " return. retrn_nil: ldaq ab|nil " any atom not having a pname has null property list. tra retrn_aq-*,ic " so return nil...this used to be error. segdef getl_ getl_: ldaq ap|-2 cana Atomic,dl " make sure it is a list. tze getl_ok-*,ic cmpaq ab|nil " nil is ok too. tze getl_ok-*,ic lcq -fn_getl,dl tsx6 error2-*,ic " error in second of two args. tra getl_-*,ic getl_ok: tsx0 get_plist-*,ic " find atom whose property is to be gotten arg -4 tra retrn_nil-*,ic " no properties -> nil getl_lp: ldaq bp|2 " check to see if any properties cmpaq ab|nil " left...if not return nil tze retrn_aq-*,ic staq ap|-4 " save as a possible return val eppbp bp|2,* epplp ap|-4 " see if cur indicator is member of list. getl_lp1: ldaq lp|2 " see if any more tings in list cmpaq ab|nil tze getl_next-*,ic epplp lp|2,* " if so, check next element ldaq lp|0 " against current indicator cmpaq bp|0 tnz getl_lp1-*,ic " if not eq, then try next element. ldaq ap|-4 " load saved result. tra retrn_aq-*,ic getl_next:eppbp bp|2,* " get next property cell pointer. tra getl_lp-*,ic segdef plist_ " function to get the plist plist_: tsx0 get_plist-*,ic arg -2 eppbp ab|nil-2 " if doesn't have one, for now use nil ldaq bp|2 " pick up the plist eppap ap|-2 tra retrn-*,ic segdef setplist_ " function to set a new plist setplist_:tsx0 get_plist-*,ic arg -4 tra cant_set_plist-*,ic " error to set plist of e.g. number. ldaq ap|-2 " get plist to set staq bp|2 " store it away ldaq ap|-4 " return first arg tra retrn_aq-*,ic cant_set_plist: lda |[cant_set_plist] eax0 -4 " ap|-4 has the bad thing tsx6 error00-*,ic " go signal error tra setplist_-*,ic " then try again segdef remprop_ remprop_loses: lcq -fn_remprop,dl " load error code tsx6 error1-*,ic " go complain to user " and if reparations made, try again. remprop_: tsx0 get_plist-*,ic " get plist of first arg arg -4 tra remprop_loses-*,ic " can't get it, complain epplp bp|0 " lp will point at cell to rplacd rem_loop: ldaq lp|2 " check for end of plist. cmpaq ab|nil tze retrn_aq-*,ic " if end, return nil. eppbp lp|2,* " get pointer at property indicator cell. ldaq bp|0 " load the indicator cmpaq ap|-2 " cand see if the desired one. tze rem_property-*,ic " if so remove the property. epplp bp|2,* " look at next element tra rem_loop-*,ic " and try again. rem_property: eppbp bp|2,* " get pointer to second cell deleted. ldaq bp|2 " and rplacd its cdr into place staq lp|2 " pointed at by lp. spribp ap|-2 " result is second cell ldaq ap|-2 " return indicator of success. tra retrn_aq-*,ic segdef putprop_ putprop_loses: lcq -fn_putprop,dl " load our name tsx6 error3-*,ic " and call the error routine putprop_: tsx0 get_plist-*,ic " find plist of arg 1 arg -6 tra putprop_loses-*,ic " if has none, barf epplb bp|0 " save address of start of plist put_loop: ldaq bp|2 " check to see if at end of plist. cmpaq ab|nil tze make_new_cells-*,ic " if so, must make addition to plist at front. eppbp bp|2,* " get pointer at indicator cell ldaq bp|0 " load indicator. eppbp bp|2,* " get value cell pointer into bp cmpaq ap|-2 " if indicator eq to arg 3, rplacd tnz put_loop-*,ic " oterwise jump down list to next indicator. ldaq ap|-4 " get new value to rplaca staq bp|0 " and do it. eppap ap|-6 " get rid of args...value to return is in aq tra retrn-*,ic make_new_cells: " code to make two new list cells and splice tem in. eppap ap|6 " get arg list room ldaq lb|2 " load old cdr of arg 1 staq ap|-2 " and set up call to cons. ldaq ap|-4-6 " load arg 2 staq ap|-4 eax7 8,x7 " get room for two type 1 calls to cons. sprilp ab|-8,x7 sprilp ab|-4,x7 stcd ab|-2,x7 " save return address. tra |[cons_] staq ap|-2 stcd ab|-2,x7 " call cons again to add indicator. tra |[cons_] staq ap|-2 " save new property list tsx0 get_plist-*,ic " get where to put it arg -4 drl 0 " I don't know what to do here ldaq ap|-2 " get back result of consing staq bp|2 " store new property list eppbp bp|2,* ldaq bp|2,* " load the value for return tra retrn_aq-*,ic " The PL/I callable entries are here... entry get,putprop,getl,remprop get: tsx6 pl1_to_lisp-*,ic tra get_-*,ic putprop: tsx6 pl1_to_lisp-*,ic tra putprop_-*,ic getl: tsx6 pl1_to_lisp-*,ic tra getl_-*,ic remprop: tsx6 pl1_to_lisp-*,ic tra remprop_-*,ic pl1_to_lisp: epbpab |[unmkd_ptr],* eppap |[stack_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code eax7 4,x7 sprilp ab|-4,x7 " save lp and return address. stcd ab|-2,x7 tra 0,x6 " and call the lisp routine. eppap ap|2 " now put result back on stack. staq ap|-2 spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code short_return error1: eax0 -4 " offset of losing arg from stack top. error: lda |[bad_arg_correctable] error00: eax7 4,x7 " save regs, error data on unmkd stack staq ab|-2,x7 eppap ap|2 " get losing arg on stack top. ldaq ap|-2,x0 staq ap|-2 stx6 ab|-4,x7 " save return address stx0 ab|-3,x7 " and stack offset of bad arg. spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code push eppap noargs-*,ic short_call |[lisp_error_] eaa sp|16,* " get back pointer from stack frame sprisp sb|stack_header.stack_end_ptr eppsp sb|0,au " and pop off stack frame. epbpab |[unmkd_ptr],* eppap |[stack_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code ldaq ap|-2 "load returnd value. eppap ap|-2 ldx0 ab|-1,x7 ldx6 ab|-2,x7 staq ap|0,x0 " put value back in correct place. eax7 -2,x7 " pop off saved index reg block. tra 0,x6 " return to try again. error2: eax0 -2 " offset of losing arg. tra error-*,ic error3: eax0 -6 " offset of losing arg. tra error-*,ic even noargs: oct 4,0 " null arg list. include stack_header include lisp_object_types include lisp_name_codes include lisp_stack_seg end  lisp_quick_fcns_.alm 11/05/86 1612.7r w 11/04/86 1039.2 257148 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " " Procedure lisp_quick_fcns_, which contains those functions which " are optimally hand-coded for maximum interpreter speed. " " DPR 14 August 72 " tempd arg(2) include stack_header include lisp_object_types include lisp_stack_seg include lisp_error_codes include lisp_name_codes even some constants for numeric routines fixnum_zero: vfd 36/fixnum_type dec 0 flonum_zero: vfd 36/flonum_type dec 0.0 good old floating point. float_q: llr 36 convert to fixed double word. lrs 36 extend sign. lde =71b25,du load exponent with magic number fad =0.0,du and normalize tra 0,x6 return " common code to return from a procedure which pushed its return address on " the unmkd pdl. popj: eppbp ab|-2,x7* reload bp from unmarked pdl eax7 -2,x7 pop off pdl tra bp|0 and return " standard return sequence for type 1 lisp subr. Such subrs " have the caller's lp and the return address pushed on the unmkd " pdl. retrn1: eppbp ab|-2,x7* reload return address epplp ab|-4,x7* and caller's lp eax7 -4,x7 pop unmarked stack tra bp|0 and return to caller. " segdef null null: ldaq ap|-2 load argument eppap ap|-2 pop stack cmpaq ab|nil see if arg is nil tze ret_t-*,ic if so, return true. ret_nil: ldaq ab|nil else return false. tra bp|0 ret_t: ldaq ab|true tra bp|0 segdef eq eq: ldaq ap|-4 cmpaq ap|-2 compare 2 arguments as pointers. eppap ap|-4 pop stack, changing no indicators. tze ret_t-*,ic tra ret_nil-*,ic segdef atom atom: lda ap|-2 load type field eppap ap|-2 and pop off stack cana Atomic,dl tze ret_nil-*,ic tra ret_t-*,ic segdef numberp numberp: ldaq ap|-2 eppap ap|-2 cana Numeric,dl tze ret_nil-*,ic tra ret_t-*,ic segdef fixp fixp: ldaq ap|-2 eppap ap|-2 cana Fixed+Big_fixed,dl tnz ret_t-*,ic tra ret_nil-*,ic segdef smallnump smallnump:ldaq ap|-2 eppap ap|-2 cmpa fixnum_type,dl " only small fixnums match here. tze ret_t-*,ic tra ret_nil-*,ic segdef bigp bigp: ldaq ap|-2 eppap ap|-2 cana Big_fixed,dl tnz ret_t-*,ic tra ret_nil-*,ic segdef floatp floatp: ldaq ap|-2 eppap ap|-2 cmpa flonum_type,dl tze bp|0 tra ret_nil-*,ic segdef stringp stringp: ldaq ap|-2 eppap ap|-2 cana String,dl tnz ret_t-*,ic tra ret_nil-*,ic segdef subrp subrp: lda ap|-2 eppap ap|-2 cana Subr,dl tnz ret_t-*,ic tra ret_nil-*,ic segdef symbolp symbolp: lda ap|-2 eppap ap|-2 cana Atsym,dl tnz ret_t tra ret_nil segdef arrayp arrayp: lda ap|-2 eppap ap|-2 cana Array,dl tnz ret_t tra ret_nil segdef filep filep: lda ap|-2 eppap ap|-2 cana File,dl tnz ret_t tra ret_nil segdef zerop zerop: ldaq ap|-2 cana Fixed+Float+Big_fixed,dl tnz 5,ic tsx4 push_ptrs zerop_tsx4: tsx4 bad_arg tsx4 pop_ptrs tra zerop eppap ap|-2 pop stack. cmpaq fixnum_zero-*,ic see if fixed zero. tze ret_t-*,ic cmpaq flonum_zero-*,ic see if float zero tze ret_t-*,ic tra ret_nil-*,ic segdef oddp " determine if fixnum is odd. oddp: ldaq ap|-2 " check arg for fixnum cana Big_fixed,dl " big case, must check least significant word. tze not_big-*,ic ldaq ap|-2,* " load first two words of bignum. oddp_test:eppap ap|-2 canq 1,dl " least significant word is in q. tze ret_nil-*,ic tra ret_t-*,ic not_big: cmpa fixnum_type,dl " must be fixnum arg. tze oddp_test-*,ic tsx4 push_ptrs oddp_tsx4:tsx4 bad_arg tsx4 pop_ptrs tra oddp-*,ic " and try again. push_ptrs: eax7 4,x7 sprilp ab|-4,x7 spribp ab|-2,x7 epplp ab|system_lp,* " get system lp. tra 0,x4 return pop_ptrs: epplp ab|-4,x7* " reload lp eppbp ab|-2,x7* eax7 -4,x7 " and pop stack. staq ap|-2 " put new value back tra 0,x4 " segdef runtime runtime: eax7 6,x7 sprilp ab|-6,x7 spribp ab|-4,x7 epplp ab|system_lp,* " get sytem lp, to save data for pl1. spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code push " get pl1 stack frame. eppbp |[unmkd_ptr],* eppbp bp|-2 " get place to put cpu time. spribp arg+2 ldaq one_arg-*,ic staq arg eppap arg short_call |[virtual_cpu_time_] eppbp sp|16,* " pop stack frame off. sprisp sb|stack_header.stack_end_ptr eppsp bp|0 epbpab |[unmkd_ptr],* eppap |[stack_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code ldq ab|-1,x7 " get cpu time. lda fixnum_type,dl eppbp ab|-4,x7* epplp ab|-6,x7* eax7 -6,x7 tra bp|0 " return " " fsubrs for comment and declare. segdef comment comment: ldaq |[comment_atom] eppap ap|-2 tra retrn1-*,ic segdef declare declare: ldaq |[declare_atom] eppap ap|-2 tra retrn1-*,ic " segdef length computes length of list. length: ldaq fixnum_zero-*,ic initial length is zero. eax7 2,x7 save return address. spribp ab|-2,x7 eppbp ap|-4 start list off right. len_loop: lxl0 bp|2 see if any more canx0 Atomic,du tnz ret_l-*,ic if none, return aq adq 1,dl bump aq eppbp bp|2,* go down cdr tra len_loop-*,ic and try again. ret_l: eppap ap|-2 pop arg off stack tra popj-*,ic and return to address saved on pdl segdef last last: ldaq ap|-2 result is arg if atomic eax7 2,x7 spribp ab|-2,x7 save return addr eppbp ap|-4 start list off right last_loop:lxl0 bp|2 get type of cdr canx0 Atomic,du see if atom, tnz ret_l-*,ic return aq if so. ldaq bp|2 else load cdr into aq eppbp bp|2,* and chase down list tra last_loop-*,ic " " lisp function _e_q_u_a_l. " " Other routines in this segment require that equal not change index register " 3 during its operation, as it is used as an internal procedure by some. " segdef equal equal: eax7 2,x7 get space and spribp ab|-2,x7 save return address. eax0 0 set recursion depth. eql_lp: ldaq ap|-4 first test for eq cmpaq ap|-2 tze ret_t_eql-*,ic and return true for this level if so. cana Atomic,dl check for list tze list_eql-*,ic and go to recursive equal cana Atsym+Subr+Fixed+Float,dl these are equal iff eq. tnz ret_nil_eql-*,ic cana Big_fixed,dl check for bignum tnz bignum_eql-*,ic cana String,dl check for string tze ret_nil_eql-*,ic and if not, unknown type. " string compare.... lda ap|-2 load type field cana String,dl tze ret_nil_eql-*,ic lda ap|-2,* load length cmpa ap|-4,* and compare lengths. tnz ret_nil_eql-*,ic if not equal, then complain. eppbp ap|-2,* get ptrs to strings epplb ap|-4,* cmpc (pr,rl),(pr,rl) desc9a bp|1,al desc9a lb|1,al tze ret_t_eql-*,ic tra ret_nil_eql-*,ic list_eql: lda ap|-2 load type of second arg cana Atomic,dl if atomic, then can't be a list tnz ret_nil_eql-*,ic eppap ap|4 get room to recurse eax0 -4,x0 and bump recursion counter. eppbp ap|-8,* get car and cdr of arg 1 ldaq bp|0 staq ap|-4 and pass to loop ldaq bp|2 staq ap|-8 eppbp ap|-6,* get car and cdr of 2nd arg ldaq bp|0 staq ap|-2 ldaq bp|2 staq ap|-6 tra eql_lp-*,ic bignum_eql: " first arg is bignum... lda ap|-2 load second arg type. cana Big_fixed,dl tze ret_nil_eql-*,ic eppbp ap|-4,* get pointer to first bignum ldq bp|0 sign and length in q epplb ap|-2,* cmpq lb|0 compare sign and length with other value. tnz ret_nil_eql-*,ic if sign or length differ, return nil eaq 1,ql get total length in qu and flush sign bits qls 2 convert to characters cmpc (pr,rl),(pr,rl) desc9a bp|0,qu desc9a lb|0,qu tze ret_t_eql-*,ic " tra ret_nil_eql-*,ic ret_nil_eql: " return nil, which propagates back... ldaq ab|nil eppap ap|-4,x0 and pop back all of stack stuff tra popj-*,ic ret_t_eql:eax0 4,x0 pop off recursion counter tze 2,ic this and next could be replaced by one inst. tpl ret_t_for_real-*,ic eppap ap|-4 pop off stack tra eql_lp-*,ic and return, checking cdr. ret_t_for_real: eppap ap|-8,x0 pop stack ldaq ab|true tra popj-*,ic segdef alphalessp alphalessp: tsx6 stringcmp tra true_return tra nil_return tra nil_return segdef samepnamep samepnamep: tsx6 stringcmp tra nil_return tra true_return tra nil_return true_return: ldaq ab|true tra 2,ic nil_return: ldaq ab|nil eppap ap|-4 tra retrn1 stringcmp: ldaq ap|-4 " load first arg. cana Atsym+String,dl tnz good_alpha1 " ok argument is string or atsym tsx4 bad_string staq ap|-4 tra stringcmp good_alpha1: ldaq ap|-2 cana Atsym+String,dl " check for string or atsym. tnz good_alpha2 tsx4 bad_string staq ap|-2 tra good_alpha1 good_alpha2: epplb ap|-2,* " get pointer to second arg. cana String,dl " if string, ptr is right. tnz 2,ic epplb lb|4 " otherwise bump pointer. eppbp ap|-4,* " get pointer to first arg's ascii in bp lda ap|-4 cana String,dl " check for string. tnz 2,ic eppbp bp|4 " otherwise bump bp to point at pname. lda bp|0 cmpa lb|0 " get minimum length of args. tmi 2,ic lda lb|0 cmpc (pr,rl),(pr,rl) desc9a bp|1,al desc9a lb|1,al tnc 0,x6 first < second tnz 2,x6 first > second " appear equal, check lengths lda bp|0 cmpa lb|0 tmi 0,x6 second longer, it is > tze 1,x6 same length, they are = tra 2,x6 first longer, it is > bad_string: eppap ap|2 staq ap|-2 " save losing arg. eax7 4,x7 " save useful index regs. stx6 ab|-3,x7 stx4 ab|-4,x7 cmpx6 alphalessp+1,du " see which function we are. tnz 3,ic lcq -fn_alphalessp,dl tra got_name " jump into error code. lcq -fn_samepnamep,dl tra got_name segdef getcharn getcharn: tsx6 2,ic same as getchar but returns a fixnum segdef getchar " routine to get nth char of pname atom or string. getchar: eax6 0 set esw " getchar and getcharn join here. x6 is nonzero for getcharn ldaq ap|-4 " validate arguments. cana Atsym+String,dl " may be pname atom or string. tnz good_getch1 getch_tsx4:tsx4 bad_arg " bad first arg... staq ap|-4 tra getchar+1 " retry with new value. good_getch1: " validate second argument...must be fixnum. ldaq ap|-2 " second arg. cmpa fixnum_type,dl " must compare exactly. tze good_getch2 getch_tsx4_2: tsx4 bad_arg staq ap|-2 tra good_getch1 " retry with new value. good_getch2: " now do the operation. eppbp ap|-4,* " get pointer to string or atsym. lda ap|-4 cana Atsym,dl " if atsym, move pointer to point to name. tze 2,ic eppbp bp|4 " name is 4 offset from beginning. sbq 1,dl " q register still contains second argument. tmi ret_nil_getch " if <= 0 then return nil...out of range. cmpq bp|0 " if > than number of chars in name, tpl ret_nil_getch " return nil for out of range. a9bd bp|1,ql bp -> char. necc. because what length to put in mrl? mrl (pr),(pr),fill(0) unpack the character into a fixnum desc9a bp|0,1 desc9a ap|-1,4 ldaq ap|-2 pick up result, fixnum type already set from arg eax6 0,x6 tnz getcharn_return-*,ic staq ap|-4 make arg to call ascii with. eppap ap|-2 and pop off other arg. tra |[ascii_alm] ret_nil_getch: ldaq ab|nil " return nil for out of bounds arguments. eax6 0,x6 tze 2,ic ldaq fixnum_zero-*,ic getcharn_return: eppap ap|-4 tra retrn1 " return as type 1 subr. segdef prog1 "10/8/80 -BSG prog1: ldaq ap|0,x5 eppap ap|0,x5 tra bp|0 segdef prog2 prog2: ldaq ap|2,x5 x5 contains -2*number of arguments. eppap ap|0,x5 tra bp|0 segdef progn progn: ldaq ap|-2 eppap ap|0,x5 tra bp|0 " segdef and and: ldaq ab|true preload for no arguments. and_loop: lxl0 ap|-2 canx0 Atomic,du test type of remaining frag of arg list. tnz and_done-*,ic eppap ap|2 get space for eval argument. eppbp ap|-4,* ldaq bp|0 staq ap|-2 ldaq bp|2 staq ap|-4 eax7 4,x7 now call eval... eax5 -2 1 argument. sprilp ab|-4,x7 stcd ab|-2,x7 save return address. tra |[eval_] KLUDGE. requires that eval_ be bound in with this proc. cmpaq ab|nil check return val. tnz and_loop-*,ic if nil, then we are done. and_done: eppap ap|-2 pop off rest of stuff on stack. tra retrn1-*,ic return to caller segdef or or: ldaq ab|nil preload or of no arguments. or_loop: lxl0 ap|-2 check for atom at end of list. canx0 Atomic,du tnz and_done-*,ic eppap ap|2 eppbp ap|-4,* ldaq bp|0 staq ap|-2 ldaq bp|2 staq ap|-4 and call eval now. eax7 4,x7 eax5 -2 1 argument sprilp ab|-4,x7 stcd ab|-2,x7 tra |[eval_] KLUDGE. (see and) cmpaq ab|nil tze or_loop-*,ic tra and_done-*,ic " segdef cond " lisp conditional function. cond: eppap ap|4 get room for temps. ldaq ab|nil staq ap|-2 cond_loop:lda ap|-6 load type of cond list cana Atomic,dl and check for end of list. tnz cond_done-*,ic eppbp ap|-6,* get head of list ldaq bp|0 staq ap|-4 and store it as the next phrase. ldaq bp|2 get cdr of cond list staq ap|-6 and save for next time. ldaq ap|-4,* get predicate. staq ap|-2 and set it to be arg to eval eax7 4,x7 eax5 -2 1 argument sprilp ab|-4,x7 set up call to eval... stcd ab|-2,x7 tra |[eval_] KLUDGE, requiring that cond be bound with eval. eppap ap|2 save result on stack staq ap|-2 cmpaq ab|nil tze cond_loop-*,ic loop back for next predicate. cond_ev: eppbp ap|-4,* get phrase ldaq bp|2 load cdr of phrase cana Atomic,dl check for end tnz cond_done-*,ic staq ap|-4 and store as rest of phrase ldaq ap|-4,* load car of phrase staq ap|-2 and store as next thing. eax7 4,x7 eax5 -2 1 argument. sprilp ab|-4,x7 save stuff for call to eval stcd ab|-2,x7 tra |[eval_] KLUDGE. eppap ap|2 staq ap|-2 save result tra cond_ev-*,ic cond_done:ldaq ap|-2 load last result eppap ap|-6 pop off stacks tra retrn1-*,ic and go to return sequence. " segdef member member: lda ap|-4 if first arg atomic, turn into memq cana Atsym+Subr+Fixed+Float,dl (see equal) tnz memq-*,ic eax7 2,x7 save return address spribp ab|-2,x7 lda ap|-2 load type of 2nd arg. memb_lp: cana Atomic,dl see if end of list. tnz ret_mq-*,ic eppap ap|4 get room for args to equal. ldaq ap|-8 load our first arg. staq ap|-4 and make it first equal arg. ldaq ap|-6,* get car of list remaining of 2nd arg staq ap|-2 and save it as secind equal arg. tspbp equal-*,ic equal is a fast call subr. cmpaq ab|nil check result, tnz ret_mq_obj-*,ic and if truely equal, return list. eppbp ap|-2,* else take cdr of list, ldaq bp|2 staq ap|-2 and make it the current list. tra memb_lp-*,ic and loop back to try again. segdef memq memq: lda ap|-2 check cdr of list eax7 2,x7 get space and spribp ab|-2,x7 save return address. mq_lp: cana Atomic,dl tnz ret_mq-*,ic eppbp ap|-2,* get car of it ldaq bp|0 cmpaq ap|-4 see if eq to first arg tze ret_mq_obj-*,ic and if so return ap|-2 ldaq bp|2 staq ap|-2 store cdr of list back tra mq_lp-*,ic ret_mq: ldaq ab|nil tra 2,ic skip to return sequence. ret_mq_obj:ldaq ap|-2 load current object list eppap ap|-4 restore stack tra popj-*,ic " segdef sassoc sassoc: eax3 -2 offset to assoc args from ap. " NOTE: assumes x3 is not used by equal! " do not change equal to use x3 or call out. tra assoc1-*,ic jump into common code. segdef assoc assoc: eax3 0 offset to assoc args from ap, see above assoc1: ldaq ap|-4,x3 pick up arg 1 cana Atsym+Subr+Fixed+Float,dl tnz assq1-*,ic if eq =_ equal, use assq or sassq eppap ap|6 get room for arg list to equal eax7 2,x7 and get space to save ret addr spribp ab|-2,x7 lda ap|-8,x3 load type of list arg 2 ass_lp: cana Atomic,dl tnz ret_ass_nil-*,ic ldaq ap|-8,x3* load car of arg 2 cana Atomic,dl either it is atom, and should be skipped tnz skip_ass-*,ic or should look at its car staq ap|-6 and save as possible return value ldaq ap|-6,* load car of that staq ap|-2 and make arg of call to equal ldaq ap|-10,x3 other arg is our first arg staq ap|-4 tspbp equal-*,ic cmpaq ab|nil tnz assq_done-*,ic if equal, then return value at ap|-2 eppap ap|4 get back space lost by equal skip_ass: eppbp ap|-8,x3* get cdr of arg 2 ldaq bp|2 staq ap|-8,x3 and save it tra ass_lp-*,ic ret_ass_nil: eppap ap|-4 pop some off stack tra ret_assq_nil-*,ic " segdef sassq sassq: eax3 -2 offset of assoc args from ap. tra assq1-*,ic get into common code. segdef assq assq: eax3 0 offset of args from ap assq1: eppap ap|2 eax7 2,x7 spribp ab|-2,x7 lda ap|-4,x3 assq_lp: cana Atomic,dl check for end of lsit tnz ret_assq_nil-*,ic eppbp ap|-4,x3* get car ldaq bp|0 cana Atomic,dl tnz skip_assq-*,ic skip atomic list element staq ap|-2 save list element ldaq ap|-2,* and get its car cmpaq ap|-6,x3 compare with first arg tze assq_done-*,ic and if eq, return ap|-2 skip_assq:ldaq bp|2 get cdr of list staq ap|-4,x3 and save it tra assq_lp-*,ic assq_done:ldaq ap|-2 load result assq_ret: eppap ap|-6,x3 restore stack tra popj-*,ic ret_assq_nil: ldaq ab|nil cmpx3 0,du see which entry we came through. tze assq_ret-*,ic if assoc or sassoc, just return nil " else want to apply third arg to nil. staq ap|-4,x3 store in second arg position for apply. ldaq ap|-2,x3 get function arg. eppap ap|-2,x3 and bump back the stack. staq ap|-4 save function as first arg to apply eax7 2,x7 now set up call to apply. ldaq ab|-4,x7 load our old return address staq ab|-2,x7 and make it apply's return address! sprilp ab|-4,x7 save our caller's lp where apply will reload it epplp ab|system_lp,* get our lp (which must be apply's also, " since we are relying on fact that apply is bound in.) eax5 -4 load lsubr arg count. tra |[apply_] call apply who will return to our caller. " segdef delete delete: ldaq ap|0,x5 get first argument cana Atsym+Subr+Fixed+Float,dl eq =_ equal for this? tnz delq-*,ic yes, turn into delq eax3 -1 load number for thing to be deleted as infinity. cmpx5 -4,du check for two args tze 3,ic if so, infinite number of deletions to be done. eax0 fn_delete tsx6 get_count-*,ic else go to subroutine get count from third arg. eppap ap|6 get room for args to equal, and temp cmpx3 0,du check for no deletion case. tze ret_del-*,ic lda ap|-8 get second arg head_loop:cana Atomic,dl see if not list, return if not. tnz ret_del-*,ic ldaq ap|-8,* get car of second arg staq ap|-2 make it arg to equal ldaq ap|-10 get our first arg staq ap|-4 make it equal's first tspbp equal-*,ic eppap ap|4 get back space cmpaq ab|nil tze end_head-*,ic if not equal, then this phase is done. eppbp ap|-8,* get pointer to list ldaq bp|2 load cdr staq ap|-8 eax3 -1,x3 decrement count of deleteions tnz head_loop-*,ic and go back to try again. tra ret_del-*,ic end_head: ldaq ap|-8 staq ap|-6 now we have to look at the cadr caddr ... del_loop: cmpx3 0,du see if no more deletions to be done. tze ret_del-*,ic del_loop1:eppbp ap|-6,* get pointer to list cell whose cadr we are checking. lda bp|2 see if there is a list at the cdr cana Atomic,dl tnz ret_del-*,ic and if not, returm ldaq bp|2,* load cadr of list staq ap|-2 and make it second arg to equal ldaq ap|-10 load our first arg, staq ap|-4 and make it equal's first tspbp equal-*,ic eppap ap|4 get back space eax2 2 so cdr's can be easily accessed. cmpaq ab|nil check result of equal call tze no_del-*,ic if not equal, don't delete eppbp ap|-6,* reload bp, clobbered by equal call ldaq bp|2,*2 get cddr of list, staq bp|2 and make it the cdr eax3 -1,x3 decrement count tra del_loop-*,ic no_del: ldaq ap|-6,*2 staq ap|-6 set result to cdr of result. tra del_loop1-*,ic ret_del: ldaq ap|-8 eppap ap|-10 back up stack tra retrn1-*,ic segdef delq delq: eax3 -1 load infinite deletion count cmpx5 -4,du see if we got more than two args tze 3,ic if not, don't check third arg. eax0 fn_delq tsx6 get_count-*,ic get deletion count eppbp ap|-2 bp always points at thing to replace if car eq " to deleted object. eax2 2 allows cdrs to be easily taken. dloop: cmpx3 0,du see if any more are to be deleted. tze dq_end-*,ic if no more, return. dloop1: lda bp|0 load type of current list position. cana Atomic,dl see if we are at end of list. tnz dq_end-*,ic ldaq bp|0,* load car of list cmpaq ap|-4 see if eq to our first arg tnz no_dq-*,ic if no deletion to be done go to get cdr ldaq bp|0,*x2 load cdr of list staq bp|0 and make it current list, rplacd'ing in place. eax3 -1,x3 decrement deletion counter tra dloop-*,ic and loop back no_dq: eppbp bp|0,*2 go to cdr of list tra dloop1-*,ic and loop back dq_end: ldaq ap|-2 load result eppap ap|-4 pop args off stack tra retrn1-*,ic and return. " segdef rplaca rplaca: ldaq ap|-4 load first arg cana Atomic,dl and check for valid rplaca tze replace-*,ic if list, then go ahead. rplaca_tsx4: tsx4 bad_arg-*,ic signal error. staq ap|-4 replace argument, tra rplaca-*,ic and retry. replace: ldaq ap|-2 load replacement staq ap|-4,* and store in car of list ldaq ap|-4 eppap ap|-4 pop back stack tra retrn1-*,ic rplaca is type one subr. segdef rplacd rplacd: eax2 2 we are to replace cdr. (no checking is done either) ldaq ap|-2 load replacement staq ap|-4,*x2 and zap it into cons. ldaq ap|-4 load result eppap ap|-4 pop stack, tra bp|0 and return. segdef displace displace: lda ap|-4 load first argument cana Atomic,dl Make sure it's not atomic tze displace_ok-*,ic OK, go ahead displace_tsx4: tsx4 bad_arg-*,ic signal error. staq ap|-4 replace argument, tra displace-*,ic and retry. displace_ok: lda ap|-2 see if second argument is atomic cana Atomic,dl tnz displace_atom if so, replace with `(progn (,y)) ldaq ap|-2,* otherwise, get (car y) staq ap|-4,* (rplaca x (car y)) eax2 2 Now do the cdrs ldaq ap|-2,*x2 (cdr y) staq ap|-4,*x2 (rplacd x (cdr y)) ldaq ap|-4 return new x eppap ap|-4 tra retrn1-*,ic displace_atom: ldaq lisp_static_vars_$progn_atom staq ap|-4,* (rplaca x 'progn) eax7 4,x7 Make way for calling ncons sprilp ab|-4,x7 save lp stcd ab|-2,x7 and return location tra lisp_alloc_$ncons_ eax2 2 store in cdr staq ap|-2,*x2 (rplacd x (ncons y)) ldaq ap|-2 return new x eppap ap|-2 tra retrn1-*,ic " routine to get 3rd arg as a fixed number in x3. " it may signal a correctable error. " get_count: eppap ap|6,x5 make sure no more than three args exist. ldaq ap|-2 get count arg eppap ap|-2 chk_count:cmpa fixnum_type,dl tnz get_count_tsx4-*,ic cmpq 0,dl check for negative argument. tpl good_count-*,ic get_count_tsx4: tsx4 bad_arg-*,ic call bad argument signaller. tra chk_count-*,ic and try again. good_count: eax3 0,ql get count in x3 tra 0,x6 return " segdef setq setq: eppap ap|4 get room ldaq ab|nil get default return value. nxt_setq: lxl0 ap|-6 load type of fsubr arg. canx0 Atomic,du and check for end. tze more_setq-*,ic if no end continue. eppap ap|-6 pop off stack tra retrn1-*,ic and return more_setq:ldaq ap|-6,* load first of list. chk_name: cana Atsym,dl see if atomic. tnz good_atom-*,ic setq_tsx4: tsx4 bad_arg-*,ic signal bad argument. tra chk_name-*,ic and retry if new value returned. good_atom:cmpaq ab|nil see if trying to setq nil. tze set_nil-*,ic signal uncorrectable error if so. staq ap|-4 remember thing set. eppbp ap|-6,* get next of list eppbp bp|2,* .. ldaq bp|0 get value staq ap|-2 ldaq bp|2 get rest of list staq ap|-6 and leave for next time. eax7 4,x7 get room for call to eval eax5 -2 and set number of args sprilp ab|-4,x7 save our lp, which is same as eval's stcd ab|-2,x7 and save return address. tra |[eval_] call eval staq ap|-2,* setq the atom we saved. eppap ap|2 get back space for eval call. tra nxt_setq-*,ic segdef set set: ldaq ap|-4 load first arg. retry_set: cana Atsym,dl check atom. tnz set_atm-*,ic set_tsx4: tsx4 bad_arg-*,ic signal correctable error staq ap|-4 reset arg. tra retry_set-*,ic and try again set_atm: cmpaq ab|nil check for set of nil. tze set_nil-*,ic and signal error if so. ldaq ap|-2 load value. staq ap|-4,* and store it eppap ap|-4 pop stack tra retrn1-*,ic set_nil: eax7 2,x7 we want to signal error lda nihil_ex_nihile,dl sta ab|-2,x7 push code on stack spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code push eppap null_arg_list-*,ic short_call |[lisp_error_] drl 0,dl should never get here. even null_arg_list: oct 4 oct 0 one_arg: oct 2000004,0 " " procedure to signal the correctable bad argument condition. " called with tsx4, with aq containing bad argument, " x6 containing data which needs to be saved (as perhaps a return address) " and which returns with aq set to replacement value. " bad_arg: eppap ap|2 get room for arg to lisp_error_ staq ap|-2 and save value. eax7 4,x7 get some room on unmkd_pdl stx6 ab|-3,x7 save x6 for caller. sxl5 ab|-3,x7 also save x5 for lsubrs. stx4 ab|-4,x7 save our return address " get code for function name into q, based on our caller's " address in x4, except when called from get_count in which " case the value is already in x0 (with minus sign). cmpx4 get_count_tsx4+1,du tnz get_my_name-*,ic eaq 0,x0 qrs 18 tra got_name-*,ic get_my_name: eaq -name_tbl_len search table of tsx4 addresses. search_for_name: cmpx4 name_tbl,qu tze 4,ic found it eaq 1,qu not found, keep looking tnz search_for_name-*,ic tra got_name-*,ic " not found, will use zero " should'nt happen anyway ldq name_tbl,qu found, get code in low half qls 18 extend sign bit qrs 18 got_name: lda bad_arg_correctable,dl load error code staq ab|-2,x7 and push it spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code push eppap null_arg_list-*,ic short_call |[lisp_error_] eaa sp|16,* back up stack sprisp sb|stack_header.stack_end_ptr eppsp sb|0,au epbpab |[unmkd_ptr],* ldx7 |[unmkd_ptr]+1 eppap |[stack_ptr],* stz ab|in_pl1_code ldx4 ab|-2,x7 reload return address ldx6 ab|-1,x7 and x6 for caller. lxl5 ab|-1,x7 also x5 for lsubrs. eax7 -2,x7 ldaq ap|-2 reload new value eppap ap|-2 and reset stack. tra 0,x4 return to caller. even random_init: oct 267762113337,155256071112 "This is the initial value for the random number generator. segdef random Lisp lsubr to return a random number. "With no args it returns a random number, with an arg it resets to inital value. random: cmpx5 0,du See if there are any args (x5 contains -2*number_of_args). tze random0-*,ic If none, go to return a random number. ldaq ap|0,x5 get argument. chk_random: cmpaq ab|nil tze init_random if nil, restart sequence cmpa fixnum_type,dl see if fixnum tze random_bounded random_tsx4: tsx4 bad_arg staq ap|0,x5 store new val away. tra chk_random init_random: ldaq random_init get the initial value. staq |[hi_random] "And then store it. ldaq ap|-2 Get the argument, to return it. eppap ap|0,x5 Pop off the arg(s) from the marked pdl. tra retrn1-*,ic And go to the common return sequence. random0: eax0 retrn1 set return operator. random1: ldaq |[hi_random] "First load the aq with two numbers, H(q) and L(q). sta |[lo_random] "The next state for the low part, L(q+1), is just the high part, H(q). lrl 1 Now right shift everthing in the aq one cell. erq |[lo_random] "Do an exclusive or between H(q) and L(q) that has been right-shifted. stq |[hi_random] "And this becomes the high part. "Or H(q+1) = H(q) +O ((2**36)*H(q) + L(q))/2 lda fixnum_type,dl We will return H(q+1) as a number. tra 0,x0 return to caller. random_bounded: lda ap|1,x5 load argument. cmpa 2,dl tmi ret_zero if arg < 2 then always return zero. tsx0 random1 cmpq 0,dl check for negative result. tpl 2,ic negl 0 negate q...note that a cannot be 4000000000.. div ap|1,x5 divide by the argument. lrl 36 shift remainder to q lda fixnum_type,dl eppap ap|0,x5 pop stack tra retrn1 ret_zero: ldaq fixnum_zero eppap ap|0,x5 tra retrn1 " " table of tsx4 addresses (du) and corresponding function name codes (dl) zero rplaca_tsx4+1,fn_rplaca zero setq_tsx4+1,fn_setq zero set_tsx4+1,fn_set zero oddp_tsx4+1,fn_oddp zero random_tsx4+1,fn_random zero getch_tsx4+1,fn_getchar zero getch_tsx4_2+1,fn_getchar zero zerop_tsx4+1,fn_zerop zero displace_tsx4+1,fn_displace name_tbl: equ name_tbl_len,9 end  lisp_reader_alm_.alm 11/05/86 1612.7r w 11/04/86 1039.2 232551 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " alm garbage for reader " 29 Nov 1972, D. A. Moon " Modified 28 Mar 73 for new I/O kludge " Modified 4 August 1973 for fast chrct, linel " **** this modification makes this routine incompatible with the 645 processor " modified 19 October 1973 by DAM for new syntax bits, new iochan format " modified 74.09.21 by DAM to accept t for tty as well as nil segdef powers_of_ten entry left_shift,tyi,tyipeek,readch,ascii_alm,tyo_alm tempd argl(4) temp temp equ save_bp,26 the arg-ptr save loc (kludge) bool NL,12 newline segref lisp_static_vars_,obarray,ctrlW,tty_output_chan,read_print_nl_sync,rdr_state,ctrlQ,tty_input_chan segref lisp_static_vars_,ctrlR,infile,outfiles,readtable equ status_terpri,296 offset of status_terpri in read_table " use of registers " x0 calls by tsx0 " x1 -> eppbp ext_entry instruction for call_out " x2 temp " x3 temp " x4 -> failure exit, which switches to pl1 version of same routine when hard case " x5 -2*nargs for lsubrs " x6 temp " x7 unmkd pdl ptr " bp -> iochan block. Also ptr temp " ap mkd pdl ptr " lp -> our linkage section " lb temporary " q character (right adjusted) " aq lisp object include lisp_iochan include lisp_array_fmt include lisp_stack_seg include stack_header include lisp_object_types include lisp_error_codes segdef listen " random subr for compatibility listen: eppbp tty_input_chan,* " get number of chars in input buffer ldq bp|iochan.iolength sbq bp|iochan.ioindex tpl 2,ic " make sure positive (?) ldq 0,dl lda fixnum_type,dl tra ab|return_op,* " fast versions of tyi, tyipeek, readch. If trouble is encountered, the slow versions " in lisp_reader_ are called. These are type 1 subrs. tyi: eax4 real_tyi establish failure exit tsx0 set_inp tsx0 rdinch aos bp|iochan.ioindex lda fixnum_type,dl " the character is in the q reg eppap ap|0,x5 tra ab|return_op,* tyipeek: eax4 real_tyipeek establish failure exit cmpx5 0,du any args? tnz 0,x4 yes, too hard to do this version of tyipeek here. "no one ever uses it anyway so no loss in efficiency. tsx0 set_inp tsx0 rdinch lda fixnum_type,dl tra ab|return_op,* " come here if need to use pl1 version of function real_tyi: tsx1 copout eppbp |[real_tyi] real_tyipeek: tsx1 copout eppbp |[real_tyipeek] real_readch: tsx1 copout eppbp |[real_readch] real_ascii: tsx1 call_out0 eppbp |[ascii] real_tyo: tsx1 copout eppbp |[tyo] copout: eaq 0,x5 put -2*nargs as lisp number qrs 18 lda fixnum_type,dl eppap ap|2 staq ap|-2 " routine to call out to pl1 program. " called with x1 -> eppbp instrruction for entry to be called " returns by ab|return_op call_out0: tsx0 call_out tra ab|return_op,* " this one returns to x0 call_out: spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code push " this macro better not change x0, x1 !! xec 0,x1 load bp with addr of ext entry call bp|0 must make null arg list, save index regs epbpab |[unmkd_ptr],* eaa sp|16,* sprisp sb|stack_header.stack_end_ptr eppsp sb|0,au ldx7 |[unmkd_ptr]+1 eppap |[stack_ptr],* stz ab|in_pl1_code ldaq ap|-2 eppap ap|-2 tra 0,x0 " ascii function ascii_alm: eax4 real_ascii establish failure exit ldaq ap|-2 cmpa fixnum_type,dl check for valid arg tnz 0,x4 cmpq 128,dl trc 0,x4 tsx0 get_sing_char eppap ap|-2 tra ab|return_op,* readch: eax4 real_readch establish failure exit tsx0 set_inp tsx0 rdinch epplb bp|0 save ptr to iochan through get_sing_char tsx0 get_sing_char eppap ap|0,x5 now return the character atom from the obarray aos lb|iochan.ioindex bumping iochan.ioindex tra ab|return_op,* " routine to get character atom from obarray, character in q " uses bp,aq,x6 get_sing_char: qls 1 eax3 0,ql for later use in indexing the obarray ldaq obarray,* is obarray really an array? cana Array,dl tze 0,x4 no, fail eppbp obarray,* -> atom eppbp bp|0,* -> array_info ldx6 bp|array_info.type cmpx6 Obarray_array,du tnz 0,x4 no, fail eppbp bp|array_data_ptr,* ldaq bp|511*2,x3 valid obarray, examine char obj cell cmpaq ab|nil has char obj been interned yet? tze 0,x4 no, fail tra 0,x0 yes, succeed " tyo function " this is a simplified version of the character output code in lisp_print_ tyo_alm: eax4 real_tyo establish failure exit ldaq ap|0,x5 make sure argument is OK cmpa fixnum_type,dl has to be a number, tnz 0,x4 cmpq 128,dl between 0 and 128. trc 0,x4 (tricky) " now find out what destinations we're going to send the output to eax2 -1 clear sent-to-tty flag eppap ap|6,x5 leave three cells for munging around in " the character to be output is in ap|-5 " this is dump_character from lisp_print_.pl1 " but it has get_dest in it too, done in line instead of by setting flags output_char: cmpx5 -2,du should maybe go to tty? tnz tyo.3 ldaq ctrlW,* yes, if ^w allows it cmpaq ab|nil tnz 2,ic tsx3 to_tty yes. " now send output to dest spec by ^r, outfiles ldaq ctrlR,* cmpaq ab|nil tze tyo.5 no. ldaq outfiles,* tra to_list_join "this is code to put to special channel (tyo with 2 args) tyo.3: ldaq ap|-4 special channel, look at it cana lisp_ptr.type,dl list? tze to_list yes, go do a do loop to_one: "no, just output to one tsx3 to_file tra tyo.5 "this is do loop to output to a list of files in ap|-4 to_list: ldaq ap|-4,* tsx3 to_file eppbp ap|-4,* ldaq bp|2 to_list_join: staq ap|-4 cana lisp_ptr.type,dl more to list? tze to_list tyo.5: "all done, return t. ldaq ab|true eppap ap|-6 tra ab|return_op,* to_file: cmpaq ab|nil tze to_tty cmpaq ab|true tze to_tty cana File,dl tnz to_file_ok staq ap|-2 eax7 2,x7 lda bad_output_dest,dl sta ab|-2,x7 eax1 lisp_error_ tsx0 call_out ldaq ap|-2 tra to_file lisp_error_: eppbp |[lisp_error_] to_file_ok: easpbp 0,au eawpbp 0,qu ldq ap|-5 tsx6 to_anyplace tra tyo_nl_maybe to_tty: eax2 1,x2 check to-tty-flag tnz 0,x3 only send to tty once ldq ap|-5 eppbp tty_output_chan,* szn read_print_nl_sync tze 3,ic cmpq NL,dl tze 2,ic tsx6 to_anyplace stz read_print_nl_sync tyo_nl_maybe: epplb readtable,* -> value cell of atom readtable epplb lb|0,* -> readtable array szn lb|status_terpri put status_terpri in indicators tmi flush2 (status terpri) /= nil, no extra NL. lda bp|iochan.flags cana iochan.image_mode,du tnz flush2 lda bp|iochan.linel tze flush2 cmpa bp|iochan.charpos tpnz flush2 linel > charpos, don't need an extra NL ldq NL,dl type extra NL. tsx6 to_anyplace lda iochan.extra_nl_done,du orsa bp|iochan.flags flush2: lda bp|iochan.flags cana iochan.seg,du tnz 0,x3 cana iochan.charmode,du tnz 5,ic cana iochan.interactive,du tze 0,x3 cana iochan.nlsync,du tze 0,x3 cana iochan.write,du tnz 0,x3 szn bp|iochan.ioindex tmoz 0,x3 eax0 0,x3 " empty a buffer, pointed at by bp. return to x0 empty_buff: eax4 0,ql save the character in the q reg tsx1 ipush eppbp sp|save_bp,* eppap sp|save_bp spriap argl+2 eppap q1qb spriap argl+4 eppap temp spriap argl+6 lda bp|iochan.flags cana not_ok_to_write,du tze flush3 eppbp |[fix_not_ok_iochan] tsx1 icall szn temp tnz popret flush3: eppap |[stack_ptr],* epbpab ap|0 ldaq ab|nil staq ap|-2 eppap ap|-2 spriap argl+4 eppbp |[end_of_block] tsx1 icall popret: eaq 0,x4 reload the char into q from x4 qrl 18 lxl4 temp tsx1 ipop tra 0,x0 q1qb: oct 400000000000 "1"b even three_args: zero 6,4 zero 0,0 ipush: spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code eppap bp|0 make bp get saved in sp|26 (= sp|save_bp) push tra 0,x1 ipop: eppbp sp|save_bp,* restore bp epbpab |[unmkd_ptr],* eaa sp|16,* sprisp sb|stack_header.stack_end_ptr eppsp sb|0,au ldx7 |[unmkd_ptr]+1 eppap |[stack_ptr],* stz ab|in_pl1_code tra 0,x1 icall: ldaq three_args staq argl call bp|0(argl) tra 0,x1 to_any_ch_code: cmpx4 0,du tnz 0,x6 tra to_anyplace_aa to_anyplace: lda bp|iochan.flags cana not_ok_to_write,du tze 3,ic tsx0 empty_buff tra to_any_ch_code lda bp|iochan.ioindex cmpa bp|iochan.iolength tze -4,ic lda flag_reset_mask,du ansa bp|iochan.flags to_anyplace_aa: lda bp|iochan.ioindex eax4 0,al anx4 3,du ars 2 epplb bp|iochan.ioptr,*al eaa 0,ql save char for compares xec qls,x4 align char in q xec stbq,x4 aos bp|iochan.ioindex " check for control character, if so do specially good things. cmpa =o40,du tmi tyo_control_table,au* control character, do specially good things. cmpa =o177,du tpl 0,x6 rubout - don't advance charpos aos bp|iochan.charpos normal character, advance charpos (caller checks for endofline) tra 0,x6 tyo_control_table: arg 0,x6 null - do nothing arg 0,x6 ^A - do nothing arg 0,x6 ^B - do nothing arg 0,x6 ^C - do nothing arg 0,x6 ^D - do nothing arg 0,x6 ^E - do nothing arg 0,x6 ^F - do nothing arg 0,x6 ^G - do nothing arg tyo_backspace BS - subtract one from charpos arg tyo_tab HT - adjust charpos to next tabstop arg tyo_newline NL - adjust charpos, linenum arg 0,x6 ^K - do nothing arg tyo_newpage NP - adjust charpos, linenum, pagenum arg tyo_car_ret CR - adjust charpos arg 0,x6 ^N - do nothing arg 0,x6 ^O - do nothing arg 0,x6 ^P - do nothing arg 0,x6 ^Q - do nothing arg 0,x6 ^R - do nothing arg 0,x6 ^S - do nothing arg 0,x6 ^T - do nothing arg 0,x6 ^U - do nothing arg 0,x6 ^V - do nothing arg 0,x6 ^W - do nothing arg 0,x6 ^X - do nothing arg 0,x6 ^Y - do nothing arg 0,x6 ^Z - do nothing arg 0,x6 $O - do nothing arg 0,x6 \034 - do nothing arg 0,x6 \035 - do nothing arg 0,x6 \036 - do nothing arg 0,x6 \037 - do nothing tyo_newline: stz bp|iochan.charpos lda iochan.nlsync,du orsa bp|iochan.flags aos bp|iochan.linenum lda bp|iochan.pagel tze 0,x6 0 pagel = infinite cmpa bp|iochan.linenum page exceeded? tpnz 0,x6 no, return tyo_newpage: stz bp|iochan.charpos NP causes return to left margin stz bp|iochan.linenum aos bp|iochan.pagenum advance to next page " page overflow - invoke endpagefn lda bp|iochan.flags cana iochan.interactive,du if this is the tty, can't endpage tnz 0,x6 ldaq bp|iochan.function cmpaq ab|nil tze 0,x6 no endpagefn - leave eax5 -4 eppap ap|4 staq ap|-4 function to apply eax7 6,x7 prepare type-1 call spribp ab|-2,x7 put type bits in bp ldaq ab|-2,x7 ora File,dl staq ap|-2 argument to endpagefn is the file object " assume can't happen to tty sprilp ab|-4,x7 stx6 ab|-6,x7 save registers 3 and 6 stx3 ab|-5,x7 epplp ab|system_lp,* stcd ab|-2,x7 tra |[funcall] ldx6 ab|-2,x7 restore registers 3 and 6 ldx3 ab|-1,x7 eax7 -2,x7 pop extraneous cruft off unmarked stack tra 0,x6 tyo_backspace: lca 1,dl szn bp|iochan.charpos tze 2,ic asa bp|iochan.charpos tra 0,x6 tyo_tab: ldq bp|iochan.charpos adq 10,dl div 10,dl mpy 10,dl stq bp|iochan.charpos tra 0,x6 tyo_car_ret: stz bp|iochan.charpos tra 0,x6 " xec vectors for storing char from q into word pointed at by sn,wo=lb, co=x4 qls: qls 27 qls 18 qls 9 nop 0,du stbq: stbq lb|0,40 stbq lb|0,20 stbq lb|0,10 stbq lb|0,04 "fast type-0 lsubrs to examine and modify certain file-object attributes. segdef chrct,linel,charpos,pagel,linenum,pagenum chrct: tsx1 process_file_arg call common routine eppbp |[chrct] instruction to get to pl1 code if can't do it here xed pick_up_chrct instruction to load the value into q, lb -> iochan xed put_down_chrct instruction to store q into the value, lb -> iochan even pick_up_chrct: ldq lb|iochan.linel convert charpos to chrct sbq lb|iochan.charpos put_down_chrct: ldq lb|iochan.linel convert chrct to charpos xed *+1 sbq ap|-1 (chrct is known to be here as well as in q) stq lb|iochan.charpos linel: tsx1 process_file_arg eppbp |[linel] ldq lb|iochan.linel stq lb|iochan.linel charpos: tsx1 process_file_arg eppbp |[charpos] ldq lb|iochan.charpos stq lb|iochan.charpos pagel: tsx1 process_file_arg eppbp |[pagel] ldq lb|iochan.pagel stq lb|iochan.pagel linenum: tsx1 process_file_arg eppbp |[linenum] ldq lb|iochan.linenum stq lb|iochan.linenum pagenum: tsx1 process_file_arg eppbp |[pagenum] ldq lb|iochan.pagenum stq lb|iochan.pagenum process_file_arg: cmpx5 -2,du get entry? tnz process_file_arg_2 no. ldaq ap|-2 yes, get file object cmpaq ab|nil tty? tze process_file_arg_nil cmpaq ab|true tze process_file_arg_nil cana File,dl tze process_file_arg_err epplb ap|-2,* no, pick up ptr to file object process_file_arg_nil_a: xec 1,x1 pick up value to be gotten lda fixnum_type,dl " tra popaj and return popaj: eppap ap|0,x5 pop off arguments. tra bp|0 and return to caller process_file_arg_nil: tsx2 get_file_object_of_nil tra process_file_arg_nil_a get_file_object_of_nil: link tty_output_chan_l,|[tty_output_chan],* epplb ab|system_lp,* epplb lb|tty_output_chan_l,* lb := lisp_static_vars_$tty_output_chan tra 0,x2 process_file_arg_err: " " can't do it here, escape out to the pl1 code " first must pretend we were a type-1 subr eax7 4,x7 spribp ab|-2,x7 sprilp ab|-4,x7 " now go away to pl1 epplp ab|system_lp,* tra copout 0,x1 is eppbp instruction to pl1 version process_file_arg_2: cmpx5 -4,du called with 2 args tnz process_file_arg_err ldaq ap|-4 file-object argument cmpaq ab|nil tze process_file_arg_2_nil cmpaq ab|true tze process_file_arg_2_nil cana File,dl tze process_file_arg_err epplb ap|-4,* process_file_arg_3: ldaq ap|-2 pick up number to be stored cmpa fixnum_type,dl tnz process_file_arg_err xec 2,x1 do the store tra popaj and return (result = 2nd arg is in aq) process_file_arg_2_nil: tsx2 get_file_object_of_nil tra process_file_arg_3 " routines copied from lisp_reader_ " set_inp sets bp to the appropriate iochan. If input is from a read list " or if end of file or end of buffer has been reached, returns to 0,x4 " If successful, returns to 0,x0. set_inp: ldq rdr_state check for macro char in readlist causing special case cmpq 2,dl tze 0,x4 yes, can't handle it here - go to lisp_reader_ " look for special channel specified by an argument eax3 0,x5 set up to scan arg list tze cke cka: ldaq ap|0,x3 cana File,dl tnz spchan cmpaq ab|nil tze set_inp_tty cmpaq ab|true tze set_inp_tty eax3 2,x3 tnz cka cke: ldaq ctrlQ,* cmpaq ab|nil tnz uread set_inp_tty: eppbp tty_input_chan,* set_inp_aa: ldq bp|iochan.ioindex cmpq bp|iochan.iolength tpl 0,x4 EOF - can't handle it here tra 0,x0 WIN. spchan: eppbp ap|0,x3* tra set_inp_aa uread: ldaq |[infile],* cana File,dl tze set_inp_tty easpbp 0,au eawpbp 0,qu tra set_inp_aa " rdinch reads in one character, returns it right justified in the q " bp must point at the iochan block. rdinch: lda bp|iochan.ioindex ldq 0,du lrs 2 divide by 4 qrl 36-2 right justify the remainder lda bp|iochan.ioptr,*al get word containing character lrl shifts,ql* right justify the character anq =o177,dl mask off to (7 bit) character cmpq =o036,dl bsg ctrl prefix? tze 0,x4 yes, only PL/I reader handles this. cmpx4 real_tyipeek,du don't do vertical motion cruft if tze 0,x0 this is tyipeek. " at this point character is in q, bp -> iochan. we handle vertical motion here. lda initial_readtable,ql this is kludgy way to test for NL and NP cana 2000,du vertical_motion right-shifted 18. tze 0,x0 ordinary character, return. cmpq NL,dl tnz vm01 " newline, bump linenum stz bp|iochan.charpos aos bp|iochan.linenum lda bp|iochan.pagel tze 0,x0 pagel of 0 = infinite cmpa bp|iochan.linenum end of page? tpnz 0,x0 no, return stz bp|iochan.linenum page exceeded, bump pagenum aos bp|iochan.pagenum tra 0,x0 NOTE - it is not necessary to call endpagefn for input files. vm01: cmpq 12,dl NP - this check is unnecc but do it anyway tnz 0,x0 stz bp|iochan.charpos adnace to new page stz bp|iochan.linenum aos bp|iochan.pagenum tra 0,x0 shifts: arg 27+36 arg 18+36 arg 9+36 arg 0+36 left_shift: lda ap|4,* get shift count " - should check for bounds here. ldq ap|2,* get number to be shifted qls 0,al shift it the right amount stq ap|2,* put it back short_return and exit " table of double floating powers of ten, from 10**-38 up to 10**+38 even powers_of_ten: oct 404663437347,325170710457 oct 414420163520,505213435275 oct 422524220444,626456344554 oct 430651264555,774172035707 oct 440411660744,575514222534 oct 446514235135,735037267263 oct 454637304365,324247145140 oct 464403472631,304550377174 oct 472504411377,565702477033 oct 500625513677,523263216642 oct 506773036657,450140062412 oct 516474723215,571074037446 oct 524614110061,127313047357 oct 532757132075,355175661253 oct 542465370246,324216516653 oct 550602666320,011262242426 oct 556743444004,013536713133 oct 566456166402,407233236771 oct 574571624103,111102106567 oct 602730171123,733322530325 oct 612447113564,351103527205 oct 620560736521,443324455046 oct 626715126245,754211570257 oct 636440165747,563526053155 oct 644550223341,520453466010 oct 652702270232,044566403412 oct 662431363140,226752042146 oct 670537657770,274544452600 oct 676667633766,353675565340 oct 706422701372,023326451314 oct 714527461670,430214163577 oct 722655376246,536257220537 oct 732414336750,132755432333 oct 740517426542,161550741022 oct 746643334272,616103131227 oct 756406111564,570651767636 oct 764507534121,727024365606 oct 772631463146,314631463147 oct 002400000000,000000000000 oct 010500000000,000000000000 oct 016620000000,000000000000 oct 024764000000,000000000000 oct 034470400000,000000000000 oct 042606500000,000000000000 oct 050750220000,000000000000 oct 060461132000,000000000000 oct 066575360400,000000000000 oct 074734654500,000000000000 oct 104452013710,000000000000 oct 112564416672,000000000000 oct 120721522450,400000000000 oct 130443023471,240000000000 oct 136553630407,510000000000 oct 144706576511,432000000000 oct 154434157115,760200000000 oct 162543212741,354240000000 oct 170674055531,647310000000 oct 200425434430,110475000000 oct 206532743536,132614200000 oct 214661534465,561357240000 oct 224417031701,446725444000 oct 232522640261,760512755000 oct 240647410336,354635550200 oct 250410545213,024002441120 oct 256512676455,631003151344 oct 264635456171,177204003635 oct 274402374713,617422402302 oct 302503074076,563327102762 oct 310623713116,320214723556 oct 316770675742,004260110511 oct 326473426555,202556055315 oct 334612334310,443311470600 oct 342755023372,554174006740 oct 352464114134,543515404254 oct 360601137163,674440705327 oct 366741367020,653551066614 oct 376454732312,413241542167 """ here is the initial readtable, extracted from lisp_reader_init_.pl1 segdef initial_readtable " NB: the macro_table portion is omitted, and must " be supplied by anyone who copies this table into a LISP array. " define syntax bits bool forcefeed,4000000000 (ITS) bool vertical_motion,2000000000 NL, NP bool string_quote_exp,1000000000 ", E bool special,400000000 bool single_char_object,200000000 standalone pname bool blank,100000000 space, tab, comma, etc. bool lparn,40000000 (, super-( bool dotted_pair_dot,20000000 . for cons bool rparn,10000000 ), super-) bool macro,4000000 character macro bool slashifier,2000000 escape char bool rubout,1000000 (ITS) bool slash_if_first,400000 print control bool decimal_point,200000 . for numbers bool slash_if_not_first,100000 print control bool slash_output,500000 .. bool bit12,40000 changes meaning of other bits bool splice,40000 bool shift_scale,20000 ^ or _ bool plus_minus,10000 + or - bool digit,4000 0,...,9 bool extd_alpha,2000 random chars as alpha bool alpha,1000 alphabetic """ Here are the 132 syntax table entries initial_readtable: vfd 36/special+slash_output \000 vfd 36/special+slash_output ^A vfd 36/special+slash_output ^B - these random ctrl chars are ignored vfd 36/special+slash_output ^C vfd 36/special+slash_output ^D vfd 36/special+slash_output ^E vfd 36/special+slash_output ^F vfd 36/special+slash_output ^G vfd 36/extd_alpha BS - allow underlined pnames vfd 36/special+blank+slash_output HT vfd 36/special+blank+vertical_motion+slash_output NL vfd 36/special+blank+slash_output VT vfd 36/special+blank+vertical_motion+slash_output NP vfd 36/special+blank+slash_output CR vfd 36/special+slash_output ^N - more worthless control chars vfd 36/special+slash_output ^O vfd 36/special+slash_output ^P vfd 36/special+slash_output ^Q vfd 36/special+slash_output ^R vfd 36/special+slash_output ^S vfd 36/special+slash_output ^T vfd 36/special+slash_output ^U vfd 36/special+slash_output ^V vfd 36/special+slash_output ^W vfd 36/special+slash_output ^X vfd 36/special+slash_output ^Y vfd 36/special+slash_output ^Z vfd 36/extd_alpha altmode vfd 36/special+slash_output \034 vfd 36/special+slash_output \035 vfd 36/special+slash_output \036 vfd 36/special+slash_output \037 vfd 36/special+blank+slash_output SP vfd 36/extd_alpha ! vfd 36/special+string_quote_exp+bit12+slash_output " vfd 36/extd_alpha # vfd 36/extd_alpha $ vfd 36/extd_alpha % vfd 36/extd_alpha & vfd 36/special+macro+slash_output ' vfd 36/special+lparn+slash_output ( vfd 36/special+rparn+slash_output ) vfd 36/extd_alpha * vfd 36/slash_if_first+plus_minus + vfd 36/special+blank+slash_output , vfd 36/slash_if_first+plus_minus+bit12 - vfd 36/special+dotted_pair_dot+slash_output+decimal_point . vfd 36/special+slashifier+slash_output / vfd 36/slash_if_first+digit 0 vfd 36/slash_if_first+digit 1 vfd 36/slash_if_first+digit 2 vfd 36/slash_if_first+digit 3 vfd 36/slash_if_first+digit 4 vfd 36/slash_if_first+digit 5 vfd 36/slash_if_first+digit 6 vfd 36/slash_if_first+digit 7 vfd 36/slash_if_first+digit 8 vfd 36/slash_if_first+digit 9 vfd 36/extd_alpha : vfd 36/special+macro+slash_output+splice semicolon vfd 36/extd_alpha < vfd 36/extd_alpha = vfd 36/extd_alpha > vfd 36/extd_alpha ? vfd 36/extd_alpha @ vfd 36/alpha A vfd 36/alpha B vfd 36/alpha C vfd 36/alpha D vfd 36/string_quote_exp+alpha E vfd 36/alpha F vfd 36/alpha G vfd 36/alpha H vfd 36/alpha I vfd 36/alpha J vfd 36/alpha K vfd 36/alpha L vfd 36/alpha M vfd 36/alpha N vfd 36/alpha O vfd 36/alpha P vfd 36/alpha Q vfd 36/alpha R vfd 36/alpha S vfd 36/alpha T vfd 36/alpha U vfd 36/alpha V vfd 36/alpha W vfd 36/alpha X vfd 36/alpha Y vfd 36/alpha Z vfd 36/extd_alpha [ vfd 36/extd_alpha \ vfd 36/extd_alpha ] vfd 36/extd_alpha+shift_scale ^ vfd 36/extd_alpha+shift_scale+bit12 _ vfd 36/extd_alpha ` vfd 36/alpha a vfd 36/alpha b vfd 36/alpha c vfd 36/alpha d vfd 36/string_quote_exp+alpha e vfd 36/alpha f vfd 36/alpha g vfd 36/alpha h vfd 36/alpha i vfd 36/alpha j vfd 36/alpha k vfd 36/alpha l vfd 36/alpha m vfd 36/alpha n vfd 36/alpha o vfd 36/alpha p vfd 36/alpha q vfd 36/alpha r vfd 36/alpha s vfd 36/alpha t vfd 36/alpha u vfd 36/alpha v vfd 36/alpha w vfd 36/alpha x vfd 36/alpha y vfd 36/alpha z vfd 36/extd_alpha { vfd 36/special+macro+slash_output | vfd 36/extd_alpha } vfd 36/extd_alpha ~ vfd 36/special+slash_output rubout vfd 36/special+slashifier+slash_output "pseudo slash" vfd 36/special+lparn+slash_output "pseudo left parenthesis" vfd 36/special+rparn+slash_output "pseudo right parenthesis" zero special+blank+slash_output "pseudo space" """ Here is the translation table dec 0 dec 1 dec 2 dec 3 dec 4 dec 5 dec 6 dec 7 dec 8 dec 9 dec 10 dec 11 dec 12 dec 13 dec 14 dec 15 dec 16 dec 17 dec 18 dec 19 dec 20 dec 21 dec 22 dec 23 dec 24 dec 25 dec 26 dec 36 translate altmode to dollar sign dec 28 dec 29 dec 30 dec 31 dec 32 dec 33 dec 34 dec 35 dec 36 dec 37 dec 38 dec 1 standard quote macro dec 40 dec 41 dec 42 dec 43 dec 44 dec 45 dec 46 dec 47 dec 48 dec 49 dec 50 dec 51 dec 52 dec 53 dec 54 dec 55 dec 56 dec 57 dec 58 dec 2 standard semicolon macro dec 60 dec 61 dec 62 dec 63 dec 64 dec 65 dec 66 dec 67 dec 68 dec 69 dec 70 dec 71 dec 72 dec 73 dec 74 dec 75 dec 76 dec 77 dec 78 dec 79 dec 80 dec 81 dec 82 dec 83 dec 84 dec 85 dec 86 dec 87 dec 88 dec 89 dec 90 dec 91 dec 92 dec 93 dec 94 dec 95 dec 96 dec 97 dec 98 dec 99 dec 100 dec 101 dec 102 dec 103 dec 104 dec 105 dec 106 dec 107 dec 108 dec 109 dec 110 dec 111 dec 112 dec 113 dec 114 dec 115 dec 116 dec 117 dec 118 dec 119 dec 120 dec 121 dec 122 dec 123 dec 3 standard vertical bar macro dec 125 dec 126 dec 127 dec 47 pseudo slash dec 40 pseudo ( dec 41 pseudo ) dec 32 pesudo space end  lisp_save_alm_.alm 07/06/83 0937.8r w 06/29/83 1542.8 14850 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** name lisp_save_alm_ " This routine fixes all the its pairs in a segment to have real segment numbers " it is called by the unsaver. " It is written in alm for extra speed. (10 Nov 1973, DAM) even al_qu_mask: zero 0,-1 zero -1,0 segdef lisp_save_alm_ lisp_save_alm_: " arg 1: ptr of seg to do, chain header " arg 2: address of pseudo-segment number table, must be unpacked pointers with ring numbers. " also it relies on the fact that it is bound in with lisp_subr_tv_ epplb |[tv_begin] eppbb ap|4,* pick up ptr to segno_table eppbb bb|0,* eppap ap|2,* -> ptr to seg epbpbp ap|0,* base of segment to be processed eax0 ap|0,* chain header tze return if no chain, return to lisp_save_ sprilb ap|0 clobber argument with ptr to sys tv for use later loop: ldaq bp|0,x0 its pair to be fixed up eax1 0,au pseudo segment 0? tnz g0001 no eaq lb|0,qu yes. relocate offset into tv + clear chain field ora ap|0 set system tv segno + ring field + or in its which is ok. tra g0002 g0001: adx1 bp|0,x0 x1 := 2 x pseudo segno anaq al_qu_mask au := 0, ql := 0 ora bb|-2,x1 set segno + ring + or in its which is OK g0002: lxl1 bp|1,x0 pick up next chain staq bp|0,x0 fix up pointer eax0 0,x1 move chain to right register + check if 0 tnz loop return: short_return end  lisp_static_vars_.alm 07/06/83 0937.8r w 06/29/83 1542.8 131850 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " " last modified October 1982 to add progn atom. " use lk join /link/lk even segdef lisp_static_vars_ lisp communications area lisp_static_vars_: its -1,1,n cclist_ptr (totally obsolete) """ Table of Contents segdef maknum_table_ptr segdef maknum_data segdef maknum_next segdef maknum_mask segdef maknum_left segdef garbage_collect_soon segdef quit_handler_flag segdef binding_reversal_flag segdef evalhook_status,evalhook_atom segdef gc_time segdef gc_mark_bits segdef gcmin,gcmin_fraction,gcsize,gcmax segdef no_snapped_links segdef space_names_atom segdef transparent switch to make lisp transparent to quits segdef read_print_nl_sync segdef rdr_state,garbage_collect_inhibit,rdr_ptr,rdr_label segdef masked segdef emptying_buffers non-negative when lisp_default_handler_ is emptying all stream output buffers segdef pending_ctrl segdef i_am_gcing segdef saved_environment_dir segdef hi_random segdef lo_random segdef ignore_faults segdef stack_ptr segdef unmkd_ptr pointer to top of unmkd_stack segdef frame_ptrs the following 6 things must be kept in the same order, segdef binding_top pointer to top of binding block chain segdef err_recp segdef prog_frame 7 pointers to threaded lists of frames in unmarked stack segdef err_frame segdef catch_frame segdef eval_frame stuff kept by eval if *rset t segdef unwp_frame head of unwind-protect frame list segdef arg_list_ptr needed by status jcl segdef top_level the top-level read-eval-print loop segdef argatom used to hold arg list of lexpr(not really an atom) segdef iochan_list list of all opened iochans (files) segdef subr_block_list list of all new (fasload) subr blocks segdef garbage_collected_ptrs segdef first_value_atom for (status system) segdef obarray segdef atomic_constants segdef nil segdef t_atom segdef ctrlD segdef ctrlQ segdef ctrlR segdef ctrlW segdef user_intr_array segdef STAR atom * segdef PLUS atom + segdef MINUS atom - segdef SLASH atom // segdef base segdef ibase segdef readtable segdef stnopoint atom *nopoint segdef tty_atom segdef errlist segdef ctrlA the atom ^a, whose value is interrupted by the CTRL/a input segdef prinlevel,prinlength segdef last_value_atom for (status system) segdef value_atom segdef readeof_atom for lisp_error_, eof_in_object err segdef s_atom segdef dollar_p_atom segdef quote_atom segdef array_atom segdef array segdef pname_atom segdef string_atom segdef fixnum_atom segdef fixnum segdef external segdef flonum_atom segdef flonum segdef random_atom segdef bignum_atom segdef list_atom segdef go_atom,return_atom,pdlframe_atom segdef alphalessp_atom segdef function_properties segdef lambda,label,subr,lsubr,fsubr,expr,fexpr segdef funarg,macro,autoload,qarg,qsetarg,qlstfy segdef quotient segdef evalframe_atom segdef arrayindex segdef setq_atom segdef question_mark segdef nouuo_flag,noret_flag segdef quote_macro,semicolon_macro special flags for builtin macros, used by rdr segdef runtime_atom,time_atom segdef comment_atom,declare_atom segdef close,deletef,filepos,infile,instack,mergef,open segdef outfile,outfiles,rename,stream segdef dsk_atom,crunit_atom,uread_atom,uwrite_atom,old_io_defaults segdef args for err_break routine in lisp_subr_tv_ segdef star_rset segdef err_atom,eval_atom,apply_atom,princ_atom,prin1_atom,print_atom segdef prin1 segdef zunderflow segdef toplevel toplevel function ptr segdef divov_flag segdef plus_status segdef status_gctwa segdef tty_input_chan -> iochan block for user_input stream segdef tty_output_chan segdef property_list_of_nil segdef number_gc_ptrs segdef number_of_atomic_constants segdef atomic_constants_names segdef template segdef template_size segdef subsys_recurse_save_size segdef cur_stat_seg segdef cur_stat_pos segdef gc_unwinder_kludge segdef activate_gc_unwinder_kludge segdef cleanup_list_exists segdef cleanup_list segdef defun,expr_hash segdef vertical_bar_macro,eof_atom,progn_atom segdef mulquit_state,mulpi_state segdef deferred_interrupt garbage_collect_soon: dec 0 garbage collection flag quit_handler_flag: oct 0 "1"b means quitting out of a quit handler even gc_time: dec 0 dec 0 gc_mark_bits: oct 525252000000 """ Bibop-compatible garbage collection parameters gcmin: dec 0.5 gcmin_fraction: oct 400000000000 bit(1) gcsize: dec 30000 gcmax: dec 1000000000 no_snapped_links: oct 0 flag, "1"b means there are no snapped links in any compiled subr blocks transparent: oct 0 read_print_nl_sync: dec 0 if this is non-zero, read has just read a newline, " and if print is to output one, it should suppress it. garbage_collect_inhibit: oct 0 set nonzero by interrupts masked: oct 0 "1"b if we are masked against alrm, cput, and ctrl chars " i.e. (nointerrupt t) mode. emptying_buffers: dec -1 i_am_gcing: oct 0 "1"b when garbage-collecting rdr_state:dec 0 0 = normal, 1 = ios_$read wait, 2 = readlist even rdr_ptr: its -1,1 -> current readlist rdr_label:its -1,1 label for abnormal exit from (tti wait) its -1,1 saved_environment_dir: aci " " aci " " aci " " aci " " even hi_random: oct 0 These are two words to store the random numbers "between calls to the function random. lo_random: oct 0 iochan_list: its -1,1 subr_block_list: its -1,1 list of all subr blocks binding_reversal_flag: oct 0 nonzero means can't interrupt because reversing a binding block evalhook_status: oct 0 see lisp_ even maknum_data: maknum_table_ptr: its -1,1 maknum_next: oct 0 maknum_mask: dec -1 maknum_left: oct 0 cleanup_list_exists:oct 0 1 => cleanup_list non-nil " (needed since might be in gc and can't look at it) activate_gc_unwinder_kludge: oct 0 flag that gc should do cleanup kludge mulquit_state: dec -1 handling of Multics quit condition mulpi_state: dec -1 handling of Multics program_interrupt condition deferred_interrupt: oct 0 we must poll interrupts when we leave (nointerrupt t) even pending_ctrl: oct 0 "1"b when in process of handling stacked-up "ctrl chars received while masked = 1. ignore_faults: dec 0 even cur_stat_seg: its -1,1 current static seg, used by make_lisp_subr_block_ cur_stat_pos: dec 0 height in seg that has been allocated even stack_ptr: its -1,1,n stack_ptr unmkd_ptr: its -1,1,n frame_ptrs: "since programs think this is an array. binding_top _m_u_s_t be first. binding_top: its -1,1,n err_recp: its -1,1 prog_frame: its -1,1 err_frame:its -1,1 catch_frame: its -1,1 eval_frame: its -1,1 unwp_frame: its -1,1 arg_list_ptr: its -1,1 top_level: its -1,1 a pl1 label is two pointers its -1,1 argatom: oct 0,0 double word zero for eval, arg.... gc_unwinder_kludge: its -1,1 target of unwindage through in-progress gc, its -1,1 has to be saved while gc is completed if cleanup list exists " """ Template for initialization of some of the above data use tx join /text/tx even template: its -1,1 cclist ptr dec 0 garbage_collect_soon oct 0 quit_handler_flag even dec 0,0 gc_time oct 525252000000 gc_mark_bits dec 0.5 gcmin oct 400000000000 gcmin_fraction dec 30000 gcsize dec 1000000000 gcmax oct 0 no_snapped_links oct 0 transparent dec 0 read_print_nl_sync oct 0 garbage_collect_inhibit oct 0 masked dec -1 emptying_buffers oct 0 i_am_gcing dec 0 rdr_state even its -1,1 rdr_ptr its -1,1 rdr_label its -1,1 .. " saved_environment_dir aci " " aci " " aci " " aci " " oct 0 hi_random oct 0 lo_random its -1,1 iochan_list its -1,1 subr_block_list oct 0 binding_reversal_flag oct 0 evalhook_status even its -1,1 maknum_table_ptr oct 0 dec -1 oct 0 oct 0 cleanup_list_exists oct 0 activate_gc_unwinder_kludge dec -1 mulquit_state dec -1 mulpi_state """ End of template template_size: zero 0,template_size-template use lk " garbage_collected_ptrs: first_value_atom: obarray: its -1,1 " the following is a table of pointers to atoms, which are needed as constants " by various system subrs. The pointers are inited by lisp_boot_ using " the table of names which appears below. These atom pointers are preserved " through a save/unsave. atomic_constants: nil: its -1,1,n t_atom: its -1,1,n pointer to atom t. external: its -1,1 the atom "external" ctrlD: its -1,1 ctrlQ: its -1,1 ctrlR: its -1,1 ctrlW: its -1,1 its -1,1 interrupt channel 0. (CTRL/@) user_intr_array: "pointers to atoms whose values are user interrupt service functions its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 its -1,1 STAR: its -1,1 PLUS: its -1,1 base: its -1,1 ibase: its -1,1 readtable: its -1,1 stnopoint:its -1,1 tty_atom: its -1,1 errlist: its -1,1 atom errlist, value used by errors. infile: its -1,1 instack: its -1,1 outfiles: its -1,1 zunderflow: its -1,1 uread_atom: its -1,1 uwrite_atom: its -1,1 old_io_defaults: its -1,1 ctrlA: its -1,1 star_rset: its -1,1 now -> the atom *rset prinlevel: its -1,1 prinlength: its -1,1 last_value_atom: value_atom: its -1,1 readeof_atom: its -1,1 s_atom: its -1,1 dollar_p_atom: its -1,1 quote_atom: its -1,1 points to the atom quote pname_atom: its -1,1 string_atom: its -1,1 fixnum: fixnum_atom: its -1,1 flonum: flonum_atom: its -1,1 random_atom: its -1,1 bignum_atom: its -1,1 list_atom: its -1,1 " constants needed by lisp_error_ go_atom: its -1,1 return_atom: its -1,1 pdlframe_atom: its -1,1 alphalessp_atom: its -1,1 "constants needed by the evaluator lambda: its -1,1 label: its -1,1 funarg: its -1,1 function_properties: subr: its -1,1 lsubr: its -1,1 fsubr: its -1,1 expr: its -1,1 fexpr: its -1,1 array: array_atom: its -1,1,n atom "array" macro: its -1,1 autoload: its -1,1 quotient: its -1,1 fail-act name qarg: its -1,1 qsetarg: its -1,1 qlstfy: its -1,1 evalframe_atom: its -1,1 atom evalframe, which is another name for pdlframe (used by that fcn) arrayindex: its -1,1 setq_atom: its -1,1 question_mark: its -1,1 the atom ?, used by array access error handler nouuo_flag: its -1,1 noret_flag: its -1,1 space_names_atom: "value=(list markedpdl unmarkedpdl) quote_macro: "used as indicator for quote macro char its -1,1 semicolon_macro: "indicator for semicolon macro char + value = (status features) its -1,1 runtime_atom: its -1,1 time_atom: its -1,1 comment_atom: its -1,1 declare_atom: its -1,1 " atomic constants needed by the new I/O system. close: its -1,1 deletef: its -1,1 filepos: its -1,1 mergef: its -1,1 open: its -1,1 cruft1: its -1,1 used to be openi evalhook_atom: its -1,1 used to be openo, now is 'evalhook (nothing to do with I/O) outfile: its -1,1 rename: its -1,1 stream: its -1,1 " atomic constants needed by status & sstatus for new I/O system dsk_atom: its -1,1 crunit_atom: its -1,1 args: its -1,1 " atomic constants needed by lisp_error_ err_atom: its -1,1 eval_atom: its -1,1 apply_atom: its -1,1 princ_atom: its -1,1 prin1: prin1_atom: its -1,1 print_atom: its -1,1 MINUS: its -1,1 SLASH: its -1,1 defun: its -1,1 expr_hash:its -1,1 vertical_bar_macro: its -1,1 eof_atom: its -1,1 progn_atom: its -1,1 end_atomic_constants: toplevel: its -1,1 divov_flag: its -1,1 (status divov) - t means handle divide overflow plus_status: its -1,1 status_gctwa: its -1,1 tty_input_chan: its -1,1 tty_output_chan: its -1,1 property_list_of_nil: its -1,1 cleanup_list: its -1,1 end_gc_area: null " use tx " join /text/tx put this unchanging stuff in the text section number_gc_ptrs: zero 0,(end_gc_area-garbage_collected_ptrs)/2 number_of_atomic_constants: zero 0,(end_atomic_constants-atomic_constants)/2 subsys_recurse_save_size: zero 0,end_gc_area-lisp_static_vars_ " table of names of atomic constants above. " in acc format. There is no maximum name length, the names " are simply concatenated. atomic_constants_names: acc /nil/ acc /t/ acc /external/ acc /^d/ acc /^q/ acc /^r/ acc /^w/ acc /internal_interrupt_0_atom_/ acc /^b/ user_intr_array(1) acc /internal_interrupt_2_atom_/ acc /alarmclock/ acc /errset/ acc /undf-fnctn/ acc /unbnd-vrbl/ acc /wrng-type-arg/ acc /unseen-go-tag/ acc /wrng-no-args/ acc /gc-lossage/ acc /fail-act/ acc /pdl-overflow/ acc /nil/ acc /internal_interrupt_14_atom_/ acc /internal_interrupt_15_atom_/ acc /internal_interrupt_16_atom_/ acc /nil/ acc /internal_autoload_atom_/ acc /*rset-trap/ acc /gc-daemon/ acc /*/ acc /+/ acc /base/ acc /ibase/ acc /readtable/ acc /*nopoint/ acc /tty/ acc /errlist/ acc /infile/ acc /instack/ acc /outfiles/ acc /zunderflow/ acc /uread/ acc /uwrite/ acc /old-io-defaults/ acc /^a/ acc /*rset/ acc /prinlevel/ acc /prinlength/ acc /value/ acc /read-eof/ acc /splicing/ acc /$p/ acc /quote/ acc /symbol/ acc /string/ acc /fixnum/ acc /flonum/ acc /random/ acc /bignum/ acc /list/ acc /go/ acc /return/ acc /pdlframe/ acc /alphalessp/ acc /lambda/ acc /label/ acc /funarg/ acc /subr/ acc /lsubr/ acc /fsubr/ acc /expr/ acc /fexpr/ acc /array/ acc /macro/ acc /autoload/ acc /quotient/ acc /arg/ acc /setarg/ acc /listify/ acc /evalframe/ acc /arrayindex/ acc /setq/ acc /?/ acc /nouuo/ nouuo flag = global var acc /noret/ noret flag = global var acc /internal_quote_macro_/ acc /internal_semicolon_macro_/ acc /runtime/ acc /time/ acc /comment/ atom for comment subr to return acc /declare/ atom for declare subr to return. acc /close/ acc /deletef/ acc /filepos/ acc /mergef/ acc /open/ acc /cruft1../ used to be openi acc /evalhook/ used to be openo... acc /outfile/ acc /rename/ acc /stream/ acc /dsk/ acc /crunit/ acc /args/ acc /err/ acc /eval/ acc /apply/ acc /princ/ acc /prin1/ acc /print/ acc /-/ acc |/| acc /defun/ acc /expr-hash/ acc /internal_vertical_bar_macro_/ acc /eof/ acc /progn/ end  lisp_subr_tv_.alm 11/05/86 1612.7r w 11/04/86 1039.2 258678 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** name lisp_subr_tv_ " This segment of lisp is used to allow pointers from the " lisp environment, which is impure, to reference lisp subroutines. " It is a transfer vector, in which each entry is comprised of four " words -- a header word containing information about the subroutine, " one or two words of code, and a word which gives information to the " bootstrapping routine which generates the initial lisp environment. " It is important that modifications to this segment not change " the positions of the unchanged subroutine entry points, so that " a change or addition to the subroutines supported by lisp " does not have to invalidate the contents of previously generated saved " environments. " " Three types of subroutine calls are handled here...the fast call " is just a transfer to the real entry point...see for example the subroutine " "cdr". The normal call is done by a tsx6 to the type_1_subr routine " which saves the return address and lp on the unmarked stack, " and then a transfer to the routine. PL/I subroutines " are called by going through an interface routine...either pl1_fixup or " pl1_lsubr_fixup is used depending on the type of the subr. " " It is important to realize that this segment will not work correctly if " not bound with the other alm modules in the lisp system. It depends on the " two facts that: " a) the binder coalesces the linkage sections of all of the " component segments when binding, so that ab|system_lp, " which is saved at entry to lisp, works for all alm modules " which require a pointer to their linkage section. " b) transfers to fast call subroutines will be altered by the linker " to direct transfers, rather than going through links, so that " lp need not be set at the time of the transfer. " " " History: " First modified by D. Reed, who generated it from the segment lisp_standard_environment_.ec, " on 2/19/73. " Modified 3/13/72 by DAM for New I/O Functions " Modified 17 Apr 1974 by DAM to add error-break fcns (formerly in lisp_standard_environment_.ec) " ***** the name of the second location counter was changed from names " ***** to Names due to a name clash. " Modified 74.12.16 by DAM. The transfer vector is now compiled from a readable, " symbolic source file called lisp_subr_tv_.macro into lisp_subr_tv_.incl.alm. " This file contains the necessary declarations and support routines. " Modified 1982.10.04 by Richard Lamson to convert into ALM, now that it has " macros, rather than converting from the " kludgiferous lisp_subr_tv_.macro equ subr,0 equ lsubr,1 equ fsubr,2 segdef tv_begin segdef lisp_subr_tv_ segdef tv_entry_count use tv tv_entry_count: zero 0,(tv_end-tv_begin)/4-1 even " must be even, else garbage collection and saving don't work right. macro type_0_subr use tv vfd 9/&4,9/&3,18/-1 tra &5 zero zero &U-lisp_subr_tv_,&1 use Names &U: acc "&2" use tv &end macro type_1_subr use tv vfd 9/&4,9/&3,18/-1 tsx6 type_1_subr tra &5 zero &U-lisp_subr_tv_,&1 use Names &U: acc "&2" use tv &end macro pl1 use tv vfd 9/&4,9/&3,18/-1 tsx6 pl1_fixup tra &5 zero &U-lisp_subr_tv_,&1 use Names &U: acc "&2" use tv &end macro pl1_lsubr use tv vfd 9/&4,9/&3,18/-1 tsx6 pl1_lsubr_fixup tra &5 zero &U-lisp_subr_tv_,&1 use Names &U: acc "&2" use tv &end macro err_break use tv vfd 9/0,9/1,18/-1 tsx6 err_break-*,ic zero &3,&4 zero &U-lisp_subr_tv_,&1 use Names &U: acc "&2" use tv &end macro none_such use tv zero 0,-1 drl 0 zero zero &U-lisp_subr_tv_,&1 use Names &U: acc "&2" use tv &end tv_begin: null lisp_subr_tv_: null star_flt: type_0_subr lsubr,*$,0,511,lisp_utils_$times_flo star_: type_0_subr lsubr,*,0,511,lisp_utils_$times_fix star_array: pl1_lsubr lsubr,*array,3,511,lisp_array_fcns_$star_array star_dif: type_1_subr lsubr,*dif,2,2,lisp_bignums_$difference star_function: type_1_subr fsubr,*function,,,lisp_$stfunction star_quo: type_1_subr lsubr,*quo,2,2,lisp_bignums_$quotient star_rearray: pl1_lsubr lsubr,*rearray,1,511,lisp_array_fcns_$star_rearray star_rset: pl1 subr,*rset,1,,lisp_status_fns_$rset star_sstatus: pl1_lsubr lsubr,*sstatus,1,511,lisp_status_fns_$sstatus_ star_status: pl1_lsubr lsubr,*status,1,511,lisp_status_fns_$status_ pls_flt: type_0_subr lsubr,+$,0,511,lisp_utils_$plus_flo pls_: type_0_subr lsubr,+,0,511,lisp_utils_$plus_fix mns_flt: type_0_subr lsubr,-$,0,511,lisp_utils_$diff_flo mns_: type_0_subr lsubr,-,0,511,lisp_utils_$diff_fix div_flt: type_0_subr lsubr,/$,0,511,lisp_utils_$quot_flo div_: type_0_subr lsubr,/,0,511,lisp_utils_$quot_fix one_pls_flt: type_0_subr subr,1+$,1,,lisp_utils_$add1_flo one_pls: type_0_subr subr,1+,1,,lisp_utils_$add1_fix one_mns_flt: type_0_subr subr,1-$,1,,lisp_utils_$sub1_flo one_mns: type_0_subr subr,1-,1,,lisp_utils_$sub1_fix ls_: type_0_subr subr,<,2,,lisp_utils_$ls_ eqn_: type_0_subr subr,=,2,,lisp_utils_$eql_ gt_: type_0_subr subr,>,2,,lisp_utils_$gt_ CtoI: pl1 subr,CtoI,1,,lisp_char_fns_$CtoI ItoC: pl1 subr,ItoC,1,,lisp_char_fns_$ItoC rem_: type_1_subr subr,\,2,,lisp_bignums_$remainder abs: type_1_subr subr,abs,1,,lisp_bignums_$abs add1: type_1_subr subr,add1,1,,lisp_bignums_$add1 alarmclock: pl1 subr,alarmclock,2,,lisp_fault_handler_$alarmclock allfiles: pl1 subr,allfiles,1,,lisp_io_fns_$allfiles and: type_1_subr fsubr,and,,,lisp_quick_fcns_$and append: type_1_subr lsubr,append,0,511,lisp_alloc_$append apply: type_1_subr lsubr,apply,2,3,lisp_$apply_ arg: type_1_subr subr,arg,1,,lisp_$arg args: pl1_lsubr lsubr,args,1,2,lisp_defsubr_$args array: pl1 fsubr,array,,,lisp_array_fcns_$array arraydims: pl1 subr,arraydims,1,,lisp_array_fcns_$arraydims ascii: type_1_subr subr,ascii,1,,lisp_reader_alm_$ascii_alm assoc: type_0_subr subr,assoc,2,,lisp_quick_fcns_$assoc assq: type_0_subr subr,assq,2,,lisp_quick_fcns_$assq atan: pl1_lsubr lsubr,atan,1,2,lisp_trig_$atan atom: type_0_subr subr,atom,1,,lisp_quick_fcns_$atom baktrace1: pl1_lsubr lsubr,baktrace1,0,2,lisp_baktrace_$baktrace1 baktrace2: pl1_lsubr lsubr,baktrace2,0,2,lisp_baktrace_$baktrace2 baktrace: pl1_lsubr lsubr,baktrace,0,2,lisp_baktrace_$baktrace bigp: type_0_subr subr,bigp,1,,lisp_quick_fcns_$bigp bltarray: pl1 subr,bltarray,2,,lisp_array_fcns_$bltarray boole: type_0_subr lsubr,boole,3,511,lisp_utils_$boole boundp: type_1_subr subr,boundp,1,,lisp_alloc_$boundp break: pl1 fsubr,break,,,lisp_prog_fns_$break caaaar: type_1_subr subr,caaaar,1,,lisp_car_cdrs_$caaaar caaadr: type_1_subr subr,caaadr,1,,lisp_car_cdrs_$caaadr caaar: type_1_subr subr,caaar,1,,lisp_car_cdrs_$caaar caadar: type_1_subr subr,caadar,1,,lisp_car_cdrs_$caadar caaddr: type_1_subr subr,caaddr,1,,lisp_car_cdrs_$caaddr caadr: type_1_subr subr,caadr,1,,lisp_car_cdrs_$caadr caar: type_1_subr subr,caar,1,,lisp_car_cdrs_$caar cadaar: type_1_subr subr,cadaar,1,,lisp_car_cdrs_$cadaar cadadr: type_1_subr subr,cadadr,1,,lisp_car_cdrs_$cadadr cadar: type_1_subr subr,cadar,1,,lisp_car_cdrs_$cadar caddar: type_1_subr subr,caddar,1,,lisp_car_cdrs_$caddar cadddr: type_1_subr subr,cadddr,1,,lisp_car_cdrs_$cadddr caddr: type_1_subr subr,caddr,1,,lisp_car_cdrs_$caddr cadr: type_1_subr subr,cadr,1,,lisp_car_cdrs_$cadr car: type_0_subr subr,car,1,,lisp_car_cdrs_$car catch: pl1 fsubr,catch,,,lisp_prog_fns_$catch catenate: pl1_lsubr lsubr,catenate,0,511,lisp_char_fns_$catenate cdaaar: type_1_subr subr,cdaaar,1,,lisp_car_cdrs_$cdaaar cdaadr: type_1_subr subr,cdaadr,1,,lisp_car_cdrs_$cdaadr cdaar: type_1_subr subr,cdaar,1,,lisp_car_cdrs_$cdaar cdadar: type_1_subr subr,cdadar,1,,lisp_car_cdrs_$cdadar cdaddr: type_1_subr subr,cdaddr,1,,lisp_car_cdrs_$cdaddr cdadr: type_1_subr subr,cdadr,1,,lisp_car_cdrs_$cdadr cdar: type_1_subr subr,cdar,1,,lisp_car_cdrs_$cdar cddaar: type_1_subr subr,cddaar,1,,lisp_car_cdrs_$cddaar cddadr: type_1_subr subr,cddadr,1,,lisp_car_cdrs_$cddadr cddar: type_1_subr subr,cddar,1,,lisp_car_cdrs_$cddar cdddar: type_1_subr subr,cdddar,1,,lisp_car_cdrs_$cdddar cddddr: type_1_subr subr,cddddr,1,,lisp_car_cdrs_$cddddr cdddr: type_1_subr subr,cdddr,1,,lisp_car_cdrs_$cdddr cddr: type_1_subr subr,cddr,1,,lisp_car_cdrs_$cddr cdr: type_0_subr subr,cdr,1,,lisp_car_cdrs_$cdr chrct: type_0_subr lsubr,chrct,1,2,lisp_reader_alm_$chrct cline: pl1 subr,cline,1,,lisp_command_caller_$cline close: pl1 subr,close,1,,lisp_io_control_$close comment: type_1_subr fsubr,comment,,,lisp_quick_fcns_$comment cond: type_1_subr fsubr,cond,,,lisp_quick_fcns_$cond cons: type_1_subr subr,cons,2,,lisp_alloc_$cons_ cos: pl1 subr,cos,1,,lisp_trig_$cos declare: type_1_subr fsubr,declare,,,lisp_quick_fcns_$declare definedp: type_1_subr subr,definedp,1,,lisp_alloc_$boundp defprop: pl1 fsubr,defprop,,,lisp_define_$defprop defsubr: pl1_lsubr lsubr,defsubr,3,7,lisp_defsubr_$defsubr defun: pl1 fsubr,defun,,,lisp_define_$defun delete: type_1_subr lsubr,delete,2,3,lisp_quick_fcns_$delete deletef: pl1 subr,deletef,1,,lisp_io_control_$deletef delq: type_1_subr lsubr,delq,2,3,lisp_quick_fcns_$delq difference: type_1_subr lsubr,difference,1,511,lisp_bignums_$difference do: pl1 fsubr,do,,,lisp_prog_fns_$do eoffn: pl1_lsubr lsubr,eoffn,1,2,lisp_io_fns_$eoffn eq: type_0_subr subr,eq,2,,lisp_quick_fcns_$eq equal: type_0_subr subr,equal,2,,lisp_quick_fcns_$equal err: pl1 fsubr,err,,,lisp_error_$err errframe: pl1 subr,errframe,1,,lisp_error_$errframe errprint: pl1 subr,errprint,1,,lisp_error_$errprint errset: pl1 fsubr,errset,,,lisp_prog_fns_$errset eval: type_1_subr lsubr,eval,1,2,lisp_$eval_ evalframe: pl1 subr,evalframe,1,,lisp_error_$pdlframe exp: pl1 subr,exp,1,,lisp_trig_$exp explode: pl1 subr,explode,1,,lisp_print_$explode explodec: pl1 subr,explodec,1,,lisp_print_$explodec exploden: pl1 subr,exploden,1,,lisp_print_$exploden expt: type_1_subr subr,expt,2,,lisp_bignums_$expt filepos: pl1_lsubr lsubr,filepos,1,2,lisp_io_fns_$filepos fix: type_1_subr subr,fix,1,,lisp_bignums_$fix fixp: type_0_subr subr,fixp,1,,lisp_quick_fcns_$fixp flatc: pl1 subr,flatc,1,,lisp_print_$flatc flatsize: pl1 subr,flatsize,1,,lisp_print_$flatsize float: type_1_subr subr,float,1,,lisp_bignums_$float floatp: type_0_subr subr,floatp,1,,lisp_quick_fcns_$floatp freturn: pl1 subr,freturn,2,,lisp_error_$freturn function: type_0_subr fsubr,function,,,lisp_car_cdrs_$quote gc: pl1 subr,gc,0,,lisp_garbage_collector_$gcsubr gctwa: pl1 fsubr,gctwa,,,lisp_status_fns_$gctwa gensym: type_1_subr lsubr,gensym,0,1,lisp_alloc_$gensym_ get: type_1_subr subr,get,2,,lisp_property_fns_$get_ get_pname: pl1 subr,get_pname,1,,lisp_char_fns_$get_pname getl: type_1_subr subr,getl,2,,lisp_property_fns_$getl_ go: type_1_subr fsubr,go,,,lisp_$go greaterp: type_1_subr lsubr,greaterp,1,511,lisp_bignums_$greaterp index: pl1 subr,index,2,,lisp_char_fns_$Index inpush: pl1 subr,inpush,1,,lisp_io_fns_$inpush intern: pl1 subr,intern,1,,lisp_obarray_utils_$intern ioc: pl1 fsubr,ioc,,,lisp_fault_handler_$ioc iog: pl1 fsubr,iog,,,lisp_fault_handler_$iog isqrt: pl1 subr,isqrt,1,,lisp_trig_$isqrt last: type_0_subr subr,last,1,,lisp_quick_fcns_$last length: type_0_subr subr,length,1,,lisp_quick_fcns_$length lessp: type_1_subr lsubr,lessp,1,511,lisp_bignums_$lessp linel: type_0_subr lsubr,linel,1,2,lisp_reader_alm_$linel list: type_1_subr lsubr,list,0,511,lisp_alloc_$list_ log: pl1 subr,log,1,,lisp_trig_$log lsh: type_0_subr subr,lsh,2,,lisp_utils_$lsh make_atom: pl1 subr,make_atom,1,,lisp_char_fns_$make_atom maknam: pl1 subr,maknam,1,,lisp_reader_$maknam makoblist: pl1 subr,makoblist,1,,lisp_obarray_utils_$makoblist makreadtable: pl1 subr,makreadtable,1,,lisp_reader_$makreadtable makunbound: type_1_subr subr,makunbound,1,,lisp_alloc_$makunbound map: type_1_subr lsubr,map,2,511,lisp_$map mapc: type_1_subr lsubr,mapc,2,511,lisp_$mapc mapcan: type_1_subr lsubr,mapcan,2,511,lisp_$mapcan mapcar: type_1_subr lsubr,mapcar,2,511,lisp_$mapcar mapcon: type_1_subr lsubr,mapcon,2,511,lisp_$mapcon maplist: type_1_subr lsubr,maplist,2,511,lisp_$maplist max: type_1_subr lsubr,max,1,511,lisp_bignums_$max member: type_0_subr subr,member,2,,lisp_quick_fcns_$member memq: type_0_subr subr,memq,2,,lisp_quick_fcns_$memq min: type_1_subr lsubr,min,1,511,lisp_bignums_$min minus: type_1_subr subr,minus,1,,lisp_bignums_$minus minusp: type_1_subr subr,minusp,1,,lisp_bignums_$minusp mergef: pl1_lsubr lsubr,mergef,2,511,lisp_io_control_$mergef nconc: type_1_subr lsubr,nconc,0,511,lisp_alloc_$nconc ncons: type_1_subr subr,ncons,1,,lisp_alloc_$ncons_ namelist: pl1 subr,namelist,1,,lisp_io_fns_$namelist names: pl1_lsubr lsubr,names,1,2,lisp_io_fns_$names namestring: pl1 subr,namestring,1,,lisp_io_fns_$namestring nointerrupt: pl1 subr,nointerrupt,1,,lisp_fault_handler_$nointerrupt noret: pl1 subr,noret,1,,lisp_status_fns_$noret not: type_0_subr subr,not,1,,lisp_quick_fcns_$null nouuo: type_1_subr subr,nouuo,1,,lisp_$nouuo nreverse: type_1_subr subr,nreverse,1,,lisp_alloc_$nreverse_ null: type_0_subr subr,null,1,,lisp_quick_fcns_$null numberp: type_0_subr subr,numberp,1,,lisp_quick_fcns_$numberp oddp: type_0_subr subr,oddp,1,,lisp_quick_fcns_$oddp opena: pl1 subr,opena,1,,lisp_io_control_$opena openi: pl1 subr,openi,1,,lisp_io_control_$openi openo: pl1 subr,openo,1,,lisp_io_control_$openo or: type_1_subr fsubr,or,,,lisp_quick_fcns_$or plus: type_1_subr lsubr,plus,0,511,lisp_bignums_$plus plusp: type_1_subr subr,plusp,1,,lisp_bignums_$plusp prin1: pl1_lsubr lsubr,prin1,1,2,lisp_print_$prin1_ princ: pl1_lsubr lsubr,princ,1,2,lisp_print_$princ_ print: pl1_lsubr lsubr,print,1,2,lisp_print_$print_ prog2: type_0_subr lsubr,prog2,2,511,lisp_quick_fcns_$prog2 prog: pl1 fsubr,prog,,,lisp_prog_fns_$prog progn: type_0_subr lsubr,progn,1,511,lisp_quick_fcns_$progn putprop: type_1_subr subr,putprop,3,,lisp_property_fns_$putprop_ quit: pl1 subr,quit,0,,lisp$quit quote: type_0_subr fsubr,quote,,,lisp_car_cdrs_$quote quotient: type_1_subr lsubr,quotient,1,511,lisp_bignums_$quotient random: type_1_subr lsubr,random,0,1,lisp_quick_fcns_$random read: pl1_lsubr lsubr,read,0,2,lisp_reader_$read readch: type_1_subr lsubr,readch,0,2,lisp_reader_alm_$readch readlist: pl1 subr,readlist,1,,lisp_reader_$readlist readline: pl1_lsubr lsubr,readline,0,2,lisp_reader_$readstring remainder: type_1_subr subr,remainder,2,,lisp_bignums_$remainder remob: pl1 subr,remob,1,,lisp_obarray_utils_$remob remprop: type_1_subr subr,remprop,2,,lisp_property_fns_$remprop_ rename: pl1 subr,rename,2,,lisp_io_control_$rename return: type_1_subr subr,return,1,,lisp_$return reverse: type_1_subr subr,reverse,1,,lisp_alloc_$reverse rot: type_0_subr subr,rot,2,,lisp_utils_$rot rplaca: type_1_subr subr,rplaca,2,,lisp_quick_fcns_$rplaca rplacd: type_0_subr subr,rplacd,2,,lisp_quick_fcns_$rplacd runtime: type_0_subr subr,runtime,0,,lisp_quick_fcns_$runtime sassoc: type_0_subr subr,sassoc,3,,lisp_quick_fcns_$sassoc sassq: type_0_subr subr,sassq,3,,lisp_quick_fcns_$sassq save: pl1 fsubr,save,,,lisp$save set: type_1_subr subr,set,2,,lisp_quick_fcns_$set setarg: type_1_subr subr,setarg,2,,lisp_$setarg setq: type_1_subr fsubr,setq,,,lisp_quick_fcns_$setq shortnamestring: pl1 subr,shortnamestring,1,,lisp_io_fns_$shortnamestring signp: type_1_subr fsubr,signp,,,lisp_utils_$signp sin: pl1 subr,sin,1,,lisp_trig_$sin sleep: pl1 subr,sleep,1,,lisp_trig_$sleep smallnump: type_0_subr subr,smallnump,1,,lisp_quick_fcns_$smallnump sqrt: pl1 subr,sqrt,1,,lisp_trig_$sqrt sstatus: pl1 fsubr,sstatus,,,lisp_status_fns_$sstatus status: pl1 fsubr,status,,,lisp_status_fns_$status store: type_1_subr fsubr,store,,,lisp_oprs_$store stringlength: pl1 subr,stringlength,1,,lisp_char_fns_$stringlength stringp: type_0_subr subr,stringp,1,,lisp_quick_fcns_$stringp sub1: type_1_subr subr,sub1,1,,lisp_bignums_$sub1 sublis: type_1_subr subr,sublis,2,,lisp_alloc_$sublis subrp: type_0_subr subr,subrp,1,,lisp_quick_fcns_$subrp subst: type_1_subr subr,subst,3,,lisp_alloc_$subst_ substr2: pl1 subr,substr2,2,,lisp_char_fns_$Substr2 substr: pl1_lsubr lsubr,substr,2,3,lisp_char_fns_$Substr sysp: pl1 subr,sysp,1,,lisp_defsubr_$sysp terpri: pl1_lsubr lsubr,terpri,0,1,lisp_print_$terpri throw: pl1 fsubr,throw,,,lisp_prog_fns_$throw time: pl1 subr,time,0,,lisp_status_fns_$time times: type_1_subr lsubr,times,0,511,lisp_bignums_$times tyi: type_1_subr lsubr,tyi,0,2,lisp_reader_alm_$tyi tyipeek: type_1_subr lsubr,tyipeek,0,2,lisp_reader_alm_$tyipeek tyo: type_1_subr lsubr,tyo,1,2,lisp_reader_alm_$tyo_alm typep: type_1_subr subr,typep,1,,lisp_utils_$typep xcons: type_1_subr subr,xcons,2,,lisp_alloc_$xcons_ zerop: type_0_subr subr,zerop,1,,lisp_quick_fcns_$zerop alphalessp: type_1_subr subr,alphalessp,2,,lisp_quick_fcns_$alphalessp samepnamep: type_1_subr subr,samepnamep,2,,lisp_quick_fcns_$samepnamep getchar: type_1_subr subr,getchar,2,,lisp_quick_fcns_$getchar sxhash: type_1_subr subr,sxhash,1,,lisp_utils_$sxhash gcd: type_1_subr subr,gcd,2,,lisp_bignums_$gcd error: pl1_lsubr lsubr,error,0,3,lisp_error_$error setsyntax: pl1 subr,setsyntax,3,,lisp_status_fns_$setsyntax cursorpos: pl1_lsubr lsubr,cursorpos,0,3,lisp_io_fns_$cursorpos force_output: pl1 subr,force-output,1,,lisp_io_control_$force_output clear_input: pl1 subr,clear-input,1,,lisp_io_control_$clear_input haipart: type_1_subr subr,haipart,2,,lisp_bignums_$haipart haulong: type_1_subr subr,haulong,1,,lisp_bignums_$haulong sort: pl1 subr,sort,2,,lisp_array_fcns_$sort sortcar: pl1 subr,sortcar,2,,lisp_array_fcns_$sortcar fillarray: pl1 subr,fillarray,2,,lisp_array_fcns_$fillarray listarray: pl1_lsubr lsubr,listarray,1,2,lisp_array_fcns_$listarray listify: type_1_subr subr,listify,1,,lisp_$listify quikload: none_such ,listen funcall: type_1_subr lsubr,funcall,1,511,lisp_$funcall listen: type_1_subr subr,listen,0,,lisp_reader_alm_$listen fixgcd: type_0_subr subr,\\,2,,lisp_utils_$fixgcd copysymbol: type_1_subr subr,copysymbol,2,,lisp_alloc_$copysymbol load: pl1 subr,load,1,,lisp_load_$lisp_load_ charpos: type_0_subr lsubr,charpos,1,2,lisp_reader_alm_$charpos linenum: type_0_subr lsubr,linenum,1,2,lisp_reader_alm_$linenum pagenum: type_0_subr lsubr,pagenum,1,2,lisp_reader_alm_$pagenum pagel: type_0_subr lsubr,pagel,1,2,lisp_reader_alm_$pagel endpagefn: pl1_lsubr lsubr,endpagefn,1,2,lisp_io_fns_$endpagefn percent_include: pl1 fsubr,%include,,,lisp_io_control_$percent_include defaultf: pl1 subr,defaultf,1,,lisp_io_fns_$defaultf alloc: pl1 subr,alloc,1,,lisp_status_fns_$alloc implode: pl1 subr,implode,1,,lisp_reader_$implode purcopy: type_0_subr subr,purcopy,1,,lisp_subr_tv_$purcopy_code nreconc: type_1_subr subr,nreconc,2,,lisp_alloc_$nreconc_ err_1: err_break ,*internal-^b-break,0,0 err_5: err_break ,*internal-undf-fnctn-break,-1,8 err_6: err_break ,*internal-unbnd-vrbl-break,-1,10 err_7: err_break ,*internal-wrng-type-arg-break,-1,12 err_8: err_break ,*internal-unseen-go-tag-break,-1,14 err_9: err_break ,*internal-wrng-no-args-break,-1,16 err_10: err_break ,*internal-gc-lossage-break,0,18 err_11: err_break ,*internal-fail-act-break,-1,20 err_12: err_break ,*internal-pdl-overflow-break,-1,22 err_19: type_0_subr subr,*internal-*rset-break,1,,lisp_subr_tv_$star_rset_trap err_18: type_0_subr subr,*internal-autoload-trap,1,,lisp_subr_tv_$autoload_trap getcharn: type_1_subr subr,getcharn,2,,lisp_quick_fcns_$getcharn subrcall: type_1_subr fsubr,subrcall,,,lisp_$subrcall lsubrcall: type_1_subr fsubr,lsubrcall,,,lisp_$lsubrcall arraycall: type_1_subr fsubr,arraycall,,,lisp_$arraycall maknum: type_1_subr subr,maknum,1,,lisp_alloc_$maknum munkam: type_1_subr subr,munkam,1,,lisp_alloc_$munkam loadarrays: pl1 subr,loadarrays,1,,lisp_loadumparrays_$loadarrays dumparrays: pl1 subr,dumparrays,2,,lisp_loadumparrays_$dumparrays expt_fix: type_0_subr subr,^,2,,lisp_utils_$expt_fix expt_flt: type_0_subr subr,^$,2,,lisp_utils_$expt_flo symeval: type_1_subr subr,symeval,1,,lisp_$symeval plist: type_1_subr subr,plist,1,,lisp_property_fns_$plist_ setplist: type_1_subr subr,setplist,2,,lisp_property_fns_$setplist_ open: pl1_lsubr lsubr,open,0,2,lisp_io_control_$open in: pl1 subr,in,1,,lisp_io_control_$in out: pl1 subr,out,2,,lisp_io_control_$out truename: pl1 subr,truename,1,,lisp_io_fns_$truename evalhook: type_1_subr subr,evalhook,2,,lisp_$evalhook fsc: type_0_subr subr,fsc,2,,lisp_utils_$fsc ifix: type_0_subr subr,ifix,1,,lisp_utils_$ifix progv: pl1 fsubr,progv,,,lisp_prog_fns_$progv mapatoms: pl1_lsubr lsubr,mapatoms,1,2,lisp_array_fcns_$mapatoms symbolp: type_0_subr subr,symbolp,1,,lisp_quick_fcns_$symbolp filep: type_0_subr subr,filep,1,,lisp_quick_fcns_$filep suspend: pl1 subr,suspend,0,,lisp_command_caller_$suspend ctrl_g: pl1 subr,^g,0,,lisp_fault_handler_$ctrl_g_function unwind_protect: pl1 fsubr,unwind-protect,,,lisp_prog_fns_$unwind_protect let: type_1_subr fsubr,let,,,lisp_$let arrayp: type_0_subr subr,arrayp,1,,lisp_quick_fcns_$arrayp list_star: type_1_subr lsubr,list*,1,511,lisp_alloc_$list_star_ eval_when: pl1 fsubr,eval-when,,,lisp_prog_fns_$eval_when read_from_string: pl1 subr,read-from-string,1,,lisp_reader_$read_from_string prog1: type_0_subr lsubr,prog1,1,511,lisp_quick_fcns_$prog1 displace: type_1_subr subr,displace,2,,lisp_quick_fcns_$displace nth: type_1_subr subr,nth,2,,lisp_car_cdrs_$nth nthcdr: type_1_subr subr,nthcdr,2,,lisp_car_cdrs_$nthcdr first: type_0_subr subr,first,1,,lisp_car_cdrs_$car second: type_1_subr subr,second,1,,lisp_car_cdrs_$cadr third: type_1_subr subr,third,1,,lisp_car_cdrs_$caddr fourth: type_1_subr subr,fourth,1,,lisp_car_cdrs_$cadddr rest1: type_0_subr subr,rest1,1,,lisp_car_cdrs_$cdr rest2: type_1_subr subr,rest2,1,,lisp_car_cdrs_$cddr rest3: type_1_subr subr,rest3,1,,lisp_car_cdrs_$cdddr rest4: type_1_subr subr,rest4,1,,lisp_car_cdrs_$cddddr includef: pl1 subr,includef,1,,lisp_io_control_$includef use tv tv_end: null " " trap code for unimplemented subrs in a given release " dup 80 tra trap_out_unimp dupend trap_out_unimp: push 64 trap_out_unimp_1: eppap trap_argl short_call signal_$signal_ tra trap_out_unimp_1 even trap_argl:zero 4,4 zero 4,0 arg trap_cname zero arg trap_nullptr zero arg *+1 oct 524000000030 arg *+1 oct 464000000000 trap_nullptr: its -1,1 trap_cname:aci "unimplemented_lisp_subr_" segdef purcopy_code purcopy_code: " code to do the purcopy function, which is nugatory ldaq ap|-2 just return argument eppap ap|-2 tra bp|0 segdef star_rset_trap,autoload_trap " used by transfer vector above null_argl: oct 4,0 type_1_subr: " routine to set up type 1 call entry for system subrs. eax7 4,x7 " get room to save lp and bp sprilp ab|-4,x7 spribp ab|-2,x7 epplp ab|system_lp,* " get linkage pointer, which all system subrs share. tra 0,x6 " return to transfer instruction. pl1_fixup: " routine to switch from lisp mode to pl1 mode. eax7 6,x7 spribp ab|-6,x7 sprilp ab|-4,x7 epplp 0,x6 sprilp ab|-2,x7 " save pointer to entry we are calling. epplp ab|system_lp,* " get system lp. spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code " now we are in pl1 code conventions. push " make a stack frame. eppbp |[unmkd_ptr],* epplb |[..lisp..] sprilb sp|stack_frame.entry_ptr eppap null_argl-*,ic short_call bp|-2,* " call the entry point. eppbp sp|16,* " pop stack. sprisp sb|stack_header.stack_end_ptr eppsp bp|0 " get old stack ptr. eppap |[stack_ptr],* "go back to lisp conventions. epbpab |[unmkd_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code epplp ab|-4,x7* eppbp ab|-6,x7* eax7 -6,x7 ldaq ap|-2 eppap ap|-2 tra bp|0 " return. pl1_lsubr_fixup: eppap ap|2 eaq 0,x5 " put x5 on stack. qrs 18 lda fixnum_type,dl staq ap|-2 tra pl1_fixup """ special internal trap & break routines autoload_trap: epplb ap|-2,* pick up argument and take cdr ldaq lb|2 staq ap|-2 pass argument's cdr to load function tra load+1-*,ic err_break: " x6 -> zero flag,atom_offset " flag = -1 if (errprint nil) should be done. " atom_offset = offset from lisp_static_vars_$user_intr_array of break tag eax7 6,x7 save caller's bp, lp sprpbp ab|-4,x7 sprplp ab|-3,x7 epplp ab|system_lp,* star_rset_break: " lambda-bind readtable and obarray, and args to argument " and + t itself eppap ap|16 ldaq |[MINUS] staq ap|-14 ldaq |[MINUS],* + hasn't been setq'ed yet staq ap|-16 staq |[PLUS],* ldaq |[args] staq ap|-10 ldaq ap|-10,* staq ap|-12 ldaq |[readtable] staq ap|-6 ldaq ap|-6,* staq ap|-8 ldaq |[obarray] staq ap|-2 ldaq ap|-2,* staq ap|-4 eax0 ap|-16 bot_block sxl0 ab|-2,x7 eax0 ap|0 top_block stx0 ab|-2,x7 lda |[binding_top]+1 sta ab|-1,x7 eax1 ab|-2,x7 stx1 |[binding_top]+1 ldaq ap|-18 set args to argument staq ap|-10,* " reset readtable, obarray to initial values sxl6 ab|-5,x7 eppap ap|4 ldaq |[readtable] staq ap|-4 ldaq |[array] staq ap|-2 tspbp get+1-*,ic cmpaq ab|nil tze 2,ic staq ap|-6,* ldaq |[obarray] eppap ap|4 staq ap|-4 ldaq |[array] staq ap|-2 tspbp get+1-*,ic cmpaq ab|nil tze 2,ic staq ap|-2,* " if necessary, do (iog vt (errprint nil)) lxl6 ab|-5,x7 szn 0,x6 tpl err_break_no_errprint-*,ic eppap ap|10 binding + arg ldaq |[ctrlW] staq ap|-8 ldaq ap|-8,* staq ap|-10 ldaq |[ctrlR] staq ap|-4 ldaq ap|-4,* staq ap|-6 eax0 ap|-2 stx0 ab|-2,x7 update top_block ldaq ab|nil staq ap|-2 staq ap|-4,* staq ap|-8,* tspbp errprint+1-*,ic " unbind ^w and ^r now ldaq ap|-4 staq ap|-2,* ldaq ap|-8 staq ap|-6,* eax0 ap|-8 stx0 ab|-2,x7 update top_block eppap ap|-8 err_break_no_errprint: eppap ap|4 ldaq ab|true construct arg list for break staq ap|-2 tspbp ncons+1-*,ic tspbp ab|xcons_op,* lxl6 ab|-5,x7 get back x6 lxl6 0,x6 get offset into user_intr_array ldaq |[user_intr_array],x6 get break tag staq bb|0 spribb ap|-2 tspbp break+1-*,ic " unbind and return eppap ap|2 staq ap|-2 save return value ldaq ap|-6 staq ap|-4,* ldaq ap|-10 staq ap|-8,* ldaq ap|-14 staq ap|-12,* ldaq ap|-18 staq ap|-16,* ldx1 ab|-1,x7 stx1 |[binding_top]+1 ldaq ap|-2 return value eppap ap|-20 16 binding + 2 arg + 2 saved result lprplp ab|-3,x7 lprpbp ab|-4,x7 eax7 -6,x7 tra bp|0 star_rset_trap: eax6 star_rset_trap_control_word-*,ic eax7 6,x7 sprpbp ab|-4,x7 sprplp ab|-3,x7 epplp ab|system_lp,* ldaq |[star_rset],* cmpaq ab|nil tnz star_rset_break-*,ic " (*rset nil) mode, just return nil " ldaq ab|nil eppap ap|-2 lprplp ab|-3,x7 lprpbp ab|-4,x7 eax7 -6,x7 tra bp|0 star_rset_trap_control_word: zero 0,36 use Names entry ..lisp.. ..lisp..: drl 0,dl used to set stack_frame.entry_ptr include stack_header include stack_frame include lisp_object_types include lisp_stack_seg use tv hope to get literals in tv section join /text/tv,Names end  lisp_utils_.alm 11/05/86 1612.7r w 11/04/86 1039.2 212247 " ************************************************************** " * * " * Copyright, (C) Massachusetts Institute of Technology, 1973 * " * * " ************************************************************** " lisp_utils_.alm " This segment contains the arithmetic functions and " a few other random functions. " translated from PL/I to ALM 28 August 1972 by D.A.Moon " ***** must be bound in with lisp_ and lisp_error_ since " relies on calling through links without the lp loaded. include lisp_stack_seg include stack_header equ t,true include lisp_object_types include lisp_error_codes include lisp_name_codes " REGISTER USAGE " " ap marked pdl pointer " ab -> lisp stack header " bp return addr (type 0 subr) " bb " lp,lb,sp,sb not used " " x0 tsx0 register " x1 -> routine to check arg for arith1, arith2 " x2 temp. used by numval. badarg is called by tsx2 " x3 -> instr for xec or xed (quasi impure code) " x4 ap,x4 -> current arg, also x4 is loop counter. " x5 -2*nargs for lsubrs, not changed. " x6 while in function xxx, contains function name code fn_xxx. " x7 unmarked pdl pointer (with ab) " routine to do eax4 -2 , tsx0 numval " called by tsx0 " used for subrs of one argument so they don't have to " do the eax4 themselves numval1: eax4 -2 and fall into numval " routine to get the type of a numeric argument " called by tsx0 with ap,x4 pointing at the argument " keeps signalling bad_arg_correctable errors until it gets a number " skip return if fixnum, nonskip return if flonum. " changes only registers 0,2 -- doesn't touch aq. numval: lxl2 ap|0,x4 get type bits without touching aq canx2 Fixed,du tnz 1,0 fixnum, skip rtn canx2 Float,du tnz 0,0 flonum, nonskip rtn eax2 numval-*,ic set error return address and fall into badarg " not a number, signal error " the function name code is in x6 " the bad arg is at ap|0,x4 " **** KLUDGE: assumes that we are bound in with lisp_error_ " so that we don't have to do a getlp. " called by tsx2, returns to 0,2 with replacement value written over bad arg badarg: eax7 10,x7 get save area sprilp ab|-10,x7 save lp of caller, so can get system lp. staq ab|-8,x7 save aq (e reg saved by sreg) spribp ab|-6,x7 save bp (return addr) eaq 0,x6 get fcn name code qrs 18 lda bad_arg_correctable,dl badarg1: staq ab|-2,x7 set error codes for lisp_error_ eppbp ap|0,x4 save addr of bad arg spribp ab|-4,x7 ldaq bp|0 get bad arg eppap ap|2 put on top of pdl for lisp_error_ staq ap|-2 fatal_error: " overflow_err joins here. epplp ab|system_lp,* get lp for system modules. spriap |[stack_ptr] save our stack pointers stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code push call |[lisp_error_] """ we rely on this call saving xr's and e reg eaa sp|16,* then pop this dummy stack frame sprisp sb|stack_header.stack_end_ptr eppsp sb|0,au eppap |[stack_ptr],* epbpab |[unmkd_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code ldaq ap|-2 get replacement value eppap ap|-2 .. staq ab|-2,x7* store over bad arg ldaq ab|-6,x7 restore aq at entry eppbp ab|-4,x7* restore bp at entry epplp ab|-8,x7* restore to caller's lp. eax7 -8,x7 pop temps off pdl tra 0,2 return to caller. even zero 0,nonfixedarg oct 0 " routines to return in divers ways " return the value at the top of the marked pdl (for 1 arg subr) ret_1: ldaq ap|-2 " return value in aq, popping 1 arg off marked pdl lisp_retn_1: eppap ap|-2 tra bp|0 *** these are type 0 subrs " return t for 1 arg subr ret_t: ldaq ab|t eppap ap|-2 tra bp|0 " return nil for 1 arg subr ret_nil: ldaq ab|nil eppap ap|-2 tra bp|0 " return t for lsubr l_ret_t: ldaq ab|t eppap ap|0,x5 pop args off pdl tra bp|0 " return nil for lsubr l_ret_nil: ldaq ab|nil eppap ap|0,x5 pop args off pdl tra bp|0 " return a fixnum from an lsubr retfixnum:lda fixnum_type,dl value is in q eppap ap|0,x5 tra bp|0 " return a flonum from an lsubr " value of flonum is in a-q-e retflonum:fst ap|1,x5 **** assumes arg 1 was numeric ldq ap|1,x5 this moves flonum to q lda flonum_type,dl eppap ap|0,x5 tra bp|0 " fixing & floating routines " these are all called by tsx0 " routine to float the q, returning result in a-q-e float_q: llr 36 fx1_to_fx2 lrs 36 lde =71b25,du fx2_to_fl2 fad =0.0,du normalize tra 0,0 " routine to float the fixnum pointed at by ap,x4 without " changing the a, q, or e. float1: eax7 2,x7 have to save aqe dfst ab|-2,x7 lda ap|1,x4 get number to be floated lrs 36 lde =71b25,du fad =0.0,du fst ap|1,x4 put it back where it came from dfld ab|-2,x7 restore a q e eax7 -2,x7 tra 0,0 " routine to fix the flonum in a-q-e, result is in q " check for overflow is made fix_aq: fad =0.0,du normalize and set indicators tmi fix_aq_minus-*,ic fcmp =o110400,du 2**35 tpl fix_ovf-*,ic ufa =71b25,du tra 0,0 fix_aq_minus: fcmg =o110400,du 2**35 tpl fix_ovf-*,ic fneg 0 magic ufa only works for + ufa =71b25,du negl 0 tra 0,0 fix_ovf: eppap ap|2 eax7 2,x7 fst ab|-2,x7 get flonum format ldq ab|-2,x7 lda flonum_type,dl staq ap|-2 lda overflow_err,dl eaq 0,x6 qrs 18 staq ab|-2,x7 tra fatal_error-*,ic never returns from lisp_error_ " routines for fixnum - only or flonum - only incrementing / decrementing. " x3 -> xed pair to do the work " for arith2 is xec inst, which can be xed if pair needed. " x1 -> fixval or floval routine " x6 = function name code. " these 2 support routines are called by tsx0 to get a " floating number or a fixed number. tra retflonum flo exit floval: lxl2 ap|0,x4 get type bits canx2 Float,du tnz 0,0 flonum -- win. tsx2 badarg-*,ic not flonum, cause error tra floval-*,ic tra retfixnum fix exit fixval: lxl2 ap|0,x4 check type bits canx2 Fixed,du tnz 0,0 fixnum -- win. tsx2 badarg-*,ic not fixnum -- error. tra fixval-*,ic " routine to do one - operand arithmetic using " x3, x1 as described above. Entered with x6 also set up. odd arith1: eax4 -2 one arg. tsx0 0,1 check type of arg xed 0,x3 perform operation. tra ret_1-*,ic and return the value at top of stack. " using x3, x1 as described above. Entered " with x5, x6 set up. " and initial value in q (fix) or aqe (float). odd " must make the xec in odd word to allow xed. prearith2: cmpx5 -2,du " check for one arg case of -, -$, //, //$ tnz arith2 tsx0 0,1 xec 3,x3 " do the operation. tra -1,x1 " and return the result. arith2: eax4 0,x5 -> first arg tze -1,1 if no args return value in q register. tsx0 0,1 check type of arg xec 0,x3 perform operation eax4 2,x4 next arg. tmi -3,ic and loop. tra -1,1 go to appropriate exit routine. " non - mixed mode increment / decrement routines. (Using subroutines " on the preceding page.) " increment fixnum. segdef add1_fix subr (1 0 0) add1_fix: eax6 fn_add1_fix eax1 fixval-*,ic eax3 add1_fix_op-*,ic tra arith1-*,ic even add1_fix_op: aos ap|-1 nop 0,du " increment flonum segdef add1_flo subr (1 0 0) add1_flo: eax6 fn_add1_flo eax1 floval-*,ic eax3 add1_flo_op-*,ic tra arith1-*,ic even add1_flo_op: fld ap|-1 xed *+1 fad =1.0,du fst ap|-1 " decrement fixnum segdef sub1_fix subr (1 0 0) sub1_fix: eax6 fn_sub1_fix eax1 fixval-*,ic eax3 sub1_fix_op-*,ic tra arith1-*,ic even sub1_fix_op: lca 1,dl asa ap|-1 " decrement flonum segdef sub1_flo subr (1 0 0) sub1_flo: eax6 fn_sub1_flo eax1 floval-*,ic eax3 sub1_flo_op-*,ic tra arith1-*,ic even sub1_flo_op: fld ap|-1 xed *+1 fsb =1.0,du fst ap|-1 " plus function for fixnums only. segdef plus_fix lsubr (777000 0 0) plus_fix: eax6 fn_plus_fix eax1 fixval-*,ic ldq 0,dl tsx3 arith2-*,ic adq ap|1,x4 " plus function for flonum's only. segdef plus_flo lsubr (777000 0 0) plus_flo: eax6 fn_plus_flo eax1 floval-*,ic fld =0.0,du tsx3 arith2-*,ic fad ap|1,x4 " exponentiation function for fixnum to fixnum power segdef expt_fix expt_fix: eax6 fn_expt_fix eax4 -4 get first arg tsx0 fixval-*,ic eax4 -2 get second arg tsx0 fixval-*,ic " OK, got args. Set up for successive squaring hackery eax7 2,x7 ldq ap|-3 base in q lda ap|-1 exponent in a tmi ret_fix_0-*,ic staq ab|-2,x7 ldq 1,dl stq ap|-3 init result expt_fix0:ldaq ab|-2,x7 cana 1,dl tze expt_fix1-*,ic mpy ap|-3 multiply into result stq ap|-3 ldaq ab|-2,x7 expt_fix1:arl 1 tze ret_fix_result-*,ic sta ab|-2,x7 mpy ab|-1,x7 square it stq ab|-1,x7 tra expt_fix0-*,ic ret_fix_0:stz ap|-3 neg exponent - zero result ret_fix_result: ldaq ap|-4 pick up result & type eax7 -2,x7 flush temporaries eppap ap|-4 .. tra bp|0 and return " flonum to a fixnum power segdef expt_flo expt_flo: eax6 fn_expt_flo eax4 -4 get first arg tsx0 floval-*,ic eax4 -2 get second arg tsx0 fixval-*,ic eax7 2,x7 get temporaries fld =1.0,du init result dfst ab|-2,x7 lda ap|-1 check sign of exponent tpl expt_fl0-*,ic fld =1.0,du minus - invert base fdv ap|-3 fst ap|-3 lca ap|-1 change sign of exponent expt_fl0: tze return_flo_result-*,ic all done cana 1,dl see if should mpy tze expt_fl1-*,ic no. sta ap|-1 yes - store a first fld ap|-3 get current square dfmp ab|-2,x7 mpy into result dfst ab|-2,x7 tra 2,ic expt_fl1: sta ap|-1 save exponent fld ap|-3 compute next square fmp ap|-3 fst ap|-3 lda ap|-1 arl 1 tra expt_fl0-*,ic return_flo_result: dfld ab|-2,x7 round off result fstr ap|-3 tra ret_fix_result-*,ic and return it, popping, etc. " times function for fixnum's only segdef times_fix lsubr (777000 0 0) times_fix: eax6 fn_times_fix eax1 fixval-*,ic ldq 1,dl tsx3 arith2-*,ic mpy ap|1,x4 " times function for flonum's only segdef times_flo lsubr (777000 0 0) times_flo: eax6 fn_times_flo eax1 floval-*,ic fld =1.0,du tsx3 arith2-*,ic fmp ap|1,x4 " difference of fixnum's only segdef diff_fix lsubr (777000 0 0) diff_fix: eax6 fn_diff_fix eax1 fixval-*,ic ldq 0,dl make sure there is a result if no args supplied. eax3 diff_fix_op_1-*,ic initial op just loads num tra prearith2-*,ic odd diff_fix_op_1: xed *+1 ldq ap|1,x4 load first arg eax3 *+1 and switch to the following, sbq ap|1,x4 which subtracts the remaining args " difference of flonum's only. segdef diff_flo lsubr (777000 0 0) diff_flo: eax6 fn_diff_flo eax1 floval-*,ic fld =0.0,du initial result. eax3 diff_flo_op_1-*,ic tra prearith2-*,ic odd diff_flo_op_1: xed *+1 fld ap|1,x4 load first arg, eax3 *+1 and set up subtract remaining args fsb ap|1,x4 " quotient of fixnum's only segdef quot_fix lsubr (777000 0 0) quot_fix: eax6 fn_quot_fix eax1 fixval-*,ic ldq 1,dl initialize zero arg case. eax3 quot_fix_op_1-*,ic initial operator tra prearith2-*,ic odd quot_fix_op_1: xed *+1 ldq ap|1,x4 this opr loads first arg, eax3 *+1 and sets up to divide by rest of args div ap|1,x4 " quotient of flonum's only segdef quot_flo lsubr (777000 0 0) quot_flo: eax6 fn_quot_flo eax1 floval-*,ic fld =1.0,du initialize zero arg case. eax3 quot_flo_op_1-*,ic tra prearith2-*,ic odd quot_flo_op_1: xed *+1 fld ap|1,x4 load first arg eax3 *+1 fdv ap|1,x4 divide by remaining ones. " lsh function shifts a fixnum left or right a " specified number of binary places. segdef lsh subr (2 0 0) lsh: eax6 fn_lsh eax4 -4 arg1 must be fixnum tsx0 numval-*,ic or flonum (treated as fixnum) eax4 -2 arg2 must be fixnum tsx0 fixval-*,ic ldq ap|-3 get number to be shifted lda ap|-1 get shift count tmi lshneg-*,ic neg = shift right tze lshret1-*,ic zero = don't shift cmpa 36,dl shift right out of register? tpl lshret0-*,ic yes, result is zero qls 0,al no, shift. tra lshret1-*,ic lshneg: neg 0 get count of right shifts cmpa 36,dl shift right out of reg? tpl lshret0-*,ic yes, result is zero qrl 0,al no, do the shift tra lshret1-*,ic lshret0: ldq 0,dl lshret1: lda fixnum_type,dl eppap ap|-4 tra bp|0 " fsc function, takes a flonum and scales it. (ade instruction). segdef fsc fsc: eax6 fn_fsc eax4 -4 " first arg must be a fixnum or flonum tsx0 numval eax4 -2 tsx0 fixval lda ap|-1 " get scale factor. als 36-8 " shift to exponent position. sta ap|-1 fld ap|-3 " load up the floating point number. fad =0.0,du " normalize ade ap|-1 " scale. fst ap|-3 ldq ap|-3 lda flonum_type,dl eppap ap|-4 tra bp|0 " rot function rotates a fixnum left or right a " specified number of binary places segdef rot subr (2 0 0) rot: eax6 fn_rot eax4 -4 arg1 must be fixnum tsx0 fixval-*,ic eax4 -2 arg2 must be fixnum tsx0 fixval-*,ic ldq ap|-1 get shift count div 36,dl modulo word length ada 0,dl set indicators from a (remainder) tpl 2,ic ada 36,dl if right rot is indicated, use "the equivalent left rot. tze rot0-*,ic if shift count is zero ldq ap|-3 get number to be rotated qlr 0,al do it tra lshret1-*,ic and return it. rot0: ldq ap|-3 (rot num 0) tra lshret1-*,ic just returns argument 1. " ifix function -- fixes a floating argument, into a fixnum. " if arg is too large, is an error. segdef ifix ifix: eax6 fn_ifix eax4 -2 tsx0 floval fld ap|-1 fcmg maxfix tmi 3,ic tsx2 badarg tra ifix ufa =71b25,du lda fixnum_type,dl eppap ap|-2 tra bp|0 maxfix: vfd 8/36,1/0,1/1 " maximum fixnum in flonum form. " boole function " uses first arg to determine operation to be performed on remaining args segdef boole lsubr (777003 0 0) boole: eax6 fn_boole eax4 0,x5 tsx0 fixval-*,ic get first arg which must be fixnum lda ap|1,x4 get first arg ana =o17,dl low 4 bits only als 1 times 2 eax3 0,al put into x3 eax4 2,x4 get 2nd arg tsx0 fixval-*,ic lda ap|1,x4 put second arg in result accumulator boole_loop: eax4 2,x4 get next arg tpl boole_fin-*,ic done -- leave. tsx0 fixval-*,ic xed boole_op,x3 do operation tra boole_loop-*,ic and get next arg boole_fin: lrl 36 make fixnum to return lda fixnum_type,dl eppap ap|0,x5 tra bp|0 " table of operations for boole " the first operand is in the a " the second operand is in ap|1,x4 " the result goes in the a " these operations are called by xed. even boole_op: lda 0,dl (0) SETZ tra boole_loop ana ap|1,x4 (1) AND tra boole_loop era ones (2) ANDCA ana ap|1,x4 lda ap|1,x4 (3) SETM tra boole_loop era ones (4) ANDCM xed andcb tra boole_loop (5) SETA nop 0,du era ap|1,x4 (6) XOR tra boole_loop ora ap|1,x4 (7) IOR tra boole_loop andcb: ora ap|1,x4 (10) ANDCB era ones era ap|1,x4 (11) EQV era ones era ones (12) SETCA tra boole_loop era ones (13) ORCA ora ap|1,x4 lda ap|1,x4 (14) SETCM era ones era ones (15) ORCM xed orcb orcb: ana ap|1,x4 (16) ORCB era ones lda ones (17) SETO tra boole_loop " constant for complementing - all ones ones: oct 777777777777 " the single-word comparison operators, <, > and =, must check for error " cases in the interpreter, so they are not identical to greaterp, lessp and eq. segdef ls_ ls_: eax6 fn_ls tsx3 compare_words_with_type tmi ret_t_2 tra ret_nil_2 segdef gt_ gt_: eax6 fn_gt tsx3 compare_words_with_type tze ret_nil_2 tpl ret_t_2 tra ret_nil_2 segdef eql_ eql_: eax6 fn_eql tsx3 compare_words_with_type tze ret_t_2 tra ret_nil_2 compare_words_with_type: eax4 -4 get first argument. tsx0 numval evaluate number...make sure it is one word fix or float tra cmp_flt if float, numval does not skip. eax4 -2 tsx0 fixval verify that val is fixed. ldq ap|-3 cmpq ap|-1 tra 0,x3 x3 must have been preserved. cmp_flt: eax4 -2 tsx0 floval verfy second arg is also float. fld ap|-3 fcmp ap|-1 tra 0,x3 return ret_t_2: ldaq ab|true return t. eppap ap|-4 tra bp|0 and go to caller. ret_nil_2: ldaq ab|nil load up nil. eppap ap|-4 tra bp|0 return to caller. " the typep function returns an atomic symbol " whose name designates the type of object given it as argument. " This is a type 1 subr since the return values are constants " in lisp_static_vars_ (We need our lp) segdef typep subr (1 1 0) " define constants in lisp_static_vars_ link pname,|[pname_atom] link string,|[string_atom] link fixnum,|[fixnum_atom] link flonum,|[flonum_atom] link random,|[random_atom] link bignum,|[bignum_atom] link list,|[list_atom] link array,|[array_atom] typep: lda ap|-2 get argument eppap ap|-2 pop pdl tze typep_4-*,ic Undefined = random cana Atsym,dl tnz typep_1-*,ic cana Big_fixed,dl tnz typep_big-*,ic cana Fixed,dl tnz typep_2-*,ic cana Float,dl tnz typep_3-*,ic cana String,dl tnz typep_str-*,ic cana Array,dl tnz typep_array-*,ic cana lisp_ptr.type,dl tnz typep_4-*,ic ldaq lp|list,* typep_xx: retrn_type_1: epplp ab|-4,x7* return from type 1 subr eppbp ab|-2,x7* eax7 -4,x7 tra bp|0 typep_1: ldaq lp|pname,* tra typep_xx-*,ic typep_array: ldaq lp|array,* tra typep_xx-*,ic typep_str:ldaq lp|string,* tra typep_xx-*,ic typep_big:ldaq lp|bignum,* tra typep_xx-*,ic typep_2: ldaq lp|fixnum,* tra typep_xx-*,ic typep_3: ldaq lp|flonum,* tra typep_xx-*,ic typep_4: ldaq lp|random,* tra typep_xx-*,ic entry pl1_sxhash pl1_sxhash: epbpab |[unmkd_ptr],* eppap |[stack_ptr],* ldx7 |[unmkd_ptr]+1 stz ab|in_pl1_code eax7 4,x7 sprilp ab|-4,x7 " save lp and return address. stcd ab|-2,x7 tra sxhash " and call the lisp routine. eppap ap|2 " now put result back on stack. staq ap|-2 spriap |[stack_ptr] stx7 |[unmkd_ptr]+1 stc1 ab|in_pl1_code short_return segdef sxhash " s-expression hash routine. sxhash: eax5 0,x7 " x5 points to two numeric temps. eax7 2,x7 " x7 keeps top of stack, as usual. stz ab|0,x5 " make sure result starts at zero. ldaq ap|-2 " load argument. tsx6 hash_fcn " call hasher. ldq ab|0,x5 " load result eax7 -2,x7 eppap ap|-2 " pop arg off stack lda fixnum_type,dl " make it a fixnum to return tra retrn_type_1 " and return. hash_fcn: cmpa fixnum_type,dl " check type and go to appropriate routine tze hash_fix cmpa flonum_type,dl tze hash_float cana Atsym,dl tnz hash_sym cana Big_fixed,dl tnz hash_big cana String,dl tnz hash_str cana Atomic,dl tnz 0,x6 " return if unknown type. eppbp ap|-2,* eppap ap|2 " must get car and cdr of list. ldaq bp|2 staq ap|-4 " store cdr for later use ldaq bp|0 staq ap|-2 " and make car the arg. eax7 2,x7 " get room to save return address stx6 ab|-2,x7 " store return address. tsx6 hash_fcn ldq ab|0,x5 " now rotate hash result right. qlr 35 " rotate right 1 stq ab|0,x5 ldx6 ab|-2,x7 " get back return address. eax7 -2,x7 eppap ap|-2 " pop off stacks ldaq ap|-2 " get cdr of list tra hash_fcn " and go back and try again. hash_fix: adlq ab|0,x5 stq ab|0,x5 " store new hash result. tra 0,x6 hash_float: fld ap|-1 " fix up float number for compatibility with PDP10 tpl 3,ic fneg 0,dl fst ap|-1 " store abs val back ldq ap|-1 " now get word of float number lls 9 ana =o777,dl ars 1 lrl 9 " move back to q tra hash_fix hash_sym: eppbp ap|-2,* " get pointer to atsym eppbp bp|4 " make pointer point to string. hash_chrs: ldq bp|0 " load length tze 0,x6 " if zero, don't bother with rest adq 3,dl qrs 2 " divide by 4 hash_com: eax4 0,ql " and move length to x4 stz ab|1,x5 " zero temporary. ldq bp|0,x4 " load the last word so far of the string ersq ab|1,x5 " and xor into result eax4 -1,x4 " move back tnz -3,ic " and loop ldq ab|1,x5 " load up the hash result tra hash_fix " and put it into result hash_str: eppbp ap|-2,* tra hash_chrs hash_big: eppbp ap|-2,* " get pointer to bignum ldq bp|0 " get number of words anq -1,dl " and mask word length out tra hash_com " the signp function, which tests whether the sign " of the second argument (evaluated) matches the sign of the " designation in the first argument (unevaluated), which can " be l,le,e,n,ge,g,a " this is a type 1 subr since it needs to call eval. segdef signp fsubr (0 1 0) signp: eppap ap|2 room for temp eax2 2 eppbp ap|-4,*2 bp = cdr of arg list eppbp bp|0,* ldaq bp|0 get cadr of arg list, = 2nd arg staq ap|-2 save for evaluation ldaq ap|-4,* get car of arg list staq ap|-4 save it. eax7 4,x7 call eval to do 2nd arg sprilp ab|-4,x7 eax5 -2 stcd ab|-2,x7 **** Must be bound in with lisp_ tra |[eval_] eppap ap|2 put result back in pdl staq ap|-2 cmpa flonum_type,dl tze signp_flt-*,ic cana Big_fixed,dl tnz signp_big-*,ic cmpa fixnum_type,dl tnz signp_nil-*,ic not a number, just return nil. szn ap|-1 tmi signp_neg-*,ic tze signp_zero-*,ic tpl signp_plus-*,ic signp_big:szn ap|-2,* points at first word of bignum, upper bit = sign. tmi signp_neg-*,ic tra signp_plus-*,ic can't be zero if a bignum. signp_flt:fszn ap|-1 tmi signp_neg-*,ic tze signp_zero-*,ic tpl signp_plus-*,ic signp_neg:eax5 -1 tra signp_com-*,ic signp_zero: eax5 0 tra signp_com-*,ic signp_plus: eax5 +1 "tra signp_com-*,ic signp_com: " decode first argument lda ap|-4 must be atomic symbol cana Atsym,dl tze bad_signp-*,ic eppbp ap|-4,* -> atomic symbol lda bp|4 get pnamel cmpa 1,dl tnz signp_2-*,ic " must be l,g,a,e,n lda bp|5 get the 1 char pname cmpa =o154000,du l ? tnz xx01-*,ic cmpx5 -1,du yes, neg? tze signp_t-*,ic yes, return t. tra signp_nil-*,ic no, return nil xx01: cmpa =o147000,du g ? tnz xx02-*,ic cmpx5 +1,du yes, pos? tze signp_t-*,ic yes, return t. tra signp_nil-*,ic no, return nil. xx02: cmpa =o141000,du a ? tze signp_t-*,ic yes, always t. cmpa =o145000,du e ? tnz xx03-*,ic cmpx5 0,du yes, zero? tze signp_t-*,ic yes, return t. tra signp_nil-*,ic no, return nil. xx03: cmpa =o156000,du n ? tnz bad_signp-*,ic no, illegal. cmpx5 0,du yes, nonzero? tnz signp_t-*,ic yes, return t. tra signp_nil-*,ic no, return nil. " signp with 1st arg of length 2. Must be le or ge signp_2: cmpa 2,dl really length 2? tnz bad_signp-*,ic no, error. lda bp|5 yes, get the pname cmpa =o147145,du ge ? tnz xx04-*,ic cmpx5 0,du yes, pos or 0? tpl signp_t-*,ic yes, return t. tra signp_nil-*,ic no, return nil. xx04: cmpa =o154145,du le ? tnz bad_signp-*,ic no, error. cmpx5 1,du is it neg or zero? tnz signp_t-*,ic yes, return t. tra signp_nil-*,ic no, return nil. " routines to return t or nil for signp signp_t: ldaq ab|t tra 2,ic signp_nil:ldaq ab|nil subr_1_2_exit: eppap ap|-4 tra typep_xx-*,ic exit from type 1 subr " come here when first arg to signp is bad. bad_signp:eax4 -4 eax6 fn_signp eax2 signp_com-*,ic tra badarg-*,ic returns to signp_com segdef fixgcd " lisp \\ subr. fixgcd: eax6 fn_gcd eax4 -4 tsx0 fixval eax4 -2 tsx0 fixval lda ap|-3 " load first arg tpnz pos1st tze lshret0 neg 0 sta ap|-3 pos1st: lda ap|-1 tpnz pos2nd tze lshret0 neg 0 sta ap|-1 pos2nd: cmpa ap|-3 tmi noexch ldq ap|-3 stq ap|-1 sta ap|-3 noexch: ldq ap|-3 div ap|-1 cmpa 0,dl tze retgcd ldq ap|-1 sta ap|-1 tra -5,ic retgcd: ldaq ap|-2 eppap ap|-4 tra bp|0 end */ ----------------------------------------------------------- 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 */