Logo Search packages:      
Sourcecode: felt version File versions  Download package

apply.c

/*
    This file is part of the FElt finite element analysis package.
    Copyright (C) 1993-2000 Jason I. Gobat and Darren C. Atkinson

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/

/************************************************************************
 * File:    apply.c                                         *
 *                                                    *
 * Description:   This file contains the function definitions for the   *
 *          virtual machine instructions related to function and  *
 *          array application and function return.                *
 ************************************************************************/

# include "trap.h"
# include "apply.h"
# include "debug.h"
# include "error.h"
# include "lexer.h"
# include "coerce.h"
# include "execute.h"
# include "functab.h"
# include "our-stdlib.h"
# include "pathsearch.h"


static descriptor *ret_val;
static descriptor  ret_obj;
static Function      top_of_stack;

static int array_index        PROTO ((descriptor *, int));
static int matrix_index       PROTO ((descriptor *, int));
static int intrinsic_call     PROTO ((descriptor *, int));
static int function_search    PROTO ((descriptor *, int));
static int external_call      PROTO ((descriptor *, int));
static int submatrix_assignment     PROTO ((descriptor *, descriptor **));


/************************************************************************
 * Function:      submatrix_assignment                            *
 *                                                    *
 * Description:   Trapped variable handler for submatrix assignment.  The     *
 *          handler verifies that the source is the same size and *
 *          type as the destination submatrix.              *
 ************************************************************************/

static int submatrix_assignment (dest, src)
    descriptor  *dest;
    descriptor **src;
{
    Matrix  a;
    Matrix  b;
    int           status;


    /* RecycleData() calls the function with only one argument. */

    if (!src) {
      D_Temp    (dest) = F_True;
      D_Trapped (dest) = F_False;
      RecycleData (dest);
      return 0;
    }


    *src = CoerceData (*src, T_Double);

    switch (D_Type (*src)) {
    case T_Double:
      a = D_Matrix (dest);
      if (Mrows (a) == 1 && Mcols (a) == 1) {
          sdata (a, 1, 1) = *D_Double (*src);
          return 0;
      }

      TypeError ("=", dest, *src, NULL, F_False);
      return 1;


    case T_Matrix:
      a = D_Matrix (*src);
      b = D_Matrix (dest);
      if ((status = CopyMatrix (b, a)))
          MatrixError ("=", b, a, status, F_False);
      return status;


    default:
      TypeError ("=", dest, *src, NULL, F_False);
      return 1;
    }
}


/************************************************************************
 * Function:      function_call                                   *
 *                                                    *
 * Description:   Calls the function whose name and arguments are on the      *
 *          stack.  After the call returns the name and arguments *
 *          are removed from the stack and the return value is    *
 *          placed on the top of the stack.  If too few arguments *
 *          are given to the function then null descriptors on    *
 *          pushed in their place.  If too many arguments are given     *
 *          then they are silently discarded.  All value arguments      *
 *          are dereferenced in place on the stack.               *
 ************************************************************************/

