← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/lsp/listlib.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/lsp/listlib.lsp
 
1
;;;;  Copyright (c) 1995, Giuseppe Attardi.
 
2
;;;;
 
3
;;;;    This program is free software; you can redistribute it and/or
 
4
;;;;    modify it under the terms of the GNU Library General Public
 
5
;;;;    License as published by the Free Software Foundation; either
 
6
;;;;    version 2 of the License, or (at your option) any later version.
 
7
;;;;
 
8
;;;;    See file '../Copyright' for full details.
 
9
;;;;                        list manipulating routines
 
10
 
 
11
(in-package "SYSTEM")
 
12
 
 
13
(defun union (list1 list2 &key test test-not key)
 
14
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
15
Returns, as a list, the union of elements in LIST1 and in LIST2."
 
16
  (do ((x list1 (cdr x))
 
17
       (first) (last))
 
18
      ((null x)
 
19
       (when last (rplacd last list2))
 
20
       (or first list2))
 
21
    (unless (member1 (car x) list2 test test-not key)
 
22
      (if last
 
23
          (progn (rplacd last (cons (car x) nil))
 
24
                 (setq last (cdr last)))
 
25
          (progn (setq first (cons (car x) nil))
 
26
                 (setq last first))))))
 
27
 
 
28
(defun nunion (list1 list2 &key test test-not key)
 
29
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
30
Destructive UNION.  Both LIST1 and LIST2 may be destroyed."
 
31
  (do ((x list1 (cdr x))
 
32
       (first) (last))
 
33
      ((null x)
 
34
       (when last (rplacd last list2))
 
35
       (or first list2))
 
36
    (unless (member1 (car x) list2 test test-not key)
 
37
      (if last
 
38
          (rplacd last x)
 
39
          (setq first x))
 
40
      (setq last x))))
 
41
 
 
42
(defun intersection (list1 list2 &key test test-not key)
 
43
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
44
Returns a list consisting of those objects that are elements of both LIST1 and
 
45
LIST2."
 
46
  (do ((x list1 (cdr x))
 
47
       (ans))
 
48
      ((null x)
 
49
       (nreverse ans)) ; optional nreverse: not required by CLtL
 
50
    (when (member1 (car x) list2 test test-not key)
 
51
        (push (car x) ans))))
 
52
 
 
53
(defun nintersection (list1 list2 &key test test-not key)
 
54
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
55
Destructive INTERSECTION.  Only LIST1 may be destroyed."
 
56
  (do ((x list1 (cdr x))
 
57
       (first) (last))
 
58
      ((null x)
 
59
       (when last (rplacd last nil))
 
60
       first)
 
61
    (when (member1 (car x) list2 test test-not key)
 
62
      (if last
 
63
          (rplacd last x)
 
64
          (setq first x))
 
65
      (setq last x))))
 
66
 
 
67
(defun set-difference (list1 list2 &key test test-not key)
 
68
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
69
Returns, as a list, those elements of LIST1 that are not elements of LIST2."
 
70
  (do ((x list1 (cdr x))
 
71
       (ans))
 
72
      ((null x) (nreverse ans))
 
73
    (unless (member1 (car x) list2 test test-not key)
 
74
      (push (car x) ans))))
 
75
 
 
76
(defun nset-difference (list1 list2 &key test test-not key)
 
77
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
78
Destructive SET-DIFFERENCE.  Only LIST1 may be destroyed."
 
79
  (do ((x list1 (cdr x))
 
80
       (first) (last))
 
81
      ((null x)
 
82
       (when last (rplacd last nil))
 
83
       first)
 
84
    (unless (member1 (car x) list2 test test-not key)
 
85
      (if last
 
86
          (rplacd last x)
 
87
          (setq first x))
 
88
      (setq last x))))
 
89
 
 
90
(defun swap-args (f)
 
91
  (declare (si::c-local))
 
92
  (and f #'(lambda (x y) (funcall f y x))))
 
93
 
 
94
(defun set-exclusive-or (list1 list2 &key test test-not key)
 
95
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
96
Returns, as a list, those elements of LIST1 that are not elements of LIST2 and
 
97
those elements of LIST2 that are not elements of LIST1."
 
98
  (nconc (set-difference list1 list2 :test test :test-not test-not :key key)
 
99
         (set-difference list2 list1 :test (swap-args test) :test-not (swap-args test-not) :key key)))
 
100
 
 
101
(defun nset-exclusive-or (list1 list2 &key test test-not key)
 
102
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
103
Destructive SET-EXCLUSIVE-OR.  Both LIST1 and LIST2 may be destroyed."
 
104
  (nconc (set-difference list1 list2 :test test :test-not test-not :key key)
 
105
         (nset-difference list2 list1 :test (swap-args test) :test-not (swap-args test-not) :key key)))
 
106
 
 
107
(defun subsetp (list1 list2 &key test test-not key)
 
108
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
 
109
Returns T if every element of LIST1 is also an element of LIST2.  Returns NIL
 
110
otherwise."
 
111
  (do ((l list1 (cdr l)))
 
112
      ((null l) t)
 
113
    (unless (member1 (car l) list2 test test-not key)
 
114
      (return nil))))
 
115
 
 
116
(defun rassoc-if (pred arg &key key)
 
117
  (rassoc pred arg :test #'funcall :key key))
 
118
(defun rassoc-if-not (pred arg &key key)
 
119
  (rassoc pred arg :test-not #'funcall :key key))
 
120
 
 
121
(defun assoc-if (pred arg &key key)
 
122
  (assoc pred arg :test #'funcall :key key))
 
123
(defun assoc-if-not (pred arg &key key)
 
124
  (assoc pred arg :test-not #'funcall :key key))
 
125
 
 
126
(defun member-if (pred arg &key key)
 
127
  (member pred arg :test #'funcall :key key))
 
128
(defun member-if-not (pred arg &key key)
 
129
  (member pred arg :test-not #'funcall :key key))
 
130
 
 
131
(defun subst-if (new old where &key key)
 
132
  (subst new old where :test #'funcall :key key))
 
133
(defun subst-if-not (new old where &key key)
 
134
  (subst new old where :test-not #'funcall :key key))
 
135
 
 
136
(defun nsubst-if (new old where &key key)
 
137
  (nsubst new old where :test #'funcall :key key))
 
138
(defun nsubst-if-not (new old where &key key)
 
139
  (nsubst new old where :test-not #'funcall :key key))