- (some #'alien-double-float-type-p arg-types)
- (some #'(lambda (type)
- (and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32)))
- arg-types)
- #!+long-float (some #'alien-long-float-type-p arg-types)
- (and (alien-integer-type-p result-type)
- (> (sb!alien::alien-integer-type-bits result-type) 32)))
- (collect ((new-args) (lambda-vars) (new-arg-types))
- (dolist (type arg-types)
- (let ((arg (gensym)))
- (lambda-vars arg)
- (cond ((and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32))
- ;; 64-bit long long types are stored in
- ;; consecutive locations, most significant word
- ;; first (big-endian).
- (new-args `(ash ,arg -32))
- (new-args `(logand ,arg #xffffffff))
- (if (alien-integer-type-signed type)
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- ((alien-single-float-type-p type)
- (new-args `(single-float-bits ,arg))
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv))))
- ((alien-double-float-type-p type)
- (new-args `(double-float-high-bits ,arg))
- (new-args `(double-float-low-bits ,arg))
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- #!+long-float
- ((alien-long-float-type-p type)
- (new-args `(long-float-exp-bits ,arg))
- (new-args `(long-float-high-bits ,arg))
- (new-args `(long-float-mid-bits ,arg))
- (new-args `(long-float-low-bits ,arg))
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- (t
- (new-args arg)
- (new-arg-types type)))))
- (cond ((and (alien-integer-type-p result-type)
- (> (sb!alien::alien-integer-type-bits result-type) 32))
- (let ((new-result-type
- (let ((sb!alien::*values-type-okay* t))
- (parse-alien-type
- (if (alien-integer-type-signed result-type)
- '(values (signed 32) (unsigned 32))
- '(values (unsigned 32) (unsigned 32)))
- (sb!kernel:make-null-lexenv)))))
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (multiple-value-bind (high low)
- (%alien-funcall function
- ',(make-alien-fun-type
- :arg-types (new-arg-types)
- :result-type new-result-type)
- ,@(new-args))
- (logior low (ash high 32))))))
- (t
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (%alien-funcall function
- ',(make-alien-fun-type
- :arg-types (new-arg-types)
- :result-type result-type)
- ,@(new-args))))))
- (sb!c::give-up-ir1-transform))))
-
-
-(define-vop (foreign-symbol-address)
- (:translate foreign-symbol-address)
+ (some #'alien-double-float-type-p arg-types)
+ (some #'(lambda (type)
+ (and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32)))
+ arg-types)
+ #!+long-float (some #'alien-long-float-type-p arg-types)
+ (and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32)))
+ (collect ((new-args) (lambda-vars) (new-arg-types))
+ (dolist (type arg-types)
+ (let ((arg (gensym)))
+ (lambda-vars arg)
+ (cond ((and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32))
+ ;; 64-bit long long types are stored in
+ ;; consecutive locations, most significant word
+ ;; first (big-endian).
+ (new-args `(ash ,arg -32))
+ (new-args `(logand ,arg #xffffffff))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ ((alien-single-float-type-p type)
+ (new-args `(single-float-bits ,arg))
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv))))
+ ((alien-double-float-type-p type)
+ (new-args `(double-float-high-bits ,arg))
+ (new-args `(double-float-low-bits ,arg))
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ #!+long-float
+ ((alien-long-float-type-p type)
+ (new-args `(long-float-exp-bits ,arg))
+ (new-args `(long-float-high-bits ,arg))
+ (new-args `(long-float-mid-bits ,arg))
+ (new-args `(long-float-low-bits ,arg))
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ (t
+ (new-args arg)
+ (new-arg-types type)))))
+ (cond ((and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32))
+ (let ((new-result-type
+ (let ((sb!alien::*values-type-okay* t))
+ (parse-alien-type
+ (if (alien-integer-type-signed result-type)
+ '(values (signed 32) (unsigned 32))
+ '(values (unsigned 32) (unsigned 32)))
+ (sb!kernel:make-null-lexenv)))))
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (multiple-value-bind (high low)
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type new-result-type)
+ ,@(new-args))
+ (logior low (ash high 32))))))
+ (t
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type result-type)
+ ,@(new-args))))))
+ (sb!c::give-up-ir1-transform))))
+
+(define-vop (foreign-symbol-sap)
+ (:translate foreign-symbol-sap)