int function_call (object, num_args)
    descriptor *object;
    int           num_args;
{
    int           i;
    int           j;
    descriptor *d;
    descriptor *fp;
    descriptor *arg;
    descriptor *args;
    descriptor *locals;
    descriptor *result;
    descriptor  temp;
    Function      function;
    Function      old_top;


    fp = sp - num_args;
    args = sp - num_args + 1;
    function = D_Function (object);

    old_top = top_of_stack;
    top_of_stack = function;


    /* Remove any extra arguments. */

    if (function -> num_args < num_args)
      for (i = function -> num_args; i < num_args; i ++)
          RecycleData (pop ( ));


    /* Add any necessary arguments. */

    else if (function -> num_args > num_args)
      for (i = num_args; i < function -> num_args; i ++) {
          arg = push ( );
          D_Type    (arg) = T_Null;
          D_Temp    (arg) = F_False;
          D_Trapped (arg) = F_False;
          D_Pointer (arg) = NULL;
      }


    /* Dereference any value arguments in place on the stack. */

    for (i = function -> num_args - 1, j = 0; i >= 0; i --, j ++) {
      arg = ntop (i);


      /* If the argument is a value argument then make a copy of it in
         place on the stack. */

      if (function -> arg_types [j] == ValueArg) {
          d = &temp;
          *d = *arg;
          d = deref (d);

          D_Type    (arg) = T_Null;
          D_Temp    (arg) = F_False;
          D_Trapped (arg) = F_False;
          D_Pointer (arg) = NULL;
          AssignData (arg, &d);


      /* Otherwise, the argument is shared.  If the argument is not
         assignable and is not temporary then we have to copy it. */

      } else if (!assignable (arg) && D_Temp (arg) == F_False) {
          d = &temp;
          *d = *arg;
          d = deref (d);

          D_Type    (arg) = T_Null;
          D_Temp    (arg) = F_False;
          D_Trapped (arg) = F_False;
          D_Pointer (arg) = NULL;
          AssignData (arg, &d);
      }

      D_Temp    (arg) = F_False;
      D_Trapped (arg) = F_False;
    }


    /* Push null descriptors for the local variables. */

    locals = sp + 1;
    for (i = 0; i < function -> num_locals; i ++) {
      arg = push ( );
      D_Type    (arg) = T_Null;
      D_Temp    (arg) = F_False;
      D_Trapped (arg) = F_False;
      D_Pointer (arg) = NULL;
    }


    /* Call the function.  If the function fails then show the stack. */

    if (execute (function -> cs, locals, args) != -1) {
      fprintf (stderr, "%s:%u: ", *strlit (curr_file_num), curr_line_num);
      fprintf (stderr, "%s (", function -> name);
      for (i = 0; i < function -> num_args; i ++)
          fprintf (stderr, "%s%s", i ? "," : "", D_TypeName (args + i));
      fprintf (stderr, ")\n");
      top_of_stack = old_top;
      return 1;
    }

    top_of_stack = old_top;

    d_printf ("freeing locals: ");
    d_printf ("%d + %d\n", function -> num_args, function -> num_locals);
    for (i = 0; i < function -> num_args + function -> num_locals; i ++)
      FreeData (pop ( ));

    RecycleData (pop ( ));

    result = push ( );
    *result = *ret_val;

    d_printf ("rtn ans =\n");
    d_PrintData (result);

    return 0;
}


/************************************************************************
 * Function:      intrinsic_call                                  *
 *                                                    *
 * Description:   Calls the intrinsic function whose index and arguments      *
 *          are on the top of the stack.  The parameter list is   *
 *          adjusted as in the case of a normal function call.    *
 *          However, a special case is made since an intrinsic    *
 *          function may take a variable number of arguments.  The      *
 *          arguments are not dereferenced.                       *
 ************************************************************************/

static int intrinsic_call (object, num_args)
    descriptor *object;
    int           num_args;
{
    int           i;
    int           nargs;
    int           index;
    int           num_passed;
    descriptor *arg;
    descriptor *result;



    /* If the function accepts a fixed number of arguments then set up the
       stack by pushing or popping extra descriptors. */

    if ((nargs = functab [index = D_Intrinsic (object)].num_args) >= 0) {


      /* Remove any extra arguments. */

      if (nargs < num_args)
          for (i = nargs; i < num_args; i ++)
            RecycleData (pop ( ));


      /* Add any necessary arguments. */

      else if (nargs > num_args)
          for (i = num_args; i < nargs; i ++) {
            arg = push ( );
            D_Type    (arg) = T_Null;
            D_Temp    (arg) = F_False;
            D_Trapped (arg) = F_False;
            D_Pointer (arg) = NULL;
          }

      num_passed = nargs;

    } else
      num_passed = num_args;


    /* Call the intrinsic function. */

    if (functab [index].func (num_passed))
      return 1;

    ret_val = pop ( );
    RecycleData (pop ( ));

    result = push ( );
    *result = *ret_val;
    return 0;
}


