← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/runtime/division.scm

  • Committer: Package Import Robot
  • Author(s): Chris Hanson
  • Date: 2011-10-15 03:08:33 UTC
  • mfrom: (1.1.8) (3.1.7 sid)
  • Revision ID: package-import@ubuntu.com-20111015030833-x7qc6yxuulvxbafv
Tags: 9.1-1
* New upstream.
* debian/control, debian/copyright, debian/mit-scheme-doc.*,
  debian/mit-scheme.install, debian/rules, Upstream has removed cover
  texts from documentation licenses, so merge packages mit-scheme and
  mit-scheme-doc back together.
* debian/compat: Bump to current version.
* debian/control: Bump standards-version to current and make
  necessary changes.
* debian/rules: Fix lintian warnings.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/division.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
 
4
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
 
5
    2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
 
6
    Technology
 
7
 
 
8
This file is part of MIT/GNU Scheme.
 
9
 
 
10
MIT/GNU Scheme is free software; you can redistribute it and/or modify
 
11
it under the terms of the GNU General Public License as published by
 
12
the Free Software Foundation; either version 2 of the License, or (at
 
13
your option) any later version.
 
14
 
 
15
MIT/GNU Scheme is distributed in the hope that it will be useful, but
 
16
WITHOUT ANY WARRANTY; without even the implied warranty of
 
17
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
18
General Public License for more details.
 
19
 
 
20
You should have received a copy of the GNU General Public License
 
21
along with MIT/GNU Scheme; if not, write to the Free Software
 
22
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
 
23
USA.
 
24
 
 
25
|#
 
26
 
 
27
;;;; Integer Division
 
28
;;;; package: (runtime integer-division)
 
29
 
 
30
(declare (usual-integrations))
 
31
 
 
32
;;;; Ceiling
 
33
 
 
34
(define (ceiling/ n d)
 
35
  (if (and (exact-integer? n) (exact-integer? d))
 
36
      (cond ((and (negative? n) (negative? d))
 
37
             (ceiling-/- n d))
 
38
            ((negative? n)
 
39
             (let ((n (- 0 n)))
 
40
               (values (- 0 (quotient n d)) (- 0 (remainder n d)))))
 
41
            ((negative? d)
 
42
             (let ((d (- 0 d)))
 
43
               (values (- 0 (quotient n d)) (remainder n d))))
 
44
            (else
 
45
             (ceiling+/+ n d)))
 
46
      (let ((q (ceiling (/ n d))))
 
47
        (values q (- n (* d q))))))
 
48
 
 
49
(define (ceiling-/- n d)
 
50
  (let ((n (- 0 n)) (d (- 0 d)))
 
51
    (let ((q (quotient n d)) (r (remainder n d)))
 
52
      (if (zero? r)
 
53
          (values q r)
 
54
          (values (+ q 1) (- d r))))))
 
55
 
 
56
(define (ceiling+/+ n d)
 
57
  (let ((q (quotient n d)) (r (remainder n d)))
 
58
    (if (zero? r)
 
59
        (values q r)
 
60
        (values (+ q 1) (- r d)))))
 
61
 
 
62
(define (ceiling-quotient n d)
 
63
  (if (and (exact-integer? n) (exact-integer? d))
 
64
      (cond ((and (negative? n) (negative? d))
 
65
             (receive (q r) (ceiling-/- n d) r q))
 
66
            ((negative? n) (- 0 (quotient (- 0 n) d)))
 
67
            ((negative? d) (- 0 (quotient n (- 0 d))))
 
68
            (else (receive (q r) (ceiling+/+ n d) r q)))
 
69
      (ceiling (/ n d))))
 
70
 
 
71
(define (ceiling-remainder n d)
 
72
  (if (and (exact-integer? n) (exact-integer? d))
 
73
      (cond ((and (negative? n) (negative? d))
 
74
             (receive (q r) (ceiling-/- n d) q r))
 
75
            ((negative? n) (- 0 (remainder (- 0 n) d)))
 
76
            ((negative? d) (remainder n (- 0 d)))
 
77
            (else (receive (q r) (ceiling+/+ n d) q r)))
 
78
      (- n (* d (ceiling (/ n d))))))
 
