/* -*-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);
}
syntax highlighted by Code2HTML, v. 0.9.1