home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / lookup.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  79KB  |  2,928 lines
  1. /* -*-C-*-
  2.  
  3. $Id: lookup.c,v 9.58 2000/12/05 21:23:45 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /*
  23.  * This file contains symbol lookup and modification routines.
  24.  * See a paper by Jim Miller and Bill Rozas in Lisp and Symbolic Computation
  25.  * (4th issue 1990) for a justification of the algorithms.
  26.  */
  27.  
  28. #include "scheme.h"
  29. #include "locks.h"
  30. #include "trap.h"
  31. #include "lookup.h"
  32.  
  33. static void EXFUN (fix_references, (SCHEME_OBJECT *, SCHEME_OBJECT));
  34. static long EXFUN
  35.   (add_reference, (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT));
  36.  
  37. /* NOTE:
  38.    Although this code has been parallelized, it has not been
  39.    exhaustively tried on a parallel processor.  There are probably
  40.    various race conditions/potential deadlocks that have to be thought
  41.    about carefully.
  42.  */
  43.  
  44. /* Useful constants. */
  45.  
  46. /* This is returned by various procedures to cause a Scheme
  47.    unbound variable error to be signalled.
  48.  */
  49.  
  50. SCHEME_OBJECT unbound_trap_object[] = { UNBOUND_OBJECT };
  51.  
  52. /* This is returned by lookup to force a deep lookup when the variable
  53.    needs to be recompiled.
  54.  */
  55.  
  56. SCHEME_OBJECT uncompiled_trap_object[] = { DANGEROUS_UNBOUND_OBJECT };
  57.  
  58. /* This is returned by lookup to cause a Scheme broken compiled
  59.    variable error to be signalled.
  60.  */
  61.  
  62. SCHEME_OBJECT illegal_trap_object[] = { ILLEGAL_OBJECT };
  63.  
  64. /* This is passed to deep_lookup as the variable to compile when
  65.    we don't really have a variable.
  66.  */
  67.  
  68. SCHEME_OBJECT fake_variable_object[3];
  69.  
  70. /* scan_frame searches a frame for a given name.
  71.    If it finds the names, it stores into hunk the path by which it was
  72.    found, so that future references do not spend the time to find it
  73.    again.  It returns a pointer to the value cell, or a null pointer
  74.    cell if the variable was not found in this frame.
  75.  */
  76.  
  77. extern SCHEME_OBJECT *
  78.   EXFUN (scan_frame,
  79.      (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, long, Boolean));
  80.  
  81. SCHEME_OBJECT *
  82. DEFUN (scan_frame, (frame, sym, hunk, depth, unbound_valid_p),
  83.        SCHEME_OBJECT frame
  84.        AND SCHEME_OBJECT sym
  85.        AND SCHEME_OBJECT * hunk
  86.        AND long depth
  87.        AND Boolean unbound_valid_p)
  88. {
  89. #ifdef DECLARE_LOCK
  90.   DECLARE_LOCK (compile_serializer);
  91. #endif
  92.   fast SCHEME_OBJECT *scan, temp;
  93.   fast long count;
  94.  
  95.   temp = MEMORY_REF (frame, ENVIRONMENT_FUNCTION);
  96.  
  97.   if (OBJECT_TYPE (temp) == AUX_LIST_TYPE)
  98.   {
  99.     /* Search for an auxiliary binding. */
  100.  
  101.     SCHEME_OBJECT *start;
  102.  
  103.     scan = OBJECT_ADDRESS (temp);
  104.     start = scan;
  105.     count = Lexical_Offset(scan[AUX_LIST_COUNT]);
  106.     scan += AUX_LIST_FIRST;
  107.  
  108.     while (--count >= 0)
  109.     {
  110.       if (FAST_PAIR_CAR (*scan) == sym)
  111.       {
  112.     SCHEME_OBJECT *cell;
  113.  
  114.     cell = PAIR_CDR_LOC (*scan);
  115.     if (MEMORY_FETCH (cell[0]) == DANGEROUS_UNBOUND_OBJECT)
  116.     {
  117.       /* A dangerous unbound object signals that
  118.          a definition here must become dangerous,
  119.          but is not a real bining.
  120.        */
  121.       return (unbound_valid_p ? (cell) : ((SCHEME_OBJECT *) NULL));
  122.     }
  123.     setup_lock(compile_serializer, hunk);
  124.     hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (AUX_REF, depth);
  125.     hunk[VARIABLE_OFFSET] = Make_Local_Offset(scan - start);
  126.     remove_lock(compile_serializer);
  127.     return (cell);
  128.       }
  129.       scan += 1;
  130.     }
  131.     temp = MEMORY_REF (temp, ENV_EXTENSION_PROCEDURE);
  132.   }
  133.  
  134.   /* Search for a formal parameter. */
  135.  
  136.   temp = (FAST_MEMORY_REF ((FAST_MEMORY_REF (temp, PROCEDURE_LAMBDA_EXPR)),
  137.                LAMBDA_FORMALS));
  138.   for (count = ((VECTOR_LENGTH (temp)) - 1),
  139.        scan = (MEMORY_LOC (temp, VECTOR_DATA + 1));
  140.        count > 0;
  141.        count -= 1,
  142.        scan += 1)
  143.   {
  144.     if (*scan == sym)
  145.     {
  146.       fast long offset;
  147.  
  148.       offset = 1 + VECTOR_LENGTH (temp) - count;
  149.  
  150.       setup_lock(compile_serializer, hunk);
  151.       if (depth != 0)
  152.       {
  153.     hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (FORMAL_REF, depth);
  154.     hunk[VARIABLE_OFFSET] = Make_Local_Offset(offset);
  155.       }
  156.       else
  157.       {
  158.     hunk[VARIABLE_COMPILED_TYPE] = Make_Local_Offset(offset);
  159.     hunk[VARIABLE_OFFSET] = SHARP_F;
  160.       }
  161.       remove_lock(compile_serializer);
  162.  
  163.       return (MEMORY_LOC (frame, offset));
  164.     }
  165.   }
  166.  
  167.   return ((SCHEME_OBJECT *) NULL);
  168. }
  169.  
  170. /* The lexical lookup procedure.
  171.    deep_lookup searches env for an occurrence of sym.  When it finds
  172.    it, it stores into hunk the path by which it was found, so that
  173.    future references do not spend the time to find it again.
  174.    It returns a pointer to the value cell, or a bogus value cell if
  175.    the variable was unbound.
  176.  */
  177.  
  178. SCHEME_OBJECT *
  179. DEFUN (deep_lookup, (env, sym, hunk),
  180.        SCHEME_OBJECT env
  181.        AND SCHEME_OBJECT sym
  182.        AND SCHEME_OBJECT * hunk)
  183. {
  184. #ifdef DECLARE_LOCK
  185.   DECLARE_LOCK (compile_serializer);
  186. #endif
  187.   fast SCHEME_OBJECT frame;
  188.   fast long depth;
  189.  
  190.   for (depth = 0, frame = env;
  191.        OBJECT_TYPE (frame) != GLOBAL_ENV;
  192.        depth += 1,
  193.        frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION),
  194.                    PROCEDURE_ENVIRONMENT))
  195.   {
  196.     fast SCHEME_OBJECT *cell;
  197.  
  198.     cell = (scan_frame (frame, sym, hunk, depth, false));
  199.     if (cell != ((SCHEME_OBJECT *) NULL))
  200.     {
  201.       return (cell);
  202.     }
  203.   }
  204.  
  205.   /* The reference is global. */
  206.  
  207.   if (OBJECT_DATUM (frame) != GO_TO_GLOBAL)
  208.   {
  209.     return (unbound_trap_object);
  210.   }
  211.  
  212.   setup_lock(compile_serializer, hunk);
  213.   hunk[VARIABLE_COMPILED_TYPE] = (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, sym));
  214.   hunk[VARIABLE_OFFSET] = SHARP_F;
  215.   remove_lock(compile_serializer);
  216.  
  217.   return (MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE));
  218. }
  219.  
  220. /* Shallow lookup performed "out of line" by various procedures.
  221.    It takes care of invoking deep_lookup when necessary.
  222.  */
  223.  
  224. extern SCHEME_OBJECT *
  225.   EXFUN (lookup_cell, (SCHEME_OBJECT *, SCHEME_OBJECT));
  226.  
  227. SCHEME_OBJECT *
  228. DEFUN (lookup_cell, (hunk, env),
  229.        SCHEME_OBJECT * hunk
  230.        AND SCHEME_OBJECT env)
  231. {
  232.   SCHEME_OBJECT *cell, value;
  233.   long trap_kind;
  234.  
  235.   lookup(cell, env, hunk, repeat_lookup_cell);
  236.  
  237.   value = MEMORY_FETCH (cell[0]);
  238.  
  239.   if (OBJECT_TYPE (value) != TC_REFERENCE_TRAP)
  240.   {
  241.     return (cell);
  242.   }
  243.  
  244.   get_trap_kind(trap_kind, value);
  245.   switch(trap_kind)
  246.   {
  247.     case TRAP_DANGEROUS:
  248.     case TRAP_UNBOUND_DANGEROUS:
  249.     case TRAP_UNASSIGNED_DANGEROUS:
  250.     case TRAP_FLUID_DANGEROUS:
  251.     case TRAP_COMPILER_CACHED_DANGEROUS:
  252.       return (deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk));
  253.  
  254.     case TRAP_COMPILER_CACHED:
  255.     case TRAP_FLUID:
  256.     case TRAP_UNBOUND:
  257.     case TRAP_UNASSIGNED:
  258.       return (cell);
  259.  
  260.     default:
  261.       return (illegal_trap_object);
  262.   }
  263. }
  264.  
  265. /* Full lookup end code.
  266.    deep_lookup_end handles all the complicated and dangerous cases.
  267.    cell is the value cell (supposedly found by deep_lookup).  Hunk is
  268.    the address of the scode variable object which may need to be
  269.    recompiled if the reference is dangerous.
  270.  */
  271.  
  272. long
  273. DEFUN (deep_lookup_end, (cell, hunk),
  274.        SCHEME_OBJECT * cell
  275.        AND SCHEME_OBJECT * hunk)
  276. {
  277.   long trap_kind;
  278.   long return_value = PRIM_DONE;
  279.   Boolean repeat_p;
  280.  
  281.   do {
  282.     repeat_p = false;
  283.     Val = MEMORY_FETCH (cell[0]);
  284.     FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
  285.     if (!(REFERENCE_TRAP_P(Val)))
  286.     {
  287.       return (PRIM_DONE);
  288.     }
  289.  
  290.     /* Remarks:
  291.        In the code below, break means uncompile the variable,
  292.        while continue means do not.
  293.        If repeat_p is set the whole process is redone, but since the
  294.        "danger bit" is kept on the outermost trap, the "uncompilation"
  295.        will not be affected by subsequent iterations.
  296.      */
  297.  
  298.     get_trap_kind(trap_kind, Val);
  299.     switch(trap_kind)
  300.     {
  301.       /* The following cases are divided into pairs:
  302.      the non-dangerous version leaves the compilation alone.
  303.      The dangerous version uncompiles.
  304.        */
  305.  
  306.       case TRAP_UNASSIGNED:
  307.     return (ERR_UNASSIGNED_VARIABLE);
  308.  
  309.       case TRAP_UNASSIGNED_DANGEROUS:
  310.     return_value = ERR_UNASSIGNED_VARIABLE;
  311.     break;
  312.  
  313.       case TRAP_DANGEROUS:
  314.       {
  315.     SCHEME_OBJECT trap_value;
  316.  
  317.     trap_value = Val;
  318.     Val = (MEMORY_REF (trap_value, TRAP_EXTRA));
  319.     FUTURE_VARIABLE_SPLICE (trap_value, TRAP_EXTRA, Val);
  320.     return_value = PRIM_DONE;
  321.     break;
  322.       }
  323.  
  324.       case TRAP_FLUID:
  325.       case TRAP_FLUID_DANGEROUS:
  326.     cell = lookup_fluid(Val);
  327.     repeat_p = true;
  328.     if (trap_kind == TRAP_FLUID)
  329.       continue;
  330.     break;
  331.  
  332.       case TRAP_COMPILER_CACHED:
  333.       case TRAP_COMPILER_CACHED_DANGEROUS:
  334.     cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
  335.     repeat_p = true;
  336.     if (trap_kind == TRAP_COMPILER_CACHED)
  337.       continue;
  338.     break;
  339.  
  340.       case TRAP_UNBOUND:
  341.     return (ERR_UNBOUND_VARIABLE);
  342.  
  343.       case TRAP_UNBOUND_DANGEROUS:
  344.     return_value = ERR_UNBOUND_VARIABLE;
  345.     break;
  346.  
  347.       default:
  348.     return_value = ERR_ILLEGAL_REFERENCE_TRAP;
  349.     break;
  350.     }
  351.  
  352.     /* The reference was dangerous, uncompile the variable. */
  353.     {
  354. #ifdef DECLARE_LOCK
  355.       DECLARE_LOCK (compile_serializer);
  356. #endif
  357.       setup_lock(compile_serializer, hunk);
  358.       hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
  359.       hunk[VARIABLE_OFFSET] = SHARP_F;
  360.       remove_lock(compile_serializer);
  361.     }
  362.  
  363.   } while (repeat_p);
  364.  
  365.   return (return_value);
  366. }
  367.  
  368. /* Simple lookup finalization.
  369.    All the hairy cases are left to deep_lookup_end.
  370.    env is the environment where the reference was supposedly resolved.
  371.    If there is any question about the validity of the resolution (due
  372.    to dangerousness, for example), a deep lookup operation is
  373.    performed, and control is given to deep_lookup_end.
  374.  */
  375.  
  376. long
  377. DEFUN (lookup_end, (cell, env, hunk),
  378.        SCHEME_OBJECT * cell
  379.        AND SCHEME_OBJECT env
  380.        AND SCHEME_OBJECT * hunk)
  381. {
  382.   long trap_kind;
  383.  
  384. lookup_end_restart:
  385.   Val = MEMORY_FETCH (cell[0]);
  386.   FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
  387.  
  388.   if (!(REFERENCE_TRAP_P(Val)))
  389.   {
  390.     return (PRIM_DONE);
  391.   }
  392.  
  393.   get_trap_kind(trap_kind, Val);
  394.   switch(trap_kind)
  395.   {
  396.     case TRAP_DANGEROUS:
  397.     case TRAP_UNBOUND_DANGEROUS:
  398.     case TRAP_UNASSIGNED_DANGEROUS:
  399.     case TRAP_FLUID_DANGEROUS:
  400.     case TRAP_COMPILER_CACHED_DANGEROUS:
  401.       return
  402.     (deep_lookup_end(deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk),
  403.              hunk));
  404.  
  405.     case TRAP_COMPILER_CACHED:
  406.       cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
  407.       goto lookup_end_restart;
  408.  
  409.     case TRAP_FLUID:
  410.       cell = lookup_fluid(Val);
  411.       goto lookup_end_restart;
  412.  
  413.     case TRAP_UNBOUND:
  414.       return (ERR_UNBOUND_VARIABLE);
  415.  
  416.     case TRAP_UNASSIGNED:
  417.       return (ERR_UNASSIGNED_VARIABLE);
  418.  
  419.     default:
  420.       return (ERR_ILLEGAL_REFERENCE_TRAP);
  421.   }
  422. }
  423.  
  424. /* Complete assignment finalization.
  425.  
  426.    deep_assignment_end handles all dangerous cases, and busts compiled
  427.    code operator reference caches as appropriate.  It is similar to
  428.    deep_lookup_end.
  429.    value is the new value for the variable.
  430.    force forces an assignment if the variable is unbound.  This is
  431.    used for redefinition in the global environment
  432.  
  433.    Notes on multiprocessor locking:
  434.  
  435.    The lock for assignment is usually in the original value cell in
  436.    the environment structure.
  437.    There are two cases where it is not:
  438.  
  439.    - Deep fluid variables.  The lock is in the fluid value cell
  440.    corresponding to this process.  The original lock is removed before
  441.    the fluid list is examined.
  442.  
  443.    - Compiler cached variables.  The lock is in the new value cell.
  444.    It is here so that compiled code can also lock it, since it does
  445.    not have a pointer to the environment structure at all.  The lock
  446.    is moved (updated) from the original location to the new location.
  447.    Ideally the original lock is not released until the new one is
  448.    acquired, but we may not be able to guarantee this.
  449.    The code is carefully written so that a weaker condition makes it
  450.    valid.  The condition is that locks should be granted in the order
  451.    of request.  The reason for this is that the code which can
  452.    affect an operation must acquire the same locks and in the same
  453.    order, thus if there is no interleaving of these operations, the
  454.    result will be correct.
  455.  
  456.    Important:
  457.  
  458.    A re-definition can take place before the lock is grabbed in this
  459.    code and we will be clobbering the wrong cell.  To be paranoid we
  460.    should redo the lookup while we have the cell locked and confirm
  461.    that this is still valid, but this is hard to do here.
  462.    Alternatively the lock could be grabbed by the caller and passed as
  463.    an argument after confirming the correctness of the binding.  A
  464.    third option (the one in place now) is not to worry about this,
  465.    saying that there is a race condition in the user code and that the
  466.    definition happened after this assignment.  For more precise
  467.    sequencing, the user should synchronize her/his assignments and
  468.    definitions her/himself.
  469.  
  470.    assignment_end suffers from this problem as well.
  471.  
  472.  */
  473.  
  474. #define RESULT(value)                            \
  475. {                                    \
  476.   return_value = (value);                        \
  477.   break;                                \
  478. }
  479.  
  480. #define UNCOMPILE(value)                        \
  481. {                                    \
  482.   uncompile_p = true;                            \
  483.   return_value = (value);                        \
  484.   break;                                \
  485. }
  486.  
  487. #define ABORT(value)                            \
  488. {                                    \
  489.   remove_lock(set_serializer);                        \
  490.   return (value);                            \
  491. }
  492.  
  493. #define REDO()                                \
  494. {                                    \
  495.   repeat_p = true;                            \
  496.   break;                                \
  497. }
  498.  
  499. long
  500. DEFUN (deep_assignment_end, (cell, hunk, value, force),
  501.        fast SCHEME_OBJECT * cell
  502.        AND SCHEME_OBJECT * hunk
  503.        AND SCHEME_OBJECT value
  504.        AND Boolean force)
  505. {
  506. #ifdef DECLARE_LOCK
  507.   DECLARE_LOCK (set_serializer);
  508. #endif
  509.   long trap_kind;
  510.   long return_value = PRIM_DONE;
  511.   SCHEME_OBJECT bogus_unassigned, extension, saved_extension;
  512.   SCHEME_OBJECT saved_value = SHARP_F;
  513.   Boolean repeat_p, uncompile_p, fluid_lock_p;
  514.  
  515.   /* State variables */
  516.   saved_extension = SHARP_F;
  517.   uncompile_p = false;
  518.   fluid_lock_p = false;
  519.  
  520.   bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
  521.   if (value == bogus_unassigned)
  522.     value = UNASSIGNED_OBJECT;
  523.  
  524.   setup_lock(set_serializer, cell);
  525.  
  526.   do {
  527.  
  528.     repeat_p = false;
  529.     Val = *cell;
  530.  
  531.     if (!(REFERENCE_TRAP_P(Val)))
  532.     {
  533.       *cell = value;
  534.       RESULT(PRIM_DONE);
  535.     }
  536.  
  537.     /* Below, break means uncompile the variable. */
  538.  
  539.     get_trap_kind(trap_kind, Val);
  540.  
  541.     switch(trap_kind)
  542.     {
  543.       case TRAP_DANGEROUS:
  544.         Val = MEMORY_REF (Val, TRAP_EXTRA);
  545.     if (value == UNASSIGNED_OBJECT)
  546.     {
  547.       *cell = DANGEROUS_UNASSIGNED_OBJECT;
  548.     }
  549.     else
  550.     {
  551.       Do_Store_No_Lock ((MEMORY_LOC (*cell, TRAP_EXTRA)), value);
  552.     }
  553.     UNCOMPILE(PRIM_DONE);
  554.  
  555.       case TRAP_UNBOUND:
  556.     if (!force)
  557.     {
  558.       UNCOMPILE(ERR_UNBOUND_VARIABLE)
  559.     }
  560.     /* Fall through */
  561.  
  562.       case TRAP_UNASSIGNED:
  563.     Val = bogus_unassigned;
  564.     *cell = value;
  565.     RESULT(PRIM_DONE);
  566.  
  567.       case TRAP_UNBOUND_DANGEROUS:
  568.     if (!force)
  569.     {
  570.       UNCOMPILE(ERR_UNBOUND_VARIABLE);
  571.     }
  572.  
  573.     if (value == UNASSIGNED_OBJECT)
  574.     {
  575.       *cell = DANGEROUS_UNASSIGNED_OBJECT;
  576.       UNCOMPILE(PRIM_DONE);
  577.     }
  578.     /* Fall through */
  579.  
  580.       case TRAP_UNASSIGNED_DANGEROUS:
  581.     Val = bogus_unassigned;
  582.     if (value != UNASSIGNED_OBJECT)
  583.     {
  584.       SCHEME_OBJECT result;
  585.  
  586.       if (GC_allocate_test(2))
  587.       {
  588.         Request_GC(2);
  589.         ABORT(PRIM_INTERRUPT);
  590.       }
  591.       result = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
  592.       *Free++ = DANGEROUS_OBJECT;
  593.       *Free++ = value;
  594.       *cell = result;
  595.     }
  596.     UNCOMPILE(PRIM_DONE);
  597.  
  598.       case TRAP_EXPENSIVE:
  599.     /* This should only happen if we have been invoked by
  600.        compiler_assignment_end invoked by compiler_reference_trap;
  601.      */
  602.     extension = cell[TRAP_EXTENSION_CLONE];
  603.     goto compiler_cache_assignment;
  604.  
  605.       case TRAP_COMPILER_CACHED_DANGEROUS:
  606.     uncompile_p = true;
  607.     /* Fall through */
  608.  
  609.       case TRAP_COMPILER_CACHED:
  610.     extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
  611.  
  612. compiler_cache_assignment:
  613.     {
  614.       SCHEME_OBJECT references;
  615.  
  616.       /* Unlock and lock at the new value cell. */
  617.  
  618.       references = (FAST_MEMORY_REF (extension,
  619.                      TRAP_EXTENSION_REFERENCES));
  620.       cell = (MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
  621.       update_lock (set_serializer, cell);
  622.  
  623.       if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
  624.           != SHARP_F)
  625.       {
  626.         if (saved_extension != SHARP_F)
  627.         {
  628.           ABORT(ERR_BROKEN_VARIABLE_CACHE);
  629.         }
  630.         saved_extension = extension;
  631.         saved_value = *cell;
  632.       }
  633.       REDO();
  634.     }
  635.  
  636.       /* Remarks:
  637.      If this is the inner trap of a compiler cache, and there are
  638.      uuo links, there will actually be no recaching, since the old
  639.      contents and the new one will be the fluid trap, and the
  640.      links will already be set up for the fluid trap.  Thus we can
  641.      temporarily unlock while the iteration takes place.
  642.        */
  643.       case TRAP_FLUID_DANGEROUS:
  644.     uncompile_p = true;
  645.     /* Fall through */
  646.  
  647.       case TRAP_FLUID:
  648.     fluid_lock_p = true;
  649.     remove_lock(set_serializer);
  650.     cell = lookup_fluid(Val);
  651.     setup_lock(set_serializer, cell);
  652.     REDO();
  653.  
  654.       default:
  655.     UNCOMPILE(ERR_ILLEGAL_REFERENCE_TRAP);
  656.     }
  657.   } while (repeat_p);
  658.  
  659.   if (saved_extension != SHARP_F)
  660.   {
  661.     if (fluid_lock_p)
  662.     {
  663.       /* Guarantee that there is a lock on the variable cache around
  664.      the call to recache_uuo_links.
  665.        */
  666.  
  667.       update_lock (set_serializer,
  668.            (MEMORY_LOC (saved_extension, TRAP_EXTENSION_CELL)));
  669.     }
  670.  
  671.     /* NOTE:
  672.        recache_uuo_links can take an arbitrary amount of time since
  673.        there may be an internal lock and the code may have to uncache
  674.        arbitrarily many links.
  675.        Deadlock should not occur since both locks are always acquired
  676.        in the same order.
  677.      */
  678.  
  679.     return_value = (recache_uuo_links (saved_extension, saved_value));
  680.     remove_lock (set_serializer);
  681.  
  682.     if (return_value != PRIM_DONE)
  683.     {
  684.       return (return_value);
  685.     }
  686.   }
  687.   else
  688.   {
  689.     remove_lock (set_serializer);
  690.   }
  691.  
  692.   /* This must be done after the assignment lock has been removed,
  693.      to avoid potential deadlock.
  694.    */
  695.  
  696.   if (uncompile_p)
  697.   {
  698.     /* The reference was dangerous, uncompile the variable. */
  699. #ifdef DECLARE_LOCK
  700.     DECLARE_LOCK (compile_serializer);
  701. #endif
  702.     setup_lock (compile_serializer, hunk);
  703.     hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
  704.     hunk[VARIABLE_OFFSET] = SHARP_F;
  705.     remove_lock (compile_serializer);
  706.   }
  707.  
  708.   return (return_value);
  709. }
  710.  
  711. #undef ABORT
  712. #undef REDO
  713. #undef RESULT
  714. #undef UNCOMPILE
  715.  
  716. /* Simple assignment end.
  717.    assignment_end lets deep_assignment_end handle all the hairy cases.
  718.    It is similar to lookup_end, but there is some hair for
  719.    unassignedness and compiled code cached references.
  720.  */
  721.  
  722. long
  723. DEFUN (assignment_end, (cell, env, hunk, value),
  724.        fast SCHEME_OBJECT * cell
  725.        AND SCHEME_OBJECT env
  726.        AND SCHEME_OBJECT * hunk
  727.        AND SCHEME_OBJECT value)
  728. {
  729. #ifdef DECLARE_LOCK
  730.   DECLARE_LOCK (set_serializer);
  731. #endif
  732.   SCHEME_OBJECT bogus_unassigned;
  733.   long temp;
  734.  
  735.   bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
  736.   if (value == bogus_unassigned)
  737.     value = UNASSIGNED_OBJECT;
  738.  
  739. assignment_end_before_lock:
  740.  
  741.   setup_lock(set_serializer, cell);
  742.  
  743. assignment_end_after_lock:
  744.  
  745.   Val = *cell;
  746.  
  747.   if (!(REFERENCE_TRAP_P(Val)))
  748.   {
  749.     *cell = value;
  750.     remove_lock(set_serializer);
  751.     return (PRIM_DONE);
  752.   }
  753.  
  754.   get_trap_kind(temp, Val);
  755.   switch(temp)
  756.   {
  757.     case TRAP_DANGEROUS:
  758.     case TRAP_UNBOUND_DANGEROUS:
  759.     case TRAP_UNASSIGNED_DANGEROUS:
  760.     case TRAP_FLUID_DANGEROUS:
  761.     case TRAP_COMPILER_CACHED_DANGEROUS:
  762.       remove_lock(set_serializer);
  763.       return
  764.     (deep_assignment_end(deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk),
  765.                  hunk,
  766.                  value,
  767.                  false));
  768.  
  769.     case TRAP_COMPILER_CACHED:
  770.     {
  771.       SCHEME_OBJECT extension, references;
  772.  
  773.       extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
  774.       references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
  775.  
  776.       if (FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) != SHARP_F)
  777.       {
  778.     /* There are uuo links.
  779.        wimp out and let deep_assignment_end handle it.
  780.      */
  781.  
  782.     remove_lock(set_serializer);
  783.     return (deep_assignment_end(cell, hunk, value, false));
  784.       }
  785.       cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
  786.       update_lock(set_serializer, cell);
  787.       goto assignment_end_after_lock;
  788.     }
  789.  
  790.     case TRAP_FLUID:
  791.       remove_lock(set_serializer);
  792.       cell = lookup_fluid(Val);
  793.       goto assignment_end_before_lock;
  794.  
  795.     case TRAP_UNBOUND:
  796.       temp = ERR_UNBOUND_VARIABLE;
  797.       break;
  798.  
  799.     case TRAP_UNASSIGNED:
  800.       Val = bogus_unassigned;
  801.       *cell = value;
  802.       temp = PRIM_DONE;
  803.       break;
  804.  
  805.     default:
  806.       temp = ERR_ILLEGAL_REFERENCE_TRAP;
  807.       break;
  808.   }
  809.   remove_lock(set_serializer);
  810.   return (temp);
  811. }
  812.  
  813. /* Finds the fluid value cell associated with the reference trap on
  814.    this processor's fluid "binding" list.  It is just like ASSQ.
  815.  */
  816.  
  817. SCHEME_OBJECT *
  818. DEFUN (lookup_fluid, (trap), fast SCHEME_OBJECT trap)
  819. {
  820.   fast SCHEME_OBJECT fluids, *this_pair;
  821.  
  822.   fluids = Fluid_Bindings;
  823.  
  824.   if (Fluids_Debug)
  825.   {
  826.     Print_Expression(fluids, "Searching fluid bindings");
  827.   }
  828.  
  829.   while (PAIR_P(fluids))
  830.   {
  831.     this_pair = OBJECT_ADDRESS (FAST_PAIR_CAR (fluids));
  832.  
  833.     if (this_pair[CONS_CAR] == trap)
  834.     {
  835.       if (Fluids_Debug)
  836.     outf_error ("Fluid found.\n");
  837.  
  838.       return (&this_pair[CONS_CDR]);
  839.     }
  840.  
  841.     fluids = FAST_PAIR_CDR (fluids);
  842.   }
  843.  
  844.   /* Not found in fluid binding alist, so use default. */
  845.  
  846.   if (Fluids_Debug)
  847.     outf_error ("Fluid not found, using default.\n");
  848.  
  849.   return (MEMORY_LOC (trap, TRAP_EXTRA));
  850. }
  851.  
  852. /* Utilities for definition.
  853.  
  854.    redefinition is used when the definition is in fact an assignment.
  855.    A binding already exists in this frame.
  856.  
  857.    dangerize is invoked to guarantee that any variables "compiled" to
  858.    this location are recompiled at the next reference.
  859.  */
  860.  
  861. #define redefinition(cell, value) \
  862.   (deep_assignment_end (cell, fake_variable_object, value, true))
  863.  
  864. long
  865. DEFUN (definition, (cell, value, shadowed_p),
  866.        SCHEME_OBJECT * cell
  867.        AND SCHEME_OBJECT value
  868.        AND Boolean shadowed_p)
  869. {
  870.   if (shadowed_p)
  871.     return (redefinition (cell, value));
  872.   else
  873.   {
  874. #ifdef DECLARE_LOCK
  875.     DECLARE_LOCK (set_serializer);
  876. #endif
  877.     setup_lock (set_serializer, cell);
  878.     if (*cell == DANGEROUS_UNBOUND_OBJECT)
  879.     {
  880.       *cell = value;
  881.       remove_lock (set_serializer);
  882.       return (PRIM_DONE);
  883.     }
  884.     else
  885.     {
  886.       /* Unfortunate fact of life: This binding will be dangerous
  887.      even if there was no need, but this is the only way to
  888.      guarantee consistent values.
  889.        */
  890.       remove_lock (set_serializer);
  891.       return (redefinition (cell, value));
  892.     }
  893.   }
  894. }
  895.  
  896. long
  897. DEFUN (dangerize, (cell, sym),
  898.        fast SCHEME_OBJECT * cell
  899.        AND SCHEME_OBJECT sym)
  900. {
  901. #ifdef DECLARE_LOCK
  902.   DECLARE_LOCK (set_serializer);
  903. #endif
  904.   fast long temp;
  905.   SCHEME_OBJECT trap;
  906.  
  907.   setup_lock (set_serializer, cell);
  908.   if (!(REFERENCE_TRAP_P (*cell)))
  909.   {
  910.     if (GC_allocate_test (2))
  911.     {
  912.       remove_lock (set_serializer);
  913.       Request_GC (2);
  914.       return (PRIM_INTERRUPT);
  915.     }
  916.     trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
  917.     *Free++ = DANGEROUS_OBJECT;
  918.     *Free++ = *cell;
  919.     *cell = trap;
  920.     remove_lock (set_serializer);
  921.     return (simple_uncache (cell, sym));
  922.   }
  923.  
  924.   get_trap_kind (temp, *cell);
  925.   switch (temp)
  926.   {
  927.     case TRAP_UNBOUND_DANGEROUS:
  928.     case TRAP_UNASSIGNED_DANGEROUS:
  929.     case TRAP_DANGEROUS:
  930.     case TRAP_FLUID_DANGEROUS:
  931.       break;
  932.  
  933.     case TRAP_COMPILER_CACHED:
  934.       Do_Store_No_Lock
  935.     ((MEMORY_LOC (*cell, TRAP_TAG)),
  936.      (LONG_TO_UNSIGNED_FIXNUM (TRAP_COMPILER_CACHED_DANGEROUS)));
  937.       /* Fall through */
  938.  
  939.     case TRAP_COMPILER_CACHED_DANGEROUS:
  940.     {
  941.       remove_lock (set_serializer);
  942.       return (compiler_uncache (cell, sym));
  943.     }
  944.  
  945.     case TRAP_FLUID:
  946.       Do_Store_No_Lock
  947.     ((MEMORY_LOC (*cell, TRAP_TAG)),
  948.      (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID_DANGEROUS)));
  949.       break;
  950.  
  951.     case TRAP_UNBOUND:
  952.       *cell = DANGEROUS_UNBOUND_OBJECT;
  953.       break;
  954.  
  955.     case TRAP_UNASSIGNED:
  956.       *cell = DANGEROUS_UNASSIGNED_OBJECT;
  957.       break;
  958.  
  959.     default:
  960.       remove_lock (set_serializer);
  961.       return (ERR_ILLEGAL_REFERENCE_TRAP);
  962.   }
  963.   remove_lock (set_serializer);
  964.   return (simple_uncache (cell, sym));
  965. }
  966.  
  967. /* The core of the incremental definition mechanism.
  968.  
  969.    It takes care of dangerizing any bindings being shadowed by this
  970.    definition, extending the frames appropriately, and uncaching or
  971.    recaching (according to the DEFINITION_RECACHES_EAGERLY flag) any
  972.    compiled code reference caches which might be affected by the new
  973.    definition.
  974.  
  975.    *UNDEFINE*: If (local?) undefine is ever implemented, it suffices
  976.    to set the value cell to DANGEROUS_UNBOUND_OBJECT, uncache all the
  977.    compiler cached variables to the location, and rewrite the code
  978.    below slightly as implied by the comments tagged *UNDEFINE*.
  979.  */
  980.  
  981. long
  982. DEFUN (extend_frame,
  983.        (env, sym, value, original_frame, recache_p),
  984.        SCHEME_OBJECT env
  985.        AND SCHEME_OBJECT sym
  986.        AND SCHEME_OBJECT value
  987.        AND SCHEME_OBJECT original_frame
  988.        AND Boolean recache_p)
  989. {
  990. #ifdef DECLARE_LOCK
  991.   DECLARE_LOCK (extension_serializer);
  992. #endif
  993.   SCHEME_OBJECT extension, the_procedure;
  994.   fast SCHEME_OBJECT *scan;
  995.   long aux_count;
  996.  
  997.   if ((OBJECT_TYPE (env)) == GLOBAL_ENV)
  998.   {
  999.     /* *UNDEFINE*: If undefine is ever implemented, this code need not
  1000.        change: There are no shadowed bindings that need to be
  1001.        recached.
  1002.      */
  1003.     if ((OBJECT_DATUM (env)) != GO_TO_GLOBAL)
  1004.     {
  1005.       if (env == original_frame)
  1006.       {
  1007.     return (ERR_BAD_FRAME);
  1008.       }
  1009.       else
  1010.       {
  1011.     /* We have a new definition in a chain rooted at the empty
  1012.        environment.
  1013.        We need not uncache/recache, but we need to set all
  1014.        global state accordingly.
  1015.        We use a cell which never needs uncacheing/recacheing
  1016.        and use the ordinary code otherwise.
  1017.  
  1018.        This is done only because of compiler cached variables.
  1019.      */
  1020.     return (compiler_uncache ((unbound_trap_object), sym));
  1021.       }
  1022.     }
  1023.     else if (env == original_frame)
  1024.     {
  1025.       return (redefinition ((MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE)),
  1026.                 value));
  1027.     }
  1028.     else
  1029.     {
  1030.       return (dangerize ((MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE)), sym));
  1031.     }
  1032.   }
  1033.  
  1034.   the_procedure = (MEMORY_REF (env, ENVIRONMENT_FUNCTION));
  1035.   if ((OBJECT_TYPE (the_procedure)) == AUX_LIST_TYPE)
  1036.     the_procedure = (MEMORY_REF (the_procedure, ENV_EXTENSION_PROCEDURE));
  1037.  
  1038.   /* Search the formals. */
  1039.  
  1040.   {
  1041.     fast long count;
  1042.     SCHEME_OBJECT formals;
  1043.  
  1044.     formals = (FAST_MEMORY_REF ((FAST_MEMORY_REF (the_procedure,
  1045.                           PROCEDURE_LAMBDA_EXPR)),
  1046.                 LAMBDA_FORMALS));
  1047.     for (count = ((VECTOR_LENGTH (formals)) - 1),
  1048.      scan = (MEMORY_LOC (formals, VECTOR_DATA + 1));
  1049.      count > 0;
  1050.      count -= 1)
  1051.     {
  1052.       /* *UNDEFINE*: If undefine is ever implemented, this code must
  1053.      check whether the value is DANGEROUS_UNBOUND_OBJECT, and if
  1054.      so, a search must be done to cause the shadowed compiler
  1055.      cached variables to be recached, as in the aux case below.
  1056.        */
  1057.       if (*scan++ == sym)
  1058.       {
  1059.     long offset;
  1060.  
  1061.     offset = (1 + (VECTOR_LENGTH (formals))) - count;
  1062.     if (env == original_frame)
  1063.     {
  1064.       return (redefinition ((MEMORY_LOC (env, offset)), value));
  1065.     }
  1066.     else
  1067.     {
  1068.       return (dangerize ((MEMORY_LOC (env, offset)), sym));
  1069.     }
  1070.       }
  1071.     }
  1072.   }
  1073.  
  1074.   /* Guarantee that there is an extension slot. */
  1075.  
  1076. redo_aux_lookup:
  1077.  
  1078.   setup_lock (extension_serializer, (OBJECT_ADDRESS (env)));
  1079.   extension = (FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION));
  1080.   if ((OBJECT_TYPE (extension)) != AUX_LIST_TYPE)
  1081.   {
  1082.     fast long i;
  1083.  
  1084.     if (GC_allocate_test (AUX_LIST_INITIAL_SIZE))
  1085.     {
  1086.       remove_lock (extension_serializer);
  1087.       Request_GC (AUX_LIST_INITIAL_SIZE);
  1088.       return (PRIM_INTERRUPT);
  1089.     }
  1090.     scan = Free;
  1091.     extension = (MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan));
  1092.  
  1093.     scan[ENV_EXTENSION_HEADER] =
  1094.       (MAKE_OBJECT (TC_MANIFEST_VECTOR, (AUX_LIST_INITIAL_SIZE - 1)));
  1095.  
  1096.     scan[ENV_EXTENSION_PARENT_FRAME] =
  1097.       (MEMORY_REF (the_procedure, PROCEDURE_ENVIRONMENT));
  1098.  
  1099.     scan[ENV_EXTENSION_PROCEDURE] = the_procedure;
  1100.  
  1101.     scan[ENV_EXTENSION_COUNT] = (Make_Local_Offset (0));
  1102.  
  1103.     for (i = AUX_CHUNK_SIZE, scan += AUX_LIST_FIRST;
  1104.      --i >= 0;)
  1105.       *scan++ = SHARP_F;
  1106.  
  1107.     Free = scan;
  1108.     Do_Store_No_Lock ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)), extension);
  1109.   }
  1110.   aux_count = (Lexical_Offset (FAST_MEMORY_REF (extension, AUX_LIST_COUNT)));
  1111.   remove_lock (extension_serializer);
  1112.  
  1113.   /* Search the aux list. */
  1114.  
  1115.   {
  1116.     fast long count;
  1117.  
  1118.     scan = (OBJECT_ADDRESS (extension));
  1119.     count = aux_count;
  1120.     scan += AUX_LIST_FIRST;
  1121.  
  1122.     while (--count >= 0)
  1123.     {
  1124.       if ((FAST_PAIR_CAR (*scan)) == sym)
  1125.       {
  1126.     scan = (PAIR_CDR_LOC (*scan));
  1127.  
  1128.     /* This is done only because of compiler cached variables.
  1129.        In their absence, this conditional is unnecessary.
  1130.  
  1131.        *UNDEFINE*: This would also have to be done for other kinds
  1132.        of bindings if undefine is ever implemented.  See the
  1133.        comments above.
  1134.      */
  1135.     if ((MEMORY_FETCH (scan[0])) == DANGEROUS_UNBOUND_OBJECT)
  1136.     {
  1137.       long temp;
  1138.  
  1139.       temp =
  1140.         (compiler_uncache
  1141.          (deep_lookup ((FAST_MEMORY_REF (extension,
  1142.                          ENV_EXTENSION_PARENT_FRAME)),
  1143.                sym,
  1144.                fake_variable_object),
  1145.           sym));
  1146.  
  1147.       if ((temp != PRIM_DONE) || (env != original_frame))
  1148.       {
  1149.         return (temp);
  1150.       }
  1151.       return (shadowing_recache (scan, env, sym, value, true));
  1152.     }
  1153.  
  1154.     if (env == original_frame)
  1155.     {
  1156.       return (redefinition (scan, value));
  1157.     }
  1158.     else
  1159.     {
  1160.       return (dangerize (scan, sym));
  1161.     }
  1162.       }
  1163.       scan += 1;
  1164.     }
  1165.   }
  1166.  
  1167.   /* Not found in this frame at all. */
  1168.  
  1169.   {
  1170.     fast long temp;
  1171.  
  1172.     temp =
  1173.       (extend_frame ((FAST_MEMORY_REF (extension, ENV_EXTENSION_PARENT_FRAME)),
  1174.              sym, SHARP_F, original_frame, recache_p));
  1175.  
  1176.     if (temp != PRIM_DONE)
  1177.     {
  1178.       return (temp);
  1179.     }
  1180.  
  1181.     /* Proceed to extend the frame:
  1182.        - If the frame is the one where the definition is occurring,
  1183.      put the value in the new value cell.
  1184.        - Otherwise, put a dangerous unbound trap there.
  1185.        - This code is careful to restart if some other process defines
  1186.          something in the meantime in this frame.
  1187.      */
  1188.  
  1189.     setup_lock (extension_serializer, (OBJECT_ADDRESS (env)));
  1190.     temp = (Lexical_Offset (FAST_MEMORY_REF (extension, AUX_LIST_COUNT)));
  1191.  
  1192.     if ((extension != (FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION))) ||
  1193.     (temp != aux_count))
  1194.     {
  1195.       remove_lock (extension_serializer);
  1196.       goto redo_aux_lookup;
  1197.     }
  1198.  
  1199.     scan = (OBJECT_ADDRESS (extension));
  1200.  
  1201.     if ((temp + (AUX_LIST_FIRST - 1)) == ((long) (VECTOR_LENGTH (extension))))
  1202.     {
  1203.       fast long i;
  1204.       fast SCHEME_OBJECT *fast_free;
  1205.  
  1206.       i = ((2 * temp) + AUX_LIST_FIRST);
  1207.  
  1208.       if (GC_allocate_test (i))
  1209.       {
  1210.     remove_lock (extension_serializer);
  1211.     Request_GC (i);
  1212.     return (PRIM_INTERRUPT);
  1213.       }
  1214.  
  1215.       fast_free = Free;
  1216.       i -= 1;
  1217.  
  1218.       scan += 1;
  1219.       *fast_free++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR, i));
  1220.       for (i = (temp + (AUX_LIST_FIRST - 1)); --i >= 0; )
  1221.     *fast_free++ = *scan++;
  1222.       for (i = temp; --i >= 0; )
  1223.     *fast_free++ = SHARP_F;
  1224.  
  1225.       scan = Free;
  1226.       Free = fast_free;
  1227.       Do_Store_No_Lock
  1228.     ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)),
  1229.      (MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan)));
  1230.     }
  1231.  
  1232.     if (GC_allocate_test (2))
  1233.     {
  1234.       remove_lock (extension_serializer);
  1235.       Request_GC (2);
  1236.       return (PRIM_INTERRUPT);
  1237.     }
  1238.  
  1239.     {
  1240.       SCHEME_OBJECT result;
  1241.  
  1242.       result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  1243.       *Free++ = sym;
  1244.       *Free++ = DANGEROUS_UNBOUND_OBJECT;
  1245.  
  1246.       scan[temp + AUX_LIST_FIRST] = result;
  1247.       scan[AUX_LIST_COUNT] = (Make_Local_Offset (temp + 1));
  1248.  
  1249.       remove_lock (extension_serializer);
  1250.  
  1251.       if ((env != original_frame) || (!recache_p))
  1252.     return (PRIM_DONE);
  1253.       else
  1254.     return (shadowing_recache ((Free - 1), env, sym, value, false));
  1255.     }
  1256.   }
  1257. }
  1258.  
  1259. /* Top level of lookup code.
  1260.    These are the procedures invoked from outside this file.
  1261.  */
  1262.  
  1263. long
  1264. DEFUN (Lex_Ref, (env, var),
  1265.        SCHEME_OBJECT env
  1266.        AND SCHEME_OBJECT var)
  1267. {
  1268.   fast SCHEME_OBJECT *cell;
  1269.   SCHEME_OBJECT *hunk;
  1270.  
  1271.   hunk = OBJECT_ADDRESS (var);
  1272.   lookup(cell, env, hunk, repeat_lex_ref_lookup);
  1273.   return (lookup_end(cell, env, hunk));
  1274. }
  1275.  
  1276. long
  1277. DEFUN (Symbol_Lex_Ref, (env, sym),
  1278.        SCHEME_OBJECT env
  1279.        AND SCHEME_OBJECT sym)
  1280. {
  1281.   return (deep_lookup_end(deep_lookup(env, sym, fake_variable_object),
  1282.               fake_variable_object));
  1283. }
  1284.  
  1285. long
  1286. DEFUN (Lex_Set, (env, var, value),
  1287.        SCHEME_OBJECT env
  1288.        AND SCHEME_OBJECT var
  1289.        AND SCHEME_OBJECT value)
  1290. {
  1291.   fast SCHEME_OBJECT *cell;
  1292.   SCHEME_OBJECT *hunk;
  1293.  
  1294.   hunk = OBJECT_ADDRESS (var);
  1295.   lookup(cell, env, hunk, repeat_lex_set_lookup);
  1296.   return (assignment_end(cell, env, hunk, value));
  1297. }
  1298.  
  1299. long
  1300. DEFUN (Symbol_Lex_Set, (env, sym, value),
  1301.        SCHEME_OBJECT env
  1302.        AND SCHEME_OBJECT sym
  1303.        AND SCHEME_OBJECT value)
  1304. {
  1305.   return (deep_assignment_end(deep_lookup(env, sym, fake_variable_object),
  1306.                   fake_variable_object,
  1307.                   value,
  1308.                   false));
  1309. }
  1310.  
  1311. long
  1312. DEFUN (Local_Set, (env, sym, value),
  1313.        SCHEME_OBJECT env
  1314.        AND SCHEME_OBJECT sym
  1315.        AND SCHEME_OBJECT value)
  1316. {
  1317.   long result;
  1318.  
  1319.   if (Define_Debug)
  1320.     outf_error ("\n;; Local_Set: defining %s.",
  1321.             (STRING_LOC ((MEMORY_REF (sym, SYMBOL_NAME)), 0)));
  1322.   result = (extend_frame (env, sym, value, env, true));
  1323.   Val = sym;
  1324.   return (result);
  1325. }
  1326.  
  1327. long
  1328. DEFUN (safe_reference_transform, (reference_result), long reference_result)
  1329. {
  1330.   if (reference_result == ERR_UNASSIGNED_VARIABLE)
  1331.   {
  1332.     Val = UNASSIGNED_OBJECT;
  1333.     return (PRIM_DONE);
  1334.   }
  1335.   else
  1336.   {
  1337.     return (reference_result);
  1338.   }
  1339. }
  1340.  
  1341. long
  1342. DEFUN (safe_lex_ref, (env, var),
  1343.        SCHEME_OBJECT env
  1344.        AND SCHEME_OBJECT var)
  1345. {
  1346.   return (safe_reference_transform (Lex_Ref (env, var)));
  1347. }
  1348.  
  1349. long
  1350. DEFUN (safe_symbol_lex_ref, (env, sym),
  1351.        SCHEME_OBJECT env
  1352.        AND SCHEME_OBJECT sym)
  1353. {
  1354.   return (safe_reference_transform (Symbol_Lex_Ref (env, sym)));
  1355. }
  1356.  
  1357. long
  1358. DEFUN (unassigned_p_transform, (reference_result), long reference_result)
  1359. {
  1360.   switch (reference_result)
  1361.   {
  1362.     case ERR_UNASSIGNED_VARIABLE:
  1363.       Val = SHARP_T;
  1364.       return (PRIM_DONE);
  1365.  
  1366.     case PRIM_DONE:
  1367.       Val = SHARP_F;
  1368.       return (PRIM_DONE);
  1369.  
  1370.     case ERR_UNBOUND_VARIABLE:
  1371.     default:
  1372.       return (reference_result);
  1373.   }
  1374. }
  1375.  
  1376. extern long
  1377.   EXFUN (Symbol_Lex_unassigned_p, (SCHEME_OBJECT, SCHEME_OBJECT)),
  1378.   EXFUN (Symbol_Lex_unbound_p, (SCHEME_OBJECT, SCHEME_OBJECT));
  1379.  
  1380. long
  1381. DEFUN (Symbol_Lex_unassigned_p, (frame, symbol),
  1382.        SCHEME_OBJECT frame
  1383.        AND SCHEME_OBJECT symbol)
  1384. {
  1385.   return (unassigned_p_transform (Symbol_Lex_Ref (frame, symbol)));
  1386. }
  1387.  
  1388. long
  1389. DEFUN (Symbol_Lex_unbound_p, (frame, symbol),
  1390.        SCHEME_OBJECT frame
  1391.        AND SCHEME_OBJECT symbol)
  1392. {
  1393.   long result;
  1394.  
  1395.   result = (Symbol_Lex_Ref (frame, symbol));
  1396.   switch (result)
  1397.   {
  1398.     case ERR_UNASSIGNED_VARIABLE:
  1399.     case PRIM_DONE:
  1400.     {
  1401.       Val = SHARP_F;
  1402.       return (PRIM_DONE);
  1403.     }
  1404.  
  1405.     case ERR_UNBOUND_VARIABLE:
  1406.     {
  1407.       Val = SHARP_T;
  1408.       return (PRIM_DONE);
  1409.     }
  1410.  
  1411.     default:
  1412.       return (result);
  1413.   }
  1414. }
  1415.  
  1416. /* force_definition is used when access to the global environment is
  1417.    not allowed.  It finds the last frame where a definition can occur,
  1418.    and performs the definition in this frame.  It then returns the
  1419.    cell where the value is stored.  It's expensive and will hardly be
  1420.    used, but is provided for completeness.
  1421. */
  1422.  
  1423. SCHEME_OBJECT *
  1424. DEFUN (force_definition, (env, symbol, message),
  1425.        fast SCHEME_OBJECT env
  1426.        AND SCHEME_OBJECT symbol
  1427.        AND long * message)
  1428. {
  1429.   fast SCHEME_OBJECT previous;
  1430.  
  1431.   if (OBJECT_TYPE (env) == GLOBAL_ENV)
  1432.   {
  1433.     *message = ERR_BAD_FRAME;
  1434.     return ((SCHEME_OBJECT *) NULL);
  1435.   }
  1436.  
  1437.   do
  1438.   {
  1439.     previous = env;
  1440.     env = FAST_MEMORY_REF (MEMORY_REF (env, ENVIRONMENT_FUNCTION),
  1441.                PROCEDURE_ENVIRONMENT);
  1442.   } while (OBJECT_TYPE (env) != GLOBAL_ENV);
  1443.  
  1444.   *message = (Local_Set (previous, symbol, UNASSIGNED_OBJECT));
  1445.   if (*message != PRIM_DONE)
  1446.   {
  1447.     return ((SCHEME_OBJECT *) NULL);
  1448.   }
  1449.   return (deep_lookup(previous, symbol, fake_variable_object));
  1450. }
  1451.  
  1452. /* Macros to allow multiprocessor interlocking in
  1453.    compiler caching and recaching.
  1454.  
  1455.    The defaults are NOPs, but can be overriden by machine dependent
  1456.    include files or config.h
  1457.  */
  1458.  
  1459. #ifndef update_uuo_prolog
  1460. #define update_uuo_prolog()
  1461. #endif
  1462.  
  1463. #ifndef update_uuo_epilog
  1464. #define update_uuo_epilog()
  1465. #endif
  1466.  
  1467. #ifndef compiler_cache_prolog
  1468. #define compiler_cache_prolog()
  1469. #endif
  1470.  
  1471. #ifndef compiler_cache_epilog
  1472. #define compiler_cache_epilog()
  1473. #endif
  1474.  
  1475. #ifndef compiler_trap_prolog
  1476. #define compiler_trap_prolog()
  1477. #endif
  1478.  
  1479. #ifndef compiler_trap_epilog
  1480. #define compiler_trap_epilog()
  1481. #endif
  1482.  
  1483. #ifndef compiler_uncache_prolog
  1484. #define compiler_uncache_prolog()
  1485. #endif
  1486.  
  1487. #ifndef compiler_uncache_epilog
  1488. #define compiler_uncache_epilog()
  1489. #endif
  1490.  
  1491. #ifndef compiler_recache_prolog
  1492. #define compiler_recache_prolog()
  1493. #endif
  1494.  
  1495. #ifndef compiler_recache_epilog
  1496. #define compiler_recache_epilog()
  1497. #endif
  1498.  
  1499. /* Fast variable reference mechanism for compiled code.
  1500.  
  1501.    compiler_cache is the core of the variable caching mechanism.
  1502.  
  1503.    It creates a variable cache for the variable at the specified cell,
  1504.    if needed, and stores it or a related object in the location
  1505.    specified by (block, offset).  It adds this reference to the
  1506.    appropriate reference list for further updating.
  1507.  
  1508.    If the reference is a lookup reference, the cache itself is stored.
  1509.  
  1510.    If the reference is an assignment reference, there are two possibilities:
  1511.    - There are no operator references cached to this location.  The
  1512.    cache itself is stored.
  1513.    - There are operator references.  A fake cache (clone) is stored instead.
  1514.    This cache will make all assignments trap so that the cached
  1515.    operators can be updated.
  1516.  
  1517.    If the reference is an operator reference, a compiled procedure or a
  1518.    "fake" compiled procedure is stored.  Furthermore, if there were
  1519.    assignment references cached, and no fake cache had been installed,
  1520.    a fake cache is created and all the assignment references are
  1521.    updated to point to it.
  1522.  */
  1523.  
  1524. #ifndef PARALLEL_PROCESSOR
  1525.  
  1526. #define compiler_cache_consistency_check()
  1527.  
  1528. #else /* PARALLEL_PROCESSOR */
  1529.  
  1530. /* The purpose of this code is to avoid a lock gap.
  1531.    A re-definition can take place before the lock is grabbed
  1532.    and we will be caching to the wrong cell.
  1533.    To be paranoid we redo the lookup while we have the
  1534.    cell locked and confim that we still have the correct cell.
  1535.  
  1536.    Note that this lookup can be "shallow" since the result of
  1537.    the previous lookup is saved in my_variable.  The "shallow"
  1538.    lookup code takes care of performing a deep lookup if the
  1539.    cell has been "dangerized".
  1540.  */
  1541.  
  1542. #define compiler_cache_consistency_check()                \
  1543. {                                    \
  1544.   SCHEME_OBJECT *new_cell;                        \
  1545.                                     \
  1546.   compiler_cache_variable[VARIABLE_SYMBOL] = name;            \
  1547.   new_cell = (lookup_cell (compiler_cache_variable, env));        \
  1548.   if (cell != new_cell)                            \
  1549.   {                                    \
  1550.     remove_lock (set_serializer);                    \
  1551.     cell = new_cell;                            \
  1552.     goto compiler_cache_retry;                        \
  1553.   }                                    \
  1554. }
  1555.  
  1556. #endif /* PARALLEL_PROCESSOR */
  1557.  
  1558. extern SCHEME_OBJECT compiler_cache_variable[];
  1559. extern long
  1560.   EXFUN (compiler_cache,
  1561.      (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT,
  1562.       SCHEME_OBJECT, long, long, Boolean));
  1563.  
  1564. SCHEME_OBJECT compiler_cache_variable[3];
  1565.  
  1566. Boolean
  1567. DEFUN (local_reference_p, (env, hunk),
  1568.        SCHEME_OBJECT env
  1569.        AND SCHEME_OBJECT * hunk)
  1570. {
  1571.   SCHEME_OBJECT spec;
  1572.  
  1573.   spec = (MEMORY_FETCH (hunk [VARIABLE_COMPILED_TYPE]));
  1574.   switch (OBJECT_TYPE (spec))
  1575.   {
  1576.     case GLOBAL_REF:
  1577.       return (env == (MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL)));
  1578.  
  1579.     case LOCAL_REF:
  1580.       return (true);
  1581.  
  1582.     case FORMAL_REF:
  1583.     case AUX_REF:
  1584.       return ((OBJECT_DATUM (spec)) == 0);      
  1585.  
  1586.     default:
  1587.       return (false);
  1588.   }
  1589. }
  1590.  
  1591. long
  1592. DEFUN (compiler_cache,
  1593.        (cell, env, name, block, offset, kind, first_time),
  1594.        fast SCHEME_OBJECT * cell
  1595.        AND SCHEME_OBJECT env
  1596.        AND SCHEME_OBJECT name
  1597.        AND SCHEME_OBJECT block
  1598.        AND long offset
  1599.        AND long kind
  1600.        AND Boolean first_time)
  1601. {
  1602.   long EXFUN (cache_reference_end,
  1603.           (long, SCHEME_OBJECT, SCHEME_OBJECT,
  1604.            SCHEME_OBJECT, long, SCHEME_OBJECT));
  1605.  
  1606. #ifdef DECLARE_LOCK
  1607.   DECLARE_LOCK (set_serializer);
  1608. #endif
  1609.   fast SCHEME_OBJECT trap, references;
  1610.   SCHEME_OBJECT extension = SHARP_F;
  1611.   SCHEME_OBJECT trap_value, store_trap_tag, store_extension;
  1612.   long trap_kind, return_value;
  1613.  
  1614.   store_trap_tag = SHARP_F;
  1615.   store_extension = SHARP_F;
  1616.   trap_kind = TRAP_COMPILER_CACHED;
  1617.  
  1618. #if 0
  1619. compiler_cache_retry:
  1620. #endif
  1621.  
  1622.   setup_lock (set_serializer, cell);
  1623.   compiler_cache_consistency_check ();
  1624.   compiler_cache_prolog ();
  1625.  
  1626.   trap = *cell;
  1627.   trap_value = trap;
  1628.  
  1629.   if (REFERENCE_TRAP_P (trap))
  1630.   {
  1631.     long old_trap_kind;
  1632.  
  1633.     get_trap_kind (old_trap_kind, trap);
  1634.     switch (old_trap_kind)
  1635.     {
  1636.       case TRAP_UNASSIGNED:
  1637.       case TRAP_UNBOUND:
  1638.       case TRAP_FLUID:
  1639.     break;
  1640.  
  1641.       case TRAP_DANGEROUS:
  1642.         trap_value = (FAST_MEMORY_REF (trap, TRAP_EXTRA));
  1643.     trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
  1644.     break;
  1645.  
  1646.       case TRAP_UNASSIGNED_DANGEROUS:
  1647.     trap_value = UNASSIGNED_OBJECT;
  1648.     trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
  1649.     break;
  1650.  
  1651.       case TRAP_UNBOUND_DANGEROUS:
  1652.     trap_value = UNBOUND_OBJECT;
  1653.     trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
  1654.     break;
  1655.  
  1656.       case TRAP_FLUID_DANGEROUS:
  1657.     store_trap_tag = (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID));
  1658.     trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
  1659.     break;
  1660.  
  1661.       case TRAP_COMPILER_CACHED:
  1662.       case TRAP_COMPILER_CACHED_DANGEROUS:
  1663.     extension = (FAST_MEMORY_REF (trap, TRAP_EXTRA));
  1664.     update_lock (set_serializer,
  1665.              (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
  1666.     trap_value = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL));
  1667.     trap_kind = -1;
  1668.     break;
  1669.  
  1670.       default:
  1671.     compiler_cache_epilog ();
  1672.     remove_lock (set_serializer);
  1673.     return (ERR_ILLEGAL_REFERENCE_TRAP);
  1674.     }
  1675.   }
  1676.  
  1677. #if TRUE
  1678.  
  1679.   /* The code below must complete to keep the data structures consistent.
  1680.      Thus instead of checking for GC overflow at each allocation, we check
  1681.      once at the beginning for the maximum amount of space needed.  If we
  1682.      cannot do everything, we interrupt now.  Otherwise, it is assumed
  1683.      that there is enough space available.
  1684.  
  1685.      MAXIMUM_CACHE_SIZE must accomodate the allocation on either
  1686.      branch below, plus potential later allocation (in the form of uuo
  1687.      links).
  1688.  
  1689.      The current value is much larger than what is actually needed, but...
  1690.    */
  1691.  
  1692. #define MAXIMUM_CACHE_SIZE 40
  1693.  
  1694.   if (GC_allocate_test (MAXIMUM_CACHE_SIZE))
  1695.   {
  1696.     compiler_cache_epilog ();
  1697.     remove_lock (set_serializer);
  1698.     Request_GC (MAXIMUM_CACHE_SIZE);
  1699.     return (PRIM_INTERRUPT);
  1700.   }
  1701.  
  1702. #endif
  1703.  
  1704.   /* A new trap is needed.
  1705.      This code could add the new reference to the appropriate list,
  1706.      but instead leaves it to the shared code below because another
  1707.      processor may acquire the lock and change things in the middle
  1708.      of update_lock.
  1709.    */
  1710.  
  1711.   if (trap_kind != -1)
  1712.   {
  1713.     SCHEME_OBJECT new_trap;
  1714.  
  1715. #if FALSE
  1716.     /* This is included in the check above. */
  1717.     if (GC_allocate_test (9))
  1718.     {
  1719.       compiler_cache_epilog ();
  1720.       remove_lock (set_serializer);
  1721.       Request_GC (9);
  1722.       return (PRIM_INTERRUPT);
  1723.     }
  1724. #endif
  1725.  
  1726.     new_trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
  1727.     *Free++ = (LONG_TO_UNSIGNED_FIXNUM (trap_kind));
  1728.     extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, (Free + 1)));
  1729.     *Free++ = extension;
  1730.  
  1731.     *Free++ = trap_value;
  1732.     *Free++ = name;
  1733.     *Free++ = SHARP_F;
  1734.     references = (MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, (Free + 1)));
  1735.     *Free++ = references;
  1736.  
  1737.     *Free++ = EMPTY_LIST;
  1738.     *Free++ = EMPTY_LIST;
  1739.     *Free++ = EMPTY_LIST;
  1740.  
  1741.     *cell = new_trap;        /* Do_Store_No_Lock ? */
  1742.     if (store_trap_tag != SHARP_F)
  1743.     {
  1744.       /* Do_Store_No_Lock ? */
  1745.       FAST_MEMORY_SET (trap, TRAP_TAG, store_trap_tag);
  1746.     }
  1747.     update_lock (set_serializer,
  1748.          (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
  1749.   }
  1750.  
  1751.   if (block == SHARP_F)
  1752.   {
  1753.     /* It is not really from compiled code.
  1754.        The environment linking stuff wants a cc cache instead.
  1755.      */
  1756.     compiler_cache_epilog ();
  1757.     remove_lock (set_serializer);
  1758.     return (PRIM_DONE);
  1759.   }
  1760.  
  1761.   /* There already is a compiled code cache.
  1762.      Maybe this should clean up all the cache lists?
  1763.    */
  1764.  
  1765.   {
  1766.     references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
  1767.  
  1768.     if (((kind == TRAP_REFERENCES_ASSIGNMENT) &&
  1769.      ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
  1770.       != EMPTY_LIST)) ||
  1771.     ((kind == TRAP_REFERENCES_OPERATOR) &&
  1772.      ((FAST_MEMORY_REF (references, TRAP_REFERENCES_ASSIGNMENT))
  1773.       != EMPTY_LIST)))
  1774.     {
  1775.       store_extension = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE));
  1776.       if (store_extension == SHARP_F)
  1777.       {
  1778. #if FALSE
  1779.     /* This is included in the check above. */
  1780.  
  1781.     if (GC_allocate_test (4))
  1782.     {
  1783.       compiler_cache_epilog ();
  1784.       remove_lock (set_serializer);
  1785.       Request_GC (4);
  1786.       return (PRIM_INTERRUPT);
  1787.     }
  1788. #endif
  1789.     store_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
  1790.     *Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
  1791.     *Free++ = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_NAME));
  1792.     *Free++ = extension;
  1793.     *Free++ = references;
  1794.     FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, store_extension);
  1795.  
  1796.     if (kind == TRAP_REFERENCES_OPERATOR)
  1797.     {
  1798.       fix_references ((MEMORY_LOC (references,
  1799.                        TRAP_REFERENCES_ASSIGNMENT)),
  1800.               store_extension);
  1801.     }
  1802.       }
  1803.     }
  1804.  
  1805.     /* *UNDEFINE*: If undefine is ever implemented, we should re-think
  1806.        references by fiat since such references have constraints
  1807.        about where they can be linked to.
  1808.        For example, if C -> B -> A (-> means descends from)
  1809.        and there is a reference by fiat from C to B, and we undefine
  1810.        in B, it can go to A, but never to C (or anything between C and B).
  1811.        Curently the only references by fiat are those of the form
  1812.        ((access foo ()) ...)
  1813.      */
  1814.  
  1815.     return_value =
  1816.       (add_reference ((MEMORY_LOC (references, kind)),
  1817.               block,
  1818.               ((local_reference_p (env, compiler_cache_variable))
  1819.                ? (MAKE_OBJECT (TC_CHARACTER, offset))
  1820.                : (MAKE_OBJECT (TC_FIXNUM, offset)))));
  1821.     if (return_value != PRIM_DONE)
  1822.     {
  1823.       compiler_cache_epilog ();
  1824.       remove_lock (set_serializer);
  1825.       return (return_value);
  1826.     }
  1827.   }
  1828.  
  1829.   /* Install an extension or a uuo link in the cc block. */
  1830.  
  1831.   return_value = (cache_reference_end (kind, extension, store_extension,
  1832.                        block, offset, trap_value));
  1833.  
  1834.   /* Unlock and return */
  1835.  
  1836.   compiler_cache_epilog ();
  1837.   remove_lock (set_serializer);
  1838.   return (return_value);
  1839. }
  1840.  
  1841. long
  1842. DEFUN (cache_reference_end,
  1843.        (kind, extension, store_extension, block, offset, value),
  1844.        long kind
  1845.        AND SCHEME_OBJECT extension
  1846.        AND SCHEME_OBJECT store_extension
  1847.        AND SCHEME_OBJECT block
  1848.        AND long offset
  1849.        AND SCHEME_OBJECT value)
  1850. {
  1851.   extern void
  1852.     EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  1853.   extern long
  1854.     EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  1855.     EXFUN (make_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
  1856.  
  1857.   switch(kind)
  1858.   {
  1859.     default:
  1860.     case TRAP_REFERENCES_ASSIGNMENT:
  1861.       if (store_extension != SHARP_F)
  1862.       {
  1863.     store_variable_cache (store_extension, block, offset);
  1864.     return (PRIM_DONE);
  1865.       }
  1866.       /* Fall through */
  1867.  
  1868.     case TRAP_REFERENCES_LOOKUP:
  1869.       store_variable_cache (extension, block, offset);
  1870.       return (PRIM_DONE);
  1871.  
  1872.     case TRAP_REFERENCES_OPERATOR:
  1873.     {
  1874.       if (REFERENCE_TRAP_P (value))
  1875.       {
  1876.     return (make_fake_uuo_link (extension, block, offset));
  1877.       }
  1878.       else
  1879.       {
  1880.     return (make_uuo_link (value, extension, block, offset));
  1881.       }
  1882.     }
  1883.   }
  1884.   /*NOTREACHED*/
  1885. }
  1886.  
  1887. /* This procedure invokes compiler_cache after finding the top-level
  1888.    value cell associated with (env, name).
  1889.  */
  1890.  
  1891. long
  1892. DEFUN (compiler_cache_reference,
  1893.        (env, name, block, offset, kind, first_time),
  1894.        SCHEME_OBJECT env
  1895.        AND SCHEME_OBJECT name
  1896.        AND SCHEME_OBJECT block
  1897.        AND long offset
  1898.        AND long kind
  1899.        AND Boolean first_time)
  1900. {
  1901.   SCHEME_OBJECT *cell;
  1902.  
  1903.   cell = (deep_lookup (env, name, compiler_cache_variable));
  1904.   if (cell == unbound_trap_object)
  1905.   {
  1906.     long message;
  1907.  
  1908.     cell = (force_definition (env, name, &message));
  1909.     if (message != PRIM_DONE)
  1910.     {
  1911.       return (message);
  1912.     }
  1913.   }
  1914.   return (compiler_cache (cell, env, name, block, offset, kind, first_time));
  1915. }
  1916.  
  1917. /* This procedure updates all the references in the cached reference
  1918.    list pointed at by slot to hold value.  It also eliminates "empty"
  1919.    pairs (pairs whose weakly held block has vanished).
  1920.  */
  1921.  
  1922. static void
  1923. DEFUN (fix_references, (slot, extension),
  1924.        fast SCHEME_OBJECT * slot
  1925.        AND fast SCHEME_OBJECT extension)
  1926. {
  1927.   fast SCHEME_OBJECT pair, block;
  1928.  
  1929.   while (*slot != EMPTY_LIST)
  1930.   {
  1931.     pair = (FAST_PAIR_CAR (*slot));
  1932.     block = (FAST_PAIR_CAR (pair));
  1933.     if (block == SHARP_F)
  1934.     {
  1935.       *slot = (FAST_PAIR_CDR (*slot));
  1936.     }
  1937.     else
  1938.     {
  1939.       extern void
  1940.     EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  1941.  
  1942.       store_variable_cache (extension,
  1943.                 block,
  1944.                 (OBJECT_DATUM (FAST_PAIR_CDR (pair))));
  1945.       slot = (PAIR_CDR_LOC (*slot));
  1946.     }
  1947.   }
  1948.   return;
  1949. }
  1950.  
  1951. /* This procedures adds a new cached reference to the cached reference
  1952.    list pointed at by slot.  It attempts to reuse pairs which have been
  1953.    "emptied" by the garbage collector.
  1954.  */
  1955.  
  1956. static long
  1957. DEFUN (add_reference, (slot, block, offset),
  1958.        fast SCHEME_OBJECT * slot
  1959.        AND SCHEME_OBJECT block
  1960.        AND SCHEME_OBJECT offset)
  1961. {
  1962.   fast SCHEME_OBJECT pair;
  1963.  
  1964.   while (*slot != EMPTY_LIST)
  1965.   {
  1966.     pair = (FAST_PAIR_CAR (*slot));
  1967.     if ((FAST_PAIR_CAR (pair)) == SHARP_F)
  1968.     {
  1969.       FAST_SET_PAIR_CAR (pair, block);
  1970.       FAST_SET_PAIR_CDR (pair, offset);
  1971.       return (PRIM_DONE);
  1972.     }
  1973.     slot = (PAIR_CDR_LOC (*slot));
  1974.   }
  1975.  
  1976.   if (GC_allocate_test (4))
  1977.   {
  1978.     Request_GC (4);
  1979.     return (PRIM_INTERRUPT);
  1980.   }
  1981.  
  1982.   *slot = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  1983.   *Free = (MAKE_POINTER_OBJECT (TC_WEAK_CONS, (Free + 2)));
  1984.   Free += 1;
  1985.   *Free++ = EMPTY_LIST;
  1986.  
  1987.   *Free++ = block;
  1988.   *Free++ = offset;
  1989.  
  1990.   return (PRIM_DONE);
  1991. }
  1992.  
  1993. extern SCHEME_OBJECT
  1994.   EXFUN (compiled_block_environment, (SCHEME_OBJECT));
  1995.  
  1996. static long
  1997.   trap_map_table[] = {
  1998.     TRAP_REFERENCES_LOOKUP,
  1999.     TRAP_REFERENCES_ASSIGNMENT,
  2000.     TRAP_REFERENCES_OPERATOR
  2001.     };
  2002.  
  2003. #define TRAP_MAP_TABLE_SIZE (sizeof(trap_map_table) / sizeof(long))
  2004.  
  2005. #ifndef DEFINITION_RECACHES_EAGERLY
  2006.  
  2007. /* compiler_uncache_slot uncaches all references in the list pointed
  2008.    at by slot, and clears the list.  If the references are operator
  2009.    references, a fake compiled procedure which will recache when
  2010.    invoked is created and installed.
  2011.  */
  2012.  
  2013. long
  2014. DEFUN (compiler_uncache_slot, (slot, sym, kind),
  2015.        fast SCHEME_OBJECT * slot
  2016.        AND SCHEME_OBJECT sym
  2017.        AND long kind)
  2018. {
  2019.   fast SCHEME_OBJECT temp, pair;
  2020.   SCHEME_OBJECT block, offset, new_extension;
  2021.  
  2022.   for (temp = *slot; temp != EMPTY_LIST; temp = *slot)
  2023.   {
  2024.     pair = (FAST_PAIR_CAR (temp));
  2025.     block = (FAST_PAIR_CAR (pair));
  2026.     if (block != SHARP_F)
  2027.     {
  2028.       offset = (FAST_PAIR_CDR (pair));
  2029.       if (CHARACTER_P (offset))
  2030.       {
  2031.     /* This reference really belongs here! -- do not uncache.
  2032.        Skip to next.
  2033.      */
  2034.  
  2035.     slot = (PAIR_CDR_LOC (temp));
  2036.     continue;
  2037.       }
  2038.       else
  2039.       {
  2040.     if (GC_allocate_test (4))
  2041.     {
  2042.       Request_GC (4);
  2043.       return (PRIM_INTERRUPT);
  2044.     }
  2045.     new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
  2046.     *Free++ = REQUEST_RECACHE_OBJECT;
  2047.     *Free++ = sym;
  2048.     *Free++ = block;
  2049.     *Free++ = offset;
  2050.  
  2051.     if (kind == TRAP_REFERENCES_OPERATOR)
  2052.     {
  2053.       extern long
  2054.         EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  2055.       long result;
  2056.  
  2057.       result = (make_fake_uuo_link (new_extension,
  2058.                     block,
  2059.                     (OBJECT_DATUM (offset))));
  2060.       if (result != PRIM_DONE)
  2061.         return (result);
  2062.     }
  2063.     else
  2064.     {
  2065.       extern void
  2066.         EXFUN (store_variable_cache, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  2067.  
  2068.       store_variable_cache (new_extension, block, (OBJECT_DATUM (offset)));
  2069.     }
  2070.       }
  2071.     }
  2072.     *slot = (FAST_PAIR_CDR (temp));
  2073.   }
  2074.   return (PRIM_DONE);
  2075. }
  2076.  
  2077. /* compiler_uncache is invoked when a redefinition occurs.
  2078.    It uncaches all references cached to this value cell, and
  2079.    sets the variables up to be recached at the next reference.
  2080.    value_cell is the value cell being shadowed.
  2081.    sym is the name of the variable.
  2082.  */
  2083.  
  2084. long
  2085. DEFUN (compiler_uncache, (value_cell, sym),
  2086.        SCHEME_OBJECT * value_cell
  2087.        AND SCHEME_OBJECT sym)
  2088. {
  2089. #ifdef DECLARE_LOCK
  2090.   DECLARE_LOCK (set_serializer);
  2091. #endif
  2092.   SCHEME_OBJECT val, extension, references;
  2093.   long trap_kind, temp, i, index;
  2094.  
  2095.   setup_lock (set_serializer, value_cell);
  2096.  
  2097.   val = *value_cell;
  2098.  
  2099.   if (!(REFERENCE_TRAP_P (val)))
  2100.   {
  2101.     remove_lock (set_serializer);
  2102.     return (PRIM_DONE);
  2103.   }
  2104.  
  2105.   get_trap_kind (trap_kind, val);
  2106.   if ((trap_kind != TRAP_COMPILER_CACHED) &&
  2107.       (trap_kind != TRAP_COMPILER_CACHED_DANGEROUS))
  2108.   {
  2109.     remove_lock (set_serializer);
  2110.     return (PRIM_DONE);
  2111.   }
  2112.  
  2113.   compiler_uncache_prolog ();
  2114.  
  2115.   extension = (FAST_MEMORY_REF (val, TRAP_EXTRA));
  2116.   references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
  2117.   update_lock (set_serializer, (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
  2118.  
  2119.   /* Uncache all of the lists. */
  2120.  
  2121.   for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
  2122.   {
  2123.     index = trap_map_table[i];
  2124.     temp = (compiler_uncache_slot ((MEMORY_LOC (references, index)),
  2125.                    sym, index));
  2126.     if (temp != PRIM_DONE)
  2127.     {
  2128.       remove_lock (set_serializer);
  2129.       compiler_uncache_epilog ();
  2130.       return (temp);
  2131.     }
  2132.   }
  2133.  
  2134.   /* Note that we can only remove the trap if no references remain,
  2135.      ie. if there were no hard-wired references to this frame.
  2136.      We can test that by checking whether all the slots were set
  2137.      to EMPTY_LIST in the preceding loop.
  2138.      The current code, however, never removes the trap.
  2139.    */
  2140.  
  2141.   /* Remove the clone extension if there is one and it is no longer needed. */
  2142.  
  2143.   if ((FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE)) != SHARP_F)
  2144.   {
  2145.     if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_ASSIGNMENT))
  2146.     == EMPTY_LIST)
  2147.     {
  2148.       FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
  2149.     }
  2150.     else if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
  2151.          == EMPTY_LIST)
  2152.     {
  2153.       /* All operators have disappeared, we can remove the clone,
  2154.      but we must update the cells.
  2155.        */
  2156.       fix_references ((MEMORY_LOC (references, TRAP_REFERENCES_ASSIGNMENT)),
  2157.               extension);
  2158.       FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
  2159.     }
  2160.   }
  2161.   compiler_uncache_epilog ();
  2162.   remove_lock (set_serializer);
  2163.   return (PRIM_DONE);
  2164. }
  2165.  
  2166. #endif /* DEFINITION_RECACHES_EAGERLY */
  2167.  
  2168. #ifdef DEFINITION_RECACHES_EAGERLY
  2169.  
  2170. /*
  2171.    compiler_recache is invoked when a redefinition occurs.  It
  2172.    recaches (at the definition point) all the references that need to
  2173.    point to the new cell.
  2174.  
  2175.    It does this in two phases:
  2176.  
  2177.    - First (by means of compiler_recache_split) it splits all
  2178.    references into those that need to be updated and those that do
  2179.    not.  This is done by side-effecting the list so that all those
  2180.    that need updating are at the end, and when we actually decide to
  2181.    go ahead, we can just clip it and install it in the new location.
  2182.    compiler_recache_split also counts how many entries are affected,
  2183.    so the total amount of gc space needed can be computed.
  2184.  
  2185.    - After checking that there is enough space to proceed, (rather
  2186.    than aborting) it actually does the recaching.  It caches to the
  2187.    new location/value by using compiler_recache_slot.  Note that the
  2188.    eventual trap extension has already been allocated so the recached
  2189.    links can point to it.
  2190.  */
  2191.  
  2192. /* Required by compiler_uncache macro. */
  2193.  
  2194. SCHEME_OBJECT *shadowed_value_cell = ((SCHEME_OBJECT *) NULL);
  2195.  
  2196. /* Each extension is a hunk4. */
  2197.  
  2198. #define SPACE_PER_EXTENSION    4
  2199.  
  2200. /* Trap, extension, and one cache-list hunk. */
  2201.  
  2202. #define SPACE_PER_TRAP        (2 + SPACE_PER_EXTENSION + 3)
  2203.  
  2204. /* 1 Pair and 1 Weak pair.
  2205.    Not really needed since the pairs and weak pairs are reused.
  2206.  */
  2207.  
  2208. #define SPACE_PER_ENTRY        (2 + 2)
  2209.  
  2210. /* Hopefully a conservative guesstimate. */
  2211.  
  2212. #ifndef SPACE_PER_LINK        /* So it can be overriden from config.h */
  2213. #define SPACE_PER_LINK        10
  2214. #endif
  2215.  
  2216. /* The spaces are 0 because the pairs are reused!  If that ever changes,
  2217.    they should all become SPACE_PER_ENTRY + curent value.
  2218.  */
  2219.  
  2220. #define SPACE_PER_LOOKUP    0
  2221. #define SPACE_PER_ASSIGNMENT    0
  2222. #define SPACE_PER_OPERATOR    (0 + SPACE_PER_LINK)
  2223.  
  2224. static long
  2225.   trap_size_table[TRAP_MAP_TABLE_SIZE] = {
  2226.     SPACE_PER_LOOKUP,
  2227.     SPACE_PER_ASSIGNMENT,
  2228.     SPACE_PER_OPERATOR
  2229.     };
  2230.  
  2231. static long
  2232.   trap_conflict_table[TRAP_MAP_TABLE_SIZE] = {
  2233.     0,                /* lookup */
  2234.     1,                /* assignment */
  2235.     1                /* operator */
  2236.     };
  2237.  
  2238. Boolean
  2239. DEFUN (environment_ancestor_or_self_p, (ancestor, descendant),
  2240.        fast SCHEME_OBJECT ancestor
  2241.        AND fast SCHEME_OBJECT descendant)
  2242. {
  2243.   while ((OBJECT_TYPE (descendant)) != GLOBAL_ENV)
  2244.   {
  2245.     if (descendant == ancestor)
  2246.       return (true);
  2247.     descendant = (FAST_MEMORY_REF ((MEMORY_REF (descendant,
  2248.                         ENVIRONMENT_FUNCTION)),
  2249.                    PROCEDURE_ENVIRONMENT));
  2250.   }
  2251.   return (descendant == ancestor);
  2252. }
  2253.  
  2254. /* This reorders the entries in slot so that the entries that are
  2255.    not affected by the redefinition appear first, and the affected
  2256.    ones appear last.  A pointer to the first affected cell is stored
  2257.    in memoize_cell, and this will be given to compiler_recache_slot
  2258.    in order to avoid recomputing the division.
  2259.  
  2260.    Note: There is an implicit assumption throughout that none of the
  2261.    pairs (or weak pairs) are in pure space.  If they are, they cannot
  2262.    be sorted or reused.
  2263.  */
  2264.  
  2265. long
  2266. DEFUN (compiler_recache_split,
  2267.        (slot, sym, definition_env, memoize_cell, link_p),
  2268.        fast SCHEME_OBJECT * slot
  2269.        AND SCHEME_OBJECT sym
  2270.        AND SCHEME_OBJECT definition_env
  2271.        AND SCHEME_OBJECT ** memoize_cell
  2272.        AND Boolean link_p)
  2273. {
  2274.   fast long count;
  2275.   SCHEME_OBJECT weak_pair, block, reference_env, invalid_head;
  2276.   fast SCHEME_OBJECT *last_invalid;
  2277.  
  2278.   count = 0;
  2279.   last_invalid = &invalid_head;
  2280.  
  2281.   while (*slot != EMPTY_LIST)
  2282.   {
  2283.     weak_pair = (FAST_PAIR_CAR (*slot));
  2284.     block = (FAST_PAIR_CAR (weak_pair));
  2285.     if (block == SHARP_F)
  2286.     {
  2287.       *slot = (FAST_PAIR_CDR (*slot));
  2288.       continue;
  2289.     }
  2290.     if (!link_p && (CHARACTER_P (FAST_PAIR_CDR (weak_pair))))
  2291.     {
  2292.       /* The reference really belongs here -- it is not affected by fiat. */
  2293.       slot = (PAIR_CDR_LOC (*slot));
  2294.     }
  2295.     else
  2296.     {
  2297.       reference_env = (compiled_block_environment (block));
  2298.       if (!environment_ancestor_or_self_p (definition_env, reference_env))
  2299.       {
  2300.     slot = (PAIR_CDR_LOC (*slot));
  2301.       }
  2302.       else
  2303.       {
  2304.     count += 1;
  2305.     *last_invalid = *slot;
  2306.     last_invalid = (PAIR_CDR_LOC (*slot));
  2307.     *slot = *last_invalid;
  2308.       }
  2309.     }
  2310.   }
  2311.   *last_invalid = EMPTY_LIST;
  2312.   *memoize_cell = slot;
  2313.   *slot = invalid_head;
  2314.   return (count);
  2315. }
  2316.  
  2317. /* This recaches the entries pointed out by cell and adds them
  2318.    to the list in slot.  It also sets to #F the contents
  2319.    of cell.
  2320.  
  2321.    Note that this reuses the pairs and weak pairs that used to be
  2322.    in cell.
  2323.  */
  2324.  
  2325. long
  2326. DEFUN (compiler_recache_slot,
  2327.        (extension, sym, kind, slot, cell, value),
  2328.        SCHEME_OBJECT extension
  2329.        AND SCHEME_OBJECT sym
  2330.        AND long kind
  2331.        AND fast SCHEME_OBJECT * slot
  2332.        AND fast SCHEME_OBJECT * cell
  2333.        AND SCHEME_OBJECT value)
  2334. {
  2335.   fast SCHEME_OBJECT pair, weak_pair;
  2336.   SCHEME_OBJECT clone, tail;
  2337.   long result;
  2338.  
  2339.   /* This is #F if there isn't one.
  2340.      This makes cache_reference_end do the right thing.
  2341.    */
  2342.   clone = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE));
  2343.   tail = * slot;
  2344.  
  2345.   for (pair = (* cell); pair != EMPTY_LIST; pair = (* cell))
  2346.   {
  2347.     weak_pair = (FAST_PAIR_CAR (pair));
  2348.     result = (cache_reference_end (kind, extension, clone,
  2349.                    (FAST_PAIR_CAR (weak_pair)),
  2350.                    (OBJECT_DATUM (FAST_PAIR_CDR (weak_pair))),
  2351.                    value));
  2352.     if (result != PRIM_DONE)
  2353.     {
  2354.       /* We are severely screwed.
  2355.      compiler_recache will do the appropriate thing.
  2356.        */
  2357.       *slot = tail;
  2358.       return (result);
  2359.     }
  2360.  
  2361.     * slot = pair;
  2362.     slot = (PAIR_CDR_LOC (pair));
  2363.     * cell = * slot;
  2364.   }
  2365.   * slot = tail;
  2366.   return (PRIM_DONE);
  2367. }
  2368.  
  2369. long
  2370. DEFUN (compiler_recache,
  2371.        (old_value_cell, new_value_cell, env, sym, value, shadowed_p, link_p),
  2372.        SCHEME_OBJECT * old_value_cell
  2373.        AND SCHEME_OBJECT * new_value_cell
  2374.        AND SCHEME_OBJECT env
  2375.        AND SCHEME_OBJECT sym
  2376.        AND SCHEME_OBJECT value
  2377.        AND Boolean shadowed_p
  2378.        AND Boolean link_p)
  2379. {
  2380. #ifdef DECLARE_LOCK
  2381.   DECLARE_LOCK (set_serializer_1);
  2382.   DECLARE_LOCK (set_serializer_2);
  2383. #endif
  2384.   SCHEME_OBJECT
  2385.     old_value, references, extension, new_extension,
  2386.     *trap_info_table[TRAP_MAP_TABLE_SIZE];
  2387.   SCHEME_OBJECT new_trap = SHARP_F;
  2388.   long
  2389.     trap_kind, temp, i, index, total_size, total_count, conflict_count;
  2390.  
  2391.   setup_locks (set_serializer_1, old_value_cell,
  2392.            set_serializer_2, new_value_cell);
  2393.  
  2394.   if ((!link_p) && (*new_value_cell != DANGEROUS_UNBOUND_OBJECT))
  2395.   {
  2396.     /* Another processor has redefined this word in the meantime.
  2397.        The other processor must have recached all the compiled code
  2398.        caches since it is shadowing the same variable.
  2399.        The definition has become a redefinition.
  2400.      */
  2401.     remove_locks (set_serializer_1, set_serializer_2);
  2402.     return (redefinition (new_value_cell, value));
  2403.   }
  2404.  
  2405.   old_value = *old_value_cell;
  2406.  
  2407.   if (!(REFERENCE_TRAP_P (old_value)))
  2408.   {
  2409.     remove_locks (set_serializer_1, set_serializer_2);
  2410.     return (link_p ?
  2411.         PRIM_DONE :
  2412.         (definition (new_value_cell, value, shadowed_p)));
  2413.   }
  2414.  
  2415.   get_trap_kind (trap_kind, old_value);
  2416.   if ((trap_kind != TRAP_COMPILER_CACHED) &&
  2417.       (trap_kind != TRAP_COMPILER_CACHED_DANGEROUS))
  2418.   {
  2419.     remove_locks (set_serializer_1, set_serializer_2);
  2420.     return (link_p ?
  2421.         PRIM_DONE :
  2422.         (definition (new_value_cell, value, shadowed_p)));
  2423.   }
  2424.  
  2425.   compiler_recache_prolog ();
  2426.  
  2427.   extension = (FAST_MEMORY_REF (old_value, TRAP_EXTRA));
  2428.   references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
  2429.   update_lock (set_serializer_1,
  2430.            (MEMORY_LOC (extension, TRAP_EXTENSION_CELL)));
  2431.  
  2432.   /*
  2433.      Split each slot and compute the amount to allocate.
  2434.    */
  2435.  
  2436.   conflict_count = 0;
  2437.   total_size = (link_p ? 0 : SPACE_PER_TRAP);
  2438.   total_count = 0;
  2439.  
  2440.   for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
  2441.   {
  2442.     index = trap_map_table[i];
  2443.     temp = compiler_recache_split ((MEMORY_LOC (references, index)),
  2444.                    sym, env, &trap_info_table[i], link_p);
  2445.  
  2446.     if (temp != 0)
  2447.     {
  2448.       conflict_count += trap_conflict_table[i];
  2449.       total_size += (temp * trap_size_table[i]);
  2450.       total_count += temp;
  2451.     }
  2452.   }
  2453.  
  2454.   if (total_count == 0)
  2455.   {
  2456.     compiler_recache_epilog ();
  2457.     remove_locks (set_serializer_1, set_serializer_2);
  2458.     return (link_p ?
  2459.         PRIM_DONE :
  2460.         (definition (new_value_cell, value, shadowed_p)));
  2461.   }
  2462.  
  2463.   if ((conflict_count == 2) &&
  2464.       ((!link_p) ||
  2465.        (new_value_cell[TRAP_EXTENSION_CLONE] == SHARP_F)))
  2466.   {
  2467.     total_size += SPACE_PER_EXTENSION;
  2468.   }
  2469.  
  2470.   if (GC_allocate_test (total_size))
  2471.   {
  2472.     /* Unfortunate fact of life: This binding will be dangerous
  2473.        even if there is no need, but this is the only way to
  2474.        guarantee consistent values.
  2475.      */
  2476.     compiler_recache_epilog ();
  2477.     remove_locks (set_serializer_1, set_serializer_2);
  2478.     Request_GC (total_size);
  2479.     return (PRIM_INTERRUPT);
  2480.   }
  2481.  
  2482.   /*
  2483.      Allocate and initialize all the cache structures if necessary.
  2484.    */
  2485.  
  2486.   if (link_p)
  2487.   {
  2488.     new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, new_value_cell));
  2489.     references = new_value_cell[TRAP_EXTENSION_REFERENCES];
  2490.   }
  2491.   else
  2492.   {
  2493.     /* The reference trap is created here, but is not installed in the
  2494.        environment structure until the end.  The new binding contains
  2495.        a DANGEROUS_UNBOUND_OBJECT so that other parallel lookups will
  2496.        skip this binding.
  2497.      */
  2498.  
  2499.     references = (MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, Free));
  2500.  
  2501.     *Free++ = EMPTY_LIST;
  2502.     *Free++ = EMPTY_LIST;
  2503.     *Free++ = EMPTY_LIST;
  2504.  
  2505.     new_extension = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
  2506.  
  2507.     *Free++ = value;
  2508.     *Free++ = sym;
  2509.     *Free++ = SHARP_F;
  2510.     *Free++ = references;
  2511.  
  2512.     new_trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
  2513.     *Free++ = (LONG_TO_UNSIGNED_FIXNUM ((shadowed_p ?
  2514.                      TRAP_COMPILER_CACHED_DANGEROUS :
  2515.                      TRAP_COMPILER_CACHED)));
  2516.     *Free++ = new_extension;
  2517.   }
  2518.  
  2519.   if ((conflict_count == 2) &&
  2520.       (MEMORY_REF (new_extension, TRAP_EXTENSION_CLONE) == SHARP_F))
  2521.   {
  2522.     SCHEME_OBJECT clone;
  2523.  
  2524.     clone = (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free));
  2525.  
  2526.     *Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
  2527.     *Free++ = sym;
  2528.     *Free++ = new_extension;
  2529.     *Free++ = references;
  2530.     FAST_MEMORY_SET (new_extension, TRAP_EXTENSION_CLONE, clone);
  2531.   }
  2532.  
  2533.   /*
  2534.      Now we actually perform the recaching, allocating freely.
  2535.    */
  2536.  
  2537.   for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
  2538.   {
  2539.     index = trap_map_table[i];
  2540.     temp = (compiler_recache_slot (new_extension, sym, index,
  2541.                    (MEMORY_LOC (references, index)),
  2542.                    trap_info_table[i],
  2543.                    value));
  2544.     if (temp != PRIM_DONE)
  2545.     {
  2546.       extern char *Abort_Names[];
  2547.  
  2548.       /* We've lost BIG. */
  2549.  
  2550.       if (temp == PRIM_INTERRUPT)
  2551.     outf_fatal ("\ncompiler_recache: Ran out of guaranteed space!\n");
  2552.       else if (temp > 0)
  2553.     outf_fatal ("\ncompiler_recache: Unexpected error value %d (%s)\n",
  2554.             temp, Abort_Names[temp]);
  2555.       else
  2556.     outf_fatal ("\ncompiler_recache: Unexpected abort value %d (%s)\n",
  2557.             -temp, Abort_Names[(-temp) - 1]);
  2558.       Microcode_Termination (TERM_EXIT);
  2559.     }
  2560.   }
  2561.  
  2562.   if (!link_p)
  2563.   {
  2564.     *new_value_cell = new_trap;
  2565.   }
  2566.   compiler_recache_epilog ();
  2567.   remove_locks (set_serializer_1, set_serializer_2);
  2568.   return (PRIM_DONE);
  2569. }
  2570.  
  2571. #endif /* DEFINITION_RECACHES_EAGERLY */
  2572.  
  2573. /* recache_uuo_links is invoked when an assignment occurs to a
  2574.    variable which has cached operator references (uuo links).
  2575.    All the operator references must be recached to the new value.
  2576.  
  2577.    It currently potentially creates a new uuo link per operator
  2578.    reference.  This may be very expensive in space, but allows a great
  2579.    deal of flexibility.  It is ultimately necessary if there is hidden
  2580.    information on each call (like arity, types of arguments, etc.).
  2581.  */
  2582.  
  2583. long
  2584. DEFUN (recache_uuo_links, (extension, old_value),
  2585.        SCHEME_OBJECT extension
  2586.        AND SCHEME_OBJECT old_value)
  2587. {
  2588.   long EXFUN (update_uuo_links,
  2589.           (SCHEME_OBJECT, SCHEME_OBJECT,
  2590.            long ((*)(SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long))));
  2591.  
  2592.   SCHEME_OBJECT value;
  2593.   long return_value;
  2594.  
  2595.   value = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL));
  2596.   if (REFERENCE_TRAP_P (value))
  2597.   {
  2598.     if (REFERENCE_TRAP_P (old_value))
  2599.     {
  2600.       /* No need to do anything.
  2601.      The uuo links are in the correct state.
  2602.        */
  2603.  
  2604.       return_value = PRIM_DONE;
  2605.     }
  2606.     else
  2607.     {
  2608.       long EXFUN (make_recache_uuo_link,
  2609.           (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
  2610.  
  2611.       return_value =
  2612.     update_uuo_links (value, extension, make_recache_uuo_link);
  2613.     }
  2614.   }
  2615.   else
  2616.   {
  2617.     extern long
  2618.       EXFUN (make_uuo_link,
  2619.          (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long));
  2620.  
  2621.     return_value =
  2622.       update_uuo_links (value, extension, make_uuo_link);
  2623.   }
  2624.  
  2625.   if (return_value != PRIM_DONE)
  2626.   {
  2627.     /*
  2628.        This reverts the variable's value to the original value except
  2629.        when the value was fluid bound.  In the latter case, it does
  2630.        not matter, it should still work: When the assignment is
  2631.        restarted, and recache_uuo_links is restarted, the relative
  2632.        "trapness" of both old and new values should be unchanged.
  2633.  
  2634.        Note that recache_uuo_links is invoked with the cell locked,
  2635.        so it is safe to "revert" the value.
  2636.      */
  2637.  
  2638.     FAST_MEMORY_SET (extension, TRAP_EXTENSION_CELL, old_value);
  2639.   }
  2640.   return (return_value);
  2641. }
  2642.  
  2643. /* This kludge is due to the lack of closures. */
  2644.  
  2645. long
  2646. DEFUN (make_recache_uuo_link, (value, extension, block, offset),
  2647.        SCHEME_OBJECT value
  2648.        AND SCHEME_OBJECT extension
  2649.        AND SCHEME_OBJECT block
  2650.        AND long offset)
  2651. {
  2652.   extern long
  2653.     EXFUN (make_fake_uuo_link, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  2654.  
  2655.   return (make_fake_uuo_link (extension, block, offset));
  2656. }
  2657.  
  2658. long
  2659. DEFUN (update_uuo_links,
  2660.        (value, extension, handler),
  2661.        SCHEME_OBJECT value
  2662.        AND SCHEME_OBJECT extension
  2663.        AND long EXFUN ((*handler),
  2664.                (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, long)))
  2665. {
  2666.   SCHEME_OBJECT references, pair, block;
  2667.   fast SCHEME_OBJECT *slot;
  2668.   long return_value;
  2669.  
  2670.   update_uuo_prolog();
  2671.   references = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES));
  2672.   slot = (MEMORY_LOC (references, TRAP_REFERENCES_OPERATOR));
  2673.  
  2674.   while (*slot != EMPTY_LIST)
  2675.   {
  2676.     pair = (FAST_PAIR_CAR (*slot));
  2677.     block = (FAST_PAIR_CAR (pair));
  2678.     if (block == SHARP_F)
  2679.     {
  2680.       *slot = (FAST_PAIR_CDR (*slot));
  2681.     }
  2682.     else
  2683.     {
  2684.       return_value =
  2685.     (*handler)(value, extension, block,
  2686.            (OBJECT_DATUM (FAST_PAIR_CDR (pair))));
  2687.       if (return_value != PRIM_DONE)
  2688.       {
  2689.     update_uuo_epilog ();
  2690.     return (return_value);
  2691.       }
  2692.       slot = (PAIR_CDR_LOC (*slot));
  2693.     }
  2694.   }
  2695.  
  2696.   /* If there are no uuo links left, and there is an extension clone,
  2697.      remove it, and make assignment references point to the real value
  2698.      cell.
  2699.    */
  2700.  
  2701.   if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) == EMPTY_LIST) &&
  2702.       (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE) != SHARP_F))
  2703.   {
  2704.     FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
  2705.     fix_references ((MEMORY_LOC (references, TRAP_REFERENCES_ASSIGNMENT)),
  2706.             extension);
  2707.   }
  2708.   update_uuo_epilog ();
  2709.   return (PRIM_DONE);
  2710. }
  2711.  
  2712. /* compiler_reference_trap is called when a reference occurs to a compiled
  2713.    reference cache which contains a reference trap.  If the trap is
  2714.    the special REQUEST_RECACHE_OBJECT, the reference is recached.
  2715.    Otherwise the reference is done normally, and the process continued.
  2716.  */
  2717.  
  2718. long
  2719. DEFUN (compiler_reference_trap, (extension, kind, handler),
  2720.        SCHEME_OBJECT extension
  2721.        AND long kind
  2722.        AND long EXFUN ((*handler),(SCHEME_OBJECT *, SCHEME_OBJECT *)))
  2723. {
  2724.   long offset, temp;
  2725.   SCHEME_OBJECT block;
  2726.  
  2727. try_again:
  2728.  
  2729.   if ((MEMORY_REF (extension, TRAP_EXTENSION_CELL)) != REQUEST_RECACHE_OBJECT)
  2730.   {
  2731.     return ((*handler) (MEMORY_LOC (extension, TRAP_EXTENSION_CELL),
  2732.             fake_variable_object));
  2733.   }
  2734.  
  2735.   block = (FAST_MEMORY_REF (extension, TRAP_EXTENSION_BLOCK));
  2736.   offset = (OBJECT_DATUM (FAST_MEMORY_REF (extension, TRAP_EXTENSION_OFFSET)));
  2737.  
  2738.   compiler_trap_prolog ();
  2739.   temp =
  2740.     (compiler_cache_reference ((compiled_block_environment (block)),
  2741.                    (FAST_MEMORY_REF (extension,
  2742.                          TRAP_EXTENSION_NAME)),
  2743.                    block, offset, kind, false));
  2744.   compiler_trap_epilog ();
  2745.   if (temp != PRIM_DONE)
  2746.   {
  2747.     return (temp);
  2748.   }
  2749.  
  2750.   switch (kind)
  2751.   {
  2752.     case TRAP_REFERENCES_OPERATOR:
  2753.     {
  2754.  
  2755.       /* Note that this value may cause another operator trap when
  2756.      invoked, since it may be a uuo-link to an interpreted
  2757.      procedure, or to a variable with a trap in it.  However, it
  2758.      should not go into a loop because the reference should be
  2759.      cached to the correct place, so the extension will no longer
  2760.      have a REQUEST_RECACHE_OBJECT in it.  The first branch in
  2761.      this procedure will be taken in this case.  On a
  2762.      multiprocessor it may in fact loop if some other processor
  2763.      redefines the variable before we have a chance to invoke the
  2764.      value.
  2765.        */
  2766.  
  2767.       extern SCHEME_OBJECT
  2768.     EXFUN (extract_uuo_link, (SCHEME_OBJECT, long));
  2769.  
  2770.       Val = (extract_uuo_link (block, offset));
  2771.       return (PRIM_DONE);
  2772.     }
  2773.  
  2774.     case TRAP_REFERENCES_ASSIGNMENT:
  2775.     case TRAP_REFERENCES_LOOKUP:
  2776.     default:
  2777.     {
  2778.       extern SCHEME_OBJECT
  2779.     EXFUN (extract_variable_cache, (SCHEME_OBJECT, long));
  2780.  
  2781.       extension = (extract_variable_cache (block, offset));
  2782.       /* This is paranoid on a single processor, but it does not hurt.
  2783.      On a multiprocessor, we need to do it because some other processor
  2784.      may have redefined this variable in the meantime.
  2785.        */
  2786.       goto try_again;
  2787.     }
  2788.   }
  2789. }
  2790.  
  2791. /* Procedures invoked from the compiled code interface. */
  2792.  
  2793. extern long
  2794.   EXFUN (compiler_cache_lookup, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  2795.   EXFUN (compiler_cache_assignment, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  2796.   EXFUN (compiler_cache_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  2797.   EXFUN (compiler_cache_global_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  2798.  
  2799. long
  2800. DEFUN (compiler_cache_lookup, (name, block, offset),
  2801.        SCHEME_OBJECT name
  2802.        AND SCHEME_OBJECT block
  2803.        AND long offset)
  2804. {
  2805.   return (compiler_cache_reference ((compiled_block_environment (block)),
  2806.                     name, block, offset,
  2807.                     TRAP_REFERENCES_LOOKUP, true));
  2808. }
  2809.  
  2810. long
  2811. DEFUN (compiler_cache_assignment, (name, block, offset),
  2812.        SCHEME_OBJECT name
  2813.        AND SCHEME_OBJECT block
  2814.        AND long offset)
  2815. {
  2816.   return (compiler_cache_reference ((compiled_block_environment (block)),
  2817.                     name, block, offset,
  2818.                     TRAP_REFERENCES_ASSIGNMENT, true));
  2819. }
  2820.  
  2821. long
  2822. DEFUN (compiler_cache_operator, (name, block, offset),
  2823.        SCHEME_OBJECT name
  2824.        AND SCHEME_OBJECT block
  2825.        AND long offset)
  2826. {
  2827.   return (compiler_cache_reference ((compiled_block_environment (block)),
  2828.                     name, block, offset,
  2829.                     TRAP_REFERENCES_OPERATOR, true));
  2830. }
  2831.  
  2832. long
  2833. DEFUN (compiler_cache_global_operator, (name, block, offset),
  2834.        SCHEME_OBJECT name
  2835.        AND SCHEME_OBJECT block
  2836.        AND long offset)
  2837. {
  2838.   return (compiler_cache_reference ((MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL)),
  2839.                     name, block, offset,
  2840.                     TRAP_REFERENCES_OPERATOR, true));
  2841. }
  2842.  
  2843. extern long
  2844.   EXFUN (complr_operator_reference_trap, (SCHEME_OBJECT *, SCHEME_OBJECT));
  2845.  
  2846. extern SCHEME_OBJECT
  2847.   EXFUN (compiler_var_error, (SCHEME_OBJECT, SCHEME_OBJECT));
  2848.  
  2849. long
  2850. DEFUN (complr_operator_reference_trap, (frame_slot, extension),
  2851.        SCHEME_OBJECT * frame_slot
  2852.        AND SCHEME_OBJECT extension)
  2853. {
  2854.   long temp;
  2855.  
  2856.   temp = (compiler_reference_trap (extension,
  2857.                    TRAP_REFERENCES_OPERATOR,
  2858.                    deep_lookup_end));
  2859.   if (temp != PRIM_DONE)
  2860.   {
  2861.     return temp;
  2862.   }
  2863.   *frame_slot = Val;
  2864.   return (PRIM_DONE);
  2865. }
  2866.  
  2867. SCHEME_OBJECT
  2868. DEFUN (compiler_var_error, (extension, environment),
  2869.        SCHEME_OBJECT extension
  2870.        AND SCHEME_OBJECT environment)
  2871. {
  2872.   return (MEMORY_REF (extension, TRAP_EXTENSION_NAME));
  2873. }
  2874.  
  2875. /* Utility for compiler_assignment_trap, below.
  2876.    Necessary because C lacks lambda.  Argh!
  2877.  */
  2878.  
  2879. static SCHEME_OBJECT saved_compiler_assignment_value;
  2880.  
  2881. long
  2882. DEFUN (compiler_assignment_end, (cell, hunk),
  2883.        SCHEME_OBJECT * cell
  2884.        AND SCHEME_OBJECT * hunk)
  2885. {
  2886.   return (deep_assignment_end (cell, hunk,
  2887.                    saved_compiler_assignment_value, false));
  2888. }
  2889.  
  2890. /* More compiled code interface procedures */
  2891.  
  2892. extern long
  2893.   EXFUN (compiler_lookup_trap, (SCHEME_OBJECT)),
  2894.   EXFUN (compiler_safe_lookup_trap, (SCHEME_OBJECT)),
  2895.   EXFUN (compiler_unassigned_p_trap, (SCHEME_OBJECT)),
  2896.   EXFUN (compiler_assignment_trap, (SCHEME_OBJECT, SCHEME_OBJECT));
  2897.  
  2898. long
  2899. DEFUN (compiler_lookup_trap, (extension), SCHEME_OBJECT extension)
  2900. {
  2901.   return (compiler_reference_trap (extension,
  2902.                    TRAP_REFERENCES_LOOKUP,
  2903.                    deep_lookup_end));
  2904. }
  2905.  
  2906. long
  2907. DEFUN (compiler_safe_lookup_trap, (extension), SCHEME_OBJECT extension)
  2908. {
  2909.   return (safe_reference_transform (compiler_lookup_trap (extension)));
  2910. }
  2911.  
  2912. long
  2913. DEFUN (compiler_unassigned_p_trap, (extension), SCHEME_OBJECT extension)
  2914. {
  2915.   return (unassigned_p_transform (compiler_lookup_trap (extension)));
  2916. }
  2917.  
  2918. long
  2919. DEFUN (compiler_assignment_trap, (extension, value),
  2920.        SCHEME_OBJECT extension
  2921.        AND SCHEME_OBJECT value)
  2922. {
  2923.   saved_compiler_assignment_value = value;
  2924.   return (compiler_reference_trap (extension,
  2925.                    TRAP_REFERENCES_ASSIGNMENT,
  2926.                    compiler_assignment_end));
  2927. }
  2928.