lispreader.cxx

   1 /* $Id: lispreader.cxx,v 1.2 2003/01/08 23:30:43 grumbel Exp $ */
   2 /*
   3  * lispreader.c
   4  *
   5  * Copyright (C) 1998-2000 Mark Probst
   6  *
   7  * This library is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU Library General Public
   9  * License as published by the Free Software Foundation; either
  10  * version 2 of the License, or (at your option) any later version.
  11  *
  12  * This library is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15  * Library General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU Library General Public
  18  * License along with this library; if not, write to the
  19  * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20  * Boston, MA 02111-1307, USA.
  21  */
  22
  23 #include <assert.h>
  24 #include <ctype.h>
  25 #include <stdlib.h>
  26 #include <string.h>
  27
  28 #include "construo_error.hxx"
  29 #include <lispreader.hxx>
  30
  31 #define TOKEN_ERROR                   -1
  32 #define TOKEN_EOF                     0
  33 #define TOKEN_OPEN_PAREN              1
  34 #define TOKEN_CLOSE_PAREN             2
  35 #define TOKEN_SYMBOL                  3
  36 #define TOKEN_STRING                  4
  37 #define TOKEN_INTEGER                 5
  38 #define TOKEN_REAL                    6
  39 #define TOKEN_PATTERN_OPEN_PAREN      7
  40 #define TOKEN_DOT                     8
  41 #define TOKEN_TRUE                    9
  42 #define TOKEN_FALSE                   10
  43
  44
  45 #define MAX_TOKEN_LENGTH           1024
  46
  47 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
  48 static int token_length = 0;
  49
  50 static lisp_object_t end_marker = { LISP_TYPE_EOF };
  51 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR };
  52 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR };
  53 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR };
  54
  55 static void
  56 _token_clear (void)
  57 {
  58     token_string[0] = '\0';
  59     token_length = 0;
  60 }
  61
  62 static void
  63 _token_append (char c)
  64 {
  65     assert(token_length < MAX_TOKEN_LENGTH);
  66
  67     token_string[token_length++] = c;
  68     token_string[token_length] = '\0';
  69 }
  70
  71 static int
  72 _next_char (lisp_stream_t *stream)
  73 {
  74     switch (stream->type)
  75     {
  76         case LISP_STREAM_FILE :
  77             return getc(stream->v.file);
  78
  79         case LISP_STREAM_STRING :
  80             {
  81                 char c = stream->v.string.buf[stream->v.string.pos];
  82
  83                 if (c == 0)
  84                     return EOF;
  85
  86                 ++stream->v.string.pos;
  87
  88                 return c;
  89             }
  90
  91         case LISP_STREAM_ANY:
  92             return stream->v.any.next_char(stream->v.any.data);
  93     }
  94     assert(0);
  95     return EOF;
  96 }
  97
  98 static void
  99 _unget_char (char c, lisp_stream_t *stream)
 100 {
 101     switch (stream->type)
 102     {
 103         case LISP_STREAM_FILE :
 104             ungetc(c, stream->v.file);
 105             break;
 106
 107         case LISP_STREAM_STRING :
 108             --stream->v.string.pos;
 109             break;
 110
 111        case LISP_STREAM_ANY:
 112             stream->v.any.unget_char(c, stream->v.any.data);
 113             break;
 114
 115         default :
 116             assert(0);
 117     }
 118 }
 119
 120 static int
 121 _scan (lisp_stream_t *stream)
 122 {
 123     static char *delims = "\"();";
 124
 125     int c;
 126
 127     _token_clear();
 128
 129     do
 130     {
 131         c = _next_char(stream);
 132         if (c == EOF)
 133             return TOKEN_EOF;
 134         else if (c == ';')       /* comment start */
 135             while (1)
 136             {
 137                 c = _next_char(stream);
 138                 if (c == EOF)
 139                     return TOKEN_EOF;
 140                 else if (c == '\n')
 141                     break;
 142             }
 143     } while (isspace(c));
 144
 145     switch (c)
 146     {
 147         case '(' :
 148             return TOKEN_OPEN_PAREN;
 149
 150         case ')' :
 151             return TOKEN_CLOSE_PAREN;
 152
 153         case '"' :
 154             while (1)
 155             {
 156                 c = _next_char(stream);
 157                 if (c == EOF)
 158                     return TOKEN_ERROR;
 159                 if (c == '"')
 160                     break;
 161                 if (c == '\\')
 162                 {
 163                     c = _next_char(stream);
 164
 165                     switch (c)
 166                     {
 167                         case EOF :
 168                             return TOKEN_ERROR;
 169
 170                         case 'n' :
 171                             c = '\n';
 172                             break;
 173
 174                         case 't' :
 175                             c = '\t';
 176                             break;
 177                     }
 178                 }
 179
 180                 _token_append(c);
 181             }
 182             return TOKEN_STRING;
 183
 184         case '#' :
 185             c = _next_char(stream);
 186             if (c == EOF)
 187                 return TOKEN_ERROR;
 188
 189             switch (c)
 190             {
 191                 case 't' :
 192                     return TOKEN_TRUE;
 193
 194                 case 'f' :
 195                     return TOKEN_FALSE;
 196
 197                 case '?' :
 198                     c = _next_char(stream);
 199                     if (c == EOF)
 200                         return TOKEN_ERROR;
 201
 202                     if (c == '(')
 203                         return TOKEN_PATTERN_OPEN_PAREN;
 204                     else
 205                         return TOKEN_ERROR;
 206             }
 207             return TOKEN_ERROR;
 208
 209         default :
 210             if (isdigit(c) || c == '-')
 211             {
 212                 int have_nondigits = 0;
 213                 int have_digits = 0;
 214                 int have_floating_point = 0;
 215
 216                 do
 217                 {
 218                     if (isdigit(c))
 219                         have_digits = 1;
 220                     else if (c == '.')
 221                         have_floating_point++;
 222                     _token_append(c);
 223
 224                     c = _next_char(stream);
 225
 226                     if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
 227                         have_nondigits = 1;
 228                 } while (c != EOF && !isspace(c) && !strchr(delims, c));
 229
 230                 if (c != EOF)
 231                     _unget_char(c, stream);
 232
 233                 if (have_nondigits || !have_digits || have_floating_point > 1)
 234                   return TOKEN_SYMBOL;
 235                 else if (have_floating_point == 1)
 236                   return TOKEN_REAL;
 237                 else
 238                   return TOKEN_INTEGER;
 239             }
 240             else
 241             {
 242                 if (c == '.')
 243                 {
 244                     c = _next_char(stream);
 245                     if (c != EOF && !isspace(c) && !strchr(delims, c))
 246                         _token_append('.');
 247                     else
 248                     {
 249                         _unget_char(c, stream);
 250                         return TOKEN_DOT;
 251                     }
 252                 }
 253                 do
 254                 {
 255                     _token_append(c);
 256                     c = _next_char(stream);
 257                 } while (c != EOF && !isspace(c) && !strchr(delims, c));
 258                 if (c != EOF)
 259                     _unget_char(c, stream);
 260
 261                 return TOKEN_SYMBOL;
 262             }
 263     }
 264
 265     assert(0);
 266     return TOKEN_ERROR;
 267 }
 268
 269 static lisp_object_t*
 270 lisp_object_alloc (int type)
 271 {
 272     lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
 273
 274     obj->type = type;
 275
 276     return obj;
 277 }
 278
 279 lisp_stream_t*
 280 lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
 281 {
 282     stream->type = LISP_STREAM_FILE;
 283     stream->v.file = file;
 284
 285     return stream;
 286 }
 287
 288 lisp_stream_t*
 289 lisp_stream_init_string (lisp_stream_t *stream, char *buf)
 290 {
 291     stream->type = LISP_STREAM_STRING;
 292     stream->v.string.buf = buf;
 293     stream->v.string.pos = 0;
 294
 295     return stream;
 296 }
 297
 298 lisp_stream_t*
 299 lisp_stream_init_any (lisp_stream_t *stream, void *data,
 300                       int (*next_char) (void *data),
 301                       void (*unget_char) (char c, void *data))
 302 {
 303     assert(next_char != 0 && unget_char != 0);
 304
 305     stream->type = LISP_STREAM_ANY;
 306     stream->v.any.data = data;
 307     stream->v.any.next_char= next_char;
 308     stream->v.any.unget_char = unget_char;
 309
 310     return stream;
 311 }
 312
 313 lisp_object_t*
 314 lisp_make_integer (int value)
 315 {
 316     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
 317
 318     obj->v.integer = value;
 319
 320     return obj;
 321 }
 322
 323 lisp_object_t*
 324 lisp_make_real (float value)
 325 {
 326     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
 327
 328     obj->v.real = value;
 329
 330     return obj;
 331 }
 332
 333 lisp_object_t*
 334 lisp_make_symbol (const char *value)
 335 {
 336     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
 337
 338     obj->v.string = strdup(value);
 339
 340     return obj;
 341 }
 342
 343 lisp_object_t*
 344 lisp_make_string (const char *value)
 345 {
 346     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
 347
 348     obj->v.string = strdup(value);
 349
 350     return obj;
 351 }
 352
 353 lisp_object_t*
 354 lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
 355 {
 356     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
 357
 358     obj->v.cons.car = car;
 359     obj->v.cons.cdr = cdr;
 360
 361     return obj;
 362 }
 363
 364 lisp_object_t*
 365 lisp_make_boolean (int value)
 366 {
 367     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
 368
 369     obj->v.integer = value ? 1 : 0;
 370
 371     return obj;
 372 }
 373
 374 static lisp_object_t*
 375 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
 376 {
 377     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
 378
 379     obj->v.cons.car = car;
 380     obj->v.cons.cdr = cdr;
 381
 382     return obj;
 383 }
 384
 385 lisp_object_t*
 386 lisp_read (lisp_stream_t *in)
 387 {
 388     int token = _scan(in);
 389     lisp_object_t *obj = lisp_nil();
 390
 391     if (token == TOKEN_EOF)
 392         return &end_marker;
 393
 394     switch (token)
 395     {
 396         case TOKEN_ERROR :
 397             return &error_object;
 398
 399         case TOKEN_EOF :
 400             return &end_marker;
 401
 402         case TOKEN_OPEN_PAREN :
 403         case TOKEN_PATTERN_OPEN_PAREN :
 404             {
 405                 lisp_object_t *last = lisp_nil(), *car;
 406
 407                 do
 408                 {
 409                     car = lisp_read(in);
 410                     if (car == &error_object || car == &end_marker)
 411                     {
 412                         lisp_free(obj);
 413                         return &error_object;
 414                     }
 415                     else if (car == &dot_marker)
 416                     {
 417                         if (lisp_nil_p(last))
 418                         {
 419                             lisp_free(obj);
 420                             return &error_object;
 421                         }
 422
 423                         car = lisp_read(in);
 424                         if (car == &error_object || car == &end_marker)
 425                         {
 426                             lisp_free(obj);
 427                             return car;
 428                         }
 429                         else
 430                         {
 431                             last->v.cons.cdr = car;
 432
 433                             if (_scan(in) != TOKEN_CLOSE_PAREN)
 434                             {
 435                                 lisp_free(obj);
 436                                 return &error_object;
 437                             }
 438
 439                             car = &close_paren_marker;
 440                         }
 441                     }
 442                     else if (car != &close_paren_marker)
 443                     {
 444                         if (lisp_nil_p(last))
 445                             obj = last = (token == TOKEN_OPEN_PAREN ? lisp_make_cons(car, lisp_nil()) : lisp_make_pattern_cons(car, lisp_nil()));
 446                         else
 447                             last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
 448                     }
 449                 } while (car != &close_paren_marker);
 450             }
 451             return obj;
 452
 453         case TOKEN_CLOSE_PAREN :
 454             return &close_paren_marker;
 455
 456         case TOKEN_SYMBOL :
 457             return lisp_make_symbol(token_string);
 458
 459         case TOKEN_STRING :
 460             return lisp_make_string(token_string);
 461
 462         case TOKEN_INTEGER :
 463             return lisp_make_integer(atoi(token_string));
 464
 465         case TOKEN_REAL :
 466             return lisp_make_real((float)atof(token_string));
 467
 468         case TOKEN_DOT :
 469             return &dot_marker;
 470
 471         case TOKEN_TRUE :
 472             return lisp_make_boolean(1);
 473
 474         case TOKEN_FALSE :
 475             return lisp_make_boolean(0);
 476     }
 477
 478     assert(0);
 479     return &error_object;
 480 }
 481
 482 void
 483 lisp_free (lisp_object_t *obj)
 484 {
 485     if (obj == 0)
 486         return;
 487
 488     switch (obj->type)
 489     {
 490         case LISP_TYPE_INTERNAL :
 491         case LISP_TYPE_PARSE_ERROR :
 492         case LISP_TYPE_EOF :
 493             return;
 494
 495         case LISP_TYPE_SYMBOL :
 496         case LISP_TYPE_STRING :
 497             free(obj->v.string);
 498             break;
 499
 500         case LISP_TYPE_CONS :
 501         case LISP_TYPE_PATTERN_CONS :
 502             lisp_free(obj->v.cons.car);
 503             lisp_free(obj->v.cons.cdr);
 504             break;
 505
 506         case LISP_TYPE_PATTERN_VAR :
 507             lisp_free(obj->v.pattern.sub);
 508             break;
 509     }
 510
 511     free(obj);
 512 }
 513
 514 lisp_object_t*
 515 lisp_read_from_string (const char *buf)
 516 {
 517     lisp_stream_t stream;
 518
 519     lisp_stream_init_string(&stream, (char*)buf);
 520     return lisp_read(&stream);
 521 }
 522
 523 int
 524 lisp_type (lisp_object_t *obj)
 525 {
 526     if (obj == 0)
 527         return LISP_TYPE_NIL;
 528     return obj->type;
 529 }
 530
 531 int
 532 lisp_integer (lisp_object_t *obj)
 533 {
 534     assert(obj->type == LISP_TYPE_INTEGER);
 535
 536     return obj->v.integer;
 537 }
 538
 539 char*
 540 lisp_symbol (lisp_object_t *obj)
 541 {
 542     assert(obj->type == LISP_TYPE_SYMBOL);
 543
 544     return obj->v.string;
 545 }
 546
 547 char*
 548 lisp_string (lisp_object_t *obj)
 549 {
 550   if (obj->type != LISP_TYPE_STRING)
 551     ConstruoError::raise("lispreader Error: obj->type != LISP_TYPE_STRING");
 552
 553     return obj->v.string;
 554 }
 555
 556 int
 557 lisp_boolean (lisp_object_t *obj)
 558 {
 559     assert(obj->type == LISP_TYPE_BOOLEAN);
 560
 561     return obj->v.integer;
 562 }
 563
 564 float
 565 lisp_real (lisp_object_t *obj)
 566 {
 567     assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
 568
 569     if (obj->type == LISP_TYPE_INTEGER)
 570         return obj->v.integer;
 571     return obj->v.real;
 572 }
 573
 574 lisp_object_t*
 575 lisp_car (lisp_object_t *obj)
 576 {
 577   if (!(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS))
 578     ConstruoError::raise("lispreader Error: !(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS)");
 579
 580     return obj->v.cons.car;
 581 }
 582
 583 lisp_object_t*
 584 lisp_cdr (lisp_object_t *obj)
 585 {
 586     assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 587
 588     return obj->v.cons.cdr;
 589 }
 590
 591 lisp_object_t*
 592 lisp_cxr (lisp_object_t *obj, const char *x)
 593 {
 594     int i;
 595
 596     for (i = strlen(x) - 1; i >= 0; --i)
 597         if (x[i] == 'a')
 598             obj = lisp_car(obj);
 599         else if (x[i] == 'd')
 600             obj = lisp_cdr(obj);
 601         else
 602             assert(0);
 603
 604     return obj;
 605 }
 606
 607 int
 608 lisp_list_length (lisp_object_t *obj)
 609 {
 610     int length = 0;
 611
 612     while (obj != 0)
 613     {
 614         assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 615
 616         ++length;
 617         obj = obj->v.cons.cdr;
 618     }
 619
 620     return length;
 621 }
 622
 623 lisp_object_t*
 624 lisp_list_nth_cdr (lisp_object_t *obj, int index)
 625 {
 626     while (index > 0)
 627     {
 628         assert(obj != 0);
 629         assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 630
 631         --index;
 632         obj = obj->v.cons.cdr;
 633     }
 634
 635     return obj;
 636 }
 637
 638 lisp_object_t*
 639 lisp_list_nth (lisp_object_t *obj, int index)
 640 {
 641     obj = lisp_list_nth_cdr(obj, index);
 642
 643     assert(obj != 0);
 644
 645     return obj->v.cons.car;
 646 }
 647
 648 void
 649 lisp_dump (lisp_object_t *obj, FILE *out)
 650 {
 651     if (obj == 0)
 652     {
 653         fprintf(out, "()");
 654         return;
 655     }
 656
 657     switch (lisp_type(obj))
 658     {
 659         case LISP_TYPE_EOF :
 660             fputs("#<eof>", out);
 661             break;
 662
 663         case LISP_TYPE_PARSE_ERROR :
 664             fputs("#<error>", out);
 665             break;
 666
 667         case LISP_TYPE_INTEGER :
 668             fprintf(out, "%d", lisp_integer(obj));
 669             break;
 670
 671         case LISP_TYPE_REAL :
 672             fprintf(out, "%f", lisp_real(obj));
 673             break;
 674
 675         case LISP_TYPE_SYMBOL :
 676             fputs(lisp_symbol(obj), out);
 677             break;
 678
 679         case LISP_TYPE_STRING :
 680             {
 681                 char *p;
 682
 683                 fputc('"', out);
 684                 for (p = lisp_string(obj); *p != 0; ++p)
 685                 {
 686                     if (*p == '"' || *p == '\\')
 687                         fputc('\\', out);
 688                     fputc(*p, out);
 689                 }
 690                 fputc('"', out);
 691             }
 692             break;
 693
 694         case LISP_TYPE_CONS :
 695         case LISP_TYPE_PATTERN_CONS :
 696             fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
 697             while (obj != 0)
 698             {
 699                 lisp_dump(lisp_car(obj), out);
 700                 obj = lisp_cdr(obj);
 701                 if (obj != 0)
 702                 {
 703                     if (lisp_type(obj) != LISP_TYPE_CONS
 704                         && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
 705                     {
 706                         fputs(" . ", out);
 707                         lisp_dump(obj, out);
 708                         break;
 709                     }
 710                     else
 711                         fputc(' ', out);
 712                 }
 713             }
 714             fputc(')', out);
 715             break;
 716
 717         case LISP_TYPE_BOOLEAN :
 718             if (lisp_boolean(obj))
 719                 fputs("#t", out);
 720             else
 721                 fputs("#f", out);
 722             break;
 723
 724         default :
 725             assert(0);
 726     }
 727 }