/* This software is Copyright 1989, 1990, 1992, 1993 by various individuals.
   Please see the accompanying file COPYRIGHT for details. */

#include <stdio.h>
#include <stdlib.h>

#include "db.h"
#include "atof.h"
#include "inst.h"
#include "defs.h"
#include "ctype.h"
#include "prims.h"
#include "externs.h"
#include "property.h"
#include "interface.h"

static hash_tab primitive_list[COMP_HASH_SIZE];

/* The name "IF_STACK" is historical; it holds most control structure,
   not just ifs. */
struct IF_STACK {
  int source;
#define SOURCE_ERROR (-1)
#define SOURCE_IF          0
#define SOURCE_ELSE        1
#define SOURCE_FOR         2
#define SOURCE_DO          3
#define SOURCE_CONTINUE    4
#define SOURCE_BREAK       5
  struct INTERMEDIATE *place;
  struct IF_STACK *next;
  } ;

struct PATCHUP {
  struct PATCHUP *next;
  struct INTERMEDIATE *place;
  } ;

/* ntoks < 0 means the definition is still being accumulated */
struct DEFINE {
  struct DEFINE *next;
  const char *name;
  int ntoks;
  const char **toks;
  unsigned int inuse : 1;
  } ;

struct EXPDEF {
  struct EXPDEF *link;
  struct DEFINE *d;
  int x;
  } ;

struct LIBINFO {
  dbref program;
  char *name;
  } ;

/* For procedures declared forward, "code" is a nil pointer until the
   procedure gets defined, and the patchups list hold pointers to calls
   that need to be patched up. */
struct PROC_LIST {
  const char *name;
  struct INTERMEDIATE *code;
  struct PROC_LIST *next;
  struct PATCHUP *patchups;
  struct LIBINFO *libinfo;
  } ;

struct INTERMEDIATE {
  int no;
  struct inst in;
  struct INTERMEDIATE *next;
  } ;

struct BLOCK_STACK {
  struct BLOCK_STACK *link;
  struct IF_STACK *css;
  struct INTERMEDIATE *patch;
  struct INTERMEDIATE *top;
  } ;

static struct DEFINE *defs;
static struct EXPDEF *dxstack;
static int dxdepth;
static struct IF_STACK *if_stack;
static struct BLOCK_STACK *blocks;
static struct PROC_LIST *procs;
static int nowords;
static struct INTERMEDIATE *curr_word;
static struct INTERMEDIATE *first_word;
static struct INTERMEDIATE *curr_proc;
static struct PROC_LIST *lastdefn;
/* this list must match init_variables() in interp.c */
static const char *variables[MAX_VAR] = { "ME",
					  "LOC",
					  "TRIGGER",
					  "COMMAND" };
#define RES_VAR 4

static struct line *curr_line;
static int lineno;
static const char *next_char;
static dbref player;
static dbref program;
static dbref msgrecip;

static int compile_err;

static char *line_copy = 0;
static int macrosubs;

/* Character defines */
#define BEGINCOMMENT '('
#define ENDCOMMENT ')'
#define BEGINSTRING '"'
#define ENDSTRING '"'
#define BEGINMACRO '.'
#define DBREFFLAG '#'
#define QUOTEFLAG '\''

#define SUBSTITUTIONS 20  /* How many nested macros will we allow? */

/* abort compile macro */
#define abort_compile(C) { abort_compile_((const char *)(C)); return(0); }

/* for void functions */
#define v_abort_compile(C) { abort_compile_((const char *)(C)); return; }

static struct INTERMEDIATE *next_word(const char *); /* forward */

static void free_define(struct DEFINE *d)
{
 int i;

 cfree(d->name);
 for (i=d->ntoks-1;i>=0;i--) cfree(d->toks[i]);
 free(d->toks);
 free(d);
}

/* Clean up everything, either when done or when aborting */
static void cleanup(void)
{
 int v;

 while (first_word)
  { struct INTERMEDIATE *wd;
    wd = first_word;
    first_word = wd->next;
    /* don't use CLEAR / interp_clear; unusual fields are used */
    switch (wd->in.type)
     { case PROG_STRING:
	  free(wd->in.data.string);
	  break;
       case PROG_FLOAT:
	  free(wd->in.data.flt);
	  break;
     }
    free(wd);
  }
 while (if_stack)
  { struct IF_STACK *i;
    i = if_stack;
    if_stack = i->next;
    free(i);
  }
 while (procs)
  { struct PROC_LIST *p;
    p = procs;
    procs = p->next;
    cfree(p->name);
    while (p->patchups)
     { struct PATCHUP *u;
       u = p->patchups;
       p->patchups = u->next;
       free(u);
     }
    if (p->libinfo)
     { free(p->libinfo->name);
       free(p->libinfo);
     }
    free(p);
  }
 while (dxstack)
  { struct EXPDEF *x;
    x = dxstack;
    dxstack = x->link;
    free(x);
  }
 dxdepth = 0;
 while (defs)
  { struct DEFINE *d;
    d = defs;
    defs = d->next;
    free_define(d);
  }
 for (v=RES_VAR;(v<MAX_VAR)&&variables[v];v++)
  { cfree(variables[v]);
    variables[v] = 0;
  }
}

static dbref notify_or_prop(const char *msg)
{
 dbref o;
 char buf[64];
 struct propref *pr;

 o = NOTHING;
 pr = lookup_property(program,"@muf-msg-owner",0);
 if (pr) o = propref_get_as_dbref(pr,&dbref_is_player);
 if (o == NOTHING) o = OWNER(program);
 if (awake_count(o) > 0)
  { notify(o,msg);
    return(o);
  }
 else
  { sprintf(&buf[0],".muf-msg-%d",(int)program);
    pr = lookup_property(o,&buf[0],LP_CREATE,PPERM_COMPAT_PRIVATE);
    propref_set_type_and_value(pr,PTYPE_STRING,msg);
    propref_done(pr);
    pr = lookup_property(o,".muf-msg-any",LP_CREATE,PPERM_COMPAT_PRIVATE);
    propref_set_type_and_value(pr,PTYPE_STRING,"y");
    propref_done(pr);
    return(NOTHING);
  }
}

static void compile_warn(const char *msg)
{
 char buf[BUFFER_LEN];

 sprintf(&buf[0],"Warning in line %d of #%d: %s",lineno,(int)program,msg);
 if (msgrecip != NOTHING)
  { notify(msgrecip,&buf[0]);
  }
 else
  { notify_or_prop(&buf[0]);
  }
}

static void abort_compile_(const char *msg)
{
 char buf[BUFFER_LEN];

 sprintf(&buf[0],"Error in line %d of #%d: %s",lineno,(int)program,msg);
 if (line_copy)
  { free((void *)line_copy);
    line_copy = 0;
  }
 if (msgrecip != NOTHING)
  { notify(msgrecip,&buf[0]);
  }
 else
  { dbref told;
    told = notify_or_prop(&buf[0]);
    if ((player != NOTHING) && (player != told))
     { sprintf(&buf[0],"Program #%d failed to compile; its owner has been notified.",(int)program);
       notify(player,&buf[0]);
     }
  }
 cleanup();
 compile_err ++;
 free_prog(program);
}

