src/c/utils.c

   1 /* utilities - basic utility functions                                 */
   2 /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
   3 /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
   4 /* You may give out copies of this software; for conditions see the    */
   5 /* file COPYING included with this distribution.                       */
   6
   7 /****** ///// clean this stuff up */
   8
   9 #include "xlisp.h"
  10 #include "xlstat.h"
  11
  12 typedef LVAL (*subrfun)(V);
  13
  14 /************************************************************************/
  15 /**                           Basic Utilities                          **/
  16 /************************************************************************/
  17
  18 /* return list of two elements */
  19 LVAL list2 P2C(LVAL, x1, LVAL, x2)
  20 {
  21   LVAL list, y1, y2;
  22
  23   /* protect some pointers */
  24   xlstkcheck(3);
  25   xlsave(list);
  26   xlsave(y1);
  27   xlsave(y2);
  28
  29   y1 = x1;
  30   y2 = x2;
  31   list = consa(y2);
  32   list = cons(y1, list);
  33
  34   /* restore the stack frame */
  35   xlpopn(3);
  36
  37   return(list);
  38 }
  39
  40 /* return list of three elements */
  41 LVAL list3 P3C(LVAL, x1, LVAL, x2, LVAL, x3)
  42 {
  43   LVAL list, y1, y2, y3;
  44
  45   /* protect some pointers */
  46   xlstkcheck(4);
  47   xlsave(list);
  48   xlsave(y1);
  49   xlsave(y2);
  50   xlsave(y3);
  51
  52   y1 = x1;
  53   y2 = x2;
  54   y3 = x3;
  55   list = consa(y3);
  56   list = cons(y2, list);
  57   list = cons(y1, list);
  58
  59   /* restore the stack frame */
  60   xlpopn(4);
  61
  62   return(list);
  63 }
  64
  65 /* return the i-th argument, without popping it; signal an error if needed. */
  66 LVAL peekarg P1C(int, i)
  67 {
  68   if (xlargc <= i) xltoofew();
  69   return(xlargv[i]);
  70 }
  71
  72 /* Get the next element in the sequence; cdr the pointer if it is a list */
  73 LVAL getnextelement P2C(LVAL *, pseq, int, i)
  74 {
  75   LVAL value;
  76
  77   switch (ntype(*pseq)) {
  78   case VECTOR:
  79     value = getelement(*pseq, i);
  80     break;
  81   case TVEC:
  82   case STRING:
  83     value = gettvecelement(*pseq, i);
  84     break;
  85   case CONS:
  86     value = car(*pseq);
  87     *pseq = cdr(*pseq);
  88     break;
  89   default:
  90     xlbadtype(*pseq);
  91     value = NIL;
  92   }
  93   return(value);
  94 }
  95
  96 /* Set the next element in the sequence; cdr the pointer if it is a list */
  97 VOID setnextelement P3C(LVAL *, pseq, int, i, LVAL, value)
  98 {
  99   switch (ntype(*pseq)) {
 100   case VECTOR:
 101     setelement(*pseq, i, value);
 102     break;
 103   case TVEC:
 104   case STRING:
 105     settvecelement(*pseq, i, value);
 106     break;
 107   case CONS:
 108     rplaca(*pseq, value);
 109     *pseq = cdr(*pseq);
 110     break;
 111   default:
 112     xlbadtype(*pseq);
 113   }
 114 }
 115
 116
 117 /************************************************************************/
 118 /**                  Function Applicaiton Utilities                    **/
 119 /************************************************************************/
 120
 121 VOID pushargvec P3C(LVAL, fun, int, argc, LVAL *, argv)
 122 {
 123   LVAL *newfp, *oldsp;
 124   int i;
 125
 126   /* build a new argument stack frame */
 127   newfp = oldsp = xlsp;
 128   pusharg(NIL); /* place holder for stack frame increment */
 129   pusharg(fun);
 130   pusharg(NIL); /* place holder for argc */
 131
 132   /* push the arguments */
 133   for (i = 0; i < argc; i++)
 134     pusharg(argv[i]);
 135
 136   /* establish the new stack frame */
 137   oldsp[0] = cvfixnum((FIXTYPE)(newfp - xlfp));
 138   oldsp[2] = cvfixnum((FIXTYPE) argc);
 139   xlfp = newfp;
 140 }
 141
 142 LVAL xsapplysubr P2C(subrfun, f, LVAL, args)
 143 {
 144   LVAL *oldargv, val;
 145   int argc, oldargc;
 146
 147   xlprot1(args); /* protect arguments while pushing */
 148   argc = pushargs(NIL, args);
 149   xlpop();       /* now they are protected since they are on the stack */
 150
 151   oldargc = xlargc;
 152   oldargv = xlargv;
 153   xlargc = argc;
 154   xlargv = xlfp + 3;
 155   val = (*f)();
 156   xlargc = oldargc;
 157   xlargv = oldargv;
 158
 159   /* remove the call frame */
 160   xlsp = xlfp;
 161   xlfp = xlfp - (int)getfixnum(*xlfp);
 162   return(val);
 163 }
 164
 165 LVAL xscallsubrvec P3C(subrfun, f, int, argc, LVAL *, argv)
 166 {
 167   LVAL *oldargv, val;
 168   int oldargc;
 169
 170   pushargvec(NIL, argc, argv);
 171   oldargc = xlargc;
 172   oldargv = xlargv;
 173   xlargc = argc;
 174   xlargv = xlfp + 3;
 175   val = (*f)();
 176   xlargc = oldargc;
 177   xlargv = oldargv;
 178
 179   /* remove the call frame */
 180   xlsp = xlfp;
 181   xlfp = xlfp - (int)getfixnum(*xlfp);
 182   return(val);
 183 }
 184
 185 LVAL xsfuncall0 P1C(LVAL, fun)
 186 {
 187   pushargvec(fun, 0, NULL);
 188   return(xlapply(0));
 189 }
 190
 191 LVAL xsfuncall1 P2C(LVAL, fun, LVAL, x)
 192 {
 193   pushargvec(fun, 1, &x);
 194   return(xlapply(1));
 195 }
 196
 197 LVAL xsfuncall2 P3C(LVAL, fun, LVAL, x, LVAL, y)
 198 {
 199   LVAL args[2];
 200
 201   args[0] = x;
 202   args[1] = y;
 203   pushargvec(fun, 2, args);
 204   return(xlapply(2));
 205 }
 206
 207 /* replicates a list n times */
 208 int xsboolkey P2C(LVAL, key, int, dflt)
 209 {
 210   LVAL val;
 211   int result = dflt;
 212
 213   if (xlgetkeyarg(key, &val)) result = ((val != NIL) ? TRUE : FALSE);
 214   return(result);
 215 }