home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / xlisp2tc / _turboc_ / xl-cl001.fix < prev    next >
Encoding:
Internet Message Format  |  1991-04-14  |  41.9 KB
  1. From sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Sat Sep 16 08:20:18 EDT 1989
  2. Article: 1 of comp.lang.lisp.x
  3. Path: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
  4. From: toma@tekgvs.LABS.TEK.COM (Tom Almy)
  5. Newsgroups: comp.lang.lisp.x
  6. Subject: XLISP 2.0 BUG(?)
  7. Message-ID: <5911@tekgvs.LABS.TEK.COM>
  8. Date: 11 Sep 89 14:34:11 GMT
  9. Reply-To: toma@tekgvs.LABS.TEK.COM (Tom Almy)
  10. Organization: Tektronix, Inc., Beaverton,  OR.
  11. Lines: 22
  12.  
  13.  
  14. Part of my effort to make xlisp more compatible with Common Lisp:
  15.  
  16. Problem: Functions which take the :end keyword argument do not allow NIL
  17.     to mean "end of list" as in Common Lisp.
  18.  
  19. Example: (string-downcase "ABC DEF" :start 4 :end NIL) gives an error.
  20.  
  21. Fix: in function getbounds() in file xlstr.c, change
  22.  
  23.     if (xlgkfixnum(ekey,&arg)) {
  24.         *pend = (int)getfixnum(arg);
  25.  
  26. to
  27.     if (xlgetkeyarg(ekey, &arg) && arg != NIL) {
  28.         if (!fixp(arg)) xlbadtype(arg);
  29.         *pend = (int)getfixnum(arg);
  30.  
  31.  
  32. Tom Almy
  33. toma@tekgvs.labs.tek.com
  34. Standard Disclaimers Apply
  35.  
  36.  
  37. From sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Sat Sep 16 08:20:26 EDT 1989
  38. Article: 2 of comp.lang.lisp.x
  39. Path: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
  40. From: toma@tekgvs.LABS.TEK.COM (Tom Almy)
  41. Newsgroups: comp.lang.lisp.x
  42. Subject: XLISP 2.0 Modifications (1 of 2)
  43. Message-ID: <5918@tekgvs.LABS.TEK.COM>
  44. Date: 11 Sep 89 22:25:11 GMT
  45. Reply-To: toma@tekgvs.LABS.TEK.COM (Tom Almy)
  46. Organization: Tektronix, Inc., Beaverton,  OR.
  47. Lines: 393
  48.  
  49. I have recently been adding a few Common Lisp functions to XLISP 2.0, and
  50. makeing some existing functions more Common-Lisp compatible (particularly
  51. in making functions that are supposed to take sequence arguments (in XLISP
  52. that would be lists, arrays, or strings) actually take them.
  53.  
  54. These changes produce the following consequences:
  55.  
  56. 1.  Functions with names starting with "STRING" will accept a symbol as
  57.     the string argument.  The symbols printname string is used.
  58.  
  59. 2.  STRCAT is eliminated (a macro is placed in init.lsp for backwards
  60.     compatibility).  The replacement function is CONCATENATE which will
  61.     concatenate sequences of any type(s) into a result sequence of any
  62.     type.  It is used: (CONCATENATE <type> <seq1> [<seq2> ...]) where 
  63.     type is the result type, one of CONS ARRAY or STRING.
  64.  
  65. 3.  AREF will work on strings as well as arrays.
  66.  
  67. 4.  SUBSEQ REVERSE REMOVE... DELETE... take sequence arguments rather 
  68.     than just list arguments.
  69.  
  70. 5.  REMOVE... and DELETE... accept :start and :end keyword arguments.
  71.  
  72. 6.  Added function (ELT <seq> <index>) which combines the functionality
  73.     of AREF and NTH.
  74.  
  75. 7.  Added function (MAP <type> <fcn> <seq1> [<seq2> ...]) a mapping
  76.     function over sequences.  The resulting sequence is of type <type>,
  77.     which is one of CONS ARRAY STRING or NIL (meaning no, or NIL, result).
  78.  
  79. 8.  Added functions POSITION-IF, FIND-IF, and COUNT-IF, which work
  80.     analogously to REMOVE-IF, but return the position of the first match,
  81.     the first match, and number of matches, respectively.
  82.  
  83. 9.  Added function (SEARCH <seq1> <seq2> &key :test :test-not :start1
  84.     :end1 :start2 :end2) which returns the index of the first occurance
  85.     of seq1 in seq2. For example (search #(a b c) '(a b a b c d)) returns
  86.     2.
  87.  
  88. 10. Added function (COERCE <expr> <type>) which can coerce between 
  89.     sequence types and in a limited basis to characters or floating point
  90.     numbers.
  91.  
  92.  
  93. This is the first of two parts.  The final line in this file is "This is
  94. the end of part 1."
  95.  
  96.  
  97. Tom Almy
  98. September 11, 1989
  99. toma@tekgvs.labs.tek.com
  100. Standard Disclaimers Apply
  101.  
  102.  
  103. ***************************************
  104. The first change reduces the amount of code.
  105.  
  106. In xlsubr.c, add the following definition:
  107.  
  108. /* xlbadtype - report a "bad argument type" error */
  109. LVAL xlbadtype(arg)
  110.   LVAL arg;
  111. {
  112.     return xlerror("bad argument type",arg);
  113. }
  114.  
  115.  
  116. Then replace all occurances of `xlerror("bad argument type",' with
  117. `xlbadtype(' throughout the program (including xlisp.h).
  118.  
  119. ***************************************
  120.  
  121. Add the file xlseq.c to your "makefile" in an appropriate manner.
  122.  
  123. ***************************************
  124. Add definition in xlisp.h:
  125.  
  126. #define xlgastrorsym()  (testarg(symbolp(*xlargv) ? getpname(nextarg()) : typearg(stringp)))
  127.  
  128. Added external declaration in xlisp.h:
  129. extern LVAL xlbadtype();        /* report "bad argument type" error */
  130.  
  131.  
  132.  
  133. ***************************************
  134. Add to init.lsp:
  135. (unless (fboundp 'strcat) ; backwards compatibility 
  136.     (defmacro strcat (&rest str) `(concatenate 'string ,@str)))
  137.  
  138.  
  139.  
  140. ***************************************
  141. In xlftab.c, add the following external declaration:
  142. extern LVAL
  143.     xcoerce(), xconcatenate(), xelt(), xmap(), xsearch(), xpositionif(),
  144.     xcountif(),xfindif();
  145.  
  146. delete the declaration for xstrcat.
  147.  
  148. In funtab[], replace the definition for STRCAT with:
  149.  
  150. {   "CONCATENATE",      S, xconcatenate }, /* 168 */
  151.  
  152. Replace NULL definitions at the end of the table with new definitions,
  153. being sure to keep the table length constant.
  154.  
  155. {   "COUNT-IF",         S, xcountif     }, /* 287 */
  156. {   "FIND-IF",          S, xfindif      }, /* 288 */
  157. {   "COERCE",           S, xcoerce      }, /* 289 */
  158. {   "ELT",              S, xelt         }, /* 290 */
  159. {   "MAP",              S, xmap         }, /* 291 */
  160. {   "POSITION-IF",      S, xpositionif  }, /* 292 */
  161. {   "SEARCH",           S, xsearch      }, /* 293 */
  162.  
  163. *******************************
  164.  
  165. In file xlglob.c, add the following definition:
  166.  
  167. LVAL s_elt = NIL;
  168.  
  169. *******************************
  170.  
  171. In file xlinit.c, add the following external declaration:
  172.  
  173. extern LVAL s_elt;
  174.  
  175. in function xlsymbols(), in section "enter setf place specifiers", add
  176.  
  177.     s_elt   = xlenter("ELT");
  178.  
  179. *******************************
  180.  
  181. In file xlbfun.c, function xaref(), change
  182.  
  183.     array = xlgavector();
  184.  
  185. to
  186.  
  187.     array = xlgetarg();
  188.  
  189. Before the section titled "range check the index" add:
  190.  
  191.     if (stringp(array)) {   /* extension -- allow fetching chars from string*/
  192.         if (i < 0 || i >= getslength(array)-1)
  193.             xlerror("string index out of bounds",index);
  194.         return (cvchar(array->n_string[i]));
  195.     }
  196.     
  197.     if (!vectorp(array)) xlbadtype(array);  /* type must be array */
  198.  
  199. ******************************
  200. In xlcont.c, add the following declaration:
  201.  
  202. extern LVAL s_elt;
  203.  
  204.  
  205. In function placeform(), replace the fun == s_aref code with:
  206.  
  207.         xlsave1(arg1);
  208.  
  209.         arg1 = evarg(&place);   /* allow string argument */
  210.         arg2 = evmatch(FIXNUM,&place); i = getfixnum(arg2);
  211.         if (place) toomany(place);
  212.  
  213.         if (stringp(arg1)) {    /* extension for strings */
  214.             if (i < 0 || i >= getslength(arg1)-1)
  215.                 xlerror("index out of range",arg2);
  216.             if (!charp(value)) 
  217.                 xlerror("strings only contain characters",value);
  218.             arg1->n_string[i] = getchcode(value);
  219.         }
  220.         else if(vectorp(arg1)) {
  221.             if (i < 0 || i >= getsize(arg1))
  222.                 xlerror("index out of range",arg2);
  223.             setelement(arg1,(int)i,value);
  224.         }
  225.         else xlbadtype(arg1);
  226.         xlpop();
  227.  
  228. Then add the following "case":
  229.  
  230.     else if (fun == s_elt) {
  231.         xlsave1(arg1);
  232.         arg1 = evarg(&place);
  233.         arg2 = evmatch(FIXNUM,&place); i = getfixnum(arg2);
  234.         if (place) toomany(place);
  235.         if (listp(arg1)) {
  236.             for (; i > 0 && consp(arg1); --i)
  237.                 arg1 = cdr(arg1);
  238.             if((!consp(arg1)) || i < 0)
  239.                 xlerror("index out of range",arg2);
  240.             rplaca(arg1,value);
  241.         }
  242.         else if (ntype(arg1) == STRING) {
  243.             if (i < 0 || i >= getslength(arg1)-1)
  244.                 xlerror("index out of range",arg2);
  245.             if (!charp(value)) 
  246.                 xlerror("strings only contain characters",value);
  247.             arg1->n_string[i] = getchcode(value);
  248.         }
  249.         else if (ntype(arg1) == VECTOR) {
  250.             if (i < 0 || i >= getsize(arg1))
  251.                 xlerror("index out of range",arg2);
  252.             setelement(arg1,(int)i,value);
  253.         }
  254.         else xlbadtype(arg1);
  255.         xlpop();
  256.     }
  257.  
  258. ***************************
  259.  
  260. In xlstr.c, function changecase(), change
  261.  
  262.     src = xlgastring();
  263.  
  264. to
  265.  
  266.     src = (destructive? xlgastring() : xlgastrorsym());
  267.  
  268.  
  269. In function strcompare(), change references to xlgastring to xlgastrorsym.
  270.  
  271. In function trim(), change references to xlgastring to xlgastrorsym.
  272.  
  273.  
  274. Delete functions xstrcat() and xsubseq().  The latter is rewritten and
  275. will be in a new file, xlseq.c
  276.  
  277. ****************************************
  278. In file xlsys.c, add the following:
  279.  
  280. int xlcvttype(arg)  /* find type of argument and return it */
  281. LVAL arg;
  282. {
  283.     if (arg == a_subr)      return SUBR;
  284.     if (arg == a_fsubr)     return FSUBR;
  285.     if (arg == a_cons)      return CONS;
  286.     if (arg == a_symbol)    return SYMBOL;
  287.     if (arg == a_fixnum)    return FIXNUM;
  288.     if (arg == a_flonum)    return FLONUM;
  289.     if (arg == a_string)    return STRING;
  290.     if (arg == a_object)    return OBJECT;
  291.     if (arg == a_stream)    return STREAM;
  292.     if (arg == a_vector)    return VECTOR;
  293.     if (arg == a_closure)   return CLOSURE;
  294.     if (arg == a_char)      return CHAR;
  295.     if (arg == a_ustream)   return USTREAM;
  296.     return 0;
  297. }
  298.  
  299. LOCAL LVAL listify(arg) /* arg must be vector or string */
  300. LVAL arg;
  301. {
  302.     LVAL val;
  303.     int i;
  304.     
  305.     xlsave1(val);
  306.     
  307.     if (ntype(arg) == VECTOR) {
  308.         for (i = getsize(arg); i-- > 0; ) 
  309.             val = cons(getelement(arg,i),val);
  310.     }
  311.     else {  /* a string */
  312.         for (i = getslength(arg)-1; i-- > 0; )
  313.             val = cons(cvchar(arg->n_string[i]),val);
  314.     }
  315.     
  316.     xlpop();
  317.     return (val);
  318. }
  319.  
  320. LOCAL LVAL vectify(arg) /* arg must be string or cons */
  321. LVAL arg;
  322. {
  323.     LVAL val,temp;
  324.     int i,l;
  325.     
  326.     if (ntype(arg) == STRING) {
  327.         l = getslength(arg)-1;
  328.         val = newvector(l);
  329.         for (i=0; i < l; i++) setelement(val,i,cvchar(arg->n_string[i]));
  330.     }
  331.     else {  /* a cons */
  332.         val = arg;
  333.         for (l = 0; consp(val); l++) val = cdr(val); /* get length */
  334.         val = newvector(l);
  335.         temp = arg;
  336.         for (i = 0; i < l; i++) {
  337.             setelement(val,i,car(temp));
  338.             temp = cdr(temp);
  339.         }
  340.     }
  341.         return val;
  342. }
  343.  
  344.  
  345. LOCAL LVAL stringify(arg)   /* arg must be vector or cons */
  346. LVAL arg;
  347. {
  348.     LVAL val,temp;
  349.     int i,l;
  350.     
  351.     if (ntype(arg) == VECTOR) {
  352.         l = getsize(arg);
  353.         val = newstring(l+1);
  354.         for (i=0; i < l; i++) {
  355.             temp = getelement(arg,i);
  356.             if (ntype(temp) != CHAR) goto failed;
  357.             val->n_string[i] = getchcode(temp);
  358.         }
  359.         val->n_string[l] = 0;
  360.         return val;
  361.     }
  362.     else {  /* must be cons */
  363.         val = arg;
  364.         for (l = 0; consp(val); l++) {
  365.             if (ntype(car(val)) != CHAR) goto failed;
  366.             val = cdr(val); /* get length */
  367.         }
  368.  
  369.         val = newstring(l+1);
  370.         temp = arg;
  371.         for (i = 0; i < l; i++) {
  372.             val->n_string[i] = getchcode(car(temp));
  373.             temp = cdr(temp);
  374.         }
  375.         val->n_string[l] = 0;
  376.         return val;
  377.     }
  378. failed:
  379.     xlerror("cannot make into string", arg);
  380. }
  381.  
  382.  
  383.  
  384. /* coerce function */
  385. LVAL xcoerce()
  386. {
  387.     LVAL type, arg, temp;
  388.     int newtype,oldtype;
  389.  
  390.     arg = xlgetarg();
  391.     type = xlgetarg();
  392.     xllastarg();
  393.     
  394.     if ((newtype = xlcvttype(type)) == 0) goto badconvert;
  395.  
  396.     oldtype = ntype(arg);
  397.     if (oldtype == newtype) return (arg);   /* easy case! */
  398.     
  399.     switch (newtype) {
  400.         case CONS: if ((oldtype == STRING)|(oldtype == VECTOR))
  401.             return (listify(arg));
  402.             break;
  403.         case STRING: if ((oldtype == CONS)|(oldtype == VECTOR))
  404.             return (stringify(arg));
  405.             break;
  406.         case VECTOR: if ((oldtype == STRING) | (oldtype == CONS))
  407.             return (vectify(arg));
  408.             break;
  409.         case CHAR:
  410.             if (oldtype == FIXNUM) return cvchar((int)getfixnum(arg));
  411.             else if ((oldtype == STRING) && (getslength(arg) == 2))
  412.                 return cvchar(arg->n_string[0]);
  413.             else if (oldtype == SYMBOL) {
  414.                 temp = getpname(arg);
  415.                 if (getslength(temp) == 2) return cvchar(temp->n_string[0]);
  416.             }
  417.             break;
  418.         case FLONUM:
  419.             if (oldtype == FIXNUM) return (cvflonum(1.0*(int)getfixnum(arg)));
  420.             break;
  421.     }
  422.  
  423.  
  424. badconvert:
  425.     xlerror("illegal coersion",arg);
  426.  
  427. }
  428.  
  429.  
  430. ******************************
  431.  
  432. In file xllist.c, delete the functions xreverse(), xremove(), remif(), 
  433. xremif(), xremifnot(), xdelete(), delif(), xdelif(), xdelifnot(), dotest1().
  434. These functions will be in the new file xlseq.c.
  435.  
  436. Remove any LOCAL atribute to function dotest2().
  437.  
  438.  
  439. ******************************
  440.  
  441. This is the end of part 1.
  442.  
  443.  
  444. From sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Sat Sep 16 08:20:33 EDT 1989
  445. Article: 3 of comp.lang.lisp.x
  446. Path: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
  447. From: toma@tekgvs.LABS.TEK.COM (Tom Almy)
  448. Newsgroups: comp.lang.lisp.x
  449. Subject: XLISP 2.0 MODIFICATIONS (2 of 2)
  450. Message-ID: <5919@tekgvs.LABS.TEK.COM>
  451. Date: 11 Sep 89 22:26:44 GMT
  452. Reply-To: toma@tekgvs.LABS.TEK.COM (Tom Almy)
  453. Organization: Tektronix, Inc., Beaverton,  OR.
  454. Lines: 1073
  455.  
  456. The remainder of the changes consists of the file xlseq.c.
  457.  
  458.  
  459. Tom Almy
  460. September 11, 1989
  461. toma@tekgvs.labs.tek.com
  462. Standard Disclaimers Apply
  463.  
  464.  
  465. ******************************
  466.  
  467. /* xlseq.c - xlisp sequence functions */
  468. /*  Written by Thomas Almy, based on code:
  469.     Copyright (c) 1985, by David Michael Betz
  470.     All Rights Reserved
  471.     Permission is granted for unrestricted non-commercial use   */
  472.  
  473. #include "xlisp.h"
  474.  
  475. /* external procedures */
  476. extern int xlcvttype();
  477. extern int xlgkfixnum();
  478. extern int xlgetkeyarg();
  479.  
  480. /* external variables */
  481. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  482.  
  483.  
  484. /* Apologies from the author (Tom Almy):
  485.    :start and :end isn't quite Kosher in
  486.    that it doesn't always signal an error for out of range.
  487.    Fixing it up is left as an exercise for the reader.*/
  488.  
  489. /* I desparately needed a "MAXINT" or "MAXLONG" constant, so I faked it*/
  490.  
  491. /* Also, I found it convenient to use "goto" statements to handle non-local
  492.    loop exits and jumps to common error routines.  A purist might complain,
  493.    but I think the code is cleaner and easier to follow this way. */
  494.  
  495. #define MAXSIZE 10000000L   /* a lie, but good enough */
  496.  
  497. LOCAL VOID getseqbounds(start,end,length,startkey,endkey)
  498. long *start, *end, length;
  499. LVAL *startkey, *endkey;
  500. {
  501.     LVAL arg;
  502.     
  503.     if (xlgkfixnum(*startkey,&arg)) {
  504.         *start = (long)getfixnum(arg);
  505.         if (*start < 0 || *start > length ) goto rangeError;
  506.     }
  507.     else *start = 0;
  508.     
  509.     if (xlgetkeyarg(*endkey, &arg) && arg != NIL) {
  510.         if (!fixp(arg)) xlbadtype(arg);
  511.         *end = (long)getfixnum(arg);
  512.         if (*end < 0  || *end > length) goto rangeError;
  513.     }
  514.     else *end = length; /* we need a maxint value! */
  515.     
  516.     if (*start <= *end)     return;
  517.     /* else there is a range error */
  518.     
  519. rangeError:
  520.     xlerror("range error",arg);
  521. }
  522.         
  523.  
  524.  
  525. /* dotest1 - call a test function with one argument */
  526. /* this function was in xllist.c */
  527. int dotest1(arg,fun)
  528.   LVAL arg,fun;
  529. {
  530.     LVAL *newfp;
  531.  
  532.     /* create the new call frame */
  533.     newfp = xlsp;
  534.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  535.     pusharg(fun);
  536.     pusharg(cvfixnum((FIXTYPE)1));
  537.     pusharg(arg);
  538.     xlfp = newfp;
  539.  
  540.     /* return the result of applying the test function */
  541.     return (xlapply(1) != NIL);
  542.  
  543. }
  544.  
  545.  
  546. /* xelt - sequence reference function */
  547. LVAL xelt()
  548. {
  549.     LVAL seq,index;
  550.     FIXTYPE i;
  551.     
  552.     /* get the sequence and the index */
  553.  
  554.     seq = xlgetarg();
  555.  
  556.     index = xlgafixnum(); i = getfixnum(index); 
  557.     if (i < 0) goto badindex;
  558.     
  559.     xllastarg();
  560.  
  561.     if (listp(seq)) { /* do like nth, but check for in range */
  562.         /* find the ith element */
  563.         while (consp(seq)) {
  564.             if (i-- == 0) return (car(seq));
  565.             seq = cdr(seq);
  566.         }
  567.         goto badindex;  /* end of list reached first */
  568.     }
  569.         
  570.  
  571.     if (ntype(seq) == STRING) { 
  572.         if (i >= getslength(seq)-1) goto badindex;
  573.         return (cvchar(seq->n_string[i]));
  574.     }
  575.     
  576.     if (ntype(seq)!=VECTOR) xlbadtype(seq); /* type must be array */
  577.  
  578.     /* range check the index */
  579.     if (i >= getsize(seq)) goto badindex;
  580.  
  581.     /* return the array element */
  582.     return (getelement(seq,(int)i));
  583.     
  584. badindex:
  585.     xlerror("index out of bounds",index);
  586. }
  587.  
  588.  
  589. /* xmap -- map function */
  590.  
  591. LOCAL long getlength(seq)
  592. LVAL seq;
  593. {
  594.     long len;
  595.     
  596.     if (seq == NIL) return 0;
  597.     
  598.     switch (ntype(seq)) {
  599.         case STRING: 
  600.             return (long)getslength(seq) - 1;
  601.         case VECTOR: 
  602.             return (long)getsize(seq);
  603.         case CONS: 
  604.             len = 0;
  605.             while (consp(seq)) {
  606.                 len++;
  607.                 seq = cdr(seq);
  608.             }
  609.             return len;
  610.         default: 
  611.             xlbadtype(seq);
  612.             return (0); /* ha ha */
  613.         }
  614. }
  615.  
  616.  
  617. LVAL xmap()
  618. {
  619.     LVAL *newfp, fun, lists, val, last, x, y;
  620.     long len,temp;
  621.     int argc, typ, i;
  622.     
  623.     /* protect some pointers */
  624.     xlstkcheck(3);
  625.     xlsave(fun);
  626.     xlsave(lists);
  627.     xlsave(val);
  628.  
  629.     /* get the type of resultant */
  630.     if ((last = xlgetarg()) == NIL) {   /* nothing is returned */
  631.         typ = 0;
  632.     }
  633.     else if ((typ = xlcvttype(last)) != CONS && 
  634.                 typ != STRING && typ != VECTOR) {
  635.         xlerror("invalid result type", last);
  636.     }
  637.     
  638.     /* get the function to apply and argument sequences */
  639.     fun = xlgetarg();
  640.     val = NIL;
  641.     lists = xlgetarg();
  642.     len = getlength(lists);
  643.     argc = 1;
  644.  
  645.     /* build a list of argument lists */
  646.     for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
  647.         val = xlgetarg();
  648.         if ((temp = getlength(val)) < len) len = temp;
  649.         argc++;
  650.         rplacd(last,(cons(val,NIL)));
  651.     }
  652.     
  653.     /* initialize the result list */
  654.     switch (typ) {
  655.         case VECTOR: val = newvector(len); break;
  656.         case STRING: val = newstring(len+1); break;
  657.         default:    val = NIL; break;
  658.     }
  659.     
  660.     
  661.     /* loop through each of the argument lists */
  662.     for (i=0;i<len;i++) {
  663.  
  664.         /* build an argument list from the sublists */
  665.         newfp = xlsp;
  666.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  667.         pusharg(fun);
  668.         pusharg(NIL);
  669.         for (x = lists; x != NIL ; x = cdr(x)) {
  670.             y = car(x);
  671.             switch (ntype(y)) {
  672.                 case CONS: 
  673.                     pusharg(car(y));
  674.                     rplaca(x,cdr(y));
  675.                     break;
  676.                 case VECTOR:
  677.                     pusharg(getelement(y,i));
  678.                     break;
  679.                 case STRING:
  680.                     pusharg(cvchar(y->n_string[i]));
  681.                     break;
  682.             }
  683.         }
  684.  
  685.         /* apply the function to the arguments */
  686.         newfp[2] = cvfixnum((FIXTYPE)argc);
  687.         xlfp = newfp;
  688.         x = xlapply(argc);
  689.         
  690.         switch (typ) {
  691.             case CONS:
  692.                 y = consa(x);
  693.                 if (val) rplacd(last,y);
  694.                 else val = y;
  695.                 last = y;
  696.                 break;
  697.             case VECTOR:
  698.                 setelement(val,i,x);
  699.                 break;
  700.             case STRING:
  701.                 if (!charp(x)) 
  702.                     xlerror("map function returned non-character",x);
  703.                 val->n_string[i] = getchcode(x);
  704.                 break;
  705.         }
  706.             
  707.     }
  708.  
  709.     /* restore the stack */
  710.     xlpopn(3);
  711.  
  712.     /* return the last test expression value */
  713.     return (val);
  714.     }
  715.  
  716.  
  717.  
  718.  
  719. /* xconcatenate - concatenate a bunch of sequences */
  720. /* replaces (and extends) strcat, now a macro */
  721. LOCAL int calclength()
  722. {
  723.     LVAL tmp, *saveargv;
  724.     int saveargc;
  725.     int len;
  726.  
  727.     /* save the argument list */
  728.     saveargv = xlargv;
  729.     saveargc = xlargc;
  730.  
  731.     /* find the length of the new string or vector */
  732.     for (len = 0; moreargs(); ) {
  733.         tmp = xlgetarg();
  734.         len += getlength(tmp);
  735.         if (len < 0) xlerror("too long",tmp);
  736.     }
  737.  
  738.     /* restore the argument list */
  739.     xlargv = saveargv;
  740.     xlargc = saveargc;
  741.  
  742.     return len;
  743. }
  744.  
  745.  
  746. LOCAL LVAL cattostring()
  747. {
  748.     LVAL tmp,temp,val;
  749.     unsigned char *str;
  750.     int len,i;
  751.     
  752.     /* find resulting length -- also validates argument types */
  753.     len = calclength();
  754.  
  755.     /* create the result string */
  756.     val = newstring(len+1);
  757.     str = getstring(val);
  758.  
  759.     /* combine the strings */
  760.     while (moreargs()) {
  761.         tmp = nextarg();
  762.         if (tmp != NIL) switch (ntype(tmp)) {
  763.             case STRING: 
  764.                 len = getslength(tmp)-1;
  765.                 memcpy((char *)str, (char *)getstring(tmp), len);
  766.                 str += len;
  767.                 break;
  768.             case VECTOR:
  769.                 len = getsize(tmp);
  770.                 for (i = 0; i < len; i++) {
  771.                     temp = getelement(tmp,i);
  772.                     if (!charp(temp)) goto failed;
  773.                     *str++ = getchcode(temp);
  774.                 }
  775.                 break;
  776.             case CONS:
  777.                 while (consp(tmp)) {
  778.                     temp = car(tmp);
  779.                     if (!charp(temp)) goto failed;
  780.                     *str++ = getchcode(temp);
  781.                     tmp = cdr(tmp);
  782.                 }
  783.                 break;
  784.         }
  785.     }
  786.  
  787.     *str = 0;   /* delimit string (why, I don't know!) */
  788.  
  789.     /* return the new string */
  790.     return (val);
  791.  
  792. failed:
  793.     xlerror("cannot make into string", tmp);
  794. }
  795.  
  796. LOCAL LVAL cattovector()
  797. {
  798.     LVAL tmp,val;
  799.     LVAL *vect;
  800.     int len,i;
  801.     
  802.     /* find resulting length -- also validates argument types */
  803.     len = calclength();
  804.  
  805.     /* create the result vector */
  806.     val = newvector(len);
  807.     vect = &val->n_vdata[0];
  808.  
  809.     /* combine the vectors */
  810.     while (moreargs()) {
  811.         tmp = nextarg();
  812.         if (tmp != NIL) switch (ntype(tmp)) {
  813.             case VECTOR: 
  814.                 len = getsize(tmp);
  815.                 memcpy(vect, &getelement(tmp,0), len*sizeof(LVAL));
  816.                 vect += len;
  817.                 break;
  818.             case STRING:
  819.                 len = getslength(tmp)-1;
  820.                 for (i = 0; i < len; i++) {
  821.                     *vect++ = cvchar(tmp->n_string[i]);
  822.                 }
  823.                 break;
  824.             case CONS:
  825.                 while (consp(tmp)) {
  826.                     *vect++ = car(tmp);
  827.                     tmp = cdr(tmp);
  828.                 }
  829.                 break;
  830.         }
  831.     }
  832.  
  833.     /* return the new vector */
  834.     return (val);
  835. }
  836.  
  837. LOCAL LVAL cattocons()
  838. {
  839.     LVAL val,tmp,next,last=NIL;
  840.     int len,i;
  841.     
  842.     xlsave1(val);       /* protect against GC */
  843.     
  844.     /* combine the lists */
  845.     while (moreargs()) {
  846.         tmp = nextarg();
  847.         if (tmp != NIL) switch (ntype(tmp)) {
  848.             case CONS:
  849.                 while (consp(tmp)) {
  850.                     next = consa(car(tmp));
  851.                     if (val) rplacd(last,next);
  852.                     else val = next;
  853.                     last = next;
  854.                     tmp = cdr(tmp);
  855.                 }
  856.                 break;
  857.             case VECTOR:
  858.                 len = getsize(tmp);
  859.                 for (i = 0; i<len; i++) {
  860.                     next = consa(getelement(tmp,i));
  861.                     if (val) rplacd(last,next);
  862.                     else val = next;
  863.                     last = next;
  864.                 }
  865.                 break;
  866.             case STRING:
  867.                 len = getslength(tmp) - 1;
  868.                 for (i = 0; i < len; i++) {
  869.                     next = consa(cvchar(tmp->n_string[i]));
  870.                     if (val) rplacd(last,next);
  871.                     else val = next;
  872.                     last = next;
  873.                 }
  874.                 break;
  875.             default: 
  876.                 xlbadtype(tmp); break; /* need default because no precheck*/
  877.         }
  878.     }
  879.     
  880.     xlpop();
  881.     
  882.     return (val);
  883.  
  884. }
  885.     
  886.  
  887. LVAL xconcatenate()
  888. {
  889.     LVAL tmp;
  890.     
  891.     switch (xlcvttype(tmp = xlgetarg())) {  /* target type of data */
  892.         case CONS:      return cattocons();
  893.         case STRING:    return cattostring();           
  894.         case VECTOR:    return cattovector();
  895.         default:        xlerror("invalid result type", tmp);
  896.     }
  897. }
  898.  
  899. /* xsubseq - return a subsequence -- new version */
  900.  
  901. LVAL xsubseq()
  902. {
  903.     int start,end,len;
  904.     int srctype;
  905.     LVAL src,dst;
  906.     LVAL next,last=NIL;
  907.  
  908.     /* get sequence */
  909.     src = xlgetarg();
  910.     if (listp(src)) srctype = CONS;
  911.     else srctype=ntype(src);
  912.  
  913.     
  914.     /* get length */
  915.     switch (srctype) {
  916.         case STRING:
  917.             len = getslength(src) - 1;
  918.             break;
  919.         case VECTOR:
  920.             len = getsize(src);
  921.             break;
  922.         case CONS:
  923.             dst = src;  /* use dst as temporary */
  924.             len = 0;
  925.             while (consp(dst)) {len++; dst = cdr(dst);}
  926.             break;
  927.         default:
  928.             xlbadtype(src);
  929.     }
  930.  
  931.     /* get the starting position */
  932.     dst = xlgafixnum(); start = (int)getfixnum(dst);
  933.     if (start < 0 || start > len) 
  934.         xlerror("sequence index out of bounds",dst);
  935.  
  936.     /* get the ending position */
  937.     if (moreargs()) {
  938.         dst = xlgafixnum(); end = (int)getfixnum(dst);
  939.         if (end < 0 || end > len)
  940.             xlerror("sequence index out of bounds",dst);
  941.     }
  942.     else
  943.         end = len;
  944.     xllastarg();
  945.  
  946.     len = end - start;
  947.     
  948.     switch (srctype) {  /* do the subsequencing */
  949.         case STRING:
  950.             dst = newstring(len+1);
  951.             memcpy(getstring(dst), getstring(src)+start, len);
  952.             dst->n_string[len] = 0;
  953.             break;
  954.         case VECTOR:
  955.             dst = newvector(len);
  956.             memcpy(dst->n_vdata, &src->n_vdata[start], sizeof(LVAL)*len);
  957.             break;
  958.         case CONS:
  959.             xlsave1(dst);
  960.             while (start--) src = cdr(src);
  961.             while (len--) {
  962.                 next = consa(car(src));
  963.                 if (dst) rplacd(last,next);
  964.                 else dst = next;
  965.                 last = next;
  966.                 src = cdr(src);
  967.             }
  968.             xlpop();
  969.             break;
  970.     }
  971.  
  972.     /* return the substring */
  973.     return (dst);
  974. }
  975.  
  976.  
  977. /* xreverse - built-in function reverse -- new version */
  978. LVAL xreverse()
  979. {
  980.     LVAL seq,val;
  981.     int i,len;
  982.  
  983.     /* get the sequence to reverse */
  984.     seq = xlgetarg();
  985.     xllastarg();
  986.  
  987.     if (seq == NIL) return (NIL);   /* empty argument */
  988.     
  989.     switch (ntype(seq)) {
  990.         case CONS:
  991.             /* protect pointer */
  992.             xlsave1(val);
  993.  
  994.             /* append each element to the head of the result list */
  995.             for (val = NIL; consp(seq); seq = cdr(seq))
  996.                 val = cons(car(seq),val);
  997.  
  998.             /* restore the stack */
  999.             xlpop();
  1000.             break;
  1001.         case VECTOR:
  1002.             len = getsize(seq);
  1003.             val = newvector(len);
  1004.             for (i = 0; i < len; i++)
  1005.                 setelement(val,i,getelement(seq,len-i-1));
  1006.             break;
  1007.         case STRING:
  1008.             len = getslength(seq) - 1;
  1009.             val = newstring(len+1);
  1010.             for (i = 0; i < len; i++)
  1011.                 val->n_string[i] = seq->n_string[len-i-1];
  1012.             val->n_string[len] = 0;
  1013.             break;
  1014.         default: 
  1015.             xlbadtype(seq); break;
  1016.     }
  1017.  
  1018.     /* return the sequence */
  1019.     return (val);
  1020. }
  1021.  
  1022.  
  1023. /* remif - common code for 'remove', 'remove-if', and 'remove-if-not' */
  1024. LOCAL LVAL remif(tresult,expr)
  1025.   int tresult,expr;
  1026. {
  1027.     LVAL x,seq,fcn,val,last,next;
  1028.     int i,j,l;
  1029.     long start,end;
  1030.  
  1031.     if (expr) {
  1032.         /* get the expression to remove and the sequence */
  1033.         x = xlgetarg();
  1034.         seq = xlgetarg();
  1035.         xltest(&fcn,&tresult);
  1036.     }
  1037.     else {
  1038.         /* get the function and the sequence */
  1039.         fcn = xlgetarg();
  1040.         seq = xlgetarg();
  1041. /*      xllastarg(); */
  1042.     }
  1043.  
  1044.     if (seq == NIL) return NIL;
  1045.  
  1046.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  1047.     
  1048.     /* protect some pointers */
  1049.     xlstkcheck(2);
  1050.     xlprotect(fcn);
  1051.     xlsave(val);
  1052.  
  1053.     /* remove matches */
  1054.     
  1055.     switch (ntype(seq)) {
  1056.         case CONS:
  1057.             end -= start;   /* length */
  1058.             for (; consp(seq); seq = cdr(seq)) {
  1059.  
  1060.                 /* check to see if this element should be deleted */
  1061.                 /* force copy if count, as specified by end, is exhausted */
  1062.                 if (start-- > 0 || end-- <= 0 || 
  1063.                     (expr?dotest2(x,car(seq),fcn)
  1064.                     :dotest1(car(seq),fcn)) != tresult) {
  1065.                     next = consa(car(seq));
  1066.                     if (val) rplacd(last,next);
  1067.                     else val = next;
  1068.                     last = next;
  1069.                 }
  1070.             }
  1071.             break;
  1072.         case VECTOR:
  1073.             val = newvector(l=getlength(seq));
  1074.             for (i=j=0; i < l; i++) {
  1075.                 if (i < start || i >= end ||    /* copy if out of range */
  1076.                     (expr?dotest2(x,getelement(seq,i),fcn)
  1077.                     :dotest1(getelement(seq,i),fcn)) != tresult) {
  1078.                     setelement(val,j++,getelement(seq,i));
  1079.                 }
  1080.             }
  1081.             if (l != j) { /* need new, shorter result -- too bad */
  1082.                 fcn = val; /* save value in protected cell */
  1083.                 val = newvector(j);
  1084.                 memcpy(val->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
  1085.             }
  1086.             break;
  1087.         case STRING:
  1088.             l = getslength(seq)-1;
  1089.             val = newstring(l+1);
  1090.             for (i=j=0; i < l; i++) {
  1091.                 if (i < start || i >= end ||    /* copy if out of range */
  1092.                     (expr?dotest2(x,cvchar(seq->n_string[i]),fcn)
  1093.                     :dotest1(cvchar(seq->n_string[i]),fcn)) != tresult) {
  1094.                     val->n_string[j++] = seq->n_string[i];
  1095.                 }
  1096.             }
  1097.             if (l != j) { /* need new, shorter result -- too bad */
  1098.                 fcn = val; /* save value in protected cell */
  1099.                 val = newstring(j+1);
  1100.                 memcpy(val->n_string, fcn->n_string, j*sizeof(char));
  1101.                 val->n_string[j] = 0;
  1102.             }
  1103.             break;
  1104.         default:
  1105.             xlbadtype(seq); break;
  1106.     }
  1107.         
  1108.             
  1109.     /* restore the stack */
  1110.     xlpopn(2);
  1111.  
  1112.     /* return the updated sequence */
  1113.     return (val);
  1114. }
  1115.  
  1116. /* xremif - built-in function 'remove-if' -- enhanced version */
  1117. LVAL xremif()
  1118. {
  1119.     return (remif(TRUE,FALSE));
  1120. }
  1121.  
  1122. /* xremifnot - built-in function 'remove-if-not' -- enhanced version */
  1123. LVAL xremifnot()
  1124. {
  1125.     return (remif(FALSE,FALSE));
  1126. }
  1127.  
  1128. /* xremove - built-in function 'remove' -- enhanced version */
  1129.  
  1130. LVAL xremove()
  1131. {
  1132.     return (remif(TRUE,TRUE));
  1133. }
  1134.  
  1135.  
  1136. /* delif - common code for 'delete', 'delete-if', and 'delete-if-not' */
  1137. LOCAL LVAL delif(tresult,expr)
  1138.   int tresult,expr;
  1139. {
  1140.     LVAL x,seq,fcn,last,val;
  1141.     int i,j,l;
  1142.     long start,end;
  1143.  
  1144.     if (expr) {
  1145.         /* get the expression to delete and the sequence */
  1146.         x = xlgetarg();
  1147.         seq = xlgetarg();
  1148.         xltest(&fcn,&tresult);
  1149.     }
  1150.     else {
  1151.         /* get the function and the sequence */
  1152.         fcn = xlgetarg();
  1153.         seq = xlgetarg();
  1154. /*      xllastarg(); */
  1155.     }
  1156.  
  1157.     if (seq == NIL) return NIL;
  1158.  
  1159.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  1160.  
  1161.     /* protect a pointer */
  1162.     xlstkcheck(1);
  1163.     xlprotect(fcn);
  1164.  
  1165.  
  1166.     /* delete matches */
  1167.     
  1168.     switch (ntype(seq)) {
  1169.         case CONS:
  1170.             end -= start; /* gives length */
  1171.             /* delete leading matches */
  1172.             while (consp(seq)) {
  1173.                 if (start-- > 0 || (expr?dotest2(x,car(seq),fcn)
  1174.                     :dotest1(car(seq),fcn)) != tresult)
  1175.                     break;
  1176.                 seq = cdr(seq);
  1177.             }
  1178.             val = last = seq;
  1179.  
  1180.             /* delete embedded matches */
  1181.             if (consp(seq)) {
  1182.  
  1183.                 /* skip the first non-matching element */
  1184.                 seq = cdr(seq);
  1185.  
  1186.                 /* look for embedded matches */
  1187.                 while (consp(seq)) {
  1188.  
  1189.                     /* check to see if this element should be deleted */
  1190.                     if (start-- <= 0 && end-- > 0 &&
  1191.                         (expr?dotest2(x,car(seq),fcn)
  1192.                     :dotest1(car(seq),fcn)) == tresult)
  1193.                         rplacd(last,cdr(seq));
  1194.                     else
  1195.                         last = seq;
  1196.  
  1197.                     /* move to the next element */
  1198.                     seq = cdr(seq);
  1199.                 }
  1200.             }
  1201.             break;
  1202.         case VECTOR:
  1203.             l = getlength(seq);
  1204.             for (i=j=0; i < l; i++) {
  1205.                 if (i < start || i >= end ||    /* copy if out of range */
  1206.                     (expr?dotest2(x,getelement(seq,i),fcn)
  1207.                     :dotest1(getelement(seq,i),fcn)) != tresult) {
  1208.                     if (i != j) setelement(seq,j,getelement(seq,i));
  1209.                     j++;
  1210.                 }
  1211.             }
  1212.             if (l != j) { /* need new, shorter result -- too bad */
  1213.                 fcn = seq; /* save value in protected cell */
  1214.                 seq = newvector(j);
  1215.                 memcpy(seq->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
  1216.             }
  1217.             val = seq;
  1218.             break;
  1219.         case STRING:
  1220.             l = getslength(seq)-1;
  1221.             for (i=j=0; i < l; i++) {
  1222.                 if (i < start || i >= end ||    /* copy if out of range */
  1223.                     (expr?dotest2(x,cvchar(seq->n_string[i]),fcn)
  1224.                     :dotest1(cvchar(seq->n_string[i]),fcn)) != tresult) {
  1225.                     if (i != j) seq->n_string[j] = seq->n_string[i];
  1226.                     j++;
  1227.                 }
  1228.             }
  1229.             if (l != j) { /* need new, shorter result -- too bad */
  1230.                 fcn = seq; /* save value in protected cell */
  1231.                 seq = newstring(j+1);
  1232.                 memcpy(seq->n_string, fcn->n_string, j*sizeof(char));
  1233.                 seq->n_string[j] = 0;
  1234.             }
  1235.             val = seq;
  1236.             break;
  1237.         default:
  1238.             xlbadtype(seq); break;
  1239.     }
  1240.         
  1241.             
  1242.     /* restore the stack */
  1243.     xlpop();
  1244.  
  1245.     /* return the updated sequence */
  1246.     return (val);
  1247. }
  1248.  
  1249. /* xdelif - built-in function 'delete-if' -- enhanced version */
  1250. LVAL xdelif()
  1251. {
  1252.     return (delif(TRUE,FALSE));
  1253. }
  1254.  
  1255. /* xdelifnot - built-in function 'delete-if-not' -- enhanced version */
  1256. LVAL xdelifnot()
  1257. {
  1258.     return (delif(FALSE,FALSE));
  1259. }
  1260.  
  1261. /* xdelete - built-in function 'delete' -- enhanced version */
  1262.  
  1263. LVAL xdelete()
  1264. {
  1265.     return (delif(TRUE,TRUE));
  1266. }
  1267.  
  1268. /* xcountif - built-in function 'count-if     TAA MOD addition */
  1269. LVAL xcountif()
  1270. {
  1271.     FIXTYPE counter=0;
  1272.     int i,l;
  1273.     long start,end;
  1274.     LVAL seq, fcn;
  1275.  
  1276.     
  1277.     /* get the arguments */
  1278.     fcn = xlgetarg();
  1279.     seq = xlgetarg();
  1280. /*  xllastarg(); */
  1281.  
  1282.     if (seq == NIL) return (cvfixnum(0L));
  1283.  
  1284.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  1285.  
  1286.     xlstkcheck(1);
  1287.     xlprotect(fcn);
  1288.  
  1289.     /* examine arg and count */
  1290.     switch (ntype(seq)) {
  1291.         case CONS:
  1292.             end -= start;
  1293.             for (; consp(seq); seq = cdr(seq))
  1294.                 if (start-- <= 0 && end-- > 0 && 
  1295.                     dotest1(car(seq),fcn)) counter++;
  1296.             break;
  1297.         case VECTOR:
  1298.             l = getlength(seq);
  1299.             if (end < l) l = end;
  1300.             for (i=start; i < l; i++)
  1301.                 if (dotest1(getelement(seq,i),fcn)) counter++;
  1302.             break;
  1303.         case STRING:
  1304.             l = getslength(seq)-1;
  1305.             if (end < l) l = end;
  1306.             for (i=start; i < l; i++)
  1307.                 if (dotest1(cvchar(seq->n_string[i]),fcn)) counter++;
  1308.             break;
  1309.         default:
  1310.             xlbadtype(seq); break;
  1311.     }
  1312.  
  1313.     xlpop();
  1314.  
  1315.     return (cvfixnum(counter));
  1316. }
  1317.  
  1318. /* xfindif - built-in function 'find-if'    TAA MOD */
  1319. LVAL xfindif()
  1320. {
  1321.     LVAL seq, fcn, val;
  1322.     long start,end;
  1323.     int i,l;
  1324.     
  1325.     fcn = xlgetarg();
  1326.     seq = xlgetarg();
  1327. /*  xllastarg(); */
  1328.     
  1329.     if (seq == NIL) return NIL;
  1330.  
  1331.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  1332.  
  1333.     xlstkcheck(1);
  1334.     xlprotect(fcn);
  1335.  
  1336.     switch (ntype(seq)) {
  1337.         case CONS:
  1338.             end -= start;
  1339.             for (; consp(seq); seq = cdr(seq)) {
  1340.                 if (start-- <= 0 && end-- > 0 &&
  1341.                     dotest1(val=car(seq), fcn)) goto fin;
  1342.             }
  1343.             break;
  1344.         case VECTOR:
  1345.             l = getlength(seq);
  1346.             if (end < l) l = end;
  1347.             for (i=start; i < l; i++)
  1348.                 if (dotest1(val=getelement(seq,i),fcn)) goto fin;
  1349.             break;
  1350.         case STRING:
  1351.             l = getslength(seq)-1;
  1352.             if (end < l) l = end;
  1353.             for (i=start; i < l; i++)
  1354.                 if (dotest1(val=cvchar(seq->n_string[i]),fcn)) goto fin;
  1355.             break;
  1356.         default:
  1357.             xlbadtype(seq); break;
  1358.     }
  1359.  
  1360.     val = NIL;  /* not found */
  1361.     
  1362. fin:
  1363.     xlpop();
  1364.     return (val);
  1365. }
  1366.  
  1367. /* xpositionif - built-in function 'position-if'    TAA MOD */
  1368. LVAL xpositionif()
  1369. {
  1370.     LVAL seq, fcn;
  1371.     long start,end;
  1372.     FIXTYPE count;
  1373.     int i,l;
  1374.     
  1375.     fcn = xlgetarg();
  1376.     seq = xlgetarg();
  1377. /*  xllastarg(); */
  1378.     
  1379.     if (seq == NIL) return NIL;
  1380.  
  1381.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  1382.  
  1383.     xlstkcheck(1);
  1384.     xlprotect(fcn);
  1385.  
  1386.     switch (ntype(seq)) {
  1387.         case CONS:
  1388.             end -= start;
  1389.             count = 0;
  1390.             for (; consp(seq); seq = cdr(seq)) {
  1391.                 if ((start-- <= 0) && (end-- > 0) &&
  1392.                     dotest1(car(seq), fcn)) goto fin;
  1393.                 count++;
  1394.             }
  1395.             break;
  1396.         case VECTOR:
  1397.             l = getlength(seq);
  1398.             if (end < l) l = end;
  1399.             for (i=start; i < l; i++)
  1400.                 if (dotest1(getelement(seq,i),fcn)) {
  1401.                     count = i;
  1402.                     goto fin;
  1403.                 }
  1404.             break;
  1405.         case STRING:
  1406.             l = getslength(seq)-1;
  1407.             if (end < l) l = end;
  1408.             for (i=start; i < l; i++)
  1409.                 if (dotest1(cvchar(seq->n_string[i]),fcn)) {
  1410.                     count = i;
  1411.                     goto fin;
  1412.                 }
  1413.             break;
  1414.         default:
  1415.             xlbadtype(seq); break;
  1416.     }
  1417.  
  1418.     xlpop();    /* not found */
  1419.     return(NIL);
  1420.  
  1421. fin:            /* found */
  1422.     xlpop();
  1423.     return (cvfixnum(count));
  1424. }
  1425.  
  1426. /* xsearch -- search function */
  1427.  
  1428. LVAL xsearch()
  1429. {
  1430.     LVAL seq1, seq2, fcn, temp1, temp2;
  1431.     long start1, start2, end1, end2, len1, len2;
  1432.     long i,j;
  1433.     int tresult,typ1, typ2;
  1434.     
  1435.     /* get the sequences */
  1436.     seq1 = xlgetarg();  
  1437.     len1 = getlength(seq1);
  1438.     seq2 = xlgetarg();
  1439.     len2 = getlength(seq2);
  1440.  
  1441.     /* test/test-not args? */
  1442.     xltest(&fcn,&tresult);
  1443.  
  1444.     /* check for start/end keys */
  1445.     getseqbounds(&start1,&end1,len1,&k_1start,&k_1end);
  1446.     getseqbounds(&start2,&end2,len2,&k_2start,&k_2end);
  1447.     
  1448.     if (end2 - 1 + (start1 - end1) > len2) {
  1449.         end2 = len2 + 1 - (start1 - end1);
  1450.         if (end2 < start2) end2 = start2;
  1451.     }
  1452.     
  1453.     len1 = end1 - start1;   /* calc lengths of sequences to test */
  1454.  
  1455.     typ1 = ntype(seq1);
  1456.     typ2 = ntype(seq2);
  1457.     
  1458.     xlstkcheck(1);
  1459.     xlprotect(fcn);
  1460.  
  1461.     if (typ1 == CONS) { /* skip leading section of sequence 1 if a cons */
  1462.         j = start1;
  1463.         while (j--) seq1 = cdr(seq1);
  1464.     }
  1465.  
  1466.     if (typ2 == CONS) { /* second string is cons */
  1467.         i = start2;     /* skip leading section of string 2 */
  1468.         while (start2--) seq2 = cdr(seq2);
  1469.  
  1470.         for (;i<end2;i++) {
  1471.             temp2 = seq2;
  1472.             if (typ1 == CONS) {
  1473.                 temp1 = seq1;
  1474.                 for (j = start1; j < end1; j++) {
  1475.                     if (dotest2(car(temp1),car(temp2),fcn) != tresult)
  1476.                         goto next1;
  1477.                     temp1 = cdr(temp1);
  1478.                     temp2 = cdr(temp2);
  1479.                 }
  1480.             }
  1481.             else {
  1482.                 for (j = start1; j < end1; j++) {
  1483.                     if (dotest2(typ1 == VECTOR ? getelement(seq1,j) 
  1484.                                                : cvchar(seq1->n_string[j]),
  1485.                         car(temp2), fcn) != tresult)
  1486.                         goto next1;
  1487.                     temp2 = cdr(temp2);
  1488.                 }
  1489.             }
  1490.             xlpop();
  1491.             return cvfixnum(i);
  1492.             next1: /* continue */
  1493.             seq2 = cdr(seq2);
  1494.         }
  1495.     }
  1496.                 
  1497.     else for (i = start2; i < end2 ; i++) { /* second string is array/string */
  1498.         if (typ1 == CONS) { 
  1499.             temp1 = seq1;
  1500.             for (j = 0; j < len1; j++) {
  1501.                 if (dotest2(car(temp1), 
  1502.                             typ2 == VECTOR ? getelement(seq2,i+j) 
  1503.                                            : cvchar(seq2->n_string[i+j]),
  1504.                             fcn) != tresult)
  1505.                     goto next2;
  1506.                 temp1 = cdr(temp1);
  1507.             }
  1508.         }
  1509.         else for (j=start1; j < end1; j++) {
  1510.             if (dotest2(typ1 == VECTOR ? getelement(seq1,j) 
  1511.                                        : cvchar(seq1->n_string[j]),
  1512.                 typ2 == VECTOR ? getelement(seq2,i+j-start1) 
  1513.                                : cvchar(seq2->n_string[i+j-start1]),
  1514.                 fcn) != tresult)
  1515.                     goto next2;
  1516.         }
  1517.         xlpop();
  1518.         return cvfixnum(i);
  1519.         next2:; /* continue */
  1520.     }
  1521.     
  1522.     xlpop();
  1523.     return (NIL);   /*no match*/
  1524.  
  1525. }
  1526.  
  1527.  
  1528. END OF PART 2
  1529.  
  1530.  
  1531.