/* Little routine to do the line_copy handling right */
static void advance_line(void)
{
 curr_line = curr_line->next;
 lineno ++;
 macrosubs = 0;
 if (line_copy)
  { free(line_copy);
    line_copy = 0;
  }
 line_copy = curr_line ? dup_string(curr_line->this_line) : 0;
 next_char = line_copy;
}

/* skip comments */
static void do_comment(void)
{
 while (1)
  { while (*next_char && (*next_char != ENDCOMMENT)) next_char ++;
    if (*next_char) break;
    advance_line();
    if (! curr_line) v_abort_compile("Unterminated comment.");
  }
 next_char ++;
}

static const char *do_string(void)
{
 char buf[BUFFER_LEN];
 int i;
 int q;

 buf[0] = *next_char++;
 i = 1;
 q = 0;
 while (*next_char && (q || (*next_char != ENDSTRING)))
  { if (!q && (*next_char == '\\'))
     { q = 1;
     }
    else
     { buf[i++] = *next_char;
       if (i >= BUFFER_LEN-2) abort_compile("String too long.");
       q = 0;
     }
    next_char ++;
  }
 if (! *next_char)
  { abort_compile("Unterminated string.");
  }
 next_char ++;
 buf[i] = '\0';
 return(dup_string(buf));
}

/* Skips comments, grabs strings, returns NULL when no more tokens to grab. */
static const char *next_token(int flags)
#define T_GETNL 1
#define T_NOXD 2
{
 char buf[BUFFER_LEN];
 char *expansion;
 char *temp;
 struct DEFINE *d;
 const char *tok;
 int i;

top:;
 if (dxstack)
  { if (dxstack->x >= dxstack->d->ntoks)
     { struct EXPDEF *x;
       x = dxstack;
       dxstack = x->link;
       x->d->inuse = 0;
       free(x);
       dxdepth --;
       goto top;
     }
    tok = dxstack->d->toks[dxstack->x++];
  }
 else
  { if (! curr_line) return(0);
    if (! next_char) return(0);
    /* skip white space */
    while (*next_char && Cisspace(*next_char)) next_char ++;
    if (! *next_char)
     { advance_line();
       if (flags & T_GETNL) return(dup_string("\n"));
       if (! curr_line) return(0);
       goto top;
     }
    /* take care of comments */
    if (*next_char == BEGINCOMMENT)
     { do_comment();
       goto top;
     }
    if (*next_char == BEGINSTRING) return(do_string());
    /* macro */
    if (*next_char == BEGINMACRO)
     { next_char ++;
       for (i=0;*next_char&&!Cisspace(*next_char);i++)
	{ buf[i] = *next_char++;
	}
       buf[i] = '\0';
       expansion = macro_expansion(macrotop,buf);
       if (! expansion)
	{ abort_compile("Macro not defined.");
	}
       else
	{ if (++macrosubs > SUBSTITUTIONS)
	   { abort_compile("Too many macro substitutions.");
	   }
	  else
	   { temp = (char *) malloc(strlen(next_char)+strlen(expansion)+21);
	     sprintf(temp,"%s%s",expansion,next_char);
	     free(expansion);
	     free(line_copy);
	     next_char = line_copy = temp;
	     goto top;
	   }
	}
     }
    /* ordinary token */
    for (i=0;*next_char&&!Cisspace(*next_char);i++)
     { buf[i] = *next_char++;
     }
    buf[i] = '\0';
    tok = &buf[0];
  }
 if (! (flags & T_NOXD))
  { for (d=defs;d;d=d->next)
     { if (d->inuse) continue;
       if (! string_compare(tok,d->name))
	{ struct EXPDEF *x;
	  x = malloc(sizeof(struct EXPDEF));
	  x->link = dxstack;
	  dxstack = x;
	  x->d = d;
	  x->x = 0;
	  d->inuse = 1;
	  goto top;
	}
     }
  }
 return(dup_string(tok));
}

/* allocate and initialize data linked structure. */
static struct INTERMEDIATE *new_inst(void)
{
 struct INTERMEDIATE *new;

 new = malloc(sizeof(struct INTERMEDIATE));
 new->next = 0;
 new->no = 0;
 new->in.type = 0;
 new->in.data.number = 0;
 return(new);
}

/* add procedure to procedures list */
static struct PROC_LIST *add_proc(const char *proc_name, struct INTERMEDIATE *place)
{
 struct PROC_LIST *new;

 new = malloc(sizeof(struct PROC_LIST));
 new->name = proc_name;
 new->code = place;
 new->next = procs;
 new->patchups = 0;
 new->libinfo = 0;
 procs = new;
 return(new);
}

/* add if to if stack */
static void addif(struct INTERMEDIATE *place, int from)
{
 struct IF_STACK *new;

 new = malloc(sizeof(struct IF_STACK));
 new->place = place;
 new->next = if_stack;
 new->source = from;
 if_stack = new;
}

/* like addif but inserts just below the argument, instead of on top. */
static void insertif(struct IF_STACK *below, struct INTERMEDIATE *place, int from)
{
 struct IF_STACK *new;

 new = malloc(sizeof(struct IF_STACK));
 new->place = place;
 new->source = from;
 new->next = below->next;
 below->next = new;
}

/* returns the type of the top element on the if stack */
static int query_if(void)
{
 return(if_stack?if_stack->source:SOURCE_ERROR);
}

/* pops topmost if off the stack and returns it */
static struct INTERMEDIATE *find_if(void)
{
 struct INTERMEDIATE *temp;
 struct IF_STACK *tofree;

 if (!if_stack) return(0);
 temp = if_stack->place;
 tofree = if_stack;
 if_stack = if_stack->next;
 free(tofree);
 return(temp);
}

/* drain SOURCE_CONTINUE and SOURCE_BREAK items */
static void drain_cont_break(int contaddr, int breakaddr)
{
 while (1)
  { switch (query_if())
     { default:
	  return;
	  break;
       case SOURCE_CONTINUE:
	  find_if()->in.data.number = contaddr;
	  break;
       case SOURCE_BREAK:
	  find_if()->in.data.number = breakaddr;
	  break;
     }
  }
}

/* finds topmost loop structure (DO or FOR), 0 if none */
static struct IF_STACK *findloop(void)
{
 struct IF_STACK *ifs;

 for (ifs=if_stack;ifs;ifs=ifs->next)
  { switch (ifs->source)
     { case SOURCE_DO: case SOURCE_FOR:
	  return(ifs);
	  break;
     }
  }
 return(0);
}

/* return primitive number, given name */
static int get_primitive(const char *token)
{
 hash_data *hd;

 hd = find_hash(token,primitive_list,COMP_HASH_SIZE);
 return(hd?hd->ival:0);
}

/* returns depth of FOR nesting */
static int for_nest(void)
{
 int rv;
 struct IF_STACK *temp;

 rv = 0;
 for (temp=if_stack;temp;temp=temp->next)
  { if (temp->source == SOURCE_FOR) rv++;
  }
 return(rv);
}

