/* (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. */
/* File: o_call.c */
/* Author: David F. Bacon */
#ifndef lint
static char sccsinfo[] = "@(#)o_call.c	1.14 3/13/90";
#endif

/*
 * o_call.c
 */

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

#include "interpform.cd"

#define NORMAL_RETURN 0
#define ERROR_RETURN 1

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

extern datarep dr_inport, dr_outport, dr_callmessage, dr_bottom, dr_variant;

NILOP(o_call)
{
  predef_exception call_subr();
  object(Callmsg);

  pcb *currentproc;
  dfd_callmessage *cm;
  message *cmmsg;
  predef_exception retcode;

#ifdef OPCHECK
  assert(OPISTYPE(DstObj,outport));
#endif

  currentproc = args->sched->ready;

  /* get pointers to pre-allocated structures */
  
  cm = & currentproc->suspend_info.call.callmessage;
				/* get ptr to pre-allocated callmessage. */
				/* the info field has already been pre- */
				/*  initialized by o_create. */

  cm->info.callmessage = & currentproc->suspend_info.call.cminfo;
				/* link the pre-allocated callmessage into */
				/*  its pre-allocated dotinfo structure.  we */
				/*  have to do this each time since this is */
				/*  stored in a union and may be */
				/*  overwritten. */ 

  cmmsg = & currentproc->suspend_info.call.msg;
				/* get address of pre-allocated inport queue */
				/*  entry. */

  /* now, do the real work */

  if ((retcode = call_subr(args, &Callmsg, cmmsg, cm)) is Normal) {

      args->sched->suspend(args->sched, currentproc, nil);
				/* suspend while waiting. */

      args->nextop = currentproc->ip;
				/* on return, ip points to the call. */
  }
  else
    raise(retcode);
}

  
predef_exception
call_subr(args, cmobj, cmmsg, cm)
argblock *args;
object *cmobj;
message *cmmsg;
dfd_callmessage *cm;
{
  register counter i;
  register object *parm;
  pcb *currentproc;
  extern predef_exception cherm_excep;
  local_cminfo *locinfo;
  predef_exception err;


  if (Dst.outport->disconnected) /* first check that the port is */
				/*  still alive. */
    return(Disconnected);


  /* note: we construct the local callmessage irregardless of whether the */
  /* final destination is remote or local. */

  currentproc = args->sched->ready;
  locinfo = & cm->info.callmessage->cminfo.local;

  locinfo->caller = currentproc;
				/* point back to calling process. */
  
  for (i = 1; (parm = args->operandstack[i]) isnt nil; i++) {
      locinfo->parameters[i-1] = parm;
      cm->data[i-1] = *parm;	/* "move" the parameters into the cm. */
  }
  cm->info.callmessage->size = i-1;
  cm->info.callmessage->local = TRUE;

  cmobj->value.callmessage = cm;
  cmobj->tsdr = &dr_callmessage;
				/* initialize the object. */
  
				/* send the callmessage */
  if ((err = (*Dst.outport->port_enq)(Dst, cmobj, cmmsg, args->sched)) 
      isnt Normal)
    return(err);
  
  set_bottom(cmobj);		/* callee owns this now */
  return(Normal);
}


pcb *
do_return(val)
valcell val;
{
  register object **parmlist;
  register counter i;
  pcb *caller;
  callmessage_info *info;
  

  info = val.callmessage->info.callmessage;

  if (not info->local)
    return(nil);

  parmlist = info->cminfo.local.parameters;
  
  for (i = 0; i < info->size; i++) 
    * parmlist[i] = val.callmessage->data[i];
				/* move the parameters back. */
      
  caller = info->cminfo.local.caller;

  return(caller);
				/* wake this process back up */
}


NILOP(o_return)
{
    void rem_return();

    pcb *caller;


    OPCHK(DstObj,callmessage);
    caller = do_return(Dst);

    if (caller) {		/* local return */
	if (not caller->interpreter) 
				/* if it uses the standard interpreter... */
	  caller->ip++;		/* advance to operation after the call */

	args->sched->wakeup_proc(args->sched, caller);
    }
    else 
      rem_return(Dst);

    set_bottom(DstObj);

#ifdef TRACE
    args->sched->ready->call_level = 0;	/* fix this proc's call level */
#endif
}


NILOP(o_return_exception)
{
    void raise_user();
    void rem_return_exception();

    pcb *caller;


    OPCHK(DstObj,callmessage);
    caller = do_return(Dst);

    if (caller) {		/* if local return... */
	raise_user(args->qualifiers, caller); /* sets ip of caller */
	args->sched->wakeup_proc(args->sched, caller); /* wake up caller */
    }
    else
      rem_return_exception(Dst, args->qualifiers);

    set_bottom(DstObj);

#ifdef TRACE
				/* fix this proc's call level */
    args->sched->ready->call_level = 0;
#endif
}


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


    if (f_op is F_DISCARD) {
	void rem_fin_callmessage();
	void raise_user();

	valcell qual;
	pcb *caller;


	/* fix later: do soft coercion of callmessage!!! */
	
	caller = do_return(value);
	
	if (caller) {		/* if a local return */
	    /* qual = prog@LI_PROGRAM@code[ip].qualifier */
	    
	    qual = dot(get_elem(dot(dcdot(caller->prog, program__LI_PROGRAM), 
				    prog__code), caller->ip),
		       operation__qualifier);
	    
	    raise_user(dot(qual, VARIANT_COMPONENT), caller);
	    sched->wakeup_proc(sched, caller);
	}
	else
	  rem_fin_callmessage(value);
	
#ifdef TRACE
	/* fix this proc's call level */
	sched->ready->call_level = 0;
#endif
    }
    else {			/* f_op is F_FREE */
	counter size, i;

	if (value.callmessage->info.callmessage->local)
	  return;		/* don't free a local cm, only a remote one */

	size = value.callmessage->info.callmessage->size;

	for (i = 0; i < size; i++)
	  re_finalize(& value.callmessage->data[i], F_FREE, (schedblock*) nil);
				/* freeing revives no processes */

	dispose(value.callmessage->info.callmessage, callmessage_info);
	freedotmain(value.callmessage, size);
    }
}


status
eq_callmessage(val1, val2)
valcell val1, val2;
{
  if (val1.callmessage is val2.callmessage)
    return(SUCCESS);		/* the usual programming in the large */
  else				/*  bit: they're only equal if they're the */
    return(FAILURE);		/*  same object. */
}
