home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d3xx / d386 / xlispstat.lha / XLispStat / src2.lzh / XLisp-Stat / common.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-10-08  |  35.6 KB  |  1,494 lines
  1. /* common - Additional Common Lisp functions not yet included in       */
  2. /* Xlisp 2.1.                                                          */
  3. /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
  4. /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
  5. /* You may give out copies of this software; for conditions see the    */
  6. /* file COPYING included with this distribution.                       */
  7.  
  8. #include <string.h>
  9. #include <stdio.h>
  10. #include "xlisp.h"
  11. #include "osdef.h"
  12. #ifdef ANSI
  13. #include "xlproto.h"
  14. #include "xlsproto.h"
  15. #include "osproto.h"
  16. #else
  17. #include "xlfun.h"
  18. #include "xlsfun.h"
  19. #include "osfun.h"
  20. #endif ANSI
  21. #include "xlvar.h"
  22. #include "xlsvar.h"
  23.  
  24. /* forward declarations */
  25. #ifdef ANSI
  26. LVAL apropos(int),getstroutput(LVAL), getargument(LVAL,int),xscomplex(void),
  27.      xsconjugate(void),xsrealpart(void),xsimagpart(void),equaltest(int),
  28.      makeseq(LVAL,int),next_elt(LVAL *,int),every_some(int,int),set_op(int);
  29. void get_format_data(char **,char *,int *,int *),set_next_elt(LVAL *,int,LVAL),
  30.      badseq(LVAL),badindex(LVAL),badcomplex(LVAL),
  31.      pushnextargs(LVAL,int,LVAL,int);
  32. int strck(char *,char *,int),is_sub_str(char *,char *),findrlen(LVAL),
  33.     is_member(LVAL,LVAL),sequence_length(LVAL),reslength(LVAL),
  34.     apply_member(LVAL,LVAL,LVAL);
  35. #else
  36. LVAL apropos(),getstroutput(), getargument(),xscomplex(),
  37.      xsconjugate(),xsrealpart(),xsimagpart(),equaltest(),
  38.      makeseq(),next_elt(),every_some(),set_op();
  39. void get_format_data(),set_next_elt(),badseq(),badindex(),badcomplex(),
  40.      pushnextargs();
  41. int strck(),is_sub_str(),findrlen(),
  42.     is_member(),sequence_length(),reslength(),
  43.     apply_member();
  44. #endif ANSI
  45.  
  46. /****************************************************************************/
  47. /****************************************************************************/
  48. /**                                                                        **/
  49. /**                         Common Lisp Functions                          **/
  50. /**                                                                        **/
  51. /****************************************************************************/
  52. /****************************************************************************/
  53.  
  54. /****************************************************************************/
  55. /**                       APROPOS and APROPOS-LIST                         **/
  56. /****************************************************************************/
  57.  
  58. /* internal version of APROPOS */
  59. static LVAL apropos(print)
  60.      int print;
  61. {
  62.   LVAL str, array, list, element, result;
  63.   unsigned char *s1, *s2;
  64.   int i, n;
  65.   
  66.   str = xlgetarg();
  67.   xllastarg();
  68.   
  69.   if (stringp(str)) s1 = getstring(str);
  70.   else if (symbolp(str)) s1 = getstring(getpname(str));
  71.   else xlbadtype(str);
  72.   
  73.   array = getvalue(obarray);
  74.   n = getsize(array);
  75.   
  76.   /* protect some pointers */
  77.   xlsave1(result);
  78.   
  79. /*  result = NIL; in macro JKL */
  80.   for (i = 0; i < n; i++) {
  81.     list = getelement(array, i);
  82.     if (listp(list)) {
  83.       for (; consp(list); list = cdr(list)) {
  84.         element = car(list);
  85.         if (symbolp(element) && element != s_unbound) {
  86.           s2 = getstring(getpname(element));
  87.           if (is_sub_str(s1, s2) == 0) {
  88.             if (print) stdprint(element);
  89.             else result = cons(element, result);
  90.           }
  91.         }
  92.       }
  93.     }
  94.   }
  95.   /* restore the stack and return the result */
  96.   xlpop();
  97.   
  98.   return(result);
  99. }
  100.  
  101. /* Common Lisp APROPOS function */
  102. LVAL xsapropos() { return(apropos(TRUE)); }
  103.  
  104. /* Common Lisp APROPOS-LIST function */
  105. LVAL xsaproposlist() { return(apropos(FALSE)); }
  106.  
  107. /* check if s1 is a substring of s2; case insensitive */
  108. static int is_sub_str(s1, s2)
  109.      char *s1, *s2;
  110. {
  111.   int n, m, i;
  112.  
  113.   m = strlen(s1);
  114.   n = strlen(s2) - m;
  115.   
  116.   for (i = 0; i <= n; i++)
  117.     if (strck(s1, &s2[i], m)) return (0);
  118.   return(1);
  119. }
  120.  
  121. /* check if s1 and s2 agree up to character m; case insensitive */
  122. static int strck(s1, s2, m)
  123.      char *s1, *s2;
  124.      int m;
  125. {
  126.   char ch1, ch2;
  127.  
  128.   while (m-- > 0) {
  129.     ch1 = isupper(*s1) ? tolower(*s1) : *s1;
  130.     ch2 = isupper(*s2) ? tolower(*s2) : *s2;
  131.     if (ch1 != ch2) return(0);
  132.     s1++;
  133.     s2++;
  134.   }
  135.   return(1);
  136. }
  137.  
  138. /*************************************************************************/
  139. /**         IDENTITY, MAKE-LIST, ADJOIN and FILE-POSITION functions     **/
  140. /*************************************************************************/
  141.  
  142. /* Common Lisp IDENTITY function */
  143. LVAL xsidentity()
  144. {
  145.   LVAL x;
  146.   
  147.   x = xlgetarg();
  148.   xllastarg();
  149.   return(x);
  150. }
  151.  
  152. /* Internal version of MAKE-LIST */
  153. LVAL mklist(n, elem)
  154.      int n;
  155.      LVAL elem;
  156. {
  157.   LVAL result = NIL, next;
  158.   
  159.   xlsave1(result);
  160.   while (n-- > 0) 
  161.     result = cons(NIL, result);
  162.   if (elem != NIL) 
  163.     for (next = result; consp(next); next = cdr(next))
  164.       rplaca(next, elem);
  165.   xlpop();
  166.   return(result);
  167. }
  168.  
  169. /* Common Lisp MAKE-LIST function */
  170. LVAL xsmklist()
  171. {
  172.   int n;
  173.   LVAL elem = NIL;
  174.   
  175.   n = getfixnum(xlgafixnum());
  176.   xlgetkeyarg(s_ielement, &elem);
  177.   
  178.   return(mklist(n, elem));
  179. }
  180.  
  181. /* Common Lisp ADJOIN function */
  182. LVAL xsadjoin()
  183. {
  184.   LVAL x, list;
  185.   if (xlargc < 2) xltoofew();
  186.   x = xlargv[0];
  187.   list = xlargv[1];
  188.   if (xmember()) return(list);
  189.   else return(cons(x, list));
  190. }
  191.  
  192. /* Common Lisp FILE-POSITION function */
  193. LVAL xsfileposition()
  194. {
  195.   LVAL fptr;
  196.   long pos;
  197.   
  198.   /* get file pointer */
  199.   fptr = xlgetfile();
  200.   
  201.   /* make sure the file exists */
  202.   if (getfile(fptr) == NULL) xlfail("file not open");
  203.   
  204.   if (moreargs()) {
  205.     pos = getfixnum(xlgafixnum());
  206.     xllastarg();
  207.     fseek(getfile(fptr), pos, 0);
  208.     return(s_true);
  209.   }
  210.   else {
  211.     return(cvfixnum((FIXTYPE) ftell(getfile(fptr))));
  212.   }
  213. }
  214.  
  215. /****************************************************************************/
  216. /**                   Common Lisp FORMAT function                          **/
  217. /**         (Includes integer and floating point formatting)               **/
  218. /****************************************************************************/
  219.  
  220. /* getstroutput - get the output stream string (internal) */
  221. static LVAL getstroutput(stream)
  222.   LVAL stream;
  223. {
  224.   unsigned char *str;
  225.   LVAL next,val;
  226.   int len,ch;
  227.  
  228.   /* compute the length of the stream */
  229.   for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
  230.     ++len;
  231.   if (len - 1 > STRMAX) xlfail("string is too long");
  232.  
  233.   /* create a new string */
  234.   val = newstring(len + 1);
  235.     
  236.   /* copy the characters into the new string */
  237.   str = getstring(val);
  238.   while ((ch = xlgetc(stream)) != EOF)
  239.     *str++ = ch;
  240.   *str = '\0';
  241.  
  242.   /* return the string */
  243.   return (val);
  244. }
  245.  
  246. /* parser for format directives (internal) */
  247. static void get_format_data(fmt, dir, nargs, fargs)
  248.      char **fmt, *dir;
  249.      int *nargs, *fargs;
  250. {
  251.   (*fmt)++;
  252.   *nargs = 0;
  253.   while ((isdigit(**fmt) || **fmt == ',' || **fmt == 'v' || **fmt == 'V')
  254.      && *nargs < 2) {
  255. #ifdef AMIGA
  256.     *dir = **fmt; /* dummy line needed for bug in Lattice 5.05 JKL */
  257. #endif AMIGA
  258.     if (isdigit(**fmt)) {
  259.       (*nargs)++;
  260.       sscanf(*fmt, "%d", fargs++);
  261.       while (isdigit(**fmt))
  262.     (*fmt)++;
  263.       if (**fmt == ',') (*fmt)++;
  264.     }
  265.     else if ( **fmt == ',') {
  266.       (*fmt)++;
  267.       (*nargs)++;
  268.       *fargs++ = -1;
  269.     }
  270.     else {
  271.       (*fmt)++;
  272.       (*nargs)++;
  273.       *fargs++ = getfixnum(xlgafixnum());
  274.       if (**fmt == ',') (*fmt)++;
  275.     }
  276.   }
  277.   *dir = **fmt;
  278. }
  279.  
  280. LVAL xsformat()
  281. {
  282.   LVAL stream, val, arg;
  283.   unsigned char *fmt, dir, contr[50];
  284.   int nargs, fargs[2], i;
  285.   
  286.   xlsave1(stream);
  287.  
  288.   /* get the stream and format string */
  289.   stream = xlgetarg();
  290.   if (stream == NIL)
  291.     val = stream = newustream();
  292.   else {
  293.     if (stream == s_true)
  294.       stream = getvalue(s_stdout);
  295.     else if (streamp(stream)) {
  296.       if (getfile(stream) == NULL)
  297.         xlfail("file not open");
  298.     }
  299.     else if (!ustreamp(stream))
  300.       xlbadtype(stream);
  301.     val = NIL;
  302.   }
  303.   fmt = getstring(xlgastring());
  304.  
  305.   for (; *fmt != '\0'; fmt++) {
  306.     if (*fmt != '~') xlputc(stream, *fmt);
  307.     else {
  308.       get_format_data(&fmt, &dir, &nargs, fargs);
  309.       switch (dir) {
  310.       case 'A':
  311.       case 'a':
  312.     xlfsize = 0;
  313.     xlprint(stream, xlgetarg(), FALSE);
  314.     if (nargs > 0)
  315.       for (; xlfsize < fargs[0]; /*xlfsize++*/) xlputc(stream, ' ');
  316.     break;
  317.       case 'S':
  318.       case 's':
  319.     xlfsize = 0;
  320.     xlprint(stream, xlgetarg(), TRUE);
  321.     if (nargs > 0)
  322.       for (; xlfsize < fargs[0]; /*xlfsize++*/) xlputc(stream, ' ');
  323.     break;
  324.       case 'D':
  325.       case 'd':
  326.     arg = xlgetarg();
  327.     if (fixp(arg)) {
  328.       if (nargs == 0) {
  329.         sprintf(buf, "%ld", (long) getfixnum(arg));
  330.         xlputstr(stream, buf);
  331.       }
  332.       else {
  333.         sprintf(contr, "%%%dld", fargs[0]);
  334.         sprintf(buf, contr, (long) getfixnum(arg));
  335.         xlputstr(stream, buf);
  336.       }
  337.     }
  338.     else
  339.       xlprint(stream, arg, FALSE);
  340.     break;
  341.       case 'E':
  342.       case 'e':
  343.       case 'F':
  344.       case 'f':
  345.       case 'G':
  346.       case 'g':
  347.     dir = (isupper(dir)) ? tolower(dir) : dir;
  348.     arg = xlgetarg();
  349.     if (floatp(arg)) {
  350.       switch (nargs) {
  351.       case 0:
  352.         sprintf(contr, "%%l%c", dir);
  353.         break;
  354.       case 1:
  355.         sprintf(contr, "%%%dl%c", fargs[0], dir);
  356.         break;
  357.       case 2:
  358.         if (fargs[0] > 0)
  359.           sprintf(contr, "%%%d.%dl%c", fargs[0], fargs[1], dir);
  360.         else
  361.           sprintf(contr, "%%.%dl%c", fargs[1], dir);
  362.         break;
  363.       default:
  364.         xlfail("too many arguments for format directive");
  365.       }
  366.       sprintf(buf, contr, (double) getflonum(arg));
  367.       xlputstr(stream, buf);
  368.     }
  369.     else             
  370.       xlprint(stream, arg, FALSE);
  371.     break;
  372.       case '~':
  373.     if (nargs == 0) xlputc(stream, '~');
  374.     else if (nargs == 1) {
  375.       /* if (fargs[0] < 0) fargs[0] = 0; line does nothing  JKL */
  376.       for (i = 0; i < fargs[0]; i++)
  377.         xlputc(stream, '~');
  378.     }
  379.     break;
  380.       case '%':
  381.     if (nargs == 0) xlterpri(stream);
  382.     else if (nargs == 1) {
  383.       /* if (fargs[0] < 0) fargs[0] = 0; line does nothing JKL */
  384.       for (i = 0; i < fargs[0]; i++)
  385.         xlterpri(stream);
  386.     }
  387.     break;
  388.       case '\n':
  389.         while (isspace(*fmt)) fmt++;
  390.         fmt--; /* set back because fmt will be advanced in the outer loop */
  391.         break;
  392.       default:
  393.     xlfail("unknown format directive");
  394.       }
  395.     }
  396.   }
  397.   if (val != NIL) val = getstroutput(val);
  398.   xlpop();
  399.  
  400.   /* return the value */
  401.   return (val);
  402. }
  403.  
  404. LVAL xsforce_output()
  405. {
  406. #ifdef MACINTOSH
  407.   TtyFlush();
  408. #else
  409.   fflush(stdout);
  410. #endif MACINTOSH
  411.   return(NIL);
  412. }
  413.  
  414. /****************************************************************************/
  415. /**                     Sequence Copying Functions                         **/
  416. /****************************************************************************/
  417.  
  418. /* Common Lisp COPY-LIST function */
  419. LVAL xscopylist()
  420. {
  421.   LVAL list;
  422.   
  423.   list = xlgalist();
  424.   xllastarg();
  425.   
  426.   return(copylist(list));
  427. }
  428.  
  429. /* Common Lisp COPY-SEQ function */
  430. LVAL xscopyseq()
  431. {
  432.   if (! moreargs()) xltoofew();
  433.   return((vectorp(xlargv[0])) ? xscopyvector() : xscopylist());
  434. }
  435.  
  436. /***********************************************************************/
  437. /**                     REDUCE and MAP functions                      **/
  438. /***********************************************************************/
  439.  
  440. /* Common Lisp REDUCE function (internal version) */
  441. LVAL reduce(fcn, sequence, has_init, initial_value)
  442.      LVAL fcn, sequence, initial_value;
  443.      int has_init;
  444. {
  445.   LVAL next, result;
  446.   int i, n;
  447.   
  448.   /* protect some pointers */
  449.   xlstkcheck(3);
  450.   xlsave(next);
  451.   xlsave(result);
  452.   xlprotect(fcn);
  453.   
  454.   if (consp(sequence)) {
  455.     next = sequence;
  456.     if (has_init) result = initial_value;
  457.     else {
  458.       result = car(next);
  459.       next = cdr(next);
  460.     }
  461.     for (; consp(next); next = cdr(next)) 
  462.       result = xsfuncall2(fcn, result, car(next));
  463.   }
  464.   else if (vectorp(sequence)) {
  465.     n = getsize(sequence);
  466.     i = 0;
  467.     if (has_init) result = initial_value;
  468.     else {
  469.       result = getelement(sequence, 0);
  470.       i = 1;
  471.     }
  472.     for (; i < n; i++)
  473.       result = xsfuncall2(fcn, result, getelement(sequence, i));
  474.   }
  475.   else badseq(sequence);
  476.   
  477.   /* restore the stack frame */
  478.   xlpopn(3);
  479.  
  480.   return(result);
  481. }
  482.  
  483. /* Common Lisp REDUCE function */
  484. LVAL xsreduce()
  485. {
  486.   LVAL fcn, sequence, initial_value;
  487.   int has_init;
  488.   
  489.   fcn = xlgetarg();
  490.   sequence = xlgetarg();
  491.   has_init = xlgetkeyarg(s_ivalue, &initial_value);
  492.   
  493.   return(reduce(fcn, sequence, has_init, initial_value));
  494. }
  495.  
  496. /* #define seqlen(x) ((vectorp(x)) ? getsize(x) : llength(x)) in xlsdef.h JKL */
  497. #define makeresult(type, n) ((type == s_vector) ? newvector(n) : mklist(n, NIL))
  498.  
  499. /* compute the length of the result sequence */
  500. LOCAL int findrlen(args)
  501.      LVAL args;
  502. {
  503.   LVAL next;
  504.   int len, rlen;
  505.  
  506.   for (rlen = -1, next = args; consp(next); next = cdr(next)) {
  507.     if (! sequencep(car(next))) badseq(car(next));
  508.     len = seqlen(car(next));
  509.     if (rlen == -1) rlen = len;
  510.     else rlen = (len < rlen) ? len : rlen;
  511.   }
  512.   return(rlen);
  513. }
  514.  
  515. LOCAL void pushnextargs(fcn, n, args, i)
  516.      LVAL fcn, args;
  517.      int n, i;
  518. {
  519.   LVAL *newfp, next, value;
  520.  
  521.   /* build a new argument stack frame */
  522.   newfp = xlsp;
  523.   pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  524.   pusharg(fcn);
  525.   pusharg(cvfixnum((FIXTYPE)n));
  526.   
  527.   /* push the arguments and shift the list pointers */
  528.   for (next = args; consp(next); next = cdr(next)) {
  529.     if (vectorp(car(next))) value = getelement(car(next), i);
  530.     else {
  531.       value = car(car(next));
  532.       rplaca(next, cdr(car(next)));
  533.     }
  534.     pusharg(value);
  535.   }
  536.  
  537.   /* establish the new stack frame */
  538.   xlfp = newfp;
  539. }
  540.   
  541. /* Internal version of Common Lisp MAP function */
  542. LVAL map(type, fcn, args, rlen)
  543.      LVAL type, fcn, args;
  544.      int rlen;
  545. {
  546.   LVAL nextr, result;
  547.   int nargs, i;
  548.  
  549.   /* protect some pointers */
  550.   xlstkcheck(2);
  551.   xlsave(result);
  552.   xlprotect(fcn);
  553.  
  554.   if (rlen < 0) rlen = findrlen(args); 
  555.   result = makeresult(type, rlen);
  556.   nargs = llength(args);
  557.  
  558.   for (i = 0, nextr = result; i < rlen; i++) {
  559.     pushnextargs(fcn, nargs, args, i);
  560.     setnextelement(&nextr, i, xlapply(nargs));
  561.   }
  562.  
  563.   /* restore the stack frame */
  564.   xlpopn(2);
  565.   
  566.   return(result);
  567. }
  568.  
  569. /* Common Lisp MAP function */
  570. LVAL xsmap()
  571. {
  572.   LVAL fcn, type, args, result;
  573.   
  574.   /* protect some pointers */
  575.   xlstkcheck(2);
  576.   xlsave(fcn);
  577.   xlsave(args);
  578.  
  579.   type = xlgasymbol();
  580.   fcn = xlgetarg();
  581.   if (type != s_list && type != s_vector)
  582.     xlerror("Not a valid sequence type", type);
  583.   args = makearglist(xlargc, xlargv);
  584.  
  585.   result = map(type, fcn, args, -1);
  586.  
  587.   /* restore the stack frame */
  588.   xlpopn(2);
  589.   return(result);
  590. }
  591.  
  592. /***********************************************************************/
  593. /**                       ELT and COERCE                              **/
  594. /***********************************************************************/
  595.  
  596. /* Common Lisp ELT function */
  597. LVAL xselt()
  598. {
  599.   LVAL x, index;
  600.   int i;
  601.   
  602.   x = xlgetarg();
  603.   index = xlgafixnum();
  604.   xllastarg();
  605.  
  606.   i = getfixnum(index);
  607.   if (simplevectorp(x)) {
  608.     if (i < 0 || i >= getsize(x)) badindex(index);
  609.     else return(getelement(x, i));
  610.   }
  611.   else if (listp(x)) {
  612.     if (i < 0) badindex(index);
  613.     else
  614.       for (; consp(x) && i > 0; x = cdr(x), i--)
  615.     ;
  616.     if (! consp(x)) badindex(index);
  617.     else return(car(x));
  618.   }
  619.   else if (stringp(x)) {
  620.     if (i < 0 || i >= strlen(getstring(x))) badindex(index);
  621.     else return(cvchar(getstring(x)[i]));
  622.   }
  623.   else badseq(x);
  624. }
  625.  
  626. /* Setf method for Common Lisp ELT function */
  627. void set_elt(x, index, val)
  628.     LVAL x, index, val;
  629. {
  630.   int i;
  631.   
  632.   i = getfixnum(index);
  633.   if (simplevectorp(x)) {
  634.     if (i < 0 || i >= getsize(x)) badindex(index);
  635.     else setelement(x, i, val);
  636.   }
  637.   else if (listp(x)) {
  638.     if (i < 0) badindex(index);
  639.     else
  640.       for (; consp(x) && i > 0; x = cdr(x), i--)
  641.     ;
  642.     if (! consp(x)) badindex(index);
  643.     else rplaca(x, val);
  644.   }
  645.   else if (stringp(x)) {
  646.     if (! charp(val)) xlerror("not a character", val);
  647.     if (i < 0 || i >= strlen(getstring(x))) badindex(index);
  648.     getstring(x)[i] = getchcode(val);
  649.   }
  650.   else badseq(x);
  651. }
  652.  
  653. /* Common Lisp COERCE function */
  654. LVAL xscoerce()
  655. {
  656.   LVAL x, result, type;
  657.   static char str[]="can't coerce this object to this type"; /* added JKL */
  658.   
  659.   x = xlgetarg();
  660.   type = xlgasymbol();
  661.   xllastarg();
  662.   
  663.   /* protect the result pointer */
  664.   xlsave1(result);
  665.   
  666.   if (stringp(x) || type == a_string) {
  667.     if (stringp(x) && type == a_string) result = x;
  668.     else result = xscallsubr2(xsconcatenate, type, x);
  669.   }
  670.   else if (type == a_flonum || type == a_float) {
  671.     if (fixp(x)) result = cvflonum((FLOTYPE) getfixnum(x));
  672.     else if (floatp(x)) result = x;
  673.     else xlfail(str/*"can't coerce this object to this type"*/);
  674.   }
  675.   else if (type == a_complex) {
  676.     if (fixp(x)) result = newicomplex(getfixnum(x), (FIXTYPE) 0);
  677.     else if (floatp(x)) result = newdcomplex(getflonum(x), (FLOTYPE) 0.0);
  678.     else if (complexp(x)) result = x;
  679.     else xlfail(str/*"can't coerce this object to this type"*/);
  680.   }    
  681.   else if (type == a_cons || type == s_list) 
  682.     result = coerce_to_list(x);
  683.   else if (type == s_vector) 
  684.     result = coerce_to_vector(x);
  685.   else if (type == s_true)
  686.     result = x;
  687.   else
  688.     xlfail(str/*"can't coerce this object to this type"*/);
  689.   
  690.   /* restore the stack frame */
  691.   xlpop();
  692.   
  693.   return(result);
  694. }
  695.  
  696. /***********************************************************************/
  697. /**                                                                   **/
  698. /**                Modified APPLY and EVAL functions                  **/
  699. /**                                                                   **/
  700. /***********************************************************************/
  701.  
  702. /* Common Lisp APPLY function. Modified to cons arguments onto last one */
  703. LVAL xsapply()
  704. {
  705.   LVAL *newfp, last;
  706.   int argc;
  707.  
  708.   /* build a new argument stack frame */
  709.   newfp = xlsp;
  710.   pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  711.   pusharg(xlgetarg());
  712.   pusharg(NIL); /* will be argc */
  713.   
  714.   /* push all but the last argument */
  715.   last = xlgetarg();
  716.   for (argc = 0; moreargs(); argc++) {
  717.     pusharg(last);
  718.     last = nextarg();
  719.   }
  720.  
  721.   /* push all elements of the last argument */
  722.   if (! listp(last)) xlerror("not a list", last);
  723.   for (; consp(last); last = cdr(last), argc++) 
  724.     pusharg(car(last));
  725.  
  726.   /* establish the new stack frame */
  727.   newfp[2] = cvfixnum((FIXTYPE)argc);
  728.   xlfp = newfp;
  729.  
  730.   /* apply the function to the arguments */
  731.   return (xlapply(argc));
  732. }
  733.  
  734. /* Common Lisp EVAL function. Modified to use null lexical environment */
  735. LVAL xseval()
  736. {
  737.   LVAL expr, result, oldenv, oldfenv;
  738.  
  739.   /* set the lexical environment to null */
  740.   xlstkcheck(3);
  741.   xlsave(oldenv); /* oldenv and oldfenv set redundantly to NIL in macros JKL */
  742.   xlsave(oldfenv);
  743.   xlsave(expr);
  744.   oldenv = xlenv; xlenv = NIL;
  745.   oldfenv = xlfenv; xlfenv = NIL;
  746.   
  747.   /* get the expression to evaluate */
  748.   expr = xlgetarg();
  749.   xllastarg();
  750.  
  751.   /* evaluate the expression */
  752.   result = xleval(expr);
  753.   
  754.   /* reset the environment */
  755.   xlenv = oldenv;
  756.   xlfenv = oldfenv;
  757.   xlpopn(3);
  758.   
  759.   return(result);
  760. }
  761.  
  762. /* Common Lisp LOAD function. Modified to use null lexical environment */
  763.  
  764. LVAL xsload()
  765. {
  766.   LVAL result, oldenv, oldfenv;
  767.  
  768.   /* set the lexical environment to null */
  769.   xlstkcheck(2);
  770.   xlsave(oldenv); /* oldenv and oldfenv set redundantly to NIL in macros JKL */
  771.   xlsave(oldfenv);
  772.   oldenv = xlenv; xlenv = NIL;
  773.   oldfenv = xlfenv; xlfenv = NIL;
  774.   
  775.   /* evaluate the expression */
  776.   result = xload();
  777.   
  778.   /* reset the environment */
  779.   xlenv = oldenv;
  780.   xlfenv = oldfenv;
  781.   xlpopn(2);
  782.   
  783.   return(result);
  784. }
  785.  
  786. /***********************************************************************/
  787. /**                                                                   **/
  788. /**                     Complex Number Functions                      **/
  789. /**                                                                   **/
  790. /***********************************************************************/
  791.  
  792. LVAL xsgetreal()
  793. {
  794.   LVAL arg = xlgetarg();
  795.   if (! numberp(arg)) xlerror("not a real number", arg);
  796.   return(arg);
  797. }
  798.  
  799. LVAL newicomplex(real, imag)
  800.     FIXTYPE real, imag;
  801. {
  802.   LVAL val;
  803.   
  804.   if (imag == 0) val = cvfixnum(real);
  805.   else {
  806.     xlsave1(val);
  807.     val = newvector(2);
  808.     val->n_type = COMPLEX;
  809.     setelement(val, 0, cvfixnum(real));
  810.     setelement(val, 1, cvfixnum(imag));
  811.     xlpop();
  812.   }
  813.   return(val);
  814. }
  815.  
  816. LVAL newdcomplex(real, imag)
  817.     double real, imag;
  818. {
  819.   LVAL val;
  820.   
  821.   xlsave1(val);
  822.   val = newvector(2);
  823.   val->n_type = COMPLEX;
  824.   setelement(val, 0, cvflonum((FLOTYPE) real));
  825.   setelement(val, 1, cvflonum((FLOTYPE) imag));
  826.   xlpop();
  827.   return(val);
  828. }
  829.  
  830. /* newcomplex - allocate and initialize a new object */
  831. LVAL newcomplex(real,imag)
  832.   LVAL real,imag;
  833. {
  834.   if (fixp(real) && fixp(imag))
  835.     return(newicomplex(getfixnum(real), getfixnum(imag)));
  836.   else
  837.     return(newdcomplex(makedouble(real), makedouble(imag)));
  838. }
  839.  
  840. LVAL xscomplexp()
  841. {
  842.   LVAL arg = xlgetarg();
  843.   xllastarg();
  844.   
  845.   return((complexp(arg)) ? s_true : NIL);
  846. }
  847.  
  848. LVAL realpart(x)
  849.     LVAL x;
  850. {
  851.   if (! complexp(x)) badcomplex(x);
  852.   return(getelement(x, 0));
  853. }
  854.  
  855. LVAL imagpart(x)
  856.     LVAL x;
  857. {
  858.   if (! complexp(x)) badcomplex(x);
  859.   return(getelement(x, 1));
  860. }
  861.  
  862. static LVAL xscomplex()
  863. {
  864.   LVAL real, imag;
  865.   
  866.   real = xsgetreal();
  867.   if (! moreargs()) return(real);
  868.   else {
  869.     imag = xsgetreal();
  870.     return(newcomplex(real, imag));
  871.   }
  872. }
  873.  
  874. static LVAL xsconjugate()
  875. {
  876.   LVAL arg = xlgetarg();
  877.   
  878.   xllastarg();
  879.   if (numberp(arg)) return(arg);
  880.   if (fixp(realpart(arg)) && fixp(imagpart(arg)))
  881.     return(newicomplex(getfixnum(realpart(arg)), -getfixnum(imagpart(arg))));
  882.   else
  883.     return(newdcomplex(makedouble(realpart(arg)), -makedouble(imagpart(arg))));
  884. }
  885.  
  886. static LVAL xsrealpart()
  887. {
  888.   LVAL arg = xlgetarg();
  889.   
  890.   xllastarg();
  891.   if (fixp(arg) || floatp(arg)) return(arg);
  892.   else return(realpart(arg));
  893. }
  894.  
  895. static LVAL xsimagpart()
  896. {
  897.   LVAL arg = xlgetarg();
  898.   
  899.   xllastarg();
  900.   if (fixp(arg)) return(cvfixnum((FIXTYPE) 0));
  901.   else if (floatp(arg)) return(cvflonum((FLOTYPE) 0.0));
  902.   else return(imagpart(arg));
  903. }
  904.  
  905. LVAL xsrcomplex()   { return (recursive_subr_map_elements(xscomplex, xsrcomplex));     }
  906. LVAL xsrconjugate() { return (recursive_subr_map_elements(xsconjugate, xsrconjugate)); }
  907. LVAL xsrrealpart()  { return (recursive_subr_map_elements(xsrealpart, xsrrealpart));   }
  908. LVAL xsrimagpart()  { return (recursive_subr_map_elements(xsimagpart, xsrimagpart));   }
  909.  
  910. static LVAL equaltest(use_eql)
  911.   int use_eql;
  912. {
  913.   LVAL arg1, arg2, r1, r2, i1, i2;
  914.   
  915.   if (! complexp(peekarg(0))) return((use_eql) ? xeql() : xequal());
  916.   else {
  917.     arg1 = xlgetarg();
  918.     arg2 = xlgetarg();
  919.     xllastarg();
  920.     
  921.     if (! complexp(arg2)) return(NIL);
  922.     
  923.     r1 = realpart(arg1);
  924.     i1 = imagpart(arg1);
  925.     r2 = realpart(arg2);
  926.     i2 = imagpart(arg2);
  927.     
  928.     if (fixp(r1) && fixp(i1) && fixp(r2) && fixp(i2)
  929.         && getfixnum(r1) == getfixnum(r2)
  930.         && getfixnum(i1) == getfixnum(i2))
  931.       return(s_true);
  932.     else if (floatp(r1) && floatp(i1) && floatp(r2) && floatp(i2)
  933.         && getflonum(r1) == getflonum(r2)
  934.         && getflonum(i1) == getflonum(i2))
  935.       return(s_true);
  936.     else return(NIL);
  937.   }
  938. }
  939.  
  940. LVAL xseql()   { return(equaltest(TRUE));  }
  941. LVAL xsequal() { return(equaltest(FALSE)); }
  942.  
  943. /***********************************************************************/
  944. /**                                                                   **/
  945. /**            Global Variable Declaration Function                   **/
  946. /**                                                                   **/
  947. /***********************************************************************/
  948.  
  949. void defconstant(sym, val)
  950.     LVAL sym, val;
  951. {
  952.   setvalue(sym, val);
  953.   setconstant(sym, TRUE);
  954. }
  955.  
  956. LVAL defsym(which)
  957.     int which;
  958. {
  959.   LVAL sym, val, doc;
  960.   
  961.   sym = xlgasymbol();
  962.   if (which == 'C' && isconstant(sym)) xlfail("can't assign to a constant");
  963.   switch (which) {
  964.   case 'C':
  965.   case 'P': val = xlgetarg(); break;
  966.   case 'V': val = (moreargs()) ? xlgetarg() : NIL; break;
  967.   }
  968.   doc = (moreargs()) ? xlgastring() : NIL;
  969.   xllastarg();
  970.   
  971.   switch (which) {
  972.   case 'C': defconstant(sym, xleval(val)); break;
  973.   case 'P': setvalue(sym, xleval(val));    break;
  974.   case 'V': if (getvalue(sym) == s_unbound) setvalue(sym, xleval(val)); break;
  975.   }
  976.   if (doc != NIL)
  977.     set_variable_docstring(sym, doc);
  978.   return(sym);
  979. }
  980.  
  981. LVAL xsdefconstant()  { return(defsym('C')); }
  982. LVAL xsdefparameter() { return(defsym('P')); }
  983. LVAL xsdefvar()       { return(defsym('V')); }
  984.  
  985. LVAL xsmakunbound()
  986. {
  987.   LVAL sym;
  988.   
  989.   sym = xlgasymbol();
  990.   xllastarg();
  991.   
  992.   setvalue(sym, s_unbound);
  993.   setconstant(sym, FALSE);
  994.   return(sym);
  995. }
  996.  
  997. LVAL xsfmakunbound()
  998. {
  999.   LVAL sym;
  1000.   
  1001.   sym = xlgasymbol();
  1002.   xllastarg();
  1003.   
  1004.   setfunction(sym,s_unbound);
  1005.   return(sym);
  1006. }
  1007.  
  1008. int keep_doc_strings()
  1009. {
  1010.   return(getvalue(xlenter("*KEEP-DOCUMENTATION-STRINGS*")) != NIL);
  1011. }
  1012.  
  1013. void set_function_docstring(sym, str)
  1014.     LVAL sym, str;
  1015. {
  1016.   if (keep_doc_strings())
  1017.     xlputprop(sym, str, s_function_documentation);
  1018. }
  1019.  
  1020. void set_variable_docstring(sym, str)
  1021.     LVAL sym, str;
  1022. {
  1023.   if (keep_doc_strings())
  1024.     xlputprop(sym, str, s_variable_documentation);
  1025. }
  1026.  
  1027. /***********************************************************************/
  1028. /**                                                                   **/
  1029. /**                  Features Maintenance Functions                   **/
  1030. /**                                                                   **/
  1031. /***********************************************************************/
  1032.  
  1033. static int is_member(x, list)
  1034.     LVAL x, list;
  1035. {
  1036.   int result = FALSE;
  1037.   
  1038.   for (; ! result && consp(list); list = cdr(list))
  1039.     if (equal(x, car(list))) result = TRUE;
  1040.   return(result);
  1041. }
  1042.  
  1043. int checkfeatures(arg, which)
  1044.     LVAL arg;
  1045.     int which;
  1046. {
  1047.   int has_feature;
  1048.   LVAL features = getvalue(s_features);
  1049.   
  1050.   if (consp(arg)) {
  1051.     if (car(arg) == s_and)
  1052.       for (has_feature = TRUE, arg = cdr(arg);
  1053.            consp(arg) && has_feature;
  1054.            arg = cdr(arg)) {
  1055.         has_feature = has_feature && checkfeatures(car(arg), which);
  1056.       }
  1057.     else if (car(arg) == s_or)
  1058.       for (has_feature = FALSE, arg = cdr(arg);
  1059.            consp(arg) && ! has_feature;
  1060.            arg = cdr(arg)) {
  1061.         has_feature = has_feature || checkfeatures(car(arg), which);
  1062.       }
  1063.     else if (car(arg) == s_not && consp(cdr(arg)))
  1064.       has_feature = ! checkfeatures(car(cdr(arg)), which);
  1065.     else xlerror("bad feature", arg);
  1066.   }
  1067.   else has_feature = is_member(arg, features);
  1068.   
  1069.   if (which == '-') has_feature = ! has_feature;
  1070.   return(has_feature);
  1071. }
  1072.  
  1073. /***********************************************************************/
  1074. /**                                                                   **/
  1075. /**                  Time and Environment Functions                   **/
  1076. /**                                                                   **/
  1077. /***********************************************************************/
  1078.  
  1079. LVAL xstime()
  1080. {
  1081.   LVAL result;
  1082.   unsigned long tm;
  1083.   double dtm;
  1084.   
  1085.   tm = run_tick_count();
  1086.   result = xeval();
  1087. #ifndef AMIGA
  1088.   tm = run_tick_count() - tm;
  1089.   dtm = (tm > 0) ? tm : -tm;
  1090. #else
  1091.   dtm = run_tick_count() - tm; /* changed due to bug in Lattice C v5.05 JKL */
  1092.   dtm = (dtm > 0) ? dtm : -dtm;
  1093. #endif AMIGA
  1094.  
  1095.   sprintf(buf, "The evaluation took %.2f seconds\n", dtm / ticks_per_second());
  1096.   stdputstr(buf);
  1097.   return(result);
  1098. }
  1099.  
  1100. LVAL xs_get_internal_run_time() { return(cvfixnum((FIXTYPE) run_tick_count())); }
  1101.  
  1102. LVAL xs_get_internal_real_time() { return(cvfixnum((FIXTYPE) real_tick_count())); }
  1103.  
  1104. LVAL xsgetenv()
  1105. {
  1106.   xllastarg();
  1107.   return(list3(xlenv, xlfenv, xldenv));
  1108. }
  1109.  
  1110. /***********************************************************************/
  1111. /**                                                                   **/
  1112. /**                       Concatenate Function                        **/
  1113. /**                                                                   **/
  1114. /***********************************************************************/
  1115.  
  1116. static int sequence_length(x)
  1117.     LVAL x;
  1118. {
  1119.   if (simplevectorp(x)) return(getsize(x));
  1120.   else if (listp(x)) return(llength(x));
  1121.   else if (stringp(x)) return(strlen(getstring(x)));
  1122.   else badseq(x);
  1123. }
  1124.  
  1125. static int reslength(x)
  1126.     LVAL x;
  1127. {
  1128.   int n;
  1129.   
  1130.   for (n = 0; consp(x); x = cdr(x)) n += sequence_length(car(x));
  1131.   return(n);
  1132. }
  1133.  
  1134. static LVAL makeseq(type, n)
  1135.     LVAL type;
  1136.     int n;
  1137. {
  1138.   LVAL result;
  1139.   int i;
  1140.   
  1141.   if (type == s_list) result = mklist(n, NIL);
  1142.   else if (type == s_vector) result = newvector(n);
  1143.   else if (type == a_string) {
  1144.     result = newstring(n + 1);
  1145.     for (i = 0; i < n; i++) getstring(result)[i] = ' ';
  1146.     getstring(result)[n] = '\0';
  1147.   }
  1148.   else xlerror("bad sequence type", type);
  1149.   return(result);
  1150. }
  1151.  
  1152. static LVAL next_elt(x, i)
  1153.     LVAL *x;
  1154.     int i;
  1155. {
  1156.   LVAL result;
  1157.   
  1158.   if (consp(*x)) {
  1159.     result = car(*x);
  1160.     *x = cdr(*x);
  1161.   }
  1162.   else if (simplevectorp(*x)) result = getelement(*x, i);
  1163.   else if (stringp(*x)) result = cvchar(getstring(*x)[i]);
  1164.   else badseq(*x);
  1165.   
  1166.   return(result);
  1167. }
  1168.  
  1169. static void set_next_elt(x, i, val)
  1170.     LVAL *x, val;
  1171.     int i;
  1172. {
  1173.   if (consp(*x)) {
  1174.     rplaca(*x, val);
  1175.     *x = cdr(*x);
  1176.   }
  1177.   else if (simplevectorp(*x)) setelement(*x, i, val);
  1178.   else if (stringp(*x)) {
  1179.     if (! charp(val)) xlerror("not a character", val);
  1180.     getstring(*x)[i] = getchcode(val);
  1181.   }
  1182.   else badseq(*x);
  1183. }
  1184.  
  1185. LVAL concatenate(type, sequences)
  1186.     LVAL type, sequences;
  1187. {
  1188.   LVAL result, next, seq, x;
  1189.   int i, j, n, m;
  1190.   
  1191.   xlstkcheck(3);
  1192.   xlprotect(sequences);
  1193.   xlsave(result);
  1194.   xlsave(x);
  1195.   
  1196.   n = reslength(sequences);
  1197.   result = makeseq(type, n);
  1198.   next = result;
  1199.   
  1200.   for (i = 0; consp(sequences); sequences = cdr(sequences)) {
  1201.     seq = car(sequences);
  1202.     m = sequence_length(seq);
  1203.     for (j = 0; j < m; i++, j++) {
  1204.       x = next_elt(&seq, j);
  1205.       set_next_elt(&next, i, x);
  1206.     }
  1207.   }
  1208.   
  1209.   xlpopn(3);
  1210.   return(result);
  1211. }
  1212.  
  1213. LVAL xsconcatenate()
  1214. {
  1215.   LVAL type, sequences, result;
  1216.   
  1217.   xlsave1(sequences);
  1218.   type = xlgasymbol();
  1219.   sequences = makearglist(xlargc, xlargv);
  1220.   result = concatenate(type, sequences);
  1221.   xlpop();
  1222.   return(result);
  1223. }
  1224.  
  1225. /***********************************************************************/
  1226. /**                                                                   **/
  1227. /**                      SOME and EVERY Functions                     **/
  1228. /**                                                                   **/
  1229. /***********************************************************************/
  1230.  
  1231. static LVAL every_some(which, negate)
  1232.     int which, negate;
  1233. {
  1234.   LVAL fcn, args, result;
  1235.   int nargs, i, rlen;
  1236.  
  1237.   /* protect some pointers */
  1238.   xlstkcheck(2);
  1239.   xlsave(args);
  1240.   xlsave(fcn);
  1241.  
  1242.   fcn = xlgetarg();
  1243.   args = makearglist(xlargc, xlargv);
  1244.   rlen = findrlen(args);
  1245.   nargs = llength(args);
  1246.  
  1247.   result = NIL;
  1248.   for (i = 0; i < rlen; i++) {
  1249.     pushnextargs(fcn, nargs, args, i);
  1250.     result = xlapply(nargs);
  1251.     if (which == 'A') {
  1252.       if (result != NIL) break;
  1253.     }
  1254.     else if (result == NIL) break;
  1255.   }
  1256.   if (negate) result = (result == NIL) ? s_true : NIL;
  1257.   
  1258.   /* restore the stack frame */
  1259.   xlpopn(3);
  1260.   
  1261.   return(result);
  1262. }
  1263.  
  1264. LVAL xssome()     { return(every_some('A', FALSE)); }
  1265. LVAL xsevery()    { return(every_some('E', FALSE)); }
  1266. LVAL xsnotany()   { return(every_some('A', TRUE));  }
  1267. LVAL xsnotevery() { return(every_some('E', TRUE));  }
  1268.  
  1269. /***********************************************************************/
  1270. /**                                                                   **/
  1271. /**                          Set Functions                            **/
  1272. /**                                                                   **/
  1273. /***********************************************************************/
  1274.  
  1275. /* apply MEMBER function, allowing for extra arguments. args should    */
  1276. /* contain two postitons for x and list arguments, and should be       */
  1277. /* protected from garbage collection before the call.                  */
  1278. static int apply_member(x, list, args)
  1279.     LVAL x, list, args;
  1280. {
  1281. /*  LVAL result;  slightly rewritten below JKL */
  1282.   
  1283.   if (consp(args) && consp(cdr(args))) {
  1284.     rplaca(args, x);
  1285.     rplaca(cdr(args), list);
  1286.   }
  1287. /*  result = xsapplysubr(xmember, args); */
  1288.   return(/*result*/ xsapplysubr(xmember, args) != NIL ? TRUE : FALSE);
  1289. }
  1290.  
  1291. static LVAL set_op(which)
  1292.     int which;
  1293. {
  1294.   LVAL x, list1, list2, rest, result;
  1295.   
  1296.   xlstkcheck(2);
  1297.   xlsave(rest);
  1298.   xlsave(result);
  1299.   
  1300.   list1 = xlgalist();
  1301.   list2 = xlgalist();
  1302.   rest = makearglist(xlargc, xlargv);
  1303.   rest = cons(NIL, rest);
  1304.   rest = cons(NIL, rest);
  1305.   
  1306.   switch(which) {
  1307.   case 'U':
  1308.     for (result = list1; consp(list2); list2 = cdr(list2)) {
  1309.       x = car(list2);
  1310.       if (! apply_member(x, list1, rest)) result = cons(x, result);
  1311.     }
  1312.     break;
  1313.   case 'I':
  1314.     for (result = NIL; consp(list2); list2 = cdr(list2)) {
  1315.       x = car(list2);
  1316.       if (apply_member(x, list1, rest)) result = cons(x, result);
  1317.     }
  1318.     break;
  1319.   case 'D':
  1320.     for (result = NIL; consp(list1); list1 = cdr(list1)) {
  1321.       x = car(list1);
  1322.       if (! apply_member(x, list2, rest)) result = cons(x, result);
  1323.     }
  1324.     break;
  1325.   case 'S':
  1326.     for (result = s_true; consp(list1); list1 = cdr(list1)) {
  1327.       x = car(list1);
  1328.       if (!apply_member(x, list2, rest)) {
  1329.         result = NIL;
  1330.         break;
  1331.       }
  1332.     }
  1333.     break;
  1334.   }
  1335.   
  1336.   xlpopn(2);
  1337.   return(result);
  1338. }
  1339.  
  1340. LVAL xsunion()          { return(set_op('U')); }
  1341. LVAL xsintersection()   { return(set_op('I')); }
  1342. LVAL xsset_difference() { return(set_op('D')); }
  1343. LVAL xssubsetp()        { return(set_op('S')); }
  1344.  
  1345. LVAL xsremove_duplicates()
  1346. {
  1347.   LVAL x, list, rest, result, tail;
  1348.   
  1349.   xlstkcheck(2);
  1350.   xlsave(rest);
  1351.   xlsave(result);
  1352.   
  1353.   list = xlgalist();
  1354.   rest = makearglist(xlargc, xlargv);
  1355.   rest = cons(NIL, rest);
  1356.   rest = cons(NIL, rest);
  1357.   
  1358.   for (result = NIL; consp(list); list = cdr(list)) {
  1359.     x = car(list);
  1360.     if (! apply_member(x, result, rest)) {
  1361.       if (result == NIL) {
  1362.         result = consa(x);
  1363.         tail = result;
  1364.       }
  1365.       else {
  1366.         rplacd(tail, consa(x));
  1367.         tail = cdr(tail);
  1368.       }
  1369.     }
  1370.   }
  1371.   xlpopn(2);
  1372.   return(result);
  1373. }
  1374.   
  1375. LVAL xsbutlast()
  1376. {
  1377.   LVAL x, next;
  1378.   int n, k;
  1379.   
  1380.   xlsave1(x);
  1381.   x = xlgalist();
  1382.   k = (moreargs()) ? getfixnum(xlgafixnum()) : 1;
  1383.   xllastarg();
  1384.   
  1385.   x = copylist(x);
  1386.   n = llength(x) - k;
  1387.   if (n <= 0) x = NIL;
  1388.   else if (k >= 1) {
  1389.     for (next = x; consp(next) && consp(cdr(next)) && n > 1; next = cdr(next), n--);
  1390.     rplacd(next, NIL);
  1391.   }
  1392.   
  1393.   xlpop();
  1394.   return(x);
  1395. }
  1396.  
  1397. static void badseq(s)
  1398.     LVAL s;
  1399. { 
  1400.   xlerror("not a sequence", s);
  1401. }
  1402.  
  1403. static void badindex(i)
  1404.     LVAL i;
  1405. {
  1406.   xlerror("not a valid index", i);
  1407. }
  1408.  
  1409. static void badcomplex(c)
  1410.     LVAL c;
  1411. {
  1412.   xlerror("not a valid complex number", c);
  1413. }
  1414.  
  1415. LVAL xsmake_string()
  1416. {
  1417.   int n, i;
  1418.   char c = ' ';
  1419.   LVAL arg, result;
  1420.   
  1421.   n = getfixnum(xlgafixnum());
  1422.   if (xlgetkeyarg(s_ielement, &arg)) {
  1423.     if (! charp(arg)) xlerror("not a character", arg);
  1424.     c = getchcode(arg);
  1425.   }
  1426.   result = newstring(n + 1);
  1427.   for (i = 0; i < n; i++)
  1428.     getstring(result)[i] = c;
  1429.   getstring(result)[n] = '\0';
  1430.   return(result);
  1431. }
  1432.  
  1433. /***********************************************************************/
  1434. /**                                                                   **/
  1435. /**                         FIND and POSITION                         **/
  1436. /**                                                                   **/
  1437. /***********************************************************************/
  1438.  
  1439. LVAL xsfind()
  1440. {
  1441.   LVAL result = xmember();
  1442.   return(consp(result) ? car(result) : NIL);
  1443. }
  1444.  
  1445. LVAL xsposition()
  1446. {
  1447.   int n;
  1448.   LVAL result;
  1449.   
  1450.   if (xlargc < 2 || ! listp(peekarg(1))) xlfail("bad arguments");
  1451.   n = llength(peekarg(1));
  1452.   result = xmember();
  1453.   n -= consp(result) ? llength(result) : 0;
  1454.   return(consp(result) ? cvfixnum((FIXTYPE) n) : NIL);
  1455. }
  1456.  
  1457. /***********************************************************************/
  1458. /**                                                                   **/
  1459. /**                         ERROR and BREAK                           **/
  1460. /**                                                                   **/
  1461. /***********************************************************************/
  1462.  
  1463. LVAL xserror()
  1464. {
  1465.   LVAL result;
  1466.   
  1467.   xlprot1(result);
  1468.   result = makearglist(xlargc, xlargv);
  1469.   result = cons(NIL, result);
  1470.   result = xsapplysubr(xsformat, result);
  1471.   result = consa(result);
  1472.   result = xsapplysubr(xerror, result);
  1473.   xlpop();
  1474.   
  1475.   return(result);
  1476. }
  1477.  
  1478. LVAL xsbreak()
  1479. {
  1480.   LVAL result;
  1481.   
  1482.   if (moreargs()) {
  1483.     xlprot1(result);
  1484.     result = makearglist(xlargc, xlargv);
  1485.     result = cons(NIL, result);
  1486.     result = xsapplysubr(xsformat, result);
  1487.     result = consa(result);
  1488.     result = xsapplysubr(xbreak, result);
  1489.     xlpop();
  1490.   }
  1491.   else result = xbreak();
  1492.   return(result);
  1493. }
  1494.