/************************************************************************
 * Function:      matrix_index                                    *
 *                                                    *
 * Description:   Indexes the descriptor whose indices are on the top of      *
 *          the stack and places the result on the stack.  The    *
 *          following types and indices are legal, where a vector *
 *          is a matrix with either a single row or column:       *
 *                                                    *
 *          scalar     (1)   -> scalar                      *
 *          scalar     (1,1) -> scalar                      *
 *          row-vector (x)   -> row-vector                        *
 *          row_vector (x,1) -> row-vector                        *
 *          col-vector (x)   -> col-vector                        *
 *          col-vector (1,x) -> col-vector                        *
 *          matrix     (x)   -> col-vector                        *
 *          matrix     (x,y) -> matrix                      *
 *                                                    *
 *          An index must either be a scalar or a vector whose    *
 *          elements are contiguous and increasing.  The result   *
 *          will be a trapped variable.  The trap handler will    *
 *          verify that the object to be assigned must be of the  *
 *          same type and size.                             *
 ************************************************************************/

static int matrix_index (object, num_args)
    descriptor *object;
    int           num_args;
{
    Matrix  a;
    Matrix  b;
    Matrix  index;
    descriptor *arg2;
    descriptor *arg1;
    descriptor *result;
    descriptor *orig;
    descriptor    temp;
    double  value;
    int           type_error;
    int           status;
    unsigned      i;
    unsigned      dim;
    unsigned      nrows;
    unsigned      ncols;
    unsigned      s_row;
    unsigned      s_col;
    unsigned      e_row;
    unsigned      e_col;


    /* Check the number of arguments. */

    if (num_args == 0 || num_args > 2) {
      rterror ("incorrect number of indices for %s", D_TypeName (object));
      return 1;
    }


    /* Set up the stack. */

    arg2 = num_args == 2 ? pop ( ) : NULL;
    arg1 = pop ( );
    result = top ( );
    temp = *result;
    object = &temp;
    orig = object;
    object = deref (object);


    /* Initialize the arguments. */

    status = 0;
    type_error = F_False;
    arg1 = CoerceData (deref (arg1), T_Double);
    if (arg2)
      arg2 = CoerceData (deref (arg2), T_Double);

    s_row = e_row = s_col = e_col = 0;


    /* Compute the starting and ending row indices. */

    switch (D_Type (arg1)) {
    case T_Double:
      s_row = e_row = *D_Double (arg1);
      break;


    case T_Matrix:
      index = D_Matrix (arg1);
      if (Mrows (index) == 1) {
          s_row = mdata (index, 1, 1);
          e_row = mdata (index, 1, Mcols (index));
          for (i = 2; i <= Mcols (index); i ++)
            if (mdata (index, 1, i) != s_row + i - 1) {
                rterror ("improper row index in index expression");
                status = 1;
                break;
            }

      } else if (Mcols (index) == 1) {
          s_row = mdata (index, 1, 1);
          e_row = mdata (index, Mrows (index), 1);
          for (i = 2; i <= Mrows (index); i ++)
            if (mdata (index, i, 1) != s_row + i - 1) {
                rterror ("improper row index in index expression");
                status = 1;
                break;
            }

      } else {
          rterror ("matrix used as row index in index expression");
          status = 1;
      }
      break;


    case T_Row:
      if (D_Type (object) == T_Double)
          s_row = e_row = 1;
      else if (D_Type (object) == T_Matrix) {
          s_row = 1;
          e_row = Mrows (D_Matrix (object));
      }
      break;


    default:
      TypeError ("in index expression", arg1, NULL, NULL, F_False);
      type_error = F_True;
      break;
    }


    /* Compute the starting and ending column indices. */

    if (arg2 && type_error == F_False && status == 0) {
      switch (D_Type (arg2)) {
      case T_Double:
          s_col = e_col = *D_Double (arg2);
          break;


      case T_Matrix:
          index = D_Matrix (arg2);
          if (Mrows (index) == 1) {
            s_col = mdata (index, 1, 1);
            e_col = mdata (index, 1, Mcols (index));
            for (i = 2; i <= Mcols (index); i ++)
                if (mdata (index, 1, i) != s_col + i - 1) {
                  rterror ("improper column index in index expression");
                  status = 1;
                  break;
                }

          } else if (Mcols (index) == 1) {
            s_col = mdata (index, 1, 1);
            e_col = mdata (index, Mrows (index), 1);
            for (i = 2; i <= Mrows (index); i ++)
                if (mdata (index, i, 1) != s_col + i - 1) {
                  rterror ("improper column index in index expression");
                  status = 1;
                  break;
                }

          } else {
            rterror ("matrix used as column index in index expression");
            status = 1;
          }
          break;


      case T_Row:
          if (D_Type (object) == T_Double)
            s_col = e_col = 1;
          else if (D_Type (object) == T_Matrix) {
            s_col = 1;
            e_col = Mcols (D_Matrix (object));
          }
          break;


      default:
          TypeError ("in index expression", arg2, NULL, NULL, F_False);
          type_error = F_True;
          break;
      }
    } else
      s_col = e_col = 1;


    /* Perform the indexing. */

    if (type_error == F_False && status == 0) {
      switch (D_Type (object)) {
      case T_Int:
      case T_Byte:
      case T_Double:
          if (s_row != 1 || e_row != 1) {
            rterror ("row index is out of range (must be one)");
            status = 1;

          } else if (s_col != 1 || e_col != 1) {
            rterror ("column index is out of range (must be one)");
            status = 1;


          /* If the object cannot be assignable then we can just copy the
             object. */

          } else if (!D_Trapped (object) && D_Type (orig) != T_Variable) {
            CreateData (result, NULL, NULL, T_Double);
            *D_Double (result) = *D_Double (object);


          /* If the object is not trapped then change the double into a
             matrix with one row and column.  The result is a submatrix of
             the new matrix.  This way, the matrix library does the
             reference counting for us. */

          } else if (D_Trapped (object) == F_False) {
            value = *D_Double (object);
            FreeData (object);
            CreateData (object, NULL, NULL, T_Matrix, 1, 1);

            a = D_Matrix (object);
            sdata (a, 1, 1) = value;
            D_Temp (object) = F_False;

            b = CreateSubsectionMatrix (a, 1, 1, 1, 1);
            D_Type        (result) = T_Matrix;
            D_Temp        (result) = F_False;
            D_Trapped (result) = AddTrap (submatrix_assignment);
            D_Matrix  (result) = b;


          /* Otherwise, we don't need to do anything (I think).  Note that
             all bytes and integers are trapped, so this case will be
             executed. */

          } else {
            /* Result should be the object itself, as located on the
               interpreter stack, as opposed to our stack. */
          }
          break;


      case T_Matrix:
          a = D_Matrix (object);
          nrows = Mrows (a);
          ncols = Mcols (a);


          /* Handle a missing second argument. */

          if (!arg2)


            /* If only one argument was specified and the object is a row
               vector then swap the indices. */

            if (Mrows (a) == 1) {
                dim = s_row;
                s_row = s_col;
                s_col = dim;
                dim = e_row;
                e_row = e_col;
                e_col = dim;


            /* If only one argument was specified and the object is a
               matrix then return the entire column. */

            } else if (Mcols (a) != 1) {
                s_col = s_row;
                e_col = e_row;
                s_row = 1;
                e_row = Mrows (a);
            }


          /* Check the indices. */

          if (s_row < 1 || s_row > nrows) {
            rterror ("row index is out of range (1 .. %u)", nrows);
            status = 1;
          } else if (e_row < s_row || e_row > nrows) {
            rterror ("row index is out of range (1 .. %u)", nrows);
            status = 1;
          } else if (s_col < 1 || s_col > ncols) {
            rterror ("column index is out of range (1 .. %u)", ncols);
            status = 1;
          } else if (e_col < s_col || e_col > ncols) {
            rterror ("column index is out of range (1 .. %u)", ncols);
            status = 1;

          } else {


            /* Compute the subsection. */

            if (IsCompact (a)) {
                b = MakeFullFromCompact (a);
                DestroyMatrix (a);
                D_Matrix (object) = a = b;
            }

            b = CreateSubsectionMatrix (a, s_row, s_col, e_row, e_col);

            if (b) {
                D_Type    (result) = T_Matrix;
                D_Temp    (result) = F_False;
                D_Trapped (result) = AddTrap (submatrix_assignment);
                D_Matrix  (result) = b;
            } else
                status = 1;
          }
          break;
      }
    }


    /* Clean up and return. */

    RecycleData (arg2);
    RecycleData (arg1);
    RecycleData (object);
    d_printf ("index ans =\n");
    d_PrintData (result);

    return type_error == F_True || status != 0;
}


