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.
33 #include "../app/globals.h"
34 #include "../app/setup.h"
35 #include "../utils/lispreader.h"
37 using namespace SuperTux;
39 #define TOKEN_ERROR -1
41 #define TOKEN_OPEN_PAREN 1
42 #define TOKEN_CLOSE_PAREN 2
43 #define TOKEN_SYMBOL 3
44 #define TOKEN_STRING 4
45 #define TOKEN_INTEGER 5
47 #define TOKEN_PATTERN_OPEN_PAREN 7
50 #define TOKEN_FALSE 10
53 #define MAX_TOKEN_LENGTH 4096
55 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
56 static int token_length = 0;
58 static lisp_object_t end_marker = { LISP_TYPE_EOF, {{0, 0}} };
59 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR , {{0,0}} };
60 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR , {{0,0}} };
61 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR , {{0,0}} };
66 token_string[0] = '\0';
71 _token_append (char c)
73 if (token_length >= MAX_TOKEN_LENGTH)
74 throw std::runtime_error("token too long.");
76 token_string[token_length++] = c;
77 token_string[token_length] = '\0';
81 _next_char (lisp_stream_t *stream)
85 case LISP_STREAM_FILE :
86 return getc(stream->v.file);
88 case LISP_STREAM_STRING :
90 char c = stream->v.string.buf[stream->v.string.pos];
95 ++stream->v.string.pos;
100 case LISP_STREAM_ANY:
101 return stream->v.any.next_char(stream->v.any.data);
109 _unget_char (char c, lisp_stream_t *stream)
111 switch (stream->type)
113 case LISP_STREAM_FILE :
114 ungetc(c, stream->v.file);
117 case LISP_STREAM_STRING :
118 --stream->v.string.pos;
121 case LISP_STREAM_ANY:
122 stream->v.any.unget_char(c, stream->v.any.data);
131 _scan (lisp_stream_t *stream)
133 static char *delims = "\"();";
141 c = _next_char(stream);
144 else if (c == ';') /* comment start */
147 c = _next_char(stream);
159 return TOKEN_OPEN_PAREN;
162 return TOKEN_CLOSE_PAREN;
167 c = _next_char(stream);
174 c = _next_char(stream);
196 c = _next_char(stream);
209 c = _next_char(stream);
214 return TOKEN_PATTERN_OPEN_PAREN;
221 if (isdigit(c) || c == '-')
223 int have_nondigits = 0;
225 int have_floating_point = 0;
232 have_floating_point++;
235 c = _next_char(stream);
237 if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
240 while (c != EOF && !isspace(c) && !strchr(delims, c));
243 _unget_char(c, stream);
245 if (have_nondigits || !have_digits || have_floating_point > 1)
247 else if (have_floating_point == 1)
250 return TOKEN_INTEGER;
256 c = _next_char(stream);
257 if (c != EOF && !isspace(c) && !strchr(delims, c))
261 _unget_char(c, stream);
268 c = _next_char(stream);
270 while (c != EOF && !isspace(c) && !strchr(delims, c));
272 _unget_char(c, stream);
278 throw std::runtime_error("invalid token in lisp file");
282 static lisp_object_t*
283 lisp_object_alloc (int type)
285 lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
293 SuperTux::lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
295 stream->type = LISP_STREAM_FILE;
296 stream->v.file = file;
302 SuperTux::lisp_stream_init_string (lisp_stream_t *stream, char *buf)
304 stream->type = LISP_STREAM_STRING;
305 stream->v.string.buf = buf;
306 stream->v.string.pos = 0;
312 SuperTux::lisp_stream_init_any (lisp_stream_t *stream, void *data,
313 int (*next_char) (void *data),
314 void (*unget_char) (char c, void *data))
316 if (next_char == 0 || unget_char == 0)
317 throw std::runtime_error("no data");
319 stream->type = LISP_STREAM_ANY;
320 stream->v.any.data = data;
321 stream->v.any.next_char= next_char;
322 stream->v.any.unget_char = unget_char;
328 SuperTux::lisp_make_integer (int value)
330 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
332 obj->v.integer = value;
338 SuperTux::lisp_make_real (float value)
340 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
348 SuperTux::lisp_make_symbol (const char *value)
350 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
352 obj->v.string = strdup(value);
358 SuperTux::lisp_make_string (const char *value)
360 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
362 obj->v.string = strdup(value);
368 SuperTux::lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
370 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
372 obj->v.cons.car = car;
373 obj->v.cons.cdr = cdr;
379 SuperTux::lisp_make_boolean (int value)
381 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
383 obj->v.integer = value ? 1 : 0;
388 static lisp_object_t*
389 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
391 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
393 obj->v.cons.car = car;
394 obj->v.cons.cdr = cdr;
399 static lisp_object_t*
400 lisp_make_pattern_var (int type, int index, lisp_object_t *sub)
402 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_VAR);
404 obj->v.pattern.type = type;
405 obj->v.pattern.index = index;
406 obj->v.pattern.sub = sub;
412 SuperTux::lisp_read (lisp_stream_t *in)
414 int token = _scan(in);
415 lisp_object_t *obj = lisp_nil();
417 if (token == TOKEN_EOF)
423 return &error_object;
428 case TOKEN_OPEN_PAREN :
429 case TOKEN_PATTERN_OPEN_PAREN :
431 lisp_object_t *last = lisp_nil(), *car;
436 if (car == &error_object || car == &end_marker)
439 return &error_object;
441 else if (car == &dot_marker)
443 if (lisp_nil_p(last))
446 return &error_object;
450 if (car == &error_object || car == &end_marker)
457 last->v.cons.cdr = car;
459 if (_scan(in) != TOKEN_CLOSE_PAREN)
462 return &error_object;
465 car = &close_paren_marker;
468 else if (car != &close_paren_marker)
470 if (lisp_nil_p(last))
471 obj = last = (token == TOKEN_OPEN_PAREN ? lisp_make_cons(car, lisp_nil()) : lisp_make_pattern_cons(car, lisp_nil()));
473 last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
476 while (car != &close_paren_marker);
480 case TOKEN_CLOSE_PAREN :
481 return &close_paren_marker;
484 return lisp_make_symbol(token_string);
487 return lisp_make_string(token_string);
490 return lisp_make_integer(atoi(token_string));
493 return lisp_make_real((float)atof(token_string));
499 return lisp_make_boolean(1);
502 return lisp_make_boolean(0);
505 throw std::runtime_error("syntax error in lisp file");
506 return &error_object;
510 SuperTux::lisp_free (lisp_object_t *obj)
515 /** We have to use this iterative code, because the recursive function
516 * produces a stack overflow and crashs on OSX 10.2
518 std::vector<lisp_object_t*> objs;
521 while(!objs.empty()) {
522 lisp_object_t* obj = objs.back();
526 case LISP_TYPE_INTERNAL :
527 case LISP_TYPE_PARSE_ERROR :
531 case LISP_TYPE_SYMBOL :
532 case LISP_TYPE_STRING :
536 case LISP_TYPE_CONS :
537 case LISP_TYPE_PATTERN_CONS :
539 objs.push_back(obj->v.cons.car);
541 objs.push_back(obj->v.cons.cdr);
544 case LISP_TYPE_PATTERN_VAR :
545 if(obj->v.pattern.sub)
546 objs.push_back(obj->v.pattern.sub);
555 SuperTux::lisp_read_from_string (const char *buf)
557 lisp_stream_t stream;
559 lisp_stream_init_string(&stream, (char*)buf);
560 return lisp_read(&stream);
564 _compile_pattern (lisp_object_t **obj, int *index)
569 switch (lisp_type(*obj))
571 case LISP_TYPE_PATTERN_CONS :
580 { "any", LISP_PATTERN_ANY },
581 { "symbol", LISP_PATTERN_SYMBOL },
582 { "string", LISP_PATTERN_STRING },
583 { "integer", LISP_PATTERN_INTEGER },
584 { "real", LISP_PATTERN_REAL },
585 { "boolean", LISP_PATTERN_BOOLEAN },
586 { "list", LISP_PATTERN_LIST },
587 { "or", LISP_PATTERN_OR },
593 lisp_object_t *pattern;
596 if (lisp_type(lisp_car(*obj)) != LISP_TYPE_SYMBOL)
599 type_name = lisp_symbol(lisp_car(*obj));
600 for (i = 0; types[i].name != 0; ++i)
602 if (strcmp(types[i].name, type_name) == 0)
604 type = types[i].type;
609 if (types[i].name == 0)
612 if (type != LISP_PATTERN_OR && lisp_cdr(*obj) != 0)
615 pattern = lisp_make_pattern_var(type, (*index)++, lisp_nil());
617 if (type == LISP_PATTERN_OR)
619 lisp_object_t *cdr = lisp_cdr(*obj);
621 if (!_compile_pattern(&cdr, index))
627 pattern->v.pattern.sub = cdr;
629 (*obj)->v.cons.cdr = lisp_nil();
638 case LISP_TYPE_CONS :
639 if (!_compile_pattern(&(*obj)->v.cons.car, index))
641 if (!_compile_pattern(&(*obj)->v.cons.cdr, index))
650 SuperTux::lisp_compile_pattern (lisp_object_t **obj, int *num_subs)
655 result = _compile_pattern(obj, &index);
657 if (result && num_subs != 0)
663 static int _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars);
666 _match_pattern_var (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
668 if (lisp_type(pattern) != LISP_TYPE_PATTERN_VAR)
669 throw std::runtime_error("type is not a var");
671 switch (pattern->v.pattern.type)
673 case LISP_PATTERN_ANY :
676 case LISP_PATTERN_SYMBOL :
677 if (obj == 0 || lisp_type(obj) != LISP_TYPE_SYMBOL)
681 case LISP_PATTERN_STRING :
682 if (obj == 0 || lisp_type(obj) != LISP_TYPE_STRING)
686 case LISP_PATTERN_INTEGER :
687 if (obj == 0 || lisp_type(obj) != LISP_TYPE_INTEGER)
691 case LISP_PATTERN_REAL :
692 if (obj == 0 || lisp_type(obj) != LISP_TYPE_REAL)
696 case LISP_PATTERN_BOOLEAN :
697 if (obj == 0 || lisp_type(obj) != LISP_TYPE_BOOLEAN)
701 case LISP_PATTERN_LIST :
702 if (obj == 0 || lisp_type(obj) != LISP_TYPE_CONS)
706 case LISP_PATTERN_OR :
711 for (sub = pattern->v.pattern.sub; sub != 0; sub = lisp_cdr(sub))
713 if (lisp_type(sub) != LISP_TYPE_CONS)
714 throw std::runtime_error("type isn't a car/cons");
716 if (_match_pattern(lisp_car(sub), obj, vars))
730 vars[pattern->v.pattern.index] = obj;
736 _match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars)
744 if (lisp_type(pattern) == LISP_TYPE_PATTERN_VAR)
745 return _match_pattern_var(pattern, obj, vars);
747 if (lisp_type(pattern) != lisp_type(obj))
750 switch (lisp_type(pattern))
752 case LISP_TYPE_SYMBOL :
753 return strcmp(lisp_symbol(pattern), lisp_symbol(obj)) == 0;
755 case LISP_TYPE_STRING :
756 return strcmp(lisp_string(pattern), lisp_string(obj)) == 0;
758 case LISP_TYPE_INTEGER :
759 return lisp_integer(pattern) == lisp_integer(obj);
761 case LISP_TYPE_REAL :
762 return lisp_real(pattern) == lisp_real(obj);
764 case LISP_TYPE_CONS :
766 int result1, result2;
768 result1 = _match_pattern(lisp_car(pattern), lisp_car(obj), vars);
769 result2 = _match_pattern(lisp_cdr(pattern), lisp_cdr(obj), vars);
771 return result1 && result2;
783 SuperTux::lisp_match_pattern (lisp_object_t *pattern, lisp_object_t *obj, lisp_object_t **vars, int num_subs)
788 for (i = 0; i < num_subs; ++i)
789 vars[i] = &error_object;
791 return _match_pattern(pattern, obj, vars);
795 SuperTux::lisp_match_string (const char *pattern_string, lisp_object_t *obj, lisp_object_t **vars)
797 lisp_object_t *pattern;
801 pattern = lisp_read_from_string(pattern_string);
803 if (pattern != 0 && (lisp_type(pattern) == LISP_TYPE_EOF
804 || lisp_type(pattern) == LISP_TYPE_PARSE_ERROR))
807 if (!lisp_compile_pattern(&pattern, &num_subs))
813 result = lisp_match_pattern(pattern, obj, vars, num_subs);
821 SuperTux::lisp_type (lisp_object_t *obj)
824 return LISP_TYPE_NIL;
829 SuperTux::lisp_integer (lisp_object_t *obj)
831 if (obj->type != LISP_TYPE_INTEGER)
832 throw std::runtime_error("expected integer");
834 return obj->v.integer;
838 SuperTux::lisp_symbol (lisp_object_t *obj)
840 if (obj->type != LISP_TYPE_SYMBOL)
841 throw std::runtime_error("expected symbol");
843 return obj->v.string;
847 SuperTux::lisp_string (lisp_object_t *obj)
849 if (obj->type != LISP_TYPE_STRING)
850 throw std::runtime_error("expected string");
852 return obj->v.string;
856 SuperTux::lisp_boolean (lisp_object_t *obj)
858 if (obj->type != LISP_TYPE_BOOLEAN)
859 throw std::runtime_error("expected boolean");
861 return obj->v.integer;
865 SuperTux::lisp_real (lisp_object_t *obj)
867 if (obj->type != LISP_TYPE_REAL && obj->type != LISP_TYPE_INTEGER)
868 throw std::runtime_error("expected real");
870 if (obj->type == LISP_TYPE_INTEGER)
871 return obj->v.integer;
876 SuperTux::lisp_car (lisp_object_t *obj)
878 if (obj->type != LISP_TYPE_CONS && obj->type != LISP_TYPE_PATTERN_CONS)
879 throw std::runtime_error("expected car");
881 return obj->v.cons.car;
885 SuperTux::lisp_cdr (lisp_object_t *obj)
887 if (obj->type != LISP_TYPE_CONS && obj->type != LISP_TYPE_PATTERN_CONS)
888 throw std::runtime_error("expected cons");
890 return obj->v.cons.cdr;
894 SuperTux::lisp_cxr (lisp_object_t *obj, const char *x)
898 for (i = strlen(x) - 1; i >= 0; --i)
901 else if (x[i] == 'd')
904 throw std::runtime_error("couldn't parse cxr");
910 SuperTux::lisp_list_length (lisp_object_t *obj)
916 if (obj->type != LISP_TYPE_CONS && obj->type != LISP_TYPE_PATTERN_CONS)
917 throw std::runtime_error("expected cons");
920 obj = obj->v.cons.cdr;
927 SuperTux::lisp_list_nth_cdr (lisp_object_t *obj, int index)
932 throw std::runtime_error("list too short");
933 if (obj->type != LISP_TYPE_CONS && obj->type != LISP_TYPE_PATTERN_CONS)
934 throw std::runtime_error("expected cons");
937 obj = obj->v.cons.cdr;
944 SuperTux::lisp_list_nth (lisp_object_t *obj, int index)
946 obj = lisp_list_nth_cdr(obj, index);
949 throw std::runtime_error("list too short");
951 return obj->v.cons.car;
955 SuperTux::lisp_dump (lisp_object_t *obj, FILE *out)
963 switch (lisp_type(obj))
966 fputs("#<eof>", out);
969 case LISP_TYPE_PARSE_ERROR :
970 fputs("#<error>", out);
973 case LISP_TYPE_INTEGER :
974 fprintf(out, "%d", lisp_integer(obj));
977 case LISP_TYPE_REAL :
978 fprintf(out, "%f", lisp_real(obj));
981 case LISP_TYPE_SYMBOL :
982 fputs(lisp_symbol(obj), out);
985 case LISP_TYPE_STRING :
990 for (p = lisp_string(obj); *p != 0; ++p)
992 if (*p == '"' || *p == '\\')
1000 case LISP_TYPE_CONS :
1001 case LISP_TYPE_PATTERN_CONS :
1002 fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
1005 lisp_dump(lisp_car(obj), out);
1006 obj = lisp_cdr(obj);
1009 if (lisp_type(obj) != LISP_TYPE_CONS
1010 && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
1013 lisp_dump(obj, out);
1023 case LISP_TYPE_BOOLEAN :
1024 if (lisp_boolean(obj))
1031 throw std::runtime_error("unknown list type");
1035 using namespace std;
1037 LispReader::LispReader (lisp_object_t* l)
1042 LispReader::~LispReader()
1049 LispReader::load(const std::string& filename, const std::string& toplevellist)
1051 lisp_object_t* obj = lisp_read_from_file(filename);
1053 if(obj->type == LISP_TYPE_EOF || obj->type == LISP_TYPE_PARSE_ERROR) {
1055 throw std::runtime_error("Error while parsing lispfile");
1058 if(toplevellist != lisp_symbol(lisp_car(obj))) {
1060 throw std::runtime_error("Worng toplevel symbol in lisp file");
1063 LispReader* reader = new LispReader(lisp_cdr(obj));
1064 reader->owner = obj;
1070 LispReader::search_for(const char* name)
1072 //std::cout << "LispReader::search_for(" << name << ")" << std::endl;
1073 lisp_object_t* cursor = lst;
1075 while(!lisp_nil_p(cursor))
1077 lisp_object_t* cur = lisp_car(cursor);
1079 if (!lisp_cons_p(cur) || !lisp_symbol_p (lisp_car(cur)))
1081 lisp_dump(cur, stdout);
1082 printf("LispReader: Read error in search\n");
1086 if (strcmp(lisp_symbol(lisp_car(cur)), name) == 0)
1088 return lisp_cdr(cur);
1092 cursor = lisp_cdr (cursor);
1098 LispReader::read_int (const char* name, int& i)
1100 lisp_object_t* obj = search_for (name);
1104 if (!lisp_integer_p(lisp_car(obj)))
1107 i = lisp_integer(lisp_car(obj));
1112 LispReader::read_uint (const char* name, unsigned int& i)
1114 lisp_object_t* obj = search_for (name);
1118 if (!lisp_integer_p(lisp_car(obj)))
1121 i = (unsigned int) lisp_integer(lisp_car(obj));
1126 LispReader::read_lisp(const char* name, lisp_object_t*& b)
1128 lisp_object_t* obj = search_for (name);
1137 LispReader::read_lisp(const char* name)
1139 return search_for(name);
1143 LispReader::read_float (const char* name, float& f)
1145 lisp_object_t* obj = search_for (name);
1149 if (!lisp_real_p(lisp_car(obj)) && !lisp_integer_p(lisp_car(obj)))
1150 Termination::abort("LispReader expected type real at token: ", name);
1152 f = lisp_real(lisp_car(obj));
1157 LispReader::read_string_vector (const char* name, std::vector<std::string>& vec)
1159 lisp_object_t* obj = search_for (name);
1164 while(!lisp_nil_p(obj))
1166 if (!lisp_string_p(lisp_car(obj)))
1167 Termination::abort("LispReader expected type string at token: ", name);
1168 vec.push_back(lisp_string(lisp_car(obj)));
1169 obj = lisp_cdr(obj);
1175 LispReader::read_int_vector (const char* name, std::vector<int>& vec)
1177 lisp_object_t* obj = search_for (name);
1182 while(!lisp_nil_p(obj))
1184 if (!lisp_integer_p(lisp_car(obj)))
1185 Termination::abort("LispReader expected type integer at token: ", name);
1186 vec.push_back(lisp_integer(lisp_car(obj)));
1187 obj = lisp_cdr(obj);
1193 LispReader::read_int_vector (const char* name, std::vector<unsigned int>& vec)
1195 lisp_object_t* obj = search_for (name);
1200 while(!lisp_nil_p(obj))
1202 if (!lisp_integer_p(lisp_car(obj)))
1203 Termination::abort("LispReader expected type integer at token: ", name);
1204 vec.push_back(lisp_integer(lisp_car(obj)));
1205 obj = lisp_cdr(obj);
1211 LispReader::read_char_vector (const char* name, std::vector<char>& vec)
1213 lisp_object_t* obj = search_for (name);
1218 while(!lisp_nil_p(obj))
1220 vec.push_back(*lisp_string(lisp_car(obj)));
1221 obj = lisp_cdr(obj);
1227 LispReader::read_string (const char* name, std::string& str, bool translatable)
1232 /* Internationalization support: check for the suffix: str + "-" + $LANG variable.
1233 If not found, use the regular string.
1234 So, translating a string in a Lisp file would result in something like:
1235 (text "Hello World!")
1236 (text-fr "Bonjour Monde!")
1237 being fr the value of LANG (echo $LANG) for the language we want to translate to */
1239 char* lang = getenv("LANG");
1241 char str_[1024]; // check, for instance, for (title-fr_FR "Bonjour")
1242 sprintf(str_, "%s-%s", name, lang);
1244 obj = search_for (str_);
1246 if(!obj) // check, for instance, for (title-fr "Bonjour")
1248 if(lang != NULL && strlen(lang) >= 2)
1251 strncpy(lang_, lang, 2);
1253 sprintf(str_, "%s-%s", name, lang_);
1255 obj = search_for (str_);
1261 if(!obj) // check, for instance, for (title "Hello")
1262 obj = search_for (name);
1265 obj = search_for (name);
1270 if (!lisp_string_p(lisp_car(obj)))
1271 Termination::abort("LispReader expected type string at token: ", name);
1272 str = lisp_string(lisp_car(obj));
1277 LispReader::read_bool (const char* name, bool& b)
1279 lisp_object_t* obj = search_for (name);
1283 if (!lisp_boolean_p(lisp_car(obj)))
1284 Termination::abort("LispReader expected type bool at token: ", name);
1285 b = lisp_boolean(lisp_car(obj));
1290 LispReader::get_lisp()
1295 lisp_object_t* SuperTux::lisp_read_from_file(const std::string& filename)
1297 FILE* in = fopen(filename.c_str(), "r");
1302 lisp_stream_t stream;
1303 lisp_stream_init_file(&stream, in);
1304 lisp_object_t* obj = lisp_read(&stream);