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