/*---------------------------------------------------------------------------
 * LPC-Compiler: Preprocessor and Lexical Analysis.
 *
 *---------------------------------------------------------------------------
 * The lexer is initialised by a call to init_lexer(). This function sets
 * up the internal tables and also reads the permanent defines from
 * the lpc_predefs list the caller set up before the call.
 *
 * A new compilation is set up by a call to start_new_file(), passing
 * the filedescriptor of the file to compile as argument. Control is
 * then passed to the parser in prolang, which calls yylex() here to
 * get the next token. After the compilation is finished, end_new_file()
 * performs the cleanup.
 *
 * The lexer also holds the table of instructions (instrs[]) and the
 * driver's own ctype tables. Both are included from the file efun_defs.c
 * which is generated by the program make_func during the building
 * process.
 *
 * For an explanation of the datastructures look at the places of
 * definition of the structures - it's too much to put here, too.
 *---------------------------------------------------------------------------
 */

#include "driver.h"

#include "my-alloca.h"
#include <stdio.h>
#include <fcntl.h>
#include <ctype.h>
#include <stddef.h>
#include <string.h>
#include <sys/types.h>
#include <sys/stat.h>
#ifdef OS2
#include <io.h>
#endif

#include "lex.h"

#include "array.h"
#include "backend.h"
#include "closure.h"
#include "comm.h"
#include "exec.h"
#include "filestat.h"
#include "gcollect.h"
#include "hash.h"
#include "instrs.h"
#include "main.h"
#include "patchlevel.h"
#include "prolang.h"
#include "simulate.h"
#include "simul_efun.h"
#include "stralloc.h"
#include "strfuns.h"

/* TODO: Use get_host_name() instead of gethostname()
 * TODO: Implement the # and ## operators.
 * TODO: New predefs' __DRIVER_VERSION__, _REVISION__, _PATCHLEVEL__, __PATH__
 * TODO:: and __BASENAME__.
 * TODO: #define macro(a,b,...) -> ... is assigned to __VA_ARGS__ (see oncoming
 * TODO:: C standard).
 * TODO: Does Standard-C allow recursive macro expansion? If not, we
 * TODO:: should disallow it, too.
 */

#ifdef AMIGA
#    include "hosts/amiga/socket.h"
#endif

#if defined(hpux) && !defined(__GNUC__)
/* This compilers handling of (char) is broken */
#    define CHAR_EOF EOF
#else
#    define CHAR_EOF ((char)EOF)
#endif

/*-------------------------------------------------------------------------*/

#define MLEN   4096
  /* Maximum length of a macro text (definition)
   */

#define NSIZE  256
  /* Maximum length of a macro (argument) name.
   */

#define NARGS 25
  /* Max number of macro arguments
   */

#define EXPANDMAX 25000
  /* Maximum number of expansions per line.
   */

#define MAXLINE 2048
  /* Maximum length of an input line.
   */

#define MAX_ANSI_CONCAT 4096
  /* Maximum length of an ANSI-style string literal concatenation.
   */

#define INC_OPEN_BUFSIZE 1024
  /* Maximum length of an include filename.
   */

#ifndef DEFMAX
#    define DEFMAX 12000
#endif
  /* Maximum length of an expanded macro.
   */

#define MAX_TOTAL_BUF 400000
  /* Maximum length of macro expansion buffer
   */

#define DEFBUF_1STLEN (DEFMAX+MAXLINE+1)
  /* Initial length of macro expansion buffer, enough
   * to allow DEFMAX + an input line + '\0'
   */

/*-------------------------------------------------------------------------*/

int current_line;
  /* Number of the current line.
   */

int total_lines;
  /* Total number of lines compiled so far (used to compute the average
   * compiled lines/s)
   */

char *current_file;
  /* Name of the file currently compiled.
   */

Bool pragma_use_local_scopes;
  /* True: treat all local scopes as one.
   */

Bool pragma_strict_types;
  /* True: enforce usage of strict types.
   */
Bool pragma_save_types;
  /* True: save argument types after compilation.
   */
Bool pragma_combine_strings;
  /* True: perform '+'-addition of constant strings at compile time.
   */
Bool pragma_verbose_errors;
  /* True: give info on the context of an error.
   */

Bool pragma_no_clone;
  /* True: prevent the object from being clone.
   */

Bool pragma_no_inherit;
  /* True: prevent the program from being inherited.
   */

char *last_lex_string;
  /* When lexing string literals, this is the (shared) string lexed
   * so far. It is used to pass string values to lang.c .
   */

struct lpc_predef_s *lpc_predefs = NULL;
  /* List of macros predefined by other parts of the driver, especially from
   * main.c for the '-D' commandline option.
   */

/*-------------------------------------------------------------------------*/
/* The lexer uses a combined file-input/macro-expansion buffer
 * called defbuf[] of length <defbuf_len>. Within this buffer, the last
 * MAXLINE bytes are reserved as (initial) file-input buffer, its beginning
 * and end marked with the pointers linebufstart and linebufend. In this
 * space, pointer outp points to the next character to process.
 *
 * The file-input buffer may contain several textlines, all terminated
 * with a '\n'. After the last (complete) textline, a '\0' is set as
 * sentinel. Usually this will overwrite the first character of the
 * incomplete line right at the end of the input buffer, therefore this
 * character is stored in the variable saved_char.
 *
 * When all lines in the buffer have been processed (ie. outp points to
 * the '\0' sentinel), the remaining fragment of the yet incomplete line
 * is copied _before_ linebufstart (and outp set accordingly), then
 * the next MAXLINE bytes are read into the buffer starting at
 * linebufstart.
 *
 * If there are less than MAXLINE bytes left to read, the end of the file
 * is marked in the buffer with the EOF character (a \0 sentinel is not
 * necessary as compilation and thus lexing will end with the EOF
 * character).
 *
 * When including files, a new area of MAXLINE bytes is reserved in defbuf,
 * which ends exactly at the current outp. The position of the current
 * area is recorded with the current position of linebufstart relative to
 * the end of defbuf. Obviously this can be repeated until the max size
 * of defbuf (MAX_TOTAL_BUF) is reached.
 *
 * Macro expansions are done such that the replacement text for a macro
 * copied right before outp (which at that time points at the character
 * after the macro use), then outp is set back to point at the beginning
 * of the added text, lexing the just expanded text next.
 *
 * Functionals (inline functions) are somewhat similar to macros. When a
 * definition '(: ... :)' is encountered, a copy of text between the
 * delimiters is stored verbatim in the list of inline functions, starting at
 * first_inline_fun. To the compiler the lexer returns F_INLINE_FUN with the
 * synthetic identifier of the function. Whenever such functions are pending
 * and the compiler is at a safe place to accept a function definition
 * (signalled in insert_inline_fun_now), the text of the pending functions is
 * inserted into the input stream like a macro.
 */

static int yyin_des;
  /* Filedescriptor of the file currently read.
   */

static char *defbuf = NULL;
  /* The combined input/expansion buffer.
   */

static unsigned long defbuf_len = 0;
  /* Current length of defbuf.
   */

static char *outp;
  /* Pointer to the next character in defbuf[] to be processed.
   */

static char *linebufstart;
  /* Begin of the input line buffer within defbuf[].
   */

static char *linebufend;
  /* End of the input line buffer within defbuf[].
   */

static char saved_char;
  /* The first character of the incomplete line after the last complete
   * one in the input buffer. Saved here because in the buffer itself
   * it is overwritten with '\0'.
   */

/*-------------------------------------------------------------------------*/

static Bool lex_fatal;
  /* True: lexer encountered fatal error.
   */

static struct svalue *inc_list;
  /* An array of pathnames to search for <>-include files.
   * This is a pointer to the vector.item[] held in the driver_hook[]
   * array.
   */

static size_t inc_list_size;
  /* The number of names in <inc_list>.
   */

static mp_int inc_list_maxlen;
  /* The lenght of the longest name in <inc_list>.
   */

static char * auto_include_string = NULL;
  /* Shared string to be compiled as the very first thing in every lpc
   * source file. It may contain any text which is valid in a file.
   */

static int auto_include_start;
  /* Number of 'lines' contained in <auto_include_string>, stored
   * as negative value.
   */

static int nexpands;
  /* Number of macro expansions on this line so far.
   */

static char yytext[MAXLINE];
  /* Temporary buffer used to collect data.
   */


/*-------------------------------------------------------------------------*/

static struct ident *ident_table[ITABLE_SIZE];
  /* The lexer stores all encountered identifiers in a hashtable of struct
   * idents. The table follows the usual structure: the index (hash value)
   *  is computed from the name of the identifier, the indexed table element
   * the points to the head of a chain of different identifier values with
   * identical hash. The most recently used identifier is always moved to
   * the head of the chain.
   *
   * The table is used to store all identifiers and their value: starting
   * from efun names and reserved words (like 'while') over preprocessor
   * macros to 'normal' lfun and variable names. The identifiers are
   * distinguished by the .type field in the ident structure. Should one
   * identifier used with several different types at the same time, one entry
   * is generated for each type, and they are all linked together by their
   * .inferior pointers into a list ordered by falling type value. The entry
   * with the highest type value is the one put into the hashtable's chain.
   */

#if ITABLE_SIZE == 256
#    define identhash(s) chashstr((s), 12)
#else
#    define identhash(s) (whashstr((s), 12) % ITABLE_SIZE)
#endif
  /* Hash an identifier name into a table index.
   */

  /* In addition to this, the lexer keeps two lists for all efuns and
   * preprocessor defines: all_efuns and all_defines. These are linked
   * together with the .next_all field in the ident structure.
   */

struct ident *all_efuns = NULL;
  /* The list of efuns. */

static struct ident *all_defines = NULL;
  /* The list of all non-permanent macro defines.
   * Entries with a NULL .name are undefined macros.
   */

static struct ident *permanent_defines = NULL;
  /* The list of all permanent macro defines. */


static struct ident *undefined_permanent_defines = NULL;
  /* 'Parking list' for permanent defines which have been #undef'ined.
   * After the compilation is complete, they will be put back into
   * the ident_table.
   */

/*-------------------------------------------------------------------------*/

struct inline_fun * first_inline_fun = NULL;
  /* Linked list of the saved function text for inline functions.
   */

Bool insert_inline_fun_now = MY_FALSE;
  /* This is TRUE when we are at a suitable point to insert the
   * saved inline functions. Usually this is at the end of a function,
   * or after a global variable definition.
   */

int next_inline_fun = 0;
  /* The running count of inline functions, used to 'name' the next
   * function to generate.
   */

/*-------------------------------------------------------------------------*/

/* The stack to handle nested #if...#else...#endif constructs.
 */

static struct ifstate
{
    struct ifstate *next;
    int             state;  /* which token to expect */
} *iftop = NULL;

/* struct ifstate.state values: */

#define EXPECT_ELSE  1
#define EXPECT_ENDIF 2

/*-------------------------------------------------------------------------*/

/* The stack to save important state information when handling
 * nested includes.
 */

static struct incstate
{
    struct incstate * next;

    int         yyin_des;       /* The file's filedescriptor */
    int         line;           /* Current line */
    char      * file;           /* Filename */
    ptrdiff_t   linebufoffset;  /* Position of linebufstart */
    int pragma_strict_types;
    char saved_char;
} *inctop = NULL;

/*-------------------------------------------------------------------------*/

/* Translation table of reserved words into the lexcodes assigned by yacc
 * in lang.h.
 */

struct s_reswords
{
    char *name;  /* The reserved word */
    int   code;  /* The assigned code */
};

static struct s_reswords reswords[]
 = { { "break",          F_BREAK,        }
   , { "case",           F_CASE,         }
   , { "catch",          F_CATCH,        }
   , { "closure",        F_CLOSURE_DECL, }
   , { "continue",       F_CONTINUE,     }
   , { "default",        F_DEFAULT,      }
   , { "do",             F_DO,           }
   , { "else",           F_ELSE,         }
   , { "float",          F_FLOAT_DECL,   }
   , { "for",            F_FOR,          }
   , { "if",             F_IF,           }
   , { "inherit",        F_INHERIT,      }
   , { "int",            F_INT,          }
   , { "mapping",        F_MAPPING,      }
   , { "mixed",          F_MIXED,        }
   , { "nomask",         F_NO_MASK,      }
   , { "object",         F_OBJECT,       }
#ifdef SUPPLY_PARSE_COMMAND
   , { "parse_command",  F_PARSE_COMMAND, }
#endif
   , { "private",        F_PRIVATE,      }
   , { "protected",      F_PROTECTED,    }
   , { "public",         F_PUBLIC,       }
   , { "return",         F_RETURN,       }
   , { "sscanf",         F_SSCANF,       }
   , { "static",         F_STATIC,       }
   , { "status",         F_STATUS,       }
   , { "string",         F_STRING_DECL,  }
   , { "switch",         F_SWITCH,       }
   , { "symbol",         F_SYMBOL_DECL,  }
   , { "varargs",        F_VARARGS,      }
   , { "virtual",        F_VIRTUAL,      }
   , { "void",           F_VOID,         }
   , { "while",          F_WHILE,        }
   };

/*-------------------------------------------------------------------------*/

/* The definitions and tables for the preprocessor expression evaluator.
 */


#define BNOT   1  /* Unary operator opcodes*/
#define LNOT   2
#define UMINUS 3
#define UPLUS  4

#define MULT   1  /* Binary operator opcodes */
#define DIV    2
#define MOD    3
#define BPLUS  4
#define BMINUS 5
#define LSHIFT 6
#define RSHIFT 7
#define LESS   8
#define LEQ    9
#define GREAT 10
#define GEQ   11
#define EQ    12
#define NEQ   13
#define BAND  14
#define XOR   15
#define BOR   16
#define LAND  17
#define LOR   18
#define QMARK 19

  /* lookup table for initial operator characters.
   * The table covers the characters [' '..'~'].
   * 0 for no operator, else index into optab2.
   */
static char _optab[]
 = {0,6,0,0,0,46,50,0,0,0,2,18,0,14,0,10,0,0,0,0,0,0,0,0,0,0,0,0,22,42,32,68,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,64,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,57,0,1
 };

  /* Lookup table for the complete operator data in a serial format.
   *
   * optab2[index-1] : operation code for unary operator, 0 for none.
   * optab2[index+0 .. +3 .. +6 ...] :
   * two character binary operators: second character, operation code, prio
   * one character binary operator & end: 0,           operation code, prio
   * end: 0, 0
   *
   * Note that some entries overlap.
   */
static char optab2[]
  = { BNOT, 0                                 /*  1: ~         */
    ,         0,   MULT,   11                 /*  2: *         */
    , LNOT,   '=', NEQ,     7                 /*  6: !, !=     */
    , 0,      0,   DIV,    11                 /* 10: /         */
    , UMINUS, 0,   BMINUS, 10                 /* 14: -x, x-y   */
    , UPLUS,  0,   BPLUS,  10                 /* 18: +x, x+y   */
    , 0,      '<', LSHIFT,  9, '=', LEQ,  8, 0, LESS,  8
                                              /* 22: <<, <=, < */
    , 0,      '>', RSHIFT,  9, '=', GEQ,  8, 0, GREAT, 8
                                              /* 32: >>, >=, > */
    , 0,      '=', EQ,      7                 /* 42: ==        */
    , 0,      0,   MOD,    11                 /* 46: %         */
    , 0,      '&', LAND,    3, 0,   BAND, 6   /* 50: &&, &     */
    , 0,      '|', LOR,     2, 0,   BOR,  4   /* 57: ||, |     */
    , 0,      0,   XOR,     5                 /* 64: ^         */
    , 0,      0,   QMARK,   1                 /* 68: ?         */
};

#define optab1 (_optab-' ')
  /* Use optab1 to index _optab with raw characters.
   */

/*-------------------------------------------------------------------------*/

  /* A handy macro to statically determine the number of
   * elements in an array.
   */
#define NELEM(a) (sizeof (a) / sizeof (a)[0])

  /* Save the character in variable 'c' in the yytext buffer, if
   * there is enough space left.
   */
#define SAVEC \
    if (yyp < yytext+MAXLINE-5)\
       *yyp++ = (char)c;\
    else {\
       lexerror("Line too long");\
       break;\
    }

  /* The magic character used for function macros to mark the places
   * in the replacement text where the macro arguments are to be
   * inserted.
   * The marking sequence for argument n is { '@', '@'+n+1 }, and
   * the character '@' itself is stored as { '@', '@' }.
   */
#define MARKS '@'

/*-------------------------------------------------------------------------*/
/* Forward declarations */

static INLINE int number(long);
static INLINE int string(char *);
static void handle_define(char *, Bool);
static void add_define(char *, short, char *);
static void add_permanent_define(char *, short, void *, Bool);
static Bool expand_define(void);
static Bool _expand_define(struct defn*);
static INLINE void myungetc(char);
static int cond_get_exp(int, struct svalue *);
static int exgetc(void);
static char *get_current_file(char **);
static char *get_current_line(char **);
static char *get_version(char **);
static char *get_hostname(char **);
static char *get_domainname(char **);
static char *efun_defined(char **);
static void lexerror(char *);
static struct ident *lookup_define(char *);

/*-------------------------------------------------------------------------*/

#include "efun_defs.c"

/* struct instr instrs[] = { ... };
 *
 * Information about all instructions and efuns, generated by make_func.
 * Also included are the table for our own ctype functions.
 *
 * The numbers of arguments are used by the compiler.
 * If min == max, then no information has to be coded about the
 * actual number of arguments. Otherwise, the actual number of arguments
 * will be stored in the byte after the instruction.
 * A maximum value of -1 means unlimited maximum value.
 *
 * If an argument has type 0 (T_INVALID) specified, then no checks will
 * be done at run time.
 *
 * The argument types are checked by the compiler if type checking is enabled,
 * and always at runtime.
 */

