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