Changeset 2603 for branches

Timestamp:

2015-06-20T01:10:34-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/polynomial.lisp (modified) (2 diffs)

branches/f4grobner/polynomial.lisp

@@ -91 +91 @@
   self)
 
-(defun fast-add-to (p q order-fn)
-  "Fast destructive addition of termlists
-Note that this assumes the presence of a
-dummy header."
-  (macrolet ((lt (x) `(cadr ,x))
-             (lc (x) `(r-coeff (cadr ,x))))
-    (do ((p p)
-         (q q))
-        ((or (endp (cdr p)) (endp (cdr q)))
-         p)
-      (multiple-value-bind 
-            (greater-p equal-p)
-          (funcall order-fn (lt q) (lt p))
-        (cond
-          (greater-p
-           (rotatef (cdr p) (cdr q)))
-          (equal-p
-           (let ((s (add-to (lc p) (lc q))))
-             (if (r-zerop s)
-                 (setf (cdr p) (cddr p))
-                 (setf (lc p) s
-                       q (cdr q)))))))
-      (setf p (cdr p)))))
 
 (defmethod add-to ((self poly) (other poly))
@@ -120 +97 @@
 The result is stored in SELF. This implementation does
 no consing, entirely reusing the sells of SELF and OTHER."
-  (with-slots ((termlist1 termlist) (order1 order))
-      self
-    (with-slots ((termlist2 termlist) (order2 order))
-        other
-      ;; Ensure orders are compatible
-      (unless (eq order1 order2)
-        (setf termlist2 (sort termlist2 order1)
-              order2 order1))
-      ;; Create dummy head
-      (push nil termlist1)
-      (push nil termlist2)
-      (fast-add-to termlist1 termlist2 order1)
-      ;; Remove dummy head
-      (pop termlist1)))
+  (flet ((fast-add-to (p q order-fn)
+           ;; Fast destructive addition of termlists Note that this
+           ;; assumes the presence of a dummy header."
+           (macrolet ((lt (x) `(cadr ,x))
+                      (lc (x) `(r-coeff (cadr ,x))))
+             (do ((p p)
+                  (q q))
+                 ((or (endp (cdr p)) (endp (cdr q)))
+                  p)
+               (multiple-value-bind 
+                     (greater-p equal-p)
+                   (funcall order-fn (lt q) (lt p))
+                 (cond
+                   (greater-p
+                    (rotatef (cdr p) (cdr q)))
+                   (equal-p
+                    (let ((s (add-to (lc p) (lc q))))
+                      (if (r-zerop s)
+                          (setf (cdr p) (cddr p))
+                          (setf (lc p) s
+                                q (cdr q)))))))
+               (setf p (cdr p))))))
+    (with-slots ((termlist1 termlist) (order1 order))
+        self
+      (with-slots ((termlist2 termlist) (order2 order))
+          other
+        ;; Ensure orders are compatible
+        (unless (eq order1 order2)
+          (setf termlist2 (sort termlist2 order1)
+                order2 order1))
+        ;; Create dummy head
+        (push nil termlist1)
+        (push nil termlist2)
+        (fast-add-to termlist1 termlist2 order1)
+        ;; Remove dummy head
+        (pop termlist1))))
   self)