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