Handle run-program with :directory nil.

[sbcl.git] / src / code / host-alieneval.lisp

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index eb883db..c78853f 100644 (file)
--- 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))
@@ -1137,27 +1139,68 @@
 \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-=