path: root/gcc/f/where.c

/* where.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

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

GNU Fortran 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 Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

   Related Modules:

   Description:
      Simple data abstraction for Fortran source lines (called card images).

   Modifications:
*/

/* Include files. */

#include "proj.h"
#include "where.h"
#include "lex.h"
#include "malloc.h"
#include "ggc.h"

/* Externals defined here. */

struct _ffewhere_line_ ffewhere_unknown_line_
=
{NULL, NULL, 0, 0, 0, {0}};

/* Simple definitions and enumerations. */


/* Internal typedefs. */

typedef struct _ffewhere_ll_ *ffewhereLL_;

/* Private include files. */


/* Internal structure definitions. */

struct _ffewhere_ll_
  {
    ffewhereLL_ next;
    ffewhereLL_ previous;
    ffewhereFile wf;
    ffewhereLineNumber line_no;	/* ffelex_line_number() at time of creation. */
    ffewhereLineNumber offset;	/* User-desired offset (usually 1). */
  };

struct _ffewhere_root_ll_
  {
    ffewhereLL_ first;
    ffewhereLL_ last;
  };

struct _ffewhere_root_line_
  {
    ffewhereLine first;
    ffewhereLine last;
    ffewhereLineNumber none;
  };

/* Static objects accessed by functions in this module. */

static struct _ffewhere_root_ll_ ffewhere_root_ll_;
static struct _ffewhere_root_line_ ffewhere_root_line_;

/* Static functions (internal). */

static ffewhereLL_ ffewhere_ll_lookup_ (ffewhereLineNumber ln);

/* Internal macros. */


/* Look up line-to-line object from absolute line num.  */

static ffewhereLL_
ffewhere_ll_lookup_ (ffewhereLineNumber ln)
{
  ffewhereLL_ ll;

  if (ln == 0)
    return ffewhere_root_ll_.first;

  for (ll = ffewhere_root_ll_.last;
       ll != (ffewhereLL_) &ffewhere_root_ll_.first;
       ll = ll->previous)
    {
      if (ll->line_no <= ln)
	return ll;
    }

  assert ("no line num" == NULL);
  return NULL;
}

/* A somewhat evil way to prevent the garbage collector
   from collecting 'file' structures.  */
#define NUM_FFEWHERE_HEAD_FILES 31
static struct ffewhere_ggc_tracker 
{
  struct ffewhere_ggc_tracker *next;
  ffewhereFile files[NUM_FFEWHERE_HEAD_FILES];
} *ffewhere_head = NULL;

static void 
mark_ffewhere_head (void *arg)
{
  struct ffewhere_ggc_tracker *head;
  int i;
  
  for (head = * (struct ffewhere_ggc_tracker **) arg;
       head != NULL;
       head = head->next)
  {
    ggc_mark (head);
    for (i = 0; i < NUM_FFEWHERE_HEAD_FILES; i++)
      ggc_mark (head->files[i]);
  }
}


/* Kill file object.

   Note that this object must not have been passed in a call
   to any other ffewhere function except ffewhere_file_name and
   ffewhere_file_namelen.  */

void
ffewhere_file_kill (ffewhereFile wf)
{
  struct ffewhere_ggc_tracker *head;
  int i;
  
  for (head = ffewhere_head; head != NULL; head = head->next)
    for (i = 0; i < NUM_FFEWHERE_HEAD_FILES; i++)
      if (head->files[i] == wf)
	{
	  head->files[i] = NULL;
	  return;
	}
  /* Called on a file that has already been deallocated... */
  abort();
}

/* Create file object.  */

ffewhereFile
ffewhere_file_new (const char *name, size_t length)
{
  ffewhereFile wf;
  int filepos;
 
  wf = ggc_alloc (offsetof (struct _ffewhere_file_, text)
		  + length + 1);
  wf->length = length;
  memcpy (&wf->text[0], name, length);
  wf->text[length] = '\0';

  if (ffewhere_head == NULL)
    {
      ggc_add_root (&ffewhere_head, 1, sizeof ffewhere_head,
		    mark_ffewhere_head);
      filepos = NUM_FFEWHERE_HEAD_FILES;
    }
  else
    {
      for (filepos = 0; filepos < NUM_FFEWHERE_HEAD_FILES; filepos++)
	if (ffewhere_head->files[filepos] == NULL)
	  {
	    ffewhere_head->files[filepos] = wf;
	    break;
	  }
    }
  if (filepos == NUM_FFEWHERE_HEAD_FILES)
    {
      /* Need to allocate a new block.  */
      struct ffewhere_ggc_tracker *old_head = ffewhere_head;
      int i;
      
      ffewhere_head = ggc_alloc (sizeof (*ffewhere_head));
      ffewhere_head->next = old_head;
      ffewhere_head->files[0] = wf;
      for (i = 1; i < NUM_FFEWHERE_HEAD_FILES; i++)
	ffewhere_head->files[i] = NULL;
    }

  return wf;
}

