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