source: trunk/libdjvu/miniexp.cpp @ 15

Last change on this file since 15 was 15, checked in by Eugene Romanenko, 15 years ago

needed libs update

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