/* Adds variable.  Return variable number, or 0 if no space left.
   Note variable number 0 is valid but already taken by a builtin. */
static int add_variable(const char *varname)
{
 int i;

 for (i=RES_VAR;i<MAX_VAR;i++) if (!variables[i]) break;
 if (i == MAX_VAR) return(0);
 variables[i] = dup_string(varname);
 return(i);
}

/* XXX */

static int variable(const char *token)
{
 int i;

 for (i=0;(i<MAX_VAR)&&variables[i];i++)
  { if (!string_compare(token,variables[i])) return(1);
  }
 return(0);
}

/* returns number corresponding to variable number; assume it exists */
static struct INTERMEDIATE *var_word(const char *token)
{
 struct INTERMEDIATE *new;
 int var_no;

 new = new_inst();
 new->no = nowords++;
 new->in.type = PROG_VAR;
 for (var_no=0;var_no<MAX_VAR;var_no++)
  { if (!string_compare(token,variables[var_no])) break;
  }
 new->in.data.number = var_no;
 return(new);
}

/* see if call to already-defined word */
static struct PROC_LIST *call(const char *token)
{
 struct PROC_LIST *i;

 for (i=procs;i;i=i->next)
  { if (!string_compare(i->name,token)) return(i);
  }
 return(0);
}

static void reference_procedure(struct PROC_LIST *p, struct INTERMEDIATE *i)
{
 struct PATCHUP *u;

 if (p->code)
  { i->in.data.number = p->code->no;
  }
 else
  { i->in.data.number = -1;
    u = malloc(sizeof(struct PATCHUP));
    u->next = p->patchups;
    p->patchups = u;
    u->place = i;
  }
}

static void repair_patchups(struct PROC_LIST *p)
{
 struct PATCHUP *u;

 while (p->patchups)
  { u = p->patchups;
    p->patchups = u->next;
    u->place->in.data.number = p->code->no;
    free(u);
  }
}

/* call a defined word: push address onto stack, then IN_EXECUTE it. */
static struct INTERMEDIATE *call_word(const char *token)
{
 struct INTERMEDIATE *new;
 struct PROC_LIST *p;

 new = new_inst();
 new->no = nowords++;
 new->in.type = PROG_ADD;
 p = call(token);
 if (! p) abort_compile("Compiler internal error: can't find call");
 reference_procedure(p,new);
 new->next = new_inst();
 new->next->no = nowords++;
 new->next->in.type = PROG_PRIMITIVE;
 new->next->in.data.number = IN_EXECUTE;
 return(new);
}

/* Built-in "syntax" words */
static int special(const char *token)
{
 struct spec {
   const char *name;
   int val;
   } ;
 static struct spec specials[] = {
#define SPEC__TICK 1
				   { "'", SPEC__TICK },
#define SPEC__COLON 2
				   { ":", SPEC__COLON },
#define SPEC__SEMICOLON 3
				   { ";", SPEC__SEMICOLON },
#define SPEC_IF 4
				   { "IF", SPEC_IF },
#define SPEC_ELSE 5
				   { "ELSE", SPEC_ELSE },
#define SPEC_EIF 6
				   { "EIF", SPEC_EIF },
#define SPEC_THEN 7
				   { "THEN", SPEC_THEN },
#define SPEC_FOR 8
				   { "FOR", SPEC_FOR },
#define SPEC_DO 9
				   { "BEGIN", SPEC_DO },
				   { "DO", SPEC_DO },
#define SPEC_BREAK 10
				   { "BREAK", SPEC_BREAK },
#define SPEC_CONTINUE 11
				   { "CONTINUE", SPEC_CONTINUE },
#define SPEC_WHILE 12
				   { "WHILE", SPEC_WHILE },
#define SPEC_UNTIL 13
				   { "UNTIL", SPEC_UNTIL },
#define SPEC_LOOP 14
				   { "LOOP", SPEC_LOOP },
				   { "REPEAT", SPEC_LOOP },
#define SPEC_CALL 15
				   { "CALL", SPEC_CALL },
#define SPEC_EXEC 16
				   { "EXEC", SPEC_EXEC },
#define SPEC_EXIT 17
				   { "EXIT", SPEC_EXIT },
#define SPEC_FORK 18
				   { "FORK", SPEC_FORK },
#define SPEC_VAR 19
				   { "VAR", SPEC_VAR },
#define SPEC_FORWARD 20
				   { "FORWARD", SPEC_FORWARD },
#define SPEC__DEF 21
				   { "$DEF", SPEC__DEF },
#define SPEC__DEFINE 22
				   { "$DEFINE", SPEC__DEFINE },
#define SPEC__ENDDEF 23
				   { "$ENDDEF", SPEC__ENDDEF },
#define SPEC__UNDEF 24
				   { "$UNDEF", SPEC__UNDEF },
#define SPEC_TIMED_PROMPT 25
				   { "TIMED-PROMPT", SPEC_TIMED_PROMPT },
#define SPEC__LBRACE 26
				   { "{"/*}*/, SPEC__LBRACE },
#define SPEC__RBRACE 27
				   { /*{*/"}", SPEC__RBRACE },
#define SPEC__LIB 28
				   { "$LIB", SPEC__LIB },
#define SPEC__IMPORT 29
				   { "$IMPORT", SPEC__IMPORT },
				   };
#define SPEC__N (sizeof(specials)/sizeof(specials[0]))
 static int didinit = 0;
 int l;
 int h;
 int m;
 int c;

 if (! didinit)
  { int i;
    int any;
    struct spec t;
    do
     { any = 0;
       for (i=SPEC__N-1;i>0;i--)
	{ if (string_compare(specials[i-1].name,specials[i].name) > 0)
	   { t = specials[i-1];
	     specials[i-1] = specials[i];
	     specials[i] = t;
	     any ++;
	   }
	}
     } while (any);
    didinit = 1;
  }
 if (! token) return(0);
 l = -1;
 h = SPEC__N;
 while (h-l > 1)
  { m = (l + h) / 2;
    c = string_compare(token,specials[m].name);
    if (c == 0) return(specials[m].val);
    if (c < 0) h = m; else l = m;
  }
 return(0);
}

