#pragma implementation
#include <strstream.h>
#include "gfunc.h"
#include "symbol.h"
//#include "hash.h"
#include "genmap.h"
#include "genfiles.h"
#include "gennum.h"
#include "gkinds.h"
#include "gvars.h"
#include "builtin-syms.h"
#include "gassign.h"
#include <std.h>
#include "ifthenelse.h"
#include "exceptions.h"
#include "expression.h"
#include "evalprocs.h"
#include "shell.h"
#include "traverse.h"
#include "modules.h"
#include "gfiles.h"
#include <CharSet.h>

#include "bool-hash.h"

void PrefixOp::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  Root *result;
  if (args.rCount == 0)
    result = DoCurry(this, args);
  else
    {
      Root* nextArg = args.rArgs[0];
      Root* val = prefix(nextArg);
      if (val == NULL)
	{
	  Root *thisPtr;
	  Root **lArgs;
	  if (args.lCount)
	    {
	      lArgs = (Root**)alloca((args.lCount+1) * sizeof(Root*));
	      memcpy(lArgs, args.lArgs, args.lCount * sizeof(Root*));
	    }
	  else
	    lArgs = &thisPtr;
	  lArgs[args.lCount] = (Root*)this;
	  result = nextArg->apply(lArgs, args.rArgs+1, args.nArgs, args.names,
				  args.lCount+1, args.rCount-1, args.nCount);
	}
      else
	result = val->apply(args.lArgs, args.rArgs+1, args.nArgs, args.names,
			    args.lCount, args.rCount-1, args.nCount);
    }
  dstType->coerceFromRoot(dst, result);
}

void GFunction::printon(ostream& outs) const
{
    struct Clause *clause;
    int iClause;
    outs << "FUNCTION[";
    if (func->str_name() != NULL)
	outs << func->str_name() << ", ";
    outs.form(" nClauses:%d]\n", func->nClauses);
    for (clause = func->clauses, iClause = 0; iClause < func->nClauses;
	clause++, iClause++) {
	if (clause->flags & ClauseHasNotBeenTraversed)
	    continue;
	int leftCount = clause->pn[0].required + clause->pn[0].optional
	    + clause->pn[0].tuple;
	outs << "\t";
	for (int iFormal = 0; iFormal < clause->nParams; iFormal++) {
	    if (iFormal > 0) outs << ' ';
	    if (iFormal == leftCount) outs << ". ";
	    struct Formal *formal = &clause->formals[iFormal];
	    if (formal->flags & FormalMustUnify)
		outs << formal->u.ex;
	    else
		outs << formal->u.id->name->string();
	    if (formal->flags & FormalMultiple)
		outs << "@[M]";
	    if (formal->default_expr) {
		outs << " =[D] " << *formal->default_expr;
	    }
	}
	outs << "\n";
    }
}

static
void ArgEvalList(register Expr_Ptr *exList, struct DisplayEnv *env,
		 RootPtr *bPlain, RootPtr *bNamed, Symbol**bNames,
		 int rCount)
// WARNING: The registers declared 'register' really must be
// assigned to registers by the compiler. Otherwise,
// back-tracking might break!!!
{
    register int iPlain = 0, iNamed = 0, iTuple = 0;
    for (; exList->E; exList++) {
	if (exList->code() == MapPair_code) {
#if 0
	    Root *name = exList->bin()->arg[0].eval(env);
	    if (name->magic() != SymbolKind) abort();
#else
	    Symbol *sym = ((MapPairExpr*)exList->E)->label();
#endif
	    Root *val;
	    exList->bin()->arg[1].eval(&val, &RefRoot, env);
	    bPlain[rCount+2*iNamed] = sym;
	    bPlain[rCount+2*iNamed+1] = val;
	    bNames[iNamed] = sym;
	    bNamed[iNamed] =  val;
	    iNamed++;
	}
	else
	    exList->eval(&bPlain[iPlain++], &RefRoot, env);
    }
}

CurriedFunction::CurriedFunction(Functional *function, ArgDesc& args)
    : saved_Function(function)
{
    args.copy_to(saved);
}

Functional * DoCurry(Functional *function, ArgDesc& args)
{
    if (args.empty()) return function;
    CurriedFunction *curry = new CurriedFunction(function, args);
    return curry;
}

void UpdatingFunction::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  Root* result;
  if (args.lCount == 0)
    result = DoCurry(this, args);
  else
    {
      if (args.lCount > 1) abort();
      Assignable* var = args.lArgs[0]->assignable();
      if (var == NULL) RaiseDomainError(NULL);
      Root* old = var->value();
      ArgDesc work_args(&old, args.rArgs, args.nArgs, args.names,
			1, args.rCount, args.nCount);
      var->assign(worker->apply(work_args));
      var->NotifyDependents();
      result = &NullSequence;
    }
  dstType->coerceFromRoot(dst, result);
}

// Return number of excess arguments.
// Return -1 if there are too few arguments.
int
SetupArgList(
    struct DisplayEnv *env, struct Clause *clause, struct Function *func,
    RootPtr *args, int count,
    int side /* 0: left args, 1: right args */
)
{
/* WARNING: register declarations must be honored, in case of backtracking */
    register int iArg; /* number of non-keyword parameters used up */
    register int iFormal;
    register struct Formal *formal;
    register int defaults_to_skip = 0;
    int use_for_multiple = 0;
    int nFormal;

    if (count > clause->pn[side].required + clause->pn[side].optional) {
	defaults_to_skip = clause->pn[side].optional;
	use_for_multiple =
	    count - clause->pn[side].required - clause->pn[side].optional;
//	if (use_for_multiple && !clause->pn[side].tuple) return 1;
    } else if (count < clause->pn[side].required)
	return -1;
    else {
	use_for_multiple = 0;
	defaults_to_skip = count - clause->pn[side].required;
    }

    int leftCount = clause->pn[0].total();
    if (side==0) {
	iFormal = 0;
	nFormal = leftCount;
    } else {
	iFormal = leftCount;
	nFormal = func->nParams - clause->pn[2].total();
    }
    for (iArg = 0; iFormal < nFormal; iFormal++) {
	RootPtr val;
	formal = &clause->formals[iFormal];
	if (iFormal == func->nParams) return 0;
	if (formal->flags & FormalMultiple) {
	    if ((formal->flags & FormalMultiple) == FormalMultipleList) {
		val = &NilSymbol;
		for (int i = use_for_multiple; --i >= 0; )
		    val = new ConsPair(args[iArg+i], val);
	    }
	    else
		val = NewVector(use_for_multiple, &args[iArg]);
	    iArg += use_for_multiple;
	}
	else if (formal->default_expr == NULL)
	    val = args[iArg++];
	else if (defaults_to_skip > 0)
	    val = args[iArg++], defaults_to_skip--;
	else if (formal->default_expr == &NULL_expr)
	    val = NULL;
	else
	    val = formal->default_expr->eval(env);
	if (formal->flags & FormalMustUnify) {
	 /* Use tmp values in case evaluations have multiple results. */
	 /* Use volatile for force non-register (???) */
	    volatile Root *tmp2;
	    formal->u.ex->eval(&tmp2, &RefRoot, env);
	    tmp2->unify(*val);
	}
	else {
	    void *dst = env->env[1];
	    IFV(SetupArgHandler) {
		SetField(val, dst, formal->u.id);
	    } THENV { }
	    ELSEV(SetupArgHandler,Fail) {
		Signal(new ParameterFail(formal, val));
	    } ENDV;
	}
    }
    return clause->pn[side].tuple ? 0 : use_for_multiple;
}

