Esempio n. 1
0
LOCAL LVAL datareduce1 P4C(subrfun, f, subrfun, bf, LVAL, nullval, int, count)
{
  LVAL fcn, x, result;
  
  switch (xlargc) {
  case 0: result = nullval; break;
  case 1: 
    if (compoundp(peekarg(0))) {
      xlstkcheck(2);
      xlsave(x);
      xlsave(fcn);
      fcn = cvsubr(bf, SUBR, 0);
      x = subr_map_elements(f);
      x = compounddataseq(x);
      result = reduce(fcn, x, FALSE, NIL);
      xlpopn(2);
    }
    else result = (count) ? cvfixnum((FIXTYPE) 1) : xlgetarg();
    break;
  default:
    xlsave1(x);
    x = makearglist(xlargc, xlargv);
    result = xlcallsubr1(f, x);
    xlpop();
  }
  return(result);
}
Esempio n. 2
0
LOCAL VOID set_hardware_address P3C(CPTR, ptr, LVAL, object, int *, type)
{
  LVAL t, p, last, result, oblistsym, newoblist;
  
  if (! objectp(object)) xlerror("not an object", object);
  
  oblistsym = s_hardware_objects;
  if (! consp(getvalue(oblistsym))) setvalue(oblistsym, NIL);
  
  xlstkcheck(4);
  xlsave(t);
  xlsave(p);
  xlsave(result);
  xlsave(newoblist);
  
  t = cvfixnum((FIXTYPE) time_stamp);
  p = cvfixnum((FIXTYPE) ptr);
  result = last = consa(object);
  result = cons(p, result);
  result = cons(t, result);
  
  newoblist = cons(result, getvalue(oblistsym));
  setvalue(oblistsym, newoblist);
  set_slot_value(object, s_hardware_address, result);
  
  for (;*type != NONE; type++, last = cdr(last)) {
    t = cvfixnum((FIXTYPE) *type);
    t = consa(t);
    rplacd(last, t);
  }
  xlpopn(4);
}
Esempio n. 3
0
/* xlexpandmacros - expand macros in a form */
LVAL xlexpandmacros(LVAL form)
{
    LVAL fun,args;
    
    /* protect some pointers */
    xlstkcheck(3);
    xlprotect(form);
    xlsave(fun);
    xlsave(args);

    /* expand until the form isn't a macro call */
    while (consp(form)) {
        fun = car(form);                /* get the macro name */
        args = cdr(form);               /* get the arguments */
        if (!symbolp(fun) || !fboundp(fun))
            break;
        fun = xlgetfunction(fun);       /* get the expansion function */
        if (!macroexpand(fun,args,&form))
            break;
    }

    /* restore the stack and return the expansion */
    xlpopn(3);
    return (form);
}
Esempio n. 4
0
LVAL xssample(V)
{
  LVAL x, result, temp, elem;
  int n, N, replace, i, j;
  
  x = xlgaseq();
  n = getfixnum(xlgafixnum());
  N = seqlen(x);
  replace = (moreargs()) ? (xlgetarg() != NIL) : FALSE;
  xllastarg();

  if (! replace && n > N) n = N;

  xlstkcheck(4);
  xlprotect(x);
  xlsave(result);
  xlsave(elem);
  xlsave(temp);
  x = (listp(x)) ? coerce_to_tvec(x, s_true) : copyvector(x);
  result = NIL;
  if (N > 0 && n > 0) {
    for (i = 0; i < n; i++) {
      j = (replace) ? osrand(N) : i + osrand(N - i);
      elem = gettvecelement(x, j);
      result = cons(elem, result);
      if (! replace) {           /* swap elements i and j */
        temp = gettvecelement(x, i);
        settvecelement(x, i, elem);
        settvecelement(x, j, temp);
      }
    }
  }
  xlpopn(4);
  return(result);
}
Esempio n. 5
0
VOID StGWObDoMouse P5C(LVAL, object, int, x, int, y, MouseEventType, type, MouseClickModifier, mods)
{
  LVAL Lx, Ly, argv[6], olddenv;
  int extend, option;
  
  xlstkcheck(2);
  xlsave(Lx);
  xlsave(Ly);
  argv[0] = object;
  argv[2] = Lx = cvfixnum((FIXTYPE) x);
  argv[3] = Ly = cvfixnum((FIXTYPE) y);

  olddenv = xldenv;
  xldbind(s_in_callback, s_true);
  if (type == MouseClick) {
	extend = ((int) mods) % 2;
	option = ((int) mods) / 2;
    argv[1] = sk_do_click;
	argv[4] = (extend) ? s_true : NIL;
	argv[5] = (option) ? s_true : NIL;
    xscallsubrvec(xmsend, 6, argv);
  }
  else {
    argv[1] = sk_do_motion;
    xscallsubrvec(xmsend, 4, argv);
  }
  xlpopn(2);
  xlunbind(olddenv);
}
Esempio n. 6
0
/* MAP-ELEMENTS for internal subroutines */
LVAL subr_map_elements P1C(mapfun, f)
{
  LVAL arglist, result, fcn, first_compound, type;
  int rlen;

  first_compound = findcompound(FALSE);

  if (first_compound == NIL) result = (*f)();
  else {
    xlstkcheck(3);
    xlsave(arglist);
    xlsave(fcn);
    xlsave(result);
    fcn = cvsubr(f, SUBR, 0);
    type = compoundseqtype(first_compound);
    arglist = makearglist(xlargc, xlargv);
    rlen = findrlen(arglist);
    fixuparglist(arglist);
    result = map(type, fcn, arglist, rlen);
    result = makecompound(first_compound, result);
#ifdef MULVALS
    xlnumresults = 1;
    xlresults[0] = result;
#endif /* MULVALS */
    xlpopn(3);
  }
  return(result);
}
Esempio n. 7
0
/* remif - common code for 'remove-if' and 'remove-if-not' */
LOCAL LVAL remif(int tresult)
{
    LVAL list,fcn,val,last=NULL,next;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(fcn);
    xlsave(val);

    /* get the expression to remove and the list */
    fcn = xlgetarg();
    list = xlgalist();
    xllastarg();

    /* remove matches */
    for (; consp(list); list = cdr(list))

        /* check to see if this element should be deleted */
        if (dotest1(car(list),fcn) != tresult) {
            next = consa(car(list));
            if (val) rplacd(last,next);
            else val = next;
            last = next;
        }

    /* restore the stack */
    xlpopn(2);

    /* return the updated list */
    return (val);
}
Esempio n. 8
0
LVAL xsmake_rotation(V)
{
  LVAL x, y, dx, dy, val;
  double alpha=0.0;
  int n, use_alpha = FALSE;
  
  x = xlgetarg();
  y = xlgetarg();
  if (moreargs()) {
    use_alpha = TRUE;
    alpha = makefloat(xlgetarg());
  }
  xllastarg();
  
  xlstkcheck(3);
  xlsave(dx);
  xlsave(dy);
  xlsave(val);

  dx = coerce_to_tvec(x, s_c_double);
  dy = coerce_to_tvec(y, s_c_double);
  n = gettvecsize(dx);

  if (gettvecsize(dy) != n)
    xlfail("sequences not the same length");

  val = mktvec(n * n, s_c_double);
  make_rotation(n, REDAT(val), REDAT(dx), REDAT(dy), use_alpha, alpha);
  val = linalg2genmat(val, n, n, FALSE);
  
  xlpopn(3);

  return val;
}
Esempio n. 9
0
/* xsort - built-in function 'sort' */
LVAL xsort(void)
{
    LVAL sortlist();
    LVAL list,fcn;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(list);
    xlsave(fcn);

    /* get the list to sort and the comparison function */
    list = xlgalist();
    fcn = xlgetarg();
    xllastarg();

    /* sort the list */
    list = sortlist(list,fcn);

    if (list && (ntype(list) == FREE_NODE)) {
        stdputstr("error in sort 2");
    }

    /* restore the stack and return the sorted list */
    xlpopn(2);
    return (list);
}
Esempio n. 10
0
LVAL xschol_decomp(V)
{
  LVAL a, da, val;
  int n;
  double maxoffl, maxadd;

  a = xlgadarray();
  maxoffl = moreargs() ? makefloat(xlgetarg()) : 0.0;
  xllastarg();

  checksquarematrix(a);
  n = numrows(a);

  xlstkcheck(2);
  xlsave(da);
  xlsave(val);

  da = gen2linalg(a, n, n, s_c_double, FALSE);
  choldecomp(REDAT(da), n, maxoffl, &maxadd);

  val = consa(cvflonum((FLOTYPE) maxadd));
  val = cons(linalg2genmat(da, n, n, FALSE), val);

  xlpopn(2);

  return val;
}
Esempio n. 11
0
/* xcomplement - create a complementary function */
LVAL xcomplement(V)
{
    LVAL val;
    LVAL args, body;
    LVAL newxlenv;

    /* protect some pointers */
    xlstkcheck(3);
    xlsave(newxlenv);
    xlsave(args);
    xlsave(body);


    /* get the argument */
    val = xlgetarg();
    xllastarg();

    /* build the argument list (&rest x) */
    args = cons(lk_rest, consa(s_x));

    /* build body (not (apply s x)) */
    body = consa(cons(s_not, consa(cons(s_apply, cons(s_s, consa(s_x))))));

    /* create a closure for lambda expressions */
    newxlenv = xlframe(newxlenv);
    xlpbind(s_s, val, newxlenv);
    val = xlclose(NIL,s_lambda,args,body,newxlenv,NIL);

    /* unprotect pointers */
    xlpopn(3);

    /* return the function */
    return (val);
}
Esempio n. 12
0
/* x1macroexpand - expand a macro call */
LVAL x1macroexpand(void)
{
    LVAL form,fun,args;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(fun);
    xlsave(args);

    /* get the form */
    form = xlgetarg();
    xllastarg();

    /* expand until the form isn't a macro call */
    if (consp(form)) {
        fun = car(form);		/* get the macro name */
        args = cdr(form);		/* get the arguments */
        if (symbolp(fun) && fboundp(fun)) {
            fun = xlgetfunction(fun);	/* get the expansion function */
            macroexpand(fun,args,&form);
        }
    }

    /* restore the stack and return the expansion */
    xlpopn(2);
    return (form);
}
Esempio n. 13
0
LVAL xsfft(V)
{
  LVAL data, result, x, work;
  int n, isign;
  
  data = xlgaseq();
  isign = (moreargs() && xlgetarg() != NIL) ? -1.0 : 1.0; 
  xllastarg();
  
  /* check and convert the data */
  n = seqlen(data);
  if (n <= 0)
    xlfail("not enough data");

  xlstkcheck(2);
  xlsave(x);
  xlsave(work);
  x = gen2linalg(data, n, 1, s_c_dcomplex, FALSE);
  work = mktvec(4 * n + 15, s_c_double);

  cfft(n, REDAT(x), REDAT(work), isign);

  result = listp(x) ? coerce_to_list(x) : coerce_to_tvec(x, s_true);
  xlpopn(2);

  return result;
}
Esempio n. 14
0
void nyx_set_audio_params(double rate, long len)
{
   LVAL flo;
   LVAL con;

   xlstkcheck(2);
   xlsave(flo);
   xlsave(con);

   /* Bind the sample rate to the "*sound-srate*" global */
   flo = cvflonum(rate);
   setvalue(xlenter("*SOUND-SRATE*"), flo);

   /* Bind selection len to "len" global */
   flo = cvflonum(len);
   setvalue(xlenter("LEN"), flo);

   /* Set the "*warp*" global based on the length of the audio */
   con = cons(NULL, NULL);
   flo = cvflonum(len > 0 ? (double) len / rate : 1.0);
   con = cons(flo, con);
   flo = cvflonum(0);
   con = cons(flo, con);
   setvalue(xlenter("*WARP*"), con);

   xlpopn(2);
}
Esempio n. 15
0
/* plist - parse a list */
LOCAL LVAL plist(LVAL fptr)
{
    LVAL val,expr,lastnptr,nptr;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(val);
    xlsave(expr);

    /* keep appending nodes until a closing paren is found */
    for (lastnptr = NIL; nextch(fptr) != ')'; )

        /* get the next expression */
        switch (readone(fptr,&expr)) {
        case EOF:
            badeof(fptr);
        case TRUE:

            /* check for a dotted tail */
            if (expr == s_dot) {
                /* make sure there's a node */
                if (lastnptr == NIL)
                    xlfail("invalid dotted pair");

                /* parse the expression after the dot */
                if (!xlread(fptr,&expr,TRUE))
                    badeof(fptr);
                rplacd(lastnptr,expr);

                /* make sure its followed by a close paren */
                if (nextch(fptr) != ')')
                    xlfail("invalid dotted pair");
            }

            /* otherwise, handle a normal list element */
            else {
                nptr = consa(expr);
                if (lastnptr == NIL)
                    val = nptr;
                else
                    rplacd(lastnptr,nptr);
                lastnptr = nptr;
            }
            break;
        }

    /* skip the closing paren */
    xlgetc(fptr);

    /* restore the stack */
    xlpopn(2);

    /* return successfully */
    return (val);
}
Esempio n. 16
0
/* pvector - parse a vector */
LOCAL LVAL pvector(LVAL fptr)
{
    LVAL list,expr,val,lastnptr,nptr;
    int len,ch,i;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(list);
    xlsave(expr);

    /* keep appending nodes until a closing paren is found */
    for (lastnptr = NIL, len = 0; (ch = nextch(fptr)) != ')'; ) {

        /* check for end of file */
        if (ch == EOF)
            badeof(fptr);

        /* get the next expression */
        switch (readone(fptr,&expr)) {
        case EOF:
            badeof(fptr);
        case TRUE:
            nptr = consa(expr);
            if (lastnptr == NIL)
                list = nptr;
            else
                rplacd(lastnptr,nptr);
            lastnptr = nptr;
            len++;
            break;
        }
    }

    /* skip the closing paren */
    xlgetc(fptr);

    /* make a vector of the appropriate length */
    val = newvector(len);

    /* copy the list into the vector */
    for (i = 0; i < len; ++i, list = cdr(list))
        setelement(val,i,car(list));

    /* restore the stack */
    xlpopn(2);

    /* return successfully */
    return (val);
}
Esempio n. 17
0
/* Internal version of Common Lisp MAP function */
LOCAL LVAL map P4C(LVAL, type, LVAL, fcn, LVAL, args, int, rlen)
{
  LVAL nextr, result;
  int nargs, i;

  /* protect some pointers */
  xlstkcheck(2);
  xlsave(result);
  xlprotect(fcn);
 
  if (rlen < 0) rlen = findmaprlen(args); 
  if (type == a_vector)
    result = newvector(rlen);
  else
    result = mklist(rlen, NIL);
  nargs = llength(args);

  for (i = 0, nextr = result; i < rlen; i++) {
    pushnextargs(fcn, nargs, args, i);
    setnextelement(&nextr, i, xlapply(nargs));
  }

  /* restore the stack frame */
  xlpopn(2);
  
  return(result);
}
Esempio n. 18
0
static LVAL add_contour_point P10C(int, m,
				   int, i,
				   int, j,
				   int,  k,
				   int, l,
				   double *, x,
				   double *, y,
				   double *, z,
				   double, v,
				   LVAL, result)
{
  LVAL pt;
  double p, q;
  double zij = z[i * m + j];
  double zkl = z[k * m + l];
  
  if ((zij <= v && v < zkl) || (zkl <= v && v < zij)) {
    xlsave(pt);
    pt = mklist(2, NIL);
    p = (v - zij) / (zkl - zij);
    q = 1.0 - p;
    rplaca(pt, cvflonum((FLOTYPE) (q * x[i] + p * x[k])));
    rplaca(cdr(pt), cvflonum((FLOTYPE) (q * y[j] + p * y[l])));
    result = cons(pt, result);
    xlpop();
  }
  return(result);
}
Esempio n. 19
0
/* xevalhook - eval hook function */
LVAL xevalhook(void)
{
    LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;

    /* protect some pointers */
    xlstkcheck(3);
    xlsave(oldenv);
    xlsave(oldfenv);
    xlsave(newenv);

    /* get the expression, the new hook functions and the environment */
    expr = xlgetarg();
    newehook = xlgetarg();
    newahook = xlgetarg();
    newenv = (moreargs() ? xlgalist() : NIL);
    xllastarg();

    /* bind *evalhook* and *applyhook* to the hook functions */
    olddenv = xldenv;
    xldbind(s_evalhook,newehook);
    xldbind(s_applyhook,newahook);

    /* establish the environment for the hook function */
    if (newenv) {
        oldenv = xlenv;
        oldfenv = xlfenv;
        xlenv = car(newenv);
        xlfenv = cdr(newenv);
    }

    /* evaluate the expression (bypassing *evalhook*) */
    val = xlxeval(expr);

    /* restore the old environment */
    xlunbind(olddenv);
    if (newenv) {
        xlenv = oldenv;
        xlfenv = oldfenv;
    }

    /* restore the stack */
    xlpopn(3);

    /* return the result */
    return (val);
}
Esempio n. 20
0
/* evmethod - evaluate a method */
LOCAL LVAL evmethod(LVAL obj, LVAL msgcls, LVAL method)
{
    LVAL oldenv,oldfenv,cptr,name,val=NULL;
    XLCONTEXT cntxt;

    /* protect some pointers */
    xlstkcheck(3);
    xlsave(oldenv);
    xlsave(oldfenv);
    xlsave(cptr);

    /* create an 'object' stack entry and a new environment frame */
    oldenv = xlenv;
    oldfenv = xlfenv;
    xlenv = cons(cons(obj,msgcls),closure_getenv(method));
    xlenv = xlframe(xlenv);
    xlfenv = getfenv(method);

    /* bind the formal parameters */
    xlabind(method,xlargc,xlargv);

    /* setup the implicit block */
    if ((name = getname(method)))
        xlbegin(&cntxt,CF_RETURN,name);

    /* execute the block */
    if (name && _setjmp(cntxt.c_jmpbuf))
        val = xlvalue;
    else
        for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
            val = xleval(car(cptr));

    /* finish the block context */
    if (name)
        xlend(&cntxt);

    /* restore the environment */
    xlenv = oldenv;
    xlfenv = oldfenv;

    /* restore the stack */
    xlpopn(3);

    /* return the result value */
    return (val);
}
Esempio n. 21
0
/* evfun - evaluate a function */
LOCAL LVAL evfun(LVAL fun, int argc, LVAL *argv)
{
    LVAL oldenv,oldfenv,cptr,name,val;
    XLCONTEXT cntxt;

    /* protect some pointers */
    xlstkcheck(4);
    xlsave(oldenv);
    xlsave(oldfenv);
    xlsave(cptr);
    xlprotect(fun);     /* (RBD) Otherwise, fun is unprotected */

    /* create a new environment frame */
    oldenv = xlenv;
    oldfenv = xlfenv;
    xlenv = xlframe(closure_getenv(fun));
    xlfenv = getfenv(fun);

    /* bind the formal parameters */
    xlabind(fun,argc,argv);

    /* setup the implicit block */
    if (name = getname(fun))
        xlbegin(&cntxt,CF_RETURN,name);

    /* execute the block */
    if (name && setjmp(cntxt.c_jmpbuf))
        val = xlvalue;
    else
        for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
            val = xleval(car(cptr));

    /* finish the block context */
    if (name)
        xlend(&cntxt);

    /* restore the environment */
    xlenv = oldenv;
    xlfenv = oldfenv;

    /* restore the stack */
    xlpopn(4);

    /* return the result value */
    return (val);
}
Esempio n. 22
0
NODE *xlevarg(NODE **pargs)
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,(NODE **)0);
val = xlarg(pargs);
val = xleval(val);
xlstack = oldstk;
return (val);
}
Esempio n. 23
0
static LVAL newmatrix P2C(unsigned, r, unsigned, c)
{
  LVAL rows, cols, dim, result;
  
  
  xlstkcheck(3);
  xlsave(rows);
  xlsave(cols);
  xlsave(dim);
  
  rows = cvfixnum((FIXTYPE) r);
  cols = cvfixnum((FIXTYPE) c);
  dim = list2(rows, cols);
  result = mkarray(dim, NIL, NIL, s_true);
  xlpopn(3);
  
  return(result);
}
Esempio n. 24
0
/* Common Lisp REDUCE function (internal version) */
LVAL reduce P4C(LVAL, fcn,LVAL,  sequence, int, has_init, LVAL, initial_value)
{
  LVAL next, result;
  int i, n;
  
  /* protect some pointers */
  xlstkcheck(3);
  xlsave(next);
  xlsave(result);
  xlprotect(fcn);

  switch (ntype(sequence)) {
  case CONS:
    next = sequence;
    if (has_init) result = initial_value;
    else {
      result = car(next);
      next = cdr(next);
    }
    for (; consp(next); next = cdr(next)) 
      result = xsfuncall2(fcn, result, car(next));
    break;
  case VECTOR:
  case TVEC:
    n = gettvecsize(sequence);
    i = 0;
    if (has_init) result = initial_value;
    else {
      result = gettvecelement(sequence, 0);
      i = 1;
    }
    for (; i < n; i++) 
      result = xsfuncall2(fcn, result, gettvecelement(sequence, i));
    break;
  default:
    xlbadtype(sequence);
  }

  /* restore the stack frame */
  xlpopn(3);

  return(result);
}
Esempio n. 25
0
LVAL xssurface_contour(V)
{
  LVAL s1, s2, mat, result;
  LVAL x, y, z;
  double *dx, *dy, *dz;
  double v;
  int i, j, n, m;
  
  s1 = xlgaseq();
  s2 = xlgaseq();
  mat = xlgamatrix();
  v = makefloat(xlgetarg());
  xllastarg();
    
  n = seqlen(s1);
  m = seqlen(s2);
  if (n != numrows(mat) || m != numcols(mat))
    xlfail("dimensions do not match");

  xlstkcheck(4);
  xlsave(x);
  xlsave(y);
  xlsave(z);
  xlsave(result);

  x = gen2linalg(s1,  n, 1, s_c_double, FALSE); dx = REDAT(x);
  y = gen2linalg(s2,  m, 1, s_c_double, FALSE); dy = REDAT(y);
  z = gen2linalg(mat, n, m, s_c_double, FALSE); dz = REDAT(z);
  result = NIL;

  for (i = 0; i < n - 1; i++) {
    for (j = 0; j < m - 1; j++) {
      result = add_contour_point(m, i,   j,   i,   j+1, dx, dy, dz, v, result);
      result = add_contour_point(m, i,   j+1, i+1, j+1, dx, dy, dz, v, result);
      result = add_contour_point(m, i+1, j+1, i+1, j,   dx, dy, dz, v, result);
      result = add_contour_point(m, i+1, j,   i,   j,   dx, dy, dz, v, result);
    }
  }
  xlpopn(4);
  
  return(result);
}
Esempio n. 26
0
xlputprop(NODE *sym, NODE *val, NODE *prp)
{
NODE ***oldstk,*p,*pair;
if ((pair = findprop(sym,prp)) == (NODE *)0) {
oldstk = xlsave(&p,(NODE **)0);
p = consa(prp);
((p)->n_info.n_xlist.xl_cdr = (pair = cons(val,((sym)->n_info.n_xsym.xsy_plist->n_info.n_xlist.xl_cdr))));
((sym)->n_info.n_xsym.xsy_plist->n_info.n_xlist.xl_cdr = (p));
xlstack = oldstk;
}
((pair)->n_info.n_xlist.xl_car = (val));
}
Esempio n. 27
0
LVAL iview_get_nice_range(V)
{
  double low, high;
  int ticks;
  LVAL temp, result;
  
  low = makefloat(xlgetarg());
  high = makefloat(xlgetarg());
  ticks = getfixnum(xlgafixnum());
  xllastarg();
  
  GetNiceRange(&low, &high, &ticks);
  xlstkcheck(2);
  xlsave(result);
  xlsave(temp);
  temp = cvfixnum((FIXTYPE) ticks); result = consa(temp);
  temp = cvflonum((FLOTYPE) high); result = cons(temp, result);
  temp = cvflonum((FLOTYPE) low); result = cons(temp, result);  
  xlpopn(2);
  
  return(result);
}
Esempio n. 28
0
/* sortlist - sort a list using quicksort */
LOCAL LVAL sortlist(LVAL list, LVAL fcn)
{
    LVAL gluelists();
    LVAL smaller,pivot,larger;
    
    /* protect some pointers */
    xlstkcheck(3);
    xlsave(smaller);
    xlsave(pivot);
    xlsave(larger);
    
    /* lists with zero or one element are already sorted */
    if (consp(list) && consp(cdr(list))) {
        pivot = list; list = cdr(list);
        splitlist(pivot,list,&smaller,&larger,fcn);
        smaller = sortlist(smaller,fcn);
        larger = sortlist(larger,fcn);
        list = gluelists(smaller,pivot,larger);
    }

    /* cleanup the stack and return the sorted list */
    xlpopn(3);
    return (list);
}
Esempio n. 29
0
/* Built in MAP-ELEMENTS */
LVAL xsmap_elements(V)
{
  LVAL arglist, result, fcn, first_compound, type;
  int rlen;

  if (xlargc < 2) xltoofew();
  first_compound = findcompound(TRUE);

  if (first_compound == NIL) result = xfuncall();
  else {
    xlstkcheck(2)
    xlsave(arglist);
    xlsave(result);
    fcn = xlgetarg();
    type = compoundseqtype(first_compound);
    arglist = makearglist(xlargc, xlargv);
    rlen = findrlen(arglist);
    fixuparglist(arglist);
    result = map(type, fcn, arglist, rlen);
    result = makecompound(first_compound,result);
    xlpopn(2);
  }
  return(result);
}
Esempio n. 30
0
static int breakloop(char *hdr, char *cmsg, char *emsg, NODE *arg, int cflag)
{
NODE ***oldstk,*expr,*val;
CONTEXT cntxt;
int type;
xlerrprint(hdr,cmsg,emsg,arg);
xlflush();
if (((s_tracenable)->n_info.n_xsym.xsy_value)) {
val = ((s_tlimit)->n_info.n_xsym.xsy_value);
xlbaktrace(((val) && (val)->n_type == 5) ? (int)((val)->n_info.n_xint.xi_int) : -1);
}
oldstk = xlsave(&expr,(NODE **)0);
xldebug++;
xlbegin(&cntxt,8|16|32,true);
for (type = 0; type == 0; ) {
if (type = setjmp(cntxt.c_jmpbuf))
switch (type) {
case 8:
xlflush();
type = 0;
continue;
case 16:
continue;
case 32:
if (cflag) {
stdputstr("[ continue from break loop ]\n");
continue;
}
else xlabort("this error can't be continued");
}
if (!xlread(((s_stdin)->n_info.n_xsym.xsy_value),&expr,0)) {
type = 16;
break;
}
expr = xleval(expr);
xlprint(((s_stdout)->n_info.n_xsym.xsy_value),expr,1);
xlterpri(((s_stdout)->n_info.n_xsym.xsy_value));
}
xlend(&cntxt);
xldebug--;
xlstack = oldstk;
if (type == 16) {
stdputstr("[ abort to previous level ]\n");
xlsignal(0,(NODE *)0);
}
}