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-2024 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 (a68_bufprt (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 (a68_bufprt (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 (a68_bufprt (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 a68_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 a68_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 a68_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 a68_bufcpy (A68_MON (symbol), ":=", BUFFER_SIZE);
198 A68_MON (attr) = ASSIGN_SYMBOL;
199 } else {
200 A68_MON (pos)++;
201 a68_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 (a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s %s", sym, moid_to_string (x, MOID_WIDTH, NO_NODE)) >= 0);
486 } else {
487 ASSERT (a68_bufprt (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 (a68_bufprt (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 (a68_bufprt (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 a68_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 a68_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 a68_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 a68_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 (a68_bufprt (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 (a68_bufprt (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 if (f == A68_STDOUT) {
1292 io_close_tty_line ();
1293 }
1294 for (int k = 0; k < A68_MON (tabs); k++) {
1295 WRITE (f, " ");
1296 }
1297 }
1298
1299 //! @brief Show value of object.
1300
1301 void show_item (FILE_T f, NODE_T * p, BYTE_T * item, MOID_T * mode)
1302 {
1303 if (item == NO_BYTE || mode == NO_MOID) {
1304 return;
1305 }
1306 if (IS_REF (mode)) {
1307 A68_REF *z = (A68_REF *) item;
1308 if (IS_NIL (*z)) {
1309 if (INITIALISED (z)) {
1310 WRITE (A68_STDOUT, " = NIL");
1311 } else {
1312 WRITE (A68_STDOUT, NO_VALUE);
1313 }
1314 } else {
1315 if (INITIALISED (z)) {
1316 WRITE (A68_STDOUT, " refers to ");
1317 if (IS_IN_HEAP (z)) {
1318 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "heap(%p)", (void *) ADDRESS (z)) >= 0);
1319 WRITE (A68_STDOUT, A68 (output_line));
1320 A68_MON (tabs)++;
1321 show_item (f, p, ADDRESS (z), SUB (mode));
1322 A68_MON (tabs)--;
1323 } else if (IS_IN_FRAME (z)) {
1324 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "frame(" A68_LU ")", REF_OFFSET (z)) >= 0);
1325 WRITE (A68_STDOUT, A68 (output_line));
1326 } else if (IS_IN_STACK (z)) {
1327 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "stack(" A68_LU ")", REF_OFFSET (z)) >= 0);
1328 WRITE (A68_STDOUT, A68 (output_line));
1329 }
1330 } else {
1331 WRITE (A68_STDOUT, NO_VALUE);
1332 }
1333 }
1334 } else if (mode == M_STRING) {
1335 if (!INITIALISED ((A68_REF *) item)) {
1336 WRITE (A68_STDOUT, NO_VALUE);
1337 } else {
1338 print_item (p, f, item, mode);
1339 }
1340 } else if ((IS_ROW (mode) || IS_FLEX (mode)) && mode != M_STRING) {
1341 MOID_T *deflexed = DEFLEX (mode);
1342 int old_tabs = A68_MON (tabs);
1343 A68_MON (tabs) += 2;
1344 if (!INITIALISED ((A68_REF *) item)) {
1345 WRITE (A68_STDOUT, NO_VALUE);
1346 } else {
1347 A68_ARRAY *arr; A68_TUPLE *tup;
1348 GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1349 int elems = get_row_size (tup, DIM (arr));
1350 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, ", %d element(s)", elems) >= 0);
1351 WRITE (f, A68 (output_line));
1352 if (get_row_size (tup, DIM (arr)) != 0) {
1353 BYTE_T *base_addr = ADDRESS (&ARRAY (arr));
1354 BOOL_T done = A68_FALSE;
1355 initialise_internal_index (tup, DIM (arr));
1356 int count = 0, act_count = 0;
1357 while (!done && ++count <= (A68_MON (max_row_elems) + 1)) {
1358 if (count <= A68_MON (max_row_elems)) {
1359 ADDR_T row_index = calculate_internal_index (tup, DIM (arr));
1360 ADDR_T elem_addr = ROW_ELEMENT (arr, row_index);
1361 BYTE_T *elem = &base_addr[elem_addr];
1362 indent_crlf (f);
1363 WRITE (f, "[");
1364 print_internal_index (f, tup, DIM (arr));
1365 WRITE (f, "]");
1366 show_item (f, p, elem, SUB (deflexed));
1367 act_count++;
1368 done = increment_internal_index (tup, DIM (arr));
1369 }
1370 }
1371 indent_crlf (f);
1372 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, " %d element(s) written (%d%%)", act_count, (int) ((100.0 * act_count) / elems)) >= 0);
1373 WRITE (f, A68 (output_line));
1374 }
1375 }
1376 A68_MON (tabs) = old_tabs;
1377 } else if (IS_STRUCT (mode)) {
1378 A68_MON (tabs)++;
1379 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1380 BYTE_T *elem = &item[OFFSET (q)];
1381 indent_crlf (f);
1382 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, " %s \"%s\"", moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), TEXT (q)) >= 0);
1383 WRITE (A68_STDOUT, A68 (output_line));
1384 show_item (f, p, elem, MOID (q));
1385 }
1386 A68_MON (tabs)--;
1387 } else if (IS (mode, UNION_SYMBOL)) {
1388 A68_UNION *z = (A68_UNION *) item;
1389 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1390 WRITE (A68_STDOUT, A68 (output_line));
1391 show_item (f, p, &item[SIZE_ALIGNED (A68_UNION)], (MOID_T *) (VALUE (z)));
1392 } else if (mode == M_SIMPLIN) {
1393 A68_UNION *z = (A68_UNION *) item;
1394 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1395 WRITE (A68_STDOUT, A68 (output_line));
1396 } else if (mode == M_SIMPLOUT) {
1397 A68_UNION *z = (A68_UNION *) item;
1398 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1399 WRITE (A68_STDOUT, A68 (output_line));
1400 } else {
1401 BOOL_T init;
1402 if (check_initialisation (p, item, mode, &init)) {
1403 if (init) {
1404 if (IS (mode, PROC_SYMBOL)) {
1405 A68_PROCEDURE *z = (A68_PROCEDURE *) item;
1406 if (z != NO_PROCEDURE && STATUS (z) & STANDENV_PROC_MASK) {
1407 char *fname = standard_environ_proc_name (*(PROCEDURE (&BODY (z))));
1408 WRITE (A68_STDOUT, " standenv procedure");
1409 if (fname != NO_TEXT) {
1410 WRITE (A68_STDOUT, " (");
1411 WRITE (A68_STDOUT, fname);
1412 WRITE (A68_STDOUT, ")");
1413 }
1414 } else if (z != NO_PROCEDURE && STATUS (z) & SKIP_PROCEDURE_MASK) {
1415 WRITE (A68_STDOUT, " skip procedure");
1416 } else if (z != NO_PROCEDURE && (PROCEDURE (&BODY (z))) != NO_GPROC) {
1417 ASSERT (a68_bufprt (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);
1418 WRITE (A68_STDOUT, A68 (output_line));
1419 } else {
1420 WRITE (A68_STDOUT, " cannot show value");
1421 }
1422 } else if (mode == M_FORMAT) {
1423 A68_FORMAT *z = (A68_FORMAT *) item;
1424 if (z != NO_FORMAT && BODY (z) != NO_NODE) {
1425 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68_LU ")", LINE_NUMBER (BODY (z)), ENVIRON (z)) >= 0);
1426 WRITE (A68_STDOUT, A68 (output_line));
1427 } else {
1428 monitor_error (CANNOT_SHOW, NO_TEXT);
1429 }
1430 } else if (mode == M_SOUND) {
1431 A68_SOUND *z = (A68_SOUND *) item;
1432 if (z != NO_SOUND) {
1433 ASSERT (a68_bufprt (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);
1434 WRITE (A68_STDOUT, A68 (output_line));
1435
1436 } else {
1437 monitor_error (CANNOT_SHOW, NO_TEXT);
1438 }
1439 } else {
1440 print_item (p, f, item, mode);
1441 }
1442 } else {
1443 WRITE (A68_STDOUT, NO_VALUE);
1444 }
1445 } else {
1446 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, " mode %s, %s", moid_to_string (mode, MOID_WIDTH, NO_NODE), CANNOT_SHOW) >= 0);
1447 WRITE (A68_STDOUT, A68 (output_line));
1448 }
1449 }
1450 }
1451
1452 //! @brief Overview of frame item.
1453
1454 void show_frame_item (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, int modif)
1455 {
1456 (void) p;
1457 ADDR_T addr = a68_link + FRAME_INFO_SIZE + OFFSET (q);
1458 ADDR_T loc = FRAME_INFO_SIZE + OFFSET (q);
1459 indent_crlf (A68_STDOUT);
1460 if (modif != ANONYMOUS) {
1461 ASSERT (a68_bufprt (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);
1462 WRITE (A68_STDOUT, A68 (output_line));
1463 show_item (f, p, FRAME_ADDRESS (addr), MOID (q));
1464 } else {
1465 switch (PRIO (q)) {
1466 case GENERATOR: {
1467 ASSERT (a68_bufprt (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);
1468 WRITE (A68_STDOUT, A68 (output_line));
1469 break;
1470 }
1471 default: {
1472 ASSERT (a68_bufprt (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);
1473 WRITE (A68_STDOUT, A68 (output_line));
1474 break;
1475 }
1476 }
1477 show_item (f, p, FRAME_ADDRESS (addr), MOID (q));
1478 }
1479 }
1480
1481 //! @brief Overview of frame items.
1482
1483 void show_frame_items (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, int modif)
1484 {
1485 (void) p;
1486 for (; q != NO_TAG; FORWARD (q)) {
1487 show_frame_item (f, p, a68_link, q, modif);
1488 }
1489 }
1490
1491 //! @brief Introduce stack frame.
1492
1493 void intro_frame (FILE_T f, NODE_T * p, ADDR_T a68_link, int *printed)
1494 {
1495 if (*printed > 0) {
1496 WRITELN (f, "");
1497 }
1498 (*printed)++;
1499 TABLE_T *q = TABLE (p);
1500 where_in_source (f, p);
1501 ASSERT (a68_bufprt (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);
1502 WRITELN (f, A68 (output_line));
1503 }
1504
1505 //! @brief View contents of stack frame.
1506
1507 void show_stack_frame (FILE_T f, NODE_T * p, ADDR_T a68_link, int *printed)
1508 {
1509 // show the frame starting at frame pointer 'a68_link', using symbol table from p as a map.
1510 if (p != NO_NODE) {
1511 TABLE_T *q = TABLE (p);
1512 intro_frame (f, p, a68_link, printed);
1513 #if (A68_LEVEL >= 3)
1514 ASSERT (a68_bufprt (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);
1515 WRITELN (A68_STDOUT, A68 (output_line));
1516 #else
1517 ASSERT (a68_bufprt (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);
1518 WRITELN (A68_STDOUT, A68 (output_line));
1519 #endif
1520 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Procedure frame=%s", (FRAME_PROC_FRAME (a68_link) ? "yes" : "no")) >= 0);
1521 WRITELN (A68_STDOUT, A68 (output_line));
1522 #if defined (BUILD_PARALLEL_CLAUSE)
1523 if (pthread_equal (FRAME_THREAD_ID (a68_link), A68_PAR (main_thread_id)) != 0) {
1524 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "In main thread") >= 0);
1525 } else {
1526 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Not in main thread") >= 0);
1527 }
1528 WRITELN (A68_STDOUT, A68 (output_line));
1529 #endif
1530 show_frame_items (f, p, a68_link, IDENTIFIERS (q), IDENTIFIER);
1531 show_frame_items (f, p, a68_link, OPERATORS (q), OPERATOR);
1532 show_frame_items (f, p, a68_link, ANONYMOUS (q), ANONYMOUS);
1533 }
1534 }
1535
1536 //! @brief Shows lines around the line where 'p' is at.
1537
1538 void list (FILE_T f, NODE_T * p, int n, int m)
1539 {
1540 if (p != NO_NODE) {
1541 if (m == 0) {
1542 LINE_T *r = LINE (INFO (p));
1543 for (LINE_T *l = TOP_LINE (&A68_JOB); l != NO_LINE; FORWARD (l)) {
1544 if (NUMBER (l) > 0 && abs (NUMBER (r) - NUMBER (l)) <= n) {
1545 write_source_line (f, l, NO_NODE, A68_TRUE);
1546 }
1547 }
1548 } else {
1549 for (LINE_T *l = TOP_LINE (&A68_JOB); l != NO_LINE; FORWARD (l)) {
1550 if (NUMBER (l) > 0 && NUMBER (l) >= n && NUMBER (l) <= m) {
1551 write_source_line (f, l, NO_NODE, A68_TRUE);
1552 }
1553 }
1554 }
1555 }
1556 }
1557
1558 //! @brief Overview of the heap.
1559
1560 void show_heap (FILE_T f, NODE_T * p, A68_HANDLE * z, int top, int n)
1561 {
1562 int k = 0, m = n, sum = 0;
1563 (void) p;
1564 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "size=%u available=%d garbage collections=" A68_LD, A68 (heap_size), heap_available (), A68_GC (sweeps)) >= 0);
1565 WRITELN (f, A68 (output_line));
1566 for (; z != NO_HANDLE; FORWARD (z), k++) {
1567 if (n > 0 && sum <= top) {
1568 n--;
1569 indent_crlf (f);
1570 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "heap(%p+%d) %s", (void *) POINTER (z), SIZE (z), moid_to_string (MOID (z), MOID_WIDTH, NO_NODE)) >= 0);
1571 WRITE (f, A68 (output_line));
1572 sum += SIZE (z);
1573 }
1574 }
1575 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "printed %d out of %d handles", m, k) >= 0);
1576 WRITELN (f, A68 (output_line));
1577 }
1578
1579 //! @brief Search current frame and print it.
1580
1581 void stack_dump_current (FILE_T f, ADDR_T a68_link)
1582 {
1583 if (a68_link > 0) {
1584 int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1585 NODE_T *p = FRAME_TREE (a68_link);
1586 if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1587 if (FRAME_NUMBER (a68_link) == A68_MON (current_frame)) {
1588 int printed = 0;
1589 show_stack_frame (f, p, a68_link, &printed);
1590 } else {
1591 stack_dump_current (f, dynamic_a68_link);
1592 }
1593 }
1594 }
1595 }
1596
1597 //! @brief Overview of the stack.
1598
1599 void stack_a68_link_dump (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1600 {
1601 if (depth > 0 && a68_link > 0) {
1602 NODE_T *p = FRAME_TREE (a68_link);
1603 if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1604 show_stack_frame (f, p, a68_link, printed);
1605 stack_a68_link_dump (f, FRAME_STATIC_LINK (a68_link), depth - 1, printed);
1606 }
1607 }
1608 }
1609
1610 //! @brief Overview of the stack.
1611
1612 void stack_dump (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1613 {
1614 if (depth > 0 && a68_link > 0) {
1615 NODE_T *p = FRAME_TREE (a68_link);
1616 if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1617 show_stack_frame (f, p, a68_link, printed);
1618 stack_dump (f, FRAME_DYNAMIC_LINK (a68_link), depth - 1, printed);
1619 }
1620 }
1621 }
1622
1623 //! @brief Overview of the stack.
1624
1625 void stack_trace (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1626 {
1627 if (depth > 0 && a68_link > 0) {
1628 int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1629 if (FRAME_PROC_FRAME (a68_link)) {
1630 NODE_T *p = FRAME_TREE (a68_link);
1631 show_stack_frame (f, p, a68_link, printed);
1632 stack_trace (f, dynamic_a68_link, depth - 1, printed);
1633 } else {
1634 stack_trace (f, dynamic_a68_link, depth, printed);
1635 }
1636 }
1637 }
1638
1639 //! @brief Examine tags.
1640
1641 void examine_tags (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, char *sym, int *printed)
1642 {
1643 for (; q != NO_TAG; FORWARD (q)) {
1644 if (NODE (q) != NO_NODE && strcmp (NSYMBOL (NODE (q)), sym) == 0) {
1645 intro_frame (f, p, a68_link, printed);
1646 show_frame_item (f, p, a68_link, q, PRIO (q));
1647 }
1648 }
1649 }
1650
1651 //! @brief Search symbol in stack.
1652
1653 void examine_stack (FILE_T f, ADDR_T a68_link, char *sym, int *printed)
1654 {
1655 if (a68_link > 0) {
1656 int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1657 NODE_T *p = FRAME_TREE (a68_link);
1658 if (p != NO_NODE) {
1659 TABLE_T *q = TABLE (p);
1660 examine_tags (f, p, a68_link, IDENTIFIERS (q), sym, printed);
1661 examine_tags (f, p, a68_link, OPERATORS (q), sym, printed);
1662 }
1663 examine_stack (f, dynamic_a68_link, sym, printed);
1664 }
1665 }
1666
1667 //! @brief Set or reset breakpoints.
1668
1669 void change_breakpoints (NODE_T * p, unt set, int num, BOOL_T * is_set, char *loc_expr)
1670 {
1671 for (; p != NO_NODE; FORWARD (p)) {
1672 change_breakpoints (SUB (p), set, num, is_set, loc_expr);
1673 if (set == BREAKPOINT_MASK) {
1674 if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) {
1675 STATUS_SET (p, BREAKPOINT_MASK);
1676 a68_free (EXPR (INFO (p)));
1677 EXPR (INFO (p)) = loc_expr;
1678 *is_set = A68_TRUE;
1679 }
1680 } else if (set == BREAKPOINT_TEMPORARY_MASK) {
1681 if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) {
1682 STATUS_SET (p, BREAKPOINT_TEMPORARY_MASK);
1683 a68_free (EXPR (INFO (p)));
1684 EXPR (INFO (p)) = loc_expr;
1685 *is_set = A68_TRUE;
1686 }
1687 } else if (set == NULL_MASK) {
1688 if (LINE_NUMBER (p) != num) {
1689 STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK));
1690 a68_free (EXPR (INFO (p)));
1691 EXPR (INFO (p)) = NO_TEXT;
1692 } else if (num == 0) {
1693 STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK));
1694 a68_free (EXPR (INFO (p)));
1695 EXPR (INFO (p)) = NO_TEXT;
1696 }
1697 }
1698 }
1699 }
1700
1701 //! @brief List breakpoints.
1702
1703 void list_breakpoints (NODE_T * p, int *listed)
1704 {
1705 for (; p != NO_NODE; FORWARD (p)) {
1706 list_breakpoints (SUB (p), listed);
1707 if (STATUS_TEST (p, BREAKPOINT_MASK)) {
1708 (*listed)++;
1709 WIS (p);
1710 if (EXPR (INFO (p)) != NO_TEXT) {
1711 WRITELN (A68_STDOUT, "breakpoint condition \"");
1712 WRITE (A68_STDOUT, EXPR (INFO (p)));
1713 WRITE (A68_STDOUT, "\"");
1714 }
1715 }
1716 }
1717 }
1718
1719 //! @brief Execute monitor command.
1720
1721 BOOL_T single_stepper (NODE_T * p, char *cmd)
1722 {
1723 A68_MON (mon_errors) = 0;
1724 errno = 0;
1725 if (strlen (cmd) == 0) {
1726 return A68_FALSE;
1727 }
1728 while (IS_SPACE (cmd[strlen (cmd) - 1])) {
1729 cmd[strlen (cmd) - 1] = NULL_CHAR;
1730 }
1731 if (match_string (cmd, "CAlls", BLANK_CHAR)) {
1732 int k = get_num_arg (cmd, NO_VAR);
1733 int printed = 0;
1734 if (k > 0) {
1735 stack_trace (A68_STDOUT, A68_FP, k, &printed);
1736 } else if (k == 0) {
1737 stack_trace (A68_STDOUT, A68_FP, 3, &printed);
1738 }
1739 return A68_FALSE;
1740 } else if (match_string (cmd, "Continue", NULL_CHAR) || match_string (cmd, "Resume", NULL_CHAR)) {
1741 A68 (do_confirm_exit) = A68_TRUE;
1742 return A68_TRUE;
1743 } else if (match_string (cmd, "DO", BLANK_CHAR) || match_string (cmd, "EXEC", BLANK_CHAR)) {
1744 char *sym = cmd;
1745 SKIP_ONE_SYMBOL (sym);
1746 if (sym[0] != NULL_CHAR) {
1747 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "return code %d", system (sym)) >= 0);
1748 WRITELN (A68_STDOUT, A68 (output_line));
1749 }
1750 return A68_FALSE;
1751 } else if (match_string (cmd, "ELems", BLANK_CHAR)) {
1752 int k = get_num_arg (cmd, NO_VAR);
1753 if (k > 0) {
1754 A68_MON (max_row_elems) = k;
1755 }
1756 return A68_FALSE;
1757 } else if (match_string (cmd, "Evaluate", BLANK_CHAR) || match_string (cmd, "X", BLANK_CHAR)) {
1758 char *sym = cmd;
1759 SKIP_ONE_SYMBOL (sym);
1760 if (sym[0] != NULL_CHAR) {
1761 ADDR_T old_sp = A68_SP;
1762 evaluate (A68_STDOUT, p, sym);
1763 if (A68_MON (mon_errors) == 0 && A68_MON (_m_sp) > 0) {
1764 BOOL_T cont = A68_TRUE;
1765 while (cont) {
1766 MOID_T *res = A68_MON (_m_stack)[0];
1767 WRITELN (A68_STDOUT, "(");
1768 WRITE (A68_STDOUT, moid_to_string (res, MOID_WIDTH, NO_NODE));
1769 WRITE (A68_STDOUT, ")");
1770 show_item (A68_STDOUT, p, STACK_ADDRESS (old_sp), res);
1771 cont = (BOOL_T) (IS_REF (res) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (old_sp)));
1772 if (cont) {
1773 A68_REF z;
1774 POP_REF (p, &z);
1775 A68_MON (_m_stack)[0] = SUB (A68_MON (_m_stack)[0]);
1776 PUSH (p, ADDRESS (&z), SIZE (A68_MON (_m_stack)[0]));
1777 }
1778 }
1779 } else {
1780 monitor_error (CANNOT_SHOW, NO_TEXT);
1781 }
1782 A68_SP = old_sp;
1783 A68_MON (_m_sp) = 0;
1784 }
1785 return A68_FALSE;
1786 } else if (match_string (cmd, "EXamine", BLANK_CHAR)) {
1787 char *sym = cmd;
1788 SKIP_ONE_SYMBOL (sym);
1789 if (sym[0] != NULL_CHAR && (IS_LOWER (sym[0]) || IS_UPPER (sym[0]))) {
1790 int printed = 0;
1791 examine_stack (A68_STDOUT, A68_FP, sym, &printed);
1792 if (printed == 0) {
1793 monitor_error ("tag not found", sym);
1794 }
1795 } else {
1796 monitor_error ("tag expected", NO_TEXT);
1797 }
1798 return A68_FALSE;
1799 } 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) {
1800 if (confirm_exit ()) {
1801 exit_genie (p, A68_RUNTIME_ERROR + A68_FORCE_QUIT);
1802 }
1803 return A68_FALSE;
1804 } else if (match_string (cmd, "Frame", NULL_CHAR)) {
1805 if (A68_MON (current_frame) == 0) {
1806 int printed = 0;
1807 stack_dump (A68_STDOUT, A68_FP, 1, &printed);
1808 } else {
1809 stack_dump_current (A68_STDOUT, A68_FP);
1810 }
1811 return A68_FALSE;
1812 } else if (match_string (cmd, "Frame", BLANK_CHAR)) {
1813 int n = get_num_arg (cmd, NO_VAR);
1814 A68_MON (current_frame) = (n > 0 ? n : 0);
1815 stack_dump_current (A68_STDOUT, A68_FP);
1816 return A68_FALSE;
1817 } else if (match_string (cmd, "HEAp", BLANK_CHAR)) {
1818 int top = get_num_arg (cmd, NO_VAR);
1819 if (top <= 0) {
1820 top = A68 (heap_size);
1821 }
1822 show_heap (A68_STDOUT, p, A68_GC (busy_handles), top, A68 (term_heigth) - 4);
1823 return A68_FALSE;
1824 } else if (match_string (cmd, "APropos", NULL_CHAR) || match_string (cmd, "Help", NULL_CHAR) || match_string (cmd, "INfo", NULL_CHAR)) {
1825 apropos (A68_STDOUT, NO_TEXT, "monitor");
1826 return A68_FALSE;
1827 } else if (match_string (cmd, "APropos", BLANK_CHAR) || match_string (cmd, "Help", BLANK_CHAR) || match_string (cmd, "INfo", BLANK_CHAR)) {
1828 char *sym = cmd;
1829 SKIP_ONE_SYMBOL (sym);
1830 apropos (A68_STDOUT, NO_TEXT, sym);
1831 return A68_FALSE;
1832 } else if (match_string (cmd, "HT", NULL_CHAR)) {
1833 A68 (halt_typing) = A68_TRUE;
1834 A68 (do_confirm_exit) = A68_TRUE;
1835 return A68_TRUE;
1836 } else if (match_string (cmd, "RT", NULL_CHAR)) {
1837 A68 (halt_typing) = A68_FALSE;
1838 A68 (do_confirm_exit) = A68_TRUE;
1839 return A68_TRUE;
1840 } else if (match_string (cmd, "Breakpoint", BLANK_CHAR)) {
1841 char *sym = cmd;
1842 SKIP_ONE_SYMBOL (sym);
1843 if (sym[0] == NULL_CHAR) {
1844 int listed = 0;
1845 list_breakpoints (TOP_NODE (&A68_JOB), &listed);
1846 if (listed == 0) {
1847 WRITELN (A68_STDOUT, "No breakpoints set");
1848 }
1849 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1850 WRITELN (A68_STDOUT, "Watchpoint condition \"");
1851 WRITE (A68_STDOUT, A68_MON (watchpoint_expression));
1852 WRITE (A68_STDOUT, "\"");
1853 } else {
1854 WRITELN (A68_STDOUT, "No watchpoint expression set");
1855 }
1856 } else if (IS_DIGIT (sym[0])) {
1857 char *mod;
1858 int k = get_num_arg (cmd, &mod);
1859 SKIP_SPACE (mod);
1860 if (mod[0] == NULL_CHAR) {
1861 BOOL_T set = A68_FALSE;
1862 change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_MASK, k, &set, NULL);
1863 if (set == A68_FALSE) {
1864 monitor_error ("cannot set breakpoint in that line", NO_TEXT);
1865 }
1866 } else if (match_string (mod, "IF", BLANK_CHAR)) {
1867 char *cexpr = mod;
1868 BOOL_T set = A68_FALSE;
1869 SKIP_ONE_SYMBOL (cexpr);
1870 change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_MASK, k, &set, new_string (cexpr, NO_TEXT));
1871 if (set == A68_FALSE) {
1872 monitor_error ("cannot set breakpoint in that line", NO_TEXT);
1873 }
1874 } else if (match_string (mod, "Clear", NULL_CHAR)) {
1875 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, k, NULL, NULL);
1876 } else {
1877 monitor_error ("invalid breakpoint command", NO_TEXT);
1878 }
1879 } else if (match_string (sym, "List", NULL_CHAR)) {
1880 int listed = 0;
1881 list_breakpoints (TOP_NODE (&A68_JOB), &listed);
1882 if (listed == 0) {
1883 WRITELN (A68_STDOUT, "No breakpoints set");
1884 }
1885 if (A68_MON (watchpoint_expression) != NO_TEXT) {
1886 WRITELN (A68_STDOUT, "Watchpoint condition \"");
1887 WRITE (A68_STDOUT, A68_MON (watchpoint_expression));
1888 WRITE (A68_STDOUT, "\"");
1889 } else {
1890 WRITELN (A68_STDOUT, "No watchpoint expression set");
1891 }
1892 } else if (match_string (sym, "Watch", BLANK_CHAR)) {
1893 char *cexpr = sym;
1894 SKIP_ONE_SYMBOL (cexpr);
1895 a68_free (A68_MON (watchpoint_expression));
1896 A68_MON (watchpoint_expression) = NO_TEXT;
1897 A68_MON (watchpoint_expression) = new_string (cexpr, NO_TEXT);
1898 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_TRUE);
1899 } else if (match_string (sym, "Clear", BLANK_CHAR)) {
1900 char *mod = sym;
1901 SKIP_ONE_SYMBOL (mod);
1902 if (mod[0] == NULL_CHAR) {
1903 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1904 a68_free (A68_MON (watchpoint_expression));
1905 A68_MON (watchpoint_expression) = NO_TEXT;
1906 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1907 } else if (match_string (mod, "ALL", NULL_CHAR)) {
1908 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1909 a68_free (A68_MON (watchpoint_expression));
1910 A68_MON (watchpoint_expression) = NO_TEXT;
1911 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1912 } else if (match_string (mod, "Breakpoints", NULL_CHAR)) {
1913 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1914 } else if (match_string (mod, "Watchpoint", NULL_CHAR)) {
1915 a68_free (A68_MON (watchpoint_expression));
1916 A68_MON (watchpoint_expression) = NO_TEXT;
1917 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1918 } else {
1919 monitor_error ("invalid breakpoint command", NO_TEXT);
1920 }
1921 } else {
1922 monitor_error ("invalid breakpoint command", NO_TEXT);
1923 }
1924 return A68_FALSE;
1925 } else if (match_string (cmd, "List", BLANK_CHAR)) {
1926 char *cwhere;
1927 int n = get_num_arg (cmd, &cwhere);
1928 int m = get_num_arg (cwhere, NO_VAR);
1929 if (m == NOT_A_NUM) {
1930 if (n > 0) {
1931 list (A68_STDOUT, p, n, 0);
1932 } else if (n == NOT_A_NUM) {
1933 list (A68_STDOUT, p, 10, 0);
1934 }
1935 } else if (n > 0 && m > 0 && n <= m) {
1936 list (A68_STDOUT, p, n, m);
1937 }
1938 return A68_FALSE;
1939 } else if (match_string (cmd, "PROmpt", BLANK_CHAR)) {
1940 char *sym = cmd;
1941 SKIP_ONE_SYMBOL (sym);
1942 if (sym[0] != NULL_CHAR) {
1943 if (sym[0] == QUOTE_CHAR) {
1944 sym++;
1945 }
1946 if (sym[strlen (sym) - 1] == QUOTE_CHAR) {
1947 sym[strlen (sym) - 1] = NULL_CHAR;
1948 }
1949 a68_bufcpy (A68_MON (prompt), sym, BUFFER_SIZE);
1950 }
1951 return A68_FALSE;
1952 } else if (match_string (cmd, "RERun", NULL_CHAR) || match_string (cmd, "REStart", NULL_CHAR)) {
1953 if (confirm_exit ()) {
1954 exit_genie (p, A68_RERUN);
1955 }
1956 return A68_FALSE;
1957 } else if (match_string (cmd, "RESET", NULL_CHAR)) {
1958 if (confirm_exit ()) {
1959 change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1960 a68_free (A68_MON (watchpoint_expression));
1961 A68_MON (watchpoint_expression) = NO_TEXT;
1962 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1963 exit_genie (p, A68_RERUN);
1964 }
1965 return A68_FALSE;
1966 } else if (match_string (cmd, "LINk", BLANK_CHAR)) {
1967 int k = get_num_arg (cmd, NO_VAR), printed = 0;
1968 if (k > 0) {
1969 stack_a68_link_dump (A68_STDOUT, A68_FP, k, &printed);
1970 } else if (k == NOT_A_NUM) {
1971 stack_a68_link_dump (A68_STDOUT, A68_FP, 3, &printed);
1972 }
1973 return A68_FALSE;
1974 } else if (match_string (cmd, "STAck", BLANK_CHAR) || match_string (cmd, "BT", BLANK_CHAR)) {
1975 int k = get_num_arg (cmd, NO_VAR), printed = 0;
1976 if (k > 0) {
1977 stack_dump (A68_STDOUT, A68_FP, k, &printed);
1978 } else if (k == NOT_A_NUM) {
1979 stack_dump (A68_STDOUT, A68_FP, 3, &printed);
1980 }
1981 return A68_FALSE;
1982 } else if (match_string (cmd, "Next", NULL_CHAR)) {
1983 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
1984 A68 (do_confirm_exit) = A68_FALSE;
1985 A68_MON (break_proc_level) = PROCEDURE_LEVEL (INFO (p));
1986 return A68_TRUE;
1987 } else if (match_string (cmd, "STEp", NULL_CHAR)) {
1988 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
1989 A68 (do_confirm_exit) = A68_FALSE;
1990 return A68_TRUE;
1991 } else if (match_string (cmd, "FINish", NULL_CHAR) || match_string (cmd, "OUT", NULL_CHAR)) {
1992 A68_MON (finish_frame_pointer) = FRAME_PARAMETERS (A68_FP);
1993 A68 (do_confirm_exit) = A68_FALSE;
1994 return A68_TRUE;
1995 } else if (match_string (cmd, "Until", BLANK_CHAR)) {
1996 int k = get_num_arg (cmd, NO_VAR);
1997 if (k > 0) {
1998 BOOL_T set = A68_FALSE;
1999 change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, k, &set, NULL);
2000 if (set == A68_FALSE) {
2001 monitor_error ("cannot set breakpoint in that line", NO_TEXT);
2002 return A68_FALSE;
2003 }
2004 A68 (do_confirm_exit) = A68_FALSE;
2005 return A68_TRUE;
2006 } else {
2007 monitor_error ("line number expected", NO_TEXT);
2008 return A68_FALSE;
2009 }
2010 } else if (match_string (cmd, "Where", NULL_CHAR)) {
2011 WIS (p);
2012 return A68_FALSE;
2013 } else if (strcmp (cmd, "?") == 0) {
2014 apropos (A68_STDOUT, A68_MON (prompt), "monitor");
2015 return A68_FALSE;
2016 } else if (match_string (cmd, "Sizes", NULL_CHAR)) {
2017 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Frame stack pointer=" A68_LU " available=" A68_LU, A68_FP, A68 (frame_stack_size) - A68_FP) >= 0);
2018 WRITELN (A68_STDOUT, A68 (output_line));
2019 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Expression stack pointer=" A68_LU " available=" A68_LU, A68_SP, (UNSIGNED_T) (A68 (expr_stack_size) - A68_SP)) >= 0);
2020 WRITELN (A68_STDOUT, A68 (output_line));
2021 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Heap size=%u available=%u", A68 (heap_size), heap_available ()) >= 0);
2022 WRITELN (A68_STDOUT, A68 (output_line));
2023 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Garbage collections=" A68_LD, A68_GC (sweeps)) >= 0);
2024 WRITELN (A68_STDOUT, A68 (output_line));
2025 return A68_FALSE;
2026 } else if (match_string (cmd, "XRef", NULL_CHAR)) {
2027 int k = LINE_NUMBER (p);
2028 for (LINE_T *line = TOP_LINE (&A68_JOB); line != NO_LINE; FORWARD (line)) {
2029 if (NUMBER (line) > 0 && NUMBER (line) == k) {
2030 list_source_line (A68_STDOUT, line, A68_TRUE);
2031 }
2032 }
2033 return A68_FALSE;
2034 } else if (match_string (cmd, "XRef", BLANK_CHAR)) {
2035 int k = get_num_arg (cmd, NO_VAR);
2036 if (k == NOT_A_NUM) {
2037 monitor_error ("line number expected", NO_TEXT);
2038 } else {
2039 for (LINE_T *line = TOP_LINE (&A68_JOB); line != NO_LINE; FORWARD (line)) {
2040 if (NUMBER (line) > 0 && NUMBER (line) == k) {
2041 list_source_line (A68_STDOUT, line, A68_TRUE);
2042 }
2043 }
2044 }
2045 return A68_FALSE;
2046 } else if (strlen (cmd) == 0) {
2047 return A68_FALSE;
2048 } else {
2049 monitor_error ("unrecognised command", NO_TEXT);
2050 return A68_FALSE;
2051 }
2052 }
2053
2054 //! @brief Evaluate conditional breakpoint expression.
2055
2056 BOOL_T evaluate_breakpoint_expression (NODE_T * p)
2057 {
2058 ADDR_T top_sp = A68_SP;
2059 volatile BOOL_T res = A68_FALSE;
2060 A68_MON (mon_errors) = 0;
2061 if (EXPR (INFO (p)) != NO_TEXT) {
2062 evaluate (A68_STDOUT, p, EXPR (INFO (p)));
2063 if (A68_MON (_m_sp) != 1 || A68_MON (mon_errors) != 0) {
2064 A68_MON (mon_errors) = 0;
2065 monitor_error ("deleted invalid breakpoint expression", NO_TEXT);
2066 a68_free (EXPR (INFO (p)));
2067 EXPR (INFO (p)) = A68_MON (expr);
2068 res = A68_TRUE;
2069 } else if (TOP_MODE == M_BOOL) {
2070 A68_BOOL z;
2071 POP_OBJECT (p, &z, A68_BOOL);
2072 res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE);
2073 } else {
2074 monitor_error ("deleted invalid breakpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
2075 a68_free (EXPR (INFO (p)));
2076 EXPR (INFO (p)) = A68_MON (expr);
2077 res = A68_TRUE;
2078 }
2079 }
2080 A68_SP = top_sp;
2081 return res;
2082 }
2083
2084 //! @brief Evaluate conditional watchpoint expression.
2085
2086 BOOL_T evaluate_watchpoint_expression (NODE_T * p)
2087 {
2088 ADDR_T top_sp = A68_SP;
2089 volatile BOOL_T res = A68_FALSE;
2090 A68_MON (mon_errors) = 0;
2091 if (A68_MON (watchpoint_expression) != NO_TEXT) {
2092 evaluate (A68_STDOUT, p, A68_MON (watchpoint_expression));
2093 if (A68_MON (_m_sp) != 1 || A68_MON (mon_errors) != 0) {
2094 A68_MON (mon_errors) = 0;
2095 monitor_error ("deleted invalid watchpoint expression", NO_TEXT);
2096 a68_free (A68_MON (watchpoint_expression));
2097 A68_MON (watchpoint_expression) = NO_TEXT;
2098 res = A68_TRUE;
2099 }
2100 if (TOP_MODE == M_BOOL) {
2101 A68_BOOL z;
2102 POP_OBJECT (p, &z, A68_BOOL);
2103 res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE);
2104 } else {
2105 monitor_error ("deleted invalid watchpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
2106 a68_free (A68_MON (watchpoint_expression));
2107 A68_MON (watchpoint_expression) = NO_TEXT;
2108 res = A68_TRUE;
2109 }
2110 }
2111 A68_SP = top_sp;
2112 return res;
2113 }
2114
2115 //! @brief Execute monitor.
2116
2117 void single_step (NODE_T * p, unt mask)
2118 {
2119 volatile BOOL_T do_cmd = A68_TRUE;
2120 ADDR_T top_sp = A68_SP;
2121 A68_MON (current_frame) = 0;
2122 A68_MON (max_row_elems) = MAX_ROW_ELEMS;
2123 A68_MON (mon_errors) = 0;
2124 A68_MON (tabs) = 0;
2125 A68_MON (prompt_set) = A68_FALSE;
2126 if (LINE_NUMBER (p) == 0) {
2127 return;
2128 }
2129 #if defined (HAVE_CURSES)
2130 genie_curses_end (NO_NODE);
2131 #endif
2132 if (mask == (unt) BREAKPOINT_ERROR_MASK) {
2133 WRITELN (A68_STDOUT, "Monitor entered after an error");
2134 WIS ((p));
2135 } else if ((mask & BREAKPOINT_INTERRUPT_MASK) != 0) {
2136 WRITELN (A68_STDOUT, NEWLINE_STRING);
2137 WIS ((p));
2138 if (A68 (do_confirm_exit) && confirm_exit ()) {
2139 exit_genie ((p), A68_RUNTIME_ERROR + A68_FORCE_QUIT);
2140 }
2141 } else if ((mask & BREAKPOINT_MASK) != 0) {
2142 if (EXPR (INFO (p)) != NO_TEXT) {
2143 if (!evaluate_breakpoint_expression (p)) {
2144 return;
2145 }
2146 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Breakpoint (%s)", EXPR (INFO (p))) >= 0);
2147 } else {
2148 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Breakpoint") >= 0);
2149 }
2150 WRITELN (A68_STDOUT, A68 (output_line));
2151 WIS (p);
2152 } else if ((mask & BREAKPOINT_TEMPORARY_MASK) != 0) {
2153 if (A68_MON (break_proc_level) != 0 && PROCEDURE_LEVEL (INFO (p)) > A68_MON (break_proc_level)) {
2154 return;
2155 }
2156 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_FALSE);
2157 WRITELN (A68_STDOUT, "Temporary breakpoint (now removed)");
2158 WIS (p);
2159 } else if ((mask & BREAKPOINT_WATCH_MASK) != 0) {
2160 if (!evaluate_watchpoint_expression (p)) {
2161 return;
2162 }
2163 if (A68_MON (watchpoint_expression) != NO_TEXT) {
2164 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Watchpoint (%s)", A68_MON (watchpoint_expression)) >= 0);
2165 } else {
2166 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Watchpoint (now removed)") >= 0);
2167 }
2168 WRITELN (A68_STDOUT, A68 (output_line));
2169 WIS (p);
2170 } else if ((mask & BREAKPOINT_TRACE_MASK) != 0) {
2171 PROP_T *prop = &GPROP (p);
2172 WIS ((p));
2173 if (propagator_name ((const PROP_PROC *) UNIT (prop)) != NO_TEXT) {
2174 WRITELN (A68_STDOUT, propagator_name ((const PROP_PROC *) UNIT (prop)));
2175 }
2176 return;
2177 } else {
2178 WRITELN (A68_STDOUT, "Monitor entered with no valid reason (continuing execution)");
2179 WIS ((p));
2180 return;
2181 }
2182 #if defined (BUILD_PARALLEL_CLAUSE)
2183 if (is_main_thread ()) {
2184 WRITELN (A68_STDOUT, "This is the main thread");
2185 } else {
2186 WRITELN (A68_STDOUT, "This is not the main thread");
2187 }
2188 #endif
2189 // Entry into the monitor.
2190 if (A68_MON (prompt_set) == A68_FALSE) {
2191 a68_bufcpy (A68_MON (prompt), "(a68g) ", BUFFER_SIZE);
2192 A68_MON (prompt_set) = A68_TRUE;
2193 }
2194 A68_MON (in_monitor) = A68_TRUE;
2195 A68_MON (break_proc_level) = 0;
2196 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE);
2197 STATUS_CLEAR (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK);
2198 while (do_cmd) {
2199 char *cmd;
2200 A68_SP = top_sp;
2201 io_close_tty_line ();
2202 while (strlen (cmd = read_string_from_tty (A68_MON (prompt))) == 0) {;
2203 }
2204 if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) {
2205 a68_bufcpy (cmd, LOGOUT_STRING, BUFFER_SIZE);
2206 WRITE (A68_STDOUT, LOGOUT_STRING);
2207 WRITE (A68_STDOUT, NEWLINE_STRING);
2208 }
2209 A68_MON (_m_sp) = 0;
2210 do_cmd = (BOOL_T) (!single_stepper (p, cmd));
2211 }
2212 A68_SP = top_sp;
2213 A68_MON (in_monitor) = A68_FALSE;
2214 if (mask == (unt) BREAKPOINT_ERROR_MASK) {
2215 WRITELN (A68_STDOUT, "Continuing from an error might corrupt things");
2216 single_step (p, (unt) BREAKPOINT_ERROR_MASK);
2217 } else {
2218 WRITELN (A68_STDOUT, "Continuing ...");
2219 WRITELN (A68_STDOUT, "");
2220 }
2221 }
2222
2223 //! @brief PROC debug = VOID
2224
2225 void genie_debug (NODE_T * p)
2226 {
2227 single_step (p, BREAKPOINT_INTERRUPT_MASK);
2228 }
2229
2230 //! @brief PROC break = VOID
2231
2232 void genie_break (NODE_T * p)
2233 {
2234 (void) p;
2235 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
2236 }
2237
2238 //! @brief PROC evaluate = (STRING) STRING
2239
2240 void genie_evaluate (NODE_T * p)
2241 {
2242 // Pop argument.
2243 A68_REF u;
2244 POP_REF (p, (A68_REF *) & u);
2245 volatile ADDR_T top_sp = A68_SP;
2246 CHECK_MON_REF (p, u, M_STRING);
2247 reset_transput_buffer (UNFORMATTED_BUFFER);
2248 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u);
2249 A68_REF v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
2250 // Evaluate in the monitor.
2251 A68_MON (in_monitor) = A68_TRUE;
2252 A68_MON (mon_errors) = 0;
2253 evaluate (A68_STDOUT, p, get_transput_buffer (UNFORMATTED_BUFFER));
2254 A68_MON (in_monitor) = A68_FALSE;
2255 if (A68_MON (_m_sp) != 1) {
2256 monitor_error ("invalid expression", NO_TEXT);
2257 }
2258 if (A68_MON (mon_errors) == 0) {
2259 MOID_T *res;
2260 BOOL_T cont = A68_TRUE;
2261 while (cont) {
2262 res = TOP_MODE;
2263 cont = (BOOL_T) (IS_REF (res) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (top_sp)));
2264 if (cont) {
2265 A68_REF w;
2266 POP_REF (p, &w);
2267 TOP_MODE = SUB (TOP_MODE);
2268 PUSH (p, ADDRESS (&w), SIZE (TOP_MODE));
2269 }
2270 }
2271 reset_transput_buffer (UNFORMATTED_BUFFER);
2272 genie_write_standard (p, TOP_MODE, STACK_ADDRESS (top_sp), nil_ref);
2273 v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
2274 }
2275 A68_SP = top_sp;
2276 PUSH_REF (p, v);
2277 }
2278
2279 //! @brief PROC abend = (STRING) VOID
2280
2281 void genie_abend (NODE_T * p)
2282 {
2283 A68_REF u;
2284 POP_REF (p, (A68_REF *) & u);
2285 reset_transput_buffer (UNFORMATTED_BUFFER);
2286 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u);
2287 diagnostic (A68_RUNTIME_ERROR | A68_NO_SYNTHESIS, p, get_transput_buffer (UNFORMATTED_BUFFER), NO_TEXT);
2288 exit_genie (p, A68_RUNTIME_ERROR);
2289 }
