source: trunk/libdjvu/miniexp.cpp @ 426

Last change on this file since 426 was 280, checked in by rbri, 12 years ago

DJVU plugin: djvulibre updated to version 3.5.22

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