/*-------------------------------------------------------------------------*/
void
init_lexer(void)

/* Initialize the various lexer tables, including the predefined macros
 * from the commandline given in lpc_predefs.
 * The lpc_predefs list is deallocated by this call.
 */

{
    size_t i, n;
    char mtext[MLEN];
    static short binary_operators[]
      = { F_ADD, F_SUBTRACT, F_MULTIPLY, F_DIVIDE, F_MOD
        , F_LT, F_GT, F_EQ, F_GE, F_LE, F_NE
        , F_OR, F_XOR, F_LSH, F_RSH
        , F_INDEX, F_RINDEX, F_EXTRACT2
        };
    static short ternary_operators[]
      = { F_RANGE, F_NR_RANGE, F_RR_RANGE, F_RN_RANGE
        , F_MAP_INDEX
        };

    /* Clear the table of identifiers */
    for (i = 0; i < ITABLE_SIZE; i++)
        ident_table[i] = NULL;

    /* For every efun, create a global entry in ident_table[] */
    for (n = 0; n < NELEM(instrs); n++)
    {
        struct ident *p;

        if (instrs[n].Default == -1)
            continue;

        p = make_shared_identifier(instrs[n].name, I_TYPE_GLOBAL, 0);
        if (!p)
            fatal("Out of memory\n");
        p->type = I_TYPE_GLOBAL;
        p->u.global.efun     =  (short)n;
        p->u.global.sim_efun = -1;
        p->u.global.function = -2;
        p->u.global.variable = -2;
        p->next_all = all_efuns;
        all_efuns = p;
    }

    /* For every reserved word, create a global entry in ident_table[] */
    for (i = 0; i < NELEM(reswords); i++)
    {
        struct ident *p;

        p = make_shared_identifier(reswords[i].name, I_TYPE_RESWORD, 0);
        if (!p)
            fatal("Out of memory\n");
        p->type = I_TYPE_RESWORD;
        p->u.code = reswords[i].code;
    }

    /* Operators are difficult to specify properly in func_spec syntax,
     * therefore update their instrs[] entries manually.
     */
    for (i = 0; i < NELEM(binary_operators); i++)
    {
        n = (unsigned)binary_operators[i] - F_OFFSET;
        instrs[n].min_arg = instrs[n].max_arg = 2;
        instrs[n].Default = 0;
        instrs[n].ret_type = TYPE_ANY;
    }
    for (i=0; i<NELEM(ternary_operators); i++)
    {
        n = (unsigned)ternary_operators[i] - F_OFFSET;
        instrs[n].min_arg = instrs[n].max_arg = 3;
        instrs[n].Default = 0;
        instrs[n].ret_type = TYPE_ANY;
    }
    n = F_AND - F_OFFSET;
        instrs[n].min_arg = instrs[n].max_arg = 2;
        instrs[n].ret_type = TYPE_ANY;
    n = F_COMPL - F_OFFSET;
        instrs[n].min_arg = instrs[n].max_arg = 1;
        instrs[n].Default = 0;
        instrs[n].ret_type = TYPE_ANY;
    n = F_NOT - F_OFFSET;
        instrs[n].min_arg = instrs[n].max_arg = 1;
        instrs[n].ret_type = TYPE_ANY;


    /* Add the standard permanent macro definitions */

    add_permanent_define("LPC3", -1, string_copy(""), MY_FALSE);
#ifdef COMPAT_MODE
        add_permanent_define("COMPAT_FLAG", -1, string_copy(""), MY_FALSE);
        add_permanent_define("__COMPAT_MODE__", -1, string_copy(""), MY_FALSE);
#endif
    add_permanent_define("__EUIDS__", -1, string_copy(""), MY_FALSE);
    if (strict_euids)
        add_permanent_define("__STRICT_EUIDS__", -1, string_copy(""), MY_FALSE);

#ifdef COMPAT_MODE
    mtext[0] = '"';
    strcpy(mtext+1, master_name);
    strcat(mtext+1, "\"");
#else
    mtext[0] = '"';
    mtext[1] = '/';
    strcpy(mtext+2, master_name);
    strcat(mtext+2, "\"");
#endif
    add_permanent_define("__MASTER_OBJECT__", -1, string_copy(mtext), MY_FALSE);
    add_permanent_define("__FILE__", -1, (void *)get_current_file, MY_TRUE);
    add_permanent_define("__LINE__", -1, (void *)get_current_line, MY_TRUE);
    add_permanent_define("__VERSION__", -1, (void *)get_version, MY_TRUE);
    add_permanent_define("__HOST_NAME__", -1, (void *)get_hostname, MY_TRUE);
    add_permanent_define("__DOMAIN_NAME__", -1, (void *)get_domainname, MY_TRUE);
    add_permanent_define("__HOST_IP_NUMBER__", -1
                        , (void*)get_host_ip_number, MY_TRUE);
    sprintf(mtext, "%d", MAX_USER_TRACE);
    add_permanent_define("__MAX_RECURSION__", -1, string_copy(mtext), MY_FALSE);
    add_permanent_define("__EFUN_DEFINED__", 1, (void *)efun_defined, MY_TRUE);
#ifdef ERQ_DEMON
    sprintf(mtext, "%d", ERQ_MAX_SEND);
    add_permanent_define("__ERQ_MAX_SEND__", -1, string_copy(mtext), MY_FALSE);
    sprintf(mtext, "%d", ERQ_MAX_REPLY);
    add_permanent_define("__ERQ_MAX_REPLY__", -1, string_copy(mtext), MY_FALSE);
#endif
    sprintf(mtext, "%ld", def_eval_cost);
    add_permanent_define("__MAX_EVAL_COST__", -1, string_copy(mtext), MY_FALSE);

    /* Add the permanent macro definitions given on the commandline */

    while (NULL != lpc_predefs)
    {
        char namebuf[NSIZE];
        struct lpc_predef_s *tmpf;

        tmpf = lpc_predefs;
        lpc_predefs = lpc_predefs->next;

        *mtext = '\0';
        sscanf(tmpf->flag, "%[^=]=%[ -~=]", namebuf, mtext);
        if ( strlen(namebuf) >= NSIZE )
            fatal("-D%s: macroname too long (>%d)\n", tmpf->flag, NSIZE);
        if ( strlen(mtext) >= MLEN )
            fatal("-D%s: macrotext too long (>%d)\n", tmpf->flag, MLEN);
        add_permanent_define(namebuf, -1, string_copy(mtext), MY_FALSE);

        xfree(tmpf->flag);
        xfree(tmpf);
    }
} /* init_lexer() */

/*-------------------------------------------------------------------------*/
struct ident *
make_shared_identifier (char *s, int n, int depth)

/* Find and/or add identifier <s> of type <n> to the ident_table, and
 * return a pointer to the found/generated struct ident. New generated
 * entries have their type set to I_TYPE_UNKNOWN regardless of <n>.
 * Local identifiers (<n> == I_TYPE_LOCAL) are additionally distinguished by
 * their definition <depth>.
 *
 * If an identifier with the same name but a lower type exists in the table,
 * it is shifted down: a new entry for this name created and put into the
 * table, the original entry is referenced by the .inferior pointer in the
 * new entry. The same happens when a new LOCAL of greater depth is
 * added to an existing LOCAL of smaller depth.
 *
 * Return NULL when out of memory.
 */

{
    struct ident *curr, *prev;
    int   h;
    char *str;

#if defined(LEXDEBUG)
    printf("make_shared_identifier called:%s\n",s);
#endif

    h = identhash(s);  /* the identifiers hash code */

    /* look for the identifier in the table */

    curr = ident_table[h];
    prev = NULL;
    while (curr)
    {
#if defined(LEXDEBUG)
        printf("checking %s.\n", curr->name);
#endif
        if (!strcmp(curr->name, s)) /* found it */
        {
#if defined(LEXDEBUG)
            printf("found.\n");
#endif
            /* Move the found entry to the head of the chain */
            if (prev) /* not at head of chain */
            {
                prev->next = curr->next;
                curr->next = ident_table[h];
                ident_table[h] = curr;
            }

            /* If the found entry is of inferior type, shift it down */
            if (n > curr->type
             || (   I_TYPE_LOCAL == curr->type && I_TYPE_LOCAL == n
                 && depth > curr->u.local.depth)
               )
            {
                struct ident *inferior = curr;

#if defined(LEXDEBUG)
                printf("shifting down inferior.\n");
#endif
                curr = xalloc(sizeof *curr);
                if ( NULL != curr )
                {
                    curr->name = inferior->name;
                    curr->next = inferior->next;
                    curr->type = I_TYPE_UNKNOWN;
                    curr->inferior = inferior;
                    curr->hash = (short)h;
                    ident_table[h] = curr;
                }
            }

            /* Return the found (or generated) entry */
            return curr;
        }

        prev = curr;
        curr = curr->next;
    }

    /* Identifier is not in table, so create a new entry */

    str = make_shared_string(s);
    if (!str)
        return NULL;
    curr = xalloc(sizeof *curr);
    if (!curr)
    {
        free_string(str);
        return NULL;
    }

    curr->name = str;
    curr->next = ident_table[h];
    curr->type = I_TYPE_UNKNOWN;
    curr->inferior = NULL;
    curr->hash = (short)h;
    ident_table[h] = curr;

    return curr;
} /* make_shared_identifier() */

/*-------------------------------------------------------------------------*/
void
free_shared_identifier (struct ident *p)

/* Remove the identifier <p> (which may be an inferior entry ) from the
 * identifier table.
 * It is a fatal error if it can't be found.
 */

{
    struct ident *curr, **q;
    int  h;
    char *s;

    h = p->hash;

    q = &ident_table[h];
    curr = *q;
    s = p->name;

#if defined(LEXDEBUG)
    printf("freeing '%s'\n",s);
    fflush(stdout);
#endif

    /* Look for the hashed entry with the same name */

    while (curr)
    {
        if (curr->name == s
#if DEBUG
         || !strcmp(curr->name, s)
#endif

           ) /* found matching name */
        {
            struct ident *first = curr;

            /* Search the list of inferiors for entry <p> */

            while (curr)
            {
                if (curr == p) /* this is the right one */
                {
                    /* Remove the entry from the inferior list */

                    if (first == curr)
                    {
                        if (curr->inferior)
                        {
                            curr->inferior->next = curr->next;
                            *q = curr->inferior;
                            xfree(curr);
                            return; /* success */
                        }
                        *q = curr->next;
                        free_string(curr->name);
                        xfree((char *)curr);
                        return;
                    }

                    *q = curr->inferior;
                    xfree((char *)curr);
                    return; /* success */
                }
                q = &curr->inferior;
                curr = *q;
            }
            fatal("free_shared_identifier: entry '%s' not found!\n", p->name);
            /* NOTREACHED */
        }

        q = &curr->next;
        curr = *q;
    } /* not found */

    fatal("free_shared_identifier: name '%s' not found!\n", p->name);
    /* NOTREACHED */
} /* free_shared_identifier() */

/*-------------------------------------------------------------------------*/
static void
realloc_defbuf (void)

/* Increase the size of defbuf[] (unless it would exceed MAX_TOTAL_BUF).
 * The old content of defbuf[] is copied to the end of the new buffer.
 * outp is corrected to the new position, other pointers into defbuf
 * become invalid.
 */

{
    char * old_defbuf = defbuf;
    size_t old_defbuf_len = defbuf_len;
    char * old_outp = outp;
    ptrdiff_t outp_off;

    if (MAX_TOTAL_BUF <= defbuf_len)
      return;

    outp_off = &defbuf[defbuf_len] - outp;

    /* Double the current size of defbuf, but top off at MAX_TOTAL_BUF. */
    if (defbuf_len > (MAX_TOTAL_BUF >> 1) )
    {
        defbuf_len = MAX_TOTAL_BUF;
    } else {
        defbuf_len <<= 1;
    }
    if (comp_flag)
        fprintf(stderr, "(reallocating defbuf from %ld (%ld left) to %ld) "
               , (long)old_defbuf_len, (long)(old_outp-defbuf), defbuf_len);
    defbuf = xalloc(defbuf_len);
    memcpy(defbuf+defbuf_len-old_defbuf_len, old_defbuf, old_defbuf_len);
    xfree(old_defbuf);
    outp = &defbuf[defbuf_len] - outp_off;
} /* realloc_defbuf() */

/*-------------------------------------------------------------------------*/
static /* NO inline */ char *
_myfilbuf (void)

/* Read the next MAXLINE bytes from the inputfile <yyin_des> and store
 * them in the input-buffer. If there were the beginning of an incomplete
 * line left in the buffer, they are copied right before linebufstart.
 * The end of the last complete line in the buffer is marked with a '\0'
 * sentinel, or, if the file is exhausted, the end of data is marked
 * with the EOF char.
 *
 * outp is set to point to the new data (which may be the copied remnants
 * from the incomplete line) and also returned as result.
 *
 * The function must not be called unless all lines in the buffer have
 * been processed. This macro */

#define myfilbuf() (*outp?0:_myfilbuf())

 /* takes care of that.
  */

{
    int i;
    char *p;

    /* Restore the data clobbered by the old sentinel */
    *outp = saved_char;

    /* Copy any remnants of an incomplete line before the buffer begin
     * and reset outp.
     */
    if (linebufend - outp)
        memcpy(outp-MAXLINE, outp, (size_t)(linebufend - outp));
    outp -= MAXLINE;

    *(outp-1) = '\n'; /* so an ungetc() gives a sensible result */

    /* Read the next block of data */
    p = linebufstart; /* == linebufend - MAXLINE */
    i = read(yyin_des, p, MAXLINE);

    if (i < MAXLINE)
    {
        /* End of file or error: put in the final EOF marker */

        if (i < 0)
        {
            i = 0;
        }

        p += i;
        if (p - outp ? p[-1] != '\n' : current_line == 1)
            *p++ = '\n';
        *p++ = EOF;
        return outp;
    }

    /* Buffer filled: mark the last line with the '\0' sentinel */
    p += i;
    while (*--p != '\n') NOOP; /* find last newline */
    if (p < linebufstart)
    {
        lexerror("line too long");
        *(p = linebufend-1) = '\n';
    }
    p++;
    saved_char = *p;
    *p = '\0';

    return outp;
} /* _myfilbuf() */

/*-------------------------------------------------------------------------*/
static void
add_input (char *p)

/* Copy the text <p> into defbuf[] right before the current position of
 * outp and set outp back to point at the beginning of the new text.
 *
 * Main use is by the macro expansion routines.
 */
{
    size_t l = strlen(p);

#if defined(LEXDEBUG)
    if (l > 0)
        fprintf(stderr, "add '%s'\n", p);
#endif
    if ((ptrdiff_t)l > outp - &defbuf[10])
    {
        lexerror("Macro expansion buffer overflow");
        return;
    }

    outp -= l;
    strncpy(outp, p, l);
}

/*-------------------------------------------------------------------------*/
static INLINE char
mygetc (void)

/* Retrieve the next character from the file input buffer.
 */

{
#if 0
    fprintf(stderr, "c='%c' %x", *outp, *outp);
#endif
#if defined(LEXDEBUG)
    putc(*outp, stderr);
    fflush(stderr);
#endif
    return *outp++;
}

/*-------------------------------------------------------------------------*/
static INLINE void
myungetc (char c)

/* Store character <c> in the file input buffer so the next mygetc()
 * can retrieve it.
 */

{
    *--outp = c;
}

/*-------------------------------------------------------------------------*/
static INLINE Bool
gobble (char c)

/* Skip the next character in the input buffer if it is <c> and return true.
 * If the next character is not <c>, don't advance in the buffer and
 * return false.
 */

{
    if (c ==  mygetc())
        return MY_TRUE;
    --outp;
    return MY_FALSE;
}

/*-------------------------------------------------------------------------*/
static void
lexerror (char *s)

/* The lexer encountered fatal error <s>. Print the error via yyerror()
 * and set lex_fatal.
 */

{
    yyerror(s);
    lex_fatal = MY_TRUE;
}

/*-------------------------------------------------------------------------*/
static Bool
skip_to (char *token, char *atoken)

/* Skip the file linewise until one of the following preprocessor statements
 * is encountered:
 *   #<token> : returns true, outp is set to the following line.
 *   #<atoken>: returns false, outp is set to the following line.
 *   #elif    : returns false, the statement is rewritten to #if and
 *                outp is set to point to the '#' in the new statement.
 * If an end of file occurs, an error is generated and the function returns
 * true after setting outp to the character before the EOF.
 *
 * Nested #if ... #endif blocks are skipped altogether.
 *
 * <atoken> may be the NULL pointer and is ignored in that case.
 */

