⟦7f827d54a⟧

TextFile

/*          Hey EMACS, this is -*- C -*- code!                 */

/****************************************************************
*                                                               *
*                         Copyright (c) 1984                    *
*               Massachusetts Institute of Technology           *
*                                                               *
* This material was developed by the Scheme project at the      *
* Massachusetts Institute of Technology, Department of          *
* Electrical Engineering and Computer Science.  Permission to   *
* copy this software, to redistribute it, and to use it for any *
* purpose is granted, subject to the following restrictions and *
* understandings.                                               *
*                                                               *
* 1. Any copy made of this software must include this copyright *
* notice in full.                                               *
*                                                               *
* 2. Users of this software agree to make their best efforts (a)*
* to return to the MIT Scheme project any improvements or       *
* extensions that they make, so that these may be included in   *
* future releases; and (b) to inform MIT of noteworthy uses of  *
* this software.                                                *
*                                                               *
* 3.  All materials developed as a consequence of the use of    *
* this software shall duly acknowledge such use, in accordance  *
* with the usual standards of acknowledging credit in academic  *
* research.                                                     *
*                                                               *
* 4. MIT has made no warrantee or representation that the       *
* operation of this software will be error-free, and MIT is     *
* under no obligation to provide any services, by way of        *
* maintenance, update, or otherwise.                            *
*                                                               *
* 5.  In conjunction with products arising from the use of this *
* material, there shall be no use of the name of the            *
* Massachusetts Institute of Technology nor of any adaptation   *
* thereof in any advertising, promotional, or sales literature  *
* without prior written consent from MIT in each case.          *
*                                                               *
****************************************************************/
\f


/* File: LOOKUP.C
 *
 * This file contains symbol lookup and modification routines.  See
 * Hal Abelson for a paper describing and justifying the algorithm.
 */

#include "scheme.h"
#include "primitive.h"
#include "locks.h"
 
#define Lookup_or_Define_Debug Or2(Lookup_Debug, Define_Debug)
\f


static int Operation;		/* SET_IT, READ_IT, or TEST_IT */
static Pointer New_Value;	/* Used if Operation is SET_IT */

#define Copy_Danger_Bit(P)	\
        { if (Dangerous(P))\
	    Set_Danger_Bit(New_Value);\
          else Clear_Danger_Bit(New_Value);\
        }

/* Some aid in debugging */

#ifdef ENABLE_DEBUGGING_TOOLS

print_symbol_name(String, Symbol)
char *String;
Pointer Symbol;
{ Pointer Symbol_Name;
  long Length, i;
  char *Next;

  printf(String);
  Symbol_Name = Fast_Vector_Ref(Symbol, SYMBOL_NAME);
  Length = Get_Integer(Fast_Vector_Ref(Symbol_Name, STRING_LENGTH));
  Next = (char *) Nth_Vector_Loc(Symbol_Name, STRING_CHARS);
  for (i=0; i < Length; i++)
    printf("%c", *Next++);
}

print_variable_name(String, Variable)
Pointer Variable;
char *String;
{ print_symbol_name(String, Fast_Vector_Ref(Variable, VARIABLE_SYMBOL));
  printf(": ");
}

#else
#define print_symbol_name(String, Symbol)	printf("OOPS")
#define print_variable_name(String, Variable)	printf("OOPS")
#endif
\f


/* Do the appropriate look up based on the compiled type of
 * reference.  A "break" in one of the cases causes the value to
 * be looked up as a vector reference of Base and Offset.  If the
 * danger bit is on, the variable is recompiled.  Then the value
 * is read and/or set and PRIM_DONE is returned.
 */

