/* (C) Copyright International Business Machines Corporation 23 January */
/* 1990.  All Rights Reserved. */
/*  */
/* See the file USERAGREEMENT distributed with this software for full */
/* terms and conditions of use. */
#ifndef lint
static char sccsinfo[] = "@(#)o_poly.c	1.14 2/17/92";
#endif

#include "ops.h"
#include "recursiv.h"
#include "storage.h"
#include "sysdep.h"
#include "accessors.h"
#include "interpform.cd"

#define Dst (DstObj->value)
#define Src (SrcObj->value)
#define Src1 (Src1Obj->value)
#define Src2 (Src2Obj->value)

extern datarep dr_polymorph;


NILOP(o_wrap)
{
    predef_exception retcode;
    predef_exception che_wrap();

    if ((retcode = che_wrap(DstObj, SrcObj, args->qualifiers, args->sched))
	isnt Normal)
      raise_builtin(retcode);
}

/* che_wrap is called directly from generated C-code. */
predef_exception
che_wrap(dstobj, srcobj, qualifier, sched)
objectp dstobj;
objectp srcobj;
valcell qualifier;
schedblock *sched;
{
    void re_finalize();
    void fin_polymorph();
    predef_exception re_copy();

    extern flag cherm_flag;
    valcell newpoly;
    predef_exception retcode;
    dfd_record *record;

    if ((newpoly.polymorph = new(dfd_polymorph)) is nil)
      return(Depletion);
    set_bottom(&newpoly.polymorph->typename);
    set_bottom(&newpoly.polymorph->typestate);
    set_bottom(&newpoly.polymorph->obj);
    record = qualifier.record;
    if (record != nil) {
      if ((retcode = re_copy(& record->data[polymorph_info__type],
			     & newpoly.polymorph->typename))
	  isnt Normal)
	goto cleanup;
      if ((retcode = re_copy(& record->data[polymorph_info__typestate],
			     & newpoly.polymorph->typestate))
	  isnt Normal)
	goto cleanup;
    }
    newpoly.polymorph->obj = *srcobj;
    set_bottom(srcobj);	/* wrap is move-semantic, leaves src uninit */

    if (not cherm_flag)	  
      re_finalize(dstobj, F_DISCARD, sched);
				/* finalize the value of the destination; */
    dstobj->value.polymorph = newpoly.polymorph;
    set_init(dstobj, dr_polymorph);
    return(Normal);

    cleanup:
      fin_polymorph(newpoly, F_DISCARD, nil);
      return(retcode);
}

/* fix later to check mismatch and coerce Object to ToState */
#define Coerce(Object,FromState,ToState) SUCCESS

NILOP(o_unwrap)
{
    predef_exception retcode;
    predef_exception che_unwrap();

    if ((retcode = che_unwrap(DstObj, SrcObj, args->qualifiers, args->sched))
	isnt Normal)
      raise_builtin(retcode);
}

/* che_unwrap is called directly from generated C-code. */
predef_exception
che_unwrap(dstobj, srcobj, qualifier, sched)
objectp dstobj;
objectp srcobj;
valcell qualifier;
schedblock *sched;
{
    void re_finalize();
    void fin_polymorph();
    flag match;
    object obj;

    extern flag cherm_flag;

    OPCHK(srcobj,polymorph);
    obj = *srcobj;		/* protect src in case src is dst */
    set_bottom(srcobj);		/* discard and uninitialize the source */
    if (not cherm_flag) {

      /* things that come from the cloader have a bottom wrapped type, */
      /* since we can't really wrap the correct type.  We allow any */
      /* unwraps of such polymorphs to pass the type check */
      match = re_equal(& obj.value.polymorph->typename,
		       & qualifier.record->data[polymorph_info__type]);
      if (match is SUCCESS)
	match = Coerce(& obj.value.polymorph->typestate,
		       & qualifier.record->data[polymorph_info__typestate],
		       & obj.value.polymorph->obj);
      else
	match = obj.value.polymorph->typename.tsdr->number
	  is dr_bottom.number;
      if (match is FAILURE) {
	*srcobj = obj;		/* restore the source */
	return(PolymorphMismatch);
      }
      /* finalize the value of the destination; */
      re_finalize(dstobj, F_DISCARD, sched);
    }
    /* "move" (coerced) object from polymorph into dst */
    *dstobj = obj.value.polymorph->obj;
    set_bottom(&obj.value.polymorph->obj);

    /* release typename, typestate and dispose of the polymorph */
    fin_polymorph(obj.value, F_DISCARD, nil);
    return(Normal);
}