{
    char *p;  /* Local copy of outp */
    char *q;  /* The start of the preprocessor statement */
    char c;
    char nl = '\n';
    int nest; /* Current nesting depth of #if...#endif blocks */

    p = outp;

    for (nest = 0; ; ) {
        current_line++;
        total_lines++;
        c = *p++;

        if (c == '#')
        {
            /* Parse the preprocessor statement */

            /* Set q to the first non-blank character of the keyword */
            while(lexwhite(*p++)) NOOP;
            q = --p;

            /* Mark the end of the preprocessor keyword with \0 */
            while (isalunum(*p++)) NOOP;
            c = *--p;  /* needed for eventual undos */
            *p = '\0';

            /* Set p to the first character of the next line */
            if (c != nl)
            {
                while (*++p != nl) NOOP;
            }
            p++;

            /* fprintf(stderr, "skip checks %s\n", q); */

            /* Evaluate the token at <q> */

            if (strcmp(q, "if") == 0
             || strcmp(q, "ifdef") == 0
             || strcmp(q, "ifndef") == 0)
            {
                nest++;
            }
            else if (nest > 0)
            {
                if (strcmp(q, "endif") == 0)
                    nest--;
            }
            else
            {
                if (strcmp(q, token) == 0)
                {
                    *(p-1) = nl;
                    outp = p;
                    if (!*p)
                    {
                        _myfilbuf();
                    }
                    return MY_TRUE;
                }
                else if (atoken)
                {
                    if (strcmp(q, atoken) == 0)
                    {
                        *(p-1) = nl;
                        outp = p;
                        if (!*p) {
                            _myfilbuf();
                        }
                        return MY_FALSE;
                    }
                    else if (strcmp(q, "elif") == 0)
                    {
                        current_line--;
                        total_lines--;
                        q[0] = nl;
                        q[1] = '#';
                        q[4] = c;   /* undo the '\0' */
                        outp = q+1;
                        return MY_FALSE;
                    }
                }
            }
        }
        else /* not a preprocessor statement */
        {
            /* fprintf(stderr, "skipping (%d) %c", c, c); */
            if (c == CHAR_EOF)
            {
                outp = p - 2;
                current_line--;
                total_lines--;
                lexerror("Unexpected end of file while skipping");
                return MY_TRUE;
            }

            /* Skip the rest of the line */
            while (c != nl) c = *p++;
        }

        /* Read new data from the file if necessary */
        if (!*p)
        {
            outp = p;
            p = _myfilbuf();
        }
    } /* for () */

    /* NOTREACHED */
} /* skip_to() */

/*-------------------------------------------------------------------------*/
static void
handle_cond (Bool c)

/* Evaluate the boolean condition <c> of a preprocessor #if statement.
 * If necessary, skip to the condition branch to read next, and/or
 * push a new state onto the ifstate-stack.
 */
{
    struct ifstate *p;

    /* fprintf(stderr, "cond %d\n", c); */
    if (c || skip_to("else", "endif")) {
        /* TODO: Use pooled memory here */
        p = (struct ifstate *)xalloc(sizeof(struct ifstate));
        p->next = iftop;
        iftop = p;
        p->state = c ? EXPECT_ELSE : EXPECT_ENDIF;
    }
}

/*-------------------------------------------------------------------------*/
static void
merge (char *name, mp_int namelen, char *deststart)

/* Take the given include file <name> of length <namelen>, make it
 * a proper absolute pathname and store it into the buffer <deststart>.
 * This buffer must be at least INC_OPEN_BUFSIZE bytes big.
 * On a failure, return the empty string in *deststart.
 *
 * If <name> is a relative pathname, it is interpreted to the location
 * of <currentfile>. './' and '../' sequences in the name are properly
 * resolved (include from above the mudlib are caught).
 */

{
    char *from;  /* Next character in <name> to process */
    char *dest;  /* Destination pointer into <deststart> */

    from = name;

    /* If <name> is an absolute pathname, skip any leading '/'.
     * Else extract the pathpart from <currentfile>, put
     * it into the destination buffer and set dest to point after it.
     */
    if (*from == '/')
    {
        /* absolute path */

        dest = deststart;
        do from++; while (*from == '/');
    }
    else
    {
        /* relative path */

        char *cp, *dp;

        dest = (dp = deststart) - 1;
        for (cp = current_file; *cp; *dp++ = *cp++)
        {
            if (*cp == '/')
                dest = dp;
        }
        dest++;
    }

    /* Make sure the bufferlimits are not overrun. */
    if ((dest - deststart) + namelen >= INC_OPEN_BUFSIZE)
    {
        *deststart = '\0';
        return;
    }

    /* Append the <name> to the buffer starting at <dest>,
     * collapsing './' and '../' sequences while doing it.
     */
    for (;;)
    {
        /* <from> now points to the character after the last '/'.
         */

        if (*from == '.')
        {
            if (from[1] == '.' && from[2] == '/')
            {
                /* '../': remove the pathpart copied last */

                if (dest == deststart)
                {
                    /* including from above mudlib is NOT allowed */
                    *deststart = '\0';
                    return;
                }

                for (--dest;;)
                {
                    if (*--dest == '/')
                    {
                        dest++;
                        break;
                    }
                    if (dest == deststart)
                        break;
                }
                from += 3;
                continue;

            } else if (from[1] == '/')
            {
                /* just skip these two characters */

                from += 2;
                continue;
            }
        }

        /* Copy all characters up to and including the next '/'
         * from <name> into the destination buffer.
         * Return when at the end of the name.
         */

        {
            char c;

            do {
                c = *from++;
                *dest++ = c;
                if (!c)
                  return;
            } while (c != '/');
            while (*from == '/')
                from++;
        }
    } /* for (;;) */

    /* NOTREACHED */
} /* merge() */

/*-------------------------------------------------------------------------*/
static int
inc_open (char *buf, char *name, mp_int namelen, char delim)

/* Open the include file <name> (length <namelen>) and return the file
 * descriptor. On failure, generate an error message and return -1.
 *
 * <buf> is a buffer of size INC_OPEN_BUFSIZE and may be used to
 * generate the real filename - <name> is just the name given in the
 * #include statement.
 *
 * <delim> is '"' for #include ""-type includes, and '>' else.
 * Relative "-includes are searched relative to the current file.
 * <-includes are searched in the path(s) defined by the H_INCLUDE_DIRS
 * driver hook.
 */

{
    int fd;
    int i;
    struct stat aStat;

    if (delim == '"') /* It's a "-include */
    {
        /* Merge the <name> with the <current_file> name. */
        merge(name, namelen, buf);

        /* Test the file and open it */
        if (!stat(buf, &aStat)
         && S_ISREG(aStat.st_mode)
         && (fd = ixopen(buf, O_RDONLY|O_BINARY)) >= 0)
        {
            FCOUNT_INCL(buf);
            return fd;
        }

        if (errno == EMFILE)
            lexerror("File descriptors exhausted");
#ifdef ENFILE
        if (errno == ENFILE)
            lexerror("File table overflow");
#endif
    }

    /* Handle a '<'-include. */

    if (closure_hook[H_INCLUDE_DIRS].type == T_POINTER)
    {
        /* H_INCLUDE_DIRS is a vector of include directories.
         */

        if (namelen + inc_list_maxlen >= INC_OPEN_BUFSIZE)
        {
            yyerror("Include name too long.");
            return -1;
        }

        /* The filename must not specifiy parent directories */
        if (!check_no_parentdirs(name))
            return -1;

        /* Search all include dirs specified.
         */
        for (i = 0; i < inc_list_size; i++)
        {
            sprintf(buf, "%s%s", inc_list[i].u.string, name);
            if (!stat(buf, &aStat)
             && S_ISREG(aStat.st_mode)
             && (fd = ixopen(buf, O_RDONLY|O_BINARY)) >= 0 )
            {
                FCOUNT_INCL(buf);
                return fd;
            }
            if (errno == EMFILE) lexerror("File descriptors exhausted");
#if ENFILE
            if (errno == ENFILE) lexerror("File table overflow");
#endif
        }

        /* If we come here, the include file was not found */
    }
    else if (closure_hook[H_INCLUDE_DIRS].type == T_CLOSURE)
    {
        /* H_INCLUDE_DIRS is a function generating the full
         * include file name.
         */

        struct svalue *svp;

        /* Setup and call the closure */
        push_string_malloced(name);
        push_volatile_string(current_file);
        if (closure_hook[H_INCLUDE_DIRS].x.closure_type == CLOSURE_LAMBDA)
            closure_hook[H_INCLUDE_DIRS].u.lambda->ob = current_object;
        svp = secure_call_lambda(&closure_hook[H_INCLUDE_DIRS], 2);

        /* The result must be legal relative pathname */

        if (svp && svp->type == T_STRING
         && strlen(svp->u.string) < INC_OPEN_BUFSIZE)
        {
            strcpy(buf, svp->u.string);
            if (legal_path(buf))
            {
                if (!stat(buf, &aStat)
                 && S_ISREG(aStat.st_mode)
                 && (fd = ixopen(buf, O_RDONLY|O_BINARY)) >= 0 )
                {
                    FCOUNT_INCL(buf);
                    return fd;
                }
                if (errno == EMFILE) lexerror("File descriptors exhausted");
#if ENFILE
                if (errno == ENFILE) lexerror("File table overflow");
#endif
            }
        }

        /* If we come here, the include file was not found */
    }

    /* File not found */
    return -1;
} /* inc_open() */

/*-------------------------------------------------------------------------*/
static INLINE void
handle_include (char *name)

/* Handle an #include statement, <name> points to the first non-blank
 * character after the '#include'.
 * If the include succeeds, a new incstate is created and pushed
 * onto the include stack. Else an error message is generated.
 */

{
    char *p;
    int   fd;        /* fd of new include file */
    char  delim;     /* Filename end-delimiter ('"' or '>'). */
    char *old_outp;  /* Save the original outp */
    Bool  in_buffer = MY_FALSE; /* True if macro was expanded */
    ptrdiff_t linebufoffset;  /* Position of current linebufstart */
    char  buf[INC_OPEN_BUFSIZE];

/*fprintf(stderr, "handle include '%s'\n", name);*/
#if 0
    if (nbuf) {
        lexerror("Internal preprocessor error");
        return;
    }
#endif
    old_outp = outp;

    /* If <name> doesn't start with '"' or '<', assume that it
     * is a macro. Attempt to expand these macros until <name>
     * starts with a proper delimiter.
     */
    while (*name != '"' && *name != '<')
    {
        char c;
        struct ident *d;

        /* Locate the end of the macro and look it up */
        for (p = name; isalunum(*p); p++) NOOP;
        c = *p;
        *p = '\0';
        d = lookup_define(name);
        *p = c;

        /* Prepare to expand the macro */
        if (in_buffer)
        {
            outp = p;
        }
        else
        {
            myungetc('\n');
            add_input(p);
            in_buffer = MY_TRUE;
        }

        /* Expand the macro */
        if (!d || !_expand_define(&d->u.define) ) {
            yyerror("Missing leading \" or < in #include");
            return;
        }

        /* Set name to the first non-blank of the expansion */
        name = outp;
        while (lexwhite(*name))
            name++;
    }

    /* Store the delimiter and set p to the closing delimiter */
    delim = (char)((*name++ == '"') ? '"' : '>');
    for(p = name; *p && *p != delim; p++) NOOP;

    if (!*p) {
        yyerror("Missing trailing \" or > in #include");
        outp = old_outp;
        return;
    }
    *p = '\0';

    /* For "-includes, look for following macros or "<path>"
     * fragments on the same line and append these to the <name>.
     * The new name is created in the yytext[] buffer (if at all).
     */

    if (delim == '"')
    {
        char *q;

        q = p + 1;
        for (;;)
        {
            /* Find the first non-blank character after p */
            while(lexwhite(*q))
                q++;
            if (!*q || *q == '\n')
                break;

            /* First, try to expand a macros */
            while (*q != delim)
            {
                char *r, c;
                struct ident *d;

                /* Set r to the first blank after the macro name */
                for (r = q; isalunum(*r); r++) NOOP;

                /* Lookup the macro */
                c = *r;
                *r = '\0';
                d = lookup_define(q);
                *r = c;

                /* Prepare to expand the macro */
                if (in_buffer)
                {
                    outp = r;
                    if (name != yytext)
                    {
                        if ( (p - name) >= MAXLINE - 1)
                        {
                            yyerror("Include name too long.");
                            outp = old_outp;
                            return;
                        }
                        *p = '\0';
                        strcpy(yytext, name);
                        p += yytext - name;
                        name = yytext;
                    }
                }
                else
                {
                    myungetc('\n');
                    add_input(r);
                    in_buffer = MY_TRUE;
                }

                /* Expand the macro */
                if (!d || !_expand_define(&d->u.define) ) {
                    yyerror("Missing leading \" in #include");
                    outp = old_outp;
                    return;
                }
                q = outp;

                /* Skip the blanks until the next macro/filename */
                while (lexwhite(*q))
                    q++;
            }

            /* Second, try to parse a string literal */
            while (*++q && *q != delim)
            {
                if ( (p - name) >= MAXLINE - 1)
                {
                    yyerror("Include name too long.");
                    outp = old_outp;
                    return;
                }
                *p++ = *q;
            }
            if (!*q++) {
                yyerror("Missing trailing \" in #include");
                outp = old_outp;
                return;
            }
        } /* for (;;) */
    } /* if (delim == '"') */

    /* p now points to the character after the parsed filename */

    outp = old_outp;  /* restore outp */
    *p = '\0';        /* mark the end of the filename */

    /* Prepare defbuf for a (nested) include */
    linebufoffset = linebufstart - &defbuf[defbuf_len];
    if (outp - defbuf < 3*MAXLINE)
    {
        realloc_defbuf();
        /* linebufstart is invalid now */
        if (outp - defbuf < 2*MAXLINE)
        {
            lexerror("Maximum total buffer size exceeded");
            return;
        }
    }

    /* Open the include file, put the current lexer state onto
     * the incstack, and set up for the new file.
     */
    if ((fd = inc_open(buf, name, p - name, delim)) >= 0)
    {
        struct incstate *is;

        store_include_info(name);

        /* Copy the current state, but don't put it on the stack
         * yet in case we run into an error further down.
         */
        /* TODO: Use a memory pool here */
        is = (struct incstate *)xalloc(sizeof(struct incstate));
        if (!is) {
            lexerror("Out of memory");
            return;
        }

        is->yyin_des = yyin_des;
        is->line = current_line;
        is->file = current_file;
        is->linebufoffset = linebufoffset;
        is->saved_char = saved_char;
        is->next = inctop;
        is->pragma_strict_types = pragma_strict_types;

        /* Copy the new filename into current_file */
        current_file = xalloc(strlen(buf)+1);
        if (!current_file)
        {
            current_file = is->file;
            xfree(is);
            lexerror("Out of memory");
            return;
        }
        strcpy(current_file, buf);

        /* Now it is save to put the saved state onto the stack*/
        inctop = is;

        /* Initialise the rest of the lexer state */
        pragma_strict_types = PRAGMA_WEAK_TYPES;
        instrs[F_CALL_OTHER-F_OFFSET].ret_type = TYPE_ANY;
        current_line = 1;
        linebufend   = outp - 1; /* allow trailing zero */
        linebufstart = linebufend - MAXLINE;
        *(outp = linebufend) = '\0';
        yyin_des = fd;
        _myfilbuf();
        /* fprintf(stderr, "pushed to %s\n", buf); */
    }
    else
    {
        sprintf(buf, "Cannot #include '%s'", name);
        yyerror(buf);
    }
} /* handle_include() */

/*-------------------------------------------------------------------------*/
static void
skip_comment (void)

/* Skip a block comment (/ * ... * /). The function is entered with outp
 * pointing to the first character after the comment introducer, and left
 * with outp pointing to the first character after the comment end delimiter.
 */

{
    register char c, *p;

    p = outp;
    for(;;)
    {
        /* Skip everything until the next '*' */
        while((c =  *p++) != '*')
        {
            if (c == '\n') {
                store_line_number_info();
                nexpands = 0;
                if ((c = *p) == CHAR_EOF) {
                    outp = p - 1;
                    lexerror("End of file in a comment");
                    return;
                }
                current_line++;
                if (!c)
                {
                    outp = p;
                    p = _myfilbuf();
                }
            }
        } /* while (c == '*') */

        /* Skip all '*' until we find '/' or something else */
        do
        {
            if ((c = *p++) == '/')
            {
                outp = p;
                return;
            }

            if (c == '\n') {
                store_line_number_info();
                nexpands = 0;
                if ((c = *p) == CHAR_EOF)
                {
                    outp = p - 1;
                    lexerror("End of file in a comment");
                    return;
                }
                current_line++;
                if (!c)
                {
                    outp = p;
                    p = _myfilbuf();
                }
                c = '\0'; /* Make sure to terminate the '*' loop */
            }
        } while(c == '*');
    } /* for() */

    /* NOTREACHED */
} /* skip_comment() */

/*-------------------------------------------------------------------------*/
static char *
skip_pp_comment (char *p)

/* Skip a '//' line comment. <p> points to the first character after
 * the comment introducer, the function returns a pointer to the first
 * character after the terminating newline.
 * Note that a '\<newline>' lineend does not terminate the comment.
 */

{
    char c;

    for (;;)
    {
        c = *p++;
        if (c == '\n')
        {
            store_line_number_info();
            current_line++;
            if (p[-2] == '\\')
            {
                if (!*p)
                {
                    outp = p;
                    p = _myfilbuf();
                }
                continue;
            }
            nexpands = 0;
            if (!*p)
            {
                outp = p;
                p = _myfilbuf();
            }
            return p;
        }
    }

    /* NOTREACHED */
} /* skip_pp_comment() */

/*-------------------------------------------------------------------------*/
static void
deltrail (char *sp)

/* Look for the first blank character in the text starting at <sp> and
 * set it to '\0'. The function is used to isolate the next word
 * in '#' statements.
 */

{
    char *p;

    p = sp;
    if (!*p)
    {
        lexerror("Illegal # command");
    }
    else
    {
        while(*p && !isspace((unsigned char)*p))
            p++;
        *p = '\0';
    }
}

/*-------------------------------------------------------------------------*/
static void
handle_pragma (char *str)

/* Handle the pragma <str>. Unknown pragmas are ignored.
 */

