/* -*- C++ -*- code to massage parsed expressions before evaluation.
   Copyright (C) 1992 Per Bothner.

This file is part of Q.

Q is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

Q is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU CC; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */

#include <genob.h>
//#include <hash.h>
#include <expression.h>
#include <procs.h>
#include <debug.h>
#include <newtype.h>
#include "methods.h"
#include <traverse.h>
#include "typetabs.h"
#include "gvars.h"
#include "builtin-syms.h"
#include <std.h>
#include "shell.h"
#include "loopcons.h"

EXTERN unsigned short * ClassSearch(struct ClassDesc *classDesc, Symbol *arg);
extern short Compiling;
extern struct UnifyExpr *
  AppendDeclaration(struct Block *block, struct Declaration *decl, Expr *val);

#define DECL_INCLUDED_DECLS(decl) ((struct Field*)(decl)->fname())	       
#define DECL_INCLUDED_FIELD_COUNT(decl) ((int)(decl)->field)

void PushDecl(struct TraverseData *data, struct Declaration *decl)
{
    if (data->pass > BindPass) return;
    decl->shadowed = (Declaration*)Search(data->symTab, decl->fname());
    if (decl->shadowed && decl->blockLevel == decl->shadowed->blockLevel)
	TrError(data, "W Duplicate declaration for %s",
		SymbolString(decl->fname()));
    Insert(data->symTab, decl->fname(), decl);
}

static void PopDecl(struct TraverseData *data, struct Declaration *decl)
{
    if (decl->shadowed == NULL)
	data->symTab->remove(decl->name);
    else Insert(data->symTab, decl->fname(), decl->shadowed);
}

void BlockPopDecls(struct TraverseData *data, struct Block *block)
{
    struct Declaration *decl;
    if (data->pass > BindPass) return;
    for (decl = block->decls.first; decl; decl = decl->next())
	if (decl->fname() && decl->fname() != &Asterisk_sym && !DeclIsInclude(decl))
	    PopDecl(data, decl);
}

#if 0
struct Declaration ExplicitMarker[1] = {0};
struct Declaration ImplicitMarker[1] = {0};
#endif
struct DeclEntry { Name arg; struct Declaration *val;};
/* #define SYMS */

EXTERN HashTable *ModuleSymbols();
EXTERN ExType FindExprType();
extern struct Block * TestConstructor(register struct Block *block);

#if 0
AddNames(struct Block *exp, struct Module *module)
 /* 'exp' is a parsed-but-not-optimized expression.
  * Insert names defined in exp into module.
  */
  {
THIS HAS NOT CURRENTLY BEEN REPLACED WITH ANYTHING WORKING!
    register struct Statement *st;
    struct Declaration **lastDecl, *decl;
    struct ModuleList *link;
    if (exp == NULL || ExprCodeOf((Expr*)exp) != Block_code)
	abort();
/* NOTE: get rid of this loop by fixing data structure ! */
    for (lastDecl = &MemGetType(module)->fieldList;
	*lastDecl; lastDecl = &lastDecl[0]->next) { }
    *lastDecl = exp->decls.first;
#if 0
    for (st = exp->first; st != NULL; st = st->next)
      {
/* this loop should soon be obsolete */
	if (ExprIsType(st->src, ModuleList))
	  { link = (struct ModuleList*)st->src.P;
	    if (st->decl == NULL)
	      {
		st->decl = Symbol2Declaration(link->module->name);
		st->decl->setPrivate(1);
	      }
	    if (st->decl->isPrivate())
	        link->private = 1;
	    if (DeclIsInclude(st->decl))
		link->included = 1;
	    *module->lastMod = link;
	    module->lastMod = &link->next;
	    link->next = NULL;
	  }
      }

 /* Now done by CompileForEval. Allows implicits to work for Defaultmodule,
  * but doesn't work for recursive modules (fix FindDeclInModule). */
    *module->block->decls.last = exp->decls.first;
    module->block->decls.last = exp->decls.last;
#endif
#if 0
    for (decl = exp->decls.first; decl; decl = decl->next)
      {
	decl->block = decl->defining.P; /* ??? */
      }
#endif
  }
#endif

extern Object NewAtom();

#if 0
static int CheckSimpleName(struct Declaration *decl)
{   Expr_Ptr block;
    extern struct Declaration *NewExceptionDecl;
    block.E = decl->block;
/* check if kind of declaration where label should be == name */
    if (block.E == NULL)
	return 0;
    if (block.code() == TypeDefExpr)
	return 1;
    if (block->code() == ExprCall)
	if (block.call()->proc.P == (Object)NewExceptionDecl
	   || block.call()->proc.O.f == NewAtom
	   || block.call()->proc.name == EnterSymbol("NewAtom"))
	    return 1;
    return 0;
}
#endif

#if 0
MakeGlobalLabels(struct Module *module)
 /* generate a label for global names in module */
  { char *mod_name = module->name;
    int mod_len = strlen(mod_name); char *buf;
    register struct Declaration *decl;
    for (decl = module->declList; decl != NULL; decl = decl->next)
      { int i; register struct Declaration *dcl;
	if (DeclIsInclude(decl)) ;
	else if (CheckSimpleName(decl))
	  {
	    MakeLabelToken(&decl->token, SymbolString(decl->name), 0, 0);
	  }
	else if (decl->sameName)
	    for (dcl = decl, i = 1; dcl != NULL; dcl = dcl->sameName, i++)
	      { char i_buf[10];
		if (dcl->token.kind != NullToken) continue;
		sprintf(i_buf, "%d", i);
		i = mod_len + strlen(dcl->name) + strlen(i_buf) + 3;
		buf = (char*)malloc(i);
		sprintf(buf, "%s_%s_%s", mod_name, dcl->name, i_buf);
		MakeLabelToken(&dcl->token, strdup(buf), 0, 0);
  	      }
	else if (decl->token.kind == NullToken)
	  {
	    buf = (char*)malloc(mod_len + strlen(decl->name) + 2);
	    sprintf(buf, "%s_%s", mod_name, decl->name);
	    MakeLabelToken(&decl->token, strdup(buf), 0, 0);
	  }
      }
  }
int NewGlobals  = 1;
#endif

#if 0
void SetDeclToken(
    struct Declaration *decl,
    Name moduleName,
    struct Declaration *decl0)
  {
    register struct Declaration *decl2;
    if (moduleName == NULL) moduleName = (Name)"";
    if (decl->token.kind == ConstToken && decl->token.u.constant.offset == 0)
	return;
    if (CheckSimpleName(decl))
	MakeLabelToken(&decl->token, SymbolString(decl->name), 0, 0);
    else
    { int n_names;
      int mod_len = strlen(moduleName);
  /* n_names = # of previous declarations of decl->name in expr */
  /* note loop causing n^2 run-time !!! */
    for (decl2 = decl0, n_names = 0;
      decl2 != NULL; decl2 = decl2->next)
	if (decl2->name == decl->name)
	    n_names++;
    if (n_names > 0)
      { char i_buf[10], *buf;
	sprintf(i_buf, "%d", n_names);
	buf = (char*)malloc(
	  mod_len+strlen(decl->name)+strlen(i_buf)+3);
	sprintf(buf, "%s_%s_%s", moduleName, decl->name, i_buf);
      }
    else
      { char *buf = (char*)malloc(mod_len + strlen(decl->name) + 2);
	sprintf(buf, "%s_%s", moduleName, decl->name);
      }
    MakeLabelToken(&decl->token, strdup(buf), 0, 0);
    }
  }
