/trunk/Source/Modules/s-exp.cxx

/* ----------------------------------------------------------------------------- 
 * This file is part of SWIG, which is licensed as a whole under version 3 
 * (or any later version) of the GNU General Public License. Some additional
 * terms also apply to certain portions of SWIG. The full details of the SWIG
 * license and copyrights can be found in the LICENSE and COPYRIGHT files
 * included with the SWIG source code as distributed by the SWIG developers
 * and at http://www.swig.org/legal.html.
 *
 * s-exp.cxx
 *
 * A parse tree represented as Lisp s-expressions.
 * ----------------------------------------------------------------------------- */

char cvsroot_s_exp_cxx[] = "$Id: s-exp.cxx 11876 2010-02-27 23:53:33Z wsfulton $";

#include "swigmod.h"
#include "dohint.h"

static const char *usage = "\
S-Exp Options (available with -sexp)\n\
     -typemaplang <lang> - Typemap language\n\n";

//static Node *view_top = 0;
static File *out = 0;

class Sexp:public Language {
public:
  int indent_level;
   Sexp():indent_level(0) {
  }
  
  virtual ~ Sexp() {
  }

  virtual void main(int argc, char *argv[]) {
    // Add a symbol to the parser for conditional compilation
    Preprocessor_define("SWIGSEXP 1", 0);

    SWIG_typemap_lang("sexp");
    for (int iX = 0; iX < argc; iX++) {
      if (strcmp(argv[iX], "-typemaplang") == 0) {
	Swig_mark_arg(iX);
	iX++;
	SWIG_typemap_lang(argv[iX]);
	Swig_mark_arg(iX);
	continue;
      }
      if (strcmp(argv[iX], "-help") == 0) {
	fputs(usage, stdout);
      }
    }
  }

  DOHHash *print_circle_hash;
  int print_circle_count;
  int hanging_parens;
  bool need_whitespace;
  bool need_newline;

  /* Top of the parse tree */
  virtual int top(Node *n) {
    if (out == 0) {
      String *outfile = Getattr(n, "outfile");
      Replaceall(outfile, "_wrap.cxx", ".lisp");
      Replaceall(outfile, "_wrap.c", ".lisp");
      out = NewFile(outfile, "w", SWIG_output_files());
      if (!out) {
	FileErrorDisplay(outfile);
	SWIG_exit(EXIT_FAILURE);
      }
    }
    String *f_sink = NewString("");
    Swig_register_filebyname("header", f_sink);
    Swig_register_filebyname("wrapper", f_sink);
    Swig_register_filebyname("begin", f_sink);
    Swig_register_filebyname("runtime", f_sink);
    Swig_register_filebyname("init", f_sink);

    Swig_banner_target_lang(out, ";;;");

    Language::top(n);
    Printf(out, "\n");
    Printf(out, ";;; Lisp parse tree produced by SWIG\n");
    print_circle_hash = DohNewHash();
    print_circle_count = 0;
    hanging_parens = 0;
    need_whitespace = 0;
    need_newline = 0;
    Sexp_print_node(n);
    flush_parens();
    return SWIG_OK;
  }

  void print_indent() {
    int i;
    for (i = 0; i < indent_level; i++) {
      Printf(out, " ");
    }
  }

  void open_paren(const String *oper) {
    flush_parens();
    Printf(out, "(");
    if (oper)
      Printf(out, "%s ", oper);
    indent_level += 2;
  }

  void close_paren(bool neednewline = false) {
    hanging_parens++;
    if (neednewline)
      print_lazy_whitespace();
    indent_level -= 2;
  }

  void flush_parens() {
    int i;
    if (hanging_parens) {
      for (i = 0; i < hanging_parens; i++)
	Printf(out, ")");
      hanging_parens = 0;
      need_newline = true;
      need_whitespace = true;
    }
    if (need_newline) {
      Printf(out, "\n");
      print_indent();
      need_newline = false;
      need_whitespace = false;
    } else if (need_whitespace) {
      Printf(out, " ");
      need_whitespace = false;
    }
  }

  void print_lazy_whitespace() {
    need_whitespace = 1;
  }

