/* (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.14 2/17/92";
#endif

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

#include "predefined.cd"
#include "interpform.cd"

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

extern datarep dr_program, dr_record, dr_variant;

#include "cherm.h"

extern object *firstelem_key;		/* keys (f1) */

predef_exception h_call(), h_qcall(), h_scall();
predef_exception h_lookup();
predef_exception h_lookup_secondary();


/* Note: In most of the table operations, we can rely on all fields */
/* being initialized, since we're dealing with checked programs.  For */
/* the few operations that can work on unchecked programs, we must */
/* make sure of the initializedness of fields before working on them */

NILOP(o_new_program)
{
    predef_exception retcode;
    predef_exception che_new_program();
    
    if (che_new_program(DstObj, args->sched) != Normal)
      raise_builtin(Depletion);
}

/* che_new_program is called directly by generated c-code. */
predef_exception
che_new_program(dstobj, sched)
objectp dstobj;
schedblock *sched;
{
    void re_finalize();
    pd_program *newprog;
    extern flag cherm_flag;

    if ((newprog = (pd_program *) getdotmain(PROGRAM_SIZE)) is nil)
      return(Depletion);
    
    /* initialize the hidden field to an empty table, indicating there */
    /* is no compiled code stored with this program */
    if (avl_new_table(&newprog->data[program__CODE_MAP], firstelem_key)
	isnt SUCCESS) {
      freedotmain(newprog, PROGRAM_SIZE);
      return(Depletion);
    }

    newprog->info.program_refcount = 1;
    if (not cherm_flag)
      re_finalize(dstobj, F_DISCARD, sched);
				/* finalize the value of the destination; */

    dstobj->value.program = newprog;
    set_init(dstobj, dr_program);

    return (Normal);
}


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)
{
    predef_exception retcode;
    predef_exception che_prog_lit();

    if ((retcode = che_prog_lit(DstObj, args->qualifiers, args->sched))
	!= Normal)
      raise_builtin (retcode);
}

/* che_prog_lit is called directly by generated c-code. */
predef_exception
che_prog_lit(dstobj, qual, sched)
objectp dstobj;
valcell qual;
schedblock *sched;
{
    void re_finalize();
    extern flag cherm_flag;
    flag save_cherm_flag;
    status rc;
    pd_program *newprog;
    pd_program *current;
    predef_exception re_copy();
    valcell relrec;
    void fin_program();

    /* The program we create should be just like the current program, */
    /* except: (1) the main_program field will be the processid */
    /* extracted from the qualifer; and (2) the processes list will */
    /* include only those processes accessible from that program. */
    /* We don't prune the code map, since that's not visible to */
    /* programmers anyway. */

    current = sched->ready->prog; /* guaranteed fully init */

    if ((newprog = (pd_program *) getdotmain(PROGRAM_SIZE)) is nil) 
      return(Depletion);

    newprog->info.program_refcount = 1;
    
    if(cp_table(& dcdot(newprog, program__definitions_modules),
		dcdot(current, program__definitions_modules)) isnt Normal)
      goto cleanup;
    set_init(&newprog->data[program__definitions_modules], dr_table);

    if (cp_nominal(& dcdot(newprog, program__main_program), qual) isnt Normal)
      goto cleanup;
    set_init(&newprog->data[program__main_program], dr_nominal);

    if(cp_table(& dcdot(newprog, program__CODE_MAP),
		dcdot(current,program__CODE_MAP)) isnt Normal)
      goto cleanup;
    set_init(&newprog->data[program__CODE_MAP], dr_table);

    /* put main_program into programs, and any other processes it has
       as literals */
    /* current@programs may be empty if the absprogs have been stripped,
       so only do this if they're there, otherwise just copy  */
    if (size_of(dcdot(current,program__programs)) > 0) {
      /* make new table for newprog.programs in same way as fe does */
      /* make sure it knows this call isn't from a hermes process */
      save_cherm_flag = cherm_flag;
      cherm_flag = TRUE;
      rc = avl_new_table(& newprog->data[program__programs], firstelem_key);
      cherm_flag = save_cherm_flag;
      if(rc is FAILURE) 
	goto cleanup;
      if (get_processes(& newprog->data[program__main_program],
                        & current->data[program__programs],
                        & newprog->data[program__programs]) is FAILURE)
        goto cleanup;
    }
    else {
      if(cp_table(& dcdot(newprog, program__programs),
		  dcdot(current, program__programs)) isnt Normal)
        goto cleanup;
      set_init(&newprog->data[program__programs], dr_table);
    }

    if (not cherm_flag)
      re_finalize(dstobj, F_DISCARD, sched);
         /* finalize the value of the destination; */
    
    dstobj->value.program = newprog; /* copy pointer to the program. */
    set_init(dstobj, dr_program);
    return (Normal);
    
  cleanup:
    relrec.program = newprog;
    fin_program(relrec, F_DISCARD, sched);
    return(Depletion);
}