79
 
 
80
;;;; Euclidean Division
 
81
 
 
82
;;; 0 <= r < |d|
 
83
 
 
84
(define (euclidean/ n d)
 
85
  (if (and (exact-integer? n) (exact-integer? d))
 
86
      (cond ((and (negative? n) (negative? d)) (ceiling-/- n d))
 
87
            ((negative? n) (floor-/+ n d))
 
88
            ((negative? d)
 
89
             (let ((d (- 0 d)))
 
90
               (values (- 0 (quotient n d)) (remainder n d))))
 
91
            (else (values (quotient n d) (remainder n d))))
 
92
      (let ((q (if (negative? d) (ceiling (/ n d)) (floor (/ n d)))))
 
93
        (values q (- n (* d q))))))
 
94
 
 
95
(define (euclidean-quotient n d)
 
96
  (if (and (exact-integer? n) (exact-integer? d))
 
97
      (cond ((and (negative? n) (negative? d))
 
98
             (receive (q r) (ceiling-/- n d) r q))
 
99
            ((negative? n) (receive (q r) (floor-/+ n d) r q))
 
100
            ((negative? d) (- 0 (quotient n (- 0 d))))
 
101
            (else (quotient n d)))
 
102
      (if (negative? d) (ceiling (/ n d)) (floor (/ n d)))))
 
103
 
 
104
(define (euclidean-remainder n d)
 
105
  (if (and (exact-integer? n) (exact-integer? d))
 
106
      (cond ((and (negative? n) (negative? d))
 
107
             (receive (q r) (ceiling-/- n d) q r))
 
108
            ((negative? n) (receive (q r) (floor-/+ n d) q r))
 
109
            ((negative? d) (remainder n (- 0 d)))
 
110
            (else (remainder n d)))
 
111
      (- n (* d (if (negative? d) (ceiling (/ n d)) (floor (/ n d)))))))
 
112
 
 
113
;;;; Floor
 
114
 
 
115
(define (floor/ n d)
 
116
  (if (and (exact-integer? n) (exact-integer? d))
 
117
      (cond ((and (negative? n) (negative? d))
 
118
             (let ((n (- 0 n)) (d (- 0 d)))
 
119
               (values (quotient n d) (- 0 (remainder n d)))))
 
120
            ((negative? n) (floor-/+ n d))
 
121
            ((negative? d) (floor+/- n d))
 
122
            (else (values (quotient n d) (remainder n d))))
 
123
      (let ((q (floor (/ n d))))
 
124
        (values q (- n (* d q))))))
 
125
 
 
126
(define (floor-/+ n d)
 
127
  (let ((n (- 0 n)))
 
128
    (let ((q (quotient n d)) (r (remainder n d)))
 
129
      (if (zero? r)
 
130
          (values (- 0 q) r)
 
131
          (values (- (- 0 q) 1) (- d r))))))
 
132
 
 
133
(define (floor+/- n d)
 
134
  (let ((d (- 0 d)))
 
135
    (let ((q (quotient n d)) (r (remainder n d)))
 
136
      (if (zero? r)
 
137
          (values (- 0 q) r)
 
138
          (values (- (- 0 q) 1) (- r d))))))
 
139
 
 
140
(define (floor-quotient n d)
 
141
  (if (and (exact-integer? n) (exact-integer? d))
 
142
      (cond ((and (negative? n) (negative? d)) (quotient (- 0 n) (- 0 d)))
 
143
            ((negative? n) (receive (q r) (floor-/+ n d) r q))
 
144
            ((negative? d) (receive (q r) (floor+/- n d) r q))
 
145
            (else (quotient n d)))
 
146
      (floor (/ n d))))
 
147
 
 
148
(define (floor-remainder n d)
 
149
  (if (and (exact-integer? n) (exact-integer? d))
 
150
      (cond ((and (negative? n) (negative? d))
 
151
             (- 0 (remainder (- 0 n) (- 0 d))))
 
152
            ((negative? n) (receive (q r) (floor-/+ n d) q r))
 
153
            ((negative? d) (receive (q r) (floor+/- n d) q r))
 
154
            (else (remainder n d)))
 
155
      (- n (* d (floor (/ n d))))))
 
