Changeset 13766 in project
 Timestamp:
 03/15/09 19:06:03 (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

release/4/err5rsarithmetic/trunk/err5rsarithmeticfixnums.scm
r13762 r13766 23 23 (defineinline (%checkfixnum loc obj) (unless (%fixnum? obj) (errortypefixnum loc obj))) 24 24 25 (defineinline (%check cardinalfixnumloc obj)25 (defineinline (%checkfixnumcardinal loc obj) 26 26 (unless (and (%fixnum? obj) (%fxcardinal? obj)) 27 27 (errortypecardinalfixnum loc obj) ) ) … … 129 129 (defineinline (%fxcarrybit fx) (%arithmeticshift fx *fixnumnegatedprecision*)) 130 130 131 ;;132 133 (defineinline (%stringappend s1 s2) (##sys#stringappend s1 s2))134 135 131 ;;; 136 132 … … 138 134 139 135 (module err5rsarithmeticfixnums (;export 140 ; ERR5RS141 ; ;fixnum?  from chicken136 ;; ERR5RS 137 ;fixnum?  from chicken 142 138 fixnumwidth leastfixnum greatestfixnum 143 fx=? fx<? fx>? fx<=? fx>=? fxcompare139 fx=? fx<? fx>? fx<=? fx>=? 144 140 fxzero? fxpositive? fxnegative? fxodd? fxeven? 145 141 fxmax fxmin fxmaxandmin 146 fxabs 147 fxdiv fxdivandmod fxdiv0 fxmod0 fxdiv0andmod0 142 fxdiv fxmod fxdivandmod fxdiv0 fxmod0 fxdiv0andmod0 148 143 fx*/carry fx+/carry fx/carry 149 fxadd1 fxsub1150 fxmodulo fxquotient fxremainder151 144 fxarithmeticshift fxarithmeticshiftleft fxarithmeticshiftright 152 fx  ;;fx+ fx* fx/  from chicken153 fxand fxior fxxor ; ;fxnot  from chicken145 fx+ fx fx* 146 fxand fxior fxxor ;fxnot  from chicken 154 147 fxif 155 148 fxbitcount … … 162 155 fxrotatebitfield 163 156 fxreversebitfield 164 ; Extras 157 ;; Extras 158 fxcompare 159 fxabs 160 fxnegate 161 fxadd1 fxsub1 162 fx/ fxquotient fxremainder 163 fxifnot 164 fxpow2log2 165 165 fixnum>string 166 fxifnot 167 fxnegate 168 fxpow2log2 169 fx=?# fx<?# fx>?# fx<=?# fx>=?# 170 fx# fx+# fx*# fx/# 171 *fx= 172 *fx< 173 *fx> 174 *fx>= 175 *fx<= 176 *fx+ 177 *fx 178 *fx* 179 *fx/) 166 fx# fx#+ fx#* fx#/ 167 ; Macros 168 *fx=? *fx<? *fx>? *fx<=? *fx>=? 169 *fxmax *fxmin 170 *fx *fx+ *fx* *fx/ 171 *fxand *fxior *fxxor 172 ; Macro helpers 173 $fx= $fx< $fx> $fx>= $fx<= 174 $fxmax $fxmin 175 $fxand $fxior $fxxor 176 $fx+ $fx $fx* $fx/) 180 177 181 178 (import scheme … … 183 180 (fxmax chicken:fxmax) 184 181 (fxmin chicken:fxmin) 185 (fx chicken:fx)186 182 (fxand chicken:fxand) 187 183 (fxior chicken:fxior) 188 (fxxor chicken:fxxor)) 184 (fxxor chicken:fxxor) 185 (fx+ chicken:fx+) 186 (fx chicken:fx) 187 (fx* chicken:fx*) 188 (fx/ chicken:fx/) 189 (fxmod chicken:fxmod)) 189 190 datastructures 190 191 foreign 191 192 err5rsarithmeticbitwise) 192 193 194 ;;; Conditions 195 196 (define (makeexncondition loc msg args) 197 (makepropertycondition 'exn 'location loc 'message msg 'arguments args) ) 198 199 (define (makearithmeticcondition loc msg args) 200 (makecompositecondition 201 (makeexncondition loc msg args) 202 (makepropertycondition 'arithmetic)) ) 203 204 (define (makezerodivisioncondition loc fx1 fx2) 205 (makearithmeticcondition loc "division by zero" (list fx1 fx2)) ) 206 207 ; &implementationrestriction 208 (define (makefixnumrepresentationcondition loc fx1 fx2) 209 (makearithmeticcondition loc "result not representable as fixnum" (list fx1 fx2)) ) 210 193 211 ;;; Errors 194 212 … … 205 223 (##sys#signalhook #:boundserror loc "out of range" obj low high) ) 206 224 207 (define (errorzerodivision loc fx1 fx2)208 (##sys#signalhook #:arithmeticerror loc "division by zero" fx1 fx2) )209 210 (define (errorfixnumrepresentation loc fx1 fx2)211 (##sys#signalhook #:arithmeticerror loc "results not representable as fixnums" fx1 fx2) )212 213 225 (define (errorboundsorder loc start end) 214 226 (##sys#signalhook #:boundserror loc "bounds reversed" start end) ) … … 217 229 (##sys#signalhook #:boundserror loc "too many bits for interval" count start end) ) 218 230 231 (define (errorzerodivision loc fx1 fx2) 232 (abort (makezerodivisioncondition loc fx1 fx2)) ) 233 234 (define (errorfixnumrepresentation loc fx1 fx2) 235 (abort (makefixnumrepresentationcondition loc fx1 fx2)) ) 236 219 237 ;;; Constants 220 238 … … 223 241 ;;; Procedures wrapping primitiveinlines for fold operations 224 242 225 (define (*fx= x y) (%fx= x y)) 226 (define (*fx< x y) (%fx< x y)) 227 (define (*fx> x y) (%fx> x y)) 228 (define (*fx>= x y) (%fx>= x y)) 229 (define (*fx<= x y) (%fx<= x y)) 230 (define (*fxmax x y) (%fxmax x y)) 231 (define (*fxmin x y) (%fxmin x y)) 232 (define (*fxand x y) (%fxand x y)) 233 (define (*fxior x y) (%fxior x y)) 234 (define (*fxxor x y) (%fxxor x y)) 235 (define (*fx+ x y) (%fx+ x y)) 236 (define (*fx x y) (%fx x y)) 237 (define (*fx* x y) (%fx* x y)) 238 (define (*fx/ x y) (%fx/ x y)) 239 240 ;;; 243 (define ($fx= x y) (%fx= x y)) 244 (define ($fx< x y) (%fx< x y)) 245 (define ($fx> x y) (%fx> x y)) 246 (define ($fx>= x y) (%fx>= x y)) 247 (define ($fx<= x y) (%fx<= x y)) 248 (define ($fx+ x y) (%fx+ x y)) 249 (define ($fx x y) (%fx x y)) 250 (define ($fx* x y) (%fx* x y)) 251 (define ($fx/ x y) (%fx/ x y)) 252 (define ($fxneg x) (%fxneg x)) 253 (define ($fxmax x y) (%fxmax x y)) 254 (define ($fxmin x y) (%fxmin x y)) 255 (define ($fxand x y) (%fxand x y)) 256 (define ($fxior x y) (%fxior x y)) 257 (define ($fxxor x y) (%fxxor x y)) 258 259 ;;; ERR5RS 260 261 ;; 241 262 242 263 (define (fixnumwidth) fixnumbits) … … 244 265 (define (greatestfixnum) mostpositivefixnum) 245 266 246 ;;; 247 248 (define (fx=? fx . fxs) (%fxandfold 'fx=? *fx= fx fxs)) 249 (define (fx<? fx . fxs) (%fxandfold 'fx<? *fx< fx fxs)) 250 (define (fx>? fx . fxs) (%fxandfold 'fx>? *fx> fx fxs)) 251 (define (fx<=? fx . fxs) (%fxandfold 'fx<=? *fx<= fx fxs)) 252 (define (fx>=? fx . fxs) (%fxandfold 'fx>=? *fx>= fx fxs)) 253 254 (define (fxcompare fx1 fx2) 255 (%checkfixnum 'fxcompare fx1) 256 (%checkfixnum 'fxcompare fx2) 257 (cond ((%fx= fx1 fx2) 0) 258 ((%fx< fx1 fx2) 1) 259 (else 1) ) ) 260 261 (define (fxmax fx . fxs) (%fxfold 'fxmax *fxmax fx fxs)) 262 (define (fxmin fx . fxs) (%fxfold 'fxmin *fxmin fx fxs)) 267 ;; 268 269 (define (fx=? fx . fxs) (%fxandfold 'fx=? $fx= fx fxs)) 270 (define (fx<? fx . fxs) (%fxandfold 'fx<? $fx< fx fxs)) 271 (define (fx>? fx . fxs) (%fxandfold 'fx>? $fx> fx fxs)) 272 (define (fx<=? fx . fxs) (%fxandfold 'fx<=? $fx<= fx fxs)) 273 (define (fx>=? fx . fxs) (%fxandfold 'fx>=? $fx>= fx fxs)) 274 275 (define (fxmax fx . fxs) (%fxfold 'fxmax $fxmax fx fxs)) 276 (define (fxmin fx . fxs) (%fxfold 'fxmin $fxmin fx fxs)) 263 277 264 278 (define (fxmaxandmin fx . fxs) … … 270 284 (loop (%cdr fxs) (%fxmax mx cur) (%fxmin mn cur)) ) ) ) ) 271 285 272 ;;; 286 ;; 287 288 (define (fxand fx . fxs) (%fxfold 'fxand $fxand fx fxs)) 289 (define (fxior fx . fxs) (%fxfold 'fxior $fxior fx fxs)) 290 (define (fxxor fx . fxs) (%fxfold 'fxxor $fxxor fx fxs)) 291 292 ;; 273 293 274 294 (define (fxzero? fx) … … 292 312 (%fxeven? fx) ) 293 313 294 ;;; 295 296 (define (fxabs fx) 297 (%checkfixnum 'fxabs fx) 298 (%fxabs fx) ) 314 ;; 315 316 (define (fx+ fx1 fx2) 317 (%checkfixnum 'fx+ fx1) 318 (%checkfixnum 'fx+ fx2) 319 (%fx+ fx1 fx2) ) 320 321 (define (fx fx1 #!optional fx2) 322 (%checkfixnum 'fx fx1) 323 (if (not fx2) (%fxneg fx1) 324 (begin 325 (%checkfixnum 'fx fx2) 326 (%fx fx1 fx2) ) ) ) 327 328 (define (fx* fx1 fx2) 329 (%checkfixnum 'fx* fx1) 330 (%checkfixnum 'fx* fx2) 331 (%fx* fx1 fx2) ) 299 332 300 333 (define (fxdiv fxn fxd) … … 303 336 (%checkzerodivision 'fxdiv fxn fxd) 304 337 (%fx/ fxn fxd) ) 338 339 (define (fxmod fxn fxd) 340 (%checkfixnum 'fxmod fxn) 341 (%checkfixnum 'fxmod fxd) 342 (%checkzerodivision 'fxmod fxn fxd) 343 (%fxmod fxn fxd) ) 305 344 306 345 (define (fxdivandmod fxn fxd) … … 355 394 (values res (%fxcarrybit (% (% fx1 fx2) (%+ res fx3)))) ) ) 356 395 396 (define (fxarithmeticshift fx amount) 397 (%checkfixnum 'fxarithmeticshift fx) 398 (%checkfixnum 'fxarithmeticshift amount) 399 (if (%fxpositive? amount) (%fxshr fx (%fxneg amount)) 400 (%fxshl fx amount) ) ) 401 402 (define (fxarithmeticshiftleft fx amount) 403 (%checkfixnum 'fxarithmeticshiftleft fx) 404 (%checkfixnumcardinal 'fxarithmeticshiftleft amount) 405 (%fxshl fx amount) ) 406 407 (define (fxarithmeticshiftright fx amount) 408 (%checkfixnum 'fxarithmeticshiftright fx) 409 (%checkfixnumcardinal 'fxarithmeticshiftright amount) 410 (%fxshr fx amount) ) 411 412 ;; 413 414 (define (fxif mask true false) 415 (%checkfixnum 'fxif mask) 416 (%checkfixnum 'fxif true) 417 (%checkfixnum 'fxif false) 418 (*bitwiseif mask true false) ) 419 420 (define (fxbitcount fx) 421 (%checkfixnum 'fxbitcount fx) 422 (*bitwisebitcount fx) ) 423 424 (define (fxlength fx) 425 (%checkfixnum 'fxlength fx) 426 (*bitwiselength fx) ) 427 428 (define (fxfirstbitset fx) 429 (%checkfixnum 'fxfirstbitset fx) 430 (*bitwisefirstbitset fx) ) 431 432 (define (fxlastbitset fx) 433 (%checkfixnum 'fxlastbitset fx) 434 (*bitwiselastbitset fx) ) 435 436 (define (fxbitset? fx index) 437 (%checkfixnum 'fxbitset? fx) 438 (%checkwordbitsrange 'fxbitset? index) 439 (*bitwisebitset? fx index) ) 440 441 (define (fxcopybit fx index bit) 442 (%checkfixnum 'fxcopybit fx) 443 (%checkwordbitsrange 'fxcopybit index) 444 (%checkfixnum 'fxcopybit bit) 445 (*bitwisecopybit fx index bit) ) 446 447 (define (fxbitfield fx start end) 448 (%checkfixnum 'fxbitfield fx) 449 (%checkbitsrange 'fxbitfield start end) 450 (*bitwisebitfield fx start end) ) 451 452 (define (fxcopybitfield fxto start end fxfrom) 453 (%checkfixnum 'fxcopybitfield fxto) 454 (%checkbitsrange 'fxcopybitfield start end) 455 (%checkfixnum 'fxcopybitfield fxfrom) 456 (*bitwisecopybitfield fxto start end fxfrom) ) 457 458 (define (fxrotatebitfield fx start end count) 459 (%checkfixnum 'fxrotatebitfield fx) 460 (%checkbitsrange 'fxrotatebitfield start end) 461 (%checkfixnumcardinal 'fxrotatebitfield count) 462 (%checkfixnumbitscount 'fxrotatebitfield count start end) 463 (*bitwiserotatebitfield fx start end count) ) 464 465 (define (fxreversebitfield fx start end) 466 (%checkfixnum 'fxreversebitfield fx) 467 (%checkbitsrange 'fxreversebitfield start end) 468 (*bitwisereversebitfield fx start end) ) 469 470 ;;; Extras 471 472 ;; 473 474 (define (fxcompare fx1 fx2) 475 (%checkfixnum 'fxcompare fx1) 476 (%checkfixnum 'fxcompare fx2) 477 (cond ((%fx= fx1 fx2) 0) 478 ((%fx< fx1 fx2) 1) 479 (else 1) ) ) 480 481 ;; 482 483 (define (fxabs fx) 484 (%checkfixnum 'fxabs fx) 485 (%fxabs fx) ) 486 487 (define (fxnegate fx) 488 (%checkfixnum 'fxnegate fx) 489 (%fxneg fx) ) 490 357 491 (define (fxadd1 fx) 358 492 (%checkfixnum 'fxadd1 fx) … … 362 496 (%checkfixnum 'fxsub1 fx) 363 497 (%fxsub1 fx) ) 498 499 (define (fx/ fx1 fx2) 500 (%checkfixnum 'fx/ fxn) 501 (%checkfixnum 'fx/ fxd) 502 (%checkzerodivision 'fx/ fxn fxd) 503 (%fx/ fxn fxd) ) 364 504 365 505 (define (fxquotient fxn fxd) … … 374 514 (%checkzerodivision 'fxremainder fxn fxd) 375 515 (%fx fxn (%fx* (%fx/ fxn fxd) fxd)) ) 376 377 (define (fxmodulo fxn fxd)378 (%checkfixnum 'fxmodulo fxn)379 (%checkfixnum 'fxmodulo fxd)380 (%checkzerodivision 'fxmodulo fxn fxd)381 (%fxmod fxn fxd) )382 383 (define (fxarithmeticshift fx amount)384 (%checkfixnum 'fxarithmeticshift fx)385 (%checkfixnum 'fxarithmeticshift amount)386 (if (%fxpositive? amount) (%fxshr fx (%fxneg amount))387 (%fxshl fx amount) ) )388 389 (define (fxarithmeticshiftleft fx amount)390 (%checkfixnum 'fxarithmeticshiftleft fx)391 (%checkcardinalfixnum 'fxarithmeticshiftleft amount)392 (%fxshl fx amount) )393 394 (define (fxarithmeticshiftright fx amount)395 (%checkfixnum 'fxarithmeticshiftright fx)396 (%checkcardinalfixnum 'fxarithmeticshiftright amount)397 (%fxshr fx amount) )398 399 (define (fx fx #!optional fx2)400 (%checkfixnum 'fx fx)401 (if (not fx2) (%fxneg fx)402 (begin403 (%checkfixnum 'fx fx2)404 (%fx fx fx2) ) ) )405 406 ;;;407 408 (define (fxand fx . fxs) (%fxfold 'fxand *fxand fx fxs))409 (define (fxior fx . fxs) (%fxfold 'fxior *fxior fx fxs))410 (define (fxxor fx . fxs) (%fxfold 'fxxor *fxxor fx fxs))411 412 ;;;413 414 (define (fxif mask true false)415 (%checkfixnum 'fxif mask)416 (%checkfixnum 'fxif true)417 (%checkfixnum 'fxif false)418 (*bitwiseif mask true false) )419 420 (define (fxbitcount fx)421 (%checkfixnum 'fxbitcount fx)422 (*bitwisebitcount fx) )423 424 (define (fxlength fx)425 (%checkfixnum 'fxlength fx)426 (*bitwiselength fx) )427 428 (define (fxfirstbitset fx)429 (%checkfixnum 'fxfirstbitset fx)430 (*bitwisefirstbitset fx) )431 432 (define (fxlastbitset fx)433 (%checkfixnum 'fxlastbitset fx)434 (*bitwiselastbitset fx) )435 436 (define (fxbitset? fx index)437 (%checkfixnum 'fxbitset? fx)438 (%checkwordbitsrange 'fxbitset? index)439 (*bitwisebitset? fx index) )440 441 (define (fxcopybit fx index bit)442 (%checkfixnum 'fxcopybit fx)443 (%checkwordbitsrange 'fxcopybit index)444 (%checkfixnum 'fxcopybit bit)445 (*bitwisecopybit fx index bit) )446 447 (define (fxbitfield fx start end)448 (%checkfixnum 'fxbitfield fx)449 (%checkbitsrange 'fxbitfield start end)450 (*bitwisebitfield fx start end) )451 452 (define (fxcopybitfield fxto start end fxfrom)453 (%checkfixnum 'fxcopybitfield fxto)454 (%checkbitsrange 'fxcopybitfield start end)455 (%checkfixnum 'fxcopybitfield fxfrom)456 (*bitwisecopybitfield fxto start end fxfrom) )457 458 (define (fxrotatebitfield fx start end count)459 (%checkfixnum 'fxrotatebitfield fx)460 (%checkbitsrange 'fxrotatebitfield start end)461 (%checkcardinalfixnum 'fxrotatebitfield count)462 (%checkfixnumbitscount 'fxrotatebitfield count start end)463 (*bitwiserotatebitfield fx start end count) )464 465 (define (fxreversebitfield fx start end)466 (%checkfixnum 'fxreversebitfield fx)467 (%checkbitsrange 'fxreversebitfield start end)468 (*bitwisereversebitfield fx start end) )469 470 ;;; Extras471 516 472 517 ;; … … 490 535 str ) ) 491 536 ((%fx= mostnegativefixnum fx) 492 (%stringappend (fx>str (%fx/ fx radix)) (fx>str (%fx radix (%fxmod fx radix)))) ) 537 (##sys#stringappend 538 (fx>str (%fx/ fx radix)) 539 (fx>str (%fx radix (%fxmod fx radix)))) ) 493 540 (else 494 541 (let ((str (fxdigits (%fxneg fx) 1 1))) … … 504 551 ;; 505 552 506 (define (fxnegate fx)507 (%checkfixnum 'fxnegate fx)508 (%fxneg fx) )509 510 ;;511 512 553 (define (fxifnot mask true false) 513 554 (%checkfixnum 'fxifnot mask) … … 524 565 ;; 525 566 526 (definesyntax fx=?# 527 (syntaxrules () 528 ((_ ?x) 529 #t ) 530 ((_ ?x ?y) 531 (*fx= ?x ?y) ) 532 ((_ ?x ?y ?rest ...) 533 (and (*fx= ?x ?y) (fx=?# ?y ?rest ...)) ) ) ) 534 535 (definesyntax fx<?# 536 (syntaxrules () 537 ((_ ?x) 538 #t ) 539 ((_ ?x ?y) 540 (*fx< ?x ?y) ) 541 ((_ ?x ?y ?rest ...) 542 (and (*fx< ?x ?y) (fx<?# ?y ?rest ...)) ) ) ) 543 544 (definesyntax fx>?# 545 (syntaxrules () 546 ((_ ?x) 547 #t ) 548 ((_ ?x ?y) 549 (*fx> ?x ?y) ) 550 ((_ ?x ?y ?rest ...) 551 (and (*fx> ?x ?y) (fx>?# ?y ?rest ...)) ) ) ) 552 553 (definesyntax fx<=?# 554 (syntaxrules () 555 ((_ ?x) 556 #t ) 557 ((_ ?x ?y) 558 (*fx<= ?x ?y) ) 559 ((_ ?x ?y ?rest ...) 560 (and (*fx<= ?x ?y) (fx<=?# ?y ?rest ...)) ) ) ) 561 562 (definesyntax fx>=?# 563 (syntaxrules () 564 ((_ ?x) 565 #t ) 566 ((_ ?x ?y) 567 (*fx>= ?x ?y) ) 568 ((_ ?x ?y ?rest ...) 569 (and (*fx>= ?x ?y) (fx>=?# ?y ?rest ...)) ) ) ) 570 571 ;; 572 573 (definesyntax fx# 574 (syntaxrules () 575 ((_ ?x) 576 (*fxneg ?x) ) 577 ((_ ?x ?y) 578 (*fx ?x ?y) ) 579 ((_ ?x ?y ?rest ...) 580 (*fx ?x (fx# ?y ?rest ...) ) ) ) ) 581 582 (definesyntax fx+# 583 (syntaxrules () 584 ((_ ?x) 585 ?x ) 586 ((_ ?x ?y) 587 (*fx+ ?x ?y) ) 588 ((_ ?x ?y ?rest ...) 589 (*fx+ ?x (fx+# ?y ?rest ...) ) ) ) ) 590 591 (definesyntax fx*# 592 (syntaxrules () 593 ((_ ?x) 594 ?x ) 595 ((_ ?x ?y) 596 (*fx* ?x ?y) ) 597 ((_ ?x ?y ?rest ...) 598 (*fx* ?x (fx*# ?y ?rest ...) ) ) ) ) 599 600 (definesyntax fx/# 601 (syntaxrules () 602 ((_ ?x) 603 ?x ) 604 ((_ ?x ?y) 605 (*fx/ ?x ?y) ) 606 ((_ ?x ?y ?rest ...) 607 (*fx/ ?x (fx/# ?y ?rest ...) ) ) ) ) 608 609 # 610 ;; 611 612 (define (fx=?# fx . fxs) 613 (%checkfixnum 'fx=?# fx) 614 (cond ((%null? fxs) #t) 615 ((%null? (%cdr fxs)) (%fx= fx (%car fxs))) 616 (else (%fxandfold 'fx=?# *fx= fx fxs) ) ) ) 617 618 (define (fx<?# fx . fxs) 619 (%checkfixnum 'fx<?# fx) 620 (cond ((%null? fxs) #t) 621 ((%null? (%cdr fxs)) (%fx< fx (%car fxs))) 622 (else (%fxandfold 'fx<?# *fx< fx fxs) ) ) ) 623 624 (define (fx>?# fx . fxs) 625 (%checkfixnum 'fx>?# fx) 626 (cond ((%null? fxs) #t) 627 ((%null? (%cdr fxs)) (%fx> fx (%car fxs))) 628 (else (%fxandfold 'fx>?# *fx> fx fxs) ) ) ) 629 630 (define (fx<=?# fx . fxs) 631 (%checkfixnum 'fx<=?# fx) 632 (cond ((%null? fxs) #t) 633 ((%null? (%cdr fxs)) (%fx<= fx (%car fxs))) 634 (else (%fxandfold 'fx<=?# *fx<= fx fxs) ) ) ) 635 636 (define (fx>=?# fx . fxs) 637 (%checkfixnum 'fx>=?# fx) 638 (cond ((%null? fxs) #t) 639 ((%null? (%cdr fxs)) (%fx>= fx (%car fxs))) 640 (else (%fxandfold 'fx>=?# *fx>= fx fxs) ) ) ) 641 642 ;; 643 644 (define (fx# fx . fxs) 645 (%checkfixnum 'fx# fx) 567 (define (fx# fx . fxs) 568 (%checkfixnum 'fx# fx) 646 569 (cond ((%null? fxs) (%fxneg fx)) 647 570 ((%null? (%cdr fxs)) (%fx fx (%car fxs))) 648 (else (%fxfold 'fx # *fx fx fxs) ) ) )649 650 (define (fx +#fx . fxs)651 (%checkfixnum 'fx +#fx)571 (else (%fxfold 'fx# $fx fx fxs) ) ) ) 572 573 (define (fx#+ fx . fxs) 574 (%checkfixnum 'fx#+ fx) 652 575 (cond ((%null? fxs) fx) 653 576 ((%null? (%cdr fxs)) (%fx+ fx (%car fxs))) 654 (else (%fxfold 'fx +# *fx+ fx fxs) ) ) )655 656 (define (fx *#fx . fxs)657 (%checkfixnum 'fx *#fx)577 (else (%fxfold 'fx#+ $fx+ fx fxs) ) ) ) 578 579 (define (fx#* fx . fxs) 580 (%checkfixnum 'fx#* fx) 658 581 (cond ((%null? fxs) fx) 659 582 ((%null? (%cdr fxs)) (%fx* fx (%car fxs))) 660 (else (%fxfold 'fx *# *fx* fx fxs) ) ) )661 662 (define (fx /#fx . fxs)663 (%checkfixnum 'fx /#fx)583 (else (%fxfold 'fx#* $fx* fx fxs) ) ) ) 584 585 (define (fx#/ fx . fxs) 586 (%checkfixnum 'fx#/ fx) 664 587 (cond ((%null? fxs) fx) 665 588 ((%null? (%cdr fxs)) (%fx/ fx (%car fxs))) 666 (else (%fxfold 'fx/# *fx/ fx fxs) ) ) ) 667 # 589 (else (%fxfold 'fx#/ $fx/ fx fxs) ) ) ) 590 591 ;; 592 593 (definesyntax *fx=? 594 (syntaxrules () 595 ((_ ?x) 596 #t ) 597 ((_ ?x ?y) 598 ($fx= ?x ?y) ) 599 ((_ ?x ?y ?rest ...) 600 (and ($fx= ?x ?y) (*fx=? ?y ?rest ...)) ) ) ) 601 602 (definesyntax *fx<? 603 (syntaxrules () 604 ((_ ?x) 605 #t ) 606 ((_ ?x ?y) 607 ($fx< ?x ?y) ) 608 ((_ ?x ?y ?rest ...) 609 (and ($fx< ?x ?y) (*fx<? ?y ?rest ...)) ) ) ) 610 611 (definesyntax *fx>? 612 (syntaxrules () 613 ((_ ?x) 614 #t ) 615 ((_ ?x ?y) 616 ($fx> ?x ?y) ) 617 ((_ ?x ?y ?rest ...) 618 (and ($fx> ?x ?y) (*fx>? ?y ?rest ...)) ) ) ) 619 620 (definesyntax *fx<=? 621 (syntaxrules () 622 ((_ ?x) 623 #t ) 624 ((_ ?x ?y) 625 ($fx<= ?x ?y) ) 626 ((_ ?x ?y ?rest ...) 627 (and ($fx<= ?x ?y) (*fx<=? ?y ?rest ...)) ) ) ) 628 629 (definesyntax *fx>=? 630 (syntaxrules () 631 ((_ ?x) 632 #t ) 633 ((_ ?x ?y) 634 ($fx>= ?x ?y) ) 635 ((_ ?x ?y ?rest ...) 636 (and ($fx>= ?x ?y) (*fx>=? ?y ?rest ...)) ) ) ) 637 638 ;; 639 640 (definesyntax *fxmax 641 (syntaxrules () 642 ((_ ?x) 643 ?x ) 644 ((_ ?x ?y) 645 ($fxmax ?x ?y) ) 646 ((_ ?x ?y ?rest ...) 647 ($fxmax ?x (*fxmax ?y ?rest ...)) ) ) ) 648 649 (definesyntax *fxmin 650 (syntaxrules () 651 ((_ ?x) 652 ?x ) 653 ((_ ?x ?y) 654 ($fxmin ?x ?y) ) 655 ((_ ?x ?y ?rest ...) 656 ($fxmin ?x (*fxmin ?y ?rest ...)) ) ) ) 657 658 ;; 659 660 (definesyntax *fxand 661 (syntaxrules () 662 ((_ ?x) 663 ?x ) 664 ((_ ?x ?y) 665 ($fxand ?x ?y) ) 666 ((_ ?x ?y ?rest ...) 667 ($fxand ?x (*fxand ?y ?rest ...)) ) ) ) 668 669 (definesyntax *fxior 670 (syntaxrules () 671 ((_ ?x) 672 ?x ) 673 ((_ ?x ?y) 674 ($fxior ?x ?y) ) 675 ((_ ?x ?y ?rest ...) 676 ($fxior ?x (*fxior ?y ?rest ...)) ) ) ) 677 678 (definesyntax *fxxor 679 (syntaxrules () 680 ((_ ?x) 681 ?x ) 682 ((_ ?x ?y) 683 ($fxxor ?x ?y) ) 684 ((_ ?x ?y ?rest ...) 685 ($fxxor ?x (*fxxor ?y ?rest ...)) ) ) ) 686 687 ;; 688 689 (definesyntax *fx 690 (syntaxrules () 691 ((_ ?x) 692 ($fxneg ?x) ) 693 ((_ ?x ?y) 694 ($fx ?x ?y) ) 695 ((_ ?x ?y ?rest ...) 696 ($fx ?x (*fx ?y ?rest ...) ) ) ) ) 697 698 (definesyntax *fx+ 699 (syntaxrules () 700 ((_ ?x) 701 ?x ) 702 ((_ ?x ?y) 703 ($fx+ ?x ?y) ) 704 ((_ ?x ?y ?rest ...) 705 ($fx+ ?x (*fx+ ?y ?rest ...) ) ) ) ) 706 707 (definesyntax *fx* 708 (syntaxrules () 709 ((_ ?x) 710 ?x ) 711 ((_ ?x ?y) 712 ($fx* ?x ?y) ) 713 ((_ ?x ?y ?rest ...) 714 ($fx* ?x (*fx* ?y ?rest ...) ) ) ) ) 715 716 (definesyntax *fx/ 717 (syntaxrules () 718 ((_ ?x) 719 ?x ) 720 ((_ ?x ?y) 721 ($fx/ ?x ?y) ) 722 ((_ ?x ?y ?rest ...) 723 ($fx/ ?x (*fx/ ?y ?rest ...) ) ) ) ) 668 724 669 725 ) ;module err5rsarithmeticfixnums
Note: See TracChangeset
for help on using the changeset viewer.