/*
     libscheme	
     Copyright (C) 1994 Brent Benson

     This program is free software; you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
     the Free Software Foundation; either version 1, or (at your option)
     any later version.

     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.

     You should have received a copy of the GNU General Public License
     along with this program; if not, write to the Free Software
     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/

#include "scheme.h"

#define GLOBAL_TABLE_SIZE 100313

/* globals */
Scheme_Env *scheme_env;

/* locals */
static Scheme_Env *scheme_make_env (void);

Scheme_Env *
scheme_basic_env (void)
{
  Scheme_Env *env;

  /* The ordering of the first few init calls is important. 
     Add to the end of the list, not the beginning. */
  env = scheme_make_env ();
  scheme_init_type (env);
  scheme_init_fun (env);
  scheme_init_symbol (env);
  scheme_init_list (env);
  scheme_init_number (env);
  scheme_init_port (env);
  scheme_init_string (env);
  scheme_init_vector (env);
  scheme_init_char (env);
  scheme_init_bool (env);
  scheme_init_syntax (env);
  scheme_init_eval (env);
  scheme_init_error (env);
  scheme_init_promise (env);
  scheme_init_struct (env);
  scheme_init_buffer (env);
  scheme_init_coord (env);
  scheme_init_ctype (env);
  scheme_init_empcommand (env);
  scheme_init_vtport (env);
  scheme_init_edit (env);
  scheme_init_save (env);
  scheme_init_select (env);
  scheme_env = env;
  return (env);
}

static Scheme_Env *
scheme_make_env (void)
{
  Scheme_Env *env;

  env = (Scheme_Env *) scheme_malloc (sizeof (Scheme_Env));
  env->globals = scheme_hash_table (GLOBAL_TABLE_SIZE);
  env->next = NULL;
  return (env);
}

void
scheme_add_global (char *name, Scheme_Object *obj, Scheme_Env *env)
{
  scheme_add_to_table (env->globals, name, obj);
}

Scheme_Env *
scheme_add_frame (Scheme_Object *syms, Scheme_Object *vals, Scheme_Env *env)
{
  Scheme_Env *frame;
  int len, i;

  frame = (Scheme_Env *) scheme_malloc (sizeof (Scheme_Env));
  len = scheme_list_length (syms);
  frame->num_bindings = len;
  frame->symbols = (Scheme_Object **) scheme_malloc (len * sizeof (Scheme_Object*));
  frame->values = (Scheme_Object **) scheme_malloc (len * sizeof (Scheme_Object*));
  for ( i=0 ; i<len ; ++i )
    {
      if (SCHEME_SYMBOLP(syms))
	{
	  frame->symbols[i] = syms;
	  frame->values[i] = vals;
	}
      else
	{
	  frame->symbols[i] = SCHEME_CAR (syms);
	  frame->values[i] = SCHEME_CAR (vals);
	  syms = SCHEME_CDR (syms);
	  vals = SCHEME_CDR (vals);
	}
    }
  frame->globals = env->globals;
  frame->next = env;
  scheme_env = frame;
  return (frame);
}

Scheme_Env *
scheme_pop_frame (Scheme_Env *env)
{
  SCHEME_ASSERT ((env->next), "trying to pop a frame from an empty environment");
  scheme_env = env->next;
  return (env->next);
}

void 
scheme_set_value (Scheme_Object *symbol, Scheme_Object *val, Scheme_Env *env)
{
  Scheme_Env *frame;

  frame = env;
  while ( frame->next != NULL )
    {
      int i;

      for ( i=0 ; i<frame->num_bindings ; ++i )
	{
	  if (symbol == frame->symbols[i])
	    {
	      frame->values[i] = val;
	      return;
	    }
	}
      frame = frame->next;
    }
  if (scheme_lookup_global (symbol, frame))
    {
      scheme_change_in_table (frame->globals, SCHEME_STR_VAL (symbol), val);
    }
  else
    {
      scheme_signal_error ("set!: var unbound: %s", SCHEME_STR_VAL(symbol));
    }
}

Scheme_Object *
scheme_lookup_value (Scheme_Object *symbol, Scheme_Env *env)
{
  Scheme_Env *frame;

  frame = env;
  while ( frame->next != NULL )
    {
      int i;

      for ( i=0 ; i<frame->num_bindings ; ++i )
	{
	  if (symbol == frame->symbols[i])
	    {
	      return (frame->values[i]);
	    }
	}
      frame = frame->next;
    }
  return (scheme_lookup_global (symbol, frame));
}

Scheme_Object *
scheme_lookup_global (Scheme_Object *symbol, Scheme_Env *env)
{
  return (scheme_lookup_in_table (env->globals, SCHEME_STR_VAL(symbol)));
}