/************************************************************************
 * Function:      array_index                               *
 *                                                    *
 * Description:   Indexes the array descriptor whose index is on the top      *
 *          of the stack and places the result on the stack.  The *
 *          following types are legal:                      *
 *                                                    *
 *          array (double) -> element (array indexing)            *
 *          array (vector) -> array   (subarray creation)         *
 *                                                    *
 *          An attempt is first made to coerce the index to a     *
 *          double value.                                   *
 ************************************************************************/

static int array_index (object, num_args)
    descriptor *object;
    int           num_args;
{
    Array   array;
    Matrix  index;
    void       *ptr;
    descriptor *arg;
    descriptor *result;
    descriptor    temp;
    unsigned      i;
    unsigned      end;
    unsigned      start;
    int           len;
    int           type;
    int           handler;
    int           type_error;
    int           status;


    /* Check the number of arguments. */

    if (num_args != 1) {
      rterror ("incorrect number of indices for array");
      return 1;
    }


    /* Set up the stack. */

    arg = pop ( );
    result = top ( );
    temp = *result;
    object = &temp;
    object = deref (object);


    status = 0;
    type_error = F_False;

    start = end = 0;
    arg = CoerceData (deref (arg), T_Double);
    array = D_Array (object);


    switch (D_Type (arg)) {
    case T_Double:
      start = end = *D_Double (arg);
      break;


    case T_Matrix:
      index = D_Matrix (arg);
      if (Mrows (index) == 1) {
          start = mdata (index, 1, 1);
          end = mdata (index, 1, Mcols (index));
          for (i = 2; i <= Mcols (index); i ++)
            if (mdata (index, 1, i) != start + i - 1) {
                rterror ("improper array index in index expression");
                status = 1;
                break;
            }

      } else if (Mcols (index) == 1) {
          start = mdata (index, 1, 1);
          end = mdata (index, Mrows (index), 1);
          for (i = 2; i <= Mrows (index); i ++)
            if (mdata (index, i, 1) != start + i - 1) {
                rterror ("improper array index in index expression");
                status = 1;
                break;
            }

      } else {
          rterror ("matrix used as array index in index expression");
          status = 1;
      }
      break;


    case T_Row:
      start = 1;
      end = array -> length;
      break;


    default:
      type_error = F_True;
      break;
    }


    if (type_error == F_False && status == 0) {
      if (array -> length == 0) {
          rterror ("index is out of range (no valid array members)");
          status = 1;
      } else if (start < 1 || start > array -> length) {
          rterror ("index is out of range (1 .. %u)", array -> length);
          status = 1;
      } else if (end < start || end > array -> length) {
          rterror ("index is out of range (1 .. %u)", array -> length);
          status = 1;

      } else if (start == end) {
          ptr = (void *) ((char *) array -> ptr + start * array -> elt_size);
          D_Type    (result) = array -> type;
          D_Temp    (result) = F_False;
          D_Trapped (result) = array -> handler;
          D_Pointer (result) = ptr;

      } else {
          start --;     /* all arrays are unit offset */
          ptr = (void *) ((char *) array -> ptr + start * array -> elt_size);
          type = array -> type;
          len = end - start;
          handler = array -> handler;
          CreateData (result, NULL, NULL, T_Array, ptr, type, len, handler);
          D_Array (result) -> elt_size = array -> elt_size;
          D_Trapped (result) = D_Trapped (object);
      }
    }


    if (type_error == F_True)
      TypeError ("in index expression", arg, NULL, NULL, F_False);


    RecycleData (arg);
    RecycleData (object);
    d_printf ("index ans =\n");
    d_PrintData (result);

    return type_error == F_True || status != 0;
}


