/* Basic module support for the GPC
   Copyright (C) 1994, 1995 Free Software Foundation, Inc.

This file is part of GNU GCC.

GNU GCC 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.

GNU GCC 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 GNU GCC; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */

/*
 * Author: Jukka Virtanen <jtv@hut.fi>
 *
 */

#include "config.h"
#include <stdio.h>

#include "tree.h"
#include "c-tree.h"
#include "input.h"
#include "rtl.h"
#include "obstack.h"
#include "flags.h"

#include "gpc-defs.h"

extern tree identifier_output;
extern tree identifier_input;
extern tree global_input_file_node;
extern tree global_output_file_node;

/* Allocates global object for the module list.
 * find_module().
 */
extern struct obstack permanent_obstack;

/* We are currently compiling this module */

module_t module_list = NULL_MODULE;
module_t current_module;

/* A list of all exported names in all modules seen so far.
 *
 * TREE_LIST of exported interfaces we know at the current point of
 * compilation: TREE_VALUE is an IDENTIFIER_NODE of an exported
 * interface name TREE_PURPOSE is a TREE_LIST chain of the names (?
 * decls?) exported by this interface */
tree exported_interface_list;

/* Required module interfaces StandardInput and StandardOutput */
tree standard_interface_input;
tree standard_interface_output;

/* Scan the program/module parameter list for entries of FILE_TYPE.
 * If this is at top level, and they are variables of file type,
 * flag the files as external.
 *
 * Since the order of declarations are relaxed, this is checked
 * before every routine.
 *
 * All nodes already handled are marked.
 */
void
associate_external_objects (external_name_list)
     tree external_name_list;
{
  tree link;

  if (external_name_list && top_level_p (current_module->main_program))
    for (link = external_name_list;
	 link;
	 link = TREE_CHAIN (link))
      
      {
	tree id = TREE_VALUE (link);

	if (id == identifier_output)
	  current_module->output_file_node = global_output_file_node;
	else if (id == identifier_input)
	  current_module->input_file_node = global_input_file_node;
	else if (! TREE_PURPOSE (link))
	  {
	    tree name = lookup_name (id);
	    
	    if (name
		&& TREE_CODE (name) == VAR_DECL
		&& TREE_CODE (TREE_TYPE (name)) == FILE_TYPE)
	      {
		PASCAL_EXTERNAL_OBJECT (name) = 1;
		TREE_PURPOSE (link) = error_mark_node;
	      }
	  }
      }
}

/* Check if all the names in program/module param list have been declared
 *
 * If not, give a warning.
 */
void
check_external_objects (idlist)
     tree idlist;
{
  char *what  = current_module->main_program ? "program" : "module";

  for (; idlist; idlist = TREE_CHAIN (idlist))
    {
      tree id = TREE_VALUE (idlist);

      if (id != identifier_output && id != identifier_input)
	{
	  tree name = lookup_name (id);

	  if (name == NULL_TREE)
	    warning ("Identifier `%s' in %s heading is undefined",
		     IDENTIFIER_POINTER (id), what);
	  else if (TREE_CODE (name) != VAR_DECL
		   || TREE_CODE (TREE_TYPE (name)) != FILE_TYPE)
	    warning ("Identifier `%s' in %s heading is not a variable of file type",
		     IDENTIFIER_POINTER (id), what);
	}
    }
}

/* Possibly add the `static' qualifier.
 */
tree
maybe_make_static (qualifiers)
     tree qualifiers;
{
  int make_static = 1;

  /* @@@@ Need to verify if the function was declared with a
   *      FORWARD directive.
   */
  if (qualifiers)
    {
      tree scan = qualifiers;
      for (; scan; scan = TREE_CHAIN (scan))
	if (TREE_VALUE (scan) == extern_id)
	  {
	    make_static = FALSE;
	    break;
	  }
    }
  

  if (make_static)
    qualifiers = chainon (qualifiers, build_tree_list (NULL_TREE, static_id));

  return qualifiers;
}

/* Locates a module by it's NAME.
 * If CREATE is nonzero, create a new module if old not found
 */
module_t
find_module (name, create)
     tree name;
     int create;
{
  module_t curr;
  
  for (curr = module_list; curr; curr = curr->next)
    {
      if (curr->name == name)
	return curr;
    }
  
  if (create)
    {
      curr = (module_t) obstack_alloc (&permanent_obstack,
				       sizeof (struct module));
      /* Initialize */
      bzero ((void *)curr, sizeof (struct module));
      curr->name  = name;
      curr->next  = module_list;
      module_list = curr;
    }
  return curr;
}



void
initialize_module (id)
     tree id;
{
  current_module = find_module (id, 1);
}

/* NAME is an IDENTIFIER_NODE of the exported interface name.
 * EXPORT_LIST:
 *   TREE_LIST
 *       TREE_PURPOSE: Export renaming (new name) or NULL_TREE.
 *       TREE_VALUE  : IDENTIFIER_NODE of the exported name
 */