int
SetupKeywordArgList(
    struct DisplayEnv *env, struct Clause *clause, struct Function *func,
    RootPtr *rArgs, int rCount, int nCount)
{
/* WARNING: register declarations must be honored, in case of backtracking */
    register int iArg; /* number of non-keyword parameters used up */
    register int iFormal;
    register struct Formal *formal;
    int nFormal;

    int nKeywords = clause->pn[2].required + clause->pn[2].optional;
    nFormal = func->nParams;
    iFormal = nFormal - nKeywords;
    int nUsed = 0;
    register KeywordEntry *keywords = clause->keywords;
    for (iArg = 0; iFormal < nFormal; iFormal++, iArg++) {
	RootPtr val = NULL;
	formal = &clause->formals[iFormal];
	Symbol* name =
	    keywords[keywords[iArg].inverse_formal_number].label;
	for (register int j = nCount; --j >= 0; )
	    if (rArgs[rCount+2*j] == name) {
		val = rArgs[rCount+2*j+1]; break;
	    }
	if (val != NULL) nUsed++;
	else if (formal->default_expr)
	    val = formal->default_expr->eval(env);
	else
	    return -1;
	if (formal->flags & FormalMustUnify) {
	 /* Use tmp values in case evaluations have multiple results. */
	 /* Use volatile for force non-register (???) */
	    volatile Root *tmp2;
	    formal->u.ex->eval(&tmp2, &RefRoot, env);
	    tmp2->unify(*val);
	}
	else
	    SetField(val, env->env[1], formal->u.id);
    }
    return nUsed == nCount ? 0 : 1;
}

#ifndef CALL_C_FUNCTION
typedef RootPtr (*RFunc0)();
typedef RootPtr (*RFunc1)(Root*);
typedef RootPtr (*RFunc2)(Root*, Root*);
typedef RootPtr (*RFunc3)(Root*, Root*, Root*);
typedef RootPtr (*RFunc4)(Root*, Root*, Root*, Root*);
typedef RootPtr (*RFunc5)(Root*, Root*, Root*, Root*, Root*);
typedef RootPtr (*RFunc6)(Root*, Root*, Root*, Root*, Root*, Root*);
#endif

void ApplyClause(void* dst, Type* dstType, 
		 Clause* clause, Function* func, Root* env, ArgDesc& args)
{
    void *params;
#if 0
    availDefaults = 0;
    for (i = clause->nParams, formal = clause->formals + i; i > 0;
	formal--, i++) {
	if (formal->default_expr == NULL) continue;
	if (formal->flags & FormalKeyword)
	    if (given) continue;
	availDefaults++;
    }
#endif
    struct ProcExpr *proc = clause->expr;
    int display_min, display_max;
    if (clause->flags & ClauseCompiled) {
	display_min = 0;
	display_max = 1;
    }
    else {
	display_min = proc->expr->level - PROC_EXTRA_LEVELS;
	display_max = proc->displayMax;
    }
#ifdef __GNUC__
    char __dEnv[(display_max+1-display_min)*2*sizeof(void*)];
    struct DisplayEnv *dEnv = (struct DisplayEnv*)__dEnv;
#else
    struct DisplayEnv *dEnv = (struct DisplayEnv*)
	alloca((display_max+1-display_min)*2*sizeof(void*));
#endif
    dEnv->minLevel = display_min;
    dEnv->maxLevel = display_max;
    dEnv->tryNext = MAKE_ANY(NULL, NULL);
    dEnv->env[0] = env;
 /* params should be allocated last, so can be used directly as param list */
    params = alloca(clause->paramSize);
    dEnv->env[1] = params; /* 1 = PARAM_LEVEL(proc) - dEnv->minLevel */
    if (clause->self) {
	if (clause->self->kind == Pointer_Field)
	     *(void**)((char*)params + clause->self->u.offset) = env;
	else
	     *(struct Any*)((char*)params + clause->self->u.offset) =
		MAKE_ANY(env, NULL);
    }
    int excess;
    IFV(FuncApplyHandler) {
	if (!(clause->flags & ClauseCompiled))
	    AllocVars((struct Declaration*)clause->paramDesc->fields, params);
	if (SetupArgList(dEnv, clause, func, args.lArgs, args.lCount, 0))
	    RaiseDomainError(NULL);
	excess = SetupArgList(dEnv, clause, func, args.rArgs, args.rCount, 1);
	if (excess < 0)
	    RaiseDomainError(NULL);
	if (clause->keywords) {
		int skip = args.rCount;
		int nCount = args.nCount;
		if (excess > 0 && !(excess & 1)) { // KLUDGE!
		    Root *first_remaining = args.rArgs[skip-excess];
		    if (first_remaining->isKindOf(*Symbol::desc())
			&& ((Symbol*)first_remaining)->_package == &KeywordPackage)
			skip -= excess, nCount += excess>>1, excess = 0;
		}
		if (SetupKeywordArgList(dEnv, clause, func,
					args.rArgs, skip, nCount))
		    RaiseDomainError(NULL);
	    }
    }
    THENV {
    }
    ELSEV (FuncApplyHandler, Fail) {
	// If the formal type is scalar and the actual is a sequence ...
	if (LastRaiseCondition != NULL
	    && LastRaiseCondition->isKindOf(*ParameterFail::desc())) {
	    ParameterFail *pfail = (ParameterFail*)LastRaiseCondition;
	    if (pfail->param_value()->sequence() != NULL
		&& pfail->param_type()->is_scalar()) {
		dstType->coerceFromRoot(dst, 
					new MapSeq(clause, func, env, args));
		return;
	    }
	}
	Signal(LastRaiseCondition);
    }
    ENDV;

    if (excess) {
	Root* result;
	CallClause(&result, &RefRoot, clause, dEnv, params);
	ArgDesc xargs(NULL, args.rArgs + args.rCount - excess,
		      args.nArgs, args.names, 0, excess, args.nCount);
	result->xapply(dst, dstType, xargs);
    }
    else
	CallClause(dst, dstType, clause, dEnv, params);
}

