core: Fix gc_up_arena for x86_64.
[mes.git] / src / math.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of Mes.
6  *
7  * Mes is free software; you can redistribute it and/or modify it
8  * under the terms of the GNU General Public License as published by
9  * the Free Software Foundation; either version 3 of the License, or (at
10  * your option) any later version.
11  *
12  * Mes is distributed in the hope that it will be useful, but
13  * WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
19  */
20
21 #include <limits.h>
22
23 void
24 assert_number (char const* name, SCM x)
25 {
26   if (TYPE (x) != TNUMBER)
27     {
28       eputs (name);
29       error (cell_symbol_not_a_number, x);
30     }
31 }
32
33 SCM
34 greater_p (SCM x) ///((name . ">") (arity . n))
35 {
36   int n = INT_MAX;
37   while (x != cell_nil)
38     {
39       assert_number ("greater_p", CAR (x));
40       if (VALUE (car (x)) >= n)
41         return cell_f;
42       n = VALUE (car (x));
43       x = cdr (x);
44     }
45   return cell_t;
46 }
47
48 SCM
49 less_p (SCM x) ///((name . "<") (arity . n))
50 {
51   int n = INT_MIN;
52   while (x != cell_nil)
53     {
54       assert_number ("less_p", CAR (x));
55       if (VALUE (car (x)) <= n)
56         return cell_f;
57       n = VALUE (car (x));
58       x = cdr (x);
59     }
60   return cell_t;
61 }
62
63 SCM
64 is_p (SCM x) ///((name . "=") (arity . n))
65 {
66   if (x == cell_nil)
67     return cell_t;
68   assert_number ("is_p", CAR (x));
69   int n = VALUE (CAR (x));
70   x = cdr (x);
71   while (x != cell_nil)
72     {
73       if (VALUE (car (x)) != n)
74         return cell_f;
75       x = cdr (x);
76     }
77   return cell_t;
78 }
79
80 SCM
81 minus (SCM x) ///((name . "-") (arity . n))
82 {
83   assert_number ("minus", CAR (x));
84   SCM a = CAR (x);
85   int n = VALUE (a);
86   x = cdr (x);
87   if (x == cell_nil)
88     n = -n;
89   while (x != cell_nil)
90     {
91       assert_number ("minus", CAR (x));
92       n -= VALUE (car (x));
93       x = cdr (x);
94     }
95   return MAKE_NUMBER (n);
96 }
97
98 SCM
99 plus (SCM x) ///((name . "+") (arity . n))
100 {
101   int n = 0;
102   while (x != cell_nil)
103     {
104       assert_number ("plus", CAR (x));
105       n += VALUE (car (x));
106       x = cdr (x);
107     }
108   return MAKE_NUMBER (n);
109 }
110
111 SCM
112 divide (SCM x) ///((name . "/") (arity . n))
113 {
114   int n = 1;
115   if (x != cell_nil)
116     {
117       assert_number ("divide", CAR (x));
118       n = VALUE (car (x));
119       x = cdr (x);
120     }
121   while (x != cell_nil)
122     {
123       assert_number ("divide", CAR (x));
124       n /= VALUE (car (x));
125       x = cdr (x);
126     }
127   return MAKE_NUMBER (n);
128 }
129
130 SCM
131 modulo (SCM a, SCM b)
132 {
133   assert_number ("modulo", a);
134   assert_number ("modulo", b);
135   int x = VALUE (a);
136   while (x < 0) x += VALUE (b);
137   return MAKE_NUMBER (x % VALUE (b));
138 }
139
140 SCM
141 multiply (SCM x) ///((name . "*") (arity . n))
142 {
143   int n = 1;
144   while (x != cell_nil)
145     {
146       assert_number ("multiply", CAR (x));
147       n *= VALUE (car (x));
148       x = cdr (x);
149     }
150   return MAKE_NUMBER (n);
151 }
152
153 SCM
154 logand (SCM x) ///((arity . n))
155 {
156   int n = 0;
157   while (x != cell_nil)
158     {
159       assert_number ("multiply", CAR (x));
160       n &= VALUE (car (x));
161       x = cdr (x);
162     }
163   return MAKE_NUMBER (n);
164 }
165
166 SCM
167 logior (SCM x) ///((arity . n))
168 {
169   int n = 0;
170   while (x != cell_nil)
171     {
172       assert_number ("logior", CAR (x));
173       n |= VALUE (car (x));
174       x = cdr (x);
175     }
176   return MAKE_NUMBER (n);
177 }
178
179 SCM
180 lognot (SCM x)
181 {
182   assert_number ("lognot", x);
183   int n = ~VALUE (x);
184   return MAKE_NUMBER (n);
185 }
186
187 SCM
188 ash (SCM n, SCM count)
189 {
190   assert_number ("ash", n);
191   assert_number ("ash", count);
192   int cn = VALUE (n);
193   int ccount = VALUE (count);
194   return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
195 }