/*

Copyright (c) 2001, Dr Martin Porter
Copyright (c) 2002, Richard Boulton
All rights reserved.

Redistribution and use in source and binary forms, with 
or without modification, are permitted provided that the 
following conditions are met:

*	Redistributions of source code must retain the 
	above copyright notice, this list of conditions and 
	the following disclaimer. 
*	Redistributions in binary form must reproduce 
	above copyright notice, this list of conditions and
 	the following disclaimer in the documentation and/or 
	other materials provided with the distribution. 
*	Neither the name of the <ORGANIZATION> nor the 
	names of its contributors may be used to endorse or 
	promote products derived from this software without
	specific rior written permission. 

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 
CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 
DAMAGE.

*/
#include <stdio.h>   /* main etc */
#include <stdlib.h>  /* exit */
#include <string.h>  /* memmove */
#include "header.h"

/* recursive usage: */

static void read_program_(struct analyser * a, int terminator);
static struct node * read_C(struct analyser * a);
static struct node * C_style(struct analyser * a, char * s, int token);


static void fault(int n) { fprintf(stderr, "fault %d\n", n); exit(1); }

static void print_node_(struct node * p, int n, char * s) {

    int i;
    for (i = 0; i < n; i++) printf(i == n - 1 ? s : "  ");
    printf("%s ", name_of_token(p->type));
    unless (p->name == 0) report_b(stdout, p->name->b);
    unless (p->literalstring == 0) {
        printf("'");
        report_b(stdout, p->literalstring);
        printf("'");
    }
    printf("\n");
    unless (p->AE == 0) print_node_(p->AE, n+1, "# ");
    unless (p->left == 0) print_node_(p->left, n+1, "  ");
    unless (p->right == 0) print_node_(p->right, n, "  ");
    if (p->aux != 0) print_node_(p->aux, n+1, "@ ");
}

extern void print_program(struct analyser * a) {
    print_node_(a->program, 0, "  ");
}

static struct node * new_node(struct analyser * a, int type) {
    NEW(node, p);
    p->next = a->nodes; a->nodes = p;
    p->left = 0;
    p->right = 0;
    p->aux = 0;
    p->AE = 0;
    p->name = 0;
    p->literalstring = 0;
    p->mode = a->mode;
    p->line_number = a->tokeniser->line_number;
    p->type = type;
    return p;
}

static char * name_of_mode(int n) {
    switch (n) {
         default: fault(0);
         case m_backward: return "string backward";
         case m_forward:  return "string forward";
    /*   case m_integer:  return "integer";  */
    }
}

static char * name_of_type(int n) {
    switch (n) {
         default: fault(1);
         case 's': return "string";
         case 'i': return "integer";
         case 'r': return "routine";
         case 'R': return "routine or grouping";
         case 'g': return "grouping";
    }
}

static void count_error(struct analyser * a) {
    struct tokeniser * t = a->tokeniser;
    if (t->error_count >= 20) { fprintf(stderr, "... etc\n"); exit(1); }
    t->error_count++;
}

