guile/libguile/guile-snarf.c

/* guile-snarf.c --- extract declarations from Guile source code
   Jim Blandy <jimb@red-bean.com> --- September 1999

	  Copyright (C) 1999 Free Software Foundation, Inc.
   
   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 software; see the file COPYING.  If not, write to
   the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
   Boston, MA 02111-1307 USA
  
   As a special exception, the Free Software Foundation gives permission
   for additional uses of the text contained in its release of GUILE.
  
   The exception is that, if you link the GUILE library with other files
   to produce an executable, this does not by itself cause the
   resulting executable to be covered by the GNU General Public License.
   Your use of that executable is in no way restricted on account of
   linking the GUILE library code into it.
  
   This exception does not however invalidate any other reasons why
   the executable file might be covered by the GNU General Public License.
  
   This exception applies only to the code released by the
   Free Software Foundation under the name GUILE.  If you copy
   code from other Free Software Foundation releases into a copy of
   GUILE, as the General Public License permits, the exception does
   not apply to the code that you add in this way.  To avoid misleading
   anyone as to the status of such modified files, you must delete
   this exception notice from them.
  
   If you write modifications of your own for GUILE, it is your choice
   whether to permit this exception to apply to your modifications.
   If you do not wish that, delete this exception notice.  */


/* The problem:

   It's really nice to be able to create Scheme procedures by simply
   adding a declaration above the C function's definition.  And you
   can use similar facilities for variables, symbols, etc.
 
   Using the C preprocessor to extract declarations from the C code is
   a clever idea, but it's not very robust.  Finding the C
   preprocessor, and getting it to run without errors, is too prone to
   interference from outside influences.  We end up having to pass all
   the -I flags and compiler flags to guile-snarf, whose job doesn't
   have anything to do with them.

   Thus, we redefine snarfing as a process which operates on a single
   text file, and ignores #inclusion.

   The general strategy:

   Scan the source file in just enough detail to correctly recognize C
   identifiers or reserved words.  This means watching for comments,
   string and character literals, etc.

   When we see an identifier from our selected list, parse an argument
   list after it according to the C preprocessor's rules, and then
   pass it to an appropriate function to handle.

   Still to do:

   - Test by comparing output with old shell script.
   - Add a test for this to Makefile.am.
   - Change build process to actually use this.
   - Make sure that errors cause .x file to be deleted.  `make' will do
     this if the process exits with a non-zero status, won't it?  If not,
     delete it ourselves.
   - Could we generate both the declarations and the initializations?
   - Can we simplify or improve the argument lists for some of the
     snarfing keywords, now that we can parse them any way we like?
   - When a file declares a *lot* of something, would it save space to
     emit a table and a loop, instead of a zillion function calls?  */


#include <stddef.h>
#include <stdlib.h>
#include <strings.h>
#include <stdio.h>
#include <stdarg.h>

#include "versiondat.h"


/* Utility functions.  */

char *program_name;

static void *
check_ptr (void *p)
{
  if (! p)
    {
      fprintf (stderr, "%s: out of memory\n", program_name);
      exit (2);
    }
  return p;
}

static void *
xmalloc (size_t size)
{
  return check_ptr (malloc (size));
}

static void *
xrealloc (void *ptr, size_t size)
{
  return check_ptr (realloc (ptr, size));
}

static void
system_error (char *message, char *filename)
{
  fprintf (stderr, "%s: ", program_name);
  if (filename) fprintf (stderr, "%s: ", filename);
  perror (message);

  exit (1);
}


/* Character table.  */

struct chartable {

  enum action {

    /* Just skip this character.  */
    act_normal,
    
    /* This character is whitespace.  */
    act_space,

    /* This character begins and ends a string/char literal.  */
    act_literal,

    /* This character is '/'.  If followed by a '*', begin a block
       comment.  If followed by another '/', begin a line comment.  */
    act_comment_start,

    /* This character increments the nesting level, and must be
       matched by the character in `follow'.  */
    act_open,

    /* This character decrements the nesting level, if it matches properly.  */
    act_close,