/************************************************************************
 * Function:      function_search                                 *
 *                                                    *
 * Description:   Searches the global symbol table for a symbol with the      *
 *          same name as the specified null descriptor.  If such a      *
 *          symbol exists and is a function, then it is used as the     *
 *          basis for a function call.  Otherwise, if there is a  *
 *          file in the include-search path with the same name then     *
 *          it is included and the search is made again in the    *
 *          global symbol table.                            *
 ************************************************************************/

static int function_search (object, num_args)
    descriptor *object;
    int           num_args;
{
    int            idx;
    ste           *s;
    char    *name;
    char    *file;
    descriptor    *d;
    static char *path;


    if (D_Type (object) != T_Variable) {
      TypeError ("function call to", NULL, object, NULL, F_False);
      return 1;
    }

    idx = D_Variable (object) - varp;

    if (idx < 0 || (top_of_stack && idx > top_of_stack -> num_locals)) {
      TypeError ("function call to", NULL, object, NULL, F_False);
      return 1;
    }
      
    if (top_of_stack) {
      name = top_of_stack -> local_names [idx];
      if ((s = st_lookup (&var_st, name))) {
          d = global (s -> idx);
          d = deref (d);

          switch (D_Type (d)) {
          case T_Function:
            return function_call (d, num_args);


          case T_Intrinsic:
            return intrinsic_call (d, num_args);


          default:
            d = deref (d);
            TypeError ("function call to", NULL, d, NULL, F_False);
            return 1;
          }
      }
    } else
      name = st_index (&var_st, idx) -> name;


    if (!path)
      path = getenv ("BURLAP_PATH");

    if ((file = pathsearch (path, name, ".b", F_False))) {
      printf ("including %s\n", file);
      bfinclude (file);
      if ((s = st_lookup (&var_st, name))) {
          d = global (s -> idx);
          d = deref (d);

          switch (D_Type (d)) {
          case T_Function:
            return function_call (d, num_args);


          case T_Intrinsic:
            return intrinsic_call (d, num_args);


          default:
            d = deref (d);
            TypeError ("function call to", NULL, d, NULL, F_False);
            return 1;
          }
      }
    }

    TypeError ("function call to", NULL, deref (object), NULL, F_False);
    return 1;
}