static void error2(struct analyser * a, int n, int x) {
    struct tokeniser * t = a->tokeniser;
    count_error(a);
    fprintf(stderr, "Line %d", t->line_number);
    if (t->get_depth > 0) fprintf(stderr, " (of included file)");
    fprintf(stderr, ": ");
    if (n >= 30) report_b(stderr, t->b);
    switch (n) {
        case 0:
            fprintf(stderr, "%s omitted", name_of_token(t->omission)); break;
        case 3:
            fprintf(stderr, "in among(...), ");
        case 1:
            fprintf(stderr, "unexpected %s", name_of_token(t->token));
            if (t->token == c_number) fprintf(stderr, " %d", t->number);
            if (t->token == c_name) {
                fprintf(stderr, " ");
                report_b(stderr, t->b);
            } break;
        case 2:
            fprintf(stderr, "string omitted"); break;

        case 14:
            fprintf(stderr, "unresolved substring on line %d", x); break;
        case 15:
            fprintf(stderr, "%s not allowed inside reverse(...)", name_of_token(t->token)); break;
        case 16:
            fprintf(stderr, "empty grouping"); break;
        case 17:
            fprintf(stderr, "backwards used when already in this mode"); break;
        case 18:
            fprintf(stderr, "empty among(...)"); break;
        case 19:
            fprintf(stderr, "two adjacent bracketed expressions in among(...)"); break;
        case 20:
            fprintf(stderr, "substring preceded by another substring on line %d", x); break;

        case 30:
            fprintf(stderr, " re-declared"); break;
        case 31:
            fprintf(stderr, " undeclared"); break;
        case 32:
            fprintf(stderr, " declared as %s mode; used as %s mode",
                            name_of_mode(a->mode), name_of_mode(x)); break;
        case 33:
            fprintf(stderr, " not of type %s", name_of_type(x)); break;
        case 34:
            fprintf(stderr, " not of type string or integer"); break;
        case 35:
            fprintf(stderr, " misplaced"); break;
        case 36:
            fprintf(stderr, " redefined"); break;
        case 37:
            fprintf(stderr, " mis-used as %s mode",
                            name_of_mode(x)); break;
        default:
            fprintf(stderr, " error %d", n); break;

    }
    if (n <= 13 && t->previous_token > 0)
        fprintf(stderr, " after %s", name_of_token(t->previous_token));
    fprintf(stderr, "\n");
}

static void error(struct analyser * a, int n) { error2(a, n, 0); }

static void error3(struct analyser * a, struct node * p, symbol * b) {
    count_error(a);
    fprintf(stderr, "among(...) on line %d has repeated string '", p->line_number);
    report_b(stderr, b);
    fprintf(stderr, "'\n");
}

static void error4(struct analyser * a, struct name * q) {
    count_error(a);
    report_b(stderr, q->b);
    fprintf(stderr, " undefined\n");
}

static void omission_error(struct analyser * a, int n) {
    a->tokeniser->omission = n;
    error(a, 0);
}

static int check_token(struct analyser * a, int code) {
    struct tokeniser * t = a->tokeniser;
    if (t->token != code) { omission_error(a, code); return false; }
    return true;
}

static int get_token(struct analyser * a, int code) {
    struct tokeniser * t = a->tokeniser;
    read_token(t);
    {
        int x = check_token(a, code);
        unless (x) t->token_held = true;
        return x;
    }
}

static struct name * look_for_name(struct analyser * a) {
    struct name * p = a->names;
    symbol * q = a->tokeniser->b;
    repeat {
        if (p == 0) return 0;
        {   symbol * b = p->b;
            int n = SIZE(b);
            if (n == SIZE(q) && memcmp(q, b, n * sizeof(symbol)) == 0) {
                p->referenced = true;
                return p;
            }
        }
        p = p->next;
    }
}

static struct name * find_name(struct analyser * a) {
    struct name * p = look_for_name(a);
    if (p == 0) error(a, 31);
    return p;
}

static void check_routine_mode(struct analyser * a, struct name * p, int mode) {
    if (p->mode < 0) p->mode = mode; else
    unless (p->mode == mode) error2(a, 37, mode);
}

static void check_name_type(struct analyser * a, struct name * p, int type) {
    switch (type) {
        case 's': if (p->type == t_string) return; break;
        case 'i': if (p->type == t_integer) return; break;
        case 'b': if (p->type == t_boolean) return; break;
        case 'R': if (p->type == t_grouping) return;
        case 'r': if (p->type == t_routine ||
                      p->type == t_external) return; break;
        case 'g': if (p->type == t_grouping) return; break;
    }
    error2(a, 33, type);
}

static void read_names(struct analyser * a, int type) {
    struct tokeniser * t = a->tokeniser;
    unless (get_token(a, c_bra)) return;
    repeat {
        if (read_token(t) != c_name) break;
        if (look_for_name(a) != 0) error(a, 30); else {
            NEW(name, p);
            p->b = copy_b(t->b);
            p->type = type;
            p->mode = -1; /* routines, externals */
            p->count = a->name_count[type];
            p->referenced = false;
            p->used = false;
            p->grouping = 0;
            p->definition = 0;
            a->name_count[type] ++;
            p->next = a->names;
            a->names = p;
        }
    }
    unless (check_token(a, c_ket)) t->token_held = true;
}

