;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: interface.lisp,v 1.9 2008-10-08 16:34:07 espen Exp $
+;; $Id: interface.lisp,v 1.10 2008-12-10 02:40:18 espen Exp $
(in-package "GFFI")
#'string-capitalize
(cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
-(defun default-type-name (alien-name)
- (let ((parts
- (mapcar
- #'string-upcase
- (split-string-if alien-name #'upper-case-p))))
- (intern
- (concatenate-strings (rest parts) #\-)
- (find-prefix-package (first parts)))))
+(defun split-alien-name (alien-name)
+ (let ((parts (split-string-if alien-name #'upper-case-p)))
+ (do ((prefix (first parts) (concatenate 'string prefix (first rest)))
+ (rest (rest parts) (cdr rest)))
+ ((null rest)
+ (error "Couldn't split alien name '~A' to find a registered prefix"
+ alien-name))
+ (when (find-prefix-package prefix)
+ (return (values (string-upcase (concatenate-strings rest #\-))
+ (find-prefix-package prefix)))))))
+(defun default-type-name (alien-name)
+ (multiple-value-call #'intern (split-alien-name alien-name)))
(defun in-arg-p (style)
(find style '(:in :in/out :in/return :in-out :return)))
;;;; Type expansion
+;; A hack to make the TYPE-EXPAND code for SBCL work.
+#?+(pkg-config:sbcl>= 1 0 35 15)
+(sb-ext:without-package-locks
+ (setf (symbol-function 'sb-kernel::type-expand)
+ (lambda (form) (typexpand form))))
+
(defun type-expand-1 (form)
#+(or cmu sbcl)
(let ((def (cond ((symbolp form)
(error "~A can not be expanded to ~A" form type))))))
(expand form)))
+(defun type-equal-p (type1 type2)
+ (and (subtypep type1 type2) (subtypep type2 type1)))
;;;; Type methods