static void do_def(int shortform)
{
 struct DEFINE *d;
 struct strlist {
   struct strlist *link;
   const char *s;
   } ;
 const char *name;
 struct strlist *list;
 struct strlist **tail;
 struct strlist *l;
 const char *tok;
 int ntok;
 int i;

 if (curr_proc) panic("do_def with curr_proc"); /* caller already checked */
 name = next_token(T_NOXD);
 if (! name) v_abort_compile( shortform
			      ? "Unexpected EOF after $DEF"
			      : "Unexpected EOF after $DEFINE" );
 for (d=defs;d;d=d->next)
  { if (! string_compare(name,d->name))
     { cfree(name);
       v_abort_compile( shortform
			? "$DEF of already-defined name"
			: "$DEFINE of already-defined name" );
     }
  }
 d = malloc(sizeof(struct DEFINE));
 d->next = defs;
 defs = d;
 d->name = name;
 d->ntoks = -1;
 d->toks = 0;
 d->inuse = 0;
 tail = &list;
 ntok = 0;
 while (1)
  { tok = next_token(shortform?(T_GETNL|T_NOXD):T_NOXD);
    if (! tok) v_abort_compile("Unexpected EOF in $DEFINE");
    if (tok[0] == '\n') break;
    if (! string_compare(tok,"$ENDDEF"))
     { if (shortform)
	{ cfree(tok);
	  v_abort_compile("$ENDDEF found in $DEF replacement text");
	}
       break;
     }
    l = malloc(sizeof(struct strlist));
    l->s = tok;
    *tail = l;
    tail = &l->link;
    ntok ++;
  }
 cfree(tok);
 *tail = 0;
 d->ntoks = ntok;
 d->toks = malloc(ntok*sizeof(const char *));
 i = 0;
 while (list)
  { l = list;
    list = l->link;
    d->toks[i++] = l->s;
    free(l);
  }
 if (i != ntok) v_abort_compile("Internal error: token count mismatch in do_def");
}

/*
 * Note that we defer binding of exported names to internal names to
 *  run-time; that's why "name" in define_imported_word is the exported
 *  name, not the internal-to-the-library name.  (See map_lib_callname
 *  in interp.c for more.)
 */

static void define_imported_word(const char *as, dbref lib, const char *name)
{
 struct PROC_LIST *p;

 p = add_proc(dup_string(as),0);
 p->libinfo = malloc(sizeof(struct LIBINFO));
 p->libinfo->program = lib;
 p->libinfo->name = dup_string(name);
}

static int import_from_property(struct propref *pr, void *lvp)
{
 char *name;

 name = propref_get_name(pr);
 if ( ((propref_get_attr(pr) & PATTR_TYPE) == PTYPE_STRING) &&
      !string_n_compare(name,"_export-",8) &&
      name[8] )
  { define_imported_word(name+8,*(dbref *)lvp,name+8);
  }
 return(0);
}

static dbref find_library(const char *name)
{
 dbref d;

 if (name[0] == '#')
  { d = (dbref) atoi(name+1);
    if ((d < 0) || (d >= db_top) || (Typeof(d) != TYPE_PROGRAM)) return(NOTHING);
  }
 else
  { struct propref *pr;
    dbref libroom;
    char *pn;
    pr = lookup_property(GLOBAL_ENVIRONMENT,"@muf-library-room",0);
    if (pr == 0) return(NOTHING);
    libroom = propref_get_as_dbref(pr,&dbref_is_room);
    if (libroom == NOTHING) return(NOTHING);
    pn = malloc(5+strlen(name)+1);
    sprintf(pn,"_lib-%s",name);
    pr = lookup_property(libroom,pn,0);
    free(pn);
    if (pr)
     { d = propref_get_as_dbref(pr,&dbref_is_program);
       if (d != NOTHING) return(d);
     }
    DOLIST(d,DBFETCH(libroom)->contents)
     { if ((Typeof(d) == TYPE_PROGRAM) && !string_compare(NAME(d),name)) break;
     }
  }
 return(d);
}

static void do_library(int justoneword)
{
 const char *tofree1;
 const char *tofree2;
 const char *tofree3;
 const char *tok;
 const char *libname;
 const char *wordname;
 const char *wordas;
 dbref lib;

 tofree1 = 0;
 tofree2 = 0;
 tofree3 = 0;
 tok = next_token(T_GETNL);
 if (tok[0] == '\n')
  { abort_compile_( justoneword
		    ? "$IMPORT: missing arguments"
		    : "$LIB: missing library name" );
    goto freeret;
  }
 tofree1 = tok;
 libname = (tok[0] == BEGINSTRING) ? tok+1 : tok;
 if (justoneword)
  { tok = next_token(T_GETNL);
    if (tok[0] == '\n')
     { abort_compile_("$IMPORT: missing word name");
       goto freeret;
     }
    tofree2 = tok;
    wordname = (tok[0] == BEGINSTRING) ? tok+1 : tok;
    tok = next_token(T_GETNL);
    if (tok[0] == '\n')
     { wordas = 0;
     }
    else
     { tofree3 = tok;
       wordas = (tok[0] == BEGINSTRING) ? tok+1 : tok;
       tok = next_token(T_GETNL);
       if (tok[0] != '\n')
	{ abort_compile_("$IMPORT: trailing junk");
	  goto freeret;
	}
     }
  }
 else
  { tok = 0;
    wordname = 0;
    wordas = 0;
  }
 lib = find_library(libname);
 if (lib == NOTHING)
  { abort_compile_( justoneword
		    ? "$IMPORT: no such library"
		    : "$LIB: no such library" );
    goto freeret;
  }
 if (justoneword)
  { define_imported_word(wordas?:wordname,lib,wordname);
  }
 else
  { walk_plist(DBFETCH(lib)->properties,0,import_from_property,&lib);
  }
freeret:;
 if (tok) cfree(tok);
 if (tofree1) cfree(tofree1);
 if (tofree2) cfree(tofree2);
 if (tofree3) cfree(tofree3);
}

/* see if token is instance of a primitive */
static int primitive(const char *token)
{
 return(get_primitive(token));
}

static struct INTERMEDIATE *do_exit(void)
{
 struct INTERMEDIATE *new;
 struct INTERMEDIATE *curr;
 int nest;

 nest = for_nest();
 new = new_inst();
 if (nest > 0)
  { new->no = nowords ++;
    new->in.type = PROG_INTEGER;
    new->in.data.number = nest;
    new->next = curr = new_inst();
    curr->no = nowords ++;
    curr->in.type = PROG_PRIMITIVE;
    curr->in.data.number = IN_FOR_POP;
    curr->next = new_inst();
    curr = curr->next;
  }
 else
  { curr = new;
  }
 curr->no = nowords ++;
 curr->in.type = PROG_PRIMITIVE;
 curr->in.data.number = IN_RET;
 return(new);
}

/* Process a "special" word.  In particular, maintain the ifstack. */
static struct INTERMEDIATE *process_special(int spec)
{
 char buf[BUFFER_LEN];
 const char *tok;
 struct INTERMEDIATE *new;

