forked from gambit/gambit
-
Notifications
You must be signed in to change notification settings - Fork 1
/
#.scm
120 lines (97 loc) · 3.18 KB
/
#.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
(include "../#.scm")
(define-macro (macro-inexact-+pi) 3.141592653589793)
(define-macro (macro-inexact--pi) -3.141592653589793)
(define-macro (macro-inexact-+pi/2) 1.5707963267948966)
(define-macro (macro-inexact--pi/2) -1.5707963267948966)
(define-macro (macro-inexact-+pi/4) .7853981633974483)
(define-macro (macro-inexact-+3pi/4) 2.356194490192345)
(##define-macro (macro-cpxnum-+1/2+sqrt3/2i)
(make-rectangular 1/2 (/ (sqrt 3) 2)))
(##define-macro (macro-cpxnum-+1/2-sqrt3/2i)
(make-rectangular 1/2 (- (/ (sqrt 3) 2))))
(##define-macro (macro-cpxnum--1/2+sqrt3/2i)
(make-rectangular -1/2 (/ (sqrt 3) 2)))
(##define-macro (macro-cpxnum--1/2-sqrt3/2i)
(make-rectangular -1/2 (- (/ (sqrt 3) 2))))
(##define-macro (macro-cpxnum-+sqrt3/2+1/2i)
(make-rectangular (/ (sqrt 3) 2) 1/2))
(##define-macro (macro-cpxnum-+sqrt3/2-1/2i)
(make-rectangular (/ (sqrt 3) 2) -1/2))
(##define-macro (macro-cpxnum--sqrt3/2+1/2i)
(make-rectangular (- (/ (sqrt 3) 2)) 1/2))
(##define-macro (macro-cpxnum--sqrt3/2-1/2i)
(make-rectangular (- (/ (sqrt 3) 2)) -1/2))
(set! epsilon 1e-12)
;;; Naive, but correct, definitions of inverse trigonometric and
;;; hyperbolic functions in terms of log and sqrt.
(define (test-atanh z)
(declare (standard-bindings) (generic))
(* 1/2 (- (log (+ 1 z)) (log (- 1 z)))))
(define (test-atan z)
(declare (standard-bindings) (generic))
(/ (test-atanh (* +i z)) +i))
(define (test-asinh z)
(declare (standard-bindings) (generic))
(log (+ z (sqrt (+ (* z z) 1)))))
(define (test-asin z)
(declare (standard-bindings) (generic))
(/ (test-asinh (* +i z)) +i))
(define (test-acos z)
(declare (standard-bindings) (generic))
(- (macro-inexact-+pi/2) (test-asin z)))
(define (test-acosh z)
(declare (standard-bindings) (generic))
(* 2 (log (+ (sqrt (/ (+ z 1) 2)) (sqrt (/ (- z 1) 2))))))
(define (test-bitwise-ior x y)
(cond ((or (= x -1)
(= y -1))
-1)
((and (= x 0)
(= y 0))
0)
(else (+ (* 2 (test-bitwise-ior (arithmetic-shift x -1)
(arithmetic-shift y -1)))
(if (or (odd? x) (odd? y))
1
0)))))
(define (test-bitwise-and x y)
(cond ((or (= x 0)
(= y 0))
0)
((and (= x -1)
(= y -1))
-1)
(else (+ (* 2 (test-bitwise-and (arithmetic-shift x -1)
(arithmetic-shift y -1)))
(if (and (odd? x) (odd? y))
1
0)))))
(define (test-bitwise-xor x y)
(cond ((= x y)
0)
((or (and (= x -1)
(= y 0))
(and (= x 0)
(= y -1)))
-1)
(else
(+ (* 2 (test-bitwise-xor (arithmetic-shift x -1)
(arithmetic-shift y -1)))
(if (eq? (odd? x) (odd? y))
0
1)))))
(define (test-arithmetic-shift x n)
(if (negative? n)
(if (negative? x)
(- (quotient (- x) (expt 2 (- n))))
(quotient x (expt 2 (- n))))
(* x (expt 2 n))))
(define (test-extract-bit-field size position n)
(bitwise-and (arithmetic-shift n (- position))
(bitwise-not (arithmetic-shift -1 size))))
(define (test-test-bit-field? size position n)
(not (eqv? (test-extract-bit-field size position n)
0)))
(define (test-clear-bit-field size position n)
(bitwise-ior (arithmetic-shift (arithmetic-shift n (- (+ size position))) (+ size position))
(test-extract-bit-field position 0 n)))