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