Changeset 14031 in project


Ignore:
Timestamp:
04/01/09 05:52:00 (11 years ago)
Author:
Kon Lovett
Message:

Update inlines. Testing.

Location:
release/4/err5rs-arithmetic/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/trunk/chicken-primitive-object-inlines.scm

    r14016 r14031  
    671671                 (find-elm (%cdr ls) ls) ) ) ) )
    672672
    673 (define-inline (%list-fold-1 func init ls0)
     673(define-inline (%list-fold/1 func init ls0)
    674674  ;(assert (and (proper-list? ls0) (procedure? func)))
    675675  (let loop ((ls ls0) (acc init))
     
    677677        (loop (%cdr ls) (func (%car ls) acc)) ) ) )
    678678
    679 (define-inline (%list-map-1 func ls0)
     679(define-inline (%list-map/1 func ls0)
    680680  ;(assert (and (proper-list? ls0) (procedure? func)))
    681681  (let loop ((ls ls0))
     
    683683        (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
    684684
    685 (define-inline (%list-for-each-1 proc ls0)
     685(define-inline (%list-for-each/1 proc ls0)
    686686  ;(assert (and (proper-list? ls0) (procedure? proc)))
    687687  (let loop ((ls ls0))
     
    689689      (proc (%car ls))
    690690      (loop (%cdr ls)) ) ) )
     691
     692(define-inline (%make-list n e)
     693  (let loop ((n n) (ls '()))
     694    (if (%fxzero? n) ls
     695        (loop (%fxsub1 n) (%cons e ls)) ) ) )
     696
     697(define-inline (%list-take ls0 n)
     698  (let loop ((ls ls0) (n n))
     699    (if (%fxzero? n) '()
     700        (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
     701
     702(define-inline (%list-drop ls0 n)
     703  (let loop ((ls ls0) (n n))
     704    (if (%fxzero? n) ls
     705        (loop (%cdr ls) (%fxsub1 n)) ) ) )
    691706
    692707;; Structure (wordblock)
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm

    r14025 r14031  
    109109
    110110/* - low bit set */
    111 #define C_UWORD_LOG2_FACTORS( n )   (C_uword_log2( (n) & - (n) ) - 1)
     111#define C_UWORD_LOG2_FACTORS( n )   (C_uword_log2( (n) & -(n) ) - 1)
    112112
    113113/* Number of 1 bits */
     
    118118        #define MASK( c )      (((C_uword) (-1)) / (TWO( TWO( c ) ) + 1u))
    119119        #define COUNT( x, c )  ((x) & MASK( c )) + (((x) >> (TWO( c ))) & MASK( c ))
     120
     121  if (0 == n) return 0;
    120122
    121123        n = COUNT( n, 0 );
     
    219221
    220222    (define-inline (%check-fixnum-bits-count loc count start end)
    221       (unless (%fx< (%fxabs count) (%fx- end start)) (error-bits-count loc count start end)) ) ) )
     223      (unless (%fx< (%fxabs count) (%fx- end start))
     224        (error-bits-count loc count start end)) ) ) )
    222225
    223226;;
     
    260263  bitwise-list->integer bitwise-integer->list
    261264  bitwise-arithmetic-shift bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
    262   ;; Chicken Originals
     265  ;; Originals
    263266  chicken:bitwise-not chicken:bitwise-and chicken:bitwise-ior chicken:bitwise-xor
    264267  ;; Extras
     
    292295          (bitwise-xor chicken:bitwise-xor)
    293296          (bitwise-not chicken:bitwise-not))
    294         foreign srfi-1 int-limits)
    295 
    296 (require-library srfi-1 int-limits)
     297        foreign
     298        (only int-limits machine-word-bits machine-word-precision))
     299
     300(require-library int-limits)
    297301
    298302;;; Errors
     
    349353
    350354(define *bitwise-bit-count
     355  (foreign-lambda* unsigned-int ((unsigned-integer n))
     356   "return( 0 <= ((C_word) n) ? C_uword_bits( n ) : C_uword_bits( ~((C_word) n) ) );"))
     357
     358#;
     359(define *bitwise-bit-count
     360  (foreign-lambda* unsigned-int ((unsigned-integer n))
     361   "return( 0 <= ((C_word) n) ? C_uword_bits( n ) : ~((C_word) C_uword_bits( ~((C_word) n) )) );"))
     362
     363#;
     364(define *bitwise-bit-count
    351365  (foreign-lambda unsigned-int "C_uword_bits" unsigned-integer))
    352366
    353367(define *bitwise-length
    354368  (foreign-lambda* unsigned-int ((unsigned-integer n))
    355    "return( C_uword_log2( ((C_word) n) < 0 ? ~n : n ) );"))
     369   "return( 0 <= ((C_word) n) ? C_uword_log2( n ) : C_uword_log2( ~((C_word) n) ) );"))
     370
     371#;
     372(define *bitwise-length
     373  (foreign-lambda unsigned-int "C_uword_log2" unsigned-integer))
     374
    356375
    357376(define *bitwise-first-bit-set
     
    409428; returns (list lsb .. msb)
    410429(define *bitwise-integer->list
    411   (let ((zeros (make-list machine-word-bits #f)))
     430  (let ((zeros (%make-list machine-word-bits #f)))
    412431    (lambda (n #!optional bitlen)
    413       (if (%zero? n) (if bitlen (take zeros bitlen) zeros)
     432      (if (%zero? n) (if bitlen (%list-take zeros bitlen) zeros)
    414433          (let ((bitlen (or bitlen (*bitwise-length n))))
    415434            (let loop ((i 0) (ils '()))
     
    431450(define *bitwise-last-bit-set
    432451  (foreign-lambda* unsigned-int ((unsigned-integer n))
    433    "return( C_uword_log2( n ) - 1);"))
     452   "return( 0 == n ? 0 : (C_uword_log2( n ) - 1) );"))
    434453
    435454(define *pow2log2
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r14025 r14031  
    147147;; Arithmetic
    148148
     149(define-inline (%fx/int fxn fxd)
     150  (let ((div (%fx/ fxn fxd)))
     151    (cond ((%fxnegative? fxn)
     152           (if (%fxnegative? fxd) (%fxadd1 div)
     153               (%fxsub1 div) ) )
     154          ((%fxnegative? fxd)
     155           (if (%fxnegative? fxn) (%fxadd1 div)
     156               div ) )
     157          (else div ) ) ) )
     158
    149159(define-inline (%fx/check loc fxn fxd)
    150160  (%check-fixnum loc fxn)
     
    152162  (%check-zero-division loc fxn fxd)
    153163  (when (invalid-division? fxn fxd) (error-fixnum-representation loc fxn fxd))
    154   (%fx/ fxn fxd) )
     164  (%fx/int fxn fxd) )
    155165
    156166(define-inline (%fxmod-divisor fxd)
     
    158168           (%fxneg fxd))
    159169      fxd) )
     170
     171;FIXME
     172(define-inline (%fxmod/int fxn fxd)
     173  (%fxmod fxn (%fxmod-divisor fxd)) )
    160174
    161175(define-inline (%fxdiv0 fxn fxd)
     
    210224(define-inline (%fxshl/check loc fx amt)
    211225  (if (%fxzero? amt) fx
     226      (%fxshl fx amt)
     227      #; ;invariant broken
    212228      (let ((bits (%fx+ (*bitwise-last-bit-set fx) amt)))
    213229        (cond ((%fx<= bits fixnum-precision) (%fxshl fx amt))
     
    217233(define-inline (%fxshr/check loc fx amt)
    218234  (if (%fxzero? amt) fx
     235      (%fxshr fx amt)
     236      #; ;invariant broken
    219237      (let ((bits (%fx- (*bitwise-last-bit-set fx) amt)))
    220238        (cond ((%fx>= bits 0) (%fxshr fx amt))
     
    287305          (fx/ chicken:fx/)
    288306          (fxmod chicken:fxmod))
     307        foreign
    289308        data-structures
    290         foreign
    291         err5rs-arithmetic-bitwise)
     309        (only err5rs-arithmetic-bitwise
     310          *bitwise-if *bitwise-if-not
     311          *bitwise-bit-count *bitwise-length
     312          *bitwise-first-bit-set *bitwise-last-bit-set
     313          *bitwise-bit-set? *bitwise-copy-bit
     314          *bitwise-bit-field *bitwise-copy-bit-field
     315          *bitwise-rotate-bit-field *bitwise-reverse-bit-field
     316          *pow2log2))
    292317
    293318(require-library data-structures err5rs-arithmetic-bitwise)
     
    545570  (%check-fixnum 'fxmod fxd)
    546571  (%check-zero-division 'fxmod fxn fxd)
    547   (%fxmod fxn (%fxmod-divisor fxd)) )
     572  (%fxmod/int fxn fxd) )
    548573
    549574(define (fxdiv-and-mod fxn fxd)
     
    552577  (%check-zero-division 'fxdiv fxn fxd)
    553578  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxdiv-and-mod fxn fxd))
    554   (values (%fx/ fxn fxd) (%fxmod fxn (%fxmod-divisor fxd))) )
     579  (values (%fx/int fxn fxd) (%fxmod/int fxn fxd)) )
    555580
    556581;;
     
    778803(define-syntax $fx=?
    779804  (syntax-rules ()
    780     ((_ ?x)
    781       #t )
    782     ((_ ?x ?y)
    783       (-fx= ?x ?y) )
    784     ((_ ?x ?y ?rest ...)
    785       (and (-fx= ?x ?y) ($fx=? ?y ?rest ...)) ) ) )
     805    ((_ ?x)               #t )
     806    ((_ ?x ?y)            (-fx= ?x ?y) )
     807    ((_ ?x ?y ?rest ...)        (and (-fx= ?x ?y) ($fx=? ?y ?rest ...)) ) ) )
    786808
    787809(define-syntax $fx<?
    788810  (syntax-rules ()
    789     ((_ ?x)
    790       #t )
    791     ((_ ?x ?y)
    792       (-fx< ?x ?y) )
    793     ((_ ?x ?y ?rest ...)
    794       (and (-fx< ?x ?y) ($fx<? ?y ?rest ...)) ) ) )
     811    ((_ ?x)                                                             #t )
     812    ((_ ?x ?y)                                          (-fx< ?x ?y) )
     813    ((_ ?x ?y ?rest ...)        (and (-fx< ?x ?y) ($fx<? ?y ?rest ...)) ) ) )
    795814
    796815(define-syntax $fx>?
    797816  (syntax-rules ()
    798     ((_ ?x)
    799       #t )
    800     ((_ ?x ?y)
    801       (-fx> ?x ?y) )
    802     ((_ ?x ?y ?rest ...)
    803       (and (-fx> ?x ?y) ($fx>? ?y ?rest ...)) ) ) )
     817    ((_ ?x)                                                             #t )
     818    ((_ ?x ?y)                                          (-fx> ?x ?y) )
     819    ((_ ?x ?y ?rest ...)        (and (-fx> ?x ?y) ($fx>? ?y ?rest ...)) ) ) )
    804820
    805821(define-syntax $fx<=?
    806822  (syntax-rules ()
    807     ((_ ?x)
    808       #t )
    809     ((_ ?x ?y)
    810       (-fx<= ?x ?y) )
    811     ((_ ?x ?y ?rest ...)
    812       (and (-fx<= ?x ?y) ($fx<=? ?y ?rest ...)) ) ) )
     823    ((_ ?x)                                                             #t )
     824    ((_ ?x ?y)                                          (-fx<= ?x ?y) )
     825    ((_ ?x ?y ?rest ...)        (and (-fx<= ?x ?y) ($fx<=? ?y ?rest ...)) ) ) )
    813826
    814827(define-syntax $fx>=?
    815828  (syntax-rules ()
    816     ((_ ?x)
    817       #t )
    818     ((_ ?x ?y)
    819       (-fx>= ?x ?y) )
    820     ((_ ?x ?y ?rest ...)
    821       (and (-fx>= ?x ?y) ($fx>=? ?y ?rest ...)) ) ) )
     829    ((_ ?x)                                                             #t )
     830    ((_ ?x ?y)                                          (-fx>= ?x ?y) )
     831    ((_ ?x ?y ?rest ...)        (and (-fx>= ?x ?y) ($fx>=? ?y ?rest ...)) ) ) )
    822832
    823833(define-syntax $fx<>?
    824834  (syntax-rules ()
    825     ((_ ?x)
    826       #f )
    827     ((_ ?x ?y)
    828       (-fx<> ?x ?y) )
    829     ((_ ?x ?y ?rest ...)
    830       (and (-fx<> ?x ?y) ($fx<>? ?y ?rest ...)) ) ) )
     835    ((_ ?x)                                                             #f )
     836    ((_ ?x ?y)                                          (-fx<> ?x ?y) )
     837    ((_ ?x ?y ?rest ...)        (and (-fx<> ?x ?y) ($fx<>? ?y ?rest ...)) ) ) )
    831838
    832839;;
     
    834841(define-syntax $fxmax
    835842  (syntax-rules ()
    836     ((_ ?x)
    837       ?x )
    838     ((_ ?x ?y)
    839       (-fxmax ?x ?y) )
    840     ((_ ?x ?y ?rest ...)
    841       (-fxmax ?x ($fxmax ?y ?rest ...)) ) ) )
     843    ((_ ?x)                                                             ?x )
     844    ((_ ?x ?y)                                          (-fxmax ?x ?y) )
     845    ((_ ?x ?y ?rest ...)        (-fxmax ?x ($fxmax ?y ?rest ...)) ) ) )
    842846
    843847(define-syntax $fxmin
    844848  (syntax-rules ()
    845     ((_ ?x)
    846       ?x )
    847     ((_ ?x ?y)
    848       (-fxmin ?x ?y) )
    849     ((_ ?x ?y ?rest ...)
    850       (-fxmin ?x ($fxmin ?y ?rest ...)) ) ) )
     849    ((_ ?x)                                                             ?x )
     850    ((_ ?x ?y)                                          (-fxmin ?x ?y) )
     851    ((_ ?x ?y ?rest ...)        (-fxmin ?x ($fxmin ?y ?rest ...)) ) ) )
    851852
    852853;;
     
    854855(define-syntax $fxand
    855856  (syntax-rules ()
    856     ((_ ?x)
    857       ?x )
    858     ((_ ?x ?y)
    859       (-fxand ?x ?y) )
    860     ((_ ?x ?y ?rest ...)
    861       (-fxand ?x ($fxand ?y ?rest ...)) ) ) )
     857    ((_ ?x)                                                             ?x )
     858    ((_ ?x ?y)                                          (-fxand ?x ?y) )
     859    ((_ ?x ?y ?rest ...)        (-fxand ?x ($fxand ?y ?rest ...)) ) ) )
    862860
    863861(define-syntax $fxior
    864862  (syntax-rules ()
    865     ((_ ?x)
    866       ?x )
    867     ((_ ?x ?y)
    868       (-fxior ?x ?y) )
    869     ((_ ?x ?y ?rest ...)
    870       (-fxior ?x ($fxior ?y ?rest ...)) ) ) )
     863    ((_ ?x)                                                             ?x )
     864    ((_ ?x ?y)                                          (-fxior ?x ?y) )
     865    ((_ ?x ?y ?rest ...)        (-fxior ?x ($fxior ?y ?rest ...)) ) ) )
    871866
    872867(define-syntax $fxxor
    873868  (syntax-rules ()
    874     ((_ ?x)
    875       ?x )
    876     ((_ ?x ?y)
    877       (-fxxor ?x ?y) )
    878     ((_ ?x ?y ?rest ...)
    879       (-fxxor ?x ($fxxor ?y ?rest ...)) ) ) )
     869    ((_ ?x)                                                             ?x )
     870    ((_ ?x ?y)                                          (-fxxor ?x ?y) )
     871    ((_ ?x ?y ?rest ...)        (-fxxor ?x ($fxxor ?y ?rest ...)) ) ) )
    880872
    881873;;
     
    883875(define-syntax $fx-
    884876  (syntax-rules ()
    885     ((_ ?x)
    886       (-fx- ?x) )
    887     ((_ ?x ?y)
    888       (-fx- ?x ?y) )
    889     ((_ ?x ?y ?rest ...)
    890       (-fx- ?x ($fx- ?y ?rest ...) ) ) ) )
     877    ((_ ?x)                                                             (-fx- ?x) )
     878    ((_ ?x ?y)                                          (-fx- ?x ?y) )
     879    ((_ ?x ?y ?rest ...)        (-fx- ?x ($fx- ?y ?rest ...) ) ) ) )
    891880
    892881(define-syntax $fx+
    893882  (syntax-rules ()
    894     ((_ ?x)
    895       ?x )
    896     ((_ ?x ?y)
    897       (-fx+ ?x ?y) )
    898     ((_ ?x ?y ?rest ...)
    899       (-fx+ ?x ($fx+ ?y ?rest ...) ) ) ) )
     883    ((_ ?x)                                                             ?x )
     884    ((_ ?x ?y)                                          (-fx+ ?x ?y) )
     885    ((_ ?x ?y ?rest ...)        (-fx+ ?x ($fx+ ?y ?rest ...) ) ) ) )
    900886
    901887(define-syntax $fx*
    902888  (syntax-rules ()
    903     ((_ ?x)
    904       ?x )
    905     ((_ ?x ?y)
    906       (-fx* ?x ?y) )
    907     ((_ ?x ?y ?rest ...)
    908       (-fx* ?x ($fx* ?y ?rest ...) ) ) ) )
     889    ((_ ?x)                                                             ?x )
     890    ((_ ?x ?y)                                          (-fx* ?x ?y) )
     891    ((_ ?x ?y ?rest ...)        (-fx* ?x ($fx* ?y ?rest ...) ) ) ) )
    909892
    910893(define-syntax $fx/
    911894  (syntax-rules ()
    912     ((_ ?x)
    913       ?x )
    914     ((_ ?x ?y)
    915       (-fx/ ?x ?y) )
    916     ((_ ?x ?y ?rest ...)
    917       (-fx/ ?x ($fx/ ?y ?rest ...) ) ) ) )
     895    ((_ ?x)                                                             ?x )
     896    ((_ ?x ?y)                                          (-fx/ ?x ?y) )
     897    ((_ ?x ?y ?rest ...)        (-fx/ ?x ($fx/ ?y ?rest ...) ) ) ) )
    918898
    919899) ;module err5rs-arithmetic-fixnums
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r14025 r14031  
    2424(include "chicken-primitive-object-inlines")
    2525
    26 (include "mathh-constants")
     26#;(include "mathh-constants")
    2727
    2828;;
     
    7676;;
    7777
    78 (define-inline (%fpposzero? fp) (and (%fp=? 0.0 fp) (not (signbit fp))))
    79 (define-inline (%fpnegzero? fp) (and (%fp=? -0.0 fp) (signbit fp)))
    80 (define-inline (%fpzero? fp) (%fp= 0.0 fp) #;(or (%fpnegzero? fp) (%fpposzero? fp)))
     78(define-inline (%fpposzero? fp) (and (%fp= 0.0 fp) (not (signbit fp))))
     79(define-inline (%fpnegzero? fp) (and (%fp= -0.0 fp) (signbit fp)))
     80
     81(define-inline (%fpzero? fp) (%fp= 0.0 fp))
     82
    8183(define-inline (%fppositive? fp) (%fp< 0.0 fp))
    8284(define-inline (%fpnegative? fp) (%fp> 0.0 fp))
    8385
    84 (define-inline (%fpdiv fpn fpd) (%fpfloor (%fp/ fpn fpd)))
    85 (define-inline (%fpmod fpn fpd) (%fp- fpn (%fp* (%fpdiv fpn fpd) fpd)))
     86(define-inline (%fpadd1 fp) (%fp+ fp 1.0))
     87(define-inline (%fpsub1 fp) (%fp- fp 1.0))
     88
     89(define-inline (%fpdiv fpn fpd)
     90  (let ((div (%fp/ fpn fpd)))
     91    (if (%fpnegative? fpd) (%fpceiling div)
     92        (%fpfloor div) ) ) )
     93
     94(define-inline (%fpmod/quo quo fpn fpd) (%fp- fpn (%fp* quo fpd)))
     95
     96(define-inline (%fpmod fpn fpd) (%fpmod/quo (%fpdiv fpn fpd) fpn fpd))
    8697
    8798(define-inline (%fpdiv-and-mod  fpn fpd)
    8899  (let ((quo (%fpdiv fpn fpd)))
    89     (values quo (%fp- fpn (%fp* quo fpd))) ) )
     100    (values quo (%fpmod/quo quo fpn fpd)) ) )
    90101
    91102(define-inline (%fpinteger? obj) (and (%flonum? obj) (%integer? obj)))
     
    93104(define-inline (%fpnan? fp) (not (%fp= fp fp)))
    94105
    95 (define-inline (%fp=? x y) (%fp= x y)) ;unnecessary but symmetrical
     106(define-inline (%fp=? x y)
     107  (cond ((%fpnegzero? x) (%fpnegzero? y))
     108        ((%fpzero? x) (%fpposzero? y))
     109        (else (%fp= x y) ) ) )
    96110
    97111(define-inline (%fp<? x y)
    98   (and (not (and (%fp= 0.0 x) (%fpnegzero? y)))
    99        (or (and (%fpnegzero? x) (%fp= 0.0 y))
     112  (and (not (and (%fpzero? x) (%fpnegzero? y)))
     113       (or (and (%fpnegzero? x) (%fpzero? y))
    100114           (%fp< x y) ) ) )
    101115
    102116(define-inline (%fp<=? x y)
    103   (and (not (and (%fp= 0.0 x) (%fpnegzero? y)))
    104        (or (and (%fpnegzero? x) (%fp= 0.0 y))
     117  (and (not (and (%fpzero? x) (%fpnegzero? y)))
     118       (or (and (%fpnegzero? x) (%fpzero? y))
    105119           (%fp<= x y) ) ) )
    106120
    107121(define-inline (%fp>? x y)
    108   (and (not (and (%fpnegzero? x) (%fp= 0.0 y)))
    109        (or (and (%fp= 0.0 x) (%fpnegzero? y))
     122  (and (not (and (%fpnegzero? x) (%fpzero? y)))
     123       (or (and (%fpzero? x) (%fpnegzero? y))
    110124           (%fp> x y) ) ) )
    111125
    112126(define-inline (%fp>=? x y)
    113   (and (not (and (%fpnegzero? x) (%fp= 0.0 y)))
    114        (or (and (%fp= 0.0 x) (%fpnegzero? y))
     127  (and (not (and (%fpnegzero? x) (%fpzero? y)))
     128       (or (and (%fpzero? x) (%fpnegzero? y))
    115129           (%fp>= x y) ) ) )
    116 
    117 (define-inline (%fpdiv0-and-mod0 fpn fpd)
    118   (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
    119     (cond ((%fp<=? 0.0 fpd)
    120            (if (%fp<? rem (%fp/ fpd 2.0))
    121                (if (%fp<=? (%fp/ fpd -2.0) rem) (values quo rem)
    122                    (values (%fp- quo 1.0) (%fp+ rem fpd)) )
    123                (values (%fp+ quo 1.0) (%fp- rem fpd)) ) )
    124           ((%fp<? rem (%fp/ fpd -2.0))
    125            (if (%fp<=? (%fp/ fpd 2.0) rem) (values quo rem)
    126                (values (%fp+ quo 1.0) (%fp- rem fpd)) ) )
    127           (else
    128            (values (%fp- quo 1.0) (%fp+ rem fpd)) ) ) ) )
    129130
    130131(define-inline (%fpdiv0 fpn fpd)
    131132  (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
    132133    (cond ((%fp<=? 0.0 fpd)
    133            (if (%fp<? rem (%fp/ fpd 2.0))
     134           (if (%fp>=? rem (%fp/ fpd 2.0)) (%fpadd1 quo)
    134135               (if (%fp<=? (%fp/ fpd -2.0) rem) quo
    135                    (%fp- quo 1.0) )
    136                (%fp+ quo 1.0) ) )
     136                   (%fpsub1 quo) ) ) )
    137137          ((%fp<? rem (%fp/ fpd -2.0))
    138138           (if (%fp<=? (%fp/ fpd 2.0) rem) quo
    139                (%fp+ quo 1.0) ) )
     139               (%fpadd1 quo) ) )
    140140          (else
    141            (%fp- quo 1.0) ) ) ) )
     141           (%fpsub1 quo) ) ) ) )
    142142
    143143(define-inline (%fpmod0 fpn fpd)
    144144  (let ((rem (%fpmod fpn fpd)))
    145145    (cond ((%fp<=? 0.0 fpd)
    146            (if (%fp<? rem (%fp/ fpd 2.0))
     146           (if (%fp>=? rem (%fp/ fpd 2.0)) (%fp- rem fpd)
    147147               (if (%fp<=? (%fp/ fpd -2.0) rem) rem
    148                    (%fp+ rem fpd) )
    149                (%fp- rem fpd) ) )
     148                   (%fp+ rem fpd) ) ) )
    150149          ((%fp<? rem (%fp/ fpd -2.0))
    151150           (if (%fp<=? (%fp/ fpd 2.0) rem) rem
     
    153152          (else
    154153           (%fp+ rem fpd) ) ) ) )
     154
     155(define-inline (%fpdiv0-and-mod0 fpn fpd)
     156  (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
     157    (cond ((%fp<=? 0.0 fpd)
     158           (if (%fp>=? rem (%fp/ fpd 2.0)) (values (%fpadd1 quo) (%fp- rem fpd))
     159               (if (%fp<=? (%fp/ fpd -2.0) rem) (values quo rem)
     160                   (values (%fpsub1 quo) (%fp+ rem fpd)) ) ) )
     161          ((%fp<? rem (%fp/ fpd -2.0))
     162           (if (%fp<=? (%fp/ fpd 2.0) rem) (values quo rem)
     163               (values (%fpadd1 quo) (%fp- rem fpd)) ) )
     164          (else
     165           (values (%fpsub1 quo) (%fp+ rem fpd)) ) ) ) )
    155166
    156167;;;
     
    403414(define (flodd? fp)
    404415  (%check-flonum 'flodd? fp)
    405   (not (%fp=? 0.0 (%fpmod fp 2.0))) )
     416  (not (%fpzero? (%fpmod fp 2.0))) )
    406417
    407418(define (fleven? fp)
    408419  (%check-flonum 'fleven? fp)
    409   (%fp=? 0.0 (%fpmod fp 2.0)) )
     420  (%fpzero? (%fpmod fp 2.0)) )
    410421
    411422(define (flfinite? fp)
     
    527538  (%fpacos fp) )
    528539 
    529 (define -PI (%fpnegate PI))
    530 (define -PI/2 (%fpnegate PI/2))
    531 
    532540(define (flatan fp #!optional fpd)
     541  #;(define -PI (%fpnegate PI))
     542  #;(define -PI/2 (%fpnegate PI/2))
    533543  (%check-flonum 'flatan fp)
    534544  (cond (fpd
    535545         (%check-flonum 'flatan fpd)
     546         (%fpatan2 fp fpd)
     547         #; ;Per R6RS spec but not test suite
    536548         (cond ((%fpnegzero? fpd)
    537549                (cond ((%fppositive? fp) -0.0)
     
    607619  (%check-flonum 'flcompare fl1)
    608620  (%check-flonum 'flcompare fl2)
    609         (cond ((%fp=? fl1 fl2)
    610                (cond ((%fpnegzero? fl1)
    611                       (if (%fpnegzero? fl1) 0 1) )
    612                ((%fpnegzero? fl2)
    613                 (if (%fp=? 0.0 fl1) -1 0) )
    614                      (else
    615                       0 ) ) )
    616               ((%fp<? fl1 fl2)
    617                -1 )
    618               (else
    619                1 ) ) )
     621        (cond ((%fp=? fl1 fl2)  0)
     622              ((%fp<? fl1 fl2)  -1)
     623              (else             1) ) )
    620624
    621625(define (flfraction fp)
     
    631635(define-syntax $fl=?
    632636  (syntax-rules ()
    633     ((_ ?x)
    634       #t )
    635     ((_ ?x ?y)
    636       (-fp=? ?x ?y) )
    637     ((_ ?x ?y ?rest ...)
    638       (and (-fp=? ?x ?y) ($fl=? ?y ?rest ...)) ) ) )
     637    ((_ ?x)               #t )
     638    ((_ ?x ?y)            (-fp=? ?x ?y) )
     639    ((_ ?x ?y ?rest ...)  (and (-fp=? ?x ?y) ($fl=? ?y ?rest ...)) ) ) )
    639640
    640641(define-syntax $fl<?
    641642  (syntax-rules ()
    642     ((_ ?x)
    643       #t )
    644     ((_ ?x ?y)
    645       (-fp<? ?x ?y) )
    646     ((_ ?x ?y ?rest ...)
    647       (and (-fp<? ?x ?y) ($fl<? ?y ?rest ...)) ) ) )
     643    ((_ ?x)               #t )
     644    ((_ ?x ?y)            (-fp<? ?x ?y) )
     645    ((_ ?x ?y ?rest ...)  (and (-fp<? ?x ?y) ($fl<? ?y ?rest ...)) ) ) )
    648646
    649647(define-syntax $fl>?
    650648  (syntax-rules ()
    651     ((_ ?x)
    652       #t )
    653     ((_ ?x ?y)
    654       (-fp>? ?x ?y) )
    655     ((_ ?x ?y ?rest ...)
    656       (and (-fp>? ?x ?y) ($fl>? ?y ?rest ...)) ) ) )
     649    ((_ ?x)               #t )
     650    ((_ ?x ?y)            (-fp>? ?x ?y) )
     651    ((_ ?x ?y ?rest ...)  (and (-fp>? ?x ?y) ($fl>? ?y ?rest ...)) ) ) )
    657652
    658653(define-syntax $fl<=?
    659654  (syntax-rules ()
    660     ((_ ?x)
    661       #t )
    662     ((_ ?x ?y)
    663       (-fp<=? ?x ?y) )
    664     ((_ ?x ?y ?rest ...)
    665       (and (-fp<=? ?x ?y) ($fl<=? ?y ?rest ...)) ) ) )
     655    ((_ ?x)               #t )
     656    ((_ ?x ?y)            (-fp<=? ?x ?y) )
     657    ((_ ?x ?y ?rest ...)  (and (-fp<=? ?x ?y) ($fl<=? ?y ?rest ...)) ) ) )
    666658
    667659(define-syntax $fl>=?
    668660  (syntax-rules ()
    669     ((_ ?x)
    670       #t )
    671     ((_ ?x ?y)
    672       (-fp>=? ?x ?y) )
    673     ((_ ?x ?y ?rest ...)
    674       (and (-fp>=? ?x ?y) ($fl>=? ?y ?rest ...)) ) ) )
     661    ((_ ?x)               #t )
     662    ((_ ?x ?y)            (-fp>=? ?x ?y) )
     663    ((_ ?x ?y ?rest ...)  (and (-fp>=? ?x ?y) ($fl>=? ?y ?rest ...)) ) ) )
    675664
    676665(define-syntax $fl<>?
    677666  (syntax-rules ()
    678     ((_ ?x)
    679       #f )
    680     ((_ ?x ?y)
    681       (-fp<>? ?x ?y) )
    682     ((_ ?x ?y ?rest ...)
    683       (and (-fp<>? ?x ?y) ($fl<>? ?y ?rest ...)) ) ) )
     667    ((_ ?x)               #f )
     668    ((_ ?x ?y)            (-fp<>? ?x ?y) )
     669    ((_ ?x ?y ?rest ...)  (and (-fp<>? ?x ?y) ($fl<>? ?y ?rest ...)) ) ) )
    684670
    685671;;
     
    687673(define-syntax $flmax
    688674  (syntax-rules ()
    689     ((_ ?x)
    690       ?x )
    691     ((_ ?x ?y)
    692       (-fpmax ?x ?y) )
    693     ((_ ?x ?y ?rest ...)
    694       (-fpmax ?x ($flmax ?y ?rest ...)) ) ) )
     675    ((_ ?x)               ?x )
     676    ((_ ?x ?y)            (-fpmax ?x ?y) )
     677    ((_ ?x ?y ?rest ...)  (-fpmax ?x ($flmax ?y ?rest ...)) ) ) )
    695678
    696679(define-syntax $flmin
    697680  (syntax-rules ()
    698     ((_ ?x)
    699       ?x )
    700     ((_ ?x ?y)
    701       (-fpmin ?x ?y) )
    702     ((_ ?x ?y ?rest ...)
    703       (-fpmin ?x ($flmin ?y ?rest ...)) ) ) )
     681    ((_ ?x)               ?x )
     682    ((_ ?x ?y)            (-fpmin ?x ?y) )
     683    ((_ ?x ?y ?rest ...)  (-fpmin ?x ($flmin ?y ?rest ...)) ) ) )
    704684
    705685;;
     
    707687(define-syntax $fl-
    708688  (syntax-rules ()
    709     ((_ ?x)
    710       (-fpneg ?x) )
    711     ((_ ?x ?y)
    712       (-fp- ?x ?y) )
    713     ((_ ?x ?y ?rest ...)
    714       (-fp- ?x ($fl- ?y ?rest ...) ) ) ) )
     689    ((_ ?x)               (-fpneg ?x) )
     690    ((_ ?x ?y)            (-fp- ?x ?y) )
     691    ((_ ?x ?y ?rest ...)  (-fp- ?x ($fl- ?y ?rest ...) ) ) ) )
    715692
    716693(define-syntax $fl+
    717694  (syntax-rules ()
    718     ((_ ?x)
    719       ?x )
    720     ((_ ?x ?y)
    721       (-fp+ ?x ?y) )
    722     ((_ ?x ?y ?rest ...)
    723       (-fp+ ?x ($fl+ ?y ?rest ...) ) ) ) )
     695    ((_ ?x)               ?x )
     696    ((_ ?x ?y)            (-fp+ ?x ?y) )
     697    ((_ ?x ?y ?rest ...)  (-fp+ ?x ($fl+ ?y ?rest ...) ) ) ) )
    724698
    725699(define-syntax $fl*
    726700  (syntax-rules ()
    727     ((_ ?x)
    728       ?x )
    729     ((_ ?x ?y)
    730       (-fp* ?x ?y) )
    731     ((_ ?x ?y ?rest ...)
    732       (-fp* ?x ($fl* ?y ?rest ...) ) ) ) )
     701    ((_ ?x)               ?x )
     702    ((_ ?x ?y)            (-fp* ?x ?y) )
     703    ((_ ?x ?y ?rest ...)  (-fp* ?x ($fl* ?y ?rest ...) ) ) ) )
    733704
    734705(define-syntax $fl/
    735706  (syntax-rules ()
    736     ((_ ?x)
    737       ?x )
    738     ((_ ?x ?y)
    739       (-fp/ ?x ?y) )
    740     ((_ ?x ?y ?rest ...)
    741       (-fp/ ?x ($fl/ ?y ?rest ...) ) ) ) )
     707    ((_ ?x)               ?x )
     708    ((_ ?x ?y)            (-fp/ ?x ?y) )
     709    ((_ ?x ?y ?rest ...)  (-fp/ ?x ($fl/ ?y ?rest ...) ) ) ) )
    742710
    743711) ;module err5rs-arithmetic-flonums
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r14025 r14031  
    11;;;; err5rs-arithmetic-test
    22
    3 (require-extension test int-limits)
    4 (require-extension err5rs-arithmetic-fixnums err5rs-arithmetic-flonums err5rs-arithmetic-bitwise)
     3(require-extension srfi-1 test int-limits)
     4(require-extension err5rs-arithmetic-bitwise err5rs-arithmetic-fixnums err5rs-arithmetic-flonums)
    55
    66;;
     
    1010         (rem (- n (* quo d))))
    1111    (cond ((<= 0 d)
    12            (if (< (* rem 2) d)
     12           (if (>= (* rem 2) d) (+ quo 1)
    1313               (if (<= (* rem -2) d) quo
    14                    (- quo 1) )
    15                (+ quo 1) ) )
     14                   (- quo 1) ) ) )
    1615          ((< d (* rem -2))
    1716           (if (<= d (* rem 2)) quo
     
    2423         (rem (- n (* quo d))))
    2524    (cond ((<= 0 d)
    26            (if (< (* rem 2) d)
     25           (if (>= (* rem 2) d) (- rem d)
    2726               (if (<= (* rem -2) d) rem
    28                    (+ rem d) )
    29                (- rem d) ) )
     27                   (+ rem d) ) ) )
    3028          ((< d (* rem -2))
    3129           (if (<= d (* rem 2)) rem
     
    809807
    810808    (test 0 (bitwise-last-bit-set 0))
    811     (test 8 (bitwise-last-bit-set #b10111100))
    812     (test (sub1 machine-word-bits) (bitwise-last-bit-set -1))
     809    (test 7 (bitwise-last-bit-set #b10111100))
     810    (test machine-word-precision (bitwise-last-bit-set -1))
    813811
    814812    (test -1 (bitwise-first-bit-set 0))
Note: See TracChangeset for help on using the changeset viewer.