1 /* Scheme/Guile language support routines for GDB, the GNU debugger.
2 Copyright 1995 Free Software Foundation, Inc.
4 This file is part of GDB.
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.
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.
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. */
23 #include "expression.h"
24 #include "parser-defs.h"
29 extern struct type
** const (c_builtin_types
[]);
30 extern value_ptr value_allocate_space_in_inferior
PARAMS ((int));
31 extern value_ptr find_function_in_inferior
PARAMS ((char*));
33 static void scm_lreadr ();
36 scm_read_token (c
, weird
)
51 case ' ': case '\t': case '\r': case '\f':
55 case '\0': /* End of line */
96 switch ((c
= *lexptr
++))
103 switch ((c
= *lexptr
++))
112 case ' ': case '\t': case '\r': case '\f': case '\n':
124 int c
= scm_skip_ws ();
125 if (')' == c
|| ']' == c
)
129 error ("missing close paren");
151 error ("unexpected #\\%c", c
);
183 case '*': /* bitvector */
184 scm_read_token (c
, 0);
187 scm_read_token (c
, 1);
189 case '\\': /* character */
191 scm_read_token (c
, 0);
194 j
= 1; /* here j is the comment nesting depth */
201 error ("unbalanced comment");
205 if ('#' != (c
= *lexptr
++))
211 if ('|' != (c
= *lexptr
++))
224 while ('\"' != (c
= *lexptr
++))
227 switch (c
= *lexptr
++)
230 error ("non-terminated string literal");
244 case '0': case '1': case '2': case '3': case '4':
245 case '5': case '6': case '7': case '8': case '9':
250 scm_read_token (c
, 0);
253 scm_read_token ('-', 0);
256 scm_read_token (c
, 0);
267 while (*lexptr
== ' ')
271 str
.length
= lexptr
- start
;
273 write_exp_elt_opcode (OP_EXPRSTRING
);
274 write_exp_string (str
);
275 write_exp_elt_opcode (OP_EXPRSTRING
);
280 scm_printchar (c
, stream
)
284 fprintf_filtered (stream
, "#\\%c", c
);
288 scm_printstr (stream
, string
, length
, force_ellipses
)
294 fprintf_filtered (stream
, "\"%s\"", string
);
298 is_object_type (type
)
301 /* FIXME - this should test for the SCM type, but we can't do that ! */
302 return TYPE_CODE (type
) == TYPE_CODE_INT
305 && strcmp (TYPE_NAME (type
), "SCM") == 0;
307 && TYPE_LENGTH (type
) == TYPE_LENGTH (builtin_type_long
)
308 && strcmp (TYPE_NAME (type
), "long int") == 0;
312 /* Prints the SCM value VALUE by invoking the inferior, if appropraite.
313 Returns >= 0 on succes; retunr -1 if the inferior cannot/should not
317 scm_inferior_print (value
, stream
, format
, deref_ref
, recurse
, pretty
)
323 enum val_prettyprint pretty
;
328 #define SCM_ITAG8_DATA(X) ((X)>>8)
329 #define SCM_ICHR(x) ((unsigned char)SCM_ITAG8_DATA(x))
330 #define SCM_ICHRP(x) (SCM_ITAG8(x) == scm_tc8_char)
331 #define scm_tc8_char 0xf4
332 #define SCM_IFLAGP(n) ((0x87 & (int)(n))==4)
333 #define SCM_ISYMNUM(n) ((int)((n)>>9))
334 #define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)])
335 #define SCM_ILOCP(n) ((0xff & (int)(n))==0xfc)
336 #define SCM_ITAG8(X) ((int)(X) & 0xff)
338 /* {Names of immediate symbols}
339 * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/
341 static char *scm_isymnames
[] =
343 /* This table must agree with the declarations */
359 "#@literal-variable-ref",
360 "#@literal-variable-set!",
363 "#@call-with-current-continuation",
365 /* user visible ISYMS */
378 scm_val_print (type
, valaddr
, address
, stream
, format
, deref_ref
, recurse
,
387 enum val_prettyprint pretty
;
389 if (is_object_type (type
))
391 LONGEST svalue
= unpack_long (type
, valaddr
);
392 if (scm_inferior_print (svalue
, stream
, format
,
393 deref_ref
, recurse
, pretty
) >= 0)
402 print_longest (stream
, format
? format
: 'd', 1, svalue
>> 2);
405 if (SCM_ICHRP (svalue
))
407 svalue
= SCM_ICHR (svalue
);
408 scm_printchar (svalue
, stream
);
411 else if (SCM_IFLAGP (svalue
)
412 && (SCM_ISYMNUM (svalue
)
413 < (sizeof scm_isymnames
/ sizeof (char *))))
415 fputs_filtered (SCM_ISYMCHARS (svalue
), stream
);
418 else if (SCM_ILOCP (svalue
))
421 fputs_filtered ("#@", stream
);
422 scm_intprint ((long) IFRAME (exp
), 10, port
);
423 scm_putc (ICDRP (exp
) ? '-' : '+', port
);
424 scm_intprint ((long) IDIST (exp
), 10, port
);
429 fprintf_filtered (stream
, "#<%lX>", svalue
);
437 return c_val_print (type
, valaddr
, address
, stream
, format
,
438 deref_ref
, recurse
, pretty
);
443 scm_value_print (val
, stream
, format
, pretty
)
447 enum val_prettyprint pretty
;
449 return (val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
),
450 VALUE_ADDRESS (val
), stream
, format
, 1, 0, pretty
));
454 evaluate_subexp_scm (expect_type
, exp
, pos
, noside
)
455 struct type
*expect_type
;
456 register struct expression
*exp
;
460 enum exp_opcode op
= exp
->elts
[*pos
].opcode
;
461 value_ptr func
, addr
;
462 int len
, pc
; char *str
;
467 len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
468 (*pos
) += 3 + BYTES_TO_EXP_ELEM (len
+ 1);
469 if (noside
== EVAL_SKIP
)
471 str
= &exp
->elts
[ + 2].string
;
472 addr
= value_allocate_space_in_inferior (len
);
473 write_memory (value_as_long (addr
), str
, len
);
474 func
= find_function_in_inferior ("scm_evstr");
475 return call_function_by_hand (func
, 1, &addr
);
478 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
480 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
483 const struct language_defn scm_language_defn
= {
484 "scheme", /* Language name */
492 scm_printchar
, /* Print a character constant */
493 scm_printstr
, /* Function to print string constant */
494 NULL
, /* Create fundamental type in this language */
495 c_print_type
, /* Print a type using appropriate syntax */
496 scm_val_print
, /* Print a value using appropriate syntax */
497 scm_value_print
, /* Print a top-level value */
498 {"", "", "", ""}, /* Binary format info */
499 {"#o%lo", "#o", "o", ""}, /* Octal format info */
500 {"%ld", "", "d", ""}, /* Decimal format info */
501 {"#x%lX", "#X", "X", ""}, /* Hex format info */
502 NULL
, /* expression operators for printing */
503 1, /* c-style arrays */
504 0, /* String lower bound */
505 &builtin_type_char
, /* Type of string elements */
510 _initialize_scheme_language ()
512 add_language (&scm_language_defn
);