1 /*
2 * lispreader.c
3 *
4 * Copyright (C) 1998-2004 Mark Probst
5 *
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Library General Public
8 * License as published by the Free Software Foundation; either
9 * version 2 of the License, or (at your option) any later version.
10 *
11 * This library is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 * Library General Public License for more details.
15 *
16 * You should have received a copy of the GNU Library General Public
17 * License along with this library; if not, write to the
18 * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 * Boston, MA 02111-1307, USA.
20 */
21
22 #include <sys/types.h>
23 #include <sys/stat.h>
24 #include <sys/mman.h>
25 #include <unistd.h>
26 #include <ctype.h>
27 #include <stdlib.h>
28 #include <string.h>
29 #include <fcntl.h>
30 #include <assert.h>
31
32 #include <lispreader.h>
33
34 #define TOKEN_ERROR -1
35 #define TOKEN_EOF 0
36 #define TOKEN_OPEN_PAREN 1
37 #define TOKEN_CLOSE_PAREN 2
38 #define TOKEN_SYMBOL 3
39 #define TOKEN_STRING 4
40 #define TOKEN_INTEGER 5
41 #define TOKEN_REAL 6
42 #define TOKEN_PATTERN_OPEN_PAREN 7
43 #define TOKEN_DOT 8
44 #define TOKEN_TRUE 9
45 #define TOKEN_FALSE 10
46
47 #define MAX_TOKEN_LENGTH 8192
48
49 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
50 static int token_length = 0;
51
52 static char *mmap_token_start, *mmap_token_stop;
53
54 static lisp_object_t end_marker = { LISP_TYPE_EOF };
55 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR };
56 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR };
57 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR };
58
59 static void
_token_clear(void)60 _token_clear (void)
61 {
62 token_string[0] = '\0';
63 token_length = 0;
64 }
65
66 static void
_token_append(char c)67 _token_append (char c)
68 {
69 assert(token_length < MAX_TOKEN_LENGTH);
70
71 token_string[token_length++] = c;
72 token_string[token_length] = '\0';
73 }
74
75 static void
copy_mmapped_token(void)76 copy_mmapped_token (void)
77 {
78 token_length = mmap_token_stop - mmap_token_start;
79
80 assert(token_length < MAX_TOKEN_LENGTH);
81
82 memcpy(token_string, mmap_token_start, token_length);
83 token_string[token_length] = '\0';
84 }
85
86 static int
_next_char(lisp_stream_t * stream)87 _next_char (lisp_stream_t *stream)
88 {
89 switch (stream->type)
90 {
91 case LISP_STREAM_MMAP_FILE :
92 case LISP_STREAM_STRING :
93 assert(0);
94 return EOF;
95
96 case LISP_STREAM_FILE :
97 return getc(stream->v.file);
98
99 case LISP_STREAM_ANY:
100 return stream->v.any.next_char(stream->v.any.data);
101 }
102 assert(0);
103 return EOF;
104 }
105
106 static void
_unget_char(char c,lisp_stream_t * stream)107 _unget_char (char c, lisp_stream_t *stream)
108 {
109 switch (stream->type)
110 {
111 case LISP_STREAM_MMAP_FILE :
112 case LISP_STREAM_STRING :
113 assert(0);
114 break;
115
116 case LISP_STREAM_FILE :
117 ungetc(c, stream->v.file);
118 break;
119
120 case LISP_STREAM_ANY:
121 stream->v.any.unget_char(c, stream->v.any.data);
122 break;
123
124 default :
125 assert(0);
126 }
127 }
128
129 static int
my_atoi(const char * start,const char * stop)130 my_atoi (const char *start, const char *stop)
131 {
132 int value = 0;
133
134 while (start < stop)
135 {
136 value = value * 10 + (*start - '0');
137 ++start;
138 }
139
140 return value;
141 }
142
143 #define SCAN_FUNC_NAME _scan_mmap
144 #define SCAN_DECLS char *pos = stream->v.mmap.pos, *end = stream->v.mmap.end;
145 #define NEXT_CHAR (pos == end ? EOF : *pos++)
146 #define UNGET_CHAR(c) (--pos)
147 #define TOKEN_START(o) (mmap_token_start = pos - (o))
148 #define TOKEN_APPEND(c)
149 #define TOKEN_STOP (mmap_token_stop = pos)
150 #define RETURN(t) ({ stream->v.mmap.pos = pos ; return (t); })
151
152 #include "lispscan.h"
153
154 #undef SCAN_FUNC_NAME
155 #undef SCAN_DECLS
156 #undef NEXT_CHAR
157 #undef UNGET_CHAR
158 #undef TOKEN_START
159 #undef TOKEN_APPEND
160 #undef TOKEN_STOP
161 #undef RETURN
162
163 #define SCAN_FUNC_NAME _scan
164 #define SCAN_DECLS
165 #define NEXT_CHAR _next_char(stream)
166 #define UNGET_CHAR(c) _unget_char((c), stream)
167 #define TOKEN_START(o) _token_clear()
168 #define TOKEN_APPEND(c) _token_append((c))
169 #define TOKEN_STOP
170 #define RETURN(t) return (t)
171
172 #include "lispscan.h"
173
174 #undef SCAN_FUNC_NAME
175 #undef SCAN_DECLS
176 #undef NEXT_CHAR
177 #undef UNGET_CHAR
178 #undef TOKEN_START
179 #undef TOKEN_APPEND
180 #undef TOKEN_STOP
181 #undef RETURN
182
183 #define IS_STREAM_MMAPPED(s) ((s)->type <= LISP_LAST_MMAPPED_STREAM)
184 #define SCAN(s) (IS_STREAM_MMAPPED((s)) ? _scan_mmap((s)) : _scan((s)))
185
186 static lisp_object_t*
lisp_object_alloc(allocator_t * allocator,int type)187 lisp_object_alloc (allocator_t *allocator, int type)
188 {
189 lisp_object_t *obj = (lisp_object_t*)allocator_alloc(allocator, sizeof(lisp_object_t));
190
191 obj->type = type;
192
193 return obj;
194 }
195
196 lisp_stream_t*
lisp_stream_init_path(lisp_stream_t * stream,const char * path)197 lisp_stream_init_path (lisp_stream_t *stream, const char *path)
198 {
199 int fd;
200 struct stat sb;
201 size_t len;
202 void *buf;
203
204 fd = open(path, O_RDONLY, 0);
205
206 if (fd == -1)
207 return 0;
208
209 if (fstat(fd, &sb) == -1)
210 {
211 close(fd);
212 return 0;
213 }
214
215 len = sb.st_size;
216
217 buf = mmap(0, len, PROT_READ, MAP_SHARED, fd, 0);
218
219 if (buf == (void*)-1)
220 {
221 FILE *file = fdopen(fd, "r");
222
223 if (file == 0)
224 {
225 close(fd);
226
227 return 0;
228 }
229 else
230 return lisp_stream_init_file(stream, file);
231 }
232 else
233 {
234 close(fd);
235
236 stream->type = LISP_STREAM_MMAP_FILE;
237 stream->v.mmap.buf = buf;
238 stream->v.mmap.pos = buf;
239 stream->v.mmap.end = buf + len;
240 }
241
242 return stream;
243 }
244
245 lisp_stream_t*
lisp_stream_init_file(lisp_stream_t * stream,FILE * file)246 lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
247 {
248 stream->type = LISP_STREAM_FILE;
249 stream->v.file = file;
250
251 return stream;
252 }
253
254 lisp_stream_t*
lisp_stream_init_string(lisp_stream_t * stream,char * buf)255 lisp_stream_init_string (lisp_stream_t *stream, char *buf)
256 {
257 stream->type = LISP_STREAM_STRING;
258 stream->v.mmap.buf = buf;
259 stream->v.mmap.end = buf + strlen(buf);
260 stream->v.mmap.pos = buf;
261
262 return stream;
263 }
264
265 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))266 lisp_stream_init_any (lisp_stream_t *stream, void *data,
267 int (*next_char) (void *data),
268 void (*unget_char) (char c, void *data))
269 {
270 assert(next_char != 0 && unget_char != 0);
271
272 stream->type = LISP_STREAM_ANY;
273 stream->v.any.data = data;
274 stream->v.any.next_char= next_char;
275 stream->v.any.unget_char = unget_char;
276
277 return stream;
278 }
279
280 void
lisp_stream_free_path(lisp_stream_t * stream)281 lisp_stream_free_path (lisp_stream_t *stream)
282 {
283 assert(stream->type == LISP_STREAM_MMAP_FILE
284 || stream->type == LISP_STREAM_FILE);
285
286 if (stream->type == LISP_STREAM_MMAP_FILE)
287 munmap(stream->v.mmap.buf, stream->v.mmap.end - stream->v.mmap.buf);
288 else
289 fclose(stream->v.file);
290 }
291
292 lisp_object_t*
lisp_make_integer_with_allocator(allocator_t * allocator,int value)293 lisp_make_integer_with_allocator (allocator_t *allocator, int value)
294 {
295 lisp_object_t *obj = lisp_object_alloc(allocator, LISP_TYPE_INTEGER);
296
297 obj->v.integer = value;
298
299 return obj;
300 }
301
302 lisp_object_t*
lisp_make_real_with_allocator(allocator_t * allocator,float value)303 lisp_make_real_with_allocator (allocator_t *allocator, float value)
304 {
305 lisp_object_t *obj = lisp_object_alloc(allocator, LISP_TYPE_REAL);
306
307 obj->v.real = value;
308
309 return obj;
310 }
311
312 static lisp_object_t*
lisp_make_symbol_with_allocator_internal(allocator_t * allocator,const char * str,size_t len)313 lisp_make_symbol_with_allocator_internal (allocator_t *allocator, const char *str, size_t len)
314 {
315 lisp_object_t *obj = lisp_object_alloc(allocator, LISP_TYPE_SYMBOL);
316
317 obj->v.string = allocator_alloc(allocator, len + 1);
318 memcpy(obj->v.string, str, len + 1);
319 obj->v.string[len] = '\0';
320
321 return obj;
322 }
323
324 lisp_object_t*
lisp_make_symbol_with_allocator(allocator_t * allocator,const char * value)325 lisp_make_symbol_with_allocator (allocator_t *allocator, const char *value)
326 {
327 return lisp_make_symbol_with_allocator_internal(allocator, value, strlen(value));
328 }
329
330 lisp_object_t*
lisp_make_string_with_allocator(allocator_t * allocator,const char * value)331 lisp_make_string_with_allocator (allocator_t *allocator, const char *value)
332 {
333 lisp_object_t *obj = lisp_object_alloc(allocator, LISP_TYPE_STRING);
334
335 obj->v.string = allocator_strdup(allocator, value);
336
337 return obj;
338 }
339
340 lisp_object_t*
lisp_make_cons_with_allocator(allocator_t * allocator,lisp_object_t * car,lisp_object_t * cdr)341 lisp_make_cons_with_allocator (allocator_t *allocator, lisp_object_t *car, lisp_object_t *cdr)
342 {
343 lisp_object_t *obj = lisp_object_alloc(allocator, LISP_TYPE_CONS);
344
345 obj->v.cons.car = car;
346 obj->v.cons.cdr = cdr;
347
348 return obj;
349 }
350
351 lisp_object_t*
lisp_make_boolean_with_allocator(allocator_t * allocator,int value)352 lisp_make_boolean_with_allocator (allocator_t *allocator, int value)
353 {
354 lisp_object_t *obj = lisp_object_alloc(allocator, LISP_TYPE_BOOLEAN);
355
356 obj->v.integer = value ? 1 : 0;
357
358 return obj;
359 }
360
361 lisp_object_t*
lisp_make_integer(int value)362 lisp_make_integer (int value)
363 {
364 return lisp_make_integer_with_allocator(&malloc_allocator, value);
365 }
366
367 lisp_object_t*
lisp_make_real(float value)368 lisp_make_real (float value)
369 {
370 return lisp_make_real_with_allocator(&malloc_allocator, value);
371 }
372
373 lisp_object_t*
lisp_make_symbol(const char * value)374 lisp_make_symbol (const char *value)
375 {
376 return lisp_make_symbol_with_allocator(&malloc_allocator, value);
377 }
378
379 lisp_object_t*
lisp_make_string(const char * value)380 lisp_make_string (const char *value)
381 {
382 return lisp_make_string_with_allocator(&malloc_allocator, value);
383 }
384
385 lisp_object_t*
lisp_make_cons(lisp_object_t * car,lisp_object_t * cdr)386 lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
387 {
388 return lisp_make_cons_with_allocator(&malloc_allocator, car, cdr);
389 }
390
391 lisp_object_t*
lisp_make_boolean(int value)392 lisp_make_boolean (int value)
393 {
394 return lisp_make_boolean_with_allocator(&malloc_allocator, value);
395 }
396
397 static lisp_object_t*
lisp_make_pattern_cons_with_allocator(allocator_t * allocator,lisp_object_t * car,lisp_object_t * cdr)398 lisp_make_pattern_cons_with_allocator (allocator_t *allocator, lisp_object_t *car, lisp_object_t *cdr)
399 {
400 lisp_object_t *obj = lisp_object_alloc(allocator, LISP_TYPE_PATTERN_CONS);
401
402 obj->v.cons.car = car;
403 obj->v.cons.cdr = cdr;
404
405 return obj;
406 }
407
408 static lisp_object_t*
lisp_make_pattern_var_with_allocator(allocator_t * allocator,int type,int index,lisp_object_t * sub)409 lisp_make_pattern_var_with_allocator (allocator_t *allocator, int type, int index, lisp_object_t *sub)
410 {
411 lisp_object_t *obj = lisp_object_alloc(allocator, LISP_TYPE_PATTERN_VAR);
412
413 obj->v.pattern.type = type;
414 obj->v.pattern.index = index;
415 obj->v.pattern.sub = sub;
416
417 return obj;
418 }
419
420 lisp_object_t*
lisp_read_with_allocator(allocator_t * allocator,lisp_stream_t * in)421 lisp_read_with_allocator (allocator_t *allocator, lisp_stream_t *in)
422 {
423 int token = SCAN(in);
424 lisp_object_t *obj = lisp_nil();
425
426 if (token == TOKEN_EOF)
427 return &end_marker;
428
429 switch (token)
430 {
431 case TOKEN_ERROR :
432 return &error_object;
433
434 case TOKEN_EOF :
435 return &end_marker;
436
437 case TOKEN_OPEN_PAREN :
438 case TOKEN_PATTERN_OPEN_PAREN :
439 {
440 lisp_object_t *last = lisp_nil(), *car;
441
442 do
443 {
444 car = lisp_read_with_allocator(allocator, in);
445 if (car == &error_object || car == &end_marker)
446 {
447 lisp_free_with_allocator(allocator, obj);
448 return &error_object;
449 }
450 else if (car == &dot_marker)
451 {
452 if (lisp_nil_p(last))
453 {
454 lisp_free_with_allocator(allocator, obj);
455 return &error_object;
456 }
457
458 car = lisp_read_with_allocator(allocator, in);
459 if (car == &error_object || car == &end_marker)
460 {
461 lisp_free_with_allocator(allocator, obj);
462 return car;
463 }
464 else
465 {
466 last->v.cons.cdr = car;
467
468 if (SCAN(in) != TOKEN_CLOSE_PAREN)
469 {
470 lisp_free_with_allocator(allocator, obj);
471 return &error_object;
472 }
473
474 car = &close_paren_marker;
475 }
476 }
477 else if (car != &close_paren_marker)
478 {
479 if (lisp_nil_p(last))
480 obj = last = (token == TOKEN_OPEN_PAREN
481 ? lisp_make_cons_with_allocator(allocator, car, lisp_nil())
482 : lisp_make_pattern_cons_with_allocator(allocator, car, lisp_nil()));
483 else
484 last = last->v.cons.cdr = lisp_make_cons_with_allocator(allocator, car, lisp_nil());
485 }
486 } while (car != &close_paren_marker);
487 }
488 return obj;
489
490 case TOKEN_CLOSE_PAREN :
491 return &close_paren_marker;
492
493 case TOKEN_SYMBOL :
494 if (IS_STREAM_MMAPPED(in))
495 return lisp_make_symbol_with_allocator_internal(allocator, mmap_token_start,
496 mmap_token_stop - mmap_token_start);
497 else
498 return lisp_make_symbol_with_allocator(allocator, token_string);
499
500 case TOKEN_STRING :
501 return lisp_make_string_with_allocator(allocator, token_string);
502
503 case TOKEN_INTEGER :
504 if (IS_STREAM_MMAPPED(in))
505 return lisp_make_integer_with_allocator(allocator, my_atoi(mmap_token_start, mmap_token_stop));
506 else
507 return lisp_make_integer_with_allocator(allocator, atoi(token_string));
508
509 case TOKEN_REAL :
510 if (IS_STREAM_MMAPPED(in))
511 copy_mmapped_token();
512 return lisp_make_real_with_allocator(allocator, (float)atof(token_string));
513
514 case TOKEN_DOT :
515 return &dot_marker;
516
517 case TOKEN_TRUE :
518 return lisp_make_boolean_with_allocator(allocator, 1);
519
520 case TOKEN_FALSE :
521 return lisp_make_boolean_with_allocator(allocator, 0);
522 }
523
524 assert(0);
525 return &error_object;
526 }
527
528 lisp_object_t*
lisp_read(lisp_stream_t * in)529 lisp_read (lisp_stream_t *in)
530 {
531 return lisp_read_with_allocator(&malloc_allocator, in);
532 }
533
534 void
lisp_free_with_allocator(allocator_t * allocator,lisp_object_t * obj)535 lisp_free_with_allocator (allocator_t *allocator, lisp_object_t *obj)
536 {
537 restart:
538
539 if (obj == 0)
540 return;
541
542 switch (obj->type)
543 {
544 case LISP_TYPE_INTERNAL :
545 case LISP_TYPE_PARSE_ERROR :
546 case LISP_TYPE_EOF :
547 return;
548
549 case LISP_TYPE_SYMBOL :
550 case LISP_TYPE_STRING :
551 allocator_free(allocator, obj->v.string);
552 break;
553
554 case LISP_TYPE_CONS :
555 case LISP_TYPE_PATTERN_CONS :
556 /* If we just recursively free car and cdr we risk a stack
557 overflow because lists may be nested arbitrarily deep.
558
559 We can get rid of one recursive call with a tail call,
560 but there's still one remaining.
561
562 The solution is to flatten a recursive list until we
563 can free the car without recursion. Then we free the
564 cdr with a tail call.
565
566 The transformation we perform on the list is this:
567
568 ((a . b) . c) -> (a . (b . c))
569 */
570 if (!lisp_nil_p(obj->v.cons.car)
571 && (lisp_type(obj->v.cons.car) == LISP_TYPE_CONS
572 || lisp_type(obj->v.cons.car) == LISP_TYPE_PATTERN_CONS))
573 {
574 /* this is the transformation */
575
576 lisp_object_t *car, *cdar;
577
578 car = obj->v.cons.car;
579 cdar = car->v.cons.cdr;
580
581 car->v.cons.cdr = obj;
582
583 obj->v.cons.car = cdar;
584
585 obj = car;
586
587 goto restart;
588 }
589 else
590 {
591 /* here we just free the car (which is not recursive),
592 the cons itself and the cdr via a tail call. */
593
594 lisp_object_t *tmp;
595
596 lisp_free_with_allocator(allocator, obj->v.cons.car);
597
598 tmp = obj;
599 obj = obj->v.cons.cdr;
600
601 allocator_free(allocator, tmp);
602
603 goto restart;
604 }
605
606 case LISP_TYPE_PATTERN_VAR :
607 lisp_free_with_allocator(allocator, obj->v.pattern.sub);
608 break;
609 }
610
611 allocator_free(allocator, obj);
612 }
613
614 void
lisp_free(lisp_object_t * obj)615 lisp_free (lisp_object_t *obj)
616 {
617 lisp_free_with_allocator(&malloc_allocator, obj);
618 }
619
620 lisp_object_t*
lisp_read_from_string_with_allocator(allocator_t * allocator,const char * buf)621 lisp_read_from_string_with_allocator (allocator_t *allocator, const char *buf)
622 {
623 lisp_stream_t stream;
624
625 lisp_stream_init_string(&stream, (char*)buf);
626 return lisp_read_with_allocator(allocator, &stream);
627 }
628
629 lisp_object_t*
lisp_read_from_string(const char * buf)630 lisp_read_from_string (const char *buf)
631 {
632 return lisp_read_from_string_with_allocator(&malloc_allocator, buf);
633 }
634
635 static int
_compile_pattern(lisp_object_t ** obj,int * index)636 _compile_pattern (lisp_object_t **obj, int *index)
637 {
638 if (*obj == 0)
639 return 1;
640
641 switch (lisp_type(*obj))
642 {
643 case LISP_TYPE_PATTERN_CONS :
644 {
645 struct { char *name; int type; } types[] =
646 {
647 { "any", LISP_PATTERN_ANY },
648 { "symbol", LISP_PATTERN_SYMBOL },
649 { "string", LISP_PATTERN_STRING },
650 { "integer", LISP_PATTERN_INTEGER },
651 { "real", LISP_PATTERN_REAL },
652 { "boolean", LISP_PATTERN_BOOLEAN },
653 { "list", LISP_PATTERN_LIST },
654 { "or", LISP_PATTERN_OR },
655 { "number", LISP_PATTERN_NUMBER },
656 { 0, 0 }
657 };
658 char *type_name;
659 int type = 0; /* makes gcc happy */
660 int i;
661 lisp_object_t *pattern;
662
663 if (lisp_type(lisp_car(*obj)) != LISP_TYPE_SYMBOL)
664 return 0;
665
666 type_name = lisp_symbol(lisp_car(*obj));
667 for (i = 0; types[i].name != 0; ++i)
668 {
669 if (strcmp(types[i].name, type_name) == 0)
670 {
671 type = types[i].type;
672 break;
673 }
674 }
675
676 if (types[i].name == 0)
677 return 0;
678
679 if (type != LISP_PATTERN_OR && lisp_cdr(*obj) != 0)
680 return 0;
681
682 pattern = lisp_make_pattern_var_with_allocator(&malloc_allocator, type, (*index)++, lisp_nil());
683
684 if (type == LISP_PATTERN_OR)
685 {
686 lisp_object_t *cdr = lisp_cdr(*obj);
687
688 if (!_compile_pattern(&cdr, index))
689 {
690 lisp_free(pattern);
691 return 0;
692 }
693
694 pattern->v.pattern.sub = cdr;
695
696 (*obj)->v.cons.cdr = lisp_nil();
697 }
698
699 lisp_free(*obj);
700
701 *obj = pattern;
702 }
703 break;
704
705 case LISP_TYPE_CONS :
706 if (!_compile_pattern(&(*obj)->v.cons.car, index))
707 return 0;
708 if (!_compile_pattern(&(*obj)->v.cons.cdr, index))
709 return 0;
710 break;
711 }
712
713 return 1;
714 }
715
716 int
lisp_compile_pattern(lisp_object_t ** obj,int * num_subs)717 lisp_compile_pattern (lisp_object_t **obj, int *num_subs)
718 {
719 int index = 0;
720 int result;
721
722 result = _compile_pattern(obj, &index);
723
724 if (result && num_subs != 0)
725 *num_subs = index;
726
727 return result;
728 }
729
730 static int _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars);
731
732 static int
_match_pattern_var(lisp_object_t * pattern,lisp_object_t * obj,lisp_object_t ** vars)733 _match_pattern_var (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
734 {
735 assert(lisp_type(pattern) == LISP_TYPE_PATTERN_VAR);
736
737 switch (pattern->v.pattern.type)
738 {
739 case LISP_PATTERN_ANY :
740 break;
741
742 case LISP_PATTERN_SYMBOL :
743 if (obj == 0 || lisp_type(obj) != LISP_TYPE_SYMBOL)
744 return 0;
745 break;
746
747 case LISP_PATTERN_STRING :
748 if (obj == 0 || lisp_type(obj) != LISP_TYPE_STRING)
749 return 0;
750 break;
751
752 case LISP_PATTERN_INTEGER :
753 if (obj == 0 || lisp_type(obj) != LISP_TYPE_INTEGER)
754 return 0;
755 break;
756
757 case LISP_PATTERN_REAL :
758 if (obj == 0 || lisp_type(obj) != LISP_TYPE_REAL)
759 return 0;
760 break;
761
762 case LISP_PATTERN_BOOLEAN :
763 if (obj == 0 || lisp_type(obj) != LISP_TYPE_BOOLEAN)
764 return 0;
765 break;
766
767 case LISP_PATTERN_LIST :
768 if (obj == 0 || lisp_type(obj) != LISP_TYPE_CONS)
769 return 0;
770 break;
771
772 case LISP_PATTERN_OR :
773 {
774 lisp_object_t *sub;
775 int matched = 0;
776
777 for (sub = pattern->v.pattern.sub; sub != 0; sub = lisp_cdr(sub))
778 {
779 assert(lisp_type(sub) == LISP_TYPE_CONS);
780
781 if (_match_pattern(lisp_car(sub), obj, vars))
782 matched = 1;
783 }
784
785 if (!matched)
786 return 0;
787 }
788 break;
789
790 case LISP_PATTERN_NUMBER :
791 if (obj == 0 || (lisp_type(obj) != LISP_TYPE_INTEGER
792 && lisp_type(obj) != LISP_TYPE_REAL))
793 return 0;
794 break;
795
796 default :
797 assert(0);
798 }
799
800 if (vars != 0)
801 vars[pattern->v.pattern.index] = obj;
802
803 return 1;
804 }
805
806 static int
_match_pattern(lisp_object_t * pattern,lisp_object_t * obj,lisp_object_t ** vars)807 _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
808 {
809 if (pattern == 0)
810 return obj == 0;
811
812 if (obj == 0)
813 return 0;
814
815 if (lisp_type(pattern) == LISP_TYPE_PATTERN_VAR)
816 return _match_pattern_var(pattern, obj, vars);
817
818 if (lisp_type(pattern) != lisp_type(obj))
819 return 0;
820
821 switch (lisp_type(pattern))
822 {
823 case LISP_TYPE_SYMBOL :
824 return strcmp(lisp_symbol(pattern), lisp_symbol(obj)) == 0;
825
826 case LISP_TYPE_STRING :
827 return strcmp(lisp_string(pattern), lisp_string(obj)) == 0;
828
829 case LISP_TYPE_INTEGER :
830 return lisp_integer(pattern) == lisp_integer(obj);
831
832 case LISP_TYPE_REAL :
833 return lisp_real(pattern) == lisp_real(obj);
834
835 case LISP_TYPE_CONS :
836 {
837 int result1, result2;
838
839 result1 = _match_pattern(lisp_car(pattern), lisp_car(obj), vars);
840 result2 = _match_pattern(lisp_cdr(pattern), lisp_cdr(obj), vars);
841
842 return result1 && result2;
843 }
844 break;
845
846 default :
847 assert(0);
848 }
849
850 return 0;
851 }
852
853 int
lisp_match_pattern(lisp_object_t * pattern,lisp_object_t * obj,lisp_object_t ** vars,int num_subs)854 lisp_match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars, int num_subs)
855 {
856 int i;
857
858 if (vars != 0)
859 for (i = 0; i < num_subs; ++i)
860 vars[i] = &error_object;
861
862 return _match_pattern(pattern, obj, vars);
863 }
864
865 int
lisp_match_string(const char * pattern_string,lisp_object_t * obj,lisp_object_t ** vars)866 lisp_match_string (const char *pattern_string, lisp_object_t *obj, lisp_object_t **vars)
867 {
868 lisp_object_t *pattern;
869 int result;
870 int num_subs;
871
872 pattern = lisp_read_from_string(pattern_string);
873
874 if (pattern != 0 && (lisp_type(pattern) == LISP_TYPE_EOF
875 || lisp_type(pattern) == LISP_TYPE_PARSE_ERROR))
876 return 0;
877
878 if (!lisp_compile_pattern(&pattern, &num_subs))
879 {
880 lisp_free(pattern);
881 return 0;
882 }
883
884 result = lisp_match_pattern(pattern, obj, vars, num_subs);
885
886 lisp_free(pattern);
887
888 return result;
889 }
890
891 int
lisp_type(lisp_object_t * obj)892 lisp_type (lisp_object_t *obj)
893 {
894 if (obj == 0)
895 return LISP_TYPE_NIL;
896 return obj->type;
897 }
898
899 int
lisp_integer(lisp_object_t * obj)900 lisp_integer (lisp_object_t *obj)
901 {
902 assert(obj->type == LISP_TYPE_INTEGER);
903
904 return obj->v.integer;
905 }
906
907 char*
lisp_symbol(lisp_object_t * obj)908 lisp_symbol (lisp_object_t *obj)
909 {
910 assert(obj->type == LISP_TYPE_SYMBOL);
911
912 return obj->v.string;
913 }
914
915 char*
lisp_string(lisp_object_t * obj)916 lisp_string (lisp_object_t *obj)
917 {
918 assert(obj->type == LISP_TYPE_STRING);
919
920 return obj->v.string;
921 }
922
923 int
lisp_boolean(lisp_object_t * obj)924 lisp_boolean (lisp_object_t *obj)
925 {
926 assert(obj->type == LISP_TYPE_BOOLEAN);
927
928 return obj->v.integer;
929 }
930
931 float
lisp_real(lisp_object_t * obj)932 lisp_real (lisp_object_t *obj)
933 {
934 assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
935
936 if (obj->type == LISP_TYPE_INTEGER)
937 return obj->v.integer;
938 return obj->v.real;
939 }
940
941 lisp_object_t*
lisp_car(lisp_object_t * obj)942 lisp_car (lisp_object_t *obj)
943 {
944 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
945
946 return obj->v.cons.car;
947 }
948
949 lisp_object_t*
lisp_cdr(lisp_object_t * obj)950 lisp_cdr (lisp_object_t *obj)
951 {
952 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
953
954 return obj->v.cons.cdr;
955 }
956
957 lisp_object_t*
lisp_cxr(lisp_object_t * obj,const char * x)958 lisp_cxr (lisp_object_t *obj, const char *x)
959 {
960 int i;
961
962 for (i = strlen(x) - 1; i >= 0; --i)
963 if (x[i] == 'a')
964 obj = lisp_car(obj);
965 else if (x[i] == 'd')
966 obj = lisp_cdr(obj);
967 else
968 assert(0);
969
970 return obj;
971 }
972
973 int
lisp_list_length(lisp_object_t * obj)974 lisp_list_length (lisp_object_t *obj)
975 {
976 int length = 0;
977
978 while (obj != 0)
979 {
980 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
981
982 ++length;
983 obj = obj->v.cons.cdr;
984 }
985
986 return length;
987 }
988
989 lisp_object_t*
lisp_list_nth_cdr(lisp_object_t * obj,int index)990 lisp_list_nth_cdr (lisp_object_t *obj, int index)
991 {
992 while (index > 0)
993 {
994 assert(obj != 0);
995 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
996
997 --index;
998 obj = obj->v.cons.cdr;
999 }
1000
1001 return obj;
1002 }
1003
1004 lisp_object_t*
lisp_list_nth(lisp_object_t * obj,int index)1005 lisp_list_nth (lisp_object_t *obj, int index)
1006 {
1007 obj = lisp_list_nth_cdr(obj, index);
1008
1009 assert(obj != 0);
1010
1011 return obj->v.cons.car;
1012 }
1013
1014 void
lisp_dump(lisp_object_t * obj,FILE * out)1015 lisp_dump (lisp_object_t *obj, FILE *out)
1016 {
1017 if (obj == 0)
1018 {
1019 fprintf(out, "()");
1020 return;
1021 }
1022
1023 switch (lisp_type(obj))
1024 {
1025 case LISP_TYPE_EOF :
1026 fputs("#<eof>", out);
1027 break;
1028
1029 case LISP_TYPE_PARSE_ERROR :
1030 fputs("#<error>", out);
1031 break;
1032
1033 case LISP_TYPE_INTEGER :
1034 fprintf(out, "%d", lisp_integer(obj));
1035 break;
1036
1037 case LISP_TYPE_REAL :
1038 fprintf(out, "%f", lisp_real(obj));
1039 break;
1040
1041 case LISP_TYPE_SYMBOL :
1042 fputs(lisp_symbol(obj), out);
1043 break;
1044
1045 case LISP_TYPE_STRING :
1046 {
1047 char *p;
1048
1049 fputc('"', out);
1050 for (p = lisp_string(obj); *p != 0; ++p)
1051 {
1052 if (*p == '"' || *p == '\\')
1053 fputc('\\', out);
1054 fputc(*p, out);
1055 }
1056 fputc('"', out);
1057 }
1058 break;
1059
1060 case LISP_TYPE_CONS :
1061 case LISP_TYPE_PATTERN_CONS :
1062 fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
1063 while (obj != 0)
1064 {
1065 lisp_dump(lisp_car(obj), out);
1066 obj = lisp_cdr(obj);
1067 if (obj != 0)
1068 {
1069 if (lisp_type(obj) != LISP_TYPE_CONS
1070 && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
1071 {
1072 fputs(" . ", out);
1073 lisp_dump(obj, out);
1074 break;
1075 }
1076 else
1077 fputc(' ', out);
1078 }
1079 }
1080 fputc(')', out);
1081 break;
1082
1083 case LISP_TYPE_BOOLEAN :
1084 if (lisp_boolean(obj))
1085 fputs("#t", out);
1086 else
1087 fputs("#f", out);
1088 break;
1089
1090 default :
1091 assert(0);
1092 }
1093 }
1094