void CallClause(void* dst, Type* dstType, Clause *clause,
		struct DisplayEnv *dEnv, void *params)
{
    ostrstream* temp_ostream = NULL;
    if (clause->result) {
	void *r;
	const struct Type *t = clause->result->type;
	if (t == dstType) {
	    r = dst; // Result passed from caller
	}
	else if (t->kind == RecordTypeKind)
	    r = (char*)((RecordType*)t)->alloc();
	else if (t == &Text) {
	    r = temp_ostream = new ostrstream();
	}
	else
	    abort();
	dEnv->env[PROC_EXTRA_LEVELS] = r;
	*(void**)((char*)params + clause->result->u.offset) = r;
    }
    if (clause->code != NULL) { /* compiled */
	Func f = (Func)clause->code;
	Root* result;
#ifdef CALL_C_FUNCTION
	result = CALL_C_FUNCTION(f, params, clause->paramSize);
#else
	Root **p = (Root**)params;
        int arg_count =
	    (clause->paramSize + (sizeof(RootPtr) - 1)) / sizeof(RootPtr);
	switch (arg_count) {
	  case 0: result = (*(RFunc0)(f))(); break;
	  case 1: result = (*(RFunc1)(f))(p[0]); break;
	  case 2: result = (*(RFunc2)(f))(p[0], p[1]); break;
	  case 3: result = (*(RFunc3)(f))(p[0], p[1], p[2]); break;
	  case 4: result = (*(RFunc4)(f))(p[0], p[1], p[2], p[3]); break;
	  case 5: result = (*(RFunc5)(f))(p[0], p[1], p[2], p[3], p[4]); break;
	  case 6: result = (*(RFunc6)(f))(p[0], p[1], p[2], p[3], p[4], p[5]); break;
	  default:
		  Signal(new UnimplementedOp
			 ("Call to compiled function with > 6 parameters.",
			  NULL));
	}
#endif
	if (temp_ostream) {
	    result = NewString(temp_ostream->pcount(), temp_ostream->str());
	    temp_ostream->freeze(0);
	    delete temp_ostream;
	}
	if (clause->result && clause->result->type == dstType)
	    ; // Result allocated by caller
	else
	    dstType->coerceFromRoot(dst, result);
	return;
    }
    clause->expr->expr->eval(dst, dstType, dEnv);
}

void GFunction::xapply(void* dst, Type* dstType, ArgDesc& args)
{
    int i = func->nClauses;
    register Clause *clause = func->clauses;
    int not_traversed = 0;
    for (; --i >= 0; clause++) {
	if (clause->flags & ClauseHasNotBeenTraversed)
	    not_traversed++;
    }
    if (not_traversed) {
	TraverseData data(DefaultModule); // WRONG module!
	PushPendingProc(func, &data);
	PopPendingProcs(&data);
    }
    if (args.lCount < func->min_required[0]
	|| args.rCount < func->min_required[1]){
	dstType->coerceFromRoot(dst, DoCurry(this, args));
	return;
    }

//  struct Field *field; struct Declaration *decl;
    register int nClauses = func->nClauses;
    clause = func->clauses;
    Continuation cont;
    int unlink_cont = 0;
  start_clause:
    if (nClauses > 1) {
#if defined(USE_LONGJMP)
	if (SaveIfHandler(0, &cont)) { /* never true */
	    clause++; /* compiler bug here? only 1 gets added, not sizeof */
	    nClauses--;
	    unlink_cont = 0;
	    goto start_clause;
	}
	unlink_cont = 1;
#else
	extern char retry_label[1];
	if (!SaveOrHandler(retry_label, &cont)) { /* never true */
	    PRIM_HANDLER(Fail, "retry_label");
	    clause++; /* compiler bug here? only 1 gets added, not sizeof */
	    nClauses--;
	    goto start_clause;
	}
#endif
    }
    ApplyClause(dst, dstType, clause, func, env, args);
    if (unlink_cont)
	UnlinkIfHandler(&cont);
}

void CurriedFunction::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  if (args.empty())
    {
      dstType->coerceFromRoot(dst, this);
      return;
    }
  ArgDesc combined;
  combined.lCount = saved.lCount + args.lCount;
  if (args.lCount == 0) combined.lArgs = saved.lArgs;
  else if (saved.lCount == 0) combined.lArgs = args.lArgs;
  else
    {
      combined.lArgs = (Root**)alloca(combined.lCount * sizeof(Root*));
      memcpy(combined.lArgs, saved.lArgs, saved.lCount * sizeof(Root*));
      memcpy(combined.lArgs+saved.lCount, args.lArgs, args.lCount*sizeof(Root*));
    }

  combined.rCount = saved.rCount + args.rCount;
  if (args.rCount == 0) combined.rArgs = saved.rArgs;
  else if (saved.rCount == 0) combined.rArgs = args.rArgs;
  else
    {
      combined.rArgs = (Root**)alloca(combined.rCount * sizeof(Root*));
      memcpy(combined.rArgs, saved.rArgs, saved.rCount * sizeof(Root*));
      memcpy(combined.rArgs + saved.rCount, args.rArgs, args.rCount * sizeof(Root*));
    }
  if (args.nCount || saved.nCount) abort();
  else combined.nCount = 0;
  saved_Function->xapply(dst, dstType, combined);
}

// This function takes an evaluated argument list,
// does Tuple-expandsion, checks for Missing elements, and then
// actually does an application.

void CallEvaluated(void* dst, Type* dstType, Root* self, ArgDesc& args)
{
    int i;
    size_t seqLen = 0;
    int iTuple = 0;
    for (i = 0; i < args.rCount; i++) {
	Root *arg = args.rArgs[i];
#if 0
	// This code should be replaced by an exception.
	if (arg == Missing) {
	    dstType->coerceFromRoot(dst, Missing);
	    return;
	}
#endif
	if (arg->isA() != Tuple::desc()) continue;
	Tuple *tuple = (Tuple*)arg;
	seqLen += tuple->size;
	iTuple++;
    }
    if (iTuple) {
	int new_rCount = args.rCount - iTuple + seqLen;
	Root** pArgs = (Root**)alloca(new_rCount * sizeof(Root*));
	ArgDesc xargs(args.lArgs, pArgs, args.nArgs, args.names,
		      args.lCount, new_rCount, args.nCount);
	for (i = 0; i < args.rCount; i++) {
	    Root *arg = args.rArgs[i];
	    if (arg->isA() != Tuple::desc()) {
		*pArgs++ = arg;
		continue;
	    }
	    Tuple *tuple = (Tuple*)arg;

	    if (tuple->size <= MAX_TUPLE_INLINE) {
		for (int j = 0; j < tuple->size; j++)
		    *pArgs++ = tuple->head[j];
	    }
	    else {
		GenSeq *seq = tuple->val->sequence();
		ITERATOR(it, seq);
		for (;;) {
		    Root* val = it.next();
#if 1
		    if (val == Missing) break;
#endif
		    *pArgs++ = val;
		}
	    }
	}
	self->xapply(dst, dstType, xargs);
    }
    else
	self->xapply(dst, dstType, args);
}

Root *CallEvaluated(Root *self,
		    Root **lArgs, Root **rArgs, Root **nArgs, Symbol**names,
		    int lCount, int rCount, int nCount)
{
    ArgDesc args;
    args.lArgs = lArgs;
    args.nArgs = nArgs;
    args.rArgs = rArgs;
    args.names = names;
    args.lCount = lCount;
    args.rCount = rCount;
    args.nCount = nCount;
    Root *dst;
    CallEvaluated(&dst, &RefRoot, self, args);
    return dst;
}

