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