X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=19e6be9e874281e8c5c0963c4cd16805ded55b0c;hb=a572ab7de4266dec958d50612a8376df6bb45226;hp=3f02be24e69dc65c015e07684a9e45c011fe3ead;hpb=c45da820b56cd0bd4bd958b66639fa021054f962;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 3f02be2..19e6be9 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -1304,30 +1304,30 @@ the first."
 
 ;;;; GCD and LCM
 
-(defun gcd (&rest numbers)
+(defun gcd (&rest integers)
   #!+sb-doc
   "Return the greatest common divisor of the arguments, which must be
   integers. Gcd with no arguments is defined to be 0."
-  (cond ((null numbers) 0)
-        ((null (cdr numbers)) (abs (the integer (car numbers))))
+  (cond ((null integers) 0)
+        ((null (cdr integers)) (abs (the integer (car integers))))
         (t
-         (do ((gcd (the integer (car numbers))
+         (do ((gcd (the integer (car integers))
                    (gcd gcd (the integer (car rest))))
-              (rest (cdr numbers) (cdr rest)))
+              (rest (cdr integers) (cdr rest)))
              ((null rest) gcd)
            (declare (integer gcd)
                     (list rest))))))
 
-(defun lcm (&rest numbers)
+(defun lcm (&rest integers)
   #!+sb-doc
   "Return the least common multiple of one or more integers. LCM of no
   arguments is defined to be 1."
-  (cond ((null numbers) 1)
-        ((null (cdr numbers)) (abs (the integer (car numbers))))
+  (cond ((null integers) 1)
+        ((null (cdr integers)) (abs (the integer (car integers))))
         (t
-         (do ((lcm (the integer (car numbers))
+         (do ((lcm (the integer (car integers))
                    (lcm lcm (the integer (car rest))))
-              (rest (cdr numbers) (cdr rest)))
+              (rest (cdr integers) (cdr rest)))
              ((null rest) lcm)
            (declare (integer lcm) (list rest))))))
 
@@ -1340,6 +1340,10 @@ the first."
       ;; complicated way of writing the algorithm in the CLHS page for
       ;; LCM, and I don't know why.  To be investigated.  -- CSR,
       ;; 2003-09-11
+      ;;
+      ;;    It seems to me that this is written this way to avoid
+      ;;    unnecessary bignumification of intermediate results.
+      ;;        -- TCR, 2008-03-05
       (let ((m (abs m))
             (n (abs n)))
         (multiple-value-bind (max min)
@@ -1425,30 +1429,18 @@ the first."
 ;;;; modular functions
 #.
 (collect ((forms))
-  (flet ((definition (name lambda-list width pattern)
-           `(defun ,name ,lambda-list
-              (flet ((prepare-argument (x)
-                       (declare (integer x))
-                       (etypecase x
-                         ((unsigned-byte ,width) x)
-                         (fixnum (logand x ,pattern))
-                         (bignum (logand x ,pattern)))))
-                (,name ,@(loop for arg in lambda-list
-                               collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
-          ;; FIXME: We need to process only "toplevel" functions
-          when (listp infos)
-          do (loop for info in infos
-                   for name = (sb!c::modular-fun-info-name info)
-                   and width = (sb!c::modular-fun-info-width info)
-                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
-                   for pattern = (1- (ash 1 width))
-                   do (forms (definition name lambda-list width pattern)))))
-  `(progn ,@(forms)))
-
-#.
-(collect ((forms))
-  (flet ((definition (name lambda-list width)
+  (flet ((unsigned-definition (name lambda-list width)
+           (let ((pattern (1- (ash 1 width))))
+             `(defun ,name ,lambda-list
+               (flet ((prepare-argument (x)
+                        (declare (integer x))
+                        (etypecase x
+                          ((unsigned-byte ,width) x)
+                          (fixnum (logand x ,pattern))
+                          (bignum (logand x ,pattern)))))
+                 (,name ,@(loop for arg in lambda-list
+                                collect `(prepare-argument ,arg)))))))
+         (signed-definition (name lambda-list width)
            `(defun ,name ,lambda-list
               (flet ((prepare-argument (x)
                        (declare (integer x))
@@ -1458,14 +1450,22 @@ the first."
                          (bignum (sb!c::mask-signed-field ,width x)))))
                 (,name ,@(loop for arg in lambda-list
                                collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
-          ;; FIXME: We need to process only "toplevel" functions
-          when (listp infos)
-          do (loop for info in infos
-                   for name = (sb!c::modular-fun-info-name info)
-                   and width = (sb!c::modular-fun-info-width info)
-                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
-                   do (forms (definition name lambda-list width)))))
+    (flet ((do-mfuns (class)
+             (loop for infos being each hash-value of (sb!c::modular-class-funs class)
+                   ;; FIXME: We need to process only "toplevel" functions
+                   when (listp infos)
+                   do (loop for info in infos
+                            for name = (sb!c::modular-fun-info-name info)
+                            and width = (sb!c::modular-fun-info-width info)
+                            and signedp = (sb!c::modular-fun-info-signedp info)
+                            and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+                            if signedp
+                            do (forms (signed-definition name lambda-list width))
+                            else
+                            do (forms (unsigned-definition name lambda-list width))))))
+      (do-mfuns sb!c::*untagged-unsigned-modular-class*)
+      (do-mfuns sb!c::*untagged-signed-modular-class*)
+      (do-mfuns sb!c::*tagged-modular-class*)))
   `(progn ,@(forms)))
 
 ;;; KLUDGE: these out-of-line definitions can't use the modular