/************************************************************************
 * Function:      external_call                                   *
 *                                                    *
 * Description:   Calls the external C function pointed to by the       *
 *          specified descriptor.  This mechanism is used to call *
 *          the set-up and stress functions of the built-in FElt  *
 *          elements.  The first argument must be an element and  *
 *          the second argument, if specified, must be an integer.      *
 ************************************************************************/

static int external_call (object, num_args)
    descriptor *object;
    int           num_args;
{
    void      **ptr;
    descriptor *arg1;
    descriptor *arg2;
    descriptor *result;
    descriptor    temp;
    int           type_error;
    int           mode;
    int           i;


    if (num_args < 1) {
      rterror ("incorrect number of arguments for %s", D_TypeName (object));
      return 1;
    }

    for (i = 2; i < num_args; i ++)
      RecycleData (pop ( ));

    arg2 = num_args >= 2 ? pop ( ) : NULL;
    result = top ( );
    temp = *result;
    arg1 = &temp;


    type_error = F_False;
    arg1 = CoerceData (deref (arg1), T_Double);

    if (arg2)
      arg2 = CoerceData (deref (arg2), T_Int);


    if (D_Type (arg1) == T_Element) {
      CreateData (result, NULL, NULL, T_Double);
      ptr = (void **) D_Pointer (arg1);
      mode = arg2 && D_Type (arg2) == T_Int ? *D_Int (arg2) : 0;
      *D_Double (result) = (*D_External (object)) (*ptr, mode);
    } else
      type_error = F_True;


    if (type_error == F_True)
      TypeError ("in C function call", arg1, arg2, NULL, F_False);


    RecycleData (arg1);
    RecycleData (arg2);

    return type_error == F_True;
}


