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