1.0.22.22: (SETF FIND-CLASSOID) to drop DEFTYPE lambda-lists and source-locations
[sbcl/tcr.git] / src / runtime / parse.c
blobb4218e51fa9b030d1f2802b1b8394f893d202420
1 /* parsing for LDB monitor */
3 /*
4 * This software is part of the SBCL system. See the README file for
5 * more information.
7 * This software is derived from the CMU CL system, which was
8 * written at Carnegie Mellon University and released into the
9 * public domain. The software is in the public domain and is
10 * provided with absolutely no warranty. See the COPYING and CREDITS
11 * files for more information.
14 #include <stdio.h>
15 #include <stdlib.h>
16 #include <ctype.h>
17 #include <signal.h>
19 #include "sbcl.h"
20 #include "runtime.h"
22 #if defined(LISP_FEATURE_SB_LDB)
24 #include "globals.h"
25 #include "vars.h"
26 #include "parse.h"
27 #include "os.h"
28 #include "interrupt.h"
29 #include "lispregs.h"
30 #include "monitor.h"
31 #include "validate.h"
32 #include "arch.h"
33 #include "search.h"
34 #include "thread.h"
36 #include "genesis/simple-fun.h"
37 #include "genesis/fdefn.h"
38 #include "genesis/symbol.h"
39 #include "genesis/static-symbols.h"
41 static void skip_ws(char **ptr)
43 while (**ptr <= ' ' && **ptr != '\0')
44 (*ptr)++;
47 static boolean string_to_long(char *token, long *value)
49 int base, digit;
50 long num;
51 char *ptr;
53 if (token == 0)
54 return 0;
56 if (token[0] == '0')
57 if (token[1] == 'x') {
58 base = 16;
59 token += 2;
61 else {
62 base = 8;
63 token++;
65 else if (token[0] == '#') {
66 switch (token[1]) {
67 case 'x':
68 case 'X':
69 base = 16;
70 token += 2;
71 break;
72 case 'o':
73 case 'O':
74 base = 8;
75 token += 2;
76 break;
77 default:
78 return 0;
81 else
82 base = 10;
84 num = 0;
85 ptr = token;
86 while (*ptr != '\0') {
87 if (*ptr >= 'a' && *ptr <= 'f')
88 digit = *ptr + 10 - 'a';
89 else if (*ptr >= 'A' && *ptr <= 'F')
90 digit = *ptr + 10 - 'A';
91 else if (*ptr >= '0' && *ptr <= '9')
92 digit = *ptr - '0';
93 else
94 return 0;
95 if (digit < 0 || digit >= base)
96 return 0;
98 ptr++;
99 num = num * base + digit;
102 *value = num;
103 return 1;
106 static boolean lookup_variable(char *name, lispobj *result)
108 struct var *var = lookup_by_name(name);
110 if (var == NULL)
111 return 0;
112 else {
113 *result = var_value(var);
114 return 1;
119 boolean more_p(ptr)
120 char **ptr;
122 skip_ws(ptr);
124 if (**ptr == '\0')
125 return 0;
126 else
127 return 1;
130 char *parse_token(ptr)
131 char **ptr;
133 char *token;
135 skip_ws(ptr);
137 if (**ptr == '\0')
138 return NULL;
140 token = *ptr;
142 while (**ptr > ' ')
143 (*ptr)++;
145 if (**ptr != '\0') {
146 **ptr = '\0';
147 (*ptr)++;
150 return token;
153 #if 0
154 static boolean number_p(token)
155 char *token;
157 char *okay;
159 if (token == NULL)
160 return 0;
162 okay = "abcdefABCDEF987654321d0";
164 if (token[0] == '0')
165 if (token[1] == 'x' || token[1] == 'X')
166 token += 2;
167 else {
168 token++;
169 okay += 14;
171 else if (token[0] == '#') {
172 switch (token[1]) {
173 case 'x':
174 case 'X':
175 break;
176 case 'o':
177 case 'O':
178 okay += 14;
179 break;
180 default:
181 return 0;
184 else
185 okay += 12;
187 while (*token != '\0')
188 if (index(okay, *token++) == NULL)
189 return 0;
190 return 1;
192 #endif
194 long parse_number(ptr)
195 char **ptr;
197 char *token = parse_token(ptr);
198 long result;
200 if (token == NULL) {
201 printf("expected a number\n");
202 throw_to_monitor();
204 else if (string_to_long(token, &result))
205 return result;
206 else {
207 printf("invalid number: ``%s''\n", token);
208 throw_to_monitor();
210 return 0;
213 char *parse_addr(ptr)
214 char **ptr;
216 char *token = parse_token(ptr);
217 lispobj result;
219 if (token == NULL) {
220 printf("expected an address\n");
221 throw_to_monitor();
223 else if (token[0] == '$') {
224 if (!lookup_variable(token+1, &result)) {
225 printf("unknown variable: ``%s''\n", token);
226 throw_to_monitor();
228 result &= ~7;
230 else {
231 long value;
232 if (!string_to_long(token, &value)) {
233 printf("invalid number: ``%s''\n", token);
234 throw_to_monitor();
236 result = (value & ~3);
239 if (!is_valid_lisp_addr((os_vm_address_t)result)) {
240 printf("invalid Lisp-level address: %p\n", (void *)result);
241 throw_to_monitor();
244 return (char *)result;
247 static boolean lookup_symbol(char *name, lispobj *result)
249 int count;
250 lispobj *headerptr;
252 /* Search static space. */
253 headerptr = (lispobj *)STATIC_SPACE_START;
254 count =
255 (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0) -
256 (lispobj *)STATIC_SPACE_START;
257 if (search_for_symbol(name, &headerptr, &count)) {
258 *result = make_lispobj(headerptr,OTHER_POINTER_LOWTAG);
259 return 1;
262 /* Search dynamic space. */
263 #if defined(LISP_FEATURE_GENCGC)
264 headerptr = (lispobj *)DYNAMIC_SPACE_START;
265 count = (lispobj *)get_alloc_pointer() - headerptr;
266 #else
267 headerptr = (lispobj *)current_dynamic_space;
268 count = dynamic_space_free_pointer - headerptr;
269 #endif
271 if (search_for_symbol(name, &headerptr, &count)) {
272 *result = make_lispobj(headerptr, OTHER_POINTER_LOWTAG);
273 return 1;
276 return 0;
279 static int
280 parse_regnum(char *s)
282 if ((s[1] == 'R') || (s[1] == 'r')) {
283 int regnum;
285 if (s[2] == '\0')
286 return -1;
288 /* skip the $R part and call atoi on the number */
289 regnum = atoi(s + 2);
290 if ((regnum >= 0) && (regnum < NREGS))
291 return regnum;
292 else
293 return -1;
294 } else {
295 int i;
297 for (i = 0; i < NREGS ; i++)
298 if (strcasecmp(s + 1, lisp_register_names[i]) == 0)
299 #ifdef LISP_FEATURE_X86
300 return i*2;
301 #else
302 return i;
303 #endif
305 return -1;
309 lispobj parse_lispobj(ptr)
310 char **ptr;
312 struct thread *thread=arch_os_get_current_thread();
313 char *token = parse_token(ptr);
314 long pointer;
315 lispobj result;
316 long value;
318 if (token == NULL) {
319 printf("expected an object\n");
320 throw_to_monitor();
321 } else if (token[0] == '$') {
322 if (isalpha(token[1])) {
323 int free_ici;
324 int regnum;
325 os_context_t *context;
327 free_ici = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread));
329 if (free_ici == 0) {
330 printf("Variable ``%s'' is not valid -- there is no current interrupt context.\n", token);
331 throw_to_monitor();
334 context = thread->interrupt_contexts[free_ici - 1];
336 regnum = parse_regnum(token);
337 if (regnum < 0) {
338 printf("bogus register: ``%s''\n", token);
339 throw_to_monitor();
342 result = *os_context_register_addr(context, regnum);
343 } else if (!lookup_variable(token+1, &result)) {
344 printf("unknown variable: ``%s''\n", token);
345 throw_to_monitor();
347 } else if (token[0] == '@') {
348 if (string_to_long(token+1, &pointer)) {
349 pointer &= ~3;
350 if (is_valid_lisp_addr((os_vm_address_t)pointer))
351 result = *(lispobj *)pointer;
352 else {
353 printf("invalid Lisp-level address: ``%s''\n", token+1);
354 throw_to_monitor();
357 else {
358 printf("invalid address: ``%s''\n", token+1);
359 throw_to_monitor();
362 else if (string_to_long(token, &value))
363 result = value;
364 else if (lookup_symbol(token, &result))
366 else {
367 printf("invalid Lisp object: ``%s''\n", token);
368 throw_to_monitor();
371 return result;
374 #endif /* defined(LISP_FEATURE_SB_LDB) */