#endif

#if 0
struct Block *
OptimizeModule(struct Block *expr, struct Module *module, int options)
 /*
  * Returns the result of various optimizations and fixups to 'expr;.
  * Assume 'expr' is destroyed in the process.
  * 'options' controls the amount and types of optimizations to perform.
  * options==0 means only do certain standard, default fixups.
  */
  { register struct Declaration *decl, **lastDecl;
    struct TraverseData data(module);
    char *mod_name = module->name;
    int mod_len = strlen(mod_name);
    if (LogExpr & 2)
      {
	fprintf(LogFile, "Parsed:{ ");
	PrintDetailed(expr, LogFile, LogExpr & 4 ? 1 : 0);
	fprintf(LogFile, " }\n");
      }

/*    data.decl = (struct Declaration*)0; */

  /* give labels to global declarations */
    if (module && ExprCodeOf(expr) == Block_code)
      { struct Statement *st;
#ifdef SYMS
        if (module->syms == NULL)
            module->syms = HashTable::New(64);
	for (decl = expr->decls.first; decl != NULL; decl = decl->next)
	  {
	    if (!DeclIsInclude(decl))
	      {
		if (decl->token.kind == NullToken)
		    SetDeclToken(decl, module->name, expr->decls.first);
		ModPutDecl(module, decl, 0);
	      }
	    else if (!HasHType(decl->defining, ModuleList))
		RunError(0, "*: Must be followed by LOAD module");
	    else
		ModPutModule(module,
		    ((struct ModuleList*)(decl->defining))->module, 1);
	  }
#endif SYMS
      }
/*    else */
       /* traverse the whole expression tree */
	expr = &ExprTraverse(expr, &data)->block;

    if (LogExpr & 1)
      {
	fprintf(LogFile, "Optimized:{ ");
	PrintDetailed(expr, LogFile, LogExpr & 4 ? 1 : 0);
	fprintf(LogFile, " }\n");
      }

    if (ExprCodeOf(expr) == Block_code)
      {
	*module->decls.last = expr->decls.first;
	module->decls.last = expr->decls.last;	
      }
    return expr;
  }

struct Declaration *decl;
CheckAlreadyInClosure(Name name, struct ProcExpr *proc)
  { register struct Declaration *decl;
    if (proc != NULL)
      {
	if (proc->closure)
	    for (decl = proc->closure->first->decl;
	      decl!= NULL; decl = decl->next)
		if (decl->name == name)
		    return decl;
	for (decl = proc->c.varList; decl != NULL; decl = decl->next)
            if (decl->name == name)
		return decl;
      }
    return NULL;
  }
#endif

void AllocContext(struct ProcExpr *proc)
{
    struct Identifier *context = proc->context;
    if (context == NULL)
      {
	struct Declaration *decl = Symbol2Declaration(&self_sym);
	struct Type *type = ExType_Type(proc->closure->type);
	decl->blockLevel = PARAM_LEVEL(proc);
	decl->flags |= SetDeclaration|AnyPairDecl|PrivateDeclaration;
	decl->set_pointer_field(0, type);
	context = Decl2Ident(decl);
	context->type = decl->type;
	proc->context = context;
      }
}

struct Block* GetClosure(struct TraverseData *data)
{
    struct ProcExpr *curProc = data->curProc;
    if (curProc == NULL) {
	TrError(data, "Internal error: GetClosure called; not in function.");
	return NULL;
    }
    struct Block *closure = curProc->closure;
    if (closure == NULL) {
	closure = new Block(curProc->expr->enclosing);
	curProc->expr->enclosing = closure;
	closure->level = closure->enclosing->level + 1;
	closure->flags |= BlockReturnSelf;
	closure->type = curProc->type;
	curProc->closure = closure;
    }
    if (closure->rtype == 0)
	BindRecordType(closure, 0);
    AllocContext(curProc);
    return closure;
}

#if 0
struct Identifier *
ConvertNonLocalReference(struct Identifier *id, struct ProcExpr *proc)
 /* replace "id" by "self'(id->name)". id is trashed (re-used) */
  {
    struct Identifier *context = proc->context;
    Name name = id->name;
    AllocContext(proc);
    id->type = context->type;
    if (name == &self_sym)
      {
	id->decl = context->decl;
	return id;
      }
    id->name = context->name;
    id->decl = context->decl;
    id->decl->useCount++;
    return id;
  }
#endif

static struct Declaration *
AddDeclToBlock(struct Block *block, Symbol * name, struct Identifier *id)
  { register struct Declaration *decl;
    decl = Symbol2Declaration(name);
    AddDeclaration(block, decl);
    decl->flags |= UnusedDeclaration + PrivateDeclaration;
/* NOTE bug for case: ( ...; ... ($...$ ...i...) ...; ... i ...) */
/*    decl->block = data->block; */
//    decl->offset = -1;
//    decl->kind = Pointer_Field;
    if (name == &Asterisk_sym) { decl->name = NULL; decl->size = Include_SizeCode;}
    if (id != NULL) {
#if 1
	if (id->flags & IdentExported)
	    decl->flags &= ~PrivateDeclaration;
#else
	if ((id->flags & IdentExplicit+IdentHasMark) == IdentExplicit)
	    decl->flags &= ~PrivateDeclaration;
#endif
	id->v.decl = decl;
    }
    return decl;
  }

struct Declaration LookupSpecialDecl[1];

static void MarkVarSet(struct Declaration *decl, struct TraverseData *data)
  {
#if 0
    struct VarStateList *state; struct VarStateLink *link;
    if (data->pass > BindPass) return;
    state = data->varStates;
    if (decl->blockLevel <= list->level)
#else
    struct VarStateList *list; struct VarStateLink *link;
    struct VarStateLink **lptr = decl->linkAddr();
    if (data->pass > BindPass) return;
    for (list = data->varStates; list != NULL; list = list->next)
      {
	if (decl->blockLevel > list->level)
	    break;
	if (*lptr && (*lptr)->level == list->level) {
	    link = *lptr;
	    lptr = &link->down;
	    continue;
	}
	link = (struct VarStateLink*)malloc(sizeof(struct VarStateLink));
	link->decl = decl;
	link->next = list->first;
	list->first = link;
	link->saveFlags = UnusedDeclaration;
	link->down = *lptr;
	*lptr = link;
	lptr = &link->down;
	link->level = list->level;
      }
#endif
    decl->flags &= ~ImplicitDeclMask;
    decl->flags |= SetDeclaration;
  }

// Check if func has clauses that haven't been traversed yet.
// If so, we must push them onto data->pendingProcs.
void PushPendingProc(Function *func, struct TraverseData *data)
{
    if (func == NULL)
	return;
    int i = func->nClauses;
    Clause *clause = func->clauses;
    for (; --i >= 0; clause++) {
	if (clause->flags & ClauseHasNotBeenTraversed) {
	    ProcExpr *proc = clause->procexpr();
	    if (!(proc->flags & ProcIsPending)) {
		proc->chain = data->pendingProcs;
		data->pendingProcs = proc;
		proc->flags |= ProcIsPending;
	    }
	}
    }
}

void PopPendingProcs(TraverseData *data)
{
    // Now traverse any pending functions.
    while (data->pendingProcs) {
	ProcExpr *proc = data->pendingProcs;
	data->pendingProcs = proc->chain;
	proc->closure = NULL; // Shouldn't be needed. Alias for proc->chain.
	proc->flags &= ~ProcIsPending;
	if (proc->clause->flags & ClauseHasNotBeenTraversed)
	    proc->traverse(data);
    }
}

