Merged revisions 10726-10727,10738,10743,10747,10749 via svnmerge from

https://swig.svn.sourceforge.net/svnroot/swig/trunk

........
  r10726 | wuzzeb | 2008-08-02 10:28:02 +0200 (Sat, 02 Aug 2008) | 1 line
  
  Commit patch 2019314
........
  r10727 | wuzzeb | 2008-08-02 10:49:43 +0200 (Sat, 02 Aug 2008) | 1 line
  
  add assert.h to fix chicken build of external runtime (ext_test testsuite)
........
  r10738 | talby | 2008-08-07 08:28:13 +0200 (Thu, 07 Aug 2008) | 2 lines
  
  hoist globals to local scope where trival.
........
  r10743 | talby | 2008-08-08 05:10:55 +0200 (Fri, 08 Aug 2008) | 2 lines
  
  initial steps to clean up perl5 class methods (primarily constructors).
........
  r10747 | talby | 2008-08-09 06:08:26 +0200 (Sat, 09 Aug 2008) | 2 lines
  
  moves perl space constructor fixups into wrapper code.
........
  r10749 | talby | 2008-08-10 01:57:55 +0200 (Sun, 10 Aug 2008) | 2 lines
  
  usage_func() fix + CHANGES.current entry to explain my past few commits.
........


git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/branches/gsoc2008-jezabek@10793 626c5289-ae23-0410-ae9c-e8d60b6d4f22

7 files changed, 136 insertions, 65 deletions

diff --git a/CHANGES.current b/CHANGES.current
index eb8d81e29..7d1b70ca7 100644
--- a/CHANGES.current
+++ b/CHANGES.current
@@ -1,6 +1,14 @@
 Version 1.3.37 (in progress)
 =============================
 
+2008-08-09: talby
+            [Perl5] Unify Perl and C portions of constructor wrappers.
+
+2008-08-02: wuzzeb
+            [Chicken,Allegro] Commit Patch 2019314
+            Fixes a build error in chicken, and several build errors and other errors
+            in Allegro CL
+
 2008-07-19: wsfulton
             Fix building of Tcl examples/test-suite on Mac OSX reported by Gideon Simpson.
 
diff --git a/Examples/test-suite/perl5/imports_runme.pl b/Examples/test-suite/perl5/imports_runme.pl
index fd730fedf..13ca08a1c 100644
--- a/Examples/test-suite/perl5/imports_runme.pl
+++ b/Examples/test-suite/perl5/imports_runme.pl
@@ -1,5 +1,5 @@
 use imports_b;
 use imports_a;
 
-$x = imports_bc::new_B();
+$x = imports_b::B->new();
 imports_ac::A_hello($x);
diff --git a/Lib/allegrocl/allegrocl.swg b/Lib/allegrocl/allegrocl.swg
index 0ae8ed76c..8132e4628 100644
--- a/Lib/allegrocl/allegrocl.swg
+++ b/Lib/allegrocl/allegrocl.swg
@@ -296,15 +296,30 @@ $body)"
 	  sym))))
 
 (cl::defun full-name (id type arity class)
-  (cl::case type
-    (:getter (cl::format nil "~@[~A_~]~A" class id))
-    (:constructor (cl::format nil "new_~A~@[~A~]" id arity))
-    (:destructor (cl::format nil "delete_~A" id))
-    (:type (cl::format nil "ff_~A" id))
-    (:slot id)
-    (:ff-operator (cl::format nil "ffi_~A" id))
-    (otherwise (cl::format nil "~@[~A_~]~A~@[~A~]"
-                       class id arity))))
+  ; We need some kind of a hack here to handle template classes
+  ; and other synonym types right. We need the original name.
+  (let*( (sym (read-symbol-from-string 
+                (if (eq *swig-identifier-converter* 'identifier-convert-lispify)
+                  (string-lispify id)
+                  id)))
+         (sym-class (find-class sym nil))
+         (id (cond ( (not sym-class)
+                     id )
+                   ( (and sym-class
+                          (not (eq (class-name sym-class)
+                                sym)))
+                     (class-name sym-class) )
+                   ( t
+                     id ))) )
+    (cl::case type
+      (:getter (cl::format nil "~@[~A_~]~A" class id))
+      (:constructor (cl::format nil "new_~A~@[~A~]" id arity))
+      (:destructor (cl::format nil "delete_~A" id))
+      (:type (cl::format nil "ff_~A" id))
+      (:slot id)
+      (:ff-operator (cl::format nil "ffi_~A" id))
+      (otherwise (cl::format nil "~@[~A_~]~A~@[~A~]"
+                         class id arity)))))
   
 (cl::defun identifier-convert-null (id &key type class arity)
   (cl::if (cl::eq type :setter)
@@ -312,40 +327,37 @@ $body)"
                id :type :getter :class class :arity arity))
       (read-symbol-from-string (full-name id type arity class))))
 
