path: root/src/x-lisp.c

/* xgettext Lisp backend.
   Copyright (C) 2001-2002 Free Software Foundation, Inc.

   This file was written by Bruno Haible <haible@clisp.cons.org>, 2001.

   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 2, 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */

#ifdef HAVE_CONFIG_H
# include "config.h"
#endif

#include <errno.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#include "message.h"
#include "x-lisp.h"
#include "xgettext.h"
#include "error.h"
#include "xmalloc.h"
#include "exit.h"
#include "hash.h"
#include "gettext.h"

#define _(s) gettext(s)


/* The Common Lisp syntax is described in the Common Lisp HyperSpec, chapter 2.
   Since we are interested only in strings and in forms similar to
        (gettext msgid ...)
   or   (ngettext msgid msgid_plural ...)
   we make the following simplifications:

   - Assume the keywords and strings are in an ASCII compatible encoding.
     This means we can read the input file one byte at a time, instead of
     one character at a time.  No need to worry about multibyte characters:
     If they occur as part of identifiers, they most probably act as
     constituent characters, and the byte based approach will do the same.

   - Assume the read table is the standard Common Lisp read table.
     Non-standard read tables are mostly used to read data, not programs.

   - Assume the read table case is :UPCASE, and *READ-BASE* is 10.

   - Don't interpret #n= and #n#, they usually don't appear in programs.

   - Don't interpret #+, #-, they are unlikely to appear in a gettext form.

   The remaining syntax rules are:

   - The syntax code assigned to each character, and how tokens are built
     up from characters (single escape, multiple escape etc.).

   - Comment syntax: ';' and '#| ... |#'.

   - String syntax: "..." with single escapes.

   - Read macros and dispatch macro character '#'.  Needed to be able to
     tell which is the n-th argument of a function call.

 */


/* Prototypes for local functions.  Needed to ensure compiler checking of
   function argument counts despite of K&R C function definition syntax.  */
struct char_syntax;
struct token;
struct object;
static void init_keywords PARAMS ((void));
static int do_getc PARAMS ((void));
static void do_ungetc PARAMS ((int c));
static inline void init_token PARAMS ((struct token *tp));
static inline void free_token PARAMS ((struct token *tp));
static inline void grow_token PARAMS ((struct token *tp));
static void read_token PARAMS ((struct token *tp,
				const struct char_syntax *first));
static inline bool has_a_dot PARAMS ((const struct token *tp));
static inline bool all_a_number PARAMS ((const struct token *tp));
static inline void a_letter_to_digit PARAMS ((const struct token *tp,
					      int base));
static inline bool has_a_digit PARAMS ((const struct token *tp));
static inline bool has_adjacent_letters PARAMS ((const struct token *tp));
static bool is_potential_number PARAMS ((const struct token *tp, int *basep));
static void upcase_token PARAMS ((struct token *tp));
static void downcase_token PARAMS ((struct token *tp));
static void case_convert_token  PARAMS ((struct token *tp));
static inline void comment_start PARAMS ((void));
static inline void comment_add PARAMS ((int c));
static inline void comment_line_end PARAMS ((size_t chars_to_remove));
static inline void free_object PARAMS ((struct object *op));
static char * string_of_object PARAMS ((const struct object *op));
static void read_object PARAMS ((struct object *op));


/* ========================= Lexer customization.  ========================= */

/* 'readtable_case' is the case conversion that is applied to non-escaped
    parts of symbol tokens.  In Common Lisp: (readtable-case *readtable*).  */

enum rtcase
{
  case_upcase,
  case_downcase,
  case_preserve,
  case_invert
};

static enum rtcase readtable_case = case_upcase;

/* 'read_base' is the assumed radix of integers and rational numbers.
   In Common Lisp: *read-base*.  */
static int read_base = 10;

/* 'read_preserve_whitespace' specifies whether a whitespace character
   that terminates a token must be pushed back on the input stream.
   We set it to true, because the special newline side effect in read_object()
   requires that read_object() sees every newline not inside a token.  */
static bool read_preserve_whitespace = true;


/* ====================== Keyword set customization.  ====================== */

/* If true extract all strings.  */
static bool extract_all = false;

static hash_table keywords;
static bool default_keywords = true;


void
x_lisp_extract_all ()
{
  extract_all = true;
}


