- (unless (alien-function-type-p alien-type)
- (give-up-ir1-transform))
- (let ((arg-types (alien-function-type-arg-types alien-type)))
- (unless (= (length args) (length arg-types))
- (abort-ir1-transform
- "wrong number of arguments; expected ~D, got ~D"
- (length arg-types)
- (length args)))
- (collect ((params) (deports))
- (dolist (arg-type arg-types)
- (let ((param (gensym)))
- (params param)
- (deports `(deport ,param ',arg-type))))
- (let ((return-type (alien-function-type-result-type alien-type))
- (body `(%alien-funcall (deport function ',alien-type)
- ',alien-type
- ,@(deports))))
- (if (alien-values-type-p return-type)
- (collect ((temps) (results))
- (dolist (type (alien-values-type-values return-type))
- (let ((temp (gensym)))
- (temps temp)
- (results `(naturalize ,temp ',type))))
- (setf body
- `(multiple-value-bind ,(temps) ,body
- (values ,@(results)))))
- (setf body `(naturalize ,body ',return-type)))
- (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
- `(lambda (function ,@(params))
- ,body)))))))
+ (unless (alien-fun-type-p alien-type)
+ (give-up-ir1-transform))
+ (let ((arg-types (alien-fun-type-arg-types alien-type)))
+ (unless (= (length args) (length arg-types))
+ (abort-ir1-transform
+ "wrong number of arguments; expected ~W, got ~W"
+ (length arg-types)
+ (length args)))
+ (collect ((params) (deports))
+ (dolist (arg-type arg-types)
+ (let ((param (gensym)))
+ (params param)
+ (deports `(deport ,param ',arg-type))))
+ ;; Build BODY from the inside out.
+ (let ((return-type (alien-fun-type-result-type alien-type))
+ ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
+ ;; to them) and do the call.
+ (body `(%alien-funcall (deport function ',alien-type)
+ ',alien-type
+ ,@(deports))))
+ ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
+ ;; the SAPs are taken for won't be moved by the GC. (If
+ ;; needed: some alien types won't need it).
+ (setf body `(maybe-with-pinned-objects ,(params) ,arg-types
+ ,body))
+ ;; Around that handle any memory allocation that's needed.
+ ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
+ ;; identity operation, but for example for deporting a
+ ;; Unicode string we need to convert the string into an
+ ;; octet array. This step needs to be done before the pinning
+ ;; to ensure we pin the right objects, so it can't be combined
+ ;; with the deporting.
+ ;; -- JES 2006-03-16
+ (loop for param in (params)
+ for arg-type in arg-types
+ do (setf body
+ `(let ((,param (deport-alloc ,param ',arg-type)))
+ ,body)))
+ (if (alien-values-type-p return-type)
+ (collect ((temps) (results))
+ (dolist (type (alien-values-type-values return-type))
+ (let ((temp (gensym)))
+ (temps temp)
+ (results `(naturalize ,temp ',type))))
+ (setf body
+ `(multiple-value-bind ,(temps) ,body
+ (values ,@(results)))))
+ (setf body `(naturalize ,body ',return-type)))
+ (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
+ `(lambda (function ,@(params))
+ ,body)))))))