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