Changeset 24645 for lang/commonlisp

Timestamp:

11/22/08 20:07:56 (4 years ago)

Author:

quek

Message:

apply Matthew D. Swank's patch. Thanks!

Location:

lang/commonlisp/cl-win32ole/trunk

Files:

• api (modified) (1 prop)
• api/compat.lisp (modified) (1 diff)
• api/variant.lisp (modified) (1 diff)
• cl-win32ole-sys.asd (modified) (1 diff)
• sys (modified) (1 prop)
• sys/ole-variant.lisp (modified) (2 diffs)
• sys/ole.lisp (modified) (1 diff)
• sys/package.lisp (modified) (1 diff)
• sys/util.lisp (modified) (1 diff)

lang/commonlisp/cl-win32ole/trunk/api/compat.lisp

@@ -2 +2 @@
 
 (defun finalize (object lambda)
-  #+sbcl
-  (sb-ext:finalize object lambda))
+  (tg:finalize object lambda))

lang/commonlisp/cl-win32ole/trunk/api/variant.lisp

@@ -14 +14 @@
     (cond ((variant-array-p ptr)
            (variant-array-to-lisp ptr))
-          (t (ecase (logand type (lognot VT_BYREF))
-               (#.VT_EMPTY nil)
-               (#.VT_I4 v)
-               (#.VT_R4 v)
-               (#.VT_R8 v)
-               (#.VT_BSTR (bstr->lisp v))
-               (#.VT_BOOL (= VARIANT_TRUE v))
-               (#.VT_DISPATCH (let ((dispatch (make-dispatch v)))
-                                (add-ref dispatch)
-                                dispatch)))))))
+          (t (eswitch (logand type (lognot VT_BYREF))
+               (VT_EMPTY nil)
+               (VT_I4 v)
+               (VT_R4 v)
+               (VT_R8 v)
+               (VT_BSTR (bstr->lisp v))
+               (VT_BOOL (= VARIANT_TRUE v))
+               (VT_DISPATCH (let ((dispatch (make-dispatch v)))
+                              (add-ref dispatch)
+                              dispatch)))))))
 
 (defun map-dim (fn list)

lang/commonlisp/cl-win32ole/trunk/cl-win32ole-sys.asd

@@ -20 +20 @@
                          (:file "safearray")
                          )))
-  :depends-on (cffi cl-ppcre))
+  :depends-on (cffi cl-ppcre trivial-garbage))

lang/commonlisp/cl-win32ole/trunk/sys/ole-variant.lisp

@@ -98 +98 @@
   (cond ((variant-array-p variant)
          'pointer)
-        (t (ecase (variant-type variant)
-             (#.VT_EMPTY 'long-long)
-             (#.VT_I4 'long)
-             (#.VT_R4 'float)
-             (#.VT_R8 'double)
-             (#.VT_BSTR 'pointer)
-             (#.VT_BOOL 'bool)
-             (#.VT_VARIANT 'pointer)
-             (#.VT_DISPATCH 'pointer)
+        (t (eswitch (variant-type variant)
+             (VT_EMPTY 'long-long)
+             (VT_I4 'long)
+             (VT_R4 'float)
+             (VT_R8 'double)
+             (VT_BSTR 'pointer)
+             (VT_BOOL 'bool)
+             (VT_VARIANT 'pointer)
+             (VT_DISPATCH 'pointer)
              ))))
 
@@ -183 +183 @@
     (setf (variant-type variant) type)
     (setf (variant-value variant)
-          (ecase (variant-type variant)
-            (#.VT_I4 value)
-            (#.VT_R4 value)
-            (#.VT_R8 value)
-            (#.VT_BSTR (lisp->bstr value))
-            (#.VT_BOOL (if value VARIANT_TRUE VARIANT_FALSE))
-            (#.VT_VARIANT value)
-            (#.VT_DISPATCH value)
-            (#.(logior VT_VARIANT VT_ARRAY) value)
+          (eswitch (variant-type variant)
+            (VT_I4 value)
+            (VT_R4 value)
+            (VT_R8 value)
+            (VT_BSTR (lisp->bstr value))
+            (VT_BOOL (if value VARIANT_TRUE VARIANT_FALSE))
+            (VT_VARIANT value)
+            (VT_DISPATCH value)
+            ((logior VT_VARIANT VT_ARRAY) value)
             ))
     variant))

lang/commonlisp/cl-win32ole/trunk/sys/ole.lisp

@@ -36 +36 @@
            do (let ((c (code-char
                         (cffi:mem-aref buffer :unsigned-short i))))
-                (unless (member c '(#\CR #\LF))
+                (unless (member c '(#\Return #\Linefeed))
                   (write-char c))))))))
 

lang/commonlisp/cl-win32ole/trunk/sys/package.lisp

@@ -136 +136 @@
 
            #:p
+           #:switch
+           #:eswitch
            ))
 

lang/commonlisp/cl-win32ole/trunk/sys/util.lisp

@@ -6 +6 @@
                         `(format t "~30a ; => ~a~%" ',arg ,arg))
                     body)))
+
+(defmacro switch (keyform &body cases)
+  "Switch is like case, except that it does not quote keys, and only accepts
+one key per case."
+  (let ((k (gensym)))
+    `(let ((,k ,keyform))
+       ,(reduce (lambda (case rest)
+                  (destructuring-bind (key &body forms) case
+                    `(cond ((eql ,key ,k) ,@forms)
+                           (t ,rest))))
+                cases
+                :from-end t
+                :initial-value nil))))
+ 
+(defmacro eswitch (keyform &body cases)
+  "ESwitch is like ecase, except that it does not quote keys, and only accepts
+one key per case."
+  (let ((k (gensym))
+        (cases (mapcar (lambda (case)
+                         (destructuring-bind (key &body forms) case
+                           (cons (list (gensym) key) forms)))
+                       cases)))
+    `(let ((,k ,keyform)
+           ,@(mapcar #'car cases))
+       ,(reduce (lambda (case rest)
+                  (destructuring-bind ((key-val key) &body forms) case
+                    (declare (ignore key))
+                    `(cond ((eql ,key-val ,k) ,@forms)
+                           (t ,rest))))
+                cases
+                :from-end t
+                :initial-value `(error "~a fell through ESWITCH expression. Wanted one of ~a"
+                                       ,k (list ,@(mapcar #'caar cases)))))))
+