void
export_interface (name, export_list)
     tree name;
     tree export_list;
{
  tree exported       = exported_interface_list;
  tree exported_names = NULL_TREE;
  tree nscan;

  for (; exported; exported = TREE_CHAIN (exported))
    if (TREE_VALUE (exported) == name)
      {
	error ("Interface `%s' has already been exported",
	       IDENTIFIER_POINTER (name));
	return;
      }

  for (nscan = export_list; nscan; nscan = TREE_CHAIN (nscan))
    {
      tree value = build_tree_list (NULL_TREE, TREE_VALUE (nscan));

      if (TREE_PURPOSE (nscan))
	warning ("Export renaming is not yet implemented; exporting `%s'",
		 IDENTIFIER_POINTER (TREE_VALUE (nscan)));

      exported_names = chainon (exported_names, value);
    }


  current_module->exports
    = chainon (current_module->exports,
	       build_tree_list (exported_names, name));

  exported_interface_list = chainon (exported_interface_list,
				     build_tree_list (exported_names,
						      name));
}

int
name_exported_p (name)
     tree name;
{
  tree scan = current_module->exports;
  for (; scan; scan = TREE_CHAIN (scan))
    {
      tree id_chain = TREE_PURPOSE (scan);

      for (; id_chain; id_chain = TREE_CHAIN(id_chain))
	if (name == TREE_VALUE (id_chain))
	  return 1;
    }

  /* For Borland Pascal units and
   * perhaps a "export foo = all" clause 
   */
  if (current_module->autoexport && current_module->exports)
    {
      TREE_PURPOSE (current_module->exports) =
        chainon (TREE_PURPOSE (current_module->exports),
          module_export_clause (name, NULL_TREE, 0));
      return 1;
    }

  return 0;
}

/*
 * NAME is an IDENTIFIER_NODE of the interface name
 * IMPORT_QUALIFIER:
 *     NULL_TREE if no qualifiers qiven,
 *     TREE_LIST:
 *       TREE_PURPOSE:
 *           NULL_TREE  -> no restricted_import_option given
 *           !NULL_TREE -> restricted_import_option (== ONLY) given
 *	 TREE_VALUE:
 *           TREE_LIST
 *             TREE_PURPOSE: imported <name> from the interface
 *             TREE_VALUE:
 *		   NULL_TREE: name has not been renamed
 *		   identifier_node: new name of the renamed <name>
 * ONLY_QUALIFIED is 0 if unqualified references are allowed;
 *                   1 if qualified references are mandatory.
 */
void
import_interface (interface, import_qualifier, only_qualified)
     tree interface;
     tree import_qualifier;
     long only_qualified;
{
  tree exported_name_list;
  tree exported;

  current_module->imports = chainon (current_module->imports,
				     build_tree_list (NULL_TREE,
						      interface));

  if (standard_interface_input == interface)
    {
      current_module->input_file_node = global_input_file_node;
      exported_name_list = build_tree_list (NULL_TREE, identifier_input);
    }
  else if (standard_interface_output == interface)
    {
      current_module->output_file_node = global_output_file_node;
      exported_name_list = build_tree_list (NULL_TREE, identifier_output);
    }
  else
    {
      for (exported = exported_interface_list;
	   exported;
	   exported = TREE_CHAIN (exported))
	if (TREE_VALUE (exported) == interface)
	  break;
      
      if (! exported)
	{
	  error ("No exported interface matching `%s'",
		 IDENTIFIER_POINTER (interface));
	  return;
	}

      exported_name_list = TREE_PURPOSE (exported);
    }

  if (only_qualified)
    warning ("QUALIFIED not yet supported; it is ignored");

  /* EXPORTED is now the correct interface */
  if (import_qualifier)
    {
      tree inames = TREE_VALUE (import_qualifier);
      if (TREE_PURPOSE (import_qualifier))
	warning ("Restricted import option `ONLY' not yet supported; it is ignored");
      for (; inames; inames = TREE_CHAIN (inames))
	{
	  tree in = TREE_PURPOSE (inames);
	  tree echeck = exported_name_list;
	  int found = FALSE;

	  if (TREE_VALUE (inames))
	    warning ("Renaming of imported interface `%s' to `%s' is not yet supported",
		     IDENTIFIER_POINTER (in), IDENTIFIER_POINTER (TREE_VALUE (inames)));
	  for (; !found && echeck; echeck = TREE_CHAIN (echeck))
	    if (TREE_VALUE (echeck) == in)
	      found = TRUE;

	  if (! found)
	    error ("Interface `%s' does not export `%s'",
		   IDENTIFIER_POINTER (interface), IDENTIFIER_POINTER (in));
	}
    }
}

/*
 * Only exportable names allowed as the NAME here:
 *	  constant_name
 *	| type_name
 *	| schema_name
 *	| procedure_name
 *	| function_name
 *	| variable_name
 *	| PROTECTED variable_name
 */
tree
module_export_clause (name, renamed, protected)
     tree name;
     tree renamed;
     int  protected;
{
  tree rval = build_tree_list (renamed, name);

  if (protected)
    warning ("PROTECTED exports are not yet implemented; handled as a normal exports");

  return rval;
}

tree
module_export_range (low, high)
     tree low;
     tree high;
{
  /* @@@@@@ exported ranges are not yet supported */
  warning ("Exported ranges are not yet supported; ABORTING");
  abort ();
}

