rts-char.c
1 //! @file rts-char.c
2 //! @author J. Marcel van der Veer
3 //!
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
8 //!
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! CHAR, STRING and BYTES routines.
25
26 #include "a68g.h"
27 #include "a68g-genie.h"
28 #include "a68g-prelude.h"
29 #include "a68g-mp.h"
30 #include "a68g-double.h"
31 #include "a68g-transput.h"
32
33 // OP (CHAR, CHAR) BOOL.
34
35 #define A68_CMP_CHAR(n, OP)\
36 void n (NODE_T * p) {\
37 A68_CHAR i, j;\
38 POP_OBJECT (p, &j, A68_CHAR);\
39 POP_OBJECT (p, &i, A68_CHAR);\
40 PUSH_VALUE (p, (BOOL_T) (TO_UCHAR (VALUE (&i)) OP TO_UCHAR (VALUE (&j))), A68_BOOL);\
41 }
42
43 A68_CMP_CHAR (genie_eq_char, ==);
44 A68_CMP_CHAR (genie_ne_char, !=);
45 A68_CMP_CHAR (genie_lt_char, <);
46 A68_CMP_CHAR (genie_gt_char, >);
47 A68_CMP_CHAR (genie_le_char, <=);
48 A68_CMP_CHAR (genie_ge_char, >=);
49
50 //! @brief OP ABS = (CHAR) INT
51
52 void genie_abs_char (NODE_T * p)
53 {
54 A68_CHAR i;
55 POP_OBJECT (p, &i, A68_CHAR);
56 PUSH_VALUE (p, TO_UCHAR (VALUE (&i)), A68_INT);
57 }
58
59 //! @brief OP REPR = (INT) CHAR
60
61 void genie_repr_char (NODE_T * p)
62 {
63 A68_INT k;
64 POP_OBJECT (p, &k, A68_INT);
65 PRELUDE_ERROR (VALUE (&k) < 0 || VALUE (&k) > (int) UCHAR_MAX, p, ERROR_OUT_OF_BOUNDS, M_CHAR);
66 PUSH_VALUE (p, (char) (VALUE (&k)), A68_CHAR);
67 }
68
69 // OP (CHAR) BOOL.
70
71 #define A68_CHAR_BOOL(n, OP)\
72 void n (NODE_T * p) {\
73 A68_CHAR ch;\
74 POP_OBJECT (p, &ch, A68_CHAR);\
75 PUSH_VALUE (p, (BOOL_T) (OP (VALUE (&ch)) == 0 ? A68_FALSE : A68_TRUE), A68_BOOL);\
76 }
77
78 A68_CHAR_BOOL (genie_is_alnum, IS_ALNUM);
79 A68_CHAR_BOOL (genie_is_alpha, IS_ALPHA);
80 A68_CHAR_BOOL (genie_is_cntrl, IS_CNTRL);
81 A68_CHAR_BOOL (genie_is_digit, IS_DIGIT);
82 A68_CHAR_BOOL (genie_is_graph, IS_GRAPH);
83 A68_CHAR_BOOL (genie_is_lower, IS_LOWER);
84 A68_CHAR_BOOL (genie_is_print, IS_PRINT);
85 A68_CHAR_BOOL (genie_is_punct, IS_PUNCT);
86 A68_CHAR_BOOL (genie_is_space, IS_SPACE);
87 A68_CHAR_BOOL (genie_is_upper, IS_UPPER);
88 A68_CHAR_BOOL (genie_is_xdigit, IS_XDIGIT);
89
90 #define A68_CHAR_CHAR(n, OP)\
91 void n (NODE_T * p) {\
92 A68_CHAR *ch;\
93 POP_OPERAND_ADDRESS (p, ch, A68_CHAR);\
94 VALUE (ch) = (char) (OP (TO_UCHAR (VALUE (ch))));\
95 }
96 A68_CHAR_CHAR (genie_to_lower, TO_LOWER)
97 A68_CHAR_CHAR (genie_to_upper, TO_UPPER)
98 //! @brief OP + = (CHAR, CHAR) STRING
99 void genie_add_char (NODE_T * p)
100 {
101 A68_CHAR a, b;
102 A68_REF c, d;
103 A68_ARRAY *a_3;
104 A68_TUPLE *t_3;
105 BYTE_T *b_3;
106 // right part.
107 POP_OBJECT (p, &b, A68_CHAR);
108 CHECK_INIT (p, INITIALISED (&b), M_CHAR);
109 // left part.
110 POP_OBJECT (p, &a, A68_CHAR);
111 CHECK_INIT (p, INITIALISED (&a), M_CHAR);
112 // sum.
113 c = heap_generator (p, M_STRING, DESCRIPTOR_SIZE (1));
114 d = heap_generator (p, M_STRING, 2 * SIZE (M_CHAR));
115 GET_DESCRIPTOR (a_3, t_3, &c);
116 DIM (a_3) = 1;
117 MOID (a_3) = M_CHAR;
118 ELEM_SIZE (a_3) = SIZE (M_CHAR);
119 SLICE_OFFSET (a_3) = 0;
120 FIELD_OFFSET (a_3) = 0;
121 ARRAY (a_3) = d;
122 LWB (t_3) = 1;
123 UPB (t_3) = 2;
124 SHIFT (t_3) = LWB (t_3);
125 SPAN (t_3) = 1;
126 // add chars.
127 b_3 = DEREF (BYTE_T, &ARRAY (a_3));
128 MOVE ((BYTE_T *) & b_3[0], (BYTE_T *) & a, SIZE (M_CHAR));
129 MOVE ((BYTE_T *) & b_3[SIZE (M_CHAR)], (BYTE_T *) & b, SIZE (M_CHAR));
130 PUSH_REF (p, c);
131 }
132
133 //! @brief OP ELEM = (INT, STRING) CHAR # ALGOL68C #
134
135 void genie_elem_string (NODE_T * p)
136 {
137 A68_REF z;
138 A68_ARRAY *a;
139 A68_TUPLE *t;
140 A68_INT k;
141 BYTE_T *base;
142 A68_CHAR *ch;
143 POP_REF (p, &z);
144 CHECK_REF (p, z, M_STRING);
145 POP_OBJECT (p, &k, A68_INT);
146 GET_DESCRIPTOR (a, t, &z);
147 PRELUDE_ERROR (VALUE (&k) < LWB (t), p, ERROR_INDEX_OUT_OF_BOUNDS, NO_TEXT);
148 PRELUDE_ERROR (VALUE (&k) > UPB (t), p, ERROR_INDEX_OUT_OF_BOUNDS, NO_TEXT);
149 base = DEREF (BYTE_T, &(ARRAY (a)));
150 ch = (A68_CHAR *) & (base[INDEX_1_DIM (a, t, VALUE (&k))]);
151 PUSH_VALUE (p, VALUE (ch), A68_CHAR);
152 }
153
154 //! @brief OP + = (STRING, STRING) STRING
155
156 void genie_add_string (NODE_T * p)
157 {
158 A68_REF a, b, c, d;
159 A68_ARRAY *a_1, *a_2, *a_3;
160 A68_TUPLE *t_1, *t_2, *t_3;
161 BYTE_T *b_1, *b_2, *b_3;
162 // right part.
163 POP_REF (p, &b);
164 CHECK_INIT (p, INITIALISED (&b), M_STRING);
165 GET_DESCRIPTOR (a_2, t_2, &b);
166 int l_2 = ROW_SIZE (t_2);
167 // left part.
168 POP_REF (p, &a);
169 CHECK_REF (p, a, M_STRING);
170 GET_DESCRIPTOR (a_1, t_1, &a);
171 int l_1 = ROW_SIZE (t_1);
172 // sum.
173 c = heap_generator (p, M_STRING, DESCRIPTOR_SIZE (1));
174 d = heap_generator (p, M_STRING, (l_1 + l_2) * SIZE (M_CHAR));
175 // Calculate again since garbage collector might have moved data.
176 GET_DESCRIPTOR (a_1, t_1, &a);
177 GET_DESCRIPTOR (a_2, t_2, &b);
178 GET_DESCRIPTOR (a_3, t_3, &c);
179 DIM (a_3) = 1;
180 MOID (a_3) = M_CHAR;
181 ELEM_SIZE (a_3) = SIZE (M_CHAR);
182 SLICE_OFFSET (a_3) = 0;
183 FIELD_OFFSET (a_3) = 0;
184 ARRAY (a_3) = d;
185 LWB (t_3) = 1;
186 UPB (t_3) = l_1 + l_2;
187 SHIFT (t_3) = LWB (t_3);
188 SPAN (t_3) = 1;
189 // add strings.
190 b_3 = DEREF (BYTE_T, &ARRAY (a_3));
191 int m = 0;
192 if (ROW_SIZE (t_1) > 0) {
193 b_1 = DEREF (BYTE_T, &ARRAY (a_1));
194 for (int k = LWB (t_1); k <= UPB (t_1); k++) {
195 MOVE ((BYTE_T *) & b_3[m], (BYTE_T *) & b_1[INDEX_1_DIM (a_1, t_1, k)], SIZE (M_CHAR));
196 m += SIZE (M_CHAR);
197 }
198 }
199 if (ROW_SIZE (t_2) > 0) {
200 b_2 = DEREF (BYTE_T, &ARRAY (a_2));
201 for (int k = LWB (t_2); k <= UPB (t_2); k++) {
202 MOVE ((BYTE_T *) & b_3[m], (BYTE_T *) & b_2[INDEX_1_DIM (a_2, t_2, k)], SIZE (M_CHAR));
203 m += SIZE (M_CHAR);
204 }
205 }
206 PUSH_REF (p, c);
207 }
208
209 //! @brief OP * = (INT, STRING) STRING
210
211 void genie_times_int_string (NODE_T * p)
212 {
213 A68_REF a;
214 POP_REF (p, &a);
215 A68_INT k;
216 POP_OBJECT (p, &k, A68_INT);
217 PRELUDE_ERROR (VALUE (&k) < 0, p, ERROR_INVALID_ARGUMENT, M_INT);
218 CHECK_INT_SHORTEN (p, VALUE (&k));
219 PUSH_REF (p, empty_string (p));
220 while (VALUE (&k)--) {
221 PUSH_REF (p, a);
222 genie_add_string (p);
223 }
224 }
225
226 //! @brief OP * = (STRING, INT) STRING
227
228 void genie_times_string_int (NODE_T * p)
229 {
230 A68_INT k;
231 POP_OBJECT (p, &k, A68_INT);
232 A68_REF a;
233 POP_REF (p, &a);
234 PUSH_VALUE (p, VALUE (&k), A68_INT);
235 PUSH_REF (p, a);
236 genie_times_int_string (p);
237 }
238
239 //! @brief OP * = (INT, CHAR) STRING
240
241 void genie_times_int_char (NODE_T * p)
242 {
243 // Pop operands.
244 A68_CHAR a;
245 POP_OBJECT (p, &a, A68_CHAR);
246 A68_INT str_size;
247 POP_OBJECT (p, &str_size, A68_INT);
248 PRELUDE_ERROR (VALUE (&str_size) < 0, p, ERROR_INVALID_ARGUMENT, M_INT);
249 CHECK_INT_SHORTEN (p, VALUE (&str_size));
250 // Make new string.
251 A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup;
252 NEW_ROW_1D (z, row, arr, tup, M_ROW_CHAR, M_CHAR, (int) (VALUE (&str_size)));
253 BYTE_T *base = ADDRESS (&row);
254 for (int k = 0; k < VALUE (&str_size); k++) {
255 A68_CHAR ch;
256 STATUS (&ch) = INIT_MASK;
257 VALUE (&ch) = VALUE (&a);
258 *(A68_CHAR *) & base[k * SIZE (M_CHAR)] = ch;
259 }
260 PUSH_REF (p, z);
261 }
262
263 //! @brief OP * = (CHAR, INT) STRING
264
265 void genie_times_char_int (NODE_T * p)
266 {
267 A68_INT k;
268 A68_CHAR a;
269 POP_OBJECT (p, &k, A68_INT);
270 POP_OBJECT (p, &a, A68_CHAR);
271 PUSH_VALUE (p, VALUE (&k), A68_INT);
272 PUSH_VALUE (p, VALUE (&a), A68_CHAR);
273 genie_times_int_char (p);
274 }
275
276 //! @brief OP +:= = (REF STRING, STRING) REF STRING
277
278 void genie_plusab_string (NODE_T * p)
279 {
280 genie_f_and_becomes (p, M_REF_STRING, genie_add_string);
281 }
282
283 //! @brief OP +=: = (STRING, REF STRING) REF STRING
284
285 void genie_plusto_string (NODE_T * p)
286 {
287 A68_REF refa, a, b;
288 POP_REF (p, &refa);
289 CHECK_REF (p, refa, M_REF_STRING);
290 a = *DEREF (A68_REF, &refa);
291 CHECK_INIT (p, INITIALISED (&a), M_STRING);
292 POP_REF (p, &b);
293 PUSH_REF (p, b);
294 PUSH_REF (p, a);
295 genie_add_string (p);
296 POP_REF (p, DEREF (A68_REF, &refa));
297 PUSH_REF (p, refa);
298 }
299
300 //! @brief OP *:= = (REF STRING, INT) REF STRING
301
302 void genie_timesab_string (NODE_T * p)
303 {
304 A68_INT k;
305 POP_OBJECT (p, &k, A68_INT);
306 PRELUDE_ERROR (VALUE (&k) < 0, p, ERROR_INVALID_ARGUMENT, M_INT);
307 A68_REF ref;
308 POP_REF (p, &ref);
309 CHECK_REF (p, ref, M_REF_STRING);
310 A68_REF a = *DEREF (A68_REF, &ref);
311 CHECK_INIT (p, INITIALISED (&a), M_STRING);
312 // Multiplication as repeated addition.
313 PUSH_REF (p, empty_string (p));
314 for (int i = 1; i <= VALUE (&k); i++) {
315 PUSH_REF (p, a);
316 genie_add_string (p);
317 }
318 // The stack contains a STRING, promote to REF STRING.
319 POP_REF (p, DEREF (A68_REF, &ref));
320 PUSH_REF (p, ref);
321 }
322
323 //! @brief Difference between two STRINGs in the stack.
324
325 int string_difference (NODE_T * p)
326 {
327 // Pop operands.
328 A68_REF row2; A68_ARRAY *a_2; A68_TUPLE *t_2;
329 POP_REF (p, &row2);
330 CHECK_INIT (p, INITIALISED (&row2), M_STRING);
331 GET_DESCRIPTOR (a_2, t_2, &row2);
332 int s_2 = ROW_SIZE (t_2);
333 //
334 A68_REF row1; A68_ARRAY *a_1; A68_TUPLE *t_1;
335 POP_REF (p, &row1);
336 CHECK_INIT (p, INITIALISED (&row1), M_STRING);
337 GET_DESCRIPTOR (a_1, t_1, &row1);
338 int s_1 = ROW_SIZE (t_1);
339 // Compute string difference.
340 int size = (s_1 > s_2 ? s_1 : s_2), diff = 0;
341 BYTE_T *b_1 = (s_1 > 0 ? DEREF (BYTE_T, &ARRAY (a_1)) : NO_BYTE);
342 BYTE_T *b_2 = (s_2 > 0 ? DEREF (BYTE_T, &ARRAY (a_2)) : NO_BYTE);
343 for (int k = 0; k < size && diff == 0; k++) {
344 int a, b;
345 if (s_1 > 0 && k < s_1) {
346 A68_CHAR *ch = (A68_CHAR *) & b_1[INDEX_1_DIM (a_1, t_1, LWB (t_1) + k)];
347 a = (int) VALUE (ch);
348 } else {
349 a = 0;
350 }
351 if (s_2 > 0 && k < s_2) {
352 A68_CHAR *ch = (A68_CHAR *) & b_2[INDEX_1_DIM (a_2, t_2, LWB (t_2) + k)];
353 b = (int) VALUE (ch);
354 } else {
355 b = 0;
356 }
357 diff += (TO_UCHAR (a) - TO_UCHAR (b));
358 }
359 return diff;
360 }
361
362 // OP (STRING, STRING) BOOL.
363
364 #define A68_CMP_STRING(n, OP)\
365 void n (NODE_T * p) {\
366 int k = string_difference (p);\
367 PUSH_VALUE (p, (BOOL_T) (k OP 0), A68_BOOL);\
368 }
369
370 A68_CMP_STRING (genie_eq_string, ==)
371 A68_CMP_STRING (genie_ne_string, !=)
372 A68_CMP_STRING (genie_lt_string, <)
373 A68_CMP_STRING (genie_gt_string, >)
374 A68_CMP_STRING (genie_le_string, <=)
375 A68_CMP_STRING (genie_ge_string, >=)
376 // BYTES operations.
377 //! @brief OP ELEM = (INT, BYTES) CHAR
378 void genie_elem_bytes (NODE_T * p)
379 {
380 A68_BYTES j; A68_INT i;
381 POP_OBJECT (p, &j, A68_BYTES);
382 POP_OBJECT (p, &i, A68_INT);
383 PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT);
384 if (VALUE (&i) > (int) strlen (VALUE (&j))) {
385 genie_null_char (p);
386 } else {
387 PUSH_VALUE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR);
388 }
389 }
390
391 //! @brief PROC bytes pack = (STRING) BYTES
392
393 void genie_bytespack (NODE_T * p)
394 {
395 A68_REF z; A68_BYTES b;
396 POP_REF (p, &z);
397 CHECK_REF (p, z, M_STRING);
398 PRELUDE_ERROR (a68_string_size (p, z) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_STRING);
399 STATUS (&b) = INIT_MASK;
400 ASSERT (a_to_c_string (p, VALUE (&b), z) != NO_TEXT);
401 PUSH_BYTES (p, VALUE (&b));
402 }
403
404 //! @brief PROC bytes pack = (STRING) BYTES
405
406 void genie_add_bytes (NODE_T * p)
407 {
408 A68_BYTES *i, *j;
409 POP_OPERAND_ADDRESSES (p, i, j, A68_BYTES);
410 PRELUDE_ERROR (((int) strlen (VALUE (i)) + (int) strlen (VALUE (j))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_BYTES);
411 bufcat (VALUE (i), VALUE (j), BYTES_WIDTH);
412 }
413
414 //! @brief OP +:= = (REF BYTES, BYTES) REF BYTES
415
416 void genie_plusab_bytes (NODE_T * p)
417 {
418 genie_f_and_becomes (p, M_REF_BYTES, genie_add_bytes);
419 }
420
421 //! @brief OP +=: = (BYTES, REF BYTES) REF BYTES
422
423 void genie_plusto_bytes (NODE_T * p)
424 {
425 A68_BYTES i, *address, j;
426 A68_REF z;
427 POP_REF (p, &z);
428 CHECK_REF (p, z, M_REF_BYTES);
429 address = DEREF (A68_BYTES, &z);
430 CHECK_INIT (p, INITIALISED (address), M_BYTES);
431 POP_OBJECT (p, &i, A68_BYTES);
432 PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_BYTES);
433 bufcpy (VALUE (&j), VALUE (&i), BYTES_WIDTH);
434 bufcat (VALUE (&j), VALUE (address), BYTES_WIDTH);
435 bufcpy (VALUE (address), VALUE (&j), BYTES_WIDTH);
436 PUSH_REF (p, z);
437 }
438
439 //! @brief Difference between BYTE strings.
440
441 int compare_bytes (NODE_T * p)
442 {
443 A68_BYTES x, y;
444 POP_OBJECT (p, &y, A68_BYTES);
445 POP_OBJECT (p, &x, A68_BYTES);
446 return strcmp (VALUE (&x), VALUE (&y));
447 }
448
449 // OP (BYTES, BYTES) BOOL.
450
451 #define A68_CMP_BYTES(n, OP)\
452 void n (NODE_T * p) {\
453 int k = compare_bytes (p);\
454 PUSH_VALUE (p, (BOOL_T) (k OP 0), A68_BOOL);\
455 }
456
457 A68_CMP_BYTES (genie_eq_bytes, ==);
458 A68_CMP_BYTES (genie_ne_bytes, !=);
459 A68_CMP_BYTES (genie_lt_bytes, <);
460 A68_CMP_BYTES (genie_gt_bytes, >);
461 A68_CMP_BYTES (genie_le_bytes, <=);
462 A68_CMP_BYTES (genie_ge_bytes, >=);
463
464 //! @brief OP LENG = (BYTES) LONG BYTES
465
466 void genie_leng_bytes (NODE_T * p)
467 {
468 A68_LONG_BYTES a;
469 memset (VALUE (&a), 0, sizeof (VALUE (&a)));
470 POP_OBJECT (p, (A68_BYTES *) &a, A68_BYTES);
471 PUSH_LONG_BYTES (p, VALUE (&a));
472 }
473
474 //! @brief OP SHORTEN = (LONG BYTES) BYTES
475
476 void genie_shorten_bytes (NODE_T * p)
477 {
478 A68_LONG_BYTES a;
479 POP_OBJECT (p, &a, A68_LONG_BYTES);
480 PRELUDE_ERROR (strlen (VALUE (&a)) >= BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_BYTES);
481 PUSH_BYTES (p, VALUE (&a));
482 }
483
484 //! @brief OP ELEM = (INT, LONG BYTES) CHAR
485
486 void genie_elem_long_bytes (NODE_T * p)
487 {
488 A68_LONG_BYTES j; A68_INT i;
489 POP_OBJECT (p, &j, A68_LONG_BYTES);
490 POP_OBJECT (p, &i, A68_INT);
491 PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT);
492 if (VALUE (&i) > (int) strlen (VALUE (&j))) {
493 genie_null_char (p);
494 } else {
495 PUSH_VALUE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR);
496 }
497 }
498
499 //! @brief PROC long bytes pack = (STRING) LONG BYTES
500
501 void genie_long_bytespack (NODE_T * p)
502 {
503 A68_REF z; A68_LONG_BYTES b;
504 POP_REF (p, &z);
505 CHECK_REF (p, z, M_STRING);
506 PRELUDE_ERROR (a68_string_size (p, z) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_STRING);
507 STATUS (&b) = INIT_MASK;
508 ASSERT (a_to_c_string (p, VALUE (&b), z) != NO_TEXT);
509 PUSH_LONG_BYTES (p, VALUE (&b));
510 }
511
512 //! @brief OP + = (LONG BYTES, LONG BYTES) LONG BYTES
513
514 void genie_add_long_bytes (NODE_T * p)
515 {
516 A68_LONG_BYTES *i, *j;
517 POP_OPERAND_ADDRESSES (p, i, j, A68_LONG_BYTES);
518 PRELUDE_ERROR (((int) strlen (VALUE (i)) + (int) strlen (VALUE (j))) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_LONG_BYTES);
519 bufcat (VALUE (i), VALUE (j), LONG_BYTES_WIDTH);
520 }
521
522 //! @brief OP +:= = (REF LONG BYTES, LONG BYTES) REF LONG BYTES
523
524 void genie_plusab_long_bytes (NODE_T * p)
525 {
526 genie_f_and_becomes (p, M_REF_LONG_BYTES, genie_add_long_bytes);
527 }
528
529 //! @brief OP +=: = (LONG BYTES, REF LONG BYTES) REF LONG BYTES
530
531 void genie_plusto_long_bytes (NODE_T * p)
532 {
533 A68_LONG_BYTES i, *address, j;
534 A68_REF z;
535 POP_REF (p, &z);
536 CHECK_REF (p, z, M_REF_LONG_BYTES);
537 address = DEREF (A68_LONG_BYTES, &z);
538 CHECK_INIT (p, INITIALISED (address), M_LONG_BYTES);
539 POP_OBJECT (p, &i, A68_LONG_BYTES);
540 PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_LONG_BYTES);
541 bufcpy (VALUE (&j), VALUE (&i), LONG_BYTES_WIDTH);
542 bufcat (VALUE (&j), VALUE (address), LONG_BYTES_WIDTH);
543 bufcpy (VALUE (address), VALUE (&j), LONG_BYTES_WIDTH);
544 PUSH_REF (p, z);
545 }
546
547 //! @brief Difference between LONG BYTE strings.
548
549 int compare_long_bytes (NODE_T * p)
550 {
551 A68_LONG_BYTES x, y;
552 POP_OBJECT (p, &y, A68_LONG_BYTES);
553 POP_OBJECT (p, &x, A68_LONG_BYTES);
554 return strcmp (VALUE (&x), VALUE (&y));
555 }
556
557 // OP (LONG BYTES, LONG BYTES) BOOL.
558
559 #define A68_CMP_LONG_BYTES(n, OP)\
560 void n (NODE_T * p) {\
561 int k = compare_long_bytes (p);\
562 PUSH_VALUE (p, (BOOL_T) (k OP 0), A68_BOOL);\
563 }
564
565 A68_CMP_LONG_BYTES (genie_eq_long_bytes, ==);
566 A68_CMP_LONG_BYTES (genie_ne_long_bytes, !=);
567 A68_CMP_LONG_BYTES (genie_lt_long_bytes, <);
568 A68_CMP_LONG_BYTES (genie_gt_long_bytes, >);
569 A68_CMP_LONG_BYTES (genie_le_long_bytes, <=);
570 A68_CMP_LONG_BYTES (genie_ge_long_bytes, >=);
571
572 //! @brief PROC char in string = (CHAR, REF INT, STRING) BOOL
573
574 void genie_char_in_string (NODE_T * p)
575 {
576 A68_REF ref_str; A68_ARRAY *arr; A68_TUPLE *tup;
577 POP_REF (p, &ref_str);
578 A68_ROW row = *(A68_REF *) &ref_str;
579 CHECK_INIT (p, INITIALISED (&row), M_ROWS);
580 GET_DESCRIPTOR (arr, tup, &row);
581 A68_REF ref_pos; A68_INT pos;
582 POP_REF (p, &ref_pos);
583 A68_CHAR c;
584 POP_OBJECT (p, &c, A68_CHAR);
585 reset_transput_buffer (PATTERN_BUFFER);
586 add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_str);
587 int len = get_transput_buffer_index (PATTERN_BUFFER);
588 char *q = get_transput_buffer (PATTERN_BUFFER);
589 char ch = (char) VALUE (&c);
590 for (int k = 0; k < len; k++) {
591 if (q[k] == ch) {
592 STATUS (&pos) = INIT_MASK;
593 VALUE (&pos) = k + LOWER_BOUND (tup);
594 *DEREF (A68_INT, &ref_pos) = pos;
595 PUSH_VALUE (p, A68_TRUE, A68_BOOL);
596 return;
597 }
598 }
599 PUSH_VALUE (p, A68_FALSE, A68_BOOL);
600 }
601
602 //! @brief PROC last char in string = (CHAR, REF INT, STRING) BOOL
603
604 void genie_last_char_in_string (NODE_T * p)
605 {
606 A68_REF ref_str; A68_ARRAY *arr; A68_TUPLE *tup;
607 POP_REF (p, &ref_str);
608 A68_ROW row = *(A68_REF *) &ref_str;
609 CHECK_INIT (p, INITIALISED (&row), M_ROWS);
610 GET_DESCRIPTOR (arr, tup, &row);
611 A68_REF ref_pos; A68_INT pos;
612 POP_REF (p, &ref_pos);
613 A68_CHAR c;
614 POP_OBJECT (p, &c, A68_CHAR);
615 reset_transput_buffer (PATTERN_BUFFER);
616 add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_str);
617 int len = get_transput_buffer_index (PATTERN_BUFFER);
618 char *q = get_transput_buffer (PATTERN_BUFFER);
619 char ch = (char) VALUE (&c);
620 for (int k = len - 1; k >= 0; k--) {
621 if (q[k] == ch) {
622 STATUS (&pos) = INIT_MASK;
623 VALUE (&pos) = k + LOWER_BOUND (tup);
624 *DEREF (A68_INT, &ref_pos) = pos;
625 PUSH_VALUE (p, A68_TRUE, A68_BOOL);
626 return;
627 }
628 }
629 PUSH_VALUE (p, A68_FALSE, A68_BOOL);
630 }
631
632 //! @brief PROC string in string = (STRING, REF INT, STRING) BOOL
633
634 void genie_string_in_string (NODE_T * p)
635 {
636 A68_REF ref_pos, ref_str, ref_pat; A68_ARRAY *arr; A68_TUPLE *tup;
637 POP_REF (p, &ref_str);
638 A68_ROW row = *(A68_REF *) &ref_str;
639 CHECK_INIT (p, INITIALISED (&row), M_ROWS);
640 GET_DESCRIPTOR (arr, tup, &row);
641 POP_REF (p, &ref_pos);
642 POP_REF (p, &ref_pat);
643 reset_transput_buffer (PATTERN_BUFFER);
644 reset_transput_buffer (STRING_BUFFER);
645 add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat);
646 add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str);
647 char *q = strstr (get_transput_buffer (STRING_BUFFER), get_transput_buffer (PATTERN_BUFFER));
648 if (q != NO_TEXT) {
649 if (!IS_NIL (ref_pos)) {
650 A68_INT pos;
651 STATUS (&pos) = INIT_MASK;
652 // ANSI standard leaves pointer difference undefined.
653 VALUE (&pos) = LOWER_BOUND (tup) + (int) get_transput_buffer_index (STRING_BUFFER) - (int) strlen (q);
654 *DEREF (A68_INT, &ref_pos) = pos;
655 }
656 PUSH_VALUE (p, A68_TRUE, A68_BOOL);
657 } else {
658 PUSH_VALUE (p, A68_FALSE, A68_BOOL);
659 }
660 }
661