/* Set file and first line number.

   Pass FALSE if no line number is specified.  */

void
ffewhere_file_set (ffewhereFile wf, bool have_num, ffewhereLineNumber ln)
{
  ffewhereLL_ ll;

  ll = malloc_new_kp (ffe_pool_file (), "ffewhereLL_", sizeof (*ll));
  ll->next = (ffewhereLL_) &ffewhere_root_ll_.first;
  ll->previous = ffewhere_root_ll_.last;
  ll->next->previous = ll;
  ll->previous->next = ll;
  if (wf == NULL)
    {
      if (ll->previous == ll->next)
	ll->wf = NULL;
      else
	ll->wf = ll->previous->wf;
    }
  else
    ll->wf = wf;
  ll->line_no = ffelex_line_number ();
  if (have_num)
    ll->offset = ln;
  else
    {
      if (ll->previous == ll->next)
	ll->offset = 1;
      else
	ll->offset
	  = ll->line_no - ll->previous->line_no + ll->previous->offset;
    }
}

/* Do initializations.  */

void
ffewhere_init_1 ()
{
  ffewhere_root_line_.first = ffewhere_root_line_.last
  = (ffewhereLine) &ffewhere_root_line_.first;
  ffewhere_root_line_.none = 0;

  ffewhere_root_ll_.first = ffewhere_root_ll_.last
    = (ffewhereLL_) &ffewhere_root_ll_.first;
}

/* Return the textual content of the line.  */

char *
ffewhere_line_content (ffewhereLine wl)
{
  assert (wl != NULL);
  return wl->content;
}

/* Look up file object from line object.  */

ffewhereFile
ffewhere_line_file (ffewhereLine wl)
{
  ffewhereLL_ ll;

  assert (wl != NULL);
  ll = ffewhere_ll_lookup_ (wl->line_num);
  return ll->wf;
}

/* Lookup file object from line object, calc line#.  */

ffewhereLineNumber
ffewhere_line_filelinenum (ffewhereLine wl)
{
  ffewhereLL_ ll;

  assert (wl != NULL);
  ll = ffewhere_ll_lookup_ (wl->line_num);
  return wl->line_num + ll->offset - ll->line_no;
}

/* Decrement use count for line, deallocate if no uses left.  */

void
ffewhere_line_kill (ffewhereLine wl)
{
#if 0
  if (!ffewhere_line_is_unknown (wl))
    fprintf (dmpout, "; ffewhere_line_kill %" ffewhereLineNumber_f "u, uses=%"
	     ffewhereUses_f_ "u\n",
	     wl->line_num, wl->uses);
#endif
  assert (ffewhere_line_is_unknown (wl) || (wl->uses != 0));
  if (!ffewhere_line_is_unknown (wl) && (--wl->uses == 0))
    {
      wl->previous->next = wl->next;
      wl->next->previous = wl->previous;
      malloc_kill_ks (ffe_pool_file (), wl,
		      offsetof (struct _ffewhere_line_, content)
		      + wl->length + 1);
    }
}

/* Make a new line or increment use count of existing one.

   Find out where line object is, if anywhere.	If in lexer, it might also
   be at the end of the list of lines, else put it on the end of the list.
   Then, if in the list of lines, increment the use count and return the
   line object.	 Else, make an empty line object (no line) and return
   that.  */

