build: Resurrect --with-cheating.
[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 "mes/lib.h"
22 #include "mes/mes.h"
23
24 #include <assert.h>
25 #include <ctype.h>
26 #include <limits.h>
27 #include <stdio.h>
28 #include <string.h>
29
30 void
31 assert_number (char const *name, SCM x)
32 {
33   if (TYPE (x) != TNUMBER)
34     {
35       eputs (name);
36       error (cell_symbol_not_a_number, x);
37     }
38 }
39
40 SCM
41 greater_p (SCM x)               ///((name . ">") (arity . n))
42 {
43   if (x == cell_nil)
44     return cell_t;
45   assert_number ("greater_p", CAR (x));
46   long n = VALUE (CAR (x));
47   x = CDR (x);
48   while (x != cell_nil)
49     {
50       assert_number ("greater_p", CAR (x));
51       if (VALUE (car (x)) >= n)
52         return cell_f;
53       n = VALUE (car (x));
54       x = cdr (x);
55     }
56   return cell_t;
57 }
58
59 SCM
60 less_p (SCM x)                  ///((name . "<") (arity . n))
61 {
62   if (x == cell_nil)
63     return cell_t;
64   assert_number ("less_p", CAR (x));
65   long n = VALUE (CAR (x));
66   x = CDR (x);
67   while (x != cell_nil)
68     {
69       assert_number ("less_p", CAR (x));
70       if (VALUE (car (x)) <= n)
71         return cell_f;
72       n = VALUE (car (x));
73       x = cdr (x);
74     }
75   return cell_t;
76 }
77
78 SCM
79 is_p (SCM x)                    ///((name . "=") (arity . n))
80 {
81   if (x == cell_nil)
82     return cell_t;
83   assert_number ("is_p", CAR (x));
84   long n = VALUE (CAR (x));
85   x = cdr (x);
86   while (x != cell_nil)
87     {
88       if (VALUE (car (x)) != n)
89         return cell_f;
90       x = cdr (x);
91     }
92   return cell_t;
93 }
94
95 SCM
96 minus (SCM x)                   ///((name . "-") (arity . n))
97 {
98   assert_number ("minus", CAR (x));
99   long n = VALUE (CAR (x));
100   x = cdr (x);
101   if (x == cell_nil)
102     n = -n;
103   while (x != cell_nil)
104     {
105       assert_number ("minus", CAR (x));
106       n -= VALUE (car (x));
107       x = cdr (x);
108     }
109   return MAKE_NUMBER (n);
110 }
111
112 SCM
113 plus (SCM x)                    ///((name . "+") (arity . n))
114 {
115   long n = 0;
116   while (x != cell_nil)
117     {
118       assert_number ("plus", CAR (x));
119       n += VALUE (car (x));
120       x = cdr (x);
121     }
122   return MAKE_NUMBER (n);
123 }
124
125 SCM
126 divide (SCM x)                  ///((name . "/") (arity . n))
127 {
128   long n = 1;
129   if (x != cell_nil)
130     {
131       assert_number ("divide", CAR (x));
132       n = VALUE (car (x));
133       x = cdr (x);
134     }
135   while (x != cell_nil)
136     {
137       assert_number ("divide", CAR (x));
138       long y = VALUE (CAR (x));
139       if (y == 0)
140         error (cstring_to_symbol ("divide-by-zero"), x);
141       if (!n)
142         break;
143       n /= y;
144       x = cdr (x);
145     }
146   return MAKE_NUMBER (n);
147 }
148
149 SCM
150 modulo (SCM a, SCM b)
151 {
152   assert_number ("modulo", a);
153   assert_number ("modulo", b);
154   long x = VALUE (a);
155   long y = VALUE (b);
156   if (y == 0)
157     error (cstring_to_symbol ("divide-by-zero"), a);
158   while (x < 0)
159     x += y;
160   x = x ? x % y : 0;
161   return MAKE_NUMBER (x);
162 }
163
164 SCM
165 multiply (SCM x)                ///((name . "*") (arity . n))
166 {
167   long n = 1;
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 logand (SCM x)                  ///((arity . n))
179 {
180   long n = 0;
181   while (x != cell_nil)
182     {
183       assert_number ("multiply", CAR (x));
184       n &= VALUE (car (x));
185       x = cdr (x);
186     }
187   return MAKE_NUMBER (n);
188 }
189
190 SCM
191 logior (SCM x)                  ///((arity . n))
192 {
193   long n = 0;
194   while (x != cell_nil)
195     {
196       assert_number ("logior", CAR (x));
197       n |= VALUE (car (x));
198       x = cdr (x);
199     }
200   return MAKE_NUMBER (n);
201 }
202
203 SCM
204 lognot (SCM x)
205 {
206   assert_number ("lognot", x);
207   long n = ~VALUE (x);
208   return MAKE_NUMBER (n);
209 }
210
211 SCM
212 logxor (SCM x)                  ///((arity . n))
213 {
214   long n = 0;
215   while (x != cell_nil)
216     {
217       assert_number ("logxor", CAR (x));
218       n ^= VALUE (car (x));
219       x = cdr (x);
220     }
221   return MAKE_NUMBER (n);
222 }
223
224 SCM
225 ash (SCM n, SCM count)
226 {
227   assert_number ("ash", n);
228   assert_number ("ash", count);
229   long cn = VALUE (n);
230   long ccount = VALUE (count);
231   return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
232 }