status
get_processes(id, srcprocesses, dstprocesses)
object *id;              /* processid */
object *srcprocesses;    /* processes */
object *dstprocesses;    /* processes */
{
  extern flag cherm_flag;
  flag save_cherm_flag;
  status rc;

  /* make sure that everyone knows we're not calling from Hermes */
  save_cherm_flag = cherm_flag;
  cherm_flag = TRUE;
  rc = get_procs(id, srcprocesses, dstprocesses);
  cherm_flag = save_cherm_flag;
  return(rc);
}

status
get_procs(id, srcprocesses, dstprocesses)
object *id;              /* processid */
object *srcprocesses;    /* processes */
object *dstprocesses;    /* processes */
{
  objectp foundproc, proccopy;     /* proc */
  object foundproc_obj, proccopy_obj;
  qualholder qh, qh2;
  predef_exception rc;
  object *clause; 
  object *clauses;
  object *statement;              
  object *statements;
  object clause_obj, statement_obj;

  foundproc = &foundproc_obj;
  proccopy = &proccopy_obj;
  clause = &clause_obj;
  statement = &statement_obj;

  /* find srcprocesses[id], insert copy of it into dstprocesses, and
     recurse on id's of any prog_lits in it. */

  if(h_lookup(foundproc, srcprocesses, id) isnt Normal)
    /* This is odd, the process labeled by id isn't there.
       We now have the option of returning an incomplete absprog,
       or raising Depletion.  We'll take the former. */
    return(SUCCESS);
  if(re_copy(foundproc, proccopy) isnt Normal)
    return(FAILURE);
  rc = h_call(o_insert, dstprocesses, proccopy, 0);

  if (rc is Normal) {
    /* inspect clause in foundproc@execution_environment@clauses */
    /* inspect statement in clause@statements */
    /* check if case of statement@qualifier is 'program literal', and if so,
       call get_processes with that id. */
    clauses = dot(dot(foundproc, proc__executable_part),
		  execution_environment__clauses);

    qh.val.record = nil;
    h_qcall(o_initget, qh, clause, clauses, 0);

    /* following won't really raise an exception because of cherm_flag */
    while (h_call(o_get_or_err, clause, clauses, 0) is Normal) {
      statements = dot(clause, clause__statements);
      
      qh2.val.record = nil;
      h_qcall(o_initget, qh2, statement, statements, 0);
      while (h_call(o_get_or_err, statement, statements, 0) is Normal) {
        if (obj_case_of(dot(statement, statement__qualifier)) is
	    qualifier_types__program_literal) {
          if (get_processes(obj_varcomp_of(dot(statement,
					       statement__qualifier)),
                            srcprocesses,
                            dstprocesses)
              is FAILURE)
            return(FAILURE);
        }
      }
    }
    return(SUCCESS);
  }
  else if (rc is DuplicateKey)
    return(SUCCESS);
  else
    return(FAILURE);
}


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

    if ((current = make_pgm_copy(args->sched->ready->prog)) is nil)
      raise_builtin(Depletion);
    else {
      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);
    }
}


predef_exception
cp_program(dst, src)
valcell *dst, src;
{
    pd_program *newprog;
    pd_program *make_pgm_copy();

    if ((newprog = make_pgm_copy(src.program)) is nil)
      return(Depletion);
    else {
      dst->program = newprog;
      return(Normal);
    }
}

pd_program *
make_pgm_copy(src)
pd_program *src;
{
  pd_program *newprog;
  valcell relrec;
  void fin_program();

  if ((newprog = (pd_program *) getdotmain(PROGRAM_SIZE)) is nil) 
    return(nil);
  else 
    newprog->info.program_refcount = 1;

  /* definitions_modules, programs, and CODE_MAP are tables; we assume
     they are lazy-copied.  Otherwise this will kill us. */
  if(re_copy(& src->data[program__definitions_modules],
	     & newprog->data[program__definitions_modules]) isnt Normal)
    goto cleanup;

  if(re_copy(& src->data[program__main_program],
	     & newprog->data[program__main_program]) isnt Normal)
    goto cleanup;

  if(re_copy(& src->data[program__programs],
	     & newprog->data[program__programs]) isnt Normal)
    goto cleanup;

  if(re_copy(& src->data[program__CODE_MAP],
	     & newprog->data[program__CODE_MAP]) isnt Normal)
    goto cleanup;

  return(newprog);

cleanup:	   
  relrec.program = newprog;
  fin_program(relrec, F_DISCARD, (schedblock *) nil);
  return(nil);

}