void
x_lisp_keyword (name)
     const char *name;
{
  if (name == NULL)
    default_keywords = false;
  else
    {
      const char *end;
      int argnum1;
      int argnum2;
      const char *colon;
      size_t len;
      char *symname;
      size_t i;

      if (keywords.table == NULL)
	init_hash (&keywords, 100);

      split_keywordspec (name, &end, &argnum1, &argnum2);

      /* The characters between name and end should form a valid Lisp symbol.
	 Extract the symbol name part.  */
      colon = strchr (name, ':');
      if (colon != NULL && colon < end)
	{
	  name = colon + 1;
	  if (name < end && *name == ':')
	    name++;
	  colon = strchr (name, ':');
	  if (colon != NULL && colon < end)
	    return;
	}

      /* Uppercase it.  */
      len = end - name;
      symname = (char *) xmalloc (len);
      for (i = 0; i < len; i++)
	symname[i] =
	  (name[i] >= 'a' && name[i] <= 'z' ? name[i] - 'a' + 'A' : name[i]);

      if (argnum1 == 0)
	argnum1 = 1;
      insert_entry (&keywords, symname, len,
		    (void *) (long) (argnum1 + (argnum2 << 10)));
    }
}

/* Finish initializing the keywords hash table.
   Called after argument processing, before each file is processed.  */
static void
init_keywords ()
{
  if (default_keywords)
    {
      x_lisp_keyword ("gettext");	/* I18N:GETTEXT */
      x_lisp_keyword ("ngettext:1,2");	/* I18N:NGETTEXT */
      x_lisp_keyword ("gettext-noop");
      default_keywords = false;
    }
}


/* ======================== Reading of characters.  ======================== */

/* Real filename, used in error messages about the input file.  */
static const char *real_file_name;

/* Logical filename and line number, used to label the extracted messages.  */
static char *logical_file_name;
static int line_number;

/* The input file stream.  */
static FILE *fp;


/* Fetch the next character from the input file.  */
static int
do_getc ()
{
  int c = getc (fp);

  if (c == EOF)
    {
      if (ferror (fp))
	error (EXIT_FAILURE, errno, _("\
error while reading \"%s\""), real_file_name);
    }
  else if (c == '\n')
   line_number++;

  return c;
}

/* Put back the last fetched character, not EOF.  */
static void
do_ungetc (c)
     int c;
{
  if (c == '\n')
    line_number--;
  ungetc (c, fp);
}


/* ========= Reading of tokens.  See CLHS 2.2 "Reader Algorithm".  ========= */


/* Syntax code.  See CLHS 2.1.4 "Character Syntax Types".  */

enum syntax_code
{
  syntax_illegal,	/* non-printable, except whitespace	*/
  syntax_single_esc,	/* '\' (single escape)			*/
  syntax_multi_esc,	/* '|' (multiple escape)		*/
  syntax_constituent,	/* everything else (constituent)	*/
  syntax_whitespace,	/* TAB,LF,FF,CR,' ' (whitespace)	*/
  syntax_eof,		/* EOF					*/
  syntax_t_macro,	/* '()'"' (terminating macro)		*/
  syntax_nt_macro	/* '#' (non-terminating macro)		*/
};

/* Prototypes for local functions.  Needed to ensure compiler checking of
   function argument counts despite of K&R C function definition syntax.  */
static enum syntax_code
       syntax_code_of PARAMS ((/*promote: unsigned char*/ int c));
static void read_char_syntax PARAMS ((struct char_syntax *p));

/* Returns the syntax code of a character.  */
static enum syntax_code
syntax_code_of (c)
     unsigned char c;
{
  switch (c)
    {
    case '\\':
      return syntax_single_esc;
    case '|':
      return syntax_multi_esc;
    case '\t': case '\n': case '\f': case '\r': case ' ':
      return syntax_whitespace;
    case '(': case ')': case '\'': case '"': case ',': case ';': case '`':
      return syntax_t_macro;
    case '#':
      return syntax_nt_macro;
    default:
      if (c < ' ' && c != '\b')
	return syntax_illegal;
      else
	return syntax_constituent;
    }
}

struct char_syntax
{
  int ch;			/* character */
  enum syntax_code scode;	/* syntax code */
};

/* Returns the next character and its syntax code.  */
static void
read_char_syntax (p)
     struct char_syntax *p;
{
  int c = do_getc ();

  p->ch = c;
  p->scode = (c == EOF ? syntax_eof : syntax_code_of (c));
}

/* Every character in a token has an attribute assigned.  The attributes
   help during interpretation of the token.  See
   CLHS 2.3 "Interpretation of Tokens" for the possible interpretations,
   and CLHS 2.1.4.2 "Constituent Traits".  */

enum attribute
{
  a_illg,	/* invalid constituent */
  a_pack_m,	/* ':' package marker */
  a_alpha,	/* normal alphabetic */
  a_escaped,	/* alphabetic but not subject to case conversion */
  a_ratio,	/* '/' */
  a_dot,	/* '.' */
  a_sign,	/* '+-' */
  a_extens,	/* '_^' extension characters */
  a_digit,	/* '0123456789' */
  a_letterdigit,/* 'A'-'Z','a'-'z' below base, except 'esfdlESFDL' */
  a_expodigit,	/* 'esfdlESFDL' below base */
  a_letter,	/* 'A'-'Z','a'-'z', except 'esfdlESFDL' */
  a_expo	/* 'esfdlESFDL' */
};

