rts-monitor.c
1 //! @file monitor.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 //! GDB-style monitor for the interpreter.
25
26 // This is a basic monitor for Algol68G. It activates when the interpreter
27 // receives SIGINT (CTRL-C, for instance) or when PROC VOID break, debug or
28 // evaluate is called, or when a runtime error occurs and --debug is selected.
29 //
30 // The monitor allows single stepping (unit-wise through serial/enquiry
31 // clauses) and has basic means for inspecting call-frame stack and heap.
32
33 #include "a68g.h"
34 #include "a68g-genie.h"
35 #include "a68g-frames.h"
36 #include "a68g-prelude.h"
37 #include "a68g-mp.h"
38 #include "a68g-transput.h"
39 #include "a68g-parser.h"
40 #include "a68g-listing.h"
41
42 #define CANNOT_SHOW " unprintable value or uninitialised value"
43 #define MAX_ROW_ELEMS 24
44 #define NOT_A_NUM (-1)
45 #define NO_VALUE " uninitialised value"
46 #define TOP_MODE (A68_MON (_m_stack)[A68_MON (_m_sp) - 1])
47 #define LOGOUT_STRING "exit"
48
49 void parse (FILE_T, NODE_T *, int);
50
51 BOOL_T check_initialisation (NODE_T *, BYTE_T *, MOID_T *, BOOL_T *);
52
53 #define SKIP_ONE_SYMBOL(sym) {\
54 while (!IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
55 (sym)++;\
56 }\
57 while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
58 (sym)++;\
59 }}
60
61 #define SKIP_SPACE(sym) {\
62 while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
63 (sym)++;\
64 }}
65
66 #define CHECK_MON_REF(p, z, m)\
67 if (! INITIALISED (&z)) {\
68 ASSERT (snprintf(A68 (edit_line), SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\
69 monitor_error (NO_VALUE, A68 (edit_line));\
70 QUIT_ON_ERROR;\
71 } else if (IS_NIL (z)) {\
72 ASSERT (snprintf(A68 (edit_line), SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\
73 monitor_error ("accessing NIL name", A68 (edit_line));\
74 QUIT_ON_ERROR;\
75 }
76
77 #define QUIT_ON_ERROR\
78 if (A68_MON (mon_errors) > 0) {\
79 return;\
80 }
81
82 #define PARSE_CHECK(f, p, d)\
83 parse ((f), (p), (d));\
84 QUIT_ON_ERROR;
85
86 #define SCAN_CHECK(f, p)\
87 scan_sym((f), (p));\
88 QUIT_ON_ERROR;
89
90 //! @brief Confirm that we really want to quit.
91
92 BOOL_T confirm_exit (void)
93 {
94 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Terminate %s (yes|no): ", A68 (a68_cmd_name)) >= 0);
95 WRITELN (STDOUT_FILENO, A68 (output_line));
96 char *cmd = read_string_from_tty (NULL);
97 if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) {
98 return confirm_exit ();
99 }
100 for (int k = 0; cmd[k] != NULL_CHAR; k++) {
101 cmd[k] = (char) TO_LOWER (cmd[k]);
102 }
103 if (strcmp (cmd, "y") == 0) {
104 return A68_TRUE;
105 }
106 if (strcmp (cmd, "yes") == 0) {
107 return A68_TRUE;
108 }
109 if (strcmp (cmd, "n") == 0) {
110 return A68_FALSE;
111 }
112 if (strcmp (cmd, "no") == 0) {
113 return A68_FALSE;
114 }
115 return confirm_exit ();
116 }
117
118 //! @brief Give a monitor error message.
119
120 void monitor_error (char *msg, char *info)
121 {
122 QUIT_ON_ERROR;
123 A68_MON (mon_errors)++;
124 bufcpy (A68_MON (error_text), msg, BUFFER_SIZE);
125 WRITELN (STDOUT_FILENO, A68 (a68_cmd_name));
126 WRITE (STDOUT_FILENO, ": monitor error: ");
127 WRITE (STDOUT_FILENO, A68_MON (error_text));
128 if (info != NO_TEXT) {
129 WRITE (STDOUT_FILENO, " (");
130 WRITE (STDOUT_FILENO, info);
131 WRITE (STDOUT_FILENO, ")");
132 }
133 WRITE (STDOUT_FILENO, ".");
134 }
135
136 //! @brief Scan symbol from input.
137
138 void scan_sym (FILE_T f, NODE_T * p)
139 {
140 int k = 0;
141 (void) f;
142 (void) p;
143 A68_MON (symbol)[0] = NULL_CHAR;
144 A68_MON (attr) = 0;
145 QUIT_ON_ERROR;
146 while (IS_SPACE (A68_MON (expr)[A68_MON (pos)])) {
147 A68_MON (pos)++;
148 }
149 if (A68_MON (expr)[A68_MON (pos)] == NULL_CHAR) {
150 A68_MON (attr) = 0;
151 A68_MON (symbol)[0] = NULL_CHAR;
152 return;
153 } else if (A68_MON (expr)[A68_MON (pos)] == ':') {
154 if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":=:", 3) == 0) {
155 A68_MON (pos) += 3;
156 bufcpy (A68_MON (symbol), ":=:", BUFFER_SIZE);
157 A68_MON (attr) = IS_SYMBOL;
158 } else if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":/=:", 4) == 0) {
159 A68_MON (pos) += 4;
160 bufcpy (A68_MON (symbol), ":/=:", BUFFER_SIZE);
161 A68_MON (attr) = ISNT_SYMBOL;
162 } else if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":=", 2) == 0) {
163 A68_MON (pos) += 2;
164 bufcpy (A68_MON (symbol), ":=", BUFFER_SIZE);
165 A68_MON (attr) = ASSIGN_SYMBOL;
166 } else {
167 A68_MON (pos)++;
168 bufcpy (A68_MON (symbol), ":", BUFFER_SIZE);
169 A68_MON (attr) = COLON_SYMBOL;
170 }
171 return;
172 } else if (A68_MON (expr)[A68_MON (pos)] == QUOTE_CHAR) {
173 BOOL_T cont = A68_TRUE;
174 A68_MON (pos)++;
175 while (cont) {
176 while (A68_MON (expr)[A68_MON (pos)] != QUOTE_CHAR) {
177 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
178 }
179 if (A68_MON (expr)[++A68_MON (pos)] == QUOTE_CHAR) {
180 A68_MON (symbol)[k++] = QUOTE_CHAR;
181 } else {
182 cont = A68_FALSE;
183 }
184 }
185 A68_MON (symbol)[k] = NULL_CHAR;
186 A68_MON (attr) = ROW_CHAR_DENOTATION;
187 return;
188 } else if (IS_LOWER (A68_MON (expr)[A68_MON (pos)])) {
189 while (IS_LOWER (A68_MON (expr)[A68_MON (pos)]) || IS_DIGIT (A68_MON (expr)[A68_MON (pos)]) || IS_SPACE (A68_MON (expr)[A68_MON (pos)])) {
190 if (IS_SPACE (A68_MON (expr)[A68_MON (pos)])) {
191 A68_MON (pos)++;
192 } else {
193 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
194 }
195 }
196 A68_MON (symbol)[k] = NULL_CHAR;
197 A68_MON (attr) = IDENTIFIER;
198 return;
199 } else if (IS_UPPER (A68_MON (expr)[A68_MON (pos)])) {
200 KEYWORD_T *kw;
201 while (IS_UPPER (A68_MON (expr)[A68_MON (pos)])) {
202 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
203 }
204 A68_MON (symbol)[k] = NULL_CHAR;
205 kw = find_keyword (A68 (top_keyword), A68_MON (symbol));
206 if (kw != NO_KEYWORD) {
207 A68_MON (attr) = ATTRIBUTE (kw);
208 } else {
209 A68_MON (attr) = OPERATOR;
210 }
211 return;
212 } else if (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) {
213 while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) {
214 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
215 }
216 if (A68_MON (expr)[A68_MON (pos)] == 'r') {
217 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
218 while (IS_XDIGIT (A68_MON (expr)[A68_MON (pos)])) {
219 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
220 }
221 A68_MON (symbol)[k] = NULL_CHAR;
222 A68_MON (attr) = BITS_DENOTATION;
223 return;
224 }
225 if (A68_MON (expr)[A68_MON (pos)] != POINT_CHAR && A68_MON (expr)[A68_MON (pos)] != 'e' && A68_MON (expr)[A68_MON (pos)] != 'E') {
226 A68_MON (symbol)[k] = NULL_CHAR;
227 A68_MON (attr) = INT_DENOTATION;
228 return;
229 }
230 if (A68_MON (expr)[A68_MON (pos)] == POINT_CHAR) {
231 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
232 while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) {
233 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
234 }
235 }
236 if (A68_MON (expr)[A68_MON (pos)] != 'e' && A68_MON (expr)[A68_MON (pos)] != 'E') {
237 A68_MON (symbol)[k] = NULL_CHAR;
238 A68_MON (attr) = REAL_DENOTATION;
239 return;
240 }
241 A68_MON (symbol)[k++] = (char) TO_UPPER (A68_MON (expr)[A68_MON (pos)++]);
242 if (A68_MON (expr)[A68_MON (pos)] == '+' || A68_MON (expr)[A68_MON (pos)] == '-') {
243 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
244 }
245 while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) {
246 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
247 }
248 A68_MON (symbol)[k] = NULL_CHAR;
249 A68_MON (attr) = REAL_DENOTATION;
250 return;
251 } else if (strchr (MONADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT || strchr (NOMADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT) {
252 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
253 if (strchr (NOMADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT) {
254 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
255 }
256 if (A68_MON (expr)[A68_MON (pos)] == ':') {
257 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
258 if (A68_MON (expr)[A68_MON (pos)] == '=') {
259 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
260 } else {
261 A68_MON (symbol)[k] = NULL_CHAR;
262 monitor_error ("invalid operator symbol", A68_MON (symbol));
263 }
264 } else if (A68_MON (expr)[A68_MON (pos)] == '=') {
265 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
266 if (A68_MON (expr)[A68_MON (pos)] == ':') {
267 A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
268 } else {
269 A68_MON (symbol)[k] = NULL_CHAR;
270 monitor_error ("invalid operator symbol", A68_MON (symbol));
271 }
272 }
273 A68_MON (symbol)[k] = NULL_CHAR;
274 A68_MON (attr) = OPERATOR;
275 return;
276 } else if (A68_MON (expr)[A68_MON (pos)] == '(') {
277 A68_MON (pos)++;
278 A68_MON (attr) = OPEN_SYMBOL;
279 return;
280 } else if (A68_MON (expr)[A68_MON (pos)] == ')') {
281 A68_MON (pos)++;
282 A68_MON (attr) = CLOSE_SYMBOL;
283 return;
284 } else if (A68_MON (expr)[A68_MON (pos)] == '[') {
285 A68_MON (pos)++;
286 A68_MON (attr) = SUB_SYMBOL;
287 return;
288 } else if (A68_MON (expr)[A68_MON (pos)] == ']') {
289 A68_MON (pos)++;
290 A68_MON (attr) = BUS_SYMBOL;
291 return;
292 } else if (A68_MON (expr)[A68_MON (pos)] == ',') {
293 A68_MON (pos)++;
294 A68_MON (attr) = COMMA_SYMBOL;
295 return;
296 } else if (A68_MON (expr)[A68_MON (pos)] == ';') {
297 A68_MON (pos)++;
298 A68_MON (attr) = SEMI_SYMBOL;
299 return;
300 }
301 }
302
303 //! @brief Find a tag, searching symbol tables towards the root.
304
305 TAG_T *find_tag (TABLE_T * table, int a, char *name)
306 {
307 if (table != NO_TABLE) {
308 TAG_T *s = NO_TAG;
309 if (a == OP_SYMBOL) {
310 s = OPERATORS (table);
311 } else if (a == PRIO_SYMBOL) {
312 s = PRIO (table);
313 } else if (a == IDENTIFIER) {
314 s = IDENTIFIERS (table);
315 } else if (a == INDICANT) {
316 s = INDICANTS (table);
317 } else if (a == LABEL) {
318 s = LABELS (table);
319 } else {
320 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
321 }
322 for (; s != NO_TAG; FORWARD (s)) {
323 if (strcmp (NSYMBOL (NODE (s)), name) == 0) {
324 return s;
325 }
326 }
327 return find_tag_global (PREVIOUS (table), a, name);
328 } else {
329 return NO_TAG;
330 }
331 }
332
333 //! @brief Priority for symbol at input.
334
335 int prio (FILE_T f, NODE_T * p)
336 {
337 TAG_T *s = find_tag (A68_STANDENV, PRIO_SYMBOL, A68_MON (symbol));
338 (void) p;
339 (void) f;
340 if (s == NO_TAG) {
341 monitor_error ("unknown operator, cannot set priority", A68_MON (symbol));
342 return 0;
343 }
344 return PRIO (s);
345 }
346
347 //! @brief Push a mode on the stack.
348
349 void push_mode (FILE_T f, MOID_T * m)
350 {
351 (void) f;
352 if (A68_MON (_m_sp) < MON_STACK_SIZE) {
353 A68_MON (_m_stack)[A68_MON (_m_sp)++] = m;
354 } else {
355 monitor_error ("expression too complex", NO_TEXT);
356 }
357 }
358
359 //! @brief Dereference, WEAK or otherwise.
360
361 BOOL_T deref_condition (int k, int context)
362 {
363 MOID_T *u = A68_MON (_m_stack)[k];
364 if (context == WEAK && SUB (u) != NO_MOID) {
365 MOID_T *v = SUB (u);
366 BOOL_T stowed = (BOOL_T) (IS_FLEX (v) || IS_ROW (v) || IS_STRUCT (v));
367 return (BOOL_T) (IS_REF (u) && !stowed);
368 } else {
369 return (BOOL_T) (IS_REF (u));
370 }
371 }
372
373 //! @brief Weak dereferencing.
374
375 void deref (NODE_T * p, int k, int context)
376 {
377 while (deref_condition (k, context)) {
378 A68_REF z;
379 POP_REF (p, &z);
380 CHECK_MON_REF (p, z, A68_MON (_m_stack)[k]);
381 A68_MON (_m_stack)[k] = SUB (A68_MON (_m_stack)[k]);
382 PUSH (p, ADDRESS (&z), SIZE (A68_MON (_m_stack)[k]));
383 }
384 }
385
386 //! @brief Search moid that matches indicant.
387
388 MOID_T *search_mode (int refs, int leng, char *indy)
389 {
390 MOID_T *m = NO_MOID, *z = NO_MOID;
391 for (m = TOP_MOID (&A68_JOB); m != NO_MOID; FORWARD (m)) {
392 if (NODE (m) != NO_NODE) {
393 if (indy == NSYMBOL (NODE (m)) && leng == DIM (m)) {
394 z = m;
395 while (EQUIVALENT (z) != NO_MOID) {
396 z = EQUIVALENT (z);
397 }
398 }
399 }
400 }
401 if (z == NO_MOID) {
402 monitor_error ("unknown indicant", indy);
403 return NO_MOID;
404 }
405 for (m = TOP_MOID (&A68_JOB); m != NO_MOID; FORWARD (m)) {
406 int k = 0;
407 while (IS_REF (m)) {
408 k++;
409 m = SUB (m);
410 }
411 if (k == refs && m == z) {
412 while (EQUIVALENT (z) != NO_MOID) {
413 z = EQUIVALENT (z);
414 }
415 return z;
416 }
417 }
418 return NO_MOID;
419 }
420
421 //! @brief Search operator X SYM Y.
422
423 TAG_T *search_operator (char *sym, MOID_T * x, MOID_T * y)
424 {
425 TAG_T *t;
426 for (t = OPERATORS (A68_STANDENV); t != NO_TAG; FORWARD (t)) {
427 if (strcmp (NSYMBOL (NODE (t)), sym) == 0) {
428 PACK_T *p = PACK (MOID (t));
429 if (x == MOID (p)) {
430 FORWARD (p);
431 if (p == NO_PACK && y == NO_MOID) {
432 // Matched in case of a monad.
433 return t;
434 } else if (p != NO_PACK && y != NO_MOID && y == MOID (p)) {
435 // Matched in case of a nomad.
436 return t;
437 }
438 }
439 }
440 }
441 // Not found yet, try dereferencing.
442 if (IS_REF (x)) {
443 return search_operator (sym, SUB (x), y);
444 }
445 if (y != NO_MOID && IS_REF (y)) {
446 return search_operator (sym, x, SUB (y));
447 }
448 // Not found. Grrrr. Give a message.
449 if (y == NO_MOID) {
450 ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s %s", sym, moid_to_string (x, MOID_WIDTH, NO_NODE)) >= 0);
451 } else {
452 ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s %s %s", moid_to_string (x, MOID_WIDTH, NO_NODE), sym, moid_to_string (y, MOID_WIDTH, NO_NODE)) >= 0);
453 }
454 monitor_error ("cannot find operator in standard environ", A68 (edit_line));
455 return NO_TAG;
456 }
457
458 //! @brief Search identifier in frame stack and push value.
459
460 void search_identifier (FILE_T f, NODE_T * p, ADDR_T a68_link, char *sym)
461 {
462 if (a68_link > 0) {
463 int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
464 if (A68_MON (current_frame) == 0 || (A68_MON (current_frame) == FRAME_NUMBER (a68_link))) {
465 NODE_T *u = FRAME_TREE (a68_link);
466 if (u != NO_NODE) {
467 TABLE_T *q = TABLE (u);
468 TAG_T *i = IDENTIFIERS (q);
469 for (; i != NO_TAG; FORWARD (i)) {
470 if (strcmp (NSYMBOL (NODE (i)), sym) == 0) {
471 ADDR_T posit = a68_link + FRAME_INFO_SIZE + OFFSET (i);
472 MOID_T *m = MOID (i);
473 PUSH (p, FRAME_ADDRESS (posit), SIZE (m));
474 push_mode (f, m);
475 return;
476 }
477 }
478 }
479 }
480 search_identifier (f, p, dynamic_a68_link, sym);
481 } else {
482 TABLE_T *q = A68_STANDENV;
483 TAG_T *i = IDENTIFIERS (q);
484 for (; i != NO_TAG; FORWARD (i)) {
485 if (strcmp (NSYMBOL (NODE (i)), sym) == 0) {
486 if (IS (MOID (i), PROC_SYMBOL)) {
487 static A68_PROCEDURE z;
488 STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | STANDENV_PROC_MASK);
489 PROCEDURE (&(BODY (&z))) = PROCEDURE (i);
490 ENVIRON (&z) = 0;
491 LOCALE (&z) = NO_HANDLE;
492 MOID (&z) = MOID (i);
493 PUSH_PROCEDURE (p, z);
494 } else {
495 (*(PROCEDURE (i))) (p);
496 }
497 push_mode (f, MOID (i));
498 return;
499 }
500 }
501 monitor_error ("cannot find identifier", sym);
502 }
503 }
504
505 //! @brief Coerce arguments in a call.
506
507 void coerce_arguments (FILE_T f, NODE_T * p, MOID_T * proc, int bot, int top, int top_sp)
508 {
509 int k;
510 PACK_T *u;
511 ADDR_T pop_sp = top_sp;
512 (void) f;
513 if ((top - bot) != DIM (proc)) {
514 monitor_error ("invalid procedure argument count", NO_TEXT);
515 }
516 QUIT_ON_ERROR;
517 for (k = bot, u = PACK (proc); k < top; k++, FORWARD (u)) {
518 if (A68_MON (_m_stack)[k] == MOID (u)) {
519 PUSH (p, STACK_ADDRESS (pop_sp), SIZE (MOID (u)));
520 pop_sp += SIZE (MOID (u));
521 } else if (IS_REF (A68_MON (_m_stack)[k])) {
522 A68_REF *v = (A68_REF *) STACK_ADDRESS (pop_sp);
523 PUSH_REF (p, *v);
524 pop_sp += A68_REF_SIZE;
525 deref (p, k, STRONG);
526 if (A68_MON (_m_stack)[k] != MOID (u)) {
527 ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s to %s", moid_to_string (A68_MON (_m_stack)[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0);
528 monitor_error ("invalid argument mode", A68 (edit_line));
529 }
530 } else {
531 ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s to %s", moid_to_string (A68_MON (_m_stack)[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0);
532 monitor_error ("cannot coerce argument", A68 (edit_line));
533 }
534 QUIT_ON_ERROR;
535 }
536 MOVE (STACK_ADDRESS (top_sp), STACK_ADDRESS (pop_sp), A68_SP - pop_sp);
537 A68_SP = top_sp + (A68_SP - pop_sp);
538 }
539
540 //! @brief Perform a selection.
541
542 void selection (FILE_T f, NODE_T * p, char *field)
543 {
544 BOOL_T name;
545 MOID_T *moid;
546 PACK_T *u, *v;
547 SCAN_CHECK (f, p);
548 if (A68_MON (attr) != IDENTIFIER && A68_MON (attr) != OPEN_SYMBOL) {
549 monitor_error ("invalid selection syntax", NO_TEXT);
550 }
551 QUIT_ON_ERROR;
552 PARSE_CHECK (f, p, MAX_PRIORITY + 1);
553 deref (p, A68_MON (_m_sp) - 1, WEAK);
554 if (IS_REF (TOP_MODE)) {
555 name = A68_TRUE;
556 u = PACK (NAME (TOP_MODE));
557 moid = SUB (A68_MON (_m_stack)[--A68_MON (_m_sp)]);
558 v = PACK (moid);
559 } else {
560 name = A68_FALSE;
561 moid = A68_MON (_m_stack)[--A68_MON (_m_sp)];
562 u = PACK (moid);
563 v = PACK (moid);
564 }
565 if (!IS (moid, STRUCT_SYMBOL)) {
566 monitor_error ("invalid selection mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
567 }
568 QUIT_ON_ERROR;
569 for (; u != NO_PACK; FORWARD (u), FORWARD (v)) {
570 if (strcmp (field, TEXT (u)) == 0) {
571 if (name) {
572 A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE));
573 CHECK_MON_REF (p, *z, moid);
574 OFFSET (z) += OFFSET (v);
575 } else {
576 DECREMENT_STACK_POINTER (p, SIZE (moid));
577 MOVE (STACK_TOP, STACK_OFFSET (OFFSET (v)), (unt) SIZE (MOID (u)));
578 INCREMENT_STACK_POINTER (p, SIZE (MOID (u)));
579 }
580 push_mode (f, MOID (u));
581 return;
582 }
583 }
584 monitor_error ("invalid field name", field);
585 }
586
587 //! @brief Perform a call.
588
589 void call (FILE_T f, NODE_T * p, int depth)
590 {
591 A68_PROCEDURE z;
592 NODE_T q;
593 int args, old_m_sp;
594 MOID_T *proc;
595 (void) depth;
596 QUIT_ON_ERROR;
597 deref (p, A68_MON (_m_sp) - 1, STRONG);
598 proc = A68_MON (_m_stack)[--A68_MON (_m_sp)];
599 old_m_sp = A68_MON (_m_sp);
600 if (!IS (proc, PROC_SYMBOL)) {
601 monitor_error ("invalid procedure mode", moid_to_string (proc, MOID_WIDTH, NO_NODE));
602 }
603 QUIT_ON_ERROR;
604 POP_PROCEDURE (p, &z);
605 args = A68_MON (_m_sp);
606 ADDR_T top_sp = A68_SP;
607 if (A68_MON (attr) == OPEN_SYMBOL) {
608 do {
609 SCAN_CHECK (f, p);
610 PARSE_CHECK (f, p, 0);
611 } while (A68_MON (attr) == COMMA_SYMBOL);
612 if (A68_MON (attr) != CLOSE_SYMBOL) {
613 monitor_error ("unmatched parenthesis", NO_TEXT);
614 }
615 SCAN_CHECK (f, p);
616 }
617 coerce_arguments (f, p, proc, args, A68_MON (_m_sp), top_sp);
618 if (STATUS (&z) & STANDENV_PROC_MASK) {
619 MOID (&q) = A68_MON (_m_stack)[--A68_MON (_m_sp)];
620 INFO (&q) = INFO (p);
621 NSYMBOL (&q) = NSYMBOL (p);
622 (void) ((*PROCEDURE (&(BODY (&z)))) (&q));
623 A68_MON (_m_sp) = old_m_sp;
624 push_mode (f, SUB_MOID (&z));
625 } else {
626 monitor_error ("can only call standard environ routines", NO_TEXT);
627 }
628 }
629
630 //! @brief Perform a slice.
631
632 void slice (FILE_T f, NODE_T * p, int depth)
633 {
634 MOID_T *moid, *res;
635 A68_REF z;
636 A68_ARRAY *arr;
637 A68_TUPLE *tup;
638 ADDR_T address;
639 int dim, k, iindex, args;
640 BOOL_T name;
641 (void) depth;
642 QUIT_ON_ERROR;
643 deref (p, A68_MON (_m_sp) - 1, WEAK);
644 if (IS_REF (TOP_MODE)) {
645 name = A68_TRUE;
646 res = NAME (TOP_MODE);
647 deref (p, A68_MON (_m_sp) - 1, STRONG);
648 moid = A68_MON (_m_stack)[--A68_MON (_m_sp)];
649 } else {
650 name = A68_FALSE;
651 moid = A68_MON (_m_stack)[--A68_MON (_m_sp)];
652 res = SUB (moid);
653 }
654 if (!IS_ROW (moid) && !IS_FLEX (moid)) {
655 monitor_error ("invalid row mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
656 }
657 QUIT_ON_ERROR;
658 // Get descriptor.
659 POP_REF (p, &z);
660 CHECK_MON_REF (p, z, moid);
661 GET_DESCRIPTOR (arr, tup, &z);
662 if (IS_FLEX (moid)) {
663 dim = DIM (SUB (moid));
664 } else {
665 dim = DIM (moid);
666 }
667 // Get iindexer.
668 args = A68_MON (_m_sp);
669 if (A68_MON (attr) == SUB_SYMBOL) {
670 do {
671 SCAN_CHECK (f, p);
672 PARSE_CHECK (f, p, 0);
673 } while (A68_MON (attr) == COMMA_SYMBOL);
674 if (A68_MON (attr) != BUS_SYMBOL) {
675 monitor_error ("unmatched parenthesis", NO_TEXT);
676 }
677 SCAN_CHECK (f, p);
678 }
679 if ((A68_MON (_m_sp) - args) != dim) {
680 monitor_error ("invalid slice index count", NO_TEXT);
681 }
682 QUIT_ON_ERROR;
683 for (k = 0, iindex = 0; k < dim; k++, A68_MON (_m_sp)--) {
684 A68_TUPLE *t = &(tup[dim - k - 1]);
685 A68_INT i;
686 deref (p, A68_MON (_m_sp) - 1, MEEK);
687 if (TOP_MODE != M_INT) {
688 monitor_error ("invalid indexer mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
689 }
690 QUIT_ON_ERROR;
691 POP_OBJECT (p, &i, A68_INT);
692 if (VALUE (&i) < LOWER_BOUND (t) || VALUE (&i) > UPPER_BOUND (t)) {
693 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
694 exit_genie (p, A68_RUNTIME_ERROR);
695 }
696 QUIT_ON_ERROR;
697 iindex += SPAN (t) * VALUE (&i) - SHIFT (t);
698 }
699 address = ROW_ELEMENT (arr, iindex);
700 if (name) {
701 z = ARRAY (arr);
702 OFFSET (&z) += address;
703 REF_SCOPE (&z) = PRIMAL_SCOPE;
704 PUSH_REF (p, z);
705 } else {
706 PUSH (p, ADDRESS (&(ARRAY (arr))) + address, SIZE (res));
707 }
708 push_mode (f, res);
709 }
710
711 //! @brief Perform a call or a slice.
712
713 void call_or_slice (FILE_T f, NODE_T * p, int depth)
714 {
715 while (A68_MON (attr) == OPEN_SYMBOL || A68_MON (attr) == SUB_SYMBOL) {
716 QUIT_ON_ERROR;
717 if (A68_MON (attr) == OPEN_SYMBOL) {
718 call (f, p, depth);
719 } else if (A68_MON (attr) == SUB_SYMBOL) {
720 slice (f, p, depth);
721 }
722 }
723 }
724
725 //! @brief Parse expression on input.
726
727 void parse (FILE_T f, NODE_T * p, int depth)
728 {
729 LOW_STACK_ALERT (p);
730 QUIT_ON_ERROR;
731 if (depth <= MAX_PRIORITY) {
732 if (depth == 0) {
733 // Identity relations.
734 PARSE_CHECK (f, p, 1);
735 while (A68_MON (attr) == IS_SYMBOL || A68_MON (attr) == ISNT_SYMBOL) {
736 A68_REF x, y;
737 BOOL_T res;
738 int op = A68_MON (attr);
739 if (TOP_MODE != M_HIP && !IS_REF (TOP_MODE)) {
740 monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
741 }
742 SCAN_CHECK (f, p);
743 PARSE_CHECK (f, p, 1);
744 if (TOP_MODE != M_HIP && !IS_REF (TOP_MODE)) {
745 monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
746 }
747 QUIT_ON_ERROR;
748 if (TOP_MODE != M_HIP && A68_MON (_m_stack)[A68_MON (_m_sp) - 2] != M_HIP) {
749 if (TOP_MODE != A68_MON (_m_stack)[A68_MON (_m_sp) - 2]) {
750 monitor_error ("invalid identity relation operand mode", NO_TEXT);
751 }
752 }
753 QUIT_ON_ERROR;
754 A68_MON (_m_sp) -= 2;
755 POP_REF (p, &y);
756 POP_REF (p, &x);
757 res = (BOOL_T) (ADDRESS (&x) == ADDRESS (&y));
758 PUSH_VALUE (p, (BOOL_T) (op == IS_SYMBOL ? res : !res), A68_BOOL);
759 push_mode (f, M_BOOL);
760 }
761 } else {
762 // Dyadic expressions.
763 PARSE_CHECK (f, p, depth + 1);
764 while (A68_MON (attr) == OPERATOR && prio (f, p) == depth) {
765 int args;
766 NODE_T q;
767 TAG_T *opt;
768 BUFFER name;
769 bufcpy (name, A68_MON (symbol), BUFFER_SIZE);
770 args = A68_MON (_m_sp) - 1;
771 ADDR_T top_sp = A68_SP - SIZE (A68_MON (_m_stack)[args]);
772 SCAN_CHECK (f, p);
773 PARSE_CHECK (f, p, depth + 1);
774 opt = search_operator (name, A68_MON (_m_stack)[A68_MON (_m_sp) - 2], TOP_MODE);
775 QUIT_ON_ERROR;
776 coerce_arguments (f, p, MOID (opt), args, A68_MON (_m_sp), top_sp);
777 A68_MON (_m_sp) -= 2;
778 MOID (&q) = MOID (opt);
779 INFO (&q) = INFO (p);
780 NSYMBOL (&q) = NSYMBOL (p);
781 (void) ((*(PROCEDURE (opt)))) (&q);
782 push_mode (f, SUB_MOID (opt));
783 }
784 }
785 } else if (A68_MON (attr) == OPERATOR) {
786 int args;
787 NODE_T q;
788 TAG_T *opt;
789 BUFFER name;
790 bufcpy (name, A68_MON (symbol), BUFFER_SIZE);
791 args = A68_MON (_m_sp);
792 ADDR_T top_sp = A68_SP;
793 SCAN_CHECK (f, p);
794 PARSE_CHECK (f, p, depth);
795 opt = search_operator (name, TOP_MODE, NO_MOID);
796 QUIT_ON_ERROR;
797 coerce_arguments (f, p, MOID (opt), args, A68_MON (_m_sp), top_sp);
798 A68_MON (_m_sp)--;
799 MOID (&q) = MOID (opt);
800 INFO (&q) = INFO (p);
801 NSYMBOL (&q) = NSYMBOL (p);
802 (void) ((*(PROCEDURE (opt))) (&q));
803 push_mode (f, SUB_MOID (opt));
804 } else if (A68_MON (attr) == REF_SYMBOL) {
805 int refs = 0, length = 0;
806 MOID_T *m = NO_MOID;
807 while (A68_MON (attr) == REF_SYMBOL) {
808 refs++;
809 SCAN_CHECK (f, p);
810 }
811 while (A68_MON (attr) == LONG_SYMBOL) {
812 length++;
813 SCAN_CHECK (f, p);
814 }
815 m = search_mode (refs, length, A68_MON (symbol));
816 QUIT_ON_ERROR;
817 if (m == NO_MOID) {
818 monitor_error ("unknown reference to mode", NO_TEXT);
819 }
820 SCAN_CHECK (f, p);
821 if (A68_MON (attr) != OPEN_SYMBOL) {
822 monitor_error ("cast expects open-symbol", NO_TEXT);
823 }
824 SCAN_CHECK (f, p);
825 PARSE_CHECK (f, p, 0);
826 if (A68_MON (attr) != CLOSE_SYMBOL) {
827 monitor_error ("cast expects close-symbol", NO_TEXT);
828 }
829 SCAN_CHECK (f, p);
830 while (IS_REF (TOP_MODE) && TOP_MODE != m) {
831 MOID_T *sub = SUB (TOP_MODE);
832 A68_REF z;
833 POP_REF (p, &z);
834 CHECK_MON_REF (p, z, TOP_MODE);
835 PUSH (p, ADDRESS (&z), SIZE (sub));
836 TOP_MODE = sub;
837 }
838 if (TOP_MODE != m) {
839 monitor_error ("invalid cast mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
840 }
841 } else if (A68_MON (attr) == LONG_SYMBOL) {
842 int length = 0;
843 MOID_T *m;
844 while (A68_MON (attr) == LONG_SYMBOL) {
845 length++;
846 SCAN_CHECK (f, p);
847 }
848 // Cast L INT -> L REAL.
849 if (A68_MON (attr) == REAL_SYMBOL) {
850 MOID_T *i = (length == 1 ? M_LONG_INT : M_LONG_LONG_INT);
851 MOID_T *r = (length == 1 ? M_LONG_REAL : M_LONG_LONG_REAL);
852 SCAN_CHECK (f, p);
853 if (A68_MON (attr) != OPEN_SYMBOL) {
854 monitor_error ("cast expects open-symbol", NO_TEXT);
855 }
856 SCAN_CHECK (f, p);
857 PARSE_CHECK (f, p, 0);
858 if (A68_MON (attr) != CLOSE_SYMBOL) {
859 monitor_error ("cast expects close-symbol", NO_TEXT);
860 }
861 SCAN_CHECK (f, p);
862 if (TOP_MODE != i) {
863 monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
864 }
865 QUIT_ON_ERROR;
866 TOP_MODE = r;
867 return;
868 }
869 // L INT or L REAL denotation.
870 if (A68_MON (attr) == INT_DENOTATION) {
871 m = (length == 1 ? M_LONG_INT : M_LONG_LONG_INT);
872 } else if (A68_MON (attr) == REAL_DENOTATION) {
873 m = (length == 1 ? M_LONG_REAL : M_LONG_LONG_REAL);
874 } else if (A68_MON (attr) == BITS_DENOTATION) {
875 m = (length == 1 ? M_LONG_BITS : M_LONG_LONG_BITS);
876 } else {
877 m = NO_MOID;
878 }
879 if (m != NO_MOID) {
880 int digits = DIGITS (m);
881 MP_T *z = nil_mp (p, digits);
882 if (genie_string_to_value_internal (p, m, A68_MON (symbol), (BYTE_T *) z) == A68_FALSE) {
883 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m);
884 exit_genie (p, A68_RUNTIME_ERROR);
885 }
886 MP_STATUS (z) = (MP_T) (INIT_MASK | CONSTANT_MASK);
887 push_mode (f, m);
888 SCAN_CHECK (f, p);
889 } else {
890 monitor_error ("invalid mode", NO_TEXT);
891 }
892 } else if (A68_MON (attr) == INT_DENOTATION) {
893 A68_INT z;
894 if (genie_string_to_value_internal (p, M_INT, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) {
895 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_INT);
896 exit_genie (p, A68_RUNTIME_ERROR);
897 }
898 PUSH_VALUE (p, VALUE (&z), A68_INT);
899 push_mode (f, M_INT);
900 SCAN_CHECK (f, p);
901 } else if (A68_MON (attr) == REAL_DENOTATION) {
902 A68_REAL z;
903 if (genie_string_to_value_internal (p, M_REAL, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) {
904 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_REAL);
905 exit_genie (p, A68_RUNTIME_ERROR);
906 }
907 PUSH_VALUE (p, VALUE (&z), A68_REAL);
908 push_mode (f, M_REAL);
909 SCAN_CHECK (f, p);
910 } else if (A68_MON (attr) == BITS_DENOTATION) {
911 A68_BITS z;
912 if (genie_string_to_value_internal (p, M_BITS, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) {
913 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_BITS);
914 exit_genie (p, A68_RUNTIME_ERROR);
915 }
916 PUSH_VALUE (p, VALUE (&z), A68_BITS);
917 push_mode (f, M_BITS);
918 SCAN_CHECK (f, p);
919 } else if (A68_MON (attr) == ROW_CHAR_DENOTATION) {
920 if (strlen (A68_MON (symbol)) == 1) {
921 PUSH_VALUE (p, A68_MON (symbol)[0], A68_CHAR);
922 push_mode (f, M_CHAR);
923 } else {
924 A68_REF z;
925 A68_ARRAY *arr;
926 A68_TUPLE *tup;
927 z = c_to_a_string (p, A68_MON (symbol), DEFAULT_WIDTH);
928 GET_DESCRIPTOR (arr, tup, &z);
929 BLOCK_GC_HANDLE (&z);
930 BLOCK_GC_HANDLE (&(ARRAY (arr)));
931 PUSH_REF (p, z);
932 push_mode (f, M_STRING);
933 (void) tup;
934 }
935 SCAN_CHECK (f, p);
936 } else if (A68_MON (attr) == TRUE_SYMBOL) {
937 PUSH_VALUE (p, A68_TRUE, A68_BOOL);
938 push_mode (f, M_BOOL);
939 SCAN_CHECK (f, p);
940 } else if (A68_MON (attr) == FALSE_SYMBOL) {
941 PUSH_VALUE (p, A68_FALSE, A68_BOOL);
942 push_mode (f, M_BOOL);
943 SCAN_CHECK (f, p);
944 } else if (A68_MON (attr) == NIL_SYMBOL) {
945 PUSH_REF (p, nil_ref);
946 push_mode (f, M_HIP);
947 SCAN_CHECK (f, p);
948 } else if (A68_MON (attr) == REAL_SYMBOL) {
949 A68_INT k;
950 SCAN_CHECK (f, p);
951 if (A68_MON (attr) != OPEN_SYMBOL) {
952 monitor_error ("cast expects open-symbol", NO_TEXT);
953 }
954 SCAN_CHECK (f, p);
955 PARSE_CHECK (f, p, 0);
956 if (A68_MON (attr) != CLOSE_SYMBOL) {
957 monitor_error ("cast expects close-symbol", NO_TEXT);
958 }
959 SCAN_CHECK (f, p);
960 if (TOP_MODE != M_INT) {
961 monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
962 }
963 QUIT_ON_ERROR;
964 POP_OBJECT (p, &k, A68_INT);
965 PUSH_VALUE (p, (REAL_T) VALUE (&k), A68_REAL);
966 TOP_MODE = M_REAL;
967 } else if (A68_MON (attr) == IDENTIFIER) {
968 ADDR_T old_sp = A68_SP;
969 BOOL_T init;
970 MOID_T *moid;
971 BUFFER name;
972 bufcpy (name, A68_MON (symbol), BUFFER_SIZE);
973 SCAN_CHECK (f, p);
974 if (A68_MON (attr) == OF_SYMBOL) {
975 selection (f, p, name);
976 } else {
977 search_identifier (f, p, A68_FP, name);
978 QUIT_ON_ERROR;
979 call_or_slice (f, p, depth);
980 }
981 moid = TOP_MODE;
982 QUIT_ON_ERROR;
983 if (check_initialisation (p, STACK_ADDRESS (old_sp), moid, &init)) {
984 if (init == A68_FALSE) {
985 monitor_error (NO_VALUE, name);
986 }
987 } else {
988 monitor_error ("cannot process value of mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
989 }
990 } else if (A68_MON (attr) == OPEN_SYMBOL) {
991 do {
992 SCAN_CHECK (f, p);
993 PARSE_CHECK (f, p, 0);
994 } while (A68_MON (attr) == COMMA_SYMBOL);
995 if (A68_MON (attr) != CLOSE_SYMBOL) {
996 monitor_error ("unmatched parenthesis", NO_TEXT);
997 }
998 SCAN_CHECK (f, p);
999 call_or_slice (f, p, depth);
1000 } else {
1001 monitor_error ("invalid expression syntax", NO_TEXT);
1002 }
1003 }
1004
1005 //! @brief Perform assignment.
1006
1007 void assign (FILE_T f, NODE_T * p)
1008 {
1009 LOW_STACK_ALERT (p);
1010 PARSE_CHECK (f, p, 0);
1011 if (A68_MON (attr) == ASSIGN_SYMBOL) {
1012 MOID_T *m = A68_MON (_m_stack)[--A68_MON (_m_sp)];
1013 A68_REF z;
1014 if (!IS_REF (m)) {
1015 monitor_error ("invalid destination mode", moid_to_string (m, MOID_WIDTH, NO_NODE));
1016 }
1017 QUIT_ON_ERROR;
1018 POP_REF (p, &z);
1019 CHECK_MON_REF (p, z, m);
1020 SCAN_CHECK (f, p);
1021 assign (f, p);
1022 QUIT_ON_ERROR;
1023 while (IS_REF (TOP_MODE) && TOP_MODE != SUB (m)) {
1024 MOID_T *sub = SUB (TOP_MODE);
1025 A68_REF y;
1026 POP_REF (p, &y);
1027 CHECK_MON_REF (p, y, TOP_MODE);
1028 PUSH (p, ADDRESS (&y), SIZE (sub));
1029 TOP_MODE = sub;
1030 }
1031 if (TOP_MODE != SUB (m) && TOP_MODE != M_HIP) {
1032 monitor_error ("invalid source mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
1033 }
1034 QUIT_ON_ERROR;
1035 POP (p, ADDRESS (&z), SIZE (TOP_MODE));
1036 PUSH_REF (p, z);
1037 TOP_MODE = m;
1038 }
1039 }
1040
1041 //! @brief Evaluate expression on input.
1042
1043 void evaluate (FILE_T f, NODE_T * p, char *str)
1044 {
1045 LOW_STACK_ALERT (p);
1046 A68_MON (_m_sp) = 0;
1047 A68_MON (_m_stack)[0] = NO_MOID;
1048 A68_MON (pos) = 0;
1049 bufcpy (A68_MON (expr), str, BUFFER_SIZE);
1050 SCAN_CHECK (f, p);
1051 QUIT_ON_ERROR;
1052 assign (f, p);
1053 if (A68_MON (attr) != 0) {
1054 monitor_error ("trailing character in expression", A68_MON (symbol));
1055 }
1056 }
1057
1058 //! @brief Convert string to int.
1059
1060 int get_num_arg (char *num, char **rest)
1061 {
1062 char *end;
1063 int k;
1064 if (rest != NO_VAR) {
1065 *rest = NO_TEXT;
1066 }
1067 if (num == NO_TEXT) {
1068 return NOT_A_NUM;
1069 }
1070 SKIP_ONE_SYMBOL (num);
1071 if (IS_DIGIT (num[0])) {
1072 errno = 0;
1073 k = (int) a68_strtou (num, &end, 10);
1074 if (end != num && errno == 0) {
1075 if (rest != NO_VAR) {
1076 *rest = end;
1077 }
1078 return k;
1079 } else {
1080 monitor_error ("invalid numerical argument", error_specification ());
1081 return NOT_A_NUM;
1082 }
1083 } else {
1084 if (num[0] != NULL_CHAR) {
1085 monitor_error ("invalid numerical argument", num);
1086 }
1087 return NOT_A_NUM;
1088 }
1089 }
1090
1091 //! @brief Whether item at "w" of mode "q" is initialised.
1092
1093 BOOL_T check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q, BOOL_T * result)
1094 {
1095 BOOL_T initialised = A68_FALSE, recognised = A68_FALSE;
1096 (void) p;
1097 switch (SHORT_ID (q)) {
1098 case MODE_NO_CHECK:
1099 case UNION_SYMBOL:
1100 {
1101 initialised = A68_TRUE;
1102 recognised = A68_TRUE;
1103 break;
1104 }
1105 case REF_SYMBOL:
1106 {
1107 A68_REF *z = (A68_REF *) w;
1108 initialised = INITIALISED (z);
1109 recognised = A68_TRUE;
1110 break;
1111 }
1112 case PROC_SYMBOL:
1113 {
1114 A68_PROCEDURE *z = (A68_PROCEDURE *) w;
1115 initialised = INITIALISED (z);
1116 recognised = A68_TRUE;
1117 break;
1118 }
1119 case MODE_INT:
1120 {
1121 A68_INT *z = (A68_INT *) w;
1122 initialised = INITIALISED (z);
1123 recognised = A68_TRUE;
1124 break;
1125 }
1126 case MODE_REAL:
1127 {
1128 A68_REAL *z = (A68_REAL *) w;
1129 initialised = INITIALISED (z);
1130 recognised = A68_TRUE;
1131 break;
1132 }
1133 case MODE_COMPLEX:
1134 {
1135 A68_REAL *r = (A68_REAL *) w;
1136 A68_REAL *i = (A68_REAL *) (w + SIZE_ALIGNED (A68_REAL));
1137 initialised = (BOOL_T) (INITIALISED (r) && INITIALISED (i));
1138 recognised = A68_TRUE;
1139 break;
1140 }
1141 #if (A68_LEVEL >= 3)
1142 case MODE_LONG_INT:
1143 case MODE_LONG_BITS:
1144 {
1145 A68_LONG_INT *z = (A68_LONG_INT *) w;
1146 initialised = INITIALISED (z);
1147 recognised = A68_TRUE;
1148 break;
1149 }
1150 case MODE_LONG_REAL:
1151 {
1152 A68_LONG_REAL *z = (A68_LONG_REAL *) w;
1153 initialised = INITIALISED (z);
1154 recognised = A68_TRUE;
1155 break;
1156 }
1157 #else
1158 case MODE_LONG_INT:
1159 case MODE_LONG_REAL:
1160 case MODE_LONG_BITS:
1161 {
1162 MP_T *z = (MP_T *) w;
1163 initialised = (BOOL_T) ((unt) MP_STATUS (z) & INIT_MASK);
1164 recognised = A68_TRUE;
1165 break;
1166 }
1167 #endif
1168 case MODE_LONG_LONG_INT:
1169 case MODE_LONG_LONG_REAL:
1170 case MODE_LONG_LONG_BITS:
1171 {
1172 MP_T *z = (MP_T *) w;
1173 initialised = (BOOL_T) ((unt) MP_STATUS (z) & INIT_MASK);
1174 recognised = A68_TRUE;
1175 break;
1176 }
1177 case MODE_LONG_COMPLEX:
1178 {
1179 MP_T *r = (MP_T *) w;
1180 MP_T *i = (MP_T *) (w + size_mp ());
1181 initialised = (BOOL_T) (((unt) MP_STATUS (r) & INIT_MASK) && ((unt) MP_STATUS (i) & INIT_MASK));
1182 recognised = A68_TRUE;
1183 break;
1184 }
1185 case MODE_LONG_LONG_COMPLEX:
1186 {
1187 MP_T *r = (MP_T *) w;
1188 MP_T *i = (MP_T *) (w + size_mp ());
1189 initialised = (BOOL_T) (((unt) MP_STATUS (r) & INIT_MASK) && ((unt) MP_STATUS (i) & INIT_MASK));
1190 recognised = A68_TRUE;
1191 break;
1192 }
1193 case MODE_BOOL:
1194 {
1195 A68_BOOL *z = (A68_BOOL *) w;
1196 initialised = INITIALISED (z);
1197 recognised = A68_TRUE;
1198 break;
1199 }
1200 case MODE_CHAR:
1201 {
1202 A68_CHAR *z = (A68_CHAR *) w;
1203 initialised = INITIALISED (z);
1204 recognised = A68_TRUE;
1205 break;
1206 }
1207 case MODE_BITS:
1208 {
1209 A68_BITS *z = (A68_BITS *) w;
1210 initialised = INITIALISED (z);
1211 recognised = A68_TRUE;
1212 break;
1213 }
1214 case MODE_BYTES:
1215 {
1216 A68_BYTES *z = (A68_BYTES *) w;
1217 initialised = INITIALISED (z);
1218 recognised = A68_TRUE;
1219 break;
1220 }
1221 case MODE_LONG_BYTES:
1222 {
1223 A68_LONG_BYTES *z = (A68_LONG_BYTES *) w;
1224 initialised = INITIALISED (z);
1225 recognised = A68_TRUE;
1226 break;
1227 }
1228 case MODE_FILE:
1229 {
1230 A68_FILE *z = (A68_FILE *) w;
1231 initialised = INITIALISED (z);
1232 recognised = A68_TRUE;
1233 break;
1234 }
1235 case MODE_FORMAT:
1236 {
1237 A68_FORMAT *z = (A68_FORMAT *) w;
1238 initialised = INITIALISED (z);
1239 recognised = A68_TRUE;
1240 break;
1241 }
1242 case MODE_PIPE:
1243 {
1244 A68_REF *pipe_read = (A68_REF *) w;
1245 A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE);
1246 A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE);
1247 initialised = (BOOL_T) (INITIALISED (pipe_read) && INITIALISED (pipe_write) && INITIALISED (pid));
1248 recognised = A68_TRUE;
1249 break;
1250 }
1251 case MODE_SOUND:
1252 {
1253 A68_SOUND *z = (A68_SOUND *) w;
1254 initialised = INITIALISED (z);
1255 recognised = A68_TRUE;
1256 }
1257 }
1258 if (result != NO_BOOL) {
1259 *result = initialised;
1260 }
1261 return recognised;
1262 }
1263
1264 //! @brief Show value of object.
1265
1266 void print_item (NODE_T * p, FILE_T f, BYTE_T * item, MOID_T * mode)
1267 {
1268 A68_REF nil_file = nil_ref;
1269 reset_transput_buffer (UNFORMATTED_BUFFER);
1270 genie_write_standard (p, mode, item, nil_file);
1271 if (get_transput_buffer_index (UNFORMATTED_BUFFER) > 0) {
1272 if (mode == M_CHAR || mode == M_ROW_CHAR || mode == M_STRING) {
1273 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " \"%s\"", get_transput_buffer (UNFORMATTED_BUFFER)) >= 0);
1274 WRITE (f, A68 (output_line));
1275 } else {
1276 char *str = get_transput_buffer (UNFORMATTED_BUFFER);
1277 while (IS_SPACE (str[0])) {
1278 str++;
1279 }
1280 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %s", str) >= 0);
1281 WRITE (f, A68 (output_line));
1282 }
1283 } else {
1284 WRITE (f, CANNOT_SHOW);
1285 }
1286 }
1287
1288 //! @brief Indented indent_crlf.
1289
1290 void indent_crlf (FILE_T f)
1291 {
1292 int k;
1293 io_close_tty_line ();
1294 for (k = 0; k < A68_MON (tabs); k++) {
1295 WRITE (f, " ");
1296 }
1297 }
1298
1299 //! @brief Show value of object.
1300
1301 void show_item (FILE_T f, NODE_T * p, BYTE_T * item, MOID_T * mode)
1302 {
1303 if (item == NO_BYTE || mode == NO_MOID) {
1304 return;
1305 }
1306 if (IS_REF (mode)) {
1307 A68_REF *z = (A68_REF *) item;
1308 if (IS_NIL (*z)) {
1309 if (INITIALISED (z)) {
1310 WRITE (STDOUT_FILENO, " = NIL");
1311 } else {
1312 WRITE (STDOUT_FILENO, NO_VALUE);
1313 }
1314 } else {
1315 if (INITIALISED (z)) {
1316 WRITE (STDOUT_FILENO, " refers to ");
1317 if (IS_IN_HEAP (z)) {
1318 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "heap(%p)", (void *) ADDRESS (z)) >= 0);
1319 WRITE (STDOUT_FILENO, A68 (output_line));
1320 A68_MON (tabs)++;
1321 show_item (f, p, ADDRESS (z), SUB (mode));
1322 A68_MON (tabs)--;
1323 } else if (IS_IN_FRAME (z)) {
1324 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "frame(" A68_LU ")", REF_OFFSET (z)) >= 0);
1325 WRITE (STDOUT_FILENO, A68 (output_line));
1326 } else if (IS_IN_STACK (z)) {
1327 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "stack(" A68_LU ")", REF_OFFSET (z)) >= 0);
1328 WRITE (STDOUT_FILENO, A68 (output_line));
1329 }
1330 } else {
1331 WRITE (STDOUT_FILENO, NO_VALUE);
1332 }
1333 }
1334 } else if (mode == M_STRING) {
1335 if (!INITIALISED ((A68_REF *) item)) {
1336 WRITE (STDOUT_FILENO, NO_VALUE);
1337 } else {
1338 print_item (p, f, item, mode);
1339 }
1340 } else if ((IS_ROW (mode) || IS_FLEX (mode)) && mode != M_STRING) {
1341 MOID_T *deflexed = DEFLEX (mode);
1342 int old_tabs = A68_MON (tabs);
1343 A68_MON (tabs) += 2;
1344 if (!INITIALISED ((A68_REF *) item)) {
1345 WRITE (STDOUT_FILENO, NO_VALUE);
1346 } else {
1347 A68_ARRAY *arr;
1348 A68_TUPLE *tup;
1349 int count = 0, act_count = 0, elems;
1350 GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1351 elems = get_row_size (tup, DIM (arr));
1352 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %d element(s)", elems) >= 0);
1353 WRITE (f, A68 (output_line));
1354 if (get_row_size (tup, DIM (arr)) != 0) {
1355 BYTE_T *base_addr = ADDRESS (&ARRAY (arr));
1356 BOOL_T done = A68_FALSE;
1357 initialise_internal_index (tup, DIM (arr));
1358 while (!done && ++count <= (A68_MON (max_row_elems) + 1)) {
1359 if (count <= A68_MON (max_row_elems)) {
1360 ADDR_T row_index = calculate_internal_index (tup, DIM (arr));
1361 ADDR_T elem_addr = ROW_ELEMENT (arr, row_index);
1362 BYTE_T *elem = &base_addr[elem_addr];
1363 indent_crlf (f);
1364 WRITE (f, "[");
1365 print_internal_index (f, tup, DIM (arr));
1366 WRITE (f, "]");
1367 show_item (f, p, elem, SUB (deflexed));
1368 act_count++;
1369 done = increment_internal_index (tup, DIM (arr));
1370 }
1371 }
1372 indent_crlf (f);
1373 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %d element(s) written (%d%%)", act_count, (int) ((100.0 * act_count) / elems)) >= 0);
1374 WRITE (f, A68 (output_line));
1375 }
1376 }
1377 A68_MON (tabs) = old_tabs;
1378 } else if (IS_STRUCT (mode)) {
1379 PACK_T *q = PACK (mode);
1380 A68_MON (tabs)++;
1381 for (; q != NO_PACK; FORWARD (q)) {
1382 BYTE_T *elem = &item[OFFSET (q)];
1383 indent_crlf (f);
1384 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %s \"%s\"", moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), TEXT (q)) >= 0);
1385 WRITE (STDOUT_FILENO, A68 (output_line));
1386 show_item (f, p, elem, MOID (q));
1387 }
1388 A68_MON (tabs)--;
1389 } else if (IS (mode, UNION_SYMBOL)) {
1390 A68_UNION *z = (A68_UNION *) item;
1391 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1392 WRITE (STDOUT_FILENO, A68 (output_line));
1393 show_item (f, p, &item[SIZE_ALIGNED (A68_UNION)], (MOID_T *) (VALUE (z)));
1394 } else if (mode == M_SIMPLIN) {
1395 A68_UNION *z = (A68_UNION *) item;
1396 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1397 WRITE (STDOUT_FILENO, A68 (output_line));
1398 } else if (mode == M_SIMPLOUT) {
1399 A68_UNION *z = (A68_UNION *) item;
1400 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1401 WRITE (STDOUT_FILENO, A68 (output_line));
1402 } else {
1403 BOOL_T init;
1404 if (check_initialisation (p, item, mode, &init)) {
1405 if (init) {
1406 if (IS (mode, PROC_SYMBOL)) {
1407 A68_PROCEDURE *z = (A68_PROCEDURE *) item;
1408 if (z != NO_PROCEDURE && STATUS (z) & STANDENV_PROC_MASK) {
1409 char *fname = standard_environ_proc_name (*(PROCEDURE (&BODY (z))));
1410 WRITE (STDOUT_FILENO, " standenv procedure");
1411 if (fname != NO_TEXT) {
1412 WRITE (STDOUT_FILENO, " (");
1413 WRITE (STDOUT_FILENO, fname);
1414 WRITE (STDOUT_FILENO, ")");
1415 }
1416 } else if (z != NO_PROCEDURE && STATUS (z) & SKIP_PROCEDURE_MASK) {
1417 WRITE (STDOUT_FILENO, " skip procedure");
1418 } else if (z != NO_PROCEDURE && (PROCEDURE (&BODY (z))) != NO_GPROC) {
1419 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68_LU "), locale %p", LINE_NUMBER ((NODE_T *) NODE (&BODY (z))), ENVIRON (z), (void *) LOCALE (z)) >= 0);
1420 WRITE (STDOUT_FILENO, A68 (output_line));
1421 } else {
1422 WRITE (STDOUT_FILENO, " cannot show value");
1423 }
1424 } else if (mode == M_FORMAT) {
1425 A68_FORMAT *z = (A68_FORMAT *) item;
1426 if (z != NO_FORMAT && BODY (z) != NO_NODE) {
1427 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68_LU ")", LINE_NUMBER (BODY (z)), ENVIRON (z)) >= 0);
1428 WRITE (STDOUT_FILENO, A68 (output_line));
1429 } else {
1430 monitor_error (CANNOT_SHOW, NO_TEXT);
1431 }
1432 } else if (mode == M_SOUND) {
1433 A68_SOUND *z = (A68_SOUND *) item;
1434 if (z != NO_SOUND) {
1435 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%u channels, %u bits, %u rate, %u samples", NUM_CHANNELS (z), BITS_PER_SAMPLE (z), SAMPLE_RATE (z), NUM_SAMPLES (z)) >= 0);
1436 WRITE (STDOUT_FILENO, A68 (output_line));
1437
1438 } else {
1439 monitor_error (CANNOT_SHOW, NO_TEXT);
1440 }
1441 } else {
1442 print_item (p, f, item, mode);
1443 }
1444 } else {
1445 WRITE (STDOUT_FILENO, NO_VALUE);
1446 }
1447 } else {
1448 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " mode %s, %s", moid_to_string (mode, MOID_WIDTH, NO_NODE), CANNOT_SHOW) >= 0);
1449 WRITE (STDOUT_FILENO, A68 (output_line));
1450 }
1451 }
1452 }
1453
1454 //! @brief Overview of frame item.
1455
1456 void show_frame_item (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, int modif)
1457 {
1458 ADDR_T addr = a68_link + FRAME_INFO_SIZE + OFFSET (q);
1459 ADDR_T loc = FRAME_INFO_SIZE + OFFSET (q);
1460 (void) p;
1461 indent_crlf (STDOUT_FILENO);
1462 if (modif != ANONYMOUS) {
1463 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " frame(" A68_LU "=" A68_LU "+" A68_LU ") %s \"%s\"", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), NSYMBOL (NODE (q))) >= 0);
1464 WRITE (STDOUT_FILENO, A68 (output_line));
1465 show_item (f, p, FRAME_ADDRESS (addr), MOID (q));
1466 } else {
1467 switch (PRIO (q)) {
1468 case GENERATOR:
1469 {
1470 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " frame(" A68_LU "=" A68_LU "+" A68_LU ") LOC %s", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0);
1471 WRITE (STDOUT_FILENO, A68 (output_line));
1472 break;
1473 }
1474 default:
1475 {
1476 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " frame(" A68_LU "=" A68_LU "+" A68_LU ") internal %s", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0);
1477 WRITE (STDOUT_FILENO, A68 (output_line));
1478 break;
1479 }
1480 }
1481 show_item (f, p, FRAME_ADDRESS (addr), MOID (q));
1482 }
1483 }
1484
1485 //! @brief Overview of frame items.
1486
1487 void show_frame_items (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, int modif)
1488 {
1489 (void) p;
1490 for (; q != NO_TAG; FORWARD (q)) {
1491 show_frame_item (f, p, a68_link, q, modif);
1492 }
1493 }
1494
1495 //! @brief Introduce stack frame.
1496
1497 void intro_frame (FILE_T f, NODE_T * p, ADDR_T a68_link, int *printed)
1498 {
1499 TABLE_T *q = TABLE (p);
1500 if (*printed > 0) {
1501 WRITELN (f, "");
1502 }
1503 (*printed)++;
1504 where_in_source (f, p);
1505 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Stack frame %d at frame(" A68_LU "), level=%d, size=" A68_LU " bytes", FRAME_NUMBER (a68_link), a68_link, LEVEL (q), (UNSIGNED_T) (FRAME_INCREMENT (a68_link) + FRAME_INFO_SIZE)) >= 0);
1506 WRITELN (f, A68 (output_line));
1507 }
1508
1509 //! @brief View contents of stack frame.
1510
1511 void show_stack_frame (FILE_T f, NODE_T * p, ADDR_T a68_link, int *printed)
1512 {
1513 // show the frame starting at frame pointer 'a68_link', using symbol table from p as a map.
1514 if (p != NO_NODE) {
1515 TABLE_T *q = TABLE (p);
1516 intro_frame (f, p, a68_link, printed);
1517 #if (A68_LEVEL >= 3)
1518 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Dynamic link=frame(%llu), static link=frame(%llu), parameters=frame(%llu)", FRAME_DYNAMIC_LINK (a68_link), FRAME_STATIC_LINK (a68_link), FRAME_PARAMETERS (a68_link)) >= 0);
1519 WRITELN (STDOUT_FILENO, A68 (output_line));
1520 #else
1521 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Dynamic link=frame(%u), static link=frame(%u), parameters=frame(%u)", FRAME_DYNAMIC_LINK (a68_link), FRAME_STATIC_LINK (a68_link), FRAME_PARAMETERS (a68_link)) >= 0);
1522 WRITELN (STDOUT_FILENO, A68 (output_line));
1523 #endif
1524 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Procedure frame=%s", (FRAME_PROC_FRAME (a68_link) ? "yes" : "no")) >= 0);
1525 WRITELN (STDOUT_FILENO, A68 (output_line));
1526 #if defined (BUILD_PARALLEL_CLAUSE)
1527 if (pthread_equal (FRAME_THREAD_ID (a68_link), A68_PAR (main_thread_id)) != 0) {
1528 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "In main thread") >= 0);
1529 } else {
1530 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Not in main thread") >= 0);
1531 }
1532 WRITELN (STDOUT_FILENO, A68 (output_line));
1533 #endif
1534 show_frame_items (f, p, a68_link, IDENTIFIERS (q), IDENTIFIER);
1535 show_frame_items (f, p, a68_link, OPERATORS (q), OPERATOR);
1536 show_frame_items (f, p, a68_link, ANONYMOUS (q), ANONYMOUS);
1537 }
1538 }
1539
1540 //! @brief Shows lines around the line where 'p' is at.
1541
1542 void list (FILE_T f, NODE_T * p, int n, int m)
1543 {
1544 if (p != NO_NODE) {
1545 if (m == 0) {
1546 LINE_T *r = LINE (INFO (p));
1547 LINE_T *l = TOP_LINE (&A68_JOB);
1548 for (; l != NO_LINE; FORWARD (l)) {
1549 if (NUMBER (l) > 0 && abs (NUMBER (r) - NUMBER (l)) <= n) {
1550 write_source_line (f, l, NO_NODE, A68_TRUE);
1551 }
1552 }
1553 } else {
1554 LINE_T *l = TOP_LINE (&A68_JOB);
1555 for (; l != NO_LINE; FORWARD (l)) {
1556 if (NUMBER (l) > 0 && NUMBER (l) >= n && NUMBER (l) <= m) {
1557 write_source_line (f, l, NO_NODE, A68_TRUE);
1558 }
1559 }
1560 }
1561 }
1562 }
1563
1564 //! @brief Overview of the heap.
1565
1566 void show_heap (FILE_T f, NODE_T * p, A68_HANDLE * z, int top, int n)
1567 {
1568 int k = 0, m = n, sum = 0;
1569 (void) p;
1570 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "size=%u available=%d garbage collections=" A68_LD, A68 (heap_size), heap_available (), A68_GC (sweeps)) >= 0);
1571 WRITELN (f, A68 (output_line));
1572 for (; z != NO_HANDLE; FORWARD (z), k++) {
1573 if (n > 0 && sum <= top) {
1574 n--;
1575 indent_crlf (f);
1576 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "heap(%p+%d) %s", (void *) POINTER (z), SIZE (z), moid_to_string (MOID (z), MOID_WIDTH, NO_NODE)) >= 0);
1577 WRITE (f, A68 (output_line));
1578 sum += SIZE (z);
1579 }
1580 }
1581 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "printed %d out of %d handles", m, k) >= 0);
1582 WRITELN (f, A68 (output_line));
1583 }
1584
1585 //! @brief Search current frame and print it.
1586
1587 void stack_dump_current (FILE_T f, ADDR_T a68_link)
1588 {
1589 if (a68_link > 0) {
1590 int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1591 NODE_T *p = FRAME_TREE (a68_link);
1592 if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1593 if (FRAME_NUMBER (a68_link) == A68_MON (current_frame)) {
1594 int printed = 0;
1595 show_stack_frame (f, p, a68_link, &printed);
1596 } else {
1597 stack_dump_current (f, dynamic_a68_link);
1598 }
1599 }
1600 }
1601 }
1602
1603 //! @brief Overview of the stack.
1604
1605 void stack_a68_link_dump (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1606 {
1607 if (depth > 0 && a68_link > 0) {
1608 NODE_T *p = FRAME_TREE (a68_link);
1609 if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1610 show_stack_frame (f, p, a68_link, printed);
1611 stack_a68_link_dump (f, FRAME_STATIC_LINK (a68_link), depth - 1, printed);
1612 }
1613 }
1614 }
1615
1616 //! @brief Overview of the stack.
1617
1618 void stack_dump (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1619 {
1620 if (depth > 0 && a68_link > 0) {
1621 NODE_T *p = FRAME_TREE (a68_link);
1622 if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1623 show_stack_frame (f, p, a68_link, printed);
1624 stack_dump (f, FRAME_DYNAMIC_LINK (a68_link), depth - 1, printed);
1625 }
1626 }
1627 }
1628
1629 //! @brief Overview of the stack.
1630
1631 void stack_trace (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1632 {
1633 if (depth > 0 && a68_link > 0) {
1634 int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1635 if (FRAME_PROC_FRAME (a68_link)) {
1636 NODE_T *p = FRAME_TREE (a68_link);
1637 show_stack_frame (f, p, a68_link, printed);
1638 stack_trace (f, dynamic_a68_link, depth - 1, printed);
1639 } else {
1640 stack_trace (f, dynamic_a68_link, depth, printed);
1641 }
1642 }
1643 }
1644
1645 //! @brief Examine tags.
1646
1647 void examine_tags (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, char *sym, int *printed)
1648 {
1649 for (; q != NO_TAG; FORWARD (q)) {
1650 if (NODE (q) != NO_NODE && strcmp (NSYMBOL (NODE (q)), sym) == 0) {
1651 intro_frame (f, p, a68_link, printed);
1652 show_frame_item (f, p, a68_link, q, PRIO (q));
1653 }
1654 }
1655 }
1656
1657 //! @brief Search symbol in stack.
1658
1659 void examine_stack (FILE_T f, ADDR_T a68_link, char *sym, int *printed)
1660 {
1661 if (a68_link > 0) {
1662 int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1663 NODE_T *p = FRAME_TREE (a68_link);
1664 if (p != NO_NODE) {
1665 TABLE_T *q = TABLE (p);
1666 examine_tags (f, p, a68_link, IDENTIFIERS (q), sym, printed);
1667 examine_tags (f, p, a68_link, OPERATORS (q), sym, printed);
1668 }
1669 examine_stack (f, dynamic_a68_link, sym, printed);
1670 }
1671 }
1672
1673 //! @brief Set or reset breakpoints.
1674
1675 void change_breakpoints (NODE_T * p, unt set, int num, BOOL_T * is_set, char *loc_expr)
1676 {
1677 for (; p != NO_NODE; FORWARD (p)) {
1678 change_breakpoints (SUB (p), set, num, is_set, loc_expr);
1679 if (set == BREAKPOINT_MASK) {
1680 if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) {
1681 STATUS_SET (p, BREAKPOINT_MASK);
1682 if (EXPR (INFO (p)) != NO_TEXT) {
1683 a68_free (EXPR (INFO (p)));
1684 }
1685 EXPR (INFO (p)) = loc_expr;
1686 *is_set = A68_TRUE;
1687 }
1688 } else if (set == BREAKPOINT_TEMPORARY_MASK) {
1689 if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) {
1690 STATUS_SET (p, BREAKPOINT_TEMPORARY_MASK);
1691 if (EXPR (INFO (p)) != NO_TEXT) {
1692 a68_free (EXPR (INFO (p)));
1693 }
1694 EXPR (INFO (p)) = loc_expr;
1695 *is_set = A68_TRUE;
1696 }
1697 } else if (set == NULL_MASK) {
1698 if (LINE_NUMBER (p) != num) {
1699 STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK));
1700 if (EXPR (INFO (p)) == NO_TEXT) {
1701 a68_free (EXPR (INFO (p)));
1702 }
1703 EXPR (INFO (p)) = NO_TEXT;
1704 } else if (num == 0) {
1705 STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK));
1706 if (EXPR (INFO (p)) != NO_TEXT) {
1707 a68_free (EXPR (INFO (p)));
1708 }
1709 EXPR (INFO (p)) = NO_TEXT;
1710 }
1711 }
1712 }
1713 }
1714
1715 //! @brief List breakpoints.
1716
1717 void list_breakpoints (NODE_T * p, int *listed)
1718 {
1719 for (; p != NO_NODE; FORWARD (p)) {
1720 list_breakpoints (SUB (p), listed);
1721 if (STATUS_TEST (p, BREAKPOINT_MASK)) {
1722 (*listed)++;
1723 WIS (p);
1724 if (EXPR (INFO (p)) != NO_TEXT) {
1725 WRITELN (STDOUT_FILENO, "breakpoint condition \"");
1726 WRITE (STDOUT_FILENO, EXPR (INFO (p)));
1727 WRITE (STDOUT_FILENO, "\"");
1728 }
1729 }
1730 }
1731 }
1732
1733 //! @brief Execute monitor command.
1734
1735 BOOL_T single_stepper (NODE_T * p, char *cmd)
1736 {
1737 A68_MON (mon_errors) = 0;
1738 errno = 0;
1739 if (strlen (cmd) == 0) {
1740 return A68_FALSE;
1741 }
1742 while (IS_SPACE (cmd[strlen (cmd) - 1])) {
1743 cmd[strlen (cmd) - 1] = NULL_CHAR;
1744 }
1745 if (match_string (cmd, "CAlls", BLANK_CHAR)) {
1746 int k = get_num_arg (cmd, NO_VAR);
1747 int printed = 0;
1748 if (k > 0) {
1749 stack_trace (STDOUT_FILENO, A68_FP, k, &printed);
1750 } else if (k == 0) {
1751 stack_trace (STDOUT_FILENO, A68_FP, 3, &printed);
1752 }
1753 return A68_FALSE;
1754 } else if (match_string (cmd, "Continue", NULL_CHAR) || match_string (cmd, "Resume", NULL_CHAR)) {
1755 A68 (do_confirm_exit) = A68_TRUE;
1756 return A68_TRUE;
1757 } else if (match_string (cmd, "DO", BLANK_CHAR) || match_string (cmd, "EXEC", BLANK_CHAR)) {
1758 char *sym = cmd;
1759 SKIP_ONE_SYMBOL (sym);
1760 if (sym[0] != NULL_CHAR) {
1761 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "return code %d", system (sym)) >= 0);
1762 WRITELN (STDOUT_FILENO, A68 (output_line));
1763 }
1764 return A68_FALSE;
1765 } else if (match_string (cmd, "ELems", BLANK_CHAR)) {
1766 int k = get_num_arg (cmd, NO_VAR);
1767 if (k > 0) {
1768 A68_MON (max_row_elems) = k;
1769 }
1770 return A68_FALSE;
1771 } else if (match_string (cmd, "Evaluate", BLANK_CHAR) || match_string (cmd, "X", BLANK_CHAR)) {
1772 char *sym = cmd;
1773 SKIP_ONE_SYMBOL (sym);
1774 if (sym[0] != NULL_CHAR) {
1775 ADDR_T old_sp = A68_SP;
1776 evaluate (STDOUT_FILENO, p, sym);
1777 if (A68_MON (mon_errors) == 0 && A68_MON (_m_sp) > 0) {
1778 MOID_T *res;
1779 BOOL_T cont = A68_TRUE;
1780 while (cont) {
1781 res = A68_MON (_m_stack)[0];
1782 WRITELN (STDOUT_FILENO, "(");
1783 WRITE (STDOUT_FILENO, moid_to_string (res, MOID_WIDTH, NO_NODE));
1784 WRITE (STDOUT_FILENO, ")");
1785 show_item (STDOUT_FILENO, p, STACK_ADDRESS (old_sp), res);
1786 cont = (BOOL_T) (IS_REF (res) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (old_sp)));
1787 if (cont) {
1788 A68_REF z;
1789 POP_REF (p, &z);
1790 A68_MON (_m_stack)[0] = SUB (A68_MON (_m_stack)[0]);
1791 PUSH (p, ADDRESS (&z), SIZE (A68_MON (_m_stack)[0]));
1792 }
1793 }
1794 } else {
1795 monitor_error (CANNOT_SHOW, NO_TEXT);
1796 }
1797 A68_SP = old_sp;
1798 A68_MON (_m_sp) = 0;
1799 }
1800 return A68_FALSE;
1801 } else if (match_string (cmd, "EXamine", BLANK_CHAR)) {
1802 char *sym = cmd;
1803 SKIP_ONE_SYMBOL (sym);
1804 if (sym[0] != NULL_CHAR && (IS_LOWER (sym[0]) || IS_UPPER (sym[0]))) {
1805 int printed = 0;
1806 examine_stack (STDOUT_FILENO, A68_FP, sym, &printed);
1807 if (printed == 0) {
1808 monitor_error ("tag not found", sym);
1809 }
1810 } else {
1811 monitor_error ("tag expected", NO_TEXT);
1812 }
1813 return A68_FALSE;
1814 } else if (match_string (cmd, "EXIt", NULL_CHAR) || match_string (cmd, "HX", NULL_CHAR) || match_string (cmd, "Quit", NULL_CHAR) || strcmp (cmd, LOGOUT_STRING) == 0) {
1815 if (confirm_exit ()) {
1816 exit_genie (p, A68_RUNTIME_ERROR + A68_FORCE_QUIT);
1817 }
1818 return A68_FALSE;
1819 } else if (match_string (cmd, "Frame", NULL_CHAR)) {
1820 if (A68_MON (current_frame) == 0) {
1821 int printed = 0;
1822 stack_dump (STDOUT_FILENO, A68_FP, 1, &printed);
1823 } else {
1824 stack_dump_current (STDOUT_FILENO, A68_FP);
1825 }
1826 return A68_FALSE;
1827 } else if (match_string (cmd, "Frame", BLANK_CHAR)) {
1828 int n = get_num_arg (cmd, NO_VAR);
1829 A68_MON (current_frame) = (n > 0 ? n : 0);
1830 stack_dump_current (STDOUT_FILENO, A68_FP);
1831 return A68_FALSE;
1832 } else if (match_string (cmd, "HEAp", BLANK_CHAR)) {
1833 int top = get_num_arg (cmd, NO_VAR);
1834 if (top <= 0) {
1835 top = A68 (heap_size);
1836 }
1837 show_heap (STDOUT_FILENO, p, A68_GC (busy_handles), top, A68 (term_heigth) - 4);
1838 return A68_FALSE;
1839 } else if (match_string (cmd, "APropos", NULL_CHAR) || match_string (cmd, "Help", NULL_CHAR) || match_string (cmd, "INfo", NULL_CHAR)) {
1840 apropos (STDOUT_FILENO, NO_TEXT, "monitor");
1841 return A68_FALSE;
1842 } else if (match_string (cmd, "APropos", BLANK_CHAR) || match_string (cmd, "Help", BLANK_CHAR) || match_string (cmd, "INfo", BLANK_CHAR)) {
1843 char *sym = cmd;
1844 SKIP_ONE_SYMBOL (sym);
1845 apropos (STDOUT_FILENO, NO_TEXT, sym);
1846 return A68_FALSE;
1847 } else if (match_string (cmd, "HT", NULL_CHAR)) {
1848 A68 (halt_typing) = A68_TRUE;
1849 A68 (do_confirm_exit) = A68_TRUE;
1850 return A68_TRUE;
1851 } else if (match_string (cmd, "RT", NULL_CHAR)) {
1852 A68 (halt_typing) = A68_FALSE;
1853 A68 (do_confirm_exit) = A68_TRUE;
1854 return A68_TRUE;
1855 } else if (match_string (cmd, "Breakpoint", BLANK_CHAR)) {
1856 char *sym = cmd;
1857 SKIP_ONE_SYMBOL (sym);
1858 if (sym[0] == NULL_CHAR) {
1859 int listed = 0;
1860 list_breakpoints (TOP_NODE (&A68_JOB), &listed);
1861 if (listed == 0) {
1862 WRITELN (STDOUT_FILENO, "No breakpoints set");
1863 }
1864 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1865 WRITELN (STDOUT_FILENO, "Watchpoint condition \"");
1866 WRITE (STDOUT_FILENO, A68_MON (watchpoint_expression));
1867 WRITE (STDOUT_FILENO, "\"");
1868 } else {
1869 WRITELN (STDOUT_FILENO, "No watchpoint expression set");
1870 }
1871 } else if (IS_DIGIT (sym[0])) {
1872 char *mod;
1873 int k = get_num_arg (cmd, &mod);
1874 SKIP_SPACE (mod);
1875 if (mod[0] == NULL_CHAR) {
1876 BOOL_T set = A68_FALSE;
1877 change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_MASK, k, &set, NULL);
1878 if (set == A68_FALSE) {
1879 monitor_error ("cannot set breakpoint in that line", NO_TEXT);
1880 }
1881 } else if (match_string (mod, "IF", BLANK_CHAR)) {
1882 char *cexpr = mod;
1883 BOOL_T set = A68_FALSE;
1884 SKIP_ONE_SYMBOL (cexpr);
1885 change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_MASK, k, &set, new_string (cexpr, NO_TEXT));
1886 if (set == A68_FALSE) {
1887 monitor_error ("cannot set breakpoint in that line", NO_TEXT);
1888 }
1889 } else if (match_string (mod, "Clear", NULL_CHAR)) {
1890 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, k, NULL, NULL);
1891 } else {
1892 monitor_error ("invalid breakpoint command", NO_TEXT);
1893 }
1894 } else if (match_string (sym, "List", NULL_CHAR)) {
1895 int listed = 0;
1896 list_breakpoints (TOP_NODE (&A68_JOB), &listed);
1897 if (listed == 0) {
1898 WRITELN (STDOUT_FILENO, "No breakpoints set");
1899 }
1900 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1901 WRITELN (STDOUT_FILENO, "Watchpoint condition \"");
1902 WRITE (STDOUT_FILENO, A68_MON (watchpoint_expression));
1903 WRITE (STDOUT_FILENO, "\"");
1904 } else {
1905 WRITELN (STDOUT_FILENO, "No watchpoint expression set");
1906 }
1907 } else if (match_string (sym, "Watch", BLANK_CHAR)) {
1908 char *cexpr = sym;
1909 SKIP_ONE_SYMBOL (cexpr);
1910 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1911 a68_free (A68_MON (watchpoint_expression));
1912 A68_MON (watchpoint_expression) = NO_TEXT;
1913 }
1914 A68_MON (watchpoint_expression) = new_string (cexpr, NO_TEXT);
1915 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_TRUE);
1916 } else if (match_string (sym, "Clear", BLANK_CHAR)) {
1917 char *mod = sym;
1918 SKIP_ONE_SYMBOL (mod);
1919 if (mod[0] == NULL_CHAR) {
1920 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1921 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1922 a68_free (A68_MON (watchpoint_expression));
1923 A68_MON (watchpoint_expression) = NO_TEXT;
1924 }
1925 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1926 } else if (match_string (mod, "ALL", NULL_CHAR)) {
1927 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1928 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1929 a68_free (A68_MON (watchpoint_expression));
1930 A68_MON (watchpoint_expression) = NO_TEXT;
1931 }
1932 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1933 } else if (match_string (mod, "Breakpoints", NULL_CHAR)) {
1934 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1935 } else if (match_string (mod, "Watchpoint", NULL_CHAR)) {
1936 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1937 a68_free (A68_MON (watchpoint_expression));
1938 A68_MON (watchpoint_expression) = NO_TEXT;
1939 }
1940 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1941 } else {
1942 monitor_error ("invalid breakpoint command", NO_TEXT);
1943 }
1944 } else {
1945 monitor_error ("invalid breakpoint command", NO_TEXT);
1946 }
1947 return A68_FALSE;
1948 } else if (match_string (cmd, "List", BLANK_CHAR)) {
1949 char *cwhere;
1950 int n = get_num_arg (cmd, &cwhere);
1951 int m = get_num_arg (cwhere, NO_VAR);
1952 if (m == NOT_A_NUM) {
1953 if (n > 0) {
1954 list (STDOUT_FILENO, p, n, 0);
1955 } else if (n == NOT_A_NUM) {
1956 list (STDOUT_FILENO, p, 10, 0);
1957 }
1958 } else if (n > 0 && m > 0 && n <= m) {
1959 list (STDOUT_FILENO, p, n, m);
1960 }
1961 return A68_FALSE;
1962 } else if (match_string (cmd, "PROmpt", BLANK_CHAR)) {
1963 char *sym = cmd;
1964 SKIP_ONE_SYMBOL (sym);
1965 if (sym[0] != NULL_CHAR) {
1966 if (sym[0] == QUOTE_CHAR) {
1967 sym++;
1968 }
1969 if (sym[strlen (sym) - 1] == QUOTE_CHAR) {
1970 sym[strlen (sym) - 1] = NULL_CHAR;
1971 }
1972 bufcpy (A68_MON (prompt), sym, BUFFER_SIZE);
1973 }
1974 return A68_FALSE;
1975 } else if (match_string (cmd, "RERun", NULL_CHAR) || match_string (cmd, "REStart", NULL_CHAR)) {
1976 if (confirm_exit ()) {
1977 exit_genie (p, A68_RERUN);
1978 }
1979 return A68_FALSE;
1980 } else if (match_string (cmd, "RESET", NULL_CHAR)) {
1981 if (confirm_exit ()) {
1982 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1983 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1984 a68_free (A68_MON (watchpoint_expression));
1985 A68_MON (watchpoint_expression) = NO_TEXT;
1986 }
1987 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1988 exit_genie (p, A68_RERUN);
1989 }
1990 return A68_FALSE;
1991 } else if (match_string (cmd, "LINk", BLANK_CHAR)) {
1992 int k = get_num_arg (cmd, NO_VAR);
1993 int printed = 0;
1994 if (k > 0) {
1995 stack_a68_link_dump (STDOUT_FILENO, A68_FP, k, &printed);
1996 } else if (k == NOT_A_NUM) {
1997 stack_a68_link_dump (STDOUT_FILENO, A68_FP, 3, &printed);
1998 }
1999 return A68_FALSE;
2000 } else if (match_string (cmd, "STAck", BLANK_CHAR) || match_string (cmd, "BT", BLANK_CHAR)) {
2001 int k = get_num_arg (cmd, NO_VAR);
2002 int printed = 0;
2003 if (k > 0) {
2004 stack_dump (STDOUT_FILENO, A68_FP, k, &printed);
2005 } else if (k == NOT_A_NUM) {
2006 stack_dump (STDOUT_FILENO, A68_FP, 3, &printed);
2007 }
2008 return A68_FALSE;
2009 } else if (match_string (cmd, "Next", NULL_CHAR)) {
2010 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
2011 A68 (do_confirm_exit) = A68_FALSE;
2012 A68_MON (break_proc_level) = PROCEDURE_LEVEL (INFO (p));
2013 return A68_TRUE;
2014 } else if (match_string (cmd, "STEp", NULL_CHAR)) {
2015 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
2016 A68 (do_confirm_exit) = A68_FALSE;
2017 return A68_TRUE;
2018 } else if (match_string (cmd, "FINish", NULL_CHAR) || match_string (cmd, "OUT", NULL_CHAR)) {
2019 A68_MON (finish_frame_pointer) = FRAME_PARAMETERS (A68_FP);
2020 A68 (do_confirm_exit) = A68_FALSE;
2021 return A68_TRUE;
2022 } else if (match_string (cmd, "Until", BLANK_CHAR)) {
2023 int k = get_num_arg (cmd, NO_VAR);
2024 if (k > 0) {
2025 BOOL_T set = A68_FALSE;
2026 change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, k, &set, NULL);
2027 if (set == A68_FALSE) {
2028 monitor_error ("cannot set breakpoint in that line", NO_TEXT);
2029 return A68_FALSE;
2030 }
2031 A68 (do_confirm_exit) = A68_FALSE;
2032 return A68_TRUE;
2033 } else {
2034 monitor_error ("line number expected", NO_TEXT);
2035 return A68_FALSE;
2036 }
2037 } else if (match_string (cmd, "Where", NULL_CHAR)) {
2038 WIS (p);
2039 return A68_FALSE;
2040 } else if (strcmp (cmd, "?") == 0) {
2041 apropos (STDOUT_FILENO, A68_MON (prompt), "monitor");
2042 return A68_FALSE;
2043 } else if (match_string (cmd, "Sizes", NULL_CHAR)) {
2044 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Frame stack pointer=" A68_LU " available=" A68_LU, A68_FP, A68 (frame_stack_size) - A68_FP) >= 0);
2045 WRITELN (STDOUT_FILENO, A68 (output_line));
2046 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Expression stack pointer=" A68_LU " available=" A68_LU, A68_SP, (UNSIGNED_T) (A68 (expr_stack_size) - A68_SP)) >= 0);
2047 WRITELN (STDOUT_FILENO, A68 (output_line));
2048 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Heap size=%u available=%u", A68 (heap_size), heap_available ()) >= 0);
2049 WRITELN (STDOUT_FILENO, A68 (output_line));
2050 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Garbage collections=" A68_LD, A68_GC (sweeps)) >= 0);
2051 WRITELN (STDOUT_FILENO, A68 (output_line));
2052 return A68_FALSE;
2053 } else if (match_string (cmd, "XRef", NULL_CHAR)) {
2054 int k = LINE_NUMBER (p);
2055 LINE_T *line = TOP_LINE (&A68_JOB);
2056 for (; line != NO_LINE; FORWARD (line)) {
2057 if (NUMBER (line) > 0 && NUMBER (line) == k) {
2058 list_source_line (STDOUT_FILENO, line, A68_TRUE);
2059 }
2060 }
2061 return A68_FALSE;
2062 } else if (match_string (cmd, "XRef", BLANK_CHAR)) {
2063 LINE_T *line = TOP_LINE (&A68_JOB);
2064 int k = get_num_arg (cmd, NO_VAR);
2065 if (k == NOT_A_NUM) {
2066 monitor_error ("line number expected", NO_TEXT);
2067 } else {
2068 for (; line != NO_LINE; FORWARD (line)) {
2069 if (NUMBER (line) > 0 && NUMBER (line) == k) {
2070 list_source_line (STDOUT_FILENO, line, A68_TRUE);
2071 }
2072 }
2073 }
2074 return A68_FALSE;
2075 } else if (strlen (cmd) == 0) {
2076 return A68_FALSE;
2077 } else {
2078 monitor_error ("unrecognised command", NO_TEXT);
2079 return A68_FALSE;
2080 }
2081 }
2082
2083 //! @brief Evaluate conditional breakpoint expression.
2084
2085 BOOL_T evaluate_breakpoint_expression (NODE_T * p)
2086 {
2087 ADDR_T top_sp = A68_SP;
2088 volatile BOOL_T res = A68_FALSE;
2089 A68_MON (mon_errors) = 0;
2090 if (EXPR (INFO (p)) != NO_TEXT) {
2091 evaluate (STDOUT_FILENO, p, EXPR (INFO (p)));
2092 if (A68_MON (_m_sp) != 1 || A68_MON (mon_errors) != 0) {
2093 A68_MON (mon_errors) = 0;
2094 monitor_error ("deleted invalid breakpoint expression", NO_TEXT);
2095 if (EXPR (INFO (p)) != NO_TEXT) {
2096 a68_free (EXPR (INFO (p)));
2097 }
2098 EXPR (INFO (p)) = A68_MON (expr);
2099 res = A68_TRUE;
2100 } else if (TOP_MODE == M_BOOL) {
2101 A68_BOOL z;
2102 POP_OBJECT (p, &z, A68_BOOL);
2103 res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE);
2104 } else {
2105 monitor_error ("deleted invalid breakpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
2106 if (EXPR (INFO (p)) != NO_TEXT) {
2107 a68_free (EXPR (INFO (p)));
2108 }
2109 EXPR (INFO (p)) = A68_MON (expr);
2110 res = A68_TRUE;
2111 }
2112 }
2113 A68_SP = top_sp;
2114 return res;
2115 }
2116
2117 //! @brief Evaluate conditional watchpoint expression.
2118
2119 BOOL_T evaluate_watchpoint_expression (NODE_T * p)
2120 {
2121 ADDR_T top_sp = A68_SP;
2122 volatile BOOL_T res = A68_FALSE;
2123 A68_MON (mon_errors) = 0;
2124 if (A68_MON (watchpoint_expression) != NO_TEXT) {
2125 evaluate (STDOUT_FILENO, p, A68_MON (watchpoint_expression));
2126 if (A68_MON (_m_sp) != 1 || A68_MON (mon_errors) != 0) {
2127 A68_MON (mon_errors) = 0;
2128 monitor_error ("deleted invalid watchpoint expression", NO_TEXT);
2129 if (A68_MON (watchpoint_expression) != NO_TEXT) {
2130 a68_free (A68_MON (watchpoint_expression));
2131 A68_MON (watchpoint_expression) = NO_TEXT;
2132 }
2133 res = A68_TRUE;
2134 }
2135 if (TOP_MODE == M_BOOL) {
2136 A68_BOOL z;
2137 POP_OBJECT (p, &z, A68_BOOL);
2138 res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE);
2139 } else {
2140 monitor_error ("deleted invalid watchpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
2141 if (A68_MON (watchpoint_expression) != NO_TEXT) {
2142 a68_free (A68_MON (watchpoint_expression));
2143 A68_MON (watchpoint_expression) = NO_TEXT;
2144 }
2145 res = A68_TRUE;
2146 }
2147 }
2148 A68_SP = top_sp;
2149 return res;
2150 }
2151
2152 //! @brief Execute monitor.
2153
2154 void single_step (NODE_T * p, unt mask)
2155 {
2156 volatile BOOL_T do_cmd = A68_TRUE;
2157 ADDR_T top_sp = A68_SP;
2158 A68_MON (current_frame) = 0;
2159 A68_MON (max_row_elems) = MAX_ROW_ELEMS;
2160 A68_MON (mon_errors) = 0;
2161 A68_MON (tabs) = 0;
2162 A68_MON (prompt_set) = A68_FALSE;
2163 if (LINE_NUMBER (p) == 0) {
2164 return;
2165 }
2166 #if defined (HAVE_CURSES)
2167 genie_curses_end (NO_NODE);
2168 #endif
2169 if (mask == (unt) BREAKPOINT_ERROR_MASK) {
2170 WRITELN (STDOUT_FILENO, "Monitor entered after an error");
2171 WIS ((p));
2172 } else if ((mask & BREAKPOINT_INTERRUPT_MASK) != 0) {
2173 WRITELN (STDOUT_FILENO, NEWLINE_STRING);
2174 WIS ((p));
2175 if (A68 (do_confirm_exit) && confirm_exit ()) {
2176 exit_genie ((p), A68_RUNTIME_ERROR + A68_FORCE_QUIT);
2177 }
2178 } else if ((mask & BREAKPOINT_MASK) != 0) {
2179 if (EXPR (INFO (p)) != NO_TEXT) {
2180 if (!evaluate_breakpoint_expression (p)) {
2181 return;
2182 }
2183 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Breakpoint (%s)", EXPR (INFO (p))) >= 0);
2184 } else {
2185 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Breakpoint") >= 0);
2186 }
2187 WRITELN (STDOUT_FILENO, A68 (output_line));
2188 WIS (p);
2189 } else if ((mask & BREAKPOINT_TEMPORARY_MASK) != 0) {
2190 if (A68_MON (break_proc_level) != 0 && PROCEDURE_LEVEL (INFO (p)) > A68_MON (break_proc_level)) {
2191 return;
2192 }
2193 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_FALSE);
2194 WRITELN (STDOUT_FILENO, "Temporary breakpoint (now removed)");
2195 WIS (p);
2196 } else if ((mask & BREAKPOINT_WATCH_MASK) != 0) {
2197 if (!evaluate_watchpoint_expression (p)) {
2198 return;
2199 }
2200 if (A68_MON (watchpoint_expression) != NO_TEXT) {
2201 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Watchpoint (%s)", A68_MON (watchpoint_expression)) >= 0);
2202 } else {
2203 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Watchpoint (now removed)") >= 0);
2204 }
2205 WRITELN (STDOUT_FILENO, A68 (output_line));
2206 WIS (p);
2207 } else if ((mask & BREAKPOINT_TRACE_MASK) != 0) {
2208 PROP_T *prop = &GPROP (p);
2209 WIS ((p));
2210 if (propagator_name (UNIT (prop)) != NO_TEXT) {
2211 WRITELN (STDOUT_FILENO, propagator_name (UNIT (prop)));
2212 }
2213 return;
2214 } else {
2215 WRITELN (STDOUT_FILENO, "Monitor entered with no valid reason (continuing execution)");
2216 WIS ((p));
2217 return;
2218 }
2219 #if defined (BUILD_PARALLEL_CLAUSE)
2220 if (is_main_thread ()) {
2221 WRITELN (STDOUT_FILENO, "This is the main thread");
2222 } else {
2223 WRITELN (STDOUT_FILENO, "This is not the main thread");
2224 }
2225 #endif
2226 // Entry into the monitor.
2227 if (A68_MON (prompt_set) == A68_FALSE) {
2228 bufcpy (A68_MON (prompt), "(a68g) ", BUFFER_SIZE);
2229 A68_MON (prompt_set) = A68_TRUE;
2230 }
2231 A68_MON (in_monitor) = A68_TRUE;
2232 A68_MON (break_proc_level) = 0;
2233 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE);
2234 STATUS_CLEAR (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK);
2235 while (do_cmd) {
2236 char *cmd;
2237 A68_SP = top_sp;
2238 io_close_tty_line ();
2239 while (strlen (cmd = read_string_from_tty (A68_MON (prompt))) == 0) {;
2240 }
2241 if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) {
2242 bufcpy (cmd, LOGOUT_STRING, BUFFER_SIZE);
2243 WRITE (STDOUT_FILENO, LOGOUT_STRING);
2244 WRITE (STDOUT_FILENO, NEWLINE_STRING);
2245 }
2246 A68_MON (_m_sp) = 0;
2247 do_cmd = (BOOL_T) (!single_stepper (p, cmd));
2248 }
2249 A68_SP = top_sp;
2250 A68_MON (in_monitor) = A68_FALSE;
2251 if (mask == (unt) BREAKPOINT_ERROR_MASK) {
2252 WRITELN (STDOUT_FILENO, "Continuing from an error might corrupt things");
2253 single_step (p, (unt) BREAKPOINT_ERROR_MASK);
2254 } else {
2255 WRITELN (STDOUT_FILENO, "Continuing ...");
2256 WRITELN (STDOUT_FILENO, "");
2257 }
2258 }
2259
2260 //! @brief PROC debug = VOID
2261
2262 void genie_debug (NODE_T * p)
2263 {
2264 single_step (p, BREAKPOINT_INTERRUPT_MASK);
2265 }
2266
2267 //! @brief PROC break = VOID
2268
2269 void genie_break (NODE_T * p)
2270 {
2271 (void) p;
2272 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
2273 }
2274
2275 //! @brief PROC evaluate = (STRING) STRING
2276
2277 void genie_evaluate (NODE_T * p)
2278 {
2279 A68_REF u, v;
2280 v = empty_string (p);
2281 // Pop argument.
2282 POP_REF (p, (A68_REF *) & u);
2283 volatile ADDR_T top_sp = A68_SP;
2284 CHECK_MON_REF (p, u, M_STRING);
2285 reset_transput_buffer (UNFORMATTED_BUFFER);
2286 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u);
2287 v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
2288 // Evaluate in the monitor.
2289 A68_MON (in_monitor) = A68_TRUE;
2290 A68_MON (mon_errors) = 0;
2291 evaluate (STDOUT_FILENO, p, get_transput_buffer (UNFORMATTED_BUFFER));
2292 A68_MON (in_monitor) = A68_FALSE;
2293 if (A68_MON (_m_sp) != 1) {
2294 monitor_error ("invalid expression", NO_TEXT);
2295 }
2296 if (A68_MON (mon_errors) == 0) {
2297 MOID_T *res;
2298 BOOL_T cont = A68_TRUE;
2299 while (cont) {
2300 res = TOP_MODE;
2301 cont = (BOOL_T) (IS_REF (res) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (top_sp)));
2302 if (cont) {
2303 A68_REF w;
2304 POP_REF (p, &w);
2305 TOP_MODE = SUB (TOP_MODE);
2306 PUSH (p, ADDRESS (&w), SIZE (TOP_MODE));
2307 }
2308 }
2309 reset_transput_buffer (UNFORMATTED_BUFFER);
2310 genie_write_standard (p, TOP_MODE, STACK_ADDRESS (top_sp), nil_ref);
2311 v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
2312 }
2313 A68_SP = top_sp;
2314 PUSH_REF (p, v);
2315 }
2316
2317 //! @brief PROC abend = (STRING) VOID
2318
2319 void genie_abend (NODE_T * p)
2320 {
2321 A68_REF u;
2322 POP_REF (p, (A68_REF *) & u);
2323 reset_transput_buffer (UNFORMATTED_BUFFER);
2324 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u);
2325 diagnostic (A68_RUNTIME_ERROR | A68_NO_SYNTHESIS, p, get_transput_buffer (UNFORMATTED_BUFFER), NO_TEXT);
2326 exit_genie (p, A68_RUNTIME_ERROR);
2327 }