static symbol * new_literalstring(struct analyser * a) {
    NEW(literalstring, p);
    p->b = copy_b(a->tokeniser->b);
    p->next = a->literalstrings;
    a->literalstrings = p;
    return p->b;
}

static int read_AE_test(struct analyser * a) {

    struct tokeniser * t = a->tokeniser;
    switch (read_token(t)) {
        case c_assign: return c_mathassign;
        case c_plusassign:
        case c_minusassign:
        case c_multiplyassign:
        case c_divideassign:
        case c_eq:
        case c_ne:
        case c_gr:
        case c_ge:
        case c_ls:
        case c_le: return t->token;
        default: error(a, 1); t->token_held = true; return c_eq;
    }
}

static int binding(int t) {
    switch (t) {
        case c_plus: case c_minus: return 1;
        case c_multiply: case c_divide: return 2;
        default: return -2;
    }
}

static void name_to_node(struct analyser * a, struct node * p, int type) {
    struct name * q = find_name(a);
    unless (q == 0) {
        check_name_type(a, q, type);
        q->used = true;
    }
    p->name = q;
}

static struct node * read_AE(struct analyser * a, int B) {
    struct tokeniser * t = a->tokeniser;
    struct node * p;
    struct node * q;
    switch (read_token(t)) {
        case c_minus: /* monadic */
            p = new_node(a, c_neg);
            p->right = read_AE(a, 100);
            break;
        case c_bra:
            p = read_AE(a, 0);
            get_token(a, c_ket);
            break;
        case c_name:
            p = new_node(a, c_name);
            name_to_node(a, p, 'i');
            break;
        case c_maxint:
        case c_minint:
        case c_cursor:
        case c_limit:
        case c_size:
            p = new_node(a, t->token);
            break;
        case c_number:
            p = new_node(a, c_number);
            p->number = t->number;
            break;
        case c_sizeof:
            p = C_style(a, "s", c_sizeof);
            break;
        default:
            error(a, 1);
            t->token_held = true;
            return 0;
    }
    repeat {
        int token = read_token(t);
        int b = binding(token);
        unless (binding(token) > B) {
            t->token_held = true;
            return p;
        }
        q = new_node(a, token);
        q->left = p;
        q->right = read_AE(a, b);
        p = q;
    }
}

static struct node * read_C_connection(struct analyser * a, struct node * q, int op) {
    struct tokeniser * t = a->tokeniser;
    struct node * p = new_node(a, op);
    struct node * p_end = q;
    p->left = q;
    repeat {
        q = read_C(a);
        p_end->right = q; p_end = q;
        if (read_token(t) != op) {
            t->token_held = true;
            break;
        }
    }
    return p;
}

static struct node * read_C_list(struct analyser * a) {
    struct tokeniser * t = a->tokeniser;
    struct node * p = new_node(a, c_bra);
    struct node * p_end = 0;
    repeat {
        int token = read_token(t);
        if (token == c_ket) return p;
        if (token < 0) { omission_error(a, c_ket); return p; }
        t->token_held = true;
        {
            struct node * q = read_C(a);
            repeat {
                token = read_token(t);
                if (token != c_and && token != c_or) {
                    t->token_held = true;
                    break;
                }
                q = read_C_connection(a, q, token);
            }
            if (p_end == 0) p->left = q; else p_end->right = q;
            p_end = q;
        }
    }
}

static struct node * C_style(struct analyser * a, char * s, int token) {
    int i;
    struct node * p = new_node(a, token);
    for (i = 0; s[i] != 0; i++) switch(s[i]) {
        case 'C':
            p->left = read_C(a); continue;
        case 'D':
            p->aux = read_C(a); continue;
        case 'A':
            p->AE = read_AE(a, 0); continue;
        case 'f':
            get_token(a, c_for); continue;
        case 'S':
            {
                int str_token = read_token(a->tokeniser);
                if (str_token == c_name) name_to_node(a, p, 's'); else
                if (str_token == c_literalstring) p->literalstring = new_literalstring(a);
                else error(a, 2);
            }
            continue;
        case 'b':
        case 's':
        case 'i':
            if (get_token(a, c_name)) name_to_node(a, p, s[i]);
            continue;
    }
    return p;
}

