`(member t nil))
(define-alien-type-method (boolean :naturalize-gen) (type alien)
- (declare (ignore type))
- `(not (zerop ,alien)))
+ (let ((bits (alien-boolean-type-bits type)))
+ (if (= bits sb!vm:n-word-bits)
+ `(not (zerop ,alien))
+ `(logtest ,alien ,(ldb (byte bits 0) -1)))))
(define-alien-type-method (boolean :deport-gen) (type value)
(declare (ignore type))
\f
;;;; the FUNCTION and VALUES alien types
+;;; Calling-convention spec, typically one of predefined keywords.
+;;; Add or remove as needed for target platform. It makes sense to
+;;; support :cdecl everywhere.
+;;;
+;;; Null convention is supposed to be platform-specific most-universal
+;;; callout convention. For x86, SBCL calls foreign functions in a way
+;;; allowing them to be either stdcall or cdecl; null convention is
+;;; appropriate here, as it is for specifying callbacks that could be
+;;; accepted by foreign code both in cdecl and stdcall form.
+(def!type calling-convention () `(or null (member :stdcall :cdecl)))
+
+;;; Convention could be a values type class, stored at result-type.
+;;; However, it seems appropriate only for epilogue-related
+;;; conventions, those not influencing incoming arg passing.
+;;;
+;;; As of x86's :stdcall and :cdecl, supported by now, both are
+;;; epilogue-related, but future extensions (like :fastcall and
+;;; miscellaneous non-x86 stuff) might affect incoming argument
+;;; translation as well.
+
(define-alien-type-class (fun :include mem-block)
(result-type (missing-arg) :type alien-type)
(arg-types (missing-arg) :type list)
- (stub nil :type (or null function)))
+ (stub nil :type (or null function))
+ (convention nil :type calling-convention))
+
+;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
+;;; convention specification for function types is unobvious.
+;;;
+;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
+;;; starting with a convention keyword; its second item is a real
+;;; result-type in this case. If convention is ever to become a part
+;;; of result-type, such a syntax can be retained.
(define-alien-type-translator function (result-type &rest arg-types
&environment env)
- (make-alien-fun-type
- :result-type (let ((*values-type-okay* t))
- (parse-alien-type result-type env))
- :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
- arg-types)))
+ (multiple-value-bind (bare-result-type calling-convention)
+ (typecase result-type
+ ((cons calling-convention *)
+ (values (second result-type) (first result-type)))
+ (t result-type))
+ (make-alien-fun-type
+ :convention calling-convention
+ :result-type (let ((*values-type-okay* t))
+ (parse-alien-type bare-result-type env))
+ :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
+ arg-types))))
(define-alien-type-method (fun :unparse) (type)
- `(function ,(%unparse-alien-type (alien-fun-type-result-type type))
+ `(function ,(let ((result-type
+ (%unparse-alien-type (alien-fun-type-result-type type)))
+ (convention (alien-fun-type-convention type)))
+ (if convention (list convention result-type)
+ result-type))
,@(mapcar #'%unparse-alien-type
(alien-fun-type-arg-types type))))
(define-alien-type-method (fun :type=) (type1 type2)
(and (alien-type-= (alien-fun-type-result-type type1)
(alien-fun-type-result-type type2))
+ (eq (alien-fun-type-convention type1)
+ (alien-fun-type-convention type2))
(= (length (alien-fun-type-arg-types type1))
(length (alien-fun-type-arg-types type2)))
(every #'alien-type-=