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         type = -1;
 572
 573         if (lisp_type(lisp_car(*obj)) != LISP_TYPE_SYMBOL)
 574           return 0;
 575
 576         type_name = lisp_symbol(lisp_car(*obj));
 577         for (i = 0; types[i].name != 0; ++i)
 578           {
 579             if (strcmp(types[i].name, type_name) == 0)
 580               {
 581                 type = types[i].type;
 582                 break;
 583               }
 584           }
 585
 586         if (types[i].name == 0)
 587           return 0;
 588
 589         if (type != LISP_PATTERN_OR && lisp_cdr(*obj) != 0)
 590           return 0;
 591
 592         pattern = lisp_make_pattern_var(type, (*index)++, lisp_nil());
 593
 594         if (type == LISP_PATTERN_OR)
 595           {
 596             lisp_object_t *cdr = lisp_cdr(*obj);
 597
 598             if (!_compile_pattern(&cdr, index))
 599               {
 600                 lisp_free(pattern);
 601                 return 0;
 602               }
 603
 604             pattern->v.pattern.sub = cdr;
 605
 606             (*obj)->v.cons.cdr = lisp_nil();
 607           }
 608
 609         lisp_free(*obj);
 610
 611         *obj = pattern;
 612       }
 613       break;
 614
 615     case LISP_TYPE_CONS :
 616       if (!_compile_pattern(&(*obj)->v.cons.car, index))
 617         return 0;
 618       if (!_compile_pattern(&(*obj)->v.cons.cdr, index))
 619         return 0;
 620       break;
 621     }
 622
 623   return 1;
 624 }
 625
 626 int
 627 lisp_compile_pattern (lisp_object_t **obj, int *num_subs)
 628 {
 629   int index = 0;
 630   int result;
 631
 632   result = _compile_pattern(obj, &index);
 633
 634   if (result && num_subs != 0)
 635     *num_subs = index;
 636
 637   return result;
 638 }
 639
 640 static int _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars);
 641
 642 static int
 643 _match_pattern_var (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
 644 {
 645   assert(lisp_type(pattern) == LISP_TYPE_PATTERN_VAR);
 646
 647   switch (pattern->v.pattern.type)
 648     {
 649     case LISP_PATTERN_ANY :
 650       break;
 651
 652     case LISP_PATTERN_SYMBOL :
 653       if (obj == 0 || lisp_type(obj) != LISP_TYPE_SYMBOL)
 654         return 0;
 655       break;
 656
 657     case LISP_PATTERN_STRING :
 658       if (obj == 0 || lisp_type(obj) != LISP_TYPE_STRING)
 659         return 0;
 660       break;
 661
 662     case LISP_PATTERN_INTEGER :
 663       if (obj == 0 || lisp_type(obj) != LISP_TYPE_INTEGER)
 664         return 0;
 665       break;
 666
 667     case LISP_PATTERN_REAL :
 668       if (obj == 0 || lisp_type(obj) != LISP_TYPE_REAL)
 669         return 0;
 670       break;
 671
 672     case LISP_PATTERN_BOOLEAN :
 673       if (obj == 0 || lisp_type(obj) != LISP_TYPE_BOOLEAN)
 674         return 0;
 675       break;
 676
 677     case LISP_PATTERN_LIST :
 678       if (obj == 0 || lisp_type(obj) != LISP_TYPE_CONS)
 679         return 0;
 680       break;
 681
 682     case LISP_PATTERN_OR :
 683       {
 684         lisp_object_t *sub;
 685         int matched = 0;
 686
 687         for (sub = pattern->v.pattern.sub; sub != 0; sub = lisp_cdr(sub))
 688           {
 689             assert(lisp_type(sub) == LISP_TYPE_CONS);
 690
 691             if (_match_pattern(lisp_car(sub), obj, vars))
 692               matched = 1;
 693           }
 694
 695         if (!matched)
 696           return 0;
 697       }
 698       break;
 699
 700     default :
 701       assert(0);
 702     }
 703
 704   if (vars != 0)
 705     vars[pattern->v.pattern.index] = obj;
 706
 707   return 1;
 708 }
 709
 710 static int
 711 _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
 712 {
 713   if (pattern == 0)
 714     return obj == 0;
 715
 716   if (obj == 0)
 717     return 0;
 718
 719   if (lisp_type(pattern) == LISP_TYPE_PATTERN_VAR)
 720     return _match_pattern_var(pattern, obj, vars);
 721
 722   if (lisp_type(pattern) != lisp_type(obj))
 723     return 0;
 724
 725   switch (lisp_type(pattern))
 726     {
 727     case LISP_TYPE_SYMBOL :
 728       return strcmp(lisp_symbol(pattern), lisp_symbol(obj)) == 0;
 729
 730     case LISP_TYPE_STRING :
 731       return strcmp(lisp_string(pattern), lisp_string(obj)) == 0;
 732
 733     case LISP_TYPE_INTEGER :
 734       return lisp_integer(pattern) == lisp_integer(obj);
 735
 736     case LISP_TYPE_REAL :
 737       return lisp_real(pattern) == lisp_real(obj);
 738
 739     case LISP_TYPE_CONS :
 740       {
 741         int result1, result2;
 742
 743         result1 = _match_pattern(lisp_car(pattern), lisp_car(obj), vars);
 744         result2 = _match_pattern(lisp_cdr(pattern), lisp_cdr(obj), vars);
 745
 746         return result1 && result2;
 747       }
 748       break;
 749
 750     default :
 751       assert(0);
 752     }
 753
 754   return 0;
 755 }
 756
 757 int
 758 lisp_match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars, int num_subs)
 759 {
 760   int i;
 761
 762   if (vars != 0)
 763     for (i = 0; i < num_subs; ++i)
 764       vars[i] = &error_object;
 765
 766   return _match_pattern(pattern, obj, vars);
 767 }
 768
 769 int
 770 lisp_match_string (const char *pattern_string, lisp_object_t *obj, lisp_object_t **vars)
 771 {
 772   lisp_object_t *pattern;
 773   int result;
 774   int num_subs;
 775
 776   pattern = lisp_read_from_string(pattern_string);
 777
 778   if (pattern != 0 && (lisp_type(pattern) == LISP_TYPE_EOF
 779                        || lisp_type(pattern) == LISP_TYPE_PARSE_ERROR))
 780     return 0;
 781
 782   if (!lisp_compile_pattern(&pattern, &num_subs))
 783     {
 784       lisp_free(pattern);
 785       return 0;
 786     }
 787
 788   result = lisp_match_pattern(pattern, obj, vars, num_subs);
 789
 790   lisp_free(pattern);
 791
 792   return result;
 793 }
 794
 795 int
 796 lisp_type (lisp_object_t *obj)
 797 {
 798   if (obj == 0)
 799     return LISP_TYPE_NIL;
 800   return obj->type;
 801 }
 802
 803 int
 804 lisp_integer (lisp_object_t *obj)
 805 {
 806   assert(obj->type == LISP_TYPE_INTEGER);
 807
 808   return obj->v.integer;
 809 }
 810
 811 char*
 812 lisp_symbol (lisp_object_t *obj)
 813 {
 814   assert(obj->type == LISP_TYPE_SYMBOL);
 815
 816   return obj->v.string;
 817 }
 818
 819 char*
 820 lisp_string (lisp_object_t *obj)
 821 {
 822   assert(obj->type == LISP_TYPE_STRING);
 823
 824   return obj->v.string;
 825 }
 826
 827 int
 828 lisp_boolean (lisp_object_t *obj)
 829 {
 830   assert(obj->type == LISP_TYPE_BOOLEAN);
 831
 832   return obj->v.integer;
 833 }
 834
 835 float
 836 lisp_real (lisp_object_t *obj)
 837 {
 838   assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
 839
 840   if (obj->type == LISP_TYPE_INTEGER)
 841     return obj->v.integer;
 842   return obj->v.real;
 843 }
 844
 845 lisp_object_t*
 846 lisp_car (lisp_object_t *obj)
 847 {
 848   assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 849
 850   return obj->v.cons.car;
 851 }
 852
 853 lisp_object_t*
 854 lisp_cdr (lisp_object_t *obj)
 855 {
 856   assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 857
 858   return obj->v.cons.cdr;
 859 }
 860
 861 lisp_object_t*
 862 lisp_cxr (lisp_object_t *obj, const char *x)
 863 {
 864   int i;
 865
 866   for (i = strlen(x) - 1; i >= 0; --i)
 867     if (x[i] == 'a')
 868       obj = lisp_car(obj);
 869     else if (x[i] == 'd')
 870       obj = lisp_cdr(obj);
 871     else
 872       assert(0);
 873
 874   return obj;
 875 }
 876
 877 int
 878 lisp_list_length (lisp_object_t *obj)
 879 {
 880   int length = 0;
 881
 882   while (obj != 0)
 883     {
 884       assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 885
 886       ++length;
 887       obj = obj->v.cons.cdr;
 888     }
 889
 890   return length;
 891 }
 892
 893 lisp_object_t*
 894 lisp_list_nth_cdr (lisp_object_t *obj, int index)
 895 {
 896   while (index > 0)
 897     {
 898       assert(obj != 0);
 899       assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
 900
 901       --index;
 902       obj = obj->v.cons.cdr;
 903     }
 904
 905   return obj;
 906 }
 907
 908 lisp_object_t*
 909 lisp_list_nth (lisp_object_t *obj, int index)
 910 {
 911   obj = lisp_list_nth_cdr(obj, index);
 912
 913   assert(obj != 0);
 914
 915   return obj->v.cons.car;
 916 }
 917
 918 void
 919 lisp_dump (lisp_object_t *obj, FILE *out)
 920 {
 921   if (obj == 0)
 922     {
 923       fprintf(out, "()");
 924       return;
 925     }
 926
 927   switch (lisp_type(obj))
 928     {
 929     case LISP_TYPE_EOF :
 930       fputs("#<eof>", out);
 931       break;
 932
 933     case LISP_TYPE_PARSE_ERROR :
 934       fputs("#<error>", out);
 935       break;
 936
 937     case LISP_TYPE_INTEGER :
 938       fprintf(out, "%d", lisp_integer(obj));
 939       break;
 940
 941     case LISP_TYPE_REAL :
 942       fprintf(out, "%f", lisp_real(obj));
 943       break;
 944
 945     case LISP_TYPE_SYMBOL :
 946       fputs(lisp_symbol(obj), out);
 947       break;
 948
 949     case LISP_TYPE_STRING :
 950       {
 951         char *p;
 952
 953         fputc('"', out);
 954         for (p = lisp_string(obj); *p != 0; ++p)
 955           {
 956             if (*p == '"' || *p == '\\')
 957               fputc('\\', out);
 958             fputc(*p, out);
 959           }
 960         fputc('"', out);
 961       }
 962       break;
 963
 964     case LISP_TYPE_CONS :
 965     case LISP_TYPE_PATTERN_CONS :
 966       fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
 967       while (obj != 0)
 968         {
 969           lisp_dump(lisp_car(obj), out);
 970           obj = lisp_cdr(obj);
 971           if (obj != 0)
 972             {
 973               if (lisp_type(obj) != LISP_TYPE_CONS
 974                   && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
 975                 {
 976                   fputs(" . ", out);
 977                   lisp_dump(obj, out);
 978                   break;
 979                 }
 980               else
 981                 fputc(' ', out);
 982             }
 983         }
 984       fputc(')', out);
 985       break;
 986
 987     case LISP_TYPE_BOOLEAN :
 988       if (lisp_boolean(obj))
 989         fputs("#t", out);
 990       else
 991         fputs("#f", out);
 992       break;
 993
 994     default :
 995       assert(0);
 996     }
 997 }
 998
 999 using namespace std;
1000
1001 LispReader::LispReader (lisp_object_t* l)
1002     : lst (l)
1003 {
1004   //std::cout << "LispReader: " << std::flush;
1005   //lisp_dump(lst, stdout);
1006   //std::cout << std::endl;
1007 }
1008
1009 lisp_object_t*
1010 LispReader::search_for(const char* name)
1011 {
1012   //std::cout << "LispReader::search_for(" << name << ")" << std::endl;
1013   lisp_object_t* cursor = lst;
1014
1015   while(!lisp_nil_p(cursor))
1016     {
1017       lisp_object_t* cur = lisp_car(cursor);
1018
1019       if (!lisp_cons_p(cur) || !lisp_symbol_p (lisp_car(cur)))
1020         {
1021           lisp_dump(cur, stdout);
1022           //throw ConstruoError (std::string("LispReader: Read error in search_for ") + name);
1023           printf("LispReader: Read error in search\n");
1024         }
1025       else
1026         {
1027           if (strcmp(lisp_symbol(lisp_car(cur)), name) == 0)
1028             {
1029               return lisp_cdr(cur);
1030             }
1031         }
1032
1033       cursor = lisp_cdr (cursor);
1034     }
1035   return 0;
1036 }
1037
1038 bool
1039 LispReader::read_int (const char* name, int* i)
1040 {
1041   lisp_object_t* obj = search_for (name);
1042   if (obj)
1043     {
1044       *i = lisp_integer(lisp_car(obj));
1045       return true;
1046     }
1047   return false;
1048 }
1049
1050 bool
1051 LispReader::read_float (const char* name, float* f)
1052 {
1053   lisp_object_t* obj = search_for (name);
1054   if (obj)
1055     {
1056       *f = lisp_real(lisp_car(obj));
1057       return true;
1058     }
1059   return false;
1060 }
1061
1062 bool
1063 LispReader::read_int_vector (const char* name, std::vector<int>* vec)
1064 {
1065   lisp_object_t* obj = search_for (name);
1066   if (obj)
1067     {
1068       while(!lisp_nil_p(obj))
1069         {
1070           vec->push_back(lisp_integer(lisp_car(obj)));
1071           obj = lisp_cdr(obj);
1072         }
1073       return true;
1074     }
1075   return false;
1076 }
1077
1078 bool
1079 LispReader::read_char_vector (const char* name, std::vector<char>* vec)
1080 {
1081   lisp_object_t* obj = search_for (name);
1082   if (obj)
1083     {
1084       while(!lisp_nil_p(obj))
1085         {
1086           vec->push_back(*lisp_string(lisp_car(obj)));
1087           obj = lisp_cdr(obj);
1088         }
1089       return true;
1090     }
1091   return false;
1092 }
1093
1094 bool
1095 LispReader::read_string (const char* name, std::string* str)
1096 {
1097   lisp_object_t* obj = search_for (name);
1098   if (obj)
1099     {
1100
1101      *str = lisp_string(lisp_car(obj));
1102       return true;
1103     }
1104   return false;
1105 }
1106
1107 bool
1108 LispReader::read_bool (const char* name, bool* b)
1109 {
1110   lisp_object_t* obj = search_for (name);
1111   if (obj)
1112     {
1113       *b = lisp_boolean(lisp_car(obj));
1114       return true;
1115     }
1116   return false;
1117 }
1118
1119 LispWriter::LispWriter (const char* name)
1120 {
1121   lisp_objs.push_back(lisp_make_symbol (name));
1122 }
1123
1124 void
1125 LispWriter::append (lisp_object_t* obj)
1126 {
1127   lisp_objs.push_back(obj);
1128 }
1129
1130 lisp_object_t*
1131 LispWriter::make_list3 (lisp_object_t* a, lisp_object_t* b, lisp_object_t* c)
1132 {
1133   return lisp_make_cons (a, lisp_make_cons(b, lisp_make_cons(c, lisp_nil())));
1134 }
1135
1136 lisp_object_t*
1137 LispWriter::make_list2 (lisp_object_t* a, lisp_object_t* b)
1138 {
1139   return lisp_make_cons (a, lisp_make_cons(b, lisp_nil()));
1140 }
1141
1142 void
1143 LispWriter::write_float (const char* name, float f)
1144 {
1145   append(make_list2 (lisp_make_symbol (name),
1146                      lisp_make_real(f)));
1147 }
1148
1149 void
1150 LispWriter::write_int (const char* name, int i)
1151 {
1152   append(make_list2 (lisp_make_symbol (name),
1153                      lisp_make_integer(i)));
1154 }
1155
1156 void
1157 LispWriter::write_string (const char* name, const char* str)
1158 {
1159   append(make_list2 (lisp_make_symbol (name),
1160                      lisp_make_string(str)));
1161 }
1162
1163 void
1164 LispWriter::write_symbol (const char* name, const char* symname)
1165 {
1166   append(make_list2 (lisp_make_symbol (name),
1167                      lisp_make_symbol(symname)));
1168 }
1169
1170 void
1171 LispWriter::write_lisp_obj(const char* name, lisp_object_t* lst)
1172 {
1173   append(make_list2 (lisp_make_symbol (name),
1174                      lst));
1175 }
1176
1177 void
1178 LispWriter::write_boolean (const char* name, bool b)
1179 {
1180   append(make_list2 (lisp_make_symbol (name),
1181                      lisp_make_boolean(b)));
1182 }
1183
1184 lisp_object_t*
1185 LispWriter::create_lisp ()
1186 {
1187   lisp_object_t* lisp_obj = lisp_nil();
1188
1189   for(std::vector<lisp_object_t*>::reverse_iterator i = lisp_objs.rbegin ();
1190       i != lisp_objs.rend (); ++i)
1191     {
1192       lisp_obj = lisp_make_cons (*i, lisp_obj);
1193     }
1194   lisp_objs.clear();
1195
1196   return lisp_obj;
1197 }
1198
1199 void mygzungetc(char c, void* file)
1200 {
1201   gzungetc(c, file);
1202 }
1203
1204 lisp_stream_t* lisp_stream_init_gzfile (lisp_stream_t *stream, gzFile file)
1205 {
1206   return lisp_stream_init_any (stream, file, gzgetc, mygzungetc);
1207 }
1208
1209 bool has_suffix(const char* data, const char* suffix)
1210 {
1211   int suffix_len = strlen(suffix);
1212   int data_len   = strlen(data);
1213
1214   const char* data_suffix = (data + data_len - suffix_len);
1215
1216   if (data_suffix >= data)
1217     {
1218       return (strcmp(data_suffix, suffix) == 0);
1219     }
1220   else
1221     {
1222       return false;
1223     }
1224 }
1225
1226 lisp_object_t* lisp_read_from_file(const char* filename)
1227 {
1228   lisp_stream_t stream;
1229
1230   if (has_suffix(filename, ".gz"))
1231     {
1232       lisp_object_t* obj = 0;
1233       gzFile in = gzopen(filename, "r");
1234
1235       if (in)
1236         {
1237           lisp_stream_init_gzfile(&stream, in);
1238           obj = lisp_read(&stream);
1239           gzclose(in);
1240         }
1241
1242       return obj;
1243     }
1244   else
1245     {
1246       lisp_object_t* obj = 0;
1247       FILE* in = fopen(filename, "r");
1248
1249       if (in)
1250         {
1251           lisp_stream_init_file(&stream, in);
1252           obj = lisp_read(&stream);
1253           fclose(in);
1254         }
1255
1256       return obj;
1257     }
1258 }
1259
1260 // EOF //