Changeset 13645 in project


Ignore:
Timestamp:
03/10/09 09:01:52 (11 years ago)
Author:
Kon Lovett
Message:

Better argument checking.

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

Legend:

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

    r13619 r13645  
    1616    ##sys#check-list
    1717    ##sys#check-integer
    18     ##sys#check-exact
    1918    ##sys#signal-hook
    2019    ##sys#string-append ) )
     
    3130/* Bit operations */
    3231
    33 #define HIGH_MASK( s )                (-1 << (s))
    34 #define LOW_MASK( s )                 (~ HIGH_MASK( s ))
    35 
    36 #define HIGH_BITS( n, s )             ((n) & HIGH_MASK( s ))
    37 #define LOW_BITS( n, s )              ((n) & LOW_MASK( s ))
     32#define HIGH_MASK( p )                (-1 << (p))
     33#define LOW_MASK( p )                 (~ HIGH_MASK( p ))
     34
     35#define HIGH_BITS( n, p )             ((n) & HIGH_MASK( p ))
     36#define LOW_BITS( n, p )              ((n) & LOW_MASK( p ))
    3837
    3938#define BITS( n, s, e )               (((n) & LOW_MASK( e )) >> (s))
     
    4847    (BITS_MERGE( HIGH_MASK( s ) & LOW_MASK( e ), (f) << (s), (t)))
    4948
    50 #define BIT_SET( n, s )               ((n) | (1 << (s)))
    51 #define BIT_CLEAR( n, s )             ((n) & ~ (1 << (s)))
    52 #define BIT_TEST( n, s )              ((n) & (1 << (s)))
    53 #define BIT_COPY( n, s, b )           BITS_MERGE( 1 << (s), (b) << (s), (n) )
     49#define BIT_SET( n, p )               ((n) | (1 << (p)))
     50#define BIT_CLEAR( n, p )             ((n) & ~ (1 << (p)))
     51#define BIT_TEST( n, p )              ((n) & (1 << (p)))
     52#define BIT_COPY( n, p, b )           BITS_MERGE( 1 << (p), (b) << (p), (n) )
    5453
    5554/* Integer log2 - high bit set */
     
    222221#if 0 /* Doesn't work */
    223222static C_uword
    224 C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e )
     223C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e, C_uword c )
    225224{
    226   #define ASH( n, s )  ((0 < (s)) ? ((n) << (s)) : ((n) >> -(s)))
     225  #define ASH( n , s )  ((0 < (s)) ? ((n) << (s)) : ((n) >> -(s)))
     226
    227227  C_uword wid = e - s;
    228   C_word cnt = count % wid;
    229   C_uword msk = LOW_MASK( wid );
    230   C_uword fld = BITS( n, s, e );
    231   C_return( ((((msk & ASH( fld, cnt )) | ASH( fld, cnt - wid ))) << s) | (n & ~ (msk << s)) );
     228
     229  if (0 == wid) C_return( n );
     230  else {
     231    C_word cnt = c % wid;
     232    C_uword msk = LOW_MASK( wid );
     233    C_uword fld = BITS( n, s, e );
     234
     235    C_return( ((((msk & ASH( fld, cnt )) | ASH( fld, cnt - wid ))) << s) | (n & ~ (msk << s)) );
     236  }
     237
    232238  #undef ASH
    233239}
    234240#else
    235241static C_uword
    236 C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e )
     242C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e, C_uword c )
    237243{
    238244  if (0 == n) C_return( n );
    239245  else {
    240246    C_uword wid = e - s;
    241     C_uword cnt = count % wid;
     247    C_uword cnt = c % wid;
    242248    C_uword fld = BITS( n, s, e );
     249
     250    #if 0
    243251    C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
     252    #else
     253    C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
     254    #endif
    244255  }
    245256}
     
    249260;;
    250261
     262(define-inline (%error-outside-range loc obj low high)
     263  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
     264
     265;;
     266
    251267(define-inline (%check-list loc obj) (##sys#check-list obj loc))
    252268
    253269(define-inline (%check-integer loc obj) (##sys#check-integer obj loc))
    254270
    255 (define-inline (%check-fixnum loc obj) (##sys#check-exact obj loc)
    256 
    257 (define-inline (%check-non-negative-fixnum loc obj)
    258   (unless (and (%fixnum? obj) (%fx<= 0 obj))
    259     (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative fixnum" obj) ) )
    260 
    261 (define-inline (%check-fixnum<= loc fx1 fx2)
     271(define-inline (%check-fixnum loc obj)
     272  (unless (%fixnum? obj)
     273    (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) ) )
     274
     275;;
     276
     277(define-inline (%check-fixnum-bounds-order loc fx1 fx2)
    262278  (unless (%fx<= fx1 fx2)
    263     (##sys#signal-hook #:bounds-error loc "not a fixnum interval" fx1 fx2) ) )
    264 
    265 (define-inline (%check-word-bits loc fx)
    266   (unless (%fx<= fx machine-word-bits)
    267     (##sys#signal-hook #:bounds-error loc "out of integer range" fx) ) )
    268 
    269 (define *word-bits-end* (%fx+ machine-word-bits 1))
    270 
    271 (define-inline (%check-word-bits+1 loc fx)
    272   (unless (%fx<= fx *word-bits-end*)
    273     (##sys#signal-hook #:bounds-error loc "out of integer range" fx) ) )
     279    (##sys#signal-hook #:bounds-error loc "bounds reversed" fx1 fx2) ) )
     280
     281(define-inline (%check-fixnum-range loc lfx fx hfx)
     282  (unless (%fxclosed? lfx fx hfx)
     283    (%error-outside-range loc fx lfx hfx) ) )
     284
     285;;
     286
     287(define-inline (%check-word-bits-range loc obj)
     288   (%check-fixnum loc obj)
     289   (%check-fixnum-range loc 0 obj machine-word-bits))
     290
     291(define-inline (%check-bits-range loc start end)
     292  (%check-fixnum loc start)
     293  (%check-fixnum loc end)
     294  (%check-fixnum-bounds-order loc start end)
     295  (%check-fixnum-range loc 0 start machine-word-precision)
     296  (%check-fixnum-range loc 0 end machine-word-bits) )
     297
     298(define-inline (%check-fixnum-bits-count loc count start end)
     299  (unless (%fx< (%fxabs count) (%fx- end start))
     300    (##sys#signal-hook #:bounds-error loc "too many bits for range" count start end) ) )
    274301
    275302;;
     
    327354;;; Extras
    328355
     356;; ERR5RS Unchecked Variants
     357
    329358(define *bitwise-if
    330359  (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
     
    367396
    368397(define *bitwise-rotate-bit-field
    369   (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e))
    370    "C_return( C_uword_bits_rotate_bit_field( (C_uword) n, s, e ) );"))
     398  (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e) (unsigned-int c))
     399   "C_return( C_uword_bits_rotate_bit_field( (C_uword) n, s, e, c ) );"))
    371400
    372401(define (*bitwise-reverse n c)
    373402  (let ((negval? (%negative? n)))
    374403    (do ((mask (if negval? (%bitwise-not n) n) (%arithmetic-shift mask -1))
    375          (count (%fx- c 1) (%fx- c 1))
     404         (count (%fxsub1 c) (%fxsub1 c))
    376405         (revval 0 (%bitwise-ior (%arithmetic-shift revval 1) (%bitwise-and 1 mask))) )
    377406        ((%negative? count) (if negval? (%bitwise-not revval) revval)) ) ) )
     
    404433            (let loop ((i 0) (ils '()))
    405434              (if (%fx= bitlen i) ils
    406                   (loop (%fx+ i 1) (%cons (*bitwise-bit-set? n i) ils)) ) ) ) ) ) ) )
     435                  (loop (%fxadd1 i) (%cons (*bitwise-bit-set? n i) ils)) ) ) ) ) ) ) )
    407436
    408437(define (*bitwise-arithmetic-shift value signed-count)
     
    415444   (%arithmetic-shift value (%fxneg count)) )
    416445
    417 ;; Extras
     446;; Extra Unchecked Variants
    418447
    419448(define *bitwise-if-not
     
    424453  (foreign-lambda* unsigned-int ((integer n))
    425454   "C_return( 2 << C_uword_log2( (C_uword) n ) );"))
     455
     456(define (bitwise-if-not mask true false)
     457  (%check-integer 'bitwise-if-not mask)
     458  (%check-integer 'bitwise-if-not true)
     459  (%check-integer 'bitwise-if-not false)
     460  (*bitwise-if-not mask true false))
     461
     462;; Extra Checked Variants
     463
     464(define (pow2log2 value)
     465  (%check-integer 'pow2log2 value)
     466  (*pow2log2 value) )
     467
     468;;
     469
     470(define (boolean->bit bit) (%boolean->bit* bit))
    426471
    427472
     
    457502(define (bitwise-bit-set? value index)
    458503  (%check-integer 'bitwise-bit-set? value)
    459   (%check-non-negative-fixnum 'bitwise-bit-set? index)
    460   (%check-word-bits 'bitwise-bit-set? index)
     504  (%check-word-bits-range 'bitwise-bit-set? index)
    461505  (*bitwise-bit-set? value index))
    462506
    463507(define (bitwise-copy-bit to index bit)
    464508  (%check-integer 'bitwise-copy-bit to)
    465   (%check-non-negative-fixnum 'bitwise-copy-bit index)
    466   (%check-word-bits 'bitwise-copy-bit index)
     509  (%check-word-bits-range 'bitwise-copy-bit index)
    467510  (*bitwise-copy-bit to index (%boolean->bit* bit) bit)) )
    468511
    469512(define (bitwise-bit-field value start end)
    470513  (%check-integer 'bitwise-bit-field value)
    471   (%check-non-negative-fixnum 'bitwise-bit-field start)
    472   (%check-non-negative-fixnum 'bitwise-bit-field end)
    473   (%check-fixnum<= 'bitwise-bit-field start end)
    474   (%check-word-bits 'bitwise-bit-field start)
    475   (%check-word-bits+1 'bitwise-bit-field end)
     514  (%check-bits-range 'bitwise-bit-field start end)
    476515  (*bitwise-bit-field value start end))
    477516
    478517(define (bitwise-copy-bit-field to start end from)
    479518  (%check-integer 'bitwise-copy-bit-field to)
    480   (%check-non-negative-fixnum 'bitwise-copy-bit-field start)
    481   (%check-non-negative-fixnum 'bitwise-copy-bit-field end)
    482   (%check-fixnum<= 'bitwise-copy-bit-field start end)
    483   (%check-word-bits 'bitwise-copy-bit-field start)
    484   (%check-word-bits+1 'bitwise-copy-bit-field end)
     519  (%check-bits-range 'bitwise-copy-bit-field start end)
    485520  (%check-integer 'bitwise-copy-bit-field from)
    486521  (*bitwise-copy-bit-field to start end from))
    487522
     523; Supports negative count for rotate right
    488524(define (bitwise-rotate-bit-field value start end count)
    489525  (%check-integer 'bitwise-rotate-bit-field value)
    490   (%check-non-negative-fixnum 'bitwise-rotate-bit-field start)
    491   (%check-non-negative-fixnum 'bitwise-rotate-bit-field end)
    492   (%check-fixnum<= 'bitwise-rotate-bit-field start end)
    493   (%check-word-bits 'bitwise-rotate-bit-field start)
    494   (%check-word-bits+1 'bitwise-rotate-bit-field end)
    495526  (%check-fixnum 'bitwise-rotate-bit-field count)
    496   (unless (%fx- count (%fx- end start))
    497     (##sys#signal-hook #:bounds-error 'bitwise-rotate-bit-field "outside of interval" count start end) )
    498   (%check-word-bits 'bitwise-rotate-bit-field count)
     527  (%check-bits-range 'bitwise-rotate-bit-field start end)
     528  (%check-fixnum-bits-count 'bitwise-rotate-bit-field count start end)
    499529  (*bitwise-rotate-bit-field value start end count) )
    500530
    501531(define (bitwise-reverse value count)
    502532  (%check-integer 'bitwise-reverse value)
    503   (%check-non-negative-fixnum 'bitwise-reverse count)
    504   (%check-word-bits 'bitwise-reverse count)
     533  (%check-word-bits-range 'bitwise-reverse count)
    505534  (*bitwise-reverse value count) )
    506535
    507536(define (bitwise-reverse-bit-field value start end)
    508537  (%check-integer 'bitwise-reverse-bit-field value)
    509   (%check-non-negative-fixnum 'bitwise-reverse-bit-field start)
    510   (%check-non-negative-fixnum 'bitwise-reverse-bit-field end)
    511   (%check-fixnum<= 'bitwise-reverse-bit-field start end)
    512   (%check-word-bits 'bitwise-reverse-bit-field start)
    513   (%check-word-bits+1 'bitwise-reverse-bit-field end)
     538  (%check-bits-range 'bitwise-reverse-bit-field start end)
    514539  (*bitwise-reverse-bit-field value start end) )
    515540
     
    521546  (%check-integer 'bitwise-integer->list value)
    522547  (when bitlen
    523     (%check-non-negative-fixnum 'bitwise-integer->list bitlen)
    524     (%check-word-bits 'bitwise-integer->list bitlen) )
     548    (%check-word-bits-range 'bitwise-integer->list bitlen) )
    525549  (*bitwise-integer->list value bitlen) )
    526550
    527551(define (bitwise-arithmetic-shift value signed-count)
    528552  (%check-integer 'bitwise-arithmetic-shift value)
    529   (%check-fixnum 'bitwise-arithmetic-shift signed-count)
    530   (let ([count (if (%fx< signed-count 0) (%fxneg signed-count) signed-count)])
    531     (%check-word-bits 'bitwise-arithmetic-shift count) )
     553  (%check-word-bits-range 'bitwise-arithmetic-shift (fxabs signed-count))
    532554  (%arithmetic-shift value signed-count) )
    533555
    534556(define (bitwise-arithmetic-shift-left value count)
    535557  (%check-integer 'bitwise-arithmetic-shift-left value)
    536   (%check-non-negative-fixnum 'bitwise-arithmetic-shift-left count)
    537   (%check-word-bits 'bitwise-arithmetic-shift-left count)
     558  (%check-word-bits-range 'bitwise-arithmetic-shift-left count)
    538559  (%arithmetic-shift value count) )
    539560
    540561(define (bitwise-arithmetic-shift-right value count)
    541562  (%check-integer 'bitwise-arithmetic-shift-right value)
    542   (%check-non-negative-fixnum 'bitwise-arithmetic-shift-right count)
    543   (%check-word-bits 'bitwise-arithmetic-shift-right count)
     563  (%check-word-bits-range 'bitwise-arithmetic-shift-right count)
    544564  (%arithmetic-shift value (%fxneg count)) )
    545565
    546 ;; Extras
    547 
    548 (define (bitwise-if-not mask true false)
    549   (%check-integer 'bitwise-if-not mask)
    550   (%check-integer 'bitwise-if-not true)
    551   (%check-integer 'bitwise-if-not false)
    552   (*bitwise-if-not mask true false))
    553 
    554 (define (boolean->bit bit)
    555   (%boolean->bit* bit) )
    556 
    557 (define (pow2log2 value)
    558   (%check-integer 'pow2log2 value)
    559   (*pow2log2 value) )
    560 
    561566) ;module err5rs-arithmetic-bitwise
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r13619 r13645  
    1414  (no-procedure-checks)
    1515  (bound-to-procedure
    16     ##sys#check-exact
    1716    ##sys#signal-hook
    1817    ##sys#string-append ) )
     
    2625;;
    2726
    28 (define-inline (%fixnum-zero-division-error loc fx1 fx2)
     27(define-inline (%error-invalid-radix loc radix)
     28  (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
     29
     30(define-inline (%error-zero-division loc fx1 fx2)
    2931  (##sys#signal-hook #:arithmetic-error loc "division by zero" fx1 fx2) )
    3032
    31 (define-inline (%fixnum-representation-error loc fx1 fx2)
     33(define-inline (%error-fixnum-representation loc fx1 fx2)
    3234  (##sys#signal-hook #:arithmetic-error loc "results not representable as fixnums" fx1 fx2) )
    3335
    34 (define-inline (%check-fixnum loc obj) (##sys#check-exact obj loc))
    35 
    36 (define-inline (%check-non-negative-fixnum loc obj)
    37   (unless (and (%fixnum? obj) (%fx<= 0 obj))
    38     (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative fixnum" obj) ) )
    39 
    40 (define-inline (%check-fixnum<= loc fx1 fx2)
    41   (unless (%fx<= fx1 fx2)
    42     (##sys#signal-hook #:bounds-error loc "not a fixnum interval" fx1 fx2) ) )
    43 
    44 (define-inline (%check-fixnum-bits loc fx)
    45   (unless (%fx<= fx fixnum-bits)
    46     (##sys#signal-hook #:bounds-error loc "out of fixnum range" fx) ) )
    47 
    48 (define *fixnum-bits-end* (%fx+ fixnum-bits 1))
    49 
    50 (define-inline (%check-fixnum-bits+1 loc fx)
    51   (unless (%fx<= fx *fixnum-bits-end*)
    52     (##sys#signal-hook #:bounds-error loc "out of fixnum range" fx) ) )
     36;;
     37
     38(define-inline (%check-fixnum loc obj)
     39  (unless (%fixnum? obj)
     40    (%error-invalid-fixnum-argument loc obj) ) )
     41
     42(define-inline (%check-cardinal-fixnum loc obj)
     43  (unless (and (%fixnum? obj) (%fxcardinal? obj))
     44    (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal fixnum" obj) ) )
     45
     46;;
     47
     48(define-inline (%check-fixnum-bounds-order loc start end)
     49  (unless (%fx<= start end)
     50    (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) ) )
     51
     52(define-inline (%check-fixnum-range loc lfx fx hfx)
     53  (unless (%fxclosed? lfx fx hfx)
     54    (%error-outside-range loc fx lfx hfx) ) )
     55
     56;;
     57
     58(define-inline (%check-word-bits-range loc obj)
     59   (%check-fixnum loc obj)
     60   (%check-fixnum-range loc 0 obj fixnum-precision))
     61
     62(define-inline (%check-bits-range loc start end)
     63  (%check-fixnum loc start)
     64  (%check-fixnum loc end)
     65  (%check-fixnum-bounds-order loc start end)
     66  ; Inclusive start
     67  (%check-fixnum-range loc 0 start fixnum-precision)
     68  ; Exclusive end
     69  (%check-fixnum-range loc 0 end fixnum-width) )
     70
     71(define-inline (%check-fixnum-bits-count loc count start end)
     72  (unless (%fx< count (%fx- end start))
     73    (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) ) )
     74
     75;;
    5376
    5477(define-inline (%check-zero-division loc fx1 fx2)
    55   (when (%fx= 0 fx2)
    56     (%fixnum-zero-division-error loc fx1 fx2) ) )
     78  (when (%fxzero? fx2)
     79    (%error-zero-division loc fx1 fx2) ) )
    5780
    5881;;
     
    6083;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
    6184
    62 (define-inline (%fxfold-1 loc func init lyst)
     85(define-inline (%fxfold loc func init lyst)
    6386  (%check-fixnum loc init)
    6487  (let loop ((ls lyst) (acc init))
     
    6891          (loop (%cdr ls) (func acc cur)) ) ) ) )
    6992
    70 (define-inline (%fxand-fold-1 loc func init lyst)
     93(define-inline (%fxand-fold loc func init lyst)
    7194  (%check-fixnum loc init)
    7295  (let loop ((ls lyst) (acc init))
     
    82105  (let* ((quo (%quotient fxn fxd))
    83106         (rem (%- fxn (%* quo fxd))))
    84     (cond ((%>= fxd 0)
     107    (cond ((%<= 0 fxd)
    85108           (if (%< (%* rem 2) fxd)
    86109               (if (%<= (%* rem -2) fxd) (values quo rem)
    87110                   (values (%- quo 1) (%+ rem fxd)) )
    88111               (values (%+ quo 1) (%- rem fxd)) ) )
    89           ((%> (%* rem -2) fxd)
    90            (if (%>= (%* rem 2) fxd) (values quo rem)
     112          ((%< fxd (%* rem -2))
     113           (if (%<= fxd (%* rem 2)) (values quo rem)
    91114               (values (%+ quo 1) (%- rem fxd)) ) )
    92115          (else
     
    96119  (let* ((quo (%quotient fxn fxd))
    97120         (rem (%- fxn (%* quo fxd))))
    98     (cond ((%>= fxd 0)
     121    (cond ((%<= 0 fxd)
    99122           (if (%< (%* rem 2) fxd)
    100123               (if (%<= (%* rem -2) fxd) quo
    101124                   (%- quo 1) )
    102125               (%+ quo 1) ) )
    103           ((%> (%* rem -2) fxd)
    104            (if (%>= (%* rem 2) fxd) quo
     126          ((%< fxd (%* rem -2))
     127           (if (%<= fxd (%* rem 2)) quo
    105128               (%+ quo 1) ) )
    106129          (else
     
    110133  (let* ((quo (%quotient fxn fxd))
    111134         (rem (%- fxn (%* quo fxd))))
    112     (cond ((%>= fxd 0)
     135    (cond ((%<= 0 fxd)
    113136           (if (%< (%* rem 2) fxd)
    114137               (if (%<= (%* rem -2) fxd) rem
    115138                   (%+ rem fxd) )
    116139               (%- rem fxd) ) )
    117           ((%> (%* rem -2) fxd)
    118            (if (%>= (%* rem 2) fxd) rem
     140          ((%< fxd (%* rem -2))
     141           (if (%<= fxd (%* rem 2)) rem
    119142               (%- rem fxd) ) )
    120143          (else
    121144           (%+ rem fxd) ) ) ) )
     145
     146(define-inline (%fxcarry-bit fx) (%arithmetic-shift fx *fixnum-negated-precision*))
    122147
    123148;;
     
    142167  fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right
    143168  fx- ;;fx+ fx* fx/ - from chicken
    144   fxand fxior fxxor
     169  fxand fxior fxxor ;;fxnot - from chicken
    145170  fxif
    146171  fxbit-count
     
    158183  fxnegate
    159184  fxpow2log2
     185  fx=?# fx<?# fx>?# fx<=?# fx>=?#
    160186  fx-# fx+# fx*# fx/#)
    161187
     
    189215
    190216
    191 ;;;
     217;;; Used by '%' inlines.
    192218
    193219(define *fixnum-negated-precision* (%fxneg fixnum-precision))
     
    196222;;;
    197223
    198 (define (fixnum-width) fixnum-precision)
    199 
     224(define (fixnum-width) fixnum-bits)
    200225(define (least-fixnum) most-negative-fixnum)
    201 
    202226(define (greatest-fixnum) most-positive-fixnum)
    203227
     
    205229;;;
    206230
    207 (define (fx=? fx . fxs)
    208   (%fxand-fold-1 'fx=? *fx= fx fxs) )
    209 
    210 (define (fx<? fx . fxs)
    211   (%fxand-fold-1 'fx<? *fx< fx fxs) )
    212 
    213 (define (fx>? fx . fxs)
    214   (%fxand-fold-1 'fx>? *fx> fx fxs) )
    215 
    216 (define (fx<=? fx . fxs)
    217   (%fxand-fold-1 'fx<=? *fx<= fx fxs) )
    218 
    219 (define (fx>=? fx . fxs)
    220   (%fxand-fold-1 'fx>=? *fx>= fx fxs) )
     231(define (fx=? fx . fxs) (%fxand-fold 'fx=? *fx= fx fxs))
     232(define (fx<? fx . fxs) (%fxand-fold 'fx<? *fx< fx fxs))
     233(define (fx>? fx . fxs) (%fxand-fold 'fx>? *fx> fx fxs))
     234(define (fx<=? fx . fxs) (%fxand-fold 'fx<=? *fx<= fx fxs))
     235(define (fx>=? fx . fxs) (%fxand-fold 'fx>=? *fx>= fx fxs))
    221236
    222237(define (fxcompare fx1 fx2)
     
    227242        (else             1) ) )
    228243
    229 (define (fxmax fx . fxs)
    230   (%fxfold-1 'fxmax *fxmax fx fxs) )
    231 
    232 (define (fxmin fx . fxs)
    233   (%fxfold-1 'fxmin *fxmin fx fxs) )
     244(define (fxmax fx . fxs) (%fxfold 'fxmax *fxmax fx fxs))
     245(define (fxmin fx . fxs) (%fxfold 'fxmin *fxmin fx fxs))
    234246
    235247(define (fxmax-and-min fx . fxs)
     
    246258(define (fxzero? fx)
    247259  (%check-fixnum 'fxzero? fx)
    248   (%fx= 0 fx) )
     260  (%fxzero? fx) )
    249261
    250262(define (fxpositive? fx)
    251263  (%check-fixnum 'fxpositive? fx)
    252   (%fx< 0 fx) )
     264  (%fxpositive? fx) )
    253265
    254266(define (fxnegative? fx)
    255267  (%check-fixnum 'fxnegative? fx)
    256   (%fx< fx 0) )
     268  (%fxnegative? fx) )
    257269
    258270(define (fxodd? fx)
    259271  (%check-fixnum 'fxodd? fx)
    260   (%fx= 1 (%fxand fx 1)) )
     272  (%fxodd? fx) )
    261273
    262274(define (fxeven? fx)
    263275  (%check-fixnum 'fxeven? fx)
    264   (%fx= 0 (%fxand fx 1)) )
     276  (%fxeven? fx) )
    265277
    266278
     
    269281(define (fxabs fx)
    270282  (%check-fixnum 'fxabs fx)
    271   (if (%fx< fx 0) (%fxneg fx)
    272       fx ) )
     283  (%fxabs fx) )
    273284
    274285(define (fxdiv fxn fxd)
     
    290301  (let ((d (%fxdiv0 fxn fxd)))
    291302    (if (%fixnum? d) d
    292         (%fixnum-representation-error 'fxdiv0 fxn fxd) ) ) )
     303        (%error-fixnum-representation 'fxdiv0 fxn fxd) ) ) )
    293304
    294305(define (fxmod0 fxn fxd)
     
    298309  (let ((m (%fxmod0 fxn fxd)))
    299310    (if (%fixnum? m) m
    300         (%fixnum-representation-error 'fxmod0 fxn fxd) ) ) )
     311        (%error-fixnum-representation 'fxmod0 fxn fxd) ) ) )
    301312
    302313(define (fxdiv0-and-mod0 fxn fxd)
     
    306317  (let-values (((d m) (%fxdiv0-and-mod0 fxn fxd)))
    307318    (if (and (%fixnum? d) (%fixnum? m)) (values d m)
    308         (%fixnum-representation-error 'fxdiv0-and-mod0 fxn fxd) ) ) )
     319        (%error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd) ) ) )
    309320
    310321(define (fx*/carry fx1 fx2 fx3)
     
    313324  (%check-fixnum 'fx*/carry fx3)
    314325  (let ((res (%fx+ (%fx* fx1 fx2) fx3)))
    315     (values res (%arithmetic-shift (%+ (%* fx1 fx2) (%- fx3 res)) *fixnum-negated-precision*) ) ) )
     326    (values res (%fxcarry-bit (%+ (%* fx1 fx2) (%- fx3 res)))) ) )
    316327
    317328(define (fx+/carry fx1 fx2 fx3)
     
    320331  (%check-fixnum 'fx+/carry fx3)
    321332  (let ((res (%fx+ (%fx+ fx1 fx2) fx3)))
    322     (values res (%arithmetic-shift (%+ (%+ fx1 fx2) (%- fx3 res)) *fixnum-negated-precision*) ) ) )
     333    (values res (%fxcarry-bit (%+ (%+ fx1 fx2) (%- fx3 res)))) ) )
    323334
    324335(define (fx-/carry fx1 fx2 fx3)
     
    327338  (%check-fixnum 'fx-/carry fx3)
    328339  (let ((res (%fx- (%fx- fx1 fx2) fx3)))
    329     (values res (%arithmetic-shift (%- (%- fx1 fx2) (%+ res fx3)) *fixnum-negated-precision*) ) ) )
     340    (values res (%fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) )
    330341
    331342(define (fxadd1 fx)
    332343  (%check-fixnum 'fxadd1 fx)
    333   (%fx+ fx 1) )
     344  (%fxadd1 fx) )
    334345
    335346(define (fxsub1 fx)
    336347  (%check-fixnum 'fxsub1 fx)
    337   (%fx- fx 1) )
     348  (%fxsub1 fx) )
    338349
    339350(define (fxquotient fxn fxd)
     
    358369  (%check-fixnum 'fxarithmetic-shift fx)
    359370  (%check-fixnum 'fxarithmetic-shift amount)
    360   (if (%fx< 0 amount) (%fxshr fx (%fxneg amount))
     371  (if (%fxpositive amount) (%fxshr fx (%fxneg amount))
    361372      (%fxshl fx amount) ) )
    362373
    363374(define (fxarithmetic-shift-left fx amount)
    364375  (%check-fixnum 'fxarithmetic-shift-left fx)
    365   (%check-non-negative-fixnum 'fxarithmetic-shift-left amount)
     376  (%check-cardinal-fixnum 'fxarithmetic-shift-left amount)
    366377  (%fxshl fx amount) )
    367378
    368379(define (fxarithmetic-shift-right fx amount)
    369380  (%check-fixnum 'fxarithmetic-shift-right fx)
    370   (%check-non-negative-fixnum 'fxarithmetic-shift-right amount)
     381  (%check-cardinal-fixnum 'fxarithmetic-shift-right amount)
    371382  (%fxshr fx amount) )
    372383
    373 (define (fx- fx . maybe-fx)
     384(define (fx- fx #!optional fx2)
    374385  (%check-fixnum 'fx- fx)
    375   (if (%null? maybe-fx) (%fxneg fx)
    376       (let ((fx2 (%car maybe-fx)))
     386  (if (not fx2) (%fxneg fx)
     387      (begin
    377388        (%check-fixnum 'fx- fx2)
    378389        (%fx- fx fx2) ) ) )
     
    381392;;;
    382393
    383 (define (fxand fx . fxs)
    384   (%fxfold-1 'fxand *fxand fx fxs) )
    385 
    386 (define (fxior fx . fxs)
    387   (%fxfold-1 'fxior *fxior fx fxs) )
    388 
    389 (define (fxxor fx . fxs)
    390   (%fxfold-1 'fxxor *fxxor fx fxs) )
     394(define (fxand fx . fxs) (%fxfold 'fxand *fxand fx fxs))
     395(define (fxior fx . fxs) (%fxfold 'fxior *fxior fx fxs))
     396(define (fxxor fx . fxs) (%fxfold 'fxxor *fxxor fx fxs))
    391397
    392398
     
    417423(define (fxbit-set? fx index)
    418424  (%check-fixnum 'fxbit-set? fx)
    419   (%check-non-negative-fixnum 'fxbit-set? index)
    420   (%check-fixnum-bits 'fxbit-set? index)
     425  (%check-word-bits-range 'fxbit-set? index)
    421426  (*bitwise-bit-set? fx index) )
    422427
    423428(define (fxcopy-bit fx index bit)
    424429  (%check-fixnum 'fxcopy-bit fx)
    425   (%check-non-negative-fixnum 'fxcopy-bit index)
    426   (%check-fixnum-bits 'fxcopy-bit index)
     430  (%check-word-bits-range 'fxcopy-bit index)
    427431  (%check-fixnum 'fxcopy-bit bit)
    428432  (*bitwise-copy-bit fx index bit) )
     
    430434(define (fxbit-field fx start end)
    431435  (%check-fixnum 'fxbit-field fx)
    432   (%check-non-negative-fixnum 'fxbit-field start)
    433   (%check-non-negative-fixnum 'fxbit-field end)
    434   (%check-fixnum<= 'fxbit-field start end)
    435   (%check-fixnum-bits 'fxbit-field start)
    436   (%check-fixnum-bits+1 'fxbit-field end)
     436  (%check-bits-range 'fxbit-field start end)
    437437  (*bitwise-bit-field fx start end) )
    438438
    439439(define (fxcopy-bit-field fxto start end fxfrom)
    440440  (%check-fixnum 'fxcopy-bit-field fxto)
    441   (%check-non-negative-fixnum 'fxcopy-bit-field start)
    442   (%check-non-negative-fixnum 'fxcopy-bit-field end)
    443   (%check-fixnum<= 'fxcopy-bit-field start end)
    444   (%check-fixnum-bits 'fxcopy-bit-field start)
    445   (%check-fixnum-bits+1 'fxcopy-bit-field end)
     441  (%check-bits-range 'fxcopy-bit-field start end)
    446442  (%check-fixnum 'fxcopy-bit-field fxfrom)
    447443  (*bitwise-copy-bit-field fxto start end fxfrom) )
     
    449445(define (fxrotate-bit-field fx start end count)
    450446  (%check-fixnum 'fxrotate-bit-field fx)
    451   (%check-non-negative-fixnum 'fxrotate-bit-field start)
    452   (%check-non-negative-fixnum 'fxrotate-bit-field end)
    453   (%check-fixnum<= 'fxrotate-bit-field start end)
    454   (%check-fixnum-bits 'fxrotate-bit-field start)
    455   (%check-fixnum-bits+1 'fxrotate-bit-field end)
    456   (%check-non-negative-fixnum 'fxrotate-bit-field count)
    457   (unless (%fx<= count (%fx- end start))
    458     (##sys#signal-hook #:bounds-error 'fxrotate-bit-field "outside of interval" count start end) )
     447  (%check-bits-range 'fxrotate-bit-field start end)
     448  (%check-cardinal-fixnum 'fxrotate-bit-field count)
     449  (%check-fixnum-bits-count 'fxrotate-bit-field count start end)
    459450  (*bitwise-rotate-bit-field fx start end count) )
    460451
    461452(define (fxreverse-bit-field fx start end)
    462453  (%check-fixnum 'fxreverse-bit-field fx)
    463   (%check-non-negative-fixnum 'fxreverse-bit-field start)
    464   (%check-non-negative-fixnum 'fxreverse-bit-field end)
    465   (%check-fixnum<= 'fxreverse-bit-field start end)
    466   (%check-fixnum-bits 'fxreverse-bit-field start)
    467   (%check-fixnum-bits+1 'fxreverse-bit-field end)
     454  (%check-bits-range 'fxreverse-bit-field start end)
    468455  (*bitwise-reverse-bit-field fx start end) )
    469456
    470457
    471458;;; Extras
     459
     460;;
    472461
    473462(define fixnum->string
     
    475464    (lambda (fx #!optional (radix 10))
    476465      (define (fx-digits fx from to)
    477         (if (%fx= 0 fx) (values (%make-string from #\#) to)
     466        (if (%fxzero? fx) (values (%make-string from #\#) to)
    478467            (let* ((quo (%fx/ fx radix))
    479468                   (digit (%string-ref digits (%fx- fx (%fx* quo radix)))))
     
    482471                (values str (%fx+ to 1)) ) ) ) )
    483472      (define (fx->str fx)
    484         (cond ((%fx= 0 fx)
     473        (cond ((%fxzero? fx)
    485474               (%make-string 1 #\0))
    486               ((%fx< 0 fx)
     475              ((%fxpositive fx)
    487476               (let ((str (fx-digits fx 0 0)))
    488477                 (noop str) ; force reference
     
    499488          (fx->str fx))
    500489        (else
    501           (##sys#signal-hook #:type-error 'fixnum->string "bad argument type - invalid radix" radix) ) ) ) ) )
     490          (%error-invalid-radix 'fixnum->string radix) ) ) ) ) )
     491
     492;;
     493
     494(define (fxnegate fx)
     495  (%check-fixnum 'fxnegate fx)
     496  (%fxneg fx) )
     497
     498;;
    502499
    503500(define (fxif-not mask true false)
     
    507504  (*bitwise-if-not mask true false) )
    508505
    509 (define (fxnegate fx)
    510   (%check-fixnum 'fxnegate fx)
    511   (%fxneg fx) )
     506;;
    512507
    513508(define (fxpow2log2 fx)
     
    515510  (*pow2log2 fx) )
    516511
     512;;
     513
     514(define (fx=?# fx . fxs)
     515  (%check-fixnum 'fx=?# fx)
     516  (cond ((%null? fxs)         #t)
     517        ((%null? (%cdr fxs))  (%fx= fx (%car fxs)))
     518        (else                 (%fxand-fold 'fx=?# *fx= fx fxs) ) ) )
     519
     520(define (fx<?# fx . fxs)
     521  (%check-fixnum 'fx<?# fx)
     522  (cond ((%null? fxs)         #t)
     523        ((%null? (%cdr fxs))  (%fx< fx (%car fxs)))
     524        (else                 (%fxand-fold 'fx<?# *fx< fx fxs) ) ) )
     525
     526(define (fx>?# fx . fxs)
     527  (%check-fixnum 'fx>?# fx)
     528  (cond ((%null? fxs)         #t)
     529        ((%null? (%cdr fxs))  (%fx> fx (%car fxs)))
     530        (else                 (%fxand-fold 'fx>?# *fx> fx fxs) ) ) )
     531
     532(define (fx<=?# fx . fxs)
     533  (%check-fixnum 'fx<=?# fx)
     534  (cond ((%null? fxs)         #t)
     535        ((%null? (%cdr fxs))  (%fx<= fx (%car fxs)))
     536        (else                 (%fxand-fold 'fx<=?# *fx<= fx fxs) ) ) )
     537
     538(define (fx>=?# fx . fxs)
     539  (%check-fixnum 'fx>=?# fx)
     540  (cond ((%null? fxs)         #t)
     541        ((%null? (%cdr fxs))  (%fx>= fx (%car fxs)))
     542        (else                 (%fxand-fold 'fx>=?# *fx>= fx fxs) ) ) )
     543
     544;;
     545
    517546(define (fx-# fx . fxs)
    518547  (%check-fixnum 'fx-# fx)
    519   (if (%null? fxs) (%fxneg fx)
    520       (%fxfold-1 'fx-# *fx- fx fxs) ) )
     548  (cond ((%null? fxs)         (%fxneg fx))
     549        ((%null? (%cdr fxs))  (%fx- fx (%car fxs)))
     550        (else                 (%fxfold 'fx-# *fx- fx fxs) ) ) )
    521551
    522552(define (fx+# fx . fxs)
    523553  (%check-fixnum 'fx+# fx)
    524   (if (%null? fxs) fx
    525       (%fxfold-1 'fx+# *fx+ fx fxs) ) )
     554  (cond ((%null? fxs)         fx)
     555        ((%null? (%cdr fxs))  (%fx+ fx (%car fxs)))
     556        (else                 (%fxfold 'fx+# *fx+ fx fxs) ) ) )
    526557
    527558(define (fx*# fx . fxs)
    528559  (%check-fixnum 'fx*# fx)
    529   (if (%null? fxs) fx
    530       (%fxfold-1 'fx*# *fx* fx fxs) ) )
     560  (cond ((%null? fxs)         fx)
     561        ((%null? (%cdr fxs))  (%fx* fx (%car fxs)))
     562        (else                 (%fxfold 'fx*# *fx* fx fxs) ) ) )
    531563
    532564(define (fx/# fx . fxs)
    533565  (%check-fixnum 'fx/# fx)
    534   (if (%null? fxs) fx
    535       (%fxfold-1 'fx/# *fx/ fx fxs) ) )
     566  (cond ((%null? fxs)         fx)
     567        ((%null? (%cdr fxs))  (%fx/ fx (%car fxs)))
     568        (else                 (%fxfold 'fx/# *fx/ fx fxs) ) ) )
    536569
    537570) ;module err5rs-arithmetic-fixnums
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13619 r13645  
    3131(define-inline (%check-flonum loc obj) (##sys#check-inexact obj loc))
    3232
    33 (define-inline (%check-non-negative-integer loc obj)
    34   (##sys#check-integer obj loc)
    35   (unless (%< 0 obj)
    36     (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) )
     33(define-inline (%check-cardinal loc obj)
     34  (unless (%cardinal obj)
     35    (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal number" obj) ) )
    3736
    3837(define-inline (%check-real loc obj)
     
    4443;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
    4544
    46 (define-inline (%fpfold-1 loc func init lyst)
     45(define-inline (%fpfold loc func init lyst)
    4746  (%check-flonum loc init)
    4847  (let loop ((ls lyst) (acc init))
     
    5251          (loop (%cdr ls) (func acc cur)) ) ) ) )
    5352
    54 (define-inline (%fpand-fold-1 loc func init lyst)
     53(define-inline (%fpand-fold loc func init lyst)
    5554  (%check-flonum loc init)
    5655  (let loop ((ls lyst) (acc init))
     
    176175
    177176(define (fl=? fl . fls)
    178         (%fpand-fold-1 'fl=? *fp=? fl fls) )
     177        (%fpand-fold 'fl=? *fp=? fl fls) )
    179178
    180179(define (fl<? fl . fls)
    181         (%fpand-fold-1 'fl<? *fp<? fl fls) )
     180        (%fpand-fold 'fl<? *fp<? fl fls) )
    182181
    183182(define (fl>? fl . fls)
    184         (%fpand-fold-1 'fl>? *fp>? fl fls) )
     183        (%fpand-fold 'fl>? *fp>? fl fls) )
    185184
    186185(define (fl<=? fl . fls)
    187         (%fpand-fold-1 'fl<=? *fp<=? fl fls) )
     186        (%fpand-fold 'fl<=? *fp<=? fl fls) )
    188187
    189188(define (fl>=? fl . fls)
    190         (%fpand-fold-1 'fl>=? *fp>=? fl fls) )
     189        (%fpand-fold 'fl>=? *fp>=? fl fls) )
    191190
    192191(define (flcompare fl1 fl2)
     
    203202
    204203(define (flmax fl . fls)
    205         (%fpfold-1 'flmax *fpmax fl fls) )
     204        (%fpfold 'flmax *fpmax fl fls) )
    206205
    207206(define (flmin fl . fls)
    208         (%fpfold-1 'flmin *fpmin fl fls) )
     207        (%fpfold 'flmin *fpmin fl fls) )
    209208
    210209(define (flmax-and-min fl . fls)
     
    259258
    260259(define (fl+ fl . fls)
    261         (%fpfold-1 'fl+ %fp+ fl fls) )
     260        (%fpfold 'fl+ %fp+ fl fls) )
    262261
    263262(define (fl* fl . fls)
    264         (%fpfold-1 'fl* %fp* fl fls) )
     263        (%fpfold 'fl* %fp* fl fls) )
    265264
    266265(define (fl- fl . fls)
    267266  (if (%null? fls) (%fpnegate fl)
    268       (%fpfold-1 'fl- %fp- fl fls) ) )
     267      (%fpfold 'fl- %fp- fl fls) ) )
    269268
    270269(define (fl/ fl . fls)
    271270  (if (%null? fls) (%fp/ 1.0 fl)
    272         (%fpfold-1 'fl/ %fp/ fl fls) ) )
     271        (%fpfold 'fl/ %fp/ fl fls) ) )
    273272
    274273(define (flabs fl)
     
    342341  (if (not base) (%fplog fl)
    343342      (begin
    344         (%check-non-negative-integer 'fllog base)
     343        (%check-cardinal 'fllog base)
    345344        ((log/base base) fl) ) ) )
    346345
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r13610 r13645  
    9797        (test-assert #b10 (bitwise-rotate-bit-field #b0100 0 4 3) )
    9898        (test-assert #b10 (bitwise-rotate-bit-field #b0100 0 4 -1))
     99        ;                    9   5
    99100        (test-assert #b110100010010000 (bitwise-rotate-bit-field #b110100100010000 5 9 -1))
    100101        (test-assert #b110100000110000 (bitwise-rotate-bit-field #b110100100010000 5 9 1) )
Note: See TracChangeset for help on using the changeset viewer.