static struct node * read_literalstring(struct analyser * a) {
    struct node * p = new_node(a, c_literalstring);
    p->literalstring = new_literalstring(a);
    return p;
}

static void reverse_b(symbol * b) {
    int i = 0; int j = SIZE(b) - 1;
    until (i >= j) {
        int ch1 = b[i]; int ch2 = b[j];
        b[i++] = ch2; b[j--] = ch1;
    }
}

static int compare_amongvec(const void *pv, const void *qv) {
    const struct amongvec * p = (const struct amongvec*)pv;
    const struct amongvec * q = (const struct amongvec*)qv;
    symbol * b_p = p->b; int p_size = p->size;
    symbol * b_q = q->b; int q_size = q->size;
    int smaller_size = p_size < q_size ? p_size : q_size;
    int i;
    for (i = 0; i < smaller_size; i++)
        if (b_p[i] != b_q[i]) return b_p[i] - b_q[i];
    return p_size - q_size;
}

static void make_among(struct analyser * a, struct node * p, struct node * substring) {

    NEW(among, x);
    NEWVEC(amongvec, v, p->number);
    struct node * q = p->left;
    struct amongvec * w0 = v;
    struct amongvec * w1 = v;
    int result = 1;

    int direction = substring != 0 ? substring->mode : p->mode;
    int backward = direction == m_backward;

    if (a->amongs == 0) a->amongs = x; else a->amongs_end->next = x;
    a->amongs_end = x;
    x->next = 0;
    x->b = v;
    x->number = a->among_count++;
    x->starter = 0;

    if (q->type == c_bra) { x->starter = q; q = q->right; }

    until (q == 0) {
        if (q->type == c_literalstring) {
            symbol * b = q->literalstring;
            w1->b = b;           /* pointer to case string */
            w1->p = 0;           /* pointer to corresponding case expression */
            w1->size = SIZE(b);  /* number of characters in string */
            w1->i = -1;          /* index of longest substring */
            w1->result = -1;     /* number of corresponding case expression */
            w1->function = q->left == 0 ? 0 : q->left->name;
            unless (w1->function == 0)
                check_routine_mode(a, w1->function, direction);
            w1++;
        }
        else
        if (q->left == 0)  /* empty command: () */
            w0 = w1;
        else {
            until (w0 == w1) {
                w0->p = q;
                w0->result = result;
                w0++;
            }
            result++;
        }
        q = q->right;
    }
    unless (w1-v == p->number) { fprintf(stderr, "oh! %d %d\n", (int)(w1-v), p->number); exit(1); }
    if (backward) for (w0 = v; w0 < w1; w0++) reverse_b(w0->b);
    qsort(v, w1 - v, sizeof(struct amongvec), compare_amongvec);

    /* the following loop is O(n squared) */
    for (w0 = w1 - 1; w0 >= v; w0--) {
        symbol * b = w0->b;
        int size = w0->size;
        struct amongvec * w;

        for (w = w0 - 1; w >= v; w--) {
            if (w->size < size && memcmp(w->b, b, w->size * sizeof(symbol)) == 0) {
                w0->i = w - v;  /* fill in index of longest substring */
                break;
            }
        }
    }
    if (backward) for (w0 = v; w0 < w1; w0++) reverse_b(w0->b);

    for (w0 = v; w0 < w1 - 1; w0++)
        if (w0->size == (w0 + 1)->size &&
            memcmp(w0->b, (w0 + 1)->b, w0->size * sizeof(symbol)) == 0) error3(a, p, w0->b);

    x->literalstring_count = p->number;
    x->command_count = result - 1;
    p->among = x;

    x->substring = substring;
    if (substring != 0) substring->among = x;
    unless (x->command_count == 0 && x->starter == 0) a->amongvar_needed = true;
}

