Update AllegroCL for :long-long on 64-bit platforms

[uffi.git] / src / primitives.lisp

diff --git a/src/primitives.lisp b/src/primitives.lisp
index 81110254a4596e94a3c9c7a0f06c88ce422d063f..14763f732227e650dca9bac9cc898417172c6056 100644 (file)
--- a/src/primitives.lisp
+++ b/src/primitives.lisp
@@ -7,9 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
 ;;;;
 ;;;; *************************************************************************
 
@@ -22,7 +20,7 @@
 ; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL)
 ; So this provides a function to convert any quoted symbols to keywords.
 (defun keyword (obj)
-  (cond ((keywordp obj) 
+  (cond ((keywordp obj)
          obj)
         ((null obj)
          nil)
@@ -32,7 +30,7 @@
          (keyword (cadr obj)))
         ((stringp obj)
          (intern obj *keyword-package*))
-        (t 
+        (t
          obj)))
 
 ; Wrapper for unexported function we have to use
@@ -61,7 +59,7 @@ supports takes advantage of this optimization."
 (defmacro null-char-p (val)
   "Returns T if character is NULL"
   `(zerop ,val))
-      
+
 (defmacro def-foreign-type (name type)
   #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
   #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
@@ -75,13 +73,13 @@ supports takes advantage of this optimization."
     #+digitool
     `(def-mcl-type ,(keyword name) ,mcl-type)
     #+openmcl
-    `(ccl::def-foreign-type ,(keyword name) ,mcl-type))  
+    `(ccl::def-foreign-type ,(keyword name) ,mcl-type))
   )
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq))
   #+(or cmu sbcl scl) (defvar *cmu-def-type-hash*
-                       (make-hash-table :size 20 :test #'eq))
+                        (make-hash-table :size 20 :test #'eq))
   )
 
 #+(or cmu scl)
@@ -98,6 +96,8 @@ supports takes advantage of this optimization."
       #-x86-64 (:unsigned-long . (alien:unsigned 32))
       #+x86-64 (:long . (alien:signed 64))
       #+x86-64 (:unsigned-long . (alien:unsigned 64))
+      (:long-long (alien:signed 64))
+      (:unsigned-long-long (alien:unsigned 64))
       (:float . alien:single-float)
       (:double . alien:double-float)
       (:void . t)
@@ -118,6 +118,8 @@ supports takes advantage of this optimization."
       #-x86-64 (:unsigned-long . (sb-alien:unsigned 32))
       #+x86-64 (:long . (sb-alien:signed 64))
       #+x86-64 (:unsigned-long . (sb-alien:unsigned 64))
+      (:long-long (sb-alien:signed 64))
+      (:unsigned-long-long (sb-alien:unsigned 64))
       (:float . sb-alien:single-float)
       (:double . sb-alien:double-float)
       (:void . t)
@@ -128,34 +130,46 @@ supports takes advantage of this optimization."
 
 #+(or cmu scl)
 (setq *type-conversion-list*
-    '((* . *) (:void . c-call:void) 
+    '((* . *) (:void . c-call:void)
       (:pointer-void . (* t))
       (:cstring . c-call:c-string)
-      (:char . c-call:char) 
+      (:char . c-call:char)
       (:unsigned-char . (alien:unsigned 8))
       (:byte . (alien:signed 8))
       (:unsigned-byte . (alien:unsigned 8))
       (:short . c-call:short)
       (:unsigned-short . c-call:unsigned-short)
-      (:int . alien:integer) (:unsigned-int . c-call:unsigned-int) 
+      (:int . alien:integer) (:unsigned-int . c-call:unsigned-int)
       (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
+      #+#.(cl:if (cl:and (cl:find-package (cl:string '#:c-call))
+                         (cl:find-symbol (cl:string '#:long-long)
+                                         (cl:string '#:c-call)))
+                 '(and) '(or))
+      (:long-long . c-call:long-long)
+      #+#.(cl:if (cl:and (cl:find-package (cl:string '#:c-call))
+                         (cl:find-symbol (cl:string '#:unsigned-long-long)
+                                         (cl:string '#:c-call)))
+                 '(and) '(or))
+      (:unsigned-long-long . c-call:unsigned-long-long)
       (:float . c-call:float) (:double . c-call:double)
       (:array . alien:array)))
 
 #+sbcl
 (setq *type-conversion-list*
-    '((* . *) (:void . sb-alien:void) 
+    '((* . *) (:void . sb-alien:void)
       (:pointer-void . (* t))
       #-sb-unicode(:cstring . sb-alien:c-string)
       #+sb-unicode(:cstring . sb-alien:utf8-string)
-      (:char . sb-alien:char) 
+      (:char . sb-alien:char)
       (:unsigned-char . (sb-alien:unsigned 8))
       (:byte . (sb-alien:signed 8))
       (:unsigned-byte . (sb-alien:unsigned 8))
       (:short . sb-alien:short)
       (:unsigned-short . sb-alien:unsigned-short)
-      (:int . sb-alien:int) (:unsigned-int . sb-alien:unsigned-int) 
+      (:int . sb-alien:int) (:unsigned-int . sb-alien:unsigned-int)
       (:long . sb-alien:long) (:unsigned-long . sb-alien:unsigned-long)
+      (:long-long . sb-alien:long-long)
+      (:unsigned-long-long . sb-alien:unsigned-long-long)
       (:float . sb-alien:float) (:double . sb-alien:double)
       (:array . sb-alien:array)))
 
@@ -169,31 +183,44 @@ supports takes advantage of this optimization."
       (:unsigned-byte . :unsigned-char)
       (:char . :char)
       (:unsigned-char . :unsigned-char)
-      (:int . :int) (:unsigned-int . :unsigned-int) 
+      (:int . :int) (:unsigned-int . :unsigned-int)
       (:long . :long) (:unsigned-long . :unsigned-long)
+#+64bit (:unsigned-long-long . :unsigned-long)
+#+64bit (:long-long . :unsigned-long)
       (:float . :float) (:double . :double)
       (:array . :array)))
 
+#+(and allegro (not 64bit))
+(push 'uffi:no-long-long cl:*features*)
+
+#+cormanlisp
+(push 'uffi:no-long-long cl:*features*)
+
 #+lispworks
 (setq *type-conversion-list*
-    '((* . :pointer) (:void . :void) 
+    '((* . :pointer) (:void . :void)
       (:short . :short)
       (:pointer-void . (:pointer :void))
       (:cstring . (:reference-pass (:ef-mb-string :external-format
-                                   (:latin-1 :eol-style :lf))
-                  :allow-null t))
+                                    (:latin-1 :eol-style :lf))
+                   :allow-null t))
       (:cstring-returning . (:reference (:ef-mb-string :external-format
-                                        (:latin-1 :eol-style :lf))
-                            :allow-null t))
+                                         (:latin-1 :eol-style :lf))
+                             :allow-null t))
       (:byte . :byte)
       (:unsigned-byte . (:unsigned :byte))
       (:char . :char)
       (:unsigned-char . (:unsigned :char))
       (:int . :int) (:unsigned-int . (:unsigned :int))
       (:long . :long) (:unsigned-long . (:unsigned :long))