Lookup(Compiled_Var, Frame)
Pointer Compiled_Var, Frame;
{ Pointer Base;
  long Offset;
  if (Lookup_Debug)
    print_variable_name("  Looking up ", Compiled_Var);
  switch
    (Type_Code(Vector_Ref(Compiled_Var, VARIABLE_COMPILED_TYPE)))
  { case GLOBAL_REF:
      Base = Fast_Vector_Ref(Compiled_Var, VARIABLE_SYMBOL);
      Offset = SYMBOL_GLOBAL_VALUE;
      if (Lookup_Debug) printf(" compiled global");
      break;

    case FORMAL_REF:
    { fast long Frame_No, i;
      fast Pointer This_Frame = Frame;
      Frame_No = Get_Integer(Fast_Vector_Ref(Compiled_Var, 
                                             VARIABLE_FRAME_NO));
      for (i=0; i < Frame_No; i++)
      { This_Frame =
          Fast_Vector_Ref(Fast_Vector_Ref(This_Frame, HEAP_ENV_FUNCTION),
                          PROCEDURE_ENVIRONMENT);
      }
      Base = This_Frame;
      Offset = Get_Integer(Fast_Vector_Ref(Compiled_Var, VARIABLE_OFFSET));
      if (Lookup_Debug)
        printf("compiled local %d, %d", Frame_No, Offset);
      break;
    }

/* Lookup continues on the next page */
\f


/* Lookup, continued */

/* The following case can no longer occur! */
   /* The compiled reference says what frame the AUX was found
    * in.  Search the current chain of frames looking for that
    * frame.  If it is in the chain, use it.  If it is not in the
    * chain, recompile the reference.
    */
/* REMOVED BELOW HERE
    case AUX_REF:
    { long i;
      unsigned Desired_Frame_Addr;
      Pointer This_Frame;
      This_Frame = Frame;
      Desired_Frame_Addr =
        Get_Integer(Fast_Vector_Ref(Compiled_Var, VARIABLE_FRAME_NO));
      while (Get_Integer(This_Frame) != Desired_Frame_Addr)
      { if (Type_Code(This_Frame) == GLOBAL_ENV)
          return Compile_Reference(Compiled_Var, Frame);
        This_Frame = Fast_Vector_Ref(This_Frame, HEAP_ENV_FUNCTION);
        This_Frame = Fast_Vector_Ref(This_Frame, PROCEDURE_ENVIRONMENT);
      }

  / * Having found the frame, just use the pointer stored
    * in VARIABLE_OFFSET ... this points to the (SYMBOL . VALUE)
    * pair.
    * /

      Base = Fast_Vector_Ref(Compiled_Var, VARIABLE_OFFSET);
      Offset = CONS_CDR;
      if (Lookup_Debug)
        printf(" compiled aux, #%o, #%o",
               Desired_Frame_Addr, Base);
      break;
    }
 END OF REMOVAL */

/* Lookup continues on the next page */
\f


/* Lookup, continued */

    case UNCOMPILED_REF:
      return Compile_Reference(Compiled_Var, Frame);

    default: return ERR_BROKEN_COMPILED_VARIABLE;
  }
  Val = Vector_Ref(Base, Offset);
  if (Dangerous(Val))
  { Vector_Set(Compiled_Var, VARIABLE_COMPILED_TYPE,
               UNCOMPILED_VARIABLE);
    return Compile_Reference(Compiled_Var, Frame);
  }
  else return End_Ref(Base, Offset);
}
\f


/* All references end here.  Val must have the value of the
 * variable referenced.  The simple case of testing for
 * unassigned or unbound is handled first.  Then if the operation
 * is a SET! or DEFINE the danger bit is copied into the new
 * value.  The value is returned with the danger bit off.
 * There is a special hack here to allow SET! to return a chosen value
 * from the fixed objects vector if the value is UNASSIGNED.
 * Similarly, if the new value is this special object the UNASSIGNED
 * object will be stored instead.
 */