// First part of Expression::traverse().
// This part checks if the identifier is declared.
// It should either return a non-decl (a constant),
// or set v.decl to the appropriate declaration.
// If the identifier is undeclared, v.decl remains NULL.
// This function can be called repeatedly.

Expr* Identifier::traverse1(struct TraverseData *data)
{
    if (v.decl)
	return this;
    if (name == &UnderScore_sym && name == &Asterisk_sym)
	return this;
    Declaration* decl = (Declaration*)Search(data->symTab, name);
    if (decl == NULL) {
	Root * val;
	if (flags & IdentFuncOnly)
	    val = name->sym_function();
	else {
	    val = name->sym_value();
	    if (val == NULL)
		val = name->sym_function();
	}
	if (val == NULL) {
	    Symbol *sym = BuiltinPackage.find_exported(name->string(),
						       name->length());
	    if (sym)
		val = sym->sym_value();
	    if (val != NULL)
		return new ExprQuote(val);
	}
	else if (name->_flags & (int)Symbol::is_constant)
	    return new ExprQuote(val);
#if 0
	if (val == NULL && check_executable_file(name->string())) {
	    val = new RunOp(name->string());
	}
#endif
	if (val != NULL && val->isKindOf(*MFunction::desc())
	    && !(data->flags & TraverseLisp+TraverseScheme)) {
	    return new ExprQuote(val);
	}
	if (val != NULL) {
	    if (val->isMemberOf(*GFunction::desc())) {
		PushPendingProc(((GFunction*)val)->func,
				data);
	    }
	    v.decl = LookupSpecialDecl;
	    type = ExTypePtr;
	    return this;
	}
	if (val != NULL) return new ExprQuote(val);
#if 0
	if (access(name->string(), 0) == 0)
	    return new FileName(quote_words());
#endif
    }
    else
	v.decl = decl;
    return this;
}

Expr * Identifier::traverse(struct TraverseData *data)
{
    Expr* tmp = traverse1(data);
    if (tmp != this)
	return tmp;
    if (v.decl == NULL) {
	fprintf(stderr,
		"[Lookup special variable: %s]\n", symbol()->string());
	v.decl = LookupSpecialDecl;
	type = ExTypePtr;
    }
    return traverse2(data);
}

/* struct Identifier * */
Expr * Identifier::traverse2(struct TraverseData *data)
{
    int traverse_flags = data->flags;
    int non_local = 0;
    struct ProcExpr *curProc = data->curProc;
    struct Block *block = data->curBlock;
    struct Block *outer_most = block;
    if (data->pass > BindPass
	|| (data->flags & TraverseInQuote))
	return this;
    data->flags &= ~TraverseInUnify;
#if 0
    if (flags & IdentNesting)
	flags &= ~IdentNesting, v.decl = NULL;
    register struct Declaration *decl = Ident2Decl(this);
    if (v.decl != NULL) /* catches LoopCons_code */
	goto fix;
#endif
    if (name == &self_sym || name == &SELF_sym)
	if (curProc->closure == NULL)
	    TrError(data, "Bad use of '%s'", SymbolString(name));
	else {
	    AllocContext(curProc);
	    v.decl = curProc->context->v.decl;
#if 0
	    if (name == &SELF_sym) {
		decl->name = &SELF_sym;
		curProc->context->name == &self_sym;
		decl->type = ExTypeAny;
		type = decl->type;
	    } else
#endif
		type = MakeExType(ExPointerType,
		    ExType_Type(curProc->closure->type));
	    return this;
	}
    if (name != &UnderScore_sym && name != &Asterisk_sym) {
//	if (decl == (struct Declaration*)&forget_sym)
//	    goto implicit;
	type = v.decl->type;
	block = data->level2block[v.decl->blockLevel];
	if (v.decl->loop_nesting()) {
	    v.decl->flags |= GeneralDeclaration; // FIXME
//	    fprintf(stderr, "[Nested id: %s, level:%d, bl:%x]\n",
//		    SymbolString(name), v.decl->loop_nesting(), block);
	    IndexExpr *ind = new IndexExpr();
	    ind->arg[0].E = this;
	    ind->arg[1].E = NewIdentifier(&_INDEX__sym, NULL)->traverse(data);
	    return ind;
	}
	if ((flags & IdentExplicit+IdentHasMark) == IdentExplicit)
	    v.decl->flags &= ~PrivateDeclaration;
	if (v.decl->blockLevel == 0) goto fix; /* global variable */
	if (!curProc || v.decl->blockLevel > ENVIR_LEVEL(curProc))
	    goto fix;

	/* check if it is a non-locally defined name */
	/* add to "proc"->varList */
	struct Declaration *dcl;
	struct Block *closure = GetClosure(data);
	if (v.decl->blockLevel == closure->level) {
	    if (v.decl->flags & PrivateDeclaration)
		v.decl->flags |= NonLocalDeclaration;
//	    v.decl = decl;
	    return this;
	}
	dcl = Symbol2Declaration(name);
	if (ExType_Kind(v.decl->type) == 0 && ExType_Ptr(v.decl->type) == 0)
	    // Do this kludge instead of (more coorectly) unifying the type.
	    // Having dcl->type point indirectly to decl->type would be best,
	    // but we would have to change the time offsets are calculated.
	    v.decl->set_pointer_field(v.decl->u.offset, NULL);
	dcl->size = v.decl->size;
	dcl->type = v.decl->type;
	dcl->flags |=
	    NonLocalDeclaration|SetDeclaration|PrivateDeclaration;
	AppendDeclaration(closure, dcl, NewIdentifier(v.decl->name, NULL));
	dcl->blockLevel = closure->level;
	PushDecl(data, dcl);
	v.decl = dcl;
	return this;
    }
//  implicit:
    if (data->notFoundId != NULL)
	{ struct Identifier *new_id = (data->notFoundId)(this, data);
	  if (new_id != NULL) return new_id;
      }
    /*	if ((data->flags & TraverseInArgList) == 0 && LogVerbose > 0) */
    v.decl = AddDeclToBlock(outer_most, name, this);
    if (name != &Asterisk_sym) {
	TrError(data, "W Variable %s treated as implicit ", name);
    }
    /*  flags |= IdentFirstRef; -- redundant */

  fix:
    if (v.decl->is_proc()) {
	// Check if decl is a proc which hasn't been traversed yet.
	// If so, we must push it onto data->pendingProcs.
	PushPendingProc(v.decl->get_proc(), data);
    }
    flags |= LastfixProtect+ExprAtMostOneResult+ExprCannotFail;
    if ((v.decl->flags & ImplicitDeclMask) ==  UnusedDeclaration
      /*&& v.decl->blockLevel != 0*/) {
	flags |= IdentFirstRef;
	if (traverse_flags & TraverseInUnify) {
#if 1
	    MarkVarSet(v.decl, data);
#else
	    v.decl->flags &= ~ImplicitDeclMask;
	    v.decl->flags |= SetDeclaration;
#endif
	    data->flags |= TraverseInUnify;
	}
    }
    if ((v.decl->flags & ImplicitDeclMask) != SetDeclaration) {
	v.decl->flags &= ~ImplicitDeclMask;
	v.decl->flags |= GeneralDeclaration;
    }
    return this;
}

int RegParmFlag = 1;
int ExplicitUnify = 1;

