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