5 * Copyright (C) 1998-2000 Mark Probst
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Library General Public
9 * License as published by the Free Software Foundation; either
10 * version 2 of the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Library General Public License for more details.
17 * You should have received a copy of the GNU Library General Public
18 * License along with this library; if not, write to the
19 * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 * Boston, MA 02111-1307, USA.
28 #include <lispreader.h>
30 #define TOKEN_ERROR -1
32 #define TOKEN_OPEN_PAREN 1
33 #define TOKEN_CLOSE_PAREN 2
34 #define TOKEN_SYMBOL 3
35 #define TOKEN_STRING 4
36 #define TOKEN_INTEGER 5
38 #define TOKEN_PATTERN_OPEN_PAREN 7
41 #define TOKEN_FALSE 10
44 #define MAX_TOKEN_LENGTH 1024
46 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
47 static int token_length = 0;
49 static lisp_object_t end_marker = { LISP_TYPE_EOF };
50 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR };
51 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR };
52 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR };
57 token_string[0] = '\0';
62 _token_append (char c)
64 assert(token_length < MAX_TOKEN_LENGTH);
66 token_string[token_length++] = c;
67 token_string[token_length] = '\0';
71 _next_char (lisp_stream_t *stream)
75 case LISP_STREAM_FILE :
76 return getc(stream->v.file);
78 case LISP_STREAM_STRING :
80 char c = stream->v.string.buf[stream->v.string.pos];
85 ++stream->v.string.pos;
91 return stream->v.any.next_char(stream->v.any.data);
98 _unget_char (char c, lisp_stream_t *stream)
100 switch (stream->type)
102 case LISP_STREAM_FILE :
103 ungetc(c, stream->v.file);
106 case LISP_STREAM_STRING :
107 --stream->v.string.pos;
110 case LISP_STREAM_ANY:
111 stream->v.any.unget_char(c, stream->v.any.data);
120 _scan (lisp_stream_t *stream)
122 static char *delims = "\"();";
130 c = _next_char(stream);
133 else if (c == ';') /* comment start */
136 c = _next_char(stream);
142 } while (isspace(c));
147 return TOKEN_OPEN_PAREN;
150 return TOKEN_CLOSE_PAREN;
155 c = _next_char(stream);
162 c = _next_char(stream);
184 c = _next_char(stream);
197 c = _next_char(stream);
202 return TOKEN_PATTERN_OPEN_PAREN;
209 if (isdigit(c) || c == '-')
211 int have_nondigits = 0;
213 int have_floating_point = 0;
220 have_floating_point++;
223 c = _next_char(stream);
225 if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
227 } while (c != EOF && !isspace(c) && !strchr(delims, c));
230 _unget_char(c, stream);
232 if (have_nondigits || !have_digits || have_floating_point > 1)
234 else if (have_floating_point == 1)
237 return TOKEN_INTEGER;
243 c = _next_char(stream);
244 if (c != EOF && !isspace(c) && !strchr(delims, c))
248 _unget_char(c, stream);
255 c = _next_char(stream);
256 } while (c != EOF && !isspace(c) && !strchr(delims, c));
258 _unget_char(c, stream);
268 static lisp_object_t*
269 lisp_object_alloc (int type)
271 lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
279 lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
281 stream->type = LISP_STREAM_FILE;
282 stream->v.file = file;
288 lisp_stream_init_string (lisp_stream_t *stream, char *buf)
290 stream->type = LISP_STREAM_STRING;
291 stream->v.string.buf = buf;
292 stream->v.string.pos = 0;
298 lisp_stream_init_any (lisp_stream_t *stream, void *data,
299 int (*next_char) (void *data),
300 void (*unget_char) (char c, void *data))
302 assert(next_char != 0 && unget_char != 0);
304 stream->type = LISP_STREAM_ANY;
305 stream->v.any.data = data;
306 stream->v.any.next_char= next_char;
307 stream->v.any.unget_char = unget_char;
313 lisp_make_integer (int value)
315 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
317 obj->v.integer = value;
323 lisp_make_real (float value)
325 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
333 lisp_make_symbol (const char *value)
335 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
337 obj->v.string = strdup(value);
343 lisp_make_string (const char *value)
345 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
347 obj->v.string = strdup(value);
353 lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
355 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
357 obj->v.cons.car = car;
358 obj->v.cons.cdr = cdr;
364 lisp_make_boolean (int value)
366 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
368 obj->v.integer = value ? 1 : 0;
373 static lisp_object_t*
374 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
376 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
378 obj->v.cons.car = car;
379 obj->v.cons.cdr = cdr;
384 static lisp_object_t*
385 lisp_make_pattern_var (int type, int index, lisp_object_t *sub)
387 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_VAR);
389 obj->v.pattern.type = type;
390 obj->v.pattern.index = index;
391 obj->v.pattern.sub = sub;
397 lisp_read (lisp_stream_t *in)
399 int token = _scan(in);
400 lisp_object_t *obj = lisp_nil();
402 if (token == TOKEN_EOF)
408 return &error_object;
413 case TOKEN_OPEN_PAREN :
414 case TOKEN_PATTERN_OPEN_PAREN :
416 lisp_object_t *last = lisp_nil(), *car;
421 if (car == &error_object || car == &end_marker)
424 return &error_object;
426 else if (car == &dot_marker)
428 if (lisp_nil_p(last))
431 return &error_object;
435 if (car == &error_object || car == &end_marker)
442 last->v.cons.cdr = car;
444 if (_scan(in) != TOKEN_CLOSE_PAREN)
447 return &error_object;
450 car = &close_paren_marker;
453 else if (car != &close_paren_marker)
455 if (lisp_nil_p(last))
456 obj = last = (token == TOKEN_OPEN_PAREN ? lisp_make_cons(car, lisp_nil()) : lisp_make_pattern_cons(car, lisp_nil()));
458 last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
460 } while (car != &close_paren_marker);
464 case TOKEN_CLOSE_PAREN :
465 return &close_paren_marker;
468 return lisp_make_symbol(token_string);
471 return lisp_make_string(token_string);
474 return lisp_make_integer(atoi(token_string));
477 return lisp_make_real((float)atof(token_string));
483 return lisp_make_boolean(1);
486 return lisp_make_boolean(0);
490 return &error_object;
494 lisp_free (lisp_object_t *obj)
501 case LISP_TYPE_INTERNAL :
502 case LISP_TYPE_PARSE_ERROR :
506 case LISP_TYPE_SYMBOL :
507 case LISP_TYPE_STRING :
511 case LISP_TYPE_CONS :
512 case LISP_TYPE_PATTERN_CONS :
513 lisp_free(obj->v.cons.car);
514 lisp_free(obj->v.cons.cdr);
517 case LISP_TYPE_PATTERN_VAR :
518 lisp_free(obj->v.pattern.sub);
526 lisp_read_from_string (const char *buf)
528 lisp_stream_t stream;
530 lisp_stream_init_string(&stream, (char*)buf);
531 return lisp_read(&stream);
535 _compile_pattern (lisp_object_t **obj, int *index)
540 switch (lisp_type(*obj))
542 case LISP_TYPE_PATTERN_CONS :
544 struct { char *name; int type; } types[] =
546 { "any", LISP_PATTERN_ANY },
547 { "symbol", LISP_PATTERN_SYMBOL },
548 { "string", LISP_PATTERN_STRING },
549 { "integer", LISP_PATTERN_INTEGER },
550 { "real", LISP_PATTERN_REAL },
551 { "boolean", LISP_PATTERN_BOOLEAN },
552 { "list", LISP_PATTERN_LIST },
553 { "or", LISP_PATTERN_OR },
559 lisp_object_t *pattern;
561 if (lisp_type(lisp_car(*obj)) != LISP_TYPE_SYMBOL)
564 type_name = lisp_symbol(lisp_car(*obj));
565 for (i = 0; types[i].name != 0; ++i)
567 if (strcmp(types[i].name, type_name) == 0)
569 type = types[i].type;
574 if (types[i].name == 0)
577 if (type != LISP_PATTERN_OR && lisp_cdr(*obj) != 0)
580 pattern = lisp_make_pattern_var(type, (*index)++, lisp_nil());
582 if (type == LISP_PATTERN_OR)
584 lisp_object_t *cdr = lisp_cdr(*obj);
586 if (!_compile_pattern(&cdr, index))
592 pattern->v.pattern.sub = cdr;
594 (*obj)->v.cons.cdr = lisp_nil();
603 case LISP_TYPE_CONS :
604 if (!_compile_pattern(&(*obj)->v.cons.car, index))
606 if (!_compile_pattern(&(*obj)->v.cons.cdr, index))
615 lisp_compile_pattern (lisp_object_t **obj, int *num_subs)
620 result = _compile_pattern(obj, &index);
622 if (result && num_subs != 0)
628 static int _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars);
631 _match_pattern_var (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
633 assert(lisp_type(pattern) == LISP_TYPE_PATTERN_VAR);
635 switch (pattern->v.pattern.type)
637 case LISP_PATTERN_ANY :
640 case LISP_PATTERN_SYMBOL :
641 if (obj == 0 || lisp_type(obj) != LISP_TYPE_SYMBOL)
645 case LISP_PATTERN_STRING :
646 if (obj == 0 || lisp_type(obj) != LISP_TYPE_STRING)
650 case LISP_PATTERN_INTEGER :
651 if (obj == 0 || lisp_type(obj) != LISP_TYPE_INTEGER)
655 case LISP_PATTERN_REAL :
656 if (obj == 0 || lisp_type(obj) != LISP_TYPE_REAL)
660 case LISP_PATTERN_BOOLEAN :
661 if (obj == 0 || lisp_type(obj) != LISP_TYPE_BOOLEAN)
665 case LISP_PATTERN_LIST :
666 if (obj == 0 || lisp_type(obj) != LISP_TYPE_CONS)
670 case LISP_PATTERN_OR :
675 for (sub = pattern->v.pattern.sub; sub != 0; sub = lisp_cdr(sub))
677 assert(lisp_type(sub) == LISP_TYPE_CONS);
679 if (_match_pattern(lisp_car(sub), obj, vars))
693 vars[pattern->v.pattern.index] = obj;
699 _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
707 if (lisp_type(pattern) == LISP_TYPE_PATTERN_VAR)
708 return _match_pattern_var(pattern, obj, vars);
710 if (lisp_type(pattern) != lisp_type(obj))
713 switch (lisp_type(pattern))
715 case LISP_TYPE_SYMBOL :
716 return strcmp(lisp_symbol(pattern), lisp_symbol(obj)) == 0;
718 case LISP_TYPE_STRING :
719 return strcmp(lisp_string(pattern), lisp_string(obj)) == 0;
721 case LISP_TYPE_INTEGER :
722 return lisp_integer(pattern) == lisp_integer(obj);
724 case LISP_TYPE_REAL :
725 return lisp_real(pattern) == lisp_real(obj);
727 case LISP_TYPE_CONS :
729 int result1, result2;
731 result1 = _match_pattern(lisp_car(pattern), lisp_car(obj), vars);
732 result2 = _match_pattern(lisp_cdr(pattern), lisp_cdr(obj), vars);
734 return result1 && result2;
746 lisp_match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars, int num_subs)
751 for (i = 0; i < num_subs; ++i)
752 vars[i] = &error_object;
754 return _match_pattern(pattern, obj, vars);
758 lisp_match_string (const char *pattern_string, lisp_object_t *obj, lisp_object_t **vars)
760 lisp_object_t *pattern;
764 pattern = lisp_read_from_string(pattern_string);
766 if (pattern != 0 && (lisp_type(pattern) == LISP_TYPE_EOF
767 || lisp_type(pattern) == LISP_TYPE_PARSE_ERROR))
770 if (!lisp_compile_pattern(&pattern, &num_subs))
776 result = lisp_match_pattern(pattern, obj, vars, num_subs);
784 lisp_type (lisp_object_t *obj)
787 return LISP_TYPE_NIL;
792 lisp_integer (lisp_object_t *obj)
794 assert(obj->type == LISP_TYPE_INTEGER);
796 return obj->v.integer;
800 lisp_symbol (lisp_object_t *obj)
802 assert(obj->type == LISP_TYPE_SYMBOL);
804 return obj->v.string;
808 lisp_string (lisp_object_t *obj)
810 assert(obj->type == LISP_TYPE_STRING);
812 return obj->v.string;
816 lisp_boolean (lisp_object_t *obj)
818 assert(obj->type == LISP_TYPE_BOOLEAN);
820 return obj->v.integer;
824 lisp_real (lisp_object_t *obj)
826 assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
828 if (obj->type == LISP_TYPE_INTEGER)
829 return obj->v.integer;
834 lisp_car (lisp_object_t *obj)
836 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
838 return obj->v.cons.car;
842 lisp_cdr (lisp_object_t *obj)
844 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
846 return obj->v.cons.cdr;
850 lisp_cxr (lisp_object_t *obj, const char *x)
854 for (i = strlen(x) - 1; i >= 0; --i)
857 else if (x[i] == 'd')
866 lisp_list_length (lisp_object_t *obj)
872 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
875 obj = obj->v.cons.cdr;
882 lisp_list_nth_cdr (lisp_object_t *obj, int index)
887 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
890 obj = obj->v.cons.cdr;
897 lisp_list_nth (lisp_object_t *obj, int index)
899 obj = lisp_list_nth_cdr(obj, index);
903 return obj->v.cons.car;
907 lisp_dump (lisp_object_t *obj, FILE *out)
915 switch (lisp_type(obj))
918 fputs("#<eof>", out);
921 case LISP_TYPE_PARSE_ERROR :
922 fputs("#<error>", out);
925 case LISP_TYPE_INTEGER :
926 fprintf(out, "%d", lisp_integer(obj));
929 case LISP_TYPE_REAL :
930 fprintf(out, "%f", lisp_real(obj));
933 case LISP_TYPE_SYMBOL :
934 fputs(lisp_symbol(obj), out);
937 case LISP_TYPE_STRING :
942 for (p = lisp_string(obj); *p != 0; ++p)
944 if (*p == '"' || *p == '\\')
952 case LISP_TYPE_CONS :
953 case LISP_TYPE_PATTERN_CONS :
954 fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
957 lisp_dump(lisp_car(obj), out);
961 if (lisp_type(obj) != LISP_TYPE_CONS
962 && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
975 case LISP_TYPE_BOOLEAN :
976 if (lisp_boolean(obj))