#if 0
ConvertParam(struct ProcExpr *proc, int i, struct TraverseData *data)
/* Convert parameter i of proc to use explicit unification */
  { Object ex; struct Identifier *id;
    register ProcDesc *pd = proc->procDesc;
    if ((ex = pd->parm[i].pattern_expr) != NULL)
      {
      /* add explicit unification of parameters, unless already done */
#define AlreadyExplicitUnification (-1)
	if (pd->parm[i].type != AlreadyExplicitUnification)
	  {
	    struct Declaration *parm;
	    struct UnifyExpr *eq = new UnifyExpr(ex, 0);
	    if (proc->flags & ProcRegParms)
	      {
		struct Declaration **ptr; char *name;
		int reg_code = i;
		if (proc->flags & ProcPrefix)
		    reg_code++;
		switch (reg_code)
		  {
		  case 0:
		    ptr = &proc->leftArg; name = "ARG_LEFT"; break;
		  case 1:
		    ptr = &proc->rightArg; name = "ARG_RIGHT"; break;
		  case 2:
		    ptr = &proc->auxArg; name = "ARG_AUX"; break;
		  default:
		    RunError(0, "Internal error: Bad args to proc #%X", proc);
		    return proc;
		  }
		if (*ptr == NULL)
		  {
		    parm = Symbol2Declaration(EnterSymbol(name));
		    parm->blockLevel = ?;
		    *ptr = parm;
		  }
	     } else  {
		parm = Symbol2Declaration(EnterSymbol("PARM"));
		parm->blockLevel = ?;
		parm->offset = (2 + i)* sizeof(Object);
	      }
	    id = Decl2Ident(parm);
	    id->flags |= IdentFree;
	    eq->right = id;
	    ex = eq;
	    pd->parm[i].type = AlreadyExplicitUnification;
	  }
	pd->parm[i].pattern_expr = ex->traverse(data);
      }
  }

AlphaComp(Name name1, Name name2)
/* compare name1 with name2 */
{ 
   register unsigned char *p1, *p2;
   register i; int n1, n2;
   p1 = SymbolUnsignedString(name1); p2 = SymbolUnsignedString(name2);
   n1 = SymbolLength(name1); n2 = SymbolLength(name2);
   i = n1<n2 ? n1 : n2;
   for (; --i <= 0;) {
	unsigned char c1 = *p1++, c2 = *p2++;
	if (c1 >= 'A' && c1 <= 'Z') c1 += 'a'-'A';
	if (c2 >= 'A' && c2 <= 'Z') c2 += 'a'-'A';
	if (c1 < c2) return -1;
	if (c1 > c2) return 1;
    }
    p1 = SymbolUnsignedString(name1); p2 = SymbolUnsignedString(name2);
    i = n1<n2 ? n1 : n2;
    for (; --i <= 0;) {
	unsigned char c1 = *p1++, c2 = *p2++;
	if (c1 < c2) return -1;
	if (c1 > c2) return 1;
    }
    return 0;
}

/* List merge sort; from Knuth: Sorting and Searching, 5.2.4, algorithm L */
#define LinkNegative 2
struct SortRecord {
    Name name;
    struct Declaration *decl;
    short index;
    char last; /* p->last corresponds to Knuth's L[p] < 0 */
};
#endif

unsigned short * ClassSearch(register struct ClassDesc *classDesc, Symbol *arg)
{
    unsigned short hash = SymbolHash(arg);
#define HASH_ELEMENT_TYPE unsigned short
#define HASH_ELEMENT_LOG 1
#define HASH_LENGTH_LOG (classDesc->nHashLog)
#define HASH_EQUAL(element, arg) (classDesc->fields[*element].name == arg)
#define HASH_NULL(element) (*element == 0)
#define HASH_DATA (classDesc->hash)
#define HASH_TO_STEP(hash) \
	(((hash<<1)+1) & ((1<<HASH_LENGTH_LOG)-1)) << HASH_ELEMENT_LOG
#include "hashfunc.h"
}

/* We use some fields temporarily so we can patch things up after sorting */
#define TEMP_NEXT_INDEX(fld) (fld)->offset
#define TEMP_FIRST_INCLUDED(fld) FIELD_FIRST_INCLUDED(fld)
#define TEMP_SELF_INDEX(fld) (fld)->_next /* index before sorting */
#define TEMP_DECL(fld) (fld)->u.value

struct ClassDesc *
CreateClassDesc(
    struct ClassDesc *classDesc,
    struct Declaration *decls,
    struct TraverseData *data)
{
    int uFields = 1; /* count of unnamed fields: initial self + includes */
    int iFields = 0; /* count of named included fields */
    int nFields = 0; /* count of named fields, also counting iFields */
    if (classDesc == NULL) classDesc = new ClassDesc;
    classDesc->flags = 0;
#if 0
    int nHash;
    int i, j;
    int uIndex, iIndex, nIndex;
    struct Field *sr, *tab;
    struct Declaration *decl;
    classDesc->stdMethods = DefaultMethodTable;
#endif

    classDesc->fields = decls;
#if 0
    classDesc->fields = tab;
    classDesc->nFields = nFields;
    classDesc->uFields = uFields;

    nHash += 4 + (nHash>>3); /* guarantee some free space */
    i = nHash;
    for (i = 2; (1<<i) < nHash; i++) ;
    classDesc->nHashLog = i;
    nHash = 1<<i;
    i = nHash * sizeof(unsigned short);
    classDesc->hash = (unsigned short*)malloc(i);
    bzero(classDesc->hash, i);
    for (sr = tab+uFields, i = 0; i < nFields; i++, sr++) {
	unsigned short *element = ClassSearch(classDesc, sr->name);
	if (*element == 0) *element = uFields+i;
    }
#endif
    return classDesc;
}

#if 0
static
TestInsert(HashTable *tab, Name name, struct Declaration *decl)
  { register struct DeclEntry *entry =
	(struct DeclEntry*)SymbolLookup(tab, name);
    if (HashNone(entry->arg)) entry->val = decl;
    else if (decl == ImplicitMarker && (Name)entry->val != &forget_sym) { }
    else entry->val = decl; /* NOTE: should actually merge !!! */
    if (HashNone(entry->arg)) { entry->arg = name; tab.rehash_if_needed(); }
  }

CleanupBlock(block, data)
    struct Block *block;
  {
    HashTable *hash = (HashTable*)HashTable::New(16);
    struct Statement *st, *prev, *next;
    register struct Identifier *id;
    struct Declaration *decl;
 /*
  * Since the statements in the block must be traversed in backwards
  * order, we temporarily reverse the links.
  */
    for (prev = NULL, st = block->first; st != NULL;) {
	next = st->next;
	st->next = prev;
	prev = st;
	st = next;
    }
    for (st = prev, prev = NULL; st != NULL; ) {
	if (st->kind == ForgetStatement) {
 /*
  *	    For each id in hash matching the delete:
  *		Add the id to the post-define list of st
  *		remove the id from hash
  */
	    for (id = st->idList; id != NULL; id = id->next)
		if (id->flags & IdentExplicit) {
		    decl = (struct Declaration*)Search(hash, id->name);
		    if (decl != NULL) {
			id->decl = decl;
			hash->remove(id->name);
		    }
		}
	}
	else {
	    for(id = st->idList; id != NULL; id = id->next) {
	        Name name = id->name;
		if (name == NULL || name == &Asterisk_sym) continue;
		decl = (struct Declaration*)Search(hash, name);
		if (id->flags & IdentNotRecursive) {
		    if (decl != ImplicitMarker && decl != ExplicitMarker)
			id->decl = decl;
		/*    if (id->decl->is_proc()) Error();  */
		    hash->remove(name);
		 }
		else if (!(id->flags & IdentExplicit)) {
		    if (decl == NULL) Insert(hash, name, ImplicitMarker);
		}
		else {
		    if (decl == NULL || decl == ImplicitMarker) {
			decl = id->decl;
			if (decl == NULL) decl = ExplicitMarker;
			Insert(hash, name, decl);
			decl = id->decl;
		    }
		    else
			TrError(data, "W duplicate declaration for %s", name);
	        }
	    }
	}
	/* Fix the links to point forwards again */
	next = st->next;
	st->next = prev;
	prev = st;
	st = next;
    }

 /* For each id in hash: Add id to block's init-defining list */
    if (block->locals == NULL)
	block->locals = hash;
    else
	ForEachInTab(hash, TestInsert, block->locals);
}
#endif

