Fix make-array transforms.
[sbcl.git] / src / runtime / parse.c
1 /* parsing for LDB monitor */
2
3 /*
4  * This software is part of the SBCL system. See the README file for
5  * more information.
6  *
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.
12  */
13
14 #include <stdio.h>
15 #include <stdlib.h>
16 #include <ctype.h>
17
18 #include "sbcl.h"
19 #if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD)
20 #include "pthreads_win32.h"
21 #else
22 #include <signal.h>
23 #endif
24 #include "runtime.h"
25
26 #if defined(LISP_FEATURE_SB_LDB)
27
28 #include "globals.h"
29 #include "vars.h"
30 #include "parse.h"
31 #include "os.h"
32 #include "interrupt.h"
33 #include "lispregs.h"
34 #include "monitor.h"
35 #include "validate.h"
36 #include "arch.h"
37 #include "search.h"
38 #include "thread.h"
39 #include "pseudo-atomic.h"
40
41 #include "genesis/simple-fun.h"
42 #include "genesis/fdefn.h"
43 #include "genesis/symbol.h"
44 #include "genesis/static-symbols.h"
45
46 static void skip_ws(char **ptr)
47 {
48     while (**ptr <= ' ' && **ptr != '\0')
49         (*ptr)++;
50 }
51
52 static boolean string_to_long(char *token, uword_t *value)
53 {
54     int base, digit;
55     uword_t num;
56     char *ptr;
57
58     if (token == 0)
59         return 0;
60
61     if (token[0] == '0')
62         if (token[1] == 'x') {
63             base = 16;
64             token += 2;
65         }
66         else {
67             base = 8;
68             token++;
69         }
70     else if (token[0] == '#') {
71         switch (token[1]) {
72             case 'x':
73             case 'X':
74                 base = 16;
75                 token += 2;
76                 break;
77             case 'o':
78             case 'O':
79                 base = 8;
80                 token += 2;
81                 break;
82             default:
83                 return 0;
84         }
85     }
86     else
87         base = 10;
88
89     num = 0;
90     ptr = token;
91     while (*ptr != '\0') {
92         if (*ptr >= 'a' && *ptr <= 'f')
93             digit = *ptr + 10 - 'a';
94         else if (*ptr >= 'A' && *ptr <= 'F')
95             digit = *ptr + 10 - 'A';
96         else if (*ptr >= '0' && *ptr <= '9')
97             digit = *ptr - '0';
98         else
99             return 0;
100         if (digit < 0 || digit >= base)
101             return 0;
102
103         ptr++;
104         num = num * base + digit;
105     }
106
107     *value = num;
108     return 1;
109 }
110
111 static boolean lookup_variable(char *name, lispobj *result)
112 {
113     struct var *var = lookup_by_name(name);
114
115     if (var == NULL)
116         return 0;
117     else {
118         *result = var_value(var);
119         return 1;
120     }
121 }
122
123
124 boolean more_p(ptr)
125 char **ptr;
126 {
127     skip_ws(ptr);
128
129     if (**ptr == '\0')
130         return 0;
131     else
132         return 1;
133 }
134
135 char *parse_token(ptr)
136 char **ptr;
137 {
138     char *token;
139
140     skip_ws(ptr);
141
142     if (**ptr == '\0')
143         return NULL;
144
145     token = *ptr;
146
147     while (**ptr > ' ')
148         (*ptr)++;
149
150     if (**ptr != '\0') {
151         **ptr = '\0';
152         (*ptr)++;
153     }
154
155     return token;
156 }
157
158 #if 0
159 static boolean number_p(token)
160 char *token;
161 {
162     char *okay;
163
164     if (token == NULL)
165         return 0;
166
167     okay = "abcdefABCDEF987654321d0";
168
169     if (token[0] == '0')
170         if (token[1] == 'x' || token[1] == 'X')
171             token += 2;
172         else {
173             token++;
174             okay += 14;
175         }
176     else if (token[0] == '#') {
177         switch (token[1]) {
178             case 'x':
179             case 'X':
180                 break;
181             case 'o':
182             case 'O':
183                 okay += 14;
184                 break;
185             default:
186                 return 0;
187         }
188     }
189     else
190         okay += 12;
191
192     while (*token != '\0')
193         if (index(okay, *token++) == NULL)
194             return 0;
195     return 1;
196 }
197 #endif
198
199 uword_t parse_number(ptr)
200 char **ptr;
201 {
202     char *token = parse_token(ptr);
203     uword_t result;
204
205     if (token == NULL) {
206         printf("expected a number\n");
207         throw_to_monitor();
208     }
209     else if (string_to_long(token, &result))
210         return result;
211     else {
212         printf("invalid number: ``%s''\n", token);
213         throw_to_monitor();
214     }
215     return 0;
216 }
217
218 char *parse_addr(ptr)
219 char **ptr;
220 {
221     char *token = parse_token(ptr);
222     lispobj result;
223
224     if (token == NULL) {
225         printf("expected an address\n");
226         throw_to_monitor();
227     }
228     else if (token[0] == '$') {
229         if (!lookup_variable(token+1, &result)) {
230             printf("unknown variable: ``%s''\n", token);
231             throw_to_monitor();
232         }
233         result &= ~7;
234     }
235     else {
236         uword_t value;
237         if (!string_to_long(token, &value)) {
238             printf("invalid number: ``%s''\n", token);
239             throw_to_monitor();
240         }
241         result = (value & ~3);
242     }
243
244     if (!is_valid_lisp_addr((os_vm_address_t)result)) {
245         printf("invalid Lisp-level address: %p\n", (void *)result);
246         throw_to_monitor();
247     }
248
249     return (char *)result;
250 }
251
252 static boolean lookup_symbol(char *name, lispobj *result)
253 {
254     int count;
255     lispobj *headerptr;
256
257     /* Search static space. */
258     headerptr = (lispobj *)STATIC_SPACE_START;
259     count =
260         (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0) -
261         (lispobj *)STATIC_SPACE_START;
262     if (search_for_symbol(name, &headerptr, &count)) {
263         *result = make_lispobj(headerptr,OTHER_POINTER_LOWTAG);
264         return 1;
265     }
266
267     /* Search dynamic space. */
268 #if defined(LISP_FEATURE_GENCGC)
269     headerptr = (lispobj *)DYNAMIC_SPACE_START;
270     count = (lispobj *)get_alloc_pointer() - headerptr;
271 #else
272     headerptr = (lispobj *)current_dynamic_space;
273     count = dynamic_space_free_pointer - headerptr;
274 #endif
275
276     if (search_for_symbol(name, &headerptr, &count)) {
277         *result = make_lispobj(headerptr, OTHER_POINTER_LOWTAG);
278         return 1;
279     }
280
281     return 0;
282 }
283
284 static int
285 parse_regnum(char *s)
286 {
287     if ((s[1] == 'R') || (s[1] == 'r')) {
288         int regnum;
289
290         if (s[2] == '\0')
291             return -1;
292
293         /* skip the $R part and call atoi on the number */
294         regnum = atoi(s + 2);
295         if ((regnum >= 0) && (regnum < NREGS))
296             return regnum;
297         else
298             return -1;
299     } else {
300         int i;
301
302         for (i = 0; i < NREGS ; i++)
303             if (strcasecmp(s + 1, lisp_register_names[i]) == 0)
304 #ifdef LISP_FEATURE_X86
305                 return i*2;
306 #else
307         return i;
308 #endif
309
310         return -1;
311     }
312 }
313
314 lispobj parse_lispobj(ptr)
315 char **ptr;
316 {
317     struct thread *thread=arch_os_get_current_thread();
318     char *token = parse_token(ptr);
319     uword_t pointer;
320     lispobj result;
321     uword_t value;
322
323     if (token == NULL) {
324         printf("expected an object\n");
325         throw_to_monitor();
326     } else if (token[0] == '$') {
327         if (isalpha(token[1])) {
328             int free_ici;
329             int regnum;
330             os_context_t *context;
331
332             free_ici = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread));
333
334             if (free_ici == 0) {
335                 printf("Variable ``%s'' is not valid -- there is no current interrupt context.\n", token);
336                 throw_to_monitor();
337             }
338
339             context = thread->interrupt_contexts[free_ici - 1];
340
341             regnum = parse_regnum(token);
342             if (regnum < 0) {
343                 printf("bogus register: ``%s''\n", token);
344                 throw_to_monitor();
345             }
346
347             result = *os_context_register_addr(context, regnum);
348         } else if (!lookup_variable(token+1, &result)) {
349             printf("unknown variable: ``%s''\n", token);
350             throw_to_monitor();
351         }
352     } else if (token[0] == '@') {
353         if (string_to_long(token+1, &pointer)) {
354             pointer &= ~3;
355             if (is_valid_lisp_addr((os_vm_address_t)pointer))
356                 result = *(lispobj *)pointer;
357             else {
358                 printf("invalid Lisp-level address: ``%s''\n", token+1);
359                 throw_to_monitor();
360             }
361         }
362         else {
363             printf("invalid address: ``%s''\n", token+1);
364             throw_to_monitor();
365         }
366     }
367     else if (string_to_long(token, &value))
368         result = value;
369     else if (lookup_symbol(token, &result))
370         ;
371     else {
372         printf("invalid Lisp object: ``%s''\n", token);
373         throw_to_monitor();
374     }
375
376     return result;
377 }
378
379 #endif /* defined(LISP_FEATURE_SB_LDB) */