Logo Search packages:      
Sourcecode: yorick-yeti version File versions  Download package

yeti_misc.c

/*
 * yeti_misc.c --
 *
 *    Implement miscellaneous builtin functions in Yeti.
 *
 *-----------------------------------------------------------------------------
 *
 *    Copyright (C) 1999-2006 Eric Thiébaut.
 *
 *    This file is part of Yeti.
 *
 *    Yeti is  free software;  you can redistribute  it and/or  modify it
 *    under  the terms of  the GNU  General Public  License version  2 as
 *    published by the Free Software Foundation.
 *
 *    Yeti 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  Yeti (file "COPYING"  in the top source  directory); if
 *    not, write to  the Free Software Foundation, Inc.,  51 Franklin St,
 *    Fifth Floor, Boston, MA 02110-1301 USA
 *
 *-----------------------------------------------------------------------------
 *
 * History:
 *    $Id: yeti_misc.c,v 1.6 2007/05/01 20:23:39 eric Exp $
 *    $Log: yeti_misc.c,v $
 *    Revision 1.6  2007/05/01 20:23:39  eric
 *     - Fixed some compiler warnings.
 *
 *    Revision 1.5  2007/04/24 07:58:07  eric
 *     - The `symbol_names` function can now specifically select
 *       lists, hash tables and/or auto-loaded functions.
 *
 *    Revision 1.4  2006/12/05 07:19:51  eric
 *     - Renamed built-in `typeIDof` as `identof`.
 *
 *    Revision 1.3  2006/07/19 17:33:11  eric
 *     - New built-in function insure_temporary.
 *
 *    Revision 1.2  2006/07/19 14:50:13  eric
 *     - Copyright notice updated.
 *     - Many new built-in functions: is_scalar, is_vector, etc.
 *     - Changes in Yeti initialization.
 *
 *    Revision 1.1  2005/05/24 13:24:44  eric
 *    Initial revision
 */

#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <float.h>

#include <yapi.h>
#include <yio.h>
#include <pstdio.h>
#include <hlevel.h>
#include <xfancy.h>

#include "config.h"
#include "yeti.h"

/* Shall we use faster complex division? (depends Yorick version) */
#if (YORICK_VERSION_MAJOR >= 2)
# define USE_FASTER_DIVIDE_Z 0
#elif (YORICK_VERSION_MAJOR == 1 && YORICK_VERSION_MINOR >= 6)
# define USE_FASTER_DIVIDE_Z 0
#elif (YORICK_VERSION_MAJOR == 1 && YORICK_VERSION_MINOR == 5 &&  YORICK_VERSION_MICRO >= 15)
# define USE_FASTER_DIVIDE_Z 0
#else
# define USE_FASTER_DIVIDE_Z 1
#endif

/* Built-in functions defined in this file: */
extern BuiltIn Y__yeti_init;
extern BuiltIn Y_mem_base, Y_mem_copy, Y_mem_peek;
extern BuiltIn Y_window_geometry;
extern BuiltIn Y_set_alarm;
extern BuiltIn Y_get_encoding;
extern BuiltIn Y_symbol_exists, Y_symbol_names;
extern BuiltIn Y_unref, Y_swap;
extern BuiltIn Y_get_includes, Y_current_include;
extern BuiltIn Y_filepath;
extern BuiltIn Y_identof, Y_nrefsof;
extern BuiltIn Y_smooth3;
#if PROVIDE_IS_LIST
extern BuiltIn Y_is_list;
#endif /* PROVIDE_IS_LIST */
extern BuiltIn Y_is_scalar, Y_is_vector, Y_is_matrix;
extern BuiltIn Y_is_integer, Y_is_real, Y_is_complex, Y_is_string;
extern BuiltIn Y_is_numerical;

#if 0
/* Yorick functions defined elsewhere: */
PLUG_API void BuildDimList(Symbol *stack, int argc);  /* ops3.c */
PLUG_API DataBlock *ForceToDB(Symbol *s);             /* ops3.c */
#endif

/*---------------------------------------------------------------------------*/
/* INITIALIZATION OF YETI */

/* The order of parsing of startup files is as follows:
 *   1. Yorick startup scripts: paths.i, std.i, graph.i, matrix.i, fft.i;
 *   2. Package(s) startup scripts: yeti.i, ...;
 *   3. Yorick post-initialization: stdx.i  (just call 'set_path').
 *
 * It is therefore possible to fool Yorick post-initialization by
 * changing builtin function 'set_path' to something else.
 *
 * Until step 3, search path include the launch directory.
 * Built-in 'set_site' function is called at statup by 'std.i' to
 * define global variables:
 *   Y_LAUNCH    the directory containing the Yorick executable
 *   Y_VERSION   Yorick's version as "MAJOR.MINOR.MICRO"
 *   Y_HOME      Yorick's "site directory" with machine dependent files
 *   Y_SITE      Yorick's "site directory" with machine independent files
 */

/* Symbols defined in std0.c: */
extern char *yLaunchDir;
extern int yBatchMode;

/* Symbols defined in ops0.c: */
extern void *BuildResult2(Operand *l, Operand *r);

/* Symbols defined in ycode.c: */
extern char *yHomeDir;  /* e.g., "/usr/local/lib/yorick/1.5"   */
extern char *ySiteDir;  /* e.g., "/usr/local/share/yorick/1.5" */
extern char *yUserPath; /* e.g., ".:~/yorick:~/Yorick"         */

#ifndef PLUG_IN
/* Yeti default's: */
static char *default_path = (char *)0;
static char *yeti_home = YETI_HOME;

static void globalize_function(const char *name, BuiltIn *value, int quiet);
static void append_to_default_path(const char *part1, const char *part2);
static void set_path(int argc);
#endif /* PLUG_IN */
static void globalize_string(const char *name, const char *value);


#if USE_FASTER_DIVIDE_Z
static void fast_DivideZ(Operand *l, Operand *r);
#endif /* USE_FASTER_DIVIDE_Z */

void Y_yeti_init(int argc)
{
  static int first_time = 1;
  char buf[128];

  if (first_time) {
    /* This is the first time _yeti_init has been called. */

#ifndef PLUG_IN
    /* Setup default path (for Yeti + Yorick); note that Yorick's
       "contrib" directory is always left at the end. */
    default_path = (yUserPath ? p_strcpy(yUserPath) : (char *)0);
    append_to_default_path(ySiteDir, "i");
    if (yLaunchDir && yLaunchDir[0]) {
      int offset, length = strlen(yLaunchDir);
      char *pathtmp = p_malloc(length + 1);
      memcpy(pathtmp, yLaunchDir, length + 1);
      while (length > 0 && pathtmp[length - 1] == '/') {
      --length;
      }
      pathtmp[length] = 0;
      offset = length;
      while (offset > 0 && pathtmp[offset - 1] != '/') {
      --offset;
      }
      if (strcmp(pathtmp + offset, "launch")) {
      /* Tail of launch directory does not match "launch": assume
         execution from source directory and append launch directory
         to list of search paths. */
      append_to_default_path(pathtmp, (char *)0);
      
      } else {
      /* Tail of launch directory does match "launch": assume standard
         installation. */
      pathtmp[offset] = 0;
      append_to_default_path(pathtmp, "plugins");
      append_to_default_path(pathtmp, "i");
      }
      p_free(pathtmp);
    } else {
      append_to_default_path(yeti_home, "plugins");
      append_to_default_path(yeti_home, "i");
    }
    append_to_default_path(ySiteDir, "contrib");

    /* Replace built-in function 'set_path' by Yeti's version. */
    globalize_function("set_path", set_path, 1);
#endif /* PLUG_IN */

#if USE_FASTER_DIVIDE_Z
    /* Replace complex division by faster code. */
    complexOps.Divide = fast_DivideZ;
#endif /* USE_FASTER_DIVIDE_Z */

    first_time = 0;
  }

  /* Restore global variables. */
#ifndef PLUG_IN
  globalize_string("YETI_HOME", yeti_home);
#endif /* not PLUG_IN */
  sprintf(buf, "%d.%d.%d",
        YETI_VERSION_MAJOR, YETI_VERSION_MINOR, YETI_VERSION_MICRO);
  globalize_string("YETI_VERSION", buf);
  if (! CalledAsSubroutine()) {
    yeti_push_string_value(buf);
  }
}

