1 /* Scheme/Guile language support routines for GDB, the GNU debugger.
2
3 Copyright 1995, 1996, 2000, 2003, 2005 Free Software Foundation,
4 Inc.
5
6 This file is part of GDB.
7
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
12
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
22
23 #include "defs.h"
24 #include "symtab.h"
25 #include "gdbtypes.h"
26 #include "expression.h"
27 #include "parser-defs.h"
28 #include "language.h"
29 #include "value.h"
30 #include "c-lang.h"
31 #include "scm-lang.h"
32 #include "scm-tags.h"
33
34 #define USE_EXPRSTRING 0
35
36 static void scm_lreadparen (int);
37 static int scm_skip_ws (void);
38 static void scm_read_token (int, int);
39 static LONGEST scm_istring2number (char *, int, int);
40 static LONGEST scm_istr2int (char *, int, int);
41 static void scm_lreadr (int);
42
43 static LONGEST
scm_istr2int(char * str,int len,int radix)44 scm_istr2int (char *str, int len, int radix)
45 {
46 int i = 0;
47 LONGEST inum = 0;
48 int c;
49 int sign = 0;
50
51 if (0 >= len)
52 return SCM_BOOL_F; /* zero scm_length */
53 switch (str[0])
54 { /* leading sign */
55 case '-':
56 case '+':
57 sign = str[0];
58 if (++i == len)
59 return SCM_BOOL_F; /* bad if lone `+' or `-' */
60 }
61 do
62 {
63 switch (c = str[i++])
64 {
65 case '0':
66 case '1':
67 case '2':
68 case '3':
69 case '4':
70 case '5':
71 case '6':
72 case '7':
73 case '8':
74 case '9':
75 c = c - '0';
76 goto accumulate;
77 case 'A':
78 case 'B':
79 case 'C':
80 case 'D':
81 case 'E':
82 case 'F':
83 c = c - 'A' + 10;
84 goto accumulate;
85 case 'a':
86 case 'b':
87 case 'c':
88 case 'd':
89 case 'e':
90 case 'f':
91 c = c - 'a' + 10;
92 accumulate:
93 if (c >= radix)
94 return SCM_BOOL_F; /* bad digit for radix */
95 inum *= radix;
96 inum += c;
97 break;
98 default:
99 return SCM_BOOL_F; /* not a digit */
100 }
101 }
102 while (i < len);
103 if (sign == '-')
104 inum = -inum;
105 return SCM_MAKINUM (inum);
106 }
107
108 static LONGEST
scm_istring2number(char * str,int len,int radix)109 scm_istring2number (char *str, int len, int radix)
110 {
111 int i = 0;
112 char ex = 0;
113 char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
114 #if 0
115 SCM res;
116 #endif
117 if (len == 1)
118 if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */
119 return SCM_BOOL_F;
120
121 while ((len - i) >= 2 && str[i] == '#' && ++i)
122 switch (str[i++])
123 {
124 case 'b':
125 case 'B':
126 if (rx_p++)
127 return SCM_BOOL_F;
128 radix = 2;
129 break;
130 case 'o':
131 case 'O':
132 if (rx_p++)
133 return SCM_BOOL_F;
134 radix = 8;
135 break;
136 case 'd':
137 case 'D':
138 if (rx_p++)
139 return SCM_BOOL_F;
140 radix = 10;
141 break;
142 case 'x':
143 case 'X':
144 if (rx_p++)
145 return SCM_BOOL_F;
146 radix = 16;
147 break;
148 case 'i':
149 case 'I':
150 if (ex_p++)
151 return SCM_BOOL_F;
152 ex = 2;
153 break;
154 case 'e':
155 case 'E':
156 if (ex_p++)
157 return SCM_BOOL_F;
158 ex = 1;
159 break;
160 default:
161 return SCM_BOOL_F;
162 }
163
164 switch (ex)
165 {
166 case 1:
167 return scm_istr2int (&str[i], len - i, radix);
168 case 0:
169 return scm_istr2int (&str[i], len - i, radix);
170 #if 0
171 if NFALSEP
172 (res) return res;
173 #ifdef FLOATS
174 case 2:
175 return scm_istr2flo (&str[i], len - i, radix);
176 #endif
177 #endif
178 }
179 return SCM_BOOL_F;
180 }
181
182 static void
scm_read_token(int c,int weird)183 scm_read_token (int c, int weird)
184 {
185 while (1)
186 {
187 c = *lexptr++;
188 switch (c)
189 {
190 case '[':
191 case ']':
192 case '(':
193 case ')':
194 case '\"':
195 case ';':
196 case ' ':
197 case '\t':
198 case '\r':
199 case '\f':
200 case '\n':
201 if (weird)
202 goto default_case;
203 case '\0': /* End of line */
204 eof_case:
205 --lexptr;
206 return;
207 case '\\':
208 if (!weird)
209 goto default_case;
210 else
211 {
212 c = *lexptr++;
213 if (c == '\0')
214 goto eof_case;
215 else
216 goto default_case;
217 }
218 case '}':
219 if (!weird)
220 goto default_case;
221
222 c = *lexptr++;
223 if (c == '#')
224 return;
225 else
226 {
227 --lexptr;
228 c = '}';
229 goto default_case;
230 }
231
232 default:
233 default_case:
234 ;
235 }
236 }
237 }
238
239 static int
scm_skip_ws(void)240 scm_skip_ws (void)
241 {
242 int c;
243 while (1)
244 switch ((c = *lexptr++))
245 {
246 case '\0':
247 goteof:
248 return c;
249 case ';':
250 lp:
251 switch ((c = *lexptr++))
252 {
253 case '\0':
254 goto goteof;
255 default:
256 goto lp;
257 case '\n':
258 break;
259 }
260 case ' ':
261 case '\t':
262 case '\r':
263 case '\f':
264 case '\n':
265 break;
266 default:
267 return c;
268 }
269 }
270
271 static void
scm_lreadparen(int skipping)272 scm_lreadparen (int skipping)
273 {
274 for (;;)
275 {
276 int c = scm_skip_ws ();
277 if (')' == c || ']' == c)
278 return;
279 --lexptr;
280 if (c == '\0')
281 error ("missing close paren");
282 scm_lreadr (skipping);
283 }
284 }
285
286 static void
scm_lreadr(int skipping)287 scm_lreadr (int skipping)
288 {
289 int c, j;
290 struct stoken str;
291 LONGEST svalue = 0;
292 tryagain:
293 c = *lexptr++;
294 switch (c)
295 {
296 case '\0':
297 lexptr--;
298 return;
299 case '[':
300 case '(':
301 scm_lreadparen (skipping);
302 return;
303 case ']':
304 case ')':
305 error ("unexpected #\\%c", c);
306 goto tryagain;
307 case '\'':
308 case '`':
309 str.ptr = lexptr - 1;
310 scm_lreadr (skipping);
311 if (!skipping)
312 {
313 struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
314 if (!is_scmvalue_type (value_type (val)))
315 error ("quoted scm form yields non-SCM value");
316 svalue = extract_signed_integer (value_contents (val),
317 TYPE_LENGTH (value_type (val)));
318 goto handle_immediate;
319 }
320 return;
321 case ',':
322 c = *lexptr++;
323 if ('@' != c)
324 lexptr--;
325 scm_lreadr (skipping);
326 return;
327 case '#':
328 c = *lexptr++;
329 switch (c)
330 {
331 case '[':
332 case '(':
333 scm_lreadparen (skipping);
334 return;
335 case 't':
336 case 'T':
337 svalue = SCM_BOOL_T;
338 goto handle_immediate;
339 case 'f':
340 case 'F':
341 svalue = SCM_BOOL_F;
342 goto handle_immediate;
343 case 'b':
344 case 'B':
345 case 'o':
346 case 'O':
347 case 'd':
348 case 'D':
349 case 'x':
350 case 'X':
351 case 'i':
352 case 'I':
353 case 'e':
354 case 'E':
355 lexptr--;
356 c = '#';
357 goto num;
358 case '*': /* bitvector */
359 scm_read_token (c, 0);
360 return;
361 case '{':
362 scm_read_token (c, 1);
363 return;
364 case '\\': /* character */
365 c = *lexptr++;
366 scm_read_token (c, 0);
367 return;
368 case '|':
369 j = 1; /* here j is the comment nesting depth */
370 lp:
371 c = *lexptr++;
372 lpc:
373 switch (c)
374 {
375 case '\0':
376 error ("unbalanced comment");
377 default:
378 goto lp;
379 case '|':
380 if ('#' != (c = *lexptr++))
381 goto lpc;
382 if (--j)
383 goto lp;
384 break;
385 case '#':
386 if ('|' != (c = *lexptr++))
387 goto lpc;
388 ++j;
389 goto lp;
390 }
391 goto tryagain;
392 case '.':
393 default:
394 #if 0
395 callshrp:
396 #endif
397 scm_lreadr (skipping);
398 return;
399 }
400 case '\"':
401 while ('\"' != (c = *lexptr++))
402 {
403 if (c == '\\')
404 switch (c = *lexptr++)
405 {
406 case '\0':
407 error ("non-terminated string literal");
408 case '\n':
409 continue;
410 case '0':
411 case 'f':
412 case 'n':
413 case 'r':
414 case 't':
415 case 'a':
416 case 'v':
417 break;
418 }
419 }
420 return;
421 case '0':
422 case '1':
423 case '2':
424 case '3':
425 case '4':
426 case '5':
427 case '6':
428 case '7':
429 case '8':
430 case '9':
431 case '.':
432 case '-':
433 case '+':
434 num:
435 {
436 str.ptr = lexptr - 1;
437 scm_read_token (c, 0);
438 if (!skipping)
439 {
440 svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
441 if (svalue != SCM_BOOL_F)
442 goto handle_immediate;
443 goto tok;
444 }
445 }
446 return;
447 case ':':
448 scm_read_token ('-', 0);
449 return;
450 #if 0
451 do_symbol:
452 #endif
453 default:
454 str.ptr = lexptr - 1;
455 scm_read_token (c, 0);
456 tok:
457 if (!skipping)
458 {
459 str.length = lexptr - str.ptr;
460 if (str.ptr[0] == '$')
461 {
462 write_dollar_variable (str);
463 return;
464 }
465 write_exp_elt_opcode (OP_NAME);
466 write_exp_string (str);
467 write_exp_elt_opcode (OP_NAME);
468 }
469 return;
470 }
471 handle_immediate:
472 if (!skipping)
473 {
474 write_exp_elt_opcode (OP_LONG);
475 write_exp_elt_type (builtin_type_scm);
476 write_exp_elt_longcst (svalue);
477 write_exp_elt_opcode (OP_LONG);
478 }
479 }
480
481 int
scm_parse(void)482 scm_parse (void)
483 {
484 char *start;
485 while (*lexptr == ' ')
486 lexptr++;
487 start = lexptr;
488 scm_lreadr (USE_EXPRSTRING);
489 #if USE_EXPRSTRING
490 str.length = lexptr - start;
491 str.ptr = start;
492 write_exp_elt_opcode (OP_EXPRSTRING);
493 write_exp_string (str);
494 write_exp_elt_opcode (OP_EXPRSTRING);
495 #endif
496 return 0;
497 }
498