Commit patch 2019314

git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@10726 626c5289-ae23-0410-ae9c-e8d60b6d4f22

CHANGES.current

@@ -1,6 +1,11 @@
 Version 1.3.37 (in progress)
 =============================
 
+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.
 

Lib/allegrocl/allegrocl.swg

@@ -296,15 +296,30 @@ $body)"
 	  sym))))
 
 (cl::defun full-name (id type arity class)
-  (cl::case type
+  ; We need some kind of a hack here to handle template classes
-    (:getter (cl::format nil "~@[~A_~]~A" class id))
+  ; and other synonym types right. We need the original name.
-    (:constructor (cl::format nil "new_~A~@[~A~]" id arity))
+  (let*( (sym (read-symbol-from-string 
-    (:destructor (cl::format nil "delete_~A" id))
+                (if (eq *swig-identifier-converter* 'identifier-convert-lispify)
-    (:type (cl::format nil "ff_~A" id))
+                  (string-lispify id)
-    (:slot id)
+                  id)))
-    (:ff-operator (cl::format nil "ffi_~A" id))
+         (sym-class (find-class sym nil))
-    (otherwise (cl::format nil "~@[~A_~]~A~@[~A~]"
+         (id (cond ( (not sym-class)
-                       class id arity))))
+                     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,6 +327,27 @@ $body)"
                id :type :getter :class class :arity arity))
       (read-symbol-from-string (full-name id type arity class))))
 
+(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::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)))
+    (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)
@@ -321,31 +357,7 @@ $body)"
   (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 "_" "-"))
+  (read-symbol-from-string (string-lispify cname)))
-  (cl::let ((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)))
-                ;; 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::defun id-convert-and-export (name &rest kwargs)
   (cl::multiple-value-bind (symbol package)

Lib/chicken/chicken.swg

@@ -10,6 +10,7 @@
 /* chicken.h has to appear first. */
 
 %insert(runtime) %{
+#include <assert.h>
 #include <chicken.h>
 %}
 

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");