#define is_letter_attribute(a) ((a) >= a_letter)
#define is_number_attribute(a) ((a) >= a_ratio)

/* Prototypes for local functions.  Needed to ensure compiler checking of
   function argument counts despite of K&R C function definition syntax.  */
static enum attribute attribute_of PARAMS ((/*promote: unsigned char*/ int c));

/* Returns the attribute of a character, assuming base 10.  */
static enum attribute
attribute_of (c)
     unsigned char c;
{
  switch (c)
    {
    case ':':
      return a_pack_m;
    case '/':
      return a_ratio;
    case '.':
      return a_dot;
    case '+': case '-':
      return a_sign;
    case '_': case '^':
      return a_extens;
    case '0': case '1': case '2': case '3': case '4':
    case '5': case '6': case '7': case '8': case '9':
      return a_digit;
    case 'a': case 'b': case 'c': case 'g': case 'h': case 'i': case 'j':
    case 'k': case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
    case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'z':
    case 'A': case 'B': case 'C': case 'G': case 'H': case 'I': case 'J':
    case 'K': case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
    case 'T': case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z':
      return a_letter;
    case 'e': case 's': case 'd': case 'f': case 'l':
    case 'E': case 'S': case 'D': case 'F': case 'L':
      return a_expo;
    default:
      /* Treat everything as valid.  Never return a_illg.  */
      return a_alpha;
    }
}

struct token_char
{
  unsigned char ch;		/* character */
  unsigned char attribute;	/* attribute */
};

/* A token consists of a sequence of characters with associated attribute.  */
struct token
{
  int allocated;		/* number of allocated 'token_char's */
  int charcount;		/* number of used 'token_char's */
  struct token_char *chars;	/* the token's constituents */
  bool with_escape;		/* whether single-escape or multiple escape occurs */
};

/* Initialize a 'struct token'.  */
static inline void
init_token (tp)
     struct token *tp;
{
  tp->allocated = 10;
  tp->chars =
    (struct token_char *) xmalloc (tp->allocated * sizeof (struct token_char));
  tp->charcount = 0;
}

/* Free the memory pointed to by a 'struct token'.  */
static inline void
free_token (tp)
     struct token *tp;
{
  free (tp->chars);
}

/* Ensure there is enough room in the token for one more character.  */
static inline void
grow_token (tp)
     struct token *tp;
{
  if (tp->charcount == tp->allocated)
    {
      tp->allocated *= 2;
      tp->chars = (struct token_char *) xrealloc (tp->chars, tp->allocated * sizeof (struct token_char));
    }
}

/* Read the next token.  If 'first' is given, it points to the first
   character, which has already been read.
   The algorithm follows CLHS 2.2 "Reader Algorithm".  */
static void
read_token (tp, first)
     struct token *tp;
     const struct char_syntax *first;
{
  bool multiple_escape_flag;
  struct char_syntax curr;

  init_token (tp);
  tp->with_escape = false;

  multiple_escape_flag = false;
  if (first)
    curr = *first;
  else
    read_char_syntax (&curr);

  for (;; read_char_syntax (&curr))
    {
      switch (curr.scode)
	{
	case syntax_illegal:
	  /* Invalid input.  Be tolerant, no error message.  */
	  do_ungetc (curr.ch);
	  return;

	case syntax_single_esc:
	  tp->with_escape = true;
	  read_char_syntax (&curr);
	  if (curr.scode == syntax_eof)
	    /* Invalid input.  Be tolerant, no error message.  */
	    return;
	  grow_token (tp);
	  tp->chars[tp->charcount].ch = curr.ch;
	  tp->chars[tp->charcount].attribute = a_escaped;
	  tp->charcount++;
	  break;

	case syntax_multi_esc:
	  multiple_escape_flag = !multiple_escape_flag;
	  tp->with_escape = true;
	  break;

	case syntax_constituent:
	case syntax_nt_macro:
	  grow_token (tp);
	  if (multiple_escape_flag)
	    {
	      tp->chars[tp->charcount].ch = curr.ch;
	      tp->chars[tp->charcount].attribute = a_escaped;
	      tp->charcount++;
	    }
	  else
	    {
	      tp->chars[tp->charcount].ch = curr.ch;
	      tp->chars[tp->charcount].attribute = attribute_of (curr.ch);
	      tp->charcount++;
	    }
	  break;

	case syntax_whitespace:
	case syntax_t_macro:
	  if (multiple_escape_flag)
	    {
	      grow_token (tp);
	      tp->chars[tp->charcount].ch = curr.ch;
	      tp->chars[tp->charcount].attribute = a_escaped;
	      tp->charcount++;
	    }
	  else
	    {
	      if (curr.scode != syntax_whitespace || read_preserve_whitespace)
		do_ungetc (curr.ch);
	      return;
	    }
	  break;

	case syntax_eof:
	  if (multiple_escape_flag)
	    /* Invalid input.  Be tolerant, no error message.  */
	    ;
	  return;
	}
    }
}

