src/sexp.c
/* [<][>][^][v][top][bottom][index][help] */
FUNCTIONS
This source file includes following functions.
- vf_sexp_cons
- vf_sexp_car
- vf_sexp_cdr
- vf_sexp_caar
- vf_sexp_cadr
- vf_sexp_cdar
- vf_sexp_cddr
- vf_sexp_caddr
- vf_sexp_rplaca
- vf_sexp_rplacd
- vf_sexp_atom
- vf_sexp_null
- vf_sexp_consp
- vf_sexp_stringp
- vf_sexp_get_cstring
- vf_sexp_listp
- vf_sexp_alistp
- vf_sexp_member
- vf_sexp_alist_put
- vf_sexp_assoc
- vf_sexp_length
- vf_sexp_list1
- vf_sexp_list2
- vf_sexp_copy
- vf_sexp_nconc
- vf_sexp_empty_list
- vf_sexp_pp
- vf_sexp_pp_fp
- vf_sexp_pp_entry
- vf_sexp_pp_entry_fp
- vf_sexp_pp2
- SEXP_STREAM_GETC
- SEXP_STREAM_UNGETC
- vf_sexp_read_from_string_stream
- string_stream_get_char
- string_stream_unget_char
- vf_sexp_read_from_file_stream
- vf_sexp_read
- file_stream_get_char
- file_stream_unget_char
- vf_sexp_read_from_stream
- vf_sexp_do_read_from_stream
- vf_sexp_read_str
- vf_sexp_skip
- vf_sexp_cstring2string
- vf_sexp_cstring2list
- vf_sexp_cstring2alist
- vf_get_char_esc
- vf_sexp_alloc
- vf_sexp_free4
- vf_sexp_free3
- vf_sexp_free2
- vf_sexp_free1
- vf_sexp_free
- vf_sexp_obj_validate2
- vf_sexp_obj_validate
- main
1 /* vfsexp.c - a module for handling s-expressions
2 *
3 * Programmmed by Hirotsugu Kakugawa
4 * E-Mail: h.kakugawa@computer.org
5 *
6 * Edition History
7 * 7 Jan 1998 First implementation
8 * 2 May 1998 Fix a bug to fail reading a string ""
9 * 24 Jun 1998 Added a function to read an s-exp from string stream.
10 */
11
12 /*
13 * Copyright (C) 1997-1998 Hirotsugu Kakugawa.
14 * All rights reserved.
15 *
16 * This file is part of the VFlib Library. This library is free
17 * software; you can redistribute it and/or modify it under the terms of
18 * the GNU Library General Public License as published by the Free
19 * Software Foundation; either version 2 of the License, or (at your
20 * option) any later version. This library is distributed in the hope
21 * that it will be useful, but WITHOUT ANY WARRANTY; without even the
22 * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
23 * PURPOSE. See the GNU Library General Public License for more details.
24 * You should have received a copy of the GNU Library General Public
25 * License along with this library; if not, write to the Free Software
26 * Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
27 */
28
29 #include <stdio.h>
30 #include <stdlib.h>
31 #ifdef HAVE_UNISTD_H
32 # include <unistd.h>
33 #endif
34 #if defined(HAVE_STRING_H) || defined(STDC_HEADERS)
35 # include <string.h>
36 #else
37 # include <strings.h>
38 #endif
39 #include <ctype.h>
40
41 #include "sexp.h"
42 #include "mem.h"
43
44 #define TRUE (1==1)
45 #define FALSE (1==0)
46
47 static SEXP vf_sexp_alloc(int tag);
48 static void vf_sexp_obj_validate(SEXP s1);
49 static void vf_sexp_obj_validate2(SEXP s1, SEXP s2);
50
51
52
53 /*
54 * Basic Functions
55 */
56
57 SEXP
58 vf_sexp_cons(SEXP car, SEXP cdr)
/* [<][>][^][v][top][bottom][index][help] */
59 {
60 SEXP cell;
61
62 vf_sexp_obj_validate2(car, cdr);
63
64 cell = vf_sexp_alloc(VF_SEXP_TAG_CONS);
65 if (cell == NULL)
66 return NULL;
67
68 cell->t.cons.car = car;
69 cell->t.cons.cdr = cdr;
70
71 return cell;
72 }
73
74 SEXP
75 vf_sexp_car(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
76 {
77 vf_sexp_obj_validate(s);
78 if (s->tag != VF_SEXP_TAG_CONS){
79 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_car()]: %s\n",
80 "arg type error");
81 abort();
82 }
83
84 return s->t.cons.car;
85 }
86
87 SEXP
88 vf_sexp_cdr(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
89 {
90 vf_sexp_obj_validate(s);
91 if (s->tag != VF_SEXP_TAG_CONS){
92 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_cdr()]: %s\n",
93 "arg type error");
94 abort();
95 }
96
97 return s->t.cons.cdr;
98 }
99
100 SEXP
101 vf_sexp_caar(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
102 {
103 vf_sexp_obj_validate(s);
104 if ((s->tag != VF_SEXP_TAG_CONS)
105 || ((s->t.cons.car)->tag != VF_SEXP_TAG_CONS)){
106 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_caar()]: %s\n",
107 "arg type error");
108 abort();
109 }
110 vf_sexp_obj_validate(s->t.cons.car);
111
112 return (s->t.cons.car)->t.cons.car;
113 }
114
115 SEXP
116 vf_sexp_cadr(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
117 {
118 vf_sexp_obj_validate(s);
119 if ((s->tag != VF_SEXP_TAG_CONS)
120 || ((s->t.cons.cdr)->tag != VF_SEXP_TAG_CONS)){
121 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_cadr()]: %s\n",
122 "arg type error");
123 abort();
124 }
125 vf_sexp_obj_validate(s->t.cons.cdr);
126
127 return (s->t.cons.cdr)->t.cons.car;
128 }
129
130 SEXP
131 vf_sexp_cdar(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
132 {
133 vf_sexp_obj_validate(s);
134 if ((s->tag != VF_SEXP_TAG_CONS)
135 || ((s->t.cons.car)->tag != VF_SEXP_TAG_CONS)){
136 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_cdar()]: %s\n",
137 "arg type error");
138 abort();
139 }
140 vf_sexp_obj_validate(s->t.cons.car);
141
142 return (s->t.cons.car)->t.cons.cdr;
143 }
144
145 SEXP
146 vf_sexp_cddr(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
147 {
148 vf_sexp_obj_validate(s);
149 if ((s->tag != VF_SEXP_TAG_CONS)
150 || ((s->t.cons.cdr)->tag != VF_SEXP_TAG_CONS)){
151 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_cddr()]: %s\n",
152 "arg type error");
153 abort();
154 }
155 vf_sexp_obj_validate(s->t.cons.cdr);
156
157 return (s->t.cons.cdr)->t.cons.cdr;
158 }
159
160 SEXP
161 vf_sexp_caddr(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
162 {
163 vf_sexp_obj_validate(s);
164 if ((s->tag != VF_SEXP_TAG_CONS)
165 || ((s->t.cons.cdr)->tag != VF_SEXP_TAG_CONS)
166 || (((s->t.cons.cdr)->t.cons.cdr)->tag != VF_SEXP_TAG_CONS)){
167 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_caddr()]: %s\n",
168 "arg type error");
169 abort();
170 }
171 vf_sexp_obj_validate(s->t.cons.cdr);
172 vf_sexp_obj_validate((s->t.cons.cdr)->t.cons.cdr);
173
174 return ((s->t.cons.cdr)->t.cons.cdr)->t.cons.car;
175 }
176
177 void
178 vf_sexp_rplaca(SEXP s, SEXP val)
/* [<][>][^][v][top][bottom][index][help] */
179 {
180 vf_sexp_obj_validate2(s, val);
181 if (s->tag != VF_SEXP_TAG_CONS){
182 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_rplaca()]: %s\n",
183 "arg type error");
184 abort();
185 }
186
187 s->t.cons.car = val;
188 }
189
190 void
191 vf_sexp_rplacd(SEXP s, SEXP val)
/* [<][>][^][v][top][bottom][index][help] */
192 {
193 vf_sexp_obj_validate2(s, val);
194 if (s->tag != VF_SEXP_TAG_CONS){
195 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_rplacd()]: %s\n",
196 "arg type error");
197 abort();
198 }
199
200 s->t.cons.cdr = val;
201 }
202
203 int
204 vf_sexp_atom(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
205 {
206 if (s == NULL)
207 return FALSE;
208 vf_sexp_obj_validate(s);
209
210 return (s->tag != VF_SEXP_TAG_CONS);
211 }
212
213 int
214 vf_sexp_null(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
215 {
216 if (s == NULL)
217 return FALSE;
218 vf_sexp_obj_validate(s);
219
220 return (s->tag == VF_SEXP_TAG_NIL);
221 }
222
223 int
224 vf_sexp_consp(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
225 {
226 if (s == NULL)
227 return FALSE;
228 vf_sexp_obj_validate(s);
229
230 return (s->tag == VF_SEXP_TAG_CONS);
231 }
232
233 int
234 vf_sexp_stringp(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
235 {
236 if (s == NULL)
237 return FALSE;
238
239 vf_sexp_obj_validate(s);
240 return (((s->tag == VF_SEXP_TAG_STRING) || (s->tag == VF_SEXP_TAG_SYMBOL))
241 && (s->t.str != NULL));
242 }
243
244 char*
245 vf_sexp_get_cstring(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
246 {
247 vf_sexp_obj_validate(s);
248 if (!vf_sexp_stringp(s)){
249 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_get_cstring()]: %s\n",
250 "arg type error");
251 abort();
252 }
253
254 return s->t.str;
255 }
256
257 int
258 vf_sexp_listp(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
259 {
260 if (s == NULL)
261 return FALSE;
262 vf_sexp_obj_validate(s);
263
264 if (vf_sexp_null(s))
265 return TRUE;
266
267 return (s->tag == VF_SEXP_TAG_CONS);
268 /* Since our s-exp reader does not support 'dot-notation',
269 all cons data forms a list. */
270 }
271
272 int
273 vf_sexp_alistp(SEXP_ALIST s)
/* [<][>][^][v][top][bottom][index][help] */
274 {
275 SEXP t;
276
277 if (vf_sexp_null(s))
278 return TRUE;
279 if (!vf_sexp_listp(s))
280 return FALSE;
281
282 for (t = s; t->tag == VF_SEXP_TAG_CONS; t = t->t.cons.cdr){
283 if (!vf_sexp_listp(t->t.cons.car))
284 return FALSE;
285 }
286 return (t->tag == VF_SEXP_TAG_NIL);
287 }
288
289 int
290 vf_sexp_member(char* key, SEXP_LIST s)
/* [<][>][^][v][top][bottom][index][help] */
291 {
292 SEXP t;
293
294 /* vf_sexp_member[(a b c ...), x] => True/False */
295
296 if (!vf_sexp_listp(s))
297 return FALSE;
298 for (t = s; t->tag == VF_SEXP_TAG_CONS; t = t->t.cons.cdr){
299 if (((t->tag == VF_SEXP_TAG_STRING) || (t->tag == VF_SEXP_TAG_SYMBOL))
300 && (t->t.str != NULL) && (strcmp(key, t->t.str) == 0))
301 return TRUE;
302 }
303 return FALSE;
304 }
305
306 SEXP
307 vf_sexp_alist_put(char *key, char *val, SEXP_ALIST alist)
/* [<][>][^][v][top][bottom][index][help] */
308 {
309 SEXP sk, sv, t, v;
310
311 if (!vf_sexp_alistp(alist))
312 return NULL;
313 if (key == NULL)
314 key = "";
315 if (val == NULL)
316 val = "";
317
318 sk = vf_sexp_cstring2string(key);
319 sv = vf_sexp_cstring2string(val);
320 t = vf_sexp_list2(sk, sv);
321 v = vf_sexp_cons(t, alist);
322
323 return v;
324 }
325
326 SEXP
327 vf_sexp_assoc(char* key, SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
328 {
329 SEXP t, pair;
330
331 /* vf_sexp_assoc[((p1 v1 ...) (p2 v2 ...) ...), pi] => (pi vi ...) */
332
333 if ((key == NULL) || (s == NULL))
334 return NULL;
335 if (!vf_sexp_alistp(s))
336 return NULL;
337
338 for (t = s; (t != NULL) && (t->tag == VF_SEXP_TAG_CONS); t = t->t.cons.cdr){
339 if (t->t.cons.car == NULL)
340 continue;
341 pair = t->t.cons.car;
342 if (vf_sexp_stringp(vf_sexp_car(pair))
343 && (strcmp(key, vf_sexp_get_cstring(vf_sexp_car(pair))) == 0))
344 return pair;
345 }
346
347 return NULL;
348 }
349
350 int
351 vf_sexp_length(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
352 {
353 int len;
354 SEXP t;
355
356 if (!vf_sexp_listp(s))
357 return 0;
358 len = 0;
359 for (t = s; t->tag == VF_SEXP_TAG_CONS; t = t->t.cons.cdr)
360 len++;
361 return len;
362 }
363
364 SEXP
365 vf_sexp_list1(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
366 {
367 return vf_sexp_cons(s, vf_sexp_empty_list());
368 }
369
370 SEXP
371 vf_sexp_list2(SEXP s1, SEXP s2)
/* [<][>][^][v][top][bottom][index][help] */
372 {
373 return vf_sexp_cons(s1, vf_sexp_cons(s2, vf_sexp_empty_list()));
374 }
375
376 SEXP
377 vf_sexp_copy(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
378 {
379 SEXP cp, car, cdr;
380
381 if (s == NULL)
382 return NULL;
383 vf_sexp_obj_validate(s);
384
385 cp = vf_sexp_alloc(s->tag);
386 if (cp == NULL)
387 return NULL;
388
389 switch (s->tag){
390 default:
391 return NULL;
392 case VF_SEXP_TAG_NIL:
393 break;
394 case VF_SEXP_TAG_CONS:
395 car = vf_sexp_copy(s->t.cons.car);
396 cdr = vf_sexp_copy(s->t.cons.cdr);
397 if ((car == NULL) || (cdr == NULL)){
398 if (car != NULL)
399 vf_sexp_free(&car);
400 if (cdr != NULL)
401 vf_sexp_free(&cdr);
402 return NULL;
403 }
404 cp->t.cons.car = car;
405 cp->t.cons.cdr = cdr;
406 break;
407 case VF_SEXP_TAG_STRING:
408 case VF_SEXP_TAG_SYMBOL:
409 if (s->t.str == NULL)
410 goto Error;
411 if ((cp->t.str = (char*)malloc(strlen(s->t.str)+1)) == NULL)
412 goto Error;
413 strcpy(cp->t.str, s->t.str);
414 break;
415 }
416 return cp;
417
418 Error:
419 vf_sexp_free(&cp);
420 return NULL;
421 }
422
423 void
424 vf_sexp_nconc(SEXP s1, SEXP s2)
/* [<][>][^][v][top][bottom][index][help] */
425 {
426 SEXP t, tt;
427
428 if (s2 == NULL)
429 return;
430 if (s1 == NULL)
431 return;
432
433 if (!vf_sexp_listp(s1) && !vf_sexp_listp(s2)){
434 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_nconc()]: %s\n",
435 "args type");
436 return;
437 }
438
439 if (vf_sexp_null(s2))
440 return;
441
442 t = s1;
443 while (vf_sexp_consp(vf_sexp_cdr(t)))
444 t = vf_sexp_cdr(t);
445 tt = vf_sexp_cdr(t);
446 vf_sexp_free(&tt);
447 vf_sexp_rplacd(t, s2);
448 }
449
450 SEXP
451 vf_sexp_empty_list(void)
/* [<][>][^][v][top][bottom][index][help] */
452 {
453 return vf_sexp_alloc(VF_SEXP_TAG_NIL);
454 }
455
456
457
458 /*
459 * Pretty Print
460 */
461 static void vf_sexp_pp2(FILE *fp, SEXP s, int depth, int need_indent,
462 int vflibcap_entry_flag);
463
464 void
465 vf_sexp_pp(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
466 {
467 vf_sexp_pp2(stdout, s, 0, 1, 0);
468 fprintf(stdout, "\n");
469 }
470
471 void
472 vf_sexp_pp_fp(SEXP s, FILE *fp)
/* [<][>][^][v][top][bottom][index][help] */
473 {
474 vf_sexp_pp2(fp, s, 0, 1, 0);
475 fprintf(fp, "\n");
476 }
477
478 void
479 vf_sexp_pp_entry(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
480 {
481 vf_sexp_pp2(stdout, s, 0, 1, 1);
482 fprintf(stdout, "\n");
483 }
484
485 void
486 vf_sexp_pp_entry_fp(SEXP s, FILE *fp)
/* [<][>][^][v][top][bottom][index][help] */
487 {
488 vf_sexp_pp2(fp, s, 0, 1, 1);
489 fprintf(fp, "\n");
490 }
491
492
493 static void
494 vf_sexp_pp2(FILE *fp, SEXP s, int depth, int need_indent,
/* [<][>][^][v][top][bottom][index][help] */
495 int vflibcap_entry_flag)
496 {
497 SEXP t, u;
498 char *p;
499 int i;
500
501 vf_sexp_obj_validate(s);
502 if ((need_indent == 1) && (depth > 0)){
503 fprintf(fp, "\n");
504 for (i = 0; i < depth; i++)
505 fprintf(fp, " ");
506 }
507
508 switch (s->tag){
509 default:
510 fprintf(stderr, "VFlib: Unknown sexp object %p", s);
511 abort();
512 case VF_SEXP_TAG_NIL:
513 fprintf(fp, "()");
514 break;
515 case VF_SEXP_TAG_STRING:
516 case VF_SEXP_TAG_SYMBOL:
517 if (s->tag == VF_SEXP_TAG_STRING)
518 fprintf(fp, "\"");
519 for (p = s->t.str; *p != '\0'; p++){
520 if (*p == '"'){
521 fprintf(fp, "\\\"");
522 } else if (!iscntrl((int)(*p))){
523 fprintf(fp, "%c", *p);
524 } else {
525 switch (*p){
526 case '\a': fprintf(fp, "\\a"); break;
527 case '\b': fprintf(fp, "\\b"); break;
528 case '\f': fprintf(fp, "\\f"); break;
529 case '\n': fprintf(fp, "\\n"); break;
530 case '\r': fprintf(fp, "\\r"); break;
531 case '\t': fprintf(fp, "\\t"); break;
532 case '\v': fprintf(fp, "\\v"); break;
533 default: fprintf(fp, "\\x%02x", *p);
534 }
535 }
536 }
537 if (s->tag == VF_SEXP_TAG_STRING)
538 fprintf(fp, "\"");
539 break;
540 case VF_SEXP_TAG_CONS:
541 #if 1
542 fprintf(fp, "(");
543 if ((depth == 0) && (vf_sexp_length(s) > 2)
544 && (vflibcap_entry_flag == 1)
545 && (vf_sexp_stringp(vf_sexp_car(s)))
546 && (vf_sexp_stringp(vf_sexp_car(vf_sexp_cdr(s)))) ){
547 vf_sexp_pp2(fp, vf_sexp_car(s), depth+1, 0, vflibcap_entry_flag);
548 fprintf(fp, " ");
549 vf_sexp_pp2(fp, vf_sexp_car(vf_sexp_cdr(s)), depth+1, 0,
550 vflibcap_entry_flag);
551 for (t = vf_sexp_cdr(vf_sexp_cdr(s));
552 vf_sexp_consp(t);
553 t = vf_sexp_cdr(t)){
554 if (vf_sexp_stringp(vf_sexp_car(t))){
555 vf_sexp_pp2(fp, vf_sexp_car(t), depth+1, 1, 0);
556 } else {
557 fprintf(fp, "\n (%s", vf_sexp_get_cstring(vf_sexp_caar(t)));
558 for (u = vf_sexp_cdar(t); vf_sexp_consp(u); u = vf_sexp_cdr(u)){
559 vf_sexp_pp2(fp, vf_sexp_car(u), depth+2, 1, 0);
560 }
561 fprintf(fp, ")");
562 }
563 }
564 } else {
565 vf_sexp_pp2(fp, vf_sexp_car(s), depth+1, 0, vflibcap_entry_flag);
566 for (t = vf_sexp_cdr(s); vf_sexp_consp(t); t = vf_sexp_cdr(t)){
567 fprintf(fp, " ");
568 vf_sexp_pp2(fp, vf_sexp_car(t), depth+1, 0, vflibcap_entry_flag);
569 }
570 }
571 fprintf(fp, ")");
572 #else
573 fprintf(fp, "(");
574 vf_sexp_pp2(fp, vf_sexp_car(s), depth+1, vflibcap_entry_flag);
575 for (t = vf_sexp_cdr(s); vf_sexp_consp(t); t = vf_sexp_cdr(t)){
576 fprintf(fp, " ");
577 vf_sexp_pp2(fp, vf_sexp_car(t), depth+1, 0, vflibcap_entry_flag);
578 }
579 fprintf(fp, ")");
580 #endif
581 break;
582 }
583 }
584
585
586 /*
587 * S-Expression Reader
588 */
589
590 typedef struct s_sexp_stream *SEXP_STREAM;
591 struct s_sexp_stream {
592 int ungetc_buff;
593 void *obj;
594 void *data1;
595 void *data2;
596 int (*get_char)(SEXP_STREAM stream);
597 void (*unget_char)(SEXP_STREAM stream, int ch);
598 };
599 #define SEXP_STREAM_GETC(stream) (stream->get_char)(stream)
/* [<][>][^][v][top][bottom][index][help] */
600 #define SEXP_STREAM_UNGETC(stream,ch) (stream->unget_char)(stream,ch)
/* [<][>][^][v][top][bottom][index][help] */
601
602 static SEXP vf_sexp_read_from_stream(SEXP_STREAM);
603
604
605 static int string_stream_get_char(SEXP_STREAM);
606 static void string_stream_unget_char(SEXP_STREAM,int);
607
608 SEXP
609 vf_sexp_read_from_string_stream(char *str)
/* [<][>][^][v][top][bottom][index][help] */
610 {
611 struct s_sexp_stream stream_obj;
612
613 stream_obj.ungetc_buff = -1;
614 stream_obj.obj = str;
615 stream_obj.data1 = str;
616 stream_obj.get_char = string_stream_get_char;
617 stream_obj.unget_char = string_stream_unget_char;
618 return vf_sexp_read_from_stream(&stream_obj);
619 }
620
621 static int
622 string_stream_get_char(SEXP_STREAM stream)
/* [<][>][^][v][top][bottom][index][help] */
623 {
624 int ch;
625 char *p;
626
627 if (stream->ungetc_buff >= 0){
628 ch = stream->ungetc_buff;
629 stream->ungetc_buff = -1;
630 return ch;
631 }
632
633 stream->ungetc_buff = -1;
634 p = stream->data1;
635 if ((ch = *p) == '\0')
636 return EOF;
637 p++;
638 stream->data1 = p;
639 return ch;
640 }
641
642 static void
643 string_stream_unget_char(SEXP_STREAM stream, int ch)
/* [<][>][^][v][top][bottom][index][help] */
644 {
645 stream->ungetc_buff = ch;
646 }
647
648
649 static int file_stream_get_char(SEXP_STREAM);
650 static void file_stream_unget_char(SEXP_STREAM,int);
651
652 SEXP
653 vf_sexp_read_from_file_stream(FILE *fp)
/* [<][>][^][v][top][bottom][index][help] */
654 {
655 struct s_sexp_stream stream_obj;
656
657 stream_obj.ungetc_buff = -1;
658 stream_obj.obj = fp;
659 stream_obj.get_char = file_stream_get_char;
660 stream_obj.unget_char = file_stream_unget_char;
661 return vf_sexp_read_from_stream(&stream_obj);
662 }
663
664 SEXP
665 vf_sexp_read(FILE *fp)
/* [<][>][^][v][top][bottom][index][help] */
666 {
667 return vf_sexp_read_from_file_stream(fp);
668 }
669
670 static int
671 file_stream_get_char(SEXP_STREAM stream)
/* [<][>][^][v][top][bottom][index][help] */
672 {
673 int ch;
674 FILE *fp;
675
676 if (stream->ungetc_buff >= 0){
677 ch = stream->ungetc_buff;
678 stream->ungetc_buff = -1;
679 return ch;
680 }
681
682 stream->ungetc_buff = -1;
683 fp = stream->obj;
684 return getc(fp);
685 }
686
687 static void
688 file_stream_unget_char(SEXP_STREAM stream, int ch)
/* [<][>][^][v][top][bottom][index][help] */
689 {
690 stream->ungetc_buff = ch;
691 }
692
693
694
695 static int vf_sexp_do_read_from_stream(SEXP_STREAM stream, SEXP sexp);
696 static int vf_sexp_read_str(SEXP_STREAM stream, char ch, SEXP sexp);
697 static int vf_sexp_skip(SEXP_STREAM stream);
698 static char vf_get_char_esc(char **pp, SEXP_STREAM stream);
699 #define NBUFFER_MIN 2*1024
700 #define NBUFFER_MED 4*1024
701 #define NBUFFER_MAX 16*1024
702
703 static SEXP
704 vf_sexp_read_from_stream(SEXP_STREAM stream)
/* [<][>][^][v][top][bottom][index][help] */
705 {
706 SEXP s;
707
708 if ((s = vf_sexp_alloc(VF_SEXP_TAG_NIL)) == NULL)
709 return NULL;
710 if (vf_sexp_do_read_from_stream(stream, s) < 0){
711 vf_sexp_free(&s);
712 return NULL;
713 }
714 return s;
715 }
716
717 static int
718 vf_sexp_do_read_from_stream(SEXP_STREAM stream, SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
719 {
720 int ch;
721
722 ch = vf_sexp_skip(stream);
723 if (ch < 0)
724 return -1;
725
726 if (ch == '('){ /* cons or nil */
727 s->tag = VF_SEXP_TAG_NIL;
728 for (;;){
729 ch = vf_sexp_skip(stream);
730 if (ch < 0)
731 return -1;
732 if (ch == ')') /* nil */
733 break;
734 SEXP_STREAM_UNGETC(stream, ch); /* cons */
735
736 s->tag = VF_SEXP_TAG_CONS;
737 s->t.cons.car = NULL;
738 s->t.cons.cdr = NULL;
739 if ((s->t.cons.car = vf_sexp_alloc(VF_SEXP_TAG_NIL)) == NULL)
740 return -1;
741 if ((s->t.cons.cdr = vf_sexp_alloc(VF_SEXP_TAG_NIL)) == NULL)
742 return -1;
743 if (vf_sexp_do_read_from_stream(stream, s->t.cons.car) < 0){
744 fprintf(stderr, "VFlib: Broken vflibcap file - unexpected EOF\n");
745 return -1;
746 }
747 s = s->t.cons.cdr;
748 ch = vf_sexp_skip(stream);
749 if (ch < 0){
750 fprintf(stderr, "VFlib: Broken vflibcap file - unexpected EOF\n");
751 return -1;
752 }
753 if (ch == ')')
754 break;
755 SEXP_STREAM_UNGETC(stream, ch);
756 }
757 return 0;
758 } else if (ch == ')'){ /* broken s-exp */
759 fprintf(stderr, "VFlib: Broken vflibcap file - unexpected ')'\n");
760 return -1;
761 } else if (ch == '"'){ /* string */
762 s->tag = VF_SEXP_TAG_STRING;
763 return vf_sexp_read_str(stream, ch, s);
764 } else { /* symbol */
765 s->tag = VF_SEXP_TAG_SYMBOL;
766 return vf_sexp_read_str(stream, ch, s);
767 }
768
769 fprintf(stderr, "VFlib Error [sexp.c:vf_sexp_read2()]: %s\n",
770 "Cannot Happen");
771 abort();
772 return -1;
773 }
774
775 static int
776 vf_sexp_read_str(SEXP_STREAM stream, char ch, SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
777 {
778 char tmp[8];
779 int ch1, dq_str;
780 int bindex, n, i;
781 static char *buff = NULL;
782 static int nbuff = 0;
783
784 bindex = 0;
785 s->t.str = NULL;
786
787 /* alloc read buffer if not exist */
788 if (buff == NULL){
789 nbuff = NBUFFER_MIN;
790 if ((buff = (char*)malloc(nbuff)) == NULL){
791 nbuff = 0;
792 return -1;
793 }
794 }
795
796 /* enclosed by double quote? */
797 dq_str = 0;
798 if (ch == '"'){
799 dq_str = 1;
800 if ((ch = SEXP_STREAM_GETC(stream)) < 0){
801 fprintf(stderr, "VFlib: Broken vflibcap file - unexpected EOF\n");
802 return -1;
803 }
804 if (ch == '"')
805 goto STR_END;
806 }
807
808
809 for (;;){
810
811 /* realloc read buffer if strng is larger than buffer size */
812 if (bindex >= nbuff-1){
813 if ((nbuff = nbuff + NBUFFER_MIN) > NBUFFER_MAX){
814 fprintf(stderr, "VFlib: vflibcap too large. Fogotten parentheses?\n");
815 exit(1);
816 }
817 if ((buff = realloc(buff, nbuff)) == NULL)
818 nbuff = 0;
819 }
820
821 if (ch == '\\'){ /* escape syntax */
822 ch1 = SEXP_STREAM_GETC(stream);
823 if (isdigit((int)ch1)){ /* '\123' - octal (3 digits) */
824 tmp[0] = SEXP_STREAM_GETC(stream);
825 tmp[1] = SEXP_STREAM_GETC(stream);
826 tmp[2] = SEXP_STREAM_GETC(stream);
827 tmp[3] = '\0';
828 sscanf(tmp, "%o", &n);
829 ch = n;
830 } else if (ch1 == 'x'){ /* '\x12' - hex (2 digits) */
831 tmp[0] = SEXP_STREAM_GETC(stream);
832 tmp[1] = SEXP_STREAM_GETC(stream);
833 tmp[2] = '\0';
834 sscanf(tmp, "%x", &n);
835 ch = n;
836 } else { /* '\n', '\t', '\:' etc. */
837 switch (ch1){
838 case 'a': ch = '\a'; break;
839 case 'b': ch = '\b'; break;
840 case 'f': ch = '\f'; break;
841 case 'n': ch = '\n'; break;
842 case 'r': ch = '\r'; break;
843 case 't': ch = '\t'; break;
844 case 'v': ch = '\v'; break;
845 default: ch = ch1; break;
846 }
847 }
848 }
849
850 /* put a char into read buffer */
851 buff[bindex++] = ch;
852
853 /* get next char */
854 ch = SEXP_STREAM_GETC(stream);
855 if ((dq_str == 0) && (ch < 0)){
856 break;
857 } else if ((dq_str == 1) && (ch < 0)){
858 fprintf(stderr, "VFlib: Broken vflibcap file - unexpected EOF: \"");
859 for (i = 0; i < bindex; i++){
860 if ((buff[i] == '\0') || (buff[i] == '\n') || (buff[i] == '\f'))
861 break;
862 fprintf(stderr, "%c", buff[i]);
863 }
864 fprintf(stderr, "...\n");
865 return -1;
866 }
867
868 if ((dq_str == 1) && (ch == '"')){
869 break;
870 } else if (dq_str == 0){
871 if (isspace((int)ch))
872 break;
873 if ((ch == '(') || (ch == ')') || (ch == ';')){
874 SEXP_STREAM_UNGETC(stream, ch);
875 break;
876 }
877 }
878
879 }
880
881 STR_END:
882 buff[bindex++] = '\0';
883
884 /* copy into sexp */
885 if ((s->t.str = malloc(bindex)) == NULL)
886 return -1;
887 memcpy(s->t.str, buff, bindex);
888
889 if (nbuff > NBUFFER_MED){ /* read buffer became large. release it. */
890 nbuff = NBUFFER_MED;
891 if ((buff = realloc(buff, nbuff)) == NULL)
892 nbuff = 0;
893 }
894
895 return 0;
896 }
897
898
899 static int
900 vf_sexp_skip(SEXP_STREAM stream)
/* [<][>][^][v][top][bottom][index][help] */
901 {
902 int ch;
903
904 for (;;){
905 /* read a char from stream */
906 if ((ch = SEXP_STREAM_GETC(stream)) < 0)
907 return -1; /* eof */
908 /* skip white space */
909 if (isspace((int)ch))
910 continue;
911 if (ch != ';')
912 break;
913 /* skip comment */
914 if (ch == ';'){
915 for (;;){ /* skip until the end of line */
916 if ((ch = SEXP_STREAM_GETC(stream)) < 0)
917 return -1;
918 if (ch == '\n')
919 break;
920 }
921 continue;
922 }
923 }
924
925 return ch;
926 }
927
928
929 /*
930 * Parse C String to String/List/AList
931 */
932
933 SEXP
934 vf_sexp_cstring2string(char *str)
/* [<][>][^][v][top][bottom][index][help] */
935 {
936 SEXP s;
937
938 if ((s = vf_sexp_alloc(VF_SEXP_TAG_STRING)) == NULL)
939 return NULL;
940 if (str == NULL)
941 str = "";
942 if ((s->t.str = (char*)malloc(strlen(str)+1)) == NULL){
943 vf_sexp_free(&s);
944 return NULL;
945 }
946 strcpy(s->t.str, str);
947
948 return s;
949 }
950
951 SEXP
952 vf_sexp_cstring2list(char *cstr)
/* [<][>][^][v][top][bottom][index][help] */
953 /* C-str "xxx, yyy, zzz, ..." ==> SEXP ("xxx" "yyy" "zzz" ...) */
954 {
955 SEXP head, tail, last, cell, str, val;
956 char c, *start, *p, *q;
957 int len, i;
958
959 head = vf_sexp_alloc(VF_SEXP_TAG_CONS);
960 tail = vf_sexp_alloc(VF_SEXP_TAG_NIL);
961 vf_sexp_rplacd(head, tail);
962
963 if (cstr == NULL)
964 goto End;
965
966 p = cstr;
967 last = head;
968 for (;;){
969 /* skip spaces */
970 for (c = *p;
971 (!isprint((int)c)||isspace((int)c)) && (c != '\0') ;
972 p++, c = *p)
973 ;
974 if (c == '\0')
975 break;
976
977 /* an element starts */
978 start = p;
979 len = 0;
980
981 /* go to end of an element */
982 for (c = *p;
983 (isprint((int)c)&&!isspace((int)c)) && (c != ',') && (c != '\0');
984 len++, p++, c = *p){
985 (void) vf_get_char_esc(&p, NULL);
986 }
987
988 /* copy string */
989 str = vf_sexp_alloc(VF_SEXP_TAG_STRING);
990 str->t.str = (char*)malloc(len+1);
991 for (i = 0, q = start; i < len; i++){
992 str->t.str[i] = vf_get_char_esc(&q, NULL);
993 q++;
994 }
995 str->t.str[len] = '\0';
996 cell = vf_sexp_cons(str, last);
997 vf_sexp_rplacd(last, cell);
998 vf_sexp_rplacd(cell, tail);
999 last = cell;
1000
1001 if (c == '\0')
1002 break;
1003
1004 /* skip spaces */
1005 for (c = *p;
1006 (!isprint((int)c)||isspace((int)c)) && (c != ',') && (c != '\0');
1007 p++, c = *p)
1008 ;
1009 if (c == '\0')
1010 break;
1011
1012 if (c == ',')
1013 p++;
1014 }
1015
1016 End:
1017 val = vf_sexp_cdr(head);
1018 head->t.cons.cdr = NULL;
1019 vf_sexp_free(&head);
1020
1021 return val;
1022 }
1023
1024 SEXP
1025 vf_sexp_cstring2alist(char *cstr)
/* [<][>][^][v][top][bottom][index][help] */
1026 /* C-str "x1=y1, x2=y2, ..." ==> SEXP (("x1" "y1") ("x2" "y2") ...) */
1027 {
1028 SEXP head, tail, last, cell_list1, cell_list2, cell, nil;
1029 SEXP str_key, str_val, val;
1030 char c, *start_key, *start_val, *p, *q;
1031 int len_key, len_val, i;
1032
1033 head = vf_sexp_alloc(VF_SEXP_TAG_CONS);
1034 tail = vf_sexp_alloc(VF_SEXP_TAG_NIL);
1035 vf_sexp_rplacd(head, tail);
1036
1037 if (cstr == NULL)
1038 goto End;
1039
1040 p = cstr;
1041 last = head;
1042 for (;;){
1043 /* skip spaces */
1044 for (c = *p;
1045 (!isprint((int)c)||isspace((int)c)) && (c != '\0');
1046 p++, c = *p)
1047 ;
1048 if (c == '\0')
1049 break;
1050
1051 /* an key starts */ /* "^..." */
1052 start_key = p;
1053 len_key = 0;
1054
1055 /* go to end of an key */
1056 for (c = *p;
1057 (isprint((int)c)&&!isspace((int)c))
1058 && (c != '=') && (c != ',') && (c != '\0');
1059 len_key++, p++, c = *p)
1060 ;
1061
1062 /* skip spaces */
1063 for (c = *p;
1064 (!isprint((int)c)||isspace((int)c)) && (c != '\0');
1065 p++, c = *p)
1066 ;
1067 if ((c == ',') || (c == '\0')){ /* "KEY ^, ..." or "KEY ^" */
1068 start_val = NULL;
1069 len_val = 0;
1070 goto Found;
1071 }
1072 if ((c != '=') && isprint((int)c)){ /* "KEY ^foo" */
1073 start_val = NULL;
1074 len_val = 0;
1075 goto Found;
1076 }
1077
1078 p++; /* "KEY ^= ..." */
1079
1080 /* skip spaces */ /* "KEY =^ ..." */
1081 for (c = *p;
1082 (!isprint((int)c)||isspace((int)c)) && (c != '\0');
1083 p++, c = *p)
1084 ;
1085 if ((c == ',') || (c == '\0')){ /* "KEY = ^, ..." or "KEY =^" */
1086 start_val = NULL;
1087 len_val = 0;
1088 goto Found;
1089 }
1090
1091 /* a value starts */ /* "KEY = ^..." */
1092 start_val = p;
1093 len_val = 0;
1094
1095 /* go to end of an value */
1096 for (c = *p;
1097 (isprint((int)c)&&!isspace((int)c))
1098 && (c != ',') && (c != '\0');
1099 len_val++, p++, c = *p)
1100 (void) vf_get_char_esc(&p, NULL);
1101 /* "KEY = VALUE^... " */
1102 Found:
1103 /* copy string */
1104 str_key = vf_sexp_alloc(VF_SEXP_TAG_STRING);
1105 str_key->t.str = (char*)malloc(len_key+1);
1106 for (i = 0; i < len_key; i++)
1107 str_key->t.str[i] = start_key[i];
1108 str_key->t.str[len_key] = '\0';
1109
1110 str_val = vf_sexp_alloc(VF_SEXP_TAG_STRING);
1111 str_val->t.str = (char*)malloc(len_val+1);
1112 for (i = 0, q = start_val; i < len_val; i++){
1113 str_val->t.str[i] = vf_get_char_esc(&q, NULL);
1114 q++;
1115 }
1116 str_val->t.str[len_val] = '\0';
1117
1118 nil = vf_sexp_alloc(VF_SEXP_TAG_NIL);
1119 cell_list2 = vf_sexp_cons(str_val, nil);
1120 cell_list1 = vf_sexp_cons(str_key, cell_list2);
1121 cell = vf_sexp_cons(cell_list1, last);
1122 vf_sexp_rplacd(last, cell);
1123 vf_sexp_rplacd(cell, tail);
1124 last = cell;
1125
1126 if (c == '\0')
1127 break;
1128
1129 /* skip spaces */
1130 for (c = *p;
1131 (!isprint((int)c)||isspace((int)c)) && (c != ',') && (c != '\0');
1132 p++, c = *p)
1133 ;
1134 if (c == '\0')
1135 break;
1136
1137 if (c == ',')
1138 p++;
1139 }
1140
1141 End:
1142 val = vf_sexp_cdr(head);
1143 head->t.cons.cdr = NULL;
1144 vf_sexp_free(&head);
1145
1146 return val;
1147 }
1148
1149 static char
1150 vf_get_char_esc(char **pp, SEXP_STREAM stream)
/* [<][>][^][v][top][bottom][index][help] */
1151 {
1152 char c, *p, tmp[8];
1153 int n;
1154
1155 p = NULL;
1156 if (pp != NULL)
1157 p = *pp;
1158
1159 c = *p;
1160 if (c == '\\'){
1161 c = *(++p);
1162 if (isdigit((int)c)){
1163 tmp[0] = c;
1164 tmp[1] = *(++p);
1165 tmp[2] = *(++p);
1166 tmp[3] = '\0';
1167 sscanf(tmp, "%o", &n);
1168 c = n;
1169 } else if (c == 'x'){
1170 tmp[0] = *(++p);
1171 tmp[1] = *(++p);
1172 tmp[2] = '\0';
1173 sscanf(tmp, "%x", &n);
1174 c = n;
1175 } else {
1176 switch (c){
1177 case 'a': c = '\a'; break;
1178 case 'b': c = '\b'; break;
1179 case 'f': c = '\f'; break;
1180 case 'n': c = '\n'; break;
1181 case 'r': c = '\r'; break;
1182 case 't': c = '\t'; break;
1183 case 'v': c = '\v'; break;
1184 }
1185 }
1186 }
1187
1188 if (pp != NULL)
1189 *pp = p;
1190
1191 return c;
1192 }
1193
1194
1195
1196 /*
1197 * Alloc/Release an S-Expression Object
1198 */
1199
1200 static SEXP
1201 vf_sexp_alloc(int tag)
/* [<][>][^][v][top][bottom][index][help] */
1202 {
1203 SEXP s;
1204
1205 if ((s = calloc(1, sizeof(struct s_sexp))) != NULL)
1206 s->tag = tag;
1207 switch (tag){
1208 case VF_SEXP_TAG_NIL:
1209 break;
1210 case VF_SEXP_TAG_CONS:
1211 s->t.cons.car = NULL;
1212 s->t.cons.cdr = NULL;
1213 break;
1214 case VF_SEXP_TAG_STRING:
1215 case VF_SEXP_TAG_SYMBOL:
1216 s->t.str = NULL;
1217 }
1218 return s;
1219 }
1220
1221 void
1222 vf_sexp_free4(SEXP *s1, SEXP *s2, SEXP *s3, SEXP *s4)
/* [<][>][^][v][top][bottom][index][help] */
1223 {
1224 vf_sexp_free(s1); vf_sexp_free(s2);
1225 vf_sexp_free(s3); vf_sexp_free(s4);
1226 }
1227
1228 void
1229 vf_sexp_free3(SEXP *s1, SEXP *s2, SEXP *s3)
/* [<][>][^][v][top][bottom][index][help] */
1230 {
1231 vf_sexp_free(s1); vf_sexp_free(s2); vf_sexp_free(s3);
1232 }
1233
1234 void
1235 vf_sexp_free2(SEXP *s1, SEXP *s2)
/* [<][>][^][v][top][bottom][index][help] */
1236 {
1237 vf_sexp_free(s1); vf_sexp_free(s2);
1238 }
1239
1240 void
1241 vf_sexp_free1(SEXP *s1)
/* [<][>][^][v][top][bottom][index][help] */
1242 {
1243 vf_sexp_free(s1);
1244 }
1245
1246 void
1247 vf_sexp_free(SEXP *var_ptr)
/* [<][>][^][v][top][bottom][index][help] */
1248 {
1249 SEXP s, scar, scdr;
1250
1251 if (var_ptr == NULL)
1252 return;
1253 if ((s = *var_ptr) == NULL)
1254 return;
1255 *var_ptr = NULL;
1256
1257 vf_sexp_obj_validate(s);
1258
1259 while (s != NULL){
1260 switch (s->tag){
1261 case VF_SEXP_TAG_CONS:
1262 scar = s->t.cons.car;
1263 scdr = s->t.cons.cdr;
1264 vf_sexp_free(&scar);
1265 s->tag = VF_SEXP_TAG_RELEASED;
1266 vf_free(s);
1267 s = scdr;
1268 break;
1269
1270 case VF_SEXP_TAG_STRING:
1271 case VF_SEXP_TAG_SYMBOL:
1272 if (s->t.str != NULL)
1273 vf_free(s->t.str);
1274 /*FALLTHROUGHT*/
1275 case VF_SEXP_TAG_NIL:
1276 s->tag = VF_SEXP_TAG_RELEASED;
1277 vf_free(s);
1278 return;
1279
1280 case VF_SEXP_TAG_RELEASED:
1281 fprintf(stderr, "VFlib internal error: releasing released s-sexp obj\n");
1282 abort();
1283 default:
1284 fprintf(stderr, "VFlib internal error: cannot happen vf_sexp_free()\n");
1285 abort();
1286 }
1287 }
1288 }
1289
1290
1291 static void
1292 vf_sexp_obj_validate2(SEXP s1, SEXP s2)
/* [<][>][^][v][top][bottom][index][help] */
1293 {
1294 vf_sexp_obj_validate(s1);
1295 vf_sexp_obj_validate(s2);
1296 }
1297
1298 static void
1299 vf_sexp_obj_validate(SEXP s)
/* [<][>][^][v][top][bottom][index][help] */
1300 {
1301 if ((s == NULL) || (s->tag == VF_SEXP_TAG_RELEASED)){
1302 fprintf(stderr, "VFlib internal error: Invalid s-exp object\n");
1303 abort();
1304 }
1305 }
1306
1307
1308 #ifdef DEBUG
1309
1310 /*
1311 * example 1 (file stream) : echo '( abcfdf 123 (3 4 5 ) )' | ./dbg-sexp
1312 * example 2 (string stream) : ./dbg-sexp '( abcfdf 123 (3 4 5 ) )'
1313 */
1314
1315 int
1316 main(int argc, char **argv)
/* [<][>][^][v][top][bottom][index][help] */
1317 {
1318 char *str;
1319 SEXP s;
1320
1321 if (argc > 1){
1322 str = argv[1];
1323 s = vf_sexp_read_from_string_stream(str);
1324 } else {
1325 s = vf_sexp_read_from_file_stream(stdin);
1326 }
1327 vf_sexp_pp(s);
1328
1329 return 0;
1330 }
1331
1332 #endif
1333
1334 /*EOF*/