770 lines
24 KiB
Scheme
770 lines
24 KiB
Scheme
|
;;; mathprims.ss
|
||
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(eval-when (compile)
|
||
|
|
|
||
|
|
(define-syntax define-relop
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name pred? err not-nan?)
|
||
|
|
(set! name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2) (#2%name x1 x2)]
|
||
|
|
[(x1 x2 x3) (if (#2%name x1 x2) (#2%name x2 x3) (begin (#2%name x2 x3) #f))]
|
||
|
|
[(x1 x2 . rest)
|
||
|
|
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||
|
|
(if (#2%name x1 x2)
|
||
|
|
(or (null? rest) (loop x2 (car rest) (cdr rest)))
|
||
|
|
(let loop ([rest rest])
|
||
|
|
(cond
|
||
|
|
[(null? rest) #f]
|
||
|
|
[(pred? (car rest)) (loop (cdr rest))]
|
||
|
|
[else (err 'name (car rest))]))))]
|
||
|
|
[(x1)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(#3%not-nan? x1)]))]))
|
||
|
|
|
||
|
|
(define-syntax define-r6rs-relop ; requires 2+ arguments
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name pred? err)
|
||
|
|
(set! name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2) (#2%name x1 x2)]
|
||
|
|
[(x1 x2 x3) (if (#2%name x1 x2) (#2%name x2 x3) (begin (#2%name x2 x3) #f))]
|
||
|
|
[(x1 x2 . rest)
|
||
|
|
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||
|
|
(if (#2%name x1 x2)
|
||
|
|
(or (null? rest) (loop x2 (car rest) (cdr rest)))
|
||
|
|
(let loop ([rest rest])
|
||
|
|
(cond
|
||
|
|
[(null? rest) #f]
|
||
|
|
[(pred? (car rest)) (loop (cdr rest))]
|
||
|
|
[else (err 'name (car rest))]))))]))]))
|
||
|
|
|
||
|
|
(define-syntax define-addop
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name)
|
||
|
|
(set! name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2) (#2%name x1 x2)]
|
||
|
|
[(x1 x2 x3) (#2%name (#2%name x1 x2) x3)]
|
||
|
|
[(x1 x2 . rest)
|
||
|
|
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||
|
|
(let ([x (#2%name x1 x2)])
|
||
|
|
(if (null? rest) x (loop x (car rest) (cdr rest)))))]
|
||
|
|
[(x1) (#2%name x1)]
|
||
|
|
[() (#2%name)]))]))
|
||
|
|
|
||
|
|
(define-syntax define-subop
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name pred? err)
|
||
|
|
(set! name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2) (#2%name x1 x2)]
|
||
|
|
[(x1 x2 x3) (#2%name (#2%name x1 x2) x3)]
|
||
|
|
[(x1) (#2%name x1)]
|
||
|
|
[(x0 x1 . rest)
|
||
|
|
(unless (pred? x0) (err 'name x0))
|
||
|
|
(let loop ([x0 x0] [x1 x1] [rest rest])
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(if (null? rest)
|
||
|
|
(#3%name x0 x1)
|
||
|
|
(loop (#3%name x0 x1) (car rest) (cdr rest))))]))]))
|
||
|
|
|
||
|
|
(define-syntax define-generic-subop
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name)
|
||
|
|
(set! name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2) (#2%name x1 x2)]
|
||
|
|
[(x1 x2 x3) (#2%name (#2%name x1 x2) x3)]
|
||
|
|
[(x1) (#2%name x1)]
|
||
|
|
[(x0 x1 . rest)
|
||
|
|
(let loop ([x0 x0] [x1 x1] [rest rest])
|
||
|
|
(if (null? rest)
|
||
|
|
(#2%name x0 x1)
|
||
|
|
(loop (#2%name x0 x1) (car rest) (cdr rest))))]))]))
|
||
|
|
|
||
|
|
(define-syntax define-cfl-relop
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name pred? err not-nan?)
|
||
|
|
(set! name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(unless (pred? x2) (err 'name x2))
|
||
|
|
(#3%name x1 x2)]
|
||
|
|
[(x1 x2 x3)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(unless (pred? x2) (err 'name x2))
|
||
|
|
(unless (pred? x3) (err 'name x3))
|
||
|
|
(and (#3%name x1 x2) (#3%name x2 x3))]
|
||
|
|
[(x1 x2 . rest)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||
|
|
(unless (pred? x2) (err 'name x2))
|
||
|
|
(if (#3%name x1 x2)
|
||
|
|
(or (null? rest) (loop x2 (car rest) (cdr rest)))
|
||
|
|
(let loop ([rest rest])
|
||
|
|
(cond
|
||
|
|
[(null? rest) #f]
|
||
|
|
[(pred? (car rest)) (loop (cdr rest))]
|
||
|
|
[else (err 'name (car rest))]))))]
|
||
|
|
[(x1)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(not-nan? x1)]))]))
|
||
|
|
|
||
|
|
(define-syntax define-cfl-addop
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name pred? err)
|
||
|
|
(set! name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(unless (pred? x2) (err 'name x2))
|
||
|
|
(#3%name x1 x2)]
|
||
|
|
[(x1 x2 x3)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(unless (pred? x2) (err 'name x2))
|
||
|
|
(unless (pred? x3) (err 'name x3))
|
||
|
|
(#3%name (#3%name x1 x2) x3)]
|
||
|
|
[(x1 x2 . rest)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||
|
|
(unless (pred? x2) (err 'name x2))
|
||
|
|
(let ([x (#3%name x1 x2)])
|
||
|
|
(if (null? rest) x (loop x (car rest) (cdr rest)))))]
|
||
|
|
[(x1)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(#3%name x1)]
|
||
|
|
[() (name)]))]))
|
||
|
|
|
||
|
|
(define-syntax define-cfl-subop
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name pred? err)
|
||
|
|
(set! name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(unless (pred? x2) (err 'name x2))
|
||
|
|
(#3%name x1 x2)]
|
||
|
|
[(x1 x2 x3)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(unless (pred? x2) (err 'name x2))
|
||
|
|
(unless (pred? x3) (err 'name x3))
|
||
|
|
(#3%name (#3%name x1 x2) x3)]
|
||
|
|
[(x1)
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(#3%name x1)]
|
||
|
|
[(x0 x1 . rest)
|
||
|
|
(unless (pred? x0) (err 'name x0))
|
||
|
|
(let loop ([x0 x0] [x1 x1] [rest rest])
|
||
|
|
(unless (pred? x1) (err 'name x1))
|
||
|
|
(if (null? rest)
|
||
|
|
(#3%name x0 x1)
|
||
|
|
(loop (#3%name x0 x1) (car rest) (cdr rest))))]))]))
|
||
|
|
)
|
||
|
|
|
||
|
|
(define 1- (lambda (x) (#2%1- x)))
|
||
|
|
|
||
|
|
(define 1+ (lambda (x) (#2%1+ x)))
|
||
|
|
|
||
|
|
(define sub1 (lambda (x) (#2%sub1 x)))
|
||
|
|
|
||
|
|
(define -1+ (lambda (x) (#2%-1+ x)))
|
||
|
|
|
||
|
|
(define add1 (lambda (x) (#2%add1 x)))
|
||
|
|
|
||
|
|
(define-addop +)
|
||
|
|
(define-generic-subop -)
|
||
|
|
(define-addop *)
|
||
|
|
(define-generic-subop /)
|
||
|
|
|
||
|
|
(define-addop logand)
|
||
|
|
(define-addop bitwise-and)
|
||
|
|
(define-addop logior)
|
||
|
|
(define-addop bitwise-ior)
|
||
|
|
(define-addop logor)
|
||
|
|
(define-addop logxor)
|
||
|
|
(define-addop bitwise-xor)
|
||
|
|
|
||
|
|
(define (lognot x) (#2%lognot x))
|
||
|
|
(define (bitwise-not x) (#2%bitwise-not x))
|
||
|
|
|
||
|
|
(define (logbit? x y) (#2%logbit? x y))
|
||
|
|
(define (bitwise-bit-set? x y) (#2%bitwise-bit-set? x y))
|
||
|
|
(define (logbit0 x y) (#2%logbit0 x y))
|
||
|
|
(define (logbit1 x y) (#2%logbit1 x y))
|
||
|
|
(define (logtest x y) (#2%logtest x y))
|
||
|
|
|
||
|
|
(eval-when (compile)
|
||
|
|
(define-syntax define-number-relop
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name)
|
||
|
|
(define name
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2) (#2%name x1 x2)]
|
||
|
|
[(x1 x2 x3) (if (#2%name x1 x2) (#2%name x2 x3) (begin (#2%name x2 x3) #f))]
|
||
|
|
[(x1) (begin (#2%name x1 0) #t)]
|
||
|
|
[(x1 x2 . rest)
|
||
|
|
(let loop ([x1 x1] [x2 x2] [ls rest])
|
||
|
|
(if (or (null? ls) (loop x2 (car ls) (cdr ls)))
|
||
|
|
(#2%name x1 x2)
|
||
|
|
(begin (#2%name x1 x2) #f)))]))])))
|
||
|
|
|
||
|
|
(define-number-relop =)
|
||
|
|
(define-number-relop <)
|
||
|
|
(define-number-relop >)
|
||
|
|
(define-number-relop <=)
|
||
|
|
(define-number-relop >=)
|
||
|
|
|
||
|
|
(eval-when (compile)
|
||
|
|
(define-syntax define-r6rs-number-relop ; requires 2+ argument
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ r6rs:name name)
|
||
|
|
(define-who #(r6rs: name)
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2) (#2%r6rs:name x1 x2)]
|
||
|
|
[(x1 x2 x3) (if (#2%r6rs:name x1 x2)
|
||
|
|
(#2%r6rs:name x2 x3)
|
||
|
|
(begin (#2%r6rs:name x2 x3) #f))]
|
||
|
|
[(x1 x2 . rest)
|
||
|
|
(let loop ([x1 x1] [x2 x2] [ls rest])
|
||
|
|
(if (or (null? ls) (loop x2 (car ls) (cdr ls)))
|
||
|
|
(#2%r6rs:name x1 x2)
|
||
|
|
(begin (#2%r6rs:name x1 x2) #f)))]))])))
|
||
|
|
|
||
|
|
(define-r6rs-number-relop r6rs:= =)
|
||
|
|
(define-r6rs-number-relop r6rs:< <)
|
||
|
|
(define-r6rs-number-relop r6rs:> >)
|
||
|
|
(define-r6rs-number-relop r6rs:<= <=)
|
||
|
|
(define-r6rs-number-relop r6rs:>= >=)
|
||
|
|
|
||
|
|
(eval-when (compile) (optimize-level 3))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define flargerr
|
||
|
|
(lambda (who x)
|
||
|
|
($oops who "~s is not a flonum" x)))
|
||
|
|
|
||
|
|
(set! fl-make-rectangular
|
||
|
|
(lambda (x y)
|
||
|
|
(unless (flonum? x) (flargerr 'fl-make-rectangular x))
|
||
|
|
(unless (flonum? y) (flargerr 'fl-make-rectangular y))
|
||
|
|
(#3%fl-make-rectangular x y)))
|
||
|
|
|
||
|
|
(define-addop fl+)
|
||
|
|
(define-subop fl- flonum? flargerr)
|
||
|
|
(define-addop fl*)
|
||
|
|
(define-subop fl/ flonum? flargerr)
|
||
|
|
|
||
|
|
(set! flabs
|
||
|
|
(lambda (x)
|
||
|
|
(unless (flonum? x) (flargerr 'flabs x))
|
||
|
|
(#3%flabs x)))
|
||
|
|
|
||
|
|
(set! flround
|
||
|
|
(lambda (x)
|
||
|
|
(unless (flonum? x) (flargerr 'flround x))
|
||
|
|
(#3%flround x)))
|
||
|
|
|
||
|
|
(set! fllp
|
||
|
|
(lambda (x)
|
||
|
|
(unless (flonum? x) (flargerr 'fllp x))
|
||
|
|
(#3%fllp x)))
|
||
|
|
|
||
|
|
(define-relop fl= flonum? flargerr fl=)
|
||
|
|
(define-relop fl< flonum? flargerr fl=)
|
||
|
|
(define-relop fl> flonum? flargerr fl=)
|
||
|
|
(define-relop fl<= flonum? flargerr fl=)
|
||
|
|
(define-relop fl>= flonum? flargerr fl=)
|
||
|
|
(define-r6rs-relop fl=? flonum? flargerr)
|
||
|
|
(define-r6rs-relop fl<? flonum? flargerr)
|
||
|
|
(define-r6rs-relop fl>? flonum? flargerr)
|
||
|
|
(define-r6rs-relop fl<=? flonum? flargerr)
|
||
|
|
(define-r6rs-relop fl>=? flonum? flargerr)
|
||
|
|
|
||
|
|
(set-who! $fleqv?
|
||
|
|
(lambda (x y)
|
||
|
|
(unless (flonum? x) (flargerr who x))
|
||
|
|
(unless (flonum? y) (flargerr who y))
|
||
|
|
(#3%$fleqv? x y)))
|
||
|
|
|
||
|
|
(set-who! $flhash
|
||
|
|
(lambda (x)
|
||
|
|
(unless (flonum? x) (flargerr who x))
|
||
|
|
(#3%$flhash x)))
|
||
|
|
|
||
|
|
(set-who! $flonum-exponent ; requires optimize-level 3
|
||
|
|
(lambda (x)
|
||
|
|
(unless (flonum? x) (flargerr who x))
|
||
|
|
($flonum-exponent x)))
|
||
|
|
|
||
|
|
(set-who! $flonum-sign ; requires optimize-level 3
|
||
|
|
(lambda (x)
|
||
|
|
(unless (flonum? x) (flargerr who x))
|
||
|
|
($flonum-sign x)))
|
||
|
|
|
||
|
|
(set-who! flonum->fixnum
|
||
|
|
(let ([flmnf (fixnum->flonum (most-negative-fixnum))]
|
||
|
|
[flmpf (fixnum->flonum (most-positive-fixnum))])
|
||
|
|
(lambda (x)
|
||
|
|
(unless (flonum? x) (flargerr who x))
|
||
|
|
(unless (fl<= flmnf x flmpf)
|
||
|
|
($oops who "result for ~s would be outside of fixnum range" x))
|
||
|
|
(#3%flonum->fixnum x))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define fxargerr
|
||
|
|
(lambda (who x)
|
||
|
|
($oops who "~s is not a fixnum" x)))
|
||
|
|
|
||
|
|
(define /zeroerr
|
||
|
|
(lambda (who)
|
||
|
|
($oops who "attempt to divide by zero")))
|
||
|
|
|
||
|
|
(define fxanserr
|
||
|
|
(lambda (who . args)
|
||
|
|
($impoops who "fixnum overflow computing ~s" (cons who args))))
|
||
|
|
|
||
|
|
(define-addop fx+)
|
||
|
|
(define-subop fx- fixnum? fxargerr)
|
||
|
|
|
||
|
|
(set-who! #(r6rs: fx+) (lambda (x y) (#2%r6rs:fx+ x y)))
|
||
|
|
(set-who! #(r6rs: fx-)
|
||
|
|
(case-lambda
|
||
|
|
[(x) (#2%r6rs:fx- x)]
|
||
|
|
[(x y) (#2%r6rs:fx- x y)]))
|
||
|
|
|
||
|
|
(set! fx1-
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fx1- x)))
|
||
|
|
|
||
|
|
(set! fx1+
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fx1+ x)))
|
||
|
|
|
||
|
|
(set! fxzero?
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxzero? x)))
|
||
|
|
|
||
|
|
(set! fx*
|
||
|
|
(rec fx*
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fixnum? x2)
|
||
|
|
; should handle fixnums (avoiding overflow)
|
||
|
|
(let ([n (* x1 x2)])
|
||
|
|
(if (fixnum? n) n (fxanserr 'fx* x1 x2)))
|
||
|
|
(fxargerr 'fx* x2))
|
||
|
|
(fxargerr 'fx* x1))]
|
||
|
|
[(x1 x2 x3)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fixnum? x2)
|
||
|
|
(if (fixnum? x3)
|
||
|
|
; should handle fixnums (avoiding overflow)
|
||
|
|
(let ([n (* x1 x2)])
|
||
|
|
(if (fixnum? n)
|
||
|
|
; should handle fixnums (avoiding overflow)
|
||
|
|
(let ([n (* n x3)])
|
||
|
|
(if (fixnum? n) n (fxanserr 'fx* x1 x2 x3)))
|
||
|
|
(fxanserr 'fx* x1 x2 x3)))
|
||
|
|
(fxargerr 'fx* x3))
|
||
|
|
(fxargerr 'fx* x2))
|
||
|
|
(fxargerr 'fx* x1))]
|
||
|
|
[(x1) (if (fixnum? x1) x1 (fxargerr 'fx* x1))]
|
||
|
|
[() 1]
|
||
|
|
[(x1 . rest)
|
||
|
|
(let loop ([a x1] [ls rest])
|
||
|
|
(if (null? ls)
|
||
|
|
a
|
||
|
|
(loop (fx* a (car ls)) (cdr ls))))])))
|
||
|
|
|
||
|
|
(set-who! #(r6rs: fx*)
|
||
|
|
(lambda (x1 x2)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fixnum? x2)
|
||
|
|
; should handle fixnums (avoiding overflow)
|
||
|
|
(let ([n (* x1 x2)])
|
||
|
|
(if (fixnum? n) n (fxanserr who x1 x2)))
|
||
|
|
(fxargerr who x2))
|
||
|
|
(fxargerr who x1))))
|
||
|
|
|
||
|
|
(set! fxquotient
|
||
|
|
(rec fxquotient
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fixnum? x2)
|
||
|
|
(begin
|
||
|
|
(when (fx= x2 0) (/zeroerr 'fxquotient))
|
||
|
|
(if (and (fx= x2 -1) (fx= x1 (most-negative-fixnum)))
|
||
|
|
(fxanserr 'fxquotient x1 x2)
|
||
|
|
(#3%fxquotient x1 x2)))
|
||
|
|
(fxargerr 'fxquotient x2))
|
||
|
|
(fxargerr 'fxquotient x1))]
|
||
|
|
[(x1 x2 x3)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fixnum? x2)
|
||
|
|
(if (fixnum? x3)
|
||
|
|
(begin
|
||
|
|
(when (fx= x2 0) (/zeroerr 'fxquotient))
|
||
|
|
(if (and (fx= x2 -1) (fx= x1 (most-negative-fixnum)))
|
||
|
|
(fxanserr 'fxquotient x1 x2 x3)
|
||
|
|
(let ([n (#3%fxquotient x1 x2)])
|
||
|
|
(when (fx= x3 0) (/zeroerr 'fxquotient))
|
||
|
|
(if (and (fx= x3 -1) (fx= n (most-negative-fixnum)))
|
||
|
|
(fxanserr 'fxquotient x1 x2 x3)
|
||
|
|
(#3%fxquotient n x3)))))
|
||
|
|
(fxargerr 'fxquotient x3))
|
||
|
|
(fxargerr 'fxquotient x2))
|
||
|
|
(fxargerr 'fxquotient x1))]
|
||
|
|
[(x1)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fx= x1 0)
|
||
|
|
(/zeroerr 'fxquotient)
|
||
|
|
(#3%fxquotient 1 x1))
|
||
|
|
(fxargerr 'fxquotient x1))]
|
||
|
|
[(x1 . rest)
|
||
|
|
(let loop ([a x1] [ls rest])
|
||
|
|
(if (null? ls)
|
||
|
|
a
|
||
|
|
(loop (fxquotient a (car ls)) (cdr ls))))])))
|
||
|
|
|
||
|
|
(set! fx/
|
||
|
|
(rec fx/ ;; same as fxquotient---should it be?
|
||
|
|
(case-lambda
|
||
|
|
[(x1 x2)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fixnum? x2)
|
||
|
|
(begin
|
||
|
|
(when (fx= x2 0) (/zeroerr 'fx/))
|
||
|
|
(if (and (fx= x2 -1) (fx= x1 (most-negative-fixnum)))
|
||
|
|
(fxanserr 'fx/ x1 x2)
|
||
|
|
(#3%fx/ x1 x2)))
|
||
|
|
(fxargerr 'fx/ x2))
|
||
|
|
(fxargerr 'fx/ x1))]
|
||
|
|
[(x1 x2 x3)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fixnum? x2)
|
||
|
|
(if (fixnum? x3)
|
||
|
|
(begin
|
||
|
|
(when (fx= x2 0) (/zeroerr 'fx/))
|
||
|
|
(if (and (fx= x2 -1) (fx= x1 (most-negative-fixnum)))
|
||
|
|
(fxanserr 'fx/ x1 x2 x3)
|
||
|
|
(let ([n (#3%fx/ x1 x2)])
|
||
|
|
(when (fx= x3 0) (/zeroerr 'fx/))
|
||
|
|
(if (and (fx= x3 -1) (fx= n (most-negative-fixnum)))
|
||
|
|
(fxanserr 'fx/ x1 x2 x3)
|
||
|
|
(#3%fx/ n x3)))))
|
||
|
|
(fxargerr 'fx/ x3))
|
||
|
|
(fxargerr 'fx/ x2))
|
||
|
|
(fxargerr 'fx/ x1))]
|
||
|
|
[(x1)
|
||
|
|
(if (fixnum? x1)
|
||
|
|
(if (fx= x1 0)
|
||
|
|
(/zeroerr 'fx/)
|
||
|
|
(#3%fx/ 1 x1))
|
||
|
|
(fxargerr 'fx/ x1))]
|
||
|
|
[(x1 . rest)
|
||
|
|
(let loop ([a x1] [ls rest])
|
||
|
|
(if (null? ls)
|
||
|
|
a
|
||
|
|
(loop (fx/ a (car ls)) (cdr ls))))])))
|
||
|
|
|
||
|
|
(set! fxabs
|
||
|
|
(lambda (x)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxabs x))
|
||
|
|
(when (fx= x (most-negative-fixnum)) (fxanserr 'fxabs x))
|
||
|
|
(#3%fxabs x)))
|
||
|
|
|
||
|
|
(define-relop fx= fixnum? fxargerr fx=)
|
||
|
|
(define-relop fx< fixnum? fxargerr fx=)
|
||
|
|
(define-relop fx> fixnum? fxargerr fx=)
|
||
|
|
(define-relop fx<= fixnum? fxargerr fx=)
|
||
|
|
(define-relop fx>= fixnum? fxargerr fx=)
|
||
|
|
(define-r6rs-relop fx=? fixnum? fxargerr)
|
||
|
|
(define-r6rs-relop fx<? fixnum? fxargerr)
|
||
|
|
(define-r6rs-relop fx>? fixnum? fxargerr)
|
||
|
|
(define-r6rs-relop fx<=? fixnum? fxargerr)
|
||
|
|
(define-r6rs-relop fx>=? fixnum? fxargerr)
|
||
|
|
|
||
|
|
(set! $fxu<
|
||
|
|
(lambda (x y)
|
||
|
|
(unless (fixnum? x) (fxargerr '$fxu< x))
|
||
|
|
(unless (fixnum? y) (fxargerr '$fxu< y))
|
||
|
|
(#3%$fxu< x y)))
|
||
|
|
|
||
|
|
(define-addop fxlogand)
|
||
|
|
(define-addop fxlogior)
|
||
|
|
(define-addop fxlogor)
|
||
|
|
(define-addop fxlogxor)
|
||
|
|
(define-addop fxand)
|
||
|
|
(define-addop fxior)
|
||
|
|
(define-addop fxxor)
|
||
|
|
|
||
|
|
(set! fxsll
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxsll x y)))
|
||
|
|
|
||
|
|
(set! fxarithmetic-shift-left
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxarithmetic-shift-left x y)))
|
||
|
|
|
||
|
|
(set! fxsrl
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxsrl x y)))
|
||
|
|
|
||
|
|
(set! fxsra
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxsra x y)))
|
||
|
|
|
||
|
|
(set! fxarithmetic-shift-right
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxarithmetic-shift-right x y)))
|
||
|
|
|
||
|
|
(set! fxarithmetic-shift
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxarithmetic-shift x y)))
|
||
|
|
|
||
|
|
(set! fxlognot
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxlognot x)))
|
||
|
|
|
||
|
|
(set! fxnot
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxnot x)))
|
||
|
|
|
||
|
|
(set! fxlogtest
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxlogtest x y)))
|
||
|
|
|
||
|
|
(set! fxlogbit?
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxlogbit? x y)))
|
||
|
|
|
||
|
|
(set! fxbit-set?
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxbit-set? x y)))
|
||
|
|
|
||
|
|
(set! fxlogbit0
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxlogbit0 x y)))
|
||
|
|
|
||
|
|
(set! fxlogbit1
|
||
|
|
(lambda (x y)
|
||
|
|
(#2%fxlogbit1 x y)))
|
||
|
|
|
||
|
|
(set-who! fxcopy-bit
|
||
|
|
(lambda (n k b)
|
||
|
|
; optimize-level 2 handler doesn't kick in unless b=0 or b=1
|
||
|
|
(unless (fixnum? n) (fxargerr who n))
|
||
|
|
(unless (fixnum? k) (fxargerr who k))
|
||
|
|
(unless ($fxu< k (fx- (fixnum-width) 1))
|
||
|
|
($oops who "invalid bit index ~s" k))
|
||
|
|
(case b
|
||
|
|
[(0) (#3%fxlogbit0 k n)]
|
||
|
|
[(1) (#3%fxlogbit1 k n)]
|
||
|
|
[else ($oops who "invalid bit value ~s" b)])))
|
||
|
|
|
||
|
|
(set! fxeven?
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxeven? x)))
|
||
|
|
|
||
|
|
(set! fxodd?
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxodd? x)))
|
||
|
|
|
||
|
|
(set! fxremainder
|
||
|
|
(lambda (x y)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxremainder x))
|
||
|
|
(unless (fixnum? y) (fxargerr 'fxremainder y))
|
||
|
|
(when (fx= y 0) (/zeroerr 'fxremainder))
|
||
|
|
(#3%fxremainder x y)))
|
||
|
|
|
||
|
|
(set! fxmodulo
|
||
|
|
(lambda (x y)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxmodulo x))
|
||
|
|
(unless (fixnum? y) (fxargerr 'fxmodulo y))
|
||
|
|
(when (fx= y 0) (/zeroerr 'fxmodulo))
|
||
|
|
(let ([r (fxremainder x y)])
|
||
|
|
(if (if (fxnegative? y) (fxpositive? r) (fxnegative? r))
|
||
|
|
(fx+ r y)
|
||
|
|
r))))
|
||
|
|
|
||
|
|
(set! fxmin
|
||
|
|
(case-lambda
|
||
|
|
[(x y)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxmin x))
|
||
|
|
(unless (fixnum? y) (fxargerr 'fxmin y))
|
||
|
|
(if (fx< y x) y x)]
|
||
|
|
[(x y z)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxmin x))
|
||
|
|
(unless (fixnum? y) (fxargerr 'fxmin y))
|
||
|
|
(unless (fixnum? z) (fxargerr 'fxmin z))
|
||
|
|
(if (fx< y x)
|
||
|
|
(if (fx< z y) z y)
|
||
|
|
(if (fx< z x) z x))]
|
||
|
|
[(x . y)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxmin x))
|
||
|
|
(let f ([x x] [y y])
|
||
|
|
(if (null? y)
|
||
|
|
x
|
||
|
|
(f (let ([z (car y)])
|
||
|
|
(unless (fixnum? z) (fxargerr 'fxmin z))
|
||
|
|
(if (fx< z x) z x))
|
||
|
|
(cdr y))))]))
|
||
|
|
|
||
|
|
(set! fxmax
|
||
|
|
(case-lambda
|
||
|
|
[(x y)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxmax x))
|
||
|
|
(unless (fixnum? y) (fxargerr 'fxmax y))
|
||
|
|
(if (fx> y x) y x)]
|
||
|
|
[(x y z)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxmax x))
|
||
|
|
(unless (fixnum? y) (fxargerr 'fxmax y))
|
||
|
|
(unless (fixnum? z) (fxargerr 'fxmax z))
|
||
|
|
(if (fx> y x)
|
||
|
|
(if (fx> z y) z y)
|
||
|
|
(if (fx> z x) z x))]
|
||
|
|
[(x . y)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fxmax x))
|
||
|
|
(let f ([x x] [y y])
|
||
|
|
(if (null? y)
|
||
|
|
x
|
||
|
|
(f (let ([z (car y)])
|
||
|
|
(unless (fixnum? z) (fxargerr 'fxmax z))
|
||
|
|
(if (fx> z x) z x))
|
||
|
|
(cdr y))))]))
|
||
|
|
|
||
|
|
(set! fxnegative?
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxnegative? x)))
|
||
|
|
|
||
|
|
(set! fxpositive?
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxpositive? x)))
|
||
|
|
|
||
|
|
(set! fxnonnegative?
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxnonnegative? x)))
|
||
|
|
|
||
|
|
(set! fxnonpositive?
|
||
|
|
(lambda (x)
|
||
|
|
(#2%fxnonpositive? x)))
|
||
|
|
|
||
|
|
(set! fixnum->flonum
|
||
|
|
(lambda (x)
|
||
|
|
(unless (fixnum? x) (fxargerr 'fixnum->flonum x))
|
||
|
|
(#3%fixnum->flonum x)))
|
||
|
|
|
||
|
|
(set-who! fxlength
|
||
|
|
(lambda (x)
|
||
|
|
(if (fixnum? x)
|
||
|
|
(#3%fxlength x)
|
||
|
|
(fxargerr who x))))
|
||
|
|
|
||
|
|
(set-who! fxfirst-bit-set
|
||
|
|
(lambda (x)
|
||
|
|
(if (fixnum? x)
|
||
|
|
(#3%fxfirst-bit-set x)
|
||
|
|
(fxargerr who x))))
|
||
|
|
|
||
|
|
(set-who! fxif
|
||
|
|
(lambda (x y z)
|
||
|
|
(if (fixnum? x)
|
||
|
|
(if (fixnum? y)
|
||
|
|
(if (fixnum? z)
|
||
|
|
(#3%fxif x y z)
|
||
|
|
(fxargerr who z))
|
||
|
|
(fxargerr who y))
|
||
|
|
(fxargerr who x))))
|
||
|
|
|
||
|
|
(set-who! fxbit-field
|
||
|
|
(lambda (n start end)
|
||
|
|
(if (fixnum? n)
|
||
|
|
(if (and (fixnum? start) ($fxu< start (fixnum-width)))
|
||
|
|
(if (and (fixnum? end) ($fxu< end (fixnum-width)))
|
||
|
|
(if (fx<= start end)
|
||
|
|
(fxsra (fxand n (fxnot (fxsll -1 end))) start)
|
||
|
|
($oops who "start index ~s is greater than end index ~s" start end))
|
||
|
|
($oops who "~s is not a valid end index" end))
|
||
|
|
($oops who "~s is not a valid start index" start))
|
||
|
|
(fxargerr who n))))
|
||
|
|
|
||
|
|
(set-who! fxcopy-bit-field
|
||
|
|
(lambda (n start end m)
|
||
|
|
(if (fixnum? n)
|
||
|
|
(if (and (fixnum? start) ($fxu< start (fixnum-width)))
|
||
|
|
(if (and (fixnum? end) ($fxu< end (fixnum-width)))
|
||
|
|
(if (fx<= start end)
|
||
|
|
(if (fixnum? m)
|
||
|
|
(let ([mask (fx- (fxsll 1 (fx- end start)) 1)])
|
||
|
|
(fxior
|
||
|
|
(fxand n (fxnot (fxsll mask start)))
|
||
|
|
(fxsll (fxand m mask) start)))
|
||
|
|
(fxargerr who m))
|
||
|
|
($oops who "start index ~s is greater than end index ~s" start end))
|
||
|
|
($oops who "~s is not a valid end index" end))
|
||
|
|
($oops who "~s is not a valid start index" start))
|
||
|
|
(fxargerr who n))))
|
||
|
|
)
|
||
|
|
|
||
|
|
;;; The "cfl" operations could be done at level 0 by expanding them out.
|
||
|
|
;;; They might be more efficient that way since they wouldn't have to
|
||
|
|
;;; do double flonum checking.
|
||
|
|
|
||
|
|
(define cflonum?
|
||
|
|
(lambda (x)
|
||
|
|
(cflonum? x)))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
|
||
|
|
(define noncflonum-error
|
||
|
|
(lambda (who x)
|
||
|
|
($oops who "~s is not a cflonum" x)))
|
||
|
|
|
||
|
|
(set! cfl-real-part
|
||
|
|
(lambda (z)
|
||
|
|
(type-case z
|
||
|
|
[($inexactnum?) ($inexactnum-real-part z)]
|
||
|
|
[(flonum?) z]
|
||
|
|
[else (noncflonum-error 'cfl-real-part z)])))
|
||
|
|
|
||
|
|
(set! cfl-imag-part
|
||
|
|
(lambda (z)
|
||
|
|
(type-case z
|
||
|
|
[($inexactnum?) ($inexactnum-imag-part z)]
|
||
|
|
[(flonum?) 0.0]
|
||
|
|
[else (noncflonum-error 'cfl-imag-part z)])))
|
||
|
|
|
||
|
|
(define-cfl-addop cfl+ cflonum? noncflonum-error)
|
||
|
|
(define-cfl-addop cfl* cflonum? noncflonum-error)
|
||
|
|
(define-cfl-subop cfl- cflonum? noncflonum-error)
|
||
|
|
(define-cfl-subop cfl/ cflonum? noncflonum-error)
|
||
|
|
(define-cfl-relop cfl= cflonum? noncflonum-error cfl=)
|
||
|
|
|
||
|
|
(set! cfl-conjugate
|
||
|
|
(lambda (x)
|
||
|
|
(type-case x
|
||
|
|
[(cflonum?) (#3%cfl-conjugate x)]
|
||
|
|
[else (noncflonum-error 'cfl-conjugate x)])))
|
||
|
|
|
||
|
|
)
|
||
|
|
)
|