/* A potential number is a token which
   1. consists only of digits, '+','-','/','^','_','.' and number markers.
      The base for digits is context dependent, but always 10 if a dot '.'
      occurs. A number marker is a non-digit letter which is not adjacent
      to a non-digit letter.
   2. has at least one digit.
   3. starts with a digit, '+','-','.','^' or '_'.
   4. does not end with '+' or '-'.
   See CLHS 2.3.1.1 "Potential Numbers as Tokens".
 */

static inline bool
has_a_dot (tp)
     const struct token *tp;
{
  int n = tp->charcount;
  int i;

  for (i = 0; i < n; i++)
    if (tp->chars[i].attribute == a_dot)
      return true;
  return false;
}

static inline bool
all_a_number (tp)
     const struct token *tp;
{
  int n = tp->charcount;
  int i;

  for (i = 0; i < n; i++)
    if (!is_number_attribute (tp->chars[i].attribute))
      return false;
  return true;
}

static inline void
a_letter_to_digit (tp, base)
     const struct token *tp;
     int base;
{
  int n = tp->charcount;
  int i;

  for (i = 0; i < n; i++)
    if (is_letter_attribute (tp->chars[i].attribute))
      {
	int c = tp->chars[i].ch;

	if (c >= 'a')
	  c -= 'a' - 'A';
	if (c - 'A' + 10 < base)
	  tp->chars[i].attribute -= 2; /* a_letter -> a_letterdigit,
					  a_expo -> a_expodigit */
      }
}

static inline bool
has_a_digit (tp)
     const struct token *tp;
{
  int n = tp->charcount;
  int i;

  for (i = 0; i < n; i++)
    if (tp->chars[i].attribute == a_digit
	|| tp->chars[i].attribute == a_letterdigit
	|| tp->chars[i].attribute == a_expodigit)
      return true;
  return false;
}

static inline bool
has_adjacent_letters (tp)
     const struct token *tp;
{
  int n = tp->charcount;
  int i;

  for (i = 1; i < n; i++)
    if (is_letter_attribute (tp->chars[i-1].attribute)
	&& is_letter_attribute (tp->chars[i].attribute))
      return true;
  return false;
}

static bool
is_potential_number (tp, basep)
     const struct token *tp;
     int *basep;
{
  /* CLHS 2.3.1.1.1:
     "A potential number cannot contain any escape characters."  */
  if (tp->with_escape)
    return false;

  if (has_a_dot (tp))
    *basep = 10;

  if (!all_a_number (tp))
    return false;

  a_letter_to_digit (tp, *basep);

  if (!has_a_digit (tp))
    return false;

  if (has_adjacent_letters (tp))
    return false;

  if (!(tp->chars[0].attribute >= a_dot
	&& tp->chars[0].attribute <= a_expodigit))
    return false;

  if (tp->chars[tp->charcount - 1].attribute == a_sign)
    return false;

  return true;
}

/* A number is one integer, ratio, float.  Each has a particular syntax.
   See CLHS 2.3.1 "Numbers as Tokens".
   But note a mistake: The exponent rule should read:
       exponent ::= exponent-marker [sign] {decimal-digit}+
   (see 22.1.3.1.3 "Printing Floats").  */

enum number_type
{
  n_none,
  n_integer,
  n_ratio,
  n_float
};

/* Prototypes for local functions.  Needed to ensure compiler checking of
   function argument counts despite of K&R C function definition syntax.  */
static enum number_type is_number PARAMS ((const struct token *tp, int *basep));

