| /* xgettext Lisp backend. |
| Copyright (C) 2001-2003, 2005-2009, 2018-2020 Free Software Foundation, Inc. |
| |
| This file was written by Bruno Haible <haible@clisp.cons.org>, 2001. |
| |
| 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 3 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, see <https://www.gnu.org/licenses/>. */ |
| |
| #ifdef HAVE_CONFIG_H |
| # include "config.h" |
| #endif |
| |
| /* Specification. */ |
| #include "x-lisp.h" |
| |
| #include <errno.h> |
| #include <stdbool.h> |
| #include <stdio.h> |
| #include <stdlib.h> |
| #include <string.h> |
| |
| #include "attribute.h" |
| #include "message.h" |
| #include "xgettext.h" |
| #include "xg-pos.h" |
| #include "xg-mixed-string.h" |
| #include "xg-arglist-context.h" |
| #include "xg-arglist-callshape.h" |
| #include "xg-arglist-parser.h" |
| #include "xg-message.h" |
| #include "error.h" |
| #include "xalloc.h" |
| #include "mem-hash-map.h" |
| #include "gettext.h" |
| |
| #define _(s) gettext(s) |
| |
| |
| /* The Common Lisp syntax is described in the Common Lisp HyperSpec, chapter 2. |
| Since we are interested only in strings and in forms similar to |
| (gettext msgid ...) |
| or (ngettext msgid msgid_plural ...) |
| we make the following simplifications: |
| |
| - Assume the keywords and strings are in an ASCII compatible encoding. |
| This means we can read the input file one byte at a time, instead of |
| one character at a time. No need to worry about multibyte characters: |
| If they occur as part of identifiers, they most probably act as |
| constituent characters, and the byte based approach will do the same. |
| |
| - Assume the read table is the standard Common Lisp read table. |
| Non-standard read tables are mostly used to read data, not programs. |
| |
| - Assume the read table case is :UPCASE, and *READ-BASE* is 10. |
| |
| - Don't interpret #n= and #n#, they usually don't appear in programs. |
| |
| - Don't interpret #+, #-, they are unlikely to appear in a gettext form. |
| |
| The remaining syntax rules are: |
| |
| - The syntax code assigned to each character, and how tokens are built |
| up from characters (single escape, multiple escape etc.). |
| |
| - Comment syntax: ';' and '#| ... |#'. |
| |
| - String syntax: "..." with single escapes. |
| |
| - Read macros and dispatch macro character '#'. Needed to be able to |
| tell which is the n-th argument of a function call. |
| |
| */ |
| |
| |
| /* ========================= Lexer customization. ========================= */ |
| |
| /* 'readtable_case' is the case conversion that is applied to non-escaped |
| parts of symbol tokens. In Common Lisp: (readtable-case *readtable*). */ |
| |
| enum rtcase |
| { |
| case_upcase, |
| case_downcase, |
| case_preserve, |
| case_invert |
| }; |
| |
| static enum rtcase readtable_case = case_upcase; |
| |
| /* 'read_base' is the assumed radix of integers and rational numbers. |
| In Common Lisp: *read-base*. */ |
| static int read_base = 10; |
| |
| /* 'read_preserve_whitespace' specifies whether a whitespace character |
| that terminates a token must be pushed back on the input stream. |
| We set it to true, because the special newline side effect in read_object() |
| requires that read_object() sees every newline not inside a token. */ |
| static bool read_preserve_whitespace = true; |
| |
| |
| /* ====================== Keyword set customization. ====================== */ |
| |
| /* If true extract all strings. */ |
| static bool extract_all = false; |
| |
| static hash_table keywords; |
| static bool default_keywords = true; |
| |
| |
| void |
| x_lisp_extract_all () |
| { |
| extract_all = true; |
| } |
| |
| |
| void |
| x_lisp_keyword (const char *name) |
| { |
| if (name == NULL) |
| default_keywords = false; |
| else |
| { |
| const char *end; |
| struct callshape shape; |
| const char *colon; |
| size_t len; |
| char *symname; |
| size_t i; |
| |
| if (keywords.table == NULL) |
| hash_init (&keywords, 100); |
| |
| split_keywordspec (name, &end, &shape); |
| |
| /* The characters between name and end should form a valid Lisp symbol. |
| Extract the symbol name part. */ |
| colon = strchr (name, ':'); |
| if (colon != NULL && colon < end) |
| { |
| name = colon + 1; |
| if (name < end && *name == ':') |
| name++; |
| colon = strchr (name, ':'); |
| if (colon != NULL && colon < end) |
| return; |
| } |
| |
| /* Uppercase it. */ |
| len = end - name; |
| symname = XNMALLOC (len, char); |
| for (i = 0; i < len; i++) |
| symname[i] = |
| (name[i] >= 'a' && name[i] <= 'z' ? name[i] - 'a' + 'A' : name[i]); |
| |
| insert_keyword_callshape (&keywords, symname, len, &shape); |
| } |
| } |
| |
| /* Finish initializing the keywords hash table. |
| Called after argument processing, before each file is processed. */ |
| static void |
| init_keywords () |
| { |
| if (default_keywords) |
| { |
| /* When adding new keywords here, also update the documentation in |
| xgettext.texi! */ |
| x_lisp_keyword ("gettext"); /* I18N:GETTEXT */ |
| x_lisp_keyword ("ngettext:1,2"); /* I18N:NGETTEXT */ |
| x_lisp_keyword ("gettext-noop"); |
| default_keywords = false; |
| } |
| } |
| |
| void |
| init_flag_table_lisp () |
| { |
| xgettext_record_flag ("gettext:1:pass-lisp-format"); |
| xgettext_record_flag ("ngettext:1:pass-lisp-format"); |
| xgettext_record_flag ("ngettext:2:pass-lisp-format"); |
| xgettext_record_flag ("gettext-noop:1:pass-lisp-format"); |
| xgettext_record_flag ("format:2:lisp-format"); |
| } |
| |
| |
| /* ======================== Reading of characters. ======================== */ |
| |
| /* The input file stream. */ |
| static FILE *fp; |
| |
| |
| /* Fetch the next character from the input file. */ |
| static int |
| do_getc () |
| { |
| int c = getc (fp); |
| |
| if (c == EOF) |
| { |
| if (ferror (fp)) |
| error (EXIT_FAILURE, errno, |
| _("error while reading \"%s\""), real_file_name); |
| } |
| else if (c == '\n') |
| line_number++; |
| |
| return c; |
| } |
| |
| /* Put back the last fetched character, not EOF. */ |
| static void |
| do_ungetc (int c) |
| { |
| if (c == '\n') |
| line_number--; |
| ungetc (c, fp); |
| } |
| |
| |
| /* ========= Reading of tokens. See CLHS 2.2 "Reader Algorithm". ========= */ |
| |
| |
| /* Syntax code. See CLHS 2.1.4 "Character Syntax Types". */ |
| |
| enum syntax_code |
| { |
| syntax_illegal, /* non-printable, except whitespace */ |
| syntax_single_esc, /* '\' (single escape) */ |
| syntax_multi_esc, /* '|' (multiple escape) */ |
| syntax_constituent, /* everything else (constituent) */ |
| syntax_whitespace, /* TAB,LF,FF,CR,' ' (whitespace) */ |
| syntax_eof, /* EOF */ |
| syntax_t_macro, /* '()'"' (terminating macro) */ |
| syntax_nt_macro /* '#' (non-terminating macro) */ |
| }; |
| |
| /* Returns the syntax code of a character. */ |
| static enum syntax_code |
| syntax_code_of (unsigned char c) |
| { |
| switch (c) |
| { |
| case '\\': |
| return syntax_single_esc; |
| case '|': |
| return syntax_multi_esc; |
| case '\t': case '\n': case '\f': case '\r': case ' ': |
| return syntax_whitespace; |
| case '(': case ')': case '\'': case '"': case ',': case ';': case '`': |
| return syntax_t_macro; |
| case '#': |
| return syntax_nt_macro; |
| default: |
| if (c < ' ' && c != '\b') |
| return syntax_illegal; |
| else |
| return syntax_constituent; |
| } |
| } |
| |
| struct char_syntax |
| { |
| int ch; /* character */ |
| enum syntax_code scode; /* syntax code */ |
| }; |
| |
| /* Returns the next character and its syntax code. */ |
| static void |
| read_char_syntax (struct char_syntax *p) |
| { |
| int c = do_getc (); |
| |
| p->ch = c; |
| p->scode = (c == EOF ? syntax_eof : syntax_code_of (c)); |
| } |
| |
| /* Every character in a token has an attribute assigned. The attributes |
| help during interpretation of the token. See |
| CLHS 2.3 "Interpretation of Tokens" for the possible interpretations, |
| and CLHS 2.1.4.2 "Constituent Traits". */ |
| |
| enum attribute |
| { |
| a_illg, /* invalid constituent */ |
| a_pack_m, /* ':' package marker */ |
| a_alpha, /* normal alphabetic */ |
| a_escaped, /* alphabetic but not subject to case conversion */ |
| a_ratio, /* '/' */ |
| a_dot, /* '.' */ |
| a_sign, /* '+-' */ |
| a_extens, /* '_^' extension characters */ |
| a_digit, /* '0123456789' */ |
| a_letterdigit,/* 'A'-'Z','a'-'z' below base, except 'esfdlESFDL' */ |
| a_expodigit, /* 'esfdlESFDL' below base */ |
| a_letter, /* 'A'-'Z','a'-'z', except 'esfdlESFDL' */ |
| a_expo /* 'esfdlESFDL' */ |
| }; |
| |
| #define is_letter_attribute(a) ((a) >= a_letter) |
| #define is_number_attribute(a) ((a) >= a_ratio) |
| |
| /* Returns the attribute of a character, assuming base 10. */ |
| static enum attribute |
| attribute_of (unsigned char c) |
| { |
| switch (c) |
| { |
| case ':': |
| return a_pack_m; |
| case '/': |
| return a_ratio; |
| case '.': |
| return a_dot; |
| case '+': case '-': |
| return a_sign; |
| case '_': case '^': |
| return a_extens; |
| case '0': case '1': case '2': case '3': case '4': |
| case '5': case '6': case '7': case '8': case '9': |
| return a_digit; |
| case 'a': case 'b': case 'c': case 'g': case 'h': case 'i': case 'j': |
| case 'k': case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': |
| case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'z': |
| case 'A': case 'B': case 'C': case 'G': case 'H': case 'I': case 'J': |
| case 'K': case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': |
| case 'T': case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z': |
| return a_letter; |
| case 'e': case 's': case 'd': case 'f': case 'l': |
| case 'E': case 'S': case 'D': case 'F': case 'L': |
| return a_expo; |
| default: |
| /* Treat everything as valid. Never return a_illg. */ |
| return a_alpha; |
| } |
| } |
| |
| struct token_char |
| { |
| unsigned char ch; /* character */ |
| unsigned char attribute; /* attribute */ |
| }; |
| |
| /* A token consists of a sequence of characters with associated attribute. */ |
| struct token |
| { |
| int allocated; /* number of allocated 'token_char's */ |
| int charcount; /* number of used 'token_char's */ |
| struct token_char *chars; /* the token's constituents */ |
| bool with_escape; /* whether single-escape or multiple escape occurs */ |
| }; |
| |
| /* Initialize a 'struct token'. */ |
| static inline void |
| init_token (struct token *tp) |
| { |
| tp->allocated = 10; |
| tp->chars = XNMALLOC (tp->allocated, struct token_char); |
| tp->charcount = 0; |
| } |
| |
| /* Free the memory pointed to by a 'struct token'. */ |
| static inline void |
| free_token (struct token *tp) |
| { |
| free (tp->chars); |
| } |
| |
| /* Ensure there is enough room in the token for one more character. */ |
| static inline void |
| grow_token (struct token *tp) |
| { |
| if (tp->charcount == tp->allocated) |
| { |
| tp->allocated *= 2; |
| tp->chars = (struct token_char *) xrealloc (tp->chars, tp->allocated * sizeof (struct token_char)); |
| } |
| } |
| |
| /* Read the next token. If 'first' is given, it points to the first |
| character, which has already been read. |
| The algorithm follows CLHS 2.2 "Reader Algorithm". */ |
| static void |
| read_token (struct token *tp, const struct char_syntax *first) |
| { |
| bool multiple_escape_flag; |
| struct char_syntax curr; |
| |
| init_token (tp); |
| tp->with_escape = false; |
| |
| multiple_escape_flag = false; |
| if (first) |
| curr = *first; |
| else |
| read_char_syntax (&curr); |
| |
| for (;; read_char_syntax (&curr)) |
| { |
| switch (curr.scode) |
| { |
| case syntax_illegal: |
| /* Invalid input. Be tolerant, no error message. */ |
| do_ungetc (curr.ch); |
| return; |
| |
| case syntax_single_esc: |
| tp->with_escape = true; |
| read_char_syntax (&curr); |
| if (curr.scode == syntax_eof) |
| /* Invalid input. Be tolerant, no error message. */ |
| return; |
| grow_token (tp); |
| tp->chars[tp->charcount].ch = curr.ch; |
| tp->chars[tp->charcount].attribute = a_escaped; |
| tp->charcount++; |
| break; |
| |
| case syntax_multi_esc: |
| multiple_escape_flag = !multiple_escape_flag; |
| tp->with_escape = true; |
| break; |
| |
| case syntax_constituent: |
| case syntax_nt_macro: |
| grow_token (tp); |
| if (multiple_escape_flag) |
| { |
| tp->chars[tp->charcount].ch = curr.ch; |
| tp->chars[tp->charcount].attribute = a_escaped; |
| tp->charcount++; |
| } |
| else |
| { |
| tp->chars[tp->charcount].ch = curr.ch; |
| tp->chars[tp->charcount].attribute = attribute_of (curr.ch); |
| tp->charcount++; |
| } |
| break; |
| |
| case syntax_whitespace: |
| case syntax_t_macro: |
| if (multiple_escape_flag) |
| { |
| grow_token (tp); |
| tp->chars[tp->charcount].ch = curr.ch; |
| tp->chars[tp->charcount].attribute = a_escaped; |
| tp->charcount++; |
| } |
| else |
| { |
| if (curr.scode != syntax_whitespace || read_preserve_whitespace) |
| do_ungetc (curr.ch); |
| return; |
| } |
| break; |
| |
| case syntax_eof: |
| if (multiple_escape_flag) |
| /* Invalid input. Be tolerant, no error message. */ |
| ; |
| return; |
| } |
| } |
| } |
| |
| /* A potential number is a token which |
| 1. consists only of digits, '+','-','/','^','_','.' and number markers. |
| The base for digits is context dependent, but always 10 if a dot '.' |
| occurs. A number marker is a non-digit letter which is not adjacent |
| to a non-digit letter. |
| 2. has at least one digit. |
| 3. starts with a digit, '+','-','.','^' or '_'. |
| 4. does not end with '+' or '-'. |
| See CLHS 2.3.1.1 "Potential Numbers as Tokens". |
| */ |
| |
| static inline bool |
| has_a_dot (const struct token *tp) |
| { |
| int n = tp->charcount; |
| int i; |
| |
| for (i = 0; i < n; i++) |
| if (tp->chars[i].attribute == a_dot) |
| return true; |
| return false; |
| } |
| |
| static inline bool |
| all_a_number (const struct token *tp) |
| { |
| int n = tp->charcount; |
| int i; |
| |
| for (i = 0; i < n; i++) |
| if (!is_number_attribute (tp->chars[i].attribute)) |
| return false; |
| return true; |
| } |
| |
| static inline void |
| a_letter_to_digit (const struct token *tp, int base) |
| { |
| int n = tp->charcount; |
| int i; |
| |
| for (i = 0; i < n; i++) |
| if (is_letter_attribute (tp->chars[i].attribute)) |
| { |
| int c = tp->chars[i].ch; |
| |
| if (c >= 'a') |
| c -= 'a' - 'A'; |
| if (c - 'A' + 10 < base) |
| tp->chars[i].attribute -= 2; /* a_letter -> a_letterdigit, |
| a_expo -> a_expodigit */ |
| } |
| } |
| |
| static inline bool |
| has_a_digit (const struct token *tp) |
| { |
| int n = tp->charcount; |
| int i; |
| |
| for (i = 0; i < n; i++) |
| if (tp->chars[i].attribute == a_digit |
| || tp->chars[i].attribute == a_letterdigit |
| || tp->chars[i].attribute == a_expodigit) |
| return true; |
| return false; |
| } |
| |
| static inline bool |
| has_adjacent_letters (const struct token *tp) |
| { |
| int n = tp->charcount; |
| int i; |
| |
| for (i = 1; i < n; i++) |
| if (is_letter_attribute (tp->chars[i-1].attribute) |
| && is_letter_attribute (tp->chars[i].attribute)) |
| return true; |
| return false; |
| } |
| |
| static bool |
| is_potential_number (const struct token *tp, int *basep) |
| { |
| /* CLHS 2.3.1.1.1: |
| "A potential number cannot contain any escape characters." */ |
| if (tp->with_escape) |
| return false; |
| |
| if (has_a_dot (tp)) |
| *basep = 10; |
| |
| if (!all_a_number (tp)) |
| return false; |
| |
| a_letter_to_digit (tp, *basep); |
| |
| if (!has_a_digit (tp)) |
| return false; |
| |
| if (has_adjacent_letters (tp)) |
| return false; |
| |
| if (!(tp->chars[0].attribute >= a_dot |
| && tp->chars[0].attribute <= a_expodigit)) |
| return false; |
| |
| if (tp->chars[tp->charcount - 1].attribute == a_sign) |
| return false; |
| |
| return true; |
| } |
| |
| /* A number is one of integer, ratio, float. Each has a particular syntax. |
| See CLHS 2.3.1 "Numbers as Tokens". |
| But note a mistake: The exponent rule should read: |
| exponent ::= exponent-marker [sign] {decimal-digit}+ |
| (see 22.1.3.1.3 "Printing Floats"). */ |
| |
| enum number_type |
| { |
| n_none, |
| n_integer, |
| n_ratio, |
| n_float |
| }; |
| |
| static enum number_type |
| is_number (const struct token *tp, int *basep) |
| { |
| struct token_char *ptr_limit; |
| struct token_char *ptr1; |
| |
| if (!is_potential_number (tp, basep)) |
| return n_none; |
| |
| /* is_potential_number guarantees |
| - all attributes are >= a_ratio, |
| - there is at least one a_digit or a_letterdigit or a_expodigit, and |
| - if there is an a_dot, then *basep = 10. */ |
| |
| ptr1 = &tp->chars[0]; |
| ptr_limit = &tp->chars[tp->charcount]; |
| |
| if (ptr1->attribute == a_sign) |
| ptr1++; |
| |
| /* Test for syntax |
| * { a_sign | } |
| * { a_digit < base }+ { a_ratio { a_digit < base }+ | } |
| */ |
| { |
| bool seen_a_ratio = false; |
| bool seen_a_digit = false; /* seen a digit in last digit block? */ |
| struct token_char *ptr; |
| |
| for (ptr = ptr1;; ptr++) |
| { |
| if (ptr >= ptr_limit) |
| { |
| if (!seen_a_digit) |
| break; |
| if (seen_a_ratio) |
| return n_ratio; |
| else |
| return n_integer; |
| } |
| if (ptr->attribute == a_digit |
| || ptr->attribute == a_letterdigit |
| || ptr->attribute == a_expodigit) |
| { |
| int c = ptr->ch; |
| |
| c = (c < 'A' ? c - '0' : c < 'a' ? c - 'A' + 10 : c - 'a' + 10); |
| if (c >= *basep) |
| break; |
| seen_a_digit = true; |
| } |
| else if (ptr->attribute == a_ratio) |
| { |
| if (seen_a_ratio || !seen_a_digit) |
| break; |
| seen_a_ratio = true; |
| seen_a_digit = false; |
| } |
| else |
| break; |
| } |
| } |
| |
| /* Test for syntax |
| * { a_sign | } |
| * { a_digit }* { a_dot { a_digit }* | } |
| * { a_expo { a_sign | } { a_digit }+ | } |
| * |
| * If there is an exponent part, there must be digits before the dot or |
| * after the dot. The result is a float. |
| * If there is no exponen: |
| * If there is no dot, it would an integer in base 10, but is has already |
| * been verified to not be an integer in the current base. |
| * If there is a dot: |
| * If there are digits after the dot, it's a float. |
| * Otherwise, if there are digits before the dot, it's an integer. |
| */ |
| *basep = 10; |
| { |
| bool seen_a_dot = false; |
| bool seen_a_dot_with_leading_digits = false; |
| bool seen_a_digit = false; /* seen a digit in last digit block? */ |
| struct token_char *ptr; |
| |
| for (ptr = ptr1;; ptr++) |
| { |
| if (ptr >= ptr_limit) |
| { |
| /* no exponent */ |
| if (!seen_a_dot) |
| return n_none; |
| if (seen_a_digit) |
| return n_float; |
| if (seen_a_dot_with_leading_digits) |
| return n_integer; |
| else |
| return n_none; |
| } |
| if (ptr->attribute == a_digit) |
| { |
| seen_a_digit = true; |
| } |
| else if (ptr->attribute == a_dot) |
| { |
| if (seen_a_dot) |
| return n_none; |
| seen_a_dot = true; |
| if (seen_a_digit) |
| seen_a_dot_with_leading_digits = true; |
| seen_a_digit = false; |
| } |
| else if (ptr->attribute == a_expo || ptr->attribute == a_expodigit) |
| break; |
| else |
| return n_none; |
| } |
| ptr++; |
| if (!seen_a_dot_with_leading_digits || !seen_a_digit) |
| return n_none; |
| if (ptr >= ptr_limit) |
| return n_none; |
| if (ptr->attribute == a_sign) |
| ptr++; |
| seen_a_digit = false; |
| for (;; ptr++) |
| { |
| if (ptr >= ptr_limit) |
| break; |
| if (ptr->attribute != a_digit) |
| return n_none; |
| seen_a_digit = true; |
| } |
| if (!seen_a_digit) |
| return n_none; |
| return n_float; |
| } |
| } |
| |
| /* A token representing a symbol must be case converted. |
| For portability, we convert only ASCII characters here. */ |
| |
| static void |
| upcase_token (struct token *tp) |
| { |
| int n = tp->charcount; |
| int i; |
| |
| for (i = 0; i < n; i++) |
| if (tp->chars[i].attribute != a_escaped) |
| { |
| unsigned char c = tp->chars[i].ch; |
| if (c >= 'a' && c <= 'z') |
| tp->chars[i].ch = c - 'a' + 'A'; |
| } |
| } |
| |
| static void |
| downcase_token (struct token *tp) |
| { |
| int n = tp->charcount; |
| int i; |
| |
| for (i = 0; i < n; i++) |
| if (tp->chars[i].attribute != a_escaped) |
| { |
| unsigned char c = tp->chars[i].ch; |
| if (c >= 'A' && c <= 'Z') |
| tp->chars[i].ch = c - 'A' + 'a'; |
| } |
| } |
| |
| static void |
| case_convert_token (struct token *tp) |
| { |
| int n = tp->charcount; |
| int i; |
| |
| switch (readtable_case) |
| { |
| case case_upcase: |
| upcase_token (tp); |
| break; |
| |
| case case_downcase: |
| downcase_token (tp); |
| break; |
| |
| case case_preserve: |
| break; |
| |
| case case_invert: |
| { |
| bool seen_uppercase = false; |
| bool seen_lowercase = false; |
| for (i = 0; i < n; i++) |
| if (tp->chars[i].attribute != a_escaped) |
| { |
| unsigned char c = tp->chars[i].ch; |
| if (c >= 'a' && c <= 'z') |
| seen_lowercase = true; |
| if (c >= 'A' && c <= 'Z') |
| seen_uppercase = true; |
| } |
| if (seen_uppercase) |
| { |
| if (!seen_lowercase) |
| downcase_token (tp); |
| } |
| else |
| { |
| if (seen_lowercase) |
| upcase_token (tp); |
| } |
| } |
| break; |
| } |
| } |
| |
| |
| /* ========================= Accumulating comments ========================= */ |
| |
| |
| static char *buffer; |
| static size_t bufmax; |
| static size_t buflen; |
| |
| static inline void |
| comment_start () |
| { |
| buflen = 0; |
| } |
| |
| static inline void |
| comment_add (int c) |
| { |
| if (buflen >= bufmax) |
| { |
| bufmax = 2 * bufmax + 10; |
| buffer = xrealloc (buffer, bufmax); |
| } |
| buffer[buflen++] = c; |
| } |
| |
| static inline void |
| comment_line_end (size_t chars_to_remove) |
| { |
| buflen -= chars_to_remove; |
| while (buflen >= 1 |
| && (buffer[buflen - 1] == ' ' || buffer[buflen - 1] == '\t')) |
| --buflen; |
| if (chars_to_remove == 0 && buflen >= bufmax) |
| { |
| bufmax = 2 * bufmax + 10; |
| buffer = xrealloc (buffer, bufmax); |
| } |
| buffer[buflen] = '\0'; |
| savable_comment_add (buffer); |
| } |
| |
| |
| /* These are for tracking whether comments count as immediately before |
| keyword. */ |
| static int last_comment_line; |
| static int last_non_comment_line; |
| |
| |
| /* ========================= Accumulating messages ========================= */ |
| |
| |
| static message_list_ty *mlp; |
| |
| |
| /* ============== Reading of objects. See CLHS 2 "Syntax". ============== */ |
| |
| |
| /* We are only interested in symbols (e.g. GETTEXT or NGETTEXT) and strings. |
| Other objects need not to be represented precisely. */ |
| enum object_type |
| { |
| t_symbol, /* symbol */ |
| t_string, /* string */ |
| t_other, /* other kind of real object */ |
| t_dot, /* '.' pseudo object */ |
| t_close, /* ')' pseudo object */ |
| t_eof /* EOF marker */ |
| }; |
| |
| struct object |
| { |
| enum object_type type; |
| struct token *token; /* for t_symbol and t_string */ |
| int line_number_at_start; /* for t_string */ |
| }; |
| |
| /* Free the memory pointed to by a 'struct object'. */ |
| static inline void |
| free_object (struct object *op) |
| { |
| if (op->type == t_symbol || op->type == t_string) |
| { |
| free_token (op->token); |
| free (op->token); |
| } |
| } |
| |
| /* Convert a t_symbol/t_string token to a char*. */ |
| static char * |
| string_of_object (const struct object *op) |
| { |
| char *str; |
| const struct token_char *p; |
| char *q; |
| int n; |
| |
| if (!(op->type == t_symbol || op->type == t_string)) |
| abort (); |
| n = op->token->charcount; |
| str = XNMALLOC (n + 1, char); |
| q = str; |
| for (p = op->token->chars; n > 0; p++, n--) |
| *q++ = p->ch; |
| *q = '\0'; |
| return str; |
| } |
| |
| /* Context lookup table. */ |
| static flag_context_list_table_ty *flag_context_list_table; |
| |
| /* Read the next object. */ |
| static void |
| read_object (struct object *op, flag_context_ty outer_context) |
| { |
| for (;;) |
| { |
| struct char_syntax curr; |
| |
| read_char_syntax (&curr); |
| |
| switch (curr.scode) |
| { |
| case syntax_eof: |
| op->type = t_eof; |
| return; |
| |
| case syntax_whitespace: |
| if (curr.ch == '\n') |
| /* Comments assumed to be grouped with a message must immediately |
| precede it, with no non-whitespace token on a line between |
| both. */ |
| if (last_non_comment_line > last_comment_line) |
| savable_comment_reset (); |
| continue; |
| |
| case syntax_illegal: |
| op->type = t_other; |
| return; |
| |
| case syntax_single_esc: |
| case syntax_multi_esc: |
| case syntax_constituent: |
| /* Start reading a token. */ |
| op->token = XMALLOC (struct token); |
| read_token (op->token, &curr); |
| last_non_comment_line = line_number; |
| |
| /* Interpret the token. */ |
| |
| /* Dots. */ |
| if (!op->token->with_escape |
| && op->token->charcount == 1 |
| && op->token->chars[0].attribute == a_dot) |
| { |
| free_token (op->token); |
| free (op->token); |
| op->type = t_dot; |
| return; |
| } |
| /* Tokens consisting entirely of dots are illegal, but be tolerant |
| here. */ |
| |
| /* Number. */ |
| { |
| int base = read_base; |
| |
| if (is_number (op->token, &base) != n_none) |
| { |
| free_token (op->token); |
| free (op->token); |
| op->type = t_other; |
| return; |
| } |
| } |
| |
| /* We interpret all other tokens as symbols (including 'reserved |
| tokens', i.e. potential numbers which are not numbers). */ |
| case_convert_token (op->token); |
| op->type = t_symbol; |
| return; |
| |
| case syntax_t_macro: |
| case syntax_nt_macro: |
| /* Read a macro. */ |
| switch (curr.ch) |
| { |
| case '(': |
| { |
| int arg = 0; /* Current argument number. */ |
| flag_context_list_iterator_ty context_iter; |
| const struct callshapes *shapes = NULL; |
| struct arglist_parser *argparser = NULL; |
| |
| for (;; arg++) |
| { |
| struct object inner; |
| flag_context_ty inner_context; |
| |
| if (arg == 0) |
| inner_context = null_context; |
| else |
| inner_context = |
| inherited_context (outer_context, |
| flag_context_list_iterator_advance ( |
| &context_iter)); |
| |
| read_object (&inner, inner_context); |
| |
| /* Recognize end of list. */ |
| if (inner.type == t_close) |
| { |
| op->type = t_other; |
| /* Don't bother converting "()" to "NIL". */ |
| last_non_comment_line = line_number; |
| if (argparser != NULL) |
| arglist_parser_done (argparser, arg); |
| return; |
| } |
| |
| /* Dots are not allowed in every position. |
| But be tolerant. */ |
| |
| /* EOF inside list is illegal. |
| But be tolerant. */ |
| if (inner.type == t_eof) |
| break; |
| |
| if (arg == 0) |
| { |
| /* This is the function position. */ |
| if (inner.type == t_symbol) |
| { |
| char *symbol_name = string_of_object (&inner); |
| int i; |
| int prefix_len; |
| void *keyword_value; |
| |
| /* Omit any package name. */ |
| i = inner.token->charcount; |
| while (i > 0 |
| && inner.token->chars[i-1].attribute != a_pack_m) |
| i--; |
| prefix_len = i; |
| |
| if (hash_find_entry (&keywords, |
| symbol_name + prefix_len, |
| strlen (symbol_name + prefix_len), |
| &keyword_value) |
| == 0) |
| shapes = (const struct callshapes *) keyword_value; |
| |
| argparser = arglist_parser_alloc (mlp, shapes); |
| |
| context_iter = |
| flag_context_list_iterator ( |
| flag_context_list_table_lookup ( |
| flag_context_list_table, |
| symbol_name, strlen (symbol_name))); |
| |
| free (symbol_name); |
| } |
| else |
| context_iter = null_context_list_iterator; |
| } |
| else |
| { |
| /* These are the argument positions. */ |
| if (argparser != NULL && inner.type == t_string) |
| { |
| char *s = string_of_object (&inner); |
| mixed_string_ty *ms = |
| mixed_string_alloc_simple (s, lc_string, |
| logical_file_name, |
| inner.line_number_at_start); |
| free (s); |
| arglist_parser_remember (argparser, arg, ms, |
| inner_context, |
| logical_file_name, |
| inner.line_number_at_start, |
| savable_comment, false); |
| } |
| } |
| |
| free_object (&inner); |
| } |
| |
| if (argparser != NULL) |
| arglist_parser_done (argparser, arg); |
| } |
| op->type = t_other; |
| last_non_comment_line = line_number; |
| return; |
| |
| case ')': |
| /* Tell the caller about the end of list. |
| Unmatched closing parenthesis is illegal. |
| But be tolerant. */ |
| op->type = t_close; |
| last_non_comment_line = line_number; |
| return; |
| |
| case ',': |
| { |
| int c = do_getc (); |
| /* The ,@ handling inside lists is wrong anyway, because |
| ,@form expands to an unknown number of elements. */ |
| if (c != EOF && c != '@' && c != '.') |
| do_ungetc (c); |
| } |
| FALLTHROUGH; |
| case '\'': |
| case '`': |
| { |
| struct object inner; |
| |
| read_object (&inner, null_context); |
| |
| /* Dots and EOF are not allowed here. But be tolerant. */ |
| |
| free_object (&inner); |
| |
| op->type = t_other; |
| last_non_comment_line = line_number; |
| return; |
| } |
| |
| case ';': |
| { |
| bool all_semicolons = true; |
| |
| last_comment_line = line_number; |
| comment_start (); |
| for (;;) |
| { |
| int c = do_getc (); |
| if (c == EOF || c == '\n') |
| break; |
| if (c != ';') |
| all_semicolons = false; |
| if (!all_semicolons) |
| { |
| /* We skip all leading white space, but not EOLs. */ |
| if (!(buflen == 0 && (c == ' ' || c == '\t'))) |
| comment_add (c); |
| } |
| } |
| comment_line_end (0); |
| continue; |
| } |
| |
| case '"': |
| { |
| op->token = XMALLOC (struct token); |
| init_token (op->token); |
| op->line_number_at_start = line_number; |
| for (;;) |
| { |
| int c = do_getc (); |
| if (c == EOF) |
| /* Invalid input. Be tolerant, no error message. */ |
| break; |
| if (c == '"') |
| break; |
| if (c == '\\') /* syntax_single_esc */ |
| { |
| c = do_getc (); |
| if (c == EOF) |
| /* Invalid input. Be tolerant, no error message. */ |
| break; |
| } |
| grow_token (op->token); |
| op->token->chars[op->token->charcount++].ch = c; |
| } |
| op->type = t_string; |
| |
| if (extract_all) |
| { |
| lex_pos_ty pos; |
| |
| pos.file_name = logical_file_name; |
| pos.line_number = op->line_number_at_start; |
| remember_a_message (mlp, NULL, string_of_object (op), false, |
| false, null_context, &pos, |
| NULL, savable_comment, false); |
| } |
| last_non_comment_line = line_number; |
| return; |
| } |
| |
| case '#': |
| /* Dispatch macro handling. */ |
| { |
| int c; |
| |
| for (;;) |
| { |
| c = do_getc (); |
| if (c == EOF) |
| /* Invalid input. Be tolerant, no error message. */ |
| { |
| op->type = t_other; |
| return; |
| } |
| if (!(c >= '0' && c <= '9')) |
| break; |
| } |
| |
| switch (c) |
| { |
| case '(': |
| case '"': |
| do_ungetc (c); |
| FALLTHROUGH; |
| case '\'': |
| case ':': |
| case '.': |
| case ',': |
| case 'A': case 'a': |
| case 'C': case 'c': |
| case 'P': case 'p': |
| case 'S': case 's': |
| { |
| struct object inner; |
| read_object (&inner, null_context); |
| /* Dots and EOF are not allowed here. |
| But be tolerant. */ |
| free_object (&inner); |
| op->type = t_other; |
| last_non_comment_line = line_number; |
| return; |
| } |
| |
| case '|': |
| { |
| int depth = 0; |
| int c; |
| |
| comment_start (); |
| c = do_getc (); |
| for (;;) |
| { |
| if (c == EOF) |
| break; |
| if (c == '|') |
| { |
| c = do_getc (); |
| if (c == EOF) |
| break; |
| if (c == '#') |
| { |
| if (depth == 0) |
| { |
| comment_line_end (0); |
| break; |
| } |
| depth--; |
| comment_add ('|'); |
| comment_add ('#'); |
| c = do_getc (); |
| } |
| else |
| comment_add ('|'); |
| } |
| else if (c == '#') |
| { |
| c = do_getc (); |
| if (c == EOF) |
| break; |
| comment_add ('#'); |
| if (c == '|') |
| { |
| depth++; |
| comment_add ('|'); |
| c = do_getc (); |
| } |
| } |
| else |
| { |
| /* We skip all leading white space. */ |
| if (!(buflen == 0 && (c == ' ' || c == '\t'))) |
| comment_add (c); |
| if (c == '\n') |
| { |
| comment_line_end (1); |
| comment_start (); |
| } |
| c = do_getc (); |
| } |
| } |
| if (c == EOF) |
| { |
| /* EOF not allowed here. But be tolerant. */ |
| op->type = t_eof; |
| return; |
| } |
| last_comment_line = line_number; |
| continue; |
| } |
| |
| case '\\': |
| { |
| struct token token; |
| struct char_syntax first; |
| first.ch = '\\'; |
| first.scode = syntax_single_esc; |
| read_token (&token, &first); |
| free_token (&token); |
| op->type = t_other; |
| last_non_comment_line = line_number; |
| return; |
| } |
| |
| case 'B': case 'b': |
| case 'O': case 'o': |
| case 'X': case 'x': |
| case 'R': case 'r': |
| case '*': |
| { |
| struct token token; |
| read_token (&token, NULL); |
| free_token (&token); |
| op->type = t_other; |
| last_non_comment_line = line_number; |
| return; |
| } |
| |
| case '=': |
| /* Ignore read labels. */ |
| continue; |
| |
| case '#': |
| /* Don't bother looking up the corresponding object. */ |
| op->type = t_other; |
| last_non_comment_line = line_number; |
| return; |
| |
| case '+': |
| case '-': |
| /* Simply assume every feature expression is true. */ |
| { |
| struct object inner; |
| read_object (&inner, null_context); |
| /* Dots and EOF are not allowed here. |
| But be tolerant. */ |
| free_object (&inner); |
| continue; |
| } |
| |
| default: |
| op->type = t_other; |
| last_non_comment_line = line_number; |
| return; |
| } |
| /*NOTREACHED*/ |
| abort (); |
| } |
| |
| default: |
| /*NOTREACHED*/ |
| abort (); |
| } |
| |
| default: |
| /*NOTREACHED*/ |
| abort (); |
| } |
| } |
| } |
| |
| |
| void |
| extract_lisp (FILE *f, |
| const char *real_filename, const char *logical_filename, |
| flag_context_list_table_ty *flag_table, |
| msgdomain_list_ty *mdlp) |
| { |
| mlp = mdlp->item[0]->messages; |
| |
| fp = f; |
| real_file_name = real_filename; |
| logical_file_name = xstrdup (logical_filename); |
| line_number = 1; |
| |
| last_comment_line = -1; |
| last_non_comment_line = -1; |
| |
| flag_context_list_table = flag_table; |
| |
| init_keywords (); |
| |
| /* Eat tokens until eof is seen. When read_object returns |
| due to an unbalanced closing parenthesis, just restart it. */ |
| do |
| { |
| struct object toplevel_object; |
| |
| read_object (&toplevel_object, null_context); |
| |
| if (toplevel_object.type == t_eof) |
| break; |
| |
| free_object (&toplevel_object); |
| } |
| while (!feof (fp)); |
| |
| /* Close scanner. */ |
| fp = NULL; |
| real_file_name = NULL; |
| logical_file_name = NULL; |
| line_number = 0; |
| } |