void ArgCount(register Expr_Ptr *exList, int *plain, int *named)
{
    int iP=0, iN=0;
    for (; exList->E; exList++) {
	if (exList->code() == MapPair_code)
	    iN++;
	else
	    iP++;
    }
    *plain = iP;
    *named = iN;
}

void EvalApply(void* dst, Type* dstType, Root *self, Root *left_arg,
	       register Expr_Ptr *exList, struct DisplayEnv *env)
{
    ArgDesc args;
    args.lCount = left_arg == NULL ? 0 : 1;
    Root *left_val = left_arg; // To allow address to be taken

    ArgCount(exList, &args.rCount, &args.nCount);
    
#if 0
    if (left_val == Missing) {
	dstType->coerceFromRoot(dst, Missing);
	return;
    }
#endif
#if 1
    args.rArgs = (RootPtr*)alloca(args.rCount * sizeof(RootPtr));
#else
    args.rArgs =
	(RootPtr*)alloca((args.rCount+2*args.nCount) * sizeof(RootPtr));
#endif
    args.nArgs = (RootPtr*)alloca(args.nCount * sizeof(RootPtr));
    args.names = (Symbol**)alloca(args.nCount * sizeof(Symbol*));
    args.lArgs = &left_val;

#if 0
    struct ResultElement {
	struct ResultElement *next;
	Root *result;
	int choice_count; // -1 means plain value
	OrContext *context;
    };
    struct ResultElement *result_list;
    struct ResultElement **result_tail = &result_list;
    int total_results = 0;
    int nargs = args.rArgs;
    int choices[nargs];
    Root* args[nargs];
    Root* result = NULL;
    OrContext* save_context[nargs];
    i = 0;
    Choice *choice;
    for (; i < nargs; i++) {
	Root *val = exList[i].eval(env);
	CHECK for fail: if so, goto do_fail;
	args[i] = val;
	save_context[i] = CurrentOrContext;
	if (val->isMemberOf(Choice::desc())) {
	    choice = (Choice*)val;
	    choices[i] = 0;
	  backtrack:
	    args.rArgs[i+args.lCount] = choice->dep[choices[i]].val();
	    CurrentOrContext = Join(CurrentorContext,
				    choice->dep[choices[i]].lenviron());
	    if (CurrentOrContext == NULL)
		goto do_fail;
	}
	else {
	    args.rArgs[i+args.lCount] = val;
	    choices[i] = -1;
	}
    }
    // FIXME: Handle tuples.
    Root *cur_result = self->apply(args);
    if (result->isMemberOf(Choice::desc())) {
	ResultElement *result_element = new ResultElement;
	*result_tail = result_element;
	result_tail = &result_element->next;
	result_element->result = result;
	result_element->choice_count = ((Choice*)cur_result)->nchoices();
	total_results += result_element->choice_count;
    }
    else if (result_tail != &result_list && result == NULL) {
	ResultElement *result_element = new ResultElement;
	*result_tail = result_element;
	result_tail = &result_element->next;
	result_element->result = result;
	result_element->choice_count = -1;
	total_results += 1;
    }
    else
	result = cur_result;
  do_fail:
    while ( --i >= 0) {
	if (choices[i] == -1) continue;
	choice = (Choice*)args[i];
	if (choices[i] < choice->nchoices()) {
	    ++choices[];
	    goto backtrack;
	}
    }
    if (total_results == 0) {
//	Re_raise();
	RaiseDomainError(0);
    }
    else if (result_tail == &result_list)
	return result;
    Choice *choice = new Choice(vals, env, total_results);
    return choice;
#else
    ArgEvalList(exList, env,
		args.rArgs, args.nArgs, args.names, args.rCount);
#endif

    CallEvaluated(dst, dstType, self, args);
}


void CurriedFunction::printon(ostream& outs) const
{
    outs << "<Curried function>";
}

#if 0
extern "C" {
GFunction *MakeFunction(struct Function *func, Root *env)
{    return new GFunction(func, env);}
}
#endif

#if 0
static Root * MakeVector
PrefixOp MakeVectorOp    virtual void printon(FILE *file) const;

#endif

Root *BinOp::doit(Root *, Root *) const { return NULL; }

const StringC *BinOp::asString(int format=0) const
{
    return NewString(strlen(name), name);
}

Root *BinOp::infix(Root *x, Root *y)
{
    Assignable *xvar = NULL;
    Assignable *yvar = NULL;
    if (!assignable_ok(0)) xvar = x->assignable();
    if (!assignable_ok(1)) yvar = y->assignable();
    if (xvar != NULL || yvar != NULL) {
	DependentAssignable *var = new DependentAssignable();
	var->function = this;
	var->current = Missing;
	var->lCount = 1;
	var->rCount = 1;
	var->nCount = 0;
	var->lDeps = new ADependency(var, x);
	var->rDeps = new ADependency(var, y);
	var->nDeps = NULL;
	var->names = NULL;
	var->update();
	return var;
    }
    Root * result = doit(x, y);
    if (result != NULL) return result;
    const Numeric *xn = x->numeric();
    const Numeric *yn = y->numeric();
    if (xn == NULL) {
#if 0
	if (x == Missing) return Missing;
#endif
	GenSeq *lseq = x->sequence();
	if (lseq != NULL) {
	    if (yn) return new BinOpSeq(this, x, y, 1, 0);
	    const GenSeq *rseq = y->sequence();
	    if (rseq != NULL) return new BinOpSeq(this, x, y, 1, 1);
	}
	RaiseDomainError(NULL);
    }
    if (yn == NULL) {
#if 0
	if (y == Missing) return Missing;
#endif
	const GenSeq *rseq = y->sequence();
	if (rseq != NULL) return new BinOpSeq(this, x, y, 0, 1);
    }
    RaiseDomainError(NULL);
    return NULL;
}

Root * BinOp::postfix(Root *arg)
{
    ArgDesc args(&arg, NULL, NULL, NULL, 1, 0, 0);
    return DoCurry(this, args);
}

Root * BinOp::prefix(Root *arg)
{
    ArgDesc args(NULL, &arg, NULL, NULL, 0, 1, 0);
    return DoCurry(this, args);
}

const Root *BinOp::rightIdentity() const { return NULL; }

void BinOp::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  if (args.nCount > 0) RaiseDomainError(0);
  Root *leftSum;
  if (args.lCount == 0)
    {
      if (args.rCount == 0)
	{
	  dstType->coerceFromRoot(dst, this);
	  return;
	}
      leftSum = prefix(args.rArgs[0]);
    }
  else
    {
      long count = args.lCount;
      leftSum = args.lArgs[--count];
      for (; --count >= 0; )
	leftSum = infix(args.lArgs[count], leftSum);
      if (args.rCount == 0)
	{
	  dstType->coerceFromRoot(dst, postfix(leftSum));
	  return;
	}
      leftSum = infix(leftSum, args.rArgs[0]);
    }
  if (args.rCount + args.nCount == 1)
    {
      dstType->coerceFromRoot(dst, leftSum);
      return;
    }
  ArgDesc xargs(args, args.lCount, 1);
  leftSum->xapply(dst, dstType, xargs);
}