static enum number_type
is_number (tp, basep)
     const struct token *tp;
     int *basep;
{
  struct token_char *ptr_limit;
  struct token_char *ptr1;

  if (!is_potential_number (tp, basep))
    return n_none;

  /* is_potential_number guarantees
     - all attributes are >= a_ratio,
     - there is at least one a_digit or a_letterdigit or a_expodigit, and
     - if there is an a_dot, then *basep = 10.  */

  ptr1 = &tp->chars[0];
  ptr_limit = &tp->chars[tp->charcount];

  if (ptr1->attribute == a_sign)
    ptr1++;

  /* Test for syntax
   * { a_sign | }
   * { a_digit < base }+ { a_ratio { a_digit < base }+ | }
   */
  {
    bool seen_a_ratio = false;
    bool seen_a_digit = false;	/* seen a digit in last digit block? */
    struct token_char *ptr;

    for (ptr = ptr1;; ptr++)
      {
	if (ptr >= ptr_limit)
	  {
	    if (!seen_a_digit)
	      break;
	    if (seen_a_ratio)
	      return n_ratio;
	    else
	      return n_integer;
	  }
	if (ptr->attribute == a_digit
	    || ptr->attribute == a_letterdigit
	    || ptr->attribute == a_expodigit)
	  {
	    int c = ptr->ch;

	    c = (c < 'A' ? c - '0' : c < 'a' ? c - 'A' + 10 : c - 'a' + 10);
	    if (c >= *basep)
	      break;
	    seen_a_digit = true;
	  }
	else if (ptr->attribute == a_ratio)
	  {
	    if (seen_a_ratio || !seen_a_digit)
	      break;
	    seen_a_ratio = true;
	    seen_a_digit = false;
	  }
	else
	  break;
      }
  }

  /* Test for syntax
   * { a_sign | }
   * { a_digit }* { a_dot { a_digit }* | }
   * { a_expo { a_sign | } { a_digit }+ | }
   *
   * If there is an exponent part, there must be digits before the dot or
   * after the dot. The result is a float.
   * If there is no exponen:
   *   If there is no dot, it would an integer in base 10, but is has already
   *   been verified to not be an integer in the current base.
   *   If there is a dot:
   *     If there are digits after the dot, it's a float.
   *     Otherwise, if there are digits before the dot, it's an integer.
   */
  *basep = 10;
  {
    bool seen_a_dot = false;
    bool seen_a_dot_with_leading_digits = false;
    bool seen_a_digit = false;	/* seen a digit in last digit block? */
    struct token_char *ptr;

    for (ptr = ptr1;; ptr++)
      {
	if (ptr >= ptr_limit)
	  {
	    /* no exponent */
	    if (!seen_a_dot)
	      return n_none;
	    if (seen_a_digit)
	      return n_float;
	    if (seen_a_dot_with_leading_digits)
	      return n_integer;
	    else
	      return n_none;
	  }
	if (ptr->attribute == a_digit)
	  {
	    seen_a_digit = true;
	  }
	else if (ptr->attribute == a_dot)
	  {
	    if (seen_a_dot)
	      return n_none;
	    seen_a_dot = true;
	    if (seen_a_digit)
	      seen_a_dot_with_leading_digits = true;
	    seen_a_digit = false;
	  }
	else if (ptr->attribute == a_expo || ptr->attribute == a_expodigit)
	  break;
	else
	  return n_none;
      }
    ptr++;
    if (!seen_a_dot_with_leading_digits || !seen_a_digit)
      return n_none;
    if (ptr >= ptr_limit)
      return n_none;
    if (ptr->attribute == a_sign)
      ptr++;
    seen_a_digit = false;
    for (;; ptr++)
      {
	if (ptr >= ptr_limit)
	  break;
	if (ptr->attribute != a_digit)
	  return n_none;
	seen_a_digit = true;
      }
    if (!seen_a_digit)
      return n_none;
    return n_float;
  }
}

/* A token representing a symbol must be case converted.
   For portability, we convert only ASCII characters here.  */

static void
upcase_token (tp)
     struct token *tp;
{
  int n = tp->charcount;
  int i;

  for (i = 0; i < n; i++)
    if (tp->chars[i].attribute != a_escaped)
      {
	unsigned char c = tp->chars[i].ch;
	if (c >= 'a' && c <= 'z')
	  tp->chars[i].ch = c - 'a' + 'A';
      }
}

static void
downcase_token (tp)
     struct token *tp;
{
  int n = tp->charcount;
  int i;

  for (i = 0; i < n; i++)
    if (tp->chars[i].attribute != a_escaped)
      {
	unsigned char c = tp->chars[i].ch;
	if (c >= 'A' && c <= 'Z')
	  tp->chars[i].ch = c - 'A' + 'a';
      }
}

static void
case_convert_token  (tp)
     struct token *tp;
{
  int n = tp->charcount;
  int i;

  switch (readtable_case)
    {
    case case_upcase:
      upcase_token (tp);
      break;

    case case_downcase:
      downcase_token (tp);
      break;

    case case_preserve:
      break;

    case case_invert:
      {
	bool seen_uppercase = false;
	bool seen_lowercase = false;
	for (i = 0; i < n; i++)
	  if (tp->chars[i].attribute != a_escaped)
	    {
	      unsigned char c = tp->chars[i].ch;
	      if (c >= 'a' && c <= 'z')
		seen_lowercase = true;
	      if (c >= 'A' && c <= 'Z')
		seen_uppercase = true;
	    }
	if (seen_uppercase)
	  {
	    if (!seen_lowercase)
	      downcase_token (tp);
	  }
	else
	  {
	    if (seen_lowercase)
	      upcase_token (tp);
	  }
      }
      break;
    }
}


