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