#define InitFromLocals(arg, new) { \
/*   Insert(block->locals, name, new); is automatic through assigning to new*/\
    PushDecl(data, arg, new); }}
/*
	if (val == ImplicitMarker)
	  { decl = LookupIdent(arg);
	    if (decl != NULL) val = decl;
	    else val = Symbol2Declaration(arg); }
*/

struct Function *AllocFunction(Symbol * name)
{
    Function *func = (Function*)malloc(sizeof(struct Function));
#if 0
/*    func->t.desc = NULL; *FunctionT->desc*/
    func->t.prefixLen = 0;
    func->t.alignment = 0;
    func->t.excess_bits = 0;
    func->t.options = 0;
    func->t.kind = FunctionTypeKind;
#endif
    func->fname = name;
    func->flags = 0;
    func->nParams = 0;
    func->nClauses = 1;
    func->min_required[0] = (unsigned short)(-1);
    func->min_required[1] = (unsigned short)(-1);
    return func;
}

void BlockScan(struct Block *block, struct TraverseData *data)
  {
    register struct Statement *st;
    register struct Declaration *decl;
      /* - since Identifier::traverse may AppendDeclaration new decls at front
	?? no longer! */
    struct Block *saveBlock = data->curBlock;
    register struct Identifier *id;
    unsigned short st_flags = ExprAtMostOneResult+ExprCannotFail;
    int params; struct ProcExpr *curProc = data->curProc;
    Expr *last = NULL;

    if (block->level == 0 /* i.e., not set by ProcExpr::traverse */
     && block->enclosing != NULL) /* i.e., not a  global block */
	block->level = block->enclosing->level + 1;
    data->curBlock = block;
    data->level2block[block->level] = block;
    /* The handling of Declarations is a mish-mash.
     * Ideally, this PushDecl should be the only one needed.
     * But the means Decls must be allocated to blocks at parse time.
     */
    for (decl = block->decls.first; decl != NULL; decl = decl->next()) {
	decl->blockLevel = block->level;
	PushDecl(data, decl);
    }

  if (data->pass == BindPass) {
    struct Identifier *methodNameList = NULL; /* list of Method declarations */
    if (block->flags & BlockReturnSelf && block->type == 0)
	block->type = block->rtype;
#if 0
    for (decl = block->decls.first; decl != NULL; decl = decl->next()) {
	if (decl->kind != Method_Field) continue;
    }
#endif
    for (st = block->first; st != NULL; st = st->next)
	if (st->kind == MethodStatement) {
	    struct Identifier *id = st->idList;
	    Symbol * name = id->name;
	    struct Function *func;
	    struct ProcExpr *proc = st->src.proc();
	    if (proc->clause == NULL) {
		decl = (struct Declaration*)Search(data->symTab, name);
		if (decl == NULL || decl->blockLevel != block->level) {
		    func = AllocFunction(name);
		    func->fname = proc->fname;
		    AddDeclToBlock(block, name, id);
		    decl = id->v.decl;
		    decl->set_proc(func);
		    decl->flags |= SetDeclaration;
		    decl->blockLevel = block->level;
		    PushDecl(data, decl);
		    /* temporarily link Procs with same name */
		    proc->clause = NULL;
		    /* temporarily use id->next for methodNameList */
		    if (id->next != NULL)
			TrError(data, "E BlockScan Confusion");
		    id->next = methodNameList; methodNameList = id;
		    if (block->flags & BlockIsGlobal) {
			Symbol *sym = decl->fname();
			GFunction* gfunc;
			if (proc->flags & ProcIsMacro)
			    gfunc = new MFunction(func);
			else
			    gfunc = new GFunction(func);
			sym->set_value(gfunc);
			if (id->flags & IdentExported) {
			    Package *pack = sym->_package;
			    if (pack)
				pack->export(sym);
			}
		    }
		}
		else {
		    func = (Function*)ExType_Ptr(decl->type);
		    func->nClauses++;
		    proc->clause = func->clauses;
		}
		func->clauses = (struct Clause*)proc;
	    }
	    else
		func = proc->function();
	    proc->type = MakeExType(ExMethodPtr, func);
	}

    /* for each Function with a given name */
    for (id = methodNameList; id != NULL; ) {
	/* allocate Clause structures and fix related pointers */
	struct Identifier *next = id->next;
	struct Function *func = (Function*)ExType_Ptr(id->v.decl->type);
	struct ProcExpr *proc = (struct ProcExpr*)func->clauses;
	struct Clause *clause =
	    (Clause*)malloc(func->nClauses * sizeof(struct Clause));
	func->clauses = clause;
	clause += func->nClauses;
	while (proc != NULL) {
	    struct ProcExpr *next = (struct ProcExpr*)proc->clause;
	    clause--;
	    InitClause(clause, proc);
	    if (clause->flags & ClauseDontEvaluateArgs) {
		if (func->nClauses != 1)
		    TrError(data,
			    "Only one method allowed if function"
			    " doesn't evaluate args!");
		func->flags |= FuncDontEvaluateArgs;
	    }
	    proc->_function = func;
	    proc = next;
	}
	func->nKeywords = 0; func->keywords = NULL; func->keywordHash = NULL;
	id->next = NULL;
	id = next;
    }
  }  /* end:if (data->pass == BindPass) */

    if (curProc && curProc->expr == block)
      {
	params = curProc->nParams;
	data->nesting = curProc->nesting;
      }
    else params = 0;
#if 0
    for (decl = block->decls.first; decl; decl = decl->next)
	if (block->type == NULL) CheckField(decl, NULL);
#endif
    for (st = block->first; st != NULL; st = st->next)
      {	struct UnifyExpr *eq = st->src.unify();
	int addNonRec = 0;
	if (params == 0)
	    data->nesting = -1;
	params--;
	if (st->kind == ClosureStatement) {
	    /* Must traverse the right-hand-side of the unification.
	     * This must be done AFTER BlockPopDecls, so we let
	     * BlockAssignFields to do it.
	     */
	    continue;
	}
#if 0
	else if (st->kind == IncludeStatement) {
	    struct UnifyExpr *unify;
	    struct Identifier *left;
	    ExType type;
	    Expr_Ptr right;
	    int count = 0;
	    struct Declaration *decl, *dcl, *dcl2, **last;

	    st->src = st->src.traverse(data);

	    unify = st->src.unify;
	    if (ExprCodeOf((Expr*)unify) != UnifyExpr_code) abort();
	    right = unify->right;
	    left = unify->left.ident;
	    type = FindExprType(right.E);
	    decl = left->v.decl;
	    decl->defining = right;
	    if (ExType_Type(type) == NULL) {
		TrError(data, "Unknown type of import"); return; }
/*	    fprintf(stderr, "*: {type: #%x}\n", type); */
	    decl->type = right.any->type;

	    last = &DECL_INCLUDED_DECLS(decl);

	    desc = ExType_Type(type)->desc;
	    FOR_EACH_FIELD(fld, desc) {
		if (fld->kind == Include_Field || fld->isPrivate())
		     continue;
		dcl2 = Symbol2Declaration(fld->name);
		if (fld->is_const())
		    dcl2->set_const(fld->get_const());
		else if (fld->is_proc())
		    dcl2->set_proc(fld->get_proc());
		    dcl2->type = MakeExType(ExMethodPtr, fld->u.type);
		else if (fld->kind == Pointer_Field)
		    dcl2->set_pointer_field(fld->offset, fld->u.type);
		else if (fld->kind == Struct_Field)
		    dcl2->size = fld->u.type->inst_size,
		    dcl2->type = MakeExType(ExDirectType, fld->u.type),
		    dcl2->offset = fld->offset;
		else
		    TrError(data, "W inclusion of %s not supported",fld->name);
		dcl2->setPrivate(decl->isPrivate());
		*last = dcl2;
		last = &dcl2->next;
		count++;
/*		Insert(block->locals, fld->name, dcl2); */
		if (fld->kind != Constant_Field && decl->blockLevel == 0)
		    TrError(data, "W inclusion of %s not supported",fld->name);
	    }
	    DECL_INCLUDED_FIELD_COUNT(decl) = count;
	}
#endif
	else
	  {
	    // If a top-level function, don't traverse it yet,
	    // but delay the traverse until it is actually needed.
	    if (st->kind != MethodStatement || block->enclosing != 0
		|| Compiling
		|| (st->src.E->flags & ProcIsMacro))
		st->src = st->src.traverse(data);
	    last = st->src.E;
	  }
	st_flags &= st->src->flags;
      }
    block->flags |= st_flags;
    if (!(block->flags & BlockReturnSelf) && last != NULL)
	block->type = last->type;
    data->curBlock = saveBlock;
    *block->decls.last = NULL; /* to avoid confusing BlockCompile */
}