ffewhereLine
ffewhere_line_new (ffewhereLineNumber ln)
{
  ffewhereLine wl = ffewhere_root_line_.last;

  /* If this is the lexer's current line, see if it is already at the end of
     the list, and if not, make it and return it. */

  if (((ln == 0)		/* Presumably asking for EOF pointer. */
       || (wl->line_num != ln))
      && (ffelex_line_number () == ln))
    {
#if 0
      fprintf (dmpout,
	       "; ffewhere_line_new %" ffewhereLineNumber_f "u, lexer\n",
	       ln);
#endif
      wl = malloc_new_ks (ffe_pool_file (), "FFEWHERE line",
			  offsetof (struct _ffewhere_line_, content)
			  + (size_t) ffelex_line_length () + 1);
      wl->next = (ffewhereLine) &ffewhere_root_line_;
      wl->previous = ffewhere_root_line_.last;
      wl->previous->next = wl;
      wl->next->previous = wl;
      wl->line_num = ln;
      wl->uses = 1;
      wl->length = ffelex_line_length ();
      strcpy (wl->content, ffelex_line ());
      return wl;
    }

  /* See if line is on list already. */

  while (wl->line_num > ln)
    wl = wl->previous;

  /* If line is there, increment its use count and return. */

  if (wl->line_num == ln)
    {
#if 0
      fprintf (dmpout, "; ffewhere_line_new %" ffewhereLineNumber_f "u, uses=%"
	       ffewhereUses_f_ "u\n", ln,
	       wl->uses);
#endif
      wl->uses++;
      return wl;
    }

  /* Else, make a new one with a blank line (since we've obviously lost it,
     which should never happen) and return it. */

  fprintf (stderr,
	   "(Cannot resurrect line %lu for error reporting purposes.)\n",
	   ln);

  wl = malloc_new_ks (ffe_pool_file (), "FFEWHERE line",
		      offsetof (struct _ffewhere_line_, content)
		      + 1);
  wl->next = (ffewhereLine) &ffewhere_root_line_;
  wl->previous = ffewhere_root_line_.last;
  wl->previous->next = wl;
  wl->next->previous = wl;
  wl->line_num = ln;
  wl->uses = 1;
  wl->length = 0;
  *(wl->content) = '\0';
  return wl;
}

/* Increment use count of line, as in a copy.  */

ffewhereLine
ffewhere_line_use (ffewhereLine wl)
{
#if 0
  fprintf (dmpout, "; ffewhere_line_use %" ffewhereLineNumber_f "u, uses=%" ffewhereUses_f_
	   "u\n", wl->line_num, wl->uses);
#endif
  assert (ffewhere_line_is_unknown (wl) || (wl->uses != 0));
  if (!ffewhere_line_is_unknown (wl))
    ++wl->uses;
  return wl;
}

/* Set an ffewhere object based on a track index.

   Determines the absolute line and column number of a character at a given
   index into an ffewhereTrack array.  wr* is the reference position, wt is
   the tracking information, and i is the index desired.  wo* is set to wr*
   plus the continual offsets described by wt[0...i-1], or unknown if any of
   the continual offsets are not known.	 */

void
ffewhere_set_from_track (ffewhereLine *wol, ffewhereColumn *woc,
			 ffewhereLine wrl, ffewhereColumn wrc,
			 ffewhereTrack wt, ffewhereIndex i)
{
  ffewhereLineNumber ln;
  ffewhereColumnNumber cn;
  ffewhereIndex j;
  ffewhereIndex k;

  if ((i == 0) || (i >= FFEWHERE_indexMAX))
    {
      *wol = ffewhere_line_use (wrl);
      *woc = ffewhere_column_use (wrc);
    }
  else
    {
      ln = ffewhere_line_number (wrl);
      cn = ffewhere_column_number (wrc);
      for (j = 0, k = 0; j < i; ++j, k += 2)
	{
	  if ((wt[k] == FFEWHERE_indexUNKNOWN)
	      || (wt[k + 1] == FFEWHERE_indexUNKNOWN))
	    {
	      *wol = ffewhere_line_unknown ();
	      *woc = ffewhere_column_unknown ();
	      return;
	    }
	  if (wt[k] == 0)
	    cn += wt[k + 1] + 1;
	  else
	    {
	      ln += wt[k];
	      cn = wt[k + 1] + 1;
	    }
	}
      if (ln == ffewhere_line_number (wrl))
	{			/* Already have the line object, just use it
				   directly. */
	  *wol = ffewhere_line_use (wrl);
	}
      else			/* Must search for the line object. */
	*wol = ffewhere_line_new (ln);
      *woc = ffewhere_column_new (cn);
    }
}

/* Build next tracking index.

   Set wt[i-1] continual offset so that it offsets from w* to (ln,cn).	Update
   w* to contain (ln,cn).  DO NOT call this routine if i >= FFEWHERE_indexMAX
   or i == 0.  */