#ifndef PLUG_IN
static void set_path(int argc)
{
  char *path;
  if (argc < 1) path = default_path;
  else if (argc == 1) path = YGetString(sp);
  else { YError("set_path takes at most one argument"); path = 0; }
  YpSetPaths(path);
}

static void append_to_default_path(const char *part1, const char *part2)
{
  char *ptr, *path;
  int len;
#define STRLEN(str) ((str) && (str)[0] ? strlen(str) : 0)
  int len0 = STRLEN(default_path);
  int len1 = STRLEN(part1);
  int len2 = STRLEN(part2);
#undef STRLEN

  /* Remove trailing '/' from PART1 and PART2 */
  while (len1 > 0 && part1[len1 - 1] == '/') --len1;
  while (len2 > 0 && part2[len2 - 1] == '/') --len2;

  /* Remove leading '/' from PART2. */
  while (len2 > 0 && part2[0] == '/') {
    --len2;
    ++part2;
  }

  if (len1 <= 0 && len2 <= 0) return; /* nothing to do */

  /* Append directory path to list of search pathes. */
  len = (len0 > 0 ? len0 + 1 : 0); /* plus 1 for the ':' separator */
  if (len1 > 0) len += len1 + 1; /* plus 1 for the '/' separator */
  if (len2 > 0) len += len2 + 1; /* plus 1 for the '/' separator */
  path = p_malloc(len + 1);
  ptr = path;
  if (len0 > 0) {
    memcpy(ptr, default_path, len0);
    ptr[len0] = ':';
    ptr += len0 + 1;
  }
  if (len1 > 0) {
    memcpy(ptr, part1, len1);
    ptr[len1] = '/';
    ptr += len1 + 1;
  }
  if (len2 > 0) {
    memcpy(ptr, part2, len2);
    ptr[len2] = '/';
    ptr += len2 + 1;
  }
  path[len] = 0;
  if (default_path) p_free(default_path);
  default_path = path;  
}

static void globalize_function(const char *name, BuiltIn *value, int quiet)
{
  long index = Globalize(name, 0L);
  DataBlock *old;
  if (globTab[index].ops == &dataBlockSym) {
    /* Symbol currently stored in global table is a data block. */
    old = globTab[index].value.db;
    if (old->ops == &builtinOps) {
      /* Previous symbol is a builtin function. */
      if (((BIFunction *)old)->function == value) {
      /* Nothing to do. */
      return;
      } else if (old->references == 0) {
      /* Just overwrite pointer to function. */
      ((BIFunction *)old)->function = value;
      ((BIFunction *)old)->index = index;
      return;
      } else if (quiet) {
      /* This is a hack to avoid printing of a warning when
         unreferencing a builtin function; the cost is that the memory
         block allocated for the builtin function is lost forever (but
         that's 16 bytes on a 32-bit machine). */
      globTab[index].value.db = (DataBlock *)NewBIFunction(value, index);
      return;
      }
    }
  } else {
    /* Symbol currently stored in global table is not a data block. */
    old = (DataBlock *)0;
  }
  globTab[index].ops = &intScalar; /* in case of interrupt */
  globTab[index].value.db = (DataBlock *)NewBIFunction(value, index);
  globTab[index].ops = &dataBlockSym;
  Unref(old);
}
#endif /* not PLUG_IN */

static void globalize_string(const char *name, const char *value)
{
  long index = Globalize(name, 0L);
  DataBlock *old = (globTab[index].ops == &dataBlockSym ?
                globTab[index].value.db : 0);
  Array *obj = NewArray(&stringStruct, (Dimension *)0);
  globTab[index].ops = &intScalar; /* in case of interrupt */
  globTab[index].value.db = (DataBlock *)obj;
  globTab[index].ops = &dataBlockSym;
  Unref(old);
  obj->value.q[0] = p_strcpy(value);
}

#if USE_FASTER_DIVIDE_Z
/* Faster code for complex division (save 1 division out of 3 with
   respect to original Yorick DivideZ code resulting in ~33% faster
   code). */
static void fast_DivideZ(Operand *l, Operand *r)
{
  const double one=1.0;
  double lr, li, rr, ri;          /* watch out for dst==lv or rv */
  double *lv, *rv, *dst;
  size_t i, n;

  dst = BuildResult2(l, r);
  if (! dst) YError("operands not conformable in binary /");
  n = l->type.number;
  lv = l->value;
  rv = r->value;
  for (i=0 ; i<n ; ++i) {
    lr= lv[2*i];  li= lv[2*i+1];
    rr= rv[2*i];  ri= rv[2*i+1];
    if ((rr>0?rr:-rr)>(ri>0?ri:-ri)) { /* be careful about overflow... */
      ri /= rr;
      rr = one/((one + ri*ri)*rr);
      dst[2*i] = (lr + li*ri)*rr;
      dst[2*i+1] = (li - lr*ri)*rr;
    } else {
      rr /= ri; /* do not care of division by zero here, since Yorick
               catches floating point exceptions */
      ri = one/((one + rr*rr)*ri);
      dst[2*i] = (lr*rr + li)*ri;
      dst[2*i+1] = (li*rr - lr)*ri;
    }
  }
  PopTo(l->owner);
}
#endif /* USE_FASTER_DIVIDE_Z */

/*---------------------------------------------------------------------------*/
/* MEMORY HACKING ROUTINES */

static void *get_address(Symbol *s);
static void build_dimlist(Symbol *stack, int nArgs);
static Operand *form_operand_db(Symbol *owner, Operand *op);

