/* libsizzle/modules.c - module handling functions
 
  Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This 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 2, or (at your option)
  any later version.
  
  This software 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 package; see the file COPYING.  If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

#include <assert.h>
#include <string.h>

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "alloc.h"
#include "node.h"
#include "validate.h"
#include "port.h"
#include "list.h"
#include "vector.h"
#include "capi.h"
#include "modules.h"

zzz_object_t zzz_tagged_type_module;

static zzz_scm_t module_list;
static zzz_scm_t use_module_keyword;
static zzz_scm_t export_keyword;

static result_t import_module (zzz_scm_t env, zzz_scm_t module,
			       zzz_scm_t * result);

/* Return 1 if @var{list} is a non-empty list of symbols, 0 otherwise.  */
static int symbol_list_p (zzz_scm_t list)
{
  if (zzz_list_length (list) < 1)
    return 0;
  while (cons_p (list))
    {
      if (!symbol_p (car (list)))
	return 0;
      list = cdr (list);
    }
  return 1;
}

/* Add the symbols in the symbol list @var{symbols} to the export list
   of the module @var{module}.  */
static result_t
export_symbols (zzz_scm_t module, zzz_scm_t symbols)
{
  zzz_scm_t tmp;
  zzz_scm_t list = NULL;
  zzz_scm_t * listp = &list;

  tmp = symbols;
  while (cons_p (tmp))
    {
      *listp = zzz_cons (car (tmp), NULL);
      listp = cdr_addr (*listp);
      tmp = cdr (tmp);
    }
  tmp = module_exports (module);
  if (!cons_p (tmp))
    module_exports (module) = list;
  else
    {
      while (cons_p (cdr (tmp)))
	tmp = cdr (tmp);
      set_cdr (tmp, list);
    }
  return RESULT_SUCCESS;
}

/*:doc
  current-module
  (current-module) => module
  Return the module in which currently definitions take place.
  doc:*/
