source: trunk/libdjvu/miniexp.cpp @ 199

Last change on this file since 199 was 17, checked in by Eugene Romanenko, 16 years ago

update makefiles, remove absolute paths, update djvulibre to version 3.5.17

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