[cffi-devel] [PATCH] emulating LONG-LONG on ECL
Stelian Ionescu
sionescu at common-lisp.net
Mon May 14 17:58:24 UTC 2007
On Mon, May 14, 2007 at 06:28:13PM +0200, Stelian Ionescu wrote:
>Attached there is a patch made against the main branch(not the newtypes
>one) which adds :UNSIGNED-LONG-LONG and :LONG-LONG to ECL; to be more specific:
sorry, I forgot to actually *attach* the patch :(
--
(sign :name "Stelian Ionescu" :aka "fe[nl]ix"
:quote "Quidquid latine dictum sit, altum videtur.")
-------------- next part --------------
diff -rN -u old-cffi/src/cffi-ecl.lisp new-cffi/src/cffi-ecl.lisp
--- old-cffi/src/cffi-ecl.lisp 2007-05-14 18:01:21.000000000 +0200
+++ new-cffi/src/cffi-ecl.lisp 2007-05-14 18:01:21.000000000 +0200
@@ -62,7 +62,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(mapc (lambda (feature) (pushnew feature *features*))
'(;; Backend mis-features.
- cffi-features:no-long-long
+ cffi-features:emulated-long-long
cffi-features:flat-namespace
;; OS/CPU features.
#+:darwin cffi-features:darwin
@@ -74,6 +74,28 @@
#+:powerpc7450 cffi-features:ppc32
)))
+;; This is very ugly but since not all implementations put the
+;; machine endianess in *FEATURES* we need to do it ourselves
+(eval-when (:compile-toplevel :load-toplevel)
+ (flet ((memset1 (value ptr offset)
+ (si:foreign-data-set-elt
+ (si:foreign-data-recast ptr (1+ offset) :void)
+ offset :unsigned-byte value))
+ (memref4 (ptr)
+ (si:foreign-data-ref-elt
+ (si:foreign-data-recast ptr 4 :void) 0 :unsigned-int)))
+ (let ((myalien (si:allocate-foreign-data :void 4)))
+ (unwind-protect
+ (progn
+ (dotimes (i 4) (memset1 (1+ i) myalien i))
+ (pushnew (case (memref4 myalien)
+ (#x01020304 :big-endian)
+ (#x04030201 :little-endian)
+ (otherwise
+ (error "Your machine seems to be neither little-endian nor big-endian.")))
+ *features*))
+ (si:free-foreign-data myalien)))))
+
;;; Symbol case.
(defun canonicalize-symbol-name-case (name)
@@ -135,21 +157,110 @@
;;;# Dereferencing
-(defun %mem-ref (ptr type &optional (offset 0))
- "Dereference an object of TYPE at OFFSET bytes from PTR."
+(defun %size-of-foreign-type (type)
+ (case type
+ ((:unsigned-long-long :long-long) 8)
+ (t (ffi:size-of-foreign-type type))))
+
+(defun %native-mem-ref (ptr type offset)
(let* ((type (cffi-type->ecl-type type))
- (type-size (ffi:size-of-foreign-type type)))
+ (type-size (%size-of-foreign-type type)))
(si:foreign-data-ref-elt
(si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
-(defun %mem-set (value ptr type &optional (offset 0))
+(define-compiler-macro %native-mem-ref (&whole form ptr type &optional (offset 0))
+ (if (constantp type)
+ (let* ((type (cffi-type->ecl-type type))
+ (type-size (%size-of-foreign-type type)))
+ (with-unique-names ($offset$)
+ `(let (($offset$ ,offset))
+ (si:foreign-data-ref-elt
+ (si:foreign-data-recast ,ptr (+ ,$offset$ ,type-size) :void) ,$offset$ ,type))))
+ form))
+
+(defmacro %double-mem-ref-32 (ptr val offset)
+ `(progn
+ #+little-endian (setf (ldb (byte 32 0) ,val) (%native-mem-ref ,ptr :unsigned-int ,offset))
+ #+little-endian (setf (ldb (byte 32 32) ,val) (%native-mem-ref ,ptr :unsigned-int (+ ,offset 4)))
+ #+big-endian (setf (ldb (byte 32 0) ,val) (%native-mem-ref ,ptr :unsigned-int (+ ,offset 4)))
+ #+big-endian (setf (ldb (byte 32 32) ,val) (%native-mem-ref ,ptr :unsigned-int ,offset))))
+
+(defun %emulated-ullong-mem-ref (ptr offset)
+ (let ((val 0))
+ (declare (type (unsigned-byte 64) val)
+ (optimize (speed 3)))
+ (%double-mem-ref-32 ptr val offset)
+ (values val)))
+
+(defun %emulated-llong-mem-ref (ptr offset)
+ (let ((val 0))
+ (declare (type (unsigned-byte 64) val)
+ (optimize (speed 3)))
+ (%double-mem-ref-32 ptr val offset)
+ (if (logbitp 63 val) ; most significant bit holds the sign
+ ;; VAL is negative, calculating two's complement
+ (lognot (logxor val #xFFFFFFFFFFFFFFFF))
+ ;; VAL is positive
+ (values val))))
+
+(defun %mem-ref (ptr type &optional (offset 0))
+ "Dereference an object of TYPE at OFFSET bytes from PTR."
+ (case (cffi::canonicalize-foreign-type type)
+ (:unsigned-long-long
+ (%emulated-ullong-mem-ref ptr offset))
+ (:long-long
+ (%emulated-llong-mem-ref ptr offset))
+ (t
+ (%native-mem-ref ptr type offset))))
+
+(defun %native-mem-set (value ptr type offset)
"Set an object of TYPE at OFFSET bytes from PTR."
(let* ((type (cffi-type->ecl-type type))
- (type-size (ffi:size-of-foreign-type type)))
+ (type-size (%size-of-foreign-type type)))
(si:foreign-data-set-elt
(si:foreign-data-recast ptr (+ offset type-size) :void)
offset type value)))
+(define-compiler-macro %native-mem-set (&whole form value ptr type &optional (offset 0))
+ (if (constantp type)
+ (let* ((type (cffi-type->ecl-type type))
+ (type-size (%size-of-foreign-type type))
+ ($offset$ (gensym "OFFSET-")))
+ `(let (($offset$ ,offset))
+ (si:foreign-data-set-elt
+ (si:foreign-data-recast ,ptr (+ ,$offset$ ,type-size) :void)
+ ,$offset$ ,type ,value)))
+ form))
+
+(defmacro %double-mem-set-32 (value ptr offset)
+ `(progn
+ #+little-endian (%native-mem-set (ldb (byte 32 0) ,value) ,ptr :unsigned-int ,offset)
+ #+little-endian (%native-mem-set (ldb (byte 32 32) ,value) ,ptr :unsigned-int (+ ,offset 4))
+ #+big-endian (%native-mem-set (ldb (byte 32 0) ,value) ,ptr :unsigned-int (+ ,offset 4))
+ #+big-endian (%native-mem-set (ldb (byte 32 32) ,value) ,ptr :unsigned-int ,offset)))
+
+(defun %emulated-ullong-mem-set (value ptr offset)
+ (declare (type (unsigned-byte 64) value)
+ (optimize (speed 3)))
+ (%double-mem-set-32 value ptr offset))
+
+(defun %emulated-llong-mem-set (value ptr offset)
+ (declare (type (signed-byte 64) value)
+ (optimize (speed 3)))
+ (%double-mem-set-32 value ptr offset))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+ "Set an object of TYPE at OFFSET bytes from PTR."
+ (case (cffi::canonicalize-foreign-type type)
+ (:unsigned-long-long
+ (locally (declare (type (unsigned-byte 64) value))
+ (%emulated-ullong-mem-set value ptr offset)))
+ (:long-long
+ (locally (declare (type (signed-byte 64) value))
+ (%emulated-llong-mem-set value ptr offset)))
+ (t
+ (%native-mem-set value ptr type offset))))
+
;;;# Type Operations
(defconstant +translation-table+
@@ -161,6 +272,8 @@
(:unsigned-int :unsigned-int "unsigned int")
(:long :long "long")
(:unsigned-long :unsigned-long "unsigned long")
+ (:long-long :long-long "long long")
+ (:unsigned-long-long :unsigned-long-long "unsigned long long")
(:float :float "float")
(:double :double "double")
(:pointer :pointer-void "void*")
@@ -178,12 +291,12 @@
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
- (nth-value 0 (ffi:size-of-foreign-type
+ (nth-value 0 (%size-of-foreign-type
(cffi-type->ecl-type type-keyword))))
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
- (nth-value 1 (ffi:size-of-foreign-type
+ (nth-value 1 (%size-of-foreign-type
(cffi-type->ecl-type type-keyword))))
;;;# Calling Foreign Functions
diff -rN -u old-cffi/src/features.lisp new-cffi/src/features.lisp
--- old-cffi/src/features.lisp 2007-05-14 18:01:21.000000000 +0200
+++ new-cffi/src/features.lisp 2007-05-14 18:01:21.000000000 +0200
@@ -43,6 +43,7 @@
;; meaning that at some point all lisps will support long-longs,
;; the foreign-funcall primitive, etc...
#:no-long-long
+ #:emulated-long-long
#:no-foreign-funcall
#:no-stdcall
#:flat-namespace
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 189 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/cffi-devel/attachments/20070514/6d7b7aca/attachment.sig>
More information about the cffi-devel
mailing list