{
#if defined(LEXDEBUG)
    printf("handle pragma:'%s'\n",str);
#endif
    if (strcmp(str, "strict_types") == 0)
    {
        pragma_strict_types = PRAGMA_STRICT_TYPES;
        instrs[F_CALL_OTHER-F_OFFSET].ret_type = TYPE_UNKNOWN;
    }
    else if (strcmp(str, "strong_types") == 0)
    {
        pragma_strict_types = PRAGMA_STRONG_TYPES;
        instrs[F_CALL_OTHER-F_OFFSET].ret_type = TYPE_ANY;
    }
    else if (strcmp(str, "save_types") == 0)
    {
        pragma_save_types = MY_TRUE;
    }
    else if (strcmp(str, "combine_strings") == 0)
    {
        pragma_combine_strings = MY_TRUE;
    }
    else if (strcmp(str, "no_combine_strings") == 0)
    {
        pragma_combine_strings = MY_FALSE;
    }
    else if (strcmp(str, "verbose_errors") == 0)
    {
        pragma_verbose_errors = MY_TRUE;
    }
    else if (strcmp(str, "no_clone") == 0)
    {
        pragma_no_clone = MY_TRUE;
    }
    else if (strcmp(str, "no_inherit") == 0)
    {
        pragma_no_inherit = MY_TRUE;
    }
    else if (strcmp(str, "no_local_scopes") == 0)
    {
        pragma_use_local_scopes = MY_FALSE;
    }
    else if (strcmp(str, "local_scopes") == 0)
    {
        pragma_use_local_scopes = MY_TRUE;
    }
#if defined( DEBUG ) && defined ( TRACE_CODE )
    else if (strcmp(str, "set_code_window") == 0)
    {
        set_code_window();
    }
    else if (strcmp(str, "show_code_window") == 0)
    {
        show_code_window();
    }
#endif
} /* handle_pragma() */

/*-------------------------------------------------------------------------*/
static INLINE int
number (long i)

/* Return a number to yacc: set yylval.number to <i> and return F_NUMBER.
 */

{
#ifdef LEXDEBUG
    printf("returning number %d.\n", i);
#endif
    yylval.number = i;
    return F_NUMBER;
}

/*-------------------------------------------------------------------------*/
static void
add_lex_string (char *str)

/* Add <str> to the global <last_lex_string> in order to implement
 * Standard-C style string concatenation.
 */

{
    size_t len1, len3;
    char *tmp;

    len1 = strlen(last_lex_string);
    len3 = len1 + strlen(str) + 1;
    if (len3 > MAX_ANSI_CONCAT)
    {
        /* Without this test, compilation would still terminate eventually,
         * thus it would still be 'correct', but it could take several hours.
         */
        lexerror("Too long ansi style string concatenation");
        /* leave the old string, ignore the new addition */
        return;
    }
    tmp = alloca(len3);
    strcpy(tmp, last_lex_string);
    strcpy(tmp + len1, str);
    free_string(last_lex_string);
    last_lex_string = make_shared_string(tmp);
}

/*-------------------------------------------------------------------------*/
static INLINE int
string (char *str)

/* Return a string to yacc: set last_lex_string to <str> and return F_STRING.
 * If there is a string in last_lex_string already, <str> is appended
 * and yylex() is called recursively to allow ANSI string concatenation.
 */

{
    if (last_lex_string)
    {
        add_lex_string(str);
        return yylex();
    }
    else
    {
        last_lex_string = make_shared_string(str);
    }
    return F_STRING;
}

/*-------------------------------------------------------------------------*/
static INLINE int
yylex1 (void)

/* Lex the next lexical element starting from outp and return its code.
 * For single characters, this is the character code itself. Multi-character
 * elements return the associated code define in lang.h.
 * Illegal characters are returned as spaces.
 * If the lexer runs into a fatal error or the end of file, -1 is returned.
 *
 * <depth> is the current nesting depth for local scopes, needed for
 * correct lookup of local identifiers.
 *
 * Some elements return additional information:
 *   F_ASSIGN:  yylval.number is the type of assignment operation
 *              e.g. F_ADD_EQ-F_OFFSET for '+='.
 *              '=' itself is returned as F_ASSIGN-F_OFFSET.
 *   F_NUMBER:  yylval.number is the parsed whole number or char constant.
 *   F_FLOAT:   yylval.float_number is the parsed float number.
 *   F_STRING:  last_lex_string is the (shared) parsed string literal.
 *   F_CLOSURE: yylval.closure.number identifies the closure. See the
 *              source for which value means what (it's a bit longish).
 *   F_QUOTED_AGGREGATE: yylval.number is the number of quotes
 *   F_SYMBOL:  yylval.symbol.name is the (shared) name of the symbol,
 *              yylval.symbol.quotes the number of quotes.
 */

