mes: More informative error reporting for number asserts.
[mes.git] / src / math.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan 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) return cell_f;
41       n = VALUE (car (x));
42       x = cdr (x);
43     }
44   return cell_t;
45 }
46
47 SCM
48 less_p (SCM x) ///((name . "<") (arity . n))
49 {
50   int n = INT_MIN;
51   while (x != cell_nil)
52     {
53       assert_number ("less_p", CAR (x));
54       if (VALUE (car (x)) <= n) return cell_f;
55       n = VALUE (car (x));
56       x = cdr (x);
57     }
58   return cell_t;
59 }
60
61 SCM
62 is_p (SCM x) ///((name . "=") (arity . n))
63 {
64   if (x == cell_nil) return cell_t;
65   assert_number ("is_p", CAR (x));
66   int n = VALUE (CAR (x));
67   x = cdr (x);
68   while (x != cell_nil)
69     {
70       if (VALUE (car (x)) != n) return cell_f;
71       x = cdr (x);
72     }
73   return cell_t;
74 }
75
76 SCM
77 minus (SCM x) ///((name . "-") (arity . n))
78 {
79   assert_number ("minus", CAR (x));
80   SCM a = CAR (x);
81   int n = VALUE (a);
82   x = cdr (x);
83   if (x == cell_nil)
84     n = -n;
85   while (x != cell_nil)
86     {
87       assert_number ("minus", CAR (x));
88       n -= VALUE (car (x));
89       x = cdr (x);
90     }
91   return MAKE_NUMBER (n);
92 }
93
94 SCM
95 plus (SCM x) ///((name . "+") (arity . n))
96 {
97   int n = 0;
98   while (x != cell_nil)
99     {
100       assert_number ("plus", CAR (x));
101       n += VALUE (car (x));
102       x = cdr (x);
103     }
104   return MAKE_NUMBER (n);
105 }
106
107 SCM
108 divide (SCM x) ///((name . "/") (arity . n))
109 {
110   int n = 1;
111   if (x != cell_nil) {
112     assert_number ("divide", CAR (x));
113     n = VALUE (car (x));
114     x = cdr (x);
115   }
116   while (x != cell_nil)
117     {
118       assert_number ("divide", CAR (x));
119       n /= VALUE (car (x));
120       x = cdr (x);
121     }
122   return MAKE_NUMBER (n);
123 }
124
125 SCM
126 modulo (SCM a, SCM b)
127 {
128   assert_number ("modulo", a);
129   assert_number ("modulo", b);
130   int x = VALUE (a);
131   while (x < 0) x += VALUE (b);
132   return MAKE_NUMBER (x % VALUE (b));
133 }
134
135 SCM
136 multiply (SCM x) ///((name . "*") (arity . n))
137 {
138   int n = 1;
139   while (x != cell_nil)
140     {
141       assert_number ("multiply", CAR (x));
142       n *= VALUE (car (x));
143       x = cdr (x);
144     }
145   return MAKE_NUMBER (n);
146 }
147
148 SCM
149 logand (SCM x) ///((arity . n))
150 {
151   int n = 0;
152   while (x != cell_nil)
153     {
154       assert_number ("multiply", CAR (x));
155       n &= VALUE (car (x));
156       x = cdr (x);
157     }
158   return MAKE_NUMBER (n);
159 }
160
161 SCM
162 logior (SCM x) ///((arity . n))
163 {
164   int n = 0;
165   while (x != cell_nil)
166     {
167       assert_number ("logior", CAR (x));
168       n |= VALUE (car (x));
169       x = cdr (x);
170     }
171   return MAKE_NUMBER (n);
172 }
173
174 SCM
175 lognot (SCM x)
176 {
177   assert_number ("lognot", x);
178   int n = ~VALUE (x);
179   return MAKE_NUMBER (n);
180 }
181
182 SCM
183 ash (SCM n, SCM count)
184 {
185   assert_number ("ash", n);
186   assert_number ("ash", count);
187   int cn = VALUE (n);
188   int ccount = VALUE (count);
189   return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
190 }