 new = 0;
 switch (spec)
  { case SPEC__TICK:
	{ const char *proc_name;
	  struct PROC_LIST *p;
	  proc_name = next_token(0);
	  if (! proc_name) abort_compile("Unexpected EOF after '");
	  p = call(proc_name);
	  if (! p)
	   { cfree(proc_name);
	     abort_compile("Token after ' is not a procedure");
	   }
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_PTR;
	  reference_procedure(p,new);
	  cfree(proc_name);
	}
       break;
    case SPEC__COLON:
	{ struct PROC_LIST *p;
	  const char *proc_name;
	  if (curr_proc) abort_compile("Definition within definition.");
	  if (blocks) abort_compile("Definition within code block.");
	  proc_name = next_token(0);
	  if (! proc_name) abort_compile("Unexpected end of file within procedure.");
	  tok = next_token(0);
	  new = next_word(tok);
	  if (tok) cfree(tok);
	  if (! new)
	   { sprintf(buf,"Error in definition of %s.",proc_name);
	     cfree(proc_name);
	     abort_compile(buf);
	   }
	  p = call(proc_name);
	  if (p)
	   { if (p->code)
	      { sprintf(&buf[0],"Redefinition of %s.",proc_name);
		cfree(proc_name);
		abort_compile(&buf[0]);
	      }
	     p->code = new;
	     repair_patchups(p);
	     cfree(proc_name);
	     lastdefn = p;
	   }
	  else
	   { if (special(proc_name) || primitive(proc_name))
	      { sprintf(&buf[0],"Definition of %s hides builtin.",proc_name);
		compile_warn(&buf[0]);
	      }
	     lastdefn = add_proc(proc_name,new);
	   }
	  curr_proc = new;
	}
       break;
    case SPEC__SEMICOLON:
       if (if_stack) abort_compile("Unexpected end of procedure definition.");
       if (blocks) abort_compile("Definition end within code block.");
       if (! curr_proc) abort_compile("Procedure without body.");
       curr_proc = 0;
       new = new_inst();
       new->no = nowords ++;
       new->in.type = PROG_PRIMITIVE;
       new->in.data.number = IN_RET;
       break;
    case SPEC__DEF:
       if (dxstack) abort_compile("$DEF appearing in a $DEF/$DEFINE expansion");
       if (curr_proc) abort_compile("$DEF inside a procedure");
       if (blocks) abort_compile("$DEF inside code block");
       do_def(1);
       break;
    case SPEC__DEFINE:
       if (dxstack) abort_compile("$DEFINE appearing in a $DEF/$DEFINE expansion");
       if (curr_proc) abort_compile("$DEFINE inside a procedure");
       if (blocks) abort_compile("$DEFINE inside code block");
       do_def(0);
       break;
    case SPEC__ENDDEF:
       abort_compile("Unexpected $ENDDEF encountered");
       break;
    case SPEC__UNDEF:
	{ const char *name;
	  struct DEFINE **dp;
	  struct DEFINE *d;
	  if (dxstack) abort_compile("$UNDEF appearing in a $DEF/$DEFINE expansion");
	  if (curr_proc) abort_compile("$UNDEF inside a procedure");
	  if (blocks) abort_compile("$UNDEF inside code block.");
	  name = next_token(T_NOXD);
	  if (! name) abort_compile("Unexpected EOF after $UNDEF");
	  for (dp=&defs;(d=*dp);)
	   { if (! string_compare(name,d->name))
	      { *dp = d->next;
		free_define(d);
	      }
	     else
	      { dp = &d->next;
	      }
	   }
	}
       break;
    case SPEC_IF:
	{ struct INTERMEDIATE *curr;
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_ADD;
	  new->in.data.number = 0;
	  new->next = curr = new_inst();
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_IF;
	  addif(new,SOURCE_IF);
	}
       break;
    case SPEC_ELSE:
	{ struct INTERMEDIATE *eef;
	  struct INTERMEDIATE *curr;
	  if (query_if() != SOURCE_IF) abort_compile("ELSE improperly nested.");
	  eef = find_if();
	  if (! eef) abort_compile("ELSE without IF.");
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_ADD;
	  new->in.data.number = 0;
	  new->next = curr = new_inst();
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_JMP;
	  addif(new,SOURCE_IF);
	  eef->in.data.number = nowords;
	}
       break;
    case SPEC_EIF:
	{ struct INTERMEDIATE *eef;
	  struct INTERMEDIATE *curr;
	  if (query_if() != SOURCE_IF) abort_compile("EIF improperly nested.");
	  eef = find_if();
	  if (! eef) abort_compile("EIF without IF.");
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_ADD;
	  new->in.data.number = 0;
	  new->next = new_inst();
	  curr = new->next;
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_IF;
	  addif(eef,SOURCE_ELSE);
	  addif(new,SOURCE_IF);
	  return(new);
	}
       break;
    case SPEC_THEN:
	{ struct INTERMEDIATE *eef;
	  if (query_if() != SOURCE_IF) abort_compile("THEN improperly nested.");
	  eef = find_if();
	  if (! eef) abort_compile("THEN without IF.");
	  eef->in.data.number = nowords;
	  while (query_if() == SOURCE_ELSE) find_if()->in.data.number = nowords;
	}
       break;
    case SPEC_FOR:
	{ struct INTERMEDIATE *curr;
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_PRIMITIVE;
	  new->in.data.number = IN_FOR_ADD;
	  new->next = curr = new_inst();
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_NOP;
	  addif(curr,SOURCE_FOR);
	}
       break;
    case SPEC_DO:
       new = new_inst();
       new->no = nowords ++;
       new->in.type = PROG_PRIMITIVE;
       new->in.data.number = IN_NOP;
       addif(new,SOURCE_DO);
       break;
    case SPEC_BREAK:
    case SPEC_WHILE:
	{ struct IF_STACK *loopif;
	  struct IF_STACK *it;
	  struct INTERMEDIATE *curr;
	  loopif = findloop();
	  if (! loopif)
	   { abort_compile( (spec == SPEC_WHILE)
			    ? "WHILE not inside a loop"
			    : "BREAK not inside a loop" );
	   }
	  if (loopif->source == SOURCE_FOR)
	   { for (it=loopif->next;it&&(it->source==SOURCE_CONTINUE);it=it->next) ;
	     if (it && (it->source == SOURCE_BREAK))
	      { new = new_inst();
		new->no = nowords ++;
		new->in.type = PROG_ADD;
		new->in.data.number = it->place->no - 2;
		new->next = new_inst();
		curr = new->next;
		curr->no = nowords ++;
		curr->in.type = PROG_PRIMITIVE;
		curr->in.data.number = (spec == SPEC_WHILE) ? IN_IF : IN_JMP;
	      }
	     else
	      { struct INTERMEDIATE *tostack;
		new = new_inst();
		curr = new;
		if (spec == SPEC_WHILE)
		 { static int IN_NOT = -1;
		   if (IN_NOT < 0) IN_NOT = get_primitive("not");
		   curr->no = nowords ++;
		   curr->in.type = PROG_PRIMITIVE;
		   curr->in.data.number = IN_NOT;
		   curr->next = new_inst();
		   curr = curr->next;
		   curr->no = nowords ++;
		   curr->in.type = PROG_ADD;
		   curr->in.data.number = nowords + 5;
		   curr->next = new_inst();
		   curr = curr->next;
		   curr->no = nowords ++;
		   curr->in.type = PROG_PRIMITIVE;
		   curr->in.data.number = IN_IF;
		   curr->next = new_inst();
		   curr = curr->next;
		 }
		curr->no = nowords ++;
		curr->in.type = PROG_INTEGER;
		curr->in.data.number = 1;
		curr->next = new_inst();
		curr = curr->next;
		curr->no = nowords ++;
		curr->in.type = PROG_PRIMITIVE;
		curr->in.data.number = IN_FOR_POP;
		curr->next = new_inst();
		curr = curr->next;
		curr->no = nowords ++;
		curr->in.type = PROG_ADD;
		curr->in.data.number = 0;
		tostack = curr;
		curr->next = new_inst();
		curr = curr->next;
		curr->no = nowords ++;
		curr->in.type = PROG_PRIMITIVE;
		curr->in.data.number = IN_JMP;
		insertif(loopif,tostack,SOURCE_BREAK);
	      }
	   }
	  else
	   { new = new_inst();
	     new->no = nowords ++;
	     new->in.type = PROG_ADD;
	     new->in.data.number = 0;
	     new->next = new_inst();
	     curr = new->next;
	     curr->no = nowords ++;
	     curr->in.type = PROG_PRIMITIVE;
	     curr->in.data.number = (spec == SPEC_WHILE) ? IN_IF : IN_JMP;
	     insertif(loopif,new,SOURCE_BREAK);
	   }
	}
       break;
    case SPEC_CONTINUE:
	{ struct IF_STACK *loopif;
	  struct INTERMEDIATE *curr;
	  loopif = findloop();
	  if (! loopif) abort_compile("CONTINUE not inside a loop");
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_ADD;
	  new->in.data.number = 0;
	  new->next = new_inst();
	  curr = new->next;
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_JMP;
	  insertif(loopif,new,SOURCE_CONTINUE);
	  return(new);
	}
       break;
    case SPEC_UNTIL:
    case SPEC_LOOP:
	{ struct INTERMEDIATE *eef;
	  struct INTERMEDIATE *curr;
	  switch (query_if())
	   { case SOURCE_IF:
	     case SOURCE_ELSE:
		abort_compile("LOOP improperly nested.");
		break;
	     case SOURCE_ERROR:
		abort_compile("Unopened LOOP.");
		break;
	     case SOURCE_DO:
		eef = find_if();
		new = new_inst();
		new->no = nowords ++;
		new->in.type = PROG_ADD;
		new->in.data.number = eef->no;
		new->next = curr = new_inst();
		curr->no = nowords ++;
		curr->in.type = PROG_PRIMITIVE;
		curr->in.data.number = (spec == SPEC_UNTIL) ? IN_IF : IN_JMP;
		drain_cont_break(eef->no,nowords);
		break;
	     case SOURCE_FOR:
		if (spec == SPEC_UNTIL) abort_compile("FOR loops cannot use UNTIL.");
		eef = find_if();
		new = new_inst();
		new->no = nowords ++;
		new->in.type = PROG_PRIMITIVE;
		new->in.data.number = IN_FOR_CHECK;
		new->next = curr = new_inst();
		curr->no = nowords ++;
		curr->in.type = PROG_ADD;
		curr->in.data.number = eef->no;
		curr->next = new_inst();
		curr = curr->next;
		curr->no = nowords ++;
		curr->in.type = PROG_PRIMITIVE;
		curr->in.data.number = IN_LOOP;
		drain_cont_break(new->no,nowords);
		break;
	     default:
		 { char BUF[80];
		   sprintf(BUF,"Unexpected IF_STACK type: %d.",query_if());
		   abort_compile(BUF);
		 }
		break;
	   }
	}
       break;
    case SPEC_CALL:
	{ struct INTERMEDIATE *curr;
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_PRIMITIVE;
	  new->in.data.number = IN_CALL;
	  new->next = curr = new_inst();
	  curr->no = nowords ++;
	  curr->in.type = PROG_OBJECT;
	  curr->in.data.objref = program;
	  curr->next = new_inst();
	  curr = curr->next;
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_PROGRAM;
	}
       break;
    case SPEC_EXEC:
	{ struct INTERMEDIATE *curr;
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_PRIMITIVE;
	  new->in.data.number = IN_EXEC;
	  new->next = curr = new_inst();
	  curr->no = nowords ++;
	  curr->in.type = PROG_OBJECT;
	  curr->in.data.objref = program;
	  curr->next = new_inst();
	  curr = curr->next;
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_ENDEXEC;
	  return(new);
	}
       break;
    case SPEC_EXIT:
       return(do_exit());
       break;
    case SPEC_FORK:
       new = new_inst();
       new->no = nowords ++;
       new->in.type = PROG_PRIMITIVE;
       new->in.data.number = IN_FORK;
       break;
    case SPEC_VAR:
       if (curr_proc) abort_compile("Variable declared within procedure.");
       if (blocks) abort_compile("Variable declared within code block.");
       tok = next_token(0);
       if (! tok) abort_compile("Unexpected EOF in variable declaration.");
       if (! add_variable(tok))
	{ cfree(tok);
	  abort_compile("Variable limit exceeded.");
	}
       if (tok) cfree(tok);
       break;
    case SPEC_FORWARD:
	{ struct PROC_LIST *p;
	  if (curr_proc) abort_compile("FORWARD declaration within procedure.");
	  if (blocks) abort_compile("FORWARD declaration within code block.");
	  tok = next_token(0);
	  if (tok)
	   { p = call(tok);
	     if (p) cfree(tok); else add_proc(tok,0);
	   }
	}
       break;
    case SPEC_TIMED_PROMPT:
	{ struct INTERMEDIATE *curr;
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_PRIMITIVE;
	  new->in.data.number = IN_TIMED_PROMPT;
	  new->next = curr = new_inst();
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_T_P_ABORT;
	  curr->next = new_inst();
	  curr = curr->next;
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_T_P_READ;
	  return(new);
	}
       break;
    case SPEC__LBRACE:
	{ struct INTERMEDIATE *curr;
	  struct BLOCK_STACK *blk;
	  new = new_inst();
	  new->no = nowords ++;
	  new->in.type = PROG_ADD;
	  new->in.data.number = 0;
	  new->next = curr = new_inst();
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_JMP;
	  curr->next = new_inst();
	  curr = curr->next;
	  curr->no = nowords ++;
	  curr->in.type = PROG_PRIMITIVE;
	  curr->in.data.number = IN_NOP;
	  blk = malloc(sizeof(struct BLOCK_STACK));
	  blk->css = if_stack;
	  if_stack = 0;
	  blk->patch = new;
	  blk->top = curr;
	  blk->link = blocks;
	  blocks = blk;
	  return(new);
	}
       break;
    case SPEC__RBRACE:
	{ struct BLOCK_STACK *blk;
	  struct INTERMEDIATE *curr;
	  if (! blocks) abort_compile(/*{*/"} without matching {."/*}*/);
	  if (if_stack) abort_compile("Unexpected end of code block.");
	  blk = blocks;
	  blocks = blk->link;
	  new = curr = do_exit();
	  while (curr->next) curr = curr->next;
	  curr->next = new_inst();
	  curr = curr->next;
	  curr->no = nowords ++;
	  curr->in.type = PROG_PTR;
	  curr->in.data.number = blk->top->no;
	  blk->patch->in.data.number = curr->no;
	  if_stack = blk->css;
	  free(blk);
	}
       break;
    case SPEC__LIB:
       if (dxstack) abort_compile("$LIB appearing inside a $DEF/$DEFINE expansion");
       if (curr_proc) abort_compile("$LIB inside a procedure");
       if (blocks) abort_compile("$LIB inside a code block");
       do_library(0);
       break;
    case SPEC__IMPORT:
       if (dxstack) abort_compile("$IMPORT appearing inside a $DEF/$DEFINE expansion");
       if (curr_proc) abort_compile("$IMPORT inside a procedure");
       if (blocks) abort_compile("$IMPORT inside a code block");
       do_library(1);
       break;
    default:
       sprintf(buf,"Compiler internal error: unrecognized special form #%d found.",spec);
       abort_compile(buf);
       break;
  }
 return(new);
}