-(cl::defun identifier-convert-lispify (cname &key type class arity)
-  (cl::assert (cl::stringp cname))
-  (cl::when (cl::eq type :setter)
-    (cl::return-from identifier-convert-lispify
-      `(cl::setf ,(identifier-convert-lispify
-               cname :type :getter :class class :arity arity))))
-  (cl::setq cname (full-name cname type arity class))
-  (cl::if (cl::eq type :constant)
-      (cl::setf cname (cl::format nil "*~A*" cname)))
-  (cl::setf cname (excl::replace-regexp cname "_" "-"))
-  (cl::let ((lastcase :other)
-       	    newcase char res)
+(cl::defun string-lispify (str)
+  (cl::let ( (cname (excl::replace-regexp str "_" "-"))
+             (lastcase :other)
+             newcase char res ) 
     (cl::dotimes (n (cl::length cname))
       (cl::setf char (cl::schar cname n))
       (excl::if* (cl::alpha-char-p char)
          then
               (cl::setf newcase (cl::if (cl::upper-case-p char) :upper :lower))
-
-              (cl::when (cl::or (cl::and (cl::eq lastcase :upper)
-	      				 (cl::eq newcase :lower))
-                                (cl::and (cl::eq lastcase :lower)
-					 (cl::eq newcase :upper)))
+              (cl::when (cl::and (cl::eq lastcase :lower)
+                                 (cl::eq newcase :upper))
                 ;; case change... add a dash
                 (cl::push #\- res)
                 (cl::setf newcase :other))
-
               (cl::push (cl::char-downcase char) res)
-
               (cl::setf lastcase newcase)
-
          else
               (cl::push char res)
               (cl::setf lastcase :other)))
-    (read-symbol-from-string (cl::coerce (cl::nreverse res) 'string))))
+    (cl::coerce (cl::nreverse res) 'string)))
+  
+(cl::defun identifier-convert-lispify (cname &key type class arity)
+  (cl::assert (cl::stringp cname))
+  (cl::when (cl::eq type :setter)
+    (cl::return-from identifier-convert-lispify
+      `(cl::setf ,(identifier-convert-lispify
+               cname :type :getter :class class :arity arity))))
+  (cl::setq cname (full-name cname type arity class))
+  (cl::if (cl::eq type :constant)
+      (cl::setf cname (cl::format nil "*~A*" cname)))
+  (read-symbol-from-string (string-lispify cname)))
 
 (cl::defun id-convert-and-export (name &rest kwargs)
   (cl::multiple-value-bind (symbol package)
diff --git a/Lib/chicken/chicken.swg b/Lib/chicken/chicken.swg
index d8b71874e..a8d1b5a57 100644
--- a/Lib/chicken/chicken.swg
+++ b/Lib/chicken/chicken.swg
@@ -10,6 +10,7 @@
 /* chicken.h has to appear first. */
 
 %insert(runtime) %{
+#include <assert.h>
 #include <chicken.h>
 %}
 
diff --git a/Lib/chicken/chickenrun.swg b/Lib/chicken/chickenrun.swg
index bd7242407..8703ea65a 100644
--- a/Lib/chicken/chickenrun.swg
+++ b/Lib/chicken/chickenrun.swg
@@ -7,6 +7,7 @@
  * ----------------------------------------------------------------------------- */
 
 #include <chicken.h>
+#include <assert.h>
 #include <stdio.h>
 #include <string.h>
 #include <stdlib.h>
diff --git a/Source/Modules/allegrocl.cxx b/Source/Modules/allegrocl.cxx
index c1d271c57..217c89b1f 100644
--- a/Source/Modules/allegrocl.cxx
+++ b/Source/Modules/allegrocl.cxx
@@ -1084,7 +1084,8 @@ void emit_synonym(Node *synonym) {
   of_ltype = lookup_defined_foreign_ltype(of_name);
 
   // Printf(f_clhead,";; from emit-synonym\n");
-  Printf(f_clhead, "(swig-def-synonym-type %s\n   %s\n   %s)\n", syn_ltype, of_ltype, syn_type);
+  if( of_ltype )
+      Printf(f_clhead, "(swig-def-synonym-type %s\n   %s\n   %s)\n", syn_ltype, of_ltype, syn_type);
 
   Delete(synonym_ns);
   Delete(of_ns_list);
@@ -1521,6 +1522,8 @@ void ALLEGROCL::main(int argc, char *argv[]) {
 
   }
 
+  Preprocessor_define("SWIGALLEGROCL 1", 0);
+
   allow_overloading();
 }
 
@@ -1531,7 +1534,7 @@ int ALLEGROCL::top(Node *n) {
 
   swig_package = unique_swig_package ? NewStringf("swig.%s", module_name) : NewString("swig");
 
-  Printf(cl_filename, "%s%s.cl", SWIG_output_directory(), Swig_file_basename(Getattr(n,"infile")));
+  Printf(cl_filename, "%s%s.cl", SWIG_output_directory(), module_name);
 
   f_cl = NewFile(cl_filename, "w");
   if (!f_cl) {
@@ -2628,7 +2631,7 @@ int ALLEGROCL::functionWrapper(Node *n) {
   String *actioncode = emit_action(n);
 
   String *tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode);
-  if (tm) {
+  if (!is_void_return && tm) {
     Replaceall(tm, "$result", "lresult");
     Printf(f->code, "%s\n", tm);
     Printf(f->code, "    return lresult;\n");
diff --git a/Source/Modules/perl5.cxx b/Source/Modules/perl5.cxx
index 6e706fc8d..2e714efe5 100644
--- a/Source/Modules/perl5.cxx
+++ b/Source/Modules/perl5.cxx
@@ -100,8 +100,6 @@ static int have_constructor = 0;
 static int have_destructor = 0;
 static int have_data_members = 0;
 static String *class_name = 0;	/* Name of the class (what Perl thinks it is) */
-static String *real_classname = 0;	/* Real name of C/C++ class */
-static String *fullclassname = 0;
 
 static String *pcode = 0;	/* Perl code associated with each class */
 						  /* static  String   *blessedmembers = 0;     *//* Member data associated with each class */
@@ -558,6 +556,7 @@ public:
     String *iname = Getattr(n, "sym:name");
     SwigType *d = Getattr(n, "type");
     ParmList *l = Getattr(n, "parms");
+    ParmList *outer = Getattr(n, "perl5:implicits");
     String *overname = 0;
 
     Parm *p;
@@ -567,7 +566,7 @@ public:
     String *tm;
     String *cleanup, *outarg;
     int num_saved = 0;
-    int num_arguments, num_required;
+    int num_arguments, num_required, num_implicits;
     int varargs = 0;
 
     if (Getattr(n, "sym:overloaded")) {
@@ -589,6 +588,19 @@ public:
     Printv(f->def, "XS(", wname, ") {\n", "{\n",	/* scope to destroy C++ objects before croaking */
 	   NIL);
 
+    num_implicits = 0;
+    if (outer) {
+      Parm *tmp = outer;
+      Parm *tail;
+      while(tmp) {
+        tail = tmp;
+        num_implicits++;
+        tmp = nextSibling(tmp);
+      }
+      /* link the outer with inner parms */
+      set_nextSibling(tail, l);
+    }
+
     emit_parameter_variables(l, f);
     emit_attach_parmmaps(l, f);
     Setattr(n, "wrap:parms", l);
@@ -601,13 +613,29 @@ public:
 
     /* Check the number of arguments */
     if (!varargs) {
-      Printf(f->code, "    if ((items < %d) || (items > %d)) {\n", num_required, num_arguments);
+      Printf(f->code, "    if ((items < %d) || (items > %d)) {\n",
+        num_required + num_implicits, num_arguments + num_implicits);
     } else {
-      Printf(f->code, "    if (items < %d) {\n", num_required);
+      Printf(f->code, "    if (items < %d) {\n",
+        num_required + num_implicits);
     }
-    Printf(f->code, "        SWIG_croak(\"Usage: %s\");\n", usage_func(Char(iname), d, l));
+    Printf(f->code, "        SWIG_croak(\"Usage: %s\");\n", usage_func(Char(iname), d, outer, l));
     Printf(f->code, "}\n");
 
+    if (num_implicits) {
+      /* TODO: support implicits of types other than SVs */
+      Parm *p = outer;
+      for(i = 0; i < num_implicits; i++) {
+        String *pname = Getattr(p, "name");
+        String *pinit = SwigType_str(Getattr(p, "type"), pname);
+        Wrapper_add_local(f, pname, pinit);
+        Delete(pinit);
+        Printf(f->code, "%s = ST(%d);\n", pname, i++);
+        p = nextSibling(p);
+      }
+      if (l)
+        Printf(f->code, "ax += %d;\n", num_implicits);
+    }
     /* Write code to extract parameters. */
     i = 0;
     for (i = 0, p = l; i < num_arguments; i++) {
@@ -720,6 +748,9 @@ public:
       Wrapper_add_localv(f, "_saved", "SV *", temp, NIL);
     }
 
+    if (num_implicits && l)
+      Printf(f->code, "ax -= %d;\n", num_implicits);
+
     /* Now write code to make the function call */
 
     Swig_director_emit_dynamic_cast(n, f);
@@ -766,6 +797,11 @@ public:
       Printf(f->code, "%s\n", tm);
     }
 
+    if (blessed && Equal(nodeType(n), "constructor")) {
+      Append(f->code,
+        "if (SvOK(ST(0))) sv_bless(ST(0), gv_stashsv(proto, 0));\n");
+    }
+
     Printv(f->code, "XSRETURN(argvi);\n", "fail:\n", cleanup, "SWIG_croak_null();\n" "}\n" "}\n", NIL);
 
     /* Add the dXSARGS last */
@@ -797,6 +833,10 @@ public:
       Printv(df->def, "XS(", dname, ") {\n", NIL);
 
       Wrapper_add_local(df, "dXSARGS", "dXSARGS");
+      if (num_implicits) {
+        Printf(df->code, "ax += %d;\n", num_implicits);
+        Printf(df->code, "items -= %d;\n", num_implicits);
+      }
       Printv(df->code, dispatch, "\n", NIL);
       Printf(df->code, "croak(\"No matching function for overloaded '%s'\");\n", iname);
       Printf(df->code, "XSRETURN(0);\n");
@@ -1033,7 +1073,7 @@ public:
   /* ------------------------------------------------------------
    * usage_func()
    * ------------------------------------------------------------ */
-  char *usage_func(char *iname, SwigType *, ParmList *l) {
+  char *usage_func(char *iname, SwigType *, ParmList *il, ParmList *l) {
     static String *temp = 0;
     Parm *p;
     int i;
@@ -1043,13 +1083,17 @@ public:
     Clear(temp);
     Printf(temp, "%s(", iname);
 
-    /* Now go through and print parameters */
-    p = l;
     i = 0;
+    /* Print implicit parameters */
+    for(p = il; p; p = nextSibling(p))
+      Printv(temp, (i > 0 ? "," : ""), Getattr(p, "name"), NIL);
+    /* Now go through and print normal parameters */
+    p = l;
     while (p != 0) {
       SwigType *pt = Getattr(p, "type");
       String *pn = Getattr(p, "name");
       if (!checkAttribute(p,"tmap:in:numinputs","0")) {
+        if (i > 0) Append(temp, ",");
 	/* If parameter has been named, use that.   Otherwise, just print a type  */
 	if (SwigType_type(pt) != T_VOID) {
 	  if (Len(pn) > 0) {
@@ -1059,16 +1103,8 @@ public:
 	  }
 	}
 	i++;
-	p = nextSibling(p);
-	if (p)
-	  if (!checkAttribute(p,"tmap:in:numinputs","0"))
-	    Putc(',', temp);
-      } else {
-	p = nextSibling(p);
-	if (p)
-	  if ((i > 0) && (!checkAttribute(p,"tmap:in:numinputs","0")))
-	    Putc(',', temp);
       }
+      p = nextSibling(p);
     }
     Printf(temp, ");");
     return Char(temp);
@@ -1186,6 +1222,8 @@ public:
    * ------------------------------------------------------------ */
 
   virtual int classHandler(Node *n) {
+    String *name = 0; /* Real name of C/C++ class */
+    String *fullclassname = 0;
 
     if (blessed) {
       have_constructor = 0;
@@ -1205,7 +1243,7 @@ public:
       } else {
 	fullclassname = NewString(class_name);
       }
-      real_classname = Getattr(n, "name");
+      name = Getattr(n, "name");
       pcode = NewString("");
       // blessedmembers = NewString("");
     }
@@ -1217,7 +1255,7 @@ public:
     /* Finish the rest of the class */
     if (blessed) {
       /* Generate a client-data entry */
-      SwigType *ct = NewStringf("p.%s", real_classname);
+      SwigType *ct = NewStringf("p.%s", name);
       Printv(f_init, "SWIG_TypeClientData(SWIGTYPE", SwigType_manglestr(ct), ", (void*) \"", fullclassname, "\");\n", NIL);
       SwigType_remember(ct);
       Delete(ct);
@@ -1490,6 +1528,15 @@ public:
 
     String *symname = Getattr(n, "sym:name");
 
+    {
+      String *type = NewString("SV");
+      SwigType_add_pointer(type);
+      Parm *p = NewParm(type, "proto");
+      Delete(type);
+      Setattr(n, "perl5:implicits", p);
+      Delete(p);
+    }
+
     member_func = 1;
     Language::constructorHandler(n);
 
@@ -1501,17 +1548,16 @@ public:
 	Delete(plaction);
 	Printv(pcode, plcode, NIL);
       } else {
-	if ((Cmp(symname, class_name) == 0)) {
-	  /* Emit a blessed constructor  */
-	  Printf(pcode, "sub new {\n");
-	} else {
-	  /* Constructor doesn't match classname so we'll just use the normal name  */
-	  Printv(pcode, "sub ", Swig_name_construct(symname), " () {\n", NIL);
-	}
-
-	Printv(pcode,
-	       tab4, "my $pkg = shift;\n",
-	       tab4, "my $self = ", cmodule, "::", Swig_name_construct(symname), "(@_);\n", tab4, "bless $self, $pkg if defined($self);\n", "}\n\n", NIL);
+	/* Emit a blessed constructor  */
+        String *cname = Swig_name_construct(symname);
+        char *pname;
+        /* override Class->Class to be Class->new */
+	if (Cmp(symname, class_name) == 0)
+          pname = "new";
+	else
+          pname = Char(cname);
+        Printf(pcode, "*%s = *%s::%s;\n", pname, cmodule, cname);
+        Delete(cname);
 
 	have_constructor = 1;
       }