in the created in the current package. The symbol is the concatenation
of the enum-name name, separator-string, and field-name"
(let ((counter 0)
in the created in the current package. The symbol is the concatenation
of the enum-name name, separator-string, and field-name"
(let ((counter 0)
- (value (if (listp arg)
- (prog1
- (setq counter (cadr arg))
- (incf counter))
- (prog1
- counter
- (incf counter)))))
- (setq name (intern (concatenate 'string
- (symbol-name enum-name)
- separator-string
- (symbol-name name))))
- (push `(uffi:def-constant ,name ,value) constants)))
+ (value (if (listp arg)
+ (prog1
+ (setq counter (cadr arg))
+ (incf counter))
+ (prog1
+ counter
+ (incf counter)))))
+ (setq name (intern (concatenate 'string
+ (symbol-name enum-name)
+ separator-string
+ (symbol-name name))))
+ (push `(uffi:def-constant ,name ,value) constants)))
- #+allegro `((ff:def-foreign-type ,enum-name :int))
- #+lispworks `((fli:define-c-typedef ,enum-name :int))
- #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
- #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
+ #+allegro `((ff:def-foreign-type ,enum-name :int))
+ #+lispworks `((fli:define-c-typedef ,enum-name :int))
+ #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
+ #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
#+digitool `((def-mcl-type ,enum-name :integer))
#+openmcl `((ccl::def-foreign-type ,enum-name :int))
#+digitool `((def-mcl-type ,enum-name :integer))
#+openmcl `((ccl::def-foreign-type ,enum-name :int))
(:array ,(convert-from-uffi-type type :array)))
#+lispworks
`(fli:define-c-typedef ,name-array
(:c-array ,(convert-from-uffi-type type :array)))
#+(or cmu scl)
(:array ,(convert-from-uffi-type type :array)))
#+lispworks
`(fli:define-c-typedef ,name-array
(:c-array ,(convert-from-uffi-type type :array)))
#+(or cmu scl)
(* ,(convert-from-uffi-type type :array)))
#+digitool
`(def-mcl-type ,name-array '(:array ,type))
(* ,(convert-from-uffi-type type :array)))
#+digitool
`(def-mcl-type ,name-array '(:array ,type))
- (type (cadr field))
- (def (append (list field-name)
- (if (eq type :pointer-self)
- #+(or cmu scl) `((* (alien:struct ,name)))
- #+sbcl `((* (sb-alien:struct ,name)))
- #+(or openmcl digitool) `((:* (:struct ,name)))
- #+lispworks `((:pointer ,name))
- #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
- `(,(convert-from-uffi-type type :struct))))))
- (if variant
- (push (list def) processed)
- (push def processed))))
+ (type (cadr field))
+ (def (append (list field-name)
+ (if (eq type :pointer-self)
+ #+(or cmu scl) `((* (alien:struct ,name)))
+ #+sbcl `((* (sb-alien:struct ,name)))
+ #+(or openmcl digitool) `((:* (:struct ,name)))
+ #+lispworks `((:pointer ,name))
+ #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
+ `(,(convert-from-uffi-type type :struct))))))
+ (if variant
+ (push (list def) processed)
+ (push def processed))))
(defmacro def-struct (name &rest fields)
#+(or cmu scl)
`(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
(defmacro def-struct (name &rest fields)
#+(or cmu scl)
`(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
`(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
#+openmcl
`(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
`(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
#+openmcl
`(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
- (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
- (when (and (listp type-list) (eq (car type-list) :array))
- (setf result (cadr type-list)))))
+ (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
+ (when (and (listp type-list) (eq (car type-list) :array))
+ (setf result (cadr type-list)))))
(defmacro deref-array (obj type i)
"Returns a field from a row"
#+(or lispworks cmu sbcl scl) (declare (ignore type))
(defmacro deref-array (obj type i)
"Returns a field from a row"
#+(or lispworks cmu sbcl scl) (declare (ignore type))
#+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
#+openmcl
(let* ((array-type (array-type type))
#+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
#+openmcl
(let* ((array-type (array-type type))
- (local-type (convert-from-uffi-type array-type :allocation))
- (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
+ (local-type (convert-from-uffi-type array-type :allocation))
+ (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
- (local-type (convert-from-uffi-type array-type :allocation))
- (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
+ (local-type (convert-from-uffi-type array-type :allocation))
+ (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
; this expands to the %set-xx functions which has different params than %put-xx
#+digitool
(defmacro deref-array-set (obj type i value)
; this expands to the %set-xx functions which has different params than %put-xx
#+digitool
(defmacro deref-array-set (obj type i value)
(local-type (convert-from-uffi-type array-type :allocation))
(accessor (first (macroexpand `(ccl:pref obj ,local-type))))
(settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
(local-type (convert-from-uffi-type array-type :allocation))
(accessor (first (macroexpand `(ccl:pref obj ,local-type))))
(settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
- `(ccl::def-foreign-type nil
- (:union ,name ,@(process-struct-fields name fields)))
+ `(ccl::def-foreign-type nil
+ (:union ,name ,@(process-struct-fields name fields)))
)
#-(or sbcl cmu)
(defun convert-from-foreign-usb8 (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
)
#-(or sbcl cmu)
(defun convert-from-foreign-usb8 (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:without-package-locks
(defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:without-package-locks
(defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
(declare (optimize (speed 3) (safety 0)))
(let ((result (make-array len :element-type '(unsigned-byte 8))))
(funcall *system-copy-fn* sap 0 result +system-copy-offset+
(declare (optimize (speed 3) (safety 0)))
(let ((result (make-array len :element-type '(unsigned-byte 8))))
(funcall *system-copy-fn* sap 0 result +system-copy-offset+