src/lispreader.cpp

   1 /* $Id$ */
   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 <lispreader.h>
  29
  30 #define TOKEN_ERROR                   -1
  31 #define TOKEN_EOF                     0
  32 #define TOKEN_OPEN_PAREN              1
  33 #define TOKEN_CLOSE_PAREN             2
  34 #define TOKEN_SYMBOL                  3
  35 #define TOKEN_STRING                  4
  36 #define TOKEN_INTEGER                 5
  37 #define TOKEN_REAL                    6
  38 #define TOKEN_PATTERN_OPEN_PAREN      7
  39 #define TOKEN_DOT                     8
  40 #define TOKEN_TRUE                    9
  41 #define TOKEN_FALSE                   10
  42
  43
  44 #define MAX_TOKEN_LENGTH           1024
  45
  46 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
  47 static int token_length = 0;
  48
  49 static lisp_object_t end_marker = { LISP_TYPE_EOF };
  50 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR };
  51 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR };
  52 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR };
  53
  54 static void
  55 _token_clear (void)
  56 {
  57     token_string[0] = '\0';
  58     token_length = 0;
  59 }
  60
  61 static void
  62 _token_append (char c)
  63 {
  64     assert(token_length < MAX_TOKEN_LENGTH);
  65
  66     token_string[token_length++] = c;
  67     token_string[token_length] = '\0';
  68 }
  69
  70 static int
  71 _next_char (lisp_stream_t *stream)
  72 {
  73     switch (stream->type)
  74     {
  75         case LISP_STREAM_FILE :
  76             return getc(stream->v.file);
  77
  78         case LISP_STREAM_STRING :
  79             {
  80                 char c = stream->v.string.buf[stream->v.string.pos];
  81
  82                 if (c == 0)
  83                     return EOF;
  84
  85                 ++stream->v.string.pos;
  86
  87                 return c;
  88             }
  89
  90         case LISP_STREAM_ANY:
  91             return stream->v.any.next_char(stream->v.any.data);
  92     }
  93     assert(0);
  94     return EOF;
  95 }
  96
  97 static void
  98 _unget_char (char c, lisp_stream_t *stream)
  99 {
 100     switch (stream->type)
 101     {
 102         case LISP_STREAM_FILE :
 103             ungetc(c, stream->v.file);
 104             break;
 105
 106         case LISP_STREAM_STRING :
 107             --stream->v.string.pos;
 108             break;
 109
 110        case LISP_STREAM_ANY:
 111             stream->v.any.unget_char(c, stream->v.any.data);
 112             break;
 113
 114         default :
 115             assert(0);
 116     }
 117 }
 118
 119 static int
 120 _scan (lisp_stream_t *stream)
 121 {
 122     static char *delims = "\"();";
 123
 124     int c;
 125
 126     _token_clear();
 127
 128     do
 129     {
 130         c = _next_char(stream);
 131         if (c == EOF)
 132             return TOKEN_EOF;
 133         else if (c == ';')       /* comment start */
 134             while (1)
 135             {
 136                 c = _next_char(stream);
 137                 if (c == EOF)
 138                     return TOKEN_EOF;
 139                 else if (c == '\n')
 140                     break;
 141             }
 142     } while (isspace(c));
 143
 144     switch (c)
 145     {
 146         case '(' :
 147             return TOKEN_OPEN_PAREN;
 148
 149         case ')' :
 150             return TOKEN_CLOSE_PAREN;
 151
 152         case '"' :
 153             while (1)
 154             {
 155                 c = _next_char(stream);
 156                 if (c == EOF)
 157                     return TOKEN_ERROR;
 158                 if (c == '"')
 159                     break;
 160                 if (c == '\\')
 161                 {
 162                     c = _next_char(stream);
 163
 164                     switch (c)
 165                     {
 166                         case EOF :
 167                             return TOKEN_ERROR;
 168
 169                         case 'n' :
 170                             c = '\n';
 171                             break;
 172
 173                         case 't' :
 174                             c = '\t';
 175                             break;
 176                     }
 177                 }
 178
 179                 _token_append(c);
 180             }
 181             return TOKEN_STRING;
 182
 183         case '#' :
 184             c = _next_char(stream);
 185             if (c == EOF)
 186                 return TOKEN_ERROR;
 187
 188             switch (c)
 189             {
 190                 case 't' :
 191                     return TOKEN_TRUE;
 192
 193                 case 'f' :
 194                     return TOKEN_FALSE;
 195
 196                 case '?' :
 197                     c = _next_char(stream);
 198                     if (c == EOF)
 199                         return TOKEN_ERROR;
 200
 201                     if (c == '(')
 202                         return TOKEN_PATTERN_OPEN_PAREN;
 203                     else
 204                         return TOKEN_ERROR;
 205             }
 206             return TOKEN_ERROR;
 207
 208         default :
 209             if (isdigit(c) || c == '-')
 210             {
 211                 int have_nondigits = 0;
 212                 int have_digits = 0;
 213                 int have_floating_point = 0;
 214
 215                 do
 216                 {
 217                     if (isdigit(c))
 218                         have_digits = 1;
 219                     else if (c == '.')
 220                         have_floating_point++;
 221                     _token_append(c);
 222
 223                     c = _next_char(stream);
 224
 225                     if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
 226                         have_nondigits = 1;
 227                 } while (c != EOF && !isspace(c) && !strchr(delims, c));
 228
 229                 if (c != EOF)
 230                     _unget_char(c, stream);
 231
 232                 if (have_nondigits || !have_digits || have_floating_point > 1)
 233                   return TOKEN_SYMBOL;
 234                 else if (have_floating_point == 1)
 235                   return TOKEN_REAL;
 236                 else
 237                   return TOKEN_INTEGER;
 238             }
 239             else
 240             {
 241                 if (c == '.')
 242                 {
 243                     c = _next_char(stream);
 244                     if (c != EOF && !isspace(c) && !strchr(delims, c))
 245                         _token_append('.');
 246                     else
 247                     {
 248                         _unget_char(c, stream);
 249                         return TOKEN_DOT;
 250                     }
 251                 }
 252                 do
 253                 {
 254                     _token_append(c);
 255                     c = _next_char(stream);
 256                 } while (c != EOF && !isspace(c) && !strchr(delims, c));
 257                 if (c != EOF)
 258                     _unget_char(c, stream);
 259
 260                 return TOKEN_SYMBOL;
 261             }
 262     }
 263
 264     assert(0);
 265     return TOKEN_ERROR;
 266 }
 267
 268 static lisp_object_t*
 269 lisp_object_alloc (int type)
 270 {
 271     lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
 272
 273     obj->type = type;
 274
 275     return obj;
 276 }
 277
 278 lisp_stream_t*
 279 lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
 280 {
 281     stream->type = LISP_STREAM_FILE;
 282     stream->v.file = file;
 283
 284     return stream;
 285 }
 286
 287 lisp_stream_t*
 288 lisp_stream_init_string (lisp_stream_t *stream, char *buf)
 289 {
 290     stream->type = LISP_STREAM_STRING;
 291     stream->v.string.buf = buf;
 292     stream->v.string.pos = 0;
 293
 294     return stream;
 295 }
 296
 297 lisp_stream_t*
 298 lisp_stream_init_any (lisp_stream_t *stream, void *data,
 299                       int (*next_char) (void *data),
 300                       void (*unget_char) (char c, void *data))
 301 {
 302     assert(next_char != 0 && unget_char != 0);
 303
 304     stream->type = LISP_STREAM_ANY;
 305     stream->v.any.data = data;
 306     stream->v.any.next_char= next_char;
 307     stream->v.any.unget_char = unget_char;
 308
 309     return stream;
 310 }
 311
 312 lisp_object_t*
 313 lisp_make_integer (int value)
 314 {
 315     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
 316
 317     obj->v.integer = value;
 318
 319     return obj;
 320 }
 321
 322 lisp_object_t*
 323 lisp_make_real (float value)
 324 {
 325     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
 326
 327     obj->v.real = value;
 328
 329     return obj;
 330 }
 331
 332 lisp_object_t*
 333 lisp_make_symbol (const char *value)
 334 {
 335     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
 336
 337     obj->v.string = strdup(value);
 338
 339     return obj;
 340 }
 341
 342 lisp_object_t*
 343 lisp_make_string (const char *value)
 344 {
 345     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
 346
 347     obj->v.string = strdup(value);
 348
 349     return obj;
 350 }
 351
 352 lisp_object_t*
 353 lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
 354 {
 355     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
 356
 357     obj->v.cons.car = car;
 358     obj->v.cons.cdr = cdr;
 359
 360     return obj;
 361 }
 362
 363 lisp_object_t*
 364 lisp_make_boolean (int value)
 365 {
 366     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
 367
 368     obj->v.integer = value ? 1 : 0;
 369
 370     return obj;
 371 }
 372
 373 static lisp_object_t*
 374 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
 375 {
 376     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
 377
 378     obj->v.cons.car = car;
 379     obj->v.cons.cdr = cdr;
 380
 381     return obj;
 382 }
 383
 384 static lisp_object_t*
 385 lisp_make_pattern_var (int type, int index, lisp_object_t *sub)
 386 {
 387     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_VAR);
 388
 389     obj->v.pattern.type = type;
 390     obj->v.pattern.index = index;
 391     obj->v.pattern.sub = sub;
 392
 393     return obj;
 394 }
 395
 396 lisp_object_t*
 397 lisp_read (lisp_stream_t *in)
 398 {
 399     int token = _scan(in);
 400     lisp_object_t *obj = lisp_nil();
 401
 402     if (token == TOKEN_EOF)
 403         return &end_marker;
 404
 405     switch (token)
 406     {
 407         case TOKEN_ERROR :
 408             return &error_object;
 409
 410         case TOKEN_EOF :
 411             return &end_marker;
 412
 413         case TOKEN_OPEN_PAREN :
 414         case TOKEN_PATTERN_OPEN_PAREN :
 415             {
 416                 lisp_object_t *last = lisp_nil(), *car;
 417
 418                 do
 419                 {
 420                     car = lisp_read(in);
 421                     if (car == &error_object || car == &end_marker)
 422                     {
 423                         lisp_free(obj);
 424                         return &error_object;
 425                     }
 426                     else if (car == &dot_marker)
 427                     {
 428                         if (lisp_nil_p(last))
 429                         {
 430                             lisp_free(obj);
 431                             return &error_object;
 432                         }
 433
 434                         car = lisp_read(in);
 435                         if (car == &error_object || car == &end_marker)
 436                         {
 437                             lisp_free(obj);
 438                             return car;
 439                         }
 440                         else
 441                         {
 442                             last->v.cons.cdr = car;
 443
 444                             if (_scan(in) != TOKEN_CLOSE_PAREN)
 445                             {
 446                                 lisp_free(obj);
 447                                 return &error_object;
 448                             }
 449
 450                             car = &close_paren_marker;
 451                         }
 452                     }
 453                     else if (car != &close_paren_marker)
 454                     {
 455                         if (lisp_nil_p(last))
 456                             obj = last = (token == TOKEN_OPEN_PAREN ? lisp_make_cons(car, lisp_nil()) : lisp_make_pattern_cons(car, lisp_nil()));
 457                         else
 458                             last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
 459                     }
 460                 } while (car != &close_paren_marker);
 461             }
 462             return obj;
 463
 464         case TOKEN_CLOSE_PAREN :
 465             return &close_paren_marker;
 466
 467         case TOKEN_SYMBOL :
 468             return lisp_make_symbol(token_string);
 469
 470         case TOKEN_STRING :
 471             return lisp_make_string(token_string);
 472
 473         case TOKEN_INTEGER :
 474             return lisp_make_integer(atoi(token_string));
 475
 476         case TOKEN_REAL :
 477             return lisp_make_real((float)atof(token_string));
 478
 479         case TOKEN_DOT :
 480             return &dot_marker;
 481
 482         case TOKEN_TRUE :
 483             return lisp_make_boolean(1);
 484
 485         case TOKEN_FALSE :
 486             return lisp_make_boolean(0);
 487     }
 488
 489     assert(0);
 490     return &error_object;
 491 }
 492
 493 void
 494 lisp_free (lisp_object_t *obj)
 495 {
 496     if (obj == 0)
 497         return;
 498
 499     switch (obj->type)
 500     {
 501         case LISP_TYPE_INTERNAL :
 502         case LISP_TYPE_PARSE_ERROR :
 503         case LISP_TYPE_EOF :
 504             return;
 505
 506         case LISP_TYPE_SYMBOL :
 507         case LISP_TYPE_STRING :
 508             free(obj->v.string);
 509             break;
 510
 511         case LISP_TYPE_CONS :
 512         case LISP_TYPE_PATTERN_CONS :
 513             lisp_free(obj->v.cons.car);
 514             lisp_free(obj->v.cons.cdr);
 515             break;
 516
 517         case LISP_TYPE_PATTERN_VAR :
 518             lisp_free(obj->v.pattern.sub);
 519             break;
 520     }
 521
 522     free(obj);
 523 }
 524
 525 lisp_object_t*
 526 lisp_read_from_string (const char *buf)
 527 {
 528     lisp_stream_t stream;
 529
 530     lisp_stream_init_string(&stream, (char*)buf);
 531     return lisp_read(&stream);
 532 }
 533
 534 static int
 535 _compile_pattern (lisp_object_t **obj, int *index)
 536 {
 537     if (*obj == 0)
 538         return 1;
 539
 540     switch (lisp_type(*obj))
 541     {
 542         case LISP_TYPE_PATTERN_CONS :
 543             {
 544                 struct { char *name; int type; } types[] =
 545                                                  {
 546                                                      { "any", LISP_PATTERN_ANY },
 547                                                      { "symbol", LISP_PATTERN_SYMBOL },
 548                                                      { "string", LISP_PATTERN_STRING },
 549                                                      { "integer", LISP_PATTERN_INTEGER },
 550                                                      { "real", LISP_PATTERN_REAL },
 551                                                      { "boolean", LISP_PATTERN_BOOLEAN },
 552                                                      { "list", LISP_PATTERN_LIST },
 553                                                      { "or", LISP_PATTERN_OR },
 554                                                      { 0, 0 }
 555                                                  };
 556                 char *type_name;
 557                 int type;
 558                 int i;
 559                 lisp_object_t *pattern;
 560
 561                 if (lisp_type(lisp_car(*obj)) != LISP_TYPE_SYMBOL)
 562                     return 0;
 563
 564                 type_name = lisp_symbol(lisp_car(*obj));
 565                 for (i = 0; types[i].name != 0; ++i)
 566                 {
 567                     if (strcmp(types[i].name, type_name) == 0)
 568                     {
 569                         type = types[i].type;
 570                         break;
 571                     }
 572                 }
 573
 574                 if (types[i].name == 0)
 575                     return 0;
 576
 577                 if (type != LISP_PATTERN_OR && lisp_cdr(*obj) != 0)
 578                     return 0;
 579
 580                 pattern = lisp_make_pattern_var(type, (*index)++, lisp_nil());
 581
 582                 if (type == LISP_PATTERN_OR)
 583                 {
 584                     lisp_object_t *cdr = lisp_cdr(*obj);
 585
 586                     if (!_compile_pattern(&cdr, index))
 587                     {
 588                         lisp_free(pattern);
 589                         return 0;
 590                     }
 591
 592                     pattern->v.pattern.sub = cdr;
 593
 594                     (*obj)->v.cons.cdr = lisp_nil();
 595                 }
 596
 597                 lisp_free(*obj);
 598
 599                 *obj = pattern;
 600             }
 601             break;
 602
 603         case LISP_TYPE_CONS :
 604             if (!_compile_pattern(&(*obj)->v.cons.car, index))
 605                 return 0;
 606             if (!_compile_pattern(&(*obj)->v.cons.cdr, index))
 607                 return 0;
 608             break;
 609     }
 610
 611     return 1;
 612 }
 613
 614 int
 615 lisp_compile_pattern (lisp_object_t **obj, int *num_subs)
 616 {
 617     int index = 0;
 618     int result;
 619
 620     result = _compile_pattern(obj, &index);
 621
 622     if (result && num_subs != 0)
 623         *num_subs = index;
 624
 625     return result;
 626 }
 627
 628 static int _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars);
 629
 630 static int
 631 _match_pattern_var (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
 632 {
 633     assert(lisp_type(pattern) == LISP_TYPE_PATTERN_VAR);
 634
 635     switch (pattern->v.pattern.type)
 636     {
 637         case LISP_PATTERN_ANY :
 638             break;
 639
 640         case LISP_PATTERN_SYMBOL :
 641             if (obj == 0 || lisp_type(obj) != LISP_TYPE_SYMBOL)
 642                 return 0;
 643             break;
 644
 645         case LISP_PATTERN_STRING :
 646             if (obj == 0 || lisp_type(obj) != LISP_TYPE_STRING)
 647                 return 0;
 648             break;
 649
 650         case LISP_PATTERN_INTEGER :
 651             if (obj == 0 || lisp_type(obj) != LISP_TYPE_INTEGER)
 652                 return 0;
 653             break;
 654
 655         case LISP_PATTERN_REAL :
 656             if (obj == 0 || lisp_type(obj) != LISP_TYPE_REAL)
 657                 return 0;
 658             break;
 659
 660         case LISP_PATTERN_BOOLEAN :
 661             if (obj == 0 || lisp_type(obj) != LISP_TYPE_BOOLEAN)
 662                 return 0;
 663             break;
 664
 665         case LISP_PATTERN_LIST :
 666             if (obj == 0 || lisp_type(obj) != LISP_TYPE_CONS)
 667                 return 0;
 668             break;
 669
 670         case LISP_PATTERN_OR :
 671             {
 672                 lisp_object_t *sub;
 673                 int matched = 0;
 674
 675                 for (sub = pattern->v.pattern.sub; sub != 0; sub = lisp_cdr(sub))
 676                 {
 677                     assert(lisp_type(sub) == LISP_TYPE_CONS);
 678
 679                     if (_match_pattern(lisp_car(sub), obj, vars))
 680                         matched = 1;
 681                 }
 682
 683                 if (!matched)
 684                     return 0;
 685             }
 686             break;
 687
 688         default :
 689             assert(0);
 690     }
 691
 692     if (vars != 0)
 693         vars[pattern->v.pattern.index] = obj;
 694
 695     return 1;
 696 }
 697
 698 static int
 699 _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
 700 {
 701     if (pattern == 0)
 702         return obj == 0;
 703
 704     if (obj == 0)
 705         return 0;
 706
 707     if (lisp_type(pattern) == LISP_TYPE_PATTERN_VAR)
 708         return _match_pattern_var(pattern, obj, vars);
 709
 710     if (lisp_type(pattern) != lisp_type(obj))
 711         return 0;
 712
 713     switch (lisp_type(pattern))
 714     {
 715         case LISP_TYPE_SYMBOL :
 716             return strcmp(lisp_symbol(pattern), lisp_symbol(obj)) == 0;
 717
 718         case LISP_TYPE_STRING :
 719             return strcmp(lisp_string(pattern), lisp_string(obj)) == 0;
 720
 721         case LISP_TYPE_INTEGER :
 722             return lisp_integer(pattern) == lisp_integer(obj);
 723
 724         case LISP_TYPE_REAL :
 725             return lisp_real(pattern) == lisp_real(obj);
 726
 727         case LISP_TYPE_CONS :
 728             {
 729                 int result1, result2;
 730
 731                 result1 = _match_pattern(lisp_car(pattern), lisp_car(obj), vars);
 732                 result2 = _match_pattern(lisp_cdr(pattern), lisp_cdr(obj), vars);
 733
 734                 return result1 && result2;
 735             }
 736             break;
 737
 738         default :
 739             assert(0);
 740     }
 741
 742     return 0;
 743 }
 744
 745 int
 746 lisp_match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars, int num_subs)
 747 {
 748     int i;
 749
 750     if (vars != 0)
 751         for (i = 0; i < num_subs; ++i)
 752             vars[i] = &error_object;
 753
 754     return _match_pattern(pattern, obj, vars);
 755 }
 756
 757 int
 758 lisp_match_string (const char *pattern_string, lisp_object_t *obj, lisp_object_t **vars)
 759 {
 760     lisp_object_t *pattern;
 761     int result;
 762     int num_subs;
 763
 764     pattern = lisp_read_from_string(pattern_string);
 765
 766     if (pattern != 0 && (lisp_type(pattern) == LISP_TYPE_EOF
 767                          || lisp_type(pattern) == LISP_TYPE_PARSE_ERROR))
 768         return 0;
 769
 770     if (!lisp_compile_pattern(&pattern, &num_subs))
 771     {
 772         lisp_free(pattern);
 773         return 0;
 774     }
 775
 776     result = lisp_match_pattern(pattern, obj, vars, num_subs);
 777
 778     lisp_free(pattern);
 779
 780     return result;
 781 }
 782
 783 int
 784 lisp_type (lisp_object_t *obj)
 785 {
 786     if (obj == 0)
 787         return LISP_TYPE_NIL;
 788     return obj->type;
 789 }
 790
 791 int
 792 lisp_integer (lisp_object_t *obj)
 793 {
 794     assert(obj->type == LISP_TYPE_INTEGER);
 795
 796     return obj->v.integer;
 797 }
 798
 799 char*
 800 lisp_symbol (lisp_object_t *obj)
 801 {
 802     assert(obj->type == LISP_TYPE_SYMBOL);
 803
 804     return obj->v.string;
 805 }
 806
 807 char*
 808 lisp_string (lisp_object_t *obj)
 809 {
 810     assert(obj->type == LISP_TYPE_STRING);
 811
 812     return obj->v.string;
 813 }
 814
 815 int
 816 lisp_boolean (lisp_object_t *obj)
 817 {
 818     assert(obj->type == LISP_TYPE_BOOLEAN);
 819
 820     return obj->v.integer;
 821 }
 822
 823 float
 824 lisp_real (lisp_object_t *obj)
 825 {
 826     assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
 827
 828     if (obj->type == LISP_TYPE_INTEGER)
 829         return obj->v.integer;
 830     return obj->v.real;
 831 }
 832
 833 lisp_object_t*
 834 lisp_car (lisp_object_t *obj)
 835 {
 836     assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 837
 838     return obj->v.cons.car;
 839 }
 840
 841 lisp_object_t*
 842 lisp_cdr (lisp_object_t *obj)
 843 {
 844     assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 845
 846     return obj->v.cons.cdr;
 847 }
 848
 849 lisp_object_t*
 850 lisp_cxr (lisp_object_t *obj, const char *x)
 851 {
 852     int i;
 853
 854     for (i = strlen(x) - 1; i >= 0; --i)
 855         if (x[i] == 'a')
 856             obj = lisp_car(obj);
 857         else if (x[i] == 'd')
 858             obj = lisp_cdr(obj);
 859         else
 860             assert(0);
 861
 862     return obj;
 863 }
 864
 865 int
 866 lisp_list_length (lisp_object_t *obj)
 867 {
 868     int length = 0;
 869
 870     while (obj != 0)
 871     {
 872         assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 873
 874         ++length;
 875         obj = obj->v.cons.cdr;
 876     }
 877
 878     return length;
 879 }
 880
 881 lisp_object_t*
 882 lisp_list_nth_cdr (lisp_object_t *obj, int index)
 883 {
 884     while (index > 0)
 885     {
 886         assert(obj != 0);
 887         assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 888
 889         --index;
 890         obj = obj->v.cons.cdr;
 891     }
 892
 893     return obj;
 894 }
 895
 896 lisp_object_t*
 897 lisp_list_nth (lisp_object_t *obj, int index)
 898 {
 899     obj = lisp_list_nth_cdr(obj, index);
 900
 901     assert(obj != 0);
 902
 903     return obj->v.cons.car;
 904 }
 905
 906 void
 907 lisp_dump (lisp_object_t *obj, FILE *out)
 908 {
 909     if (obj == 0)
 910     {
 911         fprintf(out, "()");
 912         return;
 913     }
 914
 915     switch (lisp_type(obj))
 916     {
 917         case LISP_TYPE_EOF :
 918             fputs("#<eof>", out);
 919             break;
 920
 921         case LISP_TYPE_PARSE_ERROR :
 922             fputs("#<error>", out);
 923             break;
 924
 925         case LISP_TYPE_INTEGER :
 926             fprintf(out, "%d", lisp_integer(obj));
 927             break;
 928
 929         case LISP_TYPE_REAL :
 930             fprintf(out, "%f", lisp_real(obj));
 931             break;
 932
 933         case LISP_TYPE_SYMBOL :
 934             fputs(lisp_symbol(obj), out);
 935             break;
 936
 937         case LISP_TYPE_STRING :
 938             {
 939                 char *p;
 940
 941                 fputc('"', out);
 942                 for (p = lisp_string(obj); *p != 0; ++p)
 943                 {
 944                     if (*p == '"' || *p == '\\')
 945                         fputc('\\', out);
 946                     fputc(*p, out);
 947                 }
 948                 fputc('"', out);
 949             }
 950             break;
 951
 952         case LISP_TYPE_CONS :
 953         case LISP_TYPE_PATTERN_CONS :
 954             fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
 955             while (obj != 0)
 956             {
 957                 lisp_dump(lisp_car(obj), out);
 958                 obj = lisp_cdr(obj);
 959                 if (obj != 0)
 960                 {
 961                     if (lisp_type(obj) != LISP_TYPE_CONS
 962                         && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
 963                     {
 964                         fputs(" . ", out);
 965                         lisp_dump(obj, out);
 966                         break;
 967                     }
 968                     else
 969                         fputc(' ', out);
 970                 }
 971             }
 972             fputc(')', out);
 973             break;
 974
 975         case LISP_TYPE_BOOLEAN :
 976             if (lisp_boolean(obj))
 977                 fputs("#t", out);
 978             else
 979                 fputs("#f", out);
 980             break;
 981
 982         default :
 983             assert(0);
 984     }
 985 }