/* Compile a call to a primitive. */
static struct INTERMEDIATE * primitive_word(const char *token)
{
 struct INTERMEDIATE *new;

 new = new_inst();
 new->no = nowords++;
 new->in.type = PROG_PRIMITIVE;
 new->in.data.number = get_primitive(token);
 return(new);
}

/* is this token a string? */
static int string(const char *token)
{
 return(token[0]==BEGINSTRING);
}

/* compile a string constant */
static struct INTERMEDIATE *string_word(const char *token)
{
 struct INTERMEDIATE *new;

 new = new_inst();
 new->no = nowords++;
 new->in.type = PROG_STRING;
 new->in.data.string = dup_string(token);
 return(new);
}

/* compile an integer constant */
static struct INTERMEDIATE *number_word(const char *token)
{
 struct INTERMEDIATE *new;

 new = new_inst();
 new->no = nowords++;
 new->in.type = PROG_INTEGER;
 new->in.data.number = atoi(token);
 return(new);
}

/* see if it's a floating number */
/* syntax: [(+|-)] digit* [ . digit* ] [ (e|E) [(+|-)] digit+ ]
   except that at least one digit must occur (not counting exponent digits) */
static int floatnum(const char *token)
{
 int ndig;

 if ((*token == '+') || (*token == '-')) token ++;
 ndig = 0;
 while (*token && Cisdigit(*token))
  { ndig ++;
    token ++;
  }
 if (*token == '.')
  { token ++;
    while (*token && Cisdigit(*token))
     { ndig ++;
       token ++;
     }
  }
 if (ndig == 0) return(0);
 if ((*token == 'e') || (*token == 'E'))
  { token ++;
    if ((*token == '+') || (*token == '-')) token ++;
    ndig = 0;
    while (*token && Cisdigit(*token))
     { ndig ++;
       token ++;
     }
    if (ndig == 0) return(0);
  }
 if (*token) return(0);
 return(1);
}

