1 /*
2 * Copyright (c) 2003 Nara Institute of Science and Technology
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 * 2. Redistributions in binary form must reproduce the above copyright
12 * notice, this list of conditions and the following disclaimer in the
13 * documentation and/or other materials provided with the distribution.
14 * 3. The name Nara Institute of Science and Technology may not be used to
15 * endorse or promote products derived from this software without
16 * specific prior written permission.
17 *
18 * THIS SOFTWARE IS PROVIDED BY Nara Institute of Science and Technology
19 * ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
21 * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE Nara Institute
22 * of Science and Technology BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 *
30 * $Id: lisp.c,v 1.2 2007/03/30 00:40:36 masayu-a Exp $
31 */
32
33 #include "chadic.h"
34 #include "literal.h"
35
36 #define COMMENTCHAR ';'
37 #define COMMENTCHAR2 '#'
38 #define BPARENTHESIS '('
39 #define EPARENTHESIS ')'
40 #define NILSYMBOL "NIL"
41 #define CELLALLOCSTEP 1024
42 #define LISPBUFSIZ 8192
43
44 #define new_cell() (cha_cons(NIL, NIL))
45 #define eq(x, y) (x == y)
46
47 static int c_skip = 0;
48
49 /*
50 * error_in_lisp
51 */
52 static chasen_cell_t *
error_in_lisp(void)53 error_in_lisp(void)
54 {
55 cha_exit_file(1, "premature end of file or string\n");
56 return NIL;
57 }
58
59 void
cha_set_skip_char(int c)60 cha_set_skip_char(int c)
61 {
62 c_skip = c;
63 }
64
65 /*
66 * ifnextchar - if next char is <c> return 1, otherwise return 0
67 */
68 #define ifnextchar(fp, ch) ifnextchar2(fp, ch, 0)
69 static int
ifnextchar2(FILE * fp,int ch1,int ch2)70 ifnextchar2(FILE * fp, int ch1, int ch2)
71 {
72 int c;
73
74 do {
75 c = fgetc(fp);
76 if (c == '\n')
77 Cha_lineno++;
78 } while (c == ' ' || c == '\t' || c == '\n');
79
80 if (c == EOF)
81 return EOF;
82 if (c == ch1 || (ch2 && c == ch2))
83 return TRUE;
84 ungetc(c, fp);
85 return FALSE;
86 }
87
88 /*
89 * skip comment lines
90 */
91 static int
skip_comment(FILE * fp)92 skip_comment(FILE * fp)
93 {
94 int n, c;
95
96 while ((n = ifnextchar2(fp, (int) COMMENTCHAR, c_skip)) == TRUE) {
97 while ((c = fgetc(fp)) != '\n')
98 if (c == EOF)
99 return c;
100 Cha_lineno++;
101 }
102
103 return n;
104 }
105
106 int
cha_s_feof(FILE * fp)107 cha_s_feof(FILE * fp)
108 {
109 int c;
110
111 if (Cha_lineno == 0)
112 Cha_lineno = 1;
113 Cha_lineno_error = Cha_lineno;
114
115 for (;;) {
116 if (skip_comment(fp) == EOF)
117 return TRUE;
118 if ((c = fgetc(fp)) == '\n')
119 Cha_lineno++;
120 else if (c == ' ' || c == '\t');
121 else {
122 ungetc(c, fp);
123 return FALSE;
124 }
125 }
126 }
127
128 /*
129 * malloc_free_cell()
130 *
131 */
132 #define malloc_cell() malloc_free_cell(0)
133 #define free_cell() malloc_free_cell(1)
134 static chasen_cell_t *
malloc_free_cell(int isfree)135 malloc_free_cell(int isfree)
136 {
137 static chasen_cell_t *ptr[1024 * 16];
138 static int ptr_num = 0;
139 static int idx = CELLALLOCSTEP;
140
141 if (isfree) {
142 /*
143 * free
144 */
145 if (ptr_num > 0) {
146 while (ptr_num > 1)
147 free(ptr[--ptr_num]);
148 idx = 0;
149 }
150 return NULL;
151 } else {
152 if (idx == CELLALLOCSTEP) {
153 if (ptr_num == 1024 * 16)
154 cha_exit(1, "Can't allocate memory");
155 ptr[ptr_num++] = cha_malloc(sizeof(chasen_cell_t) * idx);
156 idx = 0;
157 }
158 return ptr[ptr_num - 1] + idx++;
159 }
160 }
161
162 #define CHUNK_SIZE 512
163 #define CHA_MALLOC_SIZE (1024 * 64)
164 #define free_char() malloc_char(-1)
165 static void *
malloc_char(int size)166 malloc_char(int size)
167 {
168 static char *ptr[CHUNK_SIZE];
169 static int ptr_num = 0;
170 static int idx = CHA_MALLOC_SIZE;
171
172 if (size < 0) {
173 /*
174 * free
175 */
176 if (ptr_num > 0) {
177 while (ptr_num > 1)
178 free(ptr[--ptr_num]);
179 idx = 0;
180 }
181 return NULL;
182 } else {
183 if (idx + size >= CHA_MALLOC_SIZE) {
184 if (ptr_num == CHUNK_SIZE)
185 cha_exit(1, "Can't allocate memory");
186 ptr[ptr_num++] = cha_malloc(CHA_MALLOC_SIZE);
187 idx = 0;
188 }
189 idx += size;
190 return ptr[ptr_num - 1] + idx - size;
191 }
192 }
193
194 static char *
lisp_strdup(char * str)195 lisp_strdup(char *str)
196 {
197 char *newstr;
198
199 newstr = malloc_char(strlen(str) + 1);
200 strcpy(newstr, str);
201
202 return newstr;
203 }
204
205 void
cha_s_free(chasen_cell_t * cell)206 cha_s_free(chasen_cell_t * cell)
207 {
208 free_cell();
209 free_char();
210 }
211
212 /*
213 * cha_tmp_atom
214 */
215 chasen_cell_t *
cha_tmp_atom(char * atom)216 cha_tmp_atom(char *atom)
217 {
218 static chasen_cell_t _TmpCell;
219 static chasen_cell_t *TmpCell = &_TmpCell;
220
221 s_tag(TmpCell) = ATOM;
222 s_atom_val(TmpCell) = atom;
223
224 return TmpCell;
225 }
226
227 /*
228 * cha_cons
229 */
230 chasen_cell_t *
cha_cons(void * cha_car,void * cha_cdr)231 cha_cons(void *cha_car, void *cha_cdr)
232 {
233 chasen_cell_t *cell;
234
235 cell = malloc_cell();
236 s_tag(cell) = CONS;
237 car_val(cell) = cha_car;
238 cdr_val(cell) = cha_cdr;
239
240 return cell;
241 }
242
243 /*
244 * cha_car
245 */
246 chasen_cell_t *
cha_car(chasen_cell_t * cell)247 cha_car(chasen_cell_t * cell)
248 {
249 if (consp(cell))
250 return car_val(cell);
251
252 if (nullp(cell))
253 return NIL;
254
255 /*
256 * error
257 */
258 cha_exit_file(1, "%s is not list", cha_s_tostr(cell));
259 Cha_errno = 1;
260 return NIL;
261 }
262
263 /*
264 * cha_cdr
265 */
266 chasen_cell_t *
cha_cdr(chasen_cell_t * cell)267 cha_cdr(chasen_cell_t * cell)
268 {
269 if (consp(cell))
270 return cdr_val(cell);
271
272 if (nullp(cell))
273 return NIL;
274
275 /*
276 * error
277 */
278 cha_exit_file(1, "%s is not list\n", cha_s_tostr(cell));
279 return NIL;
280 }
281
282 char *
cha_s_atom(chasen_cell_t * cell)283 cha_s_atom(chasen_cell_t * cell)
284 {
285 if (atomp(cell))
286 return s_atom_val(cell);
287
288 /*
289 * error
290 */
291 cha_exit_file(1, "%s is not atom\n", cha_s_tostr(cell));
292 return NILSYMBOL;
293 }
294
295 /*
296 * cha_equal
297 */
298 int
cha_equal(void * x,void * y)299 cha_equal(void *x, void *y)
300 {
301 if (eq(x, y))
302 return TRUE;
303 if (nullp(x) || nullp(y))
304 return FALSE;
305 if (s_tag(x) != s_tag(y))
306 return FALSE;
307 if (s_tag(x) == ATOM)
308 return !strcmp(s_atom_val(x), s_atom_val(y));
309 if (s_tag(x) == CONS)
310 return (cha_equal(car_val(x), car_val(y))
311 && cha_equal(cdr_val(x), cdr_val(y)));
312 return FALSE;
313 }
314
315 int
cha_s_length(chasen_cell_t * list)316 cha_s_length(chasen_cell_t * list)
317 {
318 int i;
319
320 for (i = 0; consp(list); i++)
321 list = cdr_val(list);
322
323 return i;
324 }
325
326 static int
dividing_code_p(int code)327 dividing_code_p(int code)
328 {
329 switch (code) {
330 case '\n':
331 case '\t':
332 case ';':
333 case '(':
334 case ')':
335 case ' ':
336 return 1;
337 default:
338 return 0;
339 }
340 }
341
342 static int
myscanf(FILE * fp,char * str)343 myscanf(FILE * fp, char *str)
344 {
345 int code;
346 int in_quote = 0;
347 char *s = str;
348
349 code = fgetc(fp);
350 if (code == '\"' || code == '\'') {
351 in_quote = code;
352 code = fgetc(fp);
353 }
354
355 for (;;) {
356 if (in_quote) {
357 if (code == EOF)
358 return 0;
359 if (code == in_quote)
360 break;
361 } else {
362 if (dividing_code_p(code) || code == EOF) {
363 if (s == str)
364 return 0;
365 ungetc(code, fp);
366 break;
367 }
368 }
369
370 if (code != '\\' || in_quote == '\'') {
371 switch (Cha_encode) { /* XXX */
372 case CHASEN_ENCODE_SJIS:
373 *s++ = code;
374 if (code & 0x80)
375 *s++ = fgetc(fp);
376 break;
377 default:
378 *s++ = code;
379 break;
380 }
381 } else {
382 if ((code = fgetc(fp)) == EOF)
383 return 0;
384 switch (code) {
385 case 't':
386 *s++ = '\t';
387 break;
388 case 'n':
389 *s++ = '\n';
390 break;
391 default:
392 *s++ = code;
393 }
394 }
395
396 code = fgetc(fp);
397 }
398
399 *s = '\0';
400 return 1;
401 }
402
403 /*
404 * cha_s_read - read S-expression
405 */
406 static chasen_cell_t *
s_read_atom(FILE * fp)407 s_read_atom(FILE * fp)
408 {
409 chasen_cell_t *cell;
410 char buffer[LISPBUFSIZ];
411
412 skip_comment(fp);
413
414 /*
415 * changed by kurohashi.
416 */
417 if (myscanf(fp, buffer) == 0)
418 return error_in_lisp();
419
420 if (!strcmp(buffer, NILSYMBOL))
421 return NIL;
422
423 cell = new_cell();
424 s_tag(cell) = ATOM;
425 s_atom_val(cell) = lisp_strdup(buffer);
426
427 return cell;
428 }
429
430 static chasen_cell_t *s_read_cdr(FILE *);
431 static chasen_cell_t *s_read_main(FILE *);
432
433 static chasen_cell_t *
s_read_car(FILE * fp)434 s_read_car(FILE * fp)
435 {
436 chasen_cell_t *cell;
437
438 skip_comment(fp);
439
440 switch (ifnextchar(fp, (int) EPARENTHESIS)) {
441 case TRUE:
442 return NIL;
443 case FALSE:
444 cell = new_cell();
445 car_val(cell) = s_read_main(fp);
446 cdr_val(cell) = s_read_cdr(fp);
447 return cell;
448 default: /* EOF */
449 return error_in_lisp();
450 }
451 }
452
453 static chasen_cell_t *
s_read_cdr(FILE * fp)454 s_read_cdr(FILE * fp)
455 {
456 skip_comment(fp);
457
458 switch (ifnextchar(fp, (int) EPARENTHESIS)) {
459 case TRUE:
460 return NIL;
461 case FALSE:
462 return s_read_car(fp);
463 default: /* EOF */
464 return error_in_lisp();
465 }
466 }
467
468 static chasen_cell_t *
s_read_main(FILE * fp)469 s_read_main(FILE * fp)
470 {
471 /*
472 * skip_comment(fp);
473 */
474 switch (ifnextchar(fp, (int) BPARENTHESIS)) {
475 case TRUE:
476 return s_read_car(fp);
477 case FALSE:
478 return s_read_atom(fp);
479 default: /* EOF */
480 return error_in_lisp();
481 }
482 }
483
484 chasen_cell_t *
cha_s_read(FILE * fp)485 cha_s_read(FILE * fp)
486 {
487 if (Cha_lineno == 0)
488 Cha_lineno = 1;
489 Cha_lineno_error = Cha_lineno;
490
491 return s_read_main(fp);
492 }
493
494 /*
495 * cha_assoc
496 */
497 chasen_cell_t *
cha_assoc(chasen_cell_t * item,chasen_cell_t * alist)498 cha_assoc(chasen_cell_t * item, chasen_cell_t * alist)
499 {
500 while (!nullp(alist) && !cha_equal(item, (cha_car(cha_car(alist)))))
501 alist = cha_cdr(alist);
502 return cha_car(alist);
503 }
504
505 /*
506 * cha_s_print - pretty print S-expression
507 */
508 static char cell_buffer_for_print[8192];
509 static char *s_tostr_main(chasen_cell_t *);
510
511 static void
s_puts_to_buffer(char * str)512 s_puts_to_buffer(char *str)
513 {
514 static int idx = 0;
515 int len;
516
517 /*
518 * initialization
519 */
520 if (str == NULL) {
521 idx = 0;
522 return;
523 }
524
525 len = strlen(str);
526 if (idx + len >= sizeof(cell_buffer_for_print)) {
527 /*
528 * str is too long
529 */
530 idx = sizeof(cell_buffer_for_print);
531 } else {
532 strcpy(cell_buffer_for_print + idx, str);
533 idx += len;
534 }
535 }
536
537 static void
s_tostr_cdr(chasen_cell_t * cell)538 s_tostr_cdr(chasen_cell_t * cell)
539 {
540 if (!nullp(cell)) {
541 if (consp(cell)) {
542 s_puts_to_buffer(" ");
543 s_tostr_main(car_val(cell));
544 s_tostr_cdr(cdr_val(cell));
545 } else {
546 s_puts_to_buffer(" ");
547 s_tostr_main(cell);
548 }
549 }
550 }
551
552 static char *
s_tostr_main(chasen_cell_t * cell)553 s_tostr_main(chasen_cell_t * cell)
554 {
555 if (nullp(cell))
556 s_puts_to_buffer(NILSYMBOL);
557 else {
558 switch (s_tag(cell)) {
559 case CONS:
560 s_puts_to_buffer("(");
561 s_tostr_main(car_val(cell));
562 s_tostr_cdr(cdr_val(cell));
563 s_puts_to_buffer(")");
564 break;
565 case ATOM:
566 s_puts_to_buffer(s_atom_val(cell));
567 break;
568 default:
569 s_puts_to_buffer("INVALID_CELL");
570 }
571 }
572
573 return cell_buffer_for_print;
574 }
575
576 char *
cha_s_tostr(chasen_cell_t * cell)577 cha_s_tostr(chasen_cell_t * cell)
578 {
579 /*
580 * initialization
581 */
582 s_puts_to_buffer(NULL);
583
584 return s_tostr_main(cell);
585 }
586
587 chasen_cell_t *
cha_s_print(FILE * fp,chasen_cell_t * cell)588 cha_s_print(FILE * fp, chasen_cell_t * cell)
589 {
590 fputs(cha_s_tostr(cell), fp);
591 return cell;
592 }
593