* NEWS: Mention Guile removal.
* defs.h (enum language) <language_scm>: Remove.
* Makefile.in (SFILES): Remove scm-exp.c, scm-lang.c,
scm-valprint.c.
(HFILES_NO_SRCDIR): Remove scm-lang.h, scm-tags.h.
(COMMON_OBS): Remove scm-exp.o, scm-lang.o, scm-valprint.o.
* scm-exp.c, scm-lang.c, scm-valprint.c, scm-lang.h, scm-tags.h:
Remove.
gdb/testsuite
* gdb.base/default.exp: Remove "scheme" from language list.
+2010-11-02 Tom Tromey <tromey@redhat.com>
+
+ * NEWS: Mention Guile removal.
+ * defs.h (enum language) <language_scm>: Remove.
+ * Makefile.in (SFILES): Remove scm-exp.c, scm-lang.c,
+ scm-valprint.c.
+ (HFILES_NO_SRCDIR): Remove scm-lang.h, scm-tags.h.
+ (COMMON_OBS): Remove scm-exp.o, scm-lang.o, scm-valprint.o.
+ * scm-exp.c, scm-lang.c, scm-valprint.c, scm-lang.h, scm-tags.h:
+ Remove.
+
2010-11-02 Doug Evans <dje@google.com>
* top.c: #include "python/python.h".
proc-service.list progspace.c \
prologue-value.c psymtab.c \
regcache.c reggroups.c remote.c remote-fileio.c reverse.c \
- scm-exp.c scm-lang.c scm-valprint.c \
sentinel-frame.c \
serial.c ser-base.c ser-unix.c \
solib.c solib-target.c source.c \
amd64-nat.h s390-tdep.h arm-linux-tdep.h exceptions.h macroscope.h \
gdbarch.h bsd-uthread.h gdb_thread_db.h gdb_stat.h memory-map.h \
mdebugread.h m88k-tdep.h stabsread.h hppa-linux-offsets.h linux-fork.h \
-ser-unix.h scm-lang.h inf-ptrace.h terminal.h ui-out.h frame-base.h \
+ser-unix.h inf-ptrace.h terminal.h ui-out.h frame-base.h \
f-lang.h dwarf2loc.h value.h sparc-tdep.h defs.h target-descriptions.h \
objfiles.h vec.h disasm.h mips-tdep.h ser-base.h \
gdb_curses.h bfd-target.h memattr.h inferior.h ax.h dummy-frame.h \
gdb_locale.h gdb_dirent.h arch-utils.h trad-frame.h gnu-nat.h \
language.h nbsd-tdep.h wrapper.h solib-svr4.h \
macroexp.h ui-file.h regcache.h gdb_string.h tracepoint.h i386-tdep.h \
-inf-child.h p-lang.h event-top.h gdbtypes.h scm-tags.h user-regs.h \
+inf-child.h p-lang.h event-top.h gdbtypes.h user-regs.h \
regformats/regdef.h config/alpha/nm-osf3.h config/i386/nm-i386gnu.h \
config/i386/nm-fbsd.h \
config/nm-nto.h config/sparc/nm-sol2.h config/nm-linux.h \
varobj.o vec.o wrapper.o \
jv-lang.o jv-valprint.o jv-typeprint.o \
m2-lang.o p-lang.o p-typeprint.o p-valprint.o \
- scm-exp.o scm-lang.o scm-valprint.o \
sentinel-frame.o \
complaints.o typeprint.o \
ada-typeprint.o c-typeprint.o f-typeprint.o m2-typeprint.o \
see the "Tasking Support when using the Ravenscar Profile" section
in the GDB user manual.
+* Guile support was removed.
+
*** Changes in GDB 7.2
* Shared library support for remote targets by default
language_asm, /* Assembly language */
language_pascal, /* Pascal */
language_ada, /* Ada */
- language_scm, /* Guile Scheme */
language_minimal, /* All other languages, minimal support only */
nr_languages
};
+++ /dev/null
-/* Scheme/Guile language support routines for GDB, the GNU debugger.
-
- Copyright (C) 1995, 1996, 2000, 2003, 2005, 2008, 2009, 2010
- Free Software Foundation, Inc.
-
- This file is part of GDB.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-#include "defs.h"
-#include "symtab.h"
-#include "gdbtypes.h"
-#include "expression.h"
-#include "parser-defs.h"
-#include "language.h"
-#include "value.h"
-#include "c-lang.h"
-#include "scm-lang.h"
-#include "scm-tags.h"
-
-#define USE_EXPRSTRING 0
-
-static void scm_lreadparen (int);
-static int scm_skip_ws (void);
-static void scm_read_token (int, int);
-static LONGEST scm_istring2number (char *, int, int);
-static LONGEST scm_istr2int (char *, int, int);
-static void scm_lreadr (int);
-
-static LONGEST
-scm_istr2int (char *str, int len, int radix)
-{
- int i = 0;
- LONGEST inum = 0;
- int c;
- int sign = 0;
-
- if (0 >= len)
- return SCM_BOOL_F; /* zero scm_length */
- switch (str[0])
- { /* leading sign */
- case '-':
- case '+':
- sign = str[0];
- if (++i == len)
- return SCM_BOOL_F; /* bad if lone `+' or `-' */
- }
- do
- {
- switch (c = str[i++])
- {
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- c = c - '0';
- goto accumulate;
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- c = c - 'A' + 10;
- goto accumulate;
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- c = c - 'a' + 10;
- accumulate:
- if (c >= radix)
- return SCM_BOOL_F; /* bad digit for radix */
- inum *= radix;
- inum += c;
- break;
- default:
- return SCM_BOOL_F; /* not a digit */
- }
- }
- while (i < len);
- if (sign == '-')
- inum = -inum;
- return SCM_MAKINUM (inum);
-}
-
-static LONGEST
-scm_istring2number (char *str, int len, int radix)
-{
- int i = 0;
- char ex = 0;
- char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
-#if 0
- SCM res;
-#endif
-
- if (len == 1)
- if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */
- return SCM_BOOL_F;
-
- while ((len - i) >= 2 && str[i] == '#' && ++i)
- switch (str[i++])
- {
- case 'b':
- case 'B':
- if (rx_p++)
- return SCM_BOOL_F;
- radix = 2;
- break;
- case 'o':
- case 'O':
- if (rx_p++)
- return SCM_BOOL_F;
- radix = 8;
- break;
- case 'd':
- case 'D':
- if (rx_p++)
- return SCM_BOOL_F;
- radix = 10;
- break;
- case 'x':
- case 'X':
- if (rx_p++)
- return SCM_BOOL_F;
- radix = 16;
- break;
- case 'i':
- case 'I':
- if (ex_p++)
- return SCM_BOOL_F;
- ex = 2;
- break;
- case 'e':
- case 'E':
- if (ex_p++)
- return SCM_BOOL_F;
- ex = 1;
- break;
- default:
- return SCM_BOOL_F;
- }
-
- switch (ex)
- {
- case 1:
- return scm_istr2int (&str[i], len - i, radix);
- case 0:
- return scm_istr2int (&str[i], len - i, radix);
-#if 0
- if NFALSEP
- (res) return res;
-#ifdef FLOATS
- case 2:
- return scm_istr2flo (&str[i], len - i, radix);
-#endif
-#endif
- }
- return SCM_BOOL_F;
-}
-
-static void
-scm_read_token (int c, int weird)
-{
- while (1)
- {
- c = *lexptr++;
- switch (c)
- {
- case '[':
- case ']':
- case '(':
- case ')':
- case '\"':
- case ';':
- case ' ':
- case '\t':
- case '\r':
- case '\f':
- case '\n':
- if (weird)
- goto default_case;
- case '\0': /* End of line */
- eof_case:
- --lexptr;
- return;
- case '\\':
- if (!weird)
- goto default_case;
- else
- {
- c = *lexptr++;
- if (c == '\0')
- goto eof_case;
- else
- goto default_case;
- }
- case '}':
- if (!weird)
- goto default_case;
-
- c = *lexptr++;
- if (c == '#')
- return;
- else
- {
- --lexptr;
- c = '}';
- goto default_case;
- }
-
- default:
- default_case:
- ;
- }
- }
-}
-
-static int
-scm_skip_ws (void)
-{
- int c;
-
- while (1)
- switch ((c = *lexptr++))
- {
- case '\0':
- goteof:
- return c;
- case ';':
- lp:
- switch ((c = *lexptr++))
- {
- case '\0':
- goto goteof;
- default:
- goto lp;
- case '\n':
- break;
- }
- case ' ':
- case '\t':
- case '\r':
- case '\f':
- case '\n':
- break;
- default:
- return c;
- }
-}
-
-static void
-scm_lreadparen (int skipping)
-{
- for (;;)
- {
- int c = scm_skip_ws ();
-
- if (')' == c || ']' == c)
- return;
- --lexptr;
- if (c == '\0')
- error ("missing close paren");
- scm_lreadr (skipping);
- }
-}
-
-static void
-scm_lreadr (int skipping)
-{
- int c, j;
- struct stoken str;
- LONGEST svalue = 0;
-
-tryagain:
- c = *lexptr++;
- switch (c)
- {
- case '\0':
- lexptr--;
- return;
- case '[':
- case '(':
- scm_lreadparen (skipping);
- return;
- case ']':
- case ')':
- error ("unexpected #\\%c", c);
- goto tryagain;
- case '\'':
- case '`':
- str.ptr = lexptr - 1;
- scm_lreadr (skipping);
- if (!skipping)
- {
- struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
-
- if (!is_scmvalue_type (value_type (val)))
- error ("quoted scm form yields non-SCM value");
- svalue = extract_signed_integer (value_contents (val),
- TYPE_LENGTH (value_type (val)),
- gdbarch_byte_order (parse_gdbarch));
- goto handle_immediate;
- }
- return;
- case ',':
- c = *lexptr++;
- if ('@' != c)
- lexptr--;
- scm_lreadr (skipping);
- return;
- case '#':
- c = *lexptr++;
- switch (c)
- {
- case '[':
- case '(':
- scm_lreadparen (skipping);
- return;
- case 't':
- case 'T':
- svalue = SCM_BOOL_T;
- goto handle_immediate;
- case 'f':
- case 'F':
- svalue = SCM_BOOL_F;
- goto handle_immediate;
- case 'b':
- case 'B':
- case 'o':
- case 'O':
- case 'd':
- case 'D':
- case 'x':
- case 'X':
- case 'i':
- case 'I':
- case 'e':
- case 'E':
- lexptr--;
- c = '#';
- goto num;
- case '*': /* bitvector */
- scm_read_token (c, 0);
- return;
- case '{':
- scm_read_token (c, 1);
- return;
- case '\\': /* character */
- c = *lexptr++;
- scm_read_token (c, 0);
- return;
- case '|':
- j = 1; /* here j is the comment nesting depth */
- lp:
- c = *lexptr++;
- lpc:
- switch (c)
- {
- case '\0':
- error ("unbalanced comment");
- default:
- goto lp;
- case '|':
- if ('#' != (c = *lexptr++))
- goto lpc;
- if (--j)
- goto lp;
- break;
- case '#':
- if ('|' != (c = *lexptr++))
- goto lpc;
- ++j;
- goto lp;
- }
- goto tryagain;
- case '.':
- default:
-#if 0
- callshrp:
-#endif
- scm_lreadr (skipping);
- return;
- }
- case '\"':
- while ('\"' != (c = *lexptr++))
- {
- if (c == '\\')
- switch (c = *lexptr++)
- {
- case '\0':
- error ("non-terminated string literal");
- case '\n':
- continue;
- case '0':
- case 'f':
- case 'n':
- case 'r':
- case 't':
- case 'a':
- case 'v':
- break;
- }
- }
- return;
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case '.':
- case '-':
- case '+':
- num:
- {
- str.ptr = lexptr - 1;
- scm_read_token (c, 0);
- if (!skipping)
- {
- svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
- if (svalue != SCM_BOOL_F)
- goto handle_immediate;
- goto tok;
- }
- }
- return;
- case ':':
- scm_read_token ('-', 0);
- return;
-#if 0
- do_symbol:
-#endif
- default:
- str.ptr = lexptr - 1;
- scm_read_token (c, 0);
- tok:
- if (!skipping)
- {
- str.length = lexptr - str.ptr;
- if (str.ptr[0] == '$')
- {
- write_dollar_variable (str);
- return;
- }
- write_exp_elt_opcode (OP_NAME);
- write_exp_string (str);
- write_exp_elt_opcode (OP_NAME);
- }
- return;
- }
-handle_immediate:
- if (!skipping)
- {
- write_exp_elt_opcode (OP_LONG);
- write_exp_elt_type (builtin_scm_type (parse_gdbarch)->builtin_scm);
- write_exp_elt_longcst (svalue);
- write_exp_elt_opcode (OP_LONG);
- }
-}
-
-int
-scm_parse (void)
-{
- char *start;
-
- while (*lexptr == ' ')
- lexptr++;
- start = lexptr;
- scm_lreadr (USE_EXPRSTRING);
-#if USE_EXPRSTRING
- str.length = lexptr - start;
- str.ptr = start;
- write_exp_elt_opcode (OP_EXPRSTRING);
- write_exp_string (str);
- write_exp_elt_opcode (OP_EXPRSTRING);
-#endif
- return 0;
-}
+++ /dev/null
-/* Scheme/Guile language support routines for GDB, the GNU debugger.
-
- Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
- 2008, 2009, 2010 Free Software Foundation, Inc.
-
- This file is part of GDB.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-#include "defs.h"
-#include "symtab.h"
-#include "gdbtypes.h"
-#include "expression.h"
-#include "parser-defs.h"
-#include "language.h"
-#include "value.h"
-#include "c-lang.h"
-#include "scm-lang.h"
-#include "scm-tags.h"
-#include "source.h"
-#include "gdb_string.h"
-#include "gdbcore.h"
-#include "infcall.h"
-#include "objfiles.h"
-
-extern void _initialize_scheme_language (void);
-static struct value *scm_lookup_name (struct gdbarch *, char *);
-static int in_eval_c (void);
-
-void
-scm_printchar (int c, struct type *type, struct ui_file *stream)
-{
- fprintf_filtered (stream, "#\\%c", c);
-}
-
-static void
-scm_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
- unsigned int length, const char *encoding, int force_ellipses,
- const struct value_print_options *options)
-{
- fprintf_filtered (stream, "\"%s\"", string);
-}
-
-int
-is_scmvalue_type (struct type *type)
-{
- if (TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
- {
- return 1;
- }
- return 0;
-}
-
-/* Get the INDEX'th SCM value, assuming SVALUE is the address
- of the 0'th one. */
-
-LONGEST
-scm_get_field (LONGEST svalue, int index, int size,
- enum bfd_endian byte_order)
-{
- gdb_byte buffer[20];
-
- read_memory (SCM2PTR (svalue) + index * size, buffer, size);
- return extract_signed_integer (buffer, size, byte_order);
-}
-
-/* Unpack a value of type TYPE in buffer VALADDR as an integer
- (if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
- or Boolean (CONTEXT == TYPE_CODE_BOOL). */
-
-LONGEST
-scm_unpack (struct type *type, const gdb_byte *valaddr, enum type_code context)
-{
- if (is_scmvalue_type (type))
- {
- enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
- LONGEST svalue
- = extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);
-
- if (context == TYPE_CODE_BOOL)
- {
- if (svalue == SCM_BOOL_F)
- return 0;
- else
- return 1;
- }
- switch (7 & (int) svalue)
- {
- case 2:
- case 6: /* fixnum */
- return svalue >> 2;
- case 4: /* other immediate value */
- if (SCM_ICHRP (svalue)) /* character */
- return SCM_ICHR (svalue);
- else if (SCM_IFLAGP (svalue))
- {
- switch ((int) svalue)
- {
-#ifndef SICP
- case SCM_EOL:
-#endif
- case SCM_BOOL_F:
- return 0;
- case SCM_BOOL_T:
- return 1;
- }
- }
- error (_("Value can't be converted to integer."));
- default:
- return svalue;
- }
- }
- else
- return unpack_long (type, valaddr);
-}
-
-/* True if we're correctly in Guile's eval.c (the evaluator and apply). */
-
-static int
-in_eval_c (void)
-{
- struct symtab_and_line cursal = get_current_source_symtab_and_line ();
-
- if (cursal.symtab && cursal.symtab->filename)
- {
- char *filename = cursal.symtab->filename;
- int len = strlen (filename);
-
- if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
- return 1;
- }
- return 0;
-}
-
-/* Lookup a value for the variable named STR.
- First lookup in Scheme context (using the scm_lookup_cstr inferior
- function), then try lookup_symbol for compiled variables. */
-
-static struct value *
-scm_lookup_name (struct gdbarch *gdbarch, char *str)
-{
- struct value *args[3];
- int len = strlen (str);
- struct value *func;
- struct value *val;
- struct symbol *sym;
-
- func = find_function_in_inferior ("scm_lookup_cstr", NULL);
-
- args[0] = value_allocate_space_in_inferior (len);
- args[1] = value_from_longest (builtin_type (gdbarch)->builtin_int, len);
- write_memory (value_as_long (args[0]), (gdb_byte *) str, len);
-
- if (in_eval_c ()
- && (sym = lookup_symbol ("env",
- expression_context_block,
- VAR_DOMAIN, (int *) NULL)) != NULL)
- args[2] = value_of_variable (sym, expression_context_block);
- else
- /* FIXME in this case, we should try lookup_symbol first */
- args[2] = value_from_longest (builtin_scm_type (gdbarch)->builtin_scm,
- SCM_EOL);
-
- val = call_function_by_hand (func, 3, args);
- if (!value_logical_not (val))
- return value_ind (val);
-
- sym = lookup_symbol (str,
- expression_context_block,
- VAR_DOMAIN, (int *) NULL);
- if (sym)
- return value_of_variable (sym, NULL);
- error (_("No symbol \"%s\" in current context."), str);
-}
-
-struct value *
-scm_evaluate_string (char *str, int len)
-{
- struct value *func;
- struct value *addr = value_allocate_space_in_inferior (len + 1);
- LONGEST iaddr = value_as_long (addr);
-
- write_memory (iaddr, (gdb_byte *) str, len);
- /* FIXME - should find and pass env */
- write_memory (iaddr + len, (gdb_byte *) "", 1);
- func = find_function_in_inferior ("scm_evstr", NULL);
- return call_function_by_hand (func, 1, &addr);
-}
-
-static struct value *
-evaluate_exp (struct type *expect_type, struct expression *exp,
- int *pos, enum noside noside)
-{
- enum exp_opcode op = exp->elts[*pos].opcode;
- int len, pc;
- char *str;
-
- switch (op)
- {
- case OP_NAME:
- pc = (*pos)++;
- len = longest_to_int (exp->elts[pc + 1].longconst);
- (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
- if (noside == EVAL_SKIP)
- goto nosideret;
- str = &exp->elts[pc + 2].string;
- return scm_lookup_name (exp->gdbarch, str);
- case OP_STRING:
- pc = (*pos)++;
- len = longest_to_int (exp->elts[pc + 1].longconst);
- (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
- if (noside == EVAL_SKIP)
- goto nosideret;
- str = &exp->elts[pc + 2].string;
- return scm_evaluate_string (str, len);
- default:;
- }
- return evaluate_subexp_standard (expect_type, exp, pos, noside);
-nosideret:
- return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
-}
-
-const struct exp_descriptor exp_descriptor_scm =
-{
- print_subexp_standard,
- operator_length_standard,
- operator_check_standard,
- op_name_standard,
- dump_subexp_body_standard,
- evaluate_exp
-};
-
-const struct language_defn scm_language_defn =
-{
- "scheme", /* Language name */
- language_scm,
- range_check_off,
- type_check_off,
- case_sensitive_off,
- array_row_major,
- macro_expansion_no,
- &exp_descriptor_scm,
- scm_parse,
- c_error,
- null_post_parser,
- scm_printchar, /* Print a character constant */
- scm_printstr, /* Function to print string constant */
- NULL, /* Function to print a single character */
- c_print_type, /* Print a type using appropriate syntax */
- default_print_typedef, /* Print a typedef using appropriate syntax */
- scm_val_print, /* Print a value using appropriate syntax */
- scm_value_print, /* Print a top-level value */
- NULL, /* Language specific skip_trampoline */
- NULL, /* name_of_this */
- basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
- basic_lookup_transparent_type,/* lookup_transparent_type */
- NULL, /* Language specific symbol demangler */
- NULL, /* Language specific class_name_from_physname */
- NULL, /* expression operators for printing */
- 1, /* c-style arrays */
- 0, /* String lower bound */
- default_word_break_characters,
- default_make_symbol_completion_list,
- c_language_arch_info,
- default_print_array_index,
- default_pass_by_reference,
- default_get_string,
- LANG_MAGIC
-};
-
-static void *
-build_scm_types (struct gdbarch *gdbarch)
-{
- struct builtin_scm_type *builtin_scm_type
- = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_scm_type);
-
- builtin_scm_type->builtin_scm
- = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 0, "SCM");
-
- return builtin_scm_type;
-}
-
-static struct gdbarch_data *scm_type_data;
-
-const struct builtin_scm_type *
-builtin_scm_type (struct gdbarch *gdbarch)
-{
- return gdbarch_data (gdbarch, scm_type_data);
-}
-
-void
-_initialize_scheme_language (void)
-{
- scm_type_data = gdbarch_data_register_post_init (build_scm_types);
-
- add_language (&scm_language_defn);
-}
+++ /dev/null
-/* Scheme/Guile language support routines for GDB, the GNU debugger.
-
- Copyright (C) 1995, 1996, 1998, 1999, 2000, 2003, 2005, 2008, 2009, 2010
- Free Software Foundation, Inc.
-
- This file is part of GDB.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-#define SICP
-#include "scm-tags.h"
-#undef SCM_NCELLP
-#define SCM_NCELLP(x) ((SCM_SIZE-1) & (int)(x))
-#define SCM_ITAG8_DATA(X) ((X)>>8)
-#define SCM_ICHR(x) ((unsigned char)SCM_ITAG8_DATA(x))
-#define SCM_ICHRP(x) (SCM_ITAG8(x) == scm_tc8_char)
-#define scm_tc8_char 0xf4
-#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4)
-#define SCM_ISYMNUM(n) ((int)((n)>>9))
-#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)])
-#define SCM_ILOCP(n) ((0xff & (int)(n))==0xfc)
-#define SCM_ITAG8(X) ((int)(X) & 0xff)
-#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x))
-#define SCM_LENGTH(x) (((unsigned long)SCM_CAR(x))>>8)
-#define SCM_NCONSP(x) (1 & (int)SCM_CAR(x))
-#define SCM_NECONSP(x) (SCM_NCONSP(x) && (1 != SCM_TYP3(x)))
-#define SCM_CAR(x) scm_get_field (x, 0, SCM_SIZE, SCM_BYTE_ORDER)
-#define SCM_CDR(x) scm_get_field (x, 1, SCM_SIZE, SCM_BYTE_ORDER)
-#define SCM_VELTS(x) ((SCM *)SCM_CDR(x))
-#define SCM_CLOSCAR(x) (SCM_CAR(x)-scm_tc3_closure)
-#define SCM_CODE(x) SCM_CAR(SCM_CLOSCAR (x))
-#define SCM_MAKINUM(x) (((x)<<2)+2L)
-
-/* Forward decls for prototypes */
-struct value;
-
-extern int scm_value_print (struct value *, struct ui_file *,
- const struct value_print_options *);
-
-extern int scm_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
- struct ui_file *, int,
- const struct value *,
- const struct value_print_options *);
-
-extern LONGEST scm_get_field (LONGEST, int, int, enum bfd_endian);
-
-extern int is_scmvalue_type (struct type *);
-
-extern void scm_printchar (int, struct type *, struct ui_file *);
-
-extern struct value *scm_evaluate_string (char *, int);
-
-extern int scm_parse (void);
-
-extern LONGEST scm_unpack (struct type *, const gdb_byte *, enum type_code);
-
-/* Scheme types */
-
-struct builtin_scm_type
-{
- struct type *builtin_scm;
-};
-
-/* Return the Scheme type table for the specified architecture. */
-extern const struct builtin_scm_type *builtin_scm_type (struct gdbarch *gdbarch);
-
+++ /dev/null
-/* This is a minimally edited version of Guile's tags.h. */
-/* classes: h_files */
-
-#ifndef TAGSH
-#define TAGSH
-/* Copyright (C) 1995, 1999, 2008, 2009, 2010
-Free Software Foundation, Inc.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
-
- As a special exception, the Free Software Foundation gives permission
- for additional uses of the text contained in its release of GUILE.
-
- The exception is that, if you link the GUILE library with other files
- to produce an executable, this does not by itself cause the
- resulting executable to be covered by the GNU General Public License.
- Your use of that executable is in no way restricted on account of
- linking the GUILE library code into it.
-
- This exception does not however invalidate any other reasons why
- the executable file might be covered by the GNU General Public License.
-
- This exception applies only to the code released by the
- Free Software Foundation under the name GUILE. If you copy
- code from other Free Software Foundation releases into a copy of
- GUILE, as the General Public License permits, the exception does
- not apply to the code that you add in this way. To avoid misleading
- anyone as to the status of such modified files, you must delete
- this exception notice from them.
-
- If you write modifications of your own for GUILE, it is your choice
- whether to permit this exception to apply to your modifications.
- If you do not wish that, delete this exception notice. */
-\f
-
-/** This file defines the format of SCM values and cons pairs.
- ** It is here that tag bits are assigned for various purposes.
- **/
-\f
-
-/* Three Bit Tags
-
- * 000 -- a non-immediate value. Points into the pair heap.
- *
- * 001 -- a gloc (i.e., a resolved global variable in a CAR in a code graph)
- * or the CAR of an object handle (i.e., the tagged pointer to the
- * vtable part of a user-defined object).
- *
- * If X has this tag, the value at CDAR(X - 1) distinguishes
- * glocs from object handles. The distinction only needs
- * to be made in a few places. Only a few parts of the code know
- * about glocs. In most cases, when a value in the CAR of a pair
- * has the tag 001, it means that the pair is an object handle.
- *
- * 010 -- the tag for immediate, exact integers.
- *
- * 011 -- in the CAR of a pair, this tag indicates that the pair is a closure.
- * The remaining bits of the CAR are a pointer into the pair heap
- * to the code graph for the closure.
- *
- * 1xy -- an extension tag which means that there is a five or six bit
- * tag to the left of the low three bits. See the nice diagrams
- * in ../doc/code.doc if you want to know what the bits mean.
- */
-\f
-
-
-
-
-#define scm_tc3_cons 0
-#define scm_tc3_cons_gloc 1
-#define scm_tc3_closure 3
-
-#define scm_tc7_ssymbol 5
-#define scm_tc7_msymbol 7
-#define scm_tc7_string 13
-#define scm_tc7_bvect 15
-#define scm_tc7_vector 21
-#define scm_tc7_lvector 23
-#define scm_tc7_ivect 29
-#define scm_tc7_uvect 31
-/* spare 37 39 */
-#define scm_tc7_fvect 45
-#define scm_tc7_dvect 47
-#define scm_tc7_cvect 53
-#define scm_tc7_port 55
-#define scm_tc7_contin 61
-#define scm_tc7_cclo 63
-/* spare 69 71 77 79 */
-#define scm_tc7_subr_0 85
-#define scm_tc7_subr_1 87
-#define scm_tc7_cxr 93
-#define scm_tc7_subr_3 95
-#define scm_tc7_subr_2 101
-#define scm_tc7_asubr 103
-#define scm_tc7_subr_1o 109
-#define scm_tc7_subr_2o 111
-#define scm_tc7_lsubr_2 117
-#define scm_tc7_lsubr 119
-#define scm_tc7_rpsubr 125
-
-#define scm_tc7_smob 127
-#define scm_tc_free_cell 127
-
-#define scm_tc16_flo 0x017f
-#define scm_tc_flo 0x017fL
-
-#define SCM_REAL_PART (1L<<16)
-#define SCM_IMAG_PART (2L<<16)
-#define scm_tc_dblr (scm_tc16_flo|REAL_PART)
-#define scm_tc_dblc (scm_tc16_flo|REAL_PART|IMAG_PART)
-
-#define scm_tc16_bigpos 0x027f
-#define scm_tc16_bigneg 0x037f
-
-#define scm_tc16_fport (scm_tc7_port + 0*256L)
-#define scm_tc16_pipe (scm_tc7_port + 1*256L)
-#define scm_tc16_strport (scm_tc7_port + 2*256L)
-#define scm_tc16_sfport (scm_tc7_port + 3*256L)
-
-
-
-/* For cons pairs with immediate values in the CAR */
-#define scm_tcs_cons_imcar 2:case 4:case 6:case 10:\
- case 12:case 14:case 18:case 20:\
- case 22:case 26:case 28:case 30:\
- case 34:case 36:case 38:case 42:\
- case 44:case 46:case 50:case 52:\
- case 54:case 58:case 60:case 62:\
- case 66:case 68:case 70:case 74:\
- case 76:case 78:case 82:case 84:\
- case 86:case 90:case 92:case 94:\
- case 98:case 100:case 102:case 106:\
- case 108:case 110:case 114:case 116:\
- case 118:case 122:case 124:case 126
-
-/* For cons pairs with non-immediate values in the CAR */
-#define scm_tcs_cons_nimcar 0:case 8:case 16:case 24:\
- case 32:case 40:case 48:case 56:\
- case 64:case 72:case 80:case 88:\
- case 96:case 104:case 112:case 120
-
-/* A CONS_GLOC occurs in code. It's CAR is a pointer to the
- * CDR of a variable. The low order bits of the CAR are 001.
- * The CDR of the gloc is the code continuation.
- */
-#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\
- case 33:case 41:case 49:case 57:\
- case 65:case 73:case 81:case 89:\
- case 97:case 105:case 113:case 121
-
-#define scm_tcs_closures 3:case 11:case 19:case 27:\
- case 35:case 43:case 51:case 59:\
- case 67:case 75:case 83:case 91:\
- case 99:case 107:case 115:case 123
-
-#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\
- case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\
- case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr
-
-#define scm_tcs_symbols scm_tc7_ssymbol:case scm_tc7_msymbol
-
-#define scm_tcs_bignums tc16_bigpos:case tc16_bigneg
-\f
-
-
-/* References to objects are of type SCM. Values may be non-immediate
- * (pointers) or immediate (encoded, immutable, scalar values that fit
- * in an SCM variable).
- */
-
-typedef long SCM;
-
-/* Cray machines have pointers that are incremented once for each word,
- * rather than each byte, the 3 most significant bits encode the byte
- * within the word. The following macros deal with this by storing the
- * native Cray pointers like the ones that looks like scm expects. This
- * is done for any pointers that might appear in the car of a scm_cell, pointers
- * to scm_vector elts, functions, &c are not munged.
- */
-#ifdef _UNICOS
-#define SCM2PTR(x) ((int)(x) >> 3)
-#define PTR2SCM(x) (((SCM)(x)) << 3)
-#define SCM_POINTERS_MUNGED
-#else
-#define SCM2PTR(x) (x)
-#define PTR2SCM(x) ((SCM)(x))
-#endif /* def _UNICOS */
-\f
-
-
-/* Immediate? Predicates
- */
-#define SCM_IMP(x) (6 & (int)(x))
-#define SCM_NIMP(x) (!SCM_IMP(x))
-\f
-
-
-enum scm_tags
- {
- scm_tc8_char = 0xf4
- };
-
-#define SCM_ITAG8(X) ((int)(X) & 0xff)
-#define SCM_MAKE_ITAG8(X, TAG) (((X)<<8) + TAG)
-#define SCM_ITAG8_DATA(X) ((X)>>8)
-\f
-
-
-/* Local Environment Structure
- */
-#define SCM_ILOCP(n) ((0xff & (int)(n))==0xfc)
-#define SCM_ILOC00 (0x000000fcL)
-#define SCM_IDINC (0x00100000L)
-#define SCM_ICDR (0x00080000L)
-#define SCM_IFRINC (0x00000100L)
-#define SCM_IDSTMSK (-SCM_IDINC)
-#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8))
-#define SCM_IDIST(n) (((unsigned long)(n))>>20)
-#define SCM_ICDRP(n) (SCM_ICDR & (n))
-\f
-
-/* Immediate Symbols, Special Symbols, Flags (various constants).
- */
-
-/* ISYMP tests for ISPCSYM and ISYM */
-#define SCM_ISYMP(n) ((0x187 & (int)(n))==4)
-
-/* IFLAGP tests for ISPCSYM, ISYM and IFLAG */
-#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4)
-#define SCM_ISYMNUM(n) ((int)((n)>>9))
-#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)])
-#define SCM_MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
-#define SCM_MAKISYM(n) (((n)<<9)+0x74L)
-#define SCM_MAKIFLAG(n) (((n)<<9)+0x174L)
-
-/* This table must agree with the declarations
- * in repl.c: {Names of immediate symbols}.
- *
- * These are used only in eval but their values
- * have to be allocated here.
- *
- */
-
-#define SCM_IM_AND SCM_MAKSPCSYM(0)
-#define SCM_IM_BEGIN SCM_MAKSPCSYM(1)
-#define SCM_IM_CASE SCM_MAKSPCSYM(2)
-#define SCM_IM_COND SCM_MAKSPCSYM(3)
-#define SCM_IM_DO SCM_MAKSPCSYM(4)
-#define SCM_IM_IF SCM_MAKSPCSYM(5)
-#define SCM_IM_LAMBDA SCM_MAKSPCSYM(6)
-#define SCM_IM_LET SCM_MAKSPCSYM(7)
-#define SCM_IM_LETSTAR SCM_MAKSPCSYM(8)
-#define SCM_IM_LETREC SCM_MAKSPCSYM(9)
-#define SCM_IM_OR SCM_MAKSPCSYM(10)
-#define SCM_IM_QUOTE SCM_MAKSPCSYM(11)
-#define SCM_IM_SET SCM_MAKSPCSYM(12)
-#define SCM_IM_DEFINE SCM_MAKSPCSYM(13)
-#define SCM_IM_APPLY SCM_MAKISYM(14)
-#define SCM_IM_CONT SCM_MAKISYM(15)
-#define SCM_NUM_ISYMS 16
-
-/* Important immediates
- */
-
-#define SCM_BOOL_F SCM_MAKIFLAG(SCM_NUM_ISYMS+0)
-#define SCM_BOOL_T SCM_MAKIFLAG(SCM_NUM_ISYMS+1)
-#define SCM_UNDEFINED SCM_MAKIFLAG(SCM_NUM_ISYMS+2)
-#define SCM_EOF_VAL SCM_MAKIFLAG(SCM_NUM_ISYMS+3)
-
-#ifdef SICP
-#define SCM_EOL SCM_BOOL_F
-#else
-#define SCM_EOL SCM_MAKIFLAG(SCM_NUM_ISYMS+4)
-#endif
-
-#define SCM_UNSPECIFIED SCM_MAKIFLAG(SCM_NUM_ISYMS+5)
-\f
-
-
-/* Heap Pairs and the Empty List Predicates
- */
-#define SCM_NULLP(x) (SCM_EOL == (x))
-#define SCM_NNULLP(x) (SCM_EOL != (x))
-#define SCM_CELLP(x) (!SCM_NCELLP(x))
-#define SCM_NCELLP(x) ((sizeof(scm_cell)-1) & (int)(x))
-\f
-
-
-#define SCM_UNBNDP(x) (SCM_UNDEFINED==(x))
-\f
-
-
-/* Testing and Changing GC Marks in Various Standard Positions
- */
-#define SCM_GCMARKP(x) (1 & (int)SCM_CDR(x))
-#define SCM_GC8MARKP(x) (0x80 & (int)SCM_CAR(x))
-#define SCM_SETGCMARK(x) (SCM_CDR(x) |= 1)
-#define SCM_CLRGCMARK(x) (SCM_CDR(x) &= ~1L)
-#define SCM_SETGC8MARK(x) (SCM_CAR(x) |= 0x80)
-#define SCM_CLRGC8MARK(x) (SCM_CAR(x) &= ~0x80L)
-\f
-
-/* Extracting Tag Bits, With or Without GC Safety and Optional Bits
- */
-#define SCM_TYP3(x) (7 & (int)SCM_CAR(x))
-#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x))
-#define SCM_TYP7S(x) (0x7d & (int)SCM_CAR(x))
-#define SCM_TYP16(x) (0xffff & (int)SCM_CAR(x))
-#define SCM_TYP16S(x) (0xfeff & (int)SCM_CAR(x))
-#define SCM_GCTYP16(x) (0xff7f & (int)SCM_CAR(x))
-\f
-
-/* Two slightly extensible types: smobs and ptobs.
-
- */
-#define SCM_SMOBNUM(x) (0x0ff & (CAR(x)>>8));
-#define SCM_PTOBNUM(x) (0x0ff & (CAR(x)>>8));
-\f
-
-
-
-#define SCM_DIRP(x) (SCM_NIMP(x) && (TYP16(x)==(scm_tc16_dir)))
-#define SCM_OPDIRP(x) (SCM_NIMP(x) && (CAR(x)==(scm_tc16_dir | OPN)))
-\f
-
-
-/* Lvectors
- */
-#define SCM_LVECTORP(x) (TYP7(x)==tc7_lvector)
-\f
-
-#if 0
-\f
-/* Sockets
- */
-#define tc_socket (tc7_port | OPN)
-#define SCM_SOCKP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc_socket))
-#define SCM_SOCKTYP(x) (CAR(x)>>24)
-\f
-
-
-extern int scm_tc16_key_vector;
-#define SCM_KEYVECP(X) (scm_tc16_key_vector == TYP16 (X))
-#define SCM_KEYVECLEN(OBJ) (((unsigned long)CAR (obj)) >> 16)
-\f
-
-#define SCM_MALLOCDATA(obj) ((char *)CDR(obj))
-#define SCM_MALLOCLEN(obj) (((unsigned long)CAR (obj)) >> 16)
-#define SCM_WORDDATA(obj) (CDR (obj))
-
-
-#define SCM_BYTECODEP(X) ((TYP7 (X) == tc7_cclo) && (CCLO_SUBR (X) == rb_proc))
-#define SCM_BYTECODE_CONSTANTS(X) (VELTS(X)[1])
-#define SCM_BYTECODE_CODE(X) (VELTS(X)[2])
-#define SCM_BYTECODE_NAME(X) (VELTS(X)[3])
-#define SCM_BYTECODE_BCODE(X) (VELTS(X)[4])
-#define SCM_BYTECODE_ELTS 5
-\f
-
-#define SCM_FREEP(x) (CAR(x)==tc_free_cell)
-#define SCM_NFREEP(x) (!FREEP(x))
-\f
-#endif /* 0 */
-\f
-
-#endif /* TAGSH */
+++ /dev/null
-/* Scheme/Guile language support routines for GDB, the GNU debugger.
-
- Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2005, 2007, 2008, 2009,
- 2010 Free Software Foundation, Inc.
-
- This file is part of GDB.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-#include "defs.h"
-#include "symtab.h"
-#include "gdbtypes.h"
-#include "expression.h"
-#include "parser-defs.h"
-#include "language.h"
-#include "value.h"
-#include "scm-lang.h"
-#include "valprint.h"
-#include "gdbcore.h"
-#include "c-lang.h"
-#include "infcall.h"
-#include "objfiles.h"
-
-static void scm_ipruk (char *, struct type *, LONGEST, struct ui_file *);
-static void scm_scmval_print (struct type *, LONGEST, struct ui_file *,
- int, const struct value_print_options *);
-static void scm_scmlist_print (struct type *, LONGEST, struct ui_file *,
- int, const struct value_print_options *);
-static int scm_inferior_print (struct type *, LONGEST, struct ui_file *,
- int, const struct value_print_options *);
-
-/* Prints the SCM value VALUE by invoking the inferior, if appropraite.
- Returns >= 0 on success; return -1 if the inferior cannot/should not
- print VALUE. */
-
-static int
-scm_inferior_print (struct type *type, LONGEST value, struct ui_file *stream,
- int recurse, const struct value_print_options *options)
-{
- struct value *func, *arg, *result;
- struct symbol *gdb_output_sym, *gdb_output_len_sym;
- char *output;
- int ret, output_len;
-
- func = find_function_in_inferior ("gdb_print", NULL);
- arg = value_from_longest (type, value);
-
- result = call_function_by_hand (func, 1, &arg);
- ret = (int) value_as_long (result);
- if (ret == 0)
- {
- /* XXX: Should we cache these symbols? */
- gdb_output_sym =
- lookup_symbol_global ("gdb_output", NULL, VAR_DOMAIN);
- gdb_output_len_sym =
- lookup_symbol_global ("gdb_output_length", NULL, VAR_DOMAIN);
-
- if ((gdb_output_sym == NULL) || (gdb_output_len_sym == NULL))
- ret = -1;
- else
- {
- struct value *remote_buffer;
-
- read_memory (SYMBOL_VALUE_ADDRESS (gdb_output_len_sym),
- (char *) &output_len, sizeof (output_len));
-
- output = (char *) alloca (output_len);
- remote_buffer = value_at (type,
- SYMBOL_VALUE_ADDRESS (gdb_output_sym));
- read_memory (value_as_address (remote_buffer),
- output, output_len);
-
- ui_file_write (stream, output, output_len);
- }
- }
-
- return ret;
-}
-
-/* {Names of immediate symbols}
- * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/
-
-static char *scm_isymnames[] =
-{
- /* This table must agree with the declarations */
- "and",
- "begin",
- "case",
- "cond",
- "do",
- "if",
- "lambda",
- "let",
- "let*",
- "letrec",
- "or",
- "quote",
- "set!",
- "define",
-#if 0
- "literal-variable-ref",
- "literal-variable-set!",
-#endif
- "apply",
- "call-with-current-continuation",
-
- /* user visible ISYMS */
- /* other keywords */
- /* Flags */
-
- "#f",
- "#t",
- "#<undefined>",
- "#<eof>",
- "()",
- "#<unspecified>"
-};
-
-static void
-scm_scmlist_print (struct type *type, LONGEST svalue,
- struct ui_file *stream, int recurse,
- const struct value_print_options *options)
-{
-#define SCM_SIZE (TYPE_LENGTH (type))
-#define SCM_BYTE_ORDER (gdbarch_byte_order (get_type_arch (type)))
- unsigned int more = options->print_max;
-
- if (recurse > 6)
- {
- fputs_filtered ("...", stream);
- return;
- }
- scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options);
- svalue = SCM_CDR (svalue);
- for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue))
- {
- if (SCM_NECONSP (svalue))
- break;
- fputs_filtered (" ", stream);
- if (--more == 0)
- {
- fputs_filtered ("...", stream);
- return;
- }
- scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options);
- }
- if (SCM_NNULLP (svalue))
- {
- fputs_filtered (" . ", stream);
- scm_scmval_print (type, svalue, stream, recurse + 1, options);
- }
-#undef SCM_BYTE_ORDER
-#undef SCM_SIZE
-}
-
-static void
-scm_ipruk (char *hdr, struct type *type, LONGEST ptr,
- struct ui_file *stream)
-{
-#define SCM_SIZE (TYPE_LENGTH (type))
-#define SCM_BYTE_ORDER (gdbarch_byte_order (get_type_arch (type)))
- fprintf_filtered (stream, "#<unknown-%s", hdr);
- if (SCM_CELLP (ptr))
- fprintf_filtered (stream, " (0x%lx . 0x%lx) @",
- (long) SCM_CAR (ptr), (long) SCM_CDR (ptr));
- fprintf_filtered (stream, " 0x%s>", phex_nz (ptr, SCM_SIZE));
-#undef SCM_BYTE_ORDER
-#undef SCM_SIZE
-}
-
-static void
-scm_scmval_print (struct type *type, LONGEST svalue,
- struct ui_file *stream, int recurse,
- const struct value_print_options *options)
-{
- struct gdbarch *gdbarch = get_type_arch (type);
-
-#define SCM_SIZE (TYPE_LENGTH (type))
-#define SCM_BYTE_ORDER (gdbarch_byte_order (gdbarch))
-taloop:
- switch (7 & (int) svalue)
- {
- case 2:
- case 6:
- print_longest (stream,
- options->format ? options->format : 'd',
- 1, svalue >> 2);
- break;
- case 4:
- if (SCM_ICHRP (svalue))
- {
- svalue = SCM_ICHR (svalue);
- scm_printchar (svalue, builtin_type (gdbarch)->builtin_char,
- stream);
- break;
- }
- else if (SCM_IFLAGP (svalue)
- && (SCM_ISYMNUM (svalue)
- < (sizeof scm_isymnames / sizeof (char *))))
- {
- fputs_filtered (SCM_ISYMCHARS (svalue), stream);
- break;
- }
- else if (SCM_ILOCP (svalue))
- {
- fprintf_filtered (stream, "#@%ld%c%ld",
- (long) SCM_IFRAME (svalue),
- SCM_ICDRP (svalue) ? '-' : '+',
- (long) SCM_IDIST (svalue));
- break;
- }
- else
- goto idef;
- break;
- case 1:
- /* gloc */
- svalue = SCM_CAR (svalue - 1);
- goto taloop;
- default:
- idef:
- scm_ipruk ("immediate", type, svalue, stream);
- break;
- case 0:
-
- switch (SCM_TYP7 (svalue))
- {
- case scm_tcs_cons_gloc:
- if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0)
- {
-#if 0
- SCM name;
-#endif
-
- fputs_filtered ("#<latte ", stream);
-#if 1
- fputs_filtered ("???", stream);
-#else
- name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name];
- scm_lfwrite (CHARS (name),
- (sizet) sizeof (char),
- (sizet) LENGTH (name),
- port);
-#endif
- fprintf_filtered (stream, " #X%s>", phex_nz (svalue, SCM_SIZE));
- break;
- }
- case scm_tcs_cons_imcar:
- case scm_tcs_cons_nimcar:
- fputs_filtered ("(", stream);
- scm_scmlist_print (type, svalue, stream, recurse + 1, options);
- fputs_filtered (")", stream);
- break;
- case scm_tcs_closures:
- fputs_filtered ("#<CLOSURE ", stream);
- scm_scmlist_print (type, SCM_CODE (svalue), stream,
- recurse + 1, options);
- fputs_filtered (">", stream);
- break;
- case scm_tc7_string:
- {
- int len = SCM_LENGTH (svalue);
- CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue);
- int i;
- int done = 0;
- int buf_size;
- gdb_byte buffer[64];
- int truncate = options->print_max && len > (int) options->print_max;
- if (truncate)
- len = options->print_max;
- fputs_filtered ("\"", stream);
- for (; done < len; done += buf_size)
- {
- buf_size = min (len - done, 64);
- read_memory (addr + done, buffer, buf_size);
-
- for (i = 0; i < buf_size; ++i)
- switch (buffer[i])
- {
- case '\"':
- case '\\':
- fputs_filtered ("\\", stream);
- default:
- fprintf_filtered (stream, "%c", buffer[i]);
- }
- }
- fputs_filtered (truncate ? "...\"" : "\"", stream);
- break;
- }
- break;
- case scm_tcs_symbols:
- {
- int len = SCM_LENGTH (svalue);
-
- char *str = alloca (len);
- read_memory (SCM_CDR (svalue), (gdb_byte *) str, len + 1);
- /* Should handle weird characters FIXME */
- str[len] = '\0';
- fputs_filtered (str, stream);
- break;
- }
- case scm_tc7_vector:
- {
- int len = SCM_LENGTH (svalue);
- int i;
- LONGEST elements = SCM_CDR (svalue);
- LONGEST val;
-
- fputs_filtered ("#(", stream);
- for (i = 0; i < len; ++i)
- {
- if (i > 0)
- fputs_filtered (" ", stream);
- val = scm_get_field (elements, i, SCM_SIZE, SCM_BYTE_ORDER);
- scm_scmval_print (type, val, stream, recurse + 1, options);
- }
- fputs_filtered (")", stream);
- }
- break;
-#if 0
- case tc7_lvector:
- {
- SCM result;
- SCM hook;
-
- hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
- if (hook == BOOL_F)
- {
- scm_puts ("#<locked-vector ", port);
- scm_intprint (CDR (exp), 16, port);
- scm_puts (">", port);
- }
- else
- {
- result
- = scm_apply (hook,
- scm_listify (exp, port,
- (writing ? BOOL_T : BOOL_F),
- SCM_UNDEFINED),
- EOL);
- if (result == BOOL_F)
- goto punk;
- }
- break;
- }
- break;
- case tc7_bvect:
- case tc7_ivect:
- case tc7_uvect:
- case tc7_fvect:
- case tc7_dvect:
- case tc7_cvect:
- scm_raprin1 (exp, port, writing);
- break;
-#endif
- case scm_tcs_subrs:
- {
- int index = SCM_CAR (svalue) >> 8;
-#if 1
- char str[20];
- sprintf (str, "#%d", index);
-#else
- char *str = index ? SCM_CHARS (scm_heap_org + index) : "";
-#define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
- char *str = CHARS (SNAME (exp));
-#endif
-
- fprintf_filtered (stream, "#<primitive-procedure %s>",
- str);
- }
- break;
-#if 0
-#ifdef CCLO
- case tc7_cclo:
- scm_puts ("#<compiled-closure ", port);
- scm_iprin1 (CCLO_SUBR (exp), port, writing);
- scm_putc ('>', port);
- break;
-#endif
- case tc7_contin:
- fprintf_filtered (stream, "#<continuation %d @ #X%lx >",
- LENGTH (svalue),
- (long) CHARS (svalue));
- break;
- case tc7_port:
- i = PTOBNUM (exp);
- if (i < scm_numptob
- && scm_ptobs[i].print
- && (scm_ptobs[i].print) (exp, port, writing))
- break;
- goto punk;
- case tc7_smob:
- i = SMOBNUM (exp);
- if (i < scm_numsmob && scm_smobs[i].print
- && (scm_smobs[i].print) (exp, port, writing))
- break;
- goto punk;
-#endif
- default:
-#if 0
- punk:
-#endif
- scm_ipruk ("type", type, svalue, stream);
- }
- break;
- }
-#undef SCM_BYTE_ORDER
-#undef SCM_SIZE
-}
-
-int
-scm_val_print (struct type *type, const gdb_byte *valaddr,
- int embedded_offset, CORE_ADDR address,
- struct ui_file *stream, int recurse,
- const struct value *val,
- const struct value_print_options *options)
-{
- if (is_scmvalue_type (type)
- && value_bits_valid (val, TARGET_CHAR_BIT * embedded_offset,
- TARGET_CHAR_BIT * TYPE_LENGTH (type)))
- {
- enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
- LONGEST svalue
- = extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);
-
- if (scm_inferior_print (type, svalue, stream, recurse, options) >= 0)
- {
- }
- else
- {
- scm_scmval_print (type, svalue, stream, recurse, options);
- }
-
- gdb_flush (stream);
- return (0);
- }
- else
- {
- return c_val_print (type, valaddr, 0, address, stream, recurse,
- val, options);
- }
-}
-
-int
-scm_value_print (struct value *val, struct ui_file *stream,
- const struct value_print_options *options)
-{
- struct value_print_options opts = *options;
-
- opts.deref_ref = 1;
- return (common_val_print (val, stream, 0, &opts, current_language));
-}
+2010-11-02 Tom Tromey <tromey@redhat.com>
+
+ * gdb.base/default.exp: Remove "scheme" from language list.
+
2010-11-02 Jan Kratochvil <jan.kratochvil@redhat.com>
Revert:
#test set history
gdb_test "set history" "\"set history\" must be followed by the name of a history subcommand.(\[^\r\n\]*\[\r\n\])+List of set history subcommands:(\[^\r\n\]*\[\r\n\])+set history expansion -- Set history expansion on command input(\[^\r\n\]*\[\r\n\])+set history filename -- Set the filename in which to record the command history(\[^\r\n\]*\[\r\n\])+set history save -- Set saving of the history record on exit(\[^\r\n\]*\[\r\n\])+set history size -- Set the size of the command history(\[^\r\n\]*\[\r\n\])+Type \"help set history\" followed by set history subcommand name for full documentation.(\[^\r\n\]*\[\r\n\])+Command name abbreviations are allowed if unambiguous." "set history"
#test set language
-gdb_test "set language" "Requires an argument. Valid arguments are auto, local, unknown, ada, c, c.., asm, minimal, d, fortran, objective-c, java, modula-2, pascal, scheme." "set language"
+gdb_test "set language" "Requires an argument. Valid arguments are auto, local, unknown, ada, c, c.., asm, minimal, d, fortran, objective-c, java, modula-2, pascal." "set language"
#test set listsize
gdb_test "set listsize" "Argument required .integer to set it to.*" "set listsize"
#test set print "p" abbreviation
projects / binutils-gdb.git / commitdiff