Added TRANSLATE-NAME-{TO,FROM}-FOREIGN.

Patch courtesy of Greg Pfeil. Closes lp:622272.

doc/cffi-manual.texinfo

@@ -251,6 +251,10 @@ Functions
 * defcfun::                     Defines a foreign function.
 * foreign-funcall::             Performs a call to a foreign function.
 * foreign-funcall-pointer::     Performs a call through a foreign pointer.
+* translate-camelcase-name::    Converts a camelCase foreign name to/from a Lisp name.
+* translate-name-from-foreign::  Converts a foreign name to a Lisp name.
+* translate-name-to-foreign::   Converts a Lisp name to a foreign name.
+* translate-underscore-separated-name::  Converts an underscore_separated foreign name to/from a Lisp name.
 
 Libraries
 
@@ -5046,6 +5050,10 @@ Dictionary
 * defcfun::                     
 * foreign-funcall::             
 * foreign-funcall-pointer::     
+* translate-camelcase-name::
+* translate-name-from-foreign::
+* translate-name-to-foreign::
+* translate-underscore-separated-name::
 @end menu
 
 @c @node Calling Foreign Functions
@@ -5269,7 +5277,7 @@ CFFI> (foreign-funcall "printf" :string (format nil "%s: %d.~%")
 @c FOREIGN-FUNCALL-POINTER
 
 @page
-@node foreign-funcall-pointer,  , foreign-funcall, Functions
+@node foreign-funcall-pointer,  translate-camelcase-name, foreign-funcall, Functions
 @heading foreign-funcall-pointer
 @subheading Syntax
 @Macro{foreign-funcall-pointer pointer options &rest arguments @res{} return-value}
@@ -5329,6 +5337,220 @@ CFFI> (foreign-funcall-pointer (foreign-symbol-pointer "abs") ()
 @seealso{foreign-funcall}
 
 
+@c ===================================================================
+@c TRANSLATE-CAMELCASE-NAME
+
+@page
+@node translate-camelcase-name, translate-name-from-foreign, foreign-funcall-pointer, Functions
+@heading translate-camelcase-name
+@subheading Syntax
+@Function{translate-camelcase-name name &key upper-initial-p special-words @res{} return-value}
+
+@subheading Arguments and Values
+
+@table @var
+@item name
+Either a symbol or a string.
+
+@item upper-initial-p
+A generalized boolean.
+
+@item special words
+A list of strings.
+
+@item return-value
+If @var{name} is a symbol, this is a string, and vice versa.
+@end table
+
+@subheading Description
+@code{translate-camelcase-name} is a helper function for
+specializations of @code{translate-name-from-foreign} and
+@code{translate-name-to-foreign}. It handles the common case of
+converting between foreign camelCase names and lisp
+names. @var{upper-initial-p} indicates whether the first letter of the
+foreign name should be uppercase. @var{special-words} is a list of
+strings that should be treated atomically in translation. This list is
+case-sensitive.
+
+@subheading Examples
+
+@lisp
+CFFI> (translate-camelcase-name some-xml-function)
+@result{} "someXmlFunction"
+CFFI> (translate-camelcase-name some-xml-function :upper-initial-p t)
+@result{} "SomeXmlFunction"
+CFFI> (translate-camelcase-name some-xml-function :special-words '("XML"))
+@result{} "someXMLFunction"
+CFFI> (translate-camelcase-name "someXMLFunction")
+@result{} SOME-X-M-L-FUNCTION
+CFFI> (translate-camelcase-name "someXMLFunction" :special-words '("XML"))
+@result{} SOME-XML-FUNCTION
+@end lisp
+
+@subheading See Also
+@seealso{translate-name-from-foreign} @*
+@seealso{translate-name-to-foreign} @*
+@seealso{translate-underscore-separated-name}
+
+
+@c ===================================================================
+@c TRANSLATE-NAME-FROM-FOREIGN
+
+@page
+@node translate-name-from-foreign, translate-name-to-foreign, translate-camelcase-name, Functions
+@heading translate-name-from-foreign
+@subheading Syntax
+@Function{translate-name-from-foreign foreign-name package &optional varp @res{} symbol}
+
+@subheading Arguments and Values
+
+@table @var
+@item foreign-name
+A string denoting a foreign function.
+
+@item package
+A Lisp package
+
+@item varp
+A generalized boolean.
+
+@item symbol
+The Lisp symbol to be used a function name.
+@end table
+
+@subheading Description
+@code{translate-name-from-foreign} is used by @code{@seealso{defcfun}}
+to handle the conversion of foreign names to lisp names. By default,
+it translates using
+@code{@seealso{translate-underscore-separated-name}}. However, you can
+create specialized methods on this function to make translating more
+closely match the foreign library's naming conventions.
+
+Specialize @var{package} on some package. This allows other packages
+to load libraries with different naming conventions.
+
+@subheading Examples
+
+@lisp
+CFFI> (defcfun "someXmlFunction" ...)
+@result{} SOMEXMLFUNCTION
+CFFI> (defmethod translate-name-from-foreign ((spec string)
+                                              (package (eql *package*))
+                                              &optional varp)
+        (let ((name (translate-camelcase-name spec)))
+          (if varp (intern "*~a*" name) name)))
+@result{} #<STANDARD-METHOD TRANSLATE-NAME-FROM-FOREIGN (STRING (EQL #<Package "SOME-PACKAGE">))>
+CFFI> (defcfun "someXmlFunction" ...)
+@result{} SOME-XML-FUNCTION
+@end lisp
+
+@subheading See Also
+@seealso{defcfun} @*
+@seealso{translate-camelcase-name} @*
+@seealso{translate-name-to-foreign} @*
+@seealso{translate-underscore-separated-name}
+
+
+@c ===================================================================
+@c TRANSLATE-NAME-TO-FOREIGN
+
+@page
+@node translate-name-to-foreign, translate-underscore-separated-name, translate-name-from-foreign, Functions
+@heading translate-name-to-foreign
+@subheading Syntax
+@Function{translate-name-to-foreign lisp-name package &optional varp @res{} string}
+
+@subheading Arguments and Values
+
+@table @var
+@item lisp-name
+A symbol naming the Lisp function to be created.
+
+@item package
+A Lisp package
+
+@item varp
+A generalized boolean.
+
+@item string
+The string representing the foreign function name.
+@end table
+
+@subheading Description
+@code{translate-name-to-foreign} is used by @code{@seealso{defcfun}}
+to handle the conversion of lisp names to foreign names. By default,
+it translates using
+@code{@seealso{translate-underscore-separated-name}}. However, you can
+create specialized methods on this function to make translating more
+closely match the foreign library's naming conventions.
+
+Specialize @var{package} on some package. This allows other packages
+to load libraries with different naming conventions.
+
+@subheading Examples
+
+@lisp
+CFFI> (defcfun some-xml-function ...)
+@result{} "some_xml_function"
+CFFI> (defmethod translate-name-to-foreign ((spec symbol)
+                                            (package (eql *package*))
+                                            &optional varp)
+        (let ((name (translate-camelcase-name spec)))
+          (if varp (subseq name 1 (1- (length name))) name)))
+@result{} #<STANDARD-METHOD TRANSLATE-NAME-TO-FOREIGN (STRING (EQL #<Package "SOME-PACKAGE">))>
+CFFI> (defcfun some-xml-function ...)
+@result{} "someXmlFunction"
+@end lisp
+
+@subheading See Also
+@seealso{defcfun} @*
+@seealso{translate-camelcase-name} @*
+@seealso{translate-name-from-foreign} @*
+@seealso{translate-underscore-separated-name}
+
+
+@c ===================================================================
+@c TRANSLATE-UNDERSCORE-SEPARATED-NAME
+
+@page
+@node translate-underscore-separated-name,  , translate-name-to-foreign, Functions
+@heading translate-underscore-separated-name
+@subheading Syntax
+@Function{translate-underscore-separated-name name @res{} return-value}
+
+@subheading Arguments and Values
+
+@table @var
+@item name
+Either a symbol or a string.
+
+@item return-value
+If @var{name} is a symbol, this is a string, and vice versa.
+@end table
+
+@subheading Description
+@code{translate-underscore-separated-name} is a helper function for
+specializations of
+@code{@seealso{translate-name-from-foreign}} and
+@code{@seealso{translate-name-to-foreign}}. It handles the common
+case of converting between foreign underscore_separated names and lisp
+names.
+
+@subheading Examples
+
+@lisp
+CFFI> (translate-underscore-separated-name some-xml-function)
+@result{} "some_xml_function"
+CFFI> (translate-camelcase-name "some_xml_function")
+@result{} SOME-XML-FUNCTION
+@end lisp
+
+@subheading See Also
+@seealso{translate-name-from-foreign} @*
+@seealso{translate-name-to-foreign} @*
+@seealso{translate-camelcase-name}
+
+
 @c ===================================================================
 @c CHAPTER: Libraries
 

src/functions.lisp

@@ -205,32 +205,92 @@ arguments and does type promotion for the variadic arguments."
            ,@,varargs
            ,',return-type)))))
 
-;;; The following four functions take care of parsing DEFCFUN's first
-;;; argument whose syntax can be one of:
-;;;
-;;;     1.  string
-;;;     2.  symbol
-;;;     3.  \( string [symbol] options* )
-;;;     4.  \( symbol [string] options* )
-;;;
-;;; The string argument denotes the foreign function's name. The
-;;; symbol argument is used to name the Lisp function. If one isn't
-;;; present, its name is derived from the other. See the user
-;;; documentation for an explanation of the derivation rules.
+(defgeneric translate-underscore-separated-name (name)
+  (:method ((name string))
+    (values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name)))))
+  (:method ((name symbol))
+    (substitute #\_ #\- (string-downcase (symbol-name name)))))
+
+(defun collapse-prefix (l special-words)
+  (unless (null l)
+    (multiple-value-bind (newpre skip) (check-prefix l special-words)
+      (cons newpre (collapse-prefix (nthcdr skip l) special-words)))))
+
+(defun check-prefix (l special-words)
+  (let ((pl (loop for i from (1- (length l)) downto 0
+                  collect (apply #'concatenate 'simple-string (butlast l i)))))
+    (loop for w in special-words
+          for p = (position-if #'(lambda (s) (string= s w)) pl)
+          when p do (return-from check-prefix (values (nth p pl) (1+ p))))
+    (values (first l) 1)))
+
+(defun split-if (test seq &optional (dir :before))
+  (remove-if #'(lambda (x) (equal x (subseq seq 0 0)))
+             (loop for start fixnum = 0
+                     then (if (eq dir :before)
+                              stop
+                              (the fixnum (1+ (the fixnum stop))))
+                   while (< start (length seq))
+                   for stop = (position-if test seq
+                                           :start (if (eq dir :elide)
+                                                      start
+                                                      (the fixnum (1+ start))))
+                   collect (subseq seq start
+                                   (if (and stop (eq dir :after))
+                                       (the fixnum (1+ (the fixnum stop)))
+                                       stop))
+                   while stop)))
+
+(defgeneric translate-camelcase-name (name &key upper-initial-p special-words)
+  (:method ((name string) &key upper-initial-p special-words)
+    (declare (ignore upper-initial-p))
+    (values (intern (reduce #'(lambda (s1 s2)
+                                (concatenate 'simple-string s1 "-" s2))
+                            (mapcar #'string-upcase
+                                    (collapse-prefix
+                                     (split-if #'(lambda (ch)
+                                                   (or (upper-case-p ch)
+                                                       (digit-char-p ch)))
+                                               name)
+                                     special-words))))))
+  (:method ((name symbol) &key upper-initial-p special-words)
+    (apply #'concatenate
+           'string
+           (loop for str in (split-if #'(lambda (ch) (eq ch #\-))
+                                          (string name)
+                                      :elide)
+                 for first-word-p = t then nil
+                 for e = (member str special-words
+                                 :test #'equal :key #'string-upcase)
+                 collect (cond
+                           ((and first-word-p (not upper-initial-p))
+                            (string-downcase str))
+                           (e (first e))
+                           (t (string-capitalize str)))))))
+
+(defgeneric translate-name-from-foreign (foreign-name package &optional varp)
+  (:method (foreign-name package &optional varp)
+    (declare (ignore package))
+    (let ((sym (translate-underscore-separated-name foreign-name)))
+      (if varp
+          (values (intern (format nil "*~A*" sym)))
+          sym))))
+
+(defgeneric translate-name-to-foreign (lisp-name package &optional varp)
+  (:method (lisp-name package &optional varp)
+    (declare (ignore package))
+    (let ((name (translate-underscore-separated-name lisp-name)))
+      (if varp
+          (string-trim '(#\*) name)
+          name))))
 
 (defun lisp-name (spec varp)
   (check-type spec string)
-  (intern
-   (format nil (if varp "*~A*" "~A")
-           (canonicalize-symbol-name-case
-            (substitute #\- #\_ spec)))))
+  (translate-name-from-foreign spec *package* varp))
 
 (defun foreign-name (spec varp)
   (check-type spec (and symbol (not null)))
-  (let ((name (substitute #\_ #\- (string-downcase spec))))
-    (if varp
-        (string-trim "*" name)
-        name)))
+  (translate-name-to-foreign spec *package* varp))
 
 (defun foreign-options (opts varp)
   (if varp
@@ -270,6 +330,17 @@ arguments and does type promotion for the variadic arguments."
     (t
      (error "Not a valid foreign function specifier: ~A" spec))))
 
+;;; DEFCFUN's first argument has can have the following syntax:
+;;;
+;;;     1.  string
+;;;     2.  symbol
+;;;     3.  \( string [symbol] options* )
+;;;     4.  \( symbol [string] options* )
+;;;
+;;; The string argument denotes the foreign function's name. The
+;;; symbol argument is used to name the Lisp function. If one isn't
+;;; present, its name is derived from the other. See the user
+;;; documentation for an explanation of the derivation rules.
 (defun parse-name-and-options (spec &optional varp)
   (multiple-value-bind (lisp-name foreign-name options)
       (%parse-name-and-options spec varp)

src/package.lisp

@@ -71,6 +71,10 @@
    #:defcfun
    #:foreign-funcall
    #:foreign-funcall-pointer
+   #:translate-camelcase-name
+   #:translate-name-from-foreign
+   #:translate-name-to-foreign
+   #:translate-underscore-separated-name
 
    ;; Foreign library operations.
    #:*foreign-library-directories*