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