1 /* -*- C++ -*-
2 // -------------------------------------------------------------------
3 // MiniExp - Library for handling lisp expressions
4 // Copyright (c) 2005 Leon Bottou
5 //
6 // This software is subject to, and may be distributed under, the GNU
7 // Lesser General Public License, either Version 2.1 of the license,
8 // or (at your option) any later version. The license should have
9 // accompanied the software or you may obtain a copy of the license
10 // from the Free Software Foundation at http://www.fsf.org .
11 //
12 // This program 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
15 // GNU General Public License for more details.
16 // -------------------------------------------------------------------
17 */
18
19 #ifdef HAVE_CONFIG_H
20 # include "config.h"
21 #endif
22 #if NEED_GNUG_PRAGMAS
23 # pragma implementation "miniexp.h"
24 #endif
25
26 #include <stddef.h>
27 #include <stdlib.h>
28 #include <stdio.h>
29 #include <cstdio>
30 #include <ctype.h>
31 #include <errno.h>
32 #include <string.h>
33 #include <time.h>
34 #include <stdarg.h>
35
36 #define MINIEXP_IMPLEMENTATION
37
38 #include "miniexp.h"
39
40 #ifdef HAVE_NAMESPACES
41 # define BEGIN_ANONYMOUS_NAMESPACE namespace {
42 # define END_ANONYMOUS_NAMESPACE }
43 #else
44 # define BEGIN_ANONYMOUS_NAMESPACE
45 # define END_ANONYMOUS_NAMESPACE
46 #endif
47
48
49 /* -------------------------------------------------- */
50 /* ASSERT */
51 /* -------------------------------------------------- */
52
53 #if defined(__GNUC__)
54 static void
55 assertfail(const char *fn, int ln)
56 __attribute__((noreturn));
57 #endif
58
59 static void
assertfail(const char * fn,int ln)60 assertfail(const char *fn, int ln)
61 {
62 fprintf(stderr,"Assertion failed: %s:%d\n",fn,ln);
63 abort();
64 }
65
66 #define ASSERT(x) \
67 do { if (!(x)) assertfail(__FILE__,__LINE__); } while(0)
68
69
70 /* -------------------------------------------------- */
71 /* GLOBAL MUTEX */
72 /* -------------------------------------------------- */
73
74 #ifndef WITHOUT_THREADS
75 # ifdef _WIN32
76 # include <windows.h>
77 # define USE_WINTHREADS 1
78 # elif defined(HAVE_PTHREAD)
79 # include <pthread.h>
80 # define USE_PTHREADS 1
81 # endif
82 #endif
83
84 #if defined(USE_WINTHREADS)
85 // Windows critical section
86 # define CSLOCK(name) CSLocker name
87 BEGIN_ANONYMOUS_NAMESPACE
88 struct CS {
89 CRITICAL_SECTION cs;
CSCS90 CS() { InitializeCriticalSection(&cs); }
~CSCS91 ~CS() { DeleteCriticalSection(&cs); } };
92 static CS globalCS;
93 struct CSLocker {
CSLockerCSLocker94 CSLocker() { EnterCriticalSection(&globalCS.cs); }
~CSLockerCSLocker95 ~CSLocker() { LeaveCriticalSection(&globalCS.cs); } };
96 END_ANONYMOUS_NAMESPACE
97
98 #elif defined (USE_PTHREADS)
99 // Pthread critical section
100 # define CSLOCK(name) CSLocker name
101 BEGIN_ANONYMOUS_NAMESPACE
102 static pthread_mutex_t globalCS = PTHREAD_MUTEX_INITIALIZER;
103 struct CSLocker {
104 CSLocker() { pthread_mutex_lock(&globalCS); }
105 ~CSLocker() { pthread_mutex_unlock(&globalCS); } };
106 END_ANONYMOUS_NAMESPACE
107
108 #else
109 // No critical sections
110 # define CSLOCK(name) /**/
111 #endif
112
113
114 /* -------------------------------------------------- */
115 /* SYMBOLS */
116 /* -------------------------------------------------- */
117
118 static unsigned int
hashcode(const char * s)119 hashcode(const char *s)
120 {
121 long h = 0x1013;
122 while (*s)
123 {
124 h = (h<<6) | ((h&0xfc000000)>>26);
125 h ^= (*s);
126 s++;
127 }
128 return h;
129 }
130
131 BEGIN_ANONYMOUS_NAMESPACE
132
133 class symtable_t
134 {
135 public:
136 int nelems;
137 int nbuckets;
138 struct sym { unsigned int h; struct sym *l; char *n; miniexp_t v; };
139 struct sym **buckets;
140 symtable_t();
141 ~symtable_t();
142 struct sym *lookup(const char *n, bool create=false);
143 void resize(int);
144 private:
145 symtable_t(const symtable_t&);
146 symtable_t& operator=(const symtable_t&);
147 };
148
symtable_t()149 symtable_t::symtable_t()
150 : nelems(0), nbuckets(0), buckets(0)
151 {
152 resize(7);
153 }
154
~symtable_t()155 symtable_t::~symtable_t()
156 {
157 int i=0;
158 for (; i<nbuckets; i++)
159 while (buckets[i])
160 {
161 struct sym *r = buckets[i];
162 buckets[i] = r->l;
163 delete [] r->n;
164 delete r;
165 }
166 delete [] buckets;
167 }
168
169 void
resize(int nb)170 symtable_t::resize(int nb)
171 {
172 struct sym **b = new sym*[nb];
173 memset(b, 0, nb*sizeof(sym*));
174 int i=0;
175 for (; i<nbuckets; i++)
176 while (buckets[i])
177 {
178 struct sym *s = buckets[i];
179 int j = s->h % nb;
180 buckets[i] = s->l;
181 s->l = b[j];
182 b[j] = s;
183 }
184 delete [] buckets;
185 buckets = b;
186 nbuckets = nb;
187 }
188
189 struct symtable_t::sym *
lookup(const char * n,bool create)190 symtable_t::lookup(const char *n, bool create)
191 {
192 unsigned int h = hashcode(n);
193 int i = h % nbuckets;
194 struct sym *r = buckets[i];
195 while (r && strcmp(n,r->n))
196 r = r->l;
197 if (!r && create)
198 {
199 CSLOCK(lock);
200 nelems += 1;
201 r = new sym;
202 r->h = h;
203 r->l = buckets[i];
204 r->n = new char [1+strlen(n)];
205 r->v = (miniexp_t)(((size_t)r)|((size_t)2));
206 strcpy(r->n, n);
207 buckets[i] = r;
208 if ( 2 * nelems > 3 * nbuckets)
209 resize(2*nbuckets-1);
210 }
211 return r;
212 }
213
214 END_ANONYMOUS_NAMESPACE
215
216 static symtable_t *symbols;
217
218 const char *
miniexp_to_name(miniexp_t p)219 miniexp_to_name(miniexp_t p)
220 {
221 if (miniexp_symbolp(p))
222 {
223 struct symtable_t::sym *r;
224 r = ((symtable_t::sym*)(((size_t)p)&~((size_t)3)));
225 return (r && r->v == p) ? r->n : "##(dummy)";
226 }
227 return 0;
228 }
229
230 miniexp_t
miniexp_symbol(const char * name)231 miniexp_symbol(const char *name)
232 {
233 struct symtable_t::sym *r;
234 if (! symbols)
235 {
236 CSLOCK(lock);
237 if (! symbols)
238 symbols = new symtable_t;
239 }
240 r = symbols->lookup(name, true);
241 return r->v;
242 }
243
244
245 /* -------------------------------------------------- */
246 /* MEMORY AND GARBAGE COLLECTION */
247 /* -------------------------------------------------- */
248
249 // A simple mark-and-sweep garbage collector.
250 //
251 // Memory is managed in chunks of nptrs_chunk pointers.
252 // The first two pointers are used to hold mark bytes for the rest.
253 // Chunks are carved from blocks of nptrs_block pointers.
254 //
255 // Dirty hack: The sixteen most recently created pairs are
256 // not destroyed by automatic garbage collection, in order
257 // to preserve transient objects created in the course
258 // of evaluating complicated expressions.
259
260 #define nptrs_chunk (4*sizeof(void*))
261 #define sizeof_chunk (nptrs_chunk*sizeof(void*))
262 #define nptrs_block (16384-8)
263 #define recentlog (4)
264 #define recentsize (1<<recentlog)
265
266 BEGIN_ANONYMOUS_NAMESPACE
267
268 struct gctls_t {
269 gctls_t *next;
270 gctls_t **pprev;
271 void **recent[recentsize];
272 int recentindex;
273 gctls_t();
274 ~gctls_t();
275 };
276
277 struct block_t
278 {
279 block_t *next;
280 void **lo;
281 void **hi;
282 void *ptrs[nptrs_block];
283 };
284
285 static struct {
286 int lock;
287 int request;
288 int debug;
289 int pairs_total;
290 int pairs_free;
291 void **pairs_freelist;
292 block_t *pairs_blocks;
293 int objs_total;
294 int objs_free;
295 void **objs_freelist;
296 block_t *objs_blocks;
297 gctls_t *tls;
298 } gc;
299
gctls_t()300 gctls_t::gctls_t()
301 {
302 // CSLOCK(locker); [already locked]
303 recentindex = 0;
304 for (int i=0; i<recentsize; i++)
305 recent[i] = 0;
306 if ((next = gc.tls))
307 next->pprev = &next;
308 pprev = &gc.tls;
309 gc.tls = this;
310 //fprintf(stderr,"Created gctls %p\n", this);
311 }
312
~gctls_t()313 gctls_t::~gctls_t()
314 {
315 //CSLOCK(locker); [already locked]
316 //fprintf(stderr,"Deleting gctls %p\n", this);
317 if ((*pprev = next))
318 next->pprev = pprev;
319 }
320
321 END_ANONYMOUS_NAMESPACE
322
323 #if USE_PTHREADS
324
325 // Manage thread specific data with pthreads
326 static pthread_key_t gctls_key;
327 static pthread_once_t gctls_once;
gctls_destroy(void * arg)328 static void gctls_destroy(void* arg) {
329 CSLOCK(locker); delete (gctls_t*)arg;
330 }
gctls_key_alloc()331 static void gctls_key_alloc() {
332 pthread_key_create(&gctls_key, gctls_destroy);
333 }
334 # if HAVE_GCCTLS
335 static __thread gctls_t *gctls_tv = 0;
gctls_alloc()336 static void gctls_alloc() {
337 pthread_once(&gctls_once, gctls_key_alloc);
338 gctls_tv = new gctls_t();
339 pthread_setspecific(gctls_key, (void*)gctls_tv);
340 }
gctls()341 static gctls_t *gctls() {
342 if (! gctls_tv) gctls_alloc();
343 return gctls_tv;
344 }
345 # else
gctls_alloc()346 static gctls_t *gctls_alloc() {
347 gctls_t *res = new gctls_t();
348 pthread_setspecific(gctls_key, (void*)res);
349 return res;
350 }
gctls()351 static gctls_t *gctls() {
352 pthread_once(&gctls_once, gctls_key_alloc);
353 void *arg = pthread_getspecific(gctls_key);
354 return (arg) ? (gctls_t*)(arg) : gctls_alloc();
355 }
356 # endif
357
358 #elif USE_WINTHREADS
359
360 // Manage thread specific data with win32
361 #if defined(_MSC_VER) && defined(USE_MSVC_TLS)
362 // -- Pre-vista os sometimes crashes on this.
363 static __declspec(thread) gctls_t *gctls_tv = 0;
364 static gctls_t *gctls() {
365 if (! gctls_tv) gctls_tv = new gctls_t();
366 return gctls_tv;
367 }
368 static void NTAPI gctls_cb(PVOID, DWORD dwReason, PVOID) {
369 if (dwReason == DLL_THREAD_DETACH && gctls_tv)
370 { CSLOCK(locker); delete gctls_tv; gctls_tv=0; } }
371 # else
372 // -- Using Tls{Alloc,SetValue,GetValue,Free} instead.
373 static DWORD tlsIndex = TLS_OUT_OF_INDEXES;
374 static gctls_t *gctls() {
375 if (tlsIndex == TLS_OUT_OF_INDEXES) tlsIndex = TlsAlloc();
376 ASSERT(tlsIndex != TLS_OUT_OF_INDEXES);
377 gctls_t *addr = (gctls_t*)TlsGetValue(tlsIndex);
378 if (! addr) TlsSetValue(tlsIndex, (LPVOID)(addr = new gctls_t()));
379 ASSERT(addr != 0);
380 return addr;
381 }
382 static void NTAPI gctls_cb(PVOID, DWORD dwReason, PVOID) {
383 if (dwReason == DLL_THREAD_DETACH && tlsIndex != TLS_OUT_OF_INDEXES)
384 {CSLOCK(r);delete(gctls_t*)TlsGetValue(tlsIndex);TlsSetValue(tlsIndex,0);}
385 if (dwReason == DLL_PROCESS_DETACH && tlsIndex != TLS_OUT_OF_INDEXES)
386 {CSLOCK(r);TlsFree(tlsIndex);tlsIndex=TLS_OUT_OF_INDEXES;}
387 }
388 # endif
389 // -- Very black magic to clean the TLS variables
390 # if !defined(_MSC_VER)
391 # warning "This only works with MSVC. Memory leak otherwise"
392 # elif !defined(MINILISPAPI_EXPORT)
393 # pragma message("This only works for a DLL. Memory leak otherwise")
394 # else
395 # ifdef _M_IX86
396 # pragma comment (linker, "/INCLUDE:_tlscb")
397 # else
398 # pragma comment (linker, "/INCLUDE:tlscb")
399 # endif
400 # pragma const_seg(".CRT$XLB")
401 extern "C" PIMAGE_TLS_CALLBACK tlscb = gctls_cb;
402 # pragma const_seg()
403 # endif
404
405 #else
406
407 // No threads
408 static gctls_t *gctls() {
409 static gctls_t g;
410 return &g;
411 }
412
413 #endif
414
415 static inline char *
markbase(void ** p)416 markbase(void **p)
417 {
418 return (char*)(((size_t)p) & ~(sizeof_chunk-1));
419 }
420
421 static inline char *
markbyte(void ** p)422 markbyte(void **p)
423 {
424 char *base = markbase(p);
425 return base + ((p - (void**)base)>>1);
426 }
427
428 static block_t *
new_block(void)429 new_block(void)
430 {
431 block_t *b = new block_t;
432 memset(b, 0, sizeof(block_t));
433 b->lo = (void**)markbase(b->ptrs+nptrs_chunk-1);
434 b->hi = (void**)markbase(b->ptrs+nptrs_block);
435 return b;
436 }
437
438 static void
clear_marks(block_t * b)439 clear_marks(block_t *b)
440 {
441 for (void** m=b->lo; m<b->hi; m+=nptrs_chunk)
442 m[0] = m[1] = 0;
443 }
444
445 static void
collect_free(block_t * b,void ** & freelist,int & count,bool destroy)446 collect_free(block_t *b, void **&freelist, int &count, bool destroy)
447 {
448 for (void **m=b->lo; m<b->hi; m+=nptrs_chunk)
449 {
450 char *c = (char*)m;
451 for (unsigned int i=1; i<nptrs_chunk/2; i++)
452 if (! c[i])
453 {
454 miniobj_t *obj = (miniobj_t*)m[i+i];
455 if (destroy && obj && m[i+i]==m[i+i+1])
456 obj->destroy();
457 m[i+i] = (void*)freelist;
458 m[i+i+1] = 0;
459 freelist = &m[i+i];
460 count += 1;
461 }
462 }
463 }
464
465 static void
new_pair_block(void)466 new_pair_block(void)
467 {
468 int count = 0;
469 block_t *b = new_block();
470 b->next = gc.pairs_blocks;
471 gc.pairs_blocks = b;
472 clear_marks(b);
473 collect_free(b, gc.pairs_freelist, count, false);
474 gc.pairs_total += count;
475 gc.pairs_free += count;
476 }
477
478 static void
new_obj_block(void)479 new_obj_block(void)
480 {
481 int count = 0;
482 block_t *b = new_block();
483 b->next = gc.objs_blocks;
484 gc.objs_blocks = b;
485 clear_marks(b);
486 collect_free(b, gc.objs_freelist, count, false);
487 gc.objs_total += count;
488 gc.objs_free += count;
489 }
490
491 #if defined(__GNUC__) && (__GNUC__ >= 3)
492 static void gc_mark_object(void **v) __attribute__((noinline));
493 #else
494 static void gc_mark_object(void **v);
495 #endif
496
497 static bool
gc_mark_check(void * p)498 gc_mark_check(void *p)
499 {
500 if (((size_t)p) & 2)
501 return false;
502 void **v = (void**)(((size_t)p) & ~(size_t)3);
503 if (! v)
504 return false;
505 char *m = markbyte(v);
506 if (*m)
507 return false;
508 *m = 1;
509 if (! (((size_t)p) & 1))
510 return true;
511 gc_mark_object((void**)v);
512 return false;
513 }
514
515 static void
gc_mark_pair(void ** v)516 gc_mark_pair(void **v)
517 {
518 // This is a simple recursive code.
519 // Despite the tail recursion for the cdrs,
520 // it consume a stack space that grows like
521 // the longest chain of cars.
522 for(;;)
523 {
524 if (gc_mark_check(v[0]))
525 gc_mark_pair((void**)v[0]);
526 if (! gc_mark_check(v[1]))
527 break;
528 v = (void**)v[1];
529 }
530 }
531
532 static void
gc_mark(miniexp_t * pp)533 gc_mark(miniexp_t *pp)
534 {
535 void **v = (void**)*pp;
536 if (gc_mark_check((void**)*pp))
537 gc_mark_pair(v);
538 }
539
540 static void
gc_mark_object(void ** v)541 gc_mark_object(void **v)
542 {
543 ASSERT(v[0] == v[1]);
544 miniobj_t *obj = (miniobj_t*)v[0];
545 if (obj)
546 obj->mark(gc_mark);
547 }
548
549 static void
gc_run(void)550 gc_run(void)
551 {
552 gc.request++;
553 if (gc.lock == 0)
554 {
555 block_t *b;
556 gc.request = 0;
557 // clear marks
558 for (b=gc.objs_blocks; b; b=b->next)
559 clear_marks(b);
560 for (b=gc.pairs_blocks; b; b=b->next)
561 clear_marks(b);
562 // mark recents
563 for (gctls_t *tls = gc.tls; tls; tls=tls->next)
564 for (int i=0; i<recentsize; i++)
565 gc_mark((miniexp_t*)(char*)&(tls->recent[i]));
566 // mark roots
567 minivar_t::mark(gc_mark);
568 // sweep
569 gc.objs_free = gc.pairs_free = 0;
570 gc.objs_freelist = gc.pairs_freelist = 0;
571 for (b=gc.objs_blocks; b; b=b->next)
572 collect_free(b, gc.objs_freelist, gc.objs_free, true);
573 for (b=gc.pairs_blocks; b; b=b->next)
574 collect_free(b, gc.pairs_freelist, gc.pairs_free, false);
575 // alloc 33% extra space
576 while (gc.objs_free*4 < gc.objs_total)
577 new_obj_block();
578 while (gc.pairs_free*4 < gc.pairs_total)
579 new_pair_block();
580 }
581 }
582
583 static void **
gc_alloc_pair(void * a,void * d)584 gc_alloc_pair(void *a, void *d)
585 {
586 if (!gc.pairs_freelist)
587 {
588 gc_run();
589 if (!gc.pairs_freelist)
590 new_pair_block();
591 }
592 else if (gc.debug)
593 gc_run();
594 void **p = gc.pairs_freelist;
595 gc.pairs_freelist = (void**)p[0];
596 gc.pairs_free -= 1;
597 p[0] = a;
598 p[1] = d;
599 return p;
600 }
601
602 static void **
gc_alloc_object(void * obj)603 gc_alloc_object(void *obj)
604 {
605 if (!gc.objs_freelist)
606 {
607 gc_run();
608 if (!gc.objs_freelist)
609 new_obj_block();
610 }
611 else if (gc.debug)
612 gc_run();
613 void **p = gc.objs_freelist;
614 gc.objs_freelist = (void**)p[0];
615 gc.objs_free -= 1;
616 p[0] = p[1] = obj;
617 return p;
618 }
619
620
621
622
623
624 /* ---- USER FUNCTIONS --- */
625
626 miniexp_t
minilisp_acquire_gc_lock(miniexp_t x)627 minilisp_acquire_gc_lock(miniexp_t x)
628 {
629 CSLOCK(locker);
630 gc.lock++;
631 return x;
632 }
633
634 miniexp_t
minilisp_release_gc_lock(miniexp_t x)635 minilisp_release_gc_lock(miniexp_t x)
636 {
637 minivar_t v = x;
638 {
639 CSLOCK(locker);
640 if (gc.lock > 0)
641 if (--gc.lock == 0)
642 if (gc.request > 0)
643 gc_run();
644 }
645 return x;
646 }
647
648 void
minilisp_gc(void)649 minilisp_gc(void)
650 {
651 CSLOCK(locker);
652 for (gctls_t *tls = gc.tls; tls; tls=tls->next)
653 for (int i=0; i<recentsize; i++)
654 tls->recent[i] = 0;
655 gc_run();
656 }
657
658 void
minilisp_debug(int debug)659 minilisp_debug(int debug)
660 {
661 gc.debug = debug;
662 }
663
664 void
minilisp_info(void)665 minilisp_info(void)
666 {
667 CSLOCK(locker);
668 time_t tim = time(0);
669 const char *dat = ctime(&tim);
670 printf("--- begin info -- %s", dat);
671 printf("symbols: %d symbols in %d buckets\n",
672 symbols->nelems, symbols->nbuckets);
673 if (gc.debug)
674 printf("gc.debug: true\n");
675 if (gc.lock)
676 printf("gc.locked: true, %d requests\n", gc.request);
677 printf("gc.pairs: %d free, %d total\n", gc.pairs_free, gc.pairs_total);
678 printf("gc.objects: %d free, %d total\n", gc.objs_free, gc.objs_total);
679 printf("--- end info -- %s", dat);
680 }
681
682 miniexp_t
miniexp_mutate(miniexp_t,miniexp_t * var,miniexp_t val)683 miniexp_mutate(miniexp_t, miniexp_t *var, miniexp_t val)
684 {
685 CSLOCK(locker);
686 *var = val;
687 return val;
688 }
689
690
691 /* -------------------------------------------------- */
692 /* MINIVARS */
693 /* -------------------------------------------------- */
694
minivar_t()695 minivar_t::minivar_t()
696 : data(0)
697 {
698 CSLOCK(locker);
699 if ((next = vars))
700 next->pprev = &next;
701 pprev = &vars;
702 vars = this;
703 }
704
minivar_t(miniexp_t p)705 minivar_t::minivar_t(miniexp_t p)
706 : data(p)
707 {
708 CSLOCK(locker);
709 if ((next = vars))
710 next->pprev = &next;
711 pprev = &vars;
712 vars = this;
713 }
714
minivar_t(const minivar_t & v)715 minivar_t::minivar_t(const minivar_t &v)
716 : data(v.data)
717 {
718 CSLOCK(locker);
719 if ((next = vars))
720 next->pprev = &next;
721 pprev = &vars;
722 vars = this;
723 }
724
~minivar_t()725 minivar_t::~minivar_t()
726 {
727 CSLOCK(locker);
728 if ((*pprev = next))
729 next->pprev = pprev;
730 }
731
732 minivar_t *minivar_t::vars = 0;
733
734 void
mark(minilisp_mark_t * f)735 minivar_t::mark(minilisp_mark_t *f)
736 {
737 for (minivar_t *v = vars; v; v=v->next)
738 (*f)(&v->data);
739 }
740
741 minivar_t *
minivar_alloc(void)742 minivar_alloc(void)
743 {
744 return new minivar_t;
745 }
746
747 void
minivar_free(minivar_t * v)748 minivar_free(minivar_t *v)
749 {
750 delete v;
751 }
752
753 miniexp_t *
minivar_pointer(minivar_t * v)754 minivar_pointer(minivar_t *v)
755 {
756 return &(*v);
757 }
758
759
760 /* -------------------------------------------------- */
761 /* LISTS */
762 /* -------------------------------------------------- */
763
764 static inline miniexp_t &
car(miniexp_t p)765 car(miniexp_t p) {
766 return ((miniexp_t*)p)[0];
767 }
768
769 static inline miniexp_t &
cdr(miniexp_t p)770 cdr(miniexp_t p) {
771 return ((miniexp_t*)p)[1];
772 }
773
774 int
miniexp_length(miniexp_t p)775 miniexp_length(miniexp_t p)
776 {
777 int n = 0;
778 bool toggle = false;
779 miniexp_t q = p;
780 while (miniexp_consp(p))
781 {
782 p = cdr(p);
783 if (p == q)
784 return -1;
785 if ((toggle = !toggle))
786 q = cdr(q);
787 n += 1;
788 }
789 return n;
790 }
791
792 miniexp_t
miniexp_caar(miniexp_t p)793 miniexp_caar(miniexp_t p)
794 {
795 return miniexp_car(miniexp_car(p));
796 }
797
798 miniexp_t
miniexp_cadr(miniexp_t p)799 miniexp_cadr(miniexp_t p)
800 {
801 return miniexp_car(miniexp_cdr(p));
802 }
803
804 miniexp_t
miniexp_cdar(miniexp_t p)805 miniexp_cdar(miniexp_t p)
806 {
807 return miniexp_cdr(miniexp_car(p));
808 }
809
810 miniexp_t
miniexp_cddr(miniexp_t p)811 miniexp_cddr(miniexp_t p)
812 {
813 return miniexp_cdr(miniexp_cdr(p));
814 }
815
816 miniexp_t
miniexp_caddr(miniexp_t p)817 miniexp_caddr(miniexp_t p)
818 {
819 return miniexp_car(miniexp_cdr(miniexp_cdr(p)));
820 }
821
822 miniexp_t
miniexp_cdddr(miniexp_t p)823 miniexp_cdddr(miniexp_t p)
824 {
825 return miniexp_cdr(miniexp_cdr(miniexp_cdr(p)));
826 }
827
828 miniexp_t
miniexp_nth(int n,miniexp_t l)829 miniexp_nth(int n, miniexp_t l)
830 {
831 while (--n>=0 && miniexp_consp(l))
832 l = cdr(l);
833 return miniexp_car(l);
834 }
835
836 miniexp_t
miniexp_cons(miniexp_t a,miniexp_t d)837 miniexp_cons(miniexp_t a, miniexp_t d)
838 {
839 CSLOCK(locker);
840 miniexp_t r = (miniexp_t)gc_alloc_pair((void*)a, (void*)d);
841 gctls_t *tls = gctls();
842 tls->recent[(++(tls->recentindex)) & (recentsize-1)] = (void**)r;
843 return r;
844 }
845
846 miniexp_t
miniexp_rplaca(miniexp_t pair,miniexp_t newcar)847 miniexp_rplaca(miniexp_t pair, miniexp_t newcar)
848 {
849 if (miniexp_consp(pair))
850 return miniexp_mutate(pair, &car(pair), newcar);
851 return 0;
852 }
853
854 miniexp_t
miniexp_rplacd(miniexp_t pair,miniexp_t newcdr)855 miniexp_rplacd(miniexp_t pair, miniexp_t newcdr)
856 {
857 if (miniexp_consp(pair))
858 return miniexp_mutate(pair, &cdr(pair), newcdr);
859 return 0;
860 }
861
862 miniexp_t
miniexp_reverse(miniexp_t p)863 miniexp_reverse(miniexp_t p)
864 {
865 miniexp_t l = 0;
866 while (miniexp_consp(p))
867 {
868 miniexp_t q = cdr(p);
869 miniexp_mutate(p, &cdr(p), l);
870 l = p;
871 p = q;
872 }
873 return l;
874 }
875
876
877 /* -------------------------------------------------- */
878 /* MINIOBJ */
879 /* -------------------------------------------------- */
880
~miniobj_t()881 miniobj_t::~miniobj_t()
882 {
883 }
884
885 const miniexp_t miniobj_t::classname = 0;
886
887 bool
isa(miniexp_t) const888 miniobj_t::isa(miniexp_t) const
889 {
890 return false;
891 }
892
893 void
mark(minilisp_mark_t *)894 miniobj_t::mark(minilisp_mark_t*)
895 {
896 }
897
898 void
destroy()899 miniobj_t::destroy()
900 {
901 delete this;
902 }
903
904 char *
pname() const905 miniobj_t::pname() const
906 {
907 const char *cname = miniexp_to_name(classof());
908 char *res = new char[strlen(cname)+24];
909 sprintf(res,"#%s:<%p>",cname,this);
910 return res;
911 }
912
913 bool
stringp(const char * &,size_t &) const914 miniobj_t::stringp(const char* &, size_t &) const
915 {
916 return false;
917 }
918
919 bool
doublep(double &) const920 miniobj_t::doublep(double&) const
921 {
922 return false;
923 }
924
925 miniexp_t
miniexp_object(miniobj_t * obj)926 miniexp_object(miniobj_t *obj)
927 {
928 CSLOCK(locker);
929 void **v = gc_alloc_object((void*)obj);
930 v = (void**)(((size_t)v)|((size_t)1));
931 gctls_t *tls = gctls();
932 tls->recent[(++(tls->recentindex)) & (recentsize-1)] = (void**)v;
933 return (miniexp_t)(v);
934 }
935
936 miniexp_t
miniexp_classof(miniexp_t p)937 miniexp_classof(miniexp_t p)
938 {
939 miniobj_t *obj = miniexp_to_obj(p);
940 if (obj) return obj->classof();
941 return miniexp_nil;
942 }
943
944 miniexp_t
miniexp_isa(miniexp_t p,miniexp_t c)945 miniexp_isa(miniexp_t p, miniexp_t c)
946 {
947 miniobj_t *obj = miniexp_to_obj(p);
948 if (obj && obj->isa(c))
949 return obj->classof();
950 return miniexp_nil;
951 }
952
953
954 /* -------------------------------------------------- */
955 /* STRINGS */
956 /* -------------------------------------------------- */
957
958 BEGIN_ANONYMOUS_NAMESPACE
959
960 class ministring_t : public miniobj_t
961 {
962 MINIOBJ_DECLARE(ministring_t,miniobj_t,"string");
963 public:
964 ~ministring_t();
965 ministring_t(size_t len, const char *s);
966 ministring_t(size_t len, char *s, bool steal);
operator const char*() const967 operator const char*() const { return s; }
968 virtual bool stringp(const char* &s, size_t &l) const;
969 private:
970 char *s;
971 size_t l;
972 private:
973 ministring_t(const ministring_t &);
974 ministring_t& operator=(const ministring_t &);
975 };
976
977 MINIOBJ_IMPLEMENT(ministring_t,miniobj_t,"string");
978
~ministring_t()979 ministring_t::~ministring_t()
980 {
981 delete [] s;
982 }
983
ministring_t(size_t len,const char * str)984 ministring_t::ministring_t(size_t len, const char *str)
985 : s(0), l(len)
986 {
987 s = new char[l+1];
988 memcpy(s, str, l);
989 s[l] = 0;
990 }
991
ministring_t(size_t len,char * str,bool steal)992 ministring_t::ministring_t(size_t len, char *str, bool steal)
993 : s(str), l(len)
994 {
995 ASSERT(steal);
996 }
997
998 bool
stringp(const char * & rs,size_t & rl) const999 ministring_t::stringp(const char* &rs, size_t &rl) const
1000 {
1001 rs = s;
1002 rl = l;
1003 return true;
1004 }
1005
1006
1007 END_ANONYMOUS_NAMESPACE
1008
1009 static bool
char_quoted(int c,int flags)1010 char_quoted(int c, int flags)
1011 {
1012 bool print7bits = (flags & miniexp_io_print7bits);
1013 if (c>=0x80 && !print7bits)
1014 return false;
1015 if (c==0x7f || c=='\"' || c=='\\')
1016 return true;
1017 if (c>=0x20 && c<0x7f)
1018 return false;
1019 return true;
1020 }
1021
1022 static bool
char_utf8(int & c,const char * & s,size_t & len)1023 char_utf8(int &c, const char* &s, size_t &len)
1024 {
1025 if (c < 0xc0)
1026 return (c < 0x80);
1027 if (c >= 0xf8)
1028 return false;
1029 int n = (c < 0xe0) ? 1 : (c < 0xf0) ? 2 : 3;
1030 if ((size_t)n > len)
1031 return false;
1032 int x = c & (0x3f >> n);
1033 for (int i=0; i<n; i++)
1034 if ((s[i] & 0xc0) == 0x80)
1035 x = (x << 6) + (s[i] & 0x3f);
1036 else
1037 return false;
1038 static int lim[] = {0, 0x80, 0x800, 0x10000};
1039 if (x < lim[n])
1040 return false;
1041 if (x > 0x10ffff)
1042 return false;
1043 if (x >= 0xd800 && x <= 0xdfff)
1044 return false;
1045 len -= n;
1046 s += n;
1047 c = x;
1048 return true;
1049 }
1050
1051 static void
char_out(int c,char * & d,int & n)1052 char_out(int c, char* &d, int &n)
1053 {
1054 n++;
1055 if (d)
1056 *d++ = c;
1057 }
1058
1059 static int
print_c_string(const char * s,char * d,int flags,size_t len)1060 print_c_string(const char *s, char *d, int flags, size_t len)
1061 {
1062 int c;
1063 int n = 0;
1064 char_out('\"', d, n);
1065 while (len-- > 0)
1066 {
1067 c = (unsigned char)(*s++);
1068 if (char_quoted(c, flags))
1069 {
1070 char buffer[16]; /* 10+1 */
1071 static const char *tr1 = "\"\\tnrbf";
1072 static const char *tr2 = "\"\\\t\n\r\b\f";
1073 buffer[0] = buffer[1] = 0;
1074 char_out('\\', d, n);
1075 for (int i=0; tr2[i]; i++)
1076 if (c == tr2[i])
1077 buffer[0] = tr1[i];
1078 if (buffer[0] == 0 && c >= 0x80
1079 && (flags & (miniexp_io_u4escape | miniexp_io_u6escape))
1080 && char_utf8(c, s, len) )
1081 {
1082 if (c <= 0xffff && (flags & miniexp_io_u4escape))
1083 sprintf(buffer,"u%04X", c);
1084 else if (flags & miniexp_io_u6escape) // c# style
1085 sprintf(buffer,"U%06X", c);
1086 else if (flags & miniexp_io_u4escape) // json style
1087 sprintf(buffer,"u%04X\\u%04X",
1088 0xd800+(((c-0x10000)>>10)&0x3ff),
1089 0xdc00+(c&0x3ff));
1090 }
1091 if (buffer[0] == 0 && c == 0)
1092 if (*s < '0' || *s > '7')
1093 buffer[0] = '0';
1094 if (buffer[0] == 0)
1095 sprintf(buffer, "%03o", c);
1096 for (int i=0; buffer[i]; i++)
1097 char_out(buffer[i], d, n);
1098 continue;
1099 }
1100 char_out(c, d, n);
1101 }
1102 char_out('\"', d, n);
1103 char_out(0, d, n);
1104 return n;
1105 }
1106
1107 int
miniexp_stringp(miniexp_t p)1108 miniexp_stringp(miniexp_t p)
1109 {
1110 const char *s; size_t l;
1111 if (miniexp_objectp(p) && miniexp_to_obj(p)->stringp(s,l))
1112 return 1;
1113 return 0;
1114 }
1115
1116 const char *
miniexp_to_str(miniexp_t p)1117 miniexp_to_str(miniexp_t p)
1118 {
1119 const char *s = 0;
1120 miniexp_to_lstr(p, &s);
1121 return s;
1122 }
1123
1124 size_t
miniexp_to_lstr(miniexp_t p,const char ** sp)1125 miniexp_to_lstr(miniexp_t p, const char **sp)
1126 {
1127 const char *s = 0;
1128 size_t l = 0;
1129 if (miniexp_objectp(p))
1130 miniexp_to_obj(p)->stringp(s,l);
1131 if (sp)
1132 *sp = s;
1133 return l;
1134 }
1135
1136 miniexp_t
miniexp_string(const char * s)1137 miniexp_string(const char *s)
1138 {
1139 return miniexp_lstring(strlen(s), s);
1140 }
1141
1142 miniexp_t
miniexp_lstring(size_t len,const char * s)1143 miniexp_lstring(size_t len, const char *s)
1144 {
1145 ministring_t *obj = new ministring_t(len,s);
1146 return miniexp_object(obj);
1147 }
1148
1149 miniexp_t
miniexp_substring(const char * s,int len)1150 miniexp_substring(const char *s, int len)
1151 {
1152 size_t l = strlen(s);
1153 size_t n = (size_t)len;
1154 return miniexp_lstring((l < n) ? l : n, s);
1155 }
1156
1157 miniexp_t
miniexp_concat(miniexp_t p)1158 miniexp_concat(miniexp_t p)
1159 {
1160 miniexp_t l = p;
1161 const char *s;
1162 size_t n = 0;
1163 if (miniexp_length(l) < 0)
1164 return miniexp_nil;
1165 for (p=l; miniexp_consp(p); p=cdr(p))
1166 n += miniexp_to_lstr(car(p), 0);
1167 char *b = new char[n+1];
1168 char *d = b;
1169 for (p=l; miniexp_consp(p); p=cdr(p))
1170 if ((n = miniexp_to_lstr(car(p), &s))) {
1171 memcpy(d, s, n);
1172 d += n;
1173 }
1174 ministring_t *obj = new ministring_t(d-b, b, true);
1175 return miniexp_object(obj);
1176 }
1177
1178
1179 /* -------------------------------------------------- */
1180 /* FLOATNUMS */
1181 /* -------------------------------------------------- */
1182
1183
1184 BEGIN_ANONYMOUS_NAMESPACE
1185
1186 class minifloat_t : public miniobj_t
1187 {
1188 MINIOBJ_DECLARE(minifloat_t,miniobj_t,"floatnum");
1189 public:
minifloat_t(double x)1190 minifloat_t(double x) : val(x) {}
operator double() const1191 operator double() const { return val; }
1192 virtual char *pname() const;
doublep(double & d) const1193 virtual bool doublep(double &d) const { d=val; return true; }
1194 private:
1195 double val;
1196 };
1197
1198
1199 MINIOBJ_IMPLEMENT(minifloat_t,miniobj_t,"floatnum");
1200
1201 END_ANONYMOUS_NAMESPACE
1202
1203 int
miniexp_floatnump(miniexp_t p)1204 miniexp_floatnump(miniexp_t p)
1205 {
1206 return miniexp_isa(p, minifloat_t::classname) ? 1 : 0;
1207 }
1208
1209 miniexp_t
miniexp_floatnum(double x)1210 miniexp_floatnum(double x)
1211 {
1212 minifloat_t *obj = new minifloat_t(x);
1213 return miniexp_object(obj);
1214 }
1215
1216 int
miniexp_doublep(miniexp_t p)1217 miniexp_doublep(miniexp_t p)
1218 {
1219 double v = 0.0;
1220 if (miniexp_numberp(p) ||
1221 (miniexp_objectp(p) && miniexp_to_obj(p)->doublep(v)) )
1222 return 1;
1223 return 0;
1224 }
1225
1226 double
miniexp_to_double(miniexp_t p)1227 miniexp_to_double(miniexp_t p)
1228 {
1229 double v = 0.0;
1230 if (miniexp_numberp(p))
1231 v = (double) miniexp_to_int(p);
1232 else if (miniexp_objectp(p))
1233 miniexp_to_obj(p)->doublep(v);
1234 return v;
1235 }
1236
1237 miniexp_t
miniexp_double(double x)1238 miniexp_double(double x)
1239 {
1240 miniexp_t exp = miniexp_number((int)(x));
1241 if (x != (double)miniexp_to_int(exp))
1242 exp = miniexp_floatnum(x);
1243 return exp;
1244 }
1245
1246 static bool
str_looks_like_double(const char * s)1247 str_looks_like_double(const char *s)
1248 {
1249 if (isascii(*s) && isdigit(*s))
1250 return true;
1251 if ((s[0] == '+' || s[0] == '-') && s[1])
1252 return true;
1253 return false;
1254 }
1255
1256 char *
pname() const1257 minifloat_t::pname() const
1258 {
1259 char *r = new char[64];
1260 sprintf(r,"%f",val);
1261 if (! str_looks_like_double(r))
1262 sprintf(r,"+%f",val);
1263 return r;
1264 }
1265
1266 static bool
str_is_double(const char * s,double & x)1267 str_is_double(const char *s, double &x)
1268 {
1269 if (str_looks_like_double(s))
1270 {
1271 char *end;
1272 errno = 0;
1273 x = (double) strtol(s, &end, 0);
1274 if (*end == 0 && errno == 0)
1275 return true;
1276 x = (double) strtod(s, &end);
1277 if (*end == 0 && errno == 0)
1278 return true;
1279 }
1280 return false;
1281 }
1282
1283
1284
1285 /* -------------------------------------------------- */
1286 /* INPUT/OUTPUT */
1287 /* -------------------------------------------------- */
1288
true_stdio_fputs(miniexp_io_t * io,const char * s)1289 static int true_stdio_fputs(miniexp_io_t *io, const char *s) {
1290 FILE *f = (io->data[1]) ? (FILE*)(io->data[1]) : stdout;
1291 return ::fputs(s, f);
1292 }
compat_puts(const char * s)1293 static int compat_puts(const char *s) {
1294 return true_stdio_fputs(&miniexp_io, s);
1295 }
stdio_fputs(miniexp_io_t * io,const char * s)1296 static int stdio_fputs(miniexp_io_t *io, const char *s) {
1297 if (io == &miniexp_io)
1298 return (*minilisp_puts)(s);
1299 return true_stdio_fputs(io, s);
1300 }
1301
true_stdio_fgetc(miniexp_io_t * io)1302 static int true_stdio_fgetc(miniexp_io_t *io) {
1303 FILE *f = (io->data[0]) ? (FILE*)(io->data[0]) : stdin;
1304 return getc(f);
1305 }
compat_getc()1306 static int compat_getc() {
1307 return true_stdio_fgetc(&miniexp_io);
1308 }
stdio_fgetc(miniexp_io_t * io)1309 static int stdio_fgetc(miniexp_io_t *io)
1310 {
1311 if (io == &miniexp_io)
1312 return (*minilisp_getc)();
1313 return true_stdio_fgetc(io);
1314 }
1315
true_stdio_ungetc(miniexp_io_t * io,int c)1316 static int true_stdio_ungetc(miniexp_io_t *io, int c) {
1317 FILE *f = (io->data[0]) ? (FILE*)(io->data[0]) : stdin;
1318 return ::ungetc(c, f);
1319 }
compat_ungetc(int c)1320 static int compat_ungetc(int c) {
1321 return true_stdio_ungetc(&miniexp_io, c);
1322 }
stdio_ungetc(miniexp_io_t * io,int c)1323 static int stdio_ungetc(miniexp_io_t *io, int c) {
1324 if (io == &miniexp_io)
1325 return (*minilisp_ungetc)(c);
1326 return true_stdio_ungetc(io, c);
1327 }
1328
1329 extern "C"
1330 {
1331 // SunCC needs this to be defined inside extern "C" { ... }
1332 // Beware the difference between extern "C" {...} and extern "C".
1333 miniexp_t (*minilisp_macrochar_parser[128])(void);
1334 miniexp_t (*minilisp_diezechar_parser[128])(void);
1335 minivar_t minilisp_macroqueue;
1336 int minilisp_print_7bits;
1337 }
1338
1339 miniexp_io_t miniexp_io = {
1340 stdio_fputs, stdio_fgetc, stdio_ungetc, { 0, 0, 0, 0 },
1341 (int*)&minilisp_print_7bits,
1342 (miniexp_macrochar_t*)minilisp_macrochar_parser,
1343 (miniexp_macrochar_t*)minilisp_diezechar_parser,
1344 (minivar_t*)&minilisp_macroqueue,
1345 0
1346 };
1347
1348 int (*minilisp_puts)(const char *) = compat_puts;
1349 int (*minilisp_getc)(void) = compat_getc;
1350 int (*minilisp_ungetc)(int) = compat_ungetc;
1351
1352 void
miniexp_io_init(miniexp_io_t * io)1353 miniexp_io_init(miniexp_io_t *io)
1354 {
1355 io->fputs = stdio_fputs;
1356 io->fgetc = stdio_fgetc;
1357 io->ungetc = stdio_ungetc;
1358 io->data[0] = io->data[1] = io->data[2] = io->data[3] = 0;
1359 io->p_flags = (int*)&minilisp_print_7bits;;
1360 io->p_macrochar = (miniexp_macrochar_t*)minilisp_macrochar_parser;
1361 io->p_diezechar = (miniexp_macrochar_t*)minilisp_diezechar_parser;
1362 io->p_macroqueue = (minivar_t*)&minilisp_macroqueue;
1363 io->p_reserved = 0;
1364 }
1365
1366 void
miniexp_io_set_output(miniexp_io_t * io,FILE * f)1367 miniexp_io_set_output(miniexp_io_t* io, FILE *f)
1368 {
1369 io->fputs = stdio_fputs;
1370 io->data[1] = f;
1371 }
1372
1373 void
miniexp_io_set_input(miniexp_io_t * io,FILE * f)1374 miniexp_io_set_input(miniexp_io_t* io, FILE *f)
1375 {
1376 io->fgetc = stdio_fgetc;
1377 io->ungetc = stdio_ungetc;
1378 io->data[0] = f;
1379 }
1380
1381
1382 /* ---- OUTPUT */
1383
1384 BEGIN_ANONYMOUS_NAMESPACE
1385
1386 struct printer_t
1387 {
1388 int tab;
1389 bool dryrun;
1390 miniexp_io_t *io;
printer_tprinter_t1391 printer_t(miniexp_io_t *io) : tab(0), dryrun(false), io(io) {}
1392 void mlput(const char *s);
1393 void mltab(int n);
1394 void print(miniexp_t p);
1395 bool must_quote_symbol(const char *s, int flags);
1396 void mlput_quoted_symbol(const char *s);
beginprinter_t1397 virtual miniexp_t begin() { return miniexp_nil; }
newlineprinter_t1398 virtual bool newline() { return false; }
endprinter_t1399 virtual void end(miniexp_t) { }
~printer_tprinter_t1400 virtual ~printer_t() {};
1401 };
1402
1403 void
mlput(const char * s)1404 printer_t::mlput(const char *s)
1405 {
1406 if (! dryrun)
1407 io->fputs(io, s);
1408 while (*s)
1409 if (*s++ == '\n')
1410 tab = 0;
1411 else
1412 tab += 1;
1413 }
1414
1415 void
mltab(int n)1416 printer_t::mltab(int n)
1417 {
1418 while (tab+8 <= n)
1419 mlput(" ");
1420 while (tab+1 <= n)
1421 mlput(" ");
1422 }
1423
1424 bool
must_quote_symbol(const char * s,int flags)1425 printer_t::must_quote_symbol(const char *s, int flags)
1426 {
1427 int c;
1428 const char *r = s;
1429 while ((c = *r++))
1430 if (c=='(' || c==')' || c=='\"' || c=='|' ||
1431 !isascii(c) || isspace(c) || !isprint(c) ||
1432 (c >= 0 && c < 128 && io->p_macrochar && io->p_macrochar[c]) )
1433 return true;
1434 double x;
1435 if (flags & miniexp_io_quotemoresymbols)
1436 return str_looks_like_double(s);
1437 return str_is_double(s, x);
1438 }
1439
1440 void
mlput_quoted_symbol(const char * s)1441 printer_t::mlput_quoted_symbol(const char *s)
1442 {
1443 int l = strlen(s);
1444 char *r = new char[l+l+3];
1445 char *z = r;
1446 *z++ = '|';
1447 while (*s)
1448 if ((*z++ = *s++) == '|')
1449 *z++ = '|';
1450 *z++ = '|';
1451 *z++ = 0;
1452 mlput(r);
1453 delete [] r;
1454 }
1455
1456 void
print(miniexp_t p)1457 printer_t::print(miniexp_t p)
1458 {
1459 int flags = (io->p_flags) ? *io->p_flags : 0;
1460 static char buffer[32];
1461 miniexp_t b = begin();
1462 if (p == miniexp_nil)
1463 {
1464 mlput("()");
1465 }
1466 else if (miniexp_numberp(p))
1467 {
1468 sprintf(buffer, "%d", miniexp_to_int(p));
1469 mlput(buffer);
1470 }
1471 else if (miniexp_symbolp(p))
1472 {
1473 const char *s = miniexp_to_name(p);
1474 if (must_quote_symbol(s, flags))
1475 mlput_quoted_symbol(s);
1476 else
1477 mlput(s);
1478 }
1479 else if (miniexp_stringp(p))
1480 {
1481 const char *s;
1482 size_t len = miniexp_to_lstr(p, &s);
1483 int n = print_c_string(s, 0, flags, len);
1484 char *d = new char[n];
1485 if (d)
1486 print_c_string(s, d, flags, len);
1487 mlput(d);
1488 delete [] d;
1489 }
1490 else if (miniexp_objectp(p))
1491 {
1492 miniobj_t *obj = miniexp_to_obj(p);
1493 char *s = obj->pname();
1494 mlput(s);
1495 delete [] s;
1496 }
1497 else if (miniexp_listp(p))
1498 {
1499 // TODO - detect more circular structures
1500 int skip = 1;
1501 int indent = tab + 1;
1502 bool multiline = false;
1503 bool toggle = true;
1504 miniexp_t q = p;
1505 mlput("(");
1506 if (miniexp_consp(p) && miniexp_symbolp(car(p)))
1507 {
1508 skip++;
1509 indent++;
1510 }
1511 while (miniexp_consp(p))
1512 {
1513 skip -= 1;
1514 if (multiline || (newline() && skip<0 && tab>indent))
1515 {
1516 mlput("\n");
1517 mltab(indent);
1518 multiline=true;
1519 }
1520 print(car(p));
1521 if ((p = cdr(p)))
1522 mlput(" ");
1523 if ((toggle = !toggle))
1524 q = cdr(q);
1525 if (p == q)
1526 {
1527 mlput("...");
1528 p = 0;
1529 }
1530 }
1531 if (p)
1532 {
1533 skip -= 1;
1534 if (multiline || (newline() && skip<0 && tab>indent))
1535 {
1536 mlput("\n");
1537 mltab(indent);
1538 multiline=true;
1539 }
1540 mlput(". ");
1541 print(p);
1542 }
1543 if (multiline)
1544 mlput(" )");
1545 else
1546 mlput(")");
1547 }
1548 end(b);
1549 }
1550
1551 struct pprinter_t : public printer_t
1552 {
1553 int width;
1554 minivar_t l;
pprinter_tpprinter_t1555 pprinter_t(miniexp_io_t *io) : printer_t(io) {}
1556 virtual miniexp_t begin();
1557 virtual bool newline();
1558 virtual void end(miniexp_t);
1559 };
1560
1561 miniexp_t
begin()1562 pprinter_t::begin()
1563 {
1564 if (dryrun)
1565 {
1566 l = miniexp_cons(miniexp_number(tab), l);
1567 return l;
1568 }
1569 else
1570 {
1571 ASSERT(miniexp_consp(l));
1572 ASSERT(miniexp_numberp(car(l)));
1573 l = cdr(l);
1574 return miniexp_nil;
1575 }
1576 }
1577
1578 bool
newline()1579 pprinter_t::newline()
1580 {
1581 if (! dryrun)
1582 {
1583 ASSERT(miniexp_consp(l));
1584 ASSERT(miniexp_numberp(car(l)));
1585 int len = miniexp_to_int(car(l));
1586 if (tab + len >= width)
1587 return true;
1588 }
1589 return false;
1590 }
1591
1592 void
end(miniexp_t p)1593 pprinter_t::end(miniexp_t p)
1594 {
1595 if (dryrun)
1596 {
1597 ASSERT(miniexp_consp(p));
1598 ASSERT(miniexp_numberp(car(p)));
1599 int pos = miniexp_to_int(car(p));
1600 ASSERT(tab >= pos);
1601 miniexp_rplaca(p, miniexp_number(tab - pos));
1602 }
1603 }
1604
1605 END_ANONYMOUS_NAMESPACE
1606
1607 miniexp_t
miniexp_prin_r(miniexp_io_t * io,miniexp_t p)1608 miniexp_prin_r(miniexp_io_t *io, miniexp_t p)
1609 {
1610 minivar_t xp = p;
1611 printer_t printer(io);
1612 printer.print(p);
1613 return p;
1614 }
1615
1616 miniexp_t
miniexp_print_r(miniexp_io_t * io,miniexp_t p)1617 miniexp_print_r(miniexp_io_t *io, miniexp_t p)
1618 {
1619 minivar_t xp = p;
1620 miniexp_prin_r(io, p);
1621 io->fputs(io, "\n");
1622 return p;
1623 }
1624
1625 miniexp_t
miniexp_pprin_r(miniexp_io_t * io,miniexp_t p,int width)1626 miniexp_pprin_r(miniexp_io_t *io, miniexp_t p, int width)
1627 {
1628 minivar_t xp = p;
1629 pprinter_t printer(io);
1630 printer.width = width;
1631 // step1 - measure lengths into list <l>
1632 printer.tab = 0;
1633 printer.dryrun = true;
1634 printer.print(p);
1635 // step2 - print
1636 printer.tab = 0;
1637 printer.dryrun = false;
1638 printer.l = miniexp_reverse(printer.l);
1639 printer.print(p);
1640 // check
1641 ASSERT(printer.l == 0);
1642 return p;
1643 }
1644
1645 miniexp_t
miniexp_pprint_r(miniexp_io_t * io,miniexp_t p,int width)1646 miniexp_pprint_r(miniexp_io_t *io, miniexp_t p, int width)
1647 {
1648 miniexp_pprin_r(io, p, width);
1649 io->fputs(io, "\n");
1650 return p;
1651 }
1652
1653
1654 /* ---- PNAME */
1655
1656 static int
pname_fputs(miniexp_io_t * io,const char * s)1657 pname_fputs(miniexp_io_t *io, const char *s)
1658 {
1659 char *b = (char*)(io->data[0]);
1660 size_t l = (size_t)(io->data[2]);
1661 size_t m = (size_t)(io->data[3]);
1662 size_t x = strlen(s);
1663 if (l + x >= m)
1664 {
1665 size_t nm = l + x + 256;
1666 char *nb = new char[nm+1];
1667 memcpy(nb, b, l);
1668 delete [] b;
1669 b = nb;
1670 m = nm;
1671 }
1672 strcpy(b + l, s);
1673 io->data[0] = (void*)(b);
1674 io->data[2] = (void*)(l + x);
1675 io->data[3] = (void*)(m);
1676 return x;
1677 }
1678
1679 miniexp_t
miniexp_pname(miniexp_t p,int width)1680 miniexp_pname(miniexp_t p, int width)
1681 {
1682 minivar_t r;
1683 miniexp_io_t io;
1684 miniexp_io_init(&io);
1685 io.fputs = pname_fputs;
1686 io.data[0] = io.data[2] = io.data[3] = 0;
1687 try
1688 {
1689 if (width > 0)
1690 miniexp_pprin_r(&io, p, width);
1691 else
1692 miniexp_prin_r(&io, p);
1693 if (io.data[0])
1694 r = miniexp_string((const char*)io.data[0]);
1695 delete [] (char*)(io.data[0]);
1696 }
1697 catch(...)
1698 {
1699 delete [] (char*)(io.data[0]);
1700 }
1701 return r;
1702 }
1703
1704
1705 /* ---- INPUT */
1706
1707 static void
grow(char * & s,size_t & l,size_t & m)1708 grow(char* &s, size_t &l, size_t &m)
1709 {
1710 int nm = ((m<256)?256:m) + ((m>32000)?32000:m);
1711 char *ns = new char[nm+1];
1712 memcpy(ns, s, l);
1713 delete [] s;
1714 m = nm;
1715 s = ns;
1716 }
1717
1718 static void
append(int c,char * & s,size_t & l,size_t & m)1719 append(int c, char* &s, size_t &l, size_t &m)
1720 {
1721 if (l >= m)
1722 grow(s, l, m);
1723 s[l++] = c;
1724 s[l] = 0;
1725 }
1726
1727 static void
append_utf8(int x,char * & s,size_t & l,size_t & m)1728 append_utf8(int x, char *&s, size_t &l, size_t &m)
1729 {
1730 if (x >= 0 && x <= 0x10ffff)
1731 {
1732 if (l + 4 >= m)
1733 grow(s, l, m);
1734 if (x <= 0x7f) {
1735 s[l++] = (char)x;
1736 } else if (x <= 0x7ff) {
1737 s[l++] = (char)((x>>6)|0xc0);
1738 s[l++] = (char)((x|0x80)&0xbf);
1739 } else if (x <= 0xffff) {
1740 s[l++] = (char)((x>>12)|0xe0);
1741 s[l++] = (char)(((x>>6)|0x80)&0xbf);
1742 s[l++] = (char)((x|0x80)&0xbf);
1743 } else {
1744 s[l++] = (char)((x>>18)|0xf0);
1745 s[l++] = (char)(((x>>12)|0x80)&0xbf);
1746 s[l++] = (char)(((x>>6)|0x80)&0xbf);
1747 s[l++] = (char)((x|0x80)&0xbf);
1748 }
1749 s[l] = 0;
1750 }
1751 }
1752
1753 static void
skip_blank(miniexp_io_t * io,int & c)1754 skip_blank(miniexp_io_t *io, int &c)
1755 {
1756 while (isspace(c))
1757 c = io->fgetc(io);
1758 }
1759
1760 static void
skip_newline(miniexp_io_t * io,int & c)1761 skip_newline(miniexp_io_t *io, int &c)
1762 {
1763 int d = c;
1764 if (c == '\n' || c == '\r')
1765 c = io->fgetc(io);
1766 if ((c == '\n' || c == '\r') && (c != d))
1767 c = io->fgetc(io);
1768 }
1769
1770 static int
skip_octal(miniexp_io_t * io,int & c,int maxlen=3)1771 skip_octal(miniexp_io_t *io, int &c, int maxlen=3)
1772 {
1773 int n = 0;
1774 int x = 0;
1775 while (c >= '0' && c < '8' && n++ < maxlen)
1776 {
1777 x = (x<<3) + c - '0';
1778 c = io->fgetc(io);
1779 }
1780 return x;
1781 }
1782
1783 static int
skip_hexadecimal(miniexp_io_t * io,int & c,int maxlen=2)1784 skip_hexadecimal(miniexp_io_t *io, int &c, int maxlen=2)
1785 {
1786 int n = 0;
1787 int x = 0;
1788 while (isxdigit(c) && n++ < maxlen && x <= 0x10fff) // unicode range only
1789 {
1790 x = (x<<4) + (isdigit(c) ? c-'0' : toupper(c)-'A'+10);
1791 c = io->fgetc(io);
1792 }
1793 return x;
1794 }
1795
1796 static miniexp_t
read_error(miniexp_io_t * io,int & c)1797 read_error(miniexp_io_t *io, int &c)
1798 {
1799 while (c!=EOF && c!='\n')
1800 c = io->fgetc(io);
1801 return miniexp_dummy;
1802 }
1803
1804 static miniexp_t
read_c_string(miniexp_io_t * io,int & c)1805 read_c_string(miniexp_io_t *io, int &c)
1806 {
1807 miniexp_t r;
1808 char *s = 0;
1809 size_t l = 0;
1810 size_t m = 0;
1811 ASSERT(c == '\"');
1812 c = io->fgetc(io);
1813 for(;;)
1814 {
1815 if (c==EOF || (isascii(c) && !isprint(c)))
1816 return read_error(io, c);
1817 else if (c=='\"')
1818 break;
1819 else if (c=='\\')
1820 {
1821 c = io->fgetc(io);
1822 if (c == '\n' || c == '\r')
1823 {
1824 skip_newline(io, c);
1825 continue;
1826 }
1827 else if (c>='0' && c<='7')
1828 {
1829 int x = skip_octal(io, c, 3);
1830 append((char)x, s, l, m);
1831 continue;
1832 }
1833 else if (c=='x' || c=='X')
1834 {
1835 int d = c;
1836 c = io->fgetc(io);
1837 if (isxdigit(c))
1838 {
1839 int x = skip_hexadecimal(io, c, 2);
1840 append((char)x, s, l, m);
1841 continue;
1842 }
1843 io->ungetc(io, c);
1844 c = d;
1845 }
1846 else if (c == 'u' || c == 'U')
1847 {
1848 int x = -1;
1849 int d = c;
1850 c = io->fgetc(io);
1851 if (isxdigit(c))
1852 x = skip_hexadecimal(io, c, isupper(d) ? 6 : 4);
1853 while (x >= 0xd800 && x <= 0xdbff && c == '\\')
1854 {
1855 c = io->fgetc(io);
1856 if (c != 'u' && c != 'U')
1857 {
1858 io->ungetc(io, c);
1859 c = '\\';
1860 break;
1861 }
1862 d = c;
1863 c = io->fgetc(io);
1864 int z = -1;
1865 if (isxdigit(c))
1866 z = skip_hexadecimal(io, c, isupper(d) ? 6 : 4);
1867 if (z >= 0xdc00 && z <= 0xdfff)
1868 {
1869 x = 0x10000 + ((x & 0x3ff) << 10) + (z & 0x3ff);
1870 break;
1871 }
1872 append_utf8(x, s, l, m);
1873 x = z;
1874 }
1875 if (x >= 0)
1876 {
1877 append_utf8(x, s, l, m);
1878 continue;
1879 }
1880 io->ungetc(io, c);
1881 c = d;
1882 }
1883 static const char *tr1 = "tnrbfvae?";
1884 static const char *tr2 = "\t\n\r\b\f\013\007\033?";
1885 for (int i=0; tr1[i]; i++)
1886 if (c == tr1[i])
1887 c = tr2[i];
1888 }
1889 append(c,s,l,m);
1890 c = io->fgetc(io);
1891 }
1892 c = io->fgetc(io);
1893 r = miniexp_lstring(l, s);
1894 delete [] s;
1895 return r;
1896 }
1897
1898 static miniexp_t
read_quoted_symbol(miniexp_io_t * io,int & c)1899 read_quoted_symbol(miniexp_io_t *io, int &c)
1900 {
1901 miniexp_t r;
1902 char *s = 0;
1903 size_t l = 0;
1904 size_t m = 0;
1905 ASSERT(c == '|');
1906 for(;;)
1907 {
1908 c = io->fgetc(io);
1909 if (c==EOF || (isascii(c) && !isprint(c)))
1910 return read_error(io, c);
1911 if (c=='|')
1912 if ((c = io->fgetc(io)) != '|')
1913 break;
1914 append(c,s,l,m);
1915 }
1916 r = miniexp_symbol(s ? s : "");
1917 delete [] s;
1918 return r;
1919 }
1920
1921 static miniexp_t
read_symbol_or_number(miniexp_io_t * io,int & c)1922 read_symbol_or_number(miniexp_io_t *io, int &c)
1923 {
1924 miniexp_t r;
1925 char *s = 0;
1926 size_t l = 0;
1927 size_t m = 0;
1928 for(;;)
1929 {
1930 if (c==EOF || c=='(' || c==')' || c=='|' || c=='\"'
1931 || isspace(c) || !isascii(c) || !isprint(c)
1932 || (io->p_macrochar && io->p_macroqueue
1933 && c < 128 && c >= 0 && io->p_macrochar[c] ) )
1934 break;
1935 append(c,s,l,m);
1936 c = io->fgetc(io);
1937 }
1938 if (l <= 0)
1939 return read_error(io, c);
1940 double x;
1941 if (str_is_double(s, x))
1942 r = miniexp_double(x);
1943 else
1944 r = miniexp_symbol(s);
1945 delete [] s;
1946 return r;
1947 }
1948
1949 static miniexp_t
read_miniexp(miniexp_io_t * io,int & c)1950 read_miniexp(miniexp_io_t *io, int &c)
1951 {
1952 for(;;)
1953 {
1954 if (io->p_macroqueue && miniexp_consp(*io->p_macroqueue))
1955 {
1956 miniexp_t p = car(*io->p_macroqueue);
1957 *io->p_macroqueue = cdr(*io->p_macroqueue);
1958 return p;
1959 }
1960 skip_blank(io, c);
1961 if (c == EOF)
1962 {
1963 // clean end-of-file.
1964 return miniexp_dummy;
1965 }
1966 else if (c == ')')
1967 {
1968 c = io->fgetc(io);
1969 continue;
1970 }
1971 else if (c == '(')
1972 {
1973 minivar_t l = miniexp_cons(miniexp_nil, miniexp_nil);
1974 miniexp_t tail = l;
1975 minivar_t p;
1976 c = io->fgetc(io);
1977 for(;;)
1978 {
1979 skip_blank(io, c);
1980 if (c == ')')
1981 break;
1982 if (c == '.')
1983 {
1984 int d = io->fgetc(io);
1985 io->ungetc(io, d);
1986 if (isspace(d))
1987 break;
1988 }
1989 p = read_miniexp(io, c);
1990 if ((miniexp_t)p == miniexp_dummy)
1991 return read_error(io, c);
1992 p = miniexp_cons(p, miniexp_nil);
1993 miniexp_rplacd(tail, p);
1994 tail = p;
1995 }
1996 if (c == '.')
1997 {
1998 c = io->fgetc(io);
1999 skip_blank(io, c);
2000 if (c != ')')
2001 miniexp_rplacd(tail, read_miniexp(io, c));
2002 }
2003 skip_blank(io, c);
2004 if (c != ')')
2005 return read_error(io, c);
2006 c = io->fgetc(io);
2007 return cdr(l);
2008 }
2009 else if (c == '"')
2010 {
2011 return read_c_string(io, c);
2012 }
2013 else if (c == '|')
2014 {
2015 return read_quoted_symbol(io, c);
2016 }
2017 else if (io->p_macrochar && io->p_macroqueue
2018 && c >= 0 && c < 128 && io->p_macrochar[c])
2019 {
2020 miniexp_t p = io->p_macrochar[c](io);
2021 if (miniexp_length(p) > 0)
2022 *io->p_macroqueue = p;
2023 else if (p)
2024 return read_error(io, c);
2025 c = io->fgetc(io);
2026 continue;
2027 }
2028 else if (c == '#')
2029 {
2030 int nc = io->fgetc(io);
2031 if (io->p_diezechar && io->p_macroqueue
2032 && nc >= 0 && nc < 128 && io->p_diezechar[nc])
2033 {
2034 miniexp_t p = io->p_diezechar[nc](io);
2035 if (miniexp_length(p) > 0)
2036 *io->p_macroqueue = p;
2037 else if (p)
2038 return read_error(io, c);
2039 c = io->fgetc(io);
2040 continue;
2041 }
2042 else if (nc == '#')
2043 return read_error(io, c);
2044 io->ungetc(io, nc);
2045 // fall thru
2046 }
2047 // default
2048 return read_symbol_or_number(io, c);
2049 }
2050 }
2051
2052 miniexp_t
miniexp_read_r(miniexp_io_t * io)2053 miniexp_read_r(miniexp_io_t *io)
2054 {
2055 int c = io->fgetc(io);
2056 miniexp_t p = read_miniexp(io, c);
2057 if (c != EOF)
2058 io->ungetc(io, c);
2059 return p;
2060 }
2061
2062
2063 /* ---- COMPAT */
2064
miniexp_read(void)2065 miniexp_t miniexp_read(void)
2066 {
2067 return miniexp_read_r(&miniexp_io);
2068 }
2069
miniexp_prin(miniexp_t p)2070 miniexp_t miniexp_prin(miniexp_t p)
2071 {
2072 return miniexp_prin_r(&miniexp_io, p);
2073 }
2074
miniexp_print(miniexp_t p)2075 miniexp_t miniexp_print(miniexp_t p)
2076 {
2077 return miniexp_print_r(&miniexp_io, p);
2078 }
2079
miniexp_pprin(miniexp_t p,int w)2080 miniexp_t miniexp_pprin(miniexp_t p, int w)
2081 {
2082 return miniexp_pprin_r(&miniexp_io, p, w);
2083 }
2084
miniexp_pprint(miniexp_t p,int w)2085 miniexp_t miniexp_pprint(miniexp_t p, int w)
2086 {
2087 return miniexp_pprint_r(&miniexp_io, p, w);
2088 }
2089
2090 void
minilisp_set_output(FILE * f)2091 minilisp_set_output(FILE *f)
2092 {
2093 minilisp_puts = compat_puts;
2094 miniexp_io_set_output(&miniexp_io, f);
2095 }
2096
2097 void
minilisp_set_input(FILE * f)2098 minilisp_set_input(FILE *f)
2099 {
2100 minilisp_getc = compat_getc;
2101 minilisp_ungetc = compat_ungetc;
2102 miniexp_io_set_input(&miniexp_io, f);
2103 }
2104
2105
2106
2107
2108 /* -------------------------------------------------- */
2109 /* CLEANUP (SEE GC ABOVE) */
2110 /* -------------------------------------------------- */
2111
2112 static void
gc_clear(miniexp_t * pp)2113 gc_clear(miniexp_t *pp)
2114 {
2115 *pp = 0;
2116 }
2117
2118 void
minilisp_finish(void)2119 minilisp_finish(void)
2120 {
2121 CSLOCK(locker);
2122 ASSERT(!gc.lock);
2123 // clear minivars
2124 minivar_t::mark(gc_clear);
2125 for (gctls_t *tls = gc.tls; tls; tls=tls->next)
2126 for (int i=0; i<recentsize; i++)
2127 tls->recent[i] = 0;
2128 // collect everything
2129 gc_run();
2130 // deallocate everything
2131 ASSERT(gc.pairs_free == gc.pairs_total);
2132 while (gc.pairs_blocks)
2133 {
2134 block_t *b = gc.pairs_blocks;
2135 gc.pairs_blocks = b->next;
2136 delete b;
2137 }
2138 ASSERT(gc.objs_free == gc.objs_total);
2139 while (gc.objs_blocks)
2140 {
2141 block_t *b = gc.objs_blocks;
2142 gc.objs_blocks = b->next;
2143 delete b;
2144 }
2145 delete symbols;
2146 symbols = 0;
2147 }
2148
2149
2150