-#!+win32
-(deftransform %alien-funcall-stdcall ((function type &rest args) * * :node node)
- (aver (sb!c::constant-lvar-p type))
- (let* ((type (sb!c::lvar-value type))
- (env (sb!c::node-lexenv node))
- (arg-types (alien-fun-type-arg-types type))
- (result-type (alien-fun-type-result-type type)))
- (aver (= (length arg-types) (length args)))
- (if (or (some #'(lambda (type)
- (and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32)))
- 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))
- (new-args `(logand ,arg #xffffffff))
- (new-args `(ash ,arg -32))
- (new-arg-types (parse-alien-type '(unsigned 32) env))
- (if (alien-integer-type-signed type)
- (new-arg-types (parse-alien-type '(signed 32) env))
- (new-arg-types (parse-alien-type '(unsigned 32) env))))
- (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 (unsigned 32) (signed 32))
- '(values (unsigned 32) (unsigned 32)))
- env))))
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (multiple-value-bind (low high)
- (%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))))
-