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