#define FUNC_NAME "current-module"
static result_t
current_module_func (zzz_scm_t env, zzz_scm_t * result)
{
  *result = zzz_current_module;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  module-list
  (module-list) => list
  Return a list of currently loaded modules.
  doc:*/
#define FUNC_NAME "module-list"
static result_t
module_list_func (zzz_scm_t env, zzz_scm_t * result)
{
  *result = module_list;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  define-module
  (define-module name option ...) => *unspecified*
  Define a module called @var{name} and switch to the context of the new
  module, that means that all definitions made until the end of the file
  will be made in the private environment of the module.  Definitions can
  be made public using the syntactic form @code{export}, documented below.
  Options may be one or more pair of a keyword and a value.  The
  following keywords are presently defined: #:use-module, #:export.
  doc:*/
#define FUNC_NAME "define-module"
static result_t
define_module_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t param_list = param;
  zzz_scm_t name;
  zzz_scm_t option;
  zzz_scm_t tmp;
  result_t err;
  int arg_num = 2;
  int new = 0;

  param = cdr (param);				     /* Skip form name. */
  NEXT_ARG (name);
  CHECK_TYPE (1, symbol_list_p (name), _("symbol list"));

  /* Check whether this module was already defined.  */
  tmp = module_list;
  while (cons_p (tmp))
    {
      if (zzz_equal (module_name (car (tmp)), name))
	break;
      tmp = cdr (tmp);
    }
  if (cons_p (tmp))
    {
      tmp = car (tmp);
    }
  else
    {
      new = 1;
      /* Create a new module of the given name and create a fresh
	 environment for module-intern definitions.  */
      tmp = zzz_make_module (name);
      module_desc (tmp)->private = zzz_make_environment
	(11, zzz_library_environment, 0, 0);
    }

  /* Announce the newly defined module globally.  */
  zzz_current_module = tmp;
  zzz_current_environment = module_private (zzz_current_module);

  /* Process optional arguments.  These may be either `:use-module',
     followed by a module name to import into the new module; or
     `:export', followed by a list of symbols to be added to the new
     module's export list.  */
  while (cons_p (param))
    {
      NEXT_ARG (option);
      CHECK_TYPE (arg_num, keyword_p (option), zzz_keyword_type_name);

      if (option == use_module_keyword)
	{
	  NEXT_ARG (option);
	  CHECK_TYPE (arg_num, symbol_list_p (option), _("symbol list"));
	  if ((err = import_module (module_private (tmp), option, result)) !=
	      RESULT_SUCCESS)
	    return err;
	}
      else if (option == export_keyword)
	{
	  NEXT_ARG (option);
	  CHECK_TYPE (arg_num, symbol_list_p (option), _("symbol list"));
	  export_symbols (zzz_current_module, option);
	}
      arg_num++;
    }
  if (new)
    module_list = zzz_cons (tmp, module_list);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  export
  (export symbol ...) => *unspecified*
  Add all @var{symbols} to the export list of the currently active module.
  doc:*/
#define FUNC_NAME "export"
static result_t
export_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t param_list = param;
  zzz_scm_t name;
  zzz_scm_t list;
  int arg_num = 1;

  param = cdr (param);				     /* Skip form name. */
  list = param;
  do
    {
      NEXT_ARG (name);
      CHECK_TYPE (arg_num, symbol_p (name), zzz_symbol_type_name);
    }
  while (cons_p (param));
  export_symbols (zzz_current_module, list);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Import all definitions exported by @var{module} into the
   environment @var{env}.  */
static result_t
import_module (zzz_scm_t env, zzz_scm_t module, zzz_scm_t * result)
{
  static char * s_func_name = "import_module";
  zzz_scm_t tmp, tmp1;
  result_t err;

  assert (env_link (env) == zzz_library_environment);

  /* We check the list of loaded modules first.  */
  tmp = module_list;
  while (cons_p (tmp))
    {
      if (zzz_equal (module_name (car (tmp)), module))
	break;
      tmp = cdr (tmp);
    }
  if (!cons_p (tmp) || !module_loaded (car (tmp)))
    {
      /* Module is not defined, so we have to load it.  We do this by
         constructing a relative file name from the module name and
         then try to load it from the load path.  */
      zzz_scm_t filename;
      char * buf = NULL;
      int buf_len = 0;
      int len = 0;

      tmp1 = module;
      while (cons_p (tmp1))
	{
	  len = string_len (symbol_name (car (tmp1)));
	  CHECK_SAFE_FILENAME (1, symbol_name (car (tmp1)),
			       zzz_safe_filename_type_name);
	  len++;
	  buf = zzz_realloc (buf, buf_len + len, buf_len);
	  buf[buf_len] = '\0';
	  buf_len += len;
	  if (buf_len > len)
	    strcat (buf, "/");
	  strcat (buf, string_val (symbol_name (car (tmp1))));
	  tmp1 = cdr (tmp1);
	}
      len += 4;
      buf = zzz_realloc (buf, buf_len + len, buf_len);
      buf[buf_len] = '\0';
      buf_len += len;
      strcat (buf, ".scm");

      filename = zzz_make_string (buf, -1);
      if ((err = zzz_primitive_load_path (env, filename, result)) !=
	  RESULT_SUCCESS)
	{
	  zzz_free (buf, buf_len);
	  return err;
	}
      zzz_free (buf, buf_len);

      /* Search the module list once again to check whether the module
         name was defined.  */
      tmp = module_list;
      while (cons_p (tmp))
	{
	  if (zzz_equal (module_name (car (tmp)), module))
	    break;
	  tmp = cdr (tmp);
	}
      if (!cons_p (tmp))
	{
	  /* Throw an error if the loaded file did not define the
             desired module.  This may happen if the user forgot to
             define the module in the file or if the wrong file was
             found in the load path.  */
	  *result = zzz_make_misc_error_exception
	    (zzz_make_list 
	     (zzz_make_string (_("module "), -1),
	      module,
	      zzz_make_string (_(" not defined after loading "), -1),
	      filename,
	      NULL));
	  return RESULT_EXCEPTION;
	}
    }
  module = car (tmp);
  module_loaded (module) = 1;

  tmp = module_exports (module);
  while (cons_p (tmp))
    {
      zzz_scm_t symbol = car (tmp);
      zzz_scm_t c;

      assert (symbol_p (symbol));
      c = env_val (module_private (module));

      while (cons_p (c) && !zzz_eq (car (car (c)), symbol))
	{
	  c = cdr (c);
	}
      if (cons_p (c))
	{
	  tmp1 = env_val (env);
	  if (cons_p (tmp1))
	    {
	      /* We have to do some magic when the hash slot is
                 already occupied, because we have to
		 1. make sure we append definitions at the end (needed
		    for memoizing)
                 2. Must overwrite complete association cells, because they
		    must be shared between modules, or a set! in one
		    module will not affect the others.
	      */
	      while (cons_p (cdr (tmp1)))
		{
		  if (zzz_eq (car (car (tmp1)), symbol))
		    break;
		  tmp1 = cdr (tmp1);
		}
	      if (zzz_eq (car (car (tmp1)), symbol))
		set_car (tmp1, car (c));
	      else
		set_cdr (tmp1, zzz_cons (car (c), NULL));
	    }
	  else
	    {
	      to_tagged_ptr(env)->fill[1] =
		(zzz_object_t) zzz_cons (car (c), env_val (env));
	    }
	}
      else
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_make_list
	     (zzz_make_string (_("cannot use module "), -1),
	      module_name (module),
	      zzz_make_string (_(" because "), -1),
	      symbol,
	      zzz_make_string (_(" is exported, but not defined"), -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      tmp = cdr (tmp);
    }
  return RESULT_SUCCESS;
}

/*:doc
  use-modules
  (use-modules name0 name1 ...) => *unspecified*
  Import all modules listed as @var{names}.  If any module is not yet
  loaded, it will be loaded using the load path.  Modules imported by any
  of the imported modules will be loaded recursively.
  doc:*/
#define FUNC_NAME "use-modules"
static result_t
use_modules_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t param_list = param;
  zzz_scm_t name;
  int arg_num = 1;
  result_t err;

  param = cdr (param);				     /* Skip form name. */
  do
    {
      NEXT_ARG (name);
      CHECK_TYPE (arg_num, symbol_list_p (name), _("symbol list"));
      if ((err = import_module (env, name, result)) != RESULT_SUCCESS)
	return err;
      arg_num++;
    }
  while (cons_p (param));
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME



/* Create a module object.  */
zzz_scm_t
zzz_make_module (zzz_scm_t name)
{
  return zzz_create_tagged_cell (zzz_tagged_type_module, name, NULL, NULL);
}

static void *
module_constructor (zzz_tagged_t tagged, void * data0,
		    void * data1, void * data2)
{
  module_desc_t desc;

  desc = zzz_malloc (sizeof (struct module_descriptor));
  desc->name = (zzz_scm_t) data0;
  desc->exports = NULL;
  desc->private = NULL;
  desc->loaded = 0;
  tagged->fill[1] = (zzz_object_t) desc;
  return tagged;
}

/* Print the representation for the MODULE object DATA to PORT.  */
static void
module_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;

  zzz_port_puts (port, "#<module ", 9, &result);
  zzz_port_print (port, module_name (tagged), state, &result);
  zzz_port_puts (port, " ", 1, &result);
  zzz_port_print (port, module_exports (tagged), state, &result);
#if 0
  zzz_port_puts (port, " ", 1, &result);
  zzz_port_print (port, module_private (tagged), state, &result);
#endif /* 0 */
  zzz_port_puts (port, ">", 1, &result);
}

static void
module_mark (zzz_tagged_t tagged)
{
  module_desc_t desc = tagged_data0 (tagged);
  zzz_mark_cell (desc->name);
  zzz_mark_cell (desc->exports);
  zzz_mark_cell (desc->private);
}

void
module_free (zzz_tagged_t tagged)
{
  module_desc_t desc = module_desc (tagged);
  zzz_free (desc, sizeof (struct module_descriptor));
}

result_t
zzz_init_module_type (void)
{
  zzz_tagged_type_module =
    zzz_define_tagged_type (module_constructor, module_print, module_free,
			    module_mark, NULL);
  return RESULT_SUCCESS;
}

static zzz_scm_t
parse_module_name (char *cname)
{
  zzz_scm_t name = NULL;
  zzz_scm_t * namep = &name;
  char * p = cname, * startp;

  while (*p)
    {
      startp = p;
      while (*p && *p != ' ')
	p++;
      *namep = zzz_cons (zzz_make_symbol (startp, p - startp), NULL);
      namep = cdr_addr (*namep);
      while (*p == ' ')
	p++;
    }
  return name;
}

static zzz_scm_t
find_module (char * cname)
{
  zzz_scm_t name;
  zzz_scm_t tmp;

  name = parse_module_name (cname);

  /* Check whether this module was already defined.  */
  tmp = module_list;
  while (cons_p (tmp))
    {
      if (zzz_equal (module_name (car (tmp)), name))
	return (car (tmp));
      tmp = cdr (tmp);
    }
  return NULL;
}

result_t
zzz_c_create_module (char * cname, zzz_scm_t * ret_module)
{
  zzz_scm_t tmp;
  zzz_scm_t name;

  name = parse_module_name (cname);

  /* Check whether this module was already defined.  */
  tmp = module_list;
  while (cons_p (tmp))
    {
      if (zzz_equal (module_name (car (tmp)), name))
	break;
      tmp = cdr (tmp);
    }
  if (cons_p (tmp))
    tmp = car (tmp);
  else
    {
      /* Create a new module of the given name and create a fresh
	 environment for module-intern definitions.  */
      tmp = zzz_make_module (name);
      module_desc (tmp)->private = zzz_make_environment
	(11, zzz_library_environment, 0, 0);
      module_list = zzz_cons (tmp, module_list);
    }

  *ret_module = tmp;
  return RESULT_SUCCESS;
}

result_t
zzz_c_module_define (zzz_scm_t module, char * cname, zzz_scm_t value,
		     int export, zzz_scm_t * result)
{
  zzz_scm_t name;
  result_t err;
  
  name = zzz_make_symbol (cname, -1);

  if ((err = zzz_define_symbol_value (module_private (module), name,
				      value, result)) != RESULT_SUCCESS)
    return err;
  if (export)
    export_symbols (module, zzz_cons (name, NULL));
  return RESULT_SUCCESS;
}

result_t
zzz_init_modules (void)
{
  zzz_init_module_type ();

  zzz_protect_global (&module_list);
  module_list = NULL;

  /*:doc
    #:use-module
    Keyword
    Used in the option list of @code{use-modules}.
    doc:*/
  zzz_protect_global (&use_module_keyword);
  use_module_keyword = zzz_make_keyword ("use-module", -1);
  /*:doc
    #:export
    Keyword
    Used in the option list of @code{use-modules}.
    doc:*/
  zzz_protect_global (&export_keyword);
  export_keyword = zzz_make_keyword ("export", -1);

  zzz_define_function ("module-list", (zzz_prim_t) module_list_func,
		       argv_0_0_0);
  zzz_define_function ("current-module", (zzz_prim_t) current_module_func,
		       argv_0_0_0);
  zzz_define_form ("define-module", define_module_form, 0);
  zzz_define_form ("export", export_form, 0);
  zzz_define_form ("use-modules", use_modules_form, 0);

  return RESULT_SUCCESS;
}
