Changeset 13606 in project
- Timestamp:
- 03/09/09 04:25:02 (11 years ago)
- Location:
- release/4/err5rs-arithmetic/trunk
- Files:
-
- 4 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm
r13604 r13606 20 20 ##sys#string-append ) ) 21 21 22 ;; 23 22 24 (require-library srfi-1 int-limits) 23 25 24 26 (include "chicken-primitive-object-inlines") 27 28 ;TODO - add to chicken-primitive-object-inline 29 30 (define-inline (%number? x) (##core#inline "C_i_numberp" x)) 31 32 (define-inline (%zero? n) (##core#inline "C_i_zerop" n)) 33 34 (define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d)) 35 36 (define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x)) 37 (define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y)) 38 (define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y)) 39 40 (define-inline (%negative? x) (##core#inline "C_i_negativep" x)) 41 42 ;; 25 43 26 44 #> … … 271 289 ;; 272 290 273 (define-inline (%boolean->bit b) (if b 1 0)) 274 275 (define-inline (%boolean->bit* bit) (if (zero? bit) 0 (%boolean->bit bit))) 276 277 (define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d)) 278 279 (define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x)) 280 281 (define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y)) 282 283 (define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y)) 284 285 (define-inline (%negative? x) (##core#inline "C_i_negativep" x)) 291 (define-inline (%boolean->bit obj) (if obj 1 0)) 292 293 (define-inline (%boolean->bit* obj) 294 (if (and (%number obj) (%zero? obj)) 0 295 (%boolean->bit obj) ) ) 286 296 287 297 … … 403 413 (let ((zeros (make-list machine-word-bits #f))) 404 414 (lambda (n #!optional bitlen) 405 (if ( zero? n)415 (if (%zero? n) 406 416 (if bitlen (take zeros bitlen) zeros) 407 417 (let ((bitlen (or bitlen (*bitwise-length n)))) … … 527 537 (%check-non-negative-fixnum 'bitwise-integer->list bitlen) 528 538 (%check-word-bits 'bitwise-integer->list bitlen) ) 529 ( bitwise-integer->list value bitlen) )539 (*bitwise-integer->list value bitlen) ) 530 540 531 541 (define (bitwise-arithmetic-shift value signed-count) -
release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm
r13604 r13606 18 18 ##sys#string-append ) ) 19 19 20 ;; 21 20 22 (require-library err5rs-arithmetic-bitwise) 21 23 22 24 (include "chicken-primitive-object-inlines") 23 25 24 25 ;;; 26 ;TODO - add to chicken-primitive-object-inline 27 28 (define-inline (%< x y) ((##core#primitive "C_lessp") x y)) 29 (define-inline (%<= x y) ((##core#primitive "C_less_or_equal_p") x y)) 30 (define-inline (%> x y) ((##core#primitive "C_greaterp") x y)) 31 (define-inline (%>= x y) ((##core#primitive "C_greater_or_equal_p") x y)) 32 33 (define-inline (%+ x y) ((##core#primitive "C_plus") x y)) 34 (define-inline (%- x y) ((##core#primitive "C_minus") x y)) 35 (define-inline (%* x y) ((##core#primitive "C_times") x y)) 36 (define-inline (%/ x y) ((##core#primitive "C_divide") x y)) 37 38 (define-inline (%quotient x y) ((##core#primitive "C_quotient") x y)) 39 40 (define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d)) 41 42 ;; 26 43 27 44 (define-inline (%fixnum-zero-division-error loc fx1 fx2) … … 56 73 57 74 ;; 75 76 ;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func). 58 77 59 78 (define-inline (%fxfold-1 loc func init lyst) … … 71 90 (let ((cur (%car ls))) 72 91 (%check-fixnum loc cur) 73 (and (func acc (%car ls)) 74 (loop (%cdr ls) (%car ls)) ) ) ) ) ) 75 76 ;; 77 78 (define-inline (%< x y) ((##core#primitive "C_lessp") x y)) 79 80 (define-inline (%<= x y) ((##core#primitive "C_less_or_equal_p") x y)) 81 82 (define-inline (%> x y) ((##core#primitive "C_greaterp") x y)) 83 84 (define-inline (%>= x y) ((##core#primitive "C_greater_or_equal_p") x y)) 85 86 (define-inline (%+ x y) ((##core#primitive "C_plus") x y)) 87 88 (define-inline (%- x y) ((##core#primitive "C_minus") x y)) 89 90 (define-inline (%* x y) ((##core#primitive "C_times") x y)) 91 92 (define-inline (%quotient x y) ((##core#primitive "C_quotient") x y)) 93 94 (define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d)) 92 (and (func acc cur) 93 (loop (%cdr ls) cur) ) ) ) ) ) 95 94 96 95 ;; … … 191 190 192 191 (define (*fx= x y) (%fx= x y)) 193 194 192 (define (*fx< x y) (%fx< x y)) 195 196 193 (define (*fx> x y) (%fx> x y)) 197 198 194 (define (*fx>= x y) (%fx>= x y)) 199 200 195 (define (*fx<= x y) (%fx<= x y)) 201 202 196 (define (*fxmax x y) (%fxmax x y)) 203 204 197 (define (*fxmin x y) (%fxmin x y)) 205 206 198 (define (*fxand x y) (%fxand x y)) 207 208 199 (define (*fxior x y) (%fxor x y)) 209 210 200 (define (*fxxor x y) (%fxxor x y)) 211 212 201 (define (*fx+ x y) (%fx+ x y)) 213 214 202 (define (*fx- x y) (%fx- x y)) 215 216 203 (define (*fx* x y) (%fx* x y)) 217 218 204 (define (*fx/ x y) (%fx/ x y)) 219 205 -
release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm
r13604 r13606 1 ;;;; flonum-extras.scm1 ;;;; err5rs-arithmetic-flonums.scm 2 2 ;;;; Kon Lovett, Mar '09 3 3 … … 7 7 (declare 8 8 (usual-integrations) 9 (generic)10 9 (disable-interrupts) 10 (arithmetic-type generic) 11 (inline) 12 #;(local) 11 13 (no-bound-checks) 12 (no-procedure-checks -for-usual-bindings)14 (no-procedure-checks) 13 15 (bound-to-procedure 14 ##sys#signal-hook 16 ##sys#check-exact 17 ##sys#check-inexact 15 18 ##sys#check-integer 16 ##sys#flonum-fraction 17 ##sys#floor 18 ##sys#ceiling 19 ##sys#exact->inexact ) 20 (export 21 ; Checked 22 real->flonum 23 fixnum->flonum 24 fl=? 25 fl<? 26 fl>? 27 fl<=? 28 fl>=? 29 flcompare 30 flinteger? 31 flzero? 32 flpositive? 33 flnegative? 34 flodd? 35 fleven? 36 flfinite? 37 flinfinite? 38 flnan? 39 fl+ 40 fl* 41 fl- 42 fl/ 43 flmax 44 flmin 45 flmax-and-min 46 flabs 47 flfraction 48 flfloor 49 flceiling 50 flround 51 fltruncate 52 fldiv 53 flmod 54 fldiv-and-mod 55 fldiv0 56 flmod0 57 fldiv0-and-mod0 58 flexp 59 fllog 60 flsin 61 flcos 62 fltan 63 flasin 64 flacos 65 flatan 66 flsqrt 67 flexpt 68 flnumerator 69 fldenominator 70 ; Unchecked 71 %fp= 72 %fp< 73 %fp> 74 %fp>= 75 %fp<= 76 %fpmax 77 %fpmin 78 %fp+ 79 %fp- 80 %fp* 81 %fp/ 82 ) ) 83 84 (require-library mathh) 19 ##sys#check-number 20 ##sys#signal-hook ) ) 21 22 ;; 23 24 (require-library srfi-1 mathh) 85 25 86 26 (include "chicken-primitive-object-inlines") 87 27 28 ;TODO - add to chicken-primitive-object-inline 29 30 (define-inline (%< x y) ((##core#primitive "C_lessp") x y)) 31 32 (define-inline (%finite? x) (##core#inline "C_i_finitep" x)) 33 34 (define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y)) 35 (define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y)) 36 (define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y)) 37 (define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y)) 38 (define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y)) 39 40 (define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y)) 41 (define-inline (%fpmax x y) (##core#inline "C_i_flonum_min" x y)) 42 43 (define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x)) 44 (define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x)) 45 (define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x)) 46 (define-inline (%fpround x) ((##core#primitive "C_flonum_round") x)) 47 48 (define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x)) 49 50 (define-inline (%fpneg x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y)) 51 52 (define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)) 53 (define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)) 54 (define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)) 55 (define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)) 56 57 (define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x)) 58 (define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x)) 59 (define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x)) 60 (define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x)) 61 (define-inline (%fpatan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x)) 62 (define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x)) 63 (define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x)) 64 (define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x)) 65 (define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x)) 66 (define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x)) 67 (define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x)) 68 69 (define-inline (%expt x y) ((##core#primitive "C_expt") x y)) 70 71 (define-inline (%integer? x) (##core#inline "C_i_integerp" x)) 72 73 (define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x)) 74 75 ;; 76 77 (define-inline (%check-fixnum loc obj) (##sys#check-exact obj loc)) 78 79 (define-inline (%check-flonum loc obj) (##sys#check-inexact obj loc)) 80 81 (define-inline (%check-non-negative-integer loc obj) 82 (##sys#check-integer obj loc) 83 (unless (%< 0 obj) 84 (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) ) 85 86 (define-inline (%check-number loc obj) (##sys#check-number obj loc)) 87 88 ;; 89 90 ;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func). 91 92 (define-inline (%fpfold-1 loc func init lyst) 93 (%check-flonum loc init) 94 (let loop ([ls lyst] [acc init]) 95 (if (%null? ls) acc 96 (let ([cur (%car ls)]) 97 (%check-flonum loc cur) 98 (loop (%cdr ls) (func acc cur)) ) ) ) ) 99 100 (define-inline (%fpand-fold-1 loc func init lyst) 101 (%check-flonum loc init) 102 (let loop ([ls lyst] [acc init]) 103 (or (%null? ls) 104 (let ([cur (%car ls)]) 105 (%check-flonum loc cur) 106 (and (func acc cur) 107 (loop (%cdr ls) cur) ) ) ) ) ) 108 109 ;; 110 111 (define-inline (%fpquotient fpn fpd) (%fptruncate (%fp/ fpn fpd))) 112 113 (define-inline (%fpremainder fpn fpd) (%fp- fpn (%fp* (%fpquotient fpn fpd) fpd))) 114 115 (define-inline (%fpquotient-and-remainder fpn fpd) 116 (let ([quo (%fpquotient fpn fpd)]) 117 (values quo (%fp- fpn (%fp* quo fpd))) ) ) 118 119 (define-inline (%fpinteger? fp) (%integer? x)) 120 121 (define-inline (%fpnan? fp) (not (%fp= fp fp))) 122 123 (define-inline (%fp=? x y) (%fp= x y)) 124 125 (define-inline (%fp<? x y) (or (and (%fp= -0.0 x) (%fp= 0.0 y)) (%fp< x y))) 126 127 (define-inline (%fp<=? x y) (or (and (%fp= -0.0 x) (%fp= 0.0 y)) (%fp<= x y))) 128 129 (define-inline (%fp>? x y) (or (and (%fp= 0.0 x) (%fp= -0.0 y)) (%fp> x y))) 130 131 (define-inline (%fp>=? x y) (or (and (%fp= 0.0 x) (%fp= -0.0 y)) (%fp>= x y))) 132 133 (define-inline (%fpdiv0-and-mod0 fpn fpd) 134 (let-values ([(quo rem) (%fpquotient-and-remainder fpn fpd)]) 135 (cond [(%fp>=? fpd 0.0) 136 (if (%fp<? 137 rem 138 (%fp/ fpd 2.0)) 139 (if (%fp>=? 140 rem 141 (%fp/ fpd -2.0)) 142 (values quo rem) 143 (values (%fp- quo 1.0) 144 (%fp+ rem fpd)) ) 145 (values (%fp+ quo 1.0) 146 (%fp- rem fpd)) ) ] 147 [(%fp<? 148 rem 149 (%fp/ fpd -2.0)) 150 (if (%fp>=? 151 rem 152 (%fp/ fpd 2.0)) 153 (values quo rem) 154 (values (%fp+ quo 1.0) 155 (%fp- rem fpd)) ) ] 156 [else 157 (values (%fp- quo 1.0) 158 (%fp+ rem fpd)) ] ) ) ) 159 160 (define-inline (%fpdiv0 fpn fpd) 161 (let-values ([(quo rem) (%fpquotient-and-remainder fpn fpd)]) 162 (cond [(%fp>=? fpd 0.0) 163 (if (%fp<? 164 rem 165 (%fp/ fpd 2.0)) 166 (if (%fp>=? 167 rem 168 (%fp/ fpd -2.0)) 169 quo 170 (%fp- quo 1.0) ) 171 (%fp+ quo 1.0) ) ] 172 [(%fp<? 173 rem 174 (%fp/ fpd -2.0)) 175 (if (%fp>=? 176 rem 177 (%fp/ fpd 2.0)) 178 quo 179 (%fp+ quo 1.0) ) ] 180 [else 181 (%fp- quo 1.0) ] ) ) ) 182 183 (define-inline (%fpmod0 fpn fpd) 184 (let ([rem (%fpremainder fpn fpd)]) 185 (cond [(%fp>=? fpd 0.0) 186 (if (%fp<? 187 rem 188 (%fp/ fpd 2.0)) 189 (if (%fp>=? 190 rem 191 (%fp/ fpd -2.0)) 192 rem 193 (%fp+ rem fpd) ) 194 (%fp- rem fpd) ) ] 195 [(%fp<? 196 rem 197 (%fp/ fpd -2.0)) 198 (if (%fp>=? 199 rem 200 (%fp/ fpd 2.0)) 201 rem 202 (%fp- rem fpd) )] 203 [else 204 (%fp+ rem fpd) ] ) ) ) 205 206 88 207 ;;; 89 208 90 (define (check-flonum loc obj) 91 (unless (##core#inline "C_i_flonump" obj) 92 (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) ) ) 93 94 (define (check-non-negative-integer loc obj) 95 (##sys#check-integer obj loc) 96 (unless ((##core#primitive "C_lessp") 0 obj) 97 (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) ) 209 (module err5rs-arithmetic-bitwise (;export 210 ; ERR5RS 211 real->flonum fixnum->flonum 212 fl=? fl<? fl>? fl<=? fl>=? flcompare 213 flinteger? 214 flzero? flpositive? flnegative? flodd? fleven? 215 flfinite? flinfinite? flnan? 216 fl+ fl* fl- fl/ 217 flmax flmin flmax-and-min 218 flabs 219 flfraction 220 flfloor flceiling flround fltruncate 221 fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0 222 flexp fllog flsin flcos fltan flasin flacos flatan flsqrt flexpt 223 flnumerator fldenominator) 224 225 (import scheme chicken foreign srfi-1 mathh) 226 227 228 ;;; Procedures wrapping primitive-inlines for fold operations 229 230 (define (*fp=? x y) (%fp=? x y)) 231 (define (*fp<? x y) (%fp<? x y)) 232 (define (*fp>? x y) (%fp>? x y)) 233 (define (*fp<=? x y) (%fp<=? x y)) 234 (define (*fp>=? x y) (%fp>=? x y)) 235 (define (*fpmax x y) (%fpmax x y)) 236 (define (*fpmin x y) (%fpmin x y)) 237 (define (*fp- x y) (%fp- x y)) 238 (define (*fp+ x y) (%fp+ x y)) 239 (define (*fp* x y) (%fp* x y)) 240 (define (*fp/ x y) (%fp/ x y)) 241 98 242 99 243 ;;; 100 244 101 (define-inline (%fold1 loc func init lyst) 102 (check-flonum loc init) 103 (let loop ([acc init] [lyst lyst]) 104 (if (null? lyst) 105 acc 106 (let ([cur (car lyst)]) 107 (check-flonum loc cur) 108 (loop (func acc cur) (cdr lyst)) ) ) ) ) 109 110 (define-inline (%and-fold1 loc func init lyst) 111 (check-flonum loc init) 112 (let loop ([prv init] [lyst lyst]) 113 (or (null? lyst) 114 (let ([cur (car lyst)]) 115 (check-flonum loc cur) 116 (and (func prv cur) 117 (loop cur (cdr lyst)) ) ) ) ) ) 245 (define (real->flonum value) 246 (if (%flonum? value) value 247 (begin 248 (%check-number 'real->flonum value) 249 (%exact->inexact value) ) ) ) 250 251 (define (fixnum->flonum fx) 252 (%check-fixnum 'fixnum->flonum fx) 253 (%exact->inexact fx) ) 254 118 255 119 256 ;;; 120 257 121 (define %fpfrac ##sys#flonum-fraction) 122 123 (define %fptrunc ##sys#truncate) 124 125 (define %fpfloor ##sys#floor) 126 127 (define %fpceil ##sys#ceiling) 128 129 (define-inline (%fprnd fp) 130 (if (##core#inline "C_flonum_equalp" 0.0 fp) 131 0.0 132 (%fptrunc (##core#inline_allocate ("C_a_i_flonum_plus" 4) 133 fp 134 (if (##core#inline "C_flonum_lessp" 0.0 fp) 0.5 -0.5))) ) ) 135 136 (define-inline (%fpquo fpn fpd) 137 (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd)) ) 138 139 (define-inline (%fprem fpn fpd) 140 (##core#inline_allocate ("C_a_i_flonum_difference" 4) 141 fpn 142 (##core#inline_allocate ("C_a_i_flonum_times" 4) 143 (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd)) 144 fpd)) ) 145 146 (define-inline (%fpquo-and-rem fpn fpd) 147 (let ([quo (%fpquo fpn fpd)]) 148 (values quo 149 (##core#inline_allocate ("C_a_i_flonum_difference" 4) 150 fpn 151 (##core#inline_allocate ("C_a_i_flonum_times" 4) quo fpd))) ) ) 152 153 (define-inline (%fpinteger? fp) 154 (##core#inline "C_flonum_equalp" 0.0 (%fpfrac fp)) ) 155 156 (define-inline (%fpnan? fp) 157 (not (##core#inline "C_flonum_equalp" fp fp)) ) 158 159 (define (%fp= x y) 160 (##core#inline "C_flonum_equalp" x y) ) 161 162 (define (%fp< x y) 163 (or (and (##core#inline "C_flonum_equalp" -0.0 x) 164 (##core#inline "C_flonum_equalp" 0.0 y)) 165 (##core#inline "C_flonum_lessp" x y) ) ) 166 167 (define (%fp<= x y) 168 (or (and (##core#inline "C_flonum_equalp" -0.0 x) 169 (##core#inline "C_flonum_equalp" 0.0 y)) 170 (##core#inline "C_flonum_less_or_equal_p" x y) ) ) 171 172 (define (%fp> x y) 173 (or (and (##core#inline "C_flonum_equalp" 0.0 x) 174 (##core#inline "C_flonum_equalp" -0.0 y)) 175 (##core#inline "C_flonum_greaterp" x y) ) ) 176 177 (define (%fp>= x y) 178 (or (and (##core#inline "C_flonum_equalp" 0.0 x) 179 (##core#inline "C_flonum_equalp" -0.0 y)) 180 (##core#inline "C_flonum_greater_or_equal_p" x y) ) ) 181 182 (define (%fpmax x y) 183 (##core#inline "C_i_flonum_max" x y) ) 184 185 (define (%fpmin x y) 186 (##core#inline "C_i_flonum_min" x y) ) 187 188 (define (%fp+ x y) 189 (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) ) 190 191 (define (%fp- x y) 192 (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) ) 193 194 (define (%fp* x y) 195 (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) ) 196 197 (define (%fp/ x y) 198 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) ) 199 200 (define-inline (%fpdiv0-and-mod0 fpn fpd) 201 (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)]) 202 (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0) 203 (if (##core#inline "C_flonum_lessp" 204 rem 205 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0)) 206 (if (##core#inline "C_flonum_greater_or_equal_p" 207 rem 208 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0)) 209 (values quo rem) 210 (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) 211 (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) ) 212 (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) 213 (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ] 214 [(##core#inline "C_flonum_lessp" 215 rem 216 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0)) 217 (if (##core#inline "C_flonum_greater_or_equal_p" 218 rem 219 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0)) 220 (values quo rem) 221 (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) 222 (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ] 223 [else 224 (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) 225 (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) ] ) ) ) 226 227 (define-inline (%fpdiv0 fpn fpd) 228 (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)]) 229 (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0) 230 (if (##core#inline "C_flonum_lessp" 231 rem 232 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0)) 233 (if (##core#inline "C_flonum_greater_or_equal_p" 234 rem 235 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0)) 236 quo 237 (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) ) 238 (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ] 239 [(##core#inline "C_flonum_lessp" 240 rem 241 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0)) 242 (if (##core#inline "C_flonum_greater_or_equal_p" 243 rem 244 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0)) 245 quo 246 (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ] 247 [else 248 (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) ] ) ) ) 249 250 (define-inline (%fpmod0 fpn fpd) 251 (let ([rem (%fprem fpn fpd)]) 252 (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0) 253 (if (##core#inline "C_flonum_lessp" 254 rem 255 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0)) 256 (if (##core#inline "C_flonum_greater_or_equal_p" 257 rem 258 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0)) 259 rem 260 (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) ) 261 (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) ) ] 262 [(##core#inline "C_flonum_lessp" 263 rem 264 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0)) 265 (if (##core#inline "C_flonum_greater_or_equal_p" 266 rem 267 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0)) 268 rem 269 (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) )] 270 [else 271 (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) ] ) ) ) 258 (define (fl=? fl . fls) 259 (%fpand-fold-1 'fl=? *fp=? fl fls) ) 260 261 (define (fl<? fl . fls) 262 (%fpand-fold-1 'fl<? *fp<? fl fls) ) 263 264 (define (fl>? fl . fls) 265 (%fpand-fold-1 'fl>? *fp>? fl fls) ) 266 267 (define (fl<=? fl . fls) 268 (%fpand-fold-1 'fl<=? *fp<=? fl fls) ) 269 270 (define (fl>=? fl . fls) 271 (%fpand-fold-1 'fl>=? *fp>=? fl fls) ) 272 273 (define (flcompare fl1 fl2) 274 (%check-flonum 'flcompare fl1) 275 (%check-flonum 'flcompare fl2) 276 (cond [(%fp=? fl1 fl2) 277 (cond [(%fp=? -0.0 fl1) (if (%fp=? -0.0 fl1) 0 1)] 278 [(%fp=? -0.0 fl2) (if (%fp=? 0.0 fl1) -1 0)] 279 [else 0])] 280 [(%fp<? fl1 fl2) 281 -1] 282 [else 283 1 ] ) ) 284 285 (define (flmax fl . fls) 286 (%fpfold-1 'flmax *fpmax fl fls) ) 287 288 (define (flmin fl . fls) 289 (%fpfold-1 'flmin *fpmin fl fls) ) 290 291 (define (flmax-and-min fl . fls) 292 (%check-flonum 'flmax-and-min fl) 293 (let loop ([ls fls] [mx fl] [mn fl]) 294 (if (%null? ls) (values mx mn) 295 (let ([cur (%car ls)]) 296 (%check-flonum 'flmax-and-min cur) 297 (loop (%cdr ls) (%fpmax mx cur) (%fpmin mn cur)) ) ) ) ) 298 272 299 273 300 ;;; 274 301 275 (define (real->flonum value) 276 (if (##core#inline "C_i_flonump" value) 277 value 278 (##sys#exact->inexact value) ) ) 279 280 (define (fixnum->flonum fx) 281 (if (##core#inline "C_fixnump" fx) 282 (##sys#exact->inexact fx) 283 (##sys#signal-hook #:type-error 'fixnum->flonum 284 "bad argument type - not a fixnum" fx) ) ) 302 (define (flinteger? fl) 303 (%check-flonum 'flinteger? fl) 304 (%fpinteger? fl) ) 305 306 (define (flzero? fl) 307 (%check-flonum 'flzero? fl) 308 (%fp=? 0.0 fl) ) 309 310 (define (flpositive? fl) 311 (%check-flonum 'flpositive? fl) 312 (%fp<? 0.0 fl) ) 313 314 (define (flnegative? fl) 315 (%check-flonum 'flnegative? fl) 316 (or (%fp=? -0.0 fl) 317 (%fp<? fl 0.0) ) ) 318 319 (define (flodd? fl) 320 (%check-flonum 'flodd? fl) 321 (not (%fp=? 0.0 (fpmod fl 2.0))) ) 322 323 (define (fleven? fl) 324 (%check-flonum 'fleven? fl) 325 (%fp=? 0.0 (fpmod fl 2.0)) ) 326 327 (define (flfinite? fl) 328 (%check-flonum 'flfinite? fl) 329 (%finite? fl) ) 330 331 (define (flinfinite? fl) 332 (%check-flonum 'flinfinite? fl) 333 (not (%finite? fl)) ) 334 335 (define (flnan? fl) 336 (%check-flonum 'flnan? fl) 337 (%fpnan? fl) ) 338 285 339 286 340 ;;; 287 341 288 (define (fl=? fl . rest) 289 (%and-fold1 'fl=? %fp= fl rest) ) 290 291 (define (fl<? fl . rest) 292 (%and-fold1 'fl<? %fp< fl rest) ) 293 294 (define (fl>? fl . rest) 295 (%and-fold1 'fl>? %fp> fl rest) ) 296 297 (define (fl<=? fl . rest) 298 (%and-fold1 'fl<=? %fp<= fl rest) ) 299 300 (define (fl>=? fl . rest) 301 (%and-fold1 'fl>=? %fp>= fl rest) ) 302 303 (define (flcompare fl1 fl2) 304 (check-flonum 'flcompare fl1) 305 (check-flonum 'flcompare fl2) 306 (cond [(##core#inline "C_flonum_equalp" fl1 fl2) 307 (cond [(##core#inline "C_flonum_equalp" -0.0 fl1) 308 (if (##core#inline "C_flonum_equalp" -0.0 fl1) 309 0 310 1) ] 311 [(##core#inline "C_flonum_equalp" -0.0 fl2) 312 (if (##core#inline "C_flonum_equalp" 0.0 fl1) 313 -1 314 0) ] 315 [else 316 0 ] ) ] 317 [(##core#inline "C_flonum_lessp" fl1 fl2) 318 -1 ] 319 [else 320 1 ] ) ) 321 322 (define (flmax fl . rest) 323 (%fold1 'flmax %fpmax fl rest) ) 324 325 (define (flmin fl . rest) 326 (%fold1 'flmin %fpmin fl rest) ) 327 328 (define (flmax-and-min fl . rest) 329 (check-flonum 'flmax-and-min fl) 330 (let loop ([mx fl] 331 [mn fl] 332 [lyst rest]) 333 (if (null? lyst) 334 (values mx mn) 335 (let ([cur (car lyst)]) 336 (check-flonum 'flmax-and-min cur) 337 (loop (##core#inline "C_i_flonum_max" mx cur) 338 (##core#inline "C_i_flonum_min" mn cur) 339 (cdr lyst)) ) ) ) ) 340 341 ;;; 342 343 (define (flinteger? fl) 344 (check-flonum 'flinteger? fl) 345 (%fpinteger? fl) ) 346 347 (define (flzero? fl) 348 (check-flonum 'flzero? fl) 349 (##core#inline "C_flonum_equalp" 0.0 fl) ) 350 351 (define (flpositive? fl) 352 (check-flonum 'flpositive? fl) 353 (##core#inline "C_flonum_lessp" 0.0 fl) ) 354 355 (define (flnegative? fl) 356 (check-flonum 'flnegative? fl) 357 (or (##core#inline "C_flonum_equalp" -0.0 fl) 358 (##core#inline "C_flonum_lessp" fl 0.0) ) ) 359 360 (define (flodd? fl) 361 (check-flonum 'flodd? fl) 362 (not (##core#inline "C_flonum_equalp" 0.0 (fpmod fl 2.0))) ) 363 364 (define (fleven? fl) 365 (check-flonum 'fleven? fl) 366 (##core#inline "C_flonum_equalp" 0.0 (fpmod fl 2.0)) ) 367 368 (define (flfinite? fl) 369 (check-flonum 'flfinite? fl) 370 (##core#inline "C_i_finitep" fl) ) 371 372 (define (flinfinite? fl) 373 (check-flonum 'flinfinite? fl) 374 (not (##core#inline "C_i_finitep" fl)) ) 375 376 (define (flnan? fl) 377 (check-flonum 'flnan? fl) 378 (%fpnan? fl) ) 379 380 ;;; 381 382 (define (fl+ fl . rest) 383 (%fold1 'fl+ %fp+ fl rest) ) 384 385 (define (fl* fl . rest) 386 (%fold1 'fl* %fp* fl rest) ) 387 388 (define (fl- fl . rest) 389 (or (and (null? rest) 390 (##core#inline_allocate ("C_a_i_flonum_negate" 4) fl) ) 391 (%fold1 'fl- %fp- fl rest) ) ) 392 393 (define (fl/ fl . rest) 394 (or (and (null? rest) 395 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) 1.0 fl) ) 396 (%fold1 'fl/ %fp/ fl rest) ) ) 342 (define (fl+ fl . fls) 343 (%fpfold-1 'fl+ %fp+ fl fls) ) 344 345 (define (fl* fl . fls) 346 (%fpfold-1 'fl* %fp* fl fls) ) 347 348 (define (fl- fl . fls) 349 (if (%null? fls) (%fpneg fl) 350 (%fpfold-1 'fl- %fp- fl fls) ) ) 351 352 (define (fl/ fl . fls) 353 (if (%null? fls) (%fp/ 1.0 fl) 354 (%fpfold-1 'fl/ %fp/ fl fls) ) ) 397 355 398 356 (define (flabs fl) 399 ( check-flonum 'flabs fl)400 ( ##core#inline_allocate ("C_a_i_abs" 4)fl) )357 (%check-flonum 'flabs fl) 358 (%fpabs fl) ) 401 359 402 360 (define (flfraction fl) 403 ( check-flonum 'flfraction fl)404 (%fpfrac fl) )361 (%check-flonum 'flfraction fl) 362 (%fpfraction fl) ) 405 363 406 364 (define (fltruncate fl) 407 ( check-flonum 'fltruncate fl)408 (%fptrunc fl) )365 (%check-flonum 'fltruncate fl) 366 (%fptruncate fl) ) 409 367 410 368 (define (flfloor fl) 411 ( check-flonum 'flfloor fl)369 (%check-flonum 'flfloor fl) 412 370 (%fpfloor fl) ) 413 371 414 372 (define (flceiling fl) 415 ( check-flonum 'flceiling fl)373 (%check-flonum 'flceiling fl) 416 374 (%fpceil fl) ) 417 375 418 376 (define (flround fl) 419 ( check-flonum 'flround fl)420 (%fpr nd fl) )377 (%check-flonum 'flround fl) 378 (%fpround fl) ) 421 379 422 380 (define (fldiv fln fld) 423 ( check-flonum 'fldiv fln)424 ( check-flonum 'fldiv fld)425 (%fpquo fln fld) )381 (%check-flonum 'fldiv fln) 382 (%check-flonum 'fldiv fld) 383 (%fpquotient fln fld) ) 426 384 427 385 (define (flmod fln fld) 428 ( check-flonum 'flmod fln)429 ( check-flonum 'flmod fld)430 (%fprem fln fld) )386 (%check-flonum 'flmod fln) 387 (%check-flonum 'flmod fld) 388 (%fpremainder fln fld) ) 431 389 432 390 (define (fldiv-and-mod fln fld) 433 ( check-flonum 'fldiv-and-mod fln)434 ( check-flonum 'fldiv-and-mod fld)435 (%fpquo -and-remfln fld) )391 (%check-flonum 'fldiv-and-mod fln) 392 (%check-flonum 'fldiv-and-mod fld) 393 (%fpquotient-and-remainder fln fld) ) 436 394 437 395 (define (fldiv0 fln fld) 438 ( check-flonum 'fldiv0 fln)439 ( check-flonum 'fldiv0 fld)396 (%check-flonum 'fldiv0 fln) 397 (%check-flonum 'fldiv0 fld) 440 398 (%fpdiv0 fln fld) ) 441 399 442 400 (define (flmod0 fln fld) 443 ( check-flonum 'flmod0 fln)444 ( check-flonum 'flmod0 fld)401 (%check-flonum 'flmod0 fln) 402 (%check-flonum 'flmod0 fld) 445 403 (%fpmod0 fln fld) ) 446 404 447 405 (define (fldiv0-and-mod0 fln fld) 448 ( check-flonum 'fldiv0-and-mod0 fln)449 ( check-flonum 'fldiv0-and-mod0 fld)406 (%check-flonum 'fldiv0-and-mod0 fln) 407 (%check-flonum 'fldiv0-and-mod0 fld) 450 408 (%fpdiv0-and-mod0 fln fld) ) 451 409 452 410 (define (flexp fl) 453 (check-flonum 'flexp fl) 454 (##core#inline_allocate ("C_a_i_exp" 4) fl) ) 455 456 (define (fllog fl . rest) 457 (check-flonum 'fllog fl) 458 (if (null? rest) 459 (##core#inline_allocate ("C_a_i_log" 4) fl) 460 (let ([base (car rest)]) 461 (check-non-negative-integer 'fllog base) 462 ((make-log/base base) fl) ) ) ) 411 (%check-flonum 'flexp fl) 412 (%fpexp fl) ) 413 414 (define (fllog fl #!optional base) 415 (define log/base ;memoize log/base functions 416 (let ([bases '()]) 417 (lambda (base) 418 (let ([cell (assv base bases)]) 419 (if cell (cdr cell) 420 (let ([func (make-log/base base)]) 421 (set! bases (alist-cons base func bases)) 422 func ) ) ) ) ) ) 423 (%check-flonum 'fllog fl) 424 (if (not base) (%fplog fl) 425 (begin 426 (%check-non-negative-integer 'fllog base) 427 ((log/base base) fl) ) ) ) 463 428 464 429 (define (flsin fl) 465 ( check-flonum 'flsin fl)466 ( ##core#inline_allocate ("C_a_i_sin" 4)fl) )430 (%check-flonum 'flsin fl) 431 (%fpsin fl) ) 467 432 468 433 (define (flcos fl) 469 ( check-flonum 'flcos fl)470 ( ##core#inline_allocate ("C_a_i_cos" 4)fl) )434 (%check-flonum 'flcos fl) 435 (%fpcos fl) ) 471 436 472 437 (define (fltan fl) 473 ( check-flonum 'fltan fl)474 ( ##core#inline_allocate ("C_a_i_tan" 4)fl) )438 (%check-flonum 'fltan fl) 439 (%fptan fl) ) 475 440 476 441 (define (flasin fl) 477 ( check-flonum 'flasin fl)478 ( ##core#inline_allocate ("C_a_i_asin" 4)fl) )442 (%check-flonum 'flasin fl) 443 (%fpasin fl) ) 479 444 480 445 (define (flacos fl) 481 ( check-flonum 'flacos fl)482 ( ##core#inline_allocate ("C_a_i_acos" 4)fl) )446 (%check-flonum 'flacos fl) 447 (%fpacos fl) ) 483 448 484 449 (define (flatan fl . rest) 485 (check-flonum 'flatan fl) 486 (if (null? rest) 487 (##core#inline_allocate ("C_a_i_atan" 4) fl) 488 (let ([fld (car rest)]) 489 (check-flonum 'flatan fld) 490 (##core#inline_allocate ("C_a_i_atan2" 4) fl fld) ) ) ) 450 (%check-flonum 'flatan fl) 451 (if (%null? rest) (%fpatan fl) 452 (let ([fld (%car rest)]) 453 (%check-flonum 'flatan fld) 454 (%fpatan2 fl fld) ) ) ) 491 455 492 456 (define (flsqrt fl) 493 ( check-flonum 'flsqrt fl)494 ( ##core#inline_allocate ("C_a_i_sqrt" 4)fl) )457 (%check-flonum 'flsqrt fl) 458 (%fpsqrt fl) ) 495 459 496 460 (define (flexpt fl exp) 497 (check-flonum 'flexpt fl) 498 (check-flonum 'flexpt exp) 499 (or (and (= 2.0 fl) 500 (ldexp 1.0 exp) ) 501 ((##core#primitive "C_expt") fl exp) ) ) 461 (%check-flonum 'flexpt fl) 462 (%check-flonum 'flexpt exp) 463 (if (= 2.0 fl) (ldexp 1.0 exp) 464 (%expt fl exp) ) ) 502 465 503 466 (define (flnumerator fl) 504 ( check-flonum 'flnumerator fl)467 (%check-flonum 'flnumerator fl) 505 468 fl ) 506 469 507 470 (define (fldenominator fl) 508 (check-flonum 'fldenominator fl) 509 (if (%fpnan? fl) 510 fl 471 (%check-flonum 'fldenominator fl) 472 (if (%fpnan? fl) fl 511 473 1.0 ) ) 474 475 ) ;module err5rs-arithmetic-bitwise -
release/4/err5rs-arithmetic/trunk/err5rs-arithmetic.meta
r13604 r13606 7 7 (doc-from-wiki) 8 8 (synopsis "ERR5RS Arithmetic") 9 (needs setup-helper srfi-1 int-limits float-limitsmathh)9 (needs setup-helper srfi-1 int-limits mathh) 10 10 (files 11 11 "tests"
Note: See TracChangeset
for help on using the changeset viewer.