source: trunk/libdjvu/miniexp.cpp @ 269

Last change on this file since 269 was 206, checked in by Eugene Romanenko, 14 years ago

DJVU plugin: djvulibre updated to version 3.5.19

File size: 30.0 KB
Line 
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
7// GNU General Public License, either version 2 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/* $Id: miniexp.cpp,v 1.14 2007/03/25 20:48:35 leonb Exp $ */
19
20#ifdef HAVE_CONFIG_H
21# include "config.h"
22#endif
23#if NEED_GNUG_PRAGMAS
24# pragma implementation "miniexp.h"
25#endif
26
27#include <stdlib.h>
28#include <stdio.h>
29#include <ctype.h>
30#include <string.h>
31#include <time.h>
32#include <stdarg.h>
33
34#define MINIEXP_IMPLEMENTATION
35
36#include "miniexp.h"
37
38#ifdef HAVE_NAMESPACES
39# define BEGIN_ANONYMOUS_NAMESPACE namespace {
40# define END_ANONYMOUS_NAMESPACE }
41#else
42# define BEGIN_ANONYMOUS_NAMESPACE
43# define END_ANONYMOUS_NAMESPACE
44#endif
45
46
47/* -------------------------------------------------- */
48/* ASSERT                                            */
49/* -------------------------------------------------- */
50
51#if defined(__GNUC__)
52static void 
53assertfail(const char *fn, int ln) 
54  __attribute__((noreturn));
55#endif
56
57static void
58assertfail(const char *fn, int ln)
59{
60  fprintf(stderr,"Assertion failed: %s:%d\n",fn,ln);
61  abort();
62}
63
64#define ASSERT(x) \
65  do { if (!(x)) assertfail(__FILE__,__LINE__); } while(0)
66
67
68/* -------------------------------------------------- */
69/* SYMBOLS                                            */
70/* -------------------------------------------------- */
71
72static unsigned int 
73hashcode(const char *s)
74{
75  long h = 0x1013;
76  while (*s)
77    {
78      h = (h<<6) | ((h&0xfc000000)>>26);
79      h ^= (*s);
80      s++;
81    }
82  return h;
83}
84
85BEGIN_ANONYMOUS_NAMESPACE
86
87class symtable_t 
88{
89public:
90  int nelems;
91  int nbuckets;
92  struct sym { unsigned int h; struct sym *l; char *n; };
93  struct sym **buckets;
94  symtable_t();
95  ~symtable_t();
96  struct sym *lookup(const char *n, bool create=false);
97  void resize(int); 
98private:
99  symtable_t(const symtable_t&);
100  symtable_t& operator=(const symtable_t&);
101};
102
103symtable_t::symtable_t()
104  : nelems(0), nbuckets(0), buckets(0)
105{
106  resize(7);
107}
108
109symtable_t::~symtable_t()
110{
111  int i=0;
112  for (; i<nbuckets; i++)
113    while (buckets[i])
114      {
115        struct sym *r = buckets[i];
116        buckets[i] = r->l;
117        delete [] r->n;
118        delete r;
119      }
120  delete [] buckets;
121}
122
123void
124symtable_t::resize(int nb)
125{
126  struct sym **b = new sym*[nb];
127  memset(b, 0, nb*sizeof(sym*));
128  int i=0;
129  for (; i<nbuckets; i++)
130    while (buckets[i])
131      {
132        struct sym *s = buckets[i];
133        int j = s->h % nb;
134        buckets[i] = s->l;
135        s->l = b[j];
136        b[j] = s;
137      }
138  delete [] buckets;
139  buckets = b;
140  nbuckets = nb;
141}
142
143struct symtable_t::sym *
144symtable_t::lookup(const char *n, bool create)
145{
146  if (nbuckets <= 0) 
147    resize(7);
148  unsigned int h = hashcode(n);
149  int i = h % nbuckets;
150  struct sym *r = buckets[i];
151  while (r && strcmp(n,r->n))
152    r = r->l;
153  if (!r && create)
154    {
155      nelems += 1;
156      r = new sym;
157      r->h = h;
158      r->l = buckets[i];
159      r->n = new char [1+strlen(n)];
160      strcpy(r->n, n);
161      buckets[i] = r;
162      if ( 2 * nelems > 3 * nbuckets)
163        resize(2*nbuckets-1);
164    }
165  return r;
166}
167 
168END_ANONYMOUS_NAMESPACE
169
170static symtable_t *symbols;
171 
172const char *
173miniexp_to_name(miniexp_t p)
174{
175  if (miniexp_symbolp(p))
176    {
177      struct symtable_t::sym *r;
178      r = ((symtable_t::sym*)(((size_t)p)&~((size_t)3)));
179      return r->n;
180    }
181  return 0;
182}
183
184miniexp_t
185miniexp_symbol(const char *name)
186{
187  struct symtable_t::sym *r;
188  if (! symbols) 
189    symbols = new symtable_t;
190  r = symbols->lookup(name, true);
191  return (miniexp_t)(((size_t)r)|((size_t)2));
192}
193
194
195/* -------------------------------------------------- */
196/* MEMORY AND GARBAGE COLLECTION                      */
197/* -------------------------------------------------- */
198
199// A simple mark-and-sweep garbage collector.
200//
201// Memory is managed in chunks of nptrs_chunk pointers.
202// The first two pointers are used to hold mark bytes for the rest.
203// Chunks are carved from blocks of nptrs_block pointers.
204//
205// Dirty hack: The sixteen most recently created pairs are
206// not destroyed by automatic garbage collection, in order
207// to preserve transient objects created in the course
208// of evaluating complicated expressions.
209
210#define nptrs_chunk  (4*sizeof(void*))
211#define sizeof_chunk (nptrs_chunk*sizeof(void*))
212#define nptrs_block  (16384-8)
213#define recentlog    (4)
214#define recentsize   (1<<recentlog)
215
216static inline char *
217markbase(void **p)
218{
219  return (char*)(((size_t)p) & ~(sizeof_chunk-1));
220}
221
222static inline char *
223markbyte(void **p)
224{
225  char *base = markbase(p);
226  return base + ((p - (void**)base)>>1);
227}
228
229struct block_t {
230  block_t *next;
231  void **lo;
232  void **hi;
233  void *ptrs[nptrs_block];
234};
235
236static block_t *
237new_block(void)
238{
239  block_t *b = new block_t;
240  memset(b, 0, sizeof(block_t));
241  b->lo = (void**)markbase(b->ptrs+nptrs_chunk-1);
242  b->hi = (void**)markbase(b->ptrs+nptrs_block);
243  return b;
244}
245
246static void
247clear_marks(block_t *b)
248{
249  for (void** m=b->lo; m<b->hi; m+=nptrs_chunk)
250    m[0] = m[1] = 0;
251}
252
253static void
254collect_free(block_t *b, void **&freelist, int &count, bool destroy)
255{
256  for (void **m=b->lo; m<b->hi; m+=nptrs_chunk)
257    {
258      char *c = (char*)m;
259      for (unsigned int i=1; i<nptrs_chunk/2; i++)
260        if (! c[i])
261          {
262            if (destroy && m[i+i]==m[i+i+1]) 
263              delete (miniobj_t*)m[i+i];
264            m[i+i] = (void*)freelist;
265            m[i+i+1] = 0;
266            freelist = &m[i+i];
267            count += 1;
268          }
269    }
270}
271
272static struct {
273  int lock;
274  int request;
275  int debug;
276  int      pairs_total;
277  int      pairs_free;
278  void   **pairs_freelist;
279  block_t *pairs_blocks;
280  int      objs_total;
281  int      objs_free;
282  void   **objs_freelist;
283  block_t *objs_blocks;
284  void **recent[recentsize];
285  int    recentindex;
286} gc;
287
288static void
289new_pair_block(void)
290{
291  int count = 0;
292  block_t *b = new_block();
293  b->next = gc.pairs_blocks;
294  gc.pairs_blocks = b;
295  clear_marks(b);
296  collect_free(b, gc.pairs_freelist, count, false);
297  gc.pairs_total += count;
298  gc.pairs_free += count;
299}
300
301static void
302new_obj_block(void)
303{
304  int count = 0;
305  block_t *b = new_block();
306  b->next = gc.objs_blocks;
307  gc.objs_blocks = b;
308  clear_marks(b);
309  collect_free(b, gc.objs_freelist, count, false);
310  gc.objs_total += count;
311  gc.objs_free += count;
312}
313
314#if defined(__GNUC__) && (__GNUC__ >= 3)
315static void gc_mark_object(void **v)
316  __attribute__((noinline));
317#else
318static void gc_mark_object(void **v);
319#endif
320
321static void
322gc_mark(miniexp_t *pp)
323{
324  for(;;)
325    {
326      miniexp_t p = *pp;
327      if (((size_t)p) & 2) return;
328      void **v = (void**)(((size_t)p) & ~(size_t)3);
329      if (! v) return;
330      char *m = markbyte(v);
331      if (*m) return;
332      (*m) = 1;
333      if (((size_t)p) & 1)
334        { // object
335          gc_mark_object(v);
336          return;
337        }
338      else
339        { // pair
340          gc_mark((miniexp_t*)&v[0]);
341          pp = (miniexp_t*)&v[1];
342        }
343    }
344}
345
346static void
347gc_mark_object(void **v)
348{
349  miniobj_t *obj = (miniobj_t*)v[0];
350  if (obj) obj->mark(gc_mark);
351}
352
353static void
354gc_run(void)
355{
356  gc.request++;
357  if (gc.lock == 0)
358    {
359      block_t *b;
360      gc.request = 0;
361      // clear marks
362      for (b=gc.objs_blocks; b; b=b->next)
363        clear_marks(b);
364      for (b=gc.pairs_blocks; b; b=b->next)
365        clear_marks(b);
366      // mark
367      minivar_t::mark(gc_mark);
368      for (int i=0; i<recentsize; i++)
369        {
370          miniexp_t p = (miniexp_t)gc.recent[i];
371          gc_mark(&p);
372        }
373      // sweep
374      gc.objs_free = gc.pairs_free = 0;
375      gc.objs_freelist = gc.pairs_freelist = 0;
376      for (b=gc.objs_blocks; b; b=b->next)
377        collect_free(b, gc.objs_freelist, gc.objs_free, true);
378      for (b=gc.pairs_blocks; b; b=b->next)
379        collect_free(b, gc.pairs_freelist, gc.pairs_free, false);
380      // alloc 33% extra space
381      while (gc.objs_free*4 < gc.objs_total)
382        new_obj_block();
383      while (gc.pairs_free*4 < gc.pairs_total)
384        new_pair_block();
385    }
386}
387
388static void **
389gc_alloc_pair(void *a, void *d)
390{
391  if (!gc.pairs_freelist)
392    {
393      gc_run();
394      if (!gc.pairs_freelist)
395        new_pair_block();
396    }
397  else if (gc.debug)
398    minilisp_gc();
399  void **p = gc.pairs_freelist;
400  gc.pairs_freelist = (void**)p[0];
401  gc.pairs_free -= 1;
402  p[0] = a;
403  p[1] = d;
404  gc.recent[(++gc.recentindex) & (recentsize-1)] = p;
405  return p;
406}
407
408static void **
409gc_alloc_object(void *obj)
410{
411  if (!gc.objs_freelist)
412    {
413      gc_run();
414      if (!gc.objs_freelist)
415        new_obj_block();
416    }
417  else if (gc.debug)
418    minilisp_gc();
419  void **p = gc.objs_freelist;
420  gc.objs_freelist = (void**)p[0];
421  gc.objs_free -= 1;
422  p[0] = p[1] = obj;
423  gc.recent[(++gc.recentindex) & (recentsize-1)] = p;
424  return p;
425}
426
427
428
429
430
431/* ---- USER FUNCTIONS --- */
432
433miniexp_t
434minilisp_acquire_gc_lock(miniexp_t x)
435{
436  gc.lock++;
437  return x;
438}
439
440miniexp_t
441minilisp_release_gc_lock(miniexp_t x)
442{
443  if (gc.lock > 0)
444    if (--gc.lock == 0)
445      if (gc.request > 0)
446        {
447          minivar_t v = x;
448          gc_run();
449        }
450  return x;
451}
452
453void 
454minilisp_gc(void)
455{
456  int i;
457  for (i=0; i<recentsize; i++)
458    gc.recent[i] = 0;
459  gc_run();
460}
461
462void 
463minilisp_debug(int debug)
464{
465  gc.debug = debug;
466}
467
468void 
469minilisp_info(void)
470{
471  time_t tim = time(0);
472  const char *dat = ctime(&tim);
473  printf("--- begin info -- %s", dat);
474  printf("symbols: %d symbols in %d buckets\n", 
475         symbols->nelems, symbols->nbuckets);
476  if (gc.debug)
477    printf("gc.debug: true\n");
478  if (gc.lock)
479    printf("gc.locked: true, %d requests\n", gc.request);
480  printf("gc.pairs: %d free, %d total\n", gc.pairs_free, gc.pairs_total);
481  printf("gc.objects: %d free, %d total\n", gc.objs_free, gc.objs_total);
482  printf("--- end info -- %s", dat);
483}
484
485
486/* -------------------------------------------------- */
487/* MINIVARS                                           */
488/* -------------------------------------------------- */
489
490minivar_t::minivar_t()
491  : data(0)
492{
493  if ((next = vars))
494    next->pprev = &next;
495  pprev = &vars;
496  vars = this;
497}
498
499minivar_t::minivar_t(miniexp_t p)
500  : data(p)
501{
502  if ((next = vars))
503    next->pprev = &next;
504  pprev = &vars;
505  vars = this;
506}
507
508minivar_t::minivar_t(const minivar_t &v)
509  : data(v.data)
510{
511  if ((next = vars))
512    next->pprev = &next;
513  pprev = &vars;
514  vars = this;
515}
516
517minivar_t *minivar_t::vars = 0;
518
519void
520minivar_t::mark(minilisp_mark_t *f)
521{
522  for (minivar_t *v = vars; v; v=v->next)
523    (*f)(&v->data);
524}
525
526minivar_t *
527minivar_alloc(void)
528{
529  return new minivar_t;
530}
531
532void 
533minivar_free(minivar_t *v)
534{
535  delete v;
536}
537
538miniexp_t *
539minivar_pointer(minivar_t *v)
540{
541  return &(*v);
542}
543
544
545/* -------------------------------------------------- */
546/* LISTS                                              */
547/* -------------------------------------------------- */
548
549static inline miniexp_t &
550car(miniexp_t p) {
551  return ((miniexp_t*)p)[0];
552}
553
554static inline miniexp_t &
555cdr(miniexp_t p) {
556  return ((miniexp_t*)p)[1];
557}
558
559int 
560miniexp_length(miniexp_t p)
561{
562  int n = 0;
563  bool toggle = false;
564  miniexp_t q = p;
565  while (miniexp_consp(p))
566    {
567      p = cdr(p);
568      if (p == q)
569        return -1;
570      if ((toggle = !toggle))
571        q = cdr(q);
572      n += 1;
573    }
574  return n;
575}
576
577miniexp_t
578miniexp_caar(miniexp_t p)
579{
580  return miniexp_car(miniexp_car(p)); 
581}
582
583miniexp_t
584miniexp_cadr(miniexp_t p)
585{
586  return miniexp_car(miniexp_cdr(p)); 
587}
588
589miniexp_t
590miniexp_cdar(miniexp_t p)
591{
592  return miniexp_cdr(miniexp_car(p)); 
593}
594
595miniexp_t
596miniexp_cddr(miniexp_t p)
597{
598  return miniexp_cdr(miniexp_cdr(p)); 
599}
600
601miniexp_t
602miniexp_caddr(miniexp_t p)
603{
604  return miniexp_car(miniexp_cdr(miniexp_cdr(p)));
605}
606
607miniexp_t
608miniexp_cdddr(miniexp_t p)
609{
610  return miniexp_cdr(miniexp_cdr(miniexp_cdr(p)));
611}
612
613miniexp_t
614miniexp_nth(int n, miniexp_t l)
615{
616  while (--n>=0 && miniexp_consp(l)) 
617    l = cdr(l);
618  return miniexp_car(l);
619}
620
621miniexp_t
622miniexp_cons(miniexp_t a, miniexp_t d)
623{
624  gc.recent[(gc.recentindex+1) & (recentsize-1)] = (void**)a;
625  gc.recent[(gc.recentindex+2) & (recentsize-1)] = (void**)d;
626  miniexp_t r = (miniexp_t)gc_alloc_pair((void*)a, (void*)d); 
627  return r;
628}
629
630miniexp_t
631miniexp_rplaca(miniexp_t pair, miniexp_t newcar)
632{
633  if (miniexp_consp(pair))
634    {
635      car(pair) = newcar;
636      return pair;
637    }
638  return 0;
639}
640
641miniexp_t
642miniexp_rplacd(miniexp_t pair, miniexp_t newcdr)
643{
644  if (miniexp_consp(pair))
645    {
646      cdr(pair) = newcdr;
647      return pair;
648    }
649  return 0;
650}
651
652miniexp_t
653miniexp_reverse(miniexp_t p)
654{
655  miniexp_t l = 0;
656  while (miniexp_consp(p))
657    {
658      miniexp_t q = cdr(p);
659      cdr(p) = l;
660      l = p;
661      p = q;
662    }
663  return l;
664}
665
666
667/* -------------------------------------------------- */
668/* MINIOBJ                                            */
669/* -------------------------------------------------- */
670
671miniobj_t::~miniobj_t()
672{
673}
674
675miniexp_t miniobj_t::classname = 0;
676
677bool
678miniobj_t::isa(miniexp_t) const
679{
680  return false;
681}
682
683void 
684miniobj_t::mark(minilisp_mark_t*)
685{
686}
687
688char *
689miniobj_t::pname() const
690{
691  const char *cname = miniexp_to_name(classof());
692  char *res = new char[strlen(cname)+24];
693  sprintf(res,"#<%s:%p>",cname,this);
694  return res;
695}
696
697miniexp_t
698miniexp_object(miniobj_t *obj)
699{
700  void **v = gc_alloc_object((void*)obj);
701  return (miniexp_t)(((size_t)v)|(size_t)1);
702}
703
704miniexp_t
705miniexp_classof(miniexp_t p) 
706{
707  miniobj_t *obj = miniexp_to_obj(p);
708  if (obj) return obj->classof();
709  return miniexp_nil;
710}
711
712miniexp_t
713miniexp_isa(miniexp_t p, miniexp_t c)
714{
715  miniobj_t *obj = miniexp_to_obj(p);
716  if (obj && obj->isa(c))
717    return obj->classof();
718  return miniexp_nil;
719}
720
721
722/* -------------------------------------------------- */
723/* STRINGS                                            */
724/* -------------------------------------------------- */
725
726BEGIN_ANONYMOUS_NAMESPACE
727
728class ministring_t : public miniobj_t
729{
730  MINIOBJ_DECLARE(ministring_t,miniobj_t,"string");
731public:
732  ~ministring_t();
733  ministring_t(const char *s);
734  ministring_t(char *s, bool steal);
735  operator const char*() const { return s; }
736  virtual char *pname() const;
737private:
738  char *s;
739private:
740  ministring_t(const ministring_t &);
741  ministring_t& operator=(const ministring_t &);
742};
743
744MINIOBJ_IMPLEMENT(ministring_t,miniobj_t,"string");
745
746ministring_t::~ministring_t()
747{
748  delete [] s;
749}
750
751ministring_t::ministring_t(const char *str) 
752  : s(new char[strlen(str)+1])
753{
754  strcpy(s,str);
755}
756
757ministring_t::ministring_t(char *str, bool steal) 
758  : s(str)
759{
760  ASSERT(steal);
761}
762
763END_ANONYMOUS_NAMESPACE
764
765static bool
766char_quoted(int c, bool eightbits)
767{
768  if (eightbits && c>=0x80)
769    return false;
770  if (c==0x7f || c=='\"' || c=='\\')
771    return true;
772  if (c>=0x20 && c<0x7f)
773    return false;
774  return true;
775}
776
777static void
778char_out(int c, char* &d, int &n)
779{
780  n++;
781  if (d) 
782    *d++ = c;
783}
784
785static int
786print_c_string(const char *s, char *d, bool eightbits)
787{
788  int c;
789  int n = 0;
790  char_out('\"', d, n);
791  while ((c = (unsigned char)(*s++)))
792    {
793      if (char_quoted(c, eightbits))
794        {
795          char letter = 0;
796          static char *tr1 = "\"\\tnrbf";
797          static char *tr2 = "\"\\\t\n\r\b\f";
798          { // extra nesting for windows
799            for (int i=0; tr2[i]; i++)
800              if (c == tr2[i])
801                letter = tr1[i];
802          }
803          char_out('\\', d, n);
804          if (letter)
805            char_out(letter, d, n);
806          else
807            {
808              char_out('0'+ ((c>>6)&3), d, n);
809              char_out('0'+ ((c>>3)&7), d, n);
810              char_out('0'+ (c&7), d, n);
811            }
812          continue;
813        }
814      char_out(c, d, n);
815    }
816  char_out('\"', d, n);
817  char_out(0, d, n);
818  return n;
819}
820
821char *
822ministring_t::pname() const
823{
824  bool eightbits = !minilisp_print_7bits;
825  int n = print_c_string(s, 0, eightbits);
826  char *d = new char[n];
827  if (d) print_c_string(s, d, eightbits);
828  return d;
829}
830
831int 
832miniexp_stringp(miniexp_t p)
833{
834  return miniexp_isa(p, ministring_t::classname) ? 1 : 0;
835}
836
837const char *
838miniexp_to_str(miniexp_t p)
839{
840  miniobj_t *obj = miniexp_to_obj(p);
841  if (miniexp_stringp(p))
842    return (const char*) * (ministring_t*) obj;
843  return 0;
844}
845
846miniexp_t
847miniexp_string(const char *s)
848{
849  ministring_t *obj = new ministring_t(s);
850  return miniexp_object(obj);
851}
852
853miniexp_t
854miniexp_substring(const char *s, int n)
855{
856  int l = strlen(s);
857  n = (n < l) ? n : l;
858  char *b = new char[n+1];
859  strncpy(b, s, n);
860  b[n] = 0;
861  ministring_t *obj = new ministring_t(b, true);
862  return miniexp_object(obj);
863}
864
865miniexp_t
866miniexp_concat(miniexp_t p)
867{
868  miniexp_t l = p;
869  const char *s;
870  int n = 0;
871  if (miniexp_length(l) < 0)
872    return miniexp_nil;
873  for (p=l; miniexp_consp(p); p=cdr(p))
874    if ((s = miniexp_to_str(car(p))))
875      n += strlen(s);
876  char *b = new char[n+1];
877  char *d = b;
878  for (p=l; miniexp_consp(p); p=cdr(p))
879    if ((s = miniexp_to_str(car(p)))) {
880      strcpy(d, s);
881      d += strlen(d);
882    }
883  ministring_t *obj = new ministring_t(b, true);
884  return miniexp_object(obj);
885}
886
887
888/* -------------------------------------------------- */
889/* INPUT/OUTPUT                                       */
890/* -------------------------------------------------- */
891
892extern "C" { 
893  // SunCC needs this to be defined inside extern "C" { ... }
894  // Beware the difference between extern "C" {...} and extern "C".
895  miniexp_t (*minilisp_macrochar_parser[128])(void); 
896}
897
898/* --------- OUTPUT */
899
900static FILE *outputfile;
901
902static int 
903stdio_puts(const char *s)
904{
905  if (!outputfile)
906    outputfile = stdout;
907  return fputs(s, outputfile);
908  return EOF;
909}
910
911int (*minilisp_puts)(const char *s) = stdio_puts;
912
913int minilisp_print_7bits = 1;
914
915void 
916minilisp_set_output(FILE *f)
917{
918  outputfile = f;
919  minilisp_puts = stdio_puts;
920}
921
922static bool
923must_quote_symbol(const char *s)
924{
925  int c;
926  const char *r = s;
927  while ((c = *r++))
928    if (c=='(' || c==')' || c=='\"' || c=='|' || 
929        isspace(c) || !isascii(c) || !isprint(c) ||
930        minilisp_macrochar_parser[c] )
931      return true;
932  char *end;
933  strtol(s,&end,0);
934  return !(*end);
935}
936
937BEGIN_ANONYMOUS_NAMESPACE
938
939struct printer_t
940{
941  int tab;
942  bool dryrun;
943  printer_t() : tab(0), dryrun(false) {}
944  void mlput(const char *s);
945  void mltab(int n);
946  void print(miniexp_t p);
947  virtual miniexp_t begin() { return miniexp_nil; }
948  virtual bool newline() { return false; }
949  virtual void end(miniexp_t) { }
950  virtual ~printer_t() {};
951};
952
953void
954printer_t::mlput(const char *s)
955{
956  if (! dryrun)
957    minilisp_puts(s);
958  while (*s)
959    if (*s++ == '\n')
960      tab = 0;
961    else
962      tab += 1;
963}
964
965void
966printer_t::mltab(int n)
967{
968  while (tab+8 <= n)
969    mlput("        ");
970  while (tab+1 <= n)
971    mlput(" ");
972}
973
974void
975printer_t::print(miniexp_t p)
976{
977  static char buffer[32];
978  miniexp_t b = begin();
979  if (p == miniexp_nil)
980    {
981      mlput("()");
982    }
983  else if (p == miniexp_dummy)
984    {
985      mlput("#<dummy>");
986    }
987  else if (miniexp_numberp(p))
988    {
989      sprintf(buffer, "%d", miniexp_to_int(p));
990      mlput(buffer);
991    }
992  else if (miniexp_symbolp(p))
993    {
994      const char *s = miniexp_to_name(p);
995      bool needquote = must_quote_symbol(s);
996      if (needquote) mlput("|");
997      mlput(s);
998      if (needquote) mlput("|");
999    }
1000  else if (miniexp_objectp(p))
1001    {
1002      miniobj_t *obj = miniexp_to_obj(p);
1003      char *s = obj->pname();
1004      mlput(s);
1005      delete [] s;
1006    }
1007  else if (miniexp_listp(p))
1008    {
1009      // TODO - detect more circular structures
1010      int skip = 1;
1011      int indent = tab + 1;
1012      bool multiline = false;
1013      bool toggle = true;
1014      miniexp_t q = p;
1015      mlput("(");
1016      if (miniexp_consp(p) && miniexp_symbolp(car(p)))
1017        {
1018          skip++;
1019          indent++;
1020        }
1021      while (miniexp_consp(p))
1022        {
1023          skip -= 1;
1024          if (multiline || newline() && skip<0 && tab>indent)
1025            {
1026              mlput("\n"); 
1027              mltab(indent); 
1028              multiline=true; 
1029            }
1030          print(car(p));
1031          if ((p = cdr(p)))
1032            mlput(" ");
1033          if ((toggle = !toggle))
1034            q = cdr(q);
1035          if (p == q)
1036            {
1037              mlput("...");
1038              p = 0;
1039            }
1040        }
1041      if (p)
1042        {
1043          skip -= 1;
1044          if (multiline || newline() && skip<0 && tab>indent)
1045            {
1046              mlput("\n"); 
1047              mltab(indent); 
1048              multiline=true; 
1049            }
1050          mlput(". ");
1051          print(p);
1052        }
1053      if (multiline)
1054        mlput(" )");
1055      else
1056        mlput(")");
1057    }
1058  end(b);
1059}
1060
1061struct pprinter_t : public printer_t
1062{
1063  int width;
1064  minivar_t l;
1065  virtual miniexp_t begin();
1066  virtual bool newline();
1067  virtual void end(miniexp_t);
1068};
1069
1070miniexp_t
1071pprinter_t::begin()
1072{
1073  if (dryrun)
1074    {
1075      l = miniexp_cons(miniexp_number(tab), l);
1076      return l;
1077    }
1078  else
1079    {
1080      ASSERT(miniexp_consp(l));
1081      ASSERT(miniexp_numberp(car(l)));
1082      l = cdr(l);
1083      return miniexp_nil;
1084    }
1085}
1086
1087bool 
1088pprinter_t::newline()
1089{
1090  if (! dryrun)
1091    {
1092      ASSERT(miniexp_consp(l));
1093      ASSERT(miniexp_numberp(car(l)));
1094      int len = miniexp_to_int(car(l));
1095      if (tab + len >= width)
1096        return true;
1097    }
1098  return false;
1099}
1100
1101void 
1102pprinter_t::end(miniexp_t p)
1103{
1104  if (dryrun)
1105    {
1106      ASSERT(miniexp_consp(p));
1107      ASSERT(miniexp_numberp(car(p)));
1108      int pos = miniexp_to_int(car(p));
1109      ASSERT(tab >= pos);
1110      car(p) = miniexp_number(tab - pos);
1111    }
1112}
1113
1114END_ANONYMOUS_NAMESPACE
1115
1116miniexp_t
1117miniexp_prin(miniexp_t p)
1118{
1119  minivar_t xp = p;
1120  printer_t printer;
1121  printer.print(p);
1122  return p;
1123}
1124
1125miniexp_t
1126miniexp_print(miniexp_t p)
1127{
1128  minivar_t xp = p;
1129  miniexp_prin(p);
1130  minilisp_puts("\n");
1131  return p;
1132}
1133
1134miniexp_t
1135miniexp_pprin(miniexp_t p, int width)
1136{ 
1137  minivar_t xp = p;
1138  pprinter_t printer;
1139  printer.width = width;
1140  // step1 - measure lengths into list <l>
1141  printer.tab = 0;
1142  printer.dryrun = true;
1143  printer.print(p);
1144  // step2 - print
1145  printer.tab = 0;
1146  printer.dryrun = false;
1147  printer.l = miniexp_reverse(printer.l);
1148  printer.print(p);
1149  // check
1150  ASSERT(printer.l == 0);
1151  return p;
1152}
1153
1154miniexp_t
1155miniexp_pprint(miniexp_t p, int width)
1156{
1157  miniexp_pprin(p, width);
1158  minilisp_puts("\n");
1159  return p;
1160}
1161
1162/* --------- PNAME */
1163
1164static struct { 
1165  char *b; int l; int m; 
1166} pname_data;
1167
1168static int
1169pname_puts(const char *s)
1170{
1171  int x = strlen(s);
1172  if (pname_data.l + x >= pname_data.m)
1173    {
1174      int nm = pname_data.l + x + 256;
1175      char *nb = new char[nm+1];
1176      memcpy(nb, pname_data.b, pname_data.l);
1177      delete [] pname_data.b;
1178      pname_data.m = nm;
1179      pname_data.b = nb;
1180    }
1181  strcpy(pname_data.b + pname_data.l, s);
1182  pname_data.l += x;
1183  return x;
1184}
1185
1186miniexp_t
1187miniexp_pname(miniexp_t p, int width)
1188{
1189  minivar_t r;
1190  int (*saved)(const char*) = minilisp_puts;
1191  pname_data.b = 0;
1192  pname_data.m = pname_data.l = 0;
1193  try
1194    {
1195      minilisp_puts = pname_puts;
1196      if (width > 0)
1197        miniexp_pprin(p, width);
1198      else
1199        miniexp_prin(p);
1200      minilisp_puts = saved;
1201      r = miniexp_string(pname_data.b);
1202      delete [] pname_data.b;
1203      pname_data.b = 0;
1204    }
1205  catch(...)
1206    {
1207      minilisp_puts = saved;
1208      delete [] pname_data.b;
1209      pname_data.b = 0;
1210    }
1211  return r;
1212}
1213
1214
1215
1216/* --------- INPUT */
1217
1218static FILE *inputfile;
1219static minivar_t inputqueue;
1220
1221static int
1222stdio_getc(void)
1223{
1224  if (!inputfile)
1225    inputfile = stdin;
1226  return getc(inputfile);
1227}
1228
1229static int
1230stdio_ungetc(int c)
1231{
1232  if (inputfile && c>=0)
1233    return ungetc(c, inputfile);
1234  return EOF;
1235}
1236
1237int (*minilisp_getc)(void) = stdio_getc;
1238
1239int (*minilisp_ungetc)(int c) = stdio_ungetc;
1240
1241void 
1242minilisp_set_input(FILE *f)
1243{
1244  inputfile = f;
1245  minilisp_getc = stdio_getc;
1246  minilisp_ungetc = stdio_ungetc;
1247}
1248
1249static void
1250skip_blank(int &c)
1251{
1252  while (isspace(c))
1253    c = minilisp_getc();
1254}
1255
1256static void
1257append(int c, char* &s, int &l, int &m)
1258{
1259  if (l >= m)
1260    {
1261      int nm = ((m<256)?256:m) + ((m>32000)?32000:m);
1262      char *ns = new char[nm+1];
1263      memcpy(ns, s, l);
1264      delete [] s;
1265      m = nm;
1266      s = ns;
1267    }
1268  s[l++] = c;
1269  s[l] = 0;
1270}
1271
1272static miniexp_t
1273read_error(int &c)
1274{
1275  while (c!=EOF && c!='\n')
1276    c = minilisp_getc();
1277  return miniexp_dummy;
1278}
1279
1280static miniexp_t
1281read_c_string(int &c)
1282{
1283  miniexp_t r;
1284  char *s = 0;
1285  int l = 0;
1286  int m = 0;
1287  ASSERT(c == '\"');
1288  c = minilisp_getc();
1289  for(;;)
1290    {
1291      if (c==EOF || isascii(c) && !isprint(c))
1292        return read_error(c);
1293      else if (c=='\"')
1294        break;
1295      else if (c=='\\')
1296        {
1297          c = minilisp_getc();
1298          if (c == '\n')
1299            {
1300              c = minilisp_getc();
1301              continue;
1302            }
1303          else if (c>='0' && c<='7')
1304            {
1305              int x = (c-'0');
1306              c = minilisp_getc();
1307              if (c>='0' && c<='7')
1308                {
1309                  x = (x<<3)+(c-'0');
1310                  c = minilisp_getc();
1311                  if (c>='0' && c<='7')
1312                    {
1313                      x = (x<<3)+(c-'0');
1314                      c = minilisp_getc();
1315                    }
1316                }
1317              append((char)x, s, l, m);
1318              continue;
1319            }
1320          else if (c=='x' || c=='X')
1321            {
1322              int x = 0;
1323              int d = c;
1324              c = minilisp_getc();
1325              if (isxdigit(c))
1326                {
1327                  x = (x<<4) + (isdigit(c) ? c-'0' : toupper(c)-'A'+10);
1328                  c = minilisp_getc();
1329                  if (isxdigit(c))
1330                    {
1331                      x = (x<<4) + (isdigit(c) ? c-'0' : toupper(c)-'A'+10);
1332                      c = minilisp_getc();
1333                    }
1334                  append((char)x, s, l, m);
1335                  continue;
1336                }
1337              else
1338                {
1339                  minilisp_ungetc(c);
1340                  c = d;
1341                }
1342            }
1343          static char *tr1 = "tnrbfva";
1344          static char *tr2 = "\t\n\r\b\f\013\007";
1345          { // extra nesting for windows
1346            for (int i=0; tr1[i]; i++)
1347              if (c == tr1[i])
1348                c = tr2[i];
1349          }
1350        }
1351      append(c,s,l,m);
1352      c = minilisp_getc();
1353    }
1354  c = minilisp_getc();
1355  r = miniexp_string(s ? s : "");
1356  delete [] s;
1357  return r;
1358}
1359
1360static miniexp_t
1361read_quoted_symbol(int &c)
1362{
1363  miniexp_t r;
1364  char *s = 0;
1365  int l = 0;
1366  int m = 0;
1367  ASSERT(c == '|');
1368  for(;;)
1369    {
1370      c = minilisp_getc();
1371      if (c==EOF || isascii(c) && !isprint(c))
1372        return read_error(c);
1373      if (c=='|')
1374        break;
1375      append(c,s,l,m);
1376    }
1377  c = minilisp_getc();
1378  r = miniexp_symbol(s ? s : "");
1379  delete [] s;
1380  return r;
1381}
1382
1383static miniexp_t
1384read_symbol_or_number(int &c)
1385{
1386  miniexp_t r;
1387  char *s = 0;
1388  int l = 0;
1389  int m = 0;
1390  for(;;)
1391    {
1392      if (c==EOF || c=='(' || c==')' || c=='|' || c=='\"'  || 
1393          isspace(c) || !isascii(c) || !isprint(c) || 
1394          minilisp_macrochar_parser[c] )
1395        break;
1396      append(c,s,l,m);
1397      c = minilisp_getc();
1398    }
1399  if (l <= 0)
1400    return read_error(c);
1401  char *end;
1402  long x = strtol(s, &end, 0);
1403  if (*end)
1404    r = miniexp_symbol(s);
1405  else
1406    r = miniexp_number((int)x);
1407  delete [] s;
1408  return r;
1409}
1410
1411static miniexp_t
1412read_miniexp(int &c)
1413{
1414  for(;;)
1415    {
1416      if (miniexp_consp(inputqueue))
1417        {
1418          miniexp_t p = car(inputqueue);
1419          inputqueue = cdr(inputqueue);
1420          return p;
1421        }
1422      skip_blank(c);
1423      if (c == EOF)
1424        {
1425          return read_error(c);
1426        }
1427      else if (c == ')')
1428        {
1429          c = minilisp_getc();
1430          continue;
1431        }
1432      else if (c == '(')
1433        {
1434          minivar_t l;
1435          miniexp_t *where = &l;
1436          minivar_t p;
1437          c = minilisp_getc();
1438          for(;;)
1439            {
1440              skip_blank(c);
1441              if (c == ')')
1442                break;
1443              if (c == '.')
1444                {
1445                  int d = minilisp_getc();
1446                  minilisp_ungetc(d);
1447                  if (isspace(d)) 
1448                    break;
1449                }
1450              p = read_miniexp(c);
1451              if ((miniexp_t)p == miniexp_dummy)
1452                return miniexp_dummy;
1453              *where = miniexp_cons(p, miniexp_nil);
1454              where = &cdr(*where);
1455            }
1456          if (c == '.')
1457            {
1458              c = minilisp_getc();
1459              skip_blank(c);
1460              if (c != ')')
1461                *where = read_miniexp(c);
1462            }
1463          skip_blank(c);
1464          if (c != ')')
1465            return read_error(c);
1466          c = minilisp_getc();
1467          return l;
1468        }
1469      else if (c == '"')
1470        {
1471          return read_c_string(c);
1472        }
1473      else if (c == '|')
1474        {
1475          return read_quoted_symbol(c);
1476        }
1477      else if (c>=0 && c<128 && minilisp_macrochar_parser[c])
1478        {
1479          miniexp_t p = minilisp_macrochar_parser[c]();
1480          if (miniexp_length(p) > 0)
1481            inputqueue = p;
1482          c = minilisp_getc();
1483          continue;
1484        }
1485      else 
1486        {
1487          return read_symbol_or_number(c);
1488        }
1489    }
1490}
1491
1492miniexp_t
1493miniexp_read(void)
1494{
1495  int c = minilisp_getc();
1496  miniexp_t p = read_miniexp(c);
1497  minilisp_ungetc(c);
1498  return p;
1499}
1500
1501
1502/* -------------------------------------------------- */
1503/* CLEANUP (SEE GC ABOVE)                             */
1504/* -------------------------------------------------- */
1505
1506static void
1507gc_clear(miniexp_t *pp)
1508{
1509  *pp = 0;
1510}
1511
1512void
1513minilisp_finish(void)
1514{
1515  ASSERT(!gc.lock);
1516  // clear minivars
1517  minivar_t::mark(gc_clear);
1518  { // extra nesting for windows
1519    for (int i=0; i<recentsize; i++)
1520      gc.recent[i] = 0;
1521  }
1522  // collect everything
1523  gc_run();
1524  // deallocate mblocks
1525  ASSERT(gc.pairs_free == gc.pairs_total);
1526  while (gc.pairs_blocks)
1527    {
1528      block_t *b = gc.pairs_blocks;
1529      gc.pairs_blocks = b->next;
1530      delete b;
1531    }
1532  ASSERT(gc.objs_free == gc.objs_total);
1533  while (gc.objs_blocks)
1534    {
1535      block_t *b = gc.objs_blocks;
1536      gc.objs_blocks = b->next;
1537      delete b;
1538    }
1539  // deallocate symbol table
1540  delete symbols;
1541}
1542
1543
Note: See TracBrowser for help on using the repository browser.