Changeset 13766 in project


Ignore:
Timestamp:
03/15/09 19:06:03 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r13762 r13766  
    2323(define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    2424
    25 (define-inline (%check-cardinal-fixnum loc obj)
     25(define-inline (%check-fixnum-cardinal loc obj)
    2626  (unless (and (%fixnum? obj) (%fxcardinal? obj))
    2727    (error-type-cardinal-fixnum loc obj) ) )
     
    129129(define-inline (%fxcarry-bit fx) (%arithmetic-shift fx *fixnum-negated-precision*))
    130130
    131 ;;
    132 
    133 (define-inline (%string-append s1 s2) (##sys#string-append s1 s2))
    134 
    135131;;;
    136132
     
    138134
    139135(module err5rs-arithmetic-fixnums (;export
    140   ; ERR5RS
    141   ;;fixnum? - from chicken
     136  ;; ERR5RS
     137  ;fixnum? - from chicken
    142138  fixnum-width least-fixnum greatest-fixnum
    143   fx=? fx<? fx>? fx<=? fx>=? fxcompare
     139  fx=? fx<? fx>? fx<=? fx>=?
    144140  fxzero? fxpositive? fxnegative? fxodd? fxeven?
    145141  fxmax fxmin fxmax-and-min
    146   fxabs
    147   fxdiv fxdiv-and-mod fxdiv0 fxmod0 fxdiv0-and-mod0
     142  fxdiv fxmod fxdiv-and-mod fxdiv0 fxmod0 fxdiv0-and-mod0
    148143  fx*/carry fx+/carry fx-/carry
    149   fxadd1 fxsub1
    150   fxmodulo fxquotient fxremainder
    151144  fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right
    152   fx- ;;fx+ fx* fx/ - from chicken
    153   fxand fxior fxxor ;;fxnot - from chicken
     145  fx+ fx- fx*
     146  fxand fxior fxxor ;fxnot - from chicken
    154147  fxif
    155148  fxbit-count
     
    162155  fxrotate-bit-field
    163156  fxreverse-bit-field
    164   ; Extras
     157  ;; Extras
     158  fxcompare
     159  fxabs
     160  fxnegate
     161  fxadd1 fxsub1
     162  fx/ fxquotient fxremainder
     163  fxif-not
     164  fxpow2log2
    165165  fixnum->string
    166   fxif-not
    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/)
    180177
    181178(import scheme
     
    183180          (fxmax chicken:fxmax)
    184181          (fxmin chicken:fxmin)
    185           (fx- chicken:fx-)
    186182          (fxand chicken:fxand)
    187183          (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))
    189190        data-structures
    190191        foreign
    191192        err5rs-arithmetic-bitwise)
    192193
     194;;; Conditions
     195
     196(define (make-exn-condition loc msg args)
     197  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
     198
     199(define (make-arithmetic-condition loc msg args)
     200  (make-composite-condition
     201    (make-exn-condition loc msg args)
     202    (make-property-condition 'arithmetic)) )
     203
     204(define (make-zero-division-condition loc fx1 fx2)
     205  (make-arithmetic-condition loc "division by zero" (list fx1 fx2)) )
     206
     207; &implementation-restriction
     208(define (make-fixnum-representation-condition loc fx1 fx2)
     209  (make-arithmetic-condition loc "result not representable as fixnum" (list fx1 fx2)) )
     210
    193211;;; Errors
    194212
     
    205223  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
    206224
    207 (define (error-zero-division loc fx1 fx2)
    208   (##sys#signal-hook #:arithmetic-error loc "division by zero" fx1 fx2) )
    209 
    210 (define (error-fixnum-representation loc fx1 fx2)
    211   (##sys#signal-hook #:arithmetic-error loc "results not representable as fixnums" fx1 fx2) )
    212 
    213225(define (error-bounds-order loc start end)
    214226  (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
     
    217229  (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
    218230
     231(define (error-zero-division loc fx1 fx2)
     232  (abort (make-zero-division-condition loc fx1 fx2)) )
     233
     234(define (error-fixnum-representation loc fx1 fx2)
     235  (abort (make-fixnum-representation-condition loc fx1 fx2)) )
     236
    219237;;; Constants
    220238
     
    223241;;; Procedures wrapping primitive-inlines for fold operations
    224242
    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;;
    241262
    242263(define (fixnum-width) fixnum-bits)
     
    244265(define (greatest-fixnum) most-positive-fixnum)
    245266
    246 ;;;
    247 
    248 (define (fx=? fx . fxs) (%fxand-fold 'fx=? *fx= fx fxs))
    249 (define (fx<? fx . fxs) (%fxand-fold 'fx<? *fx< fx fxs))
    250 (define (fx>? fx . fxs) (%fxand-fold 'fx>? *fx> fx fxs))
    251 (define (fx<=? fx . fxs) (%fxand-fold 'fx<=? *fx<= fx fxs))
    252 (define (fx>=? fx . fxs) (%fxand-fold 'fx>=? *fx>= fx fxs))
    253 
    254 (define (fxcompare fx1 fx2)
    255   (%check-fixnum 'fxcompare fx1)
    256   (%check-fixnum '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) (%fxand-fold 'fx=? $fx= fx fxs))
     270(define (fx<? fx . fxs) (%fxand-fold 'fx<? $fx< fx fxs))
     271(define (fx>? fx . fxs) (%fxand-fold 'fx>? $fx> fx fxs))
     272(define (fx<=? fx . fxs) (%fxand-fold 'fx<=? $fx<= fx fxs))
     273(define (fx>=? fx . fxs) (%fxand-fold '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))
    263277
    264278(define (fxmax-and-min fx . fxs)
     
    270284          (loop (%cdr fxs) (%fxmax mx cur) (%fxmin mn cur)) ) ) ) )
    271285
    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;;
    273293
    274294(define (fxzero? fx)
     
    292312  (%fxeven? fx) )
    293313
    294 ;;;
    295 
    296 (define (fxabs fx)
    297   (%check-fixnum 'fxabs fx)
    298   (%fxabs fx) )
     314;;
     315
     316(define (fx+ fx1 fx2)
     317  (%check-fixnum 'fx+ fx1)
     318  (%check-fixnum 'fx+ fx2)
     319  (%fx+ fx1 fx2) )
     320
     321(define (fx- fx1 #!optional fx2)
     322  (%check-fixnum 'fx- fx1)
     323  (if (not fx2) (%fxneg fx1)
     324      (begin
     325        (%check-fixnum 'fx- fx2)
     326        (%fx- fx1 fx2) ) ) )
     327
     328(define (fx* fx1  fx2)
     329  (%check-fixnum 'fx* fx1)
     330  (%check-fixnum 'fx* fx2)
     331  (%fx* fx1 fx2) )
    299332
    300333(define (fxdiv fxn fxd)
     
    303336  (%check-zero-division 'fxdiv fxn fxd)
    304337  (%fx/ fxn fxd) )
     338
     339(define (fxmod fxn fxd)
     340  (%check-fixnum 'fxmod fxn)
     341  (%check-fixnum 'fxmod fxd)
     342  (%check-zero-division 'fxmod fxn fxd)
     343  (%fxmod fxn fxd) )
    305344
    306345(define (fxdiv-and-mod fxn fxd)
     
    355394    (values res (%fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) )
    356395
     396(define (fxarithmetic-shift fx amount)
     397  (%check-fixnum 'fxarithmetic-shift fx)
     398  (%check-fixnum 'fxarithmetic-shift amount)
     399  (if (%fxpositive? amount) (%fxshr fx (%fxneg amount))
     400      (%fxshl fx amount) ) )
     401
     402(define (fxarithmetic-shift-left fx amount)
     403  (%check-fixnum 'fxarithmetic-shift-left fx)
     404  (%check-fixnum-cardinal 'fxarithmetic-shift-left amount)
     405  (%fxshl fx amount) )
     406
     407(define (fxarithmetic-shift-right fx amount)
     408  (%check-fixnum 'fxarithmetic-shift-right fx)
     409  (%check-fixnum-cardinal 'fxarithmetic-shift-right amount)
     410  (%fxshr fx amount) )
     411
     412;;
     413
     414(define (fxif mask true false)
     415  (%check-fixnum 'fxif mask)
     416  (%check-fixnum 'fxif true)
     417  (%check-fixnum 'fxif false)
     418  (*bitwise-if mask true false) )
     419
     420(define (fxbit-count fx)
     421  (%check-fixnum 'fxbit-count fx)
     422  (*bitwise-bit-count fx) )
     423
     424(define (fxlength fx)
     425  (%check-fixnum 'fxlength fx)
     426  (*bitwise-length fx) )
     427
     428(define (fxfirst-bit-set fx)
     429  (%check-fixnum 'fxfirst-bit-set fx)
     430  (*bitwise-first-bit-set fx) )
     431
     432(define (fxlast-bit-set fx)
     433  (%check-fixnum 'fxlast-bit-set fx)
     434  (*bitwise-last-bit-set fx) )
     435
     436(define (fxbit-set? fx index)
     437  (%check-fixnum 'fxbit-set? fx)
     438  (%check-word-bits-range 'fxbit-set? index)
     439  (*bitwise-bit-set? fx index) )
     440
     441(define (fxcopy-bit fx index bit)
     442  (%check-fixnum 'fxcopy-bit fx)
     443  (%check-word-bits-range 'fxcopy-bit index)
     444  (%check-fixnum 'fxcopy-bit bit)
     445  (*bitwise-copy-bit fx index bit) )
     446
     447(define (fxbit-field fx start end)
     448  (%check-fixnum 'fxbit-field fx)
     449  (%check-bits-range 'fxbit-field start end)
     450  (*bitwise-bit-field fx start end) )
     451
     452(define (fxcopy-bit-field fxto start end fxfrom)
     453  (%check-fixnum 'fxcopy-bit-field fxto)
     454  (%check-bits-range 'fxcopy-bit-field start end)
     455  (%check-fixnum 'fxcopy-bit-field fxfrom)
     456  (*bitwise-copy-bit-field fxto start end fxfrom) )
     457
     458(define (fxrotate-bit-field fx start end count)
     459  (%check-fixnum 'fxrotate-bit-field fx)
     460  (%check-bits-range 'fxrotate-bit-field start end)
     461  (%check-fixnum-cardinal 'fxrotate-bit-field count)
     462  (%check-fixnum-bits-count 'fxrotate-bit-field count start end)
     463  (*bitwise-rotate-bit-field fx start end count) )
     464
     465(define (fxreverse-bit-field fx start end)
     466  (%check-fixnum 'fxreverse-bit-field fx)
     467  (%check-bits-range 'fxreverse-bit-field start end)
     468  (*bitwise-reverse-bit-field fx start end) )
     469
     470;;; Extras
     471
     472;;
     473
     474(define (fxcompare fx1 fx2)
     475  (%check-fixnum 'fxcompare fx1)
     476  (%check-fixnum 'fxcompare fx2)
     477  (cond ((%fx= fx1 fx2)   0)
     478        ((%fx< fx1 fx2)   -1)
     479        (else             1) ) )
     480
     481;;
     482
     483(define (fxabs fx)
     484  (%check-fixnum 'fxabs fx)
     485  (%fxabs fx) )
     486
     487(define (fxnegate fx)
     488  (%check-fixnum 'fxnegate fx)
     489  (%fxneg fx) )
     490
    357491(define (fxadd1 fx)
    358492  (%check-fixnum 'fxadd1 fx)
     
    362496  (%check-fixnum 'fxsub1 fx)
    363497  (%fxsub1 fx) )
     498
     499(define (fx/ fx1  fx2)
     500  (%check-fixnum 'fx/ fxn)
     501  (%check-fixnum 'fx/ fxd)
     502  (%check-zero-division 'fx/ fxn fxd)
     503  (%fx/ fxn fxd) )
    364504
    365505(define (fxquotient fxn fxd)
     
    374514  (%check-zero-division 'fxremainder fxn fxd)
    375515  (%fx- fxn (%fx* (%fx/ fxn fxd) fxd)) )
    376 
    377 (define (fxmodulo fxn fxd)
    378   (%check-fixnum 'fxmodulo fxn)
    379   (%check-fixnum 'fxmodulo fxd)
    380   (%check-zero-division 'fxmodulo fxn fxd)
    381   (%fxmod fxn fxd) )
    382 
    383 (define (fxarithmetic-shift fx amount)
    384   (%check-fixnum 'fxarithmetic-shift fx)
    385   (%check-fixnum 'fxarithmetic-shift amount)
    386   (if (%fxpositive? amount) (%fxshr fx (%fxneg amount))
    387       (%fxshl fx amount) ) )
    388 
    389 (define (fxarithmetic-shift-left fx amount)
    390   (%check-fixnum 'fxarithmetic-shift-left fx)
    391   (%check-cardinal-fixnum 'fxarithmetic-shift-left amount)
    392   (%fxshl fx amount) )
    393 
    394 (define (fxarithmetic-shift-right fx amount)
    395   (%check-fixnum 'fxarithmetic-shift-right fx)
    396   (%check-cardinal-fixnum 'fxarithmetic-shift-right amount)
    397   (%fxshr fx amount) )
    398 
    399 (define (fx- fx #!optional fx2)
    400   (%check-fixnum 'fx- fx)
    401   (if (not fx2) (%fxneg fx)
    402       (begin
    403         (%check-fixnum '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   (%check-fixnum 'fxif mask)
    416   (%check-fixnum 'fxif true)
    417   (%check-fixnum 'fxif false)
    418   (*bitwise-if mask true false) )
    419 
    420 (define (fxbit-count fx)
    421   (%check-fixnum 'fxbit-count fx)
    422   (*bitwise-bit-count fx) )
    423 
    424 (define (fxlength fx)
    425   (%check-fixnum 'fxlength fx)
    426   (*bitwise-length fx) )
    427 
    428 (define (fxfirst-bit-set fx)
    429   (%check-fixnum 'fxfirst-bit-set fx)
    430   (*bitwise-first-bit-set fx) )
    431 
    432 (define (fxlast-bit-set fx)
    433   (%check-fixnum 'fxlast-bit-set fx)
    434   (*bitwise-last-bit-set fx) )
    435 
    436 (define (fxbit-set? fx index)
    437   (%check-fixnum 'fxbit-set? fx)
    438   (%check-word-bits-range 'fxbit-set? index)
    439   (*bitwise-bit-set? fx index) )
    440 
    441 (define (fxcopy-bit fx index bit)
    442   (%check-fixnum 'fxcopy-bit fx)
    443   (%check-word-bits-range 'fxcopy-bit index)
    444   (%check-fixnum 'fxcopy-bit bit)
    445   (*bitwise-copy-bit fx index bit) )
    446 
    447 (define (fxbit-field fx start end)
    448   (%check-fixnum 'fxbit-field fx)
    449   (%check-bits-range 'fxbit-field start end)
    450   (*bitwise-bit-field fx start end) )
    451 
    452 (define (fxcopy-bit-field fxto start end fxfrom)
    453   (%check-fixnum 'fxcopy-bit-field fxto)
    454   (%check-bits-range 'fxcopy-bit-field start end)
    455   (%check-fixnum 'fxcopy-bit-field fxfrom)
    456   (*bitwise-copy-bit-field fxto start end fxfrom) )
    457 
    458 (define (fxrotate-bit-field fx start end count)
    459   (%check-fixnum 'fxrotate-bit-field fx)
    460   (%check-bits-range 'fxrotate-bit-field start end)
    461   (%check-cardinal-fixnum 'fxrotate-bit-field count)
    462   (%check-fixnum-bits-count 'fxrotate-bit-field count start end)
    463   (*bitwise-rotate-bit-field fx start end count) )
    464 
    465 (define (fxreverse-bit-field fx start end)
    466   (%check-fixnum 'fxreverse-bit-field fx)
    467   (%check-bits-range 'fxreverse-bit-field start end)
    468   (*bitwise-reverse-bit-field fx start end) )
    469 
    470 ;;; Extras
    471516
    472517;;
     
    490535                 str ) )
    491536              ((%fx= most-negative-fixnum fx)
    492                (%string-append (fx->str (%fx/ fx radix)) (fx->str (%fx- radix (%fxmod fx radix)))) )
     537               (##sys#string-append
     538                (fx->str (%fx/ fx radix))
     539                (fx->str (%fx- radix (%fxmod fx radix)))) )
    493540              (else
    494541               (let ((str (fx-digits (%fxneg fx) 1 1)))
     
    504551;;
    505552
    506 (define (fxnegate fx)
    507   (%check-fixnum 'fxnegate fx)
    508   (%fxneg fx) )
    509 
    510 ;;
    511 
    512553(define (fxif-not mask true false)
    513554  (%check-fixnum 'fxif-not mask)
     
    524565;;
    525566
    526 (define-syntax fx=?#
    527   (syntax-rules ()
    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 (define-syntax fx<?#
    536   (syntax-rules ()
    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 (define-syntax fx>?#
    545   (syntax-rules ()
    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 (define-syntax fx<=?#
    554   (syntax-rules ()
    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 (define-syntax fx>=?#
    563   (syntax-rules ()
    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 (define-syntax fx-#
    574   (syntax-rules ()
    575     ((_ ?x)
    576       (*fxneg ?x) )
    577     ((_ ?x ?y)
    578       (*fx- ?x ?y) )
    579     ((_ ?x ?y ?rest ...)
    580       (*fx- ?x (fx-# ?y ?rest ...) ) ) ) )
    581 
    582 (define-syntax fx+#
    583   (syntax-rules ()
    584     ((_ ?x)
    585       ?x )
    586     ((_ ?x ?y)
    587       (*fx+ ?x ?y) )
    588     ((_ ?x ?y ?rest ...)
    589       (*fx+ ?x (fx+# ?y ?rest ...) ) ) ) )
    590 
    591 (define-syntax fx*#
    592   (syntax-rules ()
    593     ((_ ?x)
    594       ?x )
    595     ((_ ?x ?y)
    596       (*fx* ?x ?y) )
    597     ((_ ?x ?y ?rest ...)
    598       (*fx* ?x (fx*# ?y ?rest ...) ) ) ) )
    599 
    600 (define-syntax fx/#
    601   (syntax-rules ()
    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   (%check-fixnum 'fx=?# fx)
    614   (cond ((%null? fxs)         #t)
    615         ((%null? (%cdr fxs))  (%fx= fx (%car fxs)))
    616         (else                 (%fxand-fold 'fx=?# *fx= fx fxs) ) ) )
    617 
    618 (define (fx<?# fx . fxs)
    619   (%check-fixnum 'fx<?# fx)
    620   (cond ((%null? fxs)         #t)
    621         ((%null? (%cdr fxs))  (%fx< fx (%car fxs)))
    622         (else                 (%fxand-fold 'fx<?# *fx< fx fxs) ) ) )
    623 
    624 (define (fx>?# fx . fxs)
    625   (%check-fixnum 'fx>?# fx)
    626   (cond ((%null? fxs)         #t)
    627         ((%null? (%cdr fxs))  (%fx> fx (%car fxs)))
    628         (else                 (%fxand-fold 'fx>?# *fx> fx fxs) ) ) )
    629 
    630 (define (fx<=?# fx . fxs)
    631   (%check-fixnum 'fx<=?# fx)
    632   (cond ((%null? fxs)         #t)
    633         ((%null? (%cdr fxs))  (%fx<= fx (%car fxs)))
    634         (else                 (%fxand-fold 'fx<=?# *fx<= fx fxs) ) ) )
    635 
    636 (define (fx>=?# fx . fxs)
    637   (%check-fixnum 'fx>=?# fx)
    638   (cond ((%null? fxs)         #t)
    639         ((%null? (%cdr fxs))  (%fx>= fx (%car fxs)))
    640         (else                 (%fxand-fold 'fx>=?# *fx>= fx fxs) ) ) )
    641 
    642 ;;
    643 
    644 (define (fx-# fx . fxs)
    645   (%check-fixnum 'fx-# fx)
     567(define (fx#- fx . fxs)
     568  (%check-fixnum 'fx#- fx)
    646569  (cond ((%null? fxs)         (%fxneg fx))
    647570        ((%null? (%cdr fxs))  (%fx- fx (%car fxs)))
    648         (else                 (%fxfold 'fx-# *fx- fx fxs) ) ) )
    649 
    650 (define (fx+# fx . fxs)
    651   (%check-fixnum 'fx+# fx)
     571        (else                 (%fxfold 'fx#- $fx- fx fxs) ) ) )
     572
     573(define (fx#+ fx . fxs)
     574  (%check-fixnum 'fx#+ fx)
    652575  (cond ((%null? fxs)         fx)
    653576        ((%null? (%cdr fxs))  (%fx+ fx (%car fxs)))
    654         (else                 (%fxfold 'fx+# *fx+ fx fxs) ) ) )
    655 
    656 (define (fx*# fx . fxs)
    657   (%check-fixnum 'fx*# fx)
     577        (else                 (%fxfold 'fx#+ $fx+ fx fxs) ) ) )
     578
     579(define (fx#* fx . fxs)
     580  (%check-fixnum 'fx#* fx)
    658581  (cond ((%null? fxs)         fx)
    659582        ((%null? (%cdr fxs))  (%fx* fx (%car fxs)))
    660         (else                 (%fxfold 'fx*# *fx* fx fxs) ) ) )
    661 
    662 (define (fx/# fx . fxs)
    663   (%check-fixnum 'fx/# fx)
     583        (else                 (%fxfold 'fx#* $fx* fx fxs) ) ) )
     584
     585(define (fx#/ fx . fxs)
     586  (%check-fixnum 'fx#/ fx)
    664587  (cond ((%null? fxs)         fx)
    665588        ((%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(define-syntax *fx=?
     594  (syntax-rules ()
     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(define-syntax *fx<?
     603  (syntax-rules ()
     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(define-syntax *fx>?
     612  (syntax-rules ()
     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(define-syntax *fx<=?
     621  (syntax-rules ()
     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(define-syntax *fx>=?
     630  (syntax-rules ()
     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(define-syntax *fxmax
     641  (syntax-rules ()
     642    ((_ ?x)
     643      ?x )
     644    ((_ ?x ?y)
     645      ($fxmax ?x ?y) )
     646    ((_ ?x ?y ?rest ...)
     647      ($fxmax ?x (*fxmax ?y ?rest ...)) ) ) )
     648
     649(define-syntax *fxmin
     650  (syntax-rules ()
     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(define-syntax *fxand
     661  (syntax-rules ()
     662    ((_ ?x)
     663      ?x )
     664    ((_ ?x ?y)
     665      ($fxand ?x ?y) )
     666    ((_ ?x ?y ?rest ...)
     667      ($fxand ?x (*fxand ?y ?rest ...)) ) ) )
     668
     669(define-syntax *fxior
     670  (syntax-rules ()
     671    ((_ ?x)
     672      ?x )
     673    ((_ ?x ?y)
     674      ($fxior ?x ?y) )
     675    ((_ ?x ?y ?rest ...)
     676      ($fxior ?x (*fxior ?y ?rest ...)) ) ) )
     677
     678(define-syntax *fxxor
     679  (syntax-rules ()
     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(define-syntax *fx-
     690  (syntax-rules ()
     691    ((_ ?x)
     692      ($fxneg ?x) )
     693    ((_ ?x ?y)
     694      ($fx- ?x ?y) )
     695    ((_ ?x ?y ?rest ...)
     696      ($fx- ?x (*fx- ?y ?rest ...) ) ) ) )
     697
     698(define-syntax *fx+
     699  (syntax-rules ()
     700    ((_ ?x)
     701      ?x )
     702    ((_ ?x ?y)
     703      ($fx+ ?x ?y) )
     704    ((_ ?x ?y ?rest ...)
     705      ($fx+ ?x (*fx+ ?y ?rest ...) ) ) ) )
     706
     707(define-syntax *fx*
     708  (syntax-rules ()
     709    ((_ ?x)
     710      ?x )
     711    ((_ ?x ?y)
     712      ($fx* ?x ?y) )
     713    ((_ ?x ?y ?rest ...)
     714      ($fx* ?x (*fx* ?y ?rest ...) ) ) ) )
     715
     716(define-syntax *fx/
     717  (syntax-rules ()
     718    ((_ ?x)
     719      ?x )
     720    ((_ ?x ?y)
     721      ($fx/ ?x ?y) )
     722    ((_ ?x ?y ?rest ...)
     723      ($fx/ ?x (*fx/ ?y ?rest ...) ) ) ) )
    668724
    669725) ;module err5rs-arithmetic-fixnums
Note: See TracChangeset for help on using the changeset viewer.