/************************************************************************
 * Function:      apply_op                                  *
 *                                                    *
 * Description:   Pops the descriptors on the top of the stack and      *
 *          performs a function or array application.  The        *
 *          following types are legal:                      *
 *                                                    *
 *          null      (...)  (function search)              *
 *          array     (...)  (array indexing)               *
 *          double    (...)  (scalar indexing)              *
 *          matrix    (...)  (matrix indexing)              *
 *          function  (...)  (user-defined function call)         *
 *          intrinsic (...)  (intrinsic function call)            *
 *          external  (...)  (external C function call)           *
 *                                                    *
 *          No coercion is performed since the result of an index *
 *          is a variable.                                  *
 ************************************************************************/

int apply_op ( )
{
    int           num_args;
    descriptor *object;


    num_args = fetch (pc ++).ival;
    object = ntop (num_args);
    object = deref (object);


    switch (D_Type (object)) {
    case T_Null:
      return function_search (ntop (num_args), num_args);


    case T_Array:
      return array_index (object, num_args);


    case T_Int:
    case T_Byte:
    case T_Double:
    case T_Matrix:
      return matrix_index (object, num_args);


    case T_Function:
      return function_call (object, num_args);


    case T_Intrinsic:
      return intrinsic_call (object, num_args);


    case T_External:
      return external_call (object, num_args);


    default:
      TypeError ("function call to", NULL, object, NULL, F_False);
      return 1;
    }
}


/************************************************************************
 * Function:      rtn_op                                          *
 *                                                    *
 * Description:   Returns from a function call.  If the descriptor on the     *
 *          top of the stack is not a global variable (i.e. it is *
 *          local to the current function) then the descriptor is *
 *          dereferenced.  The descriptor is saved in a static    *
 *          location and a termination code is returned so that   *
 *          the current stack frame will be erased and execution  *
 *          will return to the caller.                      *
 ************************************************************************/

int rtn_op ( )
{
    descriptor *d;


    d = pop ( );
    ret_val = &ret_obj;

    if (!is_global (d)) {
      d_printf ("returning =\n");
      d_PrintData (d);
      d = deref (d);
      D_Temp (d) = F_False;
      D_Type     (ret_val) = T_Null;
      D_Temp     (ret_val) = F_False;
      D_Trapped  (ret_val) = F_False;
      D_Pointer  (ret_val) = NULL;
      AssignData (ret_val, &d);
      D_Temp     (ret_val) = F_True;
    } else
      *ret_val = *d;

    d_printf ("returning = %p (%s)\n", D_Pointer (d), D_TypeName (d));
    d_printf ("rtn\n");
    return -1;
}

Generated by  Doxygen 1.6.0   Back to index