void Y_mem_base(int argc)
{
  Array *array;
  Symbol *s;
  OpTable *ops;
  long value;

  if (argc != 1) YError("mem_base takes exactly 1 argument");

  /*** based on Address() in ops3.c ***/

  /* Taking the address of a variable X, where X is a scalar constant,
     causes X to be replaced by an Array.  This is obscure, but there is no
     other obvious way to get both the efficiency of the scalar Symbols,
     AND the reference-count safety of Yorick pointers.  Notice that if the
     address of a scalar is taken, the efficient representation is lost.  */
  if (sp->ops != &referenceSym) {
  bad_arg:
    YError("expected a reference to an array object");
  }
  s = &globTab[sp->index];
  ops = s->ops;
  if (ops == &dataBlockSym) {
    array = (Array *)s->value.db;
  } else if (ops == &doubleScalar) {
    array = NewArray(&doubleStruct, (Dimension *)0);
    array->value.d[0] = s->value.d;
    s->value.db = (DataBlock *)array;
    s->ops = &dataBlockSym;
  } else if (ops == &longScalar) {
    array = NewArray(&longStruct, (Dimension *)0);
    array->value.l[0] = s->value.l;
    s->value.db = (DataBlock *)array;
    s->ops = &dataBlockSym;
  } else if (ops == &intScalar) {
    array = NewArray(&intStruct, (Dimension *)0);
    array->value.i[0] = s->value.i;
    s->value.db = (DataBlock *)array;
    s->ops = &dataBlockSym;
  } else {
    goto bad_arg;
  }
  if (! array->ops->isArray) goto bad_arg;
  value = (long)array->value.c;
  Drop(2);
  PushLongValue(value);
}

void Y_mem_copy(int argc)
{
  void *address;
  Symbol *s;

  if (argc != 2) YError("mem_copy takes exactly 2 arguments");
  address = get_address(sp-1);
  s = (sp->ops == &referenceSym) ? &globTab[sp->index] : sp;
  if (s->ops == &doubleScalar) {
    (void)memcpy(address, &(s->value.d), sizeof(double));
  } else if (s->ops == &longScalar) {
    (void)memcpy(address, &(s->value.l), sizeof(long));
  } else if (s->ops == &intScalar) {
    (void)memcpy(address, &(s->value.i), sizeof(int));
  } else if (s->ops == &dataBlockSym && s->value.db->ops->isArray) {
    Array *array = (Array *)s->value.db;
    (void)memcpy(address, array->value.c,
             array->type.number*array->type.base->size);
  } else {
    YError("unexpected non-array data");
  }
}

void Y_mem_peek(int argc)
{
  Symbol *s, *stack = sp-argc+1;
  StructDef *base;
  Array *array;
  void *address;

  if (argc < 2) YError("mem_peek takes at least 2 arguments");
  address = get_address(stack);
  s = stack+1;
  if (s->ops == &referenceSym) s = &globTab[s->index];
  if (s->ops != &dataBlockSym || s->value.db->ops != &structDefOps)
    YError("expected type definition as second argument");
  base = (StructDef *)s->value.db;
  if (base->dataOps->typeID < T_CHAR || base->dataOps->typeID > T_COMPLEX)
    YError("only basic data types are supported");
  build_dimlist(stack+2, argc-2);
  array = PushDataBlock(NewArray(base, tmpDims));
  memcpy(array->value.c, address, array->type.number*array->type.base->size);
}

static void *get_address(Symbol *s)
{
  if (s->ops == &referenceSym) s = &globTab[s->index];
#if 0 /* sizeof(int) != sizeof(size_t) on 64-bit machine */
  if (s->ops == &intScalar) return (void *)s->value.i;
#endif
  if (s->ops == &longScalar) return (void *)s->value.l;
  if (s->ops == &dataBlockSym) {
    Array *array = (Array *)s->value.db;
    if (array->ops->isArray && ! array->type.dims) {
#if 0 /* sizeof(int) != sizeof(size_t) on 64-bit machine */
      if (array->ops == &intOps) return (void *)array->value.i[0];
#endif
      if (array->ops == &longOps) return (void *)array->value.l[0];
      if (array->ops == &pointerOps) return array->value.p[0];
    }
  }
  YError("bad address (expecting integer or pointer scalar)");
  return 0; /* avoid compiler warning */
}

/* The following function is a pure copy of BuildDimList in 'ops3.c' of
   Yorick source code -- required to avoid plugin clash. */
static void build_dimlist(Symbol *stack, int nArgs)
{
  Dimension *tmp= tmpDims;
  tmpDims= 0;
  FreeDimension(tmp);

  while (nArgs--) {
    if (stack->ops==&referenceSym) ReplaceRef(stack);
    if (stack->ops==&longScalar) {
      if (stack->value.l<=0) goto badl;
      tmpDims= NewDimension(stack->value.l, 1L, tmpDims);
    } else if (stack->ops==&intScalar) {
      if (stack->value.i<=0) goto badl;
      tmpDims= NewDimension(stack->value.i, 1L, tmpDims);

    } else if (stack->ops==&dataBlockSym) {
      Operand op;
      form_operand_db(stack, &op);
      if (op.ops==&rangeOps) {
        Range *range= op.value;
        long len;
        if (range->rf || range->nilFlags || range->inc!=1)
          YError("only min:max ranges allowed in dimension list");
        len= range->max-range->min+1;
        if (len<=0) goto badl;
        tmpDims= NewDimension(len, range->min, tmpDims);

      } else if (op.ops->promoteID<=T_LONG &&
                 (!op.type.dims || !op.type.dims->next)) {
        long len;
        op.ops->ToLong(&op);
        if (!op.type.dims) {
          len= *(long *)op.value;
          if (len<=0) goto badl;
          tmpDims= NewDimension(len, 1L, tmpDims);
        } else {
          long *dim= op.value;
          long n= *dim++;
          if (n>10 || n>=op.type.number)
            YError("dimension list format [#dims, len1, len2, ...]");
          while (n--) {
            len= *dim++;
            if (len<=0) goto badl;
            tmpDims= NewDimension(len, 1L, tmpDims);
          }
        }

      } else if (op.ops!=&voidOps) {
        goto badl;
      }
    } else {
    badl:
      YError("bad dimension list");
    }
    stack++;
  }
}

/* The following function is a pure copy of FormOperandDB in 'ops0.c' of
   Yorick source code -- required to avoid plugin clash. */
static Operand *form_operand_db(Symbol *owner, Operand *op)
{
  DataBlock *db= owner->value.db;
  Operations *ops= db->ops;
  op->owner= owner;
  if (ops->isArray) {
    Array *array= (Array *)db;
    op->ops= ops;
    op->references= array->references;
    op->type.base= array->type.base;
    op->type.dims= array->type.dims;
    op->type.number= array->type.number;
    op->value= array->value.c;
  } else if (ops==&lvalueOps) {
    LValue *lvalue= (LValue *)db;
    StructDef *base= lvalue->type.base;
    if (lvalue->strider || base->model) {
      Array *array= FetchLValue(lvalue, owner);
      op->ops= array->ops;
      op->references= array->references;
      op->type.base= array->type.base;
      op->type.dims= array->type.dims;
      op->type.number= array->type.number;
      op->value= array->value.c;
    } else {
      op->ops= base->dataOps;
      op->references= 1;     /* NEVER try to use this as result */
      op->type.base= base;
      op->type.dims= lvalue->type.dims;
      op->type.number= lvalue->type.number;
      op->value= lvalue->address.m;
    }
  } else {
    op->ops= ops;
    op->references= db->references;
    op->type.base= 0;
    op->type.dims= 0;
    op->type.number= 0;
    op->value= db;
  }
  return op;
}

/*---------------------------------------------------------------------------*/
/* GIST WINDOW */