{
    register char *yyp;
    register char c;

#define TRY(c, t) if (*yyp == (c)) {yyp++; outp = yyp; return t;}

    /* If we are at a point suitable for inline function insertion,
     * do it.
     * Note: It is not strictly necessary to insert all of them
     * at once, since the compiler will set insert_inline_fun_now
     * again as soon as it is finished with this one.
     */
    if (insert_inline_fun_now)
    {
        struct inline_fun * fun;
        char buf[80];

        sprintf(buf, "#line %d\n", current_line);
        insert_inline_fun_now = MY_FALSE;
        while (first_inline_fun)
        {
            fun = first_inline_fun->next;
            if (first_inline_fun->buf.length)
            {
                strbuf_add(&(first_inline_fun->buf), buf);
                add_input(first_inline_fun->buf.buf);
                strbuf_free(&(first_inline_fun->buf));
            }
            xfree(first_inline_fun);
            first_inline_fun = fun;
        }
    }

    yyp = outp;

    for(;;) {
        switch(c = *yyp++)
        {

        /* --- End Of File --- */

        case CHAR_EOF:

            if (inctop)
            {
                /* It's the end of an included file: return the previous
                 * file
                 */

                static char call_other_return_types[]
                  = { /* PRAGMA_WEAK_TYPES:   */ TYPE_ANY
                    , /* PRAGMA_STRONG_TYPES: */ TYPE_ANY
                    , /* PRAGMA_STRICT_TYPES: */ TYPE_UNKNOWN };

                struct incstate *p;

                p = inctop;

                /* End the lexing of the included file */
                close(yyin_des);
                /* fprintf(stderr, "popping to %s\n", p->file); */
                xfree(current_file);
                nexpands = 0;

                /* Restore the previous state */
                current_file = p->file;
                current_line = p->line + 1;
                pragma_strict_types = p->pragma_strict_types;
                instrs[F_CALL_OTHER-F_OFFSET].ret_type =
                    call_other_return_types[pragma_strict_types];
                yyin_des = p->yyin_des;
                saved_char = p->saved_char;
                inctop = p->next;
                *linebufend = '\n';
                yyp = linebufend + 1;
                linebufstart = &defbuf[defbuf_len] + p->linebufoffset;
                linebufend   = linebufstart + MAXLINE;
                xfree((char *)p);
                if (!*yyp)
                {
                    outp = yyp;
                    yyp = _myfilbuf();
                }
                store_include_end();
                break;
            }

            /* Here it's the end of the main file */

            if (iftop)
            {
                /* Oops, pending #if!
                 * Note the error and clean up the if-stack.
                 */
                struct ifstate *p = iftop;

                yyerror(p->state == EXPECT_ENDIF ? "Missing #endif" : "Missing #else");
                while(iftop)
                {
                    p = iftop;
                    iftop = p->next;
                    xfree((char *)p);
                }
            }

            /* Return the EOF condition */
            outp = yyp-1;
            return -1;


        /* --- Newline --- */

        case '\n':
            {
                store_line_number_info();
                nexpands = 0;
                current_line++;
                total_lines++;
                if (!*yyp)
                {
                    outp = yyp;
                    yyp = _myfilbuf();
                }
            }
            break;


        /* --- Other line markers --- */

        case 0x1a: /* Used by some MSDOS editors as EOF */
        case '\r':
            *(yyp-1) = *(yyp-2);
            break;


        /* --- White space --- */

        case ' ':
        case '\t':
        case '\f':
        case '\v':
            break;


        /* --- Multi-Char Operators --- */
        case '+':
            switch(c = *yyp++)
            {
            case '+': outp = yyp;
                      return F_INC;
            case '=': yylval.number = F_ADD_EQ-F_OFFSET;
                      outp = yyp;
                      return F_ASSIGN;
            default:  yyp--;
            }
            outp = yyp;
            return '+';

        case '-':
            switch(c = *yyp++)
            {
            case '>': outp = yyp;
                      return F_ARROW;
            case '-': outp = yyp;
                      return F_DEC;
            case '=': yylval.number = F_SUB_EQ-F_OFFSET;
                      outp = yyp;
                      return F_ASSIGN;
            default:  yyp--;
            }
            outp = yyp;
            return '-';

        case '&':
            switch(c = *yyp++)
            {
            case '&': outp = yyp;
                      return F_LAND;
            case '=': yylval.number = F_AND_EQ-F_OFFSET;
                      outp = yyp;
                      return F_ASSIGN;
            default:  yyp--;
            }
            outp = yyp;
            return '&';

        case '|':
            switch(c = *yyp++)
            {
            case '|': outp = yyp;
                      return F_LOR;
            case '=': yylval.number = F_OR_EQ-F_OFFSET;
                      outp = yyp;
                      return F_ASSIGN;
            default:  yyp--;
            }
            outp = yyp;
            return '|';

        case '^':
            if (*yyp == '=')
            {
                yyp++;
                yylval.number = F_XOR_EQ-F_OFFSET;
                outp = yyp;
                return F_ASSIGN;
            }
            outp = yyp;
            return '^';

        case '<':
            c = *yyp++;;
            if (c == '<')
            {
                if (*yyp == '=')
                {
                    yyp++;
                    yylval.number = F_LSH_EQ-F_OFFSET;
                    outp = yyp;
                    return F_ASSIGN;
                }
                outp = yyp;
                return F_LSH;
            }
            if (c == '=') {
                outp=yyp;
                return F_LE;
            }
            yyp--;
            outp = yyp;
            return '<';

        case '>':
            c = *yyp++;
            if (c == '>')
            {
                if (*yyp == '=')
                {
                    yyp++;
                    yylval.number = F_RSH_EQ-F_OFFSET;
                    outp = yyp;
                    return F_ASSIGN;
                }
                outp = yyp;
                return F_RSH;
            }
            if (c == '=')
            {
                outp = yyp;
                return F_GE;
            }
            yyp--;
            outp = yyp;
            return '>';

        case '*':
            if (*yyp == '=')
            {
                yyp++;
                yylval.number = F_MULT_EQ-F_OFFSET;
                outp = yyp;
                return F_ASSIGN;
            }
            outp = yyp;
            return '*';

        case '%':
            if (*yyp == '=') {
                yyp++;
                yylval.number = F_MOD_EQ-F_OFFSET;
                outp = yyp;
                return F_ASSIGN;
            }
            outp = yyp;
            return '%';

        case '/':
            c = *yyp++;
            if (c == '*')
            {
                outp = yyp;
                skip_comment();
                yyp = outp;
                if (lex_fatal)
                {
                    return -1;
                }
                break;
            }
            if (c == '/')
            {
                yyp = skip_pp_comment(yyp);
                break;
            }
            if (c == '=')
            {
                yylval.number = F_DIV_EQ-F_OFFSET;
                outp = yyp;
                return F_ASSIGN;
            }
            yyp--;
            outp = yyp;
            return '/';

        case '=':
            TRY('=', F_EQ);
            yylval.number = F_ASSIGN-F_OFFSET;
            outp = yyp;
            return F_ASSIGN;

        case '!':
            TRY('=', F_NE);
            outp = yyp;
            return F_NOT;

        case '.':
            TRY('.',F_RANGE);
            goto badlex;

        case ':':
            TRY(':', F_COLON_COLON);
            outp = yyp;
            return ':';


        /* --- Inline Function --- */

        case '(':
            /* Check for '(:' but ignore '(::' which can occur e.g.
             * in 'if (::remove())'. However, accept '(:::' e.g. from
             * '(:::remove()', and '(::)'.
             */

            if (*yyp == ':'
             && (yyp[1] != ':' || yyp[2] == ':' || yyp[2] == ')'))
            {
                struct inline_fun * fun;
                strbuf_t * textbuf;
                size_t pos_return;  /* position of the 'return' */
                char name[256+MAXPATHLEN];
                int level;
                int first_line;  /* For error messages */
                char *start;

                first_line = current_line;

                /* Allocate new function list element */
                if (!first_inline_fun)
                {
                    /* Create the list */
                    first_inline_fun = xalloc(sizeof *first_inline_fun);
                    if (!first_inline_fun)
                        yyerror("Out of memory.");
                    fun = first_inline_fun;
                }
                else
                {
                    /* Append the element at the end of the list */
                    fun = first_inline_fun;
                    while (fun->next)
                        fun = fun->next;
                    fun->next = xalloc(sizeof *fun);
                    if (!fun->next)
                        yyerror("Out of memory.");
                    fun = fun->next;
                }

                textbuf = &(fun->buf);
                strbuf_zero(textbuf);
                fun->next = NULL; /* Terminate the list properly */

                /* Create the name of the new inline function */
                sprintf(name, "__inline_%s_%d_%04x", current_file
                             , current_line, next_inline_fun++);

                /* Convert all non-alnums to '_' */
                for (start = name; *start != '\0'; start++)
                {
                    if (!isalnum(*start))
                        *start = '_';
                }

                /* Create the function header in the string buffer.
                 * For now we insert a 'return' which we might 'space out'
                 * later.
                 */
                strbuf_addf(textbuf
                           , "\n#line %d\n"
                             "varargs mixed %s (mixed $1, mixed $2, mixed $3,"
                             " mixed $4, mixed $5, mixed $6, mixed $7,"
                             " mixed $8, mixed $9) { return "
                           , current_line, name);
                pos_return = (unsigned)textbuf->length-7;

                /* Set yyp to the end of (: ... :), and also check
                 * for the highest parameter used.
                 */
                yyp++;
                level = 1;
                start = yyp;
                while (level)
                {
                    switch (*yyp++)
                    {
                    case CHAR_EOF:
                        current_line = first_line;
                        yyerror("Unexpected end of file in (: .. :)");
                        return -1;

                    case '\0':
                        lexerror("Lexer failed to refill the line buffer");
                        return -1;

                    case '(':
                        if (yyp[0] == ':'
                         && (yyp[1] != ':' || yyp[2] == ':' || yyp[2] == ')')
                           )
                            level++, yyp++;
                        break;

                    case ':':
                        if (yyp[0] == ')')
                            level--, yyp++;
                        break;

                    case '#':
                        if (*yyp == '\'')
                            yyp++;
                        break;

                    case '/':
                        c = *yyp;
                        if (c == '*')
                        {
                            int this_line;

                            this_line = current_line;
                            strbuf_addn(textbuf, start, (unsigned)(yyp-start-1));
                            outp = yyp;
                            skip_comment();
                            yyp = outp;
                            if (lex_fatal)
                                return -1;

                            start = yyp;
                            while (this_line++ < current_line)
                                strbuf_addc(textbuf, '\n');

                            continue;
                        }

                        if (c == '/')
                        {
                            int this_line;

                            this_line = current_line;
                            strbuf_addn(textbuf, start, (unsigned)(yyp-start-1));
                            yyp = skip_pp_comment(yyp);

                            start = yyp;
                            while (this_line++ < current_line)
                                strbuf_addc(textbuf, '\n');

                            continue;
                        }
                        break;

                    case '\n':
                        store_line_number_info();
                        nexpands = 0;
                        current_line++;
                        total_lines++;
                        if (!*yyp)
                        {
                            strbuf_addn(textbuf, start, (unsigned)(yyp-start));
                            outp = yyp;
                            yyp = _myfilbuf();
                            start = yyp;
                        }
                        break;

                    case '\"':
                    case '\'':
                      {
                        char delimiter = yyp[-1];

                        while ((c = *yyp++) != delimiter)
                        {
                            if (c == '\\')
                            {
                                if (*yyp++ == '\n')
                                {
                                    store_line_number_info();
                                    nexpands = 0;
                                    current_line++;
                                    total_lines++;
                                    if (!*yyp)
                                    {
                                        strbuf_addn(textbuf
                                            , start
                                            , (unsigned)(yyp-start));
                                        outp = yyp;
                                        yyp = _myfilbuf();
                                        start = yyp;
                                    }
                                }
                            }
                            else if (c == '\n')
                            {
                                store_line_number_info();
                                nexpands = 0;
                                current_line++;
                                total_lines++;
                                if (!*yyp)
                                {
                                    strbuf_addn(textbuf
                                        , start
                                        , (unsigned)(yyp-start));
                                    outp = yyp;
                                    yyp = _myfilbuf();
                                    start = yyp;
                                }
                            }
                        }
                        break;
                      } /* string-case */

                    } /* switch(yyp[0]) */

                } /* while(level) */

                /* yyp now points to the character after the ':)'.
                 * This is where the next call to lex has to continue.
                 * Also copy the remaining (or the only) part of the
                 * closure into the text buffer.
                 */

                strbuf_addn(textbuf, start, (unsigned)(yyp-start-2));
                outp = yyp;

                /* The closure must not be too long (there is a hard limit in
                 * the strbuf_t datastructure.
                 */
                if (textbuf->length > MAX_STRBUF_LEN-100)
                    yyerror("Inline closure too long");

                /* Check if the last character before the ':)' is
                 * a ';' or '}'. For convenience we re-use yyp to
                 * point into our buffer (we will exit from here
                 * anyway).
                 */

                yyp = textbuf->buf + textbuf->length-1;
                while (lexwhite(*yyp) || '\n' == *yyp || '\r' == *yyp)
                    yyp--;

                if (*yyp == ';' || *yyp == '}')
                {
                    /* Functional contains statements: remove the 'return'
                     * added in the beginnin.
                     */
                    int i;

                    for (i = 0; i < 6; i++)
                        textbuf->buf[pos_return+i] = ' ';

                    /* Finish up the function text */
                    strbuf_add(textbuf, "}\n");
                }
                else
                {
                    /* Finish up the function text */
                    strbuf_add(textbuf, ";}\n");
                }


                /* Return the ID of the name of the new inline function */

                yylval.ident = make_shared_identifier(name, I_TYPE_UNKNOWN, 0);
                return F_INLINE_FUN;
            }

            /* FALL THROUGH */
        /* --- Single-char Operators and Punctuation --- */

        /* case '(' is a fall through from above */
        case ';':
        case ')':
        case ',':
        case '{':
        case '}':
        case '~':
        case '[':
        case ']':
        case '?':
            outp = yyp;
            return c;


        /* --- #: Preprocessor statement or symbol --- */

        case '#':
            if (*yyp == '\'')
            {
                /* --- #': Closure Symbol --- */

                struct ident *p;
                char *wordstart = ++yyp;
                Bool efun_override;
                    /* True if 'efun::' is specified. */

                /* Set yyp to the last character of the functionname
                 * after the #'.
                 */
                do
                    c = *yyp++;
                while (isalunum(c));
                c = *--yyp;
                /* the assignment is good for the data flow analysis :-} */

                /* Just one character? It must be an operator */
                if (yyp == wordstart) {
                    int i;

                    if ((i = symbol_operator(yyp, &outp)) < 0)
                        yyerror("Missing function name after #'");
                    yylval.closure.number = i + CLOSURE_EFUN_OFFS;
                    return F_CLOSURE;
                }

                /* Test for the 'efun::' override. If it is there,
                 * reset wordstart/yyp to point to the name after the '::'.
                 */
                efun_override = MY_FALSE;
                if (yyp - wordstart == 4
                 && !strncmp(wordstart, "efun::", 6))
                {
                    efun_override = MY_TRUE;
                    wordstart = yyp += 2;
                    do
                        c = *yyp++;
                    while (isalunum(c));
                    c = *--yyp;
                }

                outp = yyp;

                /* Lookup the name parsed from the text */
                *yyp = '\0'; /* c holds the char at this place */
                p = make_shared_identifier(wordstart, I_TYPE_GLOBAL, 0);
                *yyp = c;
                if (!p) {
                    lexerror("Out of memory");
                    return 0;
                }

                /* #' can be used only on identifiers with global visibility
                 * or better. Look along the .inferior chain for such an
                 * identifier. If the identifier happens to be a reserved
                 * word, the better for us.
                 */
                while (p->type > I_TYPE_GLOBAL)
                {
                    if (p->type == I_TYPE_RESWORD)
                    {
                        int code;

                        switch(code = p->u.code)
                        {
                        default:
                            /* There aren't efuns with reswords as names, and
                             * it is impossible to define local / global vars
                             * or functions with such a name.
                             * Thus, !p->inferior .
                             */
                            yyerrorf(
                              "No closure associated with reserved word '%s'",
                              p->name
                            );
                            code = CLOSURE_EFUN_OFFS;
                            break;
                        case F_IF:
                            code = F_BRANCH_WHEN_ZERO-F_OFFSET+CLOSURE_EFUN_OFFS;
                            break;
                        case F_DO:
                            code =
                              F_BBRANCH_WHEN_NON_ZERO-F_OFFSET+CLOSURE_EFUN_OFFS;
                            break;
                        case F_WHILE:
                            /* the politically correct code was already taken,
                             * see above.
                             */
                            code = F_BBRANCH_WHEN_ZERO-F_OFFSET+CLOSURE_EFUN_OFFS;
                            break;
                        case F_CONTINUE:
                            code = F_BRANCH-F_OFFSET+CLOSURE_EFUN_OFFS;
                            break;
                        case F_DEFAULT:
                            code = F_CSTRING0-F_OFFSET+CLOSURE_EFUN_OFFS;
                            /* as bogus as we can possibliy get :-) */
                            break;
                        case F_BREAK:
                        case F_RETURN:
                        case F_SSCANF:
                        case F_CATCH:
                        case F_SWITCH:
                            code += -F_OFFSET + CLOSURE_EFUN_OFFS;
                            break;
                        }
                        yylval.closure.number = code;
                        return F_CLOSURE;
                    }
                    if ( !(p = p->inferior) )
                        break;
                } /* while (p->type > I_TYPE_GLOBAL */

                /* Did we find a suitable identifier? */
                if (!p || p->type < I_TYPE_GLOBAL)
                {
                    if (p && p->type == I_TYPE_UNKNOWN)
                        free_shared_identifier(p);
                    c = *yyp;
                    *yyp = '\0';
                    yyerrorf("Undefined function: %s", wordstart);
                    *yyp = c;
                    yylval.closure.number = CLOSURE_EFUN_OFFS;
                    return F_CLOSURE;
                }

                /* An attempt to override a nomask simul-efun causes
                 * a privilege violation. If the master decides to allow
                 * this attempt, the efun-override will still be deactivated
                 * (iow: a nomask simul-efun overrules an efun override).
                 */
                if (efun_override
                 && p->u.global.sim_efun >= 0
                 && simul_efunp[p->u.global.sim_efun].flags & TYPE_MOD_NO_MASK
                 && p->u.global.efun >= 0
                 && master_ob)
                {
                    struct svalue *res;

                    push_volatile_string("nomask simul_efun");
                    push_volatile_string(current_file);
                    push_shared_string(p->name);
                    res = apply_master_ob(STR_PRIVILEGE, 3);
                    if (!res || res->type != T_NUMBER || res->u.number < 0)
                    {
                        yyerrorf(
                          "Privilege violation: nomask simul_efun %s",
                          p->name
                        );
                        efun_override = MY_FALSE;
                    }
                    else if (!res->u.number)
                    {
                        efun_override = MY_FALSE;
                    }
                }

                /* The code will be F_CLOSURE, now determine the right
                 * closure number to put into yylval.closure.number.
                 * The number is usually the index in the appropriate
                 * table, plus an offset indicating the type of the closure.
                 *
                 * The switch() serves just as a simple try... environment.
                 */
                switch(0) { default:
                    if (!efun_override)
                    {

                        /* lfun? */
                        if (p->u.global.function >= 0)
                        {
                            int i;

                            i = p->u.global.function;
                            yylval.closure.number = i;
                            if (i >= CLOSURE_IDENTIFIER_OFFS)
                                yyerrorf(
                                  "Too high function index of %s for #'",
                                  p->name
                                );
                            break;
                        }

                        /* simul-efun? */
                        if (p->u.global.sim_efun >= 0) {
                            yylval.closure.number =
                              p->u.global.sim_efun + CLOSURE_SIMUL_EFUN_OFFS;
                            break;
                        }
                    }

                    /* efun? */
                    if (p->u.global.efun >= 0)
                    {
                        yylval.closure.number =
                          p->u.global.efun + CLOSURE_EFUN_OFFS;
                        if (yylval.closure.number >
                            LAST_INSTRUCTION_CODE + CLOSURE_EFUN_OFFS)
                        {
                            yylval.closure.number =
                              efun_aliases[
                                yylval.closure.number - CLOSURE_EFUN_OFFS
                                  - LAST_INSTRUCTION_CODE - 1
                              ] + CLOSURE_EFUN_OFFS;
                        }
                        break;
                    }

                    /* object variable? */
                    if (p->u.global.variable >= 0)
                    {
                        if (p->u.global.variable & VIRTUAL_VAR_TAG) {
                            /* Handling this would require an extra coding of
                             * this closure type, and special treatment in
                             * replace_program_lambda_adjust() .
                             */
                            yyerrorf("closure of virtual variable");
                            yylval.closure.number = CLOSURE_IDENTIFIER_OFFS;
                            break;
                        }
                        yylval.closure.number =
                          p->u.global.variable + num_virtual_variables +
                          CLOSURE_IDENTIFIER_OFFS;
                        break;
                    }

                    /* None of these all */
                    c = *yyp;
                    *yyp = 0;
                    yyerrorf("Undefined function: %s", wordstart);
                    *yyp = c;
                    yylval.closure.number = CLOSURE_EFUN_OFFS;

                    break;
                }
                return F_CLOSURE;

            } /* if (#') */

            else if (*(yyp-2) == '\n' && !nexpands)
            {
                /* --- <newline>#: Preprocessor statement --- */

                char *sp = NULL; /* Begin of second word */
                Bool quote; /* In "" string? */
                char last;
                  /* Character last read, used to implement \-sequences */

                /* Copy the first/only line of the preprocessor statement
                 * from the input buffer into yytext[] while stripping
                 * comments.
                 */

                /* Skip initial blanks */
                outp = yyp;
                yyp = yytext;
                do {
                    c = mygetc();
                } while (lexwhite(c));

                for (quote = MY_FALSE, last = '\0';;)
                {

                    /* Skip comments */
                    while (!quote && c == '/')
                    {
                        char c2;

                        if ( (c2 = mygetc()) == '*')
                        {
                            skip_comment();
                            c = mygetc();
                        }
                        else if (c2 == '/')
                        {
                            outp = skip_pp_comment(outp);
                            current_line--;
                            c = '\n';
                        }
                        else
                        {
                            --outp;
                            break;
                        }
                    }

                    /* If the last character was '\', take this one as
                     * as it is, else interpret this character.
                     */
                    if (last == '\\')
                        last = '\0';
                    else if (c == '"')
                        quote = !quote;
                    else
                        last = c;

                    /* Remember end of the first word in the line */
                    if (!sp && lexwhite(c))
                        sp = yyp;

                    if (c == '\n')
                    {
                        break;
                    }
                    SAVEC;
                    c = mygetc();
                }

                /* Mark the end of the first word by overwriting the
                 * whitespace with '\0'. Let sp point to the next word
                 * then.
                 */
                if (sp)
                {
                    *sp++ = '\0';
                    while(lexwhite(*sp))
                        sp++;
                }
                else
                {
                    sp = yyp;
                }
                *yyp = '\0';

                /* Evaluate the preprocessor statement */
                if (strcmp("include", yytext) == 0)
                {
                    handle_include(sp);
                }
                else
                {
                   /* Make sure there is enough data in the buffer.
                    * Doing that before handling an include otoh
                    * would be waste of time and memory.
                    */
                   myfilbuf();

                if (strcmp("define", yytext) == 0)
                {
                    handle_define(sp, quote);
                }
                else if (strcmp("if", yytext) == 0)
                {
                    int cond;
                    struct svalue sv;

                    myungetc('\n');
                    add_input(sp);
                    cond = cond_get_exp(0, &sv);
                    free_svalue(&sv);
                    if (mygetc() != '\n')
                    {
                        yyerror("Condition too complex in #if");
                        while (mygetc() != '\n') NOOP;
                    }
                    else
                        handle_cond(cond);
                }
                else if (strcmp("ifdef", yytext) == 0)
                {
                    deltrail(sp);
                    handle_cond(lookup_define(sp) != 0);
                }
                else if (strcmp("ifndef", yytext) == 0)
                {
                    deltrail(sp);
                    handle_cond(lookup_define(sp) == 0);
                }
                else if (*yytext == 'e'
                      && yytext[1] == 'l'
                      && (   (yytext[2] == 's' && yytext[3] == 'e')
                          || (yytext[2] == 'i' && yytext[3] == 'f') )
                      && !yytext[4])
                {
                    if (iftop && iftop->state == EXPECT_ELSE)
                    {
                        struct ifstate *p = iftop;

                        /* fprintf(stderr, "found else\n"); */
                        iftop = p->next;
                        xfree(p);
                        skip_to("endif", NULL);
                    }
                    else
                    {
                        yyerror("Unexpected #else");
                    }
                }
                else if (strcmp("endif", yytext) == 0)
                {
                    if (iftop
                     && (   iftop->state == EXPECT_ENDIF
                         || iftop->state == EXPECT_ELSE))
                    {
                        struct ifstate *p = iftop;

                        /* fprintf(stderr, "found endif\n"); */
                        iftop = p->next;
                        xfree(p);
                    }
                    else
                    {
                        yyerror("Unexpected #endif");
                    }
                }
                else if (strcmp("undef", yytext) == 0)
                {
                    struct ident *p, **q;
                    int h;

                    deltrail(sp);
                    /* fprintf(stderr, "#undef '%s'\n", sp); */

                    /* Lookup identifier <sp> in the ident_table and
                     * remove it there if it is a #define'd identifier.
                     * If it is a permanent define, park the ident
                     * structure in the undefined_permanent_defines list.
                     */
                    h = identhash(sp);
                    for (q = &ident_table[h]; NULL != ( p= *q); q=&p->next)
                    {
                        if (strcmp(sp, p->name))
                            continue;

                        if (p->type != I_TYPE_DEFINE) /* failure */
                            break;

                        if (!p->u.define.permanent)
                        {
#if defined(LEXDEBUG)
                            fprintf(stderr, "#undef define '%s' %d '%s'\n",
                                   , p->name, p->u.define.nargs
                                   , p->u.define.exps.str);
                            fflush(stderr);
#endif
                            if (p->inferior)
                            {
                                p->inferior->next = p->next;
                                *q = p->inferior;
                            }
                            else
                            {
                                *q = p->next;
                                free_string(p->name);
                            }
                            xfree(p->u.define.exps.str);
                            p->name = NULL;
                                /* mark for later freeing by all_defines */
                            /* success */
                            break;
                       }
                       else
                       {
                            if (p->inferior)
                            {
                                p->inferior->next = p->next;
                                *q = p->inferior;
                                ref_string(p->name);
                            }
                            else
                            {
                                *q = p->next;
                            }
                            p->next = undefined_permanent_defines;
                            undefined_permanent_defines = p;
                            /* success */
                            break;
                        }
                    }
                }
                else if (strcmp("echo", yytext) == 0)
                {
                    fprintf(stderr, "%s\n", sp);
                }
                else if (strcmp("pragma", yytext) == 0)
                {
                    deltrail(sp);
                    handle_pragma(sp);
                }
                else if (strcmp("line", yytext) == 0)
                {
                    char * end;
                    long new_line;

                    deltrail(sp);
                    new_line = strtol(sp, &end, 0);
                    if (end == sp || *end != '\0')
                        yyerror("Unrecognised #line directive");
                    current_line = new_line - 1;
                }
                else
                {
                    yyerror("Unrecognised # directive");
                }} /* if() else if () */

                store_line_number_info();
                nexpands = 0;
                current_line++;
                total_lines++;
                yyp = outp;
                if (lex_fatal)
                {
                    return -1;
                }
                break;
            }

            else
                goto badlex;


        /* --- ': Character constant or lambda symbol --- */

        case '\'':
            c = *yyp++;

            if (c == '\\')
            {
                /* Parse an escape sequence */
                switch(c = *yyp++)
                {
                    case '\n':
                    case CHAR_EOF:
                        yyp--; /* this will be noted as error below */
                        break;
                    case 'a': c = '\007'; break;
                    case 'b': c = '\b';   break;
                    case 'e': c = '\033'; break;
                    case 'f': c = '\014'; break;
                    case 'n': c = '\n';   break;
                    case 'r': c = '\r';   break;
                    case 't': c = '\t';   break;
                }
                if (*yyp++ != '\'')
                {
                    yyp--;
                    yyerror("Illegal character constant");
                }

                /* Continue after the if() as if it's a normal constant */

            }
            else if (*yyp++ != '\''
                  || (   c == '\''
                      && (*yyp == '(' || isalunum(*yyp) || *yyp == '\'')) )
            {
                /* Parse the symbol or quoted aggregate.
                 *
                 * The test rejects all sequences of the form
                 *   'x'
                 * and
                 *   '''x, with x indicating that the ' character itself
                 *         is meant as the desired constant.
                 *
                 * It accepts all forms of quoted symbols, with one or
                 * more leading ' characters.
                 */

                char *wordstart;
                int quotes = 1;

                /* Count the total number of ' characters, set wordstart
                 * on the first non-quote.
                 */
                yyp -= 2;
                while (*yyp == '\'')
                {
                    quotes++;
                    yyp++;
                }
                wordstart = yyp;

                /* If the first non-quote is not an alnum, it must
                 * be a quoted aggregrate or an error.
                 */
                if (!isalpha((unsigned char)*yyp) && *yyp != '_')
                {
                    if (*yyp == '(' && yyp[1] == '{')
                    {
                        outp = yyp + 2;
                        yylval.number = quotes;
                        return F_QUOTED_AGGREGATE;
                    }
                    yyerror("Illegal character constant");
                    outp = yyp;
                    return F_NUMBER;
                }

                /* Find the end of the symbol and make it a shared string. */
                while (isalunum(*++yyp)) NOOP;
                c = *yyp;
                *yyp = 0;
                yylval.symbol.name = make_shared_string(wordstart);
                *yyp = c;
                yylval.symbol.quotes = quotes;
                outp = yyp;
                return F_SYMBOL;
            }

            /* It's a normal (or escaped) character constant. */
            yylval.number = c;
            outp = yyp;
            return F_NUMBER;


        /* --- ": String Literal --- */

        case '"':
        {
            char *p = yyp;

            /* Construct the string in yytext[], terminated with a \0.
             * ANSI style string concatenation is done by a recursive
             * call to yylex() after this literal is parsed completely.
             * This way a mixture of macros and literals is easily
             * handled.
             */
            yyp = yytext;
            for(;;)
            {
                c = *p++;

                /* No unescaped newlines allowed */
                if (c == '\n')
                {
                    outp = p-1;
                    /* myfilbuf(); not needed */
                    lexerror("Newline in string");
                    return string("");
                }
                SAVEC;

                /* Unescaped ": end of string */
                if (c == '"') {
                    *--yyp = '\0';
                    break;
                }

                /* Handle an escape sequence */
                if (c == '\\')
                {
                    yyp--; /* Undo the SAVEC */

                    switch(c = *p++)
                    {
                    case '\r':
                        /* \<cr><lf> defaults to \<lf>, but
                         * \<cr> puts <cr> into the text.
                         */
                        if (*p++ != '\n')
                        {
                            p--;
                            *yyp++ = c;
                            break;
                        }
                        /* FALLTHROUGH*/

                    case '\n':
                        /* \<lf> and \<lf><cr> are ignored */
                        store_line_number_info();
                        current_line++;
                        total_lines++;
                        if (*p == CHAR_EOF )
                        {
                            outp = p;
                            lexerror("End of file in string");
                            return string("");
                        }
                        if (!*p)
                        {
                            outp = p;
                            p = _myfilbuf();
                        }
                        if (*p++ != '\r')
                            p--;
                        break;

                    case 'a': *yyp++ = '\007'; break;
                    case 'b': *yyp++ = '\b';   break;
                    case 'e': *yyp++ = '\033'; break;
                    case 'f': *yyp++ = '\014'; break;
                    case 'n': *yyp++ = '\n'; break;
                    case 'r': *yyp++ = '\r'; break;
                    case 't': *yyp++ = '\t'; break;
                    default : *yyp++ = c;
                    }
                }
            } /* for() */

            outp = p;
            return string(yytext);
        }


        /* --- Numbers --- */

        case '0':

            /* '0' introduces octal and sedecimal numbers, or it
             * can be a float
             */

            c = *yyp++;
            if ( c == 'X' || c == 'x' )
            {
                unsigned long l;

                /* strtol() gets the sign bit wrong,
                 * strtoul() isn't portable enough.
                 */
                l = 0;
                --yyp;
                while(leXdigit(c = *++yyp))
                {
                    if (c > '9')
                        c = (char)((c & 0xf) + ( '9' + 1 - ('a' & 0xf) ));
                    l <<= 4;
                    l += c - '0';
                }
                outp = yyp;
                return number((signed)l);
            }

            /* If one '.' follows, it's the start of a float.
             * If two '..' follow, it's one end of a range
             * If some other non-digit follows, it's just the number 0.
             */
            yyp--;
            if (!lexdigit(c) && (c != '.' || yyp[1] == '.') )
            {
                outp = yyp;
                return number(0);
            }
            c = '0';

            /* FALLTHROUGH */

        case '1':case '2':case '3':case '4':
        case '5':case '6':case '7':case '8':case '9':
        {
            char *numstart = yyp;
            long l;

            l = c - '0';
            while(lexdigit(c = *yyp++)) l = (((l << 2)+l) << 1) +
#if defined(atarist) || defined(sun)
/* everybody with ascii is invited to join in... */
                  (c & 0xf ); /* can be done in the same step as the type conversion */
#else
                  (c - '0');
#endif

            /* If it's a float (and not a range), gobble up all remaining
             * digits and simply use atof() to convert the float.
             * TODO: This breaks on floats in exponential repr. like 1.2E-3.
             */
            if (c == '.' && *yyp != '.')
            {
                while(lexdigit(*yyp++)) NOOP;
                c = *--yyp;
                *yyp = 0;
                yylval.float_number = atof(numstart-1);
                *yyp = c;
                outp = yyp;
                return F_FLOAT;
            }
            --yyp;
            outp = yyp;
            return number(l);
        }


        /* --- Identifier --- */

        case 'A':case 'B':case 'C':case 'D':case 'E':case 'F':case 'G':
        case 'H':case 'I':case 'J':case 'K':case 'L':case 'M':case 'N':
        case 'O':case 'P':case 'Q':case 'R':case 'S':case 'T':case 'U':
        case 'V':case 'W':case 'X':case 'Y':case 'Z':case 'a':case 'b':
        case 'c':case 'd':case 'e':case 'f':case 'g':case 'h':case 'i':
        case 'j':case 'k':case 'l':case 'm':case 'n':case 'o':case 'p':
        case 'q':case 'r':case 's':case 't':case 'u':case 'v':case 'w':
        case 'x':case 'y':case 'z':case '_':case '$':
        {
            struct ident *p;
            char *wordstart = yyp-1;

            /* Find the end of the identifier and mark it with a '\0' */
            do
                c = *yyp++;
            while (isalunum(c));
            c = *--yyp; /* the assignment is good for the data flow analysis :-} */
            *yyp = '\0';

            /* Lookup/enter the identifier in the ident_table, then restore
             * the original text
             */
            p = make_shared_identifier(wordstart, I_TYPE_UNKNOWN, 0);
            *yyp = c;
            if (!p)
            {
                lexerror("Out of memory");
                return 0;
            }
#if 0
            printf("ident type is %d\n",p->type);
#endif

            /* Handle the identifier according to its type */

            switch(p->type)
            {
            case I_TYPE_DEFINE:

                outp = yyp;
                _expand_define(&p->u.define);
                if (lex_fatal)
                {
                    return -1;
                }
                yyp=outp;
                continue;

            case I_TYPE_RESWORD:
                outp = yyp;
                return p->u.code;

            case I_TYPE_LOCAL:
                yylval.number = p->u.local.num;
                outp = yyp;
                return F_LOCAL;

            default:
                /* _UNKNOWN identifiers get their type assigned by the
                 * parser.
                 */
                yylval.ident = p;
                outp = yyp;
                return F_IDENTIFIER;
            }
        }


        /* --- Everything else --- */

        default:
            goto badlex;
        } /* switch (c) */

    } /* for() */

badlex:

    /* We come here after an unexpected character */

    if (lex_fatal)
        return -1;

    {
        char buff[100];
        sprintf(buff, "Illegal character (hex %02x) '%c'", c, c);
        yyerror(buff);
        outp = yyp;
        return ' ';
    }

#undef TRY

} /* yylex1() */