End_Ref(Vector, Offset)
Pointer Vector;
long Offset;
{ if (Operation==SET_IT)
  { 
#ifdef COMPILE_FUTURES
    Lock_Handle Set_Serializer;
#endif
    if (Offset == HEAP_ENV_FUNCTION) return ERR_BAD_SET;
    if (New_Value==Get_Fixed_Obj_Slot(Non_Object))
      New_Value = UNASSIGNED_OBJECT;
#ifdef COMPILE_FUTURES
    Set_Serializer = Lock_Cell(Nth_Vector_Loc(Vector, Offset));
#endif
    if (Type_Code(Vector) != GLOBAL_ENV)
      Val = Fast_Vector_Ref(Vector, Offset);
    if (Val == UNBOUND_OBJECT)
    {
#ifdef COMPILE_FUTURES
      Unlock_Cell(Set_Serializer);
#endif
      return ERR_UNBOUND_VARIABLE;
    }
    Copy_Danger_Bit(Val);
    Do_Store_No_Lock(Nth_Vector_Loc(Vector, Offset), New_Value);
#ifdef COMPILE_FUTURES
    Unlock_Cell(Set_Serializer);
#endif
    if (Val == UNASSIGNED_OBJECT) Val = Get_Fixed_Obj_Slot(Non_Object);
  }

/* End_Ref continues on the next page */
\f


/* End_Ref, continued */

  else
  { Clear_Danger_Bit(Val);
    if (Type_Code(Val)==TC_UNASSIGNED)
    { if (Get_Integer(Val) != UNASSIGNED) return ERR_UNBOUND_VARIABLE;
      if (Operation==READ_IT) return ERR_UNASSIGNED_VARIABLE;
      Val = Get_Fixed_Obj_Slot(Non_Object);
    }
#ifdef COMPILE_FUTURES
    else if (Type_Code(Val)==TC_FUTURE && Future_Spliceable(Val))
    { Val = Future_Value(Val);
      Vector_Set(Vector, Offset, Val);
    }
#endif
  }
  if (Lookup_Debug)
  { printf("\n");
    Print_Expression(Val, " ... ");
    printf("\n");
  }
  return PRIM_DONE;
}
\f


#define FOUND_AUX	1
#define FOUND_FORMAL	2
#define FOUND_NOTHING	3

/* Search a single frame for a given symbol.  Returns either
   FOUND_AUX, FOUND_FORMAL, or FOUND_NOTHING. If it finds an
   Auxilliary variable, Return_Ptr points to the name/value pair.
   Otherwise it points to the procedure which caused the creation of
   the frame (for use in walking up lexical scopes), and Offset
   contains the position in the formals vector where it was found.
*/

long Search_Frame(Symbol, Frame, Offset, Return_Ptr)
Pointer Symbol, Frame, *Return_Ptr;
long *Offset;
{ long Formal_Size;
  Pointer *This_Formal, Aux_List, Temp;
	/* Search the formals */
  *Return_Ptr = Fast_Vector_Ref(Frame, HEAP_ENV_FUNCTION);
  Temp = Fast_Vector_Ref(*Return_Ptr, PROCEDURE_LAMBDA_EXPR);
  Temp = Fast_Vector_Ref(Temp, LAMBDA_FORMALS);
  Formal_Size = Vector_Length(Temp);
  for (*Offset=0, This_Formal = Nth_Vector_Loc(Temp, 1);
       *Offset < Formal_Size;
       (*Offset)++)
    if (Address(*This_Formal++) == Address(Symbol))
    { *Offset += HEAP_ENV_FUNCTION;
      return FOUND_FORMAL;
    }
	/* Search the AUX list */
  Aux_List = Vector_Ref(Frame, HEAP_ENV_AUX_SLOT);
  while (Type_Code(Aux_List) != TC_NULL)
  { if (Address(Symbol) ==
        Address(Vector_Ref(Vector_Ref(Aux_List, CONS_CAR),
                           CONS_CAR)))
    { *Return_Ptr = Vector_Ref(Aux_List, CONS_CAR);
      return FOUND_AUX;
    }
    Aux_List = Vector_Ref(Aux_List, CONS_CDR);
  }
  return FOUND_NOTHING;
}
\f


/* Compile_Reference does a deep search for the symbol and
 * then tries to modify (compile) the original reference.
 */

Compile_Reference(Compiled_Var, Frame)
Pointer Compiled_Var, Frame;
{ long Frame_No, Offset;
  Pointer Symbol, Return_Ptr;
  Symbol = Fast_Vector_Ref(Compiled_Var, VARIABLE_SYMBOL);
  Frame_No = 0;
  while (Type_Code(Frame) != GLOBAL_ENV)
  { switch (Search_Frame(Symbol, Frame,
                         &Offset, &Return_Ptr))
    { case FOUND_AUX:
        return Compile_Aux(Compiled_Var, Frame,
                           Return_Ptr);
      case FOUND_FORMAL:
        return Compile_Formal(Compiled_Var, Frame,
                              Frame_No, Offset);
    }
    Frame_No += 1;
    Frame = Fast_Vector_Ref(Return_Ptr, PROCEDURE_ENVIRONMENT);
  }
  if (Get_Integer(Frame)==GO_TO_GLOBAL)
     return Compile_Global(Compiled_Var, Symbol);
  Val = UNBOUND_OBJECT;
  return End_Ref(Frame, 0);
}
\f