/* fix later to check FromState => ToState */
#define Inspect(FromState,ToState) SUCCESS

NILOP(o_inspect_poly)
{
    predef_exception retcode;
    predef_exception che_inspect_poly();

    if ((retcode = che_inspect_poly(DstObj, SrcObj, args->qualifiers,
				    args->sched))
	isnt Normal)
      raise_builtin(retcode);
}

/* che_inspect_poly is called directly from generated C-code. */
predef_exception
che_inspect_poly(dstobj, srcobj, qualifier, sched)
objectp dstobj;
objectp srcobj;
valcell qualifier;
schedblock *sched;
{
    void re_finalize();

    extern datarep *qdatarepmap[];
    extern flag cherm_flag;

    OPCHK(srcobj,polymorph);
    if (qualifier.record != nil) {
      if (re_equal(& srcobj->value.polymorph->typename,
		& qualifier.record->data[polymorph_info__type])
	    isnt SUCCESS
	  ||
	  Inspect(& srcobj-.value.polymorph->typestate,
	  	  & qualifier.record->data[polymorph_info__typestate])
	    isnt SUCCESS
	  ) {			/* mismatch */
	return(PolymorphMismatch);
      }
      re_finalize(dstobj, F_DISCARD, sched);
				/* finalize the value of the destination; */
    }
				/* make a quopy of the object */ 
    dstobj->value = srcobj->value.polymorph->obj.value;
    dstobj->tsdr = qdatarepmap[srcobj->value.polymorph->obj.tsdr->number];
    return(Normal);
}

NILOP(o_endinspect_poly)
{
    set_bottom(DstObj);		/* don't really need to do this, but.... */
}


/*ARGSUSED*/
void
fin_polymorph(poly, f_op, sched)
valcell poly;
finalize_op f_op;
schedblock *sched;
{
    Finalize(&poly.polymorph->obj, f_op, sched);
    Finalize(&poly.polymorph->typename, f_op, sched);
    Finalize(&poly.polymorph->typestate, f_op, sched);
    { dispose(poly.polymorph, dfd_polymorph); }
}

predef_exception
cp_polymorph(dst, src)
valcell *dst, src;
{
    predef_exception re_copy();
    predef_exception retcode;
    valcell newpoly;

    if ((newpoly.polymorph = new(dfd_polymorph)) is nil)
      return(Depletion);
    else {

	set_bottom(&newpoly.polymorph->obj);
	set_bottom(&newpoly.polymorph->typename);
	set_bottom(&newpoly.polymorph->typestate);
	retcode = re_copy(& src.polymorph->obj,
			  & newpoly.polymorph->obj);
	if (retcode isnt Normal)
	  goto cleanup;
	retcode = re_copy(& src.polymorph->typename,
			  & newpoly.polymorph->typename);
	if (retcode isnt Normal)
	  goto cleanup;
	retcode = re_copy(& src.polymorph->typestate,
			  & newpoly.polymorph->typestate);
	if (retcode isnt Normal)
	  goto cleanup;
	dst->polymorph = newpoly.polymorph;
	return(Normal);

      cleanup:
	/* one of the copy operations raised an exception */
	fin_polymorph(newpoly, F_DISCARD, nil);
	return(retcode);
    }
}


status
eq_polymorph(poly1, poly2)
valcell poly1, poly2;
{

    status equal;
  
    if ((equal = re_equal(& poly1.polymorph->typename,
			  & poly2.polymorph->typename
			  )) is SUCCESS
        &&
	(equal = re_equal(& poly1.polymorph->typestate,
			  & poly2.polymorph->typestate
			  )) is SUCCESS
       )
      equal = re_equal(& poly1.polymorph->obj, & poly2.polymorph->obj);
    return(equal);

}


comparison
cmp_polymorph(poly1, poly2)
valcell poly1, poly2;
{
    comparison cmp;
    comparison re_comparekeys();

    if (poly1.polymorph is poly2.polymorph)
      return(CMP_EQUAL);
    if ((cmp = re_comparekeys(& poly1.polymorph->typename,
			      & poly2.polymorph->typename
			     )) is CMP_EQUAL
        &&
	(cmp = re_comparekeys(& poly1.polymorph->typestate,
			      & poly2.polymorph->typestate
			     )) is CMP_EQUAL
       )
      cmp = re_comparekeys(& poly1.polymorph->obj, & poly2.polymorph->obj);
    return(cmp);

}