void
ffewhere_track (ffewhereLine *wl, ffewhereColumn *wc, ffewhereTrack wt,
		ffewhereIndex i, ffewhereLineNumber ln,
		ffewhereColumnNumber cn)
{
  unsigned int lo;
  unsigned int co;

  if ((ffewhere_line_is_unknown (*wl))
      || (ffewhere_column_is_unknown (*wc))
      || ((lo = ln - ffewhere_line_number (*wl)) >= FFEWHERE_indexUNKNOWN))
    {
      wt[i * 2 - 2] = wt[i * 2 - 1] = FFEWHERE_indexUNKNOWN;
      ffewhere_line_kill (*wl);
      ffewhere_column_kill (*wc);
      *wl = FFEWHERE_lineUNKNOWN;
      *wc = FFEWHERE_columnUNKNOWN;
    }
  else if (lo == 0)
    {
      wt[i * 2 - 2] = 0;
      if ((co = cn - ffewhere_column_number (*wc)) > FFEWHERE_indexUNKNOWN)
	{
	  wt[i * 2 - 1] = FFEWHERE_indexUNKNOWN;
	  ffewhere_line_kill (*wl);
	  ffewhere_column_kill (*wc);
	  *wl = FFEWHERE_lineUNKNOWN;
	  *wc = FFEWHERE_columnUNKNOWN;
	}
      else
	{
	  wt[i * 2 - 1] = co - 1;
	  ffewhere_column_kill (*wc);
	  *wc = ffewhere_column_use (ffewhere_column_new (cn));
	}
    }
  else
    {
      wt[i * 2 - 2] = lo;
      if (cn > FFEWHERE_indexUNKNOWN)
	{
	  wt[i * 2 - 1] = FFEWHERE_indexUNKNOWN;
	  ffewhere_line_kill (*wl);
	  ffewhere_column_kill (*wc);
	  *wl = ffewhere_line_unknown ();
	  *wc = ffewhere_column_unknown ();
	}
      else
	{
	  wt[i * 2 - 1] = cn - 1;
	  ffewhere_line_kill (*wl);
	  ffewhere_column_kill (*wc);
	  *wl = ffewhere_line_use (ffewhere_line_new (ln));
	  *wc = ffewhere_column_use (ffewhere_column_new (cn));
	}
    }
}

/* Clear tracking index for internally created track.

   Set the tracking information to indicate that the tracking is at its
   simplest (no spaces or newlines within the tracking).  This means set
   everything to zero in the current implementation.  Length is the total
   length of the token; length must be 2 or greater, since length-1 tracking
   characters are set.	*/

void
ffewhere_track_clear (ffewhereTrack wt, ffewhereIndex length)
{
  ffewhereIndex i;

  if (length > FFEWHERE_indexMAX)
    length = FFEWHERE_indexMAX;

  for (i = 1; i < length; ++i)
    wt[i * 2 - 2] = wt[i * 2 - 1] = 0;
}

/* Copy tracking index from one place to another.

   Copy tracking information from swt[start] to dwt[0] and so on, presumably
   after an ffewhere_set_from_track call.  Length is the total
   length of the token; length must be 2 or greater, since length-1 tracking
   characters are set.	*/

void
ffewhere_track_copy (ffewhereTrack dwt, ffewhereTrack swt, ffewhereIndex start,
		     ffewhereIndex length)
{
  ffewhereIndex i;
  ffewhereIndex copy;

  if (length > FFEWHERE_indexMAX)
    length = FFEWHERE_indexMAX;

  if (length + start > FFEWHERE_indexMAX)
    copy = FFEWHERE_indexMAX - start;
  else
    copy = length;

  for (i = 1; i < copy; ++i)
    {
      dwt[i * 2 - 2] = swt[(i + start) * 2 - 2];
      dwt[i * 2 - 1] = swt[(i + start) * 2 - 1];
    }

  for (; i < length; ++i)
    {
      dwt[i * 2 - 2] = 0;
      dwt[i * 2 - 1] = 0;
    }
}

/* Kill tracking data.

   Kill all the tracking information by killing incremented lines from the
   first line number.  */

void
ffewhere_track_kill (ffewhereLine wrl, ffewhereColumn wrc UNUSED,
		     ffewhereTrack wt, ffewhereIndex length)
{
  ffewhereLineNumber ln;
  unsigned int lo;
  ffewhereIndex i;

  ln = ffewhere_line_number (wrl);

  if (length > FFEWHERE_indexMAX)
    length = FFEWHERE_indexMAX;

  for (i = 0; i < length - 1; ++i)
    {
      if ((lo = wt[i * 2]) == FFEWHERE_indexUNKNOWN)
	break;
      else if (lo != 0)
	{
	  ln += lo;
	  wrl = ffewhere_line_new (ln);
	  ffewhere_line_kill (wrl);
	}
    }
}