#ifndef GH_NDEVS
# define GH_NDEVS 8 /* max number of graphic windows in old Yorick */
#endif

extern BuiltIn Y_window_geometry;
void Y_window_geometry(int argc)
{
  int win;
  double *geom;
  XEngine *engine;
  GpXYMap *map;

  GpTransform *transform;
  double one_pixel, dpi, xbias, ybias, width, height;

  if (argc == 1) {
    if (YNotNil(sp)) {
      win = (int)YGetInteger(sp);
      if (win < 0 || win >= GH_NDEVS) YError("bad graphic window number");
    } else if ((win = GhGetPlotter()) < 0 || win >= GH_NDEVS) {
      PushDataBlock(RefNC(&nilDB));
      return;
    }
  } else {
    YError("window_geometry takes exactly one, possibly nil, argument");
  }

  /* NDC -> pixel coordinate transform:
   *   XPIX = (int)(XSCALE*XNDC + XOFFSET)
   *   YPIX = (int)(YSCALE*YNDC + YOFFSET)
   * with:
   *   XSCALE = ENGINE->map.x.scale    XOFFSET = ENGINE->map.x.offset - margin
   *   YSCALE = ENGINE->map.y.scale    YOFFSET = ENGINE->map.y.offset - margin
   * assuming:
   *   (XSCALE*XNDC + XOFFSET) >= 0
   *   (YSCALE*YNDC + YOFFSET) >= 0
   * the reverse transform is:
   *   XPIX <= XSCALE*XNDC + XOFFSET < XPIX + 1
   *   YPIX <= YSCALE*YNDC + YOFFSET < YPIX + 1
   * to avoid rounding errors we choose the middle of the interval:
   *   XNDC  =  (XPIX - XOFFSET + 0.5)/XSCALE  =  XBIAS + XPIX*ONE_PIXEL
   *   YNDC  =  (YPIX - YOFFSET + 0.5)/YSCALE  =  YBIAS - YPIX*ONE_PIXEL
   * with:
   *   ONE_PIXEL = 1.0/XSCALE = -1.0/YSCALE
   *       XBIAS = (0.5 - XOFFSET)*ONE_PIXEL
   *       XBIAS = (YOFFSET - 0.5)*ONE_PIXEL
   */

  engine = (XEngine *)ghDevices[win].display;
  if (engine) {
    map= &engine->e.map;
    transform = &(engine->e.transform);
    dpi = engine->dpi;
    one_pixel = 2.0/(map->x.scale - map->y.scale);
#define MARGIN(SIDE) (engine->SIDE##Margin)
    xbias = (MARGIN(left) - map->x.offset + 0.5)/map->x.scale;
    ybias = (MARGIN(top)  - map->y.offset + 0.5)/map->y.scale;
#undef MARGIN
#if (YORICK_VERSION_MAJOR == 1) && (YORICK_VERSION_MINOR <= 4)
    fprintf(stderr, "/* XEngine */ width=%d; height=%d;\nleftMargin=%d; topMargin=%d;\nx=%d; y=%d; \n",
          engine->width, engine->height,
          engine->leftMargin, engine->topMargin,
          engine->x, engine->y);
#else
    width = engine->wtop;
    height = engine->htop;
#endif
  } else {
    dpi = one_pixel = xbias = ybias = width = height = 0.0;
  }

  /* Build result array: [DPI, ONE_PIXEL, XBIAS, YBIAS, WIDTH, HEIGHT] */
  geom = YETI_PUSH_NEW_D(ynew_dim(6, NULL));
  geom[0] = dpi;
  geom[1] = one_pixel;
  geom[2] = xbias;
  geom[3] = ybias;
  geom[4] = width;
  geom[5] = height;
}

extern BuiltIn Y_window_exists;
void Y_window_exists(int argc)
{
  long n;
  if (argc != 1) YError("window_exists takes exactly one argument");
  n = YGetInteger(sp);
  PushIntValue(((n >= 0 && n < GH_NDEVS && ghDevices[n].display) ? 1 : 0));
}

extern BuiltIn Y_window_select;
void Y_window_select(int argc)
{
  int n;
  if (argc != 1) YError("window_select takes exactly one argument");
  n = (int)YGetInteger(sp);
  if (n >= 0 && n < GH_NDEVS && ghDevices[n].display) {
    GhSetPlotter(n);
    PushIntValue(1);
  } else {
    PushIntValue(0);
  }
}

extern BuiltIn Y_window_list;
void Y_window_list(int argc)
{
  long *p, i, n, dims[2];

  if (argc != 1 || YNotNil(sp)) {
    YError("window_list takes exactly one nil argument");
  }
  for (n=i=0 ; i<GH_NDEVS ; ++i) {
    if (ghDevices[i].display) {
      ++n;
    }
  }
  if (n >= 1) {
    dims[0] = 1;
    dims[1] = n;
    p = ypush_l(dims);
    for (n=i=0 ; i<GH_NDEVS ; ++i) {
      if (ghDevices[i].display) {
      p[n++] = i;
      }
    }
  } else {
    ypush_nil();
  }
}

/*---------------------------------------------------------------------------*/
/* ALARM CALLBACK */

static void check_symbol_name(const char *name);

typedef struct alarm_context alarm_context_t;
00729 struct alarm_context {
  alarm_context_t *next;
  Function *task;  /* pointer to function or NULL */
  long      index; /* index in globTab[] or -1 */
  double    time;
};

static alarm_context_t *alarm_next = 0;
static alarm_context_t *alarm_free = 0;

static void alarm_callback(void *context);

static void alarm_free_context(alarm_context_t *this)
{
  Function *task = this->task;
  alarm_next = this->next;
  this->task = 0; /* fix alloc below */
  this->next = alarm_free;
  /*if (task)*/ Unref(task);
}

static void alarm_callback(void *context)
{
  Function *task;
  alarm_context_t *this = (alarm_context_t *)context;
  
  if (! (task = this->task) && this->index >= 0) {
    Symbol *sym = &globTab[this->index];
    if (sym->ops == &dataBlockSym) {
      int typeID = sym->value.db->ops->typeID;
      if (typeID == T_FUNCTION || typeID == T_BUILTIN)
      task = (Function *)sym->value.db;
    }
  }
  this->task = 0;
  alarm_free_context(this);
  if (task) RunTaskNow(task); /* unref? */
}

static void check_symbol_name(const char *name)
{
  static int char_type[256], first_time = 1;
  int i;
  if (first_time) {
    char_type[0] = 0;
    for (i=1 ; i<256 ; ++i) char_type[i] = -1;
    char_type['_'] = 1;
    for (i='a' ; i<='z' ; ++i) char_type[i] = 1;
    for (i='A' ; i<='Z' ; ++i) char_type[i] = 1;
    for (i='0' ; i<='9' ; ++i) char_type[i] = 2;
    first_time = 0;
  }
  if (name) {
    unsigned char *s = (unsigned char *)name;
    if (char_type[*s++] == 1) {
      for (;;) {
      if ((i = char_type[*s++]) < 0) break;
      if (i == 0) return;
      }
    }
  }
  YError("invalid symbol's name");
}

