Changeset 295


Ignore:
Timestamp:
Jan 14, 2004, 7:59:52 PM (21 years ago)
Author:
Gary Byers
Message:

Special-case (TRUNCATE MOST-NEGATIVE-FIXNUM x).

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/level-0/l0-numbers.lisp

    r287 r295  
    967967    (return-from truncate (truncate-no-rem number divisor)))
    968968  (macrolet
    969     ((truncate-rat-dfloat (number divisor)
    970        `(with-stack-double-floats ((fnum ,number)
    971                                       (f2))
    972          (let ((res (%unary-truncate (%double-float/-2! fnum ,divisor f2))))
    973            (values res
    974                    (%double-float--2 fnum (%double-float*-2! (%double-float res f2) ,divisor f2))))))
    975      (truncate-rat-sfloat (number divisor)
    976        `(with-stack-short-floats ((fnum ,number)
    977                                       (f2))
    978          (let ((res (%unary-truncate (%short-float/-2! fnum ,divisor f2))))
    979            (values res
    980                    (%short-float--2 fnum (%short-float*-2! (%short-float res f2) ,divisor f2)))))))           
    981   (number-case number
    982     (fixnum (number-case divisor
    983               (fixnum (if (eq divisor 1) (values number 0) (%fixnum-truncate number divisor)))
    984               (bignum (values 0 number))
    985               (double-float (truncate-rat-dfloat number divisor))
    986               (short-float (truncate-rat-sfloat number divisor))
    987               (ratio (let ((q (truncate (* number (%denominator divisor))  ; this was wrong
    988                                (%numerator divisor))))
    989                        (values q (- number (* q divisor)))))))
    990     (bignum (number-case divisor
    991              (fixnum (if (eq divisor 1) (values number 0)
    992                          (if (eq divisor most-negative-fixnum)  ;; << aargh
    993                            (with-small-bignum-buffers ((bd divisor))
    994                              (bignum-truncate number bd))
    995                            (bignum-truncate-by-fixnum number divisor))))
    996               (bignum (bignum-truncate number divisor))
    997               (double-float  (truncate-rat-dfloat number divisor))
    998               (short-float (truncate-rat-sfloat number divisor))
    999               (ratio (let ((q (truncate (* number (%denominator divisor))  ; so was this
    1000                                (%numerator divisor))))
    1001                        (values q (- number (* q divisor)))))))
    1002     (short-float (if (eql divisor 1)
    1003                    (let* ((res (%unary-truncate number)))
    1004                      (values res (- number res)))
    1005                    (number-case divisor
    1006                      (short-float
    1007                       (with-stack-short-floats ((f2))
    1008                          (let ((res (%unary-truncate (%short-float/-2! number divisor f2))))
    1009                            (values res
    1010                                    (%short-float--2
    1011                                     number
    1012                                     (%short-float*-2! (%short-float res f2) divisor f2))))))
    1013                      ((fixnum bignum ratio)
    1014                       (with-stack-short-floats ((fdiv divisor)
    1015                                                       (f2))
    1016                          (let ((res (%unary-truncate (%short-float/-2! number fdiv f2))))
    1017                            (values res
    1018                                    (%short-float--2
    1019                                     number
    1020                                     (%short-float*-2! (%short-float res f2) fdiv f2))))))
    1021                      (double-float
    1022                       (with-stack-double-floats ((fnum number)
     969      ((truncate-rat-dfloat (number divisor)
     970         `(with-stack-double-floats ((fnum ,number)
     971                                     (f2))
     972           (let ((res (%unary-truncate (%double-float/-2! fnum ,divisor f2))))
     973             (values res
     974                     (%double-float--2 fnum (%double-float*-2! (%double-float res f2) ,divisor f2))))))
     975       (truncate-rat-sfloat (number divisor)
     976         `(with-stack-short-floats ((fnum ,number)
     977                                    (f2))
     978           (let ((res (%unary-truncate (%short-float/-2! fnum ,divisor f2))))
     979             (values res
     980                     (%short-float--2 fnum (%short-float*-2! (%short-float res f2) ,divisor f2)))))))           
     981    (number-case number
     982      (fixnum
     983       (if (eql number most-negative-fixnum)
     984         (if (zerop divisor)
     985           (error 'division-by-zero :operation 'truncate :operands (list number divisor))
     986           (with-small-bignum-buffers ((bn number))
     987             (multiple-value-bind (quo rem) (truncate bn divisor)
     988               (if (eq quo bn)
     989                 (values number rem)
     990                 (values quo rem)))))
     991         (number-case divisor
     992           (fixnum (if (eq divisor 1) (values number 0) (%fixnum-truncate number divisor)))
     993           (bignum (values 0 number))
     994           (double-float (truncate-rat-dfloat number divisor))
     995           (short-float (truncate-rat-sfloat number divisor))
     996           (ratio (let ((q (truncate (* number (%denominator divisor)) ; this was wrong
     997                                     (%numerator divisor))))
     998                    (values q (- number (* q divisor))))))))
     999      (bignum (number-case divisor
     1000                (fixnum (if (eq divisor 1) (values number 0)
     1001                          (if (eq divisor most-negative-fixnum);; << aargh
     1002                            (with-small-bignum-buffers ((bd divisor))
     1003                              (bignum-truncate number bd))
     1004                            (bignum-truncate-by-fixnum number divisor))))
     1005                (bignum (bignum-truncate number divisor))
     1006                (double-float  (truncate-rat-dfloat number divisor))
     1007                (short-float (truncate-rat-sfloat number divisor))
     1008                (ratio (let ((q (truncate (* number (%denominator divisor)) ; so was this
     1009                                          (%numerator divisor))))
     1010                         (values q (- number (* q divisor)))))))
     1011      (short-float (if (eql divisor 1)
     1012                     (let* ((res (%unary-truncate number)))
     1013                       (values res (- number res)))
     1014                     (number-case divisor
     1015                       (short-float
     1016                        (with-stack-short-floats ((f2))
     1017                          (let ((res (%unary-truncate (%short-float/-2! number divisor f2))))
     1018                            (values res
     1019                                    (%short-float--2
     1020                                     number
     1021                                     (%short-float*-2! (%short-float res f2) divisor f2))))))
     1022                       ((fixnum bignum ratio)
     1023                        (with-stack-short-floats ((fdiv divisor)
     1024                                                  (f2))
     1025                          (let ((res (%unary-truncate (%short-float/-2! number fdiv f2))))
     1026                            (values res
     1027                                    (%short-float--2
     1028                                     number
     1029                                     (%short-float*-2! (%short-float res f2) fdiv f2))))))
     1030                       (double-float
     1031                        (with-stack-double-floats ((fnum number)
     1032                                                   (f2))
     1033                          (let* ((res (%unary-truncate (%double-float/-2! fnum divisor f2))))
     1034                            (values res
     1035                                    (%double-float--2
     1036                                     fnum
     1037                                     (%double-float*-2! (%double-float res f2) divisor f2)))))))))
     1038      (double-float (if (eql divisor 1)
     1039                      (let ((res (%unary-truncate number)))
     1040                        (values res (- number res)))
     1041                      (number-case divisor
     1042                        ((fixnum bignum ratio short-float)
     1043                         (with-stack-double-floats ((fdiv divisor)
    10231044                                                    (f2))
    1024                         (let* ((res (%unary-truncate (%double-float/-2! fnum divisor f2))))
    1025                           (values res
    1026                                   (%double-float--2
    1027                                    fnum
    1028                                    (%double-float*-2! (%double-float res f2) divisor f2)))))))))
    1029     (double-float (if (eql divisor 1)
    1030                     (let ((res (%unary-truncate number)))
    1031                          (values res (- number res)))
    1032                     (number-case divisor
    1033                       ((fixnum bignum ratio short-float)
    1034                        (with-stack-double-floats ((fdiv divisor)
    1035                                                       (f2))
    1036                          (let ((res (%unary-truncate (%double-float/-2! number fdiv f2))))
    1037                            (values res
    1038                                    (%double-float--2
    1039                                     number
    1040                                     (%double-float*-2! (%double-float res f2) fdiv f2))))))                       
    1041                       (double-float
    1042                        (with-stack-double-floats ((f2))
    1043                          (let ((res (%unary-truncate (%double-float/-2! number divisor f2))))
    1044                            (values res
    1045                                    (%double-float--2
    1046                                     number
    1047                                     (%double-float*-2! (%double-float res f2) divisor f2)))))))))
    1048     (ratio (number-case divisor
    1049                   (double-float (truncate-rat-dfloat number divisor))
    1050                   (short-float (truncate-rat-sfloat number divisor))
    1051                   (rational
    1052                    (let ((q (truncate (%numerator number)
    1053                                       (* (%denominator number) divisor))))
    1054                      (values q (- number (* q divisor))))))))))
     1045                           (let ((res (%unary-truncate (%double-float/-2! number fdiv f2))))
     1046                             (values res
     1047                                     (%double-float--2
     1048                                      number
     1049                                      (%double-float*-2! (%double-float res f2) fdiv f2))))))                       
     1050                        (double-float
     1051                         (with-stack-double-floats ((f2))
     1052                           (let ((res (%unary-truncate (%double-float/-2! number divisor f2))))
     1053                             (values res
     1054                                     (%double-float--2
     1055                                      number
     1056                                      (%double-float*-2! (%double-float res f2) divisor f2)))))))))
     1057      (ratio (number-case divisor
     1058               (double-float (truncate-rat-dfloat number divisor))
     1059               (short-float (truncate-rat-sfloat number divisor))
     1060               (rational
     1061                (let ((q (truncate (%numerator number)
     1062                                   (* (%denominator number) divisor))))
     1063                  (values q (- number (* q divisor))))))))))
    10551064
    10561065(defun truncate-no-rem (number  divisor)
    … …  
    10651074                                      (f2))
    10661075         (%unary-truncate (%short-float/-2! fnum ,divisor f2)))))
    1067   (number-case number
    1068     (fixnum (number-case divisor
    1069               (fixnum (if (eq divisor 1) number (values (%fixnum-truncate number divisor))))
    1070               (bignum 0)
    1071               (double-float (truncate-rat-dfloat number divisor))
    1072               (short-float (truncate-rat-sfloat number divisor))
    1073               (ratio (let ((q (truncate (* number (%denominator divisor))
    1074                                         (%numerator divisor))))
    1075                        q))))
    1076     (bignum (number-case divisor
    1077               (fixnum (if (eq divisor 1) number
    1078                           (if (eq divisor most-negative-fixnum)
    1079                             (with-small-bignum-buffers ((bd divisor))
    1080                               (bignum-truncate number bd :no-rem))
    1081                             (bignum-truncate-by-fixnum number divisor))))
    1082               (bignum (bignum-truncate number divisor :no-rem))
    1083               (double-float  (truncate-rat-dfloat number divisor))
    1084               (short-float (truncate-rat-sfloat number divisor))
    1085               (ratio (let ((q (truncate (* number (%denominator divisor))
    1086                                         (%numerator divisor))))
    1087                        Q))))
    1088     (double-float (if (eql divisor 1)
    1089                     (let ((res (%unary-truncate number)))
    1090                       RES)
    1091                     (number-case divisor
    1092                       ((fixnum bignum ratio)
    1093                        (with-stack-double-floats ((fdiv divisor)
    1094                                                       (f2))
    1095                          (let ((res (%unary-truncate (%double-float/-2! number fdiv f2))))
    1096                            RES)))
    1097                       (short-float
    1098                        (with-stack-double-floats ((ddiv divisor)
    1099                                                       (f2))
    1100                          (%unary-truncate (%double-float/-2! number ddiv f2))))
    1101                       (double-float
    1102                        (with-stack-double-floats ((f2))
    1103                          (%unary-truncate (%double-float/-2! number divisor f2)))))))
    1104     (short-float (if (eql divisor 1)
     1076    (number-case number
     1077    (fixnum
     1078     (if (eql number most-negative-fixnum)
     1079       (if (zerop divisor)
     1080         (error 'division-by-zero :operation 'truncate :operands (list number divisor))
     1081         (with-small-bignum-buffers ((bn number))
     1082           (let* ((result (truncate-no-rem bn divisor)))
     1083             (if (eq result bn)
     1084               number
     1085               result))))
     1086       (number-case divisor
     1087         (fixnum (if (eq divisor 1) number (values (%fixnum-truncate number divisor))))
     1088         (bignum 0)
     1089         (double-float (truncate-rat-dfloat number divisor))
     1090         (short-float (truncate-rat-sfloat number divisor))
     1091         (ratio (let ((q (truncate (* number (%denominator divisor))
     1092                                   (%numerator divisor))))
     1093                  q)))))
     1094     (bignum (number-case divisor
     1095               (fixnum (if (eq divisor 1) number
     1096                         (if (eq divisor most-negative-fixnum)
     1097                           (with-small-bignum-buffers ((bd divisor))
     1098                             (bignum-truncate number bd :no-rem))
     1099                           (bignum-truncate-by-fixnum number divisor))))
     1100               (bignum (bignum-truncate number divisor :no-rem))
     1101               (double-float  (truncate-rat-dfloat number divisor))
     1102               (short-float (truncate-rat-sfloat number divisor))
     1103               (ratio (let ((q (truncate (* number (%denominator divisor))
     1104                                         (%numerator divisor))))
     1105                        Q))))
     1106     (double-float (if (eql divisor 1)
     1107                     (let ((res (%unary-truncate number)))
     1108                       RES)
     1109                     (number-case divisor
     1110                       ((fixnum bignum ratio)
     1111                        (with-stack-double-floats ((fdiv divisor)
     1112                                                   (f2))
     1113                          (let ((res (%unary-truncate (%double-float/-2! number fdiv f2))))
     1114                            RES)))
     1115                       (short-float
     1116                        (with-stack-double-floats ((ddiv divisor)
     1117                                                   (f2))
     1118                          (%unary-truncate (%double-float/-2! number ddiv f2))))
     1119                       (double-float
     1120                        (with-stack-double-floats ((f2))
     1121                          (%unary-truncate (%double-float/-2! number divisor f2)))))))
     1122     (short-float (if (eql divisor 1)
    11051123                    (let ((res (%unary-truncate number)))
    11061124                      RES)
    … …  
    11081126                      ((fixnum bignum ratio)
    11091127                       (with-stack-short-floats ((fdiv divisor)
    1110                                                       (f2))
     1128                                                 (f2))
    11111129                         (let ((res (%unary-truncate (%short-float/-2! number fdiv f2))))
    11121130                           RES)))
Note: See TracChangeset for help on using the changeset viewer.