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