FIFTH to TENTH

[jscl.git] / src / list.lisp

diff --git a/src/list.lisp b/src/list.lisp
index d2b0247..bbb7557 100644 (file)
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -1,17 +1,17 @@
 ;;; list.lisp --- 
 
 ;;; list.lisp --- 
 

-;; This program is free software: you can redistribute it and/or
+;; JSCL is free software: you can redistribute it and/or

 ;; modify it under the terms of the GNU General Public License as
 ;; published by the Free Software Foundation, either version 3 of the
 ;; License, or (at your option) any later version.
 ;;
 ;; modify it under the terms of the GNU General Public License as
 ;; published by the Free Software Foundation, either version 3 of the
 ;; License, or (at your option) any later version.
 ;;

-;; This program is distributed in the hope that it will be useful, but
+;; JSCL is distributed in the hope that it will be useful, but

 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; General Public License for more details.
 ;;
 ;; You should have received a copy of the GNU General Public License
 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; General Public License for more details.
 ;;
 ;; You should have received a copy of the GNU General Public License

-;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.

 
 ;;;; Various list functions
 
 
 ;;;; Various list functions
 

@@ -29,7 +29,7 @@
       t
       (if (consp x)
           nil
       t
       (if (consp x)
           nil

-          (error "type-error"))))
+          (error "The value `~S' is not a type list." x))))

 
 (defun car (x)
   "Return the CAR part of a cons, or NIL if X is null."
 
 (defun car (x)
   "Return the CAR part of a cons, or NIL if X is null."

@@ -37,11 +37,17 @@
 
 (defun cdr (x) (cdr x))
 
 
 (defun cdr (x) (cdr x))
 

-(defun first (x) (car x))
-(defun second (x) (cadr x))
-(defun third (x) (caddr x))
-(defun fourth (x) (cadddr x))
-(defun rest (x) (cdr x))
+(defun first   (x) (car    x))
+(defun second  (x) (cadr   x))
+(defun third   (x) (caddr  x))
+(defun fourth  (x) (cadddr x))
+(defun fifth   (x) (car    (cddddr x)))
+(defun sixth   (x) (cadr   (cddddr x)))
+(defun seventh (x) (caddr  (cddddr x)))
+(defun eighth  (x) (cadddr (cddddr x)))
+(defun ninth   (x) (car  (cddddr (cddddr x))))
+(defun tenth   (x) (cadr (cddddr (cddddr x))))
+(defun rest    (x) (cdr x))

 
 (defun list (&rest args)
   args)
 
 (defun list (&rest args)
   args)

@@ -62,7 +68,6 @@
 (defun nth (n list)
   (car (nthcdr n list)))
 
 (defun nth (n list)
   (car (nthcdr n list)))
 

-;;; The rest of the C[AD]*R functions; only a few were defined in boot.lisp

 (defun caar (x) (car (car x)))
 (defun cadr (x) (car (cdr x)))
 (defun cdar (x) (cdr (car x)))
 (defun caar (x) (car (car x)))
 (defun cadr (x) (car (cdr x)))
 (defun cdar (x) (cdr (car x)))

@@ -104,6 +109,13 @@
           (copy-tree (cdr tree)))
     tree))
 
           (copy-tree (cdr tree)))
     tree))
 

+(defun tree-equal (tree1 tree2 &key (test #'eql))
+  (if (atom tree1)
+    (and (atom tree2) (funcall test tree1 tree2))
+    (and (consp tree2)
+         (tree-equal (car tree1) (car tree2) :test test)
+         (tree-equal (cdr tree1) (cdr tree2) :test test))))
+

 (defun subst (new old tree &key (key #'identity) (test #'eql))
   (cond 
     ((funcall test (funcall key tree) (funcall key old))
 (defun subst (new old tree &key (key #'identity) (test #'eql))
   (cond 
     ((funcall test (funcall key tree) (funcall key old))