/* The format of a compiled GLOBAL reference is:
 * (VARIABLE_COMPILED_TYPE is the same as VARIABLE_FRAME_NO)
 *
 *    Offset        : Type       . Value      |
 * _________________:____________.____________|
 * VARIABLE_SYMBOL  : SYMBOL     . Symbol cell|
 * _________________:____________.____________|
 * VARIABLE_FRAME_NO: GLOBAL_REF .            |
 * _________________:____________.____________|
 * VARIABLE_OFFSET  :     ... unused ...      |
 * _________________:____________.____________|
 */

Compile_Global(Compiled_Var, Symbol)
Pointer Compiled_Var, Symbol;
{ Val = Vector_Ref(Symbol, SYMBOL_GLOBAL_VALUE);
  if ((! Dangerous(Val)) && (Val != UNBOUND_OBJECT))
    Vector_Set(Compiled_Var, VARIABLE_FRAME_NO,
	       Make_Non_Pointer(GLOBAL_REF, 0));
  if (Lookup_Debug)
    printf("compiling global");
  return End_Ref(Symbol, SYMBOL_GLOBAL_VALUE);
}
\f


/* The format of a compiled AUX reference is:
 * (VARIABLE_COMPILED_TYPE is the same as VARIABLE_FRAME_NO)
 *
 *    Offset        : Type    . Value               |
 * _________________:_________._____________________|
 * VARIABLE_SYMBOL  : SYMBOL  . Symbol cell         |
 * _________________:_________._____________________|
 * VARIABLE_FRAME_NO: AUX_REF . Frame               |
 * _________________:_________._____________________|
 * VARIABLE_OFFSET  : LIST    . (NAME . VALUE) pair |
 * _________________:_________._____________________|

............WELL, that used to be true.  The new code turns
AUX references back into uncompiled ones, so that environments
aren't unduly retained.
............
 */

Compile_Aux(Compiled_Var, Frame, This_Aux_Pair)
Pointer Compiled_Var, Frame, This_Aux_Pair;

/* REMOVED THIS CODE
 * { Val = Vector_Ref(This_Aux_Pair, CONS_CDR);
 *   if (!Dangerous(Val))
 *   { Vector_Set(Compiled_Var, VARIABLE_FRAME_NO,
 *                              Make_Pointer(AUX_REF, Frame));
 *     Vector_Set(Compiled_Var, VARIABLE_OFFSET, This_Aux_Pair);
 *   }
 *   if (Lookup_Debug)
 *     printf("compiling aux #%o, #%o", Frame, This_Aux_Pair);
 *   return End_Ref(This_Aux_Pair, CONS_CDR);
 * }
 */

{ Val = Vector_Ref(This_Aux_Pair, CONS_CDR);
/* The variable is already an uncompiled reference type */
  if (Lookup_Debug) printf("uncompiling aux");
  return End_Ref(This_Aux_Pair, CONS_CDR);
}
\f


/* The format of a compiled FORMAL reference is:
 * (VARIABLE_COMPILED_TYPE is the same as VARIABLE_FRAME_NO)
 *
 *    Offset        : Type        . Value              |
 * _________________:_____________.____________________|
 * VARIABLE_SYMBOL  : SYMBOL      . Symbol cell        |
 * _________________:_____________.____________________|
 * VARIABLE_FRAME_NO: FORMAL_REF  . # of frames back   |
 * _________________:_____________.____________________|
 * VARIABLE_OFFSET  : FIXNUM      . Offset in frame    |
 * _________________:_____________.____________________|
 */

