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