Functional * BinOp::reduce() const
{
#if 1
    abort();
#else
    return new ReducedOp(this);
#endif
}

void BinOp::printon(ostream& outs) const {outs << " operator$" << name << " ";}

void Reduction::printon(ostream& outs) const
{ 
    if (!left_to_right)
	outs << '@';
    outs << *func;
    if (left_to_right)
	outs << '@';
}

// Recursive helper routine when doing right-to-left reduction.
static void ReductionStep(StackIterator& it, Functional* func, ArgDesc& args)
{
    Root* current = it.next();
    if (current == Missing)
	return;
    ReductionStep(it, func, args); // Reduce rest of sequence
//    total = current func total;
    if (args.rArgs[0] == NULL) {
	args.rArgs[0] = current;
    }
    else {
	args.lArgs[0] = current;
	args.rArgs[0] = func->apply(args);
    }
}

void Reduction::xapply(void *dst, Type* dstType, ArgDesc& args)
{
  Root *total, *current;
  if (args.empty())
    total = this;
  else
    {
      ArgDesc func_args;
      func_args.lCount = 1;
      func_args.rCount = 1;
      func_args.nCount = 0;
      if (!left_to_right)
	{
	  func_args.lArgs = &current;
	  func_args.rArgs = &total;
	  if (args.rCount > 1 || args.lCount != 1)
	    Signal(new UnimplementedOp("Reduction"));
	  GenSeq *seq = args.lArgs[0]->sequence();
	  if (seq == 0)
	    Signal(new GenericCondition("Right operand to reduction is not a sequence."));
	  ITERATOR(it, seq);
	  total = args.rCount ? args.rArgs[0] : NULL;
	  ReductionStep(it, func, func_args);
	  if (total == NULL)
	    Signal(new GenericCondition("Reduction over empty sequence."));
	}
      else
	{
	  func_args.lArgs = &total;
	  func_args.rArgs = &current;
	  if (args.lCount >1 || args.rCount != 1 || !left_to_right)
	    Signal(new UnimplementedOp("Reduction"));

	  GenSeq *seq = args.rArgs[0]->sequence();
	  if (seq == 0)
	    Signal(new GenericCondition("Right operand to reduction is not a sequence."));
	  ITERATOR(it, seq);
	  total = args.lCount ? args.lArgs[0] : NULL;
	  if (!total)
	    total = it.next();
	  if (total == NULL || total == Missing)
	    Signal(new GenericCondition("Reduction over empty sequence."));
	  for (;;)
	    {
	      current = it.next();
	      if (current == Missing)
		break;
	      total = func->apply(func_args);
	    }
	}
    }
  dstType->coerceFromRoot(dst, total);
}

#if 0
void ReducedOp::printon(ostream& outs) const { outs << '@' << baseOp;}

Root * ReducedOp::infix(Root *larg, Root *rarg)
{
    GenSeq *lseq = larg->sequence();
    if (lseq == 0) RaiseDomainError(0);
    Root *result = rarg;
#if 1
    for (long count = lseq->length(); --count >= 0; ) {
	Root *el = lseq->index(count);
	result = result ? baseOp->infix(el, result) : el;
	if (result == NULL) RaiseDomainError(0);
    }
#else
    ITERATOR(it, *lseq);
//    if (file == 0) RaiseDomainError(0);
    for (;;) {
	Root *el = it.next();
	if (el == Missing) break;
	result = baseOp->infix(el, result);
    }
#endif
    if (result == NULL)
	result = (Root*)baseOp->rightIdentity();
    return result;
}

Root * ReducedOp::postfix(Root *larg)
{
    return infix(larg, NULL);
}

const Root *ReducedOp::rightIdentity() const {return baseOp->rightIdentity();}
#endif

void InverseOp::printon(ostream& outs) const
{
    outs << '~' << *base;
}

void InverseOp::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  Root* result;
  if (args.empty())
    result = this;
  else
    result = new InverseVariable(base, args);
  dstType->coerceFromRoot(dst, result);
}

Root* DoPlus(Numeric* x, Numeric* y)
{
#if 1
    return (Root*)x->add(*y);
#else
    const Numeric *xn = x->numeric();
    const Numeric *yn = y->numeric();
    if (xn != NULL && yn != NULL)
	return (Root*)xn->add(*yn);
    LVariable *xv = x->lvariable();
    LVariable *yv = y->lvariable();
    if (xv)
	if (yn) return new Sum(yn, 1, xv);
	else if (yv) return new Sum(Zero, 2, xv, yv);
    if (yv)
	if (xn) return new Sum(xn, 1, yv);
    return NULL;
#endif
}

Root *PlusOp::doit(Root *x, Root *y) const
{
    Numeric *xn = (Numeric*)x->numeric();
    Numeric *yn = (Numeric*)y->numeric();
    return DoPlus(xn, yn);
}
Root *PlusOp::prefix(Root *arg)
{
    return arg;
}
const Root *PlusOp::rightIdentity() const { return Zero; }

Root *DoMinus(Numeric* x, Numeric* y)
{
  if (x == NULL)
    return (Root*)&y->neg();
  else
    return (Root*)x->sub(*y);
}

Root *TimesOp::doit(Root *x, Root *y) const
{
    const Numeric *xn = x->numeric();
    const Numeric *yn = y->numeric();
    if (xn != NULL && yn != NULL)
	return (Root*)xn->mul(*yn);
    LVariable *xv = x->lvariable();
    LVariable *yv = y->lvariable();
    if (xv)
	if (yn) return new Product(yn, 1, xv);
	else if (yv) return new Product(MakeFixInt(1), 2, xv, yv);
    if (yv)
	if (xn) return new Product(xn, 1, yv);
    return NULL;
}

const Root *TimesOp::rightIdentity() const { return One; }

Root *DoTimes(Numeric* x, Numeric* y)
{
    return (Root*)x->mul(*y);
}

Root *DoDivide(Numeric* x, Numeric* y)
{
    return (Root*)x->div(*y);
}

#if 0
Root *RemainderOp::doit(Root *x, Root *y) const
{
    const Real *xr = ConvertReal(x);
    const Real *yr = ConvertReal(y);
    if (xr == NULL || yr == NULL) return NULL;
    const Real* remainder;
    div(*xr, *yr, mode, NULL, &remainder);
    return remainder;
}
#endif

Root *Selector::get_it(Root* collection)
{
    Signal(new UnimplementedOp("Selector::get_it", isA()));
}

Root *Selector::set_it(Root* collection, Root *new_value)
{
    Signal(new UnimplementedOp("Selector::set_it", isA()));
}

void Selector::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  if (args.lCount == 0)
    {
#if 1
      if (args.rCount+args.nCount == 0)
	dstType->coerceFromRoot(dst, this);
      else RaiseDomainError(NULL);
#else
      return DoCurry(this, args);
#endif
    }
  else
    ApplyRest(dst, dstType, get_it(args.lArgs[args.lCount-1]), args, 1, 0);
}

