OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [gdb-5.0/] [gdb/] [scm-exp.c] - Blame information for rev 1774

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 104 markom
/* 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,
19
   Boston, MA 02111-1307, USA.  */
20
 
21
#include "defs.h"
22
#include "symtab.h"
23
#include "gdbtypes.h"
24
#include "expression.h"
25
#include "parser-defs.h"
26
#include "language.h"
27
#include "value.h"
28
#include "c-lang.h"
29
#include "scm-lang.h"
30
#include "scm-tags.h"
31
 
32
#define USE_EXPRSTRING 0
33
 
34
static void scm_lreadparen PARAMS ((int));
35
static int scm_skip_ws PARAMS ((void));
36
static void scm_read_token PARAMS ((int, int));
37
static LONGEST scm_istring2number PARAMS ((char *, int, int));
38
static LONGEST scm_istr2int PARAMS ((char *, int, int));
39
static void scm_lreadr PARAMS ((int));
40
 
41
static LONGEST
42
scm_istr2int (str, len, radix)
43
     char *str;
44
     int len;
45
     int radix;
46
{
47
  int i = 0;
48
  LONGEST inum = 0;
49
  int c;
50
  int sign = 0;
51
 
52
  if (0 >= len)
53
    return SCM_BOOL_F;          /* zero scm_length */
54
  switch (str[0])
55
    {                           /* leading sign */
56
    case '-':
57
    case '+':
58
      sign = str[0];
59
      if (++i == len)
60
        return SCM_BOOL_F;      /* bad if lone `+' or `-' */
61
    }
62
  do
63
    {
64
      switch (c = str[i++])
65
        {
66
        case '0':
67
        case '1':
68
        case '2':
69
        case '3':
70
        case '4':
71
        case '5':
72
        case '6':
73
        case '7':
74
        case '8':
75
        case '9':
76
          c = c - '0';
77
          goto accumulate;
78
        case 'A':
79
        case 'B':
80
        case 'C':
81
        case 'D':
82
        case 'E':
83
        case 'F':
84
          c = c - 'A' + 10;
85
          goto accumulate;
86
        case 'a':
87
        case 'b':
88
        case 'c':
89
        case 'd':
90
        case 'e':
91
        case 'f':
92
          c = c - 'a' + 10;
93
        accumulate:
94
          if (c >= radix)
95
            return SCM_BOOL_F;  /* bad digit for radix */
96
          inum *= radix;
97
          inum += c;
98
          break;
99
        default:
100
          return SCM_BOOL_F;    /* not a digit */
101
        }
102
    }
103
  while (i < len);
104
  if (sign == '-')
105
    inum = -inum;
106
  return SCM_MAKINUM (inum);
107
}
108
 
109
static LONGEST
110
scm_istring2number (str, len, radix)
111
     char *str;
112
     int len;
113
     int radix;
114
{
115
  int i = 0;
116
  char ex = 0;
117
  char ex_p = 0, rx_p = 0;        /* Only allow 1 exactness and 1 radix prefix */
118
#if 0
119
  SCM res;
120
#endif
121
  if (len == 1)
122
    if (*str == '+' || *str == '-')     /* Catches lone `+' and `-' for speed */
123
      return SCM_BOOL_F;
124
 
125
  while ((len - i) >= 2 && str[i] == '#' && ++i)
126
    switch (str[i++])
127
      {
128
      case 'b':
129
      case 'B':
130
        if (rx_p++)
131
          return SCM_BOOL_F;
132
        radix = 2;
133
        break;
134
      case 'o':
135
      case 'O':
136
        if (rx_p++)
137
          return SCM_BOOL_F;
138
        radix = 8;
139
        break;
140
      case 'd':
141
      case 'D':
142
        if (rx_p++)
143
          return SCM_BOOL_F;
144
        radix = 10;
145
        break;
146
      case 'x':
147
      case 'X':
148
        if (rx_p++)
149
          return SCM_BOOL_F;
150
        radix = 16;
151
        break;
152
      case 'i':
153
      case 'I':
154
        if (ex_p++)
155
          return SCM_BOOL_F;
156
        ex = 2;
157
        break;
158
      case 'e':
159
      case 'E':
160
        if (ex_p++)
161
          return SCM_BOOL_F;
162
        ex = 1;
163
        break;
164
      default:
165
        return SCM_BOOL_F;
166
      }
167
 
168
  switch (ex)
169
    {
170
    case 1:
171
      return scm_istr2int (&str[i], len - i, radix);
172
    case 0:
173
      return scm_istr2int (&str[i], len - i, radix);
174
#if 0
175
      if NFALSEP
176
        (res) return res;
177
#ifdef FLOATS
178
    case 2:
179
      return scm_istr2flo (&str[i], len - i, radix);
180
#endif
181
#endif
182
    }
183
  return SCM_BOOL_F;
184
}
185
 