/* ========================= Accumulating comments ========================= */


static char *buffer;
static size_t bufmax;
static size_t buflen;

static inline void
comment_start ()
{
  buflen = 0;
}

static inline void
comment_add (c)
     int c;
{
  if (buflen >= bufmax)
    {
      bufmax += 100;
      buffer = xrealloc (buffer, bufmax);
    }
  buffer[buflen++] = c;
}

static inline void
comment_line_end (chars_to_remove)
     size_t chars_to_remove;
{
  buflen -= chars_to_remove;
  while (buflen >= 1
	 && (buffer[buflen - 1] == ' ' || buffer[buflen - 1] == '\t'))
    --buflen;
  if (chars_to_remove == 0 && buflen >= bufmax)
    {
      bufmax += 100;
      buffer = xrealloc (buffer, bufmax);
    }
  buffer[buflen] = '\0';
  xgettext_comment_add (buffer);
}


/* These are for tracking whether comments count as immediately before
   keyword.  */
static int last_comment_line;
static int last_non_comment_line;


/* ========================= Accumulating messages ========================= */


static message_list_ty *mlp;


/* ============== Reading of objects.  See CLHS 2 "Syntax".  ============== */


/* We are only interested in symbols (e.g. GETTEXT or NGETTEXT) and strings.
   Other objects need not to be represented precisely.  */
enum object_type
{
  t_symbol,	/* symbol */
  t_string,	/* string */
  t_other,	/* other kind of real object */
  t_dot,	/* '.' pseudo object */
  t_close,	/* ')' pseudo object */
  t_eof		/* EOF marker */
};

struct object
{
  enum object_type type;
  struct token *token;		/* for t_symbol and t_string */
  int line_number_at_start;	/* for t_string */
};

/* Free the memory pointed to by a 'struct object'.  */
static inline void
free_object (op)
     struct object *op;
{
  if (op->type == t_symbol || op->type == t_string)
    {
      free_token (op->token);
      free (op->token);
    }
}

/* Convert a t_string token to a char*.  */
static char *
string_of_object (op)
     const struct object *op;
{
  char *str;
  const struct token_char *p;
  char *q;
  int n;

  if (!(op->type == t_symbol || op->type == t_string))
    abort ();
  n = op->token->charcount;
  str = (char *) xmalloc (n + 1);
  q = str;
  for (p = op->token->chars; n > 0; p++, n--)
    *q++ = p->ch;
  *q = '\0';
  return str;
}