void
fin_program(value, f_op, sched)
valcell value;
finalize_op f_op;
schedblock *sched;
{
    void re_finalize();
    int do_delink();
    dfd_table *codemap;
    counter i;

    if (--value.program->info.program_refcount > 0)
      return;			/* decrement refcount; return if nonzero. */
    
    if (vdotrep(value, program__CODE_MAP)->number isnt dr_bottom.number) {
      codemap = vdot(value, program__CODE_MAP).table;
      if (codemap->refcount == 1) {
	/* need to delink any processes that might have had code */
	/* dynamically linked in */
	(void) (*codemap->tbls[FIRST_TBL].des->foreach)
	  (codemap, FIRST_TBL, (int (*)()) do_delink, &i, 0);
      }
    }
    for (i = 0; i < PROGRAM_SIZE; i++)
      re_finalize(& value.program->data[i], f_op, sched);

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

static int
do_delink(table, tblnum, prog, count)
dfd_table *table;
trepnum tblnum;
valcell prog;
counter count;
{
  void delink_process();
  delink_process(prog);
  return(0);
}

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

    /* if the same object or if all non-hidden fields are equal, */
    /* they are equal */ 
    if (val1.program is val2.program)
      st = SUCCESS;
    else
      for (i = 0; i < PROGRAM_VISIBLE_SIZE;  i++)
	if (! (st = re_equal(&val1.program->data[i], &val2.program->data[i])))
	  break;
    return(st);
}


/* don't have to worry about uninit fields here because typestate will */
/* ensure that val1 and val2 are in same state of initializedness, */
/* due to typestate homogeneity of table elements */
comparison
cmp_program(val1, val2)
valcell val1, val2;
{
    counter i;
    comparison cmp;

    comparison compare_program_fields();

    if (val1.program is val2.program)
      cmp = CMP_EQUAL;
    else
      /* don't include hidden fields in comparison */
      for (i = 0; i < PROGRAM_VISIBLE_SIZE;  i++) {
	cmp = re_comparekeys(&val1.program->data[i], &val2.program->data[i]);
	if (cmp isnt CMP_EQUAL)
	  break;
      }
    return(cmp);
}

NILOP(o_typename)
{
    predef_exception retcode;
    predef_exception che_typename();

    if ((retcode = che_typename(DstObj, args->qualifiers, args->sched))
	!= Normal)
      raise_builtin (retcode);
}

/* che_typename is called directly by generated c-code. */
predef_exception
che_typename(dstobj, qualifier, sched)
objectp dstobj;
valcell qualifier;
schedblock *sched;
{
    void re_finalize();
    predef_exception cp_record();
    predef_exception retcode;
    valcell newtype;
    extern flag cherm_flag;

    if ((retcode = cp_record(&newtype, qualifier)) is Normal) {
        if (not cherm_flag)
	  re_finalize(dstobj, F_DISCARD, sched);
				/* finalize the value of the destination; */

	dstobj->value = newtype;
	set_init(dstobj, dr_record);
    }
    return(retcode);
}


NILOP(o_attributename)
{
    predef_exception retcode;
    predef_exception che_attributename();

    if ((retcode = che_attributename(DstObj, args->qualifiers, args->sched))
	!= Normal)
      raise_builtin (retcode);
}

/* che_attributename is called directly by generated c-code. */
predef_exception
che_attributename(dstobj, qualifier, sched)
objectp dstobj;
valcell qualifier;
schedblock *sched;
{
    void re_finalize();
    predef_exception cp_variant();
    predef_exception retcode;
    valcell newattr;
    extern flag cherm_flag;

    if ((retcode = cp_variant(&newattr, qualifier)) is Normal) {
        if (not cherm_flag)
	  re_finalize(dstobj, F_DISCARD, sched);
				/* finalize the value of the destination; */

	dstobj->value = newattr;
	set_init(dstobj, dr_variant);
    }
    return(retcode);
}