186
static void
187
scm_read_token (c, weird)
188
     int c;
189
     int weird;
190
{
191
  while (1)
192
    {
193
      c = *lexptr++;
194
      switch (c)
195
        {
196
        case '[':
197
        case ']':
198
        case '(':
199
        case ')':
200
        case '\"':
201
        case ';':
202
        case ' ':
203
        case '\t':
204
        case '\r':
205
        case '\f':
206
        case '\n':
207
          if (weird)
208
            goto default_case;
209
        case '\0':              /* End of line */
210
        eof_case:
211
          --lexptr;
212
          return;
213
        case '\\':
214
          if (!weird)
215
            goto default_case;
216
          else
217
            {
218
              c = *lexptr++;
219
              if (c == '\0')
220
                goto eof_case;
221
              else
222
                goto default_case;
223
            }
224
        case '}':
225
          if (!weird)
226
            goto default_case;
227
 
228
          c = *lexptr++;
229
          if (c == '#')
230
            return;
231
          else
232
            {
233
              --lexptr;
234
              c = '}';
235
              goto default_case;
236
            }
237
 
238
        default:
239
        default_case:
240
          ;
241
        }
242
    }
243
}
244
 
245
static int
246
scm_skip_ws ()
247
{
248
  register int c;
249
  while (1)
250
    switch ((c = *lexptr++))
251
      {
252
      case '\0':
253
      goteof:
254
        return c;
255
      case ';':
256
      lp:
257
        switch ((c = *lexptr++))
258
          {
259
          case '\0':
260
            goto goteof;
261
          default:
262
            goto lp;
263
          case '\n':
264
            break;
265
          }
266
      case ' ':
267
      case '\t':
268
      case '\r':
269
      case '\f':
270
      case '\n':
271
        break;
272
      default:
273
        return c;
274
      }
275
}
276
 
277
static void
278
scm_lreadparen (skipping)
279
     int skipping;
280
{
281
  for (;;)
282
    {
283
      int c = scm_skip_ws ();
284
      if (')' == c || ']' == c)
285
        return;
286
      --lexptr;
287
      if (c == '\0')
288
        error ("missing close paren");
289
      scm_lreadr (skipping);
290
    }
291
}
292
 
293
static void
294
scm_lreadr (skipping)
295
     int skipping;
