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