/* -*-C-*-

$Id: syntax.c,v 1.25 2000/12/05 21:23:48 cph Exp $

Copyright (c) 1987-2000 Massachusetts Institute of Technology

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 of the License, 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., 675 Mass Ave, Cambridge, MA 02139, USA.
*/

/* Primitives to support Edwin syntax tables, word and list parsing. */

/* NOTE: This program was created by translation from the syntax table
code of GNU Emacs; it was translated from the original C to 68000
assembly language (in 1986), and then translated back from 68000
assembly language to C (in 1987).  Users should be aware that the GNU
GENERAL PUBLIC LICENSE may apply to this code.  A copy of that license
should have been included along with this file. */

#include "scheme.h"
#include "prims.h"
#include "edwin.h"
#include "syntax.h"

/* Syntax Codes */

/* Convert a letter which signifies a syntax code
   into the code it signifies. */

#define ILLEGAL ((char) syntaxcode_max)

char syntax_spec_code[0200] =
  {
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,

    ((char) syntaxcode_whitespace), ILLEGAL, ((char) syntaxcode_string),
        ILLEGAL, ((char) syntaxcode_math), ILLEGAL, ILLEGAL,
        ((char) syntaxcode_quote),
    ((char) syntaxcode_open), ((char) syntaxcode_close), ILLEGAL, ILLEGAL,
        ILLEGAL, ((char) syntaxcode_whitespace), ((char) syntaxcode_punct),
        ((char) syntaxcode_charquote),
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ((char) syntaxcode_comment),
        ILLEGAL, ((char) syntaxcode_endcomment), ILLEGAL,

    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
        ((char) syntaxcode_word),
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ((char) syntaxcode_escape), ILLEGAL,
        ILLEGAL, ((char) syntaxcode_symbol),

    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
        ((char) syntaxcode_word),
    ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL
  };

/* Indexed by syntax code, give the letter that describes it. */

unsigned char syntax_code_spec[13] =
  {
    ' ', '.', 'w', '_', '(', ')', '\'', '\"', '$', '\\', '/', '<', '>'
  };

#define MERGE_PREFIX_BIT(bit)						\
{									\
  if ((result & bit) != 0)						\
    error_bad_range_arg (1);						\
  result |= bit;							\
}

#define MERGE_COMMENT(bit) MERGE_PREFIX_BIT ((bit) << 12)

DEFINE_PRIMITIVE ("STRING->SYNTAX-ENTRY", Prim_string_to_syntax_entry, 1, 1, 0)
{
  long length, c, result;
  unsigned char * scan;
  PRIMITIVE_HEADER (1);

  CHECK_ARG (1, STRING_P);
  length = (STRING_LENGTH (ARG_REF (1)));
  scan = (STRING_LOC ((ARG_REF (1)), 0));

  if ((length--) > 0)
    {
      c = (*scan++);
      if (c >= 0200) error_bad_range_arg (1);
      result = (syntax_spec_code [c]);
      if (result == ILLEGAL) error_bad_range_arg (1);
    }
  else
    result = ((long) syntaxcode_whitespace);

  if ((length--) > 0)
    {
      c = (*scan++);
      if (c != ' ') result |= (c << 4);
    }

  while ((length--) > 0)
    switch (*scan++)
      {
      case '1': MERGE_COMMENT (COMSTART_FIRST_B); break;
      case '2': MERGE_COMMENT (COMSTART_SECOND_B); break;
      case '3': MERGE_COMMENT (COMEND_FIRST_B); break;
      case '4': MERGE_COMMENT (COMEND_SECOND_B); break;
      case '5': MERGE_COMMENT (COMSTART_FIRST_A); break;
      case '6': MERGE_COMMENT (COMSTART_SECOND_A); break;
      case '7': MERGE_COMMENT (COMEND_FIRST_A); break;
      case '8': MERGE_COMMENT (COMEND_SECOND_A); break;
      case 'b':
	switch (SYNTAX_ENTRY_CODE (result))
	  {
	  case syntaxcode_comment: MERGE_COMMENT (COMSTART_FIRST_B); break;
	  case syntaxcode_endcomment: MERGE_COMMENT (COMEND_FIRST_B); break;
	  default: break;
	  }
	break;
      case 'p': MERGE_PREFIX_BIT (1 << 20); break;
      case ' ': break;
      default: error_bad_range_arg (1);
      }
  if (((SYNTAX_ENTRY_CODE (result)) == syntaxcode_comment)
      && (! ((SYNTAX_ENTRY_COMMENT_BITS (result)) & COMSTART_FIRST)))
    MERGE_COMMENT (COMSTART_FIRST_A);
  if (((SYNTAX_ENTRY_CODE (result)) == syntaxcode_endcomment)
      && (! ((SYNTAX_ENTRY_COMMENT_BITS (result)) & COMEND_FIRST)))
    MERGE_COMMENT (COMEND_FIRST_A);
  PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
}

