src/lispreader.cpp

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