Compile_Formal(Compiled_Var, Frame, Frame_No, Offset)
Pointer Compiled_Var, Frame;
long Frame_No, Offset;
{ Val = Vector_Ref(Frame, Offset);
  if (! Dangerous(Val))
  { Vector_Set(Compiled_Var, VARIABLE_OFFSET, FIXNUM_0+Offset);
    Vector_Set(Compiled_Var, VARIABLE_FRAME_NO,
                             Make_Non_Pointer(FORMAL_REF, Frame_No));
  }
  if (Lookup_Debug)
    printf("compiling local %d, %d", Frame_No, Offset);
  return End_Ref(Frame, Offset);
}
\f


/* The routines called from outside this file: */

long Lex_Ref(Frame, Name)
Pointer Frame, Name;
{ Operation = READ_IT;
  if (Lookup_Debug) printf("  Lexical Reference");
  return Lookup(Name, Frame);
}

long Lex_Set(Frame, Name, Value)
Pointer Name, Frame, Value;
{ Operation = SET_IT;
  New_Value = Value;
  if (Lookup_Debug)
  { Print_Expression(Value, "  Lexical Set");
    printf("\n");
  }
  return Lookup(Name, Frame);
}
\f


/* Two routines called when we have symbols rather than variables
   to start with.  They make up a variable in static space first.
*/