Root *ByteSpec::get_it(Root *collection)
{
    const Integer *i = (const Integer*)ConvertInteger(collection);
    if (i == NULL)
	RaiseDomainError(NULL);
    return &i->byte(size(), position());
}

Root *ByteSpec::set_it(Root *collection, Root *new_value)
{
    const Integer *i = (const Integer*)ConvertInteger(collection);
    const Integer *new_i = (const Integer*)ConvertInteger(new_value);
    if (i == NULL || new_i == NULL)
	RaiseDomainError(NULL);
    return &i->deposit_byte(*new_i, size(), position(), 0);
}

void ByteSpec::printon(ostream& outs) const
{
    if (print_lisp)
	outs << "#.(byte " << size() << " " << position() <<")";
    else
	outs << "byte " << size() << " " << position();
}


Root* DoByteOp(int l, int p)
{
    return new ByteSpec(l, p);
}

Root* DoByteOp(Integer* len, Integer* pos) /* TEMPORARY; for lisp-prims.lisp */
{
    long p, l;
    if (!pos->getlong(&p) || !len->getlong(&l)) RaiseDomainError(NULL);
    return new ByteSpec(l, p);
}

Root *DoGCD(Integer *n1, Integer *n2)
{
    return (Root*)n1->gcd(*n2);
}

#if 0
Root *GcdOp::doit(Root *arg1, Root *arg2) const
{
    const Integer *n1 = ConvertInteger(arg1);
    const Integer *n2 = ConvertInteger(arg2);
    if (n1 == NULL || n2 == NULL) return NULL;
    return (Root*)n1->gcd(*n2);
}

const Root *GcdOp::rightIdentity() const { return Zero; }
Functional *GcdOp::reduce() const { return &ReducedGCD; }

ReducedGcdOp::ReducedGcdOp(BinOp *base) : ReducedOp(base) { }
Root * ReducedGcdOp::postfix(Root *arg)
{
    const GenSeq *lseq = arg->sequence();
    if (lseq == 0) RaiseDomainError(0);
    ITERATOR(stream, lseq);
    Root *result = stream.next();
    if (result == Missing) return (Root*)Zero;
    for (int i = 1; ; i++) {
	Root *el = stream.next();
	if (el == Missing) {
	    if (i == 1) {
		// More efficient would be e.g. result = result->abs()
		result = GCD.infix(result, result);
	    }
	    break;
	}
	result = GCD.infix(el, result);
    }
    return result;
}
#endif


Root * DoTake(Root *arg1, Numeric *num2)
{
    GenSeq *seq1 = arg1->sequence();
    long count;
    if (num2 == NULL) RaiseDomainError(NULL);
    if (seq1 == NULL) {
	const Numeric* num1 = arg1->numeric();
	if (num1) {
	    long lower;
	    if (num1->getlong(&lower) && lower >= 0) {
		if (num2 == &PosInfinity)
		    return new Range(lower, 1, InfiniteLength);
		if (!num2->getlong(&count) || count < 0)
		    RaiseDomainError(NULL);
		return new Range(lower, 1, count);
	    }
	    GenRange* r = new GenRange(num1, 1);
	    if (num2 == &PosInfinity) return r;
	    if (!num2->getlong(&count) || count < 0) RaiseDomainError(NULL);
	    r->len = count;
	    return r;
	}
	RaiseDomainError(NULL);
    }
    if (num2 == &PosInfinity) return seq1;
    if (!num2->getlong(&count)) RaiseDomainError(NULL);
    if (count < 0)
	return seq1->subseq(seq1->length()+count, -1);
    return seq1->subseq(0, count);
}

Root*
DoDrop(Root *arg1, Numeric *num2)
{
    GenSeq *seq1 = arg1->sequence();
    if (seq1 == NULL) RaiseDomainError(NULL);
    if (num2 == &PosInfinity) return &NullSequence;
    long count;
    if (!num2->getlong(&count)) RaiseDomainError(NULL);
    if (count < 0) {
	size_t len = seq1->length();
	return seq1->subseq(0, len+count);
    }
    return seq1->subseq(count, -1);
}

Root *
DoSize(Root *val)
{
    GenMap *m = val->mapping();
    if (m == NULL) RaiseDomainError(0);
    size_t len = m->length();
    if (len == InfiniteLength)
	return &PosInfinity;
    if ((long)len < 0) RaiseDomainError(NULL);
    return MakeFixInt(len);
}

Root *
DoFiniteLength(Root *val)
{
    GenSeq *q = val->sequence();
    if (q == NULL) RaiseDomainError(0);
    size_t len = q->finite_length();
    if (len == InfiniteLength)
	return &PosInfinity;
    if ((long)len < 0) RaiseDomainError(NULL);
    return MakeFixInt(len);
}

Root *
DoCycleLength(Root *val)
{
    GenSeq *q = val->sequence();
    if (q == NULL) RaiseDomainError(0);
    size_t len = q->cycle_length();
    if (len == InfiniteLength)
	return &PosInfinity;
    if ((long)len < 0) RaiseDomainError(NULL);
    return MakeFixInt(len);
}

Root *
DoFinitePart(Root *val)
{
    GenSeq *q = val->sequence();
    if (q == NULL) RaiseDomainError(0);
    size_t len = q->finite_length();
    if (len == InfiniteLength)
      return q;
    return q->subseq(0, len);
}

Root *
DoCyclePart(Root *val)
{
    GenSeq *q = val->sequence();
    if (q == NULL) RaiseDomainError(0);
    size_t clen = q->cycle_length();
    if (clen == 0)
      return &NullSequence;
    size_t flen = q->finite_length();
    if (flen == InfiniteLength)
      return &NullSequence;
    return q->subseq(flen, flen + clen);
}

Root *
DoReshape(Root *arg1, Root *arg2)
{
    int i;
    GenSeq *lengths = arg2->sequence();
    int rank = lengths != NULL ? lengths->length() : 1;
    DimInfo dims[rank];
    if (lengths != NULL) {
	for (i = 0; i < rank; i++) {
	    Root *v = lengths->index(i);
	    const Numeric *n = v->numeric();
	    if (n == NULL || !n->getlong((long*)&dims[i].length))
		 RaiseDomainError(0);
	}
    }
    else {
	const Numeric *n = arg2->numeric();
	if (n == NULL || !n->getlong((long*)&i))
	     RaiseDomainError(0);
	dims[0].length = i;
    }
    size_t size = CalculateSize(rank, dims);
    Vector *base = NewVector(size);
    Root **ptr = base->start_addr();
    Root **lim = ptr+size;
    GenSeq *seq = arg1->sequence();
    if (seq == NULL) seq = new ConstSeq(arg1);
    ITERATOR(f, seq);
    while (ptr < lim) {
	Root *v = f.next();
	if (v == Missing) {
	    f.reset();
	    v = f.next();
	    if (v == Missing) RaiseDomainError(0);
	}
	*ptr++ = v;
    }
    if (rank == 1)
	return base;
    return MArray::New(rank, base, 0, dims);
}

