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