DEFINE_PRIMITIVE ("CHAR->SYNTAX-CODE", Prim_char_to_syntax_code, 2, 2, 0)
{
  PRIMITIVE_HEADER (2);
  CHECK_ARG (1, SYNTAX_TABLE_P);
  PRIMITIVE_RETURN
    (ASCII_TO_CHAR
     (syntax_code_spec
      [((int)
	(SYNTAX_ENTRY_CODE
	 (SYNTAX_TABLE_REF ((ARG_REF (1)), (arg_ascii_char (2))))))]));
}

/* Parser Initialization */

#define NORMAL_INITIALIZATION_COMMON(arity)				\
  fast SCHEME_OBJECT syntax_table;					\
  fast SCHEME_OBJECT group;						\
  fast unsigned char * start;						\
  unsigned char * first_char, * end;					\
  long gap_length;							\
  PRIMITIVE_HEADER (arity);						\
  CHECK_ARG (1, SYNTAX_TABLE_P);					\
  syntax_table = (ARG_REF (1));						\
  CHECK_ARG (2, GROUP_P);						\
  group = (ARG_REF (2));						\
  first_char = (STRING_LOC ((GROUP_TEXT (group)), 0));			\
  start = (first_char + (arg_nonnegative_integer (3)));			\
  end = (first_char + (arg_nonnegative_integer (4)));			\
  gap_start = (first_char + (GROUP_GAP_START (group)));			\
  gap_length = (GROUP_GAP_LENGTH (group));				\
  gap_end = (first_char + (GROUP_GAP_END (group)))

#define NORMAL_INITIALIZATION_FORWARD(arity)				\
  unsigned char * gap_start;						\
  fast unsigned char * gap_end;						\
  NORMAL_INITIALIZATION_COMMON (arity);					\
  if (start >= gap_start)						\
    start += gap_length;						\
  if (end >= gap_start)							\
    end += gap_length

#define NORMAL_INITIALIZATION_BACKWARD(arity)				\
  fast unsigned char * gap_start;					\
  unsigned char * gap_end;						\
  NORMAL_INITIALIZATION_COMMON (arity);					\
  if (start > gap_start)						\
    start += gap_length;						\
  if (end > gap_start)							\
    end += gap_length

#define SCAN_LIST_INITIALIZATION(initialization)			\
  long depth, min_depth;						\
  Boolean sexp_flag, ignore_comments, math_exit;			\
  int c;								\
  initialization (7);							\
  depth = (arg_integer (5));						\
  min_depth = ((depth >= 0) ? 0 : depth);				\
  sexp_flag = (BOOLEAN_ARG (6));					\
  ignore_comments = (BOOLEAN_ARG (7));					\
  math_exit = false

/* Parse Scanning */

#define PEEK_RIGHT(scan) (SYNTAX_TABLE_REF (syntax_table, (*scan)))
#define PEEK_LEFT(scan) (SYNTAX_TABLE_REF (syntax_table, (scan[-1])))

#define MOVE_RIGHT(scan) do						\
{									\
  if ((++scan) == gap_start)						\
    scan = gap_end;							\
} while (0)

#define MOVE_LEFT(scan) do						\
{									\
  if ((--scan) == gap_end)						\
    scan = gap_start;							\
} while (0)