  void print_lazy_newline() {
    need_newline = 1;
  }

  bool internal_key_p(DOH *key) {
    return ((Cmp(key, "nodeType") == 0)
	    || (Cmp(key, "firstChild") == 0)
	    || (Cmp(key, "lastChild") == 0)
	    || (Cmp(key, "parentNode") == 0)
	    || (Cmp(key, "nextSibling") == 0)
	    || (Cmp(key, "previousSibling") == 0)
	    || (Cmp(key, "csym:nextSibling") == 0)
	    || (Cmp(key, "csym:previousSibling") == 0)
	    || (Cmp(key, "typepass:visit") == 0)
	    || (Cmp(key, "allocate:visit") == 0)
	    || (*(Char(key)) == '$'));
  }

  bool boolean_key_p(DOH *key) {
    return ((Cmp(key, "allocate:default_constructor") == 0)
	    || (Cmp(key, "allocate:default_destructor") == 0)
	    || (Cmp(key, "allows_typedef") == 0)
	    || (Cmp(key, "feature:immutable") == 0));
  }

  bool list_key_p(DOH *key) {
    return ((Cmp(key, "parms") == 0)
	    || (Cmp(key, "baselist") == 0));
  }

  bool plist_key_p(DOH *key)
      // true if KEY is the name of data that is a mapping from keys to
      // values, which should be printed as a plist.
  {
    return ((Cmp(key, "typescope") == 0));
  }

  bool maybe_plist_key_p(DOH *key) {
    return (Strncmp(key, "tmap:", 5) == 0);
  }

  bool print_circle(DOH *obj, bool list_p)
      // We have a complex object, which might be referenced several
      // times, or even recursively.  Use Lisp's reader notation for
      // circular structures (#n#, #n=).
      //
      // An object can be printed in list-mode or object-mode; LIST_P toggles.
      // return TRUE if OBJ still needs to be printed
  {
    flush_parens();
    // Following is a silly hack.  It works around the limitation of
    // DOH's hash tables that only work with string keys!
    char address[32];
    sprintf(address, "%p%c", obj, list_p ? 'L' : 'O');
    DOH *placeholder = Getattr(print_circle_hash, address);
    if (placeholder) {
      Printv(out, placeholder, NIL);
      return false;
    } else {
      String *placeholder = NewStringf("#%d#", ++print_circle_count);
      Setattr(print_circle_hash, address, placeholder);
      Printf(out, "#%d=", print_circle_count);
      return true;
    }
  }

  void Sexp_print_value_of_key(DOH *value, DOH *key) {
    if ((Cmp(key, "parms") == 0) || (Cmp(key, "wrap:parms") == 0)
	|| (Cmp(key, "kwargs") == 0) || (Cmp(key, "pattern") == 0))
      Sexp_print_parms(value);
    else if (plist_key_p(key))
      Sexp_print_plist(value);
    else if (maybe_plist_key_p(key)) {
      if (DohIsMapping(value))
	Sexp_print_plist(value);
      else
	Sexp_print_doh(value);
    } else if (list_key_p(key))
      Sexp_print_list(value);
    else if (boolean_key_p(key))
      Sexp_print_boolean(value);
    else
      Sexp_print_doh(value);
  }

  void Sexp_print_boolean(DOH *obj) {
    flush_parens();
    /* See DOH/Doh/base.c, DohGetInt() */
    if (DohIsString(obj)) {
      if (atoi(Char(obj)) != 0)
	Printf(out, "t");
      else
	Printf(out, "nil");
    } else
      Printf(out, "nil");
  }

  void Sexp_print_list(DOH *obj) {
    if (print_circle(obj, true)) {
      open_paren(NIL);
      for (; obj; obj = nextSibling(obj)) {
	Sexp_print_doh(obj);
	print_lazy_whitespace();
      }
      close_paren(true);
    }
  }

