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.
34 #include "app/globals.h"
35 #include "app/setup.h"
36 #include "lispreader.h"
38 using namespace SuperTux;
40 #define TOKEN_ERROR -1
42 #define TOKEN_OPEN_PAREN 1
43 #define TOKEN_CLOSE_PAREN 2
44 #define TOKEN_SYMBOL 3
45 #define TOKEN_STRING 4
46 #define TOKEN_INTEGER 5
48 #define TOKEN_PATTERN_OPEN_PAREN 7
51 #define TOKEN_FALSE 10
54 #define MAX_TOKEN_LENGTH 4096
56 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
57 static int token_length = 0;
59 static lisp_object_t end_marker = { LISP_TYPE_EOF, {{0, 0}} };
60 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR , {{0,0}} };
61 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR , {{0,0}} };
62 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR , {{0,0}} };
67 token_string[0] = '\0';
72 _token_append (char c)
74 if (token_length >= MAX_TOKEN_LENGTH)
75 throw std::runtime_error("token too long.");
77 token_string[token_length++] = c;
78 token_string[token_length] = '\0';
82 _next_char (lisp_stream_t *stream)
86 case LISP_STREAM_FILE :
87 return getc(stream->v.file);
89 case LISP_STREAM_STRING :
91 char c = stream->v.string.buf[stream->v.string.pos];
96 ++stream->v.string.pos;
101 case LISP_STREAM_ANY:
102 return stream->v.any.next_char(stream->v.any.data);
110 _unget_char (char c, lisp_stream_t *stream)
112 switch (stream->type)
114 case LISP_STREAM_FILE :
115 ungetc(c, stream->v.file);
118 case LISP_STREAM_STRING :
119 --stream->v.string.pos;
122 case LISP_STREAM_ANY:
123 stream->v.any.unget_char(c, stream->v.any.data);
132 _scan (lisp_stream_t *stream)
134 static char *delims = "\"();";
142 c = _next_char(stream);
145 else if (c == ';') /* comment start */
148 c = _next_char(stream);
160 return TOKEN_OPEN_PAREN;
163 return TOKEN_CLOSE_PAREN;
168 c = _next_char(stream);
175 c = _next_char(stream);
197 c = _next_char(stream);
210 c = _next_char(stream);
215 return TOKEN_PATTERN_OPEN_PAREN;
222 if (isdigit(c) || c == '-')
224 int have_nondigits = 0;
226 int have_floating_point = 0;
233 have_floating_point++;
236 c = _next_char(stream);
238 if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
241 while (c != EOF && !isspace(c) && !strchr(delims, c));
244 _unget_char(c, stream);
246 if (have_nondigits || !have_digits || have_floating_point > 1)
248 else if (have_floating_point == 1)
251 return TOKEN_INTEGER;
257 c = _next_char(stream);
258 if (c != EOF && !isspace(c) && !strchr(delims, c))
262 _unget_char(c, stream);
269 c = _next_char(stream);
271 while (c != EOF && !isspace(c) && !strchr(delims, c));
273 _unget_char(c, stream);
279 throw std::runtime_error("invalid token in lisp file");
283 static lisp_object_t*
284 lisp_object_alloc (int type)
286 lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
294 SuperTux::lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
296 stream->type = LISP_STREAM_FILE;
297 stream->v.file = file;
303 SuperTux::lisp_stream_init_string (lisp_stream_t *stream, char *buf)
305 stream->type = LISP_STREAM_STRING;
306 stream->v.string.buf = buf;
307 stream->v.string.pos = 0;
313 SuperTux::lisp_stream_init_any (lisp_stream_t *stream, void *data,
314 int (*next_char) (void *data),
315 void (*unget_char) (char c, void *data))
317 if (next_char == 0 || unget_char == 0)
318 throw std::runtime_error("no data");
320 stream->type = LISP_STREAM_ANY;
321 stream->v.any.data = data;
322 stream->v.any.next_char= next_char;
323 stream->v.any.unget_char = unget_char;
329 SuperTux::lisp_make_integer (int value)
331 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
333 obj->v.integer = value;
339 SuperTux::lisp_make_real (float value)
341 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
349 SuperTux::lisp_make_symbol (const char *value)
351 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
353 obj->v.string = strdup(value);
359 SuperTux::lisp_make_string (const char *value)
361 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
363 obj->v.string = strdup(value);
369 SuperTux::lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
371 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
373 obj->v.cons.car = car;
374 obj->v.cons.cdr = cdr;
380 SuperTux::lisp_make_boolean (int value)
382 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
384 obj->v.integer = value ? 1 : 0;
389 static lisp_object_t*
390 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
392 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
394 obj->v.cons.car = car;
395 obj->v.cons.cdr = cdr;
400 static lisp_object_t*
401 lisp_make_pattern_var (int type, int index, lisp_object_t *sub)
403 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_VAR);
405 obj->v.pattern.type = type;
406 obj->v.pattern.index = index;
407 obj->v.pattern.sub = sub;
413 SuperTux::lisp_read (lisp_stream_t *in)
415 int token = _scan(in);
416 lisp_object_t *obj = lisp_nil();
418 if (token == TOKEN_EOF)
424 return &error_object;
429 case TOKEN_OPEN_PAREN :
430 case TOKEN_PATTERN_OPEN_PAREN :
432 lisp_object_t *last = lisp_nil(), *car;
437 if (car == &error_object || car == &end_marker)
440 return &error_object;
442 else if (car == &dot_marker)
444 if (lisp_nil_p(last))
447 return &error_object;
451 if (car == &error_object || car == &end_marker)
458 last->v.cons.cdr = car;
460 if (_scan(in) != TOKEN_CLOSE_PAREN)
463 return &error_object;
466 car = &close_paren_marker;
469 else if (car != &close_paren_marker)
471 if (lisp_nil_p(last))
472 obj = last = (token == TOKEN_OPEN_PAREN ? lisp_make_cons(car, lisp_nil()) : lisp_make_pattern_cons(car, lisp_nil()));
474 last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
477 while (car != &close_paren_marker);
481 case TOKEN_CLOSE_PAREN :
482 return &close_paren_marker;
485 return lisp_make_symbol(token_string);
488 return lisp_make_string(token_string);
491 return lisp_make_integer(atoi(token_string));
494 return lisp_make_real((float)atof(token_string));
500 return lisp_make_boolean(1);
503 return lisp_make_boolean(0);
506 throw std::runtime_error("syntax error in lisp file");
507 return &error_object;
511 SuperTux::lisp_free (lisp_object_t *obj)
516 /** We have to use this iterative code, because the recursive function
517 * produces a stack overflow and crashs on OSX 10.2
519 std::vector<lisp_object_t*> objs;
522 while(!objs.empty()) {
523 lisp_object_t* obj = objs.back();
527 case LISP_TYPE_INTERNAL :
528 case LISP_TYPE_PARSE_ERROR :
532 case LISP_TYPE_SYMBOL :
533 case LISP_TYPE_STRING :
537 case LISP_TYPE_CONS :
538 case LISP_TYPE_PATTERN_CONS :
540 objs.push_back(obj->v.cons.car);
542 objs.push_back(obj->v.cons.cdr);
545 case LISP_TYPE_PATTERN_VAR :
546 if(obj->v.pattern.sub)
547 objs.push_back(obj->v.pattern.sub);
556 SuperTux::lisp_read_from_string (const char *buf)
558 lisp_stream_t stream;
560 lisp_stream_init_string(&stream, (char*)buf);
561 return lisp_read(&stream);
565 _compile_pattern (lisp_object_t **obj, int *index)
570 switch (lisp_type(*obj))
572 case LISP_TYPE_PATTERN_CONS :
581 { "any", LISP_PATTERN_ANY },
582 { "symbol", LISP_PATTERN_SYMBOL },
583 { "string", LISP_PATTERN_STRING },
584 { "integer", LISP_PATTERN_INTEGER },
585 { "real", LISP_PATTERN_REAL },
586 { "boolean", LISP_PATTERN_BOOLEAN },
587 { "list", LISP_PATTERN_LIST },
588 { "or", LISP_PATTERN_OR },
594 lisp_object_t *pattern;
597 if (lisp_type(lisp_car(*obj)) != LISP_TYPE_SYMBOL)
600 type_name = lisp_symbol(lisp_car(*obj));
601 for (i = 0; types[i].name != 0; ++i)
603 if (strcmp(types[i].name, type_name) == 0)
605 type = types[i].type;
610 if (types[i].name == 0)
613 if (type != LISP_PATTERN_OR && lisp_cdr(*obj) != 0)
616 pattern = lisp_make_pattern_var(type, (*index)++, lisp_nil());
618 if (type == LISP_PATTERN_OR)
620 lisp_object_t *cdr = lisp_cdr(*obj);
622 if (!_compile_pattern(&cdr, index))
628 pattern->v.pattern.sub = cdr;
630 (*obj)->v.cons.cdr = lisp_nil();
639 case LISP_TYPE_CONS :
640 if (!_compile_pattern(&(*obj)->v.cons.car, index))
642 if (!_compile_pattern(&(*obj)->v.cons.cdr, index))
651 SuperTux::lisp_compile_pattern (lisp_object_t **obj, int *num_subs)
656 result = _compile_pattern(obj, &index);
658 if (result && num_subs != 0)
664 static int _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars);
667 _match_pattern_var (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
669 if (lisp_type(pattern) != LISP_TYPE_PATTERN_VAR)
670 throw std::runtime_error("type is not a var");
672 switch (pattern->v.pattern.type)
674 case LISP_PATTERN_ANY :
677 case LISP_PATTERN_SYMBOL :
678 if (obj == 0 || lisp_type(obj) != LISP_TYPE_SYMBOL)
682 case LISP_PATTERN_STRING :
683 if (obj == 0 || lisp_type(obj) != LISP_TYPE_STRING)
687 case LISP_PATTERN_INTEGER :
688 if (obj == 0 || lisp_type(obj) != LISP_TYPE_INTEGER)
692 case LISP_PATTERN_REAL :
693 if (obj == 0 || lisp_type(obj) != LISP_TYPE_REAL)
697 case LISP_PATTERN_BOOLEAN :
698 if (obj == 0 || lisp_type(obj) != LISP_TYPE_BOOLEAN)
702 case LISP_PATTERN_LIST :
703 if (obj == 0 || lisp_type(obj) != LISP_TYPE_CONS)
707 case LISP_PATTERN_OR :
712 for (sub = pattern->v.pattern.sub; sub != 0; sub = lisp_cdr(sub))
714 if (lisp_type(sub) != LISP_TYPE_CONS)
715 throw std::runtime_error("type isn't a car/cons");
717 if (_match_pattern(lisp_car(sub), obj, vars))
731 vars[pattern->v.pattern.index] = obj;
737 _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
745 if (lisp_type(pattern) == LISP_TYPE_PATTERN_VAR)
746 return _match_pattern_var(pattern, obj, vars);
748 if (lisp_type(pattern) != lisp_type(obj))
751 switch (lisp_type(pattern))
753 case LISP_TYPE_SYMBOL :
754 return strcmp(lisp_symbol(pattern), lisp_symbol(obj)) == 0;
756 case LISP_TYPE_STRING :
757 return strcmp(lisp_string(pattern), lisp_string(obj)) == 0;
759 case LISP_TYPE_INTEGER :
760 return lisp_integer(pattern) == lisp_integer(obj);
762 case LISP_TYPE_REAL :
763 return lisp_real(pattern) == lisp_real(obj);
765 case LISP_TYPE_CONS :
767 int result1, result2;
769 result1 = _match_pattern(lisp_car(pattern), lisp_car(obj), vars);
770 result2 = _match_pattern(lisp_cdr(pattern), lisp_cdr(obj), vars);
772 return result1 && result2;
784 SuperTux::lisp_match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars, int num_subs)
789 for (i = 0; i < num_subs; ++i)
790 vars[i] = &error_object;
792 return _match_pattern(pattern, obj, vars);
796 SuperTux::lisp_match_string (const char *pattern_string, lisp_object_t *obj, lisp_object_t **vars)
798 lisp_object_t *pattern;
802 pattern = lisp_read_from_string(pattern_string);
804 if (pattern != 0 && (lisp_type(pattern) == LISP_TYPE_EOF
805 || lisp_type(pattern) == LISP_TYPE_PARSE_ERROR))
808 if (!lisp_compile_pattern(&pattern, &num_subs))
814 result = lisp_match_pattern(pattern, obj, vars, num_subs);
822 SuperTux::lisp_type (lisp_object_t *obj)
825 return LISP_TYPE_NIL;
830 SuperTux::lisp_integer (lisp_object_t *obj)
832 if (obj->type != LISP_TYPE_INTEGER)
833 throw std::runtime_error("expected integer");
835 return obj->v.integer;
839 SuperTux::lisp_symbol (lisp_object_t *obj)
841 if (obj->type != LISP_TYPE_SYMBOL)
842 throw std::runtime_error("expected symbol");
844 return obj->v.string;
848 SuperTux::lisp_string (lisp_object_t *obj)
850 if (obj->type != LISP_TYPE_STRING)
851 throw std::runtime_error("expected string");
853 return obj->v.string;
857 SuperTux::lisp_boolean (lisp_object_t *obj)
859 if (obj->type != LISP_TYPE_BOOLEAN)
860 throw std::runtime_error("expected boolean");
862 return obj->v.integer;
866 SuperTux::lisp_real (lisp_object_t *obj)
868 if (obj->type != LISP_TYPE_REAL && obj->type != LISP_TYPE_INTEGER)
869 throw std::runtime_error("expected real");
871 if (obj->type == LISP_TYPE_INTEGER)
872 return obj->v.integer;
877 SuperTux::lisp_car (lisp_object_t *obj)
879 if (obj->type != LISP_TYPE_CONS && obj->type != LISP_TYPE_PATTERN_CONS)
880 throw std::runtime_error("expected car");
882 return obj->v.cons.car;
886 SuperTux::lisp_cdr (lisp_object_t *obj)
888 if (obj->type != LISP_TYPE_CONS && obj->type != LISP_TYPE_PATTERN_CONS)
889 throw std::runtime_error("expected cons");
891 return obj->v.cons.cdr;
895 SuperTux::lisp_cxr (lisp_object_t *obj, const char *x)
899 for (i = strlen(x) - 1; i >= 0; --i)
902 else if (x[i] == 'd')
905 throw std::runtime_error("couldn't parse cxr");
911 SuperTux::lisp_list_length (lisp_object_t *obj)
917 if (obj->type != LISP_TYPE_CONS && obj->type != LISP_TYPE_PATTERN_CONS)
918 throw std::runtime_error("expected cons");
921 obj = obj->v.cons.cdr;
928 SuperTux::lisp_list_nth_cdr (lisp_object_t *obj, int index)
933 throw std::runtime_error("list too short");
934 if (obj->type != LISP_TYPE_CONS && obj->type != LISP_TYPE_PATTERN_CONS)
935 throw std::runtime_error("expected cons");
938 obj = obj->v.cons.cdr;
945 SuperTux::lisp_list_nth (lisp_object_t *obj, int index)
947 obj = lisp_list_nth_cdr(obj, index);
950 throw std::runtime_error("list too short");
952 return obj->v.cons.car;
956 SuperTux::lisp_dump (lisp_object_t *obj, FILE *out)
964 switch (lisp_type(obj))
967 fputs("#<eof>", out);
970 case LISP_TYPE_PARSE_ERROR :
971 fputs("#<error>", out);
974 case LISP_TYPE_INTEGER :
975 fprintf(out, "%d", lisp_integer(obj));
978 case LISP_TYPE_REAL :
979 fprintf(out, "%f", lisp_real(obj));
982 case LISP_TYPE_SYMBOL :
983 fputs(lisp_symbol(obj), out);
986 case LISP_TYPE_STRING :
991 for (p = lisp_string(obj); *p != 0; ++p)
993 if (*p == '"' || *p == '\\')
1001 case LISP_TYPE_CONS :
1002 case LISP_TYPE_PATTERN_CONS :
1003 fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
1006 lisp_dump(lisp_car(obj), out);
1007 obj = lisp_cdr(obj);
1010 if (lisp_type(obj) != LISP_TYPE_CONS
1011 && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
1014 lisp_dump(obj, out);
1024 case LISP_TYPE_BOOLEAN :
1025 if (lisp_boolean(obj))
1032 throw std::runtime_error("unknown list type");
1036 using namespace std;
1038 LispReader::LispReader (lisp_object_t* l)
1043 LispReader::~LispReader()
1050 LispReader::load(const std::string& filename, const std::string& toplevellist)
1052 lisp_object_t* obj = lisp_read_from_file(filename);
1054 if(obj->type == LISP_TYPE_EOF || obj->type == LISP_TYPE_PARSE_ERROR) {
1056 throw std::runtime_error("Error while parsing lispfile");
1059 if(toplevellist != lisp_symbol(lisp_car(obj))) {
1061 throw std::runtime_error("Worng toplevel symbol in lisp file");
1064 LispReader* reader = new LispReader(lisp_cdr(obj));
1065 reader->owner = obj;
1071 LispReader::search_for(const char* name)
1073 //std::cout << "LispReader::search_for(" << name << ")" << std::endl;
1074 lisp_object_t* cursor = lst;
1076 while(!lisp_nil_p(cursor))
1078 lisp_object_t* cur = lisp_car(cursor);
1080 if (!lisp_cons_p(cur) || !lisp_symbol_p (lisp_car(cur)))
1082 lisp_dump(cur, stdout);
1083 printf("LispReader: Read error in search\n");
1087 if (strcmp(lisp_symbol(lisp_car(cur)), name) == 0)
1089 return lisp_cdr(cur);
1093 cursor = lisp_cdr (cursor);
1099 LispReader::read_int (const char* name, int& i)
1101 lisp_object_t* obj = search_for (name);
1105 if (!lisp_integer_p(lisp_car(obj)))
1108 i = lisp_integer(lisp_car(obj));
1113 LispReader::read_uint (const char* name, unsigned int& i)
1115 lisp_object_t* obj = search_for (name);
1119 if (!lisp_integer_p(lisp_car(obj)))
1122 i = (unsigned int) lisp_integer(lisp_car(obj));
1127 LispReader::read_lisp(const char* name, lisp_object_t*& b)
1129 lisp_object_t* obj = search_for (name);
1138 LispReader::read_lisp(const char* name)
1140 return search_for(name);
1144 LispReader::read_float (const char* name, float& f)
1146 lisp_object_t* obj = search_for (name);
1150 if (!lisp_real_p(lisp_car(obj)) && !lisp_integer_p(lisp_car(obj)))
1151 Termination::abort("LispReader expected type real at token: ", name);
1153 f = lisp_real(lisp_car(obj));
1158 LispReader::read_string_vector (const char* name, std::vector<std::string>& vec)
1160 lisp_object_t* obj = search_for (name);
1165 while(!lisp_nil_p(obj))
1167 if (!lisp_string_p(lisp_car(obj)))
1168 Termination::abort("LispReader expected type string at token: ", name);
1169 vec.push_back(lisp_string(lisp_car(obj)));
1170 obj = lisp_cdr(obj);
1176 LispReader::read_int_vector (const char* name, std::vector<int>& vec)
1178 lisp_object_t* obj = search_for (name);
1183 while(!lisp_nil_p(obj))
1185 if (!lisp_integer_p(lisp_car(obj)))
1186 Termination::abort("LispReader expected type integer at token: ", name);
1187 vec.push_back(lisp_integer(lisp_car(obj)));
1188 obj = lisp_cdr(obj);
1194 LispReader::read_int_vector (const char* name, std::vector<unsigned int>& vec)
1196 lisp_object_t* obj = search_for (name);
1201 while(!lisp_nil_p(obj))
1203 if (!lisp_integer_p(lisp_car(obj)))
1204 Termination::abort("LispReader expected type integer at token: ", name);
1205 vec.push_back(lisp_integer(lisp_car(obj)));
1206 obj = lisp_cdr(obj);
1212 LispReader::read_char_vector (const char* name, std::vector<char>& vec)
1214 lisp_object_t* obj = search_for (name);
1219 while(!lisp_nil_p(obj))
1221 vec.push_back(*lisp_string(lisp_car(obj)));
1222 obj = lisp_cdr(obj);
1228 LispReader::read_string (const char* name, std::string& str, bool translatable)
1233 /* Internationalization support: check for the suffix: str + "-" + $LANG variable.
1234 If not found, use the regular string.
1235 So, translating a string in a Lisp file would result in something like:
1236 (text "Hello World!")
1237 (text-fr "Bonjour Monde!")
1238 being fr the value of LANG (echo $LANG) for the language we want to translate to */
1240 char* lang = getenv("LANG");
1242 char str_[1024]; // check, for instance, for (title-fr_FR "Bonjour")
1243 sprintf(str_, "%s-%s", name, lang);
1245 obj = search_for (str_);
1247 if(!obj) // check, for instance, for (title-fr "Bonjour")
1249 if(lang != NULL && strlen(lang) >= 2)
1252 strncpy(lang_, lang, 2);
1254 sprintf(str_, "%s-%s", name, lang_);
1256 obj = search_for (str_);
1262 if(!obj) // check, for instance, for (title "Hello")
1263 obj = search_for (name);
1266 obj = search_for (name);
1271 if (!lisp_string_p(lisp_car(obj)))
1272 Termination::abort("LispReader expected type string at token: ", name);
1273 str = lisp_string(lisp_car(obj));
1278 LispReader::read_bool (const char* name, bool& b)
1280 lisp_object_t* obj = search_for (name);
1284 if (!lisp_boolean_p(lisp_car(obj)))
1285 Termination::abort("LispReader expected type bool at token: ", name);
1286 b = lisp_boolean(lisp_car(obj));
1291 LispReader::get_lisp()
1296 lisp_object_t* SuperTux::lisp_read_from_file(const std::string& filename)
1298 FILE* in = fopen(filename.c_str(), "r");
1303 lisp_stream_t stream;
1304 lisp_stream_init_file(&stream, in);
1305 lisp_object_t* obj = lisp_read(&stream);