/[gcl]/gcl/lsp/listlib.lsp
ViewVC logotype

Diff of /gcl/lsp/listlib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by camm, Tue Oct 1 04:37:33 2002 UTC revision 1.3 by camm, Fri Jan 24 18:38:28 2003 UTC
# Line 37  Line 37 
37    (proclaim '(optimize (safety 0) (space 3)))    (proclaim '(optimize (safety 0) (space 3)))
38    )    )
39    
40    (defun key-list (key test test-not &aux (tem nil))
41      (when key (push :key tem) (push key tem))
42      (when test (push :test tem) (push test tem))
43      (when test-not (push :test-not tem) (push test-not tem))
44      (nreverse tem))
45    
46  ;(defun union (list1 list2 &rest rest &key test test-not key)  ;(defun union (list1 list2 &rest rest &key test test-not key)
47  ;  (declare (ignore test test-not key))  ;  (declare (ignore test test-not key))
48  ;  (cond ((null list1) list2)  ;  (cond ((null list1) list2)
# Line 45  Line 51 
51  ;        (t  ;        (t
52  ;         (cons (car list1)  ;         (cons (car list1)
53  ;               (apply #'union (cdr list1) list2 rest)))))  ;               (apply #'union (cdr list1) list2 rest)))))
54  (defun union (list1 list2 &rest rest &aux first last)  (defun union (list1 list2 &key test test-not key &aux first last)
55    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
56        ((null x) (if last (rplacd last list2)) (return (or first list2)))        ((null x) (if last (rplacd last list2)) (return (or first list2)))
57      (or (consp x) (error "UNION not passed a list"))      (or (consp x) (error "UNION not passed a list"))
58      (if (not (apply #'member1 (car x) list2 rest))      (if (not (apply #'member1 (car x) list2 (key-list key test test-not)))
59          (if last (progn (rplacd last (cons (car x) nil))          (if last (progn (rplacd last (cons (car x) nil))
60                          (setq last (cdr last)))                          (setq last (cdr last)))
61                   (progn (setq first (cons (car x) nil))                   (progn (setq first (cons (car x) nil))
# Line 63  Line 69 
69  ;        (t  ;        (t
70  ;         (rplacd list1  ;         (rplacd list1
71  ;                 (apply #'nunion (cdr list1) list2 rest)))))  ;                 (apply #'nunion (cdr list1) list2 rest)))))
72  (defun nunion (list1 list2 &rest rest &aux first last)  (defun nunion (list1 list2 &key test test-not key &aux first last)
73    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
74        ((null x) (if last (rplacd last list2)) (return (or first list2)))        ((null x) (if last (rplacd last list2)) (return (or first list2)))
75      (or (consp x) (error "NUNION not passed a list"))      (or (consp x) (error "NUNION not passed a list"))
76      (if (not (apply #'member1 (car x) list2 rest))      (if (not (apply #'member1 (car x) list2 (key-list key test test-not)))
77          (progn (if last (rplacd last x)          (progn (if last (rplacd last x)
78                          (setq first x))                          (setq first x))
79                 (setq last x))) ) )                 (setq last x))) ) )
# Line 82  Line 88 
88    
89  ;; all functions in this file should be written as follows:  ;; all functions in this file should be written as follows:
90  ;; Besides being non recursive, it allows compilation on safety 0  ;; Besides being non recursive, it allows compilation on safety 0
91  (defun intersection (list1 list2 &rest rest &aux ans)  (defun intersection (list1 list2 &key test test-not key &aux ans)
92    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
93        ((null x) (return ans))        ((null x) (return ans))
94      (or (consp x) (error "INTERSECTION not passed a list"))      (or (consp x) (error "INTERSECTION not passed a list"))
95      (if (apply #'member1 (car x) list2 rest)      (if (apply #'member1 (car x) list2 (key-list key test test-not))
96          (setq ans (cons (car x) ans))))          (setq ans (cons (car x) ans))))
97    )    )
98    
# Line 97  Line 103 
103  ;         (rplacd list1  ;         (rplacd list1
104  ;                 (apply #'nintersection (cdr list1) list2 rest)))  ;                 (apply #'nintersection (cdr list1) list2 rest)))
105  ;        (t (apply #'nintersection (cdr list1) list2 rest))))  ;        (t (apply #'nintersection (cdr list1) list2 rest))))
106  (defun nintersection (list1 list2 &rest rest &aux first last)  (defun nintersection (list1 list2 &key test test-not key &aux first last)
107    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
108        ((null x) (if last (rplacd last nil)) (return first))        ((null x) (if last (rplacd last nil)) (return first))
109      (or (consp x) (error "NINTERSECTION not passed a list"))      (or (consp x) (error "NINTERSECTION not passed a list"))
110      (if (apply #'member1 (car x) list2 rest)      (if (apply #'member1 (car x) list2 (key-list key test test-not))
111          (progn (if last (rplacd last x)          (progn (if last (rplacd last x)
112                          (setq first x))                          (setq first x))
113                 (setq last x))) ) )                 (setq last x))) ) )
# Line 113  Line 119 
119  ;         (cons (car list1)  ;         (cons (car list1)
120  ;               (apply #'set-difference (cdr list1) list2 rest)))  ;               (apply #'set-difference (cdr list1) list2 rest)))
121  ;        (t (apply #'set-difference (cdr list1) list2 rest))))  ;        (t (apply #'set-difference (cdr list1) list2 rest))))
122  (defun set-difference (list1 list2 &rest rest &aux ans)  (defun set-difference (list1 list2 &key test test-not key &aux ans)
123    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
124        ((null x) (return ans))        ((null x) (return ans))
125      (or (consp x) (error "SET-DIFFERENCE not passed a list"))      (or (consp x) (error "SET-DIFFERENCE not passed a list"))
126      (if (not (apply #'member1 (car x) list2 rest))      (if (not (apply #'member1 (car x) list2 (key-list key test test-not)))
127          (setq ans (cons (car x) ans))))  )          (setq ans (cons (car x) ans))))  )
128  (defun set-difference-rev (list1 list2 &rest rest &aux ans)  (defun set-difference-rev (list1 list2 &key test test-not key &aux ans)
129    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
130        ((null x) (return ans))        ((null x) (return ans))
131      (or (consp x) (error "SET-DIFFERENCE not passed a list"))      (or (consp x) (error "SET-DIFFERENCE not passed a list"))
132      (if (not (apply #'member1 (car x) list2 :rev t rest))      (if (not (apply #'member1 (car x) list2 :rev t (key-list key test test-not)))
133          (setq ans (cons (car x) ans))))  )          (setq ans (cons (car x) ans))))  )
134    
135  ;(defun nset-difference (list1 list2 &rest rest &key test test-not key)  ;(defun nset-difference (list1 list2 &rest rest &key test test-not key)
# Line 133  Line 139 
139  ;         (rplacd list1  ;         (rplacd list1
140  ;                 (apply #'nset-difference (cdr list1) list2 rest)))  ;                 (apply #'nset-difference (cdr list1) list2 rest)))
141  ;        (t (apply #'nset-difference (cdr list1) list2 rest))))  ;        (t (apply #'nset-difference (cdr list1) list2 rest))))
142  (defun nset-difference (list1 list2 &rest rest &aux first last)  (defun nset-difference (list1 list2 &key test test-not key &aux first last)
143    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
144        ((null x) (if last (rplacd last nil)) (return first))        ((null x) (if last (rplacd last nil)) (return first))
145      (or (consp x) (error "NSET-DIFFERENCE not passed a list"))      (or (consp x) (error "NSET-DIFFERENCE not passed a list"))
146      (if (not (apply #'member1 (car x) list2 rest))      (if (not (apply #'member1 (car x) list2 (key-list key test test-not)))
147          (progn (if last (rplacd last x)          (progn (if last (rplacd last x)
148                          (setq first x))                          (setq first x))
149                 (setq last x))) ) )                 (setq last x))) ) )
150  (defun nset-difference-rev (list1 list2 &rest rest &aux first last)  (defun nset-difference-rev (list1 list2 &key test test-not key &aux first last)
151    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
152        ((null x) (if last (rplacd last nil)) (return first))        ((null x) (if last (rplacd last nil)) (return first))
153      (or (consp x) (error "NSET-DIFFERENCE not passed a list"))      (or (consp x) (error "NSET-DIFFERENCE not passed a list"))
154      (if (not (apply #'member1 (car x) list2 :rev t rest))      (if (not (apply #'member1 (car x) list2 :rev t (key-list key test test-not)))
155          (progn (if last (rplacd last x)          (progn (if last (rplacd last x)
156                          (setq first x))                          (setq first x))
157                 (setq last x))) ) )                 (setq last x))) ) )
# Line 154  Line 160 
160  ;  (declare (ignore test test-not key))  ;  (declare (ignore test test-not key))
161  ;  (append (apply #'set-difference list1 list2 rest)  ;  (append (apply #'set-difference list1 list2 rest)
162  ;          (apply #'set-difference list2 list1 rest)))  ;          (apply #'set-difference list2 list1 rest)))
163  (defun set-exclusive-or (list1 list2 &rest rest &key test test-not key)  (defun set-exclusive-or (list1 list2 &key test test-not key)
164    (declare (ignore test test-not key))    (nconc (apply #'set-difference list1 list2 (key-list key test test-not))
165    (nconc (apply #'set-difference list1 list2 rest)           (apply #'set-difference-rev list2 list1 (key-list key test test-not))))
          (apply #'set-difference-rev list2 list1 rest)))  
166    
167  ;(defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key)  ;(defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key)
168  ;  (declare (ignore test test-not key))  ;  (declare (ignore test test-not key))
169  ;  (nconc (apply #'set-difference list1 list2 rest)  ;  (nconc (apply #'set-difference list1 list2 rest)
170  ;         (apply #'nset-difference list2 list1 rest)))  ;         (apply #'nset-difference list2 list1 rest)))
171  (defun nset-exclusive-or (list1 list2 &rest rest &aux first last fint lint)  (defun nset-exclusive-or (list1 list2 &key test test-not key &aux first last fint lint)
172    (do ((x list1 (cdr x)))    (do ((x list1 (cdr x)))
173        ((null x) (if lint (rplacd lint nil))        ((null x) (if lint (rplacd lint nil))
174                  (if last                  (if last
175                      (progn (rplacd last                      (progn (rplacd last
176                                     (apply #'nset-difference-rev list2 fint rest))                                     (apply #'nset-difference-rev list2 fint (key-list key test test-not)))
177                             (return first))                             (return first))
178                      (return (apply #'nset-difference-rev list2 fint rest))))                      (return (apply #'nset-difference-rev list2 fint (key-list key test test-not)))))
179      (or (consp x) (error "NSET-EXCLUSIVE-OR not passed a list"))      (or (consp x) (error "NSET-EXCLUSIVE-OR not passed a list"))
180      (if (apply #'member1 (car x) list2 rest)      (if (apply #'member1 (car x) list2 (key-list key test test-not))
181          (progn (if lint (rplacd lint x)          (progn (if lint (rplacd lint x)
182                          (setq fint x))                          (setq fint x))
183                 (setq lint x))                 (setq lint x))
# Line 180  Line 185 
185                          (setq first x))                          (setq first x))
186                 (setq last x))) ) )                 (setq last x))) ) )
187    
188  (defun subsetp (list1 list2 &rest rest &key test test-not key)  (defun subsetp (list1 list2 &key test test-not key)
   (declare (ignore test test-not key))  
189    (do ((l list1 (cdr l)))    (do ((l list1 (cdr l)))
190        ((null l) t)        ((null l) t)
191      (or (consp l) (error "SUBSETP not passed a list"))      (or (consp l) (error "SUBSETP not passed a list"))
192      (if (not (apply #'member1 (car l) list2 rest)) (return nil))))      (if (not (apply #'member1 (car l) list2 (key-list key test test-not))) (return nil))))
193    
194    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26