1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2016, 2018, 2021 Thomas Mertes */
5 /* */
6 /* This program is free software; you can redistribute it and/or */
7 /* modify it under the terms of the GNU General Public License as */
8 /* published by the Free Software Foundation; either version 2 of */
9 /* the License, or (at your option) any later version. */
10 /* */
11 /* This program is distributed in the hope that it will be useful, */
12 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
13 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
14 /* GNU General Public License for more details. */
15 /* */
16 /* You should have received a copy of the GNU General Public */
17 /* License along with this program; if not, write to the */
18 /* Free Software Foundation, Inc., 51 Franklin Street, */
19 /* Fifth Floor, Boston, MA 02110-1301, USA. */
20 /* */
21 /* Module: Library */
22 /* File: seed7/src/binlib.c */
23 /* Changes: 2015 Thomas Mertes */
24 /* Content: All primitive actions for the types bin64 and bin32. */
25 /* */
26 /********************************************************************/
27
28 #include "version.h"
29
30 #include "stdlib.h"
31 #include "stdio.h"
32
33 #include "common.h"
34 #include "data.h"
35 #include "syvarutl.h"
36 #include "objutl.h"
37 #include "runerr.h"
38 #include "int_rtl.h"
39 #include "set_rtl.h"
40 #include "big_drv.h"
41
42 #undef EXTERN
43 #define EXTERN
44 #include "biglib.h"
45
46
47
48 /**
49 * Compute a bitwise 'and' of two binary values.
50 * @return the bitwise 'and' of the two values.
51 */
bin_and(listType arguments)52 objectType bin_and (listType arguments)
53
54 { /* bin_and */
55 isit_binary(arg_1(arguments));
56 isit_binary(arg_3(arguments));
57 return bld_binary_temp(
58 take_binary(arg_1(arguments)) & take_binary(arg_3(arguments)));
59 } /* bin_and */
60
61
62
63 /**
64 * Compute a bitwise 'and' and assign the result back.
65 */
bin_and_assign(listType arguments)66 objectType bin_and_assign (listType arguments)
67
68 {
69 objectType binary_variable;
70
71 /* bin_and_assign */
72 binary_variable = arg_1(arguments);
73 isit_binary(binary_variable);
74 is_variable(binary_variable);
75 isit_binary(arg_3(arguments));
76 binary_variable->value.binaryValue &= take_binary(arg_3(arguments));
77 return SYS_EMPTY_OBJECT;
78 } /* bin_and_assign */
79
80
81
82 /**
83 * Convert to bigInteger.
84 * @return the unchanged value as integer.
85 * @exception MEMORY_ERROR Not enough memory to represent the result.
86 */
bin_big(listType arguments)87 objectType bin_big (listType arguments)
88
89 { /* bin_big */
90 isit_binary(arg_1(arguments));
91 return bld_bigint_temp(bigFromUInt64(take_binary(arg_1(arguments))));
92 } /* bin_big */
93
94
95
96 /**
97 * Convert to bin64.
98 * @return the unchanged value as bin64.
99 */
bin_binary(listType arguments)100 objectType bin_binary (listType arguments)
101
102 { /* bin_binary */
103 isit_bigint(arg_1(arguments));
104 return bld_binary_temp(bigToUInt64(take_bigint(arg_1(arguments))));
105 } /* bin_binary */
106
107
108
109 /**
110 * Determine the number of one bits in a binary value.
111 * @return the number of one bits.
112 */
bin_card(listType arguments)113 objectType bin_card (listType arguments)
114
115 { /* bin_card */
116 isit_binary(arg_1(arguments));
117 return bld_int_temp(
118 uintCard(take_binary(arg_1(arguments))));
119 } /* bin_card */
120
121
122
123 /**
124 * Compare two binary values.
125 * @return -1, 0 or 1 if the first argument is considered to be
126 * respectively less than, equal to, or greater than the
127 * second.
128 */
bin_cmp(listType arguments)129 objectType bin_cmp (listType arguments)
130
131 {
132 uintType binary1;
133 uintType binary2;
134 intType signumValue;
135
136 /* bin_cmp */
137 isit_binary(arg_1(arguments));
138 isit_binary(arg_2(arguments));
139 binary1 = take_binary(arg_1(arguments));
140 binary2 = take_binary(arg_2(arguments));
141 if (binary1 < binary2) {
142 signumValue = -1;
143 } else if (binary1 > binary2) {
144 signumValue = 1;
145 } else {
146 signumValue = 0;
147 } /* if */
148 return bld_int_temp(signumValue);
149 } /* bin_cmp */
150
151
152
153 /**
154 * Get 64 bits from a bitset starting with lowestBitNum/arg_2.
155 * @return a bit pattern with 64 bits from set1/arg_1.
156 */
bin_get_binary_from_set(listType arguments)157 objectType bin_get_binary_from_set (listType arguments)
158
159 { /* bin_get_binary_from_set */
160 isit_set(arg_1(arguments));
161 isit_int(arg_2(arguments));
162 return bld_binary_temp(
163 setToUInt(take_set(arg_1(arguments)), take_int(arg_2(arguments))));
164 } /* bin_get_binary_from_set */
165
166
167
168 /**
169 * Shift a binary value left by lshift bits.
170 * Bits that are shifted beyond the size of a binary value
171 * are lost.
172 * @return the left shifted binary value.
173 * @exception OVERFLOW_ERROR If the shift amount is
174 * negative or greater equal INTTYPE_SIZE.
175 */
bin_lshift(listType arguments)176 objectType bin_lshift (listType arguments)
177
178 {
179 intType lshift;
180
181 /* bin_lshift */
182 isit_binary(arg_1(arguments));
183 isit_int(arg_3(arguments));
184 lshift = take_int(arg_3(arguments));
185 #if CHECK_INT_OVERFLOW
186 if (unlikely(lshift < 0 || lshift >= INTTYPE_SIZE)) {
187 return raise_exception(SYS_OVF_EXCEPTION);
188 } /* if */
189 #endif
190 return bld_binary_temp(
191 take_binary(arg_1(arguments)) << lshift);
192 } /* bin_lshift */
193
194
195
196 /**
197 * Shift a binary value left by lshift bits and assign the result back.
198 * @exception OVERFLOW_ERROR If the shift amount is
199 * negative or greater equal INTTYPE_SIZE.
200 */
bin_lshift_assign(listType arguments)201 objectType bin_lshift_assign (listType arguments)
202
203 {
204 objectType binary_variable;
205 intType lshift;
206
207 /* bin_lshift_assign */
208 binary_variable = arg_1(arguments);
209 isit_binary(binary_variable);
210 is_variable(binary_variable);
211 isit_int(arg_3(arguments));
212 lshift = take_int(arg_3(arguments));
213 #if CHECK_INT_OVERFLOW
214 if (unlikely(lshift < 0 || lshift >= INTTYPE_SIZE)) {
215 return raise_exception(SYS_OVF_EXCEPTION);
216 } /* if */
217 #endif
218 binary_variable->value.binaryValue =
219 take_binary(binary_variable) << lshift;
220 return SYS_EMPTY_OBJECT;
221 } /* bin_lshift_assign */
222
223
224
225 /**
226 * Convert an unsigned integer into a big-endian encoded string of bytes.
227 * The result uses binary representation with a base of 256.
228 * The result contains chars (bytes) with an ordinal <= 255.
229 * @param number/arg_1 Unsigned integer number to be converted.
230 * @param length/arg_3 Determines the length of the result string.
231 * @return a string of 'length' bytes with the unsigned binary
232 * representation of 'number'.
233 * @exception RANGE_ERROR If ''length'' is negative or zero, or
234 * if the result would not fit in ''length'' bytes.
235 * @exception MEMORY_ERROR Not enough memory to represent the result.
236 */
bin_n_bytes_be(listType arguments)237 objectType bin_n_bytes_be (listType arguments)
238
239 { /* bin_n_bytes_be */
240 isit_binary(arg_1(arguments));
241 isit_int(arg_3(arguments));
242 return bld_stri_temp(uintNBytesBe(take_binary(arg_1(arguments)),
243 take_int(arg_3(arguments))));
244 } /* bin_n_bytes_be */
245
246
247
248 /**
249 * Convert an unsigned integer into a little-endian encoded string of bytes.
250 * The result uses binary representation with a base of 256.
251 * The result contains chars (bytes) with an ordinal <= 255.
252 * @param number/arg_1 Unsigned integer number to be converted.
253 * @param length/arg_3 Determines the length of the result string.
254 * @return a string of 'length' bytes with the unsigned binary
255 * representation of 'number'.
256 * @exception RANGE_ERROR If ''length'' is negative or zero, or
257 * if the result would not fit in ''length'' bytes.
258 * @exception MEMORY_ERROR Not enough memory to represent the result.
259 */
bin_n_bytes_le(listType arguments)260 objectType bin_n_bytes_le (listType arguments)
261
262 { /* bin_n_bytes_le */
263 isit_binary(arg_1(arguments));
264 isit_int(arg_3(arguments));
265 return bld_stri_temp(uintNBytesLe(take_binary(arg_1(arguments)),
266 take_int(arg_3(arguments))));
267 } /* bin_n_bytes_le */
268
269
270
271 /**
272 * Compute a bitwise inclusive 'or' of two integer values.
273 * @return the bitwise inclusive 'or' of the two values.
274 */
bin_or(listType arguments)275 objectType bin_or (listType arguments)
276
277 { /* bin_or */
278 isit_binary(arg_1(arguments));
279 isit_binary(arg_3(arguments));
280 return bld_binary_temp(
281 take_binary(arg_1(arguments)) | take_binary(arg_3(arguments)));
282 } /* bin_or */
283
284
285
286 /**
287 * Compute a bitwise inclusive 'or' and assign the result back.
288 */
bin_or_assign(listType arguments)289 objectType bin_or_assign (listType arguments)
290
291 {
292 objectType binary_variable;
293
294 /* bin_or_assign */
295 binary_variable = arg_1(arguments);
296 isit_binary(binary_variable);
297 is_variable(binary_variable);
298 isit_binary(arg_3(arguments));
299 binary_variable->value.binaryValue |= take_binary(arg_3(arguments));
300 return SYS_EMPTY_OBJECT;
301 } /* bin_or_assign */
302
303
304
305 /**
306 * Convert an unsigned integer number to a string using a radix.
307 * The conversion uses the numeral system with the given base.
308 * Digit values from 10 upward are encoded with lower case letters.
309 * E.g.: 10 is encoded with a, 11 with b, etc.
310 * @return the string result of the conversion.
311 * @exception RANGE_ERROR If base < 2 or base > 36 holds.
312 * @exception MEMORY_ERROR Not enough memory to represent the result.
313 */
bin_radix(listType arguments)314 objectType bin_radix (listType arguments)
315
316 { /* bin_radix */
317 isit_binary(arg_1(arguments));
318 isit_int(arg_3(arguments));
319 return bld_stri_temp(
320 uintRadix(take_binary(arg_1(arguments)), take_int(arg_3(arguments)), FALSE));
321 } /* bin_radix */
322
323
324
325 /**
326 * Convert an unsigned integer number to a string using a radix.
327 * The conversion uses the numeral system with the given base.
328 * Digit values from 10 upward are encoded with upper case letters.
329 * E.g.: 10 is encoded with A, 11 with B, etc.
330 * @return the string result of the conversion.
331 * @exception RANGE_ERROR If base < 2 or base > 36 holds.
332 * @exception MEMORY_ERROR Not enough memory to represent the result.
333 */
bin_RADIX(listType arguments)334 objectType bin_RADIX (listType arguments)
335
336 { /* bin_RADIX */
337 isit_binary(arg_1(arguments));
338 isit_int(arg_3(arguments));
339 return bld_stri_temp(
340 uintRadix(take_binary(arg_1(arguments)), take_int(arg_3(arguments)), TRUE));
341 } /* bin_RADIX */
342
343
344
345 /**
346 * Shift a binary value right by rshift bits.
347 * Bits that are shifted beyond the size of a binary value
348 * are lost.
349 * @return the right shifted binary value.
350 * @exception OVERFLOW_ERROR If the shift amount is
351 * negative or greater equal INTTYPE_SIZE.
352 */
bin_rshift(listType arguments)353 objectType bin_rshift (listType arguments)
354
355 {
356 intType rshift;
357
358 /* bin_rshift */
359 isit_binary(arg_1(arguments));
360 isit_int(arg_3(arguments));
361 rshift = take_int(arg_3(arguments));
362 #if CHECK_INT_OVERFLOW
363 if (unlikely(rshift < 0 || rshift >= INTTYPE_SIZE)) {
364 return raise_exception(SYS_OVF_EXCEPTION);
365 } /* if */
366 #endif
367 return bld_binary_temp(
368 take_binary(arg_1(arguments)) >> rshift);
369 } /* bin_rshift */
370
371
372
373 /**
374 * Shift a binary value right by rshift bits and assign the result back.
375 * @exception OVERFLOW_ERROR If the shift amount is
376 * negative or greater equal INTTYPE_SIZE.
377 */
bin_rshift_assign(listType arguments)378 objectType bin_rshift_assign (listType arguments)
379
380 {
381 objectType binary_variable;
382 intType rshift;
383
384 /* bin_rshift_assign */
385 binary_variable = arg_1(arguments);
386 isit_binary(binary_variable);
387 is_variable(binary_variable);
388 isit_int(arg_3(arguments));
389 rshift = take_int(arg_3(arguments));
390 #if CHECK_INT_OVERFLOW
391 if (unlikely(rshift < 0 || rshift >= INTTYPE_SIZE)) {
392 return raise_exception(SYS_OVF_EXCEPTION);
393 } /* if */
394 #endif
395 binary_variable->value.binaryValue =
396 take_binary(binary_variable) >> rshift;
397 return SYS_EMPTY_OBJECT;
398 } /* bin_rshift_assign */
399
400
401
402 /**
403 * Convert an unsigned integer number to a string.
404 * The number is converted to a string with decimal representation.
405 * @return the string result of the conversion.
406 * @exception MEMORY_ERROR Not enough memory to represent the result.
407 */
bin_str(listType arguments)408 objectType bin_str (listType arguments)
409
410 { /* bin_str */
411 isit_binary(arg_1(arguments));
412 return bld_stri_temp(
413 uintStr(take_binary(arg_1(arguments))));
414 } /* bin_str */
415
416
417
418 /**
419 * Compute a bitwise exclusive or ('xor') of two binary values.
420 * @return the bitwise exclusive or ('xor') of the two values.
421 */
bin_xor(listType arguments)422 objectType bin_xor (listType arguments)
423
424 { /* bin_xor */
425 isit_binary(arg_1(arguments));
426 isit_binary(arg_3(arguments));
427 return bld_binary_temp(
428 take_binary(arg_1(arguments)) ^ take_binary(arg_3(arguments)));
429 } /* bin_xor */
430
431
432
433 /**
434 * Compute a bitwise exclusive or ('xor') and assign the result back.
435 */
bin_xor_assign(listType arguments)436 objectType bin_xor_assign (listType arguments)
437
438 {
439 objectType binary_variable;
440
441 /* binbin_xor_assign */
442 binary_variable = arg_1(arguments);
443 isit_binary(binary_variable);
444 is_variable(binary_variable);
445 isit_binary(arg_3(arguments));
446 binary_variable->value.binaryValue ^= take_binary(arg_3(arguments));
447 return SYS_EMPTY_OBJECT;
448 } /* bin_xor_assign */
449