/*-------------------------------------------------------------------------*/
int
yylex (void)

/* The lex function called by the parser. The actual lexing is done
 * in yylex1(), this function just does any necessary pre- and post-
 * processing.
 * <depth> is the current nesting depth for local scopes, needed for
 * correct lookup of local identifiers.
 */

{
    int r;

#ifdef LEXDEBUG
    yytext[0] = '\0';
#endif
    r = yylex1();
#ifdef LEXDEBUG
    fprintf(stderr, "lex=%d(%s) ", r, yytext);
#endif
    return r;
}

/*-------------------------------------------------------------------------*/
void
start_new_file (int fd)

/* Start the compilation/lexing of the lpc file opened on file <fd>.
 * This must not be called for included files.
 */

{
    free_defines();

    yyin_des = fd;

    if (!defbuf_len)
    {
        defbuf = xalloc(DEFBUF_1STLEN);
        defbuf_len = DEFBUF_1STLEN;
    }

    *(outp = linebufend = (linebufstart = defbuf + DEFMAX) + MAXLINE) = '\0';

    current_line = 1; /* already used in _myfilbuf() */
    _myfilbuf();

    lex_fatal = MY_FALSE;

    if (auto_include_string)
    {
        add_input(auto_include_string);
        current_line = auto_include_start;
    }

    pragma_strict_types = PRAGMA_WEAK_TYPES;
    instrs[F_CALL_OTHER-F_OFFSET].ret_type = TYPE_ANY;
    pragma_use_local_scopes = MY_TRUE;
    pragma_save_types = MY_FALSE;
    pragma_verbose_errors = MY_FALSE;
    pragma_no_clone = MY_FALSE;
    pragma_no_inherit = MY_FALSE;

    nexpands = 0;

    next_inline_fun = 0;
    insert_inline_fun_now = MY_FALSE;
} /* start_new_file() */

/*-------------------------------------------------------------------------*/
void
end_new_file (void)

/* Clean up after a compilation terminated (successfully or not).
 */

{
    while (inctop)
    {
        struct incstate *p;
        p = inctop;
        close(yyin_des);
        xfree(current_file);
        current_file = p->file;
        yyin_des = p->yyin_des;
        inctop = p->next;
        xfree(p);
    }

    while(iftop)
    {
        struct ifstate *p;

        p = iftop;
        iftop = p->next;
        xfree(p);
    }

    if (defbuf_len > DEFBUF_1STLEN)
    {
        xfree(defbuf);
        defbuf = NULL;
        defbuf_len = 0;
    }

    if (last_lex_string)
    {
        free_string(last_lex_string);
        last_lex_string = NULL;
    }

    while (first_inline_fun)
    {
        struct inline_fun * fun = first_inline_fun;

        first_inline_fun = first_inline_fun->next;
        strbuf_free(&(fun->buf));
        xfree(fun);
    }

} /* end_new_file() */

/*-------------------------------------------------------------------------*/
void
lex_close (char *msg)

/* End the current lexing properly (ie. by calling end_new_file())
 * and throw the error message <msg>. If <msg> is NULL, a message
 * giving the current include depth.
 *
 * TODO: Only backend::write_file() uses the builtin message facility,
 * TODO:: but is it actually correct at that point?
 * TODO:: The only other call is from lang.c with 'Out of memory' as
 * TODO:: error message.
 */

{
    if (!msg)
    {
        /* Count the include depth and make a nice message */

        int i;
        struct incstate *p;
        static char buf[] =
            "File descriptors exhausted, include nesting: 12345678";

        for (i = 0, p = inctop; p; p = p->next)
            i++;

        /* skip back terminating \0 and 8 digits */
        sprintf(buf + sizeof buf - 9, "%d", i);
        msg = buf;
    }

    end_new_file();
    outp = ("##")+1; /* TODO: Not really nice */

    lexerror(msg);
} /* lex_close() */

/*-------------------------------------------------------------------------*/
char *
get_f_name (int n)

/* Return the name of instruction <n>, it if has one.
 * The result is a pointer to a static buffer.
 */

{
    if (instrs[n].name)
        return instrs[n].name;
    else
    {
        static char buf[30];
        sprintf(buf, "<OTHER %d>", n);
        return buf;
    }
}

/*-------------------------------------------------------------------------*/
static char
cmygetc (void)

/* Get the next character from the input buffer (using mygetc()) which
 * is not part of a comment.
 */

{
    char c;

    for(;;)
    {
        c = mygetc();
        if (c == '/') {
            if (gobble('*'))
                skip_comment();
            else if (gobble('/'))
            {
                outp = skip_pp_comment(outp);
                current_line--;
                return '\n';
            }
            else
                return c;
        }
        else
            return c;
    }
} /* cmygetc() */

/*-------------------------------------------------------------------------*/
static Bool
refill (Bool quote)

/* Read the next line from the input buffer into yytext[], skipping
 * comments, reading the final \n as space.
 * <quote> is true if at the time of call the text is supposed
 * to be within a string literal.
 * Result is the new value for <quote>: true if the next character to
 *   read is part of a string literal.
 */
{
    char *p;
    int c;
    char last = '\0';

    p = yytext;
    do
    {
        c = mygetc();

        if (c == '/' && !quote)
        {
            last = '\0';
            if (gobble('*'))
            {
                skip_comment();
                continue;
            }
            else if (gobble('/'))
            {
                outp = skip_pp_comment(outp);
                current_line--;
                c = '\n';
            }
        }
        else if (last == '\\')
        {
            /* Take the current character as it is */
            last = '\0';
        }
        else if (c == '"')
            quote = !quote;
        else
            last = (char)c;

        if (p < yytext+MAXLINE-5)
            *p++ = (char)c;
        else
        {
            lexerror("Line too long");
            break;
        }
    } while (c != '\n');

    /* Refill the input buffer */
    myfilbuf();

    /* Replace the trailing \n by a newline */
    p[-1] = ' ';
    *p = '\0';

    nexpands = 0;
    current_line++;
    store_line_number_info();

    return quote;
}

/*-------------------------------------------------------------------------*/
static void
handle_define (char *yyt, Bool quote)

/* This function is called from yylex1() to handle '#define' statements.
 * The text of the line with the statement is in yytext[], <yyt> points
 * to the first word after '#define'. <quote> is true if at the end
 * of the line a string literal was still open.
 */

{
  /* Get the identfier (or punctuation) pointed to by p and copy it
   * as null-terminated string to q, but at max up to address m.
   */
#define GETALPHA(p, q, m) \
    while(isalunum(*p)) {\
        *q = *p++;\
        if (q < (m))\
            q++;\
        else {\
            lexerror("Name too long");\
            return;\
        }\
    }\
    *q++ = 0

  /* Skip all whitespace from the current position of char*-variable 'p'
   * on.
   */
#define SKIPWHITE while(lexwhite(*p)) p++


    char namebuf[NSIZE];      /* temp buffer for read identifiers */
    char args[NARGS][NSIZE];  /* parsed argument names of function macros */
    char mtext[MLEN];
      /* replacement text, with arguments replaced by the MARKS characters
       */
    char *p;                  /* current text pointer */
    char *q;                  /* destination for parsed text */

    p = yyt;
    strcat(p, " "); /* Make sure GETALPHA terminates */

    /* Get the defined name */
    q = namebuf;
    GETALPHA(p, q, namebuf+NSIZE-1);

    if (*p == '(')
    {
        /* --- Function Macro --- */

        short arg;         /* Number of macro arguments */
        Bool inid;         /* true: parsing an identifier */
        char *ids = NULL;  /* Start of current identifier */

        p++;        /* skip '(' and following whitespace */
        SKIPWHITE;

        /* Parse the arguments (if any) */

        if (*p == ')')
        {
            /* no arguments */
            arg = 0;
        }
        else
        {
            /* Parse up to NARGS-1 arguments */

            for (arg = 0; arg < NARGS; )
            {
                /* Get the argname directly into args[][] */
                q = args[arg];
                GETALPHA(p, q, &args[arg][NSIZE-1]);
                arg++;

                SKIPWHITE;

                /* ')' -> no further argument */

                if (*p == ')')
                    break;

                /* else a ',' is expected as separator */
                if (*p++ != ',') {
                    yyerror("Missing ',' in #define parameter list");
                    return;
                }
                SKIPWHITE;
            }
            if (arg == NARGS)
            {
                lexerror("Too many macro arguments");
                return;
            }
        }

        p++;  /* skip ')' */

        /* Parse the replacement text into mtext[], performing
         * macro argument marking as necessary.
         */

        for (inid = MY_FALSE, q = mtext; *p; )
        {
            /* Identifiers are parsed until complete, with the first
             * character pointed to by <ids>.
             */

            if (isalunum(*p))
            {
                /* Identifier. If inid is false, it is a new one.
                 */

                if (!inid)
                {
                    inid = MY_TRUE;
                    ids = p;
                }
            }
            else
            {
                /* Not an identifier, or, if inid is true, the end
                 * of one.
                 */

                if (inid)
                {
                    int idlen = p - ids;
                    size_t l;
                    int n;

                    /* Check if the identifier matches one of the
                     * function arguments. If yes, replace it in mtext[]
                     * by the MARKS sequence.
                     */
                    for (n = 0; n < arg; n++)
                    {
                        l = strlen(args[n]);
                        if (l == idlen && strncmp(args[n], ids, l) == 0)
                        {
                            q -= idlen;
                            *q++ = (char)MARKS;
                            *q++ = (char)(n+MARKS+1);
                            break;
                        }
                    }
                    inid = MY_FALSE;
                }
            }

            /* Whatever the character is, for now store it in mtext[].
             * Literal '@' are escaped.
             */
            *q = *p;
            if (*p++ == MARKS)
                *++q = MARKS;
            if (q < mtext+MLEN-2)
                q++;
            else
            {
                lexerror("Macro text too long");
                return;
            }

            /* If we are at line's end and it is escaped with '\',
             * get the next line and continue.
             */
            if (!*p)
            {
                if (p[-2] == '\\')
                {
                    q -= 2;
                    quote = refill(quote);
                    p = yytext;
                }
                else if (p[-2] == '\r' && p[-3] == '\\' )
                {
                    q -= 3;
                    quote = refill(quote);
                    p = yytext;
                }
            }
        }

        /* Terminate the text and add the macro */
        *--q = '\0';
        add_define(namebuf, arg, mtext);
    }
    else
    {
        /* --- Normal Macro --- */

        /* Parse the replacement text into mtext[].
         */

        for (q = mtext; *p; )
        {
            *q = *p++;
            if (q < mtext+MLEN-2)
                q++;
            else
            {
                lexerror("Macro text too long");
                return;
            }

            /* If we are at line's end and it is escaped with '\',
             * get the next line and continue.
             */
            if (!*p)
            {
                if (p[-2] == '\\')
                {
                    q -= 2;
                    quote = refill(quote);
                    p = yytext;
                }
                else if (p[-2] == '\r' && p[-3] == '\\' )
                {
                    q -= 3;
                    quote = refill(quote);
                    p = yytext;
                }
            }
        }

        /* Terminate the text and add the macro */
        *--q = '\0';
        add_define(namebuf, -1, mtext);
    }

#undef GETALPHA
#undef SKIPWHITE

} /* handle_define() */

/*-------------------------------------------------------------------------*/
static void
add_define (char *name, short nargs, char *exps)

/* Add a new macro definition for macro <name> with <nargs> arguments
 * and the replacement text <exps>. The positions where the arguments
 * are to be put into <exps> have to be marked with the MARKS character
 * as described elsewhere.
 *
 * The new macro is stored in the ident_table[] and also put into
 * the list of all_defines.
 *
 * If the macro <name> is already defined, an error is generated.
 */