static struct node * read_among(struct analyser * a) {
    struct tokeniser * t = a->tokeniser;
    struct node * p = new_node(a, c_among);
    struct node * p_end = 0;
    int previous_token = -1;
    struct node * substring = a->substring;

    a->substring = 0;
    p->number = 0; /* counts the number of literals */
    unless (get_token(a, c_bra)) return p;
    repeat {
        struct node * q;
        int token = read_token(t);
        switch (token) {
            case c_literalstring:
                q = read_literalstring(a);
                if (read_token(t) == c_name) {
                    struct node * r = new_node(a, c_name);
                    name_to_node(a, r, 'r');
                    q->left = r;
                }
                else t->token_held = true;
                p->number++; break;
            case c_bra:
                if (previous_token == c_bra) error(a, 19);
                q = read_C_list(a); break;
            default:
                error(a, 3);
            case c_ket:
                if (p->number == 0) error(a, 18);
                if (t->error_count == 0) make_among(a, p, substring);
                return p;
        }
        previous_token = token;
        if (p_end == 0) p->left = q; else p_end->right = q;
        p_end = q;
    }
}

static struct node * read_substring(struct analyser * a) {

    struct node * p = new_node(a, c_substring);
    if (a->substring != 0) error2(a, 20, a->substring->line_number);
    a->substring = p;
    return p;
}

static void check_modifyable(struct analyser * a) {
    unless (a->modifyable) error(a, 15);
}

static struct node * read_C(struct analyser * a) {
    struct tokeniser * t = a->tokeniser;
    int token = read_token(t);
    switch (token) {
        case c_bra:
            return read_C_list(a);
        case c_backwards:
            {
                int mode = a->mode;
                if (a->mode == m_backward) error(a, 17); else a->mode = m_backward;
                {   struct node * p = C_style(a, "C", token);
                    a->mode = mode;
                    return p;
                }
            }
        case c_reverse:
            {
                int mode = a->mode;
                int modifyable = a->modifyable;
                a->modifyable = false;
                a->mode = mode == m_forward ? m_backward : m_forward;
                {
                    struct node * p = C_style(a, "C", token);
                    a->mode = mode;
                    a->modifyable = modifyable;
                    return p;
                }
            }
        case c_not:
        case c_try:
        case c_fail:
        case c_test:
        case c_do:
        case c_goto:
        case c_gopast:
        case c_repeat:
            return C_style(a, "C", token);
        case c_loop:
        case c_atleast:
            return C_style(a, "AC", token);
        case c_setmark:
            return C_style(a, "i", token);
        case c_tomark:
        case c_atmark:
        case c_hop:
            return C_style(a, "A", token);
        case c_delete:
            check_modifyable(a);
        case c_next:
        case c_tolimit:
        case c_atlimit:
        case c_leftslice:
        case c_rightslice:
        case c_true:
        case c_false:
        case c_debug:
            return C_style(a, "", token);
        case c_assignto:
        case c_sliceto:
            check_modifyable(a);
            return C_style(a, "s", token);
        case c_assign:
        case c_insert:
        case c_attach:
        case c_slicefrom:
            check_modifyable(a);
            return C_style(a, "S", token);
        case c_setlimit:
            return C_style(a, "CfD", token);
        case c_set:
        case c_unset:
            return C_style(a, "b", token);
        case c_dollar:
            get_token(a, c_name);
            {
                struct node * p;
                struct name * q = find_name(a);
                int mode = a->mode;
                int modifyable = a->modifyable;
                switch (q ? q->type : t_string)
                    /* above line was: switch (q->type) - bug #1 fix 7/2/2003 */
                {
                    default: error(a, 34);
                    case t_string:
                        a->mode = m_forward;
                        a->modifyable = true;
                        p = new_node(a, c_dollar);
                        p->left = read_C(a); break;
                    case t_integer:
                    /*  a->mode = m_integer;  */
                        p = new_node(a, read_AE_test(a));
                        p->AE = read_AE(a, 0); break;
                }
                p->name = q;
                a->mode = mode;
                a->modifyable = modifyable;
                return p;
            }
        case c_name:
            {
                struct name * q = find_name(a);
                struct node * p = new_node(a, c_name);
                unless (q == 0) {
                    q->used = true;
                    switch (q->type) {
                        case t_boolean:
                            p->type = c_booltest; break;
                        case t_integer:
                            error(a, 35); /* integer name misplaced */
                        case t_string:
                            break;
                        case t_routine:
                        case t_external:
                            p->type = c_call;
                            check_routine_mode(a, q, a->mode);
                            break;
                        case t_grouping:
                            p->type = c_grouping; break;
                    }
                }
                p->name = q;
                return p;
            }
        case c_non:
            {
                struct node * p = new_node(a, token);
                read_token(t);
                if (t->token == c_minus) read_token(t);
                unless (check_token(a, c_name)) { omission_error(a, c_name); return p; }
                name_to_node(a, p, 'g');
                return p;
            }
        case c_literalstring:
            return read_literalstring(a);
        case c_among: return read_among(a);
        case c_substring: return read_substring(a);
        default: error(a, 1); return 0;
    }
}

