Main Page   Namespace List   Class Hierarchy   Compound List   File List   Namespace Members   Compound Members   File Members  

lispreader.cxx

Go to the documentation of this file.
00001 /* $Id: lispreader.cxx,v 1.2 2003/01/08 23:30:43 grumbel Exp $ */
00002 /*
00003  * lispreader.c
00004  *
00005  * Copyright (C) 1998-2000 Mark Probst
00006  *
00007  * This library is free software; you can redistribute it and/or
00008  * modify it under the terms of the GNU Library General Public
00009  * License as published by the Free Software Foundation; either
00010  * version 2 of the License, or (at your option) any later version.
00011  *
00012  * This library is distributed in the hope that it will be useful,
00013  * but WITHOUT ANY WARRANTY; without even the implied warranty of
00014  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00015  * Library General Public License for more details.
00016  *
00017  * You should have received a copy of the GNU Library General Public
00018  * License along with this library; if not, write to the
00019  * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
00020  * Boston, MA 02111-1307, USA.
00021  */
00022 
00023 #include <assert.h>
00024 #include <ctype.h>
00025 #include <stdlib.h>
00026 #include <string.h>
00027 
00028 #include "construo_error.hxx"
00029 #include <lispreader.hxx>
00030 
00031 #define TOKEN_ERROR                   -1
00032 #define TOKEN_EOF                     0
00033 #define TOKEN_OPEN_PAREN              1
00034 #define TOKEN_CLOSE_PAREN             2
00035 #define TOKEN_SYMBOL                  3
00036 #define TOKEN_STRING                  4
00037 #define TOKEN_INTEGER                 5
00038 #define TOKEN_REAL                    6
00039 #define TOKEN_PATTERN_OPEN_PAREN      7
00040 #define TOKEN_DOT                     8
00041 #define TOKEN_TRUE                    9
00042 #define TOKEN_FALSE                   10
00043 
00044 
00045 #define MAX_TOKEN_LENGTH           1024
00046 
00047 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
00048 static int token_length = 0;
00049 
00050 static lisp_object_t end_marker = { LISP_TYPE_EOF };
00051 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR };
00052 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR };
00053 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR };
00054 
00055 static void
00056 _token_clear (void)
00057 {
00058     token_string[0] = '\0';
00059     token_length = 0;
00060 }
00061 
00062 static void
00063 _token_append (char c)
00064 {
00065     assert(token_length < MAX_TOKEN_LENGTH);
00066 
00067     token_string[token_length++] = c;
00068     token_string[token_length] = '\0';
00069 }
00070 
00071 static int
00072 _next_char (lisp_stream_t *stream)
00073 {
00074     switch (stream->type)
00075     {
00076         case LISP_STREAM_FILE :
00077             return getc(stream->v.file);
00078 
00079         case LISP_STREAM_STRING :
00080             {
00081                 char c = stream->v.string.buf[stream->v.string.pos];
00082 
00083                 if (c == 0)
00084                     return EOF;
00085 
00086                 ++stream->v.string.pos;
00087 
00088                 return c;
00089             }
00090 
00091         case LISP_STREAM_ANY:
00092             return stream->v.any.next_char(stream->v.any.data);
00093     }
00094     assert(0);
00095     return EOF;
00096 }
00097 
00098 static void
00099 _unget_char (char c, lisp_stream_t *stream)
00100 {
00101     switch (stream->type)
00102     {
00103         case LISP_STREAM_FILE :
00104             ungetc(c, stream->v.file);
00105             break;
00106 
00107         case LISP_STREAM_STRING :
00108             --stream->v.string.pos;
00109             break;
00110 
00111        case LISP_STREAM_ANY:
00112             stream->v.any.unget_char(c, stream->v.any.data);
00113             break;
00114          
00115         default :
00116             assert(0);
00117     }
00118 }
00119 
00120 static int
00121 _scan (lisp_stream_t *stream)
00122 {
00123     static char *delims = "\"();";
00124 
00125     int c;
00126 
00127     _token_clear();
00128 
00129     do
00130     {
00131         c = _next_char(stream);
00132         if (c == EOF)
00133             return TOKEN_EOF;
00134         else if (c == ';')       /* comment start */
00135             while (1)
00136             {   
00137                 c = _next_char(stream);
00138                 if (c == EOF)           
00139                     return TOKEN_EOF;   
00140                 else if (c == '\n')     
00141                     break;
00142             }
00143     } while (isspace(c));
00144 
00145     switch (c)
00146     {
00147         case '(' :
00148             return TOKEN_OPEN_PAREN;
00149 
00150         case ')' :
00151             return TOKEN_CLOSE_PAREN;
00152 
00153         case '"' :
00154             while (1)
00155             {
00156                 c = _next_char(stream);
00157                 if (c == EOF)
00158                     return TOKEN_ERROR;
00159                 if (c == '"')
00160                     break;
00161                 if (c == '\\')
00162                 {
00163                     c = _next_char(stream);
00164 
00165                     switch (c)
00166                     {
00167                         case EOF :
00168                             return TOKEN_ERROR;
00169                         
00170                         case 'n' :
00171                             c = '\n';
00172                             break;
00173 
00174                         case 't' :
00175                             c = '\t';
00176                             break;
00177                     }
00178                 }
00179 
00180                 _token_append(c);
00181             }
00182             return TOKEN_STRING;
00183 
00184         case '#' :
00185             c = _next_char(stream);
00186             if (c == EOF)
00187                 return TOKEN_ERROR;
00188 
00189             switch (c)
00190             {
00191                 case 't' :
00192                     return TOKEN_TRUE;
00193 
00194                 case 'f' :
00195                     return TOKEN_FALSE;
00196 
00197                 case '?' :
00198                     c = _next_char(stream);
00199                     if (c == EOF)
00200                         return TOKEN_ERROR;
00201 
00202                     if (c == '(')
00203                         return TOKEN_PATTERN_OPEN_PAREN;
00204                     else
00205                         return TOKEN_ERROR;
00206             }
00207             return TOKEN_ERROR;
00208 
00209         default :
00210             if (isdigit(c) || c == '-')
00211             {
00212                 int have_nondigits = 0;
00213                 int have_digits = 0;
00214                 int have_floating_point = 0;
00215 
00216                 do
00217                 {
00218                     if (isdigit(c))
00219                         have_digits = 1;
00220                     else if (c == '.')
00221                         have_floating_point++;
00222                     _token_append(c);
00223 
00224                     c = _next_char(stream);
00225 
00226                     if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
00227                         have_nondigits = 1;
00228                 } while (c != EOF && !isspace(c) && !strchr(delims, c));
00229 
00230                 if (c != EOF)
00231                     _unget_char(c, stream);
00232 
00233                 if (have_nondigits || !have_digits || have_floating_point > 1)
00234                   return TOKEN_SYMBOL;
00235                 else if (have_floating_point == 1)
00236                   return TOKEN_REAL;
00237                 else
00238                   return TOKEN_INTEGER;
00239             }
00240             else
00241             {
00242                 if (c == '.')
00243                 {
00244                     c = _next_char(stream);
00245                     if (c != EOF && !isspace(c) && !strchr(delims, c))
00246                         _token_append('.');
00247                     else
00248                     {
00249                         _unget_char(c, stream);
00250                         return TOKEN_DOT;
00251                     }
00252                 }
00253                 do
00254                 {
00255                     _token_append(c);
00256                     c = _next_char(stream);
00257                 } while (c != EOF && !isspace(c) && !strchr(delims, c));
00258                 if (c != EOF)
00259                     _unget_char(c, stream);
00260 
00261                 return TOKEN_SYMBOL;
00262             }
00263     }
00264 
00265     assert(0);
00266     return TOKEN_ERROR;
00267 }
00268 
00269 static lisp_object_t*
00270 lisp_object_alloc (int type)
00271 {
00272     lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
00273 
00274     obj->type = type;
00275 
00276     return obj;
00277 }
00278 
00279 lisp_stream_t*
00280 lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
00281 {
00282     stream->type = LISP_STREAM_FILE;
00283     stream->v.file = file;
00284 
00285     return stream;
00286 }
00287 
00288 lisp_stream_t*
00289 lisp_stream_init_string (lisp_stream_t *stream, char *buf)
00290 {
00291     stream->type = LISP_STREAM_STRING;
00292     stream->v.string.buf = buf;
00293     stream->v.string.pos = 0;
00294 
00295     return stream;
00296 }
00297 
00298 lisp_stream_t* 
00299 lisp_stream_init_any (lisp_stream_t *stream, void *data, 
00300                       int (*next_char) (void *data),
00301                       void (*unget_char) (char c, void *data))
00302 {
00303     assert(next_char != 0 && unget_char != 0);
00304     
00305     stream->type = LISP_STREAM_ANY;
00306     stream->v.any.data = data;
00307     stream->v.any.next_char= next_char;
00308     stream->v.any.unget_char = unget_char;
00309 
00310     return stream;
00311 }
00312 
00313 lisp_object_t*
00314 lisp_make_integer (int value)
00315 {
00316     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
00317 
00318     obj->v.integer = value;
00319 
00320     return obj;
00321 }
00322 
00323 lisp_object_t*
00324 lisp_make_real (float value)
00325 {
00326     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
00327 
00328     obj->v.real = value;
00329 
00330     return obj;
00331 }
00332 
00333 lisp_object_t*
00334 lisp_make_symbol (const char *value)
00335 {
00336     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
00337 
00338     obj->v.string = strdup(value);
00339 
00340     return obj;
00341 }
00342 
00343 lisp_object_t*
00344 lisp_make_string (const char *value)
00345 {
00346     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
00347 
00348     obj->v.string = strdup(value);
00349 
00350     return obj;
00351 }
00352 
00353 lisp_object_t*
00354 lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
00355 {
00356     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
00357 
00358     obj->v.cons.car = car;
00359     obj->v.cons.cdr = cdr;
00360 
00361     return obj;
00362 }
00363 
00364 lisp_object_t*
00365 lisp_make_boolean (int value)
00366 {
00367     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
00368 
00369     obj->v.integer = value ? 1 : 0;
00370 
00371     return obj;
00372 }
00373 
00374 static lisp_object_t*
00375 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
00376 {
00377     lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
00378 
00379     obj->v.cons.car = car;
00380     obj->v.cons.cdr = cdr;
00381 
00382     return obj;
00383 }
00384 
00385 lisp_object_t*
00386 lisp_read (lisp_stream_t *in)
00387 {
00388     int token = _scan(in);
00389     lisp_object_t *obj = lisp_nil();
00390 
00391     if (token == TOKEN_EOF)
00392         return &end_marker;
00393 
00394     switch (token)
00395     {
00396         case TOKEN_ERROR :
00397             return &error_object;
00398 
00399         case TOKEN_EOF :
00400             return &end_marker;
00401 
00402         case TOKEN_OPEN_PAREN :
00403         case TOKEN_PATTERN_OPEN_PAREN :
00404             {
00405                 lisp_object_t *last = lisp_nil(), *car;
00406 
00407                 do
00408                 {
00409                     car = lisp_read(in);
00410                     if (car == &error_object || car == &end_marker)
00411                     {
00412                         lisp_free(obj);
00413                         return &error_object;
00414                     }
00415                     else if (car == &dot_marker)
00416                     {
00417                         if (lisp_nil_p(last))
00418                         {
00419                             lisp_free(obj);
00420                             return &error_object;
00421                         }
00422 
00423                         car = lisp_read(in);
00424                         if (car == &error_object || car == &end_marker)
00425                         {
00426                             lisp_free(obj);
00427                             return car;
00428                         }
00429                         else
00430                         {
00431                             last->v.cons.cdr = car;
00432 
00433                             if (_scan(in) != TOKEN_CLOSE_PAREN)
00434                             {
00435                                 lisp_free(obj);
00436                                 return &error_object;
00437                             }
00438 
00439                             car = &close_paren_marker;
00440                         }
00441                     }
00442                     else if (car != &close_paren_marker)
00443                     {
00444                         if (lisp_nil_p(last))
00445                             obj = last = (token == TOKEN_OPEN_PAREN ? lisp_make_cons(car, lisp_nil()) : lisp_make_pattern_cons(car, lisp_nil()));
00446                         else
00447                             last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
00448                     }
00449                 } while (car != &close_paren_marker);
00450             }
00451             return obj;
00452 
00453         case TOKEN_CLOSE_PAREN :
00454             return &close_paren_marker;
00455 
00456         case TOKEN_SYMBOL :
00457             return lisp_make_symbol(token_string);
00458 
00459         case TOKEN_STRING :
00460             return lisp_make_string(token_string);
00461 
00462         case TOKEN_INTEGER :
00463             return lisp_make_integer(atoi(token_string));
00464         
00465         case TOKEN_REAL :
00466             return lisp_make_real((float)atof(token_string));
00467 
00468         case TOKEN_DOT :
00469             return &dot_marker;
00470 
00471         case TOKEN_TRUE :
00472             return lisp_make_boolean(1);
00473 
00474         case TOKEN_FALSE :
00475             return lisp_make_boolean(0);
00476     }
00477 
00478     assert(0);
00479     return &error_object;
00480 }
00481 
00482 void
00483 lisp_free (lisp_object_t *obj)
00484 {
00485     if (obj == 0)
00486         return;
00487 
00488     switch (obj->type)
00489     {
00490         case LISP_TYPE_INTERNAL :
00491         case LISP_TYPE_PARSE_ERROR :
00492         case LISP_TYPE_EOF :
00493             return;
00494 
00495         case LISP_TYPE_SYMBOL :
00496         case LISP_TYPE_STRING :
00497             free(obj->v.string);
00498             break;
00499 
00500         case LISP_TYPE_CONS :
00501         case LISP_TYPE_PATTERN_CONS :
00502             lisp_free(obj->v.cons.car);
00503             lisp_free(obj->v.cons.cdr);
00504             break;
00505 
00506         case LISP_TYPE_PATTERN_VAR :
00507             lisp_free(obj->v.pattern.sub);
00508             break;
00509     }
00510 
00511     free(obj);
00512 }
00513 
00514 lisp_object_t*
00515 lisp_read_from_string (const char *buf)
00516 {
00517     lisp_stream_t stream;
00518 
00519     lisp_stream_init_string(&stream, (char*)buf);
00520     return lisp_read(&stream);
00521 }
00522 
00523 int
00524 lisp_type (lisp_object_t *obj)
00525 {
00526     if (obj == 0)
00527         return LISP_TYPE_NIL;
00528     return obj->type;
00529 }
00530 
00531 int
00532 lisp_integer (lisp_object_t *obj)
00533 {
00534     assert(obj->type == LISP_TYPE_INTEGER);
00535 
00536     return obj->v.integer;
00537 }
00538 
00539 char*
00540 lisp_symbol (lisp_object_t *obj)
00541 {
00542     assert(obj->type == LISP_TYPE_SYMBOL);
00543 
00544     return obj->v.string;
00545 }
00546 
00547 char*
00548 lisp_string (lisp_object_t *obj)
00549 {
00550   if (obj->type != LISP_TYPE_STRING)
00551     ConstruoError::raise("lispreader Error: obj->type != LISP_TYPE_STRING");
00552 
00553     return obj->v.string;
00554 }
00555 
00556 int
00557 lisp_boolean (lisp_object_t *obj)
00558 {
00559     assert(obj->type == LISP_TYPE_BOOLEAN);
00560 
00561     return obj->v.integer;
00562 }
00563 
00564 float
00565 lisp_real (lisp_object_t *obj)
00566 {
00567     assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
00568 
00569     if (obj->type == LISP_TYPE_INTEGER)
00570         return obj->v.integer;
00571     return obj->v.real;
00572 }
00573            
00574 lisp_object_t*
00575 lisp_car (lisp_object_t *obj)
00576 {
00577   if (!(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS))
00578     ConstruoError::raise("lispreader Error: !(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS)");
00579     
00580     return obj->v.cons.car;
00581 }
00582 
00583 lisp_object_t*
00584 lisp_cdr (lisp_object_t *obj)
00585 {
00586     assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
00587 
00588     return obj->v.cons.cdr;
00589 }
00590 
00591 lisp_object_t*
00592 lisp_cxr (lisp_object_t *obj, const char *x)
00593 {
00594     int i;
00595 
00596     for (i = strlen(x) - 1; i >= 0; --i)
00597         if (x[i] == 'a')
00598             obj = lisp_car(obj);
00599         else if (x[i] == 'd')
00600             obj = lisp_cdr(obj);
00601         else
00602             assert(0);
00603 
00604     return obj;
00605 }
00606 
00607 int
00608 lisp_list_length (lisp_object_t *obj)
00609 {
00610     int length = 0;
00611 
00612     while (obj != 0)
00613     {
00614         assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
00615 
00616         ++length;
00617         obj = obj->v.cons.cdr;
00618     }
00619 
00620     return length;
00621 }
00622 
00623 lisp_object_t*
00624 lisp_list_nth_cdr (lisp_object_t *obj, int index)
00625 {
00626     while (index > 0)
00627     {
00628         assert(obj != 0);
00629         assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
00630 
00631         --index;
00632         obj = obj->v.cons.cdr;
00633     }
00634 
00635     return obj;
00636 }
00637 
00638 lisp_object_t*
00639 lisp_list_nth (lisp_object_t *obj, int index)
00640 {
00641     obj = lisp_list_nth_cdr(obj, index);
00642 
00643     assert(obj != 0);
00644 
00645     return obj->v.cons.car;
00646 }
00647 
00648 void
00649 lisp_dump (lisp_object_t *obj, FILE *out)
00650 {
00651     if (obj == 0)
00652     {
00653         fprintf(out, "()");
00654         return;
00655     }
00656 
00657     switch (lisp_type(obj))
00658     {
00659         case LISP_TYPE_EOF :
00660             fputs("#<eof>", out);
00661             break;
00662 
00663         case LISP_TYPE_PARSE_ERROR :
00664             fputs("#<error>", out);
00665             break;
00666 
00667         case LISP_TYPE_INTEGER :
00668             fprintf(out, "%d", lisp_integer(obj));
00669             break;
00670 
00671         case LISP_TYPE_REAL :
00672             fprintf(out, "%f", lisp_real(obj));
00673             break;
00674 
00675         case LISP_TYPE_SYMBOL :
00676             fputs(lisp_symbol(obj), out);
00677             break;
00678 
00679         case LISP_TYPE_STRING :
00680             {
00681                 char *p;
00682 
00683                 fputc('"', out);
00684                 for (p = lisp_string(obj); *p != 0; ++p)
00685                 {
00686                     if (*p == '"' || *p == '\\')
00687                         fputc('\\', out);
00688                     fputc(*p, out);
00689                 }
00690                 fputc('"', out);
00691             }
00692             break;
00693 
00694         case LISP_TYPE_CONS :
00695         case LISP_TYPE_PATTERN_CONS :
00696             fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
00697             while (obj != 0)
00698             {
00699                 lisp_dump(lisp_car(obj), out);
00700                 obj = lisp_cdr(obj);
00701                 if (obj != 0)
00702                 {
00703                     if (lisp_type(obj) != LISP_TYPE_CONS
00704                         && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
00705                     {
00706                         fputs(" . ", out);
00707                         lisp_dump(obj, out);
00708                         break;
00709                     }
00710                     else
00711                         fputc(' ', out);
00712                 }
00713             }
00714             fputc(')', out);
00715             break;
00716 
00717         case LISP_TYPE_BOOLEAN :
00718             if (lisp_boolean(obj))
00719                 fputs("#t", out);
00720             else
00721                 fputs("#f", out);
00722             break;
00723 
00724         default :
00725             assert(0);
00726     }
00727 }

Generated on Thu Jul 24 10:24:30 2003 for Construo by doxygen1.3-rc3