Changeset 14231 in project
 Timestamp:
 04/10/09 21:59:25 (11 years ago)
 Location:
 release/4/err5rsarithmetic/trunk
 Files:

 5 edited
Legend:
 Unmodified
 Added
 Removed

release/4/err5rsarithmetic/trunk/err5rsarithmeticbitwise.scm
r14031 r14231 21 21 22 22 (include "chickenprimitiveobjectinlines") 23 (include "inlinetypechecks") 23 24 24 25 ;; … … 176 177 (unsafe 177 178 178 (defineinline (%checkfixnum loc obj) #t)179 180 (defineinline (%checklist loc obj) #t)181 182 (defineinline (%checkinteger loc obj) #t)183 184 179 (defineinline (%checkfixnumboundsorder loc fx1 fx2) #t) 185 186 180 (defineinline (%checkfixnumrange loc lfx fx hfx) #t) 187 188 181 (defineinline (%checkwordbitsrange loc obj) #t) 189 190 182 (defineinline (%checkbitsrange loc start end) #t) 191 192 183 (defineinline (%checkfixnumbitscount loc count start end) #t) ) 193 184 194 185 (else 195 196 (defineinline (%checkfixnum loc obj)197 (unless (%fixnum? obj) (errortypefixnum loc obj)) )198 199 (defineinline (%checklist loc obj)200 (unless (%list? obj) (errortypelist loc obj)) )201 202 (defineinline (%checkinteger loc obj)203 (unless (%integer? obj) (errortypeinteger loc obj)) )204 186 205 187 (defineinline (%checkfixnumboundsorder loc fx1 fx2) … … 243 225 (%checkinteger loc cur) 244 226 (loop (%cdr ls) (func acc cur)) ) ) ) ) 227 228 (defineinline (%bwlogic loc func ls ident) 229 (if (%null? ls) ident 230 (let ((1st (%car ls)) 231 (rst (%cdr ls)) ) 232 (if (%null? rst) 1st 233 (%bwfold loc func 1st rst) ) ) ) ) 245 234 246 235 ;;; … … 287 276 *bitwisearithmeticshift *bitwisearithmeticshiftleft *bitwisearithmeticshiftright 288 277 *bitwiseifnot 289 *pow2log2) 278 *pow2log2 279 *bitwiselog2) 290 280 291 281 (import scheme … … 296 286 (bitwisenot chicken:bitwisenot)) 297 287 foreign 288 (only typeerrors errorfixnum errorinteger errorlist) 298 289 (only intlimits machinewordbits machinewordprecision)) 299 290 300 (requirelibrary intlimits)291 (requirelibrary typeerrors intlimits) 301 292 302 293 ;;; Errors 303 294 304 (condexpand 305 (unsafe) 306 (else 307 308 (define (errortypefixnum loc obj) 309 (##sys#signalhook #:typeerror loc "bad argument type  not a fixnum" obj) ) 310 311 (define (errortypeinteger loc obj) 312 (##sys#signalhook #:typeerror loc "bad argument type  not an integer" obj) ) 313 314 (define (errortypelist loc obj) 315 (##sys#signalhook #:typeerror loc "bad argument type  not a list" obj) ) 316 317 (defineinline (erroroutsiderange loc obj low high) 318 (##sys#signalhook #:boundserror loc "out of range" obj low high) ) 319 320 (define (errorboundsorder loc start end) 321 (##sys#signalhook #:boundserror loc "bounds reversed" start end) ) 322 323 (define (errorbitscount loc count start end) 324 (##sys#signalhook #:boundserror loc "too many bits for interval" count start end) ) ) ) 295 (define (erroroutsiderange loc obj low high) 296 (##sys#signalhook #:boundserror loc "out of range" obj low high) ) 297 298 (define (errorboundsorder loc start end) 299 (##sys#signalhook #:boundserror loc "bounds reversed" start end) ) 300 301 (define (errorbitscount loc count start end) 302 (##sys#signalhook #:boundserror loc "too many bits for interval" count start end) ) 325 303 326 304 ;;; Unchecked Variants … … 329 307 330 308 (define *bitwisenot 331 (foreignlambda* integer (( unsignedintegern))332 "return( ~ n);"))309 (foreignlambda* integer ((integer64 n)) 310 "return( ~((C_word) n) );")) 333 311 334 312 (define *bitwiseand 335 (foreignlambda* integer (( unsignedinteger n) (unsignedintegerm))336 "return( n & m);"))313 (foreignlambda* integer ((integer64 n) (integer64 m)) 314 "return( ((C_word) n) & ((C_word) m) );")) 337 315 338 316 (define *bitwiseior 339 (foreignlambda* integer (( unsignedinteger n) (unsignedintegerm))340 "return( n  m);"))317 (foreignlambda* integer ((integer64 n) (integer64 m)) 318 "return( ((C_word) n)  ((C_word) m) );")) 341 319 342 320 (define *bitwisexor 343 (foreignlambda* integer (( unsignedinteger n) (unsignedintegerm))344 "return( n ^ m);"))321 (foreignlambda* integer ((integer64 n) (integer64 m)) 322 "return( ((C_word) n) ^ ((C_word) m) );")) 345 323 346 324 (define *bitwiseif 347 (foreignlambda* integer (( unsignedinteger m) (unsignedinteger t) (unsignedintegerf))348 "return( BITS_MERGE( m, t,f ) );"))325 (foreignlambda* integer ((integer64 m) (integer64 t) (integer64 f)) 326 "return( BITS_MERGE( (C_uword) m, (C_uword) t, (C_uword) f ) );")) 349 327 350 328 (define *bitwisetest? 351 (foreignlambda* bool (( unsignedinteger a) (unsignedintegerb))352 "return( BITS_TEST( a,b ) );"))329 (foreignlambda* bool ((integer64 a) (integer64 b)) 330 "return( BITS_TEST( (C_uword) a, (C_uword) b ) );")) 353 331 354 332 (define *bitwisebitcount 355 (foreignlambda* unsignedint ((unsignedinteger n)) 356 "return( 0 <= ((C_word) n) ? C_uword_bits( n ) : C_uword_bits( ~((C_word) n) ) );")) 357 358 #; 359 (define *bitwisebitcount 360 (foreignlambda* unsignedint ((unsignedinteger n)) 361 "return( 0 <= ((C_word) n) ? C_uword_bits( n ) : ~((C_word) C_uword_bits( ~((C_word) n) )) );")) 362 363 #; 364 (define *bitwisebitcount 365 (foreignlambda unsignedint "C_uword_bits" unsignedinteger)) 333 (foreignlambda* int ((integer64 n)) 334 "return( 0 <= n " 335 "? C_uword_bits( (C_uword) n ) " 336 ": ~((C_word) C_uword_bits( (C_uword) ~n )) );")) 366 337 367 338 (define *bitwiselength 368 (foreignlambda* unsignedint ((unsignedinteger n)) 369 "return( 0 <= ((C_word) n) ? C_uword_log2( n ) : C_uword_log2( ~((C_word) n) ) );")) 370 371 #; 372 (define *bitwiselength 373 (foreignlambda unsignedint "C_uword_log2" unsignedinteger)) 374 339 (foreignlambda* unsignedint ((integer64 n)) 340 "return( 0 <= n " 341 "? C_uword_log2( (C_uword) n ) " 342 ": C_uword_log2( (C_uword) ~n ) );")) 375 343 376 344 (define *bitwisefirstbitset 377 (foreignlambda* int (( unsignedintegern))378 "return( C_UWORD_LOG2_FACTORS( n ) );"))345 (foreignlambda* int ((integer64 n)) 346 "return( C_UWORD_LOG2_FACTORS( (C_uword) n ) );")) 379 347 380 348 (define *bitwisebitset? 381 (foreignlambda* bool (( unsignedintegern) (unsignedint i))382 "return( BIT_TEST( n, i ) );"))349 (foreignlambda* bool ((integer64 n) (unsignedint i)) 350 "return( BIT_TEST( (C_uword) n, i ) );")) 383 351 384 352 (define *bitwisecopybit 385 (foreignlambda* integer (( unsignedintegerto) (unsignedint i) (unsignedint b))386 "return( BIT_COPY( to, i, b ) );"))353 (foreignlambda* integer ((integer64 to) (unsignedint i) (unsignedint b)) 354 "return( BIT_COPY( (C_uword) to, i, b ) );")) 387 355 388 356 (define *bitwisebitfield 389 (foreignlambda* integer (( unsignedintegern) (unsignedint s) (unsignedint e))390 "return( BITS( n, s, e ) );"))357 (foreignlambda* integer ((integer64 n) (unsignedint s) (unsignedint e)) 358 "return( BITS( (C_uword) n, s, e ) );")) 391 359 392 360 (define *bitwisecopybitfield 393 (foreignlambda* integer (( unsignedinteger t) (unsignedint s) (unsignedint e) (unsignedintegerf))394 "return( BITS_COPY( t, s, e,f ) );"))361 (foreignlambda* integer ((integer64 t) (unsignedint s) (unsignedint e) (integer64 f)) 362 "return( BITS_COPY( (C_uword) t, s, e, (C_uword) f ) );")) 395 363 396 364 (define *bitwiserotatebitfield 397 (foreignlambda integer "C_uword_rotate_bit_field" unsignedinteger unsignedint unsignedint unsignedint)) 365 (foreignlambda* integer ((integer64 n) (unsignedint s) (unsignedint e) (unsignedint c)) 366 "return( C_uword_rotate_bit_field( (C_uword) n, s, e, c ) );")) 398 367 399 368 (define *bitwisereverse 400 (foreignlambda integer "C_uword_reverse" unsignedinteger unsignedint)) 401 402 #; 403 (define (*bitwisereverse n c) 404 (let ((negval? (%negative? n))) 405 (do ((mask (if negval? (%bitwisenot n) n) (%arithmeticshift mask 1)) 406 (count (%fxsub1 c) (%fxsub1 count)) 407 (revval 0 (%bitwiseior (%arithmeticshift revval 1) (%bitwiseand 1 mask))) ) 408 ((%fxnegative? count) (if negval? (%bitwisenot revval) revval)) ) ) ) 369 (foreignlambda* integer ((integer64 n) (unsignedint c)) 370 "return( C_uword_reverse( (C_uword) n, c ) );")) 409 371 410 372 (define *bitwisereversebitfield 411 (foreignlambda integer "C_uword_reverse_bit_field" unsignedinteger unsignedint unsignedint)) 412 413 #; 414 (define (*bitwisereversebitfield n s e) 415 (let* ((width (%fx e s)) 416 (mask (%bitwisenot (%arithmeticshift 1 width))) 417 (field (%bitwiseand mask (%arithmeticshift n (%fxneg s)))) ) 418 (%bitwiseior 419 (%arithmeticshift (*bitwisereverse field width) s) 420 (%bitwiseand (%bitwisenot (%arithmeticshift mask s)) n)) ) ) 373 (foreignlambda* integer ((integer64 n) (unsignedint s) (unsignedint e)) 374 "return( C_uword_reverse_bit_field( (C_uword) n, s, e ) );")) 421 375 422 376 ; returns (list lsb .. msb) … … 445 399 446 400 (define *bitwiseifnot 447 (foreignlambda* integer (( unsignedinteger m) (unsignedinteger t) (unsignedintegerf))448 "return( BITS_MERGE_NOT( m, t,f ) );"))401 (foreignlambda* integer ((integer64 m) (integer64 t) (integer64 f)) 402 "return( BITS_MERGE_NOT( (C_uword) m, (C_uword) t, (C_uword) f ) );")) 449 403 450 404 (define *bitwiselastbitset 451 (foreignlambda* unsignedint (( unsignedintegern))452 "return( 0 == n ? 0 : (C_uword_log2(n )  1) );"))405 (foreignlambda* unsignedint ((integer64 n)) 406 "return( 0 == ((C_word) n) ? 0 : (C_uword_log2( (C_uword) n )  1) );")) 453 407 454 408 (define *pow2log2 455 (foreignlambda* unsignedint ((unsignedinteger n)) 456 "return( 2 << C_uword_log2( n ) );")) 409 (foreignlambda* unsignedint ((integer64 n)) 410 "return( 2 << C_uword_log2( (C_uword) n ) );")) 411 412 (define *bitwiselog2 413 (foreignlambda* unsignedint ((integer64 n)) 414 "return( C_uword_log2( (C_uword) n ) );")) 457 415 458 416 ;;; ERR5RS … … 462 420 (*bitwisenot value) ) 463 421 464 (define (bitwiseand value . values) 465 (%bwfold 'bitwiseand *bitwiseand value values) ) 466 467 (define (bitwiseior value . values) 468 (%bwfold 'bitwiseior *bitwiseior value values) ) 469 470 (define (bitwisexor value . values) 471 (%bwfold 'bitwisexor *bitwisexor value values) ) 422 (define (bitwiseand . values) (%bwlogic 'bitwiseand *bitwiseand values 0)) 423 (define (bitwiseior . values) (%bwlogic 'bitwiseior *bitwiseior values 1)) 424 (define (bitwisexor . values) (%bwlogic 'bitwisexor *bitwisexor values 0)) 472 425 473 426 (define (bitwiseif mask true false) 
release/4/err5rsarithmetic/trunk/err5rsarithmeticfixnums.scm
r14190 r14231 21 21 22 22 (include "chickenprimitiveobjectinlines") 23 (include "inlinetypechecks") 23 24 24 25 #> … … 76 77 (unsafe 77 78 78 (defineinline (%checkfixnum loc obj) #t)79 80 79 (defineinline (%checkfixnumshiftamount loc obj) #t) 81 82 80 (defineinline (%checkfixnumboundsorder loc start end) #t) 83 84 81 (defineinline (%checkfixnumrange loc lfx fx hfx) #t) 85 86 82 (defineinline (%checkwordbitsrange loc obj) #t) 87 88 83 (defineinline (%checkbitsrange loc start end) #t) 89 90 84 (defineinline (%checkfixnumbitscount loc obj start end) #t) 91 92 85 (defineinline (%checkzerodivision loc fx1 fx2) #t) ) 93 86 94 87 (else 95 96 (defineinline (%checkfixnum loc obj)97 (unless (%fixnum? obj) (errortypefixnum loc obj)) )98 88 99 89 (defineinline (%checkfixnumshiftamount loc obj) … … 101 91 (unless (let ((amt (if (%fxnegative? obj) (%fxneg obj) obj))) 102 92 (%fxclosed? 0 amt fixnumprecision)) 103 (error typeshiftamount loc obj) ) )93 (errorshiftamount loc obj) ) ) 104 94 105 95 (defineinline (%checkfixnumboundsorder loc start end) … … 281 271 fxlastbitset 282 272 fixnum>string 283 ; Macros 284 $fx=? $fx<? $fx>? $fx<=? $fx>=? $fx<>? 285 $fxmax $fxmin 286 $fx $fx+ $fx* $fx/ 287 $fxand $fxior $fxxor 288 ; Macro helpers 289 fx= fx< fx> fx>= fx<= fx<> 290 fxmax fxmin 291 fxand fxior fxxor 292 fx+ fx fx* fx/) 273 ;; Macros 274 ($fx=? fx=) ($fx<? fx<) ($fx>? fx>) ($fx<=? fx<=) ($fx>=? fx>=) ($fx<>? fx<>) 275 ($fxmax fxmax) ($fxmin fxmin) 276 ($fx fx) ($fx+ fx+) ($fx* fx*) ($fx/ fx/) 277 ($fxand fxand) ($fxior fxior) ($fxxor fxxor)) 293 278 294 279 (import scheme … … 307 292 foreign 308 293 datastructures 294 conditions 295 (only typeerrors errorfixnum) 309 296 (only err5rsarithmeticbitwise 310 297 *bitwiseif *bitwiseifnot … … 316 303 *pow2log2)) 317 304 318 (requirelibrary datastructures err5rsarithmeticbitwise)305 (requirelibrary datastructures conditions typeerrors err5rsarithmeticbitwise) 319 306 320 307 ;;; Conditions 321 308 322 (condexpand 323 (unsafe) 324 (else 325 326 (define (makeexncondition loc msg args) 327 (makepropertycondition 'exn 'location loc 'message msg 'arguments args) ) 328 329 (define (makearithmeticcondition loc msg args . conds) 330 (apply makecompositecondition 331 (makeexncondition loc msg args) 332 (makepropertycondition 'arithmetic) 333 conds) ) 334 335 ; &assertion 336 (define (makezerodivisioncondition loc fx1 fx2) 337 (makearithmeticcondition loc "division by zero" (list fx1 fx2) 338 (makepropertycondition 'division)) ) 339 340 ; &implementationrestriction 341 (define (makefixnumrepresentationcondition loc args) 342 (makearithmeticcondition loc "result not representable as fixnum" args 343 (makepropertycondition 'representation)) ) ) ) 309 (define (makearithmeticcondition loc msg args . cnds) 310 (apply makeexncondition+ loc msg args 'arithmetic cnds) ) 344 311 345 312 ; &assertion 346 (define (zerodivisionviolation? obj) 347 (and (condition? obj) 348 ((conditionpredicate 'arithmetic) obj) 349 ((conditionpredicate 'division) obj) ) ) 313 (define (makezerodivisioncondition loc fx1 fx2) 314 (makearithmeticcondition loc "division by zero" (list fx1 fx2) 'division) ) 350 315 351 316 ; &implementationrestriction 352 (define (representationviolation? obj) 353 (and (condition? obj) 354 ((conditionpredicate 'arithmetic) obj) 355 ((conditionpredicate 'representation) obj) ) ) 317 (define (makefixnumrepresentationcondition loc args) 318 (makearithmeticcondition loc "result not representable as fixnum" args 'representation) ) 319 320 ; &assertion 321 (define zerodivisionviolation? (makeconditionpredicate arithmetic division)) 322 323 ; &implementationrestriction 324 (define representationviolation? (makeconditionpredicate arithmetic representation)) 356 325 357 326 ;;; Errors … … 360 329 (unsafe 361 330 362 (define (errortypefixnum loc obj) #t) 363 364 (define (errortyperadix loc radix) #t) 365 366 (define (erroroutsiderange loc obj low high) #t) 367 368 (define (errorboundsorder loc start end) #t) 369 370 (define (errornegativecount loc count) #t) 371 372 (define (errorbitscount loc count start end) #t) 373 374 (define (errortypeshiftamount loc obj) #t) 375 376 (define (errorzerodivision loc fx1 fx2) #t) 331 (define (errorradix loc radix) #t) 377 332 378 333 (define (errorfixnumrepresentation loc . args) #t) ) … … 380 335 (else 381 336 382 (define (errortypefixnum loc obj) 383 (##sys#signalhook #:typeerror loc "bad argument type  not a fixnum" obj) ) 384 385 (define (errortyperadix loc radix) 337 (define (errorradix loc radix) 386 338 (##sys#signalhook #:typeerror loc "bad argument type  invalid radix" radix) ) 387 339 … … 398 350 (##sys#signalhook #:boundserror loc "too many bits for interval" count start end) ) 399 351 400 (define (error typeshiftamount loc amt)352 (define (errorshiftamount loc amt) 401 353 (##sys#signalhook #:boundserror loc "invalid shift amount" amt) ) 402 354 … … 752 704 (let ((digits "0123456789ABCDEF")) 753 705 (lambda (fx #!optional (radix 10)) 706 754 707 (define (fxdigits fx from to) 755 708 (if (%fxzero? fx) (values (%makestring from #\#) to) … … 759 712 (%stringset! str to digit) 760 713 (values str (%fx+ to 1)) ) ) ) ) 714 761 715 (define (fx>str fx) 762 716 (cond ((%fxzero? fx) … … 774 728 (%stringset! str 0 #\) 775 729 str ) ) ) ) 730 776 731 (%checkfixnum 'fixnum>string fx) 777 732 (case radix 778 ((2 8 10 16) 779 (fx>str fx)) 780 (else 781 (errortyperadix 'fixnum>string radix) ) ) ) ) ) 733 ((2 8 10 16) (fx>str fx)) 734 (else (errorradix 'fixnum>string radix) ) ) ) ) ) 782 735 783 736 ;; 
release/4/err5rsarithmetic/trunk/err5rsarithmeticflonums.scm
r14031 r14231 23 23 24 24 (include "chickenprimitiveobjectinlines") 25 25 (include "inlinetypechecks") 26 26 #;(include "mathhconstants") 27 27 28 28 ;; 29 29 30 (condexpand 31 (unsafe 32 33 (defineinline (%checkfixnum loc obj) #t) 34 35 (defineinline (%checkflonum loc obj) #t) 36 37 #;(defineinline (%checkpositiveinteger loc obj) #t) 38 39 (defineinline (%checkpositive loc obj) #t) 40 41 (defineinline (%checkreal loc obj) #t) ) 42 43 (else 44 45 (defineinline (%checkfixnum loc obj) 46 (unless (%fixnum? obj) (errortypefixnum loc obj)) ) 47 48 (defineinline (%checkflonum loc obj) 49 (unless (%flonum? obj) (errortypeflonum loc obj)) ) 50 51 #;(defineinline (%checkpositiveinteger loc obj) 52 (unless (and (%integer? obj) (%positive? obj)) (errortypepositiveinteger loc obj)) ) 53 54 (defineinline (%checkpositive loc obj) 55 (unless (and (%number? obj) (%positive? obj)) (errortypepositive loc obj)) ) 56 57 (defineinline (%checkreal loc obj) 58 (unless (real? obj) (errortypereal loc obj)) ) ) ) 30 (defineinline (%real? obj) (real? obj)) 31 (defineinlinechecktype real) 59 32 60 33 ;; … … 105 78 106 79 (defineinline (%fp=? x y) 107 (cond ((%fpnegzero? x) (%fpnegzero? y)) 108 ((%fpzero? x) (%fpposzero? y)) 109 (else (%fp= x y) ) ) ) 80 (%fp= x y) 81 #; ;0.0 = 0.0 82 (if (%fpzero? x) (and (%fpzero? y) (%eq? (signbit x) (signbit y))) 83 (%fp= x y) ) ) 110 84 111 85 (defineinline (%fp<? x y) … … 165 139 (values (%fpsub1 quo) (%fp+ rem fpd)) ) ) ) ) 166 140 141 (defineinline (%fpgcd fp1 fp2) 142 (cond ((or (not (%finite? fp1)) (not (%finite? fp2))) 0.0 ) 143 ((%fpzero? fp1) fp2 ) 144 ((%fpzero? fp2) fp1 ) 145 (else ($fpgcd fp1 fp2) ) ) ) 167 146 ;;; 168 147 169 148 (module err5rsarithmeticflonums (;export 170 ; ERR5RS 171 #;noinfinitiesviolation? #;makenoinfinitiesviolation 172 #;nonansviolation? #;makenonansviolation 149 ;; ERR5RS 173 150 real>flonum fixnum>flonum 174 151 fl=? fl<? fl>? fl<=? fl>=? … … 183 160 flexp fllog flsin flcos fltan flasin flacos flatan flsqrt flexpt 184 161 flnumerator fldenominator 185 ; Extras186 flgcd 162 ;; Extras 163 flgcd fllcm 187 164 flonum>fraction 188 165 fl<>? … … 190 167 flfraction 191 168 flnegate 192 ; Macros 193 $fl=? $fl<? $fl>? $fl<=? $fl>=? $fl<>? 194 $flmax $flmin 195 $fl $fl+ $fl* $fl/ 196 ; Macro helpers 197 fp=? fp<? fp>? fp>=? fp<=? fp<>? 198 fpmax fpmin 199 fp+ fp fp* fp/) 200 201 (import scheme chicken foreign srfi1 mathh) 202 203 (requirelibrary srfi1 mathh) 169 ;; Macros 170 ($fl=? fl=?) ($fl<? fl<?) ($fl>? fl>?) ($fl<=? fl>=?) ($fl>=? fl<=?) ($fl<>? fl<>?) 171 ($flmax flmax) ($flmin flmin) 172 ($fl flnegate fl) ($fl+ fl+) ($fl* fl*) ($fl/ fl/)) 173 174 (import scheme chicken foreign srfi1 175 (only typeerrors defineerrortype errorfixnum errorflonum errorpositivenumber) 176 mathh) 177 178 (requirelibrary srfi1 typeerrors mathh) 204 179 205 180 ;;; Errors 206 181 207 (condexpand 208 (unsafe) 209 (else 210 211 (define (errortypefixnum loc obj) 212 (##sys#signalhook #:typeerror loc "bad argument type  not a fixnum" obj) ) 213 214 (define (errortypeflonum loc obj) 215 (##sys#signalhook #:typeerror loc "bad argument type  not a flonum" obj) ) 216 217 (define (errortypereal loc obj) 218 (##sys#signalhook #:typeerror loc "bad argument type  not a real" obj) ) 219 220 (define (errortypepositive loc obj) 221 (##sys#signalhook #:typeerror loc "bad argument type  not a positive number" obj) ) ) ) 182 (defineerrortype real) 222 183 223 184 ;;; Procedures wrapping primitiveinlines for fold operations 224 185 225 (define (f p=? x y)226 (%checkflonum 'f p=? x)227 (%checkflonum 'f p=? y)186 (define (fl=? x y) 187 (%checkflonum 'fl=? x) 188 (%checkflonum 'fl=? y) 228 189 (%fp=? x y) ) 229 190 230 (define (f p<? x y)231 (%checkflonum 'f p<? x)232 (%checkflonum 'f p<? y)191 (define (fl<? x y) 192 (%checkflonum 'fl<? x) 193 (%checkflonum 'fl<? y) 233 194 (%fp<? x y) ) 234 195 235 (define (f p>? x y)236 (%checkflonum 'f p>? x)237 (%checkflonum 'f p>? y)196 (define (fl>? x y) 197 (%checkflonum 'fl>? x) 198 (%checkflonum 'fl>? y) 238 199 (%fp>? x y) ) 239 200 240 (define (f p<=? x y)241 (%checkflonum 'f p<=? x)242 (%checkflonum 'f p<=? y)201 (define (fl<=? x y) 202 (%checkflonum 'fl<=? x) 203 (%checkflonum 'fl<=? y) 243 204 (%fp<=? x y) ) 244 205 245 (define (f p>=? x y)246 (%checkflonum 'f p>=? x)247 (%checkflonum 'f p>=? y)206 (define (fl>=? x y) 207 (%checkflonum 'fl>=? x) 208 (%checkflonum 'fl>=? y) 248 209 (%fp>=? x y) ) 249 210 250 (define (f p<>? x y)251 (%checkflonum 'f p<>? x)252 (%checkflonum 'f p<>? y)211 (define (fl<>? x y) 212 (%checkflonum 'fl<>? x) 213 (%checkflonum 'fl<>? y) 253 214 (not (%fp=? x y)) ) 254 215 255 (define (f pmax x y)256 (%checkflonum 'f pmax x)257 (%checkflonum 'f pmax y)216 (define (flmax x y) 217 (%checkflonum 'flmax x) 218 (%checkflonum 'flmax y) 258 219 (%fpmax x y) ) 259 220 260 (define (f pmin x y)261 (%checkflonum 'f pmin x)262 (%checkflonum 'f pmin y)221 (define (flmin x y) 222 (%checkflonum 'flmin x) 223 (%checkflonum 'flmin y) 263 224 (%fpmin x y) ) 264 225 265 (define (fp x y) 266 (%checkflonum 'fp x) 267 (%checkflonum 'fp y) 226 (define (flnegate x) 227 (%checkflonum 'flnegate x) 228 (%fpnegate x) ) 229 230 (define (fl x y) 231 (%checkflonum 'fl x) 232 (%checkflonum 'fl y) 268 233 (%fp x y) ) 269 234 270 (define (f p+ x y)271 (%checkflonum 'f p+ x)272 (%checkflonum 'f p+ y)235 (define (fl+ x y) 236 (%checkflonum 'fl+ x) 237 (%checkflonum 'fl+ y) 273 238 (%fp+ x y) ) 274 239 275 (define (f p* x y)276 (%checkflonum 'f p* x)277 (%checkflonum 'f p* y)240 (define (fl* x y) 241 (%checkflonum 'fl* x) 242 (%checkflonum 'fl* y) 278 243 (%fp* x y) ) 279 244 280 (define (f p/ x y)281 (%checkflonum 'f p/ x)282 (%checkflonum 'f p/ y)245 (define (fl/ x y) 246 (%checkflonum 'fl/ x) 247 (%checkflonum 'fl/ y) 283 248 (%fp/ x y) ) 284 249 … … 353 318 ;;; ERR5RS 354 319 355 ;; We can represent NaN & Inf356 357 ;;(define (makenoinfinitiesviolation) )358 ;;(define (noinfinitiesviolation? obj) )359 ;;(define (makenonansviolation) )360 ;;(define (nonansviolation? obj) )361 362 320 ;; 363 321 … … 374 332 ;; 375 333 376 (define (fl=? fp . fps) (%fpandfold 'fl=? f p=? fp fps))377 (define (fl<? fp . fps) (%fpandfold 'fl<? f p<? fp fps))378 (define (fl>? fp . fps) (%fpandfold 'fl>? f p>? fp fps))379 (define (fl<=? fp . fps) (%fpandfold 'fl<=? f p<=? fp fps))380 (define (fl>=? fp . fps) (%fpandfold 'fl>=? f p>=? fp fps))381 382 ;; 383 384 (define (flmax fp . fps) (%fpfold 'flmax f pmax fp fps))385 (define (flmin fp . fps) (%fpfold 'flmin f pmin fp fps))334 (define (fl=? fp . fps) (%fpandfold 'fl=? fl=? fp fps)) 335 (define (fl<? fp . fps) (%fpandfold 'fl<? fl<? fp fps)) 336 (define (fl>? fp . fps) (%fpandfold 'fl>? fl>? fp fps)) 337 (define (fl<=? fp . fps) (%fpandfold 'fl<=? fl<=? fp fps)) 338 (define (fl>=? fp . fps) (%fpandfold 'fl>=? fl>=? fp fps)) 339 340 ;; 341 342 (define (flmax fp . fps) (%fpfold 'flmax flmax fp fps)) 343 (define (flmin fp . fps) (%fpfold 'flmin flmin fp fps)) 386 344 387 345 (define (flmaxandmin fp . fps) … … 434 392 ;; 435 393 436 (define (fl+ fp . fps) (%fpfold 'fl+ f p+ fp fps))394 (define (fl+ fp . fps) (%fpfold 'fl+ fl+ fp fps)) 437 395 438 396 (define (fl fp . fps) 439 397 (if (%null? fps) (%fpnegate fp) 440 (%fpfold 'fl f p fp fps) ) )441 442 (define (fl* fp . fps) (%fpfold 'fl* f p* fp fps))398 (%fpfold 'fl fl fp fps) ) ) 399 400 (define (fl* fp . fps) (%fpfold 'fl* fl* fp fps)) 443 401 444 402 (define (fl/ fp . fps) 445 403 (if (%null? fps) (%fp/ 1.0 fp) 446 (%fpfold 'fl/ f p/ fp fps) ) )404 (%fpfold 'fl/ fl/ fp fps) ) ) 447 405 448 406 (define (flabs fp) … … 513 471 (cond ((%fpnegzero? fp) 0.0) 514 472 (base 515 (%checkpositive 'fllog base)473 (%checkpositivenumber 'fllog base) 516 474 ((log/base base) fp) ) 517 475 (else … … 596 554 (%checkflonum 'flgcd fp1) 597 555 (%checkflonum 'flgcd fp2) 598 (cond ((or (not (%finite? fp1)) (not (%finite? fp2))) 599 0.0 ) 600 ((%fpzero? fp1) 601 fp2 ) 602 ((%fpzero? fp2) 603 fp1 ) 604 (else 605 ($fpgcd fp1 fp2) ) ) ) 556 (%fpgcd fp1 fp2) ) 557 558 (define (fllcm fp1 fp2) 559 (%checkflonum 'fllcm fp1) 560 (%checkflonum 'fllcm fp2) 561 (if (or (%fpzero? fp1) (%fpzero? fp2)) 1.0 562 (let ((gcd (%fpgcd fp1 fp2))) 563 (if (%fpzero? gcd) 1.0 564 (%quotient (%fp* fp1 fp2) gcd) ) ) ) ) 606 565 607 566 (define (flonum>fraction fp) … … 614 573 ($fp>fraction fp) ) ) ) 615 574 616 (define (fl<>? fp . fps) (%fpandfold 'fl<>? f p<>? fp fps))575 (define (fl<>? fp . fps) (%fpandfold 'fl<>? fl<>? fp fps)) 617 576 618 577 (define (flcompare fl1 fl2) 619 578 (%checkflonum 'flcompare fl1) 620 579 (%checkflonum 'flcompare fl2) 621 (cond ((%fp =? fl1 fl2) 0)622 ((%fp <? fl1 fl2) 1)580 (cond ((%fp<? fl1 fl2) 1) 581 ((%fp=? fl1 fl2) 0) 623 582 (else 1) ) ) 624 583 … … 627 586 (%fpfraction fp) ) 628 587 629 (define (flnegate fp) 630 (%checkflonum 'flnegate fp) 631 (%fpnegate fp) ) 588 (define flnegate flnegate) 632 589 633 590 ;; … … 636 593 (syntaxrules () 637 594 ((_ ?x) #t ) 638 ((_ ?x ?y) (f p=? ?x ?y) )639 ((_ ?x ?y ?rest ...) (and (f p=? ?x ?y) ($fl=? ?y ?rest ...)) ) ) )595 ((_ ?x ?y) (fl=? ?x ?y) ) 596 ((_ ?x ?y ?rest ...) (and (fl=? ?x ?y) ($fl=? ?y ?rest ...)) ) ) ) 640 597 641 598 (definesyntax $fl<? 642 599 (syntaxrules () 643 600 ((_ ?x) #t ) 644 ((_ ?x ?y) (f p<? ?x ?y) )645 ((_ ?x ?y ?rest ...) (and (f p<? ?x ?y) ($fl<? ?y ?rest ...)) ) ) )601 ((_ ?x ?y) (fl<? ?x ?y) ) 602 ((_ ?x ?y ?rest ...) (and (fl<? ?x ?y) ($fl<? ?y ?rest ...)) ) ) ) 646 603 647 604 (definesyntax $fl>? 648 605 (syntaxrules () 649 606 ((_ ?x) #t ) 650 ((_ ?x ?y) (f p>? ?x ?y) )651 ((_ ?x ?y ?rest ...) (and (f p>? ?x ?y) ($fl>? ?y ?rest ...)) ) ) )607 ((_ ?x ?y) (fl>? ?x ?y) ) 608 ((_ ?x ?y ?rest ...) (and (fl>? ?x ?y) ($fl>? ?y ?rest ...)) ) ) ) 652 609 653 610 (definesyntax $fl<=? 654 611 (syntaxrules () 655 612 ((_ ?x) #t ) 656 ((_ ?x ?y) (f p<=? ?x ?y) )657 ((_ ?x ?y ?rest ...) (and (f p<=? ?x ?y) ($fl<=? ?y ?rest ...)) ) ) )613 ((_ ?x ?y) (fl<=? ?x ?y) ) 614 ((_ ?x ?y ?rest ...) (and (fl<=? ?x ?y) ($fl<=? ?y ?rest ...)) ) ) ) 658 615 659 616 (definesyntax $fl>=? 660 617 (syntaxrules () 661 618 ((_ ?x) #t ) 662 ((_ ?x ?y) (f p>=? ?x ?y) )663 ((_ ?x ?y ?rest ...) (and (f p>=? ?x ?y) ($fl>=? ?y ?rest ...)) ) ) )619 ((_ ?x ?y) (fl>=? ?x ?y) ) 620 ((_ ?x ?y ?rest ...) (and (fl>=? ?x ?y) ($fl>=? ?y ?rest ...)) ) ) ) 664 621 665 622 (definesyntax $fl<>? 666 623 (syntaxrules () 667 624 ((_ ?x) #f ) 668 ((_ ?x ?y) (f p<>? ?x ?y) )669 ((_ ?x ?y ?rest ...) (and (f p<>? ?x ?y) ($fl<>? ?y ?rest ...)) ) ) )625 ((_ ?x ?y) (fl<>? ?x ?y) ) 626 ((_ ?x ?y ?rest ...) (and (fl<>? ?x ?y) ($fl<>? ?y ?rest ...)) ) ) ) 670 627 671 628 ;; … … 674 631 (syntaxrules () 675 632 ((_ ?x) ?x ) 676 ((_ ?x ?y) (f pmax ?x ?y) )677 ((_ ?x ?y ?rest ...) (f pmax ?x ($flmax ?y ?rest ...)) ) ) )633 ((_ ?x ?y) (flmax ?x ?y) ) 634 ((_ ?x ?y ?rest ...) (flmax ?x ($flmax ?y ?rest ...)) ) ) ) 678 635 679 636 (definesyntax $flmin 680 637 (syntaxrules () 681 638 ((_ ?x) ?x ) 682 ((_ ?x ?y) (f pmin ?x ?y) )683 ((_ ?x ?y ?rest ...) (f pmin ?x ($flmin ?y ?rest ...)) ) ) )639 ((_ ?x ?y) (flmin ?x ?y) ) 640 ((_ ?x ?y ?rest ...) (flmin ?x ($flmin ?y ?rest ...)) ) ) ) 684 641 685 642 ;; … … 687 644 (definesyntax $fl 688 645 (syntaxrules () 689 ((_ ?x) (f pneg?x) )690 ((_ ?x ?y) (f p ?x ?y) )691 ((_ ?x ?y ?rest ...) (f p ?x ($fl ?y ?rest ...) ) ) ) )646 ((_ ?x) (flnegate ?x) ) 647 ((_ ?x ?y) (fl ?x ?y) ) 648 ((_ ?x ?y ?rest ...) (fl ?x ($fl ?y ?rest ...) ) ) ) ) 692 649 693 650 (definesyntax $fl+ 694 651 (syntaxrules () 695 652 ((_ ?x) ?x ) 696 ((_ ?x ?y) (f p+ ?x ?y) )697 ((_ ?x ?y ?rest ...) (f p+ ?x ($fl+ ?y ?rest ...) ) ) ) )653 ((_ ?x ?y) (fl+ ?x ?y) ) 654 ((_ ?x ?y ?rest ...) (fl+ ?x ($fl+ ?y ?rest ...) ) ) ) ) 698 655 699 656 (definesyntax $fl* 700 657 (syntaxrules () 701 658 ((_ ?x) ?x ) 702 ((_ ?x ?y) (f p* ?x ?y) )703 ((_ ?x ?y ?rest ...) (f p* ?x ($fl* ?y ?rest ...) ) ) ) )659 ((_ ?x ?y) (fl* ?x ?y) ) 660 ((_ ?x ?y ?rest ...) (fl* ?x ($fl* ?y ?rest ...) ) ) ) ) 704 661 705 662 (definesyntax $fl/ 706 663 (syntaxrules () 707 664 ((_ ?x) ?x ) 708 ((_ ?x ?y) (f p/ ?x ?y) )709 ((_ ?x ?y ?rest ...) (f p/ ?x ($fl/ ?y ?rest ...) ) ) ) )665 ((_ ?x ?y) (fl/ ?x ?y) ) 666 ((_ ?x ?y ?rest ...) (fl/ ?x ($fl/ ?y ?rest ...) ) ) ) ) 710 667 711 668 ) ;module err5rsarithmeticflonums 
release/4/err5rsarithmetic/trunk/err5rsarithmetic.meta
r14008 r14231 7 7 (docfromwiki) 8 8 (synopsis "ERR5RS Arithmetic") 9 (needs setuphelper numberlimits mathh )9 (needs setuphelper numberlimits mathh checkerrors) 10 10 (files 11 11 "tests" 
release/4/err5rsarithmetic/trunk/tests/run.scm
r14031 r14231 10 10 (rem ( n (* quo d)))) 11 11 (cond ((<= 0 d) 12 (if (>= (* rem 2) d) ( + quo 1)12 (if (>= (* rem 2) d) (add1 quo) 13 13 (if (<= (* rem 2) d) quo 14 (  quo 1) ) ) )14 (sub1 quo) ) ) ) 15 15 ((< d (* rem 2)) 16 16 (if (<= d (* rem 2)) quo 17 ( + quo 1) ) )17 (add1 quo) ) ) 18 18 (else 19 (  quo 1) ) ) ) )19 (sub1 quo) ) ) ) ) 20 20 21 21 (define (mod0 n d) … … 31 31 (else 32 32 (+ rem d) ) ) ) ) 33 34 ;; 33 35 34 36 (define (runarithmeticfixnumstests) … … 105 107 106 108 (testassert (not (fixnum? 1.0))) 107 ;;(testassert (not (fixnum? 1+1i))) 109 #;(testassert (not (fixnum? 1+1i))) 110 (testassert (not (fixnum? 1.0))) 108 111 109 112 (testassert (fixnum? 0)) … … 225 228 (test (+ (leastfixnum) 1) (fx* 1 (greatestfixnum))) 226 229 (testerror "&implementationrestriction" (fx* (greatestfixnum) 2)) 227 (testerror " implementationrestriction" (fx* (leastfixnum) 1))230 (testerror "&implementationrestriction" (fx* (leastfixnum) 1)) 228 231 229 232 (test 1 (fx 1)) … … 487 490 (testgroup "R6RS Flonum Test Suite" 488 491 489 (currenttestepsilon 0.00 1)492 (currenttestepsilon 0.00000000000001) 490 493 491 494 (testassert (fl=? +inf +inf)) … … 717 720 (test 2.0 (flround 2.5)) 718 721 722 (currenttestepsilon 0.001) 723 719 724 (test 7.389 (flexp 2.0)) 720 725 (test 2.0 (fllog 7.389)) 721 726 (test 10.0 (fllog 1024.0 2.0)) 727 728 (currenttestepsilon 0.0001) 722 729 723 730 (test 0.0 (flsin 0.0)) … … 742 749 (test 1000.0 (flexpt 10.0 3.0)) 743 750 751 ;; We have infinities & nans 744 752 #;(test (noinfinitiesviolation? (makenoinfinitiesviolation)) #t) 745 753 #;(test ((recordpredicate (recordtypedescriptor &noinfinities)) (makenoinfinitiesviolation)) #t) … … 756 764 757 765 ;; Helpers originally from Ikarus test suite: 766 758 767 (define (ref ei) 759 (do ((result 0 ( + result 1))768 (do ((result 0 (add1 result)) 760 769 (bits (if (negative? ei) (bitwisenot ei) ei) (bitwisearithmeticshift bits 1))) 770 ((zero? bits) result))) 771 772 (define (chicken:ref ei) 773 (do ((result 0 (add1 result)) 774 (bits (if (negative? ei) (chicken:bitwisenot ei) ei) (arithmeticshift bits 1))) 761 775 ((zero? bits) result))) 762 776 … … 768 782 (define (poscountbits n) 769 783 (if (zero? n) 0 770 (let ((c (countbits (bitwisearithmeticshift right n1))))771 (if (even? n) c ( + c 1)))))784 (let ((c (countbits (bitwisearithmeticshift n 1)))) 785 (if (even? n) c (add1 c))))) 772 786 (if (>= n 0) (poscountbits n) 773 787 (bitwisenot (poscountbits (bitwisenot n))))) 788 789 (define (chicken:countbits n) 790 (define (chicken:poscountbits n) 791 (if (zero? n) 0 792 (let ((c (chicken:countbits (arithmeticshift n 1)))) 793 (if (even? n) c (add1 c))))) 794 (if (>= n 0) (chicken:poscountbits n) 795 (chicken:bitwisenot (chicken:poscountbits (chicken:bitwisenot n))))) 774 796 775 797 (definesyntax counttest … … 793 815 (test 4 (bitwisebitcount #b10101010)) 794 816 (test 0 (bitwisebitcount 0)) 795 (test 1 (bitwisebitcount 2)) 817 (test 2 (bitwisebitcount 2)) 818 (test 31 (bitwisebitcount #b11111111111111111111111111111110)) 796 819 797 820 (test 8 (bitwiselength #b10101010)) … … 889 912 (test 1 (bitwisearithmeticshift 1 1)) 890 913 914 (testerror #;(expt 2 301) (bitwisearithmeticshift (expt 2 300) 1)) 915 (testerror #;(expt 2 299) (bitwisearithmeticshift (expt 2 300) 1)) 916 (testerror #;(expt 2 600) (bitwisearithmeticshift (expt 2 300) 300)) 917 (testerror #;1 (bitwisearithmeticshift (expt 2 300) 300)) 918 919 (testerror #;(expt 2 301) (bitwisearithmeticshiftleft (expt 2 300) 1)) 920 (testerror #;(expt 2 299) (bitwisearithmeticshiftright (expt 2 300) 1)) 921 (testerror #;(expt 2 600) (bitwisearithmeticshiftleft (expt 2 300) 300)) 922 (testerror #;1 (bitwisearithmeticshiftright (expt 2 300) 300)) 923 924 (test 13 (bitwisenot 12)) 925 (test 11 (bitwisenot 12)) 926 (test 0 (bitwisenot 1)) 927 (test 1 (bitwisenot 0)) 928 (test (leastfixnum) (bitwisenot (greatestfixnum))) 929 (test (greatestfixnum) (bitwisenot (leastfixnum))) 930 891 931 (test #b1011000 (bitwisereversebitfield #b1010010 1 4)) ; 88 892 932 … … 1061 1101 1062 1102 (counttest 1) 1063 ;;(counttest 28472347823493290482390849023840928390482309480923840923840983)1064 ;;(counttest 847234234903290482390849023840928390482309480923840923840983)1103 #;(counttest 28472347823493290482390849023840928390482309480923840923840983) 1104 #;(counttest 847234234903290482390849023840928390482309480923840923840983) 1065 1105 (counttest (greatestfixnum)) 1066 1106 (counttest (leastfixnum)) 1067 1068 (test 13 (bitwisenot 12)) 1069 (test 11 (bitwisenot 12)) 1070 (test 0 (bitwisenot 1)) 1071 (test 1 (bitwisenot 0)) 1072 (test (leastfixnum) (bitwisenot (greatestfixnum))) 1073 (test (greatestfixnum) (bitwisenot (leastfixnum))) 1074 1075 ;;(test 38947389478348937489375 (bitwisenot 38947389478348937489374)) 1076 ;;(test 22300745198530623141535718272648361505980416 (bitwisenot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)) 1077 ;;(test 38947389478348937489374 (bitwisenot 38947389478348937489375)) 1078 ;;(test 22300745198530623141535718272648361505980414 (bitwisenot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)) 1079 ;;(test 340282366920938463463374607431768211456 (bitwisenot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)) 1080 ;;(test 340282366920938463463374607431768211454 (bitwisenot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)) 1081 ;;(test 79228162514264337593543950337 (bitwisenot #x1000000000000000000000000)) 1082 ;;(test 79228162514264337593543950335 (bitwisenot #x1000000000000000000000000)) 1107 (counttest 4294967295) 1108 (counttest 4294967294) 1109 1110 ;;(test 38947389478348937489375 1111 ;; (bitwisenot 38947389478348937489374)) 1112 ;;(test 22300745198530623141535718272648361505980416 1113 ;; (bitwisenot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)) 1114 ;;(test 38947389478348937489374 1115 ;; (bitwisenot 38947389478348937489375)) 1116 ;;(test 22300745198530623141535718272648361505980414 1117 ;; (bitwisenot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)) 1118 ;;(test 340282366920938463463374607431768211456 1119 ;; (bitwisenot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)) 1120 ;;(test 340282366920938463463374607431768211454 1121 ;; (bitwisenot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)) 1122 ;;(test 79228162514264337593543950337 1123 ;; (bitwisenot #x1000000000000000000000000)) 1124 ;;(test 79228162514264337593543950335 1125 ;; (bitwisenot #x1000000000000000000000000)) 1083 1126 1084 1127 ;;  1085 1128 1086 (testerror #;0 (bitwiseand (expt 2 100) 17)) 1087 (testerror #;17 (bitwiseand ( (expt 2 100) 1) 17)) 1088 (testerror #;(expt 2 90) (bitwiseand ( (expt 2 100) 1) (expt 2 90))) 1089 1090 (testerror #;(bitwiseior (expt 2 100) 17) (bitwisexor (expt 2 100) 17)) 1091 (testerror #;( (expt 2 100) 18) (bitwisexor ( (expt 2 100) 1) 17)) 1092 (testerror #;( (expt 2 100) (expt 2 90) 1) (bitwisexor ( (expt 2 100) 1) (expt 2 90))) 1093 1094 (testerror #;(+ (expt 2 100) 1) (bitwiseif (expt 2 100) 1 1)) 1095 (testerror #;1 (bitwiseif (expt 2 100) 1 1) ) 1096 (testerror #;(+ (expt 2 100) 1) (bitwiseif (expt 2 100) ( (expt 2 200) 1) 1)) 1097 1098 (testerror #;1 (bitwisebitcount (expt 2 300))) 1099 (testerror #;300 (bitwisebitcount ( (expt 2 300) 1))) 1100 (testerror #;301 (bitwisebitcount ( (expt 2 300)))) 1101 1102 (testerror #;301 (bitwiselength (expt 2 300))) 1103 (testerror #;300 (bitwiselength ( (expt 2 300) 1))) 1104 (testerror #;300 (bitwiselength ( (expt 2 300)))) 1105 1106 (testerror #;300 (bitwisefirstbitset (expt 2 300))) 1107 (testerror #;0 (bitwisefirstbitset ( (expt 2 300) 1))) 1108 1109 (testerror (bitwisebitset? (expt 2 300) 300)) 1110 (testerror (not (bitwisebitset? (expt 2 300) 0))) 1111 (testerror (not (bitwisebitset? ( (expt 2 300) 1) 300))) 1112 (testerror (bitwisebitset? ( (expt 2 300) 1) 299)) 1113 (testerror (bitwisebitset? ( (expt 2 300) 1) 298)) 1114 (testerror (not (bitwisebitset? ( (expt 2 300) 2) 0))) 1115 (testerror (bitwisebitset? 1 300)) 1116 (testassert (bitwisebitset? 1 0)) 1117 (testassert (not (bitwisebitset? 2 0))) 1118 1119 (testerror #;0 (bitwisecopybitfield (expt 2 300) 300 302 0)) 1120 (testerror #;(expt 2 300) (bitwisecopybitfield (expt 2 300) 300 302 1)) 1121 (testerror #;(expt 2 301) (bitwisecopybitfield (expt 2 300) 300 302 2)) 1122 (testerror #;(+ (expt 2 300) (expt 2 301)) (bitwisecopybitfield (expt 2 300) 300 302 3)) 1123 1124 (testerror #;(expt 2 301) (bitwisearithmeticshift (expt 2 300) 1)) 1125 (testerror #;(expt 2 299) (bitwisearithmeticshift (expt 2 300) 1)) 1126 (testerror #;(expt 2 600) (bitwisearithmeticshift (expt 2 300) 300)) 1127 (testerror #;1 (bitwisearithmeticshift (expt 2 300) 300)) 1128 1129 (testerror #;(expt 2 301) (bitwisearithmeticshiftleft (expt 2 300) 1)) 1130 (testerror #;(expt 2 299) (bitwisearithmeticshiftright (expt 2 300) 1)) 1131 (testerror #;(expt 2 600) (bitwisearithmeticshiftleft (expt 2 300) 300)) 1132 (testerror #;1 (bitwisearithmeticshiftright (expt 2 300) 300)) 1133 1134 (testerror #;(expt 2 302) (bitwiserotatebitfield (expt 2 300) 299 304 2)) 1135 (testerror #;(expt 2 299) (bitwiserotatebitfield (expt 2 300) 299 304 4)) 1136 1137 (testerror #;(expt 2 302) (bitwisereversebitfield (expt 2 300) 299 304)) 1129 ;;(test 0 (bitwiseand (expt 2 100) 17)) 1130 ;;(test 17 (bitwiseand ( (expt 2 100) 1) 17)) 1131 ;;(test (expt 2 90) (bitwiseand ( (expt 2 100) 1) (expt 2 90))) 1132 1133 ;;(test (bitwiseior (expt 2 100) 17) (bitwisexor (expt 2 100) 17)) 1134 ;;(test ( (expt 2 100) 18) (bitwisexor ( (expt 2 100) 1) 17)) 1135 ;;(test ( (expt 2 100) (expt 2 90) 1) (bitwisexor ( (expt 2 100) 1) (expt 2 90))) 1136 1137 ;;(test (+ (expt 2 100) 1) (bitwiseif (expt 2 100) 1 1)) 1138 ;;(test 1 (bitwiseif (expt 2 100) 1 1) ) 1139 ;;(test (+ (expt 2 100) 1) (bitwiseif (expt 2 100) ( (expt 2 200) 1) 1)) 1140 1141 ;;(test 1 (bitwisebitcount (expt 2 300))) 1142 ;;(test 300 (bitwisebitcount ( (expt 2 300) 1))) 1143 ;;(test 301 (bitwisebitcount ( (expt 2 300)))) 1144 1145 ;;(test 301 (bitwiselength (expt 2 300))) 1146 ;;(test 300 (bitwiselength ( (expt 2 300) 1))) 1147 ;;(test 300 (bitwiselength ( (expt 2 300)))) 1148 1149 ;;(test 300 (bitwisefirstbitset (expt 2 300))) 1150 ;;(test 0 (bitwisefirstbitset ( (expt 2 300) 1))) 1151 1152 ;;(testassert (bitwisebitset? (expt 2 300) 300)) 1153 ;;(testassert (not (bitwisebitset? (expt 2 300) 0))) 1154 ;;(testassert (not (bitwisebitset? ( (expt 2 300) 1) 300))) 1155 ;;(testassert (bitwisebitset? ( (expt 2 300) 1) 299)) 1156 ;;(testassert (bitwisebitset? ( (expt 2 300) 1) 298)) 1157 ;;(testassert (not (bitwisebitset? ( (expt 2 300) 2) 0))) 1158 ;;(testassert (bitwisebitset? 1 300)) 1159 ;;(testassert (bitwisebitset? 1 0)) 1160 ;;(testassert (not (bitwisebitset? 2 0))) 1161 1162 ;;(test 0 (bitwisecopybitfield (expt 2 300) 300 302 0)) 1163 ;;(test (expt 2 300) (bitwisecopybitfield (expt 2 300) 300 302 1)) 1164 ;;(test (expt 2 301) (bitwisecopybitfield (expt 2 300) 300 302 2)) 1165 ;;(test (+ (expt 2 300) (expt 2 301)) (bitwisecopybitfield (expt 2 300) 300 302 3)) 1166 1167 ;;(test (expt 2 302) (bitwiserotatebitfield (expt 2 300) 299 304 2)) 1168 ;;(test (expt 2 299) (bitwiserotatebitfield (expt 2 300) 299 304 4)) 1169 1170 ;;(test (expt 2 302) (bitwisereversebitfield (expt 2 300) 299 304)) 1138 1171 ) 1139 1172 )
Note: See TracChangeset
for help on using the changeset viewer.