    /* This character could appear anywhere in an identifier.  */
    act_id_start,
    
    /* This character could appear anywhere in an identifier, except
       as the first character.  */
    act_id_follow,

    /* This character separates arguments in a keyword argument list,
       if it occurs at the outermost nesting level.  */
    act_arg_separator

  } action;

  int follow;
};

struct chartable chartable[256];
#define CHARTABLE(i) (chartable[(unsigned) (i)])


static void
match (char open, char close)
{
  CHARTABLE (open).action = act_open;
  CHARTABLE (open).follow = close;
  CHARTABLE (close).action = act_close;
}

static void
init_chartable ()
{
  int i;
  char *c;

  for (i = 0; i < 256; i++)
    CHARTABLE (i).action = act_normal;

  for (c = " \t\n\f"; *c; c++)
    CHARTABLE (*c).action = act_space;

  CHARTABLE ('"' ).action = act_literal;
  CHARTABLE ('\'').action = act_literal;

  CHARTABLE ('/').action = act_comment_start;

  match ('(', ')');
  match ('[', ']');
  match ('{', '}');

  CHARTABLE (',').action = act_arg_separator;

  for (i = 'a'; i <= 'z'; i++)
    CHARTABLE (i).action = act_id_start;
  for (i = 'A'; i <= 'Z'; i++)
    CHARTABLE (i).action = act_id_start;
  CHARTABLE ('_').action = act_id_start;

  for (i = '0'; i <= '9'; i++)
    CHARTABLE (i).action = act_id_follow;
}



/* Reading text while tracking the current line number.  */

/* The input file and the line number are global, because it's too
   much of a pain to pass them around everywhere as arguments.  Sorry.  */

FILE *in;			/* The current input file. */
char *in_name;			/* Its filename. */
int in_line;			/* The current line number in that file. */

FILE *out;			/* The current output file. */

static int
source_getc ()
{
  int c = getc (in);
  if (c == '\n')
    in_line++;
  return c;
}

static void
source_ungetc (int c)
{
  if (c == '\n')
    in_line--;
  ungetc (c, in);
}

static void
syntax_error (char *message, ...)
{
  va_list args;
  va_start (args, message);
  
  fprintf (stderr, "%s:%d: ", in_name, in_line);
  vfprintf (stderr, message, args);
  va_end (args);
  exit (1);
}


/* Skipping comments.  */

/* If we've read the first character of a comment start (that is, the
   character '/'), then check the second character.  If it's '*',
   we're in a block comment; read to the end of it.  If it's '/',
   we're starting a line comment; skip to the end of the line.
   Otherwise, put the second character back on the input stream.

   Return non-zero if this was a comment, zero otherwise.  */
static int
maybe_skip_comment ()
{
  int d = source_getc ();
    
  if (d == '*')
    {
      int prev;
      int start_line = in_line;

      /* Make sure the asterisk of the comment start doesn't
	 get mistaken for the asterisk of the comment end.  */
      d = 0;

      do
	{
	  prev = d;
	  d = source_getc ();
	}
      while (d != EOF && ! (prev == '*' && d == '/'));

      if (d == EOF)
	{
	  in_line = start_line;
	  syntax_error ("unterminated comment");
	}

      return 1;
    }
  else if (d == '/')
    {
      do
	d = source_getc ();
      while (d != '\n' && d != EOF);
      
      return 1;
    }
  else
    {
      source_ungetc (d);
      return 0;
    }
}


/* Parsing argument lists for keywords.  */

static int
arglist_getc (char *keyword)
{
  int c = source_getc ();
  if (c == EOF)
    syntax_error ("file ends in midst of arguments to keyword `%s'\n",
		  keyword);
  return c;
}

struct buffer {
  int size, len;
  char *text;
};

static void
init_buffer (struct buffer *b)
{
  b->size = 1;
  b->text = (char *) xmalloc (b->size);
  b->len = 0;
}

static void
add_char (struct buffer *b, int c)
{
  if (b->len >= b->size)
    {
      b->size *= 2;
      b->text = (char *) xrealloc (b->text, b->size);
    }

  b->text[b->len++] = c;
}

