Changeset 13778 in project


Ignore:
Timestamp:
03/16/09 02:38:56 (11 years ago)
Author:
Kon Lovett
Message:

Added R6RS invariants. last-bit-set is extras. Revamped fx macros.

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

Legend:

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

    r13775 r13778  
    305305  bitwise-bit-count
    306306  bitwise-length
    307   bitwise-first-bit-set bitwise-last-bit-set
     307  bitwise-first-bit-set
    308308  bitwise-bit-set?
    309309  bitwise-copy-bit
     
    316316  bitwise-arithmetic-shift bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
    317317  ; Extras
     318  bitwise-last-bit-set
    318319  bitwise-if-not
     320  boolean->bit
     321  pow2log2
    319322  *bitwise-if
    320323  *bitwise-test?
    321324  *bitwise-bit-count
    322325  *bitwise-length
    323   *bitwise-first-bit-set *bitwise-last-bit-set
     326  *bitwise-first-bit-set
     327  *bitwise-last-bit-set
    324328  *bitwise-bit-set?
    325329  *bitwise-copy-bit
     
    332336  *bitwise-arithmetic-shift *bitwise-arithmetic-shift-left *bitwise-arithmetic-shift-right
    333337  *bitwise-if-not
    334   *pow2log2
    335   boolean->bit
    336   pow2log2)
     338  *pow2log2)
    337339
    338340(import scheme chicken foreign srfi-1 int-limits)
     
    358360  (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
    359361
    360 ;;; Extras
    361 
    362 ;; ERR5RS Unchecked Variants
     362;;; Unchecked Variants
     363
     364;; ERR5RS
    363365
    364366(define *bitwise-if
     
    380382  (foreign-lambda* int ((integer n))
    381383   "C_return( C_UWORD_LOG2_FACTORS( (C_uword) n ) );"))
    382 
    383 (define *bitwise-last-bit-set
    384   (foreign-lambda* unsigned-int ((integer n))
    385    "C_return( C_uword_log2( (C_uword) n ) );"))
    386384
    387385(define *bitwise-bit-set?
     
    450448   (%arithmetic-shift value (%fxneg count)) )
    451449
    452 ;; Extra Unchecked Variants
     450;; Extras
    453451
    454452(define *bitwise-if-not
     
    456454   "C_return( BITS_MERGE_NOT( m, t, f ) );"))
    457455
     456(define *bitwise-last-bit-set
     457  (foreign-lambda* unsigned-int ((integer n))
     458   "C_return( C_uword_log2( (C_uword) n ) );"))
     459
    458460(define *pow2log2
    459461  (foreign-lambda* unsigned-int ((integer n))
    460462   "C_return( 2 << C_uword_log2( (C_uword) n ) );"))
    461 
    462 (define (bitwise-if-not mask true false)
    463   (%check-integer 'bitwise-if-not mask)
    464   (%check-integer 'bitwise-if-not true)
    465   (%check-integer 'bitwise-if-not false)
    466   (*bitwise-if-not mask true false))
    467 
    468 ;; Extra Checked Variants
    469 
    470 (define (pow2log2 value)
    471   (%check-integer 'pow2log2 value)
    472   (*pow2log2 value) )
    473 
    474 ;;
    475 
    476 (define (boolean->bit bit) (%boolean->bit* bit))
    477463
    478464;;; ERR5RS
     
    500486  (%check-integer 'bitwise-first-bit-set value)
    501487  (*bitwise-first-bit-set value))
    502 
    503 (define (bitwise-last-bit-set value)
    504   (%check-integer 'bitwise-last-bit-set value)
    505   (*bitwise-last-bit-set value))
    506488
    507489(define (bitwise-bit-set? value index)
     
    569551  (%arithmetic-shift value (%fxneg count)) )
    570552
     553;;; Extras
     554
     555(define (bitwise-if-not mask true false)
     556  (%check-integer 'bitwise-if-not mask)
     557  (%check-integer 'bitwise-if-not true)
     558  (%check-integer 'bitwise-if-not false)
     559  (*bitwise-if-not mask true false))
     560
     561(define (bitwise-last-bit-set value)
     562  (%check-integer 'bitwise-last-bit-set value)
     563  (*bitwise-last-bit-set value))
     564
     565(define (boolean->bit bit) (%boolean->bit* bit))
     566
     567(define (pow2log2 value)
     568  (%check-integer 'pow2log2 value)
     569  (*pow2log2 value) )
     570
    571571) ;module err5rs-arithmetic-bitwise
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r13775 r13778  
    126126(define-inline (%fxcarry-bit fx) (%arithmetic-shift fx *fixnum-negated-precision*))
    127127
     128;;
     129
    128130(define-inline (%fxsamesign fx1 fx2)
    129131  (or (and (%fxpositive? fx1) (%fxpositive? fx2)) (and (%fxnegative? fx1) (%fxnegative? fx2))) )
     
    136138  (if (%fxsamesign resfx argfx) (%fx< resfx argfx)
    137139      (%fx> resfx argfx) ) )
     140
     141;;
     142
     143;invariant - (fixnum? (floor (* fx (expt 2 amt))))
     144; shl: msb + amt <= fixnum-precision
     145; shr: msb - amt >= 0
     146
     147(define-inline (%fxshl/check loc fx amt)
     148  (if (<= (%fx+ (*bitwise-last-bit-set fx) amt) fixnum-precision) (%fxshl fx amt)
     149      (error-fixnum-representation loc fx amt) ) )
     150 
     151(define-inline (%fxshr/check loc fx amt)
     152  (if (>= (%fx- (*bitwise-last-bit-set fx) amt) 0) (%fxshr fx amt)
     153      (error-fixnum-representation loc fx amt) ) )
    138154
    139155;;;
     
    156172  fxbit-count
    157173  fxlength
    158   fxfirst-bit-set fxlast-bit-set
     174  fxfirst-bit-set
    159175  fxbit-set?
    160176  fxcopy-bit
     
    171187  fx/ fxquotient fxremainder
    172188  fxif-not
     189  fxlast-bit-set
    173190  fxpow2log2
    174191  fixnum->string
     
    433450;;
    434451
    435 ;invariant - (fixnum? (floorÊ(*ÊfxÊ(exptÊ2Êamount))))
    436 
    437452(define (fxarithmetic-shift fx amount)
    438453  (%check-fixnum 'fxarithmetic-shift fx)
    439454  (%check-fixnum-shift-amount 'fxarithmetic-shift amount)
    440   (if (%fxnegative? amount) (%fxshr fx (%fxneg amount))
    441       (%fxshl fx amount) ) )
     455  (if (%fxnegative? amount) (%fxshr/check 'fxarithmetic-shift fx (%fxneg amount))
     456      (%fxshl/check 'fxarithmetic-shift fx amount) ) )
    442457
    443458(define (fxarithmetic-shift-left fx amount)
    444459  (%check-fixnum 'fxarithmetic-shift-left fx)
    445460  (%check-fixnum-shift-amount 'fxarithmetic-shift-left amount)
    446   (%fxshl fx amount) )
     461  (%fxshl/check 'fxarithmetic-shift-left fx amount) )
    447462
    448463(define (fxarithmetic-shift-right fx amount)
    449464  (%check-fixnum 'fxarithmetic-shift-right fx)
    450465  (%check-fixnum-shift-amount 'fxarithmetic-shift-right amount)
    451   (%fxshr fx amount) )
     466  (%fxshr/check 'fxarithmetic-shift-right fx amount) )
    452467
    453468;;
     
    470485  (%check-fixnum 'fxfirst-bit-set fx)
    471486  (*bitwise-first-bit-set fx) )
    472 
    473 (define (fxlast-bit-set fx)
    474   (%check-fixnum 'fxlast-bit-set fx)
    475   (*bitwise-last-bit-set fx) )
    476487
    477488(define (fxbit-set? fx index)
     
    609620  (*bitwise-if-not mask true false) )
    610621
     622(define (fxlast-bit-set fx)
     623  (%check-fixnum 'fxlast-bit-set fx)
     624  (*bitwise-last-bit-set fx) )
     625
    611626;;
    612627
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13775 r13778  
    66;; - No support for the full-numeric-tower. All operations upon core numerics.
    77;;
    8 ;; - `flnumerator' & `fldenominator` are implemented.
     8;; - `flnumerator' & `fldenominator` are unimplemented.
    99
    1010;;; Prelude
     
    379379;;
    380380;; n = fp * d
    381 ;; d = 1 / (fp / n)
     381;; d = n / fp
    382382
    383383(define (flnumerator fp)
    384384  (%check-flonum 'flnumerator fp)
    385   (cond ((%fpnan? fp)
    386          +nan )
    387         ((or #;(%fp=? -0.0 fp) (%fp=? 0.0 fp) (not (%finite? fp)))
     385  (cond ((or (%integer? fp) #;(%fp=? -0.0 fp) (%fp=? 0.0 fp) (not (%finite? fp)) (%fpnan? fp))
    388386         fp )
    389         (else
     387       (else
    390388          ) ) )
    391389
     
    394392  (cond ((%fpnan? fp)
    395393         +nan )
    396         ((or #;(%fp=? -0.0 fp) (%fp=? 0.0 fp) (not (%finite? fp)))
     394        ((or (%integer? fp) #;(%fp=? -0.0 fp) (%fp=? 0.0 fp) (not (%finite? fp)))
    397395         1.0 )
    398396        (else
Note: See TracChangeset for help on using the changeset viewer.