Changeset 935

Timestamp:

2015-06-09T19:12:13-07:00 (10 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/termlist.lisp (modified) (1 diff)

branches/f4grobner/termlist.lisp

@@ -132 +132 @@
           f))
 
-(defun termlist-add (ring p q)
+(defun termlist-add (ring-and-order p q 
+                     &aux 
+                       (ring (ro-ring ring-and-order))
+                       (order (ro-order ring-and-order)))
+  (declare (type list p q) (ring-and-order ring-and-order))
+  (do (r)
+      ((cond
+         ((endp p)
+          (setf r (revappend r q)) t)
+         ((endp q)
+          (setf r (revappend r p)) t)
+         (t
+          (multiple-value-bind
+                (lm-greater lm-equal)
+              (funcall order (termlist-lm p) (termlist-lm q))
+            (cond
+              (lm-equal
+               (let ((s (funcall (ring-add ring) (termlist-lc p) (termlist-lc q))))
+                 (unless (funcall (ring-zerop ring) s) ;check for cancellation
+                   (setf r (cons (make-term (termlist-lm p) s) r)))
+                 (setf p (cdr p) q (cdr q))))
+              (lm-greater
+               (setf r (cons (car p) r)
+                     p (cdr p)))
+              (t (setf r (cons (car q) r)
+                       q (cdr q)))))
+          nil))
+       r)))
+
+(defun termlist-sub (ring p q
+                     &aux 
+                       (ring (ro-ring ring-and-order))
+                       (order (ro-order ring-and-order)))
   (declare (type list p q) (ring-and-order ring))
   (do (r)
       ((cond
-        ((endp p)
-         (setf r (revappend r q)) t)
-        ((endp q)
-         (setf r (revappend r p)) t)
-        (t
-         (multiple-value-bind
-             (lm-greater lm-equal)
-             (funcall (ring-and-order-order ring) (termlist-lm p) (termlist-lm q))
-           (cond
-            (lm-equal
-             (let ((s (funcall (ring-add ring) (termlist-lc p) (termlist-lc q))))
-               (unless (funcall (ring-zerop ring) s)    ;check for cancellation
-                 (setf r (cons (make-term (termlist-lm p) s) r)))
-               (setf p (cdr p) q (cdr q))))
-            (lm-greater
-             (setf r (cons (car p) r)
-                   p (cdr p)))
-            (t (setf r (cons (car q) r)
-                     q (cdr q)))))
-         nil))
-       r)))
-
-(defun termlist-sub (ring p q)
-  (declare (type list p q) (ring-and-order ring))
-  (do (r)
-      ((cond
-        ((endp p)
-         (setf r (revappend r (termlist-uminus ring q)))
-         t)
-        ((endp q)
-         (setf r (revappend r p))
-         t)
-        (t
-         (multiple-value-bind
-             (mgreater mequal)
-             (funcall (ring-and-order-order ring) (termlist-lm p) (termlist-lm q))
-           (cond
-            (mequal
-             (let ((s (funcall (ring-sub ring) (termlist-lc p) (termlist-lc q))))
-               (unless (funcall (ring-zerop ring) s)    ;check for cancellation
-                 (setf r (cons (make-term (termlist-lm p) s) r)))
-               (setf p (cdr p) q (cdr q))))
-            (mgreater
-             (setf r (cons (car p) r)
-                   p (cdr p)))
-            (t (setf r (cons (make-term (termlist-lm q)
-                                        (funcall (ring-uminus ring) (termlist-lc q))) r)
-                     q (cdr q)))))
-         nil))
+         ((endp p)
+          (setf r (revappend r (termlist-uminus ring q)))
+          t)
+         ((endp q)
+          (setf r (revappend r p))
+          t)
+         (t
+          (multiple-value-bind
+                (mgreater mequal)
+              (funcall order (termlist-lm p) (termlist-lm q))
+            (cond
+              (mequal
+               (let ((s (funcall (ring-sub ring) (termlist-lc p) (termlist-lc q))))
+                 (unless (funcall (ring-zerop ring) s) ;check for cancellation
+                   (setf r (cons (make-term (termlist-lm p) s) r)))
+                 (setf p (cdr p) q (cdr q))))
+              (mgreater
+               (setf r (cons (car p) r)
+                     p (cdr p)))
+              (t (setf r (cons (make-term (termlist-lm q)
+                                          (funcall (ring-uminus ring) (termlist-lc q))) r)
+                       q (cdr q)))))
+          nil))
        r)))