+      #+lispworks6 (:long-long . :int64)
+      #+lispworks6 (:unsigned-long-long . :uint64)
       (:float . :float) (:double . :double)
       (:array . :c-array)))
 
+#+(and lispworks (not lispworks6))
+(push 'uffi:no-long-long cl:*features*)
+
 #+digitool
 (setq *type-conversion-list*
      '((* . :pointer) (:void . :void)
@@ -207,6 +234,8 @@ supports takes advantage of this optimization."
        (:long . :long) (:unsigned-long . :unsigned-long)
        (:float . :single-float) (:double . :double-float)
        (:array . :array)))
+#+digitool
+(push 'uffi:no-long-long cl:*features*)
 
 #+openmcl
 (setq *type-conversion-list*
@@ -233,7 +262,7 @@ supports takes advantage of this optimization."
 (defun basic-convert-from-uffi-type (type)
   (let ((found-type (gethash type +type-conversion-hash+)))
     (if found-type
-       found-type
+        found-type
       #-(or openmcl digitool) type
       #+(or openmcl digitool) (keyword type))))
 
@@ -243,41 +272,41 @@ supports takes advantage of this optimization."
       (cond
        #+(or allegro cormanlisp)
        ((and (or (eq context :routine) (eq context :return))
-            (eq type :cstring))
-       (setq type '((* :char) integer)))
+             (eq type :cstring))
+        (setq type '((* :char) integer)))
        #+(or cmu sbcl scl)
        ((eq context :type)
-       (let ((cmu-type (gethash type *cmu-def-type-hash*)))
-         (if cmu-type
-             cmu-type
-             (basic-convert-from-uffi-type type))))
+        (let ((cmu-type (gethash type *cmu-def-type-hash*)))
+          (if cmu-type
+              cmu-type
+              (basic-convert-from-uffi-type type))))
        #+lispworks
        ((and (eq context :return)
-            (eq type :cstring))
-       (basic-convert-from-uffi-type :cstring-returning))
+             (eq type :cstring))
+        (basic-convert-from-uffi-type :cstring-returning))
        #+digitool
        ((and (eq type :void) (eq context :return)) nil)
        (t
-       (basic-convert-from-uffi-type type)))
+        (basic-convert-from-uffi-type type)))
     (let ((sub-type (car type)))
       (case sub-type
-       (cl:quote
-        (convert-from-uffi-type (cadr type) context))
-       (:struct-pointer
-        #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
-        #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)
-        )
-       (:struct
-        #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
-        #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct)
-        )
+        (cl:quote
+         (convert-from-uffi-type (cadr type) context))
+        (:struct-pointer
+         #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+         #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)
+         )
+        (:struct
+         #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
+         #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct)
+         )
        (:union
-       #+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union))
-       #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union)
-       )
+        #+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union))
+        #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union)
+        )
        (t
-       (cons (%convert-from-uffi-type (first type) context) 
-             (%convert-from-uffi-type (rest type) context)))))))
+        (cons (%convert-from-uffi-type (first type) context)
+              (%convert-from-uffi-type (rest type) context)))))))
 
 (defun convert-from-uffi-type (type context)
   (let ((result (%convert-from-uffi-type type context)))
@@ -286,8 +315,8 @@ supports takes advantage of this optimization."
      #+openmcl
      ((eq (car result) :address)
       (if (eq context :struct)
-         (append '(:*) (cdr result))
-       :address))
+          (append '(:*) (cdr result))
+        :address))
      #+digitool
      ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
      (t result))))
@@ -296,12 +325,12 @@ supports takes advantage of this optimization."
   (when (char= #\a (schar (symbol-name '#:a) 0))
     (pushnew :uffi-lowercase-reader *features*))
   (when (not (string= (symbol-name '#:a)
-                     (symbol-name '#:A)))
+                      (symbol-name '#:A)))
     (pushnew :uffi-case-sensitive *features*)))
 
 (defun make-lisp-name (name)
   (let ((converted (substitute #\- #\_ name)))
-     (intern 
+     (intern
       #+uffi-case-sensitive converted
       #+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted)
       #+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted))))