int AssignOffsets(
    struct Declaration *decls,
    int global,
    struct TraverseData *data,
    int *align)
{
    register struct Declaration *decl;
    int fix_mask = global
	? GeneralDeclaration - TentativeDeclaration
	: SetDeclaration - TentativeDeclaration;
#if 1
    int sum_size = 0, alignment = 0;
#else
    int sum_size[2] = 0, alignment[2] = 0;
    sum_size[0] = 0; alignment[0] = 0;
    sum_size[1] = 0; alignment[1] = 0; /* temporary, private */
    int private;
#endif
    
    for (decl = decls; decl != NULL; decl = decl->next())
      { Expr *src = decl->defining.E;
	if ((decl->flags & ImplicitDeclMask) == TentativeDeclaration)
	    decl->flags += fix_mask;
	if (!decl->is_proc() && decl->size != Label_SizeCode)
	  {
	    if (decl->is_const() || decl->is_proc())
		continue;
	    if (global && decl->fname() != NULL) {
		Root *var = AllocGenVar(decl);
		decl->set_value(var);
		Symbol *sym = decl->fname();
		sym->sym_value(var);
		if (!(decl->flags & PrivateDeclaration)) {
		    Package *pack = sym->_package;
		    if (pack)
			pack->export(sym);
		}
		continue;
	    }
#if 0
	    if (decl->offset == -1)
		if ((decl->flags & (PrivateDeclaration+NonLocalDeclaration))
		== PrivateDeclaration)
		    continue;
	    if (ExType_Kind(decl->type) == ExDirectType
	     && ExType_Type(decl->type) == AnyT) {
		decl->size = sizeof(struct Any);
		decl->offset = DivByteSize(sum_size);
		sum_size += decl->size * ByteSize;
		continue;
	    }
#endif
	    if ((decl->flags & ImplicitDeclMask) != SetDeclaration) {
		decl->set_pointer_field(decl->u.offset, &RefRoot);
	    }
	    if (decl->type == NULL) {
		decl->set_pointer_field(decl->u.offset, &RefRoot);
		if (LogVerbose > 0)
		    TrError(data, "W BlockTraverse: field size unknown for %s",
			decl->name);
	    }
	    else if (decl->type->kind == ReferenceTypeKind
		     || decl->type->kind == TextTypeKind) {
		decl->set_pointer_field(decl->u.offset, decl->type);
	    }
	    else {
		decl->indirection = IsField;
		decl->kind = Struct_Field; /* ?obsolete? */
		decl->size = decl->type->inst_size;
	    }
	    if (decl->kind == Pointer_Field) {
		sum_size = DoAlign(sum_size, PointerAlign);
		if (PointerAlignLog > alignment) alignment = PointerAlignLog;
		decl->u.offset = DivByteSize(sum_size);
		sum_size += sizeof(Object) * ByteSize;
	    }
#if 0
	    else if (IsBitField(decl))
	      {
#if 0
		int alignment = 1 << decl->type->alignment;
		sum_size = DoAlign(sum_size, alignment);
#endif
		decl->offset = sum_size; /* ? */
		sum_size += BitSize(decl);
	      }
	    else if (DeclIsInclude(decl)) {
		int super_align = ((struct Type*)decl->type.ptr)->alignment;
		struct Declaration *dcl = DECL_INCLUDED_DECLS(decl);
		if (super_align > alignment) alignment = super_align;
		sum_size = DoAlign(sum_size, 1<<super_align);
		decl->offset = DivByteSize(sum_size);
		for (;dcl != NULL; dcl = dcl->next)
		    if (dcl->offset != -1)
			dcl->offset += decl->offset;
		sum_size += ExType_Type(decl->type)->inst_size * ByteSize;
	    }
#endif
	    else {
		decl->u.offset = DivByteSize(sum_size);
		sum_size += decl->type->inst_size * ByteSize;
	    }
	  }
	if (src == NULL) continue;
#if 0
	if (decl->flags & NonLocalDeclaration)
	  { /* Traverse newly closured variables */
	    decl->defining.E = src = decl->defining.E->traverse(data);
	  }
	if (ExprCodeOf(src) == ExprNode_code)
	  { struct ExprNode *node = &src->node;
	    if (node->postfix != 1) { }
	    else if (ExprCodeOf(node->func.E) == Identifier_code)
	      { struct Identifier *id = node->func.ident;
		struct Type *typ = (struct Type*)TestConstant(id);
		if (typ && MemGetType(typ) == TypeT)
		  {
		    decl->type = MakeExType(ExPointerType, typ);
		    if (id->flags & IdentHasMark)
			decl->size = typ->size;
		  }
	      }
	    else
	      { struct ExprCall *callEx = node->func.call;
		extern Expr *MakeBytesName;
		if (ExprCodeOf(callEx) ==  ExprCall_code
		&& callEx->proc.E == MakeBytesName)
		  {
		    decl->type = NULL;
		    decl->size = *(long*)callEx->arg[0].P;
		    src = node->arg.E;
		  }
	      }
	  }
#endif
      }
    sum_size = DoAlign(sum_size, 1<<ByteSizeLog);
    sum_size = DivByteSize(sum_size);
    if (align) *align = alignment;
    return sum_size;
}

