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