/* -*- C++ -*- code; generic definitions and stuff.
   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.  */

#pragma implementation
/*#include "newtype.h"*/
#include "gvars.h"
#include "genmap.h"
#if 0 /*def __GNU_LIBRARY__*/
EXTERN_C
#include <stdlib.h>
#include <bstring.h>
extern void exit(int);
END_EXTERN_C
#else
#include <std.h>
#endif
#include <strstream.h>
#include "gkinds.h"
#include "gfunc.h"
#include "gennum.h"
#include "genfiles.h"
#include "exceptions.h"
#include <stdarg.h>
#include "gcompile.h"
#include "modules.h"
#include "gfiles.h"
#include <ifthenelse.h>
#include "shell.h"
#include "tempbuf.h"
#include "evalprocs.h"
//#include "hash.h"
#include "parsefile.h"

extern void PrintResult(Root* val, ostream& outs);

void Root::printon(ostream& outs) const
{
    outs.form("<0x%X>", this);
}

const StringC * Root::asString(int format=0) const
{
    ostrstream dest;
    long save_print_lisp = print_lisp;
    long save_print_readable = print_readable;
    print_lisp = 0;
    print_readable = 0;
    dest << *this;
    print_lisp = save_print_lisp;
    print_readable = save_print_readable;
    StringC *str = NewString(dest.pcount(), dest.str());
    dest.freeze(0);
    return str;
}

#if 0
void Root::printon(FILE *file) const
{
    ostream outs(file);
    printon(outs);
}
#endif

#if 0
ostream& operator<<(ostream& stream, Root *arg)
{
    arg->printon(stream);
    return stream;
}
#endif

ostream& operator<<(ostream& stream, const Root& arg)
{
    arg.printon(stream);
    return stream;
}

#if 0
ostream& operator<<(ostream& stream, Root& arg) // OBSOLETE after re-compile!
{
    arg.printon(stream);
    return stream;
}
#endif

Root**CopyArray(Root **vals, int count)
{
    Root **tmp;
    if (count == 0) return NULL;
    tmp = (Root**)malloc(count * sizeof(Root*));
    bcopy(vals, tmp, count * sizeof(Root*));
    return tmp;
}

void ArgDesc::copy_to(ArgDesc& copied_args)
{
    copied_args.lCount = lCount;
    copied_args.lArgs = CopyArray(lArgs, lCount);
    copied_args.rArgs = CopyArray(rArgs, rCount);
    copied_args.nArgs = CopyArray(nArgs, nCount);
    copied_args.rCount = rCount;
    copied_args.nCount = nCount;
    if (nCount == 0) copied_args.names = NULL;
    else {
	copied_args.names = (Symbol**)malloc(nCount * sizeof(Symbol*));
	bcopy(names, copied_args.names, nCount*sizeof(Symbol*));
    }
}

int Root::hash() const { return -1; }
Root* Root::value() { return this; }
void Root::update() { }
void Root::assign(Root *new_value) { RaiseDomainError(0); }
long Root::magic() const { return 0; }

Numeric * Root::numeric() { return NULL; }
Assignable * Root::assignable() const { return NULL; }
LVariable * Root::lvariable() { return NULL; }
GenMap * Root::mapping() { return NULL; }
GenSeq * Root::sequence() const { return NULL; }
Functional * Root::functional() { return NULL; }

void Root::dumpPtr(CFile *cf) const
{
    cerr << "Tried to compile value with no dumpPtr method: ";
    printon(cerr);
    cerr << '\n';

    cf->asm_stream() << "<<??>>";
}

extern "C" int encode_label_for_string_max(const StringC* sym);
void StringCDumpProc(struct PrevDumped *dump, CFile *cf)
{
    StringC *str = (StringC*)dump->addr();
    char string_label[20];
    cf->generate_label(string_label);
    
    cf->asm_stream() << "char " << string_label << "[] = ";
    PrintQuotedString(str->chars(), str->leng(), cf->asm_stream());
    cf->asm_stream() << ";\n";
    cf->asm_stream() << "StringC " << dump->name() << "(" << string_label
	<< ", " << str->leng() << ");\n";
}

