Changeset 6648

Timestamp:

Jun 3, 2007, 2:44:54 AM (17 years ago)

Author:

Gary Byers

Message:

DEFCALLBACK: if error-return, use HANDLER-BIND, not HANDLER-CASE.

File:

• branches/ide-1.0/ccl/lib/macros.lisp (modified) (2 diffs)

branches/ide-1.0/ccl/lib/macros.lisp

@@ -2427 +2427 @@
                        (%setf-macptr-to-object ,stack-ptr ,stack-word)
                        (with-macptrs (,@(when fp-args-form
-                                             `((,fp-args-ptr ,fp-args-form))))
-                         ,(defcallback-body  stack-ptr
-                                             fp-args-ptr
-                                             lets
-                                             rlets
-                                             inits
-                                             `(declare (dynamic-extent ,@dynamic-extent-names))
-                                             decls
-                                             body
-                                             foreign-return-type
-                                             struct-return-arg-name
-                                             error-return
-                                             error-return-offset
-                                             ))))))
+                                              `((,fp-args-ptr ,fp-args-form))))
+                         ,(defcallback-body stack-ptr
+                                            fp-args-ptr
+                                            lets
+                                            rlets
+                                            inits
+                                            `(declare (dynamic-extent ,@dynamic-extent-names))
+                                            decls
+                                            body
+                                            foreign-return-type
+                                            struct-return-arg-name
+                                            error-return
+                                            error-return-offset
+                                            ))))))
                 ,doc
               ,woi
@@ -2449 +2449 @@
   (declare (dynamic-extent args))
   (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args
-      (let* ((result (gensym))
-         (condition-name (if (atom error-return) 'error (car error-return)))
-         (error-return-function (if (atom error-return) error-return (cadr error-return)))
-         (body
-          `(rlet ,rlets
-            (let ,lets
-              ,dynamic-extent-decls
-              ,@other-decls
-              ,@inits
-              (let ((,result (progn ,@body)))
-                (declare (ignorable ,result))
-                ,@(progn
-                   ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT
-                   (when (typep return-type 'foreign-single-float-type)
-                     (setq result `(float ,result 0.0d0)))
-                   nil)
-                ,(funcall (ftd-callback-return-value-function *target-ftd*)
-                          stack-ptr
-                          fp-args-ptr
-                          result
-                          return-type
-                          struct-return-arg))))))
-    (if error-return
-      (let* ((cond (gensym)))
-        `(handler-case ,body
-          (,condition-name (,cond) (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)))))
-      body))))
+    (declare (ignorable dynamic-extent-decls))
+    (let* ((result (gensym))
+           (condition-name (if (atom error-return) 'error (car error-return)))
+           (error-return-function (if (atom error-return) error-return (cadr error-return)))
+           (body
+            `(rlet ,rlets
+              (let ,lets
+                ,dynamic-extent-decls
+                ,@other-decls
+                ,@inits
+                (let ((,result (progn ,@body)))
+                  (declare (ignorable ,result))
+                  ,@(progn
+                     ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT
+                     (when (typep return-type 'foreign-single-float-type)
+                       (setq result `(float ,result 0.0d0)))
+                     nil)
+                  ,(funcall (ftd-callback-return-value-function *target-ftd*)
+                            stack-ptr
+                            fp-args-ptr
+                            result
+                            return-type
+                            struct-return-arg))))))
+      (if error-return
+        (let* ((cond (gensym))
+               (block (gensym)))
+          `(block ,block (handler-bind ((,condition-name
+                                         (lambda (,cond)
+                                           (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))
+                                           (return-from ,block
+                                             nil))))
+                           ,body)))
+        body))))