1 /* Copyright (C) 1992-1998 The Geometry Center
2 * Copyright (C) 1998-2000 Stuart Levy, Tamara Munzner, Mark Phillips
3 *
4 * This file is part of Geomview.
5 *
6 * Geomview is free software; you can redistribute it and/or modify it
7 * under the terms of the GNU Lesser General Public License as published
8 * by the Free Software Foundation; either version 2, or (at your option)
9 * any later version.
10 *
11 * Geomview is distributed in the hope that it will be useful, but
12 * WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 * Lesser General Public License for more details.
15 *
16 * You should have received a copy of the GNU Lesser General Public
17 * License along with Geomview; see the file COPYING. If not, write
18 * to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139,
19 * USA, or visit http://www.gnu.org.
20 */
21
22 #if HAVE_CONFIG_H
23 # include "config.h"
24 #endif
25
26 #if 0
27 static char copyright[] = "Copyright (C) 1992-1998 The Geometry Center\n\
28 Copyright (C) 1998-2000 Stuart Levy, Tamara Munzner, Mark Phillips";
29 #endif
30
31 /*
32 * geomview custom lisp object types
33 */
34
35 #include <stdio.h>
36 #include <math.h>
37 #include <stdlib.h>
38 #include <string.h>
39 #include "ooglutil.h"
40 #include "drawer.h"
41 #include "lisp.h"
42 #include "lispext.h"
43 #include "streampool.h"
44 #include "handleP.h"
45 #include "camera.h"
46 #include "geom.h"
47 #include "appearance.h"
48 #include "window.h"
49 #include "transform.h"
50 #include "fsa.h"
51 #include "lang.h"
52 #include "freelist.h"
53
54 extern HandleOps GeomOps, CamOps, WindowOps;
55 extern HandleOps TransOps, NTransOps, ImageOps, AppearanceOps;
56
57 LObject *L0, *L1;
58
59 static Fsa lang_fsa = NULL;
60 #define REJECT -1
61
62 static char **keyword_names;
63 static int n_keywords;
64
65 static DEF_FREELIST(HandleRefStruct);
66 static DEF_FREELIST(TransformStruct);
67
68 #ifdef NEW
69 # undef NEW
70 #endif
71 #define NEW(type, name) \
72 { \
73 HandleRefStruct *hrname; \
74 FREELIST_NEW(HandleRefStruct, hrname); \
75 name = (type##Struct *)hrname; \
76 }
77 #ifdef DELETE
78 # undef DELETE
79 #endif
80 #define DELETE(name) FREELIST_FREE(HandleRefStruct, name)
81
82 /************************************************************************
83 CAMERA LISP OBJECT
84 ************************************************************************/
camcopy(CameraStruct * old)85 static CameraStruct *camcopy(CameraStruct *old)
86 {
87 CameraStruct *newc;
88
89 NEW(Camera, newc);
90
91 if(old) *newc = *old;
92 else newc->cam = NULL, newc->h = NULL;
93 if (newc->cam) RefIncr((Ref*)(newc->cam));
94 if (newc->h) RefIncr((Ref*)newc->h);
95 return newc;
96 }
97
camfromobj(LObject * obj,CameraStruct ** x)98 static bool camfromobj(LObject *obj, CameraStruct **x)
99 {
100 if (obj->type != LCAMERA) return 0;
101 *x = LCAMERAVAL(obj);
102 return 1;
103 }
104
cam2obj(CameraStruct ** x)105 static LObject *cam2obj(CameraStruct **x)
106 {
107 CameraStruct *copy = camcopy(*x);
108 return LNew( LCAMERA, © );
109 }
110
camfree(CameraStruct ** x)111 static void camfree(CameraStruct **x)
112 {
113 if (*x) {
114 if ((*x)->cam) CamDelete( (*x)->cam );
115 if ((*x)->h) HandleDelete( (*x)->h );
116 DELETE(*x);
117 }
118 }
119
cammatch(CameraStruct ** a,CameraStruct ** b)120 static bool cammatch(CameraStruct **a, CameraStruct **b)
121 {
122 if ((*a)->h && ((*a)->h == (*b)->h)) return 1;
123 if ((*a)->cam && ((*a)->cam == (*b)->cam)) return 1;
124 return 0;
125 }
126
camwrite(FILE * fp,CameraStruct ** x)127 static void camwrite(FILE *fp, CameraStruct **x)
128 {
129 CamFSave( (*x)->cam, fp, "lisp output stream" );
130 }
131
campull(va_list * a_list,CameraStruct ** x)132 static void campull(va_list *a_list, CameraStruct **x)
133 {
134 *x = va_arg(*a_list, CameraStruct*);
135 }
136
camparse(Lake * lake)137 static LObject *camparse(Lake *lake)
138 {
139 CameraStruct *newc;
140
141 NEW(Camera, newc);
142
143 newc->h = NULL; newc->cam = NULL;
144 if (CamOps.strmin(POOL(lake), (Handle **)&newc->h,
145 (Ref **)(void *)&(newc->cam)) == 0) {
146 return Lnil;
147 } else
148 if(newc->h && !newc->h->permanent) {
149 HandleDelete(newc->h);
150 newc->h = NULL;
151 }
152 return LNew( LCAMERA, &newc );
153 }
154
155 LType LCamerap = {
156 "camera",
157 sizeof(CameraStruct*),
158 camfromobj,
159 cam2obj,
160 camfree,
161 camwrite,
162 cammatch,
163 campull,
164 camparse,
165 LTypeMagic
166 };
167
168 /************************************************************************
169 * WINDOW LISP OBJECT *
170 ************************************************************************/
171
wncopy(WindowStruct * old)172 static WindowStruct *wncopy(WindowStruct *old)
173 {
174 WindowStruct *neww;
175
176 NEW(Window, neww);
177
178 if(old) *neww = *old;
179 else neww->wn = NULL, neww->h = NULL;
180 if (neww->wn) RefIncr((Ref*)(neww->wn));
181 if (neww->h) RefIncr((Ref*)neww->h);
182 return neww;
183 }
184
wnfromobj(LObject * obj,WindowStruct ** x)185 static bool wnfromobj(LObject *obj, WindowStruct **x)
186 {
187 if (obj->type != LWINDOW) return 0;
188 *x = LWINDOWVAL(obj);
189 return 1;
190 }
191
wn2obj(WindowStruct ** x)192 static LObject *wn2obj(WindowStruct **x)
193 {
194 WindowStruct *copy = wncopy(*x);
195 return LNew( LWINDOW, © );
196 }
197
wnfree(WindowStruct ** x)198 static void wnfree(WindowStruct **x)
199 {
200 if (*x) {
201 if ((*x)->wn) WnDelete( (*x)->wn );
202 if ((*x)->h) HandleDelete( (*x)->h );
203 DELETE(*x);
204 }
205 }
206
wnmatch(WindowStruct ** a,WindowStruct ** b)207 static bool wnmatch(WindowStruct **a, WindowStruct **b)
208 {
209 if ((*a)->h && ((*a)->h == (*b)->h)) return 1;
210 if ((*a)->wn && ((*a)->wn == (*b)->wn)) return 1;
211 return 0;
212 }
213
wnwrite(FILE * fp,WindowStruct ** x)214 static void wnwrite(FILE *fp, WindowStruct * *x)
215 {
216 Pool *p = PoolStreamTemp("", NULL, fp, 1, &WindowOps);
217 if(p == NULL)
218 return;
219 (void) WnStreamOut(p, (*x)->h, (*x)->wn);
220 PoolDelete(p);
221 }
222
wnpull(va_list * a_list,WindowStruct ** x)223 static void wnpull(va_list *a_list, WindowStruct **x)
224 {
225 *x = va_arg(*a_list, WindowStruct*);
226 }
227
wnparse(Lake * lake)228 static LObject *wnparse(Lake *lake)
229 {
230 WindowStruct *neww;
231
232 NEW(Window, neww);
233
234 neww->h = NULL; neww->wn = NULL;
235 if (WindowOps.strmin(POOL(lake),(Handle **)&neww->h,
236 (Ref **)(void *)&(neww->wn)) == 0) {
237 return Lnil;
238 } else
239 if(neww->h && !neww->h->permanent) {
240 HandleDelete(neww->h);
241 neww->h = NULL;
242 }
243 return LNew( LWINDOW, &neww );
244 }
245
246 LType LWindowp = {
247 "window",
248 sizeof(WindowStruct*),
249 wnfromobj,
250 wn2obj,
251 wnfree,
252 wnwrite,
253 wnmatch,
254 wnpull,
255 wnparse,
256 LTypeMagic
257 };
258
259 /************************************************************************
260 * GEOM LISP OBJECT *
261 ************************************************************************/
262
geomcopy(GeomStruct * old)263 static GeomStruct *geomcopy(GeomStruct *old)
264 {
265 GeomStruct *newg;
266
267 NEW(Geom, newg);
268 if(old) *newg = *old;
269 else newg->geom = NULL, newg->h = NULL;
270 if (newg->geom) RefIncr((Ref*)(newg->geom));
271 if (newg->h) RefIncr((Ref*)newg->h);
272 return newg;
273 }
274
geomfromobj(LObject * obj,GeomStruct ** x)275 static bool geomfromobj(LObject *obj, GeomStruct **x)
276 {
277 if (obj->type != LGEOM) return 0;
278 *x = LGEOMVAL(obj);
279 return 1;
280 }
281
geom2obj(GeomStruct ** x)282 static LObject *geom2obj(GeomStruct **x)
283 {
284 GeomStruct *copy = geomcopy(*x);
285 return LNew( LGEOM, © );
286 }
287
geomfree(GeomStruct ** x)288 static void geomfree(GeomStruct **x)
289 {
290 if (*x) {
291 if ((*x)->geom) GeomDelete( (*x)->geom );
292 if ((*x)->h) HandleDelete( (*x)->h );
293 DELETE(*x);
294 }
295 }
296
geommatch(GeomStruct ** a,GeomStruct ** b)297 static bool geommatch(GeomStruct **a, GeomStruct **b)
298 {
299 if ((*a)->h && ((*a)->h == (*b)->h)) return 1;
300 if ((*a)->geom && ((*a)->geom == (*b)->geom)) return 1;
301 return 0;
302 }
303
geomwrite(FILE * fp,GeomStruct ** x)304 static void geomwrite(FILE *fp, GeomStruct **x)
305 {
306 GeomFSave( (*x)->geom, fp, "lisp output stream" );
307 }
308
geompull(va_list * a_list,GeomStruct ** x)309 static void geompull(va_list *a_list, GeomStruct **x)
310 {
311 *x = va_arg(*a_list, GeomStruct*);
312 }
313
geomparse(Lake * lake)314 static LObject *geomparse(Lake *lake)
315 {
316 GeomStruct *newg;
317
318 NEW(Geom, newg);
319
320 newg->h = NULL; newg->geom = NULL;
321 if (GeomOps.strmin(POOL(lake), (Handle **)&newg->h,
322 (Ref **)(void *)&(newg->geom)) == 0) {
323 return Lnil;
324 } else {
325 if(newg->h && !newg->h->permanent) {
326 HandleDelete(newg->h);
327 newg->h = NULL;
328 }
329 return LNew( LGEOM, &newg );
330 }
331 }
332
333 LType LGeomp = {
334 "geometry",
335 sizeof(GeomStruct*),
336 geomfromobj,
337 geom2obj,
338 geomfree,
339 geomwrite,
340 geommatch,
341 geompull,
342 geomparse,
343 LTypeMagic
344 };
345
346 /************************************************************************
347 * AP LISP OBJECT *
348 ************************************************************************/
349
apcopy(ApStruct * old)350 static ApStruct *apcopy(ApStruct *old)
351 {
352 ApStruct *newap;
353
354 NEW(Ap, newap);
355 if(old) *newap = *old;
356 else newap->ap = NULL, newap->h = NULL;
357 if (newap->ap) RefIncr((Ref*)(newap->ap));
358 if (newap->h) RefIncr((Ref*)newap->h);
359 return newap;
360 }
361
apfromobj(LObject * obj,ApStruct ** x)362 static bool apfromobj(LObject *obj, ApStruct **x)
363 {
364 if (obj->type != LAP) return 0;
365 *x = LAPVAL(obj);
366 return 1;
367 }
368
ap2obj(ApStruct ** x)369 static LObject *ap2obj(ApStruct **x)
370 {
371 ApStruct *copy = apcopy(*x);
372 return LNew( LAP, © );
373 }
374
apfree(ApStruct ** x)375 static void apfree(ApStruct **x)
376 {
377 if (*x) {
378 if ((*x)->ap) ApDelete( (*x)->ap );
379 if ((*x)->h) HandleDelete( (*x)->h );
380 DELETE(*x);
381 }
382 }
383
apmatch(ApStruct ** a,ApStruct ** b)384 static bool apmatch(ApStruct **a, ApStruct **b)
385 {
386 if ((*a)->h && ((*a)->h == (*b)->h)) return 1;
387 if ((*a)->ap && ((*a)->ap == (*b)->ap)) return 1;
388 return 0;
389 }
390
apwrite(FILE * fp,ApStruct ** x)391 static void apwrite(FILE *fp, ApStruct * *x)
392 {
393 ApFSave((*x)->ap, fp, "lisp output stream");
394 }
395
appull(va_list * a_list,ApStruct ** x)396 static void appull(va_list *a_list, ApStruct **x)
397 {
398 *x = va_arg(*a_list, ApStruct*);
399 }
400
apparse(Lake * lake)401 static LObject *apparse(Lake *lake)
402 {
403 ApStruct *newap;
404
405 NEW(Ap, newap);
406
407 newap->h = NULL; newap->ap = NULL;
408 if (ApStreamIn(POOL(lake), &newap->h, &(newap->ap)) == 0) {
409 return Lnil;
410 } else
411 if(newap->h && !newap->h->permanent) {
412 HandleDelete(newap->h);
413 newap->h = NULL;
414 }
415 return LNew( LAP, &newap );
416 }
417
418 LType LApp = {
419 "ap",
420 sizeof(ApStruct *),
421 apfromobj,
422 ap2obj,
423 apfree,
424 apwrite,
425 apmatch,
426 appull,
427 apparse,
428 LTypeMagic
429 };
430
431
432 /************************************************************************
433 * TRANSFORM LISP OBJECT *
434 ************************************************************************/
435
tmcopy(TransformStruct * old)436 static TransformStruct *tmcopy(TransformStruct *old)
437 {
438 TransformStruct *newt;
439
440 FREELIST_NEW(TransformStruct, newt);
441
442 if (old) *newt = *old;
443 else newt->h = NULL;
444 if (newt->h) RefIncr((Ref*)newt->h);
445 return newt;
446 }
447
tmfromobj(LObject * obj,TransformStruct ** x)448 static bool tmfromobj(LObject *obj, TransformStruct **x)
449 {
450 if (obj->type != LTRANSFORM) return 0;
451 *x = LTRANSFORMVAL(obj);
452 return 1;
453 }
454
tm2obj(TransformStruct ** x)455 static LObject *tm2obj(TransformStruct **x)
456 {
457 TransformStruct *copy = tmcopy(*x);
458 return LNew(LTRANSFORM, ©);
459 }
460
tmfree(TransformStruct ** x)461 static void tmfree(TransformStruct **x)
462 {
463 if (*x) {
464 if ((*x)->h) HandleDelete((*x)->h);
465 FREELIST_FREE(TransformStruct, *x);
466 }
467 }
468
tmmatch(TransformStruct ** a,TransformStruct ** b)469 static bool tmmatch(TransformStruct **a, TransformStruct **b)
470 {
471 if ((*a)->h && ((*a)->h == (*b)->h)) return 1;
472 if ((*a)->tm && ((*a)->tm == (*b)->tm)) return 1;
473 return TmCompare((*a)->tm, (*b)->tm, (float)0.0);
474 }
475
tmwrite(FILE * fp,TransformStruct ** x)476 static void tmwrite(FILE *fp, TransformStruct **x)
477 {
478 TransFSave((*x)->tm, fp, "lisp output stream");
479 }
480
tmpull(va_list * a_list,TransformStruct ** x)481 static void tmpull(va_list *a_list, TransformStruct **x)
482 {
483 *x = va_arg(*a_list, TransformStruct*);
484 }
485
tmparse(Lake * lake)486 static LObject *tmparse(Lake *lake)
487 {
488 TransformStruct *newt;
489
490 FREELIST_NEW(TransformStruct, newt);
491
492 newt->h = NULL;
493 if (TransStreamIn(POOL(lake), (Handle **)&newt->h, newt->tm) == false) {
494 return Lnil;
495 } else
496 if(newt->h && !newt->h->permanent) {
497 HandleDelete(newt->h);
498 newt->h = NULL;
499 }
500 return LNew( LTRANSFORM, &newt );
501 }
502
503 LType LTransformp = {
504 "transform",
505 sizeof(TransformStruct *),
506 tmfromobj,
507 tm2obj,
508 tmfree,
509 tmwrite,
510 tmmatch,
511 tmpull,
512 tmparse,
513 LTypeMagic
514 };
515
516 /************************************************************************
517 * N-D TRANSFORM LISP OBJECT *
518 ************************************************************************/
519
tmncopy(TmNStruct * old)520 static TmNStruct *tmncopy(TmNStruct *old)
521 {
522 TmNStruct *newt;
523
524 NEW(TmN, newt);
525
526 if(old) *newt = *old;
527 else newt->tm = NULL, newt->h = NULL;
528 if (newt->tm) RefIncr((Ref*)(newt->tm));
529 if (newt->h) RefIncr((Ref*)newt->h);
530 return newt;
531 }
532
tmnfromobj(LObject * obj,TmNStruct ** x)533 static bool tmnfromobj(LObject *obj, TmNStruct **x)
534 {
535 if (obj->type != LTRANSFORMN) return 0;
536 *x = LTRANSFORMNVAL(obj);
537 return 1;
538 }
539
tmn2obj(TmNStruct ** x)540 static LObject *tmn2obj( TmNStruct **x )
541 {
542 TmNStruct *copy = tmncopy(*x);
543 return LNew( LTRANSFORMN, © );
544 }
545
tmnfree(TmNStruct ** x)546 static void tmnfree(TmNStruct **x)
547 {
548 if (*x) {
549 if ((*x)->tm) TmNDelete( (*x)->tm );
550 if ((*x)->h) HandleDelete( (*x)->h );
551 DELETE(*x);
552 }
553 }
554
tmnmatch(TmNStruct ** a,TmNStruct ** b)555 static bool tmnmatch(TmNStruct **a, TmNStruct **b)
556 {
557 if ((*a)->h && ((*a)->h == (*b)->h)) return 1;
558 if ((*a)->tm && ((*a)->tm == (*b)->tm)) return 1;
559 return 0;
560 }
561
tmnwrite(FILE * fp,TmNStruct ** x)562 static void tmnwrite(FILE *fp, TmNStruct **x)
563 {
564 TmNPrint( fp, (*x)->tm );
565 }
566
tmnpull(va_list * a_list,TmNStruct ** x)567 static void tmnpull(va_list *a_list, TmNStruct **x)
568 {
569 *x = va_arg(*a_list, TmNStruct*);
570 }
571
tmnparse(Lake * lake)572 static LObject *tmnparse(Lake *lake)
573 {
574 TmNStruct *newt;
575
576 NEW(TmN, newt);
577
578 newt->h = NULL;
579 newt->tm = NULL;
580 if (NTransOps.strmin(POOL(lake), (Handle **)&newt->h,
581 (Ref **)(void *)(&newt->tm)) == 0) {
582 return Lnil;
583 } else {
584 if(newt->h && !newt->h->permanent) {
585 HandleDelete(newt->h);
586 newt->h = NULL;
587 }
588 return LNew( LTRANSFORMN, &newt );
589 }
590 }
591
592 LType LTransformNp = {
593 "ntransform",
594 sizeof(TmNStruct*),
595 tmnfromobj,
596 tmn2obj,
597 tmnfree,
598 tmnwrite,
599 tmnmatch,
600 tmnpull,
601 tmnparse,
602 LTypeMagic
603 };
604
605 /************************************************************************
606 * IMAGE LISP OBJECT *
607 ************************************************************************/
608
imgcopy(ImgStruct * old)609 static ImgStruct *imgcopy(ImgStruct *old)
610 {
611 ImgStruct *newi;
612
613 NEW(Img, newi);
614
615 if(old) *newi = *old;
616 else newi->img = NULL, newi->h = NULL;
617 if (newi->img) RefIncr((Ref*)(newi->img));
618 if (newi->h) RefIncr((Ref*)newi->h);
619 return newi;
620 }
621
imgfromobj(LObject * obj,ImgStruct ** x)622 static bool imgfromobj(LObject *obj, ImgStruct **x)
623 {
624 if (obj->type != LIMAGE) return 0;
625 *x = LIMAGEVAL(obj);
626 return 1;
627 }
628
img2obj(ImgStruct ** x)629 static LObject *img2obj( ImgStruct **x )
630 {
631 ImgStruct *copy = imgcopy(*x);
632 return LNew( LIMAGE, © );
633 }
634
imgfree(ImgStruct ** x)635 static void imgfree(ImgStruct **x)
636 {
637 if (*x) {
638 if ((*x)->img) ImgDelete( (*x)->img );
639 if ((*x)->h) HandleDelete( (*x)->h );
640 DELETE(*x);
641 }
642 }
643
imgmatch(ImgStruct ** a,ImgStruct ** b)644 static bool imgmatch(ImgStruct **a, ImgStruct **b)
645 {
646 if ((*a)->h && ((*a)->h == (*b)->h)) return true;
647 if ((*a)->img && ((*a)->img == (*b)->img)) return true;
648 return false;
649 }
650
imgwrite(FILE * fp,ImgStruct ** x)651 static void imgwrite(FILE *fp, ImgStruct **x)
652 {
653 ImgFSave((*x)->img, fp, "lisp output stream");
654 }
655
imgpull(va_list * a_list,ImgStruct ** x)656 static void imgpull(va_list *a_list, ImgStruct **x)
657 {
658 *x = va_arg(*a_list, ImgStruct*);
659 }
660
imgparse(Lake * lake)661 static LObject *imgparse(Lake *lake)
662 {
663 ImgStruct *newi;
664
665 NEW(Img, newi);
666
667 newi->h = NULL;
668 newi->img = NULL;
669 if (ImageOps.strmin(POOL(lake), (Handle **)&newi->h,
670 (Ref **)(void *)(&newi->img)) == 0) {
671 return Lnil;
672 } else {
673 if(newi->h && !newi->h->permanent) {
674 HandleDelete(newi->h);
675 newi->h = NULL;
676 }
677 return LNew( LIMAGE, &newi );
678 }
679 }
680
681 LType LImagep = {
682 "image",
683 sizeof(ImgStruct*),
684 imgfromobj,
685 img2obj,
686 imgfree,
687 imgwrite,
688 imgmatch,
689 imgpull,
690 imgparse,
691 LTypeMagic
692 };
693
694 /************************************************************************
695 * ID LISP OBJECT *
696 ************************************************************************/
697
idfromobj(LObject * obj,int * x)698 static bool idfromobj(LObject *obj, int *x)
699 {
700 char *tmp;
701
702 if (LSTRINGFROMOBJ(obj, &tmp)) {
703 *x = drawer_idbyname(tmp);
704 if (*x == NOID) return 0;
705 } else if (obj->type == LID) {
706 *x = LIDVAL(obj);
707 } else return 0;
708 return 1;
709 }
710
id2obj(int * x)711 static LObject *id2obj(int *x)
712 {
713 return LNew( LID, x );
714 }
715
idfree(int * x)716 static void idfree(int *x)
717 {}
718
idmatch(int * a,int * b)719 static bool idmatch(int *a, int *b)
720 {
721 return drawer_idmatch(*a,*b);
722 }
723
idwrite(FILE * fp,int * x)724 static void idwrite(FILE *fp, int *x)
725 {
726 fprintf(fp, "\"%s\"", drawer_id2name(*x));
727 }
728
729 #if 0
730 static LObject *idparse(Lake *lake)
731 {
732 LObject *obj = LSexpr(lake);
733 int id;
734 if (obj->type == LSTRING) {
735 id = drawer_idbyname(LSTRINGVAL(obj));
736 if (id == NOID) return Lnil;
737 OOGLFree(LSTRINGVAL(obj));
738 obj->type = LID;
739 obj->cell.i = id;
740 return obj;
741 } else {
742 LFree(obj);
743 return Lnil;
744 }
745 }
746 #endif
747
idpull(a_list,x)748 static void idpull(a_list, x)
749 va_list *a_list;
750 int *x;
751 {
752 *x = va_arg(*a_list, int);
753 }
754
755 LType LIdp = {
756 "id",
757 sizeof(int),
758 idfromobj,
759 id2obj,
760 idfree,
761 idwrite,
762 idmatch,
763 idpull,
764 LSexpr,
765 LTypeMagic
766 };
767
768
769 /************************************************************************
770 * KEYWORD LISP OBJECT *
771 ************************************************************************/
772
keywordfromobj(LObject * obj,int * x)773 static bool keywordfromobj(LObject *obj, int *x)
774 {
775 char *tmp;
776
777 if (LSTRINGFROMOBJ(obj, &tmp)) {
778 *x = (int)(long)fsa_parse(lang_fsa, tmp);
779 if (*x == REJECT) {
780 return false;
781 }
782 } else if (obj->type == LKEYWORD) {
783 *x = LKEYWORDVAL(obj);
784 } else {
785 return false;
786 }
787 return true;
788 }
789
keyword2obj(int * x)790 static LObject *keyword2obj(int *x)
791 {
792 return LNew( LKEYWORD, x );
793 }
794
keywordmatch(int * a,int * b)795 static bool keywordmatch(int *a, int *b)
796 {
797 return *a == *b;
798 }
799
keywordwrite(FILE * fp,Keyword * x)800 static void keywordwrite(FILE *fp, Keyword *x)
801 {
802 fprintf(fp, "%s", keywordname(*x));
803 }
804
keywordfree(void * value)805 static void keywordfree(void *value)
806 {}
807
keywordpull(a_list,x)808 static void keywordpull(a_list, x)
809 va_list *a_list;
810 int *x;
811 {
812 *x = va_arg(*a_list, int);
813 }
814
815 #if 0
816 static LObject *keywordparse(Lake *lake)
817 {
818 LObject *obj = LSexpr(lake);
819 int key;
820 if (obj->type == LSTRING) {
821 key = (int)(long)fsa_parse(lang_fsa, LSTRINGVAL(obj));
822 if (key == REJECT) return Lnil;
823 OOGLFree(LSTRINGVAL(obj));
824 obj->type = LKEYWORD;
825 obj->cell.i = key;
826 return obj;
827 } else {
828 LFree(obj);
829 return Lnil;
830 }
831 }
832 #endif
833
834 LType LKeywordp = {
835 "keyword",
836 sizeof(int),
837 keywordfromobj,
838 keyword2obj,
839 keywordfree,
840 keywordwrite,
841 keywordmatch,
842 keywordpull,
843 LSexpr,
844 LTypeMagic
845 };
846
847
848 /************************************************************************
849 * STRINGS LISP OBJECT *
850 * (a "strings" object is a string with possibly embedded spaces) *
851 * *
852 * cH: actually, this function just sucks everything in until a closing *
853 * paren is found. We now also take care of quoting and embedded parens *
854 ************************************************************************/
855
stringsfromobj(LObject * obj,char ** x)856 static bool stringsfromobj(LObject *obj, char * *x)
857 {
858 if (LSTRINGFROMOBJ(obj, x)) {
859 return true;
860 } else if (obj->type == LSTRINGS) {
861 *x = LSTRINGVAL(obj);
862 return true;
863 }
864 return false;
865 }
866
stringsparse(Lake * lake)867 static LObject *stringsparse(Lake *lake)
868 {
869 const char *tok;
870 int toklen, quote, paren = 0;
871 bool first = true;
872 vvec svv;
873
874 VVINIT(svv, char, 80);
875
876 while (paren > 0 || LakeMore(lake)) {
877 paren -= !LakeMore(lake);
878 paren += LakeNewSexpr(lake);
879 tok = LakeNextToken(lake, "e);
880 toklen = strlen(tok);
881 if (first) {
882 first = false;
883 quote = '\0'; /* we do not quote the first token */
884 } else {
885 *VVAPPEND(svv, char) = ' ';
886 }
887 if (quote != '\0') {
888 *VVAPPEND(svv, char) = (char)quote;
889 }
890 vvneeds(&svv, VVCOUNT(svv)+toklen);
891 memcpy(VVEC(svv, char)+VVCOUNT(svv), tok, toklen);
892 VVCOUNT(svv) += toklen;
893 if (quote != '\0') {
894 *VVAPPEND(svv, char) = (char)quote;
895 }
896 }
897 *VVAPPEND(svv, char) = '\0';
898 vvtrim(&svv);
899 tok = VVEC(svv, char);
900 return LNew(LSTRINGS, &tok);
901 }
902
903 LType LStringsp; /* initialized in lispext_init() */
904
905 /**********************************************************************/
906 /**********************************************************************/
907
lispext_init()908 void lispext_init()
909 {
910 LStringsp = *(LSTRING);
911 LStringsp.name = "strings";
912 LStringsp.fromobj = stringsfromobj;
913 LStringsp.parse = stringsparse;
914
915 {
916 int zero=0, one=1;
917 L0 = LNew( LINT, &zero );
918 L1 = LNew( LINT, &one );
919 }
920
921 lang_fsa = fsa_initialize(NULL, (void*)REJECT);
922 return;
923 }
924
define_keyword(char * word,Keyword value)925 void define_keyword(char *word, Keyword value)
926 {
927 if (value+1 > n_keywords) {
928 char **newwords = OOGLNewNE(char *, value+1, "New keyword list");
929 memset(newwords, 0, sizeof(char *)*(value+1));
930 memcpy(newwords, keyword_names, n_keywords*sizeof(char *));
931 OOGLFree(keyword_names);
932 keyword_names = newwords;
933 keyword_names[value] = word;
934 n_keywords = value+1;
935 } else if (keyword_names[value] == NULL) {
936 /* We allow aliases, but the name-list just picks up the first
937 * name.
938 */
939 keyword_names[value] = word;
940 }
941 fsa_install(lang_fsa, word, (void*)(long)value);
942 }
943
944 /* returns < 0 if asked to parse something that isn't a keyword. */
parse_keyword(char * word)945 Keyword parse_keyword(char *word)
946 {
947 return (Keyword)(long)fsa_parse(lang_fsa, word);
948 }
949
keywordname(Keyword keyword)950 char *keywordname(Keyword keyword)
951 {
952 if (keyword < n_keywords && keyword_names[keyword] != NULL) {
953 return keyword_names[keyword];
954 } else {
955 return "???";
956 }
957 }
958
959 /*
960 * Local Variables: ***
961 * mode: c ***
962 * c-basic-offset: 2 ***
963 * End: ***
964 */
965