void StringC::dumpPtr(CFile *cf) const
{
#if 1
    struct PrevDumped *dump = NewPendingDump(cf, this, &StringCDumpProc, 0);
    cf->aux_stream() << "extern StringC " << dump->name() << ";\n";
    cf->asm_stream() << "&" << dump->name();
#else
    char buf[encode_label_for_string_max(this)];
    int sym_no = cf->generate_label_number();
    encode_string_to_label(chars(), leng(), buf);
    cf->aux_stream() << "extern StringC __str" << sym_no
	<< " asm(\"_$ST" << buf << "\");\n";
    cf->asm_stream() << "&__str" << sym_no;
#endif
}

ArgDesc EmptyArgDesc((Root**)0, (Root**)0, (Root**)0, (Symbol**)0, 0, 0, 0);

//static const Expr * EndExLList = EndExL;
//static const struct ExList EmptyExList = { (Expr_Ptr*)&EndExLList, NULL };

Root * Root::apply_empty()
{
    return apply(EmptyArgDesc);
//    return apply(&NullSequence, EmptyExList);
}

void Root::coerceTo(void * dstAddr, Type *dstType)
{
    isA()->coerceTo(dstAddr, this, dstType);
}

struct Type *Root::typedesc() const { return ((struct Type**)this)[-1]; }

void Root::xapply(void *dst, Type *dstType, ArgDesc& args)
{
  Root *val = value();
  if (val != this && val != NULL)
    val->xapply(dst, dstType, args);
  else
    {
      if (args.rCount == 0)
	{
	  if (args.lCount + args.nCount > 0)
	    RaiseDomainError(NULL);
	  dstType->coerceFromRoot(dst, (Root*)this);
	  return;
	}
      const Root ** lBuf = (const Root**)alloca((args.lCount+1) * sizeof(Root*));
      for (int i = args.lCount; --i >= 0; ) lBuf[i] = args.lArgs[i];
      lBuf[args.lCount] = this;
      ArgDesc xargs(lBuf, args.rArgs + 1, args.nArgs, args.names,
		    args.lCount + 1, args.rCount - 1, args.nCount);
      args.rArgs[0]->xapply(dst, dstType, xargs);
    }
}

//struct ClassDesc * Root::classdesc() { return typedesc()->desc; }

int Root::compare(const Root& other) const
{ RaiseDomainError(NULL); return 0; }

void Root::unify(Root& other)
{
    if (this == &other) return;
    LVariable *var = other.lvariable();
    if (var != NULL) var->unify(*this);
    else if (compare(other))
	Signal(new CompareFail("=", this, &other));
}

void Character::printon(ostream& outs) const
{
    char buf [8];
    int c = ustring()[0];
    if (!print_readable)
	outs << (char)c;
    else if (print_lisp) {
	extern void LispPrintCharacter(ostream& outs, int c);
	LispPrintCharacter(outs, c);
    }
    else {
	PrintQuotedString(string(), 1, outs);
	outs << "@";
    }
}

EXTERN RootPtr AddAtom(Symbol * name, struct Module *module);
RootPtr AddAtom(Symbol * name, struct Module *module)
{
    Atom *atom = new Atom(name);
    if (module) {
	struct Declaration *decl = Symbol2Declaration(name);
	decl->set_value(atom);
	AddDeclaration(module->block, decl);
    }
    return atom;
}

void Atom::printon(ostream& outs) const
{
    outs << name;
}

void MissingValue::printon(ostream& outs) const
{
    outs << "NONE";
}

void MissingValue::xapply(void* dst, Type* dstType, ArgDesc&)
{
  dstType->coerceFromRoot(dst, this);
}

MissingValue __Missing__(0);

long Functional::magic() const { return FunctionKind; }

Root *Functional::infix(Root *arg1, Root *arg2)
{
    
    return apply(&arg1, &arg1, NULL, NULL, 1, 1, 0);
}

Root *Functional::prefix(Root *arg)
{
    return apply(NULL, &arg, NULL, NULL, 0, 1, 0);
}

Root *Functional::postfix(Root *arg)
{
    return apply(&arg, NULL, NULL, NULL, 1, 0, 0);
}

Functional * Functional::inverse() const
{
  return new InverseOp((Functional*)this);
}
Functional * Functional::reduce() const { return 0; }

#if 0
long QFunction::magic() const { return QFunctionKind; }

void QFunction::printon(ostream& outs) const
{
    outs << name;
}
#endif

extern int glob_pattern_p (char *pattern);
extern StringList * glob_filename(char* );