void BlockAssignFields(struct Block *block, struct TraverseData *data)
{
    int sum_size, alignment;
    struct Statement *st;
    if (data->pass > BindPass) return;
    for (st = block->first; st != NULL; st = st->next)
	/* do some traverses that were punted on in BlockScan */
	if (st->kind == ClosureStatement) {
	    st->src.unify()->right = st->src.unify()->right.traverse(data);
	}
    sum_size = AssignOffsets(block->decls.first, block->flags & BlockIsGlobal,
	data, &alignment);
    if (sum_size > block->size) block->size = sum_size;
    if (block->rtype)
	CreateClassDesc(block->rtype->desc, block->decls.first, data);
    if ((block->flags & BlockReturnSelf) && block->enclosing) {
	struct RecordType *typ = block->rtype;
	typ->inst_size = block->size;
	typ->alignment = alignment;
    }
    if (data->curProc) {
	if (data->curProc->displayMax < block->level)
	    data->curProc->displayMax = block->level;
    }
    else
	if (data->displayMax < block->level)
	    data->displayMax = block->level;
  }

struct Expression * Block::traverse(struct TraverseData *data)
{
    return bl_traverse(data);
}

void TraverseCoercion(Block* block, struct TraverseData *data)
{
    if (block->coercion == NULL)
	return;
    block->coercion = block->coercion->traverse(data);
    if (block->coercion->code() == ExprQuote_code) {
	Root* coercion_value = ((ExprQuote*)block->coercion)->value();
	Type* coercion_type;
	if (coercion_value
	    && (coercion_type = PTR_CAST(Type, coercion_value)) != NULL)
	    block->type = coercion_type;
    }
}

struct Block * Block::bl_traverse(struct TraverseData *data)
{
/* Any changes here probably require equivalent changes in the
 * case of TraverseElseExpr (when e1 is a Block). */
    struct LoopConsExpr *saveLoops = data->visibleLoopConsList;
    BlockScan(this, data);
    BlockPopDecls(data, this);
    BlockAssignFields(this, data);
    if (coercion)	
	TraverseCoercion(this, data);
    data->visibleLoopConsList = saveLoops;
    return this;
}

static int CompareKeywordEntries(const void * entry1, const void* entry2)
{
    return strcmp(((KeywordEntry*)entry1)->label->string(),
		  ((KeywordEntry*)entry2)->label->string());
}

Expr * ProcExpr::traverse(register struct TraverseData *data)
{
  traverse1(data);
  return traverse2(data);
}

void ProcExpr::traverse1(register struct TraverseData *data)
{
  extern char *SelectProcType();
  register struct Declaration *decl; 
  struct ParamExpr *arg;
  struct LoopConsExpr *saveLoops = data->visibleLoopConsList;
  struct VarStateList *save;
  extern struct VarStateList *NewVarState();
  struct Block *block = data->curBlock;
  int i, n=0, has_type;
  struct Identifier *id;

  data->curProc = this;
  displayMax = 0;
  flags &= ~ProcHasNotBeenTraversed;
  clause->flags &= ~ClauseHasNotBeenTraversed;

  if (block != NULL)
    {
      /* calculate expr->level */
      i = block->level + PROC_EXTRA_LEVELS;
      if (!(block->flags & BlockReturnSelf))
	i++; // add one level for possible closure, since we don't use block
      expr->level = i;

      if ((data->curBlock->flags & BlockIsGlobal+BlockReturnSelf)
	  == BlockReturnSelf)
	closure = data->curBlock;
    }
  else
    expr->level = PROC_EXTRA_LEVELS;

  inherit_closure = closure != NULL;

  /* actually traverse the proc (formal parameters then body) */
  save = NewVarState(data);

  /* ???  if (data->pass == BindPass)  */
  for (decl = paramDecls; decl != NULL; decl = decl->next())
    {
      decl->blockLevel = PARAM_LEVEL(this);
      PushDecl(data, decl);
    }
  for (arg = argList; arg ; arg = arg->next)
    {
      Expr *arg_expr = arg->arg_expr.E;
      if (arg->default_expr != NULL)
	{
	  struct VarStateList *save1 = NewVarState(data);
	  arg->default_expr = arg->default_expr->traverse(data);
	  MergeVarState(save1, data);
	}
      if (arg_expr->code() == InverseExpr_code
	  && IdentifierLike(arg->arg_expr.inverse()->arg.E))
	{
	  Expr *func = arg->arg_expr.inverse()->func.E->traverse(data);
	  arg->arg_expr.inverse()->func.E = func;
	  has_type = 2; arg_expr = arg->arg_expr.inverse()->arg.E;
	}
      else has_type = 0, arg_expr = arg->arg_expr.E;
      if (IdentifierLike(arg_expr))
	{
	  if (ExType_Kind(arg->arg_type) != ExBogusType && has_type == 0)
	    has_type = 1;
	  data->flags |= TraverseInUnify;
	  arg_expr = arg_expr->traverse(data);
	  if (data->flags & TraverseInUnify)
	    data->flags &= ~TraverseInUnify;
	  else
	    arg->flags |= FormalMustUnify;
	}
      else
	arg_expr = arg_expr->traverse(data),
      arg->flags |= FormalMustUnify;
      if (has_type == 2)
	{
	  Expr *q = arg->arg_expr.inverse()->func.E;
	  arg->arg_expr.inverse()->arg.E = arg_expr;
	  if (!(arg->flags & FormalMustUnify))
	    {
	      Type* type = ExprToType(q, data);
	      id = (struct Identifier*)arg_expr;
	      id->type = type;
	      id->v.decl->type = id->type;
	      arg->arg_expr.E = arg_expr;
	    }
	}
      else
	{
	  if (!(arg->flags & FormalMustUnify))
	    {
	      if (has_type > 0)
		{
		  id = (struct Identifier*)arg_expr;
		  id->type = arg->arg_type;
		  id->v.decl->type = arg->arg_type;
		}
	      else if ((arg->flags&FormalMultiple) == FormalMultipleVector)
		{
		  id = (struct Identifier*)arg_expr;
		  id->type = &RefVector;
		  id->v.decl->type = id->type;
		}
	    }
	  arg->arg_expr.E = arg_expr;
	}
    }
  if (flags & ProcIsExternal)
    TraverseCoercion(expr, data);
  else if (lisp_body && data->pass == BindPass)
    ExpandLispBody(this, data);
  else
    expr = expr->bl_traverse(data);

  if (data->pass == BindPass)
    {
      for (decl = paramDecls; decl != NULL ; decl = decl->next())
	PopDecl(data, decl);
      data->visibleLoopConsList = saveLoops;
      MergeVarState(save, data);
    }
}