{
    struct ident *p;

    /* Lookup/create a new identifier entry */
    p = make_shared_identifier(name, I_TYPE_DEFINE, 0);
    if (!p)
    {
        lexerror("Out of memory");
        return;
    }

    /* If such a macro already exists with different meaning,
     * generate an error.
     */
    if (p->type != I_TYPE_UNKNOWN)
    {
        if (nargs != p->u.define.nargs
         || p->u.define.special
         || strcmp(exps,p->u.define.exps.str) != 0)
        {
            char buf[200+NSIZE];
            sprintf(buf, "Redefinition of #define %s", name);
            yyerror(buf);
        }
        return;
    }

    /* New macro: initialise the ident.u.define and
     * add it to the list of defines.
     */

    p->type = I_TYPE_DEFINE;
    p->u.define.nargs = nargs;
    p->u.define.permanent = MY_FALSE;
    p->u.define.special = MY_FALSE;
    if ( !(p->u.define.exps.str = xalloc(strlen(exps)+1)) )
    {
        free_shared_identifier(p);
        lexerror("Out of memory");
        return;
    }
    strcpy(p->u.define.exps.str, exps);

    p->next_all = all_defines;
    all_defines = p;
#if defined(LEXDEBUG)
    fprintf(stderr, "define '%s' %d '%s'\n", name, nargs, exps);
#endif
} /* add_define() */

/*-------------------------------------------------------------------------*/
static void
add_permanent_define (char *name, short nargs, void *exps, Bool special)

/* Add a new permanent macro definition for macro <name>
 * with <nargs> arguments and the replacement text <exps>.
 * The positions where the arguments are to be put into <exps> have to be
 * marked with the MARKS character as described elsewhere.
 *
 * If <special> is true, <exps> is not a text pointer, but instead
 * a pointer to a function returning a text.
 *
 * The new macro is stored in the ident_table[] and also put into
 * the list of permanent_defines.
 *
 * If the macro <name> is already defined, an error is generated.
 *
 * TODO: Instead of <exps>,<special>, it should be <exps>,<fun>
 * TODO:: with proper types.
 */

{
    struct ident *p;

    /* Lookup/create a new identifier entry */
    p = make_shared_identifier(name, I_TYPE_DEFINE, 0);
    if (!p)
    {
        error("Out of memory\n");
    }

    /* If such a macro already exists with different meaning,
     * generate an error.
     */
    if (p->type != I_TYPE_UNKNOWN)
    {
        if (nargs != p->u.define.nargs
         || p->u.define.special
         || strcmp(exps,p->u.define.exps.str) != 0)
        {
            error("Redefinition of #define %s", name);
        }
        return;
    }

    /* New macro: initialise the ident.u.define and
     * add it to the list of permanent defines.
     */

    p->type = I_TYPE_DEFINE;
    p->u.define.nargs = nargs;
    p->u.define.permanent = MY_TRUE;
    p->u.define.special = (short)special;
    if (!special)
        p->u.define.exps.str = (char *)exps;
    else
        p->u.define.exps.fun = (defn_fun)exps;
    p->next_all = permanent_defines;
    permanent_defines = p;
} /* add_permanent_define() */

/*-------------------------------------------------------------------------*/
void
free_defines (void)

/* Free all non-permanent defines, and undo any undefine of a permanent
 * define.
 *
 * Also called from the garbage collector and simul_efun.c
 */

{
    struct ident *p, *q;

    /* Free all non-permanent defines */

    for (p = all_defines; p; p = q)
    {
        q = p->next_all;
        if (p->name)
        {
            if (!p->u.define.special)
                xfree(p->u.define.exps.str);
            free_shared_identifier(p);
        }
        else
        {
            /* has been undef'd. */
            xfree(p);
        }
    }
    all_defines = NULL;


    /* Reactivate undefined permanent defines */

    for (p = undefined_permanent_defines; p; p = q)
    {
        struct ident *curr, **prev;

        q = p->next;
        p->next = NULL;
        prev = &ident_table[p->hash];
        while ( NULL != (curr = *prev) )
        {
            if (curr->name == p->name) /* found it */
            {
                p->next = curr->next;
                free_string(p->name);
                break;
            }
            prev = &curr->next;
        } /* not found, create new one */
        p->inferior = curr;
        *prev = p;
    }
    undefined_permanent_defines = NULL;
    nexpands = 0;
} /* free_defines() */

/*-------------------------------------------------------------------------*/
static struct ident *
lookup_define (char *s)

/* Lookup the name <s> in the identtable and return a pointer to its
 * ident structure if it is a define. Return NULL else.
 */

{
    struct ident *curr, *prev;
    int h;

    h = identhash(s);

    curr = ident_table[h];
    prev = 0;
    while (curr)
    {
        if (!strcmp(curr->name, s)) /* found it */
        {
            if (prev) /* not at head of list */
            {
                prev->next = curr->next;
                curr->next = ident_table[h];
                ident_table[h] = curr;
            }
            if (curr->type == I_TYPE_DEFINE)
                return curr;
            return NULL;
        }
        prev = curr;
        curr = curr->next;
    } /* not found */

    return NULL;
} /* lookup_define() */


/*-------------------------------------------------------------------------*/
static Bool
expand_define (void)

/* Check if yytext[] holds a macro and expand it if it is.
 * Return true if it was expanded, false if not.
 */

{
    struct ident *p;

    p = lookup_define(yytext);
    if (!p) {
        return MY_FALSE;
    }
    return _expand_define(&p->u.define);
}

/*-------------------------------------------------------------------------*/
static Bool
_expand_define (struct defn *p)

/* Expand the macro <p> and add_input() the expanded text.
 * For function macros, the function expects the next non-white character
 * in the input buffer to be the opening '(' of the argument list.
 *
 * Return true if the expansion was successfull, false if not.
 */

{
  /* Skip the whitespace in the input buffer until the next non-blank
   * and store that one in variable <c>.
   */
#define SKIPW \
    for(;;) {\
        do {\
            c = cmygetc();\
        } while(lexwhite(c));\
        if (c == '\n') {\
            myfilbuf();\
            store_line_number_info();\
            current_line++;\
            total_lines++;\
        } else break;\
    }

    static char *expbuf = NULL;
      /* The arguments of a function macro, separated by '\0' characters.
       */
    static char *buf = NULL;
      /* Construction buffer for the expanded macro text.
       */

      /* Both buffers are allocated on the first call to the
       * function and reused thereafter. Putting them on the
       * stack would make _expand_define() reentrant, but
       * very slow on systems without proper alloca().
       * Right now the only possibility for a recursive call
       * is an error during the expansing, with error handling requesting
       * another expansion. In this case, reentrancy is not an issue
       * because after returning from the error, the function itself
       * returns immediately.
       *
       * But should the need ever arise, the old fragments may be
       * changed to implement a stack of buffers.
       */

#if 0
    static int mutex = 0;
      /* TODO: The mutex may be used to implement a stack of buffers if needed.
       */
#endif

    char *args[NARGS];
      /* Pointers into expbuf[] to the beginning of the actual
       * macro arguments.
       */
    char *q;  /* Pointer into expbuf[] when parsing the args */
    char *e;  /* Pointer to replacement text */
    char *b;  /* Pointer into buf[] when expanding */
    char *r;  /* Next character to read from input buffer */

#if 0
    /* TODO: This was a test for recursive calls. If a stack of buffers is
     * TODO:: needed, this code fragments allow an easy implementation,
     * TODO:: especially because the DEMUTEX macros are already where
     * TODO:: they have to be.
     */
    if (mutex++)
    {
        lexerror("Recursive call to _expand_define()");
        mutex--;
        return 0;
    }
#define DEMUTEX mutex--
#else
#define DEMUTEX NOOP
#endif

    /* Allocate the buffers if not done already */
    if (!expbuf)
        expbuf = permanent_xalloc(DEFMAX * sizeof(char));
    if (!buf)
        buf = permanent_xalloc(DEFMAX * sizeof(char));
    if (!expbuf || !buf) {
        lexerror("Stack overflow");
        DEMUTEX;
        return 0;
    }

    /* No more than EXPANDMAX expansions per line */
    if (nexpands++ > EXPANDMAX)
    {
        lexerror("Too many macro expansions");
        DEMUTEX;
        return MY_FALSE;
    }

    if (p->nargs == -1)
    {
        /* --- Normal Macro --- */

        if (!p->special)
        {
            add_input(p->exps.str);
        }
        else
        {
            e = (*p->exps.fun)(NULL);
            if (!e) {
                lexerror("Out of memory");
                DEMUTEX;
                return 0;
            }
            add_input(e);
            xfree(e);
        }

        /* That's it. Jump to the function's end now. */
    }
    else
    {
        /* --- Function Macro --- */

        int c;
        int parcnt = 0;  /* Number of pending open' (' */
        Bool dquote = MY_FALSE; /* true: in "" */
        Bool squote = MY_FALSE; /* true: in '' */
        int n;           /* Number of parsed macro arguments */

        /* Look for the argument list */
        SKIPW;
        if (c != '(') {
            yyerror("Missing '(' in macro call");
            DEMUTEX;
            return MY_FALSE;
        }

        /* Parse the macro arguments and store them in args[].
         * This is a bit complex as we have to care for character
         * constants, string literals, parentheses, symbols and
         * comments.
         */

        SKIPW;
        if (c == ')')
            n = 0;  /* No args */
        else
        {
            /* Setup */
            r = outp;
            *--r = (char)c;
            q = expbuf;
            args[0] = q;

            for (n = 0;;)
            {
                if (q >= expbuf + DEFMAX - 5)
                {
                    lexerror("Macro argument overflow");
                    DEMUTEX;
                    return MY_FALSE;
                }

                switch(c = *r++)
                {
                  case '"' :
                    /* Begin of string literal, or '"' constant */
                    if (!squote)
                        dquote = !dquote;
                    *q++ = (char)c;
                    continue;

                  case '#':
                    /* Outside of strings it must be a #'symbol.
                     */
                    *q++ = (char)c;
                    if (!squote && !dquote && *r == '\'')
                    {
                        r++;
                        *q++ = '\'';
                        if (isalunum(c = *r))
                        {
                            do {
                                *q++ = (char)c;
                                ++r;
                            } while (isalunum(c = *r));
                        }
                        else
                        {
                            char *end;

                            if (symbol_operator(r, &end) < 0)
                            {
                                yyerror("Missing function name after #'");
                            }
                            strncpy(q, r, (size_t)(end - r));
                            q += end - r;
                            r = end;
                        }
                    }
                    continue;

                  case '\'':
                    /* Begin of character constant or quoted symbol.
                     */
                    if ( !dquote
                     && (!isalunum(*r) || r[1] == '\'')
                     && (*r != '(' || r[1] != '{') )
                    {
                        squote = !squote;
                    }
                    *q++ = (char)c;
                    continue;

                  case '(' :
                    /* Begin of nested expression.
                     */
                    if (!squote && !dquote)
                        parcnt++;
                    *q++ = (char)c;
                    continue;

                  case ')' :
                    /* End of nested expression.
                     */
                    if (!squote && !dquote)
                    {
                        parcnt--;
                        if (parcnt < 0)
                        {
                            /* We found the end of the argument list */
                            *q++ = '\0';
                            n++;
                            break;
                        }
                    }
                    *q++ = (char)c;
                    continue;

                  case '\\':
                    /* In strings, escaped sequence.
                     */
                    *q++ = (char)c;
                    if (squote || dquote)
                    {
                        c = *r++;
                        if (c == '\r')
                            c = *r++;
                        if (c == '\n')  /* nope! This wracks consistency! */
                        {
                            store_line_number_info();
                            current_line++;
                            total_lines++;
                            if (!*r)
                            {
                                outp = r;
                                r = _myfilbuf();
                            }
                            q--;        /* alas, long strings should work. */
                            continue;
                        }
                        if (c == CHAR_EOF) /* can't quote THAT */
                        {
                            r--;
                            continue;
                        }
                        *q++ = (char)c;
                    }
                    continue;

                  case '\n':
                    /* Next line.
                     */
                    store_line_number_info();
                    current_line++;
                    total_lines++;
                    *q++ = ' ';
                    if (!*r) {
                        outp = r;
                        r = _myfilbuf();
                    }
                    if (squote || dquote) {
                        lexerror("Newline in string");
                        DEMUTEX;
                        return MY_FALSE;
                    }
                    continue;

                  case ',':
                    /* Argument separation
                     */
                    if (!parcnt && !dquote && !squote)
                    {
                        *q++ = '\0';
                        args[++n] = q;
                        if (n == NARGS - 1)
                        {
                            lexerror("Maximum macro argument count exceeded");
                            DEMUTEX;
                            return MY_FALSE;
                        }
                        continue;
                    }
                    *q++ = (char)c;
                    continue;

                  case CHAR_EOF:
                        lexerror("Unexpected end of file");
                        DEMUTEX;
                        return MY_FALSE;

                  case '/':
                    /* Probable comment
                     */
                    if (!squote && !dquote)
                    {
                        /* TODO: Shouldn't this recognise '//' comments, too?
                         */
                        if ( (c = *r++) == '*')
                        {
                            outp = r;
                            skip_comment();
                            r = outp;
                        }
                        else
                        {
                            --r;
                            *q++ = '/';
                        }
                        continue;
                    }

                  default:
                    *q++ = (char)c;
                    continue;
                } /* end switch */

                /* The only way to come here is in the case ')' when the
                 * end of the argument list is detected. Hence, we can
                 * break the for().
                 */
                break;
            } /* for(n = 0..NARGS) */
            outp = r;
        } /* if (normal or function macro) */

        /* Proper number of arguments? */
        if (n != p->nargs)
        {
            yyerror("Wrong number of macro arguments");
            DEMUTEX;
            return MY_FALSE;
        }

        /* (Don't) handle dynamic function macros */
        if (p->special)
        {
            (void)(*p->exps.fun)(args);
            DEMUTEX;
            return MY_TRUE;
        }

        /* Construct the expanded macro text in buf[] by simple
         * copy and replace.
         */

        b = buf;
        e = p->exps.str;
        while (*e)
        {
            if (*e == MARKS)
            {
                if (*++e == MARKS)
                    *b++ = *e++;
                else
                {
                    for (q = args[*e++ - MARKS - 1]; *q; )
                    {
                        *b++ = *q++;
                        if (b >= buf+DEFMAX)
                        {
                            lexerror("Macro expansion overflow");
                            DEMUTEX;
                            return MY_FALSE;
                        }
                    }
                }
            }
            else
            {
                *b++ = *e++;
                if (b >= buf+DEFMAX)
                {
                    lexerror("Macro expansion overflow");
                    DEMUTEX;
                    return MY_FALSE;
                }
            }
        }

        /* Terminate the expanded text and add it to the input */
        *b++ = '\0';
        add_input(buf);
    }

    /* That's it. */

    DEMUTEX;
    return MY_TRUE;

#undef SKIPW
}

/*-------------------------------------------------------------------------*/
static int
exgetc (void)

/* Get the first character of the next element of a condition
 * and return it, leaving the input pointing to the rest of it.
 * Comments are skipped, identifiers not defined as macros are
 * replaced with ' 0 ', the predicate 'defined(<name>)' is
 * replaced with ' 0 ' or ' 1 ' depending on the result.
 */

{
#define SKPW         do c = (unsigned char)mygetc(); while(lexwhite(c)); myungetc((char)c)
  /* Skip the whitespace in the input buffer until the first non-blank.
   * End with the input pointing to this non-blank.
   */

    register unsigned char c;
    register char *yyp;

    c = (unsigned char)mygetc();
    for (;;)
    {
        if ( isalpha(c) || c=='_' )
        {
            /* It's an identifier, maybe a macro name, maybe it's
             * an 'defined()' predicate.
             */

            /* Get the full identifier in yytext[] */
            yyp = yytext;
            do {
                SAVEC;
                c=(unsigned char)mygetc();
            } while ( isalunum(c) );
            myungetc((char)c);

            *yyp='\0';
            if (strcmp(yytext, "defined") == 0)
            {
                /* handle the 'defined' predicate */
                do c = (unsigned char)mygetc(); while(lexwhite(c));
                if (c != '(')
                {
                    yyerror("Missing ( in defined");
                    continue;
                }
                do c = (unsigned char)mygetc(); while(lexwhite(c));
                yyp=yytext;
                while ( isalunum(c) )
                {
                    SAVEC;
                    c=(unsigned char)mygetc();
                }
                *yyp='\0';
                while(lexwhite(c)) c = (unsigned char)mygetc();
                if (c != ')') {
                    yyerror("Missing ) in defined");
                    continue;
                }
                SKPW;
                if (lookup_define(yytext))
                    add_input(" 1 ");
                else
                    add_input(" 0 ");
            }
            else
            {
                /* Simple identifier */
                if (!expand_define())
                    add_input(" 0 ");
            }
            c = (unsigned char)mygetc();
        }
        else if (c == '\\' && *outp == '\n')
        {
            /* Escaped new line: read the next line, strip
             * all comments, and then add the result again
             * for reparsing.
             */

            Bool quote;

            outp++;
            yyp = yytext;
            for(quote = MY_FALSE;;)
            {
                c = (unsigned char)mygetc();
                if (c == '"')
                    quote = !quote;
                while(!quote && c == '/') { /* handle comments cpp-like */
                    char c2;

                    if ( (c2 = mygetc()) == '*') {
                        skip_comment();
                        c=(unsigned char)mygetc();
                    } else if (c2 == '/') {
                        outp = skip_pp_comment(outp);
                        current_line--;
                        c = '\n';
                    } else {
                        --outp;
                        break;
                    }
                }
                SAVEC;
                if (c == '\n') {
                    break;
                }
            }
            *yyp = '\0';
            current_line++;
            total_lines++;
            add_input(yytext);
            nexpands = 0;
            c = (unsigned char)mygetc();
        }
        else
        {
            break;
        }
    }

    return c;

#undef SKPW
} /* exgetc() */

/*-------------------------------------------------------------------------*/
static int
cond_get_exp (int priority, struct svalue *svp)

/* Evaluate the expression in the input buffer at a priority of at least
 * <priority> and store the result in <svp> (which is assumed to be
 * invalid at the time of call).
 * Return the result if it is numeric, or a truthvalue for string
 * expressions.
 *
 * The function assumes to be called at the proper beginning of
 * an expression, i.e. if it encounters an operator even before a value,
 * it must be unary.
 */