int StrPtrCmp(StringC**str1, StringC **str2)
{
    return strcmp((*str1)->chars(), (*str2)->chars());
}

int FindParens(char *str,
	   int *start_index, // Offset of '('
	   int *end_index) // Offset of ')'
{
    register char *ptr = str;
    register ch = *ptr++;
    for (;; ) {
	if (ch == '\\') ptr++;
	else if (ch == '\0')
	    return 0;
	else if (ch == '(')
	    break;
	ch = *ptr++;
    }
    int paren_count = 1;
    int variants = 1;
    if (start_index)
	*start_index = (ptr - str) - 1;
    ch = *ptr++;
    for (;;) {
	if (ch == '\0') return -1;
	else if (ch == '\\') ptr++;
	else if (ch == ' ' || ch == '\t') {
	    while (ch == ' ' || ch == '\t') ch = *ptr++; // Skip extra spaces
	    variants++;
	}
	else if (ch == ')')
	    break;
	ch = *ptr++;
    }
    if (end_index)
	*end_index = (ptr - str) - 1;
    return variants;
}

#if 0
void QFunction::doit_print(Root *left, StringList *argv) const
{
    Root *val = doit(left, argv);
    if (val != &NullSequence)
	cout << *val<< '\n';
}

void Multiple::printon(ostream& outs) const
{
    Iterator it(*vals);
    for (int i = 0; ; i++) {
	Root *val = it.next();
	if (val == Missing) break;
	if (i > 0) outs << '|';
	val->printon(outs);
    }
}

void Multiple::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  GenSeq *result;
  GenSeq **ptr = &result;
  Iterator it(*vals);
  for (int i = 0; ; i++)
    {
      Root *val = it.next();
      if (val == Missing) break;
      AList *pair = new AList((Root*)val->apply(args), NULL);
      *ptr = pair;
      ptr = (GenSeq**)&pair->cdr;
    }
  *ptr = &NullSequence;
  dstType->coerceFromRoot(dst, new Multiple(result));
}

long Multiple::magic() const { return MultipleKind; }

Multiple2::Multiple2(Root *val1, Root *val2)
: Multiple(new AList(val1, new AList(val2, &NullSequence))) { }
#endif

TypeList::TypeList(const char* arg0, ...)
{
	va_list ap;
	unsigned nargs = 0;
	va_start(ap, arg0);
	do nargs++; while (va_arg(ap, Type*));
	va_end(ap);
	Type** p = clp = new Type*[nargs];
	va_start(ap, arg0);
	while (nargs--) *p++ = va_arg(ap, Type*);
	va_end(ap);
}

TypeList::TypeList(Type *class0, ...)
{
	va_list ap;
	unsigned nargs = 1;
	if (class0 != NULL) {
	    va_start(ap, class0);
	    do nargs++; while (va_arg(ap, Type*));
	    va_end(ap);
	}
	Type** p = clp = new Type*[nargs];
	*p++ = class0; nargs--;
	va_start(ap, class0);
	while (nargs--) *p++ = va_arg(ap, Type*);
	va_end(ap);
}

const char* RecordType::name() const
{ 
    if (class_name == NULL)
	return "UNNAMED_CLASS";
    return class_name->string();
}

bool Class::_isKindOf(const Class& clid) const
{
    if (this == &clid) return 1;
    for (const Class** bp = class_bases; *bp; )
	if ((*bp++)->_isKindOf(clid)) return 1;
    return 0;
}

//const Type* Root::desc() { return &Root::classDesc; }

Class * (__NullTypeList[1]) = { 0 };

void Type::printon(ostream& outs) const {outs <<"Type("<<(void*)this<<")";}
void RecordType::printon(ostream& outs) const
{
    outs.form("Type(%s)", class_name->string());
}
void PrimitiveType::printon(ostream& outs) const
{
    outs.form("Type(%s)", class_name->string());
}
void ReferenceType::printon(ostream& outs) const
{
    outs << "Ref(" << *base_class << ")";
}

void Type::xapply(void* dst, Type * dstType, ArgDesc& args)
{
  if (args.rCount+args.nCount > 0 || args.lCount > 1) RaiseDomainError(NULL);
  if (args.lCount == 0)
    {
      dstType->coerceFromRoot(dst, this);
      return;
    }
  if (expanded()) RaiseDomainError(NULL);
  Root* val = args.lArgs[0];
  if (_coerceTo == NULL)
    {
      cerr << "Don't know how to coerce to " << *this << "\n";
      RaiseDomainError(NULL);
    }
  (*_coerceTo)(&val, val, this, val->isA());
  dstType->coerceFromRoot (dst, val);
}