static int next_symbol(symbol * p, symbol * W, int utf8) {
    if (utf8) {
        int ch;
        int j = get_utf8(p, & ch);
        W[0] = ch; return j;
    } else {
        W[0] = p[0]; return 1;
    }
}

static symbol * alter_grouping(symbol * p, symbol * q, int style, int utf8) {
    int j = 0;
    symbol W[1];
    int width;
    if (style == c_plus) {
        while (j < SIZE(q)) {
            width = next_symbol(q + j, W, utf8);
            p = add_to_b(p, 1, W);
            j += width;
        }
    } else {
        while (j < SIZE(q)) {
            int i;
            width = next_symbol(q + j, W, utf8);
            for (i = 0; i < SIZE(p); i++) {
                if (p[i] == W[0]) {
                    memmove(p + i, p + i + 1, (SIZE(p) - i - 1) * sizeof(symbol));
                    SIZE(p)--;
                }
            }
            j += width;
        }
    }
    return p;
}

static void read_define_grouping(struct analyser * a, struct name * q) {
    struct tokeniser * t = a->tokeniser;
    int style = c_plus;
    {
        NEW(grouping, p);
        if (a->groupings == 0) a->groupings = p; else a->groupings_end->next = p;
        a->groupings_end = p;
        q->grouping = p;
        p->next = 0;
        p->name = q;
        p->number = q->count;
        p->b = create_b(0);
        repeat {
            switch (read_token(t)) {
                case c_name:
                    {
                        struct name * r = find_name(a);
                        unless (r == 0) {
                            check_name_type(a, r, 'g');
                            p->b = alter_grouping(p->b, r->grouping->b, style, false);
                        }
                    }
                    break;
                case c_literalstring:
                    p->b = alter_grouping(p->b, t->b, style, a->utf8);
                    break;
                default: error(a, 1); return;
            }
            switch (read_token(t)) {
                case c_plus:
                case c_minus: style = t->token; break;
                default: goto label0;
            }
        }
    label0:
        {
            int i;
            int max = 0;
            int min = 1<<16;
            for (i = 0; i < SIZE(p->b); i++) {
                if (p->b[i] > max) max = p->b[i];
                if (p->b[i] < min) min = p->b[i];
            }
            p->largest_ch = max;
            p->smallest_ch = min;
            if (min == 1<<16) error(a, 16);
        }
        t->token_held = true; return;
    }
}

static void read_define_routine(struct analyser * a, struct name * q) {
    struct node * p = new_node(a, c_define);
    a->amongvar_needed = false;
    unless (q == 0) {
        check_name_type(a, q, 'R');
        if (q->definition != 0) error(a, 36);
        if (q->mode < 0) q->mode = a->mode; else
        if (q->mode != a->mode) error2(a, 32, q->mode);
    }
    p->name = q;
    if (a->program == 0) a->program = p; else a->program_end->right = p;
    a->program_end = p;
    get_token(a, c_as);
    p->left = read_C(a);
    unless (q == 0) q->definition = p->left;

    if (a->substring != 0) {
         error2(a, 14, a->substring->line_number);
         a->substring = 0;
    }
    p->amongvar_needed = a->amongvar_needed;
}

