home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / list.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-05-17  |  7.6 KB  |  294 lines
  1. /*
  2.  *
  3.  * l i s t . c            -- Lists procedures
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: ??-Oct-1993 21:37
  22.  * Last file update:  7-Nov-1995 21:36
  23.  */
  24.  
  25. #include "stk.h"
  26.  
  27. PRIMITIVE STk_pairp(SCM x)
  28. {
  29.   return CONSP(x) ? Truth : Ntruth;
  30. }
  31.  
  32. PRIMITIVE STk_cons(SCM x, SCM y)
  33. {
  34.   SCM z;
  35.   NEWCELL(z,tc_cons);
  36.   CAR(z) = x;
  37.   CDR(z) = y;
  38.   return z;
  39. }
  40.  
  41. PRIMITIVE STk_car(SCM x)
  42. {
  43.   if (TYPEP(x, tc_cons)) return CAR(x);
  44.   Err("car: wrong type of argument", x);
  45. }
  46.  
  47. PRIMITIVE STk_cdr(SCM x)
  48. {
  49.   if (TYPEP(x, tc_cons)) return CDR(x);
  50.   Err("cdr: wrong type of argument", x);
  51. }
  52.  
  53. PRIMITIVE STk_setcar(SCM cell, SCM value)
  54. {
  55.   if NCONSP(cell) Err("set-car!: wrong type of argument", cell);
  56.   CAR(cell) = value;
  57.   return UNDEFINED;
  58. }
  59.  
  60. PRIMITIVE STk_setcdr(SCM cell, SCM value)
  61. {
  62.   if NCONSP(cell) Err("set-cdr!: wrong type of argument", cell);
  63.   CDR(cell) = value;
  64.   return UNDEFINED;
  65. }
  66.  
  67. static SCM internal_cxr(SCM l, char *fct)
  68. {
  69.   register SCM tmp = l;
  70.   register char *p;
  71.  
  72.   for(p = fct + strlen(fct)-1; *p != 'X'; p--) {
  73.     if (NCONSP(tmp)) {
  74.       char name[50];
  75.       sprintf(name, "c%sr: bad list", fct+1);
  76.       Err(name, l);
  77.     }
  78.     tmp = (*p == 'a') ? CAR(tmp) : CDR(tmp);
  79.   }
  80.   return tmp;
  81. }
  82.  
  83. PRIMITIVE STk_caar  (SCM l) { return internal_cxr(l, "Xaa");   }
  84. PRIMITIVE STk_cdar  (SCM l) { return internal_cxr(l, "Xda");   }
  85. PRIMITIVE STk_cadr  (SCM l) { return internal_cxr(l, "Xad");   }
  86. PRIMITIVE STk_cddr  (SCM l) { return internal_cxr(l, "Xdd");   }
  87. PRIMITIVE STk_caaar (SCM l) { return internal_cxr(l, "Xaaa");  }
  88. PRIMITIVE STk_cdaar (SCM l) { return internal_cxr(l, "Xdaa");  }
  89. PRIMITIVE STk_cadar (SCM l) { return internal_cxr(l, "Xada");  }
  90. PRIMITIVE STk_cddar (SCM l) { return internal_cxr(l, "Xdda");  }
  91. PRIMITIVE STk_caadr (SCM l) { return internal_cxr(l, "Xaad");  }
  92. PRIMITIVE STk_cdadr (SCM l) { return internal_cxr(l, "Xdad");  }
  93. PRIMITIVE STk_caddr (SCM l) { return internal_cxr(l, "Xadd");  }
  94. PRIMITIVE STk_cdddr (SCM l) { return internal_cxr(l, "Xddd");  }
  95. PRIMITIVE STk_caaaar(SCM l) { return internal_cxr(l, "Xaaaa"); }
  96. PRIMITIVE STk_cdaaar(SCM l) { return internal_cxr(l, "Xdaaa"); }
  97. PRIMITIVE STk_cadaar(SCM l) { return internal_cxr(l, "Xadaa"); }
  98. PRIMITIVE STk_cddaar(SCM l) { return internal_cxr(l, "Xddaa"); }
  99. PRIMITIVE STk_caadar(SCM l) { return internal_cxr(l, "Xaada"); }
  100. PRIMITIVE STk_cdadar(SCM l) { return internal_cxr(l, "Xdada"); }
  101. PRIMITIVE STk_caddar(SCM l) { return internal_cxr(l, "Xadda"); }
  102. PRIMITIVE STk_cdddar(SCM l) { return internal_cxr(l, "Xddda"); }
  103. PRIMITIVE STk_caaadr(SCM l) { return internal_cxr(l, "Xaaad"); }
  104. PRIMITIVE STk_cdaadr(SCM l) { return internal_cxr(l, "Xdaad"); }
  105. PRIMITIVE STk_cadadr(SCM l) { return internal_cxr(l, "Xadad"); }
  106. PRIMITIVE STk_cddadr(SCM l) { return internal_cxr(l, "Xddad"); }
  107. PRIMITIVE STk_caaddr(SCM l) { return internal_cxr(l, "Xaadd"); }
  108. PRIMITIVE STk_cdaddr(SCM l) { return internal_cxr(l, "Xdadd"); }
  109. PRIMITIVE STk_cadddr(SCM l) { return internal_cxr(l, "Xaddd"); }
  110. PRIMITIVE STk_cddddr(SCM l) { return internal_cxr(l, "Xdddd"); }
  111.  
  112. PRIMITIVE STk_nullp(SCM x)
  113. {
  114.   return EQ(x, NIL) ? Truth: Ntruth;
  115. }
  116.  
  117. int STk_llength(SCM l)
  118. {
  119.   register SCM start = l;
  120.   register int len   = 0;
  121.     
  122.   for ( ; ; ) {
  123.     if (NULLP(l)) return len;
  124.     if ((l == start && len) || NCONSP(l)) return -1;
  125.     l = CDR(l);
  126.     len += 1;
  127.   }
  128. }
  129.  
  130. PRIMITIVE STk_listp(SCM x)
  131. {
  132.   return (STk_llength(x) < 0) ? Ntruth : Truth;
  133. }
  134.  
  135. PRIMITIVE STk_list(SCM l, int len)
  136. {
  137.   /* len is unused here */
  138.   return l;
  139. }
  140.  
  141. PRIMITIVE STk_list_length(SCM l)
  142. {
  143.   int len = STk_llength(l);
  144.   if (len >= 0) return STk_makeinteger((long) len);
  145.   Err("length: not calculable.", NIL);
  146. }
  147.  
  148. static SCM append2(SCM l1, SCM l2)
  149. {
  150.   register SCM res, p;
  151.  
  152.   if (NULLP(l1)) return l2;
  153.   if (NCONSP(l1)) goto Error;
  154.  
  155.   for (res = NIL; ; l1 = CDR(l1)) {
  156.     if (NCONSP(l1))      goto Error;
  157.     if (res == NIL){
  158.       NEWCELL(res, tc_cons);
  159.       p = res;
  160.     }
  161.     else {
  162.       NEWCELL(CDR(p), tc_cons);
  163.       p = CDR(p);
  164.     }
  165.     CAR(p) = CAR(l1);
  166.     CDR(p) = NIL;        /* Keep alwys a valid list in case of a GC */
  167.     if (NCONSP(CDR(l1))) break;
  168.   }
  169.   CDR(p) = l2;
  170.   return res;
  171. Error: 
  172.    Err("append: argument is not a list", l1);
  173. }
  174.  
  175. PRIMITIVE STk_append(SCM l, int len)
  176. {
  177.   switch (len) {
  178.     case 0:  return NIL;
  179.     case 1:  return CAR(l);
  180.     case 2:  return append2(CAR(l), CAR(CDR(l)));
  181.     default: return append2(CAR(l), STk_append(CDR(l), len-1));
  182.   }
  183. }
  184.  
  185. PRIMITIVE STk_reverse(SCM l)
  186. {
  187.   SCM p, n = NIL;
  188.  
  189.   for(p=l; NNULLP(p); p=CDR(p)) {
  190.     if (NCONSP(p)) Err("reverse: bad list", l);
  191.     n = Cons(CAR(p),n);
  192.   }
  193.   return n;
  194. }
  195.  
  196. PRIMITIVE STk_list_tail(SCM list, SCM k)
  197. {
  198.   register long x;
  199.  
  200.   if (NCONSP(list)) Err("list-tail: Bad list", list);
  201.   x = STk_integer_value(k);
  202.   if (x >= 0) {
  203.     SCM l = list;
  204.  
  205.     for (l=list; x > 0; x--) {
  206.       if (NULLP(l) || NCONSP(l)) Err("list-tail: list too short", list);
  207.       l = CDR(l);
  208.     }
  209.     return l;
  210.   }
  211.   Err("list-tail: index must be exact positive integer", k);
  212. }
  213.  
  214. PRIMITIVE STk_list_ref(SCM list, SCM k)
  215. {
  216.   register long x;
  217.  
  218.   if (NCONSP(list)) Err("list-ref: Bad list", list);    
  219.   x = STk_integer_value(k);
  220.   if (x >= 0) {
  221.     SCM l = list;
  222.  
  223.     for ( ; x > 0; x--) {
  224.       if (NULLP(l) || NCONSP(l)) goto Error;
  225.       l = CDR(l);
  226.     }
  227.     
  228.     if (CONSP(l)) return CAR(l);
  229.   Error: 
  230.     Err("list-ref: list too short", list);
  231.   }
  232.   Err("list-ref: index must be exact positive integer", k);
  233. }
  234.  
  235. static SCM lmember(SCM obj, SCM list,  SCM (*predicate)(SCM, SCM) )
  236. {
  237.   register SCM ptr;
  238.     
  239.   if (NCONSP(list) && NNULLP(list)) goto Error;
  240.   for (ptr=list; NNULLP(ptr); ) { 
  241.     if (CONSP(ptr)) {
  242.       if ((*predicate)(CAR(ptr), obj) == Truth) return ptr;
  243.     }
  244.     else 
  245.       /* end of a dotted list */
  246.       return ((*predicate)(ptr, obj) == Truth) ? ptr : Ntruth;
  247.     if ((ptr=CDR(ptr)) == list) goto Error;
  248.   }
  249.   return Ntruth;
  250. Error:
  251.   Err("member function: Bad list", list);
  252. }
  253.  
  254. PRIMITIVE STk_memq  (SCM obj, SCM list)    {return lmember(obj, list, STk_eq);   }
  255. PRIMITIVE STk_memv  (SCM obj, SCM list)    {return lmember(obj, list, STk_eqv);  }
  256. PRIMITIVE STk_member(SCM obj, SCM list)    {return lmember(obj, list, STk_equal);}
  257.  
  258. static SCM lassoc(SCM obj, SCM alist, SCM (*predicate)(SCM, SCM))
  259. {
  260.   register SCM l,tmp;
  261.     
  262.   for(l=alist; CONSP(l); ) {
  263.     tmp = CAR(l);
  264.     if (CONSP(tmp) && (*predicate)(CAR(tmp), obj) == Truth) return tmp;
  265.     if ((l=CDR(l)) == alist) goto Error;
  266.   }
  267.   if (NULLP(l)) return(Ntruth);
  268. Error:
  269.   Err("assoc function: improper list", alist);
  270. }
  271.  
  272. PRIMITIVE STk_assq (SCM obj, SCM alist){return lassoc(obj, alist, STk_eq);   }
  273. PRIMITIVE STk_assv (SCM obj, SCM alist){return lassoc(obj, alist, STk_eqv);  }
  274. PRIMITIVE STk_assoc(SCM obj, SCM alist){return lassoc(obj, alist, STk_equal);}
  275.  
  276.  
  277. /***
  278.  *
  279.  * Non standard functions 
  280.  *
  281.  ***/
  282.  
  283. PRIMITIVE STk_liststar(SCM l, int len)
  284. {
  285.   if (len == 0) return NIL;
  286.   /* l is a pair */
  287.   return (len == 1) ? CAR(l) : STk_cons(CAR(l), STk_liststar(CDR(l), len-1));
  288. }
  289.  
  290. PRIMITIVE STk_copy_tree(SCM l)
  291. {
  292.   return CONSP(l) ? STk_cons(STk_copy_tree(CAR(l)), STk_copy_tree(CDR(l))): l;
  293. }
  294.