296
{
297
  int c, j;
298
  struct stoken str;
299
  LONGEST svalue = 0;
300
tryagain:
301
  c = *lexptr++;
302
  switch (c)
303
    {
304
    case '\0':
305
      lexptr--;
306
      return;
307
    case '[':
308
    case '(':
309
      scm_lreadparen (skipping);
310
      return;
311
    case ']':
312
    case ')':
313
      error ("unexpected #\\%c", c);
314
      goto tryagain;
315
    case '\'':
316
    case '`':
317
      str.ptr = lexptr - 1;
318
      scm_lreadr (skipping);
319
      if (!skipping)
320
        {
321
          value_ptr val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
322
          if (!is_scmvalue_type (VALUE_TYPE (val)))
323
            error ("quoted scm form yields non-SCM value");
324
          svalue = extract_signed_integer (VALUE_CONTENTS (val),
325
                                           TYPE_LENGTH (VALUE_TYPE (val)));
326
          goto handle_immediate;
327
        }
328
      return;
329
    case ',':
330
      c = *lexptr++;
331
      if ('@' != c)
332
        lexptr--;
333
      scm_lreadr (skipping);
334
      return;
335
    case '#':
336
      c = *lexptr++;
337
      switch (c)
338
        {
339
        case '[':
340
        case '(':
341
          scm_lreadparen (skipping);
342
          return;
343
        case 't':
344
        case 'T':
345
          svalue = SCM_BOOL_T;
346
          goto handle_immediate;
347
        case 'f':
348
        case 'F':
349
          svalue = SCM_BOOL_F;
350
          goto handle_immediate;
351
        case 'b':
352
        case 'B':
353
        case 'o':
354
        case 'O':
355
        case 'd':
356
        case 'D':
357
        case 'x':
358
        case 'X':
359
        case 'i':
360
        case 'I':
361
        case 'e':
362
        case 'E':
363
          lexptr--;
364
          c = '#';
365
          goto num;
366
        case '*':               /* bitvector */
367
          scm_read_token (c, 0);
368
          return;
369
        case '{':
370
          scm_read_token (c, 1);
371
          return;
372
        case '\\':              /* character */
373
          c = *lexptr++;
374
          scm_read_token (c, 0);
375
          return;
376
        case '|':
377
          j = 1;                /* here j is the comment nesting depth */
378
        lp:
379
          c = *lexptr++;
380
        lpc:
381
          switch (c)
382
            {
383
            case '\0':
384
              error ("unbalanced comment");
385
            default:
386
              goto lp;
387
            case '|':
388
              if ('#' != (c = *lexptr++))
389
                goto lpc;
390
              if (--j)
391
                goto lp;
392
              break;
393
            case '#':
394
              if ('|' != (c = *lexptr++))
395
                goto lpc;
396
              ++j;
397
              goto lp;
398
            }
399
          goto tryagain;
400
        case '.':
401
        default:
402
#if 0
403
        callshrp:
404
#endif
405
          scm_lreadr (skipping);
406
          return;
407
        }
408
    case '\"':
409
      while ('\"' != (c = *lexptr++))
410
        {
411
          if (c == '\\')
412
            switch (c = *lexptr++)
413
              {
414
              case '\0':
415
                error ("non-terminated string literal");
416
              case '\n':
417
                continue;
418
              case '0':
419
              case 'f':
420
              case 'n':
421
              case 'r':
422
              case 't':
423
              case 'a':
424
              case 'v':
425
                break;
426
              }
427
        }
428
      return;
429
    case '0':
430
    case '1':
431
    case '2':
432
    case '3':
433
    case '4':
434
    case '5':
435
    case '6':
436
    case '7':
437
    case '8':
438
    case '9':
439
    case '.':
440
    case '-':
441
    case '+':
442
    num:
443
      {
444
        str.ptr = lexptr - 1;
445
        scm_read_token (c, 0);
446
        if (!skipping)
447
          {
448
            svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
449
            if (svalue != SCM_BOOL_F)
450
              goto handle_immediate;
451
            goto tok;
452
          }
453
      }
454
      return;
455
    case ':':
456
      scm_read_token ('-', 0);
457
      return;
458
#if 0
459
    do_symbol:
460
#endif
461
    default:
462
      str.ptr = lexptr - 1;
463
      scm_read_token (c, 0);
464
    tok:
465
      if (!skipping)
466
        {
467
          str.length = lexptr - str.ptr;
468
          if (str.ptr[0] == '$')
469
            {
470
              write_dollar_variable (str);
471
              return;
472
            }
473
          write_exp_elt_opcode (OP_NAME);
474
          write_exp_string (str);
475
          write_exp_elt_opcode (OP_NAME);
476
        }
477
      return;
478
    }
479
handle_immediate:
480
  if (!skipping)
481
    {
482
      write_exp_elt_opcode (OP_LONG);
483
      write_exp_elt_type (builtin_type_scm);
484
      write_exp_elt_longcst (svalue);
485
      write_exp_elt_opcode (OP_LONG);
486
    }
487
}
488
 
489
int
490
scm_parse ()
491
{
492
  char *start;
493
  while (*lexptr == ' ')
494
    lexptr++;
495
  start = lexptr;
496
  scm_lreadr (USE_EXPRSTRING);
497
#if USE_EXPRSTRING
498
  str.length = lexptr - start;
499
  str.ptr = start;
500
  write_exp_elt_opcode (OP_EXPRSTRING);
501
  write_exp_string (str);
502
  write_exp_elt_opcode (OP_EXPRSTRING);
503
#endif
504
  return 0;
505
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.