core: Avoid 64bit zero divide.
[mes.git] / src / math.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * GNU Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of GNU Mes.
6  *
7  * GNU 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  * GNU 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 GNU 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   if (x == cell_nil)
37     return cell_t;
38   assert_number ("greater_p", CAR (x));
39   long n = VALUE (CAR (x));
40   x = CDR (x);
41   while (x != cell_nil)
42     {
43       assert_number ("greater_p", CAR (x));
44       if (VALUE (car (x)) >= n)
45         return cell_f;
46       n = VALUE (car (x));
47       x = cdr (x);
48     }
49   return cell_t;
50 }
51
52 SCM
53 less_p (SCM x) ///((name . "<") (arity . n))
54 {
55   if (x == cell_nil)
56     return cell_t;
57   assert_number ("less_p", CAR (x));
58   long n = VALUE (CAR (x));
59   x = CDR (x);
60   while (x != cell_nil)
61     {
62       assert_number ("less_p", CAR (x));
63       if (VALUE (car (x)) <= n)
64         return cell_f;
65       n = VALUE (car (x));
66       x = cdr (x);
67     }
68   return cell_t;
69 }
70
71 SCM
72 is_p (SCM x) ///((name . "=") (arity . n))
73 {
74   if (x == cell_nil)
75     return cell_t;
76   assert_number ("is_p", CAR (x));
77   long n = VALUE (CAR (x));
78   x = cdr (x);
79   while (x != cell_nil)
80     {
81       if (VALUE (car (x)) != n)
82         return cell_f;
83       x = cdr (x);
84     }
85   return cell_t;
86 }
87
88 SCM
89 minus (SCM x) ///((name . "-") (arity . n))
90 {
91   assert_number ("minus", CAR (x));
92   long n = VALUE (CAR (x));
93   x = cdr (x);
94   if (x == cell_nil)
95     n = -n;
96   while (x != cell_nil)
97     {
98       assert_number ("minus", CAR (x));
99       n -= VALUE (car (x));
100       x = cdr (x);
101     }
102   return MAKE_NUMBER (n);
103 }
104
105 SCM
106 plus (SCM x) ///((name . "+") (arity . n))
107 {
108   long n = 0;
109   while (x != cell_nil)
110     {
111       assert_number ("plus", CAR (x));
112       n += VALUE (car (x));
113       x = cdr (x);
114     }
115   return MAKE_NUMBER (n);
116 }
117
118 SCM
119 divide (SCM x) ///((name . "/") (arity . n))
120 {
121   long n = 1;
122   if (x != cell_nil)
123     {
124       assert_number ("divide", CAR (x));
125       n = VALUE (car (x));
126       x = cdr (x);
127     }
128   while (x != cell_nil)
129     {
130       assert_number ("divide", CAR (x));
131       if (!n)
132         break;
133       n /= VALUE (car (x));
134       x = cdr (x);
135     }
136   return MAKE_NUMBER (n);
137 }
138
139 SCM
140 modulo (SCM a, SCM b)
141 {
142   assert_number ("modulo", a);
143   assert_number ("modulo", b);
144   long x = VALUE (a);
145   while (x < 0)
146     x += VALUE (b);
147   x = x ? x % VALUE (b) : 0;
148   return MAKE_NUMBER (x);
149 }
150
151 SCM
152 multiply (SCM x) ///((name . "*") (arity . n))
153 {
154   long n = 1;
155   while (x != cell_nil)
156     {
157       assert_number ("multiply", CAR (x));
158       n *= VALUE (car (x));
159       x = cdr (x);
160     }
161   return MAKE_NUMBER (n);
162 }
163
164 SCM
165 logand (SCM x) ///((arity . n))
166 {
167   long n = 0;
168   while (x != cell_nil)
169     {
170       assert_number ("multiply", CAR (x));
171       n &= VALUE (car (x));
172       x = cdr (x);
173     }
174   return MAKE_NUMBER (n);
175 }
176
177 SCM
178 logior (SCM x) ///((arity . n))
179 {
180   long n = 0;
181   while (x != cell_nil)
182     {
183       assert_number ("logior", CAR (x));
184       n |= VALUE (car (x));
185       x = cdr (x);
186     }
187   return MAKE_NUMBER (n);
188 }
189
190 SCM
191 lognot (SCM x)
192 {
193   assert_number ("lognot", x);
194   long n = ~VALUE (x);
195   return MAKE_NUMBER (n);
196 }
197
198 SCM
199 logxor (SCM x) ///((arity . n))
200 {
201   long n = 0;
202   while (x != cell_nil)
203     {
204       assert_number ("logxor", CAR (x));
205       n ^= VALUE (car (x));
206       x = cdr (x);
207     }
208   return MAKE_NUMBER (n);
209 }
210
211 SCM
212 ash (SCM n, SCM count)
213 {
214   assert_number ("ash", n);
215   assert_number ("ash", count);
216   long cn = VALUE (n);
217   long ccount = VALUE (count);
218   return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
219 }