/* Read the next object.  */
static void
read_object (op)
     struct object *op;
{
  for (;;)
    {
      struct char_syntax curr;

      read_char_syntax (&curr);

      switch (curr.scode)
	{
	case syntax_eof:
	  op->type = t_eof;
	  return;

	case syntax_whitespace:
	  if (curr.ch == '\n')
	    /* Comments assumed to be grouped with a message must immediately
	       precede it, with no non-whitespace token on a line between
	       both.  */
	    if (last_non_comment_line > last_comment_line)
	      xgettext_comment_reset ();
	  continue;

	case syntax_illegal:
	  op->type = t_other;
	  return;

	case syntax_single_esc:
	case syntax_multi_esc:
	case syntax_constituent:
	  /* Start reading a token.  */
	  op->token = (struct token *) xmalloc (sizeof (struct token));
	  read_token (op->token, &curr);
	  last_non_comment_line = line_number;

	  /* Interpret the token.  */

	  /* Dots.  */
	  if (!op->token->with_escape
	      && op->token->charcount == 1
	      && op->token->chars[0].attribute == a_dot)
	    {
	      free_token (op->token);
	      free (op->token);
	      op->type = t_dot;
	      return;
	    }
	  /* Tokens consisting entirely of dots are illegal, but be tolerant
	     here.  */

	  /* Number.  */
	  {
	    int base = read_base;

	    if (is_number (op->token, &base) != n_none)
	      {
		free_token (op->token);
		free (op->token);
		op->type = t_other;
		return;
	      }
	  }

	  /* We interpret all other tokens as symbols (including 'reserved
	     tokens', i.e. potential numbers which are not numbers).  */
	  case_convert_token (op->token);
	  op->type = t_symbol;
	  return;

	case syntax_t_macro:
	case syntax_nt_macro:
	  /* Read a macro.  */
	  switch (curr.ch)
	    {
	    case '(':
	      {
		int arg = 0;		/* Current argument number.  */
		int argnum1 = 0;	/* First string position.  */
		int argnum2 = 0;	/* Plural string position.  */
		message_ty *plural_mp = NULL;	/* Remember the msgid.  */

		for (;; arg++)
		  {
		    struct object inner;

		    read_object (&inner);

		    /* Recognize end of list.  */
		    if (inner.type == t_close)
		      {
			op->type = t_other;
			/* Don't bother converting "()" to "NIL".  */
			last_non_comment_line = line_number;
			return;
		      }

		    /* Dots are not allowed in every position.
		       But be tolerant.  */

		    /* EOF inside list is illegal.
		       But be tolerant.  */
		    if (inner.type == t_eof)
		      break;

		    /* No need to bother if we extract all strings anyway.  */
		    if (!extract_all)
		      {
			if (arg == 0)
			  {
			    /* This is the function position.  */
			    if (inner.type == t_symbol)
			      {
				char *symbol_name = string_of_object (&inner);
				int i;
				int prefix_len;
				void *keyword_value;

				/* Omit any package name.  */
				i = inner.token->charcount;
				while (i > 0
				       && inner.token->chars[i-1].attribute != a_pack_m)
				  i--;
				prefix_len = i;

				if (find_entry (&keywords,
						symbol_name + prefix_len,
						strlen (symbol_name + prefix_len),
						&keyword_value)
				    == 0)
				  {
				    argnum1 = (int) (long) keyword_value & ((1 << 10) - 1);
				    argnum2 = (int) (long) keyword_value >> 10;
				  }

				free (symbol_name);
			      }
			  }
			else
			  {
			    /* These are the argument positions.
			       Extract a string if we have reached the right
			       argument position.  */
			    if (arg == argnum1)
			      {
				if (inner.type == t_string)
				  {
				    lex_pos_ty pos;
				    message_ty *mp;

				    pos.file_name = logical_file_name;
				    pos.line_number = inner.line_number_at_start;
				    mp = remember_a_message (mlp, string_of_object (&inner), &pos);
				    if (argnum2 > 0)
				      plural_mp = mp;
				  }
			      }
			    else if (arg == argnum2)
			      {
				if (inner.type == t_string && plural_mp != NULL)
				  {
				    lex_pos_ty pos;

				    pos.file_name = logical_file_name;
				    pos.line_number = inner.line_number_at_start;
				    remember_a_message_plural (plural_mp, string_of_object (&inner), &pos);
				  }
			      }
			  }
		      }

		    free_object (&inner);
		  }
	      }
	      op->type = t_other;
	      last_non_comment_line = line_number;
	      return;

	    case ')':
	      /* Tell the caller about the end of list.
		 Unmatched closing parenthesis is illegal.
		 But be tolerant.  */
	      op->type = t_close;
	      last_non_comment_line = line_number;
	      return;

	    case ',':
	      {
		int c = do_getc ();
		/* The ,@ handling inside lists is wrong anyway, because
		   ,@form expands to an unknown number of elements.  */
		if (c != EOF && c != '@' && c != '.')
		  do_ungetc (c);
	      }
	      /*FALLTHROUGH*/
	    case '\'':
	    case '`':
	      {
		struct object inner;

		read_object (&inner);

		/* Dots and EOF are not allowed here.  But be tolerant.  */

		free_object (&inner);

		op->type = t_other;
		last_non_comment_line = line_number;
		return;
	      }

	    case ';':
	      {
		bool all_semicolons = true;

		last_comment_line = line_number;
		comment_start ();
		for (;;)
		  {
		    int c = do_getc ();
		    if (c == EOF || c == '\n')
		      break;
		    if (c != ';')
		      all_semicolons = false;
		    if (!all_semicolons)
		      comment_add (c);
		  }
		comment_line_end (0);
		continue;
	      }

	    case '"':
	      {
		op->token = (struct token *) xmalloc (sizeof (struct token));
		init_token (op->token);
		op->line_number_at_start = line_number;
		for (;;)
		  {
		    int c = do_getc ();
		    if (c == EOF)
		      /* Invalid input.  Be tolerant, no error message.  */
		      break;
		    if (c == '"')
		      break;
		    if (c == '\\') /* syntax_single_esc */
		      {
			c = do_getc ();
			if (c == EOF)
			  /* Invalid input.  Be tolerant, no error message.  */
			  break;
		      }
		    grow_token (op->token);
		    op->token->chars[op->token->charcount++].ch = c;
		  }
		op->type = t_string;

		if (extract_all)
		  {
		    lex_pos_ty pos;

		    pos.file_name = logical_file_name;
		    pos.line_number = op->line_number_at_start;
		    remember_a_message (mlp, string_of_object (op), &pos);
		  }
		last_non_comment_line = line_number;
		return;
	      }

	    case '#':
	      /* Dispatch macro handling.  */
	      {
		int c;

		for (;;)
		  {
		    c = do_getc ();
		    if (c == EOF)
		      /* Invalid input.  Be tolerant, no error message.  */
		      {
			op->type = t_other;
			return;
		      }
		    if (!(c >= '0' && c <= '9'))
		      break;
		  }

		switch (c)
		  {
		  case '(':
		  case '"':
		    do_ungetc (c);
		    /*FALLTHROUGH*/
		  case '\'':
		  case ':':
		  case '.':
		  case ',':
		  case 'A': case 'a':
		  case 'C': case 'c':
		  case 'P': case 'p':
		  case 'S': case 's':
		    {
		      struct object inner;
		      read_object (&inner);
		      /* Dots and EOF are not allowed here.
			 But be tolerant.  */
		      free_object (&inner);
		      op->type = t_other;
		      last_non_comment_line = line_number;
		      return;
		    }

		  case '|':
		    {
		      int depth = 0;
		      int c;

		      comment_start ();
		      c = do_getc ();
		      for (;;)
			{
			  if (c == EOF)
			    break;
			  if (c == '|')
			    {
			      c = do_getc ();
			      if (c == EOF)
				break;
			      if (c == '#')
				{
				  if (depth == 0)
				    {
				      comment_line_end (0);
				      break;
				    }
				  depth--;
				  comment_add ('|');
				  comment_add ('#');
				  c = do_getc ();
				}
			      else
				comment_add ('|');
			    }
			  else if (c == '#')
			    {
			      c = do_getc ();
			      if (c == EOF)
				break;
			      comment_add ('#');
			      if (c == '|')
				{
				  depth++;
				  comment_add ('|');
				  c = do_getc ();
				}
			    }
			  else
			    {
			      /* We skip all leading white space.  */
			      if (!(buflen == 0 && (c == ' ' || c == '\t')))
				comment_add (c);
			      if (c == '\n')
				{
				  comment_line_end (1);
				  comment_start ();
				}
			      c = do_getc ();
			    }
			}
		      if (c == EOF)
			{
			  /* EOF not allowed here.  But be tolerant.  */
			  op->type = t_eof;
			  return;
			}
		      last_comment_line = line_number;
		      continue;
		    }

		  case '\\':
		    {
		      struct token token;
		      struct char_syntax first;
		      first.ch = '\\';
		      first.scode = syntax_single_esc;
		      read_token (&token, &first);
		      free_token (&token);
		      op->type = t_other;
		      last_non_comment_line = line_number;
		      return;
		    }

		  case 'B': case 'b':
		  case 'O': case 'o':
		  case 'X': case 'x':
		  case 'R': case 'r':
		  case '*':
		    {
		      struct token token;
		      read_token (&token, NULL);
		      free_token (&token);
		      op->type = t_other;
		      last_non_comment_line = line_number;
		      return;
		    }

		  case '=':
		    /* Ignore read labels.  */
		    continue;

		  case '#':
		    /* Don't bother looking up the corresponding object.  */
		    op->type = t_other;
		    last_non_comment_line = line_number;
		    return;

		  case '+':
		  case '-':
		    /* Simply assume every feature expression is true.  */
		    {
		      struct object inner;
		      read_object (&inner);
		      /* Dots and EOF are not allowed here.
			 But be tolerant.  */
		      free_object (&inner);
		      continue;
		    }

		  default:
		    op->type = t_other;
		    last_non_comment_line = line_number;
		    return;
		  }
		/*NOTREACHED*/
		abort ();
	      }

	    default:
	      /*NOTREACHED*/
	      abort ();
	    }

	default:
	  /*NOTREACHED*/
	  abort ();
	}
    }
}


void
extract_lisp (f, real_filename, logical_filename, mdlp)
     FILE *f;
     const char *real_filename;
     const char *logical_filename;
     msgdomain_list_ty *mdlp;
{
  mlp = mdlp->item[0]->messages;

  fp = f;
  real_file_name = real_filename;
  logical_file_name = xstrdup (logical_filename);
  line_number = 1;

  last_comment_line = -1;
  last_non_comment_line = -1;

  init_keywords ();

  /* Eat tokens until eof is seen.  When read_object returns
     due to an unbalanced closing parenthesis, just restart it.  */
  do
    {
      struct object toplevel_object;

      read_object (&toplevel_object);

      if (toplevel_object.type == t_eof)
	break;
    }
  while (!feof (fp));

  /* Close scanner.  */
  fp = NULL;
  real_file_name = NULL;
  logical_file_name = NULL;
  line_number = 0;
}