int Type::is_scalar() const
{
    if (options & TypeIsScalar)
	return 1;
    // FIXME: This is of course NOT the way to do it!
    if (this == &RefInteger) return 1;
    if (this == &RefReal) return 1;
    if (this == &RefNumeric) return 1;
    if (this == &RefNumeric) return 1;
    return 0;	
}

void Type::copy_object(void* dst, void* src)
{
    memmove(dst, src, inst_size);
}

#if 0
Use val_print()
void Type::print(const void *addr, FILE *file) const
{
    switch (kind) {
      case ReferenceTypeKind:
	((ReferenceType*)this)->base_class->print(*(void**)addr, file);
	break;
      case RecordTypeKind:
      case PrimitiveTypeKind:
	(*printFunction)(addr, file);
	break;
      default:
	fprintf(file, "???");
    }
}
#endif

#if 0
static void RootPrintFunction(const void *addr, FILE *file)
{
    ((Root*)addr)->printon(file);
}

static void _longPrintFunction(const void *addr, FILE *file)
{
    fprintf(file, "%d", *(long*)addr);
}
#endif

void DefaultCoerceTo(void *dst, const void *src,
	const Type * dstClass, const Type *srcClass)
{
#if 0
    if (srcClass != dstClass) {
	if (srcClass->class_bases[0] == NULL) RaiseDomainError(NULL);
	srcClass->class_bases[0]->coerceTo(dst, src, dstClass);
    }
#endif
    if (dstClass->expanded())
	bcopy(src, dst, dstClass->size());
    else *(void**)dst = (void*)src;
}

RecordType Root_classDesc(
    EnterSymbol("Root"),
     __NullTypeList,
    sizeof(Root), DefaultCoerceTo, TypeIsCompiled);

ReferenceType RefRoot(Root::desc());

const Class * (RootTypeList[2]) = { Root::desc(), 0 };

RecordType Type_classDesc(
    EnterSymbol("Type"),
    RootTypeList,
    sizeof(Type), DefaultCoerceTo, TypeIsCompiled);

PrimitiveType _double::classDesc(
    EnterSymbol("double"),
    sizeof(double), DefaultCoerceTo, TypeIsCompiled);

PrimIntType _long::classDesc("Long", "long", sizeof(long), 1);
#if 0
PrimIntType _ulong::classDesc("ULong","unsigned long",sizeof(unsigned long),0);
PrimIntType _uint::classDesc("UInt","unsigned int",sizeof(unsigned int),0);
#endif
PrimIntType _int::classDesc("Int","int",sizeof(int),1);

#define COERCE_FUNCTION DefaultCoerceTo

DEFINE_CLASS(Symbol,RootTypeList)
const Class * (__SymbolTypeList[2]) = { Symbol::desc(), 0 };
DEFINE_CLASS(Character,__SymbolTypeList)
DEFINE_CLASS(Functional,RootTypeList)
const Class * (__FunctionalTypeList[2]) = { Functional::desc(), 0 };
DEFINE_CLASS(GFunction,__FunctionalTypeList)
const Class * (__GFunctionTypeList[2]) = { GFunction::desc(), 0 };
//DEFINE_CLASS(QFunction,RootTypeList)
DEFINE_CLASS(MFunction,__GFunctionTypeList)
//const Class * (__QFunctionTypeList[2]) = { QFunction::desc(), 0 };
//DEFINE_CLASS(RunOp,__QFunctionTypeList)
DEFINE_CLASS(CharFile,RootTypeList)
DEFINE_CLASS(Selector,RootTypeList)
const Class * (__SelectorTypeList[2]) = { Selector::desc(), 0 };
DEFINE_CLASS(ByteSpec,__SelectorTypeList)

DEFINE_CLASS(GenMap,RootTypeList)
const Class * (__GenMapTypeList[2]) = { GenMap::desc(), 0 };
DEFINE_CLASS(Record,__GenMapTypeList)

