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 / fhooks.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  6KB  |  217 lines
  1. /* -*-C-*-
  2.  
  3. $Id: fhooks.c,v 9.34 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 1990, 1999 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. /* This file contains hooks and handles for the new fluid bindings
  23.    scheme for multiprocessors. */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "trap.h"
  28. #include "lookup.h"
  29. #include "locks.h"
  30.  
  31. DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1)
  32. {
  33.   PRIMITIVE_HEADER (1);
  34.   CHECK_ARG (1, APPARENT_LIST_P);
  35.   {
  36.     SCHEME_OBJECT result = Fluid_Bindings;
  37.     Fluid_Bindings = (ARG_REF (1));
  38.     PRIMITIVE_RETURN (result);
  39.   }
  40. }
  41.  
  42. DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0)
  43. {
  44.   PRIMITIVE_HEADER (0);
  45.   PRIMITIVE_RETURN (Fluid_Bindings);
  46. }
  47.  
  48. DEFINE_PRIMITIVE ("WITH-SAVED-FLUID-BINDINGS", Prim_with_saved_fluid_bindings, 1, 1, 0)
  49. {
  50.   PRIMITIVE_HEADER (1);
  51.   {
  52.     SCHEME_OBJECT thunk = (ARG_REF (1));
  53.     PRIMITIVE_CANONICALIZE_CONTEXT ();
  54.     POP_PRIMITIVE_FRAME (1);
  55.   Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
  56.     /* Save previous fluid bindings for later restore */
  57.     Store_Expression (Fluid_Bindings);
  58.     Store_Return (RC_RESTORE_FLUIDS);
  59.     Save_Cont ();
  60.     /* Invoke the thunk. */
  61.     STACK_PUSH (thunk);
  62.     STACK_PUSH (STACK_FRAME_HEADER);
  63.   Pushed ();
  64.     PRIMITIVE_ABORT (PRIM_APPLY);
  65.     /*NOTREACHED*/
  66.   }
  67. }
  68.  
  69. #define lookup_slot(environment, variable)                \
  70.   (lookup_cell ((OBJECT_ADDRESS (variable)), (environment)))
  71.  
  72. DEFINE_PRIMITIVE ("ADD-FLUID-BINDING!", Prim_add_fluid_binding, 3, 3,
  73.   "(ADD-FLUID-BINDING! ENVIRONMENT SYMBOL/VARIABLE VALUE)\n\
  74. Dynamically bind SYMBOL/VARIABLE to VALUE in ENVIRONMENT.\n\
  75. If SYMBOL/VARIABLE has not been \"fluidized\", do so first.")
  76. {
  77.   extern SCHEME_OBJECT * lookup_cell ();
  78.   static SCHEME_OBJECT new_fluid_binding ();
  79.   PRIMITIVE_HEADER (3);
  80.   CHECK_ARG (1, ENVIRONMENT_P);
  81.   {
  82.     fast SCHEME_OBJECT environment = (ARG_REF (1));
  83.     fast SCHEME_OBJECT name = (ARG_REF (2));
  84.     fast SCHEME_OBJECT * cell;
  85.     switch (OBJECT_TYPE (name))
  86.       {
  87.     /* The next two cases are a temporary fix since compiler doesn't
  88.        do scode-quote the same way that the interpreter does.
  89.  
  90.        Ultimately we need to redesign deep fluid-let support anyway,
  91.        so this will go away.
  92.        */
  93.  
  94.       case TC_LIST:
  95.     cell = (lookup_slot (environment, (PAIR_CAR (name))));
  96.     break;
  97.  
  98.       case TC_SCODE_QUOTE:
  99.     cell =
  100.       (lookup_slot
  101.        (environment, (FAST_MEMORY_REF (name, SCODE_QUOTE_OBJECT))));
  102.     break;
  103.  
  104.       case TC_VARIABLE:
  105.     cell = (lookup_slot (environment, name));
  106.     break;
  107.  
  108.       case TC_INTERNED_SYMBOL:
  109.       case TC_UNINTERNED_SYMBOL:
  110.     cell = (deep_lookup (environment, name, fake_variable_object));
  111.     break;
  112.  
  113.       default:
  114.     error_wrong_type_arg (2);
  115.       }
  116.     PRIMITIVE_RETURN (new_fluid_binding (cell, (ARG_REF (3)), false));
  117.   }
  118. }
  119.  
  120. static SCHEME_OBJECT
  121. new_fluid_binding (cell, value, force)
  122.      SCHEME_OBJECT * cell;
  123.      SCHEME_OBJECT value;
  124.      Boolean force;
  125. {
  126.   fast SCHEME_OBJECT trap;
  127.   Lock_Handle set_serializer;
  128.   SCHEME_OBJECT new_trap_value;
  129.   long new_trap_kind = TRAP_FLUID;
  130.   long trap_kind;
  131.   SCHEME_OBJECT saved_extension = SHARP_F;
  132.   SCHEME_OBJECT saved_value;
  133.  
  134.   setup_lock (set_serializer, cell);
  135.  
  136.  new_fluid_binding_restart:
  137.   trap = (*cell);
  138.   new_trap_value = trap;
  139.   if (REFERENCE_TRAP_P (trap))
  140.     {
  141.       get_trap_kind (trap_kind, trap);
  142.       switch (trap_kind)
  143.     {
  144.     case TRAP_DANGEROUS:
  145.       MEMORY_SET
  146.         (trap,
  147.          TRAP_TAG,
  148.          (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID | (trap_kind & 1))));
  149.       /* Fall through */
  150.     case TRAP_FLUID:
  151.     case TRAP_FLUID_DANGEROUS:
  152.       new_trap_kind = -1;
  153.       break;
  154.  
  155.     case TRAP_UNBOUND:
  156.     case TRAP_UNBOUND_DANGEROUS:
  157.       if (! force)
  158.         {
  159.           remove_lock (set_serializer);
  160.           signal_error_from_primitive (ERR_UNBOUND_VARIABLE);
  161.         }
  162.       /* Fall through */
  163.     case TRAP_UNASSIGNED:
  164.     case TRAP_UNASSIGNED_DANGEROUS:
  165.       new_trap_kind = (TRAP_FLUID | (trap_kind & 1));
  166.       new_trap_value = UNASSIGNED_OBJECT;
  167.       break;
  168.  
  169.     case TRAP_COMPILER_CACHED:
  170.     case TRAP_COMPILER_CACHED_DANGEROUS:
  171.       saved_extension = (FAST_MEMORY_REF ((*cell), TRAP_EXTRA));
  172.       cell = (MEMORY_LOC (saved_extension, TRAP_EXTENSION_CELL));
  173.       update_lock (set_serializer, cell);
  174.       saved_value = (*cell);
  175.       if (REFERENCE_TRAP_P (saved_value))
  176.         /* No need to recache uuo links, they must already be recached. */
  177.         saved_extension = SHARP_F;
  178.       goto new_fluid_binding_restart;
  179.  
  180.     default:
  181.       remove_lock (set_serializer);
  182.       signal_error_from_primitive (ERR_ILLEGAL_REFERENCE_TRAP);
  183.     }
  184.     }
  185.  
  186.   if (new_trap_kind != -1)
  187.     {
  188.       if (GC_allocate_test (2))
  189.     {
  190.       remove_lock (set_serializer);
  191.       Primitive_GC (2);
  192.     }
  193.       trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
  194.       (*Free++) = (LONG_TO_UNSIGNED_FIXNUM (new_trap_kind));
  195.       (*Free++) = new_trap_value;
  196.       (*cell) = trap;
  197.     }
  198.   if (saved_extension != SHARP_F)
  199.     {
  200.       extern long recache_uuo_links ();
  201.       long value = (recache_uuo_links (saved_extension, saved_value));
  202.       if (value != PRIM_DONE)
  203.     {
  204.       remove_lock (set_serializer);
  205.       if (value == PRIM_INTERRUPT)
  206.         signal_interrupt_from_primitive ();
  207.       else
  208.         signal_error_from_primitive (value);
  209.     }
  210.     }
  211.   remove_lock (set_serializer);
  212.  
  213.   /* Fluid_Bindings is per processor private. */
  214.   Fluid_Bindings = (cons ((cons (trap, value)), Fluid_Bindings));
  215.   return (SHARP_F);
  216. }
  217.