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