static Root *
DoDecode(Root *arg1, Root *arg2, int bigendian)
{
    GenSeq *coefficients = arg1->sequence();
    if (coefficients == NULL) RaiseDomainError(NULL);
    GenSeq *factors = arg2->sequence();
    const Root *factor = NULL;
    if (factors == NULL) {
	factor = arg2->numeric();
	if (factor == NULL) RaiseDomainError(NULL);
    }
    int len = coefficients->length();
    int i;
    const Root *result = Zero;
    for (i = 0; i < len; i++) {
	int index = bigendian ? i : len - i - 1;
	if (factors) {
	    factor = factors->index(index);
	    if (factor == Missing) factor = Zero;
	}
	result = Plus(Times(result, factor), coefficients->index(index));
    }
    return (Root*)result;
}

Root * DoDecode0(Root *arg1, Root *arg2) { return DoDecode(arg1, arg2, 0); }
Root * DoDecode1(Root *arg1, Root *arg2) { return DoDecode(arg1, arg2, 1); }

Root* DoCons(Root *arg1, Root *arg2)
{
#if 1
    return new AList(arg1, arg2);
#else
    const GenSeq *rest = arg2->sequence();
    if (rest == NULL) RaiseDomainError(NULL);
    return new AList(arg1, rest);
#endif
}

Root* DoMapTo(Root *arg1, Root *arg2)
{
    return new Binding(arg1, arg2);
}

void Binding::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  if (args.lCount == 0)
    {
#if 1
      if (args.rCount+args.nCount == 0)
	dstType->coerceFromRoot(dst, this);
      else RaiseDomainError(NULL);
#else
      dstType->coerceFromRoot(dst, DoCurry(this, args));
#endif
    }
  else
    {
      Root *larg = args.lArgs[args.lCount-1];
      Selector *select_key = PTR_CAST(Selector, key());
      if (!select_key)
	Signal(new UnimplementedOp("Binding::xapply"));
      ApplyRest(dst, dstType, select_key->set_it(larg, val()), args, 1, 0);
    }
}

void Binding::printon(ostream& outs) const
{
    outs << *key() << "->" << *val();
}

#if 0
Root * ConsOp::postfix(Root *arg)
{
    return new AList(arg, &NullSequence);
}

Functional *ConsOp::reduce() const { return &Concatenate; }
#endif

#if 0
Root * ConcatOp::postfix(Root *larg)
{
    // actually result == larg, but with each element forced
    return infix(larg, &NullSequence);
}
#endif

Root * IotaOp::doit(Root *arg1, Root *arg2) const
{
    const Numeric *num1 = arg1->numeric();
    const Numeric *num2 = arg2->numeric();
#if 1
    long len;
    if (num1 && num2) {
	GenRange *r = new GenRange(num1, 1);
	if ((RationalInfinity*)num2 == &PosInfinity)
	    return r;
	if (num2->getlong(&len)) {
	    r->len = len;
	    return r;
	}
    }
#else
    long i0, len;
    if (num1 && num2 && num1->getlong(&i0)) {
	if ((RationalInfinity*)num2 == &PosInfinity)
	    return new Range((int)i0);
	if (num2->getlong(&len)) return new Range((int)i0, (unsigned)len);
    }
#endif
    return NULL;
}

Root * IotaOp::postfix(Root *arg)
{ return infix(arg, (Root*)&PosInfinity); }

Root * DoLessThan(Root *arg1, Root *arg2)
{
    if (arg1->compare(*arg2) < 0) return &NullSequence;
    Signal(new CompareFail("<", arg1, arg2));
    return NULL;
}

Root * DoGreaterThan(Root *arg1, Root *arg2)
{
    if (arg1->compare(*arg2) > 0) return &NullSequence;
    Signal(new CompareFail(">", arg1, arg2));
    return NULL;
}
Root * DoLessEqual(Root *arg1, Root *arg2)
{
    if (arg1->compare(*arg2) <= 0) return &NullSequence;
    Signal(new CompareFail("<=", arg1, arg2));
    return NULL;
}

Root * DoGreaterEqual(Root *arg1, Root *arg2)
{
    if (arg1->compare(*arg2) >= 0) return &NullSequence;
    Signal(new CompareFail(">=", arg1, arg2));
    return NULL;
}

Root * DoNotEquals(Root *arg1, Root *arg2)
{
    if (arg1->compare(*arg2) != 0) return &NullSequence;
    Signal(new CompareFail("<>", arg1, arg2));
    return NULL;
}

Root * DoEquals(Root *arg1, Root *arg2)
{
    arg1->unify(*arg2);
    return &NullSequence;
}

BoolOp * (BoolOpTable[16]) = {
    &BitClr,    &BitAnd,    &BitAndC2,	 &Bit1,
    &BitAndC1,  &Bit2,      &BitXor,     &BitIor,
    &BitNor,    &BitEqv,    &BitC2,      &BitOrC2,
    &BitC1,     &BitOrC1,   &BitNand,    &BitSet,
};

Root * BitOp::prefix(Root *arg)
{
    const Numeric *num = arg->numeric();
    long code;
    if (num == NULL || !num->getlong(&code) || (unsigned)code > 16) {
	if (arg->magic() == SymbolKind) {
	    Symbol *sym = (Symbol*)arg;
	    const struct bool_name *b_name =
		bool_name_hash(sym->string(), sym->Length());
	    if (b_name) return BoolOpTable[b_name->number];
	}
	RaiseDomainError(NULL);
    }
    return BoolOpTable[code];
}

void BoolOp::printon(ostream& outs) const
{
    outs << "bit'" << name;
}

Root *BoolOp::doit(Root*arg1, Root *arg2) const
{
    const Integer *n1 = ConvertInteger(arg1);
    const Integer *n2 = ConvertInteger(arg2);
    if (n1 == NULL || n2 == NULL) return NULL;
    return (Root*)&n1->boolean(*n2, op);
}

Root * DoClass(Root *arg) { return (Root*)arg->isA(); }

Root *UnionOp::infix(Root *arg1, Root* arg2)
{
    UnionType *utype = new UnionType;
    utype->count = 2;
    utype->members = (Root**)malloc(sizeof(Root*) * utype->count);
    utype->members[0] = arg1;
    utype->members[1] = arg2;
    return utype;
}

Root *DoBy(Root *arg1, Root* arg2)
{
    const Functional *fun = arg2->functional();
    if (fun == NULL) {
	const Numeric *num = arg2->numeric();
	long code;
	if (num == NULL || !num->getlong(&code))
	    RaiseDomainError(NULL);
	return new GenRange(arg1, code);
    }
    return new Recurrence(arg1, fun);
}

void AssignOp::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  if (args.rCount > 1 || args.lCount > 1 || args.nCount > 0)
    RaiseDomainError(0);
  Root* result;
  if (args.lCount == 0)
    result = DoCurry(this, args);
  else if (args.rCount == 1)
    {
      Assign(args.lArgs[0], args.rArgs[0]);
      result = &NullSequence;
    }
  else
    {
      Functional* farg = (Functional*)args.lArgs[0]->functional();
      if (farg)
	result = new UpdatingFunction(farg);
      else
	result = DoCurry(this, args);
    }
  dstType->coerceFromRoot(dst, result);
}

