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