#define READ_RIGHT(scan, target) do					\
{									\
  target = (SYNTAX_TABLE_REF (syntax_table, (*scan++)));		\
  if (scan == gap_start)						\
    scan = gap_end;							\
} while (0)

#define READ_LEFT(scan, target) do					\
{									\
  target = (SYNTAX_TABLE_REF (syntax_table, (*--scan)));		\
  if (scan == gap_end)							\
    scan = gap_start;							\
} while (0)

#define RIGHT_END_P(scan) (scan >= end)
#define LEFT_END_P(scan) (scan <= end)

#define LOSE_IF(expression) do						\
{									\
  if (expression)							\
    PRIMITIVE_RETURN (SHARP_F);						\
} while (0)

#define LOSE_IF_RIGHT_END(scan) LOSE_IF (RIGHT_END_P (scan))
#define LOSE_IF_LEFT_END(scan) LOSE_IF (LEFT_END_P (scan))

#define SCAN_TO_INDEX(scan)						\
  ((((scan) > gap_start) ? ((scan) - gap_length) : (scan)) - first_char)

#define INDEX_TO_SCAN(index)						\
  ((((index) + first_char) > gap_start)					\
   ? (((index) + first_char) + gap_length)				\
   : ((index) + first_char))

#define WIN_IF(expression) do						\
{									\
  if (expression)							\
    PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start)));	\
} while (0)

#define WIN_IF_RIGHT_END(scan) WIN_IF (RIGHT_END_P (scan))
#define WIN_IF_LEFT_END(scan) WIN_IF (LEFT_END_P (scan))

#define RIGHT_QUOTED_P_INTERNAL(scan, quoted) do			\
{									\
  quoted = false;							\
  while (true)								\
    {									\
      long sentry;							\
      if (LEFT_END_P (scan))						\
	break;								\
      READ_LEFT (scan, sentry);						\
      if (! (SYNTAX_ENTRY_QUOTE (sentry)))				\
	break;								\
      quoted = (! quoted);						\
    }									\
} while (0)

#define RIGHT_QUOTED_P(scan_init, quoted) do				\
{									\
  unsigned char * scan = (scan_init);					\
  RIGHT_QUOTED_P_INTERNAL (scan, quoted);				\
} while (0)

#define LEFT_QUOTED_P(scan_init, quoted) do				\
{									\
  unsigned char * scan = (scan_init);					\
  MOVE_LEFT (scan);							\
  RIGHT_QUOTED_P_INTERNAL (scan, quoted);				\
} while (0)

/* Quote Parsers */

DEFINE_PRIMITIVE ("QUOTED-CHAR?", Prim_quoted_char_p, 4, 4, 0)
{
  Boolean quoted;
  NORMAL_INITIALIZATION_BACKWARD (4);

  RIGHT_QUOTED_P (start, quoted);
  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (quoted));
}

/* This is used in conjunction with `scan-list-backward' to find the
   beginning of an s-expression. */

DEFINE_PRIMITIVE ("SCAN-BACKWARD-PREFIX-CHARS", Prim_scan_backward_prefix_chars, 4, 4, 0)
{
  Boolean quoted;
  NORMAL_INITIALIZATION_BACKWARD (4);

  while (true)
    {
      WIN_IF_LEFT_END (start);
      LEFT_QUOTED_P (start, quoted);
      WIN_IF (quoted);
      {
	long sentry = (PEEK_LEFT (start));
	WIN_IF (! (((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_quote)
		   || (SYNTAX_ENTRY_PREFIX (sentry))));
      }
      MOVE_LEFT (start);
    }
}

DEFINE_PRIMITIVE ("SCAN-FORWARD-PREFIX-CHARS", Prim_scan_forward_prefix_chars, 4, 4, 0)
{
  Boolean quoted;
  NORMAL_INITIALIZATION_FORWARD (4);

  while (true)
    {
      WIN_IF_RIGHT_END (start);
      RIGHT_QUOTED_P (start, quoted);
      WIN_IF (quoted);
      {
	long sentry = (PEEK_RIGHT (start));
	WIN_IF (! (((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_quote)
		   || (SYNTAX_ENTRY_PREFIX (sentry))));
      }
      MOVE_RIGHT (start);
    }
}

/* Word Parsers */

DEFINE_PRIMITIVE ("SCAN-FORWARD-TO-WORD", Prim_scan_forward_to_word, 4, 4, 0)
{
  NORMAL_INITIALIZATION_FORWARD (4);

  while (true)
    {
      LOSE_IF_RIGHT_END (start);
      WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) == syntaxcode_word);
      MOVE_RIGHT (start);
    }
}

