1 files changed, 394 insertions, 0 deletions
diff --git a/Source/Modules/s-exp.cxx b/Source/Modules/s-exp.cxx
new file mode 100644
index 0000000..c87d18c
--- /dev/null
+++ b/Source/Modules/s-exp.cxx
@@ -0,0 +1,394 @@
+/* ----------------------------------------------------------------------------- 
+ * See the LICENSE file for information on copyright, usage and redistribution
+ * of SWIG, and the README file for authors - http://www.swig.org/release.html.
+ *
+ * s-exp.cxx
+ *
+ * A parse tree represented as Lisp s-expressions.
+ * ----------------------------------------------------------------------------- */
+
+char cvsroot_s_exp_cxx[] = "$Id: s-exp.cxx 11133 2009-02-20 07:52:24Z 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();
+}