DEFINE_CLASS(GenArray,__GenMapTypeList)
const Class * (__GenArrayTypeList[2]) = { GenArray::desc(), 0 };
DEFINE_CLASS(GenSeq,__GenArrayTypeList)
const Class * (__GenSeqTypeList[2]) = { GenSeq::desc(), 0 };
DEFINE_CLASS(Vector,__GenSeqTypeList)
DEFINE_CLASS(CharSeq,__GenSeqTypeList)
const Class * (__CharSeqTypeList[2]) = { CharSeq::desc(), 0 };
DEFINE_CLASS(StringC,__CharSeqTypeList)
DEFINE_CLASS(FileNode,__CharSeqTypeList)
DEFINE_CLASS(GenRecur,__GenSeqTypeList)
const Class * (__GenRecurTypeList[2]) = { GenRecur::desc(), 0 };
DEFINE_CLASS(Range,__GenRecurTypeList)
DEFINE_CLASS(AList,__GenSeqTypeList)
const Class * (__AListTypeList[2]) = { AList::desc(), 0 };
DEFINE_CLASS(ConsPair,__AListTypeList)
const Class * (__VectorTypeList[2]) = { Vector::desc(), 0 };
DEFINE_CLASS(VectorV,__VectorTypeList)
const Class * (__StringCTypeList[2]) = { StringC::desc(), 0 };
DEFINE_CLASS(StringV,__StringCTypeList)

DEFINE_CLASS(Numeric,RootTypeList)
const Class * (__NumericTypeList[2]) = { Numeric::desc(), 0 };
DEFINE_CLASS(Real,__NumericTypeList)
const Class * (__RealTypeList[2]) = { Real::desc(), 0 };
const Class * (__DoubleSuperList[3]) = {Real::desc(), /*_double::desc(),*/ 0 };
DEFINE_CLASS(Double,__DoubleSuperList)
DEFINE_CLASS(Rational,__RealTypeList)
const Class * (__RationalTypeList[2]) = { Rational::desc(), 0 };
DEFINE_CLASS(Fraction,__RationalTypeList);
void IntegerCoercer(void *dst, const void *src, const Type *dstCl, const Type *srcCl)
{
    // FIXME: Check that srcCl is a real (Root*) sub-class!
    const Integer *integer = ConvertInteger((Root*)src);
    if (integer == NULL)
	Signal(new CoercionFail((const Root*)src, dstCl));
    *(const Integer**)dst = integer;
}
void RealCoercer(void *dst, const void *src, const Type *dstCl, const Type *srcCl)
{
    // FIXME: Check that srcCl is a real (Root*) sub-class!
    const Real *x = ConvertReal((const Root*)src);
    if (x == NULL)
	Signal(new CoercionFail((const Root*)src, dstCl));
    *(const Real**)dst = x;
}
void NumericCoercer(void *dst, const void *src, const Type *dstCl, const Type *srcCl)
{
    // FIXME: Check that srcCl is a real (Root*) sub-class!
    const Numeric *num = ((Root*)src)->numeric();
    if (num == NULL) {
	num = ((Root*)src)->value()->numeric();
    }
    if (num == NULL)
	Signal(new CoercionFail((const Root*)src, dstCl));
    *(const Numeric**)dst = num;
}
void VectorCoercer(void *dst, const void *src, const Type *dstCl, const Type *srcCl)
{
    // NOTE: Should it be: isMemberOf? Should we copy if VectorV?
    if (((Root*)src)->isKindOf(*Vector::desc())) {
	*(Vector**)dst = (Vector*)src;
	return;
    }
    GenSeq *seq = ((Root*)src)->sequence();
    if (seq == NULL)
	Signal(new CoercionFail((const Root*)src, dstCl));
    index_t len = seq->length();
    Vector *vec = NewVector(len);
    Root** ptr = vec->start_addr();
    ITERATOR(iter, seq);
    while (--len >= 0)
	*ptr++ = iter.next();
    *(Vector**)dst = vec;
}
DEFINE_CLASS(Integer,__RationalTypeList)
const Class * (__IntegerTypeList[2]) = { Integer::desc(), 0 };
const Class * (__FixIntSuperList[3]) = { Integer::desc(),/*_long::desc(),*/ 0};
DEFINE_CLASS(FixInt,__FixIntSuperList)
const Class * (__FixIntTypeList[2]) = { FixInt::desc(), 0 };
DEFINE_CLASS(SmallInt,__FixIntTypeList)
#undef COERCE_FUNCTION
#define COERCE_FUNCTION LVarCoerceTo
void LVarCoerceTo(void *dst, const void *src,
	const Type * dstType, const Type *srcType)
{
    IFV(VarCoerce)
	DefaultCoerceTo(dst, src, dstType, srcType);
    THENV ELSEV(VarCoerce, Fail)
	Root *val = ((LVariable*)src)->value();
	if (val == NULL)
	    RaiseDomainError(NULL);
	else
	    val->isA()->coerceTo(dst, val, dstType);
    ENDV
}
DEFINE_CLASS(Tuple,RootTypeList)
DEFINE_CLASS(LVariable,RootTypeList)
const Class * (__LVariableTypeList[2]) = { LVariable::desc(), 0 };
DEFINE_CLASS(CVariable,__LVariableTypeList)
const Class * (__CVariableTypeList[2]) = { CVariable::desc(), 0 };
DEFINE_CLASS(Combination,__CVariableTypeList)
const Class * (__CombinationTypeList[2]) = { Combination::desc(), 0 };
DEFINE_CLASS(Choice,__CombinationTypeList)
DEFINE_CLASS(Condition,RootTypeList)
const Class * (__ConditionTypeList[2]) = { Combination::desc(), 0 };
DEFINE_CLASS(ParameterFail,__ConditionTypeList)

