;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: basic-types.lisp,v 1.1 2006-04-25 20:36:05 espen Exp $
+;; $Id: basic-types.lisp,v 1.13 2008-10-08 16:27:09 espen Exp $
(in-package "GFFI")
+(deftype byte () '(unsigned-byte 8))
(deftype int ()
'(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
#+clisp #.(ffi:bitsizeof 'ffi:int)
(deftype signed (&optional (size '*)) `(signed-byte ,size))
(deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
(deftype char () 'base-char)
-(deftype pointer ()
- #+(or cmu sbcl) 'system-area-pointer
- #+clisp 'ffi:foreign-address)
+(deftype pointer-data ()
+ '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:system-area-pointer)
+ #+clisp #.(ffi:bitsizeof 'ffi:c-pointer)
+ #-(or sbcl clisp) 32))
+
(deftype bool (&optional (size '*)) (declare (ignore size)) 'boolean)
(deftype copy-of (type) type)
(deftype static (type) type)
(define-type-generic alien-type (type)
"Returns the foreign type corresponding to TYPE")
+(define-type-generic argument-type (type)
+ "Returns the type to be used in argument declarations for TYPE.")
+(define-type-generic return-type (type)
+ "Returns the type to be used in return type declarations for TYPE.")
(define-type-generic size-of (type &key inlined)
"Returns the foreign size of TYPE. The default value of INLINED is
T for basic C types and NIL for other types.")
+(define-type-generic type-alignment (type &key inlined)
+ "Returns the alignment of TYPE. The default value of INLINED is
+T for basic C types and NIL for other types.")
(define-type-generic alien-arg-wrapper (type var arg style form &optional copy-p)
"Creates a wrapper around FORM which binds the alien translation of
ARG to VAR in a way which makes it possible to pass the location of
"Returns a function of one argument which will translate objects of the given type to alien repesentation. An optional function, taking the origional object and the alien representation as arguments, to clean up after the alien value is not needed any more may be returned as a second argument.")
(define-type-generic from-alien-function (type &key ref)
"Returns a function of one argument which will translate alien objects of the given type to lisp representation. REF should be :FREE, :COPY, :STATIC or :TEMP")
+(define-type-generic alien-typep-form (type alien)
+ "Returns a form evaluating to T if ALIEN is an alien representation of TYPE.")
(define-type-generic callback-wrapper (type var arg form)
"Creates a wrapper around FORM which binds the lisp translation of
ARG to VAR during a C callback.")
:PEEK or :GET")
(define-type-generic destroy-function (type &key temp inlined)
"Returns a function taking an address and optional offset which when
-called will destroy the reference at the given location. This may
+called will destroy the object at the given location. This may
involve freeing the foreign object being referenced or decreasing it's
ref. count. If TEMP is non NIL then the reference is expected to
have been written as temporal.")
-(define-type-generic copy-function (type &key inlined))
+(define-type-generic copy-function (type &key inlined)
+ "Returns a function taking source/destination addresses and optional
+common offset, which will copy the object at the source location to
+the destination. If INLINED is non NIL, the object is assumed to be
+inlined at the source location and will be inlined at the
+destination.")
(define-type-generic unbound-value (type-spec)
"Returns a value which should be interpreted as unbound for slots with virtual allocation")
(define-type-method alien-type ((type t))
(error "No alien type corresponding to the type specifier ~A" type))
+(define-type-method argument-type ((type t))
+ type)
+
+(define-type-method return-type ((type t))
+ type)
+
(define-type-method to-alien-form ((type t) form &optional copy-p)
(declare (ignore form copy-p))
(error "Not a valid type specifier for arguments: ~A" type))
(declare (ignore type))
(size-of 'signed-byte :inlined inlined))
+(define-type-method type-alignment ((type integer) &key (inlined t))
+ (declare (ignore type))
+ (type-alignment 'signed-byte :inlined inlined))
+
(define-type-method writer-function ((type integer) &key temp (inlined t))
(declare (ignore temp))
(assert-inlined type inlined)
(32 4)
(64 8)))))
+(define-type-method type-alignment ((type signed-byte) &key (inlined t))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'signed-byte type)))
+ (let ((size (if (eq size '*)
+ (second (type-expand-to 'signed-byte 'int))
+ size)))
+ #+sbcl(sb-alignment `(sb-alien:signed ,size))
+ #+clisp(ecase size
+ ( 8 (nth-value 1 (ffi:sizeof 'ffi:sint8)))
+ (16 (nth-value 1 (ffi:sizeof 'ffi:sint16)))
+ (32 (nth-value 1 (ffi:sizeof 'ffi:sint32)))
+ (64 (nth-value 1 (ffi:sizeof 'ffi:sint64))))
+ #-(or sbcl clisp) 4)))
+
(define-type-method writer-function ((type signed-byte) &key temp (inlined t))
(declare (ignore temp))
(assert-inlined type inlined)
(second (type-expand-to 'signed-byte 'int))
size)))
(ecase size
- ( 8 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(signed-sap-ref-8 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint8 offset)
- value)))
- (16 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(signed-sap-ref-16 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint16 offset)
- value)))
- (32 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(signed-sap-ref-32 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint32 offset)
- value)))
- (64 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(signed-sap-ref-64 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint64 offset)
- value)))))))
+ ( 8 #'(setf ref-int-8))
+ (16 #'(setf ref-native-int-16))
+ (32 #'(setf ref-native-int-32))
+ (64 #'(setf ref-native-int-64))))))
(define-type-method reader-function ((type signed-byte) &key ref (inlined t))
(declare (ignore ref))
(second (type-expand-to 'signed-byte 'int))
size)))
(ecase size
- ( 8 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(signed-sap-ref-8 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint8 offset)))
- (16 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(signed-sap-ref-16 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint16 offset)))
- (32 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(signed-sap-ref-32 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint32 offset)))
- (64 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(signed-sap-ref-64 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint64 offset)))))))
-
+ ( 8 #'ref-int-8)
+ (16 #'ref-native-int-16)
+ (32 #'ref-native-int-32)
+ (64 #'ref-native-int-64)))))
;;; Unsigned Byte
(rest (mklist (type-expand-to 'unsigned-byte type)))
(size-of `(signed ,size))))
+(define-type-method type-alignment ((type unsigned-byte) &key (inlined t))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'unsigned-byte type)))
+ (type-alignment `(signed ,size))))
+
(define-type-method writer-function ((type unsigned-byte) &key temp (inlined t))
(declare (ignore temp))
(assert-inlined type inlined)
(second (type-expand-to 'signed-byte 'int))
size)))
(ecase size
- ( 8 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-8 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint8 offset)
- value)))
- (16 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-16 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint16 offset)
- value)))
- (32 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-32 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint32 offset)
- value)))
- (64 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-64 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint64 offset)
- value)))))))
+ ( 8 #'(setf ref-uint-8))
+ (16 #'(setf ref-native-uint-16))
+ (32 #'(setf ref-native-uint-32))
+ (64 #'(setf ref-native-uint-64))))))
(define-type-method reader-function ((type unsigned-byte) &key ref (inlined t))
(declare (ignore ref))
(second (type-expand-to 'signed-byte 'int))
size)))
(ecase size
- ( 8 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-8 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint8 offset)))
- (16 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-16 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint16 offset)))
- (32 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-32 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint32 offset)))
- (64 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-64 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint64 offset)))))))
-
+ ( 8 #'ref-uint-8)
+ (16 #'ref-native-uint-16)
+ (32 #'ref-native-uint-32)
+ (64 #'ref-native-uint-64)))))
;;; Single Float
#+sbcl 'sb-alien:single-float
#+clisp 'single-float)
+(define-type-method argument-type ((type single-float))
+ (declare (ignore type))
+ 'number)
+
(define-type-method size-of ((type single-float) &key (inlined t))
(assert-inlined type inlined)
#+sbcl (sb-sizeof 'sb-alien:float)
#+clisp (ffi:sizeof 'single-float)
#-(or sbcl clisp) 4)
+(define-type-method type-alignment ((type single-float) &key (inlined t))
+ (assert-inlined type inlined)
+ #+sbcl (sb-alignment 'single-float)
+ #+clisp (nth-value 1 (ffi:sizeof 'single-float))
+ #-(or sbcl clisp) 4)
+
(define-type-method to-alien-form ((type single-float) form &optional copy-p)
(declare (ignore type copy-p))
`(coerce ,form 'single-float))
(define-type-method writer-function ((type single-float) &key temp (inlined t))
(declare (ignore temp))
(assert-inlined type inlined)
- #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-single location offset)
- #+clisp(ffi:memory-as location 'single-float offset)
- (coerce value 'single-float))))
+ #'(lambda (number location &optional (offset 0))
+ (setf (ref-native-single-float location offset) (coerce number 'single-float))))
(define-type-method reader-function ((type single-float) &key ref (inlined t))
(declare (ignore ref))
(assert-inlined type inlined)
- #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-single location offset)
- #+clisp(ffi:memory-as location 'single-float offset)))
+ #'ref-native-single-float)
#+sbcl 'sb-alien:double-float
#+clisp 'double-float)
+(define-type-method argument-type ((type double-float))
+ (declare (ignore type))
+ 'number)
+
(define-type-method size-of ((type double-float) &key (inlined t))
(assert-inlined type inlined)
#+sbcl (sb-sizeof 'sb-alien:double)
#+clisp (ffi:sizeof 'double-float)
#-(or sbcl clisp) 8)
+(define-type-method type-alignment ((type double-float) &key (inlined t))
+ (assert-inlined type inlined)
+ #+sbcl (sb-alignment 'double-float)
+ #+clisp (nth-value 1 (ffi:sizeof 'double-float))
+ #-(or sbcl clisp) 4)
+
(define-type-method to-alien-form ((type double-float) form &optional copy-p)
(declare (ignore type copy-p))
`(coerce ,form 'double-float))
(declare (ignore temp))
(assert-inlined type inlined)
#'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-double location offset)
- #+clisp(ffi:memory-as location 'double-float offset)
- (coerce value 'double-float))))
+ (setf (ref-native-double-float location offset) (coerce value 'double-float))))
(define-type-method reader-function ((type double-float) &key ref (inlined t))
(declare (ignore ref))
(assert-inlined type inlined)
- #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-double location offset)
- #+clisp(ffi:memory-as location 'double-float offset)))
+ #'ref-native-double-float)
+
+(deftype optimized-double-float () 'double-float)
+
+(define-type-method to-alien-form ((type optimized-double-float) form &optional copy-p)
+ (declare (ignore type copy-p))
+ form)
+
+(define-type-method argument-type ((type optimized-double-float))
+ (declare (ignore type))
+ 'double-float)
(define-type-method size-of ((type base-char) &key (inlined t))
(assert-inlined type inlined)
1)
+
+(define-type-method type-alignment ((type base-char) &key (inlined t))
+ (assert-inlined type inlined)
+ #+sbcl (sb-alignment 'sb-alien:char)
+ #+clisp (nth-value 1 (ffi:sizeof 'ffi:character))
+ #-(or sbcl clisp) 4)
(define-type-method to-alien-form ((type base-char) form &optional copy-p)
(declare (ignore type copy-p))
(declare (ignore temp))
(assert-inlined type inlined)
#'(lambda (char location &optional (offset 0))
- #+(or cmu sbcl)
- (setf (sap-ref-8 location offset) (char-code char))
- #+clisp(setf (ffi:memory-as location 'ffi:character offset) char)))
+ (setf (ref-int-8 location offset) (char-code char))))
(define-type-method reader-function ((type base-char) &key ref (inlined t))
(declare (ignore ref))
(assert-inlined type inlined)
#'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(code-char (sap-ref-8 location offset))
- #+clisp(ffi:memory-as location 'ffi:character offset)))
+ (code-char (ref-int-8 location offset))))
;;; String
(defun utf8-length (string)
+ "Returns the length including the trailing zero, of STRING encoded as UTF8"
(1+ (loop
for char across string
as char-code = (char-code char)
((< char-code #x1FFFFF) 4)))))
(defun encode-utf8-string (string &optional location)
- (let ((location (or location (allocate-memory (utf8-length string)))))
+ (let* ((len (utf8-length string))
+ (location (or location (allocate-memory len))))
(loop
for char across string
for i from 0
as char-code = (char-code char)
do (flet ((encode (size)
(let ((rem (mod size 6)))
- (setf (ref-byte location i)
+ (setf (ref-uint-8 location i)
(deposit-field
#xFF (byte (- 7 rem) (1+ rem))
(ldb (byte rem (- size rem)) char-code)))
(loop
for pos from (- size rem 6) downto 0 by 6
- do (setf (ref-byte location (incf i))
+ do (setf (ref-uint-8 location (incf i))
(+ 128 (ldb (byte 6 pos) char-code)))))))
(cond
- ((< char-code #x80) (setf (ref-byte location i) char-code))
+ ((< char-code #x80) (setf (ref-uint-8 location i) char-code))
((< char-code #x800) (encode 11))
((< char-code #x10000) (encode 16))
- ((< char-code #x200000) (encode 21))))
- finally (setf (ref-byte location (1+ i)) 0))
+ ((< char-code #x200000) (encode 21)))))
+ (setf (ref-uint-8 location (1- len)) 0)
location))
(defun decode-utf8-string (c-string)
(with-output-to-string (string)
(loop
for i from 0
- as octet = (ref-byte c-string i)
+ as octet = (ref-uint-8 c-string i)
until (zerop octet)
do (flet ((decode (size)
(loop
for pos from (- size rem) downto 0 by 6
as code = (dpb (ldb (byte rem 0) octet) (byte rem pos) 0)
then (dpb
- (ldb (byte 6 0) (ref-byte c-string (incf i)))
+ (ldb (byte 6 0) (ref-uint-8 c-string (incf i)))
(byte 6 pos) code)
finally (write-char (code-char code) string))))
(cond
(declare (ignore type))
(alien-type 'pointer))
+(define-type-method argument-type ((type string))
+ 'string)
+
+(define-type-method return-type ((type string))
+ 'string)
+
(define-type-method size-of ((type string) &key inlined)
(assert-not-inlined type inlined)
(size-of 'pointer))
+(define-type-method type-alignment ((type string) &key inlined)
+ (assert-not-inlined type inlined)
+ (type-alignment 'pointer))
+
(define-type-method to-alien-form ((type string) string &optional copy-p)
(declare (ignore type copy-p))
`(encode-utf8-string ,string))
(let* ((string (ref-pointer from offset))
(length (loop
for i from 0
- until (zerop (ref-byte string i))
+ until (zerop (ref-uint-8 string i))
finally (return (1+ i)))))
(setf (ref-pointer to offset) (copy-memory string length)))))
(declare (ignore type))
(alien-type 'string))
+(define-type-method argument-type ((type pathname))
+ (declare (ignore type))
+ '(or pathname string))
+
(define-type-method size-of ((type pathname) &key inlined)
(assert-not-inlined type inlined)
(size-of 'string))
+(define-type-method type-alignment ((type pathname) &key inlined)
+ (assert-not-inlined type inlined)
+ (type-alignment 'string))
+
(define-type-method alien-arg-wrapper ((type pathname) var pathname style form &optional copy-in-p)
(declare (ignore type))
(alien-arg-wrapper 'string var `(namestring (translate-logical-pathname ,pathname)) style form copy-in-p))
(rest (mklist (type-expand-to 'bool type)))
(size-of `(signed-byte ,size))))
+(define-type-method type-alignment ((type bool) &key (inlined t))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'bool type)))
+ (type-alignment `(signed-byte ,size))))
+
(define-type-method to-alien-form ((type bool) bool &optional copy-p)
(declare (ignore type copy-p))
`(if ,bool 1 0))
(declare (ignore type))
(alien-type 'bool))
+(define-type-method argument-type ((type boolean))
+ (declare (ignore type))
+ t)
+
(define-type-method size-of ((type boolean) &key (inlined t))
(assert-inlined type inlined)
(size-of 'bool))
+(define-type-method type-alignment ((type boolean) &key (inlined t))
+ (assert-inlined type inlined)
+ (type-alignment 'bool))
+
(define-type-method to-alien-form ((type boolean) boolean &optional copy-p)
(declare (ignore type copy-p))
(to-alien-form 'bool boolean))
(error "No common alien type specifier for union type: ~A" type))
alien-type))
+(define-type-method argument-type ((type or))
+ (let ((expanded-type (type-expand-to 'or type)))
+ `(or ,@(mapcar #'argument-type (rest expanded-type)))))
+
+
(define-type-method size-of ((type or) &key (inlined nil inlined-p))
(loop
- for subtype in (type-expand-to 'or type)
+ for subtype in (cdr (type-expand-to 'or type))
maximize (if inlined-p
- (size-of subtype inlined)
+ (size-of subtype :inlined inlined)
(size-of subtype))))
+(define-type-method type-alignment ((type or) &key (inlined nil inlined-p))
+ (loop
+ for subtype in (cdr (type-expand-to 'or type))
+ maximize (if inlined-p
+ (type-alignment subtype :inlined inlined)
+ (type-alignment subtype))))
+
(define-type-method alien-arg-wrapper ((type or) var value style form &optional copy-in-p)
(cond
((and (in-arg-p style) (out-arg-p style))
`(,type ,(alien-arg-wrapper type var value style form copy-in-p)))
(rest (type-expand-to 'or type)))))
((in-arg-p style)
- (let ((body (make-symbol "BODY")))
- `(flet ((,body (,var)
- ,form))
- (etypecase ,value
- ,@(mapcar
- #'(lambda (type)
- `(,type ,(alien-arg-wrapper type var value style `(,body ,var) copy-in-p)))
- (rest (type-expand-to 'or type)))))))
+ ;; If the unexpanded type has explicit alien-type and
+ ;; to-alien-form methods, we just call the default arg wrapper
+ (if (and
+ (not (eq (first (mklist type)) 'or))
+ (find-type-method 'alien-type type nil)
+ (find-type-method 'to-alien-form type nil))
+ (funcall (find-type-method 'alien-arg-wrapper t) type var value style form copy-in-p)
+ (let ((body (make-symbol "BODY")))
+ `(flet ((,body (,var)
+ ,form))
+ (etypecase ,value
+ ,@(mapcar
+ #'(lambda (type)
+ `(,type ,(alien-arg-wrapper type var value style `(,body ,var) copy-in-p)))
+ (rest (type-expand-to 'or type))))))))
((out-arg-p style)
#+(or cmu sbcl)
`(with-alien ((,var ,(alien-type type)))
`(,type ,(to-alien-form type 'value copy-p)))
(rest (type-expand-to 'or type))))))
+(define-type-method from-alien-form ((type or) form &key ref)
+ (declare (ignore ref))
+ `(let ((alien ,form))
+ (cond
+ ,@(loop
+ for (type . rest) on (rest (type-expand-to 'or type))
+ collect
+ `(,(if (endp rest)
+ t
+ (alien-typep-form type 'alien))
+ ,(from-alien-form type 'alien))))))
+
+
+
(define-type-method to-alien-function ((type or) &optional copy-p)
(let* ((expanded-type (type-expand-to 'or type))
(functions (loop
#+clisp (ffi:sizeof 'ffi:c-pointer)
#-(or sbcl clisp) 4)
+(define-type-method type-alignment ((type pointer) &key (inlined t))
+ (assert-inlined type inlined)
+ #+sbcl (sb-alignment 'system-area-pointer)
+ #+clisp (ffi:sizeof 'ffi:c-pointer)
+ #-(or sbcl clisp) (size-of 'pointer))
+
(define-type-method to-alien-form ((type pointer) form &optional copy-p)
(declare (ignore type copy-p))
form)
#'ref-pointer)
+
+;;; Null Pointer
+
(define-type-method alien-type ((type null))
(declare (ignore type))
(alien-type 'pointer))
(assert-inlined type inlined)
(size-of 'pointer))
+(define-type-method alien-typep-form ((type null) null)
+ (declare (ignore type))
+ `(null-pointer-p ,null))
+
+(define-type-method from-alien-form ((type null) null &key ref)
+ (declare (ignore type null ref))
+ nil)
+
(define-type-method to-alien-form ((type null) null &optional copy-p)
(declare (ignore type copy-p))
`(progn ,null (make-pointer 0)))
;;; Copy-of
+(define-type-method return-type ((type copy-of))
+ (return-type (second type)))
+
(define-type-method from-alien-form ((type copy-of) form &key (ref :copy))
(if (eq ref :copy)
(from-alien-form (second (type-expand-to 'copy-of type)) form :ref ref)
(define-type-method from-alien-function ((type copy-of) &key (ref :copy))
(if (eq ref :copy)
(from-alien-function (second (type-expand-to 'copy-of type)) :ref ref)
- (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref)))
+ (error "Keyword arg :REF to FROM-ALIEN-FUNCTION should be :COPY for type ~A. It was give ~A" type ref)))
(define-type-method to-alien-form ((type copy-of) form &optional (copy-p t))
(if copy-p
(declare (ignore location offset))))
(define-type-method copy-function ((type copy-of) &key (inlined nil inlined-p))
- (let ((size (if inlined-p
- (size-of type :inlined inlined)
- (size-of type))))
- #'(lambda (from to &optional (offset 0))
- (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
-
+ (if inlined-p
+ (copy-function (second (type-expand-to 'copy-of type)) :inlined inlined)
+ (copy-function (second (type-expand-to 'copy-of type)))))
;;; Static
+(define-type-method return-type ((type static))
+ (return-type (second type)))
+
(define-type-method from-alien-form ((type static) form &key (ref :static))
(if (eq ref :static)
(from-alien-form (second (type-expand-to 'static type)) form :ref ref)
(define-type-method from-alien-function ((type static) &key (ref :static))
(if (eq ref :static)
(from-alien-function (second (type-expand-to 'static type)) :ref ref)
- (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref)))
+ (error "Keyword arg :REF to FROM-ALIEN-FUNCTION should be :STATIC for type ~A. It was give ~A" type ref)))
(define-type-method to-alien-function ((type static) &optional copy-p)
(if (not copy-p)
(to-alien-function (second (type-expand-to 'static type)) t)
- (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
+ (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
(define-type-method to-alien-form ((type static) &optional copy-p)
(if (not copy-p)
- (to-alien-function (second (type-expand-to 'static type)) t)
- (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
+ (to-alien-form (second (type-expand-to 'static type)) t)
+ (error "COPY-P argument to TO-ALIEN-FORM should always be NIL for type ~A" type)))
(define-type-method reader-function ((type static) &key (ref :read) (inlined nil inlined-p))
(if inlined-p
(declare (ignore location offset))))
(define-type-method copy-function ((type static) &key (inlined nil inlined-p))
- (let ((size (if inlined-p
- (size-of type :inlined inlined)
- (size-of type))))
- #'(lambda (from to &optional (offset 0))
- (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
+ (if inlined-p
+ (copy-function (second (type-expand-to 'copy-of type)) :inlined inlined)
+ (copy-function (second (type-expand-to 'copy-of type)))))
(assert-inlined type inlined)
(size-of (second (type-expand-to 'inlined type)) :inlined t))
+(define-type-method return-type ((type inlined))
+ (return-type (second type)))
+
+(define-type-method type-alignment ((type inlined) &key (inlined t))
+ (assert-inlined type inlined)
+ (type-alignment (second (type-expand-to 'inlined type)) :inlined t))
+
(define-type-method reader-function ((type inlined) &key (ref :read) (inlined t))
(assert-inlined type inlined)
(reader-function (second (type-expand-to 'inlined type)) :ref ref :inlined t))
~mdw / clg / blobdiff