src/lispreader.cpp

   1 /* $Id$ */
   2 /*
   3  * lispreader.c
   4  *
   5  * Copyright (C) 1998-2000 Mark Probst
   6  * Copyright (C) 2002 Ingo Ruhnke <grumbel@gmx.de>
   7  *
   8  * This library is free software; you can redistribute it and/or
   9  * modify it under the terms of the GNU Library General Public
  10  * License as published by the Free Software Foundation; either
  11  * version 2 of the License, or (at your option) any later version.
  12  *
  13  * This library is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16  * Library General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU Library General Public
  19  * License along with this library; if not, write to the
  20  * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21  * Boston, MA 02111-1307, USA.
  22  */
  23
  24 #include <string>
  25 #include <assert.h>
  26 #include <ctype.h>
  27 #include <stdlib.h>
  28 #include <string.h>
  29
  30 #include "lispreader.h"
  31
  32 #define TOKEN_ERROR                   -1
  33 #define TOKEN_EOF                     0
  34 #define TOKEN_OPEN_PAREN              1
  35 #define TOKEN_CLOSE_PAREN             2
  36 #define TOKEN_SYMBOL                  3
  37 #define TOKEN_STRING                  4
  38 #define TOKEN_INTEGER                 5
  39 #define TOKEN_REAL                    6
  40 #define TOKEN_PATTERN_OPEN_PAREN      7
  41 #define TOKEN_DOT                     8
  42 #define TOKEN_TRUE                    9
  43 #define TOKEN_FALSE                   10
  44
  45
  46 #define MAX_TOKEN_LENGTH           1024
  47
  48 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
  49 static int token_length = 0;
  50
  51 static lisp_object_t end_marker = { LISP_TYPE_EOF };
  52 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR };
  53 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR };
  54 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR };
  55
  56 static void
  57 _token_clear (void)
  58 {
  59   token_string[0] = '\0';
  60   token_length = 0;
  61 }
  62
  63 static void
  64 _token_append (char c)
  65 {
  66   assert(token_length < MAX_TOKEN_LENGTH);
  67
  68   token_string[token_length++] = c;
  69   token_string[token_length] = '\0';
  70 }
  71
  72 static int
  73 _next_char (lisp_stream_t *stream)
  74 {
  75   switch (stream->type)
  76     {
  77     case LISP_STREAM_FILE :
  78       return getc(stream->v.file);
  79
  80     case LISP_STREAM_STRING :
  81       {
  82         char c = stream->v.string.buf[stream->v.string.pos];
  83
  84         if (c == 0)
  85           return EOF;
  86
  87         ++stream->v.string.pos;
  88
  89         return c;
  90       }
  91
  92     case LISP_STREAM_ANY:
  93       return stream->v.any.next_char(stream->v.any.data);
  94     }
  95   assert(0);
  96   return EOF;
  97 }
  98
  99 static void
 100 _unget_char (char c, lisp_stream_t *stream)
 101 {
 102   switch (stream->type)
 103     {
 104     case LISP_STREAM_FILE :
 105       ungetc(c, stream->v.file);
 106       break;
 107
 108     case LISP_STREAM_STRING :
 109       --stream->v.string.pos;
 110       break;
 111
 112     case LISP_STREAM_ANY:
 113       stream->v.any.unget_char(c, stream->v.any.data);
 114       break;
 115
 116     default :
 117       assert(0);
 118     }
 119 }
 120
 121 static int
 122 _scan (lisp_stream_t *stream)
 123 {
 124   static char *delims = "\"();";
 125
 126   int c;
 127
 128   _token_clear();
 129
 130   do
 131     {
 132       c = _next_char(stream);
 133       if (c == EOF)
 134         return TOKEN_EOF;
 135       else if (c == ';')         /* comment start */
 136         while (1)
 137           {
 138             c = _next_char(stream);
 139             if (c == EOF)
 140               return TOKEN_EOF;
 141             else if (c == '\n')
 142               break;
 143           }
 144     }
 145   while (isspace(c));
 146
 147   switch (c)
 148     {
 149     case '(' :
 150       return TOKEN_OPEN_PAREN;
 151
 152     case ')' :
 153       return TOKEN_CLOSE_PAREN;
 154
 155     case '"' :
 156       while (1)
 157         {
 158           c = _next_char(stream);
 159           if (c == EOF)
 160             return TOKEN_ERROR;
 161           if (c == '"')
 162             break;
 163           if (c == '\\')
 164             {
 165               c = _next_char(stream);
 166
 167               switch (c)
 168                 {
 169                 case EOF :
 170                   return TOKEN_ERROR;
 171
 172                 case 'n' :
 173                   c = '\n';
 174                   break;
 175
 176                 case 't' :
 177                   c = '\t';
 178                   break;
 179                 }
 180             }
 181
 182           _token_append(c);
 183         }
 184       return TOKEN_STRING;
 185
 186     case '#' :
 187       c = _next_char(stream);
 188       if (c == EOF)
 189         return TOKEN_ERROR;
 190
 191       switch (c)
 192         {
 193         case 't' :
 194           return TOKEN_TRUE;
 195
 196         case 'f' :
 197           return TOKEN_FALSE;
 198
 199         case '?' :
 200           c = _next_char(stream);
 201           if (c == EOF)
 202             return TOKEN_ERROR;
 203
 204           if (c == '(')
 205             return TOKEN_PATTERN_OPEN_PAREN;
 206           else
 207             return TOKEN_ERROR;
 208         }
 209       return TOKEN_ERROR;
 210
 211     default :
 212       if (isdigit(c) || c == '-')
 213         {
 214           int have_nondigits = 0;
 215           int have_digits = 0;
 216           int have_floating_point = 0;
 217
 218           do
 219             {
 220               if (isdigit(c))
 221                 have_digits = 1;
 222               else if (c == '.')
 223                 have_floating_point++;
 224               _token_append(c);
 225
 226               c = _next_char(stream);
 227
 228               if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
 229                 have_nondigits = 1;
 230             }
 231           while (c != EOF && !isspace(c) && !strchr(delims, c));
 232
 233           if (c != EOF)
 234             _unget_char(c, stream);
 235
 236           if (have_nondigits || !have_digits || have_floating_point > 1)
 237             return TOKEN_SYMBOL;
 238           else if (have_floating_point == 1)
 239             return TOKEN_REAL;
 240           else
 241             return TOKEN_INTEGER;
 242         }
 243       else
 244         {
 245           if (c == '.')
 246             {
 247               c = _next_char(stream);
 248               if (c != EOF && !isspace(c) && !strchr(delims, c))
 249                 _token_append('.');
 250               else
 251                 {
 252                   _unget_char(c, stream);
 253                   return TOKEN_DOT;
 254                 }
 255             }
 256           do
 257             {
 258               _token_append(c);
 259               c = _next_char(stream);
 260             }
 261           while (c != EOF && !isspace(c) && !strchr(delims, c));
 262           if (c != EOF)
 263             _unget_char(c, stream);
 264
 265           return TOKEN_SYMBOL;
 266         }
 267     }
 268
 269   assert(0);
 270   return TOKEN_ERROR;
 271 }
 272
 273 static lisp_object_t*
 274 lisp_object_alloc (int type)
 275 {
 276   lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
 277
 278   obj->type = type;
 279
 280   return obj;
 281 }
 282
 283 lisp_stream_t*
 284 lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
 285 {
 286   stream->type = LISP_STREAM_FILE;
 287   stream->v.file = file;
 288
 289   return stream;
 290 }
 291
 292 lisp_stream_t*
 293 lisp_stream_init_string (lisp_stream_t *stream, char *buf)
 294 {
 295   stream->type = LISP_STREAM_STRING;
 296   stream->v.string.buf = buf;
 297   stream->v.string.pos = 0;
 298
 299   return stream;
 300 }
 301
 302 lisp_stream_t*
 303 lisp_stream_init_any (lisp_stream_t *stream, void *data,
 304                       int (*next_char) (void *data),
 305                       void (*unget_char) (char c, void *data))
 306 {
 307   assert(next_char != 0 && unget_char != 0);
 308
 309   stream->type = LISP_STREAM_ANY;
 310   stream->v.any.data = data;
 311   stream->v.any.next_char= next_char;
 312   stream->v.any.unget_char = unget_char;
 313
 314   return stream;
 315 }
 316
 317 lisp_object_t*
 318 lisp_make_integer (int value)
 319 {
 320   lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
 321
 322   obj->v.integer = value;
 323
 324   return obj;
 325 }
 326
 327 lisp_object_t*
 328 lisp_make_real (float value)
 329 {
 330   lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
 331
 332   obj->v.real = value;
 333
 334   return obj;
 335 }
 336
 337 lisp_object_t*
 338 lisp_make_symbol (const char *value)
 339 {
 340   lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
 341
 342   obj->v.string = strdup(value);
 343
 344   return obj;
 345 }
 346
 347 lisp_object_t*
 348 lisp_make_string (const char *value)
 349 {
 350   lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
 351
 352   obj->v.string = strdup(value);
 353
 354   return obj;
 355 }
 356
 357 lisp_object_t*
 358 lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
 359 {
 360   lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
 361
 362   obj->v.cons.car = car;
 363   obj->v.cons.cdr = cdr;
 364
 365   return obj;
 366 }
 367
 368 lisp_object_t*
 369 lisp_make_boolean (int value)
 370 {
 371   lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
 372
 373   obj->v.integer = value ? 1 : 0;
 374
 375   return obj;
 376 }
 377
 378 static lisp_object_t*
 379 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
 380 {
 381   lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
 382
 383   obj->v.cons.car = car;
 384   obj->v.cons.cdr = cdr;
 385
 386   return obj;
 387 }
 388
 389 static lisp_object_t*
 390 lisp_make_pattern_var (int type, int index, lisp_object_t *sub)
 391 {
 392   lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_VAR);
 393
 394   obj->v.pattern.type = type;
 395   obj->v.pattern.index = index;
 396   obj->v.pattern.sub = sub;
 397
 398   return obj;
 399 }
 400
 401 lisp_object_t*
 402 lisp_read (lisp_stream_t *in)
 403 {
 404   int token = _scan(in);
 405   lisp_object_t *obj = lisp_nil();
 406
 407   if (token == TOKEN_EOF)
 408     return &end_marker;
 409
 410   switch (token)
 411     {
 412     case TOKEN_ERROR :
 413       return &error_object;
 414
 415     case TOKEN_EOF :
 416       return &end_marker;
 417
 418     case TOKEN_OPEN_PAREN :
 419     case TOKEN_PATTERN_OPEN_PAREN :
 420       {
 421         lisp_object_t *last = lisp_nil(), *car;
 422
 423         do
 424           {
 425             car = lisp_read(in);
 426             if (car == &error_object || car == &end_marker)
 427               {
 428                 lisp_free(obj);
 429                 return &error_object;
 430               }
 431             else if (car == &dot_marker)
 432               {
 433                 if (lisp_nil_p(last))
 434                   {
 435                     lisp_free(obj);
 436                     return &error_object;
 437                   }
 438
 439                 car = lisp_read(in);
 440                 if (car == &error_object || car == &end_marker)
 441                   {
 442                     lisp_free(obj);
 443                     return car;
 444                   }
 445                 else
 446                   {
 447                     last->v.cons.cdr = car;
 448
 449                     if (_scan(in) != TOKEN_CLOSE_PAREN)
 450                       {
 451                         lisp_free(obj);
 452                         return &error_object;
 453                       }
 454
 455                     car = &close_paren_marker;
 456                   }
 457               }
 458             else if (car != &close_paren_marker)
 459               {
 460                 if (lisp_nil_p(last))
 461                   obj = last = (token == TOKEN_OPEN_PAREN ? lisp_make_cons(car, lisp_nil()) : lisp_make_pattern_cons(car, lisp_nil()));
 462                 else
 463                   last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
 464               }
 465           }
 466         while (car != &close_paren_marker);
 467       }
 468       return obj;
 469
 470     case TOKEN_CLOSE_PAREN :
 471       return &close_paren_marker;
 472
 473     case TOKEN_SYMBOL :
 474       return lisp_make_symbol(token_string);
 475
 476     case TOKEN_STRING :
 477       return lisp_make_string(token_string);
 478
 479     case TOKEN_INTEGER :
 480       return lisp_make_integer(atoi(token_string));
 481
 482     case TOKEN_REAL :
 483       return lisp_make_real((float)atof(token_string));
 484
 485     case TOKEN_DOT :
 486       return &dot_marker;
 487
 488     case TOKEN_TRUE :
 489       return lisp_make_boolean(1);
 490
 491     case TOKEN_FALSE :
 492       return lisp_make_boolean(0);
 493     }
 494
 495   assert(0);
 496   return &error_object;
 497 }
 498
 499 void
 500 lisp_free (lisp_object_t *obj)
 501 {
 502   if (obj == 0)
 503     return;
 504
 505   switch (obj->type)
 506     {
 507     case LISP_TYPE_INTERNAL :
 508     case LISP_TYPE_PARSE_ERROR :
 509     case LISP_TYPE_EOF :
 510       return;
 511
 512     case LISP_TYPE_SYMBOL :
 513     case LISP_TYPE_STRING :
 514       free(obj->v.string);
 515       break;
 516
 517     case LISP_TYPE_CONS :
 518     case LISP_TYPE_PATTERN_CONS :
 519       lisp_free(obj->v.cons.car);
 520       lisp_free(obj->v.cons.cdr);
 521       break;
 522
 523     case LISP_TYPE_PATTERN_VAR :
 524       lisp_free(obj->v.pattern.sub);
 525       break;
 526     }
 527
 528   free(obj);
 529 }
 530
 531 lisp_object_t*
 532 lisp_read_from_string (const char *buf)
 533 {
 534   lisp_stream_t stream;
 535
 536   lisp_stream_init_string(&stream, (char*)buf);
 537   return lisp_read(&stream);
 538 }
 539
 540 static int
 541 _compile_pattern (lisp_object_t **obj, int *index)
 542 {
 543   if (*obj == 0)
 544     return 1;
 545
 546   switch (lisp_type(*obj))
 547     {
 548     case LISP_TYPE_PATTERN_CONS :
 549       {
 550         struct
 551           {
 552             char *name;
 553             int type;
 554           }
 555         types[] =
 556           {
 557             { "any", LISP_PATTERN_ANY },
 558             { "symbol", LISP_PATTERN_SYMBOL },
 559             { "string", LISP_PATTERN_STRING },
 560             { "integer", LISP_PATTERN_INTEGER },
 561             { "real", LISP_PATTERN_REAL },
 562             { "boolean", LISP_PATTERN_BOOLEAN },
 563             { "list", LISP_PATTERN_LIST },
 564             { "or", LISP_PATTERN_OR },
 565             { 0, 0 }
 566           };
 567         char *type_name;
 568         int type;
 569         int i;
 570         lisp_object_t *pattern;
 571
 572         if (lisp_type(lisp_car(*obj)) != LISP_TYPE_SYMBOL)
 573           return 0;
 574
 575         type_name = lisp_symbol(lisp_car(*obj));
 576         for (i = 0; types[i].name != 0; ++i)
 577           {
 578             if (strcmp(types[i].name, type_name) == 0)
 579               {
 580                 type = types[i].type;
 581                 break;
 582               }
 583           }
 584
 585         if (types[i].name == 0)
 586           return 0;
 587
 588         if (type != LISP_PATTERN_OR && lisp_cdr(*obj) != 0)
 589           return 0;
 590
 591         pattern = lisp_make_pattern_var(type, (*index)++, lisp_nil());
 592
 593         if (type == LISP_PATTERN_OR)
 594           {
 595             lisp_object_t *cdr = lisp_cdr(*obj);
 596
 597             if (!_compile_pattern(&cdr, index))
 598               {
 599                 lisp_free(pattern);
 600                 return 0;
 601               }
 602
 603             pattern->v.pattern.sub = cdr;
 604
 605             (*obj)->v.cons.cdr = lisp_nil();
 606           }
 607
 608         lisp_free(*obj);
 609
 610         *obj = pattern;
 611       }
 612       break;
 613
 614     case LISP_TYPE_CONS :
 615       if (!_compile_pattern(&(*obj)->v.cons.car, index))
 616         return 0;
 617       if (!_compile_pattern(&(*obj)->v.cons.cdr, index))
 618         return 0;
 619       break;
 620     }
 621
 622   return 1;
 623 }
 624
 625 int
 626 lisp_compile_pattern (lisp_object_t **obj, int *num_subs)
 627 {
 628   int index = 0;
 629   int result;
 630
 631   result = _compile_pattern(obj, &index);
 632
 633   if (result && num_subs != 0)
 634     *num_subs = index;
 635
 636   return result;
 637 }
 638
 639 static int _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars);
 640
 641 static int
 642 _match_pattern_var (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
 643 {
 644   assert(lisp_type(pattern) == LISP_TYPE_PATTERN_VAR);
 645
 646   switch (pattern->v.pattern.type)
 647     {
 648     case LISP_PATTERN_ANY :
 649       break;
 650
 651     case LISP_PATTERN_SYMBOL :
 652       if (obj == 0 || lisp_type(obj) != LISP_TYPE_SYMBOL)
 653         return 0;
 654       break;
 655
 656     case LISP_PATTERN_STRING :
 657       if (obj == 0 || lisp_type(obj) != LISP_TYPE_STRING)
 658         return 0;
 659       break;
 660
 661     case LISP_PATTERN_INTEGER :
 662       if (obj == 0 || lisp_type(obj) != LISP_TYPE_INTEGER)
 663         return 0;
 664       break;
 665
 666     case LISP_PATTERN_REAL :
 667       if (obj == 0 || lisp_type(obj) != LISP_TYPE_REAL)
 668         return 0;
 669       break;
 670
 671     case LISP_PATTERN_BOOLEAN :
 672       if (obj == 0 || lisp_type(obj) != LISP_TYPE_BOOLEAN)
 673         return 0;
 674       break;
 675
 676     case LISP_PATTERN_LIST :
 677       if (obj == 0 || lisp_type(obj) != LISP_TYPE_CONS)
 678         return 0;
 679       break;
 680
 681     case LISP_PATTERN_OR :
 682       {
 683         lisp_object_t *sub;
 684         int matched = 0;
 685
 686         for (sub = pattern->v.pattern.sub; sub != 0; sub = lisp_cdr(sub))
 687           {
 688             assert(lisp_type(sub) == LISP_TYPE_CONS);
 689
 690             if (_match_pattern(lisp_car(sub), obj, vars))
 691               matched = 1;
 692           }
 693
 694         if (!matched)
 695           return 0;
 696       }
 697       break;
 698
 699     default :
 700       assert(0);
 701     }
 702
 703   if (vars != 0)
 704     vars[pattern->v.pattern.index] = obj;
 705
 706   return 1;
 707 }
 708
 709 static int
 710 _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
 711 {
 712   if (pattern == 0)
 713     return obj == 0;
 714
 715   if (obj == 0)
 716     return 0;
 717
 718   if (lisp_type(pattern) == LISP_TYPE_PATTERN_VAR)
 719     return _match_pattern_var(pattern, obj, vars);
 720
 721   if (lisp_type(pattern) != lisp_type(obj))
 722     return 0;
 723
 724   switch (lisp_type(pattern))
 725     {
 726     case LISP_TYPE_SYMBOL :
 727       return strcmp(lisp_symbol(pattern), lisp_symbol(obj)) == 0;
 728
 729     case LISP_TYPE_STRING :
 730       return strcmp(lisp_string(pattern), lisp_string(obj)) == 0;
 731
 732     case LISP_TYPE_INTEGER :
 733       return lisp_integer(pattern) == lisp_integer(obj);
 734
 735     case LISP_TYPE_REAL :
 736       return lisp_real(pattern) == lisp_real(obj);
 737
 738     case LISP_TYPE_CONS :
 739       {
 740         int result1, result2;
 741
 742         result1 = _match_pattern(lisp_car(pattern), lisp_car(obj), vars);
 743         result2 = _match_pattern(lisp_cdr(pattern), lisp_cdr(obj), vars);
 744
 745         return result1 && result2;
 746       }
 747       break;
 748
 749     default :
 750       assert(0);
 751     }
 752
 753   return 0;
 754 }
 755
 756 int
 757 lisp_match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars, int num_subs)
 758 {
 759   int i;
 760
 761   if (vars != 0)
 762     for (i = 0; i < num_subs; ++i)
 763       vars[i] = &error_object;
 764
 765   return _match_pattern(pattern, obj, vars);
 766 }
 767
 768 int
 769 lisp_match_string (const char *pattern_string, lisp_object_t *obj, lisp_object_t **vars)
 770 {
 771   lisp_object_t *pattern;
 772   int result;
 773   int num_subs;
 774
 775   pattern = lisp_read_from_string(pattern_string);
 776
 777   if (pattern != 0 && (lisp_type(pattern) == LISP_TYPE_EOF
 778                        || lisp_type(pattern) == LISP_TYPE_PARSE_ERROR))
 779     return 0;
 780
 781   if (!lisp_compile_pattern(&pattern, &num_subs))
 782     {
 783       lisp_free(pattern);
 784       return 0;
 785     }
 786
 787   result = lisp_match_pattern(pattern, obj, vars, num_subs);
 788
 789   lisp_free(pattern);
 790
 791   return result;
 792 }
 793
 794 int
 795 lisp_type (lisp_object_t *obj)
 796 {
 797   if (obj == 0)
 798     return LISP_TYPE_NIL;
 799   return obj->type;
 800 }
 801
 802 int
 803 lisp_integer (lisp_object_t *obj)
 804 {
 805   assert(obj->type == LISP_TYPE_INTEGER);
 806
 807   return obj->v.integer;
 808 }
 809
 810 char*
 811 lisp_symbol (lisp_object_t *obj)
 812 {
 813   assert(obj->type == LISP_TYPE_SYMBOL);
 814
 815   return obj->v.string;
 816 }
 817
 818 char*
 819 lisp_string (lisp_object_t *obj)
 820 {
 821   assert(obj->type == LISP_TYPE_STRING);
 822
 823   return obj->v.string;
 824 }
 825
 826 int
 827 lisp_boolean (lisp_object_t *obj)
 828 {
 829   assert(obj->type == LISP_TYPE_BOOLEAN);
 830
 831   return obj->v.integer;
 832 }
 833
 834 float
 835 lisp_real (lisp_object_t *obj)
 836 {
 837   assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
 838
 839   if (obj->type == LISP_TYPE_INTEGER)
 840     return obj->v.integer;
 841   return obj->v.real;
 842 }
 843
 844 lisp_object_t*
 845 lisp_car (lisp_object_t *obj)
 846 {
 847   assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 848
 849   return obj->v.cons.car;
 850 }
 851
 852 lisp_object_t*
 853 lisp_cdr (lisp_object_t *obj)
 854 {
 855   assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 856
 857   return obj->v.cons.cdr;
 858 }
 859
 860 lisp_object_t*
 861 lisp_cxr (lisp_object_t *obj, const char *x)
 862 {
 863   int i;
 864
 865   for (i = strlen(x) - 1; i >= 0; --i)
 866     if (x[i] == 'a')
 867       obj = lisp_car(obj);
 868     else if (x[i] == 'd')
 869       obj = lisp_cdr(obj);
 870     else
 871       assert(0);
 872
 873   return obj;
 874 }
 875
 876 int
 877 lisp_list_length (lisp_object_t *obj)
 878 {
 879   int length = 0;
 880
 881   while (obj != 0)
 882     {
 883       assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 884
 885       ++length;
 886       obj = obj->v.cons.cdr;
 887     }
 888
 889   return length;
 890 }
 891
 892 lisp_object_t*
 893 lisp_list_nth_cdr (lisp_object_t *obj, int index)
 894 {
 895   while (index > 0)
 896     {
 897       assert(obj != 0);
 898       assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 899
 900       --index;
 901       obj = obj->v.cons.cdr;
 902     }
 903
 904   return obj;
 905 }
 906
 907 lisp_object_t*
 908 lisp_list_nth (lisp_object_t *obj, int index)
 909 {
 910   obj = lisp_list_nth_cdr(obj, index);
 911
 912   assert(obj != 0);
 913
 914   return obj->v.cons.car;
 915 }
 916
 917 void
 918 lisp_dump (lisp_object_t *obj, FILE *out)
 919 {
 920   if (obj == 0)
 921     {
 922       fprintf(out, "()");
 923       return;
 924     }
 925
 926   switch (lisp_type(obj))
 927     {
 928     case LISP_TYPE_EOF :
 929       fputs("#<eof>", out);
 930       break;
 931
 932     case LISP_TYPE_PARSE_ERROR :
 933       fputs("#<error>", out);
 934       break;
 935
 936     case LISP_TYPE_INTEGER :
 937       fprintf(out, "%d", lisp_integer(obj));
 938       break;
 939
 940     case LISP_TYPE_REAL :
 941       fprintf(out, "%f", lisp_real(obj));
 942       break;
 943
 944     case LISP_TYPE_SYMBOL :
 945       fputs(lisp_symbol(obj), out);
 946       break;
 947
 948     case LISP_TYPE_STRING :
 949       {
 950         char *p;
 951
 952         fputc('"', out);
 953         for (p = lisp_string(obj); *p != 0; ++p)
 954           {
 955             if (*p == '"' || *p == '\\')
 956               fputc('\\', out);
 957             fputc(*p, out);
 958           }
 959         fputc('"', out);
 960       }
 961       break;
 962
 963     case LISP_TYPE_CONS :
 964     case LISP_TYPE_PATTERN_CONS :
 965       fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
 966       while (obj != 0)
 967         {
 968           lisp_dump(lisp_car(obj), out);
 969           obj = lisp_cdr(obj);
 970           if (obj != 0)
 971             {
 972               if (lisp_type(obj) != LISP_TYPE_CONS
 973                   && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
 974                 {
 975                   fputs(" . ", out);
 976                   lisp_dump(obj, out);
 977                   break;
 978                 }
 979               else
 980                 fputc(' ', out);
 981             }
 982         }
 983       fputc(')', out);
 984       break;
 985
 986     case LISP_TYPE_BOOLEAN :
 987       if (lisp_boolean(obj))
 988         fputs("#t", out);
 989       else
 990         fputs("#f", out);
 991       break;
 992
 993     default :
 994       assert(0);
 995     }
 996 }
 997
 998 using namespace std;
 999
1000 LispReader::LispReader (lisp_object_t* l)
1001     : lst (l)
1002 {
1003   //std::cout << "LispReader: " << std::flush;
1004   //lisp_dump(lst, stdout);
1005   //std::cout << std::endl;
1006 }
1007
1008 lisp_object_t*
1009 LispReader::search_for(const char* name)
1010 {
1011   //std::cout << "LispReader::search_for(" << name << ")" << std::endl;
1012   lisp_object_t* cursor = lst;
1013
1014   while(!lisp_nil_p(cursor))
1015     {
1016       lisp_object_t* cur = lisp_car(cursor);
1017
1018       if (!lisp_cons_p(cur) || !lisp_symbol_p (lisp_car(cur)))
1019         {
1020           lisp_dump(cur, stdout);
1021           //throw ConstruoError (std::string("LispReader: Read error in search_for ") + name);
1022           printf("LispReader: Read error in search\n");
1023         }
1024       else
1025         {
1026           if (strcmp(lisp_symbol(lisp_car(cur)), name) == 0)
1027             {
1028               return lisp_cdr(cur);
1029             }
1030         }
1031
1032       cursor = lisp_cdr (cursor);
1033     }
1034   return 0;
1035 }
1036
1037 bool
1038 LispReader::read_int (const char* name, int* i)
1039 {
1040   lisp_object_t* obj = search_for (name);
1041   if (obj)
1042     {
1043       *i = lisp_integer(lisp_car(obj));
1044       return true;
1045     }
1046   return false;
1047 }
1048
1049 bool
1050 LispReader::read_float (const char* name, float* f)
1051 {
1052   lisp_object_t* obj = search_for (name);
1053   if (obj)
1054     {
1055       *f = lisp_real(lisp_car(obj));
1056       return true;
1057     }
1058   return false;
1059 }
1060
1061 bool
1062 LispReader::read_int_vector (const char* name, std::vector<int>* vec)
1063 {
1064   lisp_object_t* obj = search_for (name);
1065   if (obj)
1066     {
1067       while(!lisp_nil_p(obj))
1068         {
1069           vec->push_back(lisp_integer(lisp_car(obj)));
1070           obj = lisp_cdr(obj);
1071         }
1072       return true;
1073     }
1074   return false;
1075 }
1076
1077 bool
1078 LispReader::read_string (const char* name, std::string* str)
1079 {
1080   lisp_object_t* obj = search_for (name);
1081   if (obj)
1082     {
1083       *str = lisp_string(lisp_car(obj));
1084       return true;
1085     }
1086   return false;
1087 }
1088
1089 bool
1090 LispReader::read_bool (const char* name, bool* b)
1091 {
1092   lisp_object_t* obj = search_for (name);
1093   if (obj)
1094     {
1095       *b = lisp_boolean(lisp_car(obj));
1096       return true;
1097     }
1098   return false;
1099 }
1100
1101 LispWriter::LispWriter (const char* name)
1102 {
1103   lisp_objs.push_back(lisp_make_symbol (name));
1104 }
1105
1106 void
1107 LispWriter::append (lisp_object_t* obj)
1108 {
1109   lisp_objs.push_back(obj);
1110 }
1111
1112 lisp_object_t*
1113 LispWriter::make_list3 (lisp_object_t* a, lisp_object_t* b, lisp_object_t* c)
1114 {
1115   return lisp_make_cons (a, lisp_make_cons(b, lisp_make_cons(c, lisp_nil())));
1116 }
1117
1118 lisp_object_t*
1119 LispWriter::make_list2 (lisp_object_t* a, lisp_object_t* b)
1120 {
1121   return lisp_make_cons (a, lisp_make_cons(b, lisp_nil()));
1122 }
1123
1124 void
1125 LispWriter::write_float (const char* name, float f)
1126 {
1127   append(make_list2 (lisp_make_symbol (name),
1128                      lisp_make_real(f)));
1129 }
1130
1131 void
1132 LispWriter::write_int (const char* name, int i)
1133 {
1134   append(make_list2 (lisp_make_symbol (name),
1135                      lisp_make_integer(i)));
1136 }
1137
1138 void
1139 LispWriter::write_string (const char* name, const char* str)
1140 {
1141   append(make_list2 (lisp_make_symbol (name),
1142                      lisp_make_string(str)));
1143 }
1144
1145 void
1146 LispWriter::write_symbol (const char* name, const char* symname)
1147 {
1148   append(make_list2 (lisp_make_symbol (name),
1149                      lisp_make_symbol(symname)));
1150 }
1151
1152 void
1153 LispWriter::write_lisp_obj(const char* name, lisp_object_t* lst)
1154 {
1155   append(make_list2 (lisp_make_symbol (name),
1156                      lst));
1157 }
1158
1159 void
1160 LispWriter::write_boolean (const char* name, bool b)
1161 {
1162   append(make_list2 (lisp_make_symbol (name),
1163                      lisp_make_boolean(b)));
1164 }
1165
1166 lisp_object_t*
1167 LispWriter::create_lisp ()
1168 {
1169   lisp_object_t* lisp_obj = lisp_nil();
1170
1171   for(std::vector<lisp_object_t*>::reverse_iterator i = lisp_objs.rbegin ();
1172       i != lisp_objs.rend (); ++i)
1173     {
1174       lisp_obj = lisp_make_cons (*i, lisp_obj);
1175     }
1176   lisp_objs.clear();
1177
1178   return lisp_obj;
1179 }
1180