/* Parse a string or character literal, appending its text to b.  */
static void
read_literal (char *keyword, struct buffer *b, int start)
{
  add_char (b, start);
  
  for (;;)
    {
      int c = arglist_getc (keyword);
      add_char (b, c);
      if (c == '\\')
	add_char (b, arglist_getc (keyword));
      else if (c == start)
	break;
    }
}


/* Parse the argument list following a keyword, just as the
   C preprocessor would parse the arguments to a macro invocation.
   Return the arguments as an array of strings, terminated by a null
   pointer.

   If there's an error parsing the arguments, print an error message
   using KEYWORD as the keyword name, and exit. 

   Caller must free the array and each string; see the free_args
   function.  */
static char **
parse_args (char *keyword)
{
  /* Our read-ahead character.  */
  int c = arglist_getc (keyword);

  /* String of closing parens we are expecting, outermost first.  */ 
  struct buffer stack;

  /* Current list of arguments.  */
  int arglist_size = 1;
  char **arglist = (char **) xmalloc (arglist_size * sizeof (*arglist));
  int arglist_len = 0;

  init_buffer (&stack);

  /* Skip any initial whitespace.  */
  while (CHARTABLE (c).action == act_space)
    c = arglist_getc (keyword);

  /* Require an opening paren.  */
  if (c != '(')
    syntax_error ("arguments to snarfing keyword `%s' missing", keyword);
  add_char (&stack, ')');
  c = arglist_getc (keyword);
		  
  /* Read arguments, separated by commas outside of any (), {}, or []
     pairs.  */
  while (stack.len > 0)
    {
      /* start a new argument.  */
      struct buffer arg;
      int arg_incomplete = 1;

      init_buffer (&arg);

      /* Skip whitespace.  */
      while (CHARTABLE (c).action == act_space)
	c = arglist_getc (keyword);
      
      do
	{
	  switch (CHARTABLE (c).action)
	    {
	    case act_normal:
	    case act_space:
	    case act_id_start:
	    case act_id_follow:
	      add_char (&arg, c);
	      break;

	    case act_literal:
	      read_literal (keyword, &arg, c);
	      break;

	    case act_comment_start:
	      if (maybe_skip_comment ())
		add_char (&arg, ' ');
	      else
		add_char (&arg, c);
	      break;

	    case act_open:
	      add_char (&stack, CHARTABLE (c).follow);
	      add_char (&arg, c);
	      break;

	    case act_close:
	      if (stack.len == 0)
		/* We should have finished argument list parsing
		   when the stack became empty.  */
		abort ();
	      if (c != stack.text[stack.len - 1])
		syntax_error ("mismatched parenthesis: '%c' and '%c'",
			      stack.text[stack.len - 1], c);
	      stack.len--;
	      /* Closing parens are part of the argument, except for the
		 outermost closing paren.  */
	      if (stack.len > 0)
		add_char (&arg, c);
	      else
		arg_incomplete = 0;
	      break;

	    case act_arg_separator:
	      /* Commas are part of the argument, unless they occur at
		 the top level within the argument list.  */
	      if (stack.len == 1)
		arg_incomplete = 0;
	      else
		add_char (&arg, c);
	      break;

	    default:
	      abort ();
	    }

	  c = arglist_getc (keyword);
	}
      while (arg_incomplete);

      /* Add this argument to the list.  */
      add_char (&arg, '\0');
      if (arglist_len >= arglist_size)
	{
	  arglist_size *= 2;
	  arglist = (char **) xrealloc (arglist,
					arglist_size * sizeof (*arglist));
	}
      arglist[arglist_len++] = arg.text;
    }

  /* Null-terminate the argument list.  */
  arglist = (char **) xrealloc (arglist,
				(arglist_len + 1) * sizeof (*arglist));
  arglist[arglist_len] = 0;
  return arglist;
}

static int
count_args (char **args)
{
  int i;

  for (i = 0; args[i]; i++)
    ;

  return i;
}

