libguile/list.c

   1 /*      Copyright (C) 1995,1996 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42 #include <stdio.h>
  43 #include "_scm.h"
  44 #include "eq.h"
  45
  46 #include "list.h"
  47
  48 #ifdef __STDC__
  49 #include <stdarg.h>
  50 #define var_start(x, y) va_start(x, y)
  51 #else
  52 #include <varargs.h>
  53 #define var_start(x, y) va_start(x)
  54 #endif
  55
  56 \f
  57 /* creating lists */
  58
  59 /* SCM_P won't help us deal with varargs here.  */
  60 #ifdef __STDC__
  61 SCM
  62 scm_listify (SCM elt, ...)
  63 #else
  64 SCM
  65 scm_listify (elt, va_alist)
  66      SCM elt;
  67      va_dcl
  68 #endif
  69 {
  70   va_list foo;
  71   SCM answer;
  72   SCM *pos;
  73
  74   var_start (foo, elt);
  75   answer = SCM_EOL;
  76   pos = &answer;
  77   while (elt != SCM_UNDEFINED)
  78     {
  79       *pos = scm_cons (elt, SCM_EOL);
  80       pos = SCM_CDRLOC (*pos);
  81       elt = va_arg (foo, SCM);
  82     }
  83   return answer;
  84 }
  85
  86
  87 SCM_PROC(s_list, "list", 0, 0, 1, scm_list);
  88 SCM
  89 scm_list(objs)
  90      SCM objs;
  91 {
  92   return objs;
  93 }
  94
  95
  96
  97 \f
  98 /* general questions about lists --- null?, list?, length, etc.  */
  99
 100 SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p);
 101 SCM
 102 scm_null_p(x)
 103      SCM x;
 104 {
 105  return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
 106 }
 107
 108 SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p);
 109 SCM
 110 scm_list_p(x)
 111      SCM x;
 112 {
 113   if (scm_ilength(x)<0)
 114     return SCM_BOOL_F;
 115   else
 116     return SCM_BOOL_T;
 117 }
 118
 119
 120 /* Return the length of SX, or -1 if it's not a proper list.
 121    This uses the "tortoise and hare" algorithm to detect "infinitely
 122    long" lists (i.e. lists with cycles in their cdrs), and returns -1
 123    if it does find one.  */
 124 long
 125 scm_ilength(sx)
 126      SCM sx;
 127 {
 128   register long i = 0;
 129   register SCM tortoise = sx;
 130   register SCM hare = sx;
 131
 132   do {
 133     if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1;
 134     if SCM_NCONSP(hare) return -1;
 135     hare = SCM_CDR(hare);
 136     i++;
 137     if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1;
 138     if SCM_NCONSP(hare) return -1;
 139     hare = SCM_CDR(hare);
 140     i++;
 141     /* For every two steps the hare takes, the tortoise takes one.  */
 142     tortoise = SCM_CDR(tortoise);
 143   }
 144   while (hare != tortoise);
 145
 146   /* If the tortoise ever catches the hare, then the list must contain
 147      a cycle.  */
 148   return -1;
 149 }
 150
 151 SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length);
 152 SCM
 153 scm_list_length(x)
 154      SCM x;
 155 {
 156   int i;
 157   i = scm_ilength(x);
 158   SCM_ASSERT(i >= 0, x, SCM_ARG1, s_list_length);
 159   return SCM_MAKINUM (i);
 160 }
 161
 162
 163 \f
 164 /* appending lists */
 165
 166 SCM_PROC (s_list_append, "list-append", 0, 0, 1, scm_list_append);
 167 SCM
 168 scm_list_append(args)
 169      SCM args;
 170 {
 171   SCM res = SCM_EOL;
 172   SCM *lloc = &res, arg;
 173   if SCM_IMP(args) {
 174     SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append);
 175     return res;
 176   }
 177   SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append);
 178   while (1) {
 179     arg = SCM_CAR(args);
 180     args = SCM_CDR(args);
 181     if SCM_IMP(args) {
 182       *lloc = arg;
 183       SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append);
 184       return res;
 185     }
 186     SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append);
 187     for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) {
 188       SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_list_append);
 189       *lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
 190       lloc = SCM_CDRLOC(*lloc);
 191     }
 192     SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_list_append);
 193   }
 194 }
 195
 196
 197 SCM_PROC (s_list_append_x, "list-append!", 0, 0, 1, scm_list_append_x);
 198 SCM
 199 scm_list_append_x(args)
 200      SCM args;
 201 {
 202   SCM arg;
 203  tail:
 204   if SCM_NULLP(args) return SCM_EOL;
 205   arg = SCM_CAR(args);
 206   SCM_ASSERT(SCM_NULLP(arg) || (SCM_NIMP(arg) && SCM_CONSP(arg)), arg, SCM_ARG1, s_list_append_x);
 207   args = SCM_CDR(args);
 208   if SCM_NULLP(args) return arg;
 209   if SCM_NULLP(arg) goto tail;
 210   SCM_SETCDR (scm_last_pair (arg), scm_list_append_x (args));
 211   return arg;
 212 }
 213
 214
 215 SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
 216 SCM
 217 scm_last_pair(sx)
 218      SCM sx;
 219 {
 220   register SCM res = sx;
 221   register SCM x;
 222
 223   if (SCM_NULLP (sx))
 224     return SCM_EOL;
 225
 226   SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair);
 227   while (!0) {
 228     x = SCM_CDR(res);
 229     if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
 230     res = x;
 231     x = SCM_CDR(res);
 232     if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
 233     res = x;
 234     sx = SCM_CDR(sx);
 235     SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair);
 236   }
 237 }
 238
 239 \f
 240 /* reversing lists */
 241
 242 SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse);
 243 SCM
 244 scm_list_reverse(lst)
 245      SCM lst;
 246 {
 247         SCM res = SCM_EOL;
 248         SCM p = lst;
 249         for(;SCM_NIMP(p);p = SCM_CDR(p)) {
 250                 SCM_ASSERT(SCM_CONSP(p), lst, SCM_ARG1, s_list_reverse);
 251                 res = scm_cons(SCM_CAR(p), res);
 252         }
 253         SCM_ASSERT(SCM_NULLP(p), lst, SCM_ARG1, s_list_reverse);
 254         return res;
 255 }
 256
 257 SCM_PROC (s_list_reverse_x, "list-reverse!", 1, 1, 0, scm_list_reverse_x);
 258 SCM
 259 scm_list_reverse_x (lst, newtail)
 260      SCM lst;
 261      SCM newtail;
 262 {
 263   SCM old_tail;
 264   if (newtail == SCM_UNDEFINED)
 265     newtail = SCM_EOL;
 266
 267  loop:
 268   if (!(SCM_NIMP (lst) && SCM_CONSP (lst)))
 269     return lst;
 270
 271   old_tail = SCM_CDR (lst);
 272   SCM_SETCDR (lst, newtail);
 273   if (SCM_NULLP (old_tail))
 274     return lst;
 275
 276   newtail = lst;
 277   lst = old_tail;
 278   goto loop;
 279 }
 280
 281
 282 \f
 283 /* indexing lists by element number */
 284
 285 SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref);
 286 SCM
 287 scm_list_ref(lst, k)
 288      SCM lst;
 289      SCM k;
 290 {
 291         register long i;
 292         SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref);
 293         i = SCM_INUM(k);
 294         SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_ref);
 295         while (i-- > 0) {
 296                 SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
 297                 lst = SCM_CDR(lst);
 298         }
 299 erout:  SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
 300                SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_ref);
 301         return SCM_CAR(lst);
 302 }
 303
 304 SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x);
 305 SCM
 306 scm_list_set_x(lst, k, val)
 307      SCM lst;
 308      SCM k;
 309      SCM val;
 310 {
 311         register long i;
 312         SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x);
 313         i = SCM_INUM(k);
 314         SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_set_x);
 315         while (i-- > 0) {
 316                 SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
 317                 lst = SCM_CDR(lst);
 318         }
 319 erout:  SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
 320                SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x);
 321         SCM_SETCAR (lst, val);
 322         return val;
 323 }
 324
 325
 326 SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
 327 SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail);
 328 SCM
 329 scm_list_tail(lst, k)
 330      SCM lst;
 331      SCM k;
 332 {
 333   register long i;
 334   SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail);
 335   i = SCM_INUM(k);
 336   while (i-- > 0) {
 337     SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail);
 338     lst = SCM_CDR(lst);
 339   }
 340   return lst;
 341 }
 342
 343
 344 SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x);
 345 SCM
 346 scm_list_cdr_set_x(lst, k, val)
 347      SCM lst;
 348      SCM k;
 349      SCM val;
 350 {
 351         register long i;
 352         SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x);
 353         i = SCM_INUM(k);
 354         SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_cdr_set_x);
 355         while (i-- > 0) {
 356                 SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
 357                 lst = SCM_CDR(lst);
 358         }
 359 erout:  SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
 360                SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_cdr_set_x);
 361         SCM_SETCDR (lst, val);
 362         return val;
 363 }
 364
 365
 366 \f
 367 /* copying lists, perhaps partially */
 368
 369 SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head);
 370 SCM
 371 scm_list_head(lst, k)
 372      SCM lst;
 373      SCM k;
 374 {
 375   SCM answer;
 376   SCM * pos;
 377   register long i;
 378
 379   SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_head);
 380   answer = SCM_EOL;
 381   pos = &answer;
 382   i = SCM_INUM(k);
 383   while (i-- > 0)
 384     {
 385       SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head);
 386       *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
 387       pos = SCM_CDRLOC (*pos);
 388       lst = SCM_CDR(lst);
 389     }
 390   return answer;
 391 }
 392
 393
 394 SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy);
 395 SCM
 396 scm_list_copy (lst)
 397      SCM lst;
 398 {
 399   SCM newlst;
 400   SCM * fill_here;
 401   SCM from_here;
 402
 403   newlst = SCM_EOL;
 404   fill_here = &newlst;
 405   from_here = lst;
 406
 407   while (SCM_NIMP (from_here) && SCM_CONSP (from_here))
 408     {
 409       SCM c;
 410       c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
 411       *fill_here = c;
 412       fill_here = SCM_CDRLOC (c);
 413       from_here = SCM_CDR (from_here);
 414     }
 415   return newlst;
 416 }
 417
 418 \f
 419 /* membership tests (memq, memv, etc.) */
 420
 421 static void sloppy_mem_check SCM_P ((SCM obj, char * where, char * why));
 422
 423 static void
 424 sloppy_mem_check (obj, where, why)
 425      SCM obj;
 426      char * where;
 427      char * why;
 428 {
 429   SCM_ASSERT ((scm_ilength (obj) >= 0), obj, where, why);
 430 }
 431
 432
 433 SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq);
 434 SCM
 435 scm_sloppy_memq(x, lst)
 436      SCM x;
 437      SCM lst;
 438 {
 439   for(;  SCM_NIMP(lst) && SCM_CONSP (lst);  lst = SCM_CDR(lst))
 440     {
 441       if (SCM_CAR(lst)==x)
 442         return lst;
 443     }
 444   return lst;
 445 }
 446
 447
 448 SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv);
 449 SCM
 450 scm_sloppy_memv(x, lst)
 451      SCM x;
 452      SCM lst;
 453 {
 454   for(;  SCM_NIMP(lst) && SCM_CONSP (lst);  lst = SCM_CDR(lst))
 455     {
 456       if (SCM_BOOL_F != scm_eqv_p (SCM_CAR(lst), x))
 457         return lst;
 458     }
 459   return lst;
 460 }
 461
 462
 463 SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member);
 464 SCM
 465 scm_sloppy_member (x, lst)
 466      SCM x;
 467      SCM lst;
 468 {
 469   for(;  SCM_NIMP(lst) && SCM_CONSP (lst);  lst = SCM_CDR(lst))
 470     {
 471       if (SCM_BOOL_F != scm_equal_p (SCM_CAR(lst), x))
 472         return lst;
 473     }
 474   return lst;
 475 }
 476
 477
 478
 479 SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq);
 480 SCM
 481 scm_memq(x, lst)
 482      SCM x;
 483      SCM lst;
 484 {
 485   SCM answer;
 486   answer = scm_sloppy_memq (x, lst);
 487   sloppy_mem_check (answer, (char *)SCM_ARG2, s_memq);
 488   return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
 489 }
 490
 491
 492
 493 SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv);
 494 SCM
 495 scm_memv(x, lst)
 496      SCM x;
 497      SCM lst;
 498 {
 499   SCM answer;
 500   answer = scm_sloppy_memv (x, lst);
 501   sloppy_mem_check (answer, (char *)SCM_ARG2, s_memv);
 502   return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
 503 }
 504
 505
 506 SCM_PROC(s_member, "member", 2, 0, 0, scm_member);
 507 SCM
 508 scm_member(x, lst)
 509      SCM x;
 510      SCM lst;
 511 {
 512   SCM answer;
 513   answer = scm_sloppy_member (x, lst);
 514   sloppy_mem_check (answer, (char *)SCM_ARG2, s_member);
 515   return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
 516 }
 517
 518
 519 \f
 520 /* deleting elements from a list (delq, etc.) */
 521
 522 SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x);
 523 SCM
 524 scm_delq_x (item, lst)
 525      SCM item;
 526      SCM lst;
 527 {
 528   SCM start;
 529
 530   if (SCM_IMP (lst) || SCM_NCONSP (lst))
 531     return lst;
 532
 533   if (SCM_CAR (lst) == item)
 534     return SCM_CDR (lst);
 535
 536   start = lst;
 537
 538   while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
 539     {
 540       if (SCM_CAR (SCM_CDR (lst)) == item)
 541         {
 542           SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
 543           return start;
 544         }
 545       lst = SCM_CDR (lst);
 546     }
 547   return start;
 548 }
 549
 550
 551 SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x);
 552 SCM
 553 scm_delv_x (item, lst)
 554      SCM item;
 555      SCM lst;
 556 {
 557   SCM start;
 558
 559   if (SCM_IMP (lst) || SCM_NCONSP (lst))
 560     return lst;
 561
 562   if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (lst), item))
 563     return SCM_CDR (lst);
 564
 565   start = lst;
 566
 567   while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
 568     {
 569       if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (SCM_CDR (lst)), item))
 570         {
 571           SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
 572           return start;
 573         }
 574       lst = SCM_CDR (lst);
 575     }
 576   return start;
 577 }
 578
 579
 580
 581 SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x);
 582 SCM
 583 scm_delete_x (item, lst)
 584      SCM item;
 585      SCM lst;
 586 {
 587   SCM start;
 588
 589   if (SCM_IMP (lst) || SCM_NCONSP (lst))
 590     return lst;
 591
 592   if (SCM_BOOL_F != scm_equal_p (SCM_CAR (lst), item))
 593     return SCM_CDR (lst);
 594
 595   start = lst;
 596
 597   while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
 598     {
 599       if (SCM_BOOL_F != scm_equal_p (SCM_CAR (SCM_CDR (lst)), item))
 600         {
 601           SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
 602           return start;
 603         }
 604       lst = SCM_CDR (lst);
 605     }
 606   return start;
 607 }
 608
 609
 610 \f
 611
 612
 613 SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq);
 614 SCM
 615 scm_delq (item, lst)
 616      SCM item;
 617      SCM lst;
 618 {
 619   SCM copy;
 620
 621   copy = scm_list_copy (lst);
 622   return scm_delq_x (item, copy);
 623 }
 624
 625 SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv);
 626 SCM
 627 scm_delv (item, lst)
 628      SCM item;
 629      SCM lst;
 630 {
 631   SCM copy;
 632
 633   copy = scm_list_copy (lst);
 634   return scm_delv_x (item, copy);
 635 }
 636
 637 SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete);
 638 SCM
 639 scm_delete (item, lst)
 640      SCM item;
 641      SCM lst;
 642 {
 643   SCM copy;
 644
 645   copy = scm_list_copy (lst);
 646   return scm_delete_x (item, copy);
 647 }
 648
 649
 650 \f
 651 void
 652 scm_init_list ()
 653 {
 654 #include "list.x"
 655 }