core: Support fork, waitpid, execve.
[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   if (x == cell_nil)
37     return cell_t;
38   assert_number ("greater_p", CAR (x));
39   int 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   int 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   int 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   int 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   int 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   int 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       n /= VALUE (car (x));
132       x = cdr (x);
133     }
134   return MAKE_NUMBER (n);
135 }
136
137 SCM
138 modulo (SCM a, SCM b)
139 {
140   assert_number ("modulo", a);
141   assert_number ("modulo", b);
142   int x = VALUE (a);
143   while (x < 0) x += VALUE (b);
144   return MAKE_NUMBER (x % VALUE (b));
145 }
146
147 SCM
148 multiply (SCM x) ///((name . "*") (arity . n))
149 {
150   int n = 1;
151   while (x != cell_nil)
152     {
153       assert_number ("multiply", CAR (x));
154       n *= VALUE (car (x));
155       x = cdr (x);
156     }
157   return MAKE_NUMBER (n);
158 }
159
160 SCM
161 logand (SCM x) ///((arity . n))
162 {
163   int n = 0;
164   while (x != cell_nil)
165     {
166       assert_number ("multiply", CAR (x));
167       n &= VALUE (car (x));
168       x = cdr (x);
169     }
170   return MAKE_NUMBER (n);
171 }
172
173 SCM
174 logior (SCM x) ///((arity . n))
175 {
176   int n = 0;
177   while (x != cell_nil)
178     {
179       assert_number ("logior", CAR (x));
180       n |= VALUE (car (x));
181       x = cdr (x);
182     }
183   return MAKE_NUMBER (n);
184 }
185
186 SCM
187 lognot (SCM x)
188 {
189   assert_number ("lognot", x);
190   int n = ~VALUE (x);
191   return MAKE_NUMBER (n);
192 }
193
194 SCM
195 logxor (SCM x) ///((arity . n))
196 {
197   int n = 0;
198   while (x != cell_nil)
199     {
200       assert_number ("logxor", CAR (x));
201       n ^= VALUE (car (x));
202       x = cdr (x);
203     }
204   return MAKE_NUMBER (n);
205 }
206
207 SCM
208 ash (SCM n, SCM count)
209 {
210   assert_number ("ash", n);
211   assert_number ("ash", count);
212   int cn = VALUE (n);
213   int ccount = VALUE (count);
214   return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
215 }