#define Symbol_Lookup(Frame, Symbol)				\
{ int result;							\
  Pointer *Variable = Free;					\
  Free += 3;							\
  Variable[VARIABLE_SYMBOL] = (Symbol);				\
  Variable[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;	\
  result = Lookup(Make_Pointer(TC_VARIABLE, Variable), (Frame));\
  if (Free == Variable+3) Free = Variable;			\
  return result;						\
}

long Symbol_Lex_Ref(Frame, Symbol)
Pointer Frame, Symbol;
{ Operation = READ_IT;
  if (Lookup_Debug) printf("  Lexical Symbol Reference");
  Symbol_Lookup((Frame), (Symbol));
}

long Symbol_Lex_Set(Frame, Symbol, Value)
Pointer Symbol, Frame, Value;
{ Operation = SET_IT;
  New_Value = Value;
  if (Lookup_Debug)
  { Print_Expression(Value, "  Lexical Symbol Set");
    printf("\n");
  }
  Symbol_Lookup((Frame), (Symbol));
}
\f


long Local_Set(Frame, Symbol, Value)
Pointer Frame, Symbol, Value;
{ Pointer Old_Value, Return_Ptr, Base;
  long Offset;
  if (Lookup_or_Define_Debug)
  { print_symbol_name("  Local set (define) of ", Symbol);
    Print_Expression(Value, " as");
    printf("\n");
  }
  Operation = SET_IT;
  New_Value = Value;
/* Except for errors, we always return the symbol */
  Val = Symbol;
  if (Type_Code(Frame)==GLOBAL_ENV)
/* The simple case first: setting the global value of a
 * symbol.  If the name to be set is either dangerous or
 * potentially dangerous, then make the new value dangerous.  In
 * any case return the old value without its danger bit set.
 */
  { if ((Dangerous(Vector_Ref(Symbol, GLOBAL_DANGER))) ||
        (Dangerous(Vector_Ref(Symbol, GLOBAL_P_DANGER))))
    { if (Lookup_or_Define_Debug) printf("{dangerous}");
      Set_Danger_Bit(New_Value);
    }
    Vector_Set(Symbol, SYMBOL_GLOBAL_VALUE, New_Value);
    if (Lookup_or_Define_Debug)
      printf("  Defined in global environment at 0x%x.\n", Symbol);
    return PRIM_DONE;
  }
/* *Sigh* The world has chosen to be complicated.  From here on
 * we deal with definitions other than in the global environment.
 * This divides into two cases: one where the name already exists
 * so the DEFINE is the same as SET!.  Otherwise it is a hard case.
 */
  switch (Search_Frame(Symbol, Frame, &Offset, &Return_Ptr))
  { case FOUND_FORMAL:
      Base = Frame;
      if (Lookup_or_Define_Debug)
        printf("  Becomes SET! of formal.\n");
      break;
      
    case FOUND_AUX:
      Base = Return_Ptr;
      Offset = CONS_CDR;
      if (Lookup_or_Define_Debug)
        printf("  Becomes SET! of aux.\n");
      break;

/* Local_Set continues on the next page */
\f


/* Local_Set, continued */

    default:
/* The variable must be created in the current frame.  This requires
 * (a) adding an entry to the AUX list in this frame;
 * (b) searching back frames until a variable with the same name
 *     is found.  Mark frames between here and there potentially
 *     dangerous.  Mark the frame it is found in as dangerous.
 */
    { Pointer Name_Value_Pair, New_Aux_List, New_P_D_List,
             *Potential_Danger;
      if GC_Check(Free + 4 + 2)
      { Request_GC();
        return PRIM_INTERRUPT;
      }
      Name_Value_Pair = Make_Pointer(TC_LIST, Free);
      Free[CONS_CAR] = Symbol;
      Free[CONS_CDR] = New_Value;
      Free += 2;
	/* Chain new entry on to head of aux. list */
      New_Aux_List = Make_Pointer(TC_LIST, Free);
      Free[CONS_CAR] = Name_Value_Pair;
      Free[CONS_CDR] = Vector_Ref(Frame, HEAP_ENV_AUX_SLOT);
      Free += 2;
      Vector_Set(Frame, HEAP_ENV_AUX_SLOT, New_Aux_List);
      if (Lookup_or_Define_Debug)
        printf("  Adding as aux in #%o.\n", Address(Frame));
      Potential_Danger = Nth_Vector_Loc(Frame, HEAP_ENV_P_DANGER);
      while (Type_Code(*Potential_Danger) != TC_NULL)
      { if (Address(Vector_Ref((*Potential_Danger), CONS_CAR)) ==
            Address(Symbol))
        { /* If this variable was listed as potentially dangerous,
           * just make the value dangerous, splice it out of the list,
           * and we are done. 
           */
          Set_Danger_Bit(Fast_Vector_Ref(Name_Value_Pair, CONS_CDR));
	  Store(*Potential_Danger, Vector_Ref(*Potential_Danger, CONS_CDR));
          if (Lookup_or_Define_Debug)
            printf("  Removed from PD list in same frame.\n");
          return PRIM_DONE;
        }
        Potential_Danger = Nth_Vector_Loc(*Potential_Danger, CONS_CDR);
      }

/* Local_Set continues on the next page */
\f


/* Local_Set, continued */

      while (true)
      { Pointer Return_Ptr;
        long Offset;
     /* On to the next frame */
        Frame = Fast_Vector_Ref(Frame, HEAP_ENV_FUNCTION);
        Frame = Fast_Vector_Ref(Frame, PROCEDURE_ENVIRONMENT);
        if (Type_Code(Frame) == GLOBAL_ENV) break;
        switch (Search_Frame(Symbol, Frame, &Offset, &Return_Ptr))
        { case FOUND_AUX:
            Set_Danger_Bit(Fast_Vector_Ref(Return_Ptr, CONS_CDR));
            if (Lookup_or_Define_Debug)
              printf("  Found as aux in #%o.\n", Address(Frame));
            return PRIM_DONE;

          case FOUND_FORMAL:
            Set_Danger_Bit(Fast_Vector_Ref(Frame, Offset));
            if (Lookup_or_Define_Debug)
              printf("  Found as formal in #%o.\n", Address(Frame));
            return PRIM_DONE;
        }
     /* Add to the potentially dangerous list if not on it already */
        Potential_Danger = Nth_Vector_Loc(Frame, HEAP_ENV_P_DANGER);
        while (Type_Code(*Potential_Danger) != TC_NULL)
        { if (Address(Vector_Ref(*Potential_Danger, CONS_CAR)) ==
              Address(Symbol))
          { if (Lookup_or_Define_Debug)
              printf("  Already PD in #%o.\n", Address(Frame));
            return PRIM_DONE;	/* Already on the list */
          }
          Potential_Danger = Nth_Vector_Loc(*Potential_Danger, CONS_CDR);
        }
        New_P_D_List = Make_Pointer(TC_LIST, Free);
        *Free++ = Symbol;
        *Free++ = Vector_Ref(Frame, HEAP_ENV_P_DANGER);
        Vector_Set(Frame, HEAP_ENV_P_DANGER, New_P_D_List);
        if (Lookup_or_Define_Debug)
          printf("  Added to PD list in #%o.\n", Address(Frame));
      }

/* Local_Set continues on the next page
\f


/* Local_Set, continued */

   /* Finally, since the symbol wasn't found anywhere yet, make the
    * global symbol potentially dangerous if currently undefined,
    * dangerous otherwise.
    */
      if (Type_Code(Vector_Ref(Symbol, SYMBOL_GLOBAL_VALUE)) ==
          TC_UNASSIGNED)
      { if (Lookup_or_Define_Debug)
          printf("  Made PD in global.\n", Address(Frame));
        Set_Danger_Bit(Fast_Vector_Ref(Symbol, GLOBAL_P_DANGER));
      }
      else
      { if (Lookup_or_Define_Debug)
          printf("  Made dangerous in global.\n", Address(Frame));
        Set_Danger_Bit(Fast_Vector_Ref(Symbol, GLOBAL_DANGER));
      }
      return PRIM_DONE;
    }
  }
  Old_Value = Vector_Ref(Base, Offset);
  if (Dangerous(Old_Value))
    Set_Danger_Bit(New_Value);
  Vector_Set(Base, Offset, New_Value);
  return PRIM_DONE;
}
\f


/* (LEXICAL_ASSIGNMENT ENVIRONMENT SYMBOL VALUE)
      [Primitive number 0x00]
      Sets the value of the variable with the name given in SYMBOL, as
      seen in the lexical ENVIRONMENT, to the specified VALUE.
      Returns (bad style to count on this) the previous value.  This
      is the primitive on top of which the special form SET! is
      built.  There is magic built in having to do with the special
      UNASSIGNED value.  If the previous value was UNASSIGNED, then
      the contents of a certain location in the fixed objects vector
      is returned instead of the UNASSIGNED object to prevent further
      errors occuring.  Similarly, if the object in the fixed objects
      vector is specified as VALUE, the UNASSIGNED object will be
      stored instead.
*/
Built_In_Primitive(Prim_Lexical_Assignment, 3, "LEXICAL-ASSIGNMENT")
{ long Result;
  Primitive_3_Args();
  if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
  if (! ((Type_Code(Arg2) == TC_INTERNED_SYMBOL) ||
         (Type_Code(Arg2) == TC_UNINTERNED_SYMBOL)))
    Primitive_Error(ERR_ARG_2_WRONG_TYPE);
  Result = Symbol_Lex_Set(Arg1, Arg2, Arg3);
  if (Result==PRIM_DONE) return Val;
  Primitive_Error(Result);
}
\f


/* (LEXICAL_REFERENCE ENVIRONMENT SYMBOL)
      [Primitive number 0x12]
      Returns the value of the variable with the name given in SYMBOL,
      as seen in the lexical ENVIRONMENT.  As in LEXICAL_ASSIGNMENT,
      if the true value of the variable is the special UNASSIGNED
      object, the representative of that object (found in the fixed
      objects vector) is returned instead.
*/
Built_In_Primitive(Prim_Lexical_Reference, 2, "LEXICAL-REFERENCE")
{ long Result;
  Primitive_2_Args();
  if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
  if (! ((Type_Code(Arg2) == TC_INTERNED_SYMBOL) ||
         (Type_Code(Arg2) == TC_UNINTERNED_SYMBOL)))
    Primitive_Error(ERR_ARG_2_WRONG_TYPE);
  Result = Symbol_Lex_Ref(Arg1, Arg2);
  if (Result==PRIM_DONE) return Val;
  Primitive_Error(Result);
}
\f


/* (LOCAL_ASSIGNMENT ENVIRONMENT SYMBOL VALUE)
      [Primitive number 0x02]
      This is the primitive on which DEFINE is built.  If the variable
      specified by SYMBOL already exists in the lexical ENVIRONMENT,
      then its value there is changed to VALUE.  Otherwise a new
      binding is created in that environment linking the specified
      variable to the value.  Returns (bad style to depend on this)
      SYMBOL.
*/
Built_In_Primitive(Prim_Local_Assignment, 3, "LOCAL-ASSIGNMENT")
{ long Result;
  Primitive_3_Args();
  if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
  if (! ((Type_Code(Arg2) == TC_INTERNED_SYMBOL) ||
         (Type_Code(Arg2) == TC_UNINTERNED_SYMBOL)))
    Primitive_Error(ERR_ARG_2_WRONG_TYPE);
  Result = Local_Set(Arg1, Arg2, Arg3);
  if (Result==PRIM_DONE) return Val;
  Primitive_Error(Result);
}

/* (LOCAL_REFERENCE ENVIRONMENT SYMBOL)
      [Primitive number 0x01]
      Identical to LEXICAL_REFERENCE,
*/
Built_In_Primitive(Prim_Local_Reference, 2, "LOCAL-REFERENCE")
{ long Result;
  Primitive_2_Args();
  if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
  if (! ((Type_Code(Arg2) == TC_INTERNED_SYMBOL) ||
         (Type_Code(Arg2) == TC_UNINTERNED_SYMBOL)))
    Primitive_Error(ERR_ARG_2_WRONG_TYPE);
  Result = Symbol_Lex_Ref(Arg1, Arg2);
  if (Result==PRIM_DONE) return Val;
  Primitive_Error(Result);
}
\f


/* (UNREFERENCEABLE_TEST ENVIRONMENT SYMBOL)
      [Primitive number 0x13]
      Returns #!TRUE if the variable corresponding to SYMBOL has no
      binding in ENVIRONMENT, or if the value is the special
      UNASSIGNED value. Returns NIL otherwise.  Does a complete
      lexical search for SYMBOL starting in ENVIRONMENT. Essentially
      this tells whether an attempt to find the value of SYMBOL in
      ENVIRONMENT would generate an error.  See also UNBOUND_TEST and
      UNASSIGNED_TEST.
*/
Built_In_Primitive(Prim_Unreferenceable_Test, 2, "UNREFERENCEABLE?")
{ long Result;
  Primitive_2_Args();
  if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
  if (Type_Code(Arg2) != TC_INTERNED_SYMBOL)
    Arg_2_Type(TC_UNINTERNED_SYMBOL);
  Result = Symbol_Lex_Ref(Arg1, Arg2);
  switch (Result)
  { case PRIM_DONE: return NIL;
    case ERR_UNASSIGNED_VARIABLE:
    case ERR_UNBOUND_VARIABLE: return TRUTH;
    default: Primitive_Error(Result);
  }
}
\f


/* (UNASSIGNED_TEST ENVIRONMENT SYMBOL)
      [Primitive number 0xCF]
      Returns #!TRUE if the variable corresponding to SYMBOL is bound
      but has the special UNASSIGNED value in ENVIRONMENT.  Returns
      NIL otherwise.  Does a complete lexical search for SYMBOL
      starting in ENVIRONMENT.
*/
Built_In_Primitive(Prim_Unassigned_Test, 2, "UNASSIGNED?")
{ long Result;
  Primitive_2_Args();
  if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
  if (Type_Code(Arg2) != TC_INTERNED_SYMBOL)
    Arg_2_Type(TC_UNINTERNED_SYMBOL);
  Result = Symbol_Lex_Ref(Arg1, Arg2);
  switch (Result)
  { case ERR_UNBOUND_VARIABLE:
    case PRIM_DONE: return NIL;

    case ERR_UNASSIGNED_VARIABLE: return TRUTH;

    default: Primitive_Error(Result);
  }
}
\f


/* (UNBOUND_TEST ENVIRONMENT SYMBOL)
      [Primitive number 0xCE]
      Returns #!TRUE if the variable corresponding to SYMBOL has no
      binding in ENVIRONMENT.  Returns NIL otherwise.  Does a complete
      lexical search for SYMBOL starting in ENVIRONMENT.
*/
Built_In_Primitive(Prim_Unbound_Test, 2, "UNBOUND?")
{ long Result;
  Primitive_2_Args();
  if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
  if (Type_Code(Arg2) != TC_INTERNED_SYMBOL)
    Arg_2_Type(TC_UNINTERNED_SYMBOL);
  Result = Symbol_Lex_Ref(Arg1, Arg2);
  switch (Result)
  { case ERR_UNASSIGNED_VARIABLE:
    case PRIM_DONE: return NIL;

    case ERR_UNBOUND_VARIABLE: return TRUTH;

    default: Primitive_Error(Result);
  }
}
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦7f827d54a⟧ TextFile

Derivation

TextFile