/* compile a float constant */
static struct INTERMEDIATE *float_word(const char *token)
{
 struct INTERMEDIATE *new;

 new = new_inst();
 new->no = nowords++;
 new->in.type = PROG_FLOAT;
 new->in.data.flt = malloc(sizeof(double));
 *new->in.data.flt = atof(token);
 return(new);
}

/* see if it's an object # */
static int object(const char *token)
{
 return((token[0] == DBREFFLAG) && number(token+1));
}

/* compile a dbref constant */
static struct INTERMEDIATE *object_word(const char *token)
{
 struct INTERMEDIATE *new;
 int objno;

 objno = atoi(token+1);
 new = new_inst();
 new->no = nowords++;
 new->in.type = PROG_OBJECT;
 new->in.data.objref = objno;
 return(new);
}

/* see if it's an old-style quoted procedure name */
static int quoted(const char *token)
{
 return((token[0] == QUOTEFLAG) && call(token+1));
}

/* compile an old-style quoted word constant */
static struct INTERMEDIATE *quoted_word(const char *token)
{
 struct INTERMEDIATE *new;
 struct PROC_LIST *p;

 new = new_inst();
 new->no = nowords++;
 new->in.type = PROG_ADD;
 p = call(token);
 if (! p) abort_compile("Compiler internal error: can't find quoted call");
 reference_procedure(p,new);
 return(new);
}

static struct INTERMEDIATE *next_word(const char *token)
{
 struct INTERMEDIATE *new_word;
 char buf[BUFFER_LEN];
 int n;

 if (! token) return(0);
 /* note that variables and calls get priority over builtins, so that
    new primitives can be added without breaking existing code... */
 if (variable(token))    new_word = var_word(token);        else
 if (call(token))        new_word = call_word(token);       else
 if ((n=special(token))) new_word = process_special(n);     else
 if (primitive(token))   new_word = primitive_word(token);  else
 if (string(token))      new_word = string_word(token+1);   else
 if (number(token))      new_word = number_word(token);     else
 if (floatnum(token))    new_word = float_word(token);      else
 if (object(token))      new_word = object_word(token);     else
 if (quoted(token))      new_word = quoted_word(token+1);   else
  { sprintf(buf,"Unrecognized word %s.",token);
    abort_compile(buf);
  }
 return(new_word);
}

static void define_libcalls(void)
{
 struct PROC_LIST *p;
 struct PROC_LIST **pp;

 pp = &procs;
 while ((p = *pp))
  { if (!p->code && p->libinfo)
     { if (p->patchups)
	{ struct INTERMEDIATE *c;
	  struct INTERMEDIATE *new;
	  c = new_inst();
	  new = c;
	  c->no = nowords ++;
	  c->in.type = PROG_OBJECT;
	  c->in.data.objref = p->libinfo->program;
	  c->next = new_inst();
	  c = c->next;
	  c->no = nowords ++;
	  c->in.type = PROG_STRING;
	  c->in.data.string = dup_string(p->libinfo->name);
	  c->next = new_inst();
	  c = c->next;
	  c->no = nowords ++;
	  c->in.type = PROG_PRIMITIVE;
	  c->in.data.number = IN_LIBCALL;
	  c->next = new_inst();
	  c = c->next;
	  c->no = nowords ++;
	  c->in.type = PROG_OBJECT;
	  c->in.data.objref = program;
	  c->next = new_inst();
	  c = c->next;
	  c->no = nowords ++;
	  c->in.type = PROG_PRIMITIVE;
	  c->in.data.number = IN_PROGRAM;
	  c->next = new_inst();
	  c = c->next;
	  c->no = nowords ++;
	  c->in.type = PROG_PRIMITIVE;
	  c->in.data.number = IN_RET;
	  curr_word->next = new;
	  p->code = new;
	  repair_patchups(p);
	  curr_word = c;
	  pp = &p->next;
	}
       else
	{ *pp = p->next;
	  cfree(p->name);
	  free(p->libinfo->name);
	  free(p->libinfo);
	  free(p);
	}
     }
    else
     { pp = &p->next;
     }
  }
}

