Merge branch 'build-tweaks' of https://github.com/nikodemus/jscl into nikodemus-build...

[jscl.git] / src / boot.lisp

diff --git a/src/boot.lisp b/src/boot.lisp
index d89b6bd..2dfadd7 100644 (file)
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -74,20 +74,9 @@
      ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
      ',name))
 
-(defmacro named-lambda (name args &rest body)
-  (let ((x (gensym "FN")))
-    `(let ((,x (lambda ,args ,@body)))
-       (oset ,x "fname" ,name)
-       ,x)))
-
 (defmacro defun (name args &rest body)
   `(progn
-     
-     (fset ',name
-           (named-lambda ,(symbol-name name) ,args
-             ,@(if (and (stringp (car body)) (not (null (cdr body))))
-                   `(,(car body) (block ,name ,@(cdr body)))
-                   `((block ,name ,@body)))))
+     (fset ',name #'(named-lambda ,name ,args ,@body))
      ',name))
 
 (defun null (x)
@@ -553,9 +542,9 @@
       (incf pos))
     pos))
 
-(defun assoc (x alist)
+(defun assoc (x alist &key (test #'eql))
   (while alist
-    (if (eql x (caar alist))
+    (if (funcall test x (caar alist))
         (return)
         (setq alist (cdr alist))))
   (car alist))
@@ -565,6 +554,23 @@
         ((symbolp x) (symbol-name x))
         (t (char-to-string x))))
 
+(defun equal (x y)
+  (cond
+    ((eql x y) t)
+    ((consp x)
+     (and (consp y)
+          (equal (car x) (car y))
+          (equal (cdr x) (cdr y))))
+    ((arrayp x)
+     (and (arrayp y)
+          (let ((n (length x)))
+            (when (= (length y) n)
+              (dotimes (i n)
+                (unless (equal (aref x i) (aref y i))
+                  (return-from equal nil)))
+              t))))
+    (t nil)))
+
 (defun string= (s1 s2)
   (equal s1 s2))