/* Agent Tcl
 * Bob Gray  
 * 14 August 1995
 *
 * *** NOT PART OF THE STANDARD TCL DISTRIBUTION ***
 *
 * This is part of the code that is used to capture and restore the interal
 * state of an executing Tcl script. 
 *
 * tclGlue.cc --
 *
 *    This file implmenets the routines that are used to mark variables and
 *    procedures as IMMOBILE (an IMMOBILE variable or procedure will not
 *    appear in a captured state image).
 *
 * Copyright (c) 1995, Robert S. Gray Dartmouth College
 *
 * See the file "agent.terms" for information on usage and redistribution
 * of this file and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

/* TclIsVarGlued 

   Purpose: Determine if a variable is IMMOBILE

     Input: varPtr = pointer to the variable

    Output: The procedure returns 1 if the variable is IMMOBILE and 0
            otherwise.  
*/

int TclIsVarGlued (varPtr)
	Var *varPtr;
{
    /* check if the variable is glued */

  while (varPtr -> flags & VAR_UPVAR) {
    varPtr = varPtr -> value.upvarPtr;
  }
 
  if (varPtr -> flags & VAR_NO_TRANSFER) {
    return 1;
  }

  return 0;
}

/* TclIsProcGlued

   Purpose: Determine if a command is IMMOBILE

     Input: cmdPtr = pointer to the command

    Output: The procedure returns 1 if the command is IMMOBILE and 0
            otherwise.
*/

int TclIsProcGlued (cmdPtr)
	Command *cmdPtr;
{
    /* check if the command is glued */

  if (!(cmdPtr -> commandFlag & TCL_PROC)) {
    return 1;
  }

  if (!(cmdPtr -> commandFlag & TCL_TRANSFER)) {
    return 1;
  }

  return 0;
}

/* Tcl_GlueProc

    Purpose: Mark a procedure as immobile

      Input: interp = the current interpreter
             name   = the name of the procedure

     Output: The procedure returns TCL_ERROR and sets the interpreter result
             to an appropriate error message on error.  Otherwise the procedure
             returns TCL_OK and marks the procedure as IMMOBILE.
*/
 
int Tcl_GlueProc (interp, name)
	Tcl_Interp *interp;
	char *name;
{
  Interp *iPtr = (Interp *) interp;   /* internal interpreter    */
  Tcl_HashEntry *hPtr;                /* pointer to a hash entry */
  Command *cmdPtr;                    /* pointer to a command    */

    /* find the command */

  if ((hPtr = Tcl_FindHashEntry (&iPtr -> commandTable, name)) == NULL) {
    Tcl_AppendResult (interp, "unable to glue \"", name, "\": no such procedure", (char *) NULL);
    return TCL_ERROR;
  }

  cmdPtr = (Command *) Tcl_GetHashValue (hPtr);

    /* make sure that the command is a Tcl procedure */

  if (!TclIsProc (cmdPtr)) {
    Tcl_AppendResult (interp, "unable to glue \"", name, "\": not a Tcl procedure", (char *) NULL);
    return TCL_ERROR;
  }

    /* mark the Tcl procedure as immobile */

  cmdPtr -> commandFlag &= ~TCL_TRANSFER;
  return TCL_OK;
}

/* Tcl_GlueVar2

   Purpose: Mark a variable as IMMOBILE

     Input: interp = the current interpreter
            name1  = first part of variable name
            name2  = NULL or element name if the variable is an array
            flags  = an OR'ed combination of TCL_GLOBAL_ONLY, 
		     TCL_LEAVE_ERR_MSG and PAR1_NOT_PARSED

    Output: The procedure returns TCL_ERROR and sets the interpreter result
            to an appropriate error message on error.  Otherwise the procedure
            returns TCL_OK and marks the variable as IMMOBILE.
*/
  
int Tcl_GlueVar2 (interp, name1, name2, flags)
	Tcl_Interp *interp;
	char *name1;
	char *name2;
	int flags;
{
  Var *vPtr;    /* pointer to the variable         */
  Var *aPtr;    /* pointer to the variable's array */
 
    /* lookup the variable */

  if ((vPtr = LookupVar (interp, name1, name2, flags, "glue", 0, &aPtr)) == NULL) {
    return TCL_ERROR;
  }

    /* mark the variable as IMMOBILE */

  vPtr -> flags |= VAR_NO_TRANSFER; 
  return TCL_OK;
}

/* Tcl_GlueVar

   Purpose: Mark a variable as immobile

     Input: interp = the current interpreter
            name   = name of the variable
            flags  = an OR'ed combination of TCL_GLOBAL_ONLY and
                     TCL_LEAVE_ERR_MSG

    Output: The procedure returns TCL_ERROR and sets the interpreter result
            to an appropriate error message on error.  Otherwise the procedure
            returns TCL_OK and marks the variable as immobile.
*/

int Tcl_GlueVar (interp, name, flags)
	Tcl_Interp *interp;
	char *name;
	int flags;
{
   return (Tcl_GlueVar2 (interp, name, (char *) NULL, flags | PART1_NOT_PARSED));
}
	
/* Tcl_GlueCmd

   Tcl syntax: glue [proc | var] name [name name ...]

      Purpose: Mark variables or procedures as IMMOBILE

        Input: dummy  = client data (unused)
               interp = the current interpreter
               argc   = the number of command arguments
               argv   = the command arguments

       Output: The procedure returns TCL_ERROR and sets the interpreter
               result to an appropriate error message on error.  Otherwise
               the procedure returns TCL_OK and marks the variables or
               procedures as immobile.
*/

int Tcl_GlueCmd (dummy, interp, argc, argv)
	ClientData dummy;
	Tcl_Interp *interp;
	int argc;
	char **argv;
{
  int i;      /* loop counter                                            */
  int procs;  /* 1 if we are gluing procedures and 0 if gluing variables */

    /* check the number of arguments */

  if (argc < 3) {
    Tcl_AppendResult (interp, "wrong # of args: should be \"", argv[0], " [proc | var] name [name name ...]\"", (char *) NULL);
    return TCL_ERROR;
  }   
  
    /* determine if we are gluing variables or procedures */

  if (!strcmp(argv[1], "proc")) {
    procs = 1; 
  } else if (!strcmp(argv[1], "var")) {
    procs = 0;
  } else {
    Tcl_AppendResult (interp, "second argument must be \"proc\" or \"var\"", (char *) NULL);
    return TCL_ERROR;
  }
  
    /* loop through each variable or procedure */

  for (i = 2; i < argc; i++) {
    if (procs) {
      if (Tcl_GlueProc (interp, argv[i]) != TCL_OK) {
        return TCL_ERROR;
      }
    } else {
      if (Tcl_GlueVar (interp, argv[i], TCL_LEAVE_ERR_MSG) != TCL_OK) {
        return TCL_ERROR;
      }
    }
  }
  
    /* done */

  return TCL_OK;    
}
