X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fhost-alieneval.lisp;h=c78853fe332c88ffd9c1eb4e2065fb166db48feb;hb=14dde89d91420d03a37e6b03f2e41e830218b736;hp=1f554c654885971f3e871f88d2fbb18574067a8f;hpb=a0773e7d643c53e8626e49a560fb2b5ba6d8790e;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 1f554c6..c78853f 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -666,8 +666,10 @@ `(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)) @@ -1003,7 +1005,7 @@ ;;; FIXME: This is really pretty horrible: we avoid creating new ;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the -;;; system already. This way forwrd-references sans fields get get +;;; system already. This way forward-references sans fields get ;;; "updated" for free to contain the field info. Maybe rename ;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use ;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729 @@ -1052,7 +1054,8 @@ (overall-alignment 1) (parsed-fields nil)) (dolist (field fields) - (destructuring-bind (var type &key alignment) field + (destructuring-bind (var type &key alignment bits offset) field + (declare (ignore bits)) (let* ((field-type (parse-alien-type type env)) (bits (alien-type-bits field-type)) (parsed-field @@ -1068,7 +1071,7 @@ (setf overall-alignment (max overall-alignment alignment)) (ecase kind (:struct - (let ((offset (align-offset total-bits alignment))) + (let ((offset (or offset (align-offset total-bits alignment)))) (setf (alien-record-field-offset parsed-field) offset) (setf total-bits (+ offset bits)))) (:union @@ -1095,7 +1098,9 @@ `(,(alien-record-field-name field) ,(%unparse-alien-type (alien-record-field-type field)) ,@(when (alien-record-field-bits field) - (list (alien-record-field-bits field))))) + (list :bits (alien-record-field-bits field))) + ,@(when (alien-record-field-offset field) + (list :offset (alien-record-field-offset field))))) ;;; Test the record fields. Keep a hashtable table of already compared ;;; types to detect cycles. @@ -1134,27 +1139,68 @@ ;;;; 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-=