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