const RecordType *Root::isA() const { return Root::desc(); }
const RecordType *Type::isA() const { return Type::desc(); }

static void RefEmit(struct Type *typ, void *addr, CFile *cf)
{
    DumpPointerTo(*(RootPtr*)addr, cf);
}

ReferenceType::ReferenceType(const Type *base, CoerceFunction coercer = 0)
   : base_class(base), options(0)
{
    inst_size = sizeof(void*);
    base_class = base;
    kind = ReferenceTypeKind;
    excess_bits = 0;
    options = 0;
    emitFunction = RefEmit;
    _coerceTo = coercer;
}

RecordType::RecordType(Symbol *sym, Class **bases, int size,
	CoerceFunction coercer, int _flags = 0, void* VTable = 0)
   : class_bases(bases), options(_flags), class_name(sym)
{
    inst_size = size;
    kind = RecordTypeKind;
    _coerceTo = coercer;
    instanceVTable = VTable;
}

RecordType::RecordType(int size)
  : class_bases(RootTypeList), options(0), class_name(NULL)
{
    inst_size = size;
    kind = RecordTypeKind;
    _coerceTo = DefaultCoerceTo;
}

/*
 * A "record" is implemented as a "sub-class" of the C++ class Record.
 * However, record types may be created at run-time (by the interpreter).
 * So for each record type we make a copy of the Virtual Method Table
 * of class Record, and modify the 'isA' method to point to Stub_isA().
 */

extern int ReturnPointerStubSize; // machine dependent
extern int isA_Offset; // machine dependent offset in vtable
extern "C" void MakeReturnPointerStub(char *, void *);
extern "C" int GetVTableSize(void *vTable);
//Record EmptyRecord;

const RecordType *Stub_isA(Root* record)
{
    char *vtable = *(char**)record;
    int vsize = GetVTableSize(vtable);
    return *(const RecordType**)(vtable+vsize);
}

RecordType* RecordType::new_subclass(Symbol* name) const
{
    RecordType *rType = new RecordType(0);
    if (instanceVTable == NULL)
      Signal(new UnimplementedOp("new subclass"));
    int VTableSize = GetVTableSize(instanceVTable);
    int sizeVTable = VTableSize + sizeof(const RecordType*);
    rType->instanceVTable = (void*)malloc(sizeVTable);
    memcpy(rType->instanceVTable, instanceVTable, VTableSize);
    // Create stub routine that returns 'rType'.
    char *stubAddress = (char*)rType->instanceVTable + VTableSize;
    *(RecordType**)stubAddress = rType;
    // Fix isA entry in vtable to point to stub routine
    *(char**)((char*)rType->instanceVTable + isA_Offset) = (char*)&Stub_isA;

    rType->desc->flags = 0;
    rType->desc->fields = NULL;
    rType->desc->uFields = 0;
    rType->desc->nFields = 0;
    rType->desc->hash = NULL;
    rType->desc->nHashLog = 0;
	
    return rType;
}