DEFINE_PRIMITIVE ("SCAN-WORD-FORWARD", Prim_scan_word_forward, 4, 4, 0)
{
  NORMAL_INITIALIZATION_FORWARD (4);

  while (true)
    {
      long sentry;
      LOSE_IF_RIGHT_END (start);
      READ_RIGHT (start, sentry);
      if ((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_word)
	break;
    }
  while (true)
    {
      WIN_IF_RIGHT_END (start);
      WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) != syntaxcode_word);
      MOVE_RIGHT (start);
    }
}

DEFINE_PRIMITIVE ("SCAN-WORD-BACKWARD", Prim_scan_word_backward, 4, 4, 0)
{
  NORMAL_INITIALIZATION_BACKWARD (4);

  while (true)
    {
      long sentry;
      LOSE_IF_LEFT_END (start);
      READ_LEFT (start, sentry);
      if ((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_word)
	break;
    }
  while (true)
    {
      WIN_IF_LEFT_END (start);
      WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) != syntaxcode_word);
      MOVE_LEFT (start);
    }
}

/* S-Expression Parsers */

DEFINE_PRIMITIVE ("SCAN-LIST-FORWARD", Prim_scan_list_forward, 7, 7, 0)
{
  SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_FORWARD);

  while (true)
    {
      long sentry;
      LOSE_IF_RIGHT_END (start);
      c = (*start);
      READ_RIGHT (start, sentry);

      {
	unsigned int style = 0;
	if (((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_comment)
	  style = (SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMSTART_FIRST));
	else if (! (RIGHT_END_P (start)))
	  {
	    style
	      = ((SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMSTART_FIRST))
		 & (SYNTAX_ENTRY_COMMENT_STYLE ((PEEK_RIGHT (start)),
						COMSTART_SECOND)));
	    if (style != 0)
	      MOVE_RIGHT (start);
	  }
	if (style != 0)
	  {
	    LOSE_IF_RIGHT_END (start);
	    while (true)
	      {
		READ_RIGHT (start, sentry);
		if ((SYNTAX_ENTRY_COMMENT_BITS (sentry))
		    & COMEND_FIRST
		    & style)
		  {
		    if (((SYNTAX_ENTRY_CODE (sentry)))
			== syntaxcode_endcomment)
		      break;
		    LOSE_IF_RIGHT_END (start);
		    if ((SYNTAX_ENTRY_COMMENT_BITS (PEEK_RIGHT (start)))
			& COMEND_SECOND
			& style)
		      {
			MOVE_RIGHT (start);
			break;
		      }
		  }
	      }
	    continue;
	  }
      }
      if (SYNTAX_ENTRY_PREFIX (sentry))
	continue;

      switch (SYNTAX_ENTRY_CODE (sentry))
	{
	case syntaxcode_escape:
	case syntaxcode_charquote:
	  LOSE_IF_RIGHT_END (start);
	  MOVE_RIGHT (start);

	case syntaxcode_word:
	case syntaxcode_symbol:
	  if ((depth != 0) || (! sexp_flag))
	    break;
	  while (true)
	    {
	      WIN_IF_RIGHT_END (start);
	      switch (SYNTAX_ENTRY_CODE (PEEK_RIGHT (start)))
		{
		case syntaxcode_escape:
		case syntaxcode_charquote:
		  MOVE_RIGHT (start);
		  LOSE_IF_RIGHT_END (start);

		case syntaxcode_word:
		case syntaxcode_symbol:
		  MOVE_RIGHT (start);
		  break;

		default:
		  WIN_IF (true);
		}
	    }

	case syntaxcode_math:
	  if (! sexp_flag)
	    break;
	  if ((! (RIGHT_END_P (start))) && (c == *start))
	    MOVE_RIGHT (start);
	  if (math_exit)
	    {
	      WIN_IF ((--depth) == 0);
	      LOSE_IF (depth < min_depth);
	      math_exit = false;
	    }
	  else
	    {
	      WIN_IF ((++depth) == 0);
	      math_exit = true;
	    }
	  break;

	case syntaxcode_open:
	  WIN_IF ((++depth) == 0);
	  break;

	case syntaxcode_close:
	  WIN_IF ((--depth) == 0);
	  LOSE_IF (depth < min_depth);
	  break;

	case syntaxcode_string:
	  while (true)
	    {
	      LOSE_IF_RIGHT_END (start);
	      if (c == *start)
		break;
	      READ_RIGHT (start, sentry);
	      if (SYNTAX_ENTRY_QUOTE (sentry))
		{
		  LOSE_IF_RIGHT_END (start);
		  MOVE_RIGHT (start);
		}
	    }
	  MOVE_RIGHT (start);
	  WIN_IF ((depth == 0) && sexp_flag);
	  break;

	default:
	  break;
	}
    }
}