void Y_set_alarm(int nargs)
{
  alarm_context_t  *this;
  alarm_context_t  *next = alarm_next;
  alarm_context_t **prev = &alarm_next;
  double secs, time;
  Function *task = 0;
  Symbol *s;
  Operand op;
  int typeID;
  long index = -1;
  char *name;


  if (nargs != 2) YError("set_alarm takes exactly 2 arguments");
  secs = YGetReal(sp - nargs + 1);
  time = p_wall_secs() + secs;
  s = sp - nargs + 2;
  if (! s->ops) YError("unexpected keyword argument");
  typeID = s->ops->FormOperand(s, &op)->ops->typeID;
  if (typeID == T_STRING) {
    if (op.type.dims) YError("expecting scalar string argument");
    name = *(char **)op.value;
    check_symbol_name(name);
    index = Globalize(name, 0L);
  } else if (typeID == T_FUNCTION || typeID == T_BUILTIN) {
    task = (Function *)s->value.db;
  } else {
    YError("expecting function or function name");
  }
 
  if (! alarm_free) {
    int i, n = 8;
    alarm_context_t *new = p_malloc(n*sizeof(alarm_context_t));
    new[--n].next = 0;
    for (i=0 ; i<n ; ++i) new[i].next = &new[i + 1];
    alarm_free = new;
  }
  this = alarm_free;
  this->index = index;
  this->task = 0;
  this->time = time;
  /* insert THIS into alarm_next list, kept in order of time */
  while (next && next->time <= time) {
    prev = &next->next;
    next = next->next;
  }
  alarm_free = alarm_free->next;
  this->next = next;
  *prev = this;

  if (task) this->task = Ref(task);
  
  p_set_alarm(secs, alarm_callback, this);
  PushDoubleValue(time); 
}

/*---------------------------------------------------------------------------*/
/* DATA ENCODING */

#include "prmtyp.h"