static void read_define(struct analyser * a) {
    unless (get_token(a, c_name)) return;
    {
        struct name * q = find_name(a);
        if (q != 0 && q->type == t_grouping) read_define_grouping(a, q);
            else read_define_routine(a, q);
    }
}

static void read_backwardmode(struct analyser * a) {
    int mode = a->mode;
    a->mode = m_backward;
    if (get_token(a, c_bra)) {
        read_program_(a, c_ket);
        check_token(a, c_ket);
    }
    a->mode = mode;
}

static void read_program_(struct analyser * a, int terminator) {
    struct tokeniser * t = a->tokeniser;
    repeat {
        switch (read_token(t)) {
            case c_strings:     read_names(a, t_string); break;
            case c_booleans:    read_names(a, t_boolean); break;
            case c_integers:    read_names(a, t_integer); break;
            case c_routines:    read_names(a, t_routine); break;
            case c_externals:   read_names(a, t_external); break;
            case c_groupings:   read_names(a, t_grouping); break;
            case c_define:      read_define(a); break;
            case c_backwardmode:read_backwardmode(a); break;
            case c_ket:
                if (terminator == c_ket) return;
            default:
                error(a, 1); break;
            case -1:
                unless (terminator < 0) omission_error(a, c_ket);
                return;
        }
    }
}

extern void read_program(struct analyser * a) {
    read_program_(a, -1);
    {
        struct name * q = a->names;
        until (q == 0) {
            switch(q->type) {
                case t_external: case t_routine:
                    if (q->used && q->definition == 0) error4(a, q); break;
                case t_grouping:
                    if (q->used && q->grouping == 0) error4(a, q); break;
            }
            q = q->next;
        }
    }

    if (a->tokeniser->error_count == 0) {
        struct name * q = a->names;
        int warned = false;
        until (q == 0) {
            unless (q->referenced) {
                unless (warned) {
                    fprintf(stderr, "Declared but not used:");
                    warned = true;
                }
                fprintf(stderr, " "); report_b(stderr, q->b);
            }
            q = q->next;
        }
        if (warned) fprintf(stderr, "\n");

        q = a->names;
        warned = false;
        until (q == 0) {
            if (! q->used && (q->type == t_routine ||
                              q->type == t_grouping)) {
                unless (warned) {
                    fprintf(stderr, "Declared and defined but not used:");
                    warned = true;
                }
                fprintf(stderr, " "); report_b(stderr, q->b);
            }
            q = q->next;
        }
        if (warned) fprintf(stderr, "\n");
    }
}

extern struct analyser * create_analyser(struct tokeniser * t) {
    NEW(analyser, a);
    a->tokeniser = t;
    a->nodes = 0;
    a->names = 0;
    a->literalstrings = 0;
    a->program = 0;
    a->amongs = 0;
    a->among_count = 0;
    a->groupings = 0;
    a->mode = m_forward;
    a->modifyable = true;
    { int i; for (i = 0; i < t_size; i++) a->name_count[i] = 0; }
    a->substring = 0;
    return a;
}

extern void close_analyser(struct analyser * a) {
    {
        struct node * q = a->nodes;
        until (q == 0) {
            struct node * q_next = q->next;
            FREE(q);
            q = q_next;
        }
    }
    {
        struct name * q = a->names;
        until (q == 0) {
            struct name * q_next = q->next;
            lose_b(q->b); FREE(q);
            q = q_next;
        }
    }
    {
        struct literalstring * q = a->literalstrings;
        until (q == 0) {
            struct literalstring * q_next = q->next;
            lose_b(q->b); FREE(q);
            q = q_next;
        }
    }
    {
        struct among * q = a->amongs;
        until (q == 0) {
            struct among * q_next = q->next;
            FREE(q->b); FREE(q);
            q = q_next;
        }
    }
    {
        struct grouping * q = a->groupings;
        until (q == 0) {
            struct grouping * q_next = q->next;
            lose_b(q->b); FREE(q);
            q = q_next;
        }
    }
    FREE(a);
}