/* copy program to an array */
static void copy_program(void)
{
 /* Everything should be peachy keen now, so we don't do any error checking */
 struct INTERMEDIATE *curr;
 struct inst *code;
 struct stab *stab;
 struct PROC_LIST *p;
 int i;
 int nprocs;
 int n;
 char buf[BUFFER_LEN];

 if (! first_word) v_abort_compile("Nothing to compile.");
 for (p=procs;p;p=p->next)
  { if (! p->code)
     { sprintf(&buf[0],"FORWARD word %s never defined",p->name);
       v_abort_compile(&buf[0]);
     }
    if (p->patchups)
     { sprintf(&buf[0],"Internal error: word %s has code and patchups",p->name);
       v_abort_compile(&buf[0]);
     }
  }
 code = malloc((nowords+1)*sizeof(struct inst));
 i = 0;
 for (curr=first_word;curr;curr=curr->next)
  { code[i].type = curr->in.type;
    code[i].prog = program;
    switch (code[i].type)
     { case PROG_PRIMITIVE:
       case PROG_INTEGER:
       case PROG_VAR:
	  code[i].data.number = curr->in.data.number;
	  break;
       case PROG_STRING:
	  code[i].data.string = curr->in.data.string ? dup_string(curr->in.data.string) : 0;
	  break;
       case PROG_OBJECT:
	  code[i].data.objref = curr->in.data.objref;
	  break;
       case PROG_ADD:
	  code[i].data.call = code + curr->in.data.number;
	  break;
       case PROG_PTR:
	  code[i].data.ptr = malloc(sizeof(struct progptr));
	  code[i].data.ptr->prog = program;
	  code[i].data.ptr->ptr = code + curr->in.data.number;
	  break;
       case PROG_FLOAT:
	  code[i].data.flt = malloc(sizeof(double));
	  *code[i].data.flt = *curr->in.data.flt;
	  break;
       default:
	  v_abort_compile("Unknown type compile!  Internal error.");
	  break;
     }
    i ++;
  }
 if (i != nowords)
  { fprintf(stderr,"Compiling #%d: nowords=%d i=%d\n",(int)program,nowords,i);
  }
 DBSTORE(program,sp.program.codevec,code);
 DBSTORE(program,sp.program.codesiz,nowords);
 nprocs = 0;
 for (p=procs;p;p=p->next) nprocs ++;
 DBSTORE(program,sp.program.stabsiz,nprocs);
 stab = malloc(i*sizeof(struct stab));
 i = nprocs;
 for (p=procs;p;p=p->next)
  { i --;
    stab[i].off = p->code->no;
    stab[i].name = dup_string(p->name);
  }
 if (i != 0) abort();
 do
  { n = 0;
    for (i=1;i<nprocs;i++)
     { if (stab[i-1].off > stab[i].off)
	{ struct stab t;
	  t = stab[i-1];
	  stab[i-1] = stab[i];
	  stab[i] = t;
	  n ++;
	}
     }
  } while (n);
 DBSTORE(program,sp.program.stabvec,stab);
}

static void set_start(void)
{
 DBSTORE(program,sp.program.start,DBFETCH(program)->sp.program.codevec+lastdefn->code->no);
}

static void add_primitive(int val)
{
 hash_data hd;

 hd.ival = val;
 if (! add_hash(base_inst[val-BASE_MIN],hd,primitive_list,COMP_HASH_SIZE))
  { panic("Out of memory");
  }
}

void do_compile(dbref player_in, dbref program_in, dbref msgrecip_in)
{
 struct dbref_list *list;
 struct dbref_list *temp;
 const char *token;
 struct INTERMEDIATE *new_word;

 for (list=DBFETCH(program_in)->sp.program.proglocks;list;list=temp)
  { char buf[BUFFER_LEN];
    temp = list->next;
    if (list->object != player_in)
     { switch (Typeof(list->object))
	{ case TYPE_PLAYER:
	     sprintf(buf,"This program has been recompiled by %s:",unparse_object(list->object,player_in));
	     strcat(buf,unparse_object(list->object,program_in));
	     notify(list->object,buf);
	     prog_abort(list->object);
	     break;
	  case TYPE_DAEMON:
	     sprintf(buf,"This program has been recompiled by %s:",unparse_object(list->object,player_in));
	     strcat(buf,unparse_object(list->object,program_in));
	     notify(list->object,buf);
	     remove_daemon(list->object);
	     break;
	}
     }
  }
 /* set all global variables */
 nowords = 0;
 curr_word = 0;
 first_word = 0;
 curr_proc = 0;
 player = player_in;
 program = program_in;
 msgrecip = msgrecip_in;
 lineno = 1;
 curr_line = DBFETCH(program)->sp.program.first;
 if (curr_line) next_char = curr_line->this_line;
 first_word = 0;
 curr_word = 0;
 procs = 0;
 compile_err = 0;
 if_stack = 0;
 blocks = 0;
 free_prog(program);
 if (! curr_line) v_abort_compile("Missing program text.");
 while (1)
  { token = next_token(0);
    if (! token) break;
    new_word = next_word(token);
    if (compile_err)
     { cfree(token);
       return;
     }
    if (new_word)
     { if (! first_word)
	{ first_word = new_word;
	}
       else
	{ curr_word->next = new_word;
	}
       curr_word = new_word;
     }
    if (curr_word) while (curr_word->next) curr_word = curr_word->next;
    cfree(token);
  }
 if (curr_proc) v_abort_compile("Unexpected end of file.");
 if (! procs) v_abort_compile("No procedures defined.");
 if (! lastdefn) panic("No last definition?");
 define_libcalls();
 copy_program();
 if (compile_err) return;
 set_start();
 cleanup();
}

void free_code(struct inst *code, int siz)
{
 int i;

 for (i=0;i<siz;i++) if (code[i].type & PROG__CLEAR) interp_clear(&code[i]);
 free(code);
}

void free_stab(struct stab *stab, int siz)
{
 int i;

 for (i=0;i<siz;i++) free(stab[i].name);
 free(stab);
}

void free_prog(dbref prog)
{
 free_code(DBFETCH(prog)->sp.program.codevec,DBFETCH(prog)->sp.program.codesiz);
 DBSTORE(prog,sp.program.codevec,0);
 DBSTORE(prog,sp.program.codesiz,0);
 free_stab(DBFETCH(prog)->sp.program.stabvec,DBFETCH(prog)->sp.program.stabsiz);
 DBSTORE(prog,sp.program.stabvec,0);
 DBSTORE(prog,sp.program.stabsiz,0);
 DBSTORE(prog,sp.program.start,0);
}

void clear_primitives(void)
{
 kill_hash(primitive_list,COMP_HASH_SIZE);
}

void init_primitives(void)
{
 int i;

 clear_primitives();
 for (i=BASE_MIN;i<=BASE_MAX;i++) add_primitive(i);
}

struct stab *findstab(dbref p, int off)
{
 int l;
 int m;
 int h;
 struct stab *v;

 if (Typeof(p) != TYPE_PROGRAM) return(0);
 v = DBFETCH(p)->sp.program.stabvec;
 if (v == 0) return(0);
 l = -1;
 h = DBFETCH(p)->sp.program.stabsiz;
 while (h-l > 1)
  { m = (h + l) / 2;
    if (off >= v[m].off)
     { l = m;
     }
    else
     { h = m;
     }
  }
 return((l<0)?0:v+l);
}