void Y_get_encoding(int argc)
{
  const char *name;
  static struct {
    const char *name;
    long        layout[32];
  } db[] = {
    {"alpha", {1,1,-1, 2,2,-1, 4,4,-1, 8,8,-1, 4,4,-1, 8,8,-1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"cray",  {1,1,1, 8,8,1, 8,8,1, 8,8,1, 8,8,1, 8,8,1,
             0,1,15,16,48,1,16384, 0,1,15,16,48,1,16384}},
    {"dec",   {1,1,-1, 2,2,-1, 4,4,-1, 4,4,-1, 4,4,-1, 8,8,-1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"i86",   {1,1,-1, 2,2,-1, 4,4,-1, 4,4,-1, 4,4,-1, 8,4,-1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"ibmpc", {1,1,-1, 2,2,-1, 2,2,-1, 4,2,-1, 4,2,-1, 8,2,-1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"mac",   {1,1,1, 2,2,1, 2,2,1, 4,2,1, 4,2,1, 8,2,1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"macl",  {1,1,1, 2,2,1, 2,2,1, 4,2,1, 4,2,1, 12,2,1,
             0,1,8,9,23,0,127, 0,1,15,32,64,1,16382}},
    {"sgi64", {1,1,1, 2,2,1, 4,4,1, 8,8,1, 4,4,1, 8,8,1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"sun",   {1,1,1, 2,2,1, 4,4,1, 4,4,1, 4,4,1, 8,8,1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"sun3",  {1,1,1, 2,2,1, 4,2,1, 4,2,1, 4,2,1, 8,2,1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"vax",   {1,1,-1, 2,1,-1, 4,1,-1, 4,1,-1, 4,1,2, 8,1,2,
             0,1,8,9,23,0,129, 0,1,8,9,55,0,129}},
    {"vaxg",  {1,1,-1, 2,1,-1, 4,1,-1, 4,1,-1, 4,1,2, 8,1,2,
             0,1,8,9,23,0,129, 0,1,11,12,52,0,1025}},
    {"xdr",   {1,1,1, 2,2,1, 4,4,1, 4,4,1, 4,4,1, 8,4,1,
             0,1,8,9,23,0,127, 0,1,11,12,52,0,1023}},
    {"native", {sizeof(char),   P_STRUCT_ALIGN, 0,
                sizeof(short),  P_SHORT_ALIGN,  P_SHORT_ORDER,
            sizeof(int),    P_INT_ALIGN,    P_INT_ORDER,
            sizeof(long),   P_LONG_ALIGN,   P_LONG_ORDER,
            sizeof(float),  P_FLOAT_ALIGN,  P_FLOAT_ORDER,
            sizeof(double), P_DOUBLE_ALIGN, P_DOUBLE_ORDER,
            P_FLOAT_LAYOUT, P_DOUBLE_LAYOUT}}
  };
  const int ndb = sizeof(db)/sizeof(db[0]);

  if (argc!=1) YError("get_encoding takes exactly one argument");
  name = YGetString(sp);
  if (name) {
    long *result = YETI_PUSH_NEW_L(ynew_dim(32, NULL));
    int i, c = name[0];
    for (i=0 ; i<ndb ; ++i) {
      if (c==db[i].name[0] && ! strcmp(name, db[i].name)) {
      long *layout = db[i].layout;
      for (i=0 ; i<32 ; ++i) result[i] = layout[i];
      return;
      }
    }
  }
  YError("unknown encoding name");
}

/*---------------------------------------------------------------------------*/
/* MACHINE DEPENDENT CONSTANTS */

void Y_machine_constant(int argc)
{
  double dval;
  float fval;
  long lval;
  const char *name;

  if (argc!=1) YError("machine_constant: takes exactly one argument");
  name = YGetString(sp);

  if (name[0] == 'D') {
    if (name[1] == 'B' && name[2] == 'L' && name[3] == '_') {
#define _(S,V) if (! strcmp(#S, name + 4)) { V = DBL_##S; goto push_##V; }
#if defined(DBL_EPSILON)
      _(EPSILON, dval)
#endif
#if defined(DBL_MIN)
      _(MIN, dval)
#endif
#if defined(DBL_MAX)
      _(MAX, dval)
#endif
#if defined(DBL_MIN_EXP)
      _(MIN_EXP, lval)
#endif
#if defined(DBL_MAX_EXP)
      _(MAX_EXP, lval)
#endif
#if defined(DBL_MIN_10_EXP)
      _(MIN_10_EXP, lval)
#endif
#if defined(DBL_MAX_10_EXP)
      _(MAX_10_EXP, lval)
#endif
#if defined(DBL_MANT_DIG)
      _(MANT_DIG, lval)
#endif
#if defined(DBL_DIG)
      _(DIG, lval)
#endif
#undef _
    }
  } else if (name[0] == 'F') {
    if (name[1] == 'L' && name[2] == 'T' && name[3] == '_') {
#define _(S,V) if (! strcmp(#S, name + 4)) { V = FLT_##S; goto push_##V; }
#if defined(FLT_EPSILON)
      _(EPSILON, fval)
#endif
#if defined(FLT_MIN)
      _(MIN, fval)
#endif
#if defined(FLT_MAX)
      _(MAX, fval)
#endif
#if defined(FLT_MIN_EXP)
      _(MIN_EXP, lval)
#endif
#if defined(FLT_MAX_EXP)
      _(MAX_EXP, lval)
#endif
#if defined(FLT_MIN_10_EXP)
      _(MIN_10_EXP, lval)
#endif
#if defined(FLT_MAX_10_EXP)
      _(MAX_10_EXP, lval)
#endif
#if defined(FLT_RADIX)
      _(RADIX, lval)
#endif
#if defined(FLT_MANT_DIG)
      _(MANT_DIG, lval)
#endif
#if defined(FLT_DIG)
      _(DIG, lval)
#endif
#undef _
    }
  }
  YError("unknown name of machine constant");
  return;

 push_dval:
  PushDoubleValue(dval);
  return;
 push_fval:
  *YETI_PUSH_NEW_F(NULL) = fval;
  return;
 push_lval:
  PushLongValue(lval);
  return;
}

/*---------------------------------------------------------------------------*/
/* SYMBOLS */

void Y_identof(int argc)
{
  Symbol *s;
  long typeID;
  if (argc != 1) YError("identof takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  if (s->ops==&doubleScalar) {
    typeID = T_DOUBLE;
  } else if (s->ops==&longScalar) {
    typeID = T_LONG;
  } else if (s->ops==&intScalar) {
    typeID = T_INT;
  } else if (s->ops==&dataBlockSym) {
    typeID = s->value.db->ops->typeID;
  } else {
    YError("unexpected argument");
  }
  PushLongValue(typeID);
}

void Y_nrefsof(int argc)
{
  Operand op;
  if (argc != 1) YError("nrefsof takes exactly one argument");
  if (! sp->ops) YError("unexpected keyword argument");
  PushLongValue(sp->ops->FormOperand(sp, &op)->references);
}

void Y_symbol_exists(int argc)
{
  if (argc!=1) YError("symbol_exists takes exactly one argument");
  PushIntValue(HashFind(&globalTable, YGetString(sp), 0L));
}

#define GET_ARRAY       1
#define GET_STRUCT      2
#define GET_RANGE       4
#define GET_VOID        8
#define GET_FUNCTION   16
#define GET_BUILTIN    32
#define GET_STRUCTDEF  64
#define GET_STREAM    128
#define GET_OPAQUE    256
#define GET_LIST      512
#define GET_HASH     1024
#define GET_AUTOLOAD 2048

void Y_symbol_names(int argc)
{
  extern Operations hashOps, listOps;
  long i, nitems, number;
  Operations *ops;
  char **ret;
  int match[T_OPAQUE+1];
  int type, flags, pass, get_list, get_hash, get_autoload, get_other;

  if (argc != 1) YError("symbol_list takes exactly one argument");
  flags = yeti_get_optional_integer(sp, (GET_ARRAY | GET_STRUCT | GET_RANGE |
                               GET_FUNCTION | GET_BUILTIN |
                               GET_STRUCTDEF | GET_STREAM |
                               GET_OPAQUE));
  nitems = globalTable.nItems;
  if (nitems <= 0) {
    /* No symbols defined. */
    PushDataBlock(RefNC(&nilDB));
    return;
  }
  if (flags == -1) {
    /* Return names of all symbols ever defined. */
    ret = YETI_PUSH_NEW_Q(ynew_dim(nitems, NULL));
    for (i=0 ; i<nitems ; ++i) {
      ret[i] = p_strcpy(globalTable.names[i]);
    }
    return;
  }
  if (flags & GET_OPAQUE) {
    get_list = get_autoload = get_hash = get_other = 0;
  } else {
    get_list = (flags & GET_LIST);
    get_hash = (flags & GET_HASH);
    get_autoload = (flags & GET_AUTOLOAD);
    get_other = (get_list | get_hash | get_autoload);
    if (get_other) {
      flags |= GET_OPAQUE;
    }
  }
  for (i = 0; i <= T_OPAQUE; ++i) {
    match[i] = 0;
  }
  match[T_CHAR]      = (flags & GET_ARRAY);
  match[T_SHORT]     = (flags & GET_ARRAY);
  match[T_INT]       = (flags & GET_ARRAY);
  match[T_LONG]      = (flags & GET_ARRAY);
  match[T_FLOAT]     = (flags & GET_ARRAY);
  match[T_DOUBLE]    = (flags & GET_ARRAY);
  match[T_COMPLEX]   = (flags & GET_ARRAY);
  match[T_STRING]    = (flags & GET_ARRAY);
  match[T_POINTER]   = (flags & GET_ARRAY);
  match[T_STRUCT]    = (flags & GET_STRUCT);
  match[T_RANGE]     = (flags & GET_RANGE);
#ifdef GET_LVALUE
  match[T_LVALUE]    = (flags & GET_LVALUE);
#endif
  match[T_VOID]      = (flags & GET_VOID);
  match[T_FUNCTION]  = (flags & GET_FUNCTION);
  match[T_BUILTIN]   = (flags & GET_BUILTIN);
  match[T_STRUCTDEF] = (flags & GET_STRUCTDEF);
  match[T_STREAM]    = (flags & GET_STREAM);
  match[T_OPAQUE]    = (flags & GET_OPAQUE);

  /* Counter number of matching symbols. */
  ret = NULL; /* avoids compiler warning */
  number = 0;
  for (pass = 0; pass <= 1; ++pass) {
    if (pass) {
      if (number <= 0) {
      /* No matching symbols found. */
      PushDataBlock(RefNC(&nilDB));
      return;
      }
      ret = YETI_PUSH_NEW_Q(ynew_dim(number, NULL));
    }
    for (i=0 ; i<nitems ; ++i) {
      if (globTab[i].ops != &dataBlockSym) {
      continue;
      }
      ops = globTab[i].value.db->ops;
      type = ops->typeID;
      if ((unsigned int)type > T_OPAQUE || ! match[type]) {
      continue;
      }
      if (get_other && type == T_OPAQUE) {
      if (ops == &listOps) {
        if (! get_list) {
          continue;
        }
      } else if (ops == &hashOps) {
        if (! get_hash) {
          continue;
        }
      } else if (ops == &auto_ops) {
        if (! get_autoload) {
          continue;
        }
      }
      }
      if (pass) {
      *ret++ = p_strcpy(globalTable.names[i]);
      } else {
      ++number;
      }
    }
  }
}
#undef GET_ARRAY
#undef GET_STRUCT
#undef GET_RANGE
#undef GET_VOID
#undef GET_FUNCTION
#undef GET_BUILTIN
#undef GET_STRUCTDEF
#undef GET_STREAM
#undef GET_OPAQUE
#undef GET_LIST
#undef GET_HASH
#undef GET_AUTOLOAD

extern BuiltIn Y_insure_temporary;

void Y_insure_temporary(int argc)
{
  OpTable *ops;
  Symbol *glob, *stack;
  Array *array, *copy;
  int i;

  if (argc < 1 || ! CalledAsSubroutine()) {
    YError("insure_temporary must be called as a subroutine");
  }
  for (i = 1 - argc ; i <= 0 ; ++i) {
    stack = sp + i;
    if (stack->ops != &referenceSym) {
      YError("insure_temporary expects variable reference(s)");
    }
    glob = &globTab[stack->index];
    ops = glob->ops;
    if (ops == &doubleScalar) {
      copy = NewArray(&doubleStruct, (Dimension *)0);
      copy->value.d[0] = glob->value.d;
      glob->value.db = (DataBlock *)copy;
      glob->ops = &dataBlockSym;
    } else if (ops == &longScalar) {
      copy = NewArray(&longStruct, (Dimension *)0);
      copy->value.l[0] = glob->value.l;
      glob->value.db = (DataBlock *)copy;
      glob->ops = &dataBlockSym;
    } else if (ops == &intScalar) {
      copy = NewArray(&intStruct, (Dimension *)0);
      copy->value.i[0] = glob->value.i;
      glob->value.db = (DataBlock *)copy;
      glob->ops = &dataBlockSym;
    } else if (ops == &dataBlockSym) {
      array = (Array *)glob->value.db;
      if (array->references >= 1 && array->ops->isArray) {
      /* make a fresh copy */
      copy = NewArray(array->type.base, array->type.dims);
      glob->value.db = (DataBlock *)copy;
      --array->references;
      array->type.base->Copy(array->type.base, copy->value.c,
                         array->value.c, array->type.number);
      }
    }
  }
}

/*---------------------------------------------------------------------------*/
/* OBJECTS PROPERTIES */

void Y_is_scalar(int nargs)
{
  Operand op;
  Symbol *s;

  if (nargs != 1) YError("is_scalar takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue((s->ops == &intScalar || s->ops == &longScalar ||
            s->ops == &doubleScalar) ||
             (s->ops == &dataBlockSym && s->value.db->ops->isArray &&
            ! s->ops->FormOperand(s, &op)->type.dims));
}

void Y_is_vector(int nargs)
{
  Dimension *dims;
  Operand op;
  Symbol *s;

  if (nargs != 1) YError("is_vector takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue((s->ops == &dataBlockSym && s->value.db->ops->isArray &&
            (dims = s->ops->FormOperand(s, &op)->type.dims) &&
            ! dims->next));
}

void Y_is_matrix(int nargs)
{
  Dimension *dims;
  Operand op;
  Symbol *s;

  if (nargs != 1) YError("is_matrix takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue((s->ops == &dataBlockSym && s->value.db->ops->isArray &&
            (dims = s->ops->FormOperand(s, &op)->type.dims) &&
            dims->next && ! dims->next->next));
}

#if YETI_MUST_PROVIDE_IS_LIST
void Y_is_list(int nargs)
{
  Symbol *s;
  if (nargs != 1) YError("is_list takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  if (s->ops == &dataBlockSym) {
    Operations *ops = s->value.db->ops;
#if 0 /* listOps is not exported for plugins in Yorick 1.6.02 */
    extern Operations listOps;
    PushIntValue(s->value.db->ops == &listOps);
#else
    PushIntValue(ops->typeID == T_OPAQUE && ! strcmp(ops->typeName, "list"));
#endif  
  } else {
    PushIntValue(0);
  }
}
#endif /* YETI_MUST_PROVIDE_IS_LIST */

void Y_is_integer(int nargs)
{
  Symbol *s;
  int typeID;
  if (nargs != 1) YError("is_integer takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue(s->ops == &intScalar || s->ops == &longScalar ||
             (s->ops == &dataBlockSym &&
            (typeID = s->value.db->ops->typeID) >= T_CHAR &&
            typeID <= T_LONG));
}

void Y_is_real(int nargs)
{
  Symbol *s;
  int typeID;
  if (nargs != 1) YError("is_real takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue(s->ops == &doubleScalar ||
             (s->ops == &dataBlockSym &&
            (typeID = s->value.db->ops->typeID) >= T_FLOAT &&
            typeID <= T_DOUBLE));
}

void Y_is_complex(int nargs)
{
  Symbol *s;
  if (nargs != 1) YError("is_complex takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue((s->ops == &dataBlockSym &&
            s->value.db->ops->typeID == T_COMPLEX));
}

void Y_is_string(int nargs)
{
  Symbol *s;
  if (nargs != 1) YError("is_string takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue((s->ops == &dataBlockSym &&
            s->value.db->ops->typeID == T_STRING));
}

void Y_is_pointer(int nargs)
{
  Symbol *s;
  if (nargs != 1) YError("is_pointer takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue((s->ops == &dataBlockSym &&
            s->value.db->ops->typeID == T_POINTER));
}

void Y_is_numerical(int nargs)
{
  Symbol *s;
  int typeID;
  if (nargs != 1) YError("is_numerical takes exactly one argument");
  s = YETI_DEREF_SYMBOL(sp);
  PushIntValue(s->ops == &intScalar || s->ops == &longScalar ||
             s->ops == &doubleScalar ||
             (s->ops == &dataBlockSym &&
            (typeID = s->value.db->ops->typeID) >= T_CHAR &&
            typeID <= T_COMPLEX));
}

/*---------------------------------------------------------------------------*/
/* VARIABLES */

void Y_unref(int argc)
{
  if (argc!=1) YError("unref takes exactly one argument");
  if (sp->ops == &referenceSym) {
    /* Replace reference without augmenting the number of references of
       the data block object if it is an array. */
    Symbol *ref = &globTab[sp->index];
    OpTable *ops = ref->ops;
    if (ops == &dataBlockSym) {
      DataBlock *db = ref->value.db;
      if (db && db->ops->isArray) {
      /* Replace symbol in global table by nil. */
      ref->value.db = RefNC(&nilDB);
      sp->value.db = db; /* no Ref */
      } else {
      sp->value.db = Ref(db);
      }
    } else {
      sp->value = ref->value;
    }
    sp->ops = ops; /* change ops only AFTER value updated */
  } /* NOT_NEEDED: else if (!sp->ops) YError("unexpected keyword argument"); */
}

void Y_swap(int argc)
{
  SymbolValue a_val, b_val;
  OpTable *a_ops, *b_ops;
  volatile Symbol *a_sym, *b_sym;
  if (argc!=2) YError("swap takes exactly 2 arguments");
  a_sym = sp;
  b_sym = sp-1;
  if (a_sym->ops != &referenceSym || b_sym->ops != &referenceSym)
    YError("arguments must be simple variable references");
  a_sym = &globTab[a_sym->index];
  a_ops = a_sym->ops;
  a_val = a_sym->value;
  a_sym->ops = &intScalar;
  b_sym = &globTab[b_sym->index];
  b_ops = b_sym->ops;
  b_val = b_sym->value;
  b_sym->ops = &intScalar;
  b_sym->value = a_val;
  a_sym->value = b_val;
  Drop(2);
  b_sym->ops = a_ops;
  a_sym->ops = b_ops;
}

/*---------------------------------------------------------------------------*/
/* PATHS */

void Y_current_include(int argc)
{
  if (argc != 1 || YNotNil(sp))
    YError("current_include takes exactly one nil argument");
  if (nYpIncludes > 0 && ypIncludes[nYpIncludes-1].filename) {
    yeti_push_string_value(ypIncludes[nYpIncludes-1].filename);
  } else {
    PushDataBlock(RefNC(&nilDB));
  }
}

void Y_get_includes(int argc)
{
  if (argc != 1 || YNotNil(sp))
    YError("get_includes takes exactly one nil argument");
  if (sourceTab.nItems > 0) {
    int i;
    char **s = YETI_PUSH_NEW_Q(ynew_dim(sourceTab.nItems, NULL));
    for (i=0 ; i<sourceTab.nItems ; ++i) s[i] = p_strcpy(sourceTab.names[i]);
  } else {
    PushDataBlock(RefNC(&nilDB));
  }
}

/* The following definitions _must_ match those in "ascio.c" */
PLUG_API Operations textOps;

01435 struct TextStream {
  int references;      /* reference counter */
  Operations *ops;     /* virtual function table */
#if (YORICK_VERSION_MAJOR == 1) && (YORICK_VERSION_MINOR <= 4)
  FILE *stream;        /* 0 indicates file has been closed */
#else
  p_file *stream;      /* 0 indicates file has been closed */
#endif
  char *fullname;      /* filename after YExpandName */
  int permissions;     /* +1 read permission, +2 write permission
                    +4 append mode, +8 binary mode, +16 pipe */
  /* ------ begin specific text stream part ------- */
  long lastLineRead;   /* 1-origin line number of last line read */
  long readPosition;   /* file position (ftell) after lastLineRead */
  long lastPosition;   /* file position (ftell) before lastLineRead --
                    after backup, lastPosition==readPosition,
                    and lastPosition is not valid */
  int readWrite;       /* 0 initially, 1 after read, 2 after write */
  long fileID;         /* unique number used to recognize this file */
};

void Y_filepath(int argc)
{
  Dimension *dims;
  Operand op;
  char **input, **output;
  long i, n;

  if (argc != 1) YError("filepath function takes exactly one argument");
  op.ops= 0;
  if (sp->ops) sp->ops->FormOperand(sp, &op);
  if (op.ops == &stringOps) {
    input = YGet_Q(sp, 0, &dims);
    n = TotalNumber(dims);
    output = YETI_PUSH_NEW_Q(dims);
    for (i=0 ; i<n ; ++i) {
      output[i] = (input[i] ? YExpandName(input[i]) : 0);
    }
  } else if (op.ops == &streamOps) {
    output = YETI_PUSH_NEW_Q(NULL);
    output[0] = p_strcpy(((IOStream *)op.value)->fullname);
  } else if (op.ops == &textOps) {
    output = YETI_PUSH_NEW_Q(NULL);
    output[0] = p_strcpy(((TextStream *)op.value)->fullname);
  } else if (op.ops == &voidOps) {
    PushDataBlock(RefNC(&nilDB));
  } else {
    YError("bad argument: expecting text/binary file or file name(s)");
  }
}

/*---------------------------------------------------------------------------*/
/* SMOOTHING */

static void smooth_single(double *x, double p25, double p50, double p75,
                    long n1, long n2, long n3);

void Y_smooth3(int argc)
{
  Operand op;
  double *x = NULL;
  long n1, n2, n3;
  int single = 0, is_complex;
  long which = 0; /* avoid compiler warning */
  Symbol *stack;
  Dimension *dims;
  int nparsed=0;
  double p25=0.25, p50=0.50, p75=0.75;

  for (stack=sp-argc+1 ; stack<=sp ; ++stack) {
    if (stack->ops) {
      /* non-keyword argument */
      if (++nparsed == 1) {
      stack->ops->FormOperand(stack, &op);
      } else {
      YError("too many arguments");
      }
    } else {
      /* keyword argument */
      const char *keyword = globalTable.names[stack->index];
      ++stack;
      if (keyword[0] == 'c' && keyword[1] == 0) {
      if (YNotNil(stack)) {
        p50 = YGetReal(stack);
        p25 = 0.5*(1.0 - p50);
        p75 = 0.5*(1.0 + p50);
      }
      } else if (keyword[0] == 'w' && ! strcmp(keyword, "which")) {
      if (YNotNil(stack)) {
        which = YGetInteger(stack);
        single = 1;
      }
      } else {
      YError("unknown keyword");
      }
    }
  }
  if (nparsed != 1) YError("bad number of arguments");

  /* Get input array. */
  is_complex = (op.ops->typeID == T_COMPLEX);
  n1 = (is_complex ? 2*op.type.number : op.type.number);
  stack = op.owner;
  switch (op.ops->typeID) {
  case T_CHAR:
  case T_SHORT:
  case T_INT:
  case T_LONG:
  case T_FLOAT:
    /* Convert input in a new array of double's. */
    op.ops->ToDouble(&op);
    x = op.value;
    dims = op.type.dims;
    break;

  case T_DOUBLE:
  case T_COMPLEX:
    /* If input array has references (is not temporary), make a new copy. */
    if (op.references) {
      Array *array = NewArray((is_complex ? &complexStruct : &doubleStruct),
                        op.type.dims);
      PushDataBlock(array);
      x = array->value.d;
      dims = array->type.dims;
      memcpy(x, op.value, n1*sizeof(double));
      PopTo(stack);
    } else {
      x = op.value;
      dims = op.type.dims;
    }
    break;

  default:
    YError("bad data type for input array");
  }
  while (sp != stack) Drop(1);  /* left result on top of the stack */

  /* Apply operator. */
  n3 = 1; /* product of dimensions after current one */
  if (single) {
    /* Apply operator along a single dimension. */
    Dimension *tmp = dims;
    long rank=0;
    while (tmp) {
      ++rank;
      tmp = tmp->next;
    }
    if (which <= 0) which += rank;
    if (which <= 0 || which > rank) YError("WHICH is out of range");
    while (dims) {
      n2 = dims->number;
      n1 /= n2;
      if (rank-- == which) {
      smooth_single(x, p25, p50, p75, n1, n2, n3);
      break;
      }
      n3 *= n2;
      dims = dims->next;
    }
  } else {
    /* Apply operator to every dimensions. */
    while (dims) {
      n2 = dims->number;
      n1 /= n2;
      smooth_single(x, p25, p50, p75, n1, n2, n3);
      n3 *= n2;
      dims = dims->next;
    }
  }
}

static void smooth_single(double *x, double p25, double p50, double p75,
                    long n1, long n2, long n3)
{
  if (n2 >= 2) {
    long i, stride = n1, n = n1*n2;
    double x1, x2, x3;
    if (stride == 1) {
      for ( ; --n3>=0 ; x+=n) {
      x2 = x[0];
      x3 = x[1];
      x[0] = p75*x2 + p25*x3;
      for (i=2 ; i<n ; ++i) {
        x1 = x2;
        x2 = x3;
        x3 = x[i];
        x[i - 1] = p50*x2 + p25*(x1 + x3);
      }
      x[n - 1] = p75*x3 + p25*x2;
      }
    } else {
      long p = n - stride;
      for ( ; --n3>=0 ; x+=p) {
      for (n1=stride ; --n1>=0 ; ++x) {
        x2 = x[0];
        x3 = x[stride];
        x[0] = p75*x2 + p25*x3;
        for (i=2*stride ; i<n ; i+=stride) {
          x1 = x2;
          x2 = x3;
          x3 = x[i];
          x[i - stride] = p50*x2 + p25*(x1 + x3);
        }
        x[n - stride] = p75*x3 + p25*x2;
      }
      }
    }
  }
}

/*---------------------------------------------------------------------------*/

Generated by  Doxygen 1.6.0   Back to index