/* (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_prog.c	1.8 3/13/90";
#endif

#include "ops.h"
#include "storage.h"
#include "sysdep.h"
#include "accessors.h"

#include "interpform.cd"

#define Dst (DstObj->value)
#define Src (SrcObj->value)

extern datarep dr_program, dr_record, dr_variant;


NILOP(o_new_program)
{
    void re_finalize();
    dfd_record *new_record();
    pd_program *newprog;
    extern flag cherm_flag;

    if ((newprog = (pd_program *) new_record(PROGRAM_SIZE)) is nil)
      raise(Depletion);
    else {
	newprog->info.program_refcount = 1;
        if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	Dst.program = newprog;
	set_init(DstObj, dr_program);
    }
}




status
refprog(prog)
pd_program *prog;
{
    if (prog->info.program_refcount is MAXCOUNTER)
      return(FAILURE);

    prog->info.program_refcount++;
    return(SUCCESS);
}


NILOP(o_prog_lit)
{
    void re_finalize();
    extern flag cherm_flag;

    if (refprog(args->qualifiers.program)) {
        if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	Dst = args->qualifiers;	/* copy pointer to the program. */
	set_init(DstObj, dr_program);
    }
    else
      raise(Depletion);
}



NILOP(o_currentprogram)
{
    void re_finalize();
    pd_program *current;
    extern flag cherm_flag;


    current = args->sched->ready->prog;

    if (refprog(current)) {
        if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	Dst.program = current;
	set_init(DstObj, dr_program);
    }
    else
      raise(Depletion);

}


NILOP(o_link)
{
   void re_finalize();
    valcell mainprog;
    valcell linkprog;
    extern flag cherm_flag;

    mainprog.program = args->sched->ready->prog;

    linkprog = get_elem(dot(dot(mainprog, program__LI_PROGRAM),
			    prog__linkedprogs), 
			args->qualifiers.integer);

    if (refprog(linkprog.program)) {
        if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	Dst = linkprog;
	set_init(DstObj, dr_program);    
    }
    else
      raise(Depletion);
}


predef_exception
cp_program(dst, src)
valcell *dst, src;
{
    if (refprog(src.program)) {
	dst->program = src.program;
	return(Normal);
    }
    else
      return(Depletion);
}


void
fin_program(value, f_op, sched)
valcell value;
finalize_op f_op;
schedblock *sched;
{
    void re_finalize();

    counter i;

    if (--value.program->info.program_refcount > 0)
      return;			/* decrement refcount; return if nonzero. */

    for (i = 0; i < PROGRAM_SIZE; i++)
      re_finalize(& value.program->data[i], f_op, sched);

    { freedotmain(value.program, PROGRAM_SIZE); }
}


status
eq_program(val1, val2)
valcell val1, val2;
{
    counter i;

    if (val1.program is val2.program)
      return(SUCCESS);		/* same object?  then equal. */

    for (i = 0;  i < PROGRAM_SIZE-1;  i++)
      if (!re_equal(& val1.program->data[i], & val2.program->data[i]))
	return(FAILURE);	/* if absprogs are the same, they are equal */

    return(SUCCESS);
}


NILOP(o_typename)
{
    void re_finalize();
    predef_exception cp_record();
    predef_exception retcode;
    valcell newtype;
    extern flag cherm_flag;

    if ((retcode = cp_record(&newtype, args->qualifiers)) is Normal) {
        if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	Dst = newtype;
	set_init(DstObj, dr_record);
    }
    else
      raise(retcode);
}



NILOP(o_attributename)
{
    void re_finalize();
    predef_exception cp_variant();
    predef_exception retcode;
    valcell newattr;
    extern flag cherm_flag;

    if ((retcode = cp_variant(&newattr, args->qualifiers)) is Normal) {
        if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	Dst = newattr;
	set_init(DstObj, dr_variant);
    }
    else
      raise(retcode);
}
