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 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 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 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 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 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 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 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