  void Sexp_print_parms(DOH *obj) {
    // print it as a list of plists
    if (print_circle(obj, true)) {
      open_paren(NIL);
      for (; obj; obj = nextSibling(obj)) {
	if (DohIsMapping(obj)) {
	  Iterator k;
	  open_paren(NIL);
	  for (k = First(obj); k.key; k = Next(k)) {
	    if (!internal_key_p(k.key)) {
	      DOH *value = Getattr(obj, k.key);
	      Sexp_print_as_keyword(k.key);
	      Sexp_print_value_of_key(value, k.key);
	      print_lazy_whitespace();
	    }
	  }
	  close_paren(true);
	} else
	  Sexp_print_doh(obj);
	print_lazy_whitespace();
      }
      close_paren(true);
    }
  }

  void Sexp_print_doh(DOH *obj) {
    flush_parens();
    if (DohIsString(obj)) {
      String *o = Str(obj);
      Replaceall(o, "\\", "\\\\");
      Replaceall(o, "\"", "\\\"");
      Printf(out, "\"%s\"", o);
      Delete(o);
    } else {
      if (print_circle(obj, false)) {
	// Dispatch type
	if (nodeType(obj)) {
	  Sexp_print_node(obj);
	}

	else if (DohIsMapping(obj)) {
	  Iterator k;
	  open_paren(NIL);
	  for (k = First(obj); k.key; k = Next(k)) {
	    if (!internal_key_p(k.key)) {
	      DOH *value = Getattr(obj, k.key);
	      flush_parens();
	      open_paren(NIL);
	      Sexp_print_doh(k.key);
	      Printf(out, " . ");
	      Sexp_print_value_of_key(value, k.key);
	      close_paren();
	    }
	  }
	  close_paren();
	} else if (strcmp(ObjType(obj)->objname, "List") == 0) {
	  int i;
	  open_paren(NIL);
	  for (i = 0; i < Len(obj); i++) {
	    DOH *item = Getitem(obj, i);
	    Sexp_print_doh(item);
	  }
	  close_paren();
	} else {
	  // What is it?
	  Printf(out, "#<DOH %s %x>", ObjType(obj)->objname, obj);
	}
      }
    }
  }

  void Sexp_print_as_keyword(const DOH *k) {
    /* Print key, replacing ":" with "-" because : is CL's package prefix */
    flush_parens();
    String *key = NewString(k);
    Replaceall(key, ":", "-");
    Replaceall(key, "_", "-");
    Printf(out, ":%s ", key);
    Delete(key);
  }

  void Sexp_print_plist_noparens(DOH *obj) {
    /* attributes map names to objects */
    Iterator k;
    bool first;
    for (k = First(obj), first = true; k.key; k = Next(k), first = false) {
      if (!internal_key_p(k.key)) {
	DOH *value = Getattr(obj, k.key);
	flush_parens();
	if (!first) {
	  Printf(out, " ");
	}
	Sexp_print_as_keyword(k.key);
	/* Print value */
	Sexp_print_value_of_key(value, k.key);
      }
    }
  }

  void Sexp_print_plist(DOH *obj) {
    flush_parens();
    if (print_circle(obj, true)) {
      open_paren(NIL);
      Sexp_print_plist_noparens(obj);
      close_paren();
    }
  }

  void Sexp_print_attributes(Node *obj) {
    Sexp_print_plist_noparens(obj);
  }

  void Sexp_print_node(Node *obj) {
    Node *cobj;
    open_paren(nodeType(obj));
    /* A node has an attribute list... */
    Sexp_print_attributes(obj);
    /* ... and child nodes. */
    cobj = firstChild(obj);
    if (cobj) {
      print_lazy_newline();
      flush_parens();
      Sexp_print_as_keyword("children");
      open_paren(NIL);
      for (; cobj; cobj = nextSibling(cobj)) {
	Sexp_print_node(cobj);
      }
      close_paren();
    }
    close_paren();
  }


  virtual int functionWrapper(Node *n) {
    ParmList *l = Getattr(n, "parms");
    Wrapper *f = NewWrapper();
    emit_attach_parmmaps(l, f);
    Setattr(n, "wrap:parms", l);
    DelWrapper(f);
    return SWIG_OK;
  }

};


static Language *new_swig_sexp() {
  return new Sexp();
}
extern "C" Language *swig_sexp(void) {
  return new_swig_sexp();
}