X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=bbc6340f6a15f6606276dd83b3c1808a405b9ddd;hb=a9426a807b6ea5adc09a1eadecb7233337b5aa6a;hp=8b1dcd534102a0ae43ced2f2d5b584a021c5994e;hpb=4f3745f9ef0fa39b381e30c3d442245d24520b26;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 8b1dcd5..bbc6340 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -163,7 +163,14 @@
     `(setq ,x (- ,x ,delta)))
 
   (defmacro push (x place)
-    `(setq ,place (cons ,x ,place)))
+    (multiple-value-bind (dummies vals newval setter getter)
+        (get-setf-expansion place)
+      (let ((g (gensym)))
+        `(let* ((,g ,x)
+                ,@(mapcar #'list dummies vals)
+                (,(car newval) (cons ,g ,getter))
+                ,@(cdr newval))
+           ,setter))))
 
   (defmacro dolist (iter &body body)
     (let ((var (first iter))
@@ -466,6 +473,7 @@
       ((funcall func (car list))
        (remove-if func (cdr list)))
       (t
+       ;;
        (cons (car list) (remove-if func (cdr list))))))
 
   (defun remove-if-not (func list)
@@ -495,39 +503,35 @@
       (t
        (error "Unsupported argument."))))
 
+  (defmacro do-sequence (iteration &body body)
+    (let ((seq (gensym))
+          (index (gensym)))
+      `(let ((,seq ,(second iteration)))
+         (cond
+           ;; Strings
+           ((stringp ,seq)
+            (let ((,index 0))
+              (dotimes (,index (length ,seq))
+                (let ((,(first iteration)
+                       (char ,seq ,index)))
+                  ,@body))))
+           ;; Lists
+           ((listp ,seq)
+            (dolist (,(first iteration) ,seq)
+              ,@body))
+           (t
+            (error "type-error!"))))))
+
   (defun some (function seq)
-    (cond
-      ((stringp seq)
-       (let ((index 0)
-             (size (length seq)))
-         (while (< index size)
-           (when (funcall function (char seq index))
-             (return-from some t))
-           (incf index))
-         nil))
-      ((listp seq)
-       (dolist (x seq nil)
-         (when (funcall function x)
-           (return t))))
-      (t
-       (error "Unknown sequence."))))
+    (do-sequence (elt seq)
+      (when (funcall function elt)
+        (return-from some t))))
 
   (defun every (function seq)
-    (cond
-      ((stringp seq)
-       (let ((index 0)
-             (size (length seq)))
-         (while (< index size)
-           (unless (funcall function (char seq index))
-             (return-from every nil))
-           (incf index))
-         t))
-      ((listp seq)
-       (dolist (x seq t)
-         (unless (funcall function x)
-           (return))))
-      (t
-       (error "Unknown sequence."))))
+    (do-sequence (elt seq)
+      (unless (funcall function elt)
+        (return-from every nil)))
+    t)
 
   (defun assoc (x alist)
     (while alist
@@ -645,17 +649,6 @@
               `(progn (rplacd ,cons ,new-value) ,new-value)
               `(car ,cons))))
 
-<<<<<<< HEAD
-  (defmacro push (x place)
-    (multiple-value-bind (dummies vals newval setter getter)
-        (get-setf-expansion place)
-      (let ((g (gensym)))
-        `(let* ((,g ,x)
-                ,@(mapcar #'list dummies vals)
-                (,(car newval) (cons ,g ,getter))
-                ,@(cdr newval))
-           ,setter))))
-=======
   ;; Incorrect typecase, but used in NCONC.
   (defmacro typecase (x &rest clausules)
     (let ((value (gensym)))
@@ -705,15 +698,14 @@
 
   (defun nreconc (x y)
     (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
-         (2nd x 1st) ; 2nd follows first down the list.
-         (3rd y 2nd)) ;3rd follows 2nd down the list.
+         (2nd x 1st)                ; 2nd follows first down the list.
+         (3rd y 2nd))               ;3rd follows 2nd down the list.
         ((atom 2nd) 3rd)
       (rplacd 2nd 3rd)))
 
   (defun notany (fn seq)
     (not (some fn seq)))
 
->>>>>>> backquote
 
   ;; Packages
 
@@ -962,7 +954,9 @@
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                ")"))
       ((arrayp form)
-       (concat "#" (prin1-to-string (vector-to-list form))))
+       (concat "#" (if (zerop (length form))
+                       "()"
+                       (prin1-to-string (vector-to-list form)))))
       ((packagep form)
        (concat "#<PACKAGE " (package-name form) ">"))))