Changeset 14025 in project


Ignore:
Timestamp:
04/01/09 02:51:29 (11 years ago)
Author:
Kon Lovett
Message:

Save.

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

Legend:

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

    r13998 r14025  
    135135}
    136136
    137 #if 0 /* Unused */
    138 static const unsigned char
    139 BitReverseTable256[] = {
    140   0x00, 0x80, 0x40, 0xC0, 0x20, 0xA0, 0x60, 0xE0, 0x10, 0x90, 0x50, 0xD0, 0x30, 0xB0, 0x70, 0xF0,
    141   0x08, 0x88, 0x48, 0xC8, 0x28, 0xA8, 0x68, 0xE8, 0x18, 0x98, 0x58, 0xD8, 0x38, 0xB8, 0x78, 0xF8,
    142   0x04, 0x84, 0x44, 0xC4, 0x24, 0xA4, 0x64, 0xE4, 0x14, 0x94, 0x54, 0xD4, 0x34, 0xB4, 0x74, 0xF4,
    143   0x0C, 0x8C, 0x4C, 0xCC, 0x2C, 0xAC, 0x6C, 0xEC, 0x1C, 0x9C, 0x5C, 0xDC, 0x3C, 0xBC, 0x7C, 0xFC,
    144   0x02, 0x82, 0x42, 0xC2, 0x22, 0xA2, 0x62, 0xE2, 0x12, 0x92, 0x52, 0xD2, 0x32, 0xB2, 0x72, 0xF2,
    145   0x0A, 0x8A, 0x4A, 0xCA, 0x2A, 0xAA, 0x6A, 0xEA, 0x1A, 0x9A, 0x5A, 0xDA, 0x3A, 0xBA, 0x7A, 0xFA,
    146   0x06, 0x86, 0x46, 0xC6, 0x26, 0xA6, 0x66, 0xE6, 0x16, 0x96, 0x56, 0xD6, 0x36, 0xB6, 0x76, 0xF6,
    147   0x0E, 0x8E, 0x4E, 0xCE, 0x2E, 0xAE, 0x6E, 0xEE, 0x1E, 0x9E, 0x5E, 0xDE, 0x3E, 0xBE, 0x7E, 0xFE,
    148   0x01, 0x81, 0x41, 0xC1, 0x21, 0xA1, 0x61, 0xE1, 0x11, 0x91, 0x51, 0xD1, 0x31, 0xB1, 0x71, 0xF1,
    149   0x09, 0x89, 0x49, 0xC9, 0x29, 0xA9, 0x69, 0xE9, 0x19, 0x99, 0x59, 0xD9, 0x39, 0xB9, 0x79, 0xF9,
    150   0x05, 0x85, 0x45, 0xC5, 0x25, 0xA5, 0x65, 0xE5, 0x15, 0x95, 0x55, 0xD5, 0x35, 0xB5, 0x75, 0xF5,
    151   0x0D, 0x8D, 0x4D, 0xCD, 0x2D, 0xAD, 0x6D, 0xED, 0x1D, 0x9D, 0x5D, 0xDD, 0x3D, 0xBD, 0x7D, 0xFD,
    152   0x03, 0x83, 0x43, 0xC3, 0x23, 0xA3, 0x63, 0xE3, 0x13, 0x93, 0x53, 0xD3, 0x33, 0xB3, 0x73, 0xF3,
    153   0x0B, 0x8B, 0x4B, 0xCB, 0x2B, 0xAB, 0x6B, 0xEB, 0x1B, 0x9B, 0x5B, 0xDB, 0x3B, 0xBB, 0x7B, 0xFB,
    154   0x07, 0x87, 0x47, 0xC7, 0x27, 0xA7, 0x67, 0xE7, 0x17, 0x97, 0x57, 0xD7, 0x37, 0xB7, 0x77, 0xF7,
    155   0x0F, 0x8F, 0x4F, 0xCF, 0x2F, 0xAF, 0x6F, 0xEF, 0x1F, 0x9F, 0x5F, 0xDF, 0x3F, 0xBF, 0x7F, 0xFF};
    156 
    157 #define REVERSE_BYTE( b )   BitReverseTable256[ (b) ]
    158 
    159 #define REVERSE_LOW_BITS( b, w ) \
    160     ((CHAR_BIT == (w)) \
    161         ? REVERSE_BYTE( b ) \
    162         : (HIGH_BITS( REVERSE_BYTE( LOW_BITS( (b), (w) ) ), (w) ) >> (w)))
    163 
    164 #define REVERSE_BITS( b, s, e ) \
    165     ((0 == (s)) \
    166         ? REVERSE_LOW_BITS( (b), (e) ) \
    167         : (REVERSE_LOW_BITS( ((b) >> (e)), ((e) - (s)) ) << (e)))
    168 #endif
    169 
    170 #if 0 /* Doesn't work */
    171137static C_uword
    172 C_uword_bits_reverse( C_uword n, C_uword s, C_uword e)
     138C_uword_rotate_bit_field( C_uword n, unsigned int s, unsigned int e, unsigned int c )
    173139{
    174   #define FULBYT( n )   ((n) / CHAR_BIT)
    175   #define REMBYT( n )   (0 == ((n) % CHAR_BIT) ? 0 : 1)
    176   #define TOTBYT( n )   (FULBYT( n ) + REMBYT( n ))
    177   #ifdef C_BIG_ENDIAN
    178   # define BYTPTR( n, p )   (((uint8_t *) &n) + (sizeof( C_uword ) - FULBYT( p )))
    179   #else
    180   # define BYTPTR( n, p )   (((uint8_t *) &n) + FULBYT( e ))
    181   #endif
    182 
    183   #ifdef C_SIXTY_FOUR
    184   #else
    185   #endif
    186 
    187   C_uword wid = e - s;
    188 
    189   C_uword SS = s % CHAR_BIT;
    190   C_uword EE = e % CHAR_BIT;
    191   C_word FUL = (C_word) wid - (SS * CHAR_BIT) - (EE * CHAR_BIT);
    192 
    193   C_uword SE = MIN( CHAR_BIT, EE );
    194   C_uword ES = MAX( 0, FUL );
    195 
    196   uint8_t *srt = BYTPTR( n, e );
    197   uint8_t *end = BYTPTR( n, s );
    198 
    199   for ( ; end > srt; ++srt, --end) {
    200     C_uword tmp = REVERSE_BYTE( *srt );
    201     *srt = REVERSE_BYTE( *end );
    202     *end = temp;
     140  if (0 != n) {
     141    unsigned int wid = e - s;
     142    unsigned int cnt = c % wid;
     143    C_uword fld = BITS( n, s, e );
     144    return BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) );
    203145  }
    204146
    205   *srt = REVERSE_BITS( *srt, s % CHAR_BIT, e % CHAR_BIT );
    206   *end = REVERSE_BITS( *end, s % CHAR_BIT, e % CHAR_BIT );
     147  return 0;
    207148}
    208 #endif
    209149
    210150static C_uword
    211 C_word_bits_bit_count( C_word n )
     151C_uword_reverse( C_uword n, int c )
    212152{
    213   C_return( (0 < n)
    214               ? C_uword_bits( (C_uword) n )
    215               : ((0 == n) ? 0 : /*~*/ C_uword_bits( (C_uword) ~n )) );
     153  int isneg = ((C_word) n) < 0;
     154  unsigned int mask = isneg ? ~((C_word) n) : n;
     155  C_uword revval = 0;
     156  for (--c; 0 <= c; --c, mask >>= 1) {
     157    revval = (revval << 1) | (1 & mask) ;
     158  }
     159  return isneg ? ~revval : revval;
    216160}
    217161
    218 #if 0 /* Doesn't work */
    219162static C_uword
    220 C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e, C_uword c )
     163C_uword_reverse_bit_field( C_uword n, unsigned int s, unsigned int e )
    221164{
    222   #define ASH( n , s )  ((0 < (s)) ? ((n) << (s)) : ((n) >> -(s)))
    223 
    224   C_uword wid = e - s;
    225 
    226   if (0 == wid) C_return( n );
    227   else {
    228     C_word cnt = c % wid;
    229     C_uword msk = LOW_MASK( wid );
    230     C_uword fld = BITS( n, s, e );
    231 
    232     C_return( ((((msk & ASH( fld, cnt )) | ASH( fld, cnt - wid ))) << s) | (n & ~ (msk << s)) );
    233   }
    234 
    235   #undef ASH
     165  unsigned int width = e - s;
     166  C_uword mask = ~(((C_uword) -1) << width);
     167  return (C_uword_reverse( (mask & (n >> s)), width ) << s) | (~(mask << s) & n);
    236168}
    237 #else
    238 static C_uword
    239 C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e, C_uword c )
    240 {
    241   if (0 == n) C_return( n );
    242   else {
    243     C_uword wid = e - s;
    244     C_uword cnt = c % wid;
    245     C_uword fld = BITS( n, s, e );
    246 
    247     #if 0
    248     C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
    249     #else
    250     C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
    251     #endif
    252   }
    253 }
    254 #endif
    255169<#
    256170
     
    315229      (%boolean->bit obj) ) )
    316230
     231;; Fold operations
     232
     233;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
     234
     235(define-inline (%bwfold loc func init ls)
     236  (%check-integer loc init)
     237  (let loop ((ls ls) (acc init))
     238    (if (%null? ls) acc
     239        (let ((cur (%car ls)))
     240          (%check-integer loc cur)
     241          (loop (%cdr ls) (func acc cur)) ) ) ) )
     242
    317243;;;
    318244
    319245(module err5rs-arithmetic-bitwise (;export
    320   ; ERR5RS
    321   ;;bitwise-and bitwise-ior bitwise-xor bitwise-not - from chicken
     246  ;; ERR5RS
     247  bitwise-and bitwise-ior bitwise-xor bitwise-not
    322248  bitwise-if
    323249  bitwise-test?
     
    334260  bitwise-list->integer bitwise-integer->list
    335261  bitwise-arithmetic-shift bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
    336   ; Extras
     262  ;; Chicken Originals
     263  chicken:bitwise-not chicken:bitwise-and chicken:bitwise-ior chicken:bitwise-xor
     264  ;; Extras
    337265  pow2log2
    338266  bitwise-last-bit-set
    339267  bitwise-if-not
    340268  boolean->bit
     269  *bitwise-and *bitwise-ior *bitwise-xor *bitwise-not
    341270  *bitwise-if
    342271  *bitwise-test?
     
    357286  *pow2log2)
    358287
    359 (import scheme chicken foreign srfi-1 int-limits)
     288(import scheme
     289        (rename chicken
     290          (bitwise-and chicken:bitwise-and)
     291          (bitwise-ior chicken:bitwise-ior)
     292          (bitwise-xor chicken:bitwise-xor)
     293          (bitwise-not chicken:bitwise-not))
     294        foreign srfi-1 int-limits)
    360295
    361296(require-library srfi-1 int-limits)
     
    389324;; ERR5RS
    390325
     326(define *bitwise-not
     327  (foreign-lambda* integer ((unsigned-integer n))
     328   "return( ~n );"))
     329
     330(define *bitwise-and
     331  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
     332   "return( n & m );"))
     333
     334(define *bitwise-ior
     335  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
     336   "return( n | m );"))
     337
     338(define *bitwise-xor
     339  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
     340   "return( n ^ m );"))
     341
    391342(define *bitwise-if
    392   (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
    393    "C_return( BITS_MERGE( m, t, f ) );"))
     343  (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
     344   "return( BITS_MERGE( m, t, f ) );"))
    394345
    395346(define *bitwise-test?
    396   (foreign-lambda* bool ((integer a) (integer b))
    397    "C_return( BITS_TEST( a, b ) );"))
     347  (foreign-lambda* bool ((unsigned-integer a) (unsigned-integer b))
     348   "return( BITS_TEST( a, b ) );"))
    398349
    399350(define *bitwise-bit-count
    400   (foreign-lambda unsigned-int "C_word_bits_bit_count" integer))
     351  (foreign-lambda unsigned-int "C_uword_bits" unsigned-integer))
    401352
    402353(define *bitwise-length
    403   (foreign-lambda* unsigned-int ((integer n))
    404    "C_return( C_uword_log2( (C_uword) ((n < 0) ? ~ n : n ) ) );"))
     354  (foreign-lambda* unsigned-int ((unsigned-integer n))
     355   "return( C_uword_log2( ((C_word) n) < 0 ? ~n : n ) );"))
    405356
    406357(define *bitwise-first-bit-set
    407   (foreign-lambda* int ((integer n))
    408    "C_return( C_UWORD_LOG2_FACTORS( (C_uword) n ) );"))
     358  (foreign-lambda* int ((unsigned-integer n))
     359   "return( C_UWORD_LOG2_FACTORS( n ) );"))
    409360
    410361(define *bitwise-bit-set?
    411   (foreign-lambda* bool ((integer n) (unsigned-int i))
    412    "C_return( BIT_TEST( n, i ) );"))
     362  (foreign-lambda* bool ((unsigned-integer n) (unsigned-int i))
     363   "return( BIT_TEST( n, i ) );"))
    413364
    414365(define *bitwise-copy-bit
    415   (foreign-lambda* integer ((integer to) (unsigned-int i) (unsigned-int b))
    416    "C_return( BIT_COPY( to, i, b ) );"))
     366  (foreign-lambda* integer ((unsigned-integer to) (unsigned-int i) (unsigned-int b))
     367   "return( BIT_COPY( to, i, b ) );"))
    417368
    418369(define *bitwise-bit-field
    419   (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e))
    420    "C_return( BITS( n, s, e ) );"))
     370  (foreign-lambda* integer ((unsigned-integer n) (unsigned-int s) (unsigned-int e))
     371   "return( BITS( n, s, e ) );"))
    421372
    422373(define *bitwise-copy-bit-field
    423   (foreign-lambda* integer ((integer t) (unsigned-int s) (unsigned-int e) (integer f))
    424    "C_return( BITS_COPY( t, s, e, f ) );"))
     374  (foreign-lambda* integer ((unsigned-integer t) (unsigned-int s) (unsigned-int e) (unsigned-integer f))
     375   "return( BITS_COPY( t, s, e, f ) );"))
    425376
    426377(define *bitwise-rotate-bit-field
    427   (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e) (unsigned-int c))
    428    "C_return( C_uword_bits_rotate_bit_field( (C_uword) n, s, e, c ) );"))
    429 
     378  (foreign-lambda integer "C_uword_rotate_bit_field" unsigned-integer unsigned-int unsigned-int unsigned-int))
     379
     380(define *bitwise-reverse
     381  (foreign-lambda integer "C_uword_reverse" unsigned-integer unsigned-int))
     382
     383#;
    430384(define (*bitwise-reverse n c)
    431385  (let ((negval? (%negative? n)))
     
    435389        ((%fxnegative? count) (if negval? (%bitwise-not revval) revval)) ) ) )
    436390
    437 #; ;DOESN'T WORK
    438391(define *bitwise-reverse-bit-field
    439   (foreign-lambda integer "C_uword_bits_reverse" integer unsigned-int unsigned-int))
    440 
     392  (foreign-lambda integer "C_uword_reverse_bit_field" unsigned-integer unsigned-int unsigned-int))
     393
     394#;
    441395(define (*bitwise-reverse-bit-field n s e)
    442396  (let* ((width (%fx- e s))
     
    448402
    449403; returns (list lsb .. msb)
    450 (define (*bitwise-list->integer lyst)
    451   (let loop ((ls lyst) (i 0) (n 0))
     404(define (*bitwise-list->integer ls)
     405  (let loop ((ls ls) (i 0) (n 0))
    452406    (if (%null? ls) n
    453         (loop (%cdr ls) (%fx+ i 1) (*bitwise-copy-bit n i (%boolean->bit (%car ls)))) ) ) )
     407        (loop (%cdr ls) (%fxadd1 i) (*bitwise-copy-bit n i (%boolean->bit (%car ls)))) ) ) )
    454408
    455409; returns (list lsb .. msb)
     
    457411  (let ((zeros (make-list machine-word-bits #f)))
    458412    (lambda (n #!optional bitlen)
    459       (if (%zero? n)
    460           (if bitlen (take zeros bitlen) zeros)
     413      (if (%zero? n) (if bitlen (take zeros bitlen) zeros)
    461414          (let ((bitlen (or bitlen (*bitwise-length n))))
    462415            (let loop ((i 0) (ils '()))
     
    464417                  (loop (%fxadd1 i) (%cons (*bitwise-bit-set? n i) ils)) ) ) ) ) ) ) )
    465418
    466 (define (*bitwise-arithmetic-shift value signed-count)
    467   (%arithmetic-shift value signed-count) )
    468 
    469 (define (*bitwise-arithmetic-shift-left value count)
    470   (%arithmetic-shift value count) )
    471 
    472 (define (*bitwise-arithmetic-shift-right value count)
    473    (%arithmetic-shift value (%fxneg count)) )
     419(define (*bitwise-arithmetic-shift value signed-count) (%arithmetic-shift value signed-count))
     420
     421(define (*bitwise-arithmetic-shift-left value count) (%arithmetic-shift value count))
     422
     423(define (*bitwise-arithmetic-shift-right value count) (%arithmetic-shift value (%fxneg count)))
    474424
    475425;; Extras
    476426
    477427(define *bitwise-if-not
    478   (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
    479    "C_return( BITS_MERGE_NOT( m, t, f ) );"))
     428  (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
     429   "return( BITS_MERGE_NOT( m, t, f ) );"))
    480430
    481431(define *bitwise-last-bit-set
    482   (foreign-lambda* unsigned-int ((integer n))
    483    "C_return( C_uword_log2( (C_uword) n ) );"))
     432  (foreign-lambda* unsigned-int ((unsigned-integer n))
     433   "return( C_uword_log2( n ) - 1);"))
    484434
    485435(define *pow2log2
    486   (foreign-lambda* unsigned-int ((integer n))
    487    "C_return( 2 << C_uword_log2( (C_uword) n ) );"))
     436  (foreign-lambda* unsigned-int ((unsigned-integer n))
     437   "return( 2 << C_uword_log2( n ) );"))
    488438
    489439;;; ERR5RS
     440
     441(define (bitwise-not value)
     442  (%check-integer 'bitwise-not value)
     443  (*bitwise-not value) )
     444
     445(define (bitwise-and value . values)
     446  (%bwfold 'bitwise-and *bitwise-and value values) )
     447
     448(define (bitwise-ior value . values)
     449  (%bwfold 'bitwise-ior *bitwise-ior value values) )
     450
     451(define (bitwise-xor value . values)
     452  (%bwfold 'bitwise-xor *bitwise-xor value values) )
    490453
    491454(define (bitwise-if mask true false)
     
    551514  (*bitwise-reverse-bit-field value start end) )
    552515
    553 (define (bitwise-list->integer lyst)
    554   (%check-list 'bitwise-list->integer lyst)
    555   (*bitwise-list->integer lyst) )
     516(define (bitwise-list->integer bits)
     517  (%check-list 'bitwise-list->integer bits)
     518  (*bitwise-list->integer bits) )
    556519
    557520(define (bitwise-integer->list value #!optional bitlen)
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r14016 r14025  
    133133;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
    134134
    135 (define-inline (%fxfold loc func init lyst)
    136   (let loop ((ls lyst) (acc init))
     135(define-inline (%fxfold loc func init ls)
     136  (let loop ((ls ls) (acc init))
    137137    (if (%null? ls) acc
    138138        (loop (%cdr ls) (func acc (%car ls))) ) ) )
    139139
    140 (define-inline (%fxand-fold loc func init lyst)
    141   (let loop ((ls lyst) (acc init))
     140(define-inline (%fxand-fold loc func init ls)
     141  (let loop ((ls ls) (acc init))
    142142    (or (%null? ls)
    143143        (let ((cur (%car ls)))
     
    203203
    204204;invariant - (fixnum? (floor (* fx (expt 2 amt))))
    205 ; shl: msb + amt < fixnum-precision
    206 ; shr: msb - amt > 0
     205; shl: msb + amt <= fixnum-precision
     206; shr: msb - amt >= 0
    207207;
    208208; We know that amt is-a fixnum in [0 fixnum-precision] by now
    209209
    210210(define-inline (%fxshl/check loc fx amt)
    211   (let ((bits (%fx+ (*bitwise-last-bit-set fx) amt)))
    212     (cond ((%fx= bits fixnum-precision) 0.0)
    213           ((%fx< bits fixnum-precision) (%fxshl fx amt))
    214           (else
    215            (error-fixnum-representation loc fx amt) ) ) ) )
     211  (if (%fxzero? amt) fx
     212      (let ((bits (%fx+ (*bitwise-last-bit-set fx) amt)))
     213        (cond ((%fx<= bits fixnum-precision) (%fxshl fx amt))
     214              (else
     215               (error-fixnum-representation loc fx amt) ) ) ) ) )
    216216
    217217(define-inline (%fxshr/check loc fx amt)
    218   (let ((bits (%fx- (*bitwise-last-bit-set fx) amt)))
    219     (cond ((%fxzero? bits) fx)
    220           ((%fxpositive? bits) (%fxshr fx amt))
    221           (else
    222            (error-fixnum-representation loc fx amt) ) ) ) )
     218  (if (%fxzero? amt) fx
     219      (let ((bits (%fx- (*bitwise-last-bit-set fx) amt)))
     220        (cond ((%fx>= bits 0) (%fxshr fx amt))
     221              (else
     222               (error-fixnum-representation loc fx amt) ) ) ) ) )
    223223
    224224;;;
     
    264264  fixnum->string
    265265  ; Macros
    266   *fx=? *fx<? *fx>? *fx<=? *fx>=? *fx<>?
    267   *fxmax *fxmin
    268   *fx- *fx+ *fx* *fx/
    269   *fxand *fxior *fxxor
     266  $fx=? $fx<? $fx>? $fx<=? $fx>=? $fx<>?
     267  $fxmax $fxmin
     268  $fx- $fx+ $fx* $fx/
     269  $fxand $fxior $fxxor
    270270  ; Macro helpers
    271   $fx= $fx< $fx> $fx>= $fx<= $fx<>
    272   $fxmax $fxmin
    273   $fxand $fxior $fxxor
    274   $fx+ $fx- $fx* $fx/)
     271  -fx= -fx< -fx> -fx>= -fx<= -fx<>
     272  -fxmax -fxmin
     273  -fxand -fxior -fxxor
     274  -fx+ -fx- -fx* -fx/)
    275275
    276276(import scheme
     
    388388;;; Procedures wrapping primitive-inlines for fold operations
    389389
    390 (define ($fx= x y)
     390(define (-fx= x y)
    391391  (%check-fixnum 'fx= x)
    392392  (%check-fixnum 'fx= y)
    393393  (%fx= x y) )
    394394
    395 (define ($fx< x y)
     395(define (-fx< x y)
    396396  (%check-fixnum 'fx< x)
    397397  (%check-fixnum 'fx< y)
    398398  (%fx< x y) )
    399399
    400 (define ($fx> x y)
     400(define (-fx> x y)
    401401  (%check-fixnum 'fx> x)
    402402  (%check-fixnum 'fx> y)
    403403  (%fx> x y) )
    404404
    405 (define ($fx>= x y)
     405(define (-fx>= x y)
    406406  (%check-fixnum 'fx>= x)
    407407  (%check-fixnum 'fx>= y)
    408408  (%fx>= x y) )
    409409
    410 (define ($fx<= x y)
     410(define (-fx<= x y)
    411411  (%check-fixnum 'fx<= x)
    412412  (%check-fixnum 'fx<= y)
    413413  (%fx<= x y) )
    414414
    415 (define ($fx<> x y)
     415(define (-fx<> x y)
    416416  (%check-fixnum 'fx<> x)
    417417  (%check-fixnum 'fx<> y)
    418418  (not (%fx= x y)) )
    419419
    420 (define ($fxmax x y)
     420(define (-fxmax x y)
    421421  (%check-fixnum 'fxmax x)
    422422  (%check-fixnum 'fxmax y)
    423423  (%fxmax x y) )
    424424
    425 (define ($fxmin x y)
     425(define (-fxmin x y)
    426426  (%check-fixnum 'fxmin x)
    427427  (%check-fixnum 'fxmin y)
    428428  (%fxmin x y) )
    429429
    430 (define ($fxand x y)
     430(define (-fxand x y)
    431431  (%check-fixnum 'fxand x)
    432432  (%check-fixnum 'fxand y)
    433433  (%fxand x y) )
    434434
    435 (define ($fxior x y)
     435(define (-fxior x y)
    436436  (%check-fixnum 'fxior x)
    437437  (%check-fixnum 'fxior y)
    438438  (%fxior x y) )
    439439
    440 (define ($fxxor x y)
     440(define (-fxxor x y)
    441441  (%check-fixnum 'fxxor x)
    442442  (%check-fixnum 'fxxor y)
     
    450450(define invalid-division? (foreign-lambda bool "C_invalid_divisionp" int int))
    451451
    452 (define ($fx+ x y)
     452(define (-fx+ x y)
    453453  (%check-fixnum 'fx+ x)
    454454  (%check-fixnum 'fx+ y)
     
    456456  (%fx+ x y) )
    457457
    458 (define ($fx- x #!optional y)
     458(define (-fx- x #!optional y)
    459459  (%check-fixnum 'fx- x)
    460460  (cond (y
     
    467467         (%fxneg x) ) ) )
    468468
    469 (define ($fx* x y)
     469(define (-fx* x y)
    470470  (%check-fixnum 'fx* x)
    471471  (%check-fixnum 'fx* y)
     
    473473  (%fx* x y) )
    474474
    475 (define ($fx/ x y) (%fx/check 'fx/ x y))
     475(define (-fx/ x y) (%fx/check 'fx/ x y))
    476476
    477477;;; ERR5RS
     
    485485;;
    486486
    487 (define (fx=? fx . fxs) (%fxand-fold 'fx=? $fx= fx fxs))
    488 (define (fx<? fx . fxs) (%fxand-fold 'fx<? $fx< fx fxs))
    489 (define (fx>? fx . fxs) (%fxand-fold 'fx>? $fx> fx fxs))
    490 (define (fx<=? fx . fxs) (%fxand-fold 'fx<=? $fx<= fx fxs))
    491 (define (fx>=? fx . fxs) (%fxand-fold 'fx>=? $fx>= fx fxs))
    492 
    493 (define (fxmax fx . fxs) (%fxfold 'fxmax $fxmax fx fxs))
    494 (define (fxmin fx . fxs) (%fxfold 'fxmin $fxmin fx fxs))
     487(define (fx=? fx . fxs) (%fxand-fold 'fx=? -fx= fx fxs))
     488(define (fx<? fx . fxs) (%fxand-fold 'fx<? -fx< fx fxs))
     489(define (fx>? fx . fxs) (%fxand-fold 'fx>? -fx> fx fxs))
     490(define (fx<=? fx . fxs) (%fxand-fold 'fx<=? -fx<= fx fxs))
     491(define (fx>=? fx . fxs) (%fxand-fold 'fx>=? -fx>= fx fxs))
     492
     493(define (fxmax fx . fxs) (%fxfold 'fxmax -fxmax fx fxs))
     494(define (fxmin fx . fxs) (%fxfold 'fxmin -fxmin fx fxs))
    495495
    496496(define (fxmax-and-min fx . fxs)
     
    508508  (%fxnot fx) )
    509509
    510 (define (fxand fx . fxs) (%fxfold 'fxand $fxand fx fxs))
    511 (define (fxior fx . fxs) (%fxfold 'fxior $fxior fx fxs))
    512 (define (fxxor fx . fxs) (%fxfold 'fxxor $fxxor fx fxs))
     510(define (fxand fx . fxs) (%fxfold 'fxand -fxand fx fxs))
     511(define (fxior fx . fxs) (%fxfold 'fxior -fxior fx fxs))
     512(define (fxxor fx . fxs) (%fxfold 'fxxor -fxxor fx fxs))
    513513
    514514;;
     
    536536;;
    537537
    538 (define fx+ $fx+)
    539 (define fx- $fx-)
    540 (define fx* $fx*)
     538(define fx+ -fx+)
     539(define fx- -fx-)
     540(define fx* -fx*)
    541541(define (fxdiv fxn fxd) (%fx/check 'fxdiv fxn fxd))
    542542
     
    687687;;
    688688
    689 (define (fx<>? fx . fxs) (%fxand-fold 'fx<>? $fx<> fx fxs))
     689(define (fx<>? fx . fxs) (%fxand-fold 'fx<>? -fx<> fx fxs))
    690690
    691691(define (fxcompare fx1 fx2)
     
    776776;;
    777777
    778 (define-syntax *fx=?
     778(define-syntax $fx=?
    779779  (syntax-rules ()
    780780    ((_ ?x)
    781781      #t )
    782782    ((_ ?x ?y)
    783       ($fx= ?x ?y) )
    784     ((_ ?x ?y ?rest ...)
    785       (and ($fx= ?x ?y) (*fx=? ?y ?rest ...)) ) ) )
    786 
    787 (define-syntax *fx<?
     783      (-fx= ?x ?y) )
     784    ((_ ?x ?y ?rest ...)
     785      (and (-fx= ?x ?y) ($fx=? ?y ?rest ...)) ) ) )
     786
     787(define-syntax $fx<?
    788788  (syntax-rules ()
    789789    ((_ ?x)
    790790      #t )
    791791    ((_ ?x ?y)
    792       ($fx< ?x ?y) )
    793     ((_ ?x ?y ?rest ...)
    794       (and ($fx< ?x ?y) (*fx<? ?y ?rest ...)) ) ) )
    795 
    796 (define-syntax *fx>?
     792      (-fx< ?x ?y) )
     793    ((_ ?x ?y ?rest ...)
     794      (and (-fx< ?x ?y) ($fx<? ?y ?rest ...)) ) ) )
     795
     796(define-syntax $fx>?
    797797  (syntax-rules ()
    798798    ((_ ?x)
    799799      #t )
    800800    ((_ ?x ?y)
    801       ($fx> ?x ?y) )
    802     ((_ ?x ?y ?rest ...)
    803       (and ($fx> ?x ?y) (*fx>? ?y ?rest ...)) ) ) )
    804 
    805 (define-syntax *fx<=?
     801      (-fx> ?x ?y) )
     802    ((_ ?x ?y ?rest ...)
     803      (and (-fx> ?x ?y) ($fx>? ?y ?rest ...)) ) ) )
     804
     805(define-syntax $fx<=?
    806806  (syntax-rules ()
    807807    ((_ ?x)
    808808      #t )
    809809    ((_ ?x ?y)
    810       ($fx<= ?x ?y) )
    811     ((_ ?x ?y ?rest ...)
    812       (and ($fx<= ?x ?y) (*fx<=? ?y ?rest ...)) ) ) )
    813 
    814 (define-syntax *fx>=?
     810      (-fx<= ?x ?y) )
     811    ((_ ?x ?y ?rest ...)
     812      (and (-fx<= ?x ?y) ($fx<=? ?y ?rest ...)) ) ) )
     813
     814(define-syntax $fx>=?
    815815  (syntax-rules ()
    816816    ((_ ?x)
    817817      #t )
    818818    ((_ ?x ?y)
    819       ($fx>= ?x ?y) )
    820     ((_ ?x ?y ?rest ...)
    821       (and ($fx>= ?x ?y) (*fx>=? ?y ?rest ...)) ) ) )
    822 
    823 (define-syntax *fx<>?
    824   (syntax-rules ()
    825     ((_ ?x)
    826       #t )
    827     ((_ ?x ?y)
    828       ($fx<> ?x ?y) )
    829     ((_ ?x ?y ?rest ...)
    830       (and ($fx<> ?x ?y) (*fx<>? ?y ?rest ...)) ) ) )
    831 
    832 ;;
    833 
    834 (define-syntax *fxmax
     819      (-fx>= ?x ?y) )
     820    ((_ ?x ?y ?rest ...)
     821      (and (-fx>= ?x ?y) ($fx>=? ?y ?rest ...)) ) ) )
     822
     823(define-syntax $fx<>?
     824  (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 ...)) ) ) )
     831
     832;;
     833
     834(define-syntax $fxmax
    835835  (syntax-rules ()
    836836    ((_ ?x)
    837837      ?x )
    838838    ((_ ?x ?y)
    839       ($fxmax ?x ?y) )
    840     ((_ ?x ?y ?rest ...)
    841       ($fxmax ?x (*fxmax ?y ?rest ...)) ) ) )
    842 
    843 (define-syntax *fxmin
     839      (-fxmax ?x ?y) )
     840    ((_ ?x ?y ?rest ...)
     841      (-fxmax ?x ($fxmax ?y ?rest ...)) ) ) )
     842
     843(define-syntax $fxmin
    844844  (syntax-rules ()
    845845    ((_ ?x)
    846846      ?x )
    847847    ((_ ?x ?y)
    848       ($fxmin ?x ?y) )
    849     ((_ ?x ?y ?rest ...)
    850       ($fxmin ?x (*fxmin ?y ?rest ...)) ) ) )
    851 
    852 ;;
    853 
    854 (define-syntax *fxand
     848      (-fxmin ?x ?y) )
     849    ((_ ?x ?y ?rest ...)
     850      (-fxmin ?x ($fxmin ?y ?rest ...)) ) ) )
     851
     852;;
     853
     854(define-syntax $fxand
    855855  (syntax-rules ()
    856856    ((_ ?x)
    857857      ?x )
    858858    ((_ ?x ?y)
    859       ($fxand ?x ?y) )
    860     ((_ ?x ?y ?rest ...)
    861       ($fxand ?x (*fxand ?y ?rest ...)) ) ) )
    862 
    863 (define-syntax *fxior
     859      (-fxand ?x ?y) )
     860    ((_ ?x ?y ?rest ...)
     861      (-fxand ?x ($fxand ?y ?rest ...)) ) ) )
     862
     863(define-syntax $fxior
    864864  (syntax-rules ()
    865865    ((_ ?x)
    866866      ?x )
    867867    ((_ ?x ?y)
    868       ($fxior ?x ?y) )
    869     ((_ ?x ?y ?rest ...)
    870       ($fxior ?x (*fxior ?y ?rest ...)) ) ) )
    871 
    872 (define-syntax *fxxor
     868      (-fxior ?x ?y) )
     869    ((_ ?x ?y ?rest ...)
     870      (-fxior ?x ($fxior ?y ?rest ...)) ) ) )
     871
     872(define-syntax $fxxor
    873873  (syntax-rules ()
    874874    ((_ ?x)
    875875      ?x )
    876876    ((_ ?x ?y)
    877       ($fxxor ?x ?y) )
    878     ((_ ?x ?y ?rest ...)
    879       ($fxxor ?x (*fxxor ?y ?rest ...)) ) ) )
    880 
    881 ;;
    882 
    883 (define-syntax *fx-
    884   (syntax-rules ()
    885     ((_ ?x)
    886       ($fx- ?x) )
    887     ((_ ?x ?y)
    888       ($fx- ?x ?y) )
    889     ((_ ?x ?y ?rest ...)
    890       ($fx- ?x (*fx- ?y ?rest ...) ) ) ) )
    891 
    892 (define-syntax *fx+
     877      (-fxxor ?x ?y) )
     878    ((_ ?x ?y ?rest ...)
     879      (-fxxor ?x ($fxxor ?y ?rest ...)) ) ) )
     880
     881;;
     882
     883(define-syntax $fx-
     884  (syntax-rules ()
     885    ((_ ?x)
     886      (-fx- ?x) )
     887    ((_ ?x ?y)
     888      (-fx- ?x ?y) )
     889    ((_ ?x ?y ?rest ...)
     890      (-fx- ?x ($fx- ?y ?rest ...) ) ) ) )
     891
     892(define-syntax $fx+
    893893  (syntax-rules ()
    894894    ((_ ?x)
    895895      ?x )
    896896    ((_ ?x ?y)
    897       ($fx+ ?x ?y) )
    898     ((_ ?x ?y ?rest ...)
    899       ($fx+ ?x (*fx+ ?y ?rest ...) ) ) ) )
    900 
    901 (define-syntax *fx*
     897      (-fx+ ?x ?y) )
     898    ((_ ?x ?y ?rest ...)
     899      (-fx+ ?x ($fx+ ?y ?rest ...) ) ) ) )
     900
     901(define-syntax $fx*
    902902  (syntax-rules ()
    903903    ((_ ?x)
    904904      ?x )
    905905    ((_ ?x ?y)
    906       ($fx* ?x ?y) )
    907     ((_ ?x ?y ?rest ...)
    908       ($fx* ?x (*fx* ?y ?rest ...) ) ) ) )
    909 
    910 (define-syntax *fx/
     906      (-fx* ?x ?y) )
     907    ((_ ?x ?y ?rest ...)
     908      (-fx* ?x ($fx* ?y ?rest ...) ) ) ) )
     909
     910(define-syntax $fx/
    911911  (syntax-rules ()
    912912    ((_ ?x)
    913913      ?x )
    914914    ((_ ?x ?y)
    915       ($fx/ ?x ?y) )
    916     ((_ ?x ?y ?rest ...)
    917       ($fx/ ?x (*fx/ ?y ?rest ...) ) ) ) )
     915      (-fx/ ?x ?y) )
     916    ((_ ?x ?y ?rest ...)
     917      (-fx/ ?x ($fx/ ?y ?rest ...) ) ) ) )
    918918
    919919) ;module err5rs-arithmetic-fixnums
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r14008 r14025  
    2424(include "chicken-primitive-object-inlines")
    2525
     26(include "mathh-constants")
     27
    2628;;
    2729
     
    6062;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
    6163
    62 (define-inline (%fpfold loc func init lyst)
    63   (%check-flonum loc init)
    64   (let loop ((ls lyst) (acc init))
     64(define-inline (%fpfold loc func init ls)
     65  (let loop ((ls ls) (acc init))
    6566          (if (%null? ls) acc
    66               (let ((cur (%car ls)))
    67           (%check-flonum loc cur)
    68           (loop (%cdr ls) (func acc cur)) ) ) ) )
    69 
    70 (define-inline (%fpand-fold loc func init lyst)
    71   (%check-flonum loc init)
    72   (let loop ((ls lyst) (acc init))
     67              (loop (%cdr ls) (func acc (%car ls))) ) ) )
     68
     69(define-inline (%fpand-fold loc func init ls)
     70  (let loop ((ls ls) (acc init))
    7371          (or (%null? ls)
    7472        (let ((cur (%car ls)))
    75           (%check-flonum loc cur)
    7673                (and (func acc cur)
    7774               (loop (%cdr ls) cur) ) ) ) ) )
     
    7976;;
    8077
     78(define-inline (%fpposzero? fp) (and (%fp=? 0.0 fp) (not (signbit fp))))
    8179(define-inline (%fpnegzero? fp) (and (%fp=? -0.0 fp) (signbit fp)))
    82 
    83 (define-inline (%fpzero? fp) (or #;(%fpnegzero? fp) (%fp= 0.0 fp)))
    84 
    85 (define-inline (%fpdiv fpn fpd) (%fptruncate (%fp/ fpn fpd)))
    86 
     80(define-inline (%fpzero? fp) (%fp= 0.0 fp) #;(or (%fpnegzero? fp) (%fpposzero? fp)))
     81(define-inline (%fppositive? fp) (%fp< 0.0 fp))
     82(define-inline (%fpnegative? fp) (%fp> 0.0 fp))
     83
     84(define-inline (%fpdiv fpn fpd) (%fpfloor (%fp/ fpn fpd)))
    8785(define-inline (%fpmod fpn fpd) (%fp- fpn (%fp* (%fpdiv fpn fpd) fpd)))
    8886
     
    182180  flnegate
    183181  ; Macros
    184   *fl=? *fl<? *fl>? *fl<=? *fl>=? *fl<>?
    185   *flmax *flmin
    186   *fl- *fl+ *fl* *fl/
     182  $fl=? $fl<? $fl>? $fl<=? $fl>=? $fl<>?
     183  $flmax $flmin
     184  $fl- $fl+ $fl* $fl/
    187185  ; Macro helpers
    188   $fp=? $fp<? $fp>? $fp>=? $fp<=? $fp<>?
    189   $fpmax $fpmin
    190   $fp+ $fp- $fp* $fp/)
     186  -fp=? -fp<? -fp>? -fp>=? -fp<=? -fp<>?
     187  -fpmax -fpmin
     188  -fp+ -fp- -fp* -fp/)
    191189
    192190(import scheme chicken foreign srfi-1 mathh)
     
    214212;;; Procedures wrapping primitive-inlines for fold operations
    215213
    216 (define ($fp=? x y) (%fp=? x y))
    217 (define ($fp<? x y) (%fp<? x y))
    218 (define ($fp>? x y) (%fp>? x y))
    219 (define ($fp<=? x y) (%fp<=? x y))
    220 (define ($fp>=? x y) (%fp>=? x y))
    221 (define ($fp<>? x y) (not (%fp=? x y)))
    222 (define ($fpmax x y) (%fpmax x y))
    223 (define ($fpmin x y) (%fpmin x y))
    224 (define ($fp- x y) (%fp- x y))
    225 (define ($fp+ x y) (%fp+ x y))
    226 (define ($fp* x y) (%fp* x y))
    227 (define ($fp/ x y) (%fp/ x y))
     214(define (-fp=? x y)
     215        (%check-flonum 'fp=? x)
     216        (%check-flonum 'fp=? y)
     217        (%fp=? x y) )
     218
     219(define (-fp<? x y)
     220        (%check-flonum 'fp<? x)
     221        (%check-flonum 'fp<? y)
     222        (%fp<? x y) )
     223
     224(define (-fp>? x y)
     225        (%check-flonum 'fp>? x)
     226        (%check-flonum 'fp>? y)
     227        (%fp>? x y) )
     228
     229(define (-fp<=? x y)
     230        (%check-flonum 'fp<=? x)
     231        (%check-flonum 'fp<=? y)
     232        (%fp<=? x y) )
     233
     234(define (-fp>=? x y)
     235        (%check-flonum 'fp>=? x)
     236        (%check-flonum 'fp>=? y)
     237        (%fp>=? x y) )
     238
     239(define (-fp<>? x y)
     240        (%check-flonum 'fp<>? x)
     241        (%check-flonum 'fp<>? y)
     242  (not (%fp=? x y)) )
     243
     244(define (-fpmax x y)
     245        (%check-flonum 'fpmax x)
     246        (%check-flonum 'fpmax y)
     247        (%fpmax x y) )
     248
     249(define (-fpmin x y)
     250        (%check-flonum 'fpmin x)
     251        (%check-flonum 'fpmin y)
     252        (%fpmin x y) )
     253
     254(define (-fp- x y)
     255        (%check-flonum 'fp- x)
     256        (%check-flonum 'fp- y)
     257        (%fp- x y) )
     258
     259(define (-fp+ x y)
     260        (%check-flonum 'fp+ x)
     261        (%check-flonum 'fp+ y)
     262        (%fp+ x y) )
     263
     264(define (-fp* x y)
     265        (%check-flonum 'fp* x)
     266        (%check-flonum 'fp* y)
     267        (%fp* x y) )
     268
     269(define (-fp/ x y)
     270        (%check-flonum 'fp/ x)
     271        (%check-flonum 'fp/ y)
     272        (%fp/ x y) )
    228273
    229274;;;
     
    234279#;(define digits-limit 1.0e12)
    235280
    236 (define (*fpgcd fp1 fp2 #!optional (cnvrg-limit 50))
     281(define ($fpgcd fp1 fp2 #!optional (cnvrg-limit 50))
    237282  (let ((fp1 (%fpabs fp1))
    238283        (fp2 (%fpabs fp2)) )
     
    261306                       (loop (%fxadd1 cnvrg) divisor remainder) ) ) ) ) ) ) ) ) )
    262307
    263 (define (*fp->fraction fp)
     308(define ($fp->fraction fp)
    264309  (let ((numerator-epsilon (%fp* (%fpabs fp) small-epsilon))
    265310        (numerator (%fpround fp)) )
     
    267312    (if (and (not (%fpzero? numerator))
    268313             (%fp<= (%fpabs (%fp- numerator fp)) numerator-epsilon)) (values numerator 1.0)
    269         (let* ((divisor (*fpgcd fp 1.0))
     314        (let* ((divisor ($fpgcd fp 1.0))
    270315               (numerator (%fpround (%fp/ fp divisor)))
    271316               (denominator (%fpround (%fp/ 1.0 divisor))) )
     
    280325                 (values +nan +nan) )
    281326                (else
    282                  (let ((divisor (*fpgcd numerator denominator)))
     327                 (let ((divisor ($fpgcd numerator denominator)))
    283328                       ; Fully reduced?
    284329                   (if (%fp< 1.0 divisor)
     
    318363;;
    319364
    320 (define (fl=? fp . fps) (%fpand-fold 'fl=? $fp=? fp fps))
    321 (define (fl<? fp . fps) (%fpand-fold 'fl<? $fp<? fp fps))
    322 (define (fl>? fp . fps) (%fpand-fold 'fl>? $fp>? fp fps))
    323 (define (fl<=? fp . fps) (%fpand-fold 'fl<=? $fp<=? fp fps))
    324 (define (fl>=? fp . fps) (%fpand-fold 'fl>=? $fp>=? fp fps))
    325 
    326 ;;
    327 
    328 (define (flmax fp . fps) (%fpfold 'flmax $fpmax fp fps))
    329 (define (flmin fp . fps) (%fpfold 'flmin $fpmin fp fps))
     365(define (fl=? fp . fps) (%fpand-fold 'fl=? -fp=? fp fps))
     366(define (fl<? fp . fps) (%fpand-fold 'fl<? -fp<? fp fps))
     367(define (fl>? fp . fps) (%fpand-fold 'fl>? -fp>? fp fps))
     368(define (fl<=? fp . fps) (%fpand-fold 'fl<=? -fp<=? fp fps))
     369(define (fl>=? fp . fps) (%fpand-fold 'fl>=? -fp>=? fp fps))
     370
     371;;
     372
     373(define (flmax fp . fps) (%fpfold 'flmax -fpmax fp fps))
     374(define (flmin fp . fps) (%fpfold 'flmin -fpmin fp fps))
    330375
    331376(define (flmax-and-min fp . fps)
     
    378423;;
    379424
    380 (define (fl+ fp . fps) (%fpfold 'fl+ $fp+ fp fps))
     425(define (fl+ fp . fps) (%fpfold 'fl+ -fp+ fp fps))
    381426
    382427(define (fl- fp . fps)
    383428  (if (%null? fps) (%fpnegate fp)
    384       (%fpfold 'fl- $fp- fp fps) ) )
    385 
    386 (define (fl* fp . fps) (%fpfold 'fl* $fp* fp fps))
     429      (%fpfold 'fl- -fp- fp fps) ) )
     430
     431(define (fl* fp . fps) (%fpfold 'fl* -fp* fp fps))
    387432
    388433(define (fl/ fp . fps)
    389434  (if (%null? fps) (%fp/ 1.0 fp)
    390         (%fpfold 'fl/ $fp/ fp fps) ) )
     435        (%fpfold 'fl/ -fp/ fp fps) ) )
    391436
    392437(define (flabs fp)
     
    481526  (%check-flonum 'flacos fp)
    482527  (%fpacos fp) )
     528 
     529(define -PI (%fpnegate PI))
     530(define -PI/2 (%fpnegate PI/2))
    483531
    484532(define (flatan fp #!optional fpd)
     
    486534  (cond (fpd
    487535         (%check-flonum 'flatan fpd)
    488          (%fpatan2 fp fpd) )
     536         (cond ((%fpnegzero? fpd)
     537                (cond ((%fppositive? fp) -0.0)
     538                      ((%fpnegative? fp) -PI)
     539                      ((%fpnegzero? fp) -PI)
     540                      ((%fpzero? fp) -PI/2) ) )
     541               ((%fpzero? fpd)
     542                (cond ((%fppositive? fp) 0.0)
     543                      ((%fpnegative? fp) PI)
     544                      ((%fpnegzero? fp) PI)
     545                      ((%fpzero? fp) PI/2) ) )
     546               (else (%fpatan2 fp fpd) ) ) )
    489547        (else
    490548         (%fpatan fp) ) ) )
     
    510568         fp )
    511569        (else
    512          (receive (n d) (*fp->fraction fp) n) ) ) )
     570         (receive (n d) ($fp->fraction fp) n) ) ) )
    513571
    514572(define (fldenominator fp)
     
    519577         1.0 )
    520578        (else
    521          (receive (n d) (*fp->fraction fp) d) ) ) )
     579         (receive (n d) ($fp->fraction fp) d) ) ) )
    522580
    523581;;; Extras
     
    533591         fp1 )
    534592        (else
    535          (*fpgcd fp1 fp2) ) ) )
     593         ($fpgcd fp1 fp2) ) ) )
    536594
    537595(define (flonum->fraction fp)
     
    542600         (values fp 1.0) )
    543601        (else
    544          (*fp->fraction fp) ) ) )
    545 
    546 (define (fl<>? fp . fps) (%fpand-fold 'fl<>? $fp<>? fp fps))
     602         ($fp->fraction fp) ) ) )
     603
     604(define (fl<>? fp . fps) (%fpand-fold 'fl<>? -fp<>? fp fps))
    547605
    548606(define (flcompare fl1 fl2)
     
    571629;;
    572630
    573 (define-syntax *fl=?
     631(define-syntax $fl=?
    574632  (syntax-rules ()
    575633    ((_ ?x)
    576634      #t )
    577635    ((_ ?x ?y)
    578       ($fp=? ?x ?y) )
    579     ((_ ?x ?y ?rest ...)
    580       (and ($fp=? ?x ?y) (*fl=? ?y ?rest ...)) ) ) )
    581 
    582 (define-syntax *fl<?
     636      (-fp=? ?x ?y) )
     637    ((_ ?x ?y ?rest ...)
     638      (and (-fp=? ?x ?y) ($fl=? ?y ?rest ...)) ) ) )
     639
     640(define-syntax $fl<?
    583641  (syntax-rules ()
    584642    ((_ ?x)
    585643      #t )
    586644    ((_ ?x ?y)
    587       ($fp<? ?x ?y) )
    588     ((_ ?x ?y ?rest ...)
    589       (and ($fp<? ?x ?y) (*fl<? ?y ?rest ...)) ) ) )
    590 
    591 (define-syntax *fl>?
     645      (-fp<? ?x ?y) )
     646    ((_ ?x ?y ?rest ...)
     647      (and (-fp<? ?x ?y) ($fl<? ?y ?rest ...)) ) ) )
     648
     649(define-syntax $fl>?
    592650  (syntax-rules ()
    593651    ((_ ?x)
    594652      #t )
    595653    ((_ ?x ?y)
    596       ($fp>? ?x ?y) )
    597     ((_ ?x ?y ?rest ...)
    598       (and ($fp>? ?x ?y) (*fl>? ?y ?rest ...)) ) ) )
    599 
    600 (define-syntax *fl<=?
     654      (-fp>? ?x ?y) )
     655    ((_ ?x ?y ?rest ...)
     656      (and (-fp>? ?x ?y) ($fl>? ?y ?rest ...)) ) ) )
     657
     658(define-syntax $fl<=?
    601659  (syntax-rules ()
    602660    ((_ ?x)
    603661      #t )
    604662    ((_ ?x ?y)
    605       ($fp<=? ?x ?y) )
    606     ((_ ?x ?y ?rest ...)
    607       (and ($fp<=? ?x ?y) (*fl<=? ?y ?rest ...)) ) ) )
    608 
    609 (define-syntax *fl>=?
     663      (-fp<=? ?x ?y) )
     664    ((_ ?x ?y ?rest ...)
     665      (and (-fp<=? ?x ?y) ($fl<=? ?y ?rest ...)) ) ) )
     666
     667(define-syntax $fl>=?
    610668  (syntax-rules ()
    611669    ((_ ?x)
    612670      #t )
    613671    ((_ ?x ?y)
    614       ($fp>=? ?x ?y) )
    615     ((_ ?x ?y ?rest ...)
    616       (and ($fp>=? ?x ?y) (*fl>=? ?y ?rest ...)) ) ) )
    617 
    618 (define-syntax *fl<>?
    619   (syntax-rules ()
    620     ((_ ?x)
    621       #t )
    622     ((_ ?x ?y)
    623       ($fp<>? ?x ?y) )
    624     ((_ ?x ?y ?rest ...)
    625       (and ($fp<>? ?x ?y) (*fl<>? ?y ?rest ...)) ) ) )
    626 
    627 ;;
    628 
    629 (define-syntax *flmax
     672      (-fp>=? ?x ?y) )
     673    ((_ ?x ?y ?rest ...)
     674      (and (-fp>=? ?x ?y) ($fl>=? ?y ?rest ...)) ) ) )
     675
     676(define-syntax $fl<>?
     677  (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 ...)) ) ) )
     684
     685;;
     686
     687(define-syntax $flmax
    630688  (syntax-rules ()
    631689    ((_ ?x)
    632690      ?x )
    633691    ((_ ?x ?y)
    634       ($fpmax ?x ?y) )
    635     ((_ ?x ?y ?rest ...)
    636       ($fpmax ?x (*flmax ?y ?rest ...)) ) ) )
    637 
    638 (define-syntax *flmin
     692      (-fpmax ?x ?y) )
     693    ((_ ?x ?y ?rest ...)
     694      (-fpmax ?x ($flmax ?y ?rest ...)) ) ) )
     695
     696(define-syntax $flmin
    639697  (syntax-rules ()
    640698    ((_ ?x)
    641699      ?x )
    642700    ((_ ?x ?y)
    643       ($fpmin ?x ?y) )
    644     ((_ ?x ?y ?rest ...)
    645       ($fpmin ?x (*flmin ?y ?rest ...)) ) ) )
    646 
    647 ;;
    648 
    649 (define-syntax *fl-
    650   (syntax-rules ()
    651     ((_ ?x)
    652       ($fpneg ?x) )
    653     ((_ ?x ?y)
    654       ($fp- ?x ?y) )
    655     ((_ ?x ?y ?rest ...)
    656       ($fp- ?x (*fl- ?y ?rest ...) ) ) ) )
    657 
    658 (define-syntax *fl+
     701      (-fpmin ?x ?y) )
     702    ((_ ?x ?y ?rest ...)
     703      (-fpmin ?x ($flmin ?y ?rest ...)) ) ) )
     704
     705;;
     706
     707(define-syntax $fl-
     708  (syntax-rules ()
     709    ((_ ?x)
     710      (-fpneg ?x) )
     711    ((_ ?x ?y)
     712      (-fp- ?x ?y) )
     713    ((_ ?x ?y ?rest ...)
     714      (-fp- ?x ($fl- ?y ?rest ...) ) ) ) )
     715
     716(define-syntax $fl+
    659717  (syntax-rules ()
    660718    ((_ ?x)
    661719      ?x )
    662720    ((_ ?x ?y)
    663       ($fp+ ?x ?y) )
    664     ((_ ?x ?y ?rest ...)
    665       ($fp+ ?x (*fl+ ?y ?rest ...) ) ) ) )
    666 
    667 (define-syntax *fl*
     721      (-fp+ ?x ?y) )
     722    ((_ ?x ?y ?rest ...)
     723      (-fp+ ?x ($fl+ ?y ?rest ...) ) ) ) )
     724
     725(define-syntax $fl*
    668726  (syntax-rules ()
    669727    ((_ ?x)
    670728      ?x )
    671729    ((_ ?x ?y)
    672       ($fp* ?x ?y) )
    673     ((_ ?x ?y ?rest ...)
    674       ($fp* ?x (*fl* ?y ?rest ...) ) ) ) )
    675 
    676 (define-syntax *fl/
     730      (-fp* ?x ?y) )
     731    ((_ ?x ?y ?rest ...)
     732      (-fp* ?x ($fl* ?y ?rest ...) ) ) ) )
     733
     734(define-syntax $fl/
    677735  (syntax-rules ()
    678736    ((_ ?x)
    679737      ?x )
    680738    ((_ ?x ?y)
    681       ($fp/ ?x ?y) )
    682     ((_ ?x ?y ?rest ...)
    683       ($fp/ ?x (*fl/ ?y ?rest ...) ) ) ) )
     739      (-fp/ ?x ?y) )
     740    ((_ ?x ?y ?rest ...)
     741      (-fp/ ?x ($fl/ ?y ?rest ...) ) ) ) )
    684742
    685743) ;module err5rs-arithmetic-flonums
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r14010 r14025  
    8282  (test-group "Fixnum Functions"
    8383
    84     (test 4 (*fx+ 2 2))
    85     (test -26 (*fx+ 74 -100))
    86     (test (greatest-fixnum) (*fx+ #x3ffffffe 1))
    87     (test-error (*fx+ #x3fffffff 1))
    88     (test 4 (*fx- 6 2))
    89     (test -4 (*fx- 1000 1004))
    90     (test 2004 (*fx- 1000 -1004))
    91     (test (least-fixnum) (*fx- (- #x3fffffff) 1))
    92     (test-error (*fx- (- #x3fffffff) 2))
     84    (test 4 ($fx+ 2 2))
     85    (test -26 ($fx+ 74 -100))
     86    (test (greatest-fixnum) ($fx+ #x3ffffffe 1))
     87    (test-error ($fx+ #x3fffffff 1))
     88    (test 4 ($fx- 6 2))
     89    (test -4 ($fx- 1000 1004))
     90    (test 2004 ($fx- 1000 -1004))
     91    (test (least-fixnum) ($fx- (- #x3fffffff) 1))
     92    (test-error ($fx- (- #x3fffffff) 2))
    9393  )
    9494
     
    810810    (test 0 (bitwise-last-bit-set 0))
    811811    (test 8 (bitwise-last-bit-set #b10111100))
    812     (test machine-word-bits (bitwise-last-bit-set -1))
     812    (test (sub1 machine-word-bits) (bitwise-last-bit-set -1))
    813813
    814814    (test -1 (bitwise-first-bit-set 0))
     
    10861086    ;; ----------------------------------------
    10871087
    1088     (test 0 (bitwise-and (expt 2 100) 17))
    1089     (test 17 (bitwise-and (- (expt 2 100) 1) 17))
    1090     (test (expt 2 90) (bitwise-and (- (expt 2 100) 1) (expt 2 90)))
    1091 
    1092     (test (bitwise-ior (expt 2 100) 17) (bitwise-xor (expt 2 100) 17))
    1093     (test (- (expt 2 100) 18) (bitwise-xor (- (expt 2 100) 1) 17))
    1094     (test (- (expt 2 100) (expt 2 90) 1) (bitwise-xor (- (expt 2 100) 1) (expt 2 90)))
    1095 
    1096     (test (+ (expt 2 100) 1) (bitwise-if (expt 2 100) -1 1))
    1097     (test 1 (bitwise-if (expt 2 100) 1 1) )
    1098     (test (+ (expt 2 100) 1) (bitwise-if (expt 2 100) (- (expt 2 200) 1) 1))
    1099 
    1100     (test 1 (bitwise-bit-count (expt 2 300)))
    1101     (test 300 (bitwise-bit-count (- (expt 2 300) 1)))
    1102     (test -301 (bitwise-bit-count (- (expt 2 300))))
    1103 
    1104     (test 301 (bitwise-length (expt 2 300)))
    1105     (test 300 (bitwise-length (- (expt 2 300) 1)))
    1106     (test 300 (bitwise-length (- (expt 2 300))))
    1107 
    1108     (test 300 (bitwise-first-bit-set (expt 2 300)))
    1109     (test 0 (bitwise-first-bit-set (- (expt 2 300) 1)))
     1088    (test-error #;0 (bitwise-and (expt 2 100) 17))
     1089    (test-error #;17 (bitwise-and (- (expt 2 100) 1) 17))
     1090    (test-error #;(expt 2 90) (bitwise-and (- (expt 2 100) 1) (expt 2 90)))
     1091
     1092    (test-error #;(bitwise-ior (expt 2 100) 17) (bitwise-xor (expt 2 100) 17))
     1093    (test-error #;(- (expt 2 100) 18) (bitwise-xor (- (expt 2 100) 1) 17))
     1094    (test-error #;(- (expt 2 100) (expt 2 90) 1) (bitwise-xor (- (expt 2 100) 1) (expt 2 90)))
     1095
     1096    (test-error #;(+ (expt 2 100) 1) (bitwise-if (expt 2 100) -1 1))
     1097    (test-error #;1 (bitwise-if (expt 2 100) 1 1) )
     1098    (test-error #;(+ (expt 2 100) 1) (bitwise-if (expt 2 100) (- (expt 2 200) 1) 1))
     1099
     1100    (test-error #;1 (bitwise-bit-count (expt 2 300)))
     1101    (test-error #;300 (bitwise-bit-count (- (expt 2 300) 1)))
     1102    (test-error #;-301 (bitwise-bit-count (- (expt 2 300))))
     1103
     1104    (test-error #;301 (bitwise-length (expt 2 300)))
     1105    (test-error #;300 (bitwise-length (- (expt 2 300) 1)))
     1106    (test-error #;300 (bitwise-length (- (expt 2 300))))
     1107
     1108    (test-error #;300 (bitwise-first-bit-set (expt 2 300)))
     1109    (test-error #;0 (bitwise-first-bit-set (- (expt 2 300) 1)))
    11101110
    11111111    (test-error (bitwise-bit-set? (expt 2 300) 300))
     
    11141114    (test-error (bitwise-bit-set? (- (expt 2 300) 1) 299))
    11151115    (test-error (bitwise-bit-set? (- (expt 2 300) 1) 298))
    1116     (test-assert (not (bitwise-bit-set? (- (expt 2 300) 2) 0)))
     1116    (test-error (not (bitwise-bit-set? (- (expt 2 300) 2) 0)))
    11171117    (test-error (bitwise-bit-set? -1 300))
    11181118    (test-assert (bitwise-bit-set? -1 0))
     
    11371137    (test-error #;(expt 2 299) (bitwise-rotate-bit-field (expt 2 300) 299 304 4))
    11381138
    1139     ;;(test (expt 2 302) (bitwise-reverse-bit-field (expt 2 300) 299 304))
     1139    (test-error #;(expt 2 302) (bitwise-reverse-bit-field (expt 2 300) 299 304))
    11401140  )
    11411141)
Note: See TracChangeset for help on using the changeset viewer.