Root* DoNewBuffer()
{
  return new TextBuffer();
}

Root *DoValue(Root*arg) { return (Root*)Dereference(arg); }

Root *DoFile(Root *arg)
{
    char *file_name;
    VString(arg, &file_name, NULL);
    return new FileNode(file_name);
}

Root *DoOpen(Root *arg)
{
    GenMap *map = arg->mapping();
    if (map == NULL) RaiseDomainError(NULL);
    return map->open((OpenFlags)0);
}

Root *DoGet1(Root *arg)
{
    GenFile *file = arg != NULL ? Coerce2GenFile(arg) : DEFAULT_IN_FILE;
    if (file == NULL) RaiseDomainError(NULL);
    return file->next();
}

Root *DoGetN(Root *arg1, Root *arg2)
{
    if (arg2 == NULL)
	return DoGet1(arg1);
    GenFile *file = arg1 != NULL ? Coerce2GenFile(arg1) : DEFAULT_IN_FILE;
    const Numeric *ncount = arg2->numeric();
    long icount;
    size_t scount;
    if (file == NULL || ncount == NULL) RaiseDomainError(NULL);
    if (ncount == &PosInfinity) scount = InfiniteLength;
    else if (ncount->getlong(&icount)) scount = icount;
    else RaiseDomainError(NULL);
    return file->get(scount);
}

Root *DoFilePeek(Root *arg)
{
    GenFile *file = arg != NULL ? Coerce2GenFile(arg) : DEFAULT_IN_FILE;
    if (file == NULL) RaiseDomainError(NULL);
    return file->peek_next();
}

Root* DoFlush(Root* arg1)
{
    if (arg1 == NULL) arg1 = DEFAULT_OUT_FILE;
    CharFile *file = Coerce2CharFile(arg1);
    file->rdbuf()->sync();
    return &NullSequence;
}

#if 0
Root *SeekOp::infix(Root *arg1, Root *arg2)
{
    GenFile *file = arg1->file();
    if (file == NULL) RaiseDomainError(NULL);
    if (whence == 0)
	if (file->seek(arg2) < 0) RaiseDomainError(NULL);
	else return &NullSequence;    
    Numeric *ncount = arg2->numeric();
    long icount;
    if (ncount == NULL || !ncount->getlong(&icount)) RaiseDomainError(NULL);
    if (file->seek(icount, whence) < 0) RaiseDomainError(NULL);
    return &NullSequence;
}
#endif

Root *DoSeek(Root *arg, Integer *offset)
{
    GenFile *file = Coerce2GenFile(arg);
    if (offset->big_len() != 1 || file->seek(offset->S[0], 0) < 0)
	Signal(new GenericCondition("Bad seek."));
    return &NullSequence;
}

Root *DoSeekEnd(Root *arg, Integer *offset)
{
    GenFile *file = Coerce2GenFile(arg);
    if (offset->big_len() != 1 || file->seek(offset->S[0], 2) < 0)
	Signal(new GenericCondition("Bad seek."));
    return &NullSequence;
}

Root *DoSeekRel(Root *arg, Integer *offset)
{
    GenFile *file = Coerce2GenFile(arg);
    if (offset->big_len() != 1 || file->seek(offset->S[0], 1) < 0)
	Signal(new GenericCondition("Bad seek."));
    return &NullSequence;
}

Root *DoFilePos(Root *arg)
{
    GenFile *file = Coerce2GenFile(arg);
    int pos = file->seek(0, 1);
    if (pos < 0)
	Signal(new GenericCondition("Bad pos."));
    return (Root*)MakeFixInt(pos);
}

Root* DoClose(Root* arg)
{
    GenFile *file = Coerce2GenFile(arg);
    file->close();
    return &NullSequence;
}

Root* DoNewVar()
{
  return new SimpleAssignable(Missing);
}

void ShiftAssignOp::printon(ostream& outs) const
{
    outs << ":=>";
}

void ShiftAssignOp::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  if (args.lCount > 1 || args.nCount > 0 || args.rCount <= 0)
    RaiseDomainError(NULL);
  dstType->coerceFromRoot(dst,
			  ShiftAssign(args.lCount ? args.lArgs[0] : NULL,
				      args.rArgs, args.rCount));
}

Root * MakeCharSet(Root *arg)
{
    const StringC *str = Coerce2String(arg);
    Charset *cs = new Charset;
    cs->add(str->chars(), str->leng());
    return cs;
}

Root *AllocLogicalOp::prefix(Root *) { return AllocVariable(NULL); }

PlusOp Plus ("+");
TimesOp Times ("*");
//ConcatOp Concatenate(&Cons);
IotaOp Iota("..");

BitOp Bit("bit");
BoolOp BitClr("clr", 0);
BoolOp BitAnd("and", 1);
BoolOp BitAndC2("andc2", 2);
BoolOp Bit1("1", 3);
BoolOp BitAndC1("andc1", 4);
BoolOp Bit2("2", 5);
BoolOp BitXor("xor", 6);
BoolOp BitIor("ior", 7);
BoolOp BitNor("nor", 8);
BoolOp BitEqv("eqv", 9);
BoolOp BitC2("c2", 10);
BoolOp BitOrC2("orc2", 11);
BoolOp BitC1("c1", 12);
BoolOp BitOrC1("orc1", 13);
BoolOp BitNand("nand", 14);
BoolOp BitSet("set", 15);

ShiftAssignOp ShiftAssignTo;
UnionOp Union("||");
AssignOp AssignTo(":=");
//ClassOp ClassCmd("class");
//ValueOp ValueCmd("value");
AllocLogicalOp AllocLogicalCmd;
//RemainderOp ModCmd("mod", FloorMode);
//RemainderOp RemCmd("rem", TruncateMode);
//RealToIntOp FloorCmd("floor", FloorMode);
//RealToIntOp CeilingCmd("ceiling", CeilingMode);
//RealToIntOp TruncateCmd("truncate", TruncateMode);
//RealToIntOp RoundCmd("round", RoundMode);

//HashTable *SpecialVars = NULL;
void InsertSpecial(Symbol& name, const Root& value)
{
    if (name._package == &CLispPackage)
	name.sym_function((Root*)&value);
    else
	name.set_value((Root*)&value);
}

#if 0
Root *SearchSpecial(Symbol * name)
{
    return Search(SpecialVars, name);
}
#endif

// Insert builtins into symbol table.

INSERT_BUILTIN(Infinity, PosInfinity);
INSERT_BUILTIN(bit, Bit);

Root* SingleOp(Vector *args)
{
    int count = args->leng();
    Root** vals = args->start_addr();
    if (count == 0)
	return &NilSymbol;
    else
	return vals[0];
}

Root *DoGCollect()
{
#ifdef DO_GC
  GC_gcollect();
#else
  cerr << "(Garbage collection is not supported)\n";
#endif
  return &NullSequence;
}
