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 / lookprm.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  12KB  |  421 lines
  1. /* -*-C-*-
  2.  
  3. $Id: lookprm.c,v 1.12 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. /* This file contains environment manipulation primitives.
  23.    It makes heavy use of procedures in lookup.c */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "locks.h"
  28. #include "trap.h"
  29. #include "lookup.h"
  30.  
  31. /* NOTE:
  32.    Although this code has been parallelized, it has not been
  33.    exhaustively tried on a parallel processor.  There are probably
  34.    various race conditions that have to be thought about carefully.
  35.  */
  36.  
  37. /* Utility macros */
  38.  
  39. #define VALID_ENVIRONMENT_P(env)                    \
  40.   ((OBJECT_TYPE (env) == TC_ENVIRONMENT) ||                \
  41.    ((OBJECT_TYPE (env) == GLOBAL_ENV) &&                \
  42.     (OBJECT_DATUM (env) == GO_TO_GLOBAL)))
  43.  
  44. /* This used to be more paranoid, and check for interned symbols,
  45.    rather than normal symbols.  Does it matter?
  46.  */
  47.  
  48. #define lookup_primitive_type_test()                    \
  49. do                                    \
  50. {                                    \
  51.   CHECK_ARG(1, ENVIRONMENT_P);                        \
  52.   CHECK_ARG(2, SYMBOL_P);                        \
  53. } while (0)
  54.  
  55. #define lookup_primitive_action(action)                    \
  56. {                                    \
  57.   long result;                                \
  58.                                     \
  59.   result = (action);                            \
  60.   if (result != PRIM_DONE)                        \
  61.   {                                    \
  62.     if (result == PRIM_INTERRUPT)                    \
  63.       signal_interrupt_from_primitive();                \
  64.     else                                \
  65.       signal_error_from_primitive(result);                \
  66.   }                                    \
  67. }
  68.  
  69. #define lookup_primitive_end(value, action)                \
  70. {                                    \
  71.   lookup_primitive_action(action);                    \
  72.   PRIMITIVE_RETURN(value);                        \
  73. }
  74.  
  75. #define standard_lookup_primitive(action)                \
  76. {                                    \
  77.   lookup_primitive_type_test();                        \
  78.   lookup_primitive_end(Val, action);                    \
  79.   /*NOTREACHED*/                            \
  80. }
  81.  
  82. /* (LEXICAL-ASSIGNMENT ENVIRONMENT SYMBOL VALUE)
  83.    Sets the value of the variable with the name given in SYMBOL, as
  84.    seen in the lexical ENVIRONMENT, to the specified VALUE.
  85.    Returns the previous value.
  86.  
  87.    It's indistinguishable from evaluating
  88.    (set! <symbol> <value>) in <environment>.
  89. */
  90.  
  91. DEFINE_PRIMITIVE ("LEXICAL-ASSIGNMENT", Prim_lexical_assignment, 3, 3, 0)
  92. {
  93.   PRIMITIVE_HEADER (3);
  94.  
  95.   standard_lookup_primitive(Symbol_Lex_Set(ARG_REF (1),
  96.                        ARG_REF (2), ARG_REF (3)));
  97. }
  98.  
  99. /* (LEXICAL-REFERENCE ENVIRONMENT SYMBOL)
  100.    Returns the value of the variable with the name given in SYMBOL,
  101.    as seen in the lexical ENVIRONMENT.
  102.  
  103.    Indistinguishable from evaluating <symbol> in <environment>.
  104. */
  105.  
  106. DEFINE_PRIMITIVE ("LEXICAL-REFERENCE", Prim_lexical_reference, 2, 2, 0)
  107. {
  108.   PRIMITIVE_HEADER (2);
  109.  
  110.   standard_lookup_primitive(Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2)));
  111. }
  112.  
  113. /* (LOCAL-REFERENCE ENVIRONMENT SYMBOL)
  114.    Identical to LEXICAL_REFERENCE, here for histerical reasons.
  115. */
  116.  
  117. DEFINE_PRIMITIVE ("LOCAL-REFERENCE", Prim_local_reference, 2, 2, 0)
  118. {
  119.   PRIMITIVE_HEADER (2);
  120.  
  121.   standard_lookup_primitive(Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2)));
  122. }
  123.  
  124. /* (LOCAL-ASSIGNMENT ENVIRONMENT SYMBOL VALUE)
  125.    Should be called LEXICAL-DEFINE.
  126.  
  127.    If the variable specified by SYMBOL already exists in the
  128.    lexical ENVIRONMENT, then its value there is changed to VALUE.
  129.    Otherwise a new binding is created in that environment linking
  130.    the specified variable to the value.  Returns SYMBOL.
  131.  
  132.    Indistinguishable from evaluating
  133.    (define <symbol> <value>) in <environment>. */
  134.  
  135. DEFINE_PRIMITIVE ("LOCAL-ASSIGNMENT", Prim_local_assignment, 3, 3, 0)
  136. {
  137.   PRIMITIVE_HEADER (3);
  138.   standard_lookup_primitive
  139.     (Local_Set ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3))));
  140. }
  141.  
  142. /* (LEXICAL-UNASSIGNED? ENVIRONMENT SYMBOL)
  143.    Returns #T if the variable corresponding to SYMBOL is bound
  144.    but has the special UNASSIGNED value in ENVIRONMENT.  Returns
  145.    #F otherwise.  Does a complete lexical search for SYMBOL
  146.    starting in ENVIRONMENT.
  147.    The special form (unassigned? <symbol>) is built on top of this. */
  148.  
  149. DEFINE_PRIMITIVE ("LEXICAL-UNASSIGNED?", Prim_unassigned_test, 2, 2, 0)
  150. {
  151.   extern long EXFUN (Symbol_Lex_unassigned_p, (SCHEME_OBJECT, SCHEME_OBJECT));
  152.   PRIMITIVE_HEADER (2);
  153.   standard_lookup_primitive
  154.     (Symbol_Lex_unassigned_p ((ARG_REF (1)), (ARG_REF (2))));
  155. }
  156.  
  157. /* (LEXICAL-UNBOUND? ENVIRONMENT SYMBOL)
  158.    Returns #T if the variable corresponding to SYMBOL has no
  159.    binding in ENVIRONMENT.  Returns #F otherwise.  Does a complete
  160.    lexical search for SYMBOL starting in ENVIRONMENT.
  161.    The special form (unbound? <symbol>) is built on top of this. */
  162.  
  163. DEFINE_PRIMITIVE ("LEXICAL-UNBOUND?", Prim_unbound_test, 2, 2, 0)
  164. {
  165.   extern long EXFUN (Symbol_Lex_unbound_p, (SCHEME_OBJECT, SCHEME_OBJECT));
  166.   PRIMITIVE_HEADER (2);
  167.   standard_lookup_primitive
  168.     (Symbol_Lex_unbound_p ((ARG_REF (1)), (ARG_REF (2))));
  169. }
  170.  
  171. /* (LEXICAL-UNREFERENCEABLE? ENVIRONMENT SYMBOL)
  172.    Returns #T if evaluating <symbol> in <environment> would cause
  173.    a variable lookup error (unbound or unassigned).
  174. */
  175.  
  176. DEFINE_PRIMITIVE ("LEXICAL-UNREFERENCEABLE?", Prim_unreferenceable_test, 2, 2, 0)
  177. {
  178.   long Result;
  179.   PRIMITIVE_HEADER (2);
  180.  
  181.   lookup_primitive_type_test();
  182.   Result = Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2));
  183.   switch (Result)
  184.   {
  185.     case PRIM_DONE:
  186.       PRIMITIVE_RETURN (SHARP_F);
  187.  
  188.     case PRIM_INTERRUPT:
  189.       signal_interrupt_from_primitive();
  190.       /*NOTREACHED*/
  191.  
  192.     case ERR_UNASSIGNED_VARIABLE:
  193.     case ERR_UNBOUND_VARIABLE:
  194.       PRIMITIVE_RETURN(SHARP_T);
  195.  
  196.     default:
  197.       signal_error_from_primitive(Result);
  198.   }
  199.   /*NOTREACHED*/
  200.   return (0);
  201. }
  202.  
  203. SCHEME_OBJECT
  204. DEFUN (extract_or_create_cache, (frame, sym),
  205.        SCHEME_OBJECT frame
  206.        AND SCHEME_OBJECT sym)
  207. {
  208.   extern SCHEME_OBJECT compiler_cache_variable[];
  209.   extern long EXFUN (compiler_cache,
  210.              (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT,
  211.               SCHEME_OBJECT, long, long, Boolean));
  212.   SCHEME_OBJECT *cell, value;
  213.   long trap_kind, result;
  214.  
  215.   cell = deep_lookup(frame, sym, compiler_cache_variable);
  216.   value = MEMORY_FETCH (cell[0]);
  217.   if (REFERENCE_TRAP_P(value))
  218.   {
  219.     get_trap_kind(trap_kind, value);
  220.     switch (trap_kind)
  221.     {
  222.       case TRAP_UNBOUND:
  223.       case TRAP_UNBOUND_DANGEROUS:
  224.         signal_error_from_primitive(ERR_UNBOUND_VARIABLE);
  225.  
  226.       case TRAP_COMPILER_CACHED:
  227.       case TRAP_COMPILER_CACHED_DANGEROUS:
  228.     return (FAST_MEMORY_REF (value, TRAP_EXTRA));
  229.  
  230.       /* This should list the traps explicitely */
  231.       default:
  232.         break;
  233.     }
  234.   }
  235.   result = compiler_cache(cell, frame, sym, SHARP_F, 0,
  236.               TRAP_REFERENCES_LOOKUP, true);
  237.   if (result != PRIM_DONE)
  238.   {
  239.     if (result == PRIM_INTERRUPT)
  240.       signal_interrupt_from_primitive();
  241.     else
  242.       signal_error_from_primitive(result);
  243.   }
  244.   value = MEMORY_FETCH (cell[0]);
  245.   return (FAST_MEMORY_REF (value, TRAP_EXTRA));
  246. }
  247.  
  248. void
  249. DEFUN (error_bad_environment, (arg), long arg)
  250. {
  251.   if (OBJECT_TYPE (ARG_REF(arg)) == GLOBAL_ENV)
  252.     error_bad_range_arg(arg);
  253.   else
  254.     error_wrong_type_arg(arg);
  255.   /*NOTREACHED*/
  256. }
  257.  
  258. /* (ENVIRONMENT-LINK-NAME <env1> <env2> <symbol>)
  259.    <symbol> must be locally undefined in <env1>, and defined in <env2>.
  260.    It defines <symbol> in <env1> and makes it share its value cell with
  261.    <symbol> in <env2>.
  262.  
  263.    This code returns #t if it succeeds, or the following errors
  264.    (besides type and range errors) with the following meanings:
  265.  
  266.    - ERR_UNBOUND_VARIABLE:
  267.       <symbol> is unbound in <env2>.
  268.  
  269.    - ERR_BAD_SET:
  270.       <symbol> is bound locally in <env1>.
  271.  
  272.    - ERR_BAD_FRAME:
  273.       Inconsistency in the code.  Bad value found.
  274.  
  275.    - ILLEGAL_REFERENCE_TRAP:
  276.       A bad reference trap was found.
  277.  
  278.    *UNDEFINE*: If undefine is ever implemented, the code below may be
  279.    affected.  It will have to be rethought.
  280.  
  281.    NOTE: The following procedure and extract_or_create_cache have NOT
  282.    been parallelized.  They need thinking.
  283. */
  284.  
  285. DEFINE_PRIMITIVE ("ENVIRONMENT-LINK-NAME", Prim_environment_link_name, 3, 3, 0)
  286. {
  287.   extern SCHEME_OBJECT * EXFUN (scan_frame,
  288.                 (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *,
  289.                  long, Boolean));
  290.   SCHEME_OBJECT target, source, sym;
  291.   SCHEME_OBJECT cache, *cell, *value_cell;
  292.   PRIMITIVE_HEADER (3);
  293.  
  294.   target = ARG_REF (1);
  295.   source = ARG_REF (2);
  296.   sym = ARG_REF (3);
  297.  
  298.   if (!SYMBOL_P(sym))
  299.     error_wrong_type_arg(3);
  300.  
  301.   if (!VALID_ENVIRONMENT_P(source))
  302.     error_bad_environment(2);
  303.  
  304.   if (!VALID_ENVIRONMENT_P(target))
  305.     error_bad_environment(1);
  306.  
  307.   cache = extract_or_create_cache(source, sym);
  308.  
  309.   if (OBJECT_TYPE (target) == GLOBAL_ENV)
  310.   {
  311.     long trap_kind;
  312.     SCHEME_OBJECT value;
  313.  
  314.     cell = MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE);
  315.     value = MEMORY_FETCH (cell[0]);
  316.  
  317.     if (!REFERENCE_TRAP_P(value))
  318.       /* The variable is bound! */
  319.       signal_error_from_primitive(ERR_BAD_SET);
  320.  
  321.     get_trap_kind(trap_kind, value);
  322.     switch(trap_kind)
  323.     {
  324.       case TRAP_UNBOUND:
  325.       case TRAP_UNBOUND_DANGEROUS:
  326.       {
  327.     /* Allocate new trap object. */
  328.     fast SCHEME_OBJECT *trap;
  329.  
  330.     Primitive_GC_If_Needed(2);
  331.     trap = Free;
  332.     Free += 2;
  333.     trap[0] = LONG_TO_UNSIGNED_FIXNUM((trap_kind == TRAP_UNBOUND) ?
  334.                        TRAP_COMPILER_CACHED :
  335.                        TRAP_COMPILER_CACHED_DANGEROUS);
  336.     trap[1] = cache;
  337.     MEMORY_STORE (cell[0], MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, trap));
  338.     PRIMITIVE_RETURN(SHARP_T);
  339.       }
  340.  
  341.       case TRAP_COMPILER_CACHED:
  342.       case TRAP_COMPILER_CACHED_DANGEROUS:
  343.       {
  344.     if (MEMORY_REF (MEMORY_REF (value, TRAP_EXTRA), TRAP_EXTENSION_CELL) !=
  345.         UNBOUND_OBJECT)
  346.     {
  347.       /* It is bound */
  348.  
  349.       signal_error_from_primitive(ERR_BAD_SET);
  350.     }
  351.     lookup_primitive_action(compiler_uncache(cell, sym));
  352.     value_cell = MEMORY_LOC (cache, TRAP_EXTENSION_CELL);
  353.     lookup_primitive_action
  354.       (compiler_recache(shadowed_value_cell, value_cell, target,
  355.                 sym, (MEMORY_FETCH (value_cell[0])), false, true));
  356.     MEMORY_SET (value, TRAP_EXTRA, cache);
  357.     PRIMITIVE_RETURN(SHARP_T);
  358.       }
  359.  
  360.       case TRAP_DANGEROUS:
  361.       case TRAP_UNASSIGNED:
  362.       case TRAP_UNASSIGNED_DANGEROUS:
  363.       case TRAP_FLUID:
  364.       case TRAP_FLUID_DANGEROUS:
  365.         /* The variable is bound! */
  366.         signal_error_from_primitive(ERR_BAD_SET);
  367.  
  368.       default:
  369.         signal_error_from_primitive(ERR_ILLEGAL_REFERENCE_TRAP);
  370.     }
  371.   }
  372.  
  373.   else
  374.   {
  375.     SCHEME_OBJECT *trap;
  376.  
  377.     cell = scan_frame(target, sym, fake_variable_object, 0, true);
  378.  
  379.     /* Is it bound? */
  380.  
  381.     if ((cell != ((SCHEME_OBJECT *) NULL)) &&
  382.     (MEMORY_FETCH (cell[0]) != DANGEROUS_UNBOUND_OBJECT))
  383.     {
  384.       signal_error_from_primitive(ERR_BAD_SET);
  385.     }
  386.  
  387.     /* Allocate new trap object. */
  388.  
  389.     Primitive_GC_If_Needed(2);
  390.     trap = Free;
  391.     Free += 2;
  392.     trap[1] = cache;
  393.  
  394.     lookup_primitive_action(extend_frame(target, sym, SHARP_F, target, false));
  395.  
  396.     if (cell == ((SCHEME_OBJECT *) NULL))
  397.     {
  398.       trap[0] = LONG_TO_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED);
  399.       cell = scan_frame(target, sym, fake_variable_object, 0, true);
  400.       if (cell == ((SCHEME_OBJECT *) NULL))
  401.     signal_error_from_primitive(ERR_BAD_FRAME);
  402.     }
  403.     else
  404.     {
  405.       trap[0] = LONG_TO_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED_DANGEROUS);
  406.     }
  407.  
  408.     if (MEMORY_FETCH (cell[0]) != DANGEROUS_UNBOUND_OBJECT)
  409.       signal_error_from_primitive(ERR_BAD_FRAME);
  410.  
  411.     value_cell = MEMORY_LOC (cache, TRAP_EXTENSION_CELL);
  412.     lookup_primitive_action
  413.       (compiler_recache(shadowed_value_cell, value_cell, target,
  414.             sym, MEMORY_FETCH (value_cell[0]), false, true));
  415.     MEMORY_STORE (cell[0], MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, trap));
  416.     PRIMITIVE_RETURN(SHARP_T);
  417.   }
  418.   /*NOTREACHED*/
  419.   return (0);
  420. }
  421.