static void
free_args (char **args)
{
  int i;

  for (i = 0; args[i]; i++)
    free (args[i]);
  free (args);
}


/* Individual routines for processing keywords.  */

/* Flags these routines might use to select details of their behavior.  */
enum keyword_flags {
  kw_gsubr   = 0x01,		/* create a gsubr */
  kw_generic = 0x02,		/* create a generic function */
  kw_global  = 0x04,		/* global declaration, not static */
  kw_init    = 0x08,		/* initialized value */
  kw_long    = 0x10,		/* initialize it with a long */
  kw_keyword = 0x20		/* make a keyword, not a symbol */
};

static void
check_arg_count (char *keyword, char **args, int expected)
{
  int actual = count_args (args);
  if (actual != expected)
    syntax_error ("keyword `%s' expects %d args, but got %d",
		  keyword, expected, actual);
}

static void
proc_keyword (char *keyword, char **args, int flags)
{
  int expected_args;

  if (flags & kw_gsubr)
    expected_args = 6;
  else
    expected_args = 4;

  if (flags & kw_generic)
    expected_args++;

  check_arg_count (keyword, args, expected_args);

  /* Print some nice indentation.  */
  fputs ("  ", out);

  /* Print out the function name.  */
  fprintf (out, "scm_make_%s%s",
	   (flags & kw_gsubr) ? "gsubr" : "subr",
	   (flags & kw_generic) ? "_with_generic" : "");

  /* And the arguments.  */
  fputs (" (", out);
  if (flags & kw_gsubr)
    fprintf (out, "%s, %s, %s, %s, (SCM (*) (...)) %s",
	     args[0], args[2], args[3], args[4], args[5]);
  else
    fprintf (out, "%s, %s, (SCM (*) (...)) %s",
	     args[0], args[2], args[3]);

  /* The generic versions have an extra argument at the end,
     which is a pointer to a generic function variable.  */
  if (flags & kw_generic)
    fprintf (out, ", &%s", (flags & kw_gsubr) ? args[6] : args[4]);

  fputs (");\n", out);
}

static void
syntax_keyword (char *keyword, char **args, int flags)
{
  check_arg_count (keyword, args, 4);

  fprintf (out, "  scm_make_synt (%s, %s, %s);\n",
	   args[0], args[2], args[3]);
}

static void
symbol_keyword (char *keyword, char **args, int flags)
{
  check_arg_count (keyword, args, 2);

  fprintf (out, "  %s = scm_permanent_object (", args[0]);
  if (flags & kw_keyword)
    fprintf (out, "scm_c_make_keyword (%s)", args[1]);
  else
    fprintf (out, "SCM_CAR (scm_intern0 (%s))", args[1]);
  fputs (");\n", out);
}

static void
vcell_keyword (char *keyword, char **args, int flags)
{
  check_arg_count (keyword, args, (flags & kw_init) ? 3 : 2);

  fprintf (out, "  %s = scm_permanent_object (scm_intern0 (%s));\n",
	   args[0], args[1]);
  fprintf (out, "  SCM_SETCDR (%s, ", args[0]);

  if (flags & kw_long)
    fprintf (out, "scm_long2num (%s)", args[2]);
  else if (flags & kw_init)
    fputs (args[2], out);
  else
    fputs ("SCM_BOOL_F", out);

  fputs (");\n", out);
}


/* The keyword table.  */

struct keyword {
  char *name;
  void (*func) (char *keyword, char **args, int flags);
  int flags;
};

/* The maximum length of any keyword, in bytes.  */
#define MAX_KEYWORD_LEN (20)

struct keyword keywords[] =
{
  { "SCM_PROC",   	     proc_keyword,   kw_gsubr },
  { "SCM_GPROC",  	     proc_keyword,   kw_gsubr | kw_generic },
  { "SCM_PROC1",  	     proc_keyword,   0 },
  { "SCM_GPROC1", 	     proc_keyword,   kw_generic },

  { "SCM_SYNTAX",            syntax_keyword, 0 },

