Implemented ADD DOCUMENT. Thanks to Ben Pfaff for review.
[pspp-builds.git] / src / language / lexer / lexer.c
1 /* PSPP - computes sample statistics.
2    Copyright (C) 1997-9, 2000, 2006 Free Software Foundation, Inc.
3
4    This program is free software; you can redistribute it and/or
5    modify it under the terms of the GNU General Public License as
6    published by the Free Software Foundation; either version 2 of the
7    License, or (at your option) any later version.
8
9    This program is distributed in the hope that it will be useful, but
10    WITHOUT ANY WARRANTY; without even the implied warranty of
11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12    General Public License for more details.
13
14    You should have received a copy of the GNU General Public License
15    along with this program; if not, write to the Free Software
16    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17    02110-1301, USA. */
18
19 #include <config.h>
20 #include "lexer.h"
21 #include <libpspp/message.h>
22 #include <ctype.h>
23 #include <errno.h>
24 #include <limits.h>
25 #include <math.h>
26 #include <stdarg.h>
27 #include <stdlib.h>
28 #include <libpspp/alloc.h>
29 #include <libpspp/assertion.h>
30 #include <language/command.h>
31 #include <libpspp/message.h>
32 #include <libpspp/magic.h>
33 #include <data/settings.h>
34 #include <libpspp/getl.h>
35 #include <libpspp/str.h>
36
37 #include "size_max.h"
38
39 #include "gettext.h"
40 #define _(msgid) gettext (msgid)
41 #define N_(msgid) msgid
42
43
44 #define DUMP_TOKENS 0
45
46
47 struct lexer 
48 {
49   struct string line_buffer;
50
51   struct source_stream *ss;
52
53   int token;      /* Current token. */
54   double tokval;  /* T_POS_NUM, T_NEG_NUM: the token's value. */
55
56   char tokid [LONG_NAME_LEN + 1];   /* T_ID: the identifier. */
57
58   struct string tokstr;   /* T_ID, T_STRING: token string value.
59                             For T_ID, this is not truncated as is 
60                             tokid. */
61
62   char *prog; /* Pointer to next token in line_buffer. */
63   bool dot;   /* True only if this line ends with a terminal dot. */
64
65   int put_token ; /* If nonzero, next token returned by lex_get().
66                     Used only in exceptional circumstances. */
67   
68   struct string put_tokstr;
69   double put_tokval;
70 };
71
72
73 static int parse_id (struct lexer *);
74
75 /* How a string represents its contents. */
76 enum string_type 
77   {
78     CHARACTER_STRING,   /* Characters. */
79     BINARY_STRING,      /* Binary digits. */
80     OCTAL_STRING,       /* Octal digits. */
81     HEX_STRING          /* Hexadecimal digits. */
82   };
83
84 static int parse_string (struct lexer *, enum string_type);
85
86 #if DUMP_TOKENS
87 static void dump_token (struct lexer *);
88 #endif
89 \f
90 /* Initialization. */
91
92 /* Initializes the lexer. */
93 struct lexer *
94 lex_create (struct source_stream *ss)
95 {
96   struct lexer *lexer = xzalloc (sizeof (*lexer));
97
98   ds_init_empty (&lexer->tokstr);
99   ds_init_empty (&lexer->put_tokstr);
100   ds_init_empty (&lexer->line_buffer);
101   lexer->ss = ss;
102
103   return lexer;
104 }
105
106 struct source_stream *
107 lex_get_source_stream (const struct lexer *lex)
108 {
109   return lex->ss;
110 }
111
112
113 void
114 lex_destroy (struct lexer *lexer)
115 {
116   if ( NULL != lexer ) 
117     {
118       ds_destroy (&lexer->put_tokstr);
119       ds_destroy (&lexer->tokstr);
120       ds_destroy (&lexer->line_buffer);
121
122       free (lexer);
123     }
124 }
125
126 \f
127 /* Common functions. */
128
129 /* Copies put_token, lexer->put_tokstr, put_tokval into token, tokstr,
130    tokval, respectively, and sets tokid appropriately. */
131 static void
132 restore_token (struct lexer *lexer) 
133 {
134   assert (lexer->put_token != 0);
135   lexer->token = lexer->put_token;
136   ds_assign_string (&lexer->tokstr, &lexer->put_tokstr);
137   str_copy_trunc (lexer->tokid, sizeof lexer->tokid, ds_cstr (&lexer->tokstr));
138   lexer->tokval = lexer->put_tokval;
139   lexer->put_token = 0;
140 }
141
142 /* Copies token, tokstr, lexer->tokval into lexer->put_token, put_tokstr,
143    put_lexer->tokval respectively. */
144 static void
145 save_token (struct lexer *lexer) 
146 {
147   lexer->put_token = lexer->token;
148   ds_assign_string (&lexer->put_tokstr, &lexer->tokstr);
149   lexer->put_tokval = lexer->tokval;
150 }
151
152 /* Parses a single token, setting appropriate global variables to
153    indicate the token's attributes. */
154 void
155 lex_get (struct lexer *lexer)
156 {
157   /* Find a token. */
158   for (;;)
159     {
160       if (NULL == lexer->prog && ! lex_get_line (lexer) )
161         {
162           lexer->token = T_STOP;
163           return;
164         }
165
166   /* If a token was pushed ahead, return it. */
167   if (lexer->put_token)
168     {
169       restore_token (lexer);
170 #if DUMP_TOKENS
171           dump_token (lexer);
172 #endif
173       return;
174     }
175
176   for (;;)
177     {
178       /* Skip whitespace. */
179           while (isspace ((unsigned char) *lexer->prog))
180             lexer->prog++;
181
182           if (*lexer->prog)
183             break;
184
185           if (lexer->dot)
186             {
187               lexer->dot = 0;
188               lexer->token = '.';
189 #if DUMP_TOKENS
190               dump_token (lexer);
191 #endif
192               return;
193             }
194           else if (!lex_get_line (lexer))
195             {
196               lexer->prog = NULL;
197               lexer->token = T_STOP;
198 #if DUMP_TOKENS
199               dump_token (lexer);
200 #endif
201               return;
202             }
203
204           if (lexer->put_token)
205             {
206               restore_token (lexer);
207 #if DUMP_TOKENS
208               dump_token (lexer);
209 #endif
210               return;
211             }
212         }
213
214
215       /* Actually parse the token. */
216       ds_clear (&lexer->tokstr);
217       
218       switch (*lexer->prog)
219         {
220         case '-': case '.':
221         case '0': case '1': case '2': case '3': case '4':
222         case '5': case '6': case '7': case '8': case '9':
223           {
224             char *tail;
225
226             /* `-' can introduce a negative number, or it can be a
227                token by itself.  If it is not followed by a digit or a
228                decimal point, it is definitely not a number.
229                Otherwise, it might be either, but most of the time we
230                want it as a number.  When the syntax calls for a `-'
231                token, lex_negative_to_dash() must be used to break
232                negative numbers into two tokens. */
233             if (*lexer->prog == '-')
234               {
235                 ds_put_char (&lexer->tokstr, *lexer->prog++);
236                 while (isspace ((unsigned char) *lexer->prog))
237                   lexer->prog++;
238
239                 if (!isdigit ((unsigned char) *lexer->prog) && *lexer->prog != '.')
240                   {
241                     lexer->token = '-';
242                     break;
243                   }
244                 lexer->token = T_NEG_NUM;
245               }
246             else 
247               lexer->token = T_POS_NUM;
248                 
249             /* Parse the number, copying it into tokstr. */
250             while (isdigit ((unsigned char) *lexer->prog))
251               ds_put_char (&lexer->tokstr, *lexer->prog++);
252             if (*lexer->prog == '.')
253               {
254                 ds_put_char (&lexer->tokstr, *lexer->prog++);
255                 while (isdigit ((unsigned char) *lexer->prog))
256                   ds_put_char (&lexer->tokstr, *lexer->prog++);
257               }
258             if (*lexer->prog == 'e' || *lexer->prog == 'E')
259               {
260                 ds_put_char (&lexer->tokstr, *lexer->prog++);
261                 if (*lexer->prog == '+' || *lexer->prog == '-')
262                   ds_put_char (&lexer->tokstr, *lexer->prog++);
263                 while (isdigit ((unsigned char) *lexer->prog))
264                   ds_put_char (&lexer->tokstr, *lexer->prog++);
265               }
266
267             /* Parse as floating point. */
268             lexer->tokval = strtod (ds_cstr (&lexer->tokstr), &tail);
269             if (*tail)
270               {
271                 msg (SE, _("%s does not form a valid number."),
272                      ds_cstr (&lexer->tokstr));
273                 lexer->tokval = 0.0;
274
275                 ds_clear (&lexer->tokstr);
276                 ds_put_char (&lexer->tokstr, '0');
277               }
278
279             break;
280           }
281
282         case '\'': case '"':
283           lexer->token = parse_string (lexer, CHARACTER_STRING);
284           break;
285
286         case '(': case ')': case ',': case '=': case '+': case '/':
287           lexer->token = *lexer->prog++;
288           break;
289
290         case '*':
291           if (*++lexer->prog == '*')
292             {
293               lexer->prog++;
294               lexer->token = T_EXP;
295             }
296           else
297             lexer->token = '*';
298           break;
299
300         case '<':
301           if (*++lexer->prog == '=')
302             {
303               lexer->prog++;
304               lexer->token = T_LE;
305             }
306           else if (*lexer->prog == '>')
307             {
308               lexer->prog++;
309               lexer->token = T_NE;
310             }
311           else
312             lexer->token = T_LT;
313           break;
314
315         case '>':
316           if (*++lexer->prog == '=')
317             {
318               lexer->prog++;
319               lexer->token = T_GE;
320             }
321           else
322             lexer->token = T_GT;
323           break;
324
325         case '~':
326           if (*++lexer->prog == '=')
327             {
328               lexer->prog++;
329               lexer->token = T_NE;
330             }
331           else
332             lexer->token = T_NOT;
333           break;
334
335         case '&':
336           lexer->prog++;
337           lexer->token = T_AND;
338           break;
339
340         case '|':
341           lexer->prog++;
342           lexer->token = T_OR;
343           break;
344
345         case 'b': case 'B':
346           if (lexer->prog[1] == '\'' || lexer->prog[1] == '"')
347             lexer->token = parse_string (lexer, BINARY_STRING);
348           else
349             lexer->token = parse_id (lexer);
350           break;
351           
352         case 'o': case 'O':
353           if (lexer->prog[1] == '\'' || lexer->prog[1] == '"')
354             lexer->token = parse_string (lexer, OCTAL_STRING);
355           else
356             lexer->token = parse_id (lexer);
357           break;
358           
359         case 'x': case 'X':
360           if (lexer->prog[1] == '\'' || lexer->prog[1] == '"')
361             lexer->token = parse_string (lexer, HEX_STRING);
362           else
363             lexer->token = parse_id (lexer);
364           break;
365           
366         default:
367           if (lex_is_id1 (*lexer->prog)) 
368             {
369               lexer->token = parse_id (lexer);
370               break; 
371             }
372           else
373             {
374               if (isgraph ((unsigned char) *lexer->prog))
375                 msg (SE, _("Bad character in input: `%c'."), *lexer->prog++);
376               else
377                 msg (SE, _("Bad character in input: `\\%o'."), *lexer->prog++);
378               continue; 
379             }
380         }
381       break;
382     }
383
384 #if DUMP_TOKENS
385   dump_token (lexer);
386 #endif
387 }
388
389 /* Parses an identifier at the current position into tokid and
390    tokstr.
391    Returns the correct token type. */
392 static int
393 parse_id (struct lexer *lexer) 
394 {
395   struct substring rest_of_line
396     = ss_substr (ds_ss (&lexer->line_buffer),
397                  ds_pointer_to_position (&lexer->line_buffer, lexer->prog),
398                  SIZE_MAX);
399   struct substring id = ss_head (rest_of_line,
400                                  lex_id_get_length (rest_of_line));
401   lexer->prog += ss_length (id);
402
403   ds_assign_substring (&lexer->tokstr, id);
404   str_copy_trunc (lexer->tokid, sizeof lexer->tokid, ds_cstr (&lexer->tokstr));
405   return lex_id_to_token (id);
406 }
407
408 /* Reports an error to the effect that subcommand SBC may only be
409    specified once. */
410 void
411 lex_sbc_only_once (const char *sbc) 
412 {
413   msg (SE, _("Subcommand %s may only be specified once."), sbc);
414 }
415
416 /* Reports an error to the effect that subcommand SBC is
417    missing. */
418 void
419 lex_sbc_missing (struct lexer *lexer, const char *sbc) 
420 {
421   lex_error (lexer, _("missing required subcommand %s"), sbc);
422 }
423
424 /* Prints a syntax error message containing the current token and
425    given message MESSAGE (if non-null). */
426 void
427 lex_error (struct lexer *lexer, const char *message, ...)
428 {
429   char *token_rep;
430   char where[128];
431
432   token_rep = lex_token_representation (lexer);
433   if (lexer->token == T_STOP)
434     strcpy (where, "end of file");
435   else if (lexer->token == '.')
436     strcpy (where, "end of command");
437   else
438     snprintf (where, sizeof where, "`%s'", token_rep);
439   free (token_rep);
440
441   if (message)
442     {
443       char buf[1024];
444       va_list args;
445       
446       va_start (args, message);
447       vsnprintf (buf, 1024, message, args);
448       va_end (args);
449
450       msg (SE, _("Syntax error %s at %s."), buf, where);
451     }
452   else
453     msg (SE, _("Syntax error at %s."), where);
454 }
455
456 /* Checks that we're at end of command.
457    If so, returns a successful command completion code.
458    If not, flags a syntax error and returns an error command
459    completion code. */
460 int
461 lex_end_of_command (struct lexer *lexer)
462 {
463   if (lexer->token != '.')
464     {
465       lex_error (lexer, _("expecting end of command"));
466       return CMD_FAILURE;
467     }
468   else
469     return CMD_SUCCESS;
470 }
471 \f
472 /* Token testing functions. */
473
474 /* Returns true if the current token is a number. */
475 bool
476 lex_is_number (struct lexer *lexer) 
477 {
478   return lexer->token == T_POS_NUM || lexer->token == T_NEG_NUM;
479 }
480
481
482 /* Returns true if the current token is a string. */
483 bool
484 lex_is_string (struct lexer *lexer)
485 {
486   return lexer->token == T_STRING;
487 }
488
489
490 /* Returns the value of the current token, which must be a
491    floating point number. */
492 double
493 lex_number (struct lexer *lexer)
494 {
495   assert (lex_is_number (lexer));
496   return lexer->tokval;
497 }
498
499 /* Returns true iff the current token is an integer. */
500 bool
501 lex_is_integer (struct lexer *lexer)
502 {
503   return (lex_is_number (lexer)
504           && lexer->tokval != NOT_LONG
505           && lexer->tokval >= LONG_MIN
506           && lexer->tokval <= LONG_MAX
507           && floor (lexer->tokval) == lexer->tokval);
508 }
509
510 /* Returns the value of the current token, which must be an
511    integer. */
512 long
513 lex_integer (struct lexer *lexer)
514 {
515   assert (lex_is_integer (lexer));
516   return lexer->tokval;
517 }
518 \f  
519 /* Token matching functions. */
520
521 /* If TOK is the current token, skips it and returns true
522    Otherwise, returns false. */
523 bool
524 lex_match (struct lexer *lexer, int t)
525 {
526   if (lexer->token == t)
527     {
528       lex_get (lexer);
529       return true;
530     }
531   else
532     return false;
533 }
534
535 /* If the current token is the identifier S, skips it and returns
536    true.  The identifier may be abbreviated to its first three
537    letters.
538    Otherwise, returns false. */
539 bool
540 lex_match_id (struct lexer *lexer, const char *s)
541 {
542   if (lexer->token == T_ID
543       && lex_id_match (ss_cstr (s), ss_cstr (lexer->tokid)))
544     {
545       lex_get (lexer);
546       return true;
547     }
548   else
549     return false;
550 }
551
552 /* If the current token is integer N, skips it and returns true.
553    Otherwise, returns false. */
554 bool
555 lex_match_int (struct lexer *lexer, int x)
556 {
557   if (lex_is_integer (lexer) && lex_integer (lexer) == x)
558     {
559       lex_get (lexer);
560       return true;
561     }
562   else
563     return false;
564 }
565 \f
566 /* Forced matches. */
567
568 /* If this token is identifier S, fetches the next token and returns
569    nonzero.
570    Otherwise, reports an error and returns zero. */
571 bool
572 lex_force_match_id (struct lexer *lexer, const char *s)
573 {
574   if (lex_match_id (lexer, s))
575     return true;
576   else
577     {
578       lex_error (lexer, _("expecting `%s'"), s);
579       return false;
580     }
581 }
582
583 /* If the current token is T, skips the token.  Otherwise, reports an
584    error and returns from the current function with return value false. */
585 bool
586 lex_force_match (struct lexer *lexer, int t)
587 {
588   if (lexer->token == t)
589     {
590       lex_get (lexer);
591       return true;
592     }
593   else
594     {
595       lex_error (lexer, _("expecting `%s'"), lex_token_name (t));
596       return false;
597     }
598 }
599
600 /* If this token is a string, does nothing and returns true.
601    Otherwise, reports an error and returns false. */
602 bool
603 lex_force_string (struct lexer *lexer)
604 {
605   if (lexer->token == T_STRING)
606     return true;
607   else
608     {
609       lex_error (lexer, _("expecting string"));
610       return false;
611     }
612 }
613
614 /* If this token is an integer, does nothing and returns true.
615    Otherwise, reports an error and returns false. */
616 bool
617 lex_force_int (struct lexer *lexer)
618 {
619   if (lex_is_integer (lexer))
620     return true;
621   else
622     {
623       lex_error (lexer, _("expecting integer"));
624       return false;
625     }
626 }
627         
628 /* If this token is a number, does nothing and returns true.
629    Otherwise, reports an error and returns false. */
630 bool
631 lex_force_num (struct lexer *lexer)
632 {
633   if (lex_is_number (lexer))
634     return true;
635
636   lex_error (lexer, _("expecting number"));
637   return false;
638 }
639         
640 /* If this token is an identifier, does nothing and returns true.
641    Otherwise, reports an error and returns false. */
642 bool
643 lex_force_id (struct lexer *lexer)
644 {
645   if (lexer->token == T_ID)
646     return true;
647
648   lex_error (lexer, _("expecting identifier"));
649   return false;
650 }
651
652 /* Weird token functions. */
653
654 /* Returns the first character of the next token, except that if the
655    next token is not an identifier, the character returned will not be
656    a character that can begin an identifier.  Specifically, the
657    hexstring lead-in X' causes lookahead() to return '.  Note that an
658    alphanumeric return value doesn't guarantee an ID token, it could
659    also be a reserved-word token. */
660 int
661 lex_look_ahead (struct lexer *lexer)
662 {
663   if (lexer->put_token)
664     return lexer->put_token;
665
666   for (;;)
667     {
668       if (NULL == lexer->prog && ! lex_get_line (lexer) )
669         return 0;
670
671       for (;;)
672         {
673           while (isspace ((unsigned char) *lexer->prog))
674             lexer->prog++;
675           if (*lexer->prog)
676             break;
677
678           if (lexer->dot)
679             return '.';
680           else if (!lex_get_line (lexer))
681             return 0;
682
683           if (lexer->put_token) 
684             return lexer->put_token;
685         }
686
687       if ((toupper ((unsigned char) *lexer->prog) == 'X'
688            || toupper ((unsigned char) *lexer->prog) == 'B'
689            || toupper ((unsigned char) *lexer->prog) == 'O')
690           && (lexer->prog[1] == '\'' || lexer->prog[1] == '"'))
691         return '\'';
692
693       return *lexer->prog;
694     }
695 }
696
697 /* Makes the current token become the next token to be read; the
698    current token is set to T. */
699 void
700 lex_put_back (struct lexer *lexer, int t)
701 {
702   save_token (lexer);
703   lexer->token = t;
704 }
705
706 /* Makes the current token become the next token to be read; the
707    current token is set to the identifier ID. */
708 void
709 lex_put_back_id (struct lexer *lexer, const char *id)
710 {
711   assert (lex_id_to_token (ss_cstr (id)) == T_ID);
712   save_token (lexer);
713   lexer->token = T_ID;
714   ds_assign_cstr (&lexer->tokstr, id);
715   str_copy_trunc (lexer->tokid, sizeof lexer->tokid, ds_cstr (&lexer->tokstr));
716 }
717 \f
718 /* Weird line processing functions. */
719
720 /* Returns the entire contents of the current line. */
721 const char *
722 lex_entire_line (struct lexer *lexer)
723 {
724   return ds_cstr (&lexer->line_buffer);
725 }
726
727 const struct string *
728 lex_entire_line_ds (struct lexer *lexer)
729 {
730   return &lexer->line_buffer;
731 }
732
733 /* As lex_entire_line(), but only returns the part of the current line
734    that hasn't already been tokenized.
735    If END_DOT is non-null, stores nonzero into *END_DOT if the line
736    ends with a terminal dot, or zero if it doesn't. */
737 const char *
738 lex_rest_of_line (struct lexer *lexer, int *end_dot)
739 {
740   if (end_dot)
741     *end_dot = lexer->dot;
742   return lexer->prog;
743 }
744
745 /* Causes the rest of the current input line to be ignored for
746    tokenization purposes. */
747 void
748 lex_discard_line (struct lexer *lexer)
749 {
750   ds_cstr (&lexer->line_buffer);  /* Ensures ds_end points to something valid */
751   lexer->prog = ds_end (&lexer->line_buffer);
752   lexer->dot = false;
753   lexer->put_token = 0;
754 }
755
756
757 /* Discards the rest of the current command.
758    When we're reading commands from a file, we skip tokens until
759    a terminal dot or EOF.
760    When we're reading commands interactively from the user,
761    that's just discarding the current line, because presumably
762    the user doesn't want to finish typing a command that will be
763    ignored anyway. */
764 void
765 lex_discard_rest_of_command (struct lexer *lexer) 
766 {
767   if (!getl_is_interactive (lexer->ss))
768     {
769       while (lexer->token != T_STOP && lexer->token != '.')
770         lex_get (lexer);
771     }
772   else 
773     lex_discard_line (lexer); 
774 }
775 \f
776 /* Weird line reading functions. */
777
778 /* Remove C-style comments in STRING, begun by slash-star and
779    terminated by star-slash or newline. */
780 static void
781 strip_comments (struct string *string)
782 {
783   char *cp;
784   int quote;
785   bool in_comment;
786
787   in_comment = false;
788   quote = EOF;
789   for (cp = ds_cstr (string); *cp; )
790     {
791       /* If we're not in a comment, check for quote marks. */
792       if (!in_comment)
793         {
794           if (*cp == quote)
795             quote = EOF;
796           else if (*cp == '\'' || *cp == '"')
797             quote = *cp;
798         }
799       
800       /* If we're not inside a quotation, check for comment. */
801       if (quote == EOF)
802         {
803           if (cp[0] == '/' && cp[1] == '*')
804             {
805               in_comment = true;
806               *cp++ = ' ';
807               *cp++ = ' ';
808               continue;
809             }
810           else if (in_comment && cp[0] == '*' && cp[1] == '/')
811             {
812               in_comment = false;
813               *cp++ = ' ';
814               *cp++ = ' ';
815               continue;
816             }
817         }
818       
819       /* Check commenting. */
820       if (in_comment)
821         *cp = ' ';
822       cp++;
823     }
824 }
825
826 /* Prepares LINE, which is subject to the given SYNTAX rules, for
827    tokenization by stripping comments and determining whether it
828    is the beginning or end of a command and storing into
829    *LINE_STARTS_COMMAND and *LINE_ENDS_COMMAND appropriately. */
830 void
831 lex_preprocess_line (struct string *line,
832                      enum getl_syntax syntax,
833                      bool *line_starts_command,
834                      bool *line_ends_command)
835 {
836   strip_comments (line);
837   ds_rtrim (line, ss_cstr (CC_SPACES));
838   *line_ends_command = (ds_chomp (line, get_endcmd ())
839                         || (ds_is_empty (line) && get_nulline ()));
840   *line_starts_command = false;
841   if (syntax == GETL_BATCH)
842     {
843       int first = ds_first (line);
844       *line_starts_command = !isspace (first);
845       if (first == '+' || first == '-') 
846         *ds_data (line) = ' ';
847     }
848 }
849
850 /* Reads a line, without performing any preprocessing.
851    Sets *SYNTAX, if SYNTAX is non-null, to the line's syntax
852    mode. */
853 bool 
854 lex_get_line_raw (struct lexer *lexer, enum getl_syntax *syntax)
855 {
856   enum getl_syntax dummy;
857   bool ok = getl_read_line (lexer->ss, &lexer->line_buffer,
858                               syntax != NULL ? syntax : &dummy);
859   return ok;
860 }
861
862 /* Reads a line for use by the tokenizer, and preprocesses it by
863    removing comments, stripping trailing whitespace and the
864    terminal dot, and removing leading indentors. */
865 bool
866 lex_get_line (struct lexer *lexer)
867 {
868   bool line_starts_command;
869   enum getl_syntax syntax;
870
871   if (!lex_get_line_raw (lexer, &syntax))
872     {
873       lexer->prog = NULL;
874     return false;
875     }
876
877   lex_preprocess_line (&lexer->line_buffer, syntax,
878                        &line_starts_command, &lexer->dot);
879
880   if (line_starts_command)
881     lexer->put_token = '.';
882
883   lexer->prog = ds_cstr (&lexer->line_buffer);
884   return true;
885 }
886 \f
887 /* Token names. */
888
889 /* Returns the name of a token. */
890 const char *
891 lex_token_name (int token)
892 {
893   if (lex_is_keyword (token))
894     return lex_id_name (token);
895   else if (token < 256)
896     {
897       static char t[256][2];
898       char *s = t[token];
899       s[0] = token;
900       s[1] = '\0';
901       return s;
902     }
903   else
904     NOT_REACHED ();
905 }
906
907 /* Returns an ASCII representation of the current token as a
908    malloc()'d string. */
909 char *
910 lex_token_representation (struct lexer *lexer)
911 {
912   char *token_rep;
913   
914   switch (lexer->token)
915     {
916     case T_ID:
917     case T_POS_NUM:
918     case T_NEG_NUM:
919       return ds_xstrdup (&lexer->tokstr);
920       break;
921
922     case T_STRING:
923       {
924         int hexstring = 0;
925         char *sp, *dp;
926
927         for (sp = ds_cstr (&lexer->tokstr); sp < ds_end (&lexer->tokstr); sp++)
928           if (!isprint ((unsigned char) *sp))
929             {
930               hexstring = 1;
931               break;
932             }
933               
934         token_rep = xmalloc (2 + ds_length (&lexer->tokstr) * 2 + 1 + 1);
935
936         dp = token_rep;
937         if (hexstring)
938           *dp++ = 'X';
939         *dp++ = '\'';
940
941         if (!hexstring)
942           for (sp = ds_cstr (&lexer->tokstr); *sp; )
943             {
944               if (*sp == '\'')
945                 *dp++ = '\'';
946               *dp++ = (unsigned char) *sp++;
947             }
948         else
949           for (sp = ds_cstr (&lexer->tokstr); sp < ds_end (&lexer->tokstr); sp++)
950             {
951               *dp++ = (((unsigned char) *sp) >> 4)["0123456789ABCDEF"];
952               *dp++ = (((unsigned char) *sp) & 15)["0123456789ABCDEF"];
953             }
954         *dp++ = '\'';
955         *dp = '\0';
956         
957         return token_rep;
958       }
959     break;
960
961     case T_STOP:
962       token_rep = xmalloc (1);
963       *token_rep = '\0';
964       return token_rep;
965
966     case T_EXP:
967       return xstrdup ("**");
968
969     default:
970       return xstrdup (lex_token_name (lexer->token));
971     }
972         
973   NOT_REACHED ();
974 }
975 \f
976 /* Really weird functions. */
977
978 /* Most of the time, a `-' is a lead-in to a negative number.  But
979    sometimes it's actually part of the syntax.  If a dash can be part
980    of syntax then this function is called to rip it off of a
981    number. */
982 void
983 lex_negative_to_dash (struct lexer *lexer)
984 {
985   if (lexer->token == T_NEG_NUM)
986     {
987       lexer->token = T_POS_NUM;
988       lexer->tokval = -lexer->tokval;
989       ds_assign_substring (&lexer->tokstr, ds_substr (&lexer->tokstr, 1, SIZE_MAX));
990       save_token (lexer);
991       lexer->token = '-';
992     }
993 }
994    
995 /* Skip a COMMENT command. */
996 void
997 lex_skip_comment (struct lexer *lexer)
998 {
999   for (;;)
1000     {
1001       if (!lex_get_line (lexer)) 
1002         {
1003           lexer->put_token = T_STOP;
1004           lexer->prog = NULL;
1005           return;
1006         }
1007       
1008       if (lexer->put_token == '.')
1009         break;
1010
1011       ds_cstr (&lexer->line_buffer); /* Ensures ds_end will point to a valid char */
1012       lexer->prog = ds_end (&lexer->line_buffer);
1013       if (lexer->dot)
1014         break;
1015     }
1016 }
1017 \f
1018 /* Private functions. */
1019
1020 /* When invoked, tokstr contains a string of binary, octal, or
1021    hex digits, according to TYPE.  The string is converted to
1022    characters having the specified values. */
1023 static void
1024 convert_numeric_string_to_char_string (struct lexer *lexer, 
1025                                        enum string_type type)
1026 {
1027   const char *base_name;
1028   int base;
1029   int chars_per_byte;
1030   size_t byte_cnt;
1031   size_t i;
1032   char *p;
1033
1034   switch (type) 
1035     {
1036     case BINARY_STRING:
1037       base_name = _("binary");
1038       base = 2;
1039       chars_per_byte = 8;
1040       break;
1041     case OCTAL_STRING:
1042       base_name = _("octal");
1043       base = 8;
1044       chars_per_byte = 3;
1045       break;
1046     case HEX_STRING:
1047       base_name = _("hex");
1048       base = 16;
1049       chars_per_byte = 2;
1050       break;
1051     default:
1052       NOT_REACHED ();
1053     }
1054   
1055   byte_cnt = ds_length (&lexer->tokstr) / chars_per_byte;
1056   if (ds_length (&lexer->tokstr) % chars_per_byte)
1057     msg (SE, _("String of %s digits has %d characters, which is not a "
1058                "multiple of %d."),
1059          base_name, (int) ds_length (&lexer->tokstr), chars_per_byte);
1060
1061   p = ds_cstr (&lexer->tokstr);
1062   for (i = 0; i < byte_cnt; i++)
1063     {
1064       int value;
1065       int j;
1066           
1067       value = 0;
1068       for (j = 0; j < chars_per_byte; j++, p++)
1069         {
1070           int v;
1071
1072           if (*p >= '0' && *p <= '9')
1073             v = *p - '0';
1074           else
1075             {
1076               static const char alpha[] = "abcdef";
1077               const char *q = strchr (alpha, tolower ((unsigned char) *p));
1078
1079               if (q)
1080                 v = q - alpha + 10;
1081               else
1082                 v = base;
1083             }
1084
1085           if (v >= base)
1086             msg (SE, _("`%c' is not a valid %s digit."), *p, base_name);
1087
1088           value = value * base + v;
1089         }
1090
1091       ds_cstr (&lexer->tokstr)[i] = (unsigned char) value;
1092     }
1093
1094   ds_truncate (&lexer->tokstr, byte_cnt);
1095 }
1096
1097 /* Parses a string from the input buffer into tokstr.  The input
1098    buffer pointer lexer->prog must point to the initial single or double
1099    quote.  TYPE indicates the type of string to be parsed.
1100    Returns token type. */
1101 static int 
1102 parse_string (struct lexer *lexer, enum string_type type)
1103 {
1104   if (type != CHARACTER_STRING)
1105     lexer->prog++;
1106
1107   /* Accumulate the entire string, joining sections indicated by +
1108      signs. */
1109   for (;;)
1110     {
1111       /* Single or double quote. */
1112       int c = *lexer->prog++;
1113       
1114       /* Accumulate section. */
1115       for (;;)
1116         {
1117           /* Check end of line. */
1118           if (*lexer->prog == '\0')
1119             {
1120               msg (SE, _("Unterminated string constant."));
1121               goto finish;
1122             }
1123           
1124           /* Double quote characters to embed them in strings. */
1125           if (*lexer->prog == c)
1126             {
1127               if (lexer->prog[1] == c)
1128                 lexer->prog++;
1129               else
1130                 break;
1131             }
1132
1133           ds_put_char (&lexer->tokstr, *lexer->prog++);
1134         }
1135       lexer->prog++;
1136
1137       /* Skip whitespace after final quote mark. */
1138       if (lexer->prog == NULL)
1139         break;
1140       for (;;)
1141         {
1142           while (isspace ((unsigned char) *lexer->prog))
1143             lexer->prog++;
1144           if (*lexer->prog)
1145             break;
1146
1147           if (lexer->dot)
1148             goto finish;
1149
1150           if (!lex_get_line (lexer))
1151             goto finish;
1152         }
1153
1154       /* Skip plus sign. */
1155       if (*lexer->prog != '+')
1156         break;
1157       lexer->prog++;
1158
1159       /* Skip whitespace after plus sign. */
1160       if (lexer->prog == NULL)
1161         break;
1162       for (;;)
1163         {
1164           while (isspace ((unsigned char) *lexer->prog))
1165             lexer->prog++;
1166           if (*lexer->prog)
1167             break;
1168
1169           if (lexer->dot)
1170             goto finish;
1171
1172           if (!lex_get_line (lexer))
1173             {
1174               msg (SE, _("Unexpected end of file in string concatenation."));
1175               goto finish;
1176             }
1177         }
1178
1179       /* Ensure that a valid string follows. */
1180       if (*lexer->prog != '\'' && *lexer->prog != '"')
1181         {
1182           msg (SE, _("String expected following `+'."));
1183           goto finish;
1184         }
1185     }
1186
1187   /* We come here when we've finished concatenating all the string sections
1188      into one large string. */
1189 finish:
1190   if (type != CHARACTER_STRING)
1191     convert_numeric_string_to_char_string (lexer, type);
1192
1193   if (ds_length (&lexer->tokstr) > 255)
1194     {
1195       msg (SE, _("String exceeds 255 characters in length (%d characters)."),
1196            (int) ds_length (&lexer->tokstr));
1197       ds_truncate (&lexer->tokstr, 255);
1198     }
1199       
1200   return T_STRING;
1201 }
1202 \f       
1203 #if DUMP_TOKENS
1204 /* Reads one token from the lexer and writes a textual representation
1205    on stdout for debugging purposes. */
1206 static void
1207 dump_token (struct lexer *lexer)
1208 {
1209   {
1210     const char *curfn;
1211     int curln;
1212
1213     curln = getl_source_location (lexer->ss);
1214     curfn = getl_source_name (lexer->ss);
1215     if (curfn)
1216       fprintf (stderr, "%s:%d\t", curfn, curln);
1217   }
1218   
1219   switch (lexer->token)
1220     {
1221     case T_ID:
1222       fprintf (stderr, "ID\t%s\n", lexer->tokid);
1223       break;
1224
1225     case T_POS_NUM:
1226     case T_NEG_NUM:
1227       fprintf (stderr, "NUM\t%f\n", lexer->tokval);
1228       break;
1229
1230     case T_STRING:
1231       fprintf (stderr, "STRING\t\"%s\"\n", ds_cstr (&lexer->tokstr));
1232       break;
1233
1234     case T_STOP:
1235       fprintf (stderr, "STOP\n");
1236       break;
1237
1238     case T_EXP:
1239       fprintf (stderr, "MISC\tEXP\"");
1240       break;
1241
1242     case 0:
1243       fprintf (stderr, "MISC\tEOF\n");
1244       break;
1245
1246     default:
1247       if (lex_is_keyword (lexer->token))
1248         fprintf (stderr, "KEYWORD\t%s\n", lex_token_name (lexer->token));
1249       else
1250         fprintf (stderr, "PUNCT\t%c\n", lexer->token);
1251       break;
1252     }
1253 }
1254 #endif /* DUMP_TOKENS */
1255
1256
1257 /* Token Accessor Functions */
1258
1259 int 
1260 lex_token (const struct lexer *lexer)
1261 {
1262   return lexer->token;
1263 }
1264
1265 double 
1266 lex_tokval (const struct lexer *lexer)
1267 {
1268   return lexer->tokval;
1269 }
1270
1271 const char *
1272 lex_tokid (const struct lexer *lexer)
1273 {
1274   return lexer->tokid;
1275 }
1276
1277 const struct string *
1278 lex_tokstr (const struct lexer *lexer)
1279 {
1280   return &lexer->tokstr;
1281 }