home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / syntax.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  27KB  |  1,029 lines
  1. /* -*-C-*-
  2.  
  3. $Id: syntax.c,v 1.25 2000/12/05 21:23:48 cph Exp $
  4.  
  5. Copyright (c) 1987-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Primitives to support Edwin syntax tables, word and list parsing. */
  23.  
  24. /* NOTE: This program was created by translation from the syntax table
  25. code of GNU Emacs; it was translated from the original C to 68000
  26. assembly language (in 1986), and then translated back from 68000
  27. assembly language to C (in 1987).  Users should be aware that the GNU
  28. GENERAL PUBLIC LICENSE may apply to this code.  A copy of that license
  29. should have been included along with this file. */
  30.  
  31. #include "scheme.h"
  32. #include "prims.h"
  33. #include "edwin.h"
  34. #include "syntax.h"
  35.  
  36. /* Syntax Codes */
  37.  
  38. /* Convert a letter which signifies a syntax code
  39.    into the code it signifies. */
  40.  
  41. #define ILLEGAL ((char) syntaxcode_max)
  42.  
  43. char syntax_spec_code[0200] =
  44.   {
  45.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  46.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  47.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  48.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  49.  
  50.     ((char) syntaxcode_whitespace), ILLEGAL, ((char) syntaxcode_string),
  51.         ILLEGAL, ((char) syntaxcode_math), ILLEGAL, ILLEGAL,
  52.         ((char) syntaxcode_quote),
  53.     ((char) syntaxcode_open), ((char) syntaxcode_close), ILLEGAL, ILLEGAL,
  54.         ILLEGAL, ((char) syntaxcode_whitespace), ((char) syntaxcode_punct),
  55.         ((char) syntaxcode_charquote),
  56.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  57.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ((char) syntaxcode_comment),
  58.         ILLEGAL, ((char) syntaxcode_endcomment), ILLEGAL,
  59.  
  60.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  61.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  62.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  63.         ((char) syntaxcode_word),
  64.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ((char) syntaxcode_escape), ILLEGAL,
  65.         ILLEGAL, ((char) syntaxcode_symbol),
  66.  
  67.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  68.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  69.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  70.         ((char) syntaxcode_word),
  71.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL
  72.   };
  73.  
  74. /* Indexed by syntax code, give the letter that describes it. */
  75.  
  76. unsigned char syntax_code_spec[13] =
  77.   {
  78.     ' ', '.', 'w', '_', '(', ')', '\'', '\"', '$', '\\', '/', '<', '>'
  79.   };
  80.  
  81. #define MERGE_PREFIX_BIT(bit)                        \
  82. {                                    \
  83.   if ((result & bit) != 0)                        \
  84.     error_bad_range_arg (1);                        \
  85.   result |= bit;                            \
  86. }
  87.  
  88. #define MERGE_COMMENT(bit) MERGE_PREFIX_BIT ((bit) << 12)
  89.  
  90. DEFINE_PRIMITIVE ("STRING->SYNTAX-ENTRY", Prim_string_to_syntax_entry, 1, 1, 0)
  91. {
  92.   long length, c, result;
  93.   unsigned char * scan;
  94.   PRIMITIVE_HEADER (1);
  95.  
  96.   CHECK_ARG (1, STRING_P);
  97.   length = (STRING_LENGTH (ARG_REF (1)));
  98.   scan = (STRING_LOC ((ARG_REF (1)), 0));
  99.  
  100.   if ((length--) > 0)
  101.     {
  102.       c = (*scan++);
  103.       if (c >= 0200) error_bad_range_arg (1);
  104.       result = (syntax_spec_code [c]);
  105.       if (result == ILLEGAL) error_bad_range_arg (1);
  106.     }
  107.   else
  108.     result = ((long) syntaxcode_whitespace);
  109.  
  110.   if ((length--) > 0)
  111.     {
  112.       c = (*scan++);
  113.       if (c != ' ') result |= (c << 4);
  114.     }
  115.  
  116.   while ((length--) > 0)
  117.     switch (*scan++)
  118.       {
  119.       case '1': MERGE_COMMENT (COMSTART_FIRST_B); break;
  120.       case '2': MERGE_COMMENT (COMSTART_SECOND_B); break;
  121.       case '3': MERGE_COMMENT (COMEND_FIRST_B); break;
  122.       case '4': MERGE_COMMENT (COMEND_SECOND_B); break;
  123.       case '5': MERGE_COMMENT (COMSTART_FIRST_A); break;
  124.       case '6': MERGE_COMMENT (COMSTART_SECOND_A); break;
  125.       case '7': MERGE_COMMENT (COMEND_FIRST_A); break;
  126.       case '8': MERGE_COMMENT (COMEND_SECOND_A); break;
  127.       case 'b':
  128.     switch (SYNTAX_ENTRY_CODE (result))
  129.       {
  130.       case syntaxcode_comment: MERGE_COMMENT (COMSTART_FIRST_B); break;
  131.       case syntaxcode_endcomment: MERGE_COMMENT (COMEND_FIRST_B); break;
  132.       default: break;
  133.       }
  134.     break;
  135.       case 'p': MERGE_PREFIX_BIT (1 << 20); break;
  136.       case ' ': break;
  137.       default: error_bad_range_arg (1);
  138.       }
  139.   if (((SYNTAX_ENTRY_CODE (result)) == syntaxcode_comment)
  140.       && (! ((SYNTAX_ENTRY_COMMENT_BITS (result)) & COMSTART_FIRST)))
  141.     MERGE_COMMENT (COMSTART_FIRST_A);
  142.   if (((SYNTAX_ENTRY_CODE (result)) == syntaxcode_endcomment)
  143.       && (! ((SYNTAX_ENTRY_COMMENT_BITS (result)) & COMEND_FIRST)))
  144.     MERGE_COMMENT (COMEND_FIRST_A);
  145.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
  146. }
  147.  
  148. DEFINE_PRIMITIVE ("CHAR->SYNTAX-CODE", Prim_char_to_syntax_code, 2, 2, 0)
  149. {
  150.   PRIMITIVE_HEADER (2);
  151.   CHECK_ARG (1, SYNTAX_TABLE_P);
  152.   PRIMITIVE_RETURN
  153.     (ASCII_TO_CHAR
  154.      (syntax_code_spec
  155.       [((int)
  156.     (SYNTAX_ENTRY_CODE
  157.      (SYNTAX_TABLE_REF ((ARG_REF (1)), (arg_ascii_char (2))))))]));
  158. }
  159.  
  160. /* Parser Initialization */
  161.  
  162. #define NORMAL_INITIALIZATION_COMMON(arity)                \
  163.   fast SCHEME_OBJECT syntax_table;                    \
  164.   fast SCHEME_OBJECT group;                        \
  165.   fast unsigned char * start;                        \
  166.   unsigned char * first_char, * end;                    \
  167.   long gap_length;                            \
  168.   PRIMITIVE_HEADER (arity);                        \
  169.   CHECK_ARG (1, SYNTAX_TABLE_P);                    \
  170.   syntax_table = (ARG_REF (1));                        \
  171.   CHECK_ARG (2, GROUP_P);                        \
  172.   group = (ARG_REF (2));                        \
  173.   first_char = (STRING_LOC ((GROUP_TEXT (group)), 0));            \
  174.   start = (first_char + (arg_nonnegative_integer (3)));            \
  175.   end = (first_char + (arg_nonnegative_integer (4)));            \
  176.   gap_start = (first_char + (GROUP_GAP_START (group)));            \
  177.   gap_length = (GROUP_GAP_LENGTH (group));                \
  178.   gap_end = (first_char + (GROUP_GAP_END (group)))
  179.  
  180. #define NORMAL_INITIALIZATION_FORWARD(arity)                \
  181.   unsigned char * gap_start;                        \
  182.   fast unsigned char * gap_end;                        \
  183.   NORMAL_INITIALIZATION_COMMON (arity);                    \
  184.   if (start >= gap_start)                        \
  185.     start += gap_length;                        \
  186.   if (end >= gap_start)                            \
  187.     end += gap_length
  188.  
  189. #define NORMAL_INITIALIZATION_BACKWARD(arity)                \
  190.   fast unsigned char * gap_start;                    \
  191.   unsigned char * gap_end;                        \
  192.   NORMAL_INITIALIZATION_COMMON (arity);                    \
  193.   if (start > gap_start)                        \
  194.     start += gap_length;                        \
  195.   if (end > gap_start)                            \
  196.     end += gap_length
  197.  
  198. #define SCAN_LIST_INITIALIZATION(initialization)            \
  199.   long depth, min_depth;                        \
  200.   Boolean sexp_flag, ignore_comments, math_exit;            \
  201.   int c;                                \
  202.   initialization (7);                            \
  203.   depth = (arg_integer (5));                        \
  204.   min_depth = ((depth >= 0) ? 0 : depth);                \
  205.   sexp_flag = (BOOLEAN_ARG (6));                    \
  206.   ignore_comments = (BOOLEAN_ARG (7));                    \
  207.   math_exit = false
  208.  
  209. /* Parse Scanning */
  210.  
  211. #define PEEK_RIGHT(scan) (SYNTAX_TABLE_REF (syntax_table, (*scan)))
  212. #define PEEK_LEFT(scan) (SYNTAX_TABLE_REF (syntax_table, (scan[-1])))
  213.  
  214. #define MOVE_RIGHT(scan) do                        \
  215. {                                    \
  216.   if ((++scan) == gap_start)                        \
  217.     scan = gap_end;                            \
  218. } while (0)
  219.  
  220. #define MOVE_LEFT(scan) do                        \
  221. {                                    \
  222.   if ((--scan) == gap_end)                        \
  223.     scan = gap_start;                            \
  224. } while (0)
  225.  
  226. #define READ_RIGHT(scan, target) do                    \
  227. {                                    \
  228.   target = (SYNTAX_TABLE_REF (syntax_table, (*scan++)));        \
  229.   if (scan == gap_start)                        \
  230.     scan = gap_end;                            \
  231. } while (0)
  232.  
  233. #define READ_LEFT(scan, target) do                    \
  234. {                                    \
  235.   target = (SYNTAX_TABLE_REF (syntax_table, (*--scan)));        \
  236.   if (scan == gap_end)                            \
  237.     scan = gap_start;                            \
  238. } while (0)
  239.  
  240. #define RIGHT_END_P(scan) (scan >= end)
  241. #define LEFT_END_P(scan) (scan <= end)
  242.  
  243. #define LOSE_IF(expression) do                        \
  244. {                                    \
  245.   if (expression)                            \
  246.     PRIMITIVE_RETURN (SHARP_F);                        \
  247. } while (0)
  248.  
  249. #define LOSE_IF_RIGHT_END(scan) LOSE_IF (RIGHT_END_P (scan))
  250. #define LOSE_IF_LEFT_END(scan) LOSE_IF (LEFT_END_P (scan))
  251.  
  252. #define SCAN_TO_INDEX(scan)                        \
  253.   ((((scan) > gap_start) ? ((scan) - gap_length) : (scan)) - first_char)
  254.  
  255. #define INDEX_TO_SCAN(index)                        \
  256.   ((((index) + first_char) > gap_start)                    \
  257.    ? (((index) + first_char) + gap_length)                \
  258.    : ((index) + first_char))
  259.  
  260. #define WIN_IF(expression) do                        \
  261. {                                    \
  262.   if (expression)                            \
  263.     PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start)));    \
  264. } while (0)
  265.  
  266. #define WIN_IF_RIGHT_END(scan) WIN_IF (RIGHT_END_P (scan))
  267. #define WIN_IF_LEFT_END(scan) WIN_IF (LEFT_END_P (scan))
  268.  
  269. #define RIGHT_QUOTED_P_INTERNAL(scan, quoted) do            \
  270. {                                    \
  271.   quoted = false;                            \
  272.   while (true)                                \
  273.     {                                    \
  274.       long sentry;                            \
  275.       if (LEFT_END_P (scan))                        \
  276.     break;                                \
  277.       READ_LEFT (scan, sentry);                        \
  278.       if (! (SYNTAX_ENTRY_QUOTE (sentry)))                \
  279.     break;                                \
  280.       quoted = (! quoted);                        \
  281.     }                                    \
  282. } while (0)
  283.  
  284. #define RIGHT_QUOTED_P(scan_init, quoted) do                \
  285. {                                    \
  286.   unsigned char * scan = (scan_init);                    \
  287.   RIGHT_QUOTED_P_INTERNAL (scan, quoted);                \
  288. } while (0)
  289.  
  290. #define LEFT_QUOTED_P(scan_init, quoted) do                \
  291. {                                    \
  292.   unsigned char * scan = (scan_init);                    \
  293.   MOVE_LEFT (scan);                            \
  294.   RIGHT_QUOTED_P_INTERNAL (scan, quoted);                \
  295. } while (0)
  296.  
  297. /* Quote Parsers */
  298.  
  299. DEFINE_PRIMITIVE ("QUOTED-CHAR?", Prim_quoted_char_p, 4, 4, 0)
  300. {
  301.   Boolean quoted;
  302.   NORMAL_INITIALIZATION_BACKWARD (4);
  303.  
  304.   RIGHT_QUOTED_P (start, quoted);
  305.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (quoted));
  306. }
  307.  
  308. /* This is used in conjunction with `scan-list-backward' to find the
  309.    beginning of an s-expression. */
  310.  
  311. DEFINE_PRIMITIVE ("SCAN-BACKWARD-PREFIX-CHARS", Prim_scan_backward_prefix_chars, 4, 4, 0)
  312. {
  313.   Boolean quoted;
  314.   NORMAL_INITIALIZATION_BACKWARD (4);
  315.  
  316.   while (true)
  317.     {
  318.       WIN_IF_LEFT_END (start);
  319.       LEFT_QUOTED_P (start, quoted);
  320.       WIN_IF (quoted);
  321.       {
  322.     long sentry = (PEEK_LEFT (start));
  323.     WIN_IF (! (((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_quote)
  324.            || (SYNTAX_ENTRY_PREFIX (sentry))));
  325.       }
  326.       MOVE_LEFT (start);
  327.     }
  328. }
  329.  
  330. DEFINE_PRIMITIVE ("SCAN-FORWARD-PREFIX-CHARS", Prim_scan_forward_prefix_chars, 4, 4, 0)
  331. {
  332.   Boolean quoted;
  333.   NORMAL_INITIALIZATION_FORWARD (4);
  334.  
  335.   while (true)
  336.     {
  337.       WIN_IF_RIGHT_END (start);
  338.       RIGHT_QUOTED_P (start, quoted);
  339.       WIN_IF (quoted);
  340.       {
  341.     long sentry = (PEEK_RIGHT (start));
  342.     WIN_IF (! (((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_quote)
  343.            || (SYNTAX_ENTRY_PREFIX (sentry))));
  344.       }
  345.       MOVE_RIGHT (start);
  346.     }
  347. }
  348.  
  349. /* Word Parsers */
  350.  
  351. DEFINE_PRIMITIVE ("SCAN-FORWARD-TO-WORD", Prim_scan_forward_to_word, 4, 4, 0)
  352. {
  353.   NORMAL_INITIALIZATION_FORWARD (4);
  354.  
  355.   while (true)
  356.     {
  357.       LOSE_IF_RIGHT_END (start);
  358.       WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) == syntaxcode_word);
  359.       MOVE_RIGHT (start);
  360.     }
  361. }
  362.  
  363. DEFINE_PRIMITIVE ("SCAN-WORD-FORWARD", Prim_scan_word_forward, 4, 4, 0)
  364. {
  365.   NORMAL_INITIALIZATION_FORWARD (4);
  366.  
  367.   while (true)
  368.     {
  369.       long sentry;
  370.       LOSE_IF_RIGHT_END (start);
  371.       READ_RIGHT (start, sentry);
  372.       if ((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_word)
  373.     break;
  374.     }
  375.   while (true)
  376.     {
  377.       WIN_IF_RIGHT_END (start);
  378.       WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) != syntaxcode_word);
  379.       MOVE_RIGHT (start);
  380.     }
  381. }
  382.  
  383. DEFINE_PRIMITIVE ("SCAN-WORD-BACKWARD", Prim_scan_word_backward, 4, 4, 0)
  384. {
  385.   NORMAL_INITIALIZATION_BACKWARD (4);
  386.  
  387.   while (true)
  388.     {
  389.       long sentry;
  390.       LOSE_IF_LEFT_END (start);
  391.       READ_LEFT (start, sentry);
  392.       if ((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_word)
  393.     break;
  394.     }
  395.   while (true)
  396.     {
  397.       WIN_IF_LEFT_END (start);
  398.       WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) != syntaxcode_word);
  399.       MOVE_LEFT (start);
  400.     }
  401. }
  402.  
  403. /* S-Expression Parsers */
  404.  
  405. DEFINE_PRIMITIVE ("SCAN-LIST-FORWARD", Prim_scan_list_forward, 7, 7, 0)
  406. {
  407.   SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_FORWARD);
  408.  
  409.   while (true)
  410.     {
  411.       long sentry;
  412.       LOSE_IF_RIGHT_END (start);
  413.       c = (*start);
  414.       READ_RIGHT (start, sentry);
  415.  
  416.       {
  417.     unsigned int style = 0;
  418.     if (((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_comment)
  419.       style = (SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMSTART_FIRST));
  420.     else if (! (RIGHT_END_P (start)))
  421.       {
  422.         style
  423.           = ((SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMSTART_FIRST))
  424.          & (SYNTAX_ENTRY_COMMENT_STYLE ((PEEK_RIGHT (start)),
  425.                         COMSTART_SECOND)));
  426.         if (style != 0)
  427.           MOVE_RIGHT (start);
  428.       }
  429.     if (style != 0)
  430.       {
  431.         LOSE_IF_RIGHT_END (start);
  432.         while (true)
  433.           {
  434.         READ_RIGHT (start, sentry);
  435.         if ((SYNTAX_ENTRY_COMMENT_BITS (sentry))
  436.             & COMEND_FIRST
  437.             & style)
  438.           {
  439.             if (((SYNTAX_ENTRY_CODE (sentry)))
  440.             == syntaxcode_endcomment)
  441.               break;
  442.             LOSE_IF_RIGHT_END (start);
  443.             if ((SYNTAX_ENTRY_COMMENT_BITS (PEEK_RIGHT (start)))
  444.             & COMEND_SECOND
  445.             & style)
  446.               {
  447.             MOVE_RIGHT (start);
  448.             break;
  449.               }
  450.           }
  451.           }
  452.         continue;
  453.       }
  454.       }
  455.       if (SYNTAX_ENTRY_PREFIX (sentry))
  456.     continue;
  457.  
  458.       switch (SYNTAX_ENTRY_CODE (sentry))
  459.     {
  460.     case syntaxcode_escape:
  461.     case syntaxcode_charquote:
  462.       LOSE_IF_RIGHT_END (start);
  463.       MOVE_RIGHT (start);
  464.  
  465.     case syntaxcode_word:
  466.     case syntaxcode_symbol:
  467.       if ((depth != 0) || (! sexp_flag))
  468.         break;
  469.       while (true)
  470.         {
  471.           WIN_IF_RIGHT_END (start);
  472.           switch (SYNTAX_ENTRY_CODE (PEEK_RIGHT (start)))
  473.         {
  474.         case syntaxcode_escape:
  475.         case syntaxcode_charquote:
  476.           MOVE_RIGHT (start);
  477.           LOSE_IF_RIGHT_END (start);
  478.  
  479.         case syntaxcode_word:
  480.         case syntaxcode_symbol:
  481.           MOVE_RIGHT (start);
  482.           break;
  483.  
  484.         default:
  485.           WIN_IF (true);
  486.         }
  487.         }
  488.  
  489.     case syntaxcode_math:
  490.       if (! sexp_flag)
  491.         break;
  492.       if ((! (RIGHT_END_P (start))) && (c == *start))
  493.         MOVE_RIGHT (start);
  494.       if (math_exit)
  495.         {
  496.           WIN_IF ((--depth) == 0);
  497.           LOSE_IF (depth < min_depth);
  498.           math_exit = false;
  499.         }
  500.       else
  501.         {
  502.           WIN_IF ((++depth) == 0);
  503.           math_exit = true;
  504.         }
  505.       break;
  506.  
  507.     case syntaxcode_open:
  508.       WIN_IF ((++depth) == 0);
  509.       break;
  510.  
  511.     case syntaxcode_close:
  512.       WIN_IF ((--depth) == 0);
  513.       LOSE_IF (depth < min_depth);
  514.       break;
  515.  
  516.     case syntaxcode_string:
  517.       while (true)
  518.         {
  519.           LOSE_IF_RIGHT_END (start);
  520.           if (c == *start)
  521.         break;
  522.           READ_RIGHT (start, sentry);
  523.           if (SYNTAX_ENTRY_QUOTE (sentry))
  524.         {
  525.           LOSE_IF_RIGHT_END (start);
  526.           MOVE_RIGHT (start);
  527.         }
  528.         }
  529.       MOVE_RIGHT (start);
  530.       WIN_IF ((depth == 0) && sexp_flag);
  531.       break;
  532.  
  533.     default:
  534.       break;
  535.     }
  536.     }
  537. }
  538.  
  539. DEFINE_PRIMITIVE ("SCAN-LIST-BACKWARD", Prim_scan_list_backward, 7, 7, 0)
  540. {
  541.   Boolean quoted;
  542.   SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_BACKWARD);
  543.  
  544.   while (true)
  545.     {
  546.       long sentry;
  547.       LOSE_IF_LEFT_END (start);
  548.       LEFT_QUOTED_P (start, quoted);
  549.       if (quoted)
  550.     {
  551.       MOVE_LEFT (start);
  552.       /* existence of this character is guaranteed by LEFT_QUOTED_P. */
  553.       READ_LEFT (start, sentry);
  554.       goto word_entry;
  555.     }
  556.       c = (start[-1]);
  557.       READ_LEFT (start, sentry);
  558.  
  559.       {
  560.     unsigned int style = 0;
  561.     if (((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_endcomment)
  562.       {
  563.         if (ignore_comments)
  564.           style = (SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMEND_SECOND));
  565.       }
  566.     else if (! (LEFT_END_P (start)))
  567.       {
  568.         LEFT_QUOTED_P (start, quoted);
  569.         if (!quoted)
  570.           {
  571.         style
  572.           = ((SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMEND_SECOND))
  573.              & (SYNTAX_ENTRY_COMMENT_STYLE ((PEEK_LEFT (start)),
  574.                             COMEND_FIRST)));
  575.         if (style != 0)
  576.           MOVE_LEFT (start);
  577.           }
  578.       }
  579.     if (style != 0)
  580.       {
  581.         LOSE_IF_LEFT_END (start);
  582.         while (true)
  583.           {
  584.         READ_LEFT (start, sentry);
  585.         if ((((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_comment)
  586.             && ((SYNTAX_ENTRY_COMMENT_BITS (sentry))
  587.             & COMSTART_FIRST
  588.             & style))
  589.           break;
  590.         LOSE_IF_LEFT_END (start);
  591.         if (((SYNTAX_ENTRY_COMMENT_BITS (sentry))
  592.              & COMSTART_SECOND
  593.              & style)
  594.             && ((SYNTAX_ENTRY_COMMENT_BITS (PEEK_LEFT (start)))
  595.             & COMSTART_FIRST
  596.             & style))
  597.           {
  598.             MOVE_LEFT (start);
  599.             break;
  600.           }
  601.           }
  602.         continue;
  603.       }
  604.       }
  605.  
  606.       switch (SYNTAX_ENTRY_CODE (sentry))
  607.     {
  608.     case syntaxcode_word:
  609.     case syntaxcode_symbol:
  610.     word_entry:
  611.       if ((depth != 0) || (! sexp_flag))
  612.         break;
  613.       while (true)
  614.         {
  615.           WIN_IF_LEFT_END (start);
  616.           LEFT_QUOTED_P (start, quoted);
  617.           if (quoted)
  618.         MOVE_LEFT (start);
  619.           else
  620.         {
  621.           sentry = (PEEK_LEFT (start));
  622.           WIN_IF (((SYNTAX_ENTRY_CODE (sentry)) != syntaxcode_word) &&
  623.               ((SYNTAX_ENTRY_CODE (sentry)) != syntaxcode_symbol));
  624.         }
  625.           MOVE_LEFT (start);
  626.         }
  627.  
  628.     case syntaxcode_math:
  629.       if (! sexp_flag)
  630.         break;
  631.       if ((! (LEFT_END_P (start))) && (c == start[-1]))
  632.         MOVE_LEFT (start);
  633.       if (math_exit)
  634.         {
  635.           WIN_IF ((--depth) == 0);
  636.           LOSE_IF (depth < min_depth);
  637.           math_exit = false;
  638.         }
  639.       else
  640.         {
  641.           WIN_IF ((++depth) == 0);
  642.           math_exit = true;
  643.         }
  644.       break;
  645.  
  646.     case syntaxcode_close:
  647.       WIN_IF ((++depth) == 0);
  648.       break;
  649.  
  650.     case syntaxcode_open:
  651.       WIN_IF ((--depth) == 0);
  652.       LOSE_IF (depth < min_depth);
  653.       break;
  654.  
  655.     case syntaxcode_string:
  656.       while (true)
  657.         {
  658.           LOSE_IF_LEFT_END (start);
  659.           LEFT_QUOTED_P (start, quoted);
  660.           if ((! quoted) && (c == start[-1]))
  661.         break;
  662.           MOVE_LEFT (start);
  663.         }
  664.       MOVE_LEFT (start);
  665.       WIN_IF ((depth == 0) && sexp_flag);
  666.       break;
  667.  
  668.     default:
  669.       break;
  670.     }
  671.     }
  672. }
  673.  
  674. /* Partial S-Expression Parser */
  675.  
  676. #define LEVEL_ARRAY_LENGTH 100
  677. struct levelstruct { unsigned char * last, * previous; };
  678.  
  679. #define DONE_IF(expression) do                        \
  680. {                                    \
  681.   if (expression)                            \
  682.     goto done;                                \
  683. } while (0)
  684.  
  685. #define DONE_IF_RIGHT_END(scan) DONE_IF (RIGHT_END_P (scan))
  686.  
  687. #define SEXP_START() do                            \
  688. {                                    \
  689.   if (stop_before) goto stop;                        \
  690.   (level -> last) = start;                        \
  691. } while (0)
  692.  
  693. DEFINE_PRIMITIVE ("SCAN-SEXPS-FORWARD", Prim_scan_sexps_forward, 7, 7, 0)
  694. {
  695.   long target_depth;
  696.   Boolean stop_before;
  697.   SCHEME_OBJECT state_argument;
  698.   long depth = 0;
  699.   long in_string = -1;        /* -1 or delimiter character */
  700.   /* Values of in_comment:
  701.      0 = not in comment
  702.      1 = in comment
  703.      2 = found first start of comment
  704.      3 = found first end of comment */
  705.   unsigned int in_comment = 0;
  706.   unsigned int comment_style = COMMENT_STYLE_A;
  707.   unsigned char * comment_start = 0;
  708.   Boolean quoted = false;
  709.   struct levelstruct level_start[LEVEL_ARRAY_LENGTH];
  710.   struct levelstruct *level;
  711.   struct levelstruct *level_end;
  712.   int c = 0;
  713.   long sentry = 0;
  714.   SCHEME_OBJECT result;
  715.   NORMAL_INITIALIZATION_FORWARD (7);
  716.  
  717.   target_depth = (arg_integer (5));
  718.   stop_before = (BOOLEAN_ARG (6));
  719.   state_argument = (ARG_REF (7));
  720.  
  721.   level = level_start;
  722.   level_end = (level_start + LEVEL_ARRAY_LENGTH);
  723.   (level -> previous) = NULL;
  724.  
  725.   /* Initialize the state variables from the state argument. */
  726.  
  727.   if (state_argument == SHARP_F)
  728.     {
  729.       depth = 0;
  730.       in_string = -1;
  731.       in_comment = 0;
  732.       quoted = false;
  733.     }
  734.   else if ((VECTOR_P (state_argument)) &&
  735.        (VECTOR_LENGTH (state_argument)) == 8)
  736.     {
  737.       SCHEME_OBJECT temp;
  738.  
  739.       temp = (VECTOR_REF (state_argument, 0));
  740.       if (FIXNUM_P (temp))
  741.     depth = (FIXNUM_TO_LONG (temp));
  742.       else
  743.     error_bad_range_arg (7);
  744.  
  745.       temp = (VECTOR_REF (state_argument, 1));
  746.       if (temp == SHARP_F)
  747.     in_string = -1;
  748.       else if ((UNSIGNED_FIXNUM_P (temp)) &&
  749.            ((UNSIGNED_FIXNUM_TO_LONG (temp)) < MAX_ASCII))
  750.     in_string = (UNSIGNED_FIXNUM_TO_LONG (temp));
  751.       else
  752.     error_bad_range_arg (7);
  753.  
  754.       temp = (VECTOR_REF (state_argument, 2));
  755.       if (temp == SHARP_F)
  756.     in_comment = 0;
  757.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (1)))
  758.     {
  759.       in_comment = 1;
  760.       comment_style = COMMENT_STYLE_A;
  761.     }
  762.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (2)))
  763.     {
  764.       in_comment = 2;
  765.       comment_style = COMMENT_STYLE_A;
  766.     }
  767.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (3)))
  768.     {
  769.       in_comment = 3;
  770.       comment_style = COMMENT_STYLE_A;
  771.     }
  772.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (4)))
  773.     {
  774.       in_comment = 2;
  775.       comment_style = (COMMENT_STYLE_A | COMMENT_STYLE_B);
  776.     }
  777.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (5)))
  778.     {
  779.       in_comment = 1;
  780.       comment_style = COMMENT_STYLE_B;
  781.     }
  782.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (6)))
  783.     {
  784.       in_comment = 2;
  785.       comment_style = COMMENT_STYLE_B;
  786.     }
  787.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (7)))
  788.     {
  789.       in_comment = 3;
  790.       comment_style = COMMENT_STYLE_B;
  791.     }
  792.       else
  793.     error_bad_range_arg (7);
  794.  
  795.       quoted = ((VECTOR_REF (state_argument, 3)) != SHARP_F);
  796.       
  797.       if (in_comment != 0)
  798.     {
  799.       temp = (VECTOR_REF (state_argument, 7));
  800.       if (MARK_P (temp))
  801.         comment_start = (INDEX_TO_SCAN (MARK_INDEX (temp)));
  802.       else if (UNSIGNED_FIXNUM_P (temp))
  803.         comment_start = (INDEX_TO_SCAN (UNSIGNED_FIXNUM_TO_LONG (temp)));
  804.       else
  805.         error_bad_range_arg (7);
  806.     }
  807.       if ((in_comment != 0) && ((in_string != -1) || (quoted != false)))
  808.     error_bad_range_arg (7);
  809.     }
  810.   else
  811.     error_bad_range_arg (7);
  812.  
  813.   /* Make sure there is enough room for the result before we start. */
  814.  
  815.   Primitive_GC_If_Needed (8);
  816.  
  817.   /* Enter main loop at place appropiate for initial state. */
  818.  
  819.   switch (in_comment)
  820.     {
  821.     case 1: goto in_comment_1;
  822.     case 2: goto in_comment_2;
  823.     case 3: goto in_comment_3;
  824.     }
  825.   if (quoted)
  826.     {
  827.       quoted = false;
  828.       if (in_string != -1)
  829.     goto start_quoted_in_string;
  830.       else
  831.     goto start_quoted;
  832.     }
  833.   if (in_string != -1)
  834.     goto start_in_string;
  835.  
  836.   while (true)
  837.     {
  838.       DONE_IF_RIGHT_END (start);
  839.       c = (*start);
  840.       comment_start = start;
  841.       READ_RIGHT (start, sentry);
  842.       comment_style = (SYNTAX_ENTRY_COMMENT_STYLE (sentry, COMSTART_FIRST));
  843.       if (((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_comment)
  844.     goto in_comment_1;
  845.       if (comment_style == 0)
  846.     goto not_in_comment;
  847.  
  848.     in_comment_2:
  849.       in_comment = 2;
  850.       DONE_IF_RIGHT_END (start);
  851.       comment_style
  852.     &= (SYNTAX_ENTRY_COMMENT_STYLE ((PEEK_RIGHT (start)),
  853.                     COMSTART_SECOND));
  854.       if (comment_style == 0)
  855.     goto not_in_comment;
  856.       MOVE_RIGHT (start);
  857.  
  858.     in_comment_1:
  859.       while (true)
  860.     {
  861.       in_comment = 1;
  862.       DONE_IF_RIGHT_END (start);
  863.       READ_RIGHT (start, sentry);
  864.       if ((SYNTAX_ENTRY_COMMENT_BITS (sentry))
  865.           & COMEND_FIRST
  866.           & comment_style)
  867.         {
  868.           if (((SYNTAX_ENTRY_CODE (sentry))) == syntaxcode_endcomment)
  869.         break;
  870.         in_comment_3:
  871.           in_comment = 3;
  872.           DONE_IF_RIGHT_END (start);
  873.           if ((SYNTAX_ENTRY_COMMENT_BITS (PEEK_RIGHT (start)))
  874.           & COMEND_SECOND
  875.           & comment_style)
  876.         {
  877.           MOVE_RIGHT (start);
  878.           break;
  879.         }
  880.         }
  881.     }
  882.  
  883.     not_in_comment:
  884.       in_comment = 0;
  885.       if (SYNTAX_ENTRY_PREFIX (sentry))
  886.     continue;
  887.  
  888.       switch (SYNTAX_ENTRY_CODE (sentry))
  889.     {
  890.     case syntaxcode_escape:
  891.     case syntaxcode_charquote:
  892.       SEXP_START ();
  893.     start_quoted:
  894.       if (RIGHT_END_P (start))
  895.         {
  896.           quoted = true;
  897.           DONE_IF (true);
  898.         }
  899.       MOVE_RIGHT (start);
  900.       goto start_atom;
  901.  
  902.     case syntaxcode_word:
  903.     case syntaxcode_symbol:
  904.       SEXP_START ();
  905.     start_atom:
  906.       while (! (RIGHT_END_P (start)))
  907.         {
  908.           switch (SYNTAX_ENTRY_CODE (PEEK_RIGHT (start)))
  909.         {
  910.         case syntaxcode_escape:
  911.         case syntaxcode_charquote:
  912.           MOVE_RIGHT (start);
  913.           if (RIGHT_END_P (start))
  914.             {
  915.               quoted = true;
  916.               DONE_IF (true);
  917.             }
  918.  
  919.         case syntaxcode_word:
  920.         case syntaxcode_symbol:
  921.           MOVE_RIGHT (start);
  922.           break;
  923.  
  924.         default:
  925.           goto end_atom;
  926.         }
  927.         }
  928.     end_atom:
  929.       (level -> previous) = (level -> last);
  930.       break;
  931.  
  932.     case syntaxcode_open:
  933.       SEXP_START ();
  934.       depth += 1;
  935.       level += 1;
  936.       if (level == level_end)
  937.         error_bad_range_arg (5); /* random error */
  938.       (level -> last) = NULL;
  939.       (level -> previous) = NULL;
  940.       DONE_IF ((--target_depth) == 0);
  941.       break;
  942.  
  943.     case syntaxcode_close:
  944.       depth -= 1;
  945.       if (level != level_start)
  946.         level -= 1;
  947.       (level -> previous) = (level -> last);
  948.       DONE_IF ((++target_depth) == 0);
  949.       break;
  950.  
  951.     case syntaxcode_string:
  952.       SEXP_START ();
  953.       in_string = (c);
  954.     start_in_string:
  955.       while (true)
  956.         {
  957.           DONE_IF_RIGHT_END (start);
  958.           if (in_string == (*start))
  959.         break;
  960.           READ_RIGHT (start, sentry);
  961.           if (SYNTAX_ENTRY_QUOTE (sentry))
  962.         {
  963.         start_quoted_in_string:
  964.           if (RIGHT_END_P (start))
  965.             {
  966.               quoted = true;
  967.               DONE_IF (true);
  968.             }
  969.           MOVE_RIGHT (start);
  970.         }
  971.         }
  972.       in_string = -1;
  973.       (level -> previous) = (level -> last);
  974.       MOVE_RIGHT (start);
  975.       break;
  976.  
  977.     default:
  978.       break;
  979.     }
  980.     }
  981.   /* NOTREACHED */
  982.  
  983.  stop:
  984.   /* Back up to point at character that starts sexp. */
  985.   if (start == gap_end)
  986.     start = gap_start;
  987.   start -= 1;
  988.  
  989.  done:
  990.   result = (allocate_marked_vector (TC_VECTOR, 8, true));
  991.   FAST_VECTOR_SET (result, 0, (LONG_TO_FIXNUM (depth)));
  992.   FAST_VECTOR_SET
  993.     (result, 1,
  994.      ((in_string == -1)
  995.       ? SHARP_F
  996.       : (LONG_TO_UNSIGNED_FIXNUM (in_string))));
  997.   FAST_VECTOR_SET
  998.     (result, 2,
  999.      ((in_comment == 0)
  1000.       ? SHARP_F
  1001.       : (LONG_TO_UNSIGNED_FIXNUM
  1002.      (((in_comment == 2)
  1003.        && (comment_style == (COMMENT_STYLE_A | COMMENT_STYLE_B)))
  1004.       ? 4
  1005.       : (comment_style == COMMENT_STYLE_A)
  1006.       ? in_comment
  1007.       : (in_comment + 4)))));
  1008.   FAST_VECTOR_SET (result, 3, (BOOLEAN_TO_OBJECT (quoted)));
  1009.   FAST_VECTOR_SET
  1010.     (result, 4,
  1011.      (((level -> previous) == NULL)
  1012.       ? SHARP_F
  1013.       : (LONG_TO_UNSIGNED_FIXNUM ((SCAN_TO_INDEX (level -> previous)) - 1))));
  1014.   FAST_VECTOR_SET
  1015.     (result, 5,
  1016.      (((level == level_start) || (((level - 1) -> last) == NULL))
  1017.       ? SHARP_F
  1018.       : (LONG_TO_UNSIGNED_FIXNUM
  1019.      ((SCAN_TO_INDEX ((level - 1) -> last)) - 1))));
  1020.   FAST_VECTOR_SET
  1021.     (result, 6, (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start))));
  1022.   FAST_VECTOR_SET
  1023.     (result, 7,
  1024.      ((in_comment == 0)
  1025.       ? SHARP_F
  1026.       : (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (comment_start)))));
  1027.   PRIMITIVE_RETURN (result);
  1028. }
  1029.