119370Spst/* Scheme/Guile language support routines for GDB, the GNU debugger. 219370Spst 3130803Smarcel Copyright 1995, 1996, 2000, 2003 Free Software Foundation, Inc. 4130803Smarcel 598944Sobrien This file is part of GDB. 619370Spst 798944Sobrien This program is free software; you can redistribute it and/or modify 898944Sobrien it under the terms of the GNU General Public License as published by 998944Sobrien the Free Software Foundation; either version 2 of the License, or 1098944Sobrien (at your option) any later version. 1119370Spst 1298944Sobrien This program is distributed in the hope that it will be useful, 1398944Sobrien but WITHOUT ANY WARRANTY; without even the implied warranty of 1498944Sobrien MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1598944Sobrien GNU General Public License for more details. 1619370Spst 1798944Sobrien You should have received a copy of the GNU General Public License 1898944Sobrien along with this program; if not, write to the Free Software 1998944Sobrien Foundation, Inc., 59 Temple Place - Suite 330, 2098944Sobrien Boston, MA 02111-1307, USA. */ 2119370Spst 2219370Spst#include "defs.h" 2319370Spst#include "symtab.h" 2419370Spst#include "gdbtypes.h" 2519370Spst#include "expression.h" 2619370Spst#include "parser-defs.h" 2719370Spst#include "language.h" 2819370Spst#include "value.h" 2919370Spst#include "c-lang.h" 3019370Spst#include "scm-lang.h" 3119370Spst#include "scm-tags.h" 3219370Spst 3319370Spst#define USE_EXPRSTRING 0 3419370Spst 3598944Sobrienstatic void scm_lreadparen (int); 3698944Sobrienstatic int scm_skip_ws (void); 3798944Sobrienstatic void scm_read_token (int, int); 3898944Sobrienstatic LONGEST scm_istring2number (char *, int, int); 3998944Sobrienstatic LONGEST scm_istr2int (char *, int, int); 4098944Sobrienstatic void scm_lreadr (int); 4119370Spst 4246283Sdfrstatic LONGEST 4398944Sobrienscm_istr2int (char *str, int len, int radix) 4419370Spst{ 4519370Spst int i = 0; 4619370Spst LONGEST inum = 0; 4719370Spst int c; 4819370Spst int sign = 0; 4919370Spst 5098944Sobrien if (0 >= len) 5198944Sobrien return SCM_BOOL_F; /* zero scm_length */ 5219370Spst switch (str[0]) 5398944Sobrien { /* leading sign */ 5419370Spst case '-': 5519370Spst case '+': 5619370Spst sign = str[0]; 5798944Sobrien if (++i == len) 5898944Sobrien return SCM_BOOL_F; /* bad if lone `+' or `-' */ 5919370Spst } 6098944Sobrien do 6198944Sobrien { 6298944Sobrien switch (c = str[i++]) 6398944Sobrien { 6498944Sobrien case '0': 6598944Sobrien case '1': 6698944Sobrien case '2': 6798944Sobrien case '3': 6898944Sobrien case '4': 6998944Sobrien case '5': 7098944Sobrien case '6': 7198944Sobrien case '7': 7298944Sobrien case '8': 7398944Sobrien case '9': 7498944Sobrien c = c - '0'; 7598944Sobrien goto accumulate; 7698944Sobrien case 'A': 7798944Sobrien case 'B': 7898944Sobrien case 'C': 7998944Sobrien case 'D': 8098944Sobrien case 'E': 8198944Sobrien case 'F': 8298944Sobrien c = c - 'A' + 10; 8398944Sobrien goto accumulate; 8498944Sobrien case 'a': 8598944Sobrien case 'b': 8698944Sobrien case 'c': 8798944Sobrien case 'd': 8898944Sobrien case 'e': 8998944Sobrien case 'f': 9098944Sobrien c = c - 'a' + 10; 9198944Sobrien accumulate: 9298944Sobrien if (c >= radix) 9398944Sobrien return SCM_BOOL_F; /* bad digit for radix */ 9498944Sobrien inum *= radix; 9598944Sobrien inum += c; 9698944Sobrien break; 9798944Sobrien default: 9898944Sobrien return SCM_BOOL_F; /* not a digit */ 9998944Sobrien } 10019370Spst } 10198944Sobrien while (i < len); 10219370Spst if (sign == '-') 10319370Spst inum = -inum; 10419370Spst return SCM_MAKINUM (inum); 10519370Spst} 10619370Spst 10746283Sdfrstatic LONGEST 10898944Sobrienscm_istring2number (char *str, int len, int radix) 10919370Spst{ 11019370Spst int i = 0; 11119370Spst char ex = 0; 11219370Spst char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ 11346283Sdfr#if 0 11419370Spst SCM res; 11546283Sdfr#endif 11698944Sobrien if (len == 1) 11798944Sobrien if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */ 11819370Spst return SCM_BOOL_F; 11919370Spst 12098944Sobrien while ((len - i) >= 2 && str[i] == '#' && ++i) 12198944Sobrien switch (str[i++]) 12298944Sobrien { 12398944Sobrien case 'b': 12498944Sobrien case 'B': 12598944Sobrien if (rx_p++) 12698944Sobrien return SCM_BOOL_F; 12798944Sobrien radix = 2; 12898944Sobrien break; 12998944Sobrien case 'o': 13098944Sobrien case 'O': 13198944Sobrien if (rx_p++) 13298944Sobrien return SCM_BOOL_F; 13398944Sobrien radix = 8; 13498944Sobrien break; 13598944Sobrien case 'd': 13698944Sobrien case 'D': 13798944Sobrien if (rx_p++) 13898944Sobrien return SCM_BOOL_F; 13998944Sobrien radix = 10; 14098944Sobrien break; 14198944Sobrien case 'x': 14298944Sobrien case 'X': 14398944Sobrien if (rx_p++) 14498944Sobrien return SCM_BOOL_F; 14598944Sobrien radix = 16; 14698944Sobrien break; 14798944Sobrien case 'i': 14898944Sobrien case 'I': 14998944Sobrien if (ex_p++) 15098944Sobrien return SCM_BOOL_F; 15198944Sobrien ex = 2; 15298944Sobrien break; 15398944Sobrien case 'e': 15498944Sobrien case 'E': 15598944Sobrien if (ex_p++) 15698944Sobrien return SCM_BOOL_F; 15798944Sobrien ex = 1; 15898944Sobrien break; 15998944Sobrien default: 16098944Sobrien return SCM_BOOL_F; 16198944Sobrien } 16219370Spst 16398944Sobrien switch (ex) 16498944Sobrien { 16598944Sobrien case 1: 16698944Sobrien return scm_istr2int (&str[i], len - i, radix); 16798944Sobrien case 0: 16898944Sobrien return scm_istr2int (&str[i], len - i, radix); 16919370Spst#if 0 17098944Sobrien if NFALSEP 17198944Sobrien (res) return res; 17219370Spst#ifdef FLOATS 17398944Sobrien case 2: 17498944Sobrien return scm_istr2flo (&str[i], len - i, radix); 17519370Spst#endif 17619370Spst#endif 17798944Sobrien } 17819370Spst return SCM_BOOL_F; 17919370Spst} 18019370Spst 18119370Spststatic void 18298944Sobrienscm_read_token (int c, int weird) 18319370Spst{ 18419370Spst while (1) 18519370Spst { 18619370Spst c = *lexptr++; 18719370Spst switch (c) 18819370Spst { 18919370Spst case '[': 19019370Spst case ']': 19119370Spst case '(': 19219370Spst case ')': 19319370Spst case '\"': 19419370Spst case ';': 19598944Sobrien case ' ': 19698944Sobrien case '\t': 19798944Sobrien case '\r': 19898944Sobrien case '\f': 19919370Spst case '\n': 20019370Spst if (weird) 20119370Spst goto default_case; 20298944Sobrien case '\0': /* End of line */ 20319370Spst eof_case: 20419370Spst --lexptr; 20519370Spst return; 20619370Spst case '\\': 20719370Spst if (!weird) 20819370Spst goto default_case; 20919370Spst else 21019370Spst { 21119370Spst c = *lexptr++; 21219370Spst if (c == '\0') 21319370Spst goto eof_case; 21419370Spst else 21519370Spst goto default_case; 21619370Spst } 21719370Spst case '}': 21819370Spst if (!weird) 21919370Spst goto default_case; 22019370Spst 22119370Spst c = *lexptr++; 22219370Spst if (c == '#') 22319370Spst return; 22419370Spst else 22519370Spst { 22619370Spst --lexptr; 22719370Spst c = '}'; 22819370Spst goto default_case; 22919370Spst } 23019370Spst 23119370Spst default: 23219370Spst default_case: 23319370Spst ; 23419370Spst } 23519370Spst } 23619370Spst} 23719370Spst 23898944Sobrienstatic int 23998944Sobrienscm_skip_ws (void) 24019370Spst{ 241130803Smarcel int c; 24219370Spst while (1) 24319370Spst switch ((c = *lexptr++)) 24419370Spst { 24519370Spst case '\0': 24619370Spst goteof: 24719370Spst return c; 24819370Spst case ';': 24919370Spst lp: 25019370Spst switch ((c = *lexptr++)) 25119370Spst { 25219370Spst case '\0': 25319370Spst goto goteof; 25419370Spst default: 25519370Spst goto lp; 25619370Spst case '\n': 25719370Spst break; 25819370Spst } 25998944Sobrien case ' ': 26098944Sobrien case '\t': 26198944Sobrien case '\r': 26298944Sobrien case '\f': 26398944Sobrien case '\n': 26419370Spst break; 26519370Spst default: 26619370Spst return c; 26719370Spst } 26819370Spst} 26919370Spst 27019370Spststatic void 27198944Sobrienscm_lreadparen (int skipping) 27219370Spst{ 27319370Spst for (;;) 27419370Spst { 27519370Spst int c = scm_skip_ws (); 27619370Spst if (')' == c || ']' == c) 27719370Spst return; 27819370Spst --lexptr; 27919370Spst if (c == '\0') 28019370Spst error ("missing close paren"); 28119370Spst scm_lreadr (skipping); 28219370Spst } 28319370Spst} 28419370Spst 28519370Spststatic void 28698944Sobrienscm_lreadr (int skipping) 28719370Spst{ 28819370Spst int c, j; 28919370Spst struct stoken str; 29046283Sdfr LONGEST svalue = 0; 29198944Sobrientryagain: 29219370Spst c = *lexptr++; 29319370Spst switch (c) 29419370Spst { 29519370Spst case '\0': 29619370Spst lexptr--; 29719370Spst return; 29819370Spst case '[': 29919370Spst case '(': 30019370Spst scm_lreadparen (skipping); 30119370Spst return; 30219370Spst case ']': 30319370Spst case ')': 30419370Spst error ("unexpected #\\%c", c); 30519370Spst goto tryagain; 30619370Spst case '\'': 30719370Spst case '`': 30819370Spst str.ptr = lexptr - 1; 30919370Spst scm_lreadr (skipping); 31019370Spst if (!skipping) 31119370Spst { 31298944Sobrien struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr); 31319370Spst if (!is_scmvalue_type (VALUE_TYPE (val))) 31419370Spst error ("quoted scm form yields non-SCM value"); 31519370Spst svalue = extract_signed_integer (VALUE_CONTENTS (val), 31619370Spst TYPE_LENGTH (VALUE_TYPE (val))); 31719370Spst goto handle_immediate; 31819370Spst } 31919370Spst return; 32019370Spst case ',': 32119370Spst c = *lexptr++; 32219370Spst if ('@' != c) 32319370Spst lexptr--; 32419370Spst scm_lreadr (skipping); 32519370Spst return; 32619370Spst case '#': 32719370Spst c = *lexptr++; 32819370Spst switch (c) 32919370Spst { 33019370Spst case '[': 33119370Spst case '(': 33219370Spst scm_lreadparen (skipping); 33319370Spst return; 33498944Sobrien case 't': 33598944Sobrien case 'T': 33619370Spst svalue = SCM_BOOL_T; 33719370Spst goto handle_immediate; 33898944Sobrien case 'f': 33998944Sobrien case 'F': 34019370Spst svalue = SCM_BOOL_F; 34119370Spst goto handle_immediate; 34298944Sobrien case 'b': 34398944Sobrien case 'B': 34498944Sobrien case 'o': 34598944Sobrien case 'O': 34698944Sobrien case 'd': 34798944Sobrien case 'D': 34898944Sobrien case 'x': 34998944Sobrien case 'X': 35098944Sobrien case 'i': 35198944Sobrien case 'I': 35298944Sobrien case 'e': 35398944Sobrien case 'E': 35419370Spst lexptr--; 35519370Spst c = '#'; 35619370Spst goto num; 35798944Sobrien case '*': /* bitvector */ 35819370Spst scm_read_token (c, 0); 35919370Spst return; 36019370Spst case '{': 36119370Spst scm_read_token (c, 1); 36219370Spst return; 36398944Sobrien case '\\': /* character */ 36419370Spst c = *lexptr++; 36519370Spst scm_read_token (c, 0); 36619370Spst return; 36719370Spst case '|': 36819370Spst j = 1; /* here j is the comment nesting depth */ 36919370Spst lp: 37019370Spst c = *lexptr++; 37119370Spst lpc: 37219370Spst switch (c) 37319370Spst { 37419370Spst case '\0': 37519370Spst error ("unbalanced comment"); 37619370Spst default: 37719370Spst goto lp; 37819370Spst case '|': 37919370Spst if ('#' != (c = *lexptr++)) 38019370Spst goto lpc; 38119370Spst if (--j) 38219370Spst goto lp; 38319370Spst break; 38419370Spst case '#': 38519370Spst if ('|' != (c = *lexptr++)) 38619370Spst goto lpc; 38719370Spst ++j; 38819370Spst goto lp; 38919370Spst } 39019370Spst goto tryagain; 39119370Spst case '.': 39219370Spst default: 39346283Sdfr#if 0 39419370Spst callshrp: 39546283Sdfr#endif 39619370Spst scm_lreadr (skipping); 39719370Spst return; 39819370Spst } 39919370Spst case '\"': 40019370Spst while ('\"' != (c = *lexptr++)) 40119370Spst { 40219370Spst if (c == '\\') 40319370Spst switch (c = *lexptr++) 40419370Spst { 40519370Spst case '\0': 40619370Spst error ("non-terminated string literal"); 40719370Spst case '\n': 40819370Spst continue; 40919370Spst case '0': 41019370Spst case 'f': 41119370Spst case 'n': 41219370Spst case 'r': 41319370Spst case 't': 41419370Spst case 'a': 41519370Spst case 'v': 41619370Spst break; 41719370Spst } 41819370Spst } 41919370Spst return; 42098944Sobrien case '0': 42198944Sobrien case '1': 42298944Sobrien case '2': 42398944Sobrien case '3': 42498944Sobrien case '4': 42598944Sobrien case '5': 42698944Sobrien case '6': 42798944Sobrien case '7': 42898944Sobrien case '8': 42998944Sobrien case '9': 43019370Spst case '.': 43119370Spst case '-': 43219370Spst case '+': 43319370Spst num: 43419370Spst { 43598944Sobrien str.ptr = lexptr - 1; 43619370Spst scm_read_token (c, 0); 43719370Spst if (!skipping) 43819370Spst { 43919370Spst svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10); 44019370Spst if (svalue != SCM_BOOL_F) 44119370Spst goto handle_immediate; 44219370Spst goto tok; 44319370Spst } 44419370Spst } 44519370Spst return; 44619370Spst case ':': 44719370Spst scm_read_token ('-', 0); 44819370Spst return; 44946283Sdfr#if 0 45019370Spst do_symbol: 45146283Sdfr#endif 45219370Spst default: 45398944Sobrien str.ptr = lexptr - 1; 45419370Spst scm_read_token (c, 0); 45519370Spst tok: 45619370Spst if (!skipping) 45719370Spst { 45819370Spst str.length = lexptr - str.ptr; 45919370Spst if (str.ptr[0] == '$') 46019370Spst { 46119370Spst write_dollar_variable (str); 46219370Spst return; 46319370Spst } 46419370Spst write_exp_elt_opcode (OP_NAME); 46519370Spst write_exp_string (str); 46619370Spst write_exp_elt_opcode (OP_NAME); 46719370Spst } 46819370Spst return; 46919370Spst } 47098944Sobrienhandle_immediate: 47119370Spst if (!skipping) 47219370Spst { 47319370Spst write_exp_elt_opcode (OP_LONG); 47419370Spst write_exp_elt_type (builtin_type_scm); 47519370Spst write_exp_elt_longcst (svalue); 47619370Spst write_exp_elt_opcode (OP_LONG); 47719370Spst } 47819370Spst} 47919370Spst 48019370Spstint 48198944Sobrienscm_parse (void) 48219370Spst{ 48398944Sobrien char *start; 48419370Spst while (*lexptr == ' ') 48519370Spst lexptr++; 48619370Spst start = lexptr; 48719370Spst scm_lreadr (USE_EXPRSTRING); 48819370Spst#if USE_EXPRSTRING 48919370Spst str.length = lexptr - start; 49019370Spst str.ptr = start; 49119370Spst write_exp_elt_opcode (OP_EXPRSTRING); 49219370Spst write_exp_string (str); 49319370Spst write_exp_elt_opcode (OP_EXPRSTRING); 49419370Spst#endif 49519370Spst return 0; 49619370Spst} 497