1 /* $Id: lispreader.cpp 155 2009-07-31 16:11:29Z grumbel $ */
2 /*
3 * lispreader.c
4 *
5 * Copyright (C) 1998-2000 Mark Probst
6 *
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.
11 *
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.
16 *
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.
21 */
22
23 #include <assert.h>
24 #include <ctype.h>
25 #include <stdlib.h>
26 #include <string.h>
27
28 #include "construo_error.hpp"
29 #include <lispreader.hpp>
30
31 #define TOKEN_ERROR -1
32 #define TOKEN_EOF 0
33 #define TOKEN_OPEN_PAREN 1
34 #define TOKEN_CLOSE_PAREN 2
35 #define TOKEN_SYMBOL 3
36 #define TOKEN_STRING 4
37 #define TOKEN_INTEGER 5
38 #define TOKEN_REAL 6
39 #define TOKEN_PATTERN_OPEN_PAREN 7
40 #define TOKEN_DOT 8
41 #define TOKEN_TRUE 9
42 #define TOKEN_FALSE 10
43
44
45 #define MAX_TOKEN_LENGTH 1024
46
47 static char token_string[MAX_TOKEN_LENGTH + 1] = "";
48 static int token_length = 0;
49
50 static lisp_object_t end_marker = { LISP_TYPE_EOF };
51 static lisp_object_t error_object = { LISP_TYPE_PARSE_ERROR };
52 static lisp_object_t close_paren_marker = { LISP_TYPE_PARSE_ERROR };
53 static lisp_object_t dot_marker = { LISP_TYPE_PARSE_ERROR };
54
55 static void
_token_clear(void)56 _token_clear (void)
57 {
58 token_string[0] = '\0';
59 token_length = 0;
60 }
61
62 static void
_token_append(char c)63 _token_append (char c)
64 {
65 assert(token_length < MAX_TOKEN_LENGTH);
66
67 token_string[token_length++] = c;
68 token_string[token_length] = '\0';
69 }
70
71 static int
_next_char(lisp_stream_t * stream)72 _next_char (lisp_stream_t *stream)
73 {
74 switch (stream->type)
75 {
76 case LISP_STREAM_FILE :
77 return getc(stream->v.file);
78
79 case LISP_STREAM_STRING :
80 {
81 char c = stream->v.string.buf[stream->v.string.pos];
82
83 if (c == 0)
84 return EOF;
85
86 ++stream->v.string.pos;
87
88 return c;
89 }
90
91 case LISP_STREAM_ANY:
92 return stream->v.any.next_char(stream->v.any.data);
93 }
94 assert(0);
95 return EOF;
96 }
97
98 static void
_unget_char(char c,lisp_stream_t * stream)99 _unget_char (char c, lisp_stream_t *stream)
100 {
101 switch (stream->type)
102 {
103 case LISP_STREAM_FILE :
104 ungetc(c, stream->v.file);
105 break;
106
107 case LISP_STREAM_STRING :
108 --stream->v.string.pos;
109 break;
110
111 case LISP_STREAM_ANY:
112 stream->v.any.unget_char(c, stream->v.any.data);
113 break;
114
115 default :
116 assert(0);
117 }
118 }
119
120 static int
_scan(lisp_stream_t * stream)121 _scan (lisp_stream_t *stream)
122 {
123 static const char *delims = "\"();";
124
125 int c;
126
127 _token_clear();
128
129 do
130 {
131 c = _next_char(stream);
132 if (c == EOF)
133 return TOKEN_EOF;
134 else if (c == ';') /* comment start */
135 while (1)
136 {
137 c = _next_char(stream);
138 if (c == EOF)
139 return TOKEN_EOF;
140 else if (c == '\n')
141 break;
142 }
143 } while (isspace(c));
144
145 switch (c)
146 {
147 case '(' :
148 return TOKEN_OPEN_PAREN;
149
150 case ')' :
151 return TOKEN_CLOSE_PAREN;
152
153 case '"' :
154 while (1)
155 {
156 c = _next_char(stream);
157 if (c == EOF)
158 return TOKEN_ERROR;
159 if (c == '"')
160 break;
161 if (c == '\\')
162 {
163 c = _next_char(stream);
164
165 switch (c)
166 {
167 case EOF :
168 return TOKEN_ERROR;
169
170 case 'n' :
171 c = '\n';
172 break;
173
174 case 't' :
175 c = '\t';
176 break;
177 }
178 }
179
180 _token_append(c);
181 }
182 return TOKEN_STRING;
183
184 case '#' :
185 c = _next_char(stream);
186 if (c == EOF)
187 return TOKEN_ERROR;
188
189 switch (c)
190 {
191 case 't' :
192 return TOKEN_TRUE;
193
194 case 'f' :
195 return TOKEN_FALSE;
196
197 case '?' :
198 c = _next_char(stream);
199 if (c == EOF)
200 return TOKEN_ERROR;
201
202 if (c == '(')
203 return TOKEN_PATTERN_OPEN_PAREN;
204 else
205 return TOKEN_ERROR;
206 }
207 return TOKEN_ERROR;
208
209 default :
210 if (isdigit(c) || c == '-')
211 {
212 int have_nondigits = 0;
213 int have_digits = 0;
214 int have_floating_point = 0;
215
216 do
217 {
218 if (isdigit(c))
219 have_digits = 1;
220 else if (c == '.')
221 have_floating_point++;
222 _token_append(c);
223
224 c = _next_char(stream);
225
226 if (c != EOF && !isdigit(c) && !isspace(c) && c != '.' && !strchr(delims, c))
227 have_nondigits = 1;
228 } while (c != EOF && !isspace(c) && !strchr(delims, c));
229
230 if (c != EOF)
231 _unget_char(c, stream);
232
233 if (have_nondigits || !have_digits || have_floating_point > 1)
234 return TOKEN_SYMBOL;
235 else if (have_floating_point == 1)
236 return TOKEN_REAL;
237 else
238 return TOKEN_INTEGER;
239 }
240 else
241 {
242 if (c == '.')
243 {
244 c = _next_char(stream);
245 if (c != EOF && !isspace(c) && !strchr(delims, c))
246 _token_append('.');
247 else
248 {
249 _unget_char(c, stream);
250 return TOKEN_DOT;
251 }
252 }
253 do
254 {
255 _token_append(c);
256 c = _next_char(stream);
257 } while (c != EOF && !isspace(c) && !strchr(delims, c));
258 if (c != EOF)
259 _unget_char(c, stream);
260
261 return TOKEN_SYMBOL;
262 }
263 }
264
265 assert(0);
266 return TOKEN_ERROR;
267 }
268
269 static lisp_object_t*
lisp_object_alloc(int type)270 lisp_object_alloc (int type)
271 {
272 lisp_object_t *obj = (lisp_object_t*)malloc(sizeof(lisp_object_t));
273
274 obj->type = type;
275
276 return obj;
277 }
278
279 lisp_stream_t*
lisp_stream_init_file(lisp_stream_t * stream,FILE * file)280 lisp_stream_init_file (lisp_stream_t *stream, FILE *file)
281 {
282 stream->type = LISP_STREAM_FILE;
283 stream->v.file = file;
284
285 return stream;
286 }
287
288 lisp_stream_t*
lisp_stream_init_string(lisp_stream_t * stream,char * buf)289 lisp_stream_init_string (lisp_stream_t *stream, char *buf)
290 {
291 stream->type = LISP_STREAM_STRING;
292 stream->v.string.buf = buf;
293 stream->v.string.pos = 0;
294
295 return stream;
296 }
297
298 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))299 lisp_stream_init_any (lisp_stream_t *stream, void *data,
300 int (*next_char) (void *data),
301 void (*unget_char) (char c, void *data))
302 {
303 assert(next_char != 0 && unget_char != 0);
304
305 stream->type = LISP_STREAM_ANY;
306 stream->v.any.data = data;
307 stream->v.any.next_char= next_char;
308 stream->v.any.unget_char = unget_char;
309
310 return stream;
311 }
312
313 lisp_object_t*
lisp_make_integer(int value)314 lisp_make_integer (int value)
315 {
316 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_INTEGER);
317
318 obj->v.integer = value;
319
320 return obj;
321 }
322
323 lisp_object_t*
lisp_make_real(float value)324 lisp_make_real (float value)
325 {
326 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_REAL);
327
328 obj->v.real = value;
329
330 return obj;
331 }
332
333 lisp_object_t*
lisp_make_symbol(const char * value)334 lisp_make_symbol (const char *value)
335 {
336 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_SYMBOL);
337
338 obj->v.string = strdup(value);
339
340 return obj;
341 }
342
343 lisp_object_t*
lisp_make_string(const char * value)344 lisp_make_string (const char *value)
345 {
346 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_STRING);
347
348 obj->v.string = strdup(value);
349
350 return obj;
351 }
352
353 lisp_object_t*
lisp_make_cons(lisp_object_t * car,lisp_object_t * cdr)354 lisp_make_cons (lisp_object_t *car, lisp_object_t *cdr)
355 {
356 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_CONS);
357
358 obj->v.cons.car = car;
359 obj->v.cons.cdr = cdr;
360
361 return obj;
362 }
363
364 lisp_object_t*
lisp_make_boolean(int value)365 lisp_make_boolean (int value)
366 {
367 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_BOOLEAN);
368
369 obj->v.integer = value ? 1 : 0;
370
371 return obj;
372 }
373
374 static lisp_object_t*
lisp_make_pattern_cons(lisp_object_t * car,lisp_object_t * cdr)375 lisp_make_pattern_cons (lisp_object_t *car, lisp_object_t *cdr)
376 {
377 lisp_object_t *obj = lisp_object_alloc(LISP_TYPE_PATTERN_CONS);
378
379 obj->v.cons.car = car;
380 obj->v.cons.cdr = cdr;
381
382 return obj;
383 }
384
385 lisp_object_t*
lisp_read(lisp_stream_t * in)386 lisp_read (lisp_stream_t *in)
387 {
388 int token = _scan(in);
389 lisp_object_t *obj = lisp_nil();
390
391 if (token == TOKEN_EOF)
392 return &end_marker;
393
394 switch (token)
395 {
396 case TOKEN_ERROR :
397 return &error_object;
398
399 case TOKEN_EOF :
400 return &end_marker;
401
402 case TOKEN_OPEN_PAREN :
403 case TOKEN_PATTERN_OPEN_PAREN :
404 {
405 lisp_object_t *last = lisp_nil(), *car;
406
407 do
408 {
409 car = lisp_read(in);
410 if (car == &error_object || car == &end_marker)
411 {
412 lisp_free(obj);
413 return &error_object;
414 }
415 else if (car == &dot_marker)
416 {
417 if (lisp_nil_p(last))
418 {
419 lisp_free(obj);
420 return &error_object;
421 }
422
423 car = lisp_read(in);
424 if (car == &error_object || car == &end_marker)
425 {
426 lisp_free(obj);
427 return car;
428 }
429 else
430 {
431 last->v.cons.cdr = car;
432
433 if (_scan(in) != TOKEN_CLOSE_PAREN)
434 {
435 lisp_free(obj);
436 return &error_object;
437 }
438
439 car = &close_paren_marker;
440 }
441 }
442 else if (car != &close_paren_marker)
443 {
444 if (lisp_nil_p(last))
445 obj = last = (token == TOKEN_OPEN_PAREN ? lisp_make_cons(car, lisp_nil()) : lisp_make_pattern_cons(car, lisp_nil()));
446 else
447 last = last->v.cons.cdr = lisp_make_cons(car, lisp_nil());
448 }
449 } while (car != &close_paren_marker);
450 }
451 return obj;
452
453 case TOKEN_CLOSE_PAREN :
454 return &close_paren_marker;
455
456 case TOKEN_SYMBOL :
457 return lisp_make_symbol(token_string);
458
459 case TOKEN_STRING :
460 return lisp_make_string(token_string);
461
462 case TOKEN_INTEGER :
463 return lisp_make_integer(atoi(token_string));
464
465 case TOKEN_REAL :
466 return lisp_make_real((float)atof(token_string));
467
468 case TOKEN_DOT :
469 return &dot_marker;
470
471 case TOKEN_TRUE :
472 return lisp_make_boolean(1);
473
474 case TOKEN_FALSE :
475 return lisp_make_boolean(0);
476 }
477
478 assert(0);
479 return &error_object;
480 }
481
482 void
lisp_free(lisp_object_t * obj)483 lisp_free (lisp_object_t *obj)
484 {
485 if (obj == 0)
486 return;
487
488 switch (obj->type)
489 {
490 case LISP_TYPE_INTERNAL :
491 case LISP_TYPE_PARSE_ERROR :
492 case LISP_TYPE_EOF :
493 return;
494
495 case LISP_TYPE_SYMBOL :
496 case LISP_TYPE_STRING :
497 free(obj->v.string);
498 break;
499
500 case LISP_TYPE_CONS :
501 case LISP_TYPE_PATTERN_CONS :
502 lisp_free(obj->v.cons.car);
503 lisp_free(obj->v.cons.cdr);
504 break;
505
506 case LISP_TYPE_PATTERN_VAR :
507 lisp_free(obj->v.pattern.sub);
508 break;
509 }
510
511 free(obj);
512 }
513
514 lisp_object_t*
lisp_read_from_string(const char * buf)515 lisp_read_from_string (const char *buf)
516 {
517 lisp_stream_t stream;
518
519 lisp_stream_init_string(&stream, (char*)buf);
520 return lisp_read(&stream);
521 }
522
523 int
lisp_type(lisp_object_t * obj)524 lisp_type (lisp_object_t *obj)
525 {
526 if (obj == 0)
527 return LISP_TYPE_NIL;
528 return obj->type;
529 }
530
531 int
lisp_integer(lisp_object_t * obj)532 lisp_integer (lisp_object_t *obj)
533 {
534 assert(obj->type == LISP_TYPE_INTEGER);
535
536 return obj->v.integer;
537 }
538
539 char*
lisp_symbol(lisp_object_t * obj)540 lisp_symbol (lisp_object_t *obj)
541 {
542 assert(obj->type == LISP_TYPE_SYMBOL);
543
544 return obj->v.string;
545 }
546
547 char*
lisp_string(lisp_object_t * obj)548 lisp_string (lisp_object_t *obj)
549 {
550 if (obj->type != LISP_TYPE_STRING)
551 ConstruoError::raise("lispreader Error: obj->type != LISP_TYPE_STRING");
552
553 return obj->v.string;
554 }
555
556 int
lisp_boolean(lisp_object_t * obj)557 lisp_boolean (lisp_object_t *obj)
558 {
559 assert(obj->type == LISP_TYPE_BOOLEAN);
560
561 return obj->v.integer;
562 }
563
564 float
lisp_real(lisp_object_t * obj)565 lisp_real (lisp_object_t *obj)
566 {
567 assert(obj->type == LISP_TYPE_REAL || obj->type == LISP_TYPE_INTEGER);
568
569 if (obj->type == LISP_TYPE_INTEGER)
570 return obj->v.integer;
571 return obj->v.real;
572 }
573
574 lisp_object_t*
lisp_car(lisp_object_t * obj)575 lisp_car (lisp_object_t *obj)
576 {
577 if (!(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS))
578 ConstruoError::raise("lispreader Error: !(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS)");
579
580 return obj->v.cons.car;
581 }
582
583 lisp_object_t*
lisp_cdr(lisp_object_t * obj)584 lisp_cdr (lisp_object_t *obj)
585 {
586 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
587
588 return obj->v.cons.cdr;
589 }
590
591 lisp_object_t*
lisp_cxr(lisp_object_t * obj,const char * x)592 lisp_cxr (lisp_object_t *obj, const char *x)
593 {
594 int i;
595
596 for (i = strlen(x) - 1; i >= 0; --i)
597 if (x[i] == 'a')
598 obj = lisp_car(obj);
599 else if (x[i] == 'd')
600 obj = lisp_cdr(obj);
601 else
602 assert(0);
603
604 return obj;
605 }
606
607 int
lisp_list_length(lisp_object_t * obj)608 lisp_list_length (lisp_object_t *obj)
609 {
610 int length = 0;
611
612 while (obj != 0)
613 {
614 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
615
616 ++length;
617 obj = obj->v.cons.cdr;
618 }
619
620 return length;
621 }
622
623 lisp_object_t*
lisp_list_nth_cdr(lisp_object_t * obj,int index)624 lisp_list_nth_cdr (lisp_object_t *obj, int index)
625 {
626 while (index > 0)
627 {
628 assert(obj != 0);
629 assert(obj->type == LISP_TYPE_CONS || obj->type == LISP_TYPE_PATTERN_CONS);
630
631 --index;
632 obj = obj->v.cons.cdr;
633 }
634
635 return obj;
636 }
637
638 lisp_object_t*
lisp_list_nth(lisp_object_t * obj,int index)639 lisp_list_nth (lisp_object_t *obj, int index)
640 {
641 obj = lisp_list_nth_cdr(obj, index);
642
643 assert(obj != 0);
644
645 return obj->v.cons.car;
646 }
647
648 void
lisp_dump(lisp_object_t * obj,FILE * out)649 lisp_dump (lisp_object_t *obj, FILE *out)
650 {
651 if (obj == 0)
652 {
653 fprintf(out, "()");
654 return;
655 }
656
657 switch (lisp_type(obj))
658 {
659 case LISP_TYPE_EOF :
660 fputs("#<eof>", out);
661 break;
662
663 case LISP_TYPE_PARSE_ERROR :
664 fputs("#<error>", out);
665 break;
666
667 case LISP_TYPE_INTEGER :
668 fprintf(out, "%d", lisp_integer(obj));
669 break;
670
671 case LISP_TYPE_REAL :
672 fprintf(out, "%f", lisp_real(obj));
673 break;
674
675 case LISP_TYPE_SYMBOL :
676 fputs(lisp_symbol(obj), out);
677 break;
678
679 case LISP_TYPE_STRING :
680 {
681 char *p;
682
683 fputc('"', out);
684 for (p = lisp_string(obj); *p != 0; ++p)
685 {
686 if (*p == '"' || *p == '\\')
687 fputc('\\', out);
688 fputc(*p, out);
689 }
690 fputc('"', out);
691 }
692 break;
693
694 case LISP_TYPE_CONS :
695 case LISP_TYPE_PATTERN_CONS :
696 fputs(lisp_type(obj) == LISP_TYPE_CONS ? "(" : "#?(", out);
697 while (obj != 0)
698 {
699 lisp_dump(lisp_car(obj), out);
700 obj = lisp_cdr(obj);
701 if (obj != 0)
702 {
703 if (lisp_type(obj) != LISP_TYPE_CONS
704 && lisp_type(obj) != LISP_TYPE_PATTERN_CONS)
705 {
706 fputs(" . ", out);
707 lisp_dump(obj, out);
708 break;
709 }
710 else
711 fputc(' ', out);
712 }
713 }
714 fputc(')', out);
715 break;
716
717 case LISP_TYPE_BOOLEAN :
718 if (lisp_boolean(obj))
719 fputs("#t", out);
720 else
721 fputs("#f", out);
722 break;
723
724 default :
725 assert(0);
726 }
727 }
728