{
    int c;
    int value = 0;
    int value2, x;
    struct svalue sv2;

    svp->type = T_INVALID;
    do c = exgetc(); while ( lexwhite(c) );

    /* Evaluate the first value */

    if (c == '(')
    {
        /* It's a parenthesized subexpression */

        value = cond_get_exp(0, svp);

        do c = exgetc(); while ( lexwhite(c) );
        if ( c != ')' )
        {
            yyerror("parentheses not paired in #if");
            if (c == '\n')
                myungetc('\n');
        }
    }
    else if ( ispunct(c) )
    {
        /* It is a string or an unary operator */

        if (c == '"')
        {
            /* Get the string */

            char *p, *q;

            q = p = outp;
            for (;;)
            {
                c = *p++;
                if (c == '"')
                {
                    break;
                }
                if (c == '\n')
                {
                    yyerror("unexpected end of string in #if");
                    put_malloced_string(svp, string_copy(""));
                    return 0;
                }
                if (c == '\\')
                {
                    c = *p++;
                    if (c == '\n')
                    {
                        current_line++;
                        *--p = '"';
                        break;
                    }
                }
                *q++ = (char)c;
            }
            *q = '\0';
            put_malloced_string(svp, string_copy(outp));
            outp = p;
        }
        else
        {
            /* Is it really an operator? */
            x = optab1[c];
            if (!x)
            {
                yyerror("illegal character in #if");
                return 0;
            }

            /* Get the value for this unary operator */
            value = cond_get_exp(12, svp);

            /* Evaluate the operator */
            switch ( optab2[x-1] )
            {
              case BNOT  : value = ~value; break;
              case LNOT  : value = !value; break;
              case UMINUS: value = -value; break;
              case UPLUS : value =  value; break;
              default :
                yyerror("illegal unary operator in #if");
                free_svalue(svp);
                svp->type = T_NUMBER;
                return 0;
            }

            if (svp->type != T_NUMBER)
            {
                yyerror("illegal type to unary operator in #if");
                free_svalue(svp);
                svp->type = T_NUMBER;
                return 0;
            }
            svp->u.number = value;
        }
    }
    else
    {
        /* It must be a number */

        int base;

        if ( !lexdigit(c) )
        {
            if (c == '\n')
            {
                yyerror("missing expression in #if");
                myungetc('\n');
            }
            else
                yyerror("illegal character in #if");
            return 0;
        }

        value = 0;

        /* Determine the base of the number */
        if (c != '0')
            base=10;
        else
        {
            c = mygetc();
            if (c == 'x' || c == 'X')
            {
                base = 16;
                c = mygetc();
            }
            else
                base = 8;
        }

        /* Now parse the number */
        for(;;)
        {
            if ( isdigit(c) )      x = -'0';
            else if ( isupper(c) ) x = -'A'+10;
            else if ( islower(c) ) x = -'a'+10;
            else break;
            x += c;
            if (x > base)
                break;
            value = value * base + x;
            c = mygetc();
        }
        myungetc((char)c);
        put_number(svp, value);
    }


    /* Now evaluate the following <binop> <expr> pairs (if any) */

    for (;;)
    {
        do c=exgetc(); while ( lexwhite(c) );

        /* An operator or string must come next */
        if ( !ispunct(c) )
            break;

        /* If it's a string, make it a string addition */
        if (c == '"')
        {
            myungetc('"');
            c = '+';
        }

        /* Can it be an operator at all? */
        x = optab1[c];
        if (!x)
            break;

        /* See if the optab[] defines an operator for these characters
         */
        value2 = mygetc();
        for (;;x+=3)
        {
            if (!optab2[x])
            {
                myungetc((char)value2);
                if (!optab2[x+1])
                {
                    yyerror("illegal operator use in #if");
                    return 0;
                }
                break;
            }
            if (value2 == optab2[x])
                break;
        }

        /* If the priority of the operator is too low, we are done
         * with this (sub)expression.
         */
        if (priority >= optab2[x+2])
        {
            if (optab2[x])
                myungetc((char)value2);
            break;
        }

        /* Get the second operand */
        value2 = cond_get_exp(optab2[x+2], &sv2);

        /* Evaluate the operands:
         *   Full set of operations for numbers.
         *   Addition and lexicographic comparisons for strings.
         */
        if (svp->type == T_NUMBER && sv2.type == T_NUMBER)
        {
            switch (optab2[x+1])
            {
              case MULT   : value *= value2;                break;
              case DIV    : if (!value2) lexerror("Division by zero");
                            else value /= value2;         break;
              case MOD    : if (!value2) lexerror("Division by zero");
                            else value %= value2;         break;
              case BPLUS  : value += value2;                break;
              case BMINUS : value -= value2;                break;
              case LSHIFT : if ((uint)value2 > MAX_SHIFT) value = 0;
                            else value <<= value2; break;
              case RSHIFT : value >>= (uint)value2 > MAX_SHIFT ? MAX_SHIFT : value2;
                            break;
              case LESS   : value = value <  value2;        break;
              case LEQ    : value = value <= value2;        break;
              case GREAT  : value = value >  value2;        break;
              case GEQ    : value = value >= value2;        break;
              case EQ     : value = value == value2;        break;
              case NEQ    : value = value != value2;        break;
              case BAND   : value &= value2;                break;
              case XOR    : value ^= value2;                break;
              case BOR    : value |= value2;                break;
              case LAND   : value = value && value2;        break;
              case LOR    : value = value || value2;        break;
              case QMARK  :
                  do c=exgetc(); while( lexwhite(c) );
                  if (c != ':')
                  {
                      yyerror("'?' without ':' in #if");
                      myungetc((char)c);
                      return 0;
                  }
                  if (value)
                  {
                      *svp = sv2;
                      cond_get_exp(1, &sv2);
                      free_svalue(&sv2);
                      value = value2;
                  }
                  else
                      value = cond_get_exp(1, svp);
                  break;
            } /* switch() */
        }
        else if (svp->type == T_STRING && sv2.type == T_STRING)
        {
            x = optab2[x+1];
            if (x == BPLUS)
            {
                char *str;

                str = xalloc(strlen(svp->u.string) + strlen(sv2.u.string) + 1);
                strcpy(str, svp->u.string);
                strcat(str, sv2.u.string);
                free_string_svalue(svp);
                free_string_svalue(&sv2);
                svp->u.string = str;
            }
            else
            {
                value = strcmp(svp->u.string, sv2.u.string);
                free_string_svalue(svp);
                svp->type = T_NUMBER;
                free_string_svalue(&sv2);
                switch (x)
                {
                  case LESS   : value = value <  0; break;
                  case LEQ    : value = value <= 0; break;
                  case GREAT  : value = value >  0; break;
                  case GEQ    : value = value >= 0; break;
                  case EQ     : value = value == 0; break;
                  case NEQ    : value = value != 0; break;
                  default:
                    yyerror("illegal operator use in #if");
                    return 0;
                }
                put_number(svp, value);
            }
        }
        else
        {
            yyerror("operands in #if won't match");
            free_svalue(svp);
            svp->type = T_NUMBER;
            free_svalue(&sv2);
            return 0;
        }
    }
    myungetc((char)c);
    return value;
} /* cond_get_expr() */

/*-------------------------------------------------------------------------*/
void
set_inc_list (struct vector *v)

/* EFUN: set_driver_hook(H_INCLUDE_DIRS, ({ list }) )
 *
 * Set the list of pathnames to search for <>-include files to the
 * names in <v>.
 *
 * The function takes ownership of v->item[], but replaces all string
 * values by its own copies. Since the original v is held in
 * the driver_hook[] array, this is safe to do.
 */

{
    size_t i;
    char *p;
    struct svalue *svp;
    mp_int len, max;

    /* Count and test the passed pathnames */

    svp = v->item;
    for (i = 0, max = 0; i < VEC_SIZE(v); i++, svp++)
    {
        if (svp->type != T_STRING)
        {
            error("H_INCLUDE_DIRS argument has a non-string array element\n");
        }

        /* Set p to the beginning of the pathname, skipping leading
         * '/' and './'.
         */
        p = svp->u.string;
        for(;;) {
            if (*p == '/')
                p++;
            else if (*p == '.' && p[1] == '/')
                p += 2;
            else
                break;
        }

        /* Is the path legal? */
        if (!legal_path(p))
        {
            error("H_INCLUDE_DIRS path contains '..'\n");
        }
        if (*p == '.' && !p[1])
            error("H_INCLUDE_DIRS path is a single prefix dot\n");

        len = (signed)strlen(p);
        if (max < len)
            max = len;
        if (len >= 2 && p[len -1] == '.' && p[len - 2] == '/')
            error("H_INCLUDE_DIRS path ends in single prefix dot\n");

        /* Get and store our own copy of the pathname */
        p = string_copy(p);
        if (!p)
            error("Out of memory\n");

        free_svalue(svp);
        svp->x.string_type = STRING_MALLOC;
        svp->u.string = p;
    }

    inc_list = v->item;
    inc_list_size = VEC_SIZE(v);
    inc_list_maxlen = max;
} /* set_inc_list() */

/*-------------------------------------------------------------------------*/
static char *
get_current_file (char ** args UNUSED)

/* Dynamic macro __FILE__: return the name of the current file.
 * In compat mode, don't return a leading slash.
 */

{
#ifdef __MWERKS__
#    pragma unused(args)
#endif
    char *buf;

    buf = xalloc(strlen(current_file)+4);
    if (!buf)
        return NULL;
#ifdef COMPAT_MODE
    sprintf(buf, "\"%s\"", current_file);
#else
    sprintf(buf, "\"/%s\"", current_file);
#endif
    return buf;
}

/*-------------------------------------------------------------------------*/
static char *
get_current_line (char ** args UNUSED)

/* Dynamic macro __LINE__: return the number of the current line.
 */

{
#ifdef __MWERKS__
#    pragma unused(args)
#endif
    char *buf;

    buf = xalloc(12);
    if (!buf)
        return NULL;
    sprintf(buf, "%d", current_line);
    return buf;
}

/*-------------------------------------------------------------------------*/
static char *
get_version(char ** args UNUSED)

/* Dynamic macro __VERSION__: return the driver version.
 */

{
#ifdef __MWERKS__
#    pragma unused(args)
#endif
    char *buf;
    size_t len;
    short bIsRelease;

    bIsRelease = IS_RELEASE();
    if (bIsRelease)
        len = strlen(GAME_VERSION LOCAL_LEVEL);
    else
        len = strlen(LONG_VERSION LOCAL_LEVEL);
    buf = xalloc(3 + len);
    if (!buf) return 0;
    buf[0] = '"';
    if (bIsRelease)
        strcpy(buf+1, GAME_VERSION LOCAL_LEVEL);
    else
        strcpy(buf+1, LONG_VERSION LOCAL_LEVEL);
    buf[len+1] = '"';
    buf[len+2] = '\0';
    return buf;
}

/*-------------------------------------------------------------------------*/
static char *
get_hostname (char ** args UNUSED)

/* Dynamic macro __HOSTNAME__: return the hostname.
 */

{
#ifdef __MWERKS__
#    pragma unused(args)
#endif
    char *tmp, *buf;

    tmp = query_host_name();
    buf = xalloc(strlen(tmp)+3);
    if (!buf) return 0;
    sprintf(buf, "\"%s\"", tmp);
    return buf;
}

/*-------------------------------------------------------------------------*/
static char *
get_domainname (char ** args UNUSED)

/* Dynamic macro __DOMAINNAME__: return the domainname.
 */

{
#ifdef __MWERKS__
#    pragma unused(args)
#endif
    char *buf;

    buf = xalloc(strlen(domain_name)+3);
    if (!buf)
        return 0;
    sprintf(buf, "\"%s\"", domain_name);
    return buf;
}

/*-------------------------------------------------------------------------*/
static char *
efun_defined (char **args)

/* Dynamic macro __EFUN_DEFINE__(name): test if the efun is defined
 * and add ' 0 ' or ' 1 ' depending on the result.
 */

{
    struct ident *p;

    p = make_shared_identifier(args[0], I_TYPE_GLOBAL, 0);
    if (!p)
    {
        lexerror("Out of memory");
        return NULL;
    }

    while (p->type > I_TYPE_GLOBAL)
    {
        if ( !(p = p->inferior) )
            break;
    }

    add_input(
      (p && p->type == I_TYPE_GLOBAL && p->u.global.efun >= 0) ?
        " 1 " : " 0 "
    );

    if (p && p->type == I_TYPE_UNKNOWN)
        free_shared_identifier(p);

    return NULL;
}

/*-------------------------------------------------------------------------*/
void
remove_unknown_identifier (void)

/* Remove all identifiers from the ident_table[] which are of
 * type I_TYPE_UNKNOWN.
 */

{
    int i;
    struct ident *id, *next;

    for (i = ITABLE_SIZE; --i >= 0; )
    {
        id = ident_table[i];
        for ( ; id; id = next)
        {
            next = id->next;
            if (id->type == I_TYPE_UNKNOWN)
                free_shared_identifier(id);
        }
    }
}

/*-------------------------------------------------------------------------*/
#ifdef MALLOC_smalloc

void
count_lex_refs (void)

/* GC support: clear all references held by the lexer.
 */

{
    int i;
    struct ident *id;

    /* Identifier */
    for (i = ITABLE_SIZE; --i >= 0; )
    {
        id = ident_table[i];
        for ( ; id; id = id->next) {
            count_ref_from_string(id->name);
            note_malloced_block_ref((char *)id);
        }
    }

    for (id = permanent_defines; id; id = id->next_all)
    {
        if (!id->u.define.special)
            note_malloced_block_ref(id->u.define.exps.str);
    }

    if (auto_include_string)
        note_malloced_block_ref(auto_include_string);

    if (defbuf_len)
        note_malloced_block_ref(defbuf);
}
#endif /* MALLOC_smalloc */

/*-------------------------------------------------------------------------*/
char *
lex_error_context (void)

/* Create the current lexing context in a static buffer and return its
 * pointer.
 */

{
    static char buf[20];
    char *end;
    mp_int len;

    if (!pragma_verbose_errors)
        return "";

    strcpy(buf, yychar == -1 ? (len = 5, "near ") : (len = 7, "before "));

    if (!yychar || !*outp)
    {
        strcpy(buf+len, "end of line");
    }
    else
    {
        strncpy(buf + len, outp, sizeof buf - 1 - len);
        buf[sizeof buf - 1] = '\0';
        if ( NULL != (end = strchr(buf, '\n')) )
            *end = '\0';
    }
    return buf;
}

/*-------------------------------------------------------------------------*/
void
clear_auto_include_string (void)

/* Clear the auto_include_string if any.
 */

{
    if (auto_include_string)
    {
        xfree(auto_include_string);
        auto_include_string = NULL;
    }
} /* clear_auto_include_string() */

/*-------------------------------------------------------------------------*/
struct svalue *
f_set_auto_include_string (struct svalue *sp)

/* EFUN set_auto_include_string()
 *
 *    void set_auto_include_string(string arg)
 *
 * The arg will be automatically included into every compiled LPC
 * object. This is useful to enforce global definitions, e.g.
 * ``#pragma combine_strings'' or ``#pragma strict_types''.  The
 * calling object needs to be privileged by the master object.
 *
 * Note that the auto-include-string is cleared when the master
 * object is reloaded.
 */

{
    char *s;

    if (sp->type != T_STRING)
        bad_xefun_arg(1, sp);

    if (_privilege_violation("set_auto_include_string", sp, sp) > 0)
    {
        clear_auto_include_string();
        s = sp->u.string;
        auto_include_string = xalloc(strlen(s)+2);
        *auto_include_string = '\n';
        strcpy(auto_include_string+1, s);

        /* Count the number of lines of the added string */
        for (auto_include_start = 0; *s
            ; auto_include_start -= *s++ == '\n') NOOP;
    }
    free_svalue(sp);
    return sp - 1;
} /* set_auto_include_string() */

/*-------------------------------------------------------------------------*/
struct svalue *
f_expand_define (struct svalue *sp)

/* EFUN expand_define()
 *
 *   string expand_define (string name)
 *   string expand_define (string name, string arg, ...)
 *
 * Expands the macro <name> with the argument(s) <arg>... (default is
 * one empty string "").
 * Result is the expanded macro, or 0 if there is no macro with
 * that name.
 *
 * This efun is applicable only while an object is compiled,
 * therefore its usage is restricted to a few functions like the
 * H_INCLUDE_DIRS driver hook, or the masters runtime_error()
 * function.
 */

{
    char *arg, *res, *end;
    struct ident *d;

    /* Get the arguments from the stack */
    if (sp[-1].type != T_STRING)
        bad_xefun_arg(1, sp);

    arg = sp->u.string;
    if (sp->type != T_STRING) {
        if (sp->type != T_NUMBER || sp->u.number)
            bad_xefun_arg(2, sp);
        arg = "";
    }

    res = NULL;

    /* If we are compiling, lookup the given name and store
     * the expansion in res.
     */
    if (current_file && outp > defbuf && outp <= &defbuf[defbuf_len])
    {
        myungetc('\n');
        end = outp;
        add_input(arg);
        d = lookup_define(sp[-1].u.string);
        if (d && _expand_define(&d->u.define) )
        {
            *end = '\0';
            res = string_copy(outp);
        }
        outp = &end[1];
    }
    free_svalue(sp);
    free_svalue(--sp);

    /* Return the result */
    if (!res)
    {
        put_number(sp, 0);
    }
    else
    {
        sp->x.string_type = STRING_MALLOC;
        sp->u.string = res;
    }

    return sp;
}

/***************************************************************************/

