/[gcl]/gcl/ansi-tests/cons-test-02.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/cons-test-02.lsp

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

revision 1.1 by pfdietz, Thu Sep 26 16:53:37 2002 UTC revision 1.2 by pfdietz, Thu Oct 17 13:16:56 2002 UTC
# Line 17  Line 17 
17    (cond    (cond
18     ((consp x)     ((consp x)
19      (and (consp y)      (and (consp y)
20           (not (eq x y))           (not (eqt x y))
21           (check-cons-copy (car x) (car y))           (check-cons-copy (car x) (car y))
22           (check-cons-copy (cdr x) (cdr y))))           (check-cons-copy (cdr x) (cdr y))))
23     ((eq x y) t)     ((eqt x y) t)
24     (t nil)))     (t nil)))
25    
26  ;; Try copy-tree on a tree containing elements of various kinds  ;; Try copy-tree on a tree containing elements of various kinds
# Line 55  Line 55 
55             (apply #'sublis al a             (apply #'sublis al a
56                    `(,@(when test `(:test ,test))                    `(,@(when test `(:test ,test))
57                      ,@(when test-not `(:test-not ,test-not))                      ,@(when test-not `(:test-not ,test-not))
58                      ,@(unless (eq key 'no-key) `(:key ,key))))))                      ,@(unless (eqt key 'no-key) `(:key ,key))))))
59        (and        (and
60         (check-scaffold-copy a acopy)         (check-scaffold-copy a acopy)
61         (check-scaffold-copy al alcopy)         (check-scaffold-copy al alcopy)
# Line 131  Line 131 
131           (apply #'sublis (copy-tree al) (copy-tree a)           (apply #'sublis (copy-tree al) (copy-tree a)
132                  `(,@(when test `(:test ,test))                  `(,@(when test `(:test ,test))
133                      ,@(when test-not `(:test-not ,test-not))                      ,@(when test-not `(:test-not ,test-not))
134                      ,@(unless (eq key 'no-key) `(:key ,key))))))                      ,@(unless (eqt key 'no-key) `(:key ,key))))))
135      as))      as))
136    
137    
# Line 215  Line 215 
215          (treecopy (make-scaffold-copy tree)))          (treecopy (make-scaffold-copy tree)))
216      (let ((result      (let ((result
217             (apply #'subst new old tree             (apply #'subst new old tree
218                    `(,@(unless (eq key 'no-key) `(:key ,key))                    `(,@(unless (eqt key 'no-key) `(:key ,key))
219                      ,@(when test `(:test ,test))                      ,@(when test `(:test ,test))
220                      ,@(when test-not `(:test-not ,test-not))))))                      ,@(when test-not `(:test-not ,test-not))))))
221        (and (check-scaffold-copy new newcopy)        (and (check-scaffold-copy new newcopy)
# Line 296  Line 296 
296          (treecopy (make-scaffold-copy tree)))          (treecopy (make-scaffold-copy tree)))
297      (let ((result      (let ((result
298             (apply #'subst-if new pred tree             (apply #'subst-if new pred tree
299                    (unless (eq key 'no-key) `(:key ,key)))))                    (unless (eqt key 'no-key) `(:key ,key)))))
300        (and (check-scaffold-copy new newcopy)        (and (check-scaffold-copy new newcopy)
301             (check-scaffold-copy pred predcopy)             (check-scaffold-copy pred predcopy)
302             (check-scaffold-copy tree treecopy)             (check-scaffold-copy tree treecopy)
# Line 312  Line 312 
312          (treecopy (make-scaffold-copy tree)))          (treecopy (make-scaffold-copy tree)))
313      (let ((result      (let ((result
314             (apply #'subst-if-not new pred tree             (apply #'subst-if-not new pred tree
315                    (unless (eq key 'no-key) `(:key ,key)))))                    (unless (eqt key 'no-key) `(:key ,key)))))
316        (and (check-scaffold-copy new newcopy)        (and (check-scaffold-copy new newcopy)
317             (check-scaffold-copy pred predcopy)             (check-scaffold-copy pred predcopy)
318             (check-scaffold-copy tree treecopy)             (check-scaffold-copy tree treecopy)
# Line 403  Line 403 
403    (setf old (copy-tree old))    (setf old (copy-tree old))
404    (setf tree (copy-tree tree))    (setf tree (copy-tree tree))
405    (apply #'nsubst new old tree    (apply #'nsubst new old tree
406           `(,@(unless (eq key 'no-key) `(:key ,key))           `(,@(unless (eqt key 'no-key) `(:key ,key))
407               ,@(when test `(:test ,test))               ,@(when test `(:test ,test))
408               ,@(when test-not `(:test-not ,test-not)))))               ,@(when test-not `(:test-not ,test-not)))))
409    
# Line 474  Line 474 
474    (setf new (copy-tree new))    (setf new (copy-tree new))
475    (setf tree (copy-tree tree))    (setf tree (copy-tree tree))
476    (apply #'nsubst-if new pred tree    (apply #'nsubst-if new pred tree
477           (unless (eq key 'no-key) `(:key ,key))))           (unless (eqt key 'no-key) `(:key ,key))))
478    
479  (defun check-nsubst-if-not (new pred tree &key (key 'no-key))  (defun check-nsubst-if-not (new pred tree &key (key 'no-key))
480    "Call nsubst-if-not new pred tree, with keyword arguments if present."    "Call nsubst-if-not new pred tree, with keyword arguments if present."
481    (setf new (copy-tree new))    (setf new (copy-tree new))
482    (setf tree (copy-tree tree))    (setf tree (copy-tree tree))
483    (apply #'nsubst-if-not new pred tree    (apply #'nsubst-if-not new pred tree
484                    (unless (eq key 'no-key) `(:key ,key))))                    (unless (eqt key 'no-key) `(:key ,key))))
485    
486  (deftest nsubst-if-1  (deftest nsubst-if-1
487      (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c)))      (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c)))

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

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