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     : owner(0), lst (l)
1019 {
1020 }
1021
1022 LispReader::~LispReader()
1023 {
1024   if(owner)
1025     lisp_free(owner);
1026 }
1027
1028 LispReader*
1029 LispReader::load(const std::string& filename, const std::string& toplevellist)
1030 {
1031   lisp_object_t* obj = lisp_read_from_file(filename);
1032
1033   if(obj->type == LISP_TYPE_EOF || obj->type == LISP_TYPE_PARSE_ERROR) {
1034     lisp_free(obj);
1035     throw LispReaderException("LispReader::load", __FILE__, __LINE__);
1036   }
1037
1038   if(toplevellist != lisp_symbol(lisp_car(obj))) {
1039     lisp_car(obj);
1040     throw LispReaderException("LispReader::load wrong toplevel symbol",
1041         __FILE__, __LINE__);
1042   }
1043
1044   LispReader* reader = new LispReader(lisp_cdr(obj));
1045   reader->owner = obj;
1046
1047   return reader;
1048 }
1049
1050 lisp_object_t*
1051 LispReader::search_for(const char* name)
1052 {
1053   //std::cout << "LispReader::search_for(" << name << ")" << std::endl;
1054   lisp_object_t* cursor = lst;
1055
1056   while(!lisp_nil_p(cursor))
1057     {
1058       lisp_object_t* cur = lisp_car(cursor);
1059
1060       if (!lisp_cons_p(cur) || !lisp_symbol_p (lisp_car(cur)))
1061         {
1062           lisp_dump(cur, stdout);
1063           //throw ConstruoError (std::string("LispReader: Read error in search_for ") + name);
1064           printf("LispReader: Read error in search\n");
1065         }
1066       else
1067         {
1068           if (strcmp(lisp_symbol(lisp_car(cur)), name) == 0)
1069             {
1070               return lisp_cdr(cur);
1071             }
1072         }
1073
1074       cursor = lisp_cdr (cursor);
1075     }
1076   return 0;
1077 }
1078
1079 bool
1080 LispReader::read_int (const char* name, int& i)
1081 {
1082   lisp_object_t* obj = search_for (name);
1083   if(!obj)
1084     return false;
1085
1086   if (!lisp_integer_p(lisp_car(obj)))
1087     return false;
1088
1089   i = lisp_integer(lisp_car(obj));
1090   return true;
1091 }
1092
1093 bool
1094 LispReader::read_lisp(const char* name, lisp_object_t*& b)
1095 {
1096   lisp_object_t* obj = search_for (name);
1097   if (!obj)
1098     return false;
1099
1100   b = obj;
1101   return true;
1102 }
1103
1104 LispReader*
1105 LispReader::read_lisp(const char* name)
1106 {
1107   lisp_object_t* obj = search_for(name);
1108   if(!obj)
1109     return 0;
1110
1111   return new LispReader(obj);
1112 }
1113
1114 bool
1115 LispReader::read_float (const char* name, float& f)
1116 {
1117   lisp_object_t* obj = search_for (name);
1118   if (!obj)
1119     return false;
1120
1121   if (!lisp_real_p(lisp_car(obj)) && !lisp_integer_p(lisp_car(obj)))
1122     st_abort("LispReader expected type real at token: ", name);
1123
1124   f = lisp_real(lisp_car(obj));
1125   return true;
1126 }
1127
1128 bool
1129 LispReader::read_string_vector (const char* name, std::vector<std::string>& vec)
1130 {
1131   lisp_object_t* obj = search_for (name);
1132   if (!obj)
1133     return false;
1134
1135   vec.clear();
1136   while(!lisp_nil_p(obj))
1137   {
1138     if (!lisp_string_p(lisp_car(obj)))
1139       st_abort("LispReader expected type string at token: ", name);
1140     vec.push_back(lisp_string(lisp_car(obj)));
1141     obj = lisp_cdr(obj);
1142   }
1143   return true;
1144 }
1145
1146 bool
1147 LispReader::read_int_vector (const char* name, std::vector<int>& vec)
1148 {
1149   lisp_object_t* obj = search_for (name);
1150   if (!obj)
1151     return false;
1152
1153   vec.clear();
1154   while(!lisp_nil_p(obj))
1155   {
1156     if (!lisp_integer_p(lisp_car(obj)))
1157       st_abort("LispReader expected type integer at token: ", name);
1158     vec.push_back(lisp_integer(lisp_car(obj)));
1159     obj = lisp_cdr(obj);
1160   }
1161   return true;
1162 }
1163
1164 bool
1165 LispReader::read_int_vector (const char* name, std::vector<unsigned int>& vec)
1166 {
1167   lisp_object_t* obj = search_for (name);
1168   if (!obj)
1169     return false;
1170
1171   vec.clear();
1172   while(!lisp_nil_p(obj))
1173   {
1174     if (!lisp_integer_p(lisp_car(obj)))
1175       st_abort("LispReader expected type integer at token: ", name);
1176     vec.push_back(lisp_integer(lisp_car(obj)));
1177     obj = lisp_cdr(obj);
1178   }
1179   return true;
1180 }
1181
1182 bool
1183 LispReader::read_char_vector (const char* name, std::vector<char>& vec)
1184 {
1185   lisp_object_t* obj = search_for (name);
1186   if (!obj)
1187     return false;
1188
1189   vec.clear();
1190   while(!lisp_nil_p(obj))
1191   {
1192     vec.push_back(*lisp_string(lisp_car(obj)));
1193     obj = lisp_cdr(obj);
1194   }
1195   return true;
1196 }
1197
1198 bool
1199 LispReader::read_string (const char* name, std::string& str)
1200 {
1201   lisp_object_t* obj = search_for (name);
1202   if (!obj)
1203     return false;
1204
1205   if (!lisp_string_p(lisp_car(obj)))
1206     st_abort("LispReader expected type string at token: ", name);
1207   str = lisp_string(lisp_car(obj));
1208   return true;
1209 }
1210
1211 bool
1212 LispReader::read_bool (const char* name, bool& b)
1213 {
1214   lisp_object_t* obj = search_for (name);
1215   if (!obj)
1216     return false;
1217
1218   if (!lisp_boolean_p(lisp_car(obj)))
1219     st_abort("LispReader expected type bool at token: ", name);
1220   b = lisp_boolean(lisp_car(obj));
1221   return true;
1222 }
1223
1224 lisp_object_t*
1225 LispReader::get_lisp()
1226 {
1227   return lst;
1228 }
1229
1230 lisp_object_t* lisp_read_from_file(const std::string& filename)
1231 {
1232   FILE* in = fopen(filename.c_str(), "r");
1233
1234   if(!in)
1235     return 0;
1236
1237   lisp_stream_t stream;
1238   lisp_stream_init_file(&stream, in);
1239   lisp_object_t* obj = lisp_read(&stream);
1240   fclose(in);
1241
1242   return obj;
1243 }
1244
1245 // EOF //