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