  { "SCM_SYMBOL",            symbol_keyword, 0 },
  { "SCM_GLOBAL_SYMBOL",     symbol_keyword, kw_global },
  { "SCM_KEYWORD",           symbol_keyword, kw_keyword },
  { "SCM_GLOBAL_KEYWORD",    symbol_keyword, kw_keyword | kw_global },

  { "SCM_VCELL",             vcell_keyword,  0 },
  { "SCM_GLOBAL_VCELL",      vcell_keyword,  kw_global },
  { "SCM_VCELL_INIT",        vcell_keyword,  kw_init },
  { "SCM_GLOBAL_VCELL_INIT", vcell_keyword,  kw_init | kw_global },
  { "SCM_CONST_LONG",        vcell_keyword,  kw_init | kw_long },

  { 0, 0, 0 }
  
};

/* The bigger this is, the less likely a random identifier is
   to clash with the user's program.  */
#define KEYWORD_HASH_SIZE (1009)
struct keyword *keyword_hash[KEYWORD_HASH_SIZE];

static unsigned long
hash (char *text)
{
  long h = 0;

  while (*text)
    {
      unsigned char c = (unsigned char) *text++;
      h = (h << 4) + c + (c << 9) + (h >> 24) + 32;
    }
  
  return h;
}

static struct keyword *
is_keyword (char *name)
{
  unsigned long h = hash (name) % KEYWORD_HASH_SIZE;
  if (keyword_hash[h])
    {
      if (strcmp (name, keyword_hash[h]->name))
	{
	  /* Just for testing.  */
	  fprintf (stderr, "%s: keyword/user id hash collision: %s and %s\n",
		   program_name, keyword_hash[h]->name, name);
	  return 0;
	}

      return keyword_hash[h];
    }

  return 0;
}

static void
process_keyword (struct keyword *k)
{
  char **args = parse_args (k->name);
  k->func (k->name, args, k->flags);
  free_args (args);
}

static void
init_keyword_hash_table ()
{
  int i;

  for (i = 0; keywords[i].func; i++)
    {
      unsigned long h = hash (keywords[i].name) % KEYWORD_HASH_SIZE;
      if (keyword_hash[h])
	{
	  fprintf (stderr, "%s: keyword hash collision: %s and %s\n",
		   program_name, keyword_hash[h]->name, keywords[i].name);
	  exit (2);
	}
      keyword_hash[h] = &keywords[i];
    }
}


/* Scanning a file of C code.  */

/* Skip a string or character literal that started with the character
   FOLLOW.  */
static void
skip_literal (int follow)
{
  int start_line = in_line;

  for (;;)
    {
      int c = source_getc ();

      if (c == EOF)
	{
	  in_line = start_line;
	  syntax_error ("unterminated character or string literal");
	}
      else if (c == '\\')
	source_getc ();
      else if (c == follow)
	break;
    }
}

static void
read_id (char *buf, size_t size)
{
  int i = 0;

  for (;;)
    {
      int c = source_getc ();
      int action;

      if (c == EOF)
	break;

      action = CHARTABLE (c).action;
      if (action == act_id_start || action == act_id_follow)
	{
	  if (i < size)
	    buf[i] = c;
	  i++;
	}
      else
	{
	  source_ungetc (c);
	  break;
	}
    }

  /* It doesn't matter that we truncate the keyword to SIZE-1
     characters, since the buffer is large enough to hold any valid
     keyword.  */
  buf[(i >= size) ? size - 1 : i] = '\0';
}

static void
process_stream ()
{
  int c;

  for (;;)
    {
      c = source_getc ();
      if (c == EOF)
	break;

      switch (CHARTABLE (c).action)
	{
	case act_normal:
	case act_space:
	case act_open:
	case act_close:
	case act_id_follow:
	case act_arg_separator:
	  break;

	case act_literal:
	  skip_literal (c);
	  break;
	  
	case act_comment_start:
	  maybe_skip_comment ();
	  break;

	case act_id_start:
	  {
	    char buf[MAX_KEYWORD_LEN + 1];
	    struct keyword *k;

	    source_ungetc (c);
	    read_id (buf, sizeof (buf));
	    k = is_keyword (buf);
	    if (k)
	      process_keyword (k);
	  }
	  break;

	default:
	  abort ();
	}
    }
}

