5 * Copyright (C) 1998-2000 Mark Probst
6 * Copyright (C) 2002 Ingo Ruhnke <grumbel@gmx.de>
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.
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.
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.
31 #include "lispreader.h"
33 #define TOKEN_ERROR -1
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
41 #define TOKEN_PATTERN_OPEN_PAREN 7
44 #define TOKEN_FALSE 10
47 #define MAX_TOKEN_LENGTH 1024
49 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
50 static int token_length = 0;
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}} };
60 token_string[0] = '\0';
65 _token_append (char c)
67 assert(token_length < MAX_TOKEN_LENGTH);
69 token_string[token_length++] = c;
70 token_string[token_length] = '\0';
74 _next_char (lisp_stream_t *stream)
78 case LISP_STREAM_FILE :
79 return getc(stream->v.file);
81 case LISP_STREAM_STRING :
83 char c = stream->v.string.buf[stream->v.string.pos];
88 ++stream->v.string.pos;
94 return stream->v.any.next_char(stream->v.any.data);
101 _unget_char (char c, lisp_stream_t *stream)
103 switch (stream->type)
105 case LISP_STREAM_FILE :
106 ungetc(c, stream->v.file);
109 case LISP_STREAM_STRING :
110 --stream->v.string.pos;
113 case LISP_STREAM_ANY:
114 stream->v.any.unget_char(c, stream->v.any.data);
123 _scan (lisp_stream_t *stream)
125 static char *delims = "\"();";
133 c = _next_char(stream);
136 else if (c == ';') /* comment start */
139 c = _next_char(stream);
151 return TOKEN_OPEN_PAREN;
154 return TOKEN_CLOSE_PAREN;
159 c = _next_char(stream);
166 c = _next_char(stream);
188 c = _next_char(stream);
201 c = _next_char(stream);
206 return TOKEN_PATTERN_OPEN_PAREN;
213 if (isdigit(c) || c == '-')
215 int have_nondigits = 0;
217 int have_floating_point = 0;
224 have_floating_point++;
227 c = _next_char(stream);
229 if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
232 while (c != EOF && !isspace(c) && !strchr(delims, c));
235 _unget_char(c, stream);
237 if (have_nondigits || !have_digits || have_floating_point > 1)
239 else if (have_floating_point == 1)
242 return TOKEN_INTEGER;
248 c = _next_char(stream);
249 if (c != EOF && !isspace(c) && !strchr(delims, c))
253 _unget_char(c, stream);
260 c = _next_char(stream);
262 while (c != EOF && !isspace(c) && !strchr(delims, c));
264 _unget_char(c, stream);
274 static lisp_object_t*
275 lisp_object_alloc (int type)
277 lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
285 lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
287 stream->type = LISP_STREAM_FILE;
288 stream->v.file = file;
294 lisp_stream_init_string (lisp_stream_t *stream, char *buf)
296 stream->type = LISP_STREAM_STRING;
297 stream->v.string.buf = buf;
298 stream->v.string.pos = 0;
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))
308 assert(next_char != 0 && unget_char != 0);
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;
319 lisp_make_integer (int value)
321 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
323 obj->v.integer = value;
329 lisp_make_real (float value)
331 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
339 lisp_make_symbol (const char *value)
341 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
343 obj->v.string = strdup(value);
349 lisp_make_string (const char *value)
351 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
353 obj->v.string = strdup(value);
359 lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
361 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
363 obj->v.cons.car = car;
364 obj->v.cons.cdr = cdr;
370 lisp_make_boolean (int value)
372 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
374 obj->v.integer = value ? 1 : 0;
379 static lisp_object_t*
380 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
382 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
384 obj->v.cons.car = car;
385 obj->v.cons.cdr = cdr;
390 static lisp_object_t*
391 lisp_make_pattern_var (int type, int index, lisp_object_t *sub)
393 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_VAR);
395 obj->v.pattern.type = type;
396 obj->v.pattern.index = index;
397 obj->v.pattern.sub = sub;
403 lisp_read (lisp_stream_t *in)
405 int token = _scan(in);
406 lisp_object_t *obj = lisp_nil();
408 if (token == TOKEN_EOF)
414 return &error_object;
419 case TOKEN_OPEN_PAREN :
420 case TOKEN_PATTERN_OPEN_PAREN :
422 lisp_object_t *last = lisp_nil(), *car;
427 if (car == &error_object || car == &end_marker)
430 return &error_object;
432 else if (car == &dot_marker)
434 if (lisp_nil_p(last))
437 return &error_object;
441 if (car == &error_object || car == &end_marker)
448 last->v.cons.cdr = car;
450 if (_scan(in) != TOKEN_CLOSE_PAREN)
453 return &error_object;
456 car = &close_paren_marker;
459 else if (car != &close_paren_marker)
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()));
464 last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
467 while (car != &close_paren_marker);
471 case TOKEN_CLOSE_PAREN :
472 return &close_paren_marker;
475 return lisp_make_symbol(token_string);
478 return lisp_make_string(token_string);
481 return lisp_make_integer(atoi(token_string));
484 return lisp_make_real((float)atof(token_string));
490 return lisp_make_boolean(1);
493 return lisp_make_boolean(0);
497 return &error_object;
501 lisp_free (lisp_object_t *obj)
508 case LISP_TYPE_INTERNAL :
509 case LISP_TYPE_PARSE_ERROR :
513 case LISP_TYPE_SYMBOL :
514 case LISP_TYPE_STRING :
518 case LISP_TYPE_CONS :
519 case LISP_TYPE_PATTERN_CONS :
520 lisp_free(obj->v.cons.car);
521 lisp_free(obj->v.cons.cdr);
524 case LISP_TYPE_PATTERN_VAR :
525 lisp_free(obj->v.pattern.sub);
533 lisp_read_from_string (const char *buf)
535 lisp_stream_t stream;
537 lisp_stream_init_string(&stream, (char*)buf);
538 return lisp_read(&stream);
542 _compile_pattern (lisp_object_t **obj, int *index)
547 switch (lisp_type(*obj))
549 case LISP_TYPE_PATTERN_CONS :
558 { "any", LISP_PATTERN_ANY },
559 { "symbol", LISP_PATTERN_SYMBOL },
560 { "string", LISP_PATTERN_STRING },
561 { "integer", LISP_PATTERN_INTEGER },
562 { "real", LISP_PATTERN_REAL },
563 { "boolean", LISP_PATTERN_BOOLEAN },
564 { "list", LISP_PATTERN_LIST },
565 { "or", LISP_PATTERN_OR },
571 lisp_object_t *pattern;
574 if (lisp_type(lisp_car(*obj)) != LISP_TYPE_SYMBOL)
577 type_name = lisp_symbol(lisp_car(*obj));
578 for (i = 0; types[i].name != 0; ++i)
580 if (strcmp(types[i].name, type_name) == 0)
582 type = types[i].type;
587 if (types[i].name == 0)
590 if (type != LISP_PATTERN_OR && lisp_cdr(*obj) != 0)
593 pattern = lisp_make_pattern_var(type, (*index)++, lisp_nil());
595 if (type == LISP_PATTERN_OR)
597 lisp_object_t *cdr = lisp_cdr(*obj);
599 if (!_compile_pattern(&cdr, index))
605 pattern->v.pattern.sub = cdr;
607 (*obj)->v.cons.cdr = lisp_nil();
616 case LISP_TYPE_CONS :
617 if (!_compile_pattern(&(*obj)->v.cons.car, index))
619 if (!_compile_pattern(&(*obj)->v.cons.cdr, index))
628 lisp_compile_pattern (lisp_object_t **obj, int *num_subs)
633 result = _compile_pattern(obj, &index);
635 if (result && num_subs != 0)
641 static int _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars);
644 _match_pattern_var (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
646 assert(lisp_type(pattern) == LISP_TYPE_PATTERN_VAR);
648 switch (pattern->v.pattern.type)
650 case LISP_PATTERN_ANY :
653 case LISP_PATTERN_SYMBOL :
654 if (obj == 0 || lisp_type(obj) != LISP_TYPE_SYMBOL)
658 case LISP_PATTERN_STRING :
659 if (obj == 0 || lisp_type(obj) != LISP_TYPE_STRING)
663 case LISP_PATTERN_INTEGER :
664 if (obj == 0 || lisp_type(obj) != LISP_TYPE_INTEGER)
668 case LISP_PATTERN_REAL :
669 if (obj == 0 || lisp_type(obj) != LISP_TYPE_REAL)
673 case LISP_PATTERN_BOOLEAN :
674 if (obj == 0 || lisp_type(obj) != LISP_TYPE_BOOLEAN)
678 case LISP_PATTERN_LIST :
679 if (obj == 0 || lisp_type(obj) != LISP_TYPE_CONS)
683 case LISP_PATTERN_OR :
688 for (sub = pattern->v.pattern.sub; sub != 0; sub = lisp_cdr(sub))
690 assert(lisp_type(sub) == LISP_TYPE_CONS);
692 if (_match_pattern(lisp_car(sub), obj, vars))
706 vars[pattern->v.pattern.index] = obj;
712 _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
720 if (lisp_type(pattern) == LISP_TYPE_PATTERN_VAR)
721 return _match_pattern_var(pattern, obj, vars);
723 if (lisp_type(pattern) != lisp_type(obj))
726 switch (lisp_type(pattern))
728 case LISP_TYPE_SYMBOL :
729 return strcmp(lisp_symbol(pattern), lisp_symbol(obj)) == 0;
731 case LISP_TYPE_STRING :
732 return strcmp(lisp_string(pattern), lisp_string(obj)) == 0;
734 case LISP_TYPE_INTEGER :
735 return lisp_integer(pattern) == lisp_integer(obj);
737 case LISP_TYPE_REAL :
738 return lisp_real(pattern) == lisp_real(obj);
740 case LISP_TYPE_CONS :
742 int result1, result2;
744 result1 = _match_pattern(lisp_car(pattern), lisp_car(obj), vars);
745 result2 = _match_pattern(lisp_cdr(pattern), lisp_cdr(obj), vars);
747 return result1 && result2;
759 lisp_match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars, int num_subs)
764 for (i = 0; i < num_subs; ++i)
765 vars[i] = &error_object;
767 return _match_pattern(pattern, obj, vars);
771 lisp_match_string (const char *pattern_string, lisp_object_t *obj, lisp_object_t **vars)
773 lisp_object_t *pattern;
777 pattern = lisp_read_from_string(pattern_string);
779 if (pattern != 0 && (lisp_type(pattern) == LISP_TYPE_EOF
780 || lisp_type(pattern) == LISP_TYPE_PARSE_ERROR))
783 if (!lisp_compile_pattern(&pattern, &num_subs))
789 result = lisp_match_pattern(pattern, obj, vars, num_subs);
797 lisp_type (lisp_object_t *obj)
800 return LISP_TYPE_NIL;
805 lisp_integer (lisp_object_t *obj)
807 assert(obj->type == LISP_TYPE_INTEGER);
809 return obj->v.integer;
813 lisp_symbol (lisp_object_t *obj)
815 assert(obj->type == LISP_TYPE_SYMBOL);
817 return obj->v.string;
821 lisp_string (lisp_object_t *obj)
823 assert(obj->type == LISP_TYPE_STRING);
825 return obj->v.string;
829 lisp_boolean (lisp_object_t *obj)
831 assert(obj->type == LISP_TYPE_BOOLEAN);
833 return obj->v.integer;
837 lisp_real (lisp_object_t *obj)
839 assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
841 if (obj->type == LISP_TYPE_INTEGER)
842 return obj->v.integer;
847 lisp_car (lisp_object_t *obj)
849 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
851 return obj->v.cons.car;
855 lisp_cdr (lisp_object_t *obj)
857 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
859 return obj->v.cons.cdr;
863 lisp_cxr (lisp_object_t *obj, const char *x)
867 for (i = strlen(x) - 1; i >= 0; --i)
870 else if (x[i] == 'd')
879 lisp_list_length (lisp_object_t *obj)
885 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
888 obj = obj->v.cons.cdr;
895 lisp_list_nth_cdr (lisp_object_t *obj, int index)
900 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
903 obj = obj->v.cons.cdr;
910 lisp_list_nth (lisp_object_t *obj, int index)
912 obj = lisp_list_nth_cdr(obj, index);
916 return obj->v.cons.car;
920 lisp_dump (lisp_object_t *obj, FILE *out)
928 switch (lisp_type(obj))
931 fputs("#<eof>", out);
934 case LISP_TYPE_PARSE_ERROR :
935 fputs("#<error>", out);
938 case LISP_TYPE_INTEGER :
939 fprintf(out, "%d", lisp_integer(obj));
942 case LISP_TYPE_REAL :
943 fprintf(out, "%f", lisp_real(obj));
946 case LISP_TYPE_SYMBOL :
947 fputs(lisp_symbol(obj), out);
950 case LISP_TYPE_STRING :
955 for (p = lisp_string(obj); *p != 0; ++p)
957 if (*p == '"' || *p == '\\')
965 case LISP_TYPE_CONS :
966 case LISP_TYPE_PATTERN_CONS :
967 fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
970 lisp_dump(lisp_car(obj), out);
974 if (lisp_type(obj) != LISP_TYPE_CONS
975 && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
988 case LISP_TYPE_BOOLEAN :
989 if (lisp_boolean(obj))
1000 using namespace std;
1002 LispReader::LispReader (lisp_object_t* l)
1005 //std::cout << "LispReader: " << std::flush;
1006 //lisp_dump(lst, stdout);
1007 //std::cout << std::endl;
1011 LispReader::search_for(const char* name)
1013 //std::cout << "LispReader::search_for(" << name << ")" << std::endl;
1014 lisp_object_t* cursor = lst;
1016 while(!lisp_nil_p(cursor))
1018 lisp_object_t* cur = lisp_car(cursor);
1020 if (!lisp_cons_p(cur) || !lisp_symbol_p (lisp_car(cur)))
1022 lisp_dump(cur, stdout);
1023 //throw ConstruoError (std::string("LispReader: Read error in search_for ") + name);
1024 printf("LispReader: Read error in search\n");
1028 if (strcmp(lisp_symbol(lisp_car(cur)), name) == 0)
1030 return lisp_cdr(cur);
1034 cursor = lisp_cdr (cursor);
1040 LispReader::read_int (const char* name, int* i)
1042 lisp_object_t* obj = search_for (name);
1045 if (!lisp_integer_p(lisp_car(obj)))
1046 st_abort("LispReader expected type integer at token: ", name);
1047 *i = lisp_integer(lisp_car(obj));
1054 LispReader::read_lisp(const char* name, lisp_object_t** b)
1056 lisp_object_t* obj = search_for (name);
1067 LispReader::read_float (const char* name, float* f)
1069 lisp_object_t* obj = search_for (name);
1072 if (!lisp_real_p(lisp_car(obj)) && !lisp_integer_p(lisp_car(obj)))
1073 st_abort("LispReader expected type real at token: ", name);
1074 *f = lisp_real(lisp_car(obj));
1081 LispReader::read_string_vector (const char* name, std::vector<std::string>* vec)
1083 lisp_object_t* obj = search_for (name);
1086 while(!lisp_nil_p(obj))
1088 if (!lisp_string_p(lisp_car(obj)))
1089 st_abort("LispReader expected type string at token: ", name);
1090 vec->push_back(lisp_string(lisp_car(obj)));
1091 obj = lisp_cdr(obj);
1099 LispReader::read_int_vector (const char* name, std::vector<int>* vec)
1101 lisp_object_t* obj = search_for (name);
1104 while(!lisp_nil_p(obj))
1106 if (!lisp_integer_p(lisp_car(obj)))
1107 st_abort("LispReader expected type integer at token: ", name);
1108 vec->push_back(lisp_integer(lisp_car(obj)));
1109 obj = lisp_cdr(obj);
1117 LispReader::read_char_vector (const char* name, std::vector<char>* vec)
1119 lisp_object_t* obj = search_for (name);
1122 while(!lisp_nil_p(obj))
1124 vec->push_back(*lisp_string(lisp_car(obj)));
1125 obj = lisp_cdr(obj);
1133 LispReader::read_string (const char* name, std::string* str)
1135 lisp_object_t* obj = search_for (name);
1138 if (!lisp_string_p(lisp_car(obj)))
1139 st_abort("LispReader expected type string at token: ", name);
1140 *str = lisp_string(lisp_car(obj));
1147 LispReader::read_bool (const char* name, bool* b)
1149 lisp_object_t* obj = search_for (name);
1152 if (!lisp_boolean_p(lisp_car(obj)))
1153 st_abort("LispReader expected type bool at token: ", name);
1154 *b = lisp_boolean(lisp_car(obj));
1160 LispWriter::LispWriter (const char* name)
1162 lisp_objs.push_back(lisp_make_symbol (name));
1166 LispWriter::append (lisp_object_t* obj)
1168 lisp_objs.push_back(obj);
1172 LispWriter::make_list3 (lisp_object_t* a, lisp_object_t* b, lisp_object_t* c)
1174 return lisp_make_cons (a, lisp_make_cons(b, lisp_make_cons(c, lisp_nil())));
1178 LispWriter::make_list2 (lisp_object_t* a, lisp_object_t* b)
1180 return lisp_make_cons (a, lisp_make_cons(b, lisp_nil()));
1184 LispWriter::write_float (const char* name, float f)
1186 append(make_list2 (lisp_make_symbol (name),
1187 lisp_make_real(f)));
1191 LispWriter::write_int (const char* name, int i)
1193 append(make_list2 (lisp_make_symbol (name),
1194 lisp_make_integer(i)));
1198 LispWriter::write_string (const char* name, const char* str)
1200 append(make_list2 (lisp_make_symbol (name),
1201 lisp_make_string(str)));
1205 LispWriter::write_symbol (const char* name, const char* symname)
1207 append(make_list2 (lisp_make_symbol (name),
1208 lisp_make_symbol(symname)));
1212 LispWriter::write_lisp_obj(const char* name, lisp_object_t* lst)
1214 append(make_list2 (lisp_make_symbol (name),
1219 LispWriter::write_boolean (const char* name, bool b)
1221 append(make_list2 (lisp_make_symbol (name),
1222 lisp_make_boolean(b)));
1226 LispWriter::create_lisp ()
1228 lisp_object_t* lisp_obj = lisp_nil();
1230 for(std::vector<lisp_object_t*>::reverse_iterator i = lisp_objs.rbegin ();
1231 i != lisp_objs.rend (); ++i)
1233 lisp_obj = lisp_make_cons (*i, lisp_obj);
1241 void mygzungetc(char c, void* file)
1246 lisp_stream_t* lisp_stream_init_gzfile (lisp_stream_t *stream, gzFile file)
1248 return lisp_stream_init_any (stream, file, gzgetc, mygzungetc);
1252 lisp_object_t* lisp_read_from_gzfile(const char* filename)
1255 lisp_object_t* root_obj = 0;
1256 int chunk_size = 128 * 1024;
1259 char* buf = static_cast<char*>(malloc(chunk_size));
1262 gzFile in = gzopen(filename, "r");
1266 int ret = gzread(in, buf + buf_pos, chunk_size);
1270 assert(!"Error while reading from file");
1272 else if (ret == chunk_size) // buffer got full, eof not yet there so resize
1274 buf_pos = chunk_size * try_number;
1276 buf = static_cast<char*>(realloc(buf, chunk_size * try_number));
1281 // everything fine, encountered EOF
1286 lisp_stream_t stream;
1287 lisp_stream_init_string (&stream, buf);
1288 root_obj = lisp_read (&stream);
1296 bool has_suffix(const char* data, const char* suffix)
1298 int suffix_len = strlen(suffix);
1299 int data_len = strlen(data);
1301 const char* data_suffix = (data + data_len - suffix_len);
1303 if (data_suffix >= data)
1305 return (strcmp(data_suffix, suffix) == 0);
1313 lisp_object_t* lisp_read_from_file(const std::string& filename)
1315 lisp_stream_t stream;
1317 if (has_suffix(filename.c_str(), ".gz"))
1319 return lisp_read_from_gzfile(filename.c_str());
1323 lisp_object_t* obj = 0;
1324 FILE* in = fopen(filename.c_str(), "r");
1328 lisp_stream_init_file(&stream, in);
1329 obj = lisp_read(&stream);