PrimitiveType::PrimitiveType(Symbol *sym, int size,
	CoerceFunction coercer, int _flags = 0)
   :options(_flags), class_name(sym)
{
    inst_size = size;
    kind = PrimitiveTypeKind;
    _coerceTo = coercer;
}

PrimIntType::PrimIntType(char *qname, char *cname, int size, int issigned)
: PrimitiveType(EnterSymbol(qname), size, DefaultCoerceTo,
		TypeIsCompiled|TypeIsScalar),
  c_name(cname)
{
    is_signed = issigned;
}

TextType::TextType() : options(0)
{
    inst_size = sizeof(ostream*);
    kind = TextTypeKind;
}

void TextType::printon(ostream& outs) const
{
    outs << "Type(Text)";
}

void TextType::coerceFromRoot(void *dstAddr, Root *value) const
{
    PrintResult(value, *(ostream*)dstAddr);
}

TextType Text;

void UnionType::printon(ostream& outs) const
{
    for (int i = 0; i < count; i++) {
	if (i > 0) outs << " || ";
	members[i]->printon(outs);
    }
}

void UnionType::xapply(void* dst, Type* dstType, ArgDesc& args)
{
  if (args.rCount + args.nCount == 0)
    if (args.lCount == 0)
      {
	dstType->coerceFromRoot(dst, this);
	return;
      }
    else
      {
#if 0
	check lCount == 1
	  OR[i]: if members[i]->isA()->isScalar()
	    then unify(args.lArgs[0], members[i])
	  else members[i]->apply(args);
#endif
      }
#if 0
  if (all_are_scalar && args.rCount > 0)
    {
      int i = coerce args.rArgs[0] to int;
      return members[i];
    }
  OR[i]: members[i]->apply(args);
#endif
}

void Type::coerceFromRoot(void *dstAddr, Root *value) const
{
    (*_coerceTo)(dstAddr, value, this, value->isA());
}

Root * Type::coerceToRoot(void *srcAddr) const
{
    return (Root*)srcAddr;
}

Root * PrimIntType::coerceToRoot(void *srcAddr) const
{
    if (size() == sizeof(long) && is_signed)
	return (Root*)MakeFixInt(*(long*)srcAddr);
    return 0;
}

void PrimIntType::coerceFromRoot(void *dstAddr, Root *value) const
{
     Integer* i = ConvertInteger(value);
     if (!i || i->big_len() != 1 || size() != sizeof(long) || !is_signed)
	Signal(new CoercionFail(value, this));
     *(long*)dstAddr = i->S[0];
}

Root * ReferenceType::coerceToRoot(void *srcAddr) const
{
    return base_class->coerceToRoot(*(void**)srcAddr);
}

void ReferenceType::coerceFromRoot(void *dstAddr, Root *value) const
{
    if (value != NULL && !value->isKindOf(*(RecordType*)base_class)) {
	Root *val = value->value();
	if (val && val->isKindOf(*(RecordType*)base_class))
	    value = val;
	else
	    Signal(new CoercionFail(value, this));
    }
    *(void**)dstAddr = value;
}

ReferenceType RefNumeric(Numeric::desc(), NumericCoercer);
ReferenceType RefInteger(Integer::desc(), IntegerCoercer);
ReferenceType RefReal(Real::desc(), RealCoercer);
ReferenceType RefDouble(Double::desc());
ReferenceType RefVector(Vector::desc(), VectorCoercer);

INSERT_BUILTIN(Symbol, *Symbol::desc());
INSERT_BUILTIN(LVariable, *LVariable::desc());
INSERT_BUILTIN(long, *_long::desc());
INSERT_BUILTIN(Numeric, RefNumeric);
INSERT_BUILTIN(Double, RefDouble);
INSERT_BUILTIN(double, *_double::desc());
INSERT_BUILTIN(Integer, RefInteger);
INSERT_BUILTIN(Real, RefReal);
INSERT_BUILTIN(Int, *_int::desc());
INSERT_BUILTIN(Text, Text);
INSERT_BUILTIN(MISSING, __Missing__);
INSERT_BUILTIN(NONE, __Missing__);

// Useful for debugging.
// E.g. to print a (Root *) X from gdb do:  set print_it(X)

void print_it(Root* arg)
{
    cerr << *arg << "\n";
    cerr.flush();
}

#ifdef DO_GC
void * operator new(size_t s, int dummy)
{
  return GC_malloc(s);
}
#endif