Expr * ProcExpr::traverse2(register struct TraverseData *data)
{
  struct Formal *formal;
  struct ParamExpr *arg;
  int directCallOk;
  struct ProcExpr *saveProc = data->curProc;
  struct Block *block = data->curBlock;
  struct Declaration *result_decl = NULL;

  if (data->pass == BindPass) {
#if 0
    if (pd->resultType == NULL || pd->resultType == &TObjectOb)
	pd->resultType = FindExprType(expr);
#endif

    if (expr->type == &Text)
	block = expr;
    else
	block = TestConstructor(expr);
    if (block) {
	result_decl = Symbol2Declaration(&RESULT_sym);
	if (expr->type == &Text)
	    result_decl->set_pointer_field(0, block->type);
	else
	    result_decl->set_struct_field(0, block->type); // ???
	result_decl->next() = paramDecls;
	result_decl->flags &= ~ImplicitDeclMask;
	result_decl->flags |= SetDeclaration;
	paramDecls = result_decl;
	procKind = 'C';
	block->flags |= BlockGivenResult;
	RecordType *block_type = (RecordType*)block->type;
	clause->resultType = block_type;
	if (block_type->class_name == NULL)
	    block_type->class_name = fname;
    }

    if (context) {
	struct Declaration *context_decl = context->v.decl;
	if ((flags & ProcPrefix) || paramDecls == NULL) {
	    context_decl->next() = paramDecls;
	    paramDecls = context_decl;
	}
	else {
	    context_decl->next() = paramDecls->next();
	    paramDecls->next() = context_decl;
	}
    }

    clause->paramSize = 
	AssignOffsets(paramDecls, 0, data, NULL);
    clause->formals =
	(struct Formal*)malloc(clause->nParams * sizeof(struct Formal));
    clause->paramDesc = CreateClassDesc(NULL, paramDecls, data);
    clause->keywords = !(flags & ProcHasNamedParams) ? NULL
       :(KeywordEntry*)malloc((pn[2].required+pn[2].optional)*sizeof(KeywordEntry));
    if (context) clause->self = context->v.decl;
  }   /* end:if (data->pass == BindPass) */

    data->curProc = saveProc;
    directCallOk = ClauseDirectCallOk;
    KeywordEntry* keywordPtr = clause->keywords;
    int iKeyword = 0;
    for (arg = argList, formal = clause->formals;
      arg ; arg = arg->next, formal++) {
	formal->flags = arg->flags;
	if (arg->name && data->pass == BindPass) { // Keyword parameter
	    keywordPtr->label = arg->name;
	    keywordPtr->formal_number = iKeyword++;
	    keywordPtr++;
	}
	if (arg->flags & FormalMustUnify)
	    directCallOk = 0, formal->u.ex = arg->arg_expr.E;
	else
	    formal->u.id = arg->arg_expr.ident()->v.decl;
	formal->default_expr = arg->default_expr;
	if (formal->default_expr != NULL) {
	    enum ExprCode code = formal->default_expr->code();
	    if (code != Dummy_code && code != ExprQuote_code)
		directCallOk = 0;
	}
    }

    if (nParams > _function->nParams) _function->nParams = nParams;
    if (clause->pn[0].required < _function->min_required[0])
	_function->min_required[0] = clause->pn[0].required;
    if (clause->pn[1].required < _function->min_required[1])
	_function->min_required[1] = clause->pn[1].required;

    if (clause->keywords && data->pass == BindPass) {
	int nKeywords = pn[2].required+pn[2].optional;
	qsort(clause->keywords,
	      nKeywords,
	      sizeof(KeywordEntry),
	      CompareKeywordEntries);
	Symbol* prev_label = NULL;
	register KeywordEntry *curEntry = clause->keywords;
	for (int i = 0; i < nKeywords; curEntry++, i++) {
	    if (prev_label == curEntry->label)
		TrError(data, "Duplicate keyword '%s'", prev_label->string());
	    clause->keywords[curEntry->formal_number].inverse_formal_number= i;
	    prev_label = curEntry->label;
	}
    }
    clause->flags |= directCallOk;

    if (result_decl) clause->result = result_decl;

    if (data->pass == BindPass && closure != NULL) {
	struct Statement *st;
	struct UnifyExpr *LinkParam();
	/* add extra "self" parameter to argList for environment */
	/* NOTE: above assumes *last != first */
	if (!inherit_closure) {
	    //struct Block *closure = closure;
	    /* want to do BlockTraverse on the new block,
	     * but split it up to avoid recursion on the proc */
	    BlockPopDecls(data, closure);
	    for (st = closure->first; st != NULL; st = st->next)
		st->src.unify()->right = st->src.unify()->right.traverse(data);
#if 0
    for (st = closure->first; st != NULL; st = st->next)
    st->src = st->src.traverse(data);
	    if (flags & ProcPrefix) sym = sPrefix;
	    else sym = sPostfix;
	    decl = Symbol2Declaration(sym);
	    decl->set_proc(this));
	    decl->flags |= SetDeclaration;
	    AppendDeclaration(closure, decl, this);
#endif
	//	    closure = NULL;
	    BlockAssignFields(closure, data);

/*	    clause->size = closure->size; */
	    return (Expr*)closure;
	  }
      }

    return (Expr*)this;
}

#ifdef SYMS
ModPutModule(
    struct Module *into,
    struct Module *module,
    int all) /* 0: only imported names; 1: all internals names */
  { register struct Declaration *decl;
    register struct ModuleEntry { Name arg; struct Module *module} *entry;
    register struct ModuleList *link;
 /* check if module already inserted */
    if (into->modsIncluded == NULL)
	into->modsIncluded = HashTable::New(32);
    entry =
	 (struct ModuleEntry*)SymbolLookup(into->modsIncluded, module->name);
    if (entry->arg == module->name && entry->module == module) return;
    entry->arg = module->name; entry->module = module; tab.rehash_if_needed();

    for (decl = module->block->decls.first; decl != NULL; decl = decl->next)
	ModPutDecl(into, decl, all);
    for (link = module->imported; link != NULL; link = link->next)
      {
	if (link->included && (all || link->private == 0))
	    ModPutModule(into, link->module, 0);
      }
  }

ModPutDecl(struct Module *into, register struct Declaration *decl, int all)
  { register struct DeclEntry { Name arg; struct Declaration *decl} *entry;
/*fprintf(stderr, "<ModPutDecl(%s, %s, %d)>\n", into->name, decl->name, all);*/
    if (!all && decl->isPrivate())
	return;
    if (DeclIsInclude(decl))
	return;
    if (into->syms == NULL)
	into->syms = HashTable::New(64);
    entry = (struct DeclEntry*)SymbolLookup(into->syms, decl->name);
    if (entry->arg == NULL)
      { entry->arg = decl->name; entry->decl = decl; tab.rehash_if_needed();
	decl->sameName = NULL; }
    else
      { register struct Declaration *dcl;
	/* make sure decl isn't already on the decl->entry list */
	for (dcl = entry->decl; dcl != NULL; dcl = dcl->sameName)
	  {
	    if (dcl == decl) return;
	    if (decl->token.kind == ConstToken && dcl->token.kind == ConstToken
	     && decl->token.u.constant.label == dcl->token.u.constant.label
	     && decl->token.u.constant.offset == dcl->token.u.constant.offset)
		return;
	  }

	decl->sameName = entry->decl;
	entry->decl = decl;
      }
  }
#endif SYMS

#if 0
/* generate a HashTable (name->Declaration_list) of globals */
HashTable *ModuleSymbols(Module *module, int all)
/* if all==0: only want exported symbols; else want all */
  {
    ModPutModule(module, module, all);
    return module->syms;
  }
#endif

Declaration *
Ident2Decl(Identifier *id)
{
#if 1
#if 0
    if (id->flags & IdentNesting) {
	fprintf(stderr, "IdentNesting flag on for id=%X\n", id);
	return NULL;
    }
#endif
    return id->v.decl;
#else
    struct Declaration *decl;
  retry:
    if (HasHType(id, Declaration))
	return (struct Declaration*)id;
    decl = id->decl;
    if (decl != NULL && HasHType(decl, UnifyExpr))
      { id = ((struct UnifyExpr*)decl)->left.ident; goto retry; }
    return decl;
#endif
}