DEFINE_PRIMITIVE ("SCAN-LIST-BACKWARD", Prim_scan_list_backward, 7, 7, 0)
{
  Boolean quoted;
  SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_BACKWARD);

  while (true)
    {
      long sentry;
      LOSE_IF_LEFT_END (start);
      LEFT_QUOTED_P (start, quoted);
      if (quoted)
	{
	  MOVE_LEFT (start);
	  /* existence of this character is guaranteed by LEFT_QUOTED_P. */
	  READ_LEFT (start, sentry);
	  goto word_entry;
	}
      c = (start[-1]);
      READ_LEFT (start, sentry);

      {
	unsigned int style = 0;
	if (((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_endcomment)
	  {
	    if (ignore_comments)
	      style = (SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMEND_SECOND));
	  }
	else if (! (LEFT_END_P (start)))
	  {
	    LEFT_QUOTED_P (start, quoted);
	    if (!quoted)
	      {
		style
		  = ((SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMEND_SECOND))
		     & (SYNTAX_ENTRY_COMMENT_STYLE ((PEEK_LEFT (start)),
						    COMEND_FIRST)));
		if (style != 0)
		  MOVE_LEFT (start);
	      }
	  }
	if (style != 0)
	  {
	    LOSE_IF_LEFT_END (start);
	    while (true)
	      {
		READ_LEFT (start, sentry);
		if ((((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_comment)
		    && ((SYNTAX_ENTRY_COMMENT_BITS (sentry))
			& COMSTART_FIRST
			& style))
		  break;
		LOSE_IF_LEFT_END (start);
		if (((SYNTAX_ENTRY_COMMENT_BITS (sentry))
		     & COMSTART_SECOND
		     & style)
		    && ((SYNTAX_ENTRY_COMMENT_BITS (PEEK_LEFT (start)))
			& COMSTART_FIRST
			& style))
		  {
		    MOVE_LEFT (start);
		    break;
		  }
	      }
	    continue;
	  }
      }

      switch (SYNTAX_ENTRY_CODE (sentry))
	{
	case syntaxcode_word:
	case syntaxcode_symbol:
	word_entry:
	  if ((depth != 0) || (! sexp_flag))
	    break;
	  while (true)
	    {
	      WIN_IF_LEFT_END (start);
	      LEFT_QUOTED_P (start, quoted);
	      if (quoted)
		MOVE_LEFT (start);
	      else
		{
		  sentry = (PEEK_LEFT (start));
		  WIN_IF (((SYNTAX_ENTRY_CODE (sentry)) != syntaxcode_word) &&
			  ((SYNTAX_ENTRY_CODE (sentry)) != syntaxcode_symbol));
		}
	      MOVE_LEFT (start);
	    }

	case syntaxcode_math:
	  if (! sexp_flag)
	    break;
	  if ((! (LEFT_END_P (start))) && (c == start[-1]))
	    MOVE_LEFT (start);
	  if (math_exit)
	    {
	      WIN_IF ((--depth) == 0);
	      LOSE_IF (depth < min_depth);
	      math_exit = false;
	    }
	  else
	    {
	      WIN_IF ((++depth) == 0);
	      math_exit = true;
	    }
	  break;

	case syntaxcode_close:
	  WIN_IF ((++depth) == 0);
	  break;

	case syntaxcode_open:
	  WIN_IF ((--depth) == 0);
	  LOSE_IF (depth < min_depth);
	  break;

	case syntaxcode_string:
	  while (true)
	    {
	      LOSE_IF_LEFT_END (start);
	      LEFT_QUOTED_P (start, quoted);
	      if ((! quoted) && (c == start[-1]))
		break;
	      MOVE_LEFT (start);
	    }
	  MOVE_LEFT (start);
	  WIN_IF ((depth == 0) && sexp_flag);
	  break;

	default:
	  break;
	}
    }
}

/* Partial S-Expression Parser */

#define LEVEL_ARRAY_LENGTH 100
struct levelstruct { unsigned char * last, * previous; };

#define DONE_IF(expression) do						\
{									\
  if (expression)							\
    goto done;								\
} while (0)

#define DONE_IF_RIGHT_END(scan) DONE_IF (RIGHT_END_P (scan))

#define SEXP_START() do							\
{									\
  if (stop_before) goto stop;						\
  (level -> last) = start;						\
} while (0)

DEFINE_PRIMITIVE ("SCAN-SEXPS-FORWARD", Prim_scan_sexps_forward, 7, 7, 0)
{
  long target_depth;
  Boolean stop_before;
  SCHEME_OBJECT state_argument;
  long depth = 0;
  long in_string = -1;		/* -1 or delimiter character */
  /* Values of in_comment:
     0 = not in comment
     1 = in comment
     2 = found first start of comment
     3 = found first end of comment */
  unsigned int in_comment = 0;
  unsigned int comment_style = COMMENT_STYLE_A;
  unsigned char * comment_start = 0;
  Boolean quoted = false;
  struct levelstruct level_start[LEVEL_ARRAY_LENGTH];
  struct levelstruct *level;
  struct levelstruct *level_end;
  int c = 0;
  long sentry = 0;
  SCHEME_OBJECT result;
  NORMAL_INITIALIZATION_FORWARD (7);

  target_depth = (arg_integer (5));
  stop_before = (BOOLEAN_ARG (6));
  state_argument = (ARG_REF (7));

  level = level_start;
  level_end = (level_start + LEVEL_ARRAY_LENGTH);
  (level -> previous) = NULL;

  /* Initialize the state variables from the state argument. */

  if (state_argument == SHARP_F)
    {
      depth = 0;
      in_string = -1;
      in_comment = 0;
      quoted = false;
    }
  else if ((VECTOR_P (state_argument)) &&
	   (VECTOR_LENGTH (state_argument)) == 8)
    {
      SCHEME_OBJECT temp;

      temp = (VECTOR_REF (state_argument, 0));
      if (FIXNUM_P (temp))
	depth = (FIXNUM_TO_LONG (temp));
      else
	error_bad_range_arg (7);

      temp = (VECTOR_REF (state_argument, 1));
      if (temp == SHARP_F)
	in_string = -1;
      else if ((UNSIGNED_FIXNUM_P (temp)) &&
	       ((UNSIGNED_FIXNUM_TO_LONG (temp)) < MAX_ASCII))
	in_string = (UNSIGNED_FIXNUM_TO_LONG (temp));
      else
	error_bad_range_arg (7);

      temp = (VECTOR_REF (state_argument, 2));
      if (temp == SHARP_F)
	in_comment = 0;
      else if (temp == (LONG_TO_UNSIGNED_FIXNUM (1)))
	{
	  in_comment = 1;
	  comment_style = COMMENT_STYLE_A;
	}
      else if (temp == (LONG_TO_UNSIGNED_FIXNUM (2)))
	{
	  in_comment = 2;
	  comment_style = COMMENT_STYLE_A;
	}
      else if (temp == (LONG_TO_UNSIGNED_FIXNUM (3)))
	{
	  in_comment = 3;
	  comment_style = COMMENT_STYLE_A;
	}
      else if (temp == (LONG_TO_UNSIGNED_FIXNUM (4)))
	{
	  in_comment = 2;
	  comment_style = (COMMENT_STYLE_A | COMMENT_STYLE_B);
	}
      else if (temp == (LONG_TO_UNSIGNED_FIXNUM (5)))
	{
	  in_comment = 1;
	  comment_style = COMMENT_STYLE_B;
	}
      else if (temp == (LONG_TO_UNSIGNED_FIXNUM (6)))
	{
	  in_comment = 2;
	  comment_style = COMMENT_STYLE_B;
	}
      else if (temp == (LONG_TO_UNSIGNED_FIXNUM (7)))
	{
	  in_comment = 3;
	  comment_style = COMMENT_STYLE_B;
	}
      else
	error_bad_range_arg (7);

      quoted = ((VECTOR_REF (state_argument, 3)) != SHARP_F);
      
      if (in_comment != 0)
	{
	  temp = (VECTOR_REF (state_argument, 7));
	  if (MARK_P (temp))
	    comment_start = (INDEX_TO_SCAN (MARK_INDEX (temp)));
	  else if (UNSIGNED_FIXNUM_P (temp))
	    comment_start = (INDEX_TO_SCAN (UNSIGNED_FIXNUM_TO_LONG (temp)));
	  else
	    error_bad_range_arg (7);
	}
      if ((in_comment != 0) && ((in_string != -1) || (quoted != false)))
	error_bad_range_arg (7);
    }
  else
    error_bad_range_arg (7);

  /* Make sure there is enough room for the result before we start. */

  Primitive_GC_If_Needed (8);

  /* Enter main loop at place appropiate for initial state. */

  switch (in_comment)
    {
    case 1: goto in_comment_1;
    case 2: goto in_comment_2;
    case 3: goto in_comment_3;
    }
  if (quoted)
    {
      quoted = false;
      if (in_string != -1)
	goto start_quoted_in_string;
      else
	goto start_quoted;
    }
  if (in_string != -1)
    goto start_in_string;

  while (true)
    {
      DONE_IF_RIGHT_END (start);
      c = (*start);
      comment_start = start;
      READ_RIGHT (start, sentry);
      comment_style = (SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMSTART_FIRST));
      if (((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_comment)
	goto in_comment_1;
      if (comment_style == 0)
	goto not_in_comment;

    in_comment_2:
      in_comment = 2;
      DONE_IF_RIGHT_END (start);
      comment_style
	&= (SYNTAX_ENTRY_COMMENT_STYLE ((PEEK_RIGHT (start)),
					COMSTART_SECOND));
      if (comment_style == 0)
	goto not_in_comment;
      MOVE_RIGHT (start);

    in_comment_1:
      while (true)
	{
	  in_comment = 1;
	  DONE_IF_RIGHT_END (start);
	  READ_RIGHT (start, sentry);
	  if ((SYNTAX_ENTRY_COMMENT_BITS (sentry))
	      & COMEND_FIRST
	      & comment_style)
	    {
	      if (((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_endcomment)
		break;
	    in_comment_3:
	      in_comment = 3;
	      DONE_IF_RIGHT_END (start);
	      if ((SYNTAX_ENTRY_COMMENT_BITS (PEEK_RIGHT (start)))
		  & COMEND_SECOND
		  & comment_style)
		{
		  MOVE_RIGHT (start);
		  break;
		}
	    }
	}

    not_in_comment:
      in_comment = 0;
      if (SYNTAX_ENTRY_PREFIX (sentry))
	continue;

      switch (SYNTAX_ENTRY_CODE (sentry))
	{
	case syntaxcode_escape:
	case syntaxcode_charquote:
	  SEXP_START ();
	start_quoted:
	  if (RIGHT_END_P (start))
	    {
	      quoted = true;
	      DONE_IF (true);
	    }
	  MOVE_RIGHT (start);
	  goto start_atom;

	case syntaxcode_word:
	case syntaxcode_symbol:
	  SEXP_START ();
	start_atom:
	  while (! (RIGHT_END_P (start)))
	    {
	      switch (SYNTAX_ENTRY_CODE (PEEK_RIGHT (start)))
		{
		case syntaxcode_escape:
		case syntaxcode_charquote:
		  MOVE_RIGHT (start);
		  if (RIGHT_END_P (start))
		    {
		      quoted = true;
		      DONE_IF (true);
		    }

		case syntaxcode_word:
		case syntaxcode_symbol:
		  MOVE_RIGHT (start);
		  break;

		default:
		  goto end_atom;
		}
	    }
	end_atom:
	  (level -> previous) = (level -> last);
	  break;

	case syntaxcode_open:
	  SEXP_START ();
	  depth += 1;
	  level += 1;
	  if (level == level_end)
	    error_bad_range_arg (5); /* random error */
	  (level -> last) = NULL;
	  (level -> previous) = NULL;
	  DONE_IF ((--target_depth) == 0);
	  break;

	case syntaxcode_close:
	  depth -= 1;
	  if (level != level_start)
	    level -= 1;
	  (level -> previous) = (level -> last);
	  DONE_IF ((++target_depth) == 0);
	  break;

	case syntaxcode_string:
	  SEXP_START ();
	  in_string = (c);
	start_in_string:
	  while (true)
	    {
	      DONE_IF_RIGHT_END (start);
	      if (in_string == (*start))
		break;
	      READ_RIGHT (start, sentry);
	      if (SYNTAX_ENTRY_QUOTE (sentry))
		{
		start_quoted_in_string:
		  if (RIGHT_END_P (start))
		    {
		      quoted = true;
		      DONE_IF (true);
		    }
		  MOVE_RIGHT (start);
		}
	    }
	  in_string = -1;
	  (level -> previous) = (level -> last);
	  MOVE_RIGHT (start);
	  break;

	default:
	  break;
	}
    }
  /* NOTREACHED */

 stop:
  /* Back up to point at character that starts sexp. */
  if (start == gap_end)
    start = gap_start;
  start -= 1;

 done:
  result = (allocate_marked_vector (TC_VECTOR, 8, true));
  FAST_VECTOR_SET (result, 0, (LONG_TO_FIXNUM (depth)));
  FAST_VECTOR_SET
    (result, 1,
     ((in_string == -1)
      ? SHARP_F
      : (LONG_TO_UNSIGNED_FIXNUM (in_string))));
  FAST_VECTOR_SET
    (result, 2,
     ((in_comment == 0)
      ? SHARP_F
      : (LONG_TO_UNSIGNED_FIXNUM
	 (((in_comment == 2)
	   && (comment_style == (COMMENT_STYLE_A | COMMENT_STYLE_B)))
	  ? 4
	  : (comment_style == COMMENT_STYLE_A)
	  ? in_comment
	  : (in_comment + 4)))));
  FAST_VECTOR_SET (result, 3, (BOOLEAN_TO_OBJECT (quoted)));
  FAST_VECTOR_SET
    (result, 4,
     (((level -> previous) == NULL)
      ? SHARP_F
      : (LONG_TO_UNSIGNED_FIXNUM ((SCAN_TO_INDEX (level -> previous)) - 1))));
  FAST_VECTOR_SET
    (result, 5,
     (((level == level_start) || (((level - 1) -> last) == NULL))
      ? SHARP_F
      : (LONG_TO_UNSIGNED_FIXNUM
	 ((SCAN_TO_INDEX ((level - 1) -> last)) - 1))));
  FAST_VECTOR_SET
    (result, 6, (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start))));
  FAST_VECTOR_SET
    (result, 7,
     ((in_comment == 0)
      ? SHARP_F
      : (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (comment_start)))));
  PRIMITIVE_RETURN (result);
}