static void
process_file (char *inname, char *outname)
{
  in = fopen (inname, "r");
  if (! in)
    system_error ("error opening input file", inname);
  in_line = 1;
  in_name = inname;
  
  out = fopen (outname, "w");
  if (! out)
    system_error ("error opening output file", outname);

  process_stream (in, out);

  /* I'm told the AIX C preprocessor doesn't like to #include empty files.  */
  putc ('\n', out);
  
  if (ferror (in))
    system_error ("error reading input file", inname);
  if (ferror (out))
    system_error ("error writing output file", outname);

  if (fclose (in) == EOF)
    system_error ("error closing input file", inname);
  if (fclose (out) == EOF)
    system_error ("error closing output file", outname);
}


/* The main function.  */

static void
version ()
{
  fprintf (stderr, "guile-snarf (Guile) %s\n", GUILE_VERSION);
  exit (0);
}

static void
usage ()
{
  fprintf (stderr, "Usage: %s [-o OUTFILE] INFILE\n", program_name);
}

static void
help ()
{
  fprintf (stderr, "guile-snarf -- extract declarations from Guile C code.\n");
  usage ();
  fprintf (stderr, "\
This program makes it easier to write C code which defines Scheme\n\
functions and variables and uses Scheme symbols in Guile.  Instead of\n\
writing code yourself to build the Scheme objects when your code is\n\
initialized, you can write brief declarations above your C functions\n\
indicating how they should be called from Scheme.  Then, if you run\n\
this program on your source file, it will write code for you that\n\
defines functions, builds Scheme objects, and so on.  You can then\n\
#include this program's output into your initialization function.\n\
\n\
`INFILE' is the file from which we should extract declarations and\n\
generate initialization code.\n\
\n\
`-o OUTFILE' specifies the file where we should place the output.  If\n\
omitted, it defaults to `INFILE', with its extension changed to `.x'.\n");
  exit (0);
}

static void
bad_argument ()
{
  usage ();
  fprintf (stderr, "Type `%s --help' for more information.\n", program_name);
  exit (1);
}

int
main (int argc, char **argv)
{
  char *infile, *outfile;

  program_name = strrchr (argv[0], '/');
  if (! program_name)
    program_name = argv[0];
  else
    program_name++;

  infile = 0;
  outfile = 0;
  argc--, argv++;
  while (argc > 0)
    {
      if (! strcmp (argv[0], "--version"))
	version ();
      else if (! strcmp (argv[0], "--help"))
	help ();
      else if (! strcmp (argv[0], "-o"))
	outfile = *++argv, argc--;
      else if (argv[0][0] == '-')
	{
	  fprintf (stderr, "%s: unrecognized switch: `%s'\n",
		   program_name, argv[0]);
	  bad_argument ();
	}
      else if (infile)
	{
	  fprintf (stderr, "%s: more than input file given: `%s' and `%s'\n",
		   program_name, infile, argv[0]);
	  bad_argument ();
	}
      else
	infile = argv[0];

      argc--, argv++;
    }

  if (! infile)
    {
      fprintf (stderr, "%s: no input file given\n", program_name);
      bad_argument ();
    }

  if (! outfile)
    {
      /* Choose a default output file name.  This should be the input
         file name, with the extension changed to `.x'.  */
      char *ext = strrchr (infile, '.');

      /* Make sure we haven't mistaken a dot in an earlier path
	 component for the start of the extension.  */
      if (ext && strchr (ext, '/'))
	ext = 0;

      if (ext)
	{
	  outfile = (char *) xmalloc (ext - infile + 3);
	  strcpy (outfile, infile);
	  strcpy (outfile + (ext - infile), ".x");
	}
      else
	{
	  outfile = (char *) xmalloc (strlen (infile) + 3);
	  strcpy (outfile, infile);
	  strcat (outfile, ".x");
	}
    }

  init_chartable ();
  init_keyword_hash_table ();
  process_file (infile, outfile);

  return 0;
}