156
 
 
157
;;;; Round Ties to Even
 
158
 
 
159
(define (round/ n d)
 
160
  (define (divide n d adjust leave)
 
161
    (let ((q (quotient n d)) (r (remainder n d)))
 
162
      (if (and (not (zero? r))
 
163
               (or (and (odd? q) (even? d) (divisible? n (quotient d 2)))
 
164
                   (< d (* 2 r))))
 
165
          (adjust (+ q 1) (- r d))
 
166
          (leave q r))))
 
167
  (if (and (exact-integer? n) (exact-integer? d))
 
168
      (cond ((and (negative? n) (negative? d))
 
169
             (divide (- 0 n) (- 0 d)
 
170
               (lambda (q r) (values q (- 0 r)))
 
171
               (lambda (q r) (values q (- 0 r)))))
 
172
            ((negative? n)
 
173
             (divide (- 0 n) d
 
174
               (lambda (q r) (values (- 0 q) (- 0 r)))
 
175
               (lambda (q r) (values (- 0 q) (- 0 r)))))
 
176
            ((negative? d)
 
177
             (divide n (- 0 d)
 
178
               (lambda (q r) (values (- 0 q) r))
 
179
               (lambda (q r) (values (- 0 q) r))))
 
180
            (else
 
181
             (let ((return (lambda (q r) (values q r))))
 
182
               (divide n d return return))))
 
183
      (let ((q (round (/ n d))))
 
184
        (values q (- n (* d q))))))
 
185
 
 
186
(define (divisible? n d)
 
187
  ;; This operation admits a faster implementation than the one given
 
188
  ;; here.
 
189
  (zero? (remainder n d)))
 
190
 
 
191
(define (round-quotient n d)
 
192
  (if (and (exact-integer? n) (exact-integer? d))
 
193
      (receive (q r) (round/ n d)
 
194
        r                               ;ignore
 
195
        q)
 
196
      (round (/ n d))))
 
197
 
 
198
(define (round-remainder n d)
 
199
  (if (and (exact-integer? n) (exact-integer? d))
 
200
      (receive (q r) (round/ n d)
 
201
        q                               ;ignore
 
202
        r)
 
203
      (- n (* d (round (/ n d))))))
 
204
 
 
205
;;;; Truncate
 
206
 
 
207
(define (truncate/ n d)
 
208
  (if (and (exact-integer? n) (exact-integer? d))
 
209
      (cond ((and (negative? n) (negative? d))
 
210
             (let ((n (- 0 n)) (d (- 0 d)))
 
211
               (values (quotient n d) (- 0 (remainder n d)))))
 
212
            ((negative? n)
 
213
             (let ((n (- 0 n)))
 
214
               (values (- 0 (quotient n d)) (- 0 (remainder n d)))))
 
215
            ((negative? d)
 
216
             (let ((d (- 0 d)))
 
217
               (values (- 0 (quotient n d)) (remainder n d))))
 
218
            (else
 
219
             (values (quotient n d) (remainder n d))))
 
220
      (let ((q (truncate (/ n d))))
 
221
        (values q (- n (* d q))))))
 
222
 
 
223
(define (truncate-quotient n d)
 
224
  (if (and (exact-integer? n) (exact-integer? d))
 
225
      (cond ((and (negative? n) (negative? d)) (quotient (- 0 n) (- 0 d)))
 
226
            ((negative? n) (- 0 (quotient (- 0 n) d)))
 
227
            ((negative? d) (- 0 (quotient n (- 0 d))))
 
228
            (else (quotient n d)))
 
229
      (truncate (/ n d))))
 
230
 
 
231
(define (truncate-remainder n d)
 
232
  (if (and (exact-integer? n) (exact-integer? d))
 
233
      (cond ((and (negative? n) (negative? d))
 
234
             (- 0 (remainder (- 0 n) (- 0 d))))
 
235
            ((negative? n) (- 0 (remainder (- 0 n) d)))
 
236
            ((negative? d) (remainder n (- 0 d)))
 
237
            (else (remainder n d)))
 
238
      (- n (* d (truncate (/ n d))))))
 
 
b'\\ No newline at end of file'