[oct-cvs] Oct commit: oct qd-methods.lisp

[rtoy]

Update of /project/oct/cvsroot/oct
In directory clnet:/tmp/cvs-serv30205

Modified Files:
	qd-methods.lisp 
Log Message:
For CMUCL, define compiler macros to convert two-arg-foo into the
appropriate CL function or QD-REAL function so we don't have to do
CLOS dispatch, if the types are known at compile-time.


--- /project/oct/cvsroot/oct/qd-methods.lisp	2008/07/18 17:02:04	1.66
+++ /project/oct/cvsroot/oct/qd-methods.lisp	2008/07/31 19:13:42	1.67
@@ -990,6 +990,76 @@
   (if (cdr more-numbers)
       form
       `(not (two-arg-= ,number ,(car more-numbers)))))
+
+
+;; Define compiler macro the convert two-arg-foo into the appropriate
+;; CL function or QD-REAL function so we don't have to do CLOS
+;; dispatch.
+#+cmu
+(macrolet
+    ((frob (name cl-op qd-op)
+       `(define-compiler-macro ,name (&whole form x y &environment env)
+	  (flet ((arg-type (arg)
+		   (multiple-value-bind (def-type localp decl)
+		       (ext:variable-information arg env)
+		     (declare (ignore localp))
+		     (when def-type
+		       (cdr (assoc 'type decl))))))
+	    (let ((x-type (arg-type x))
+		  (y-type (arg-type y)))
+	      (cond ((and (subtypep x-type 'cl:number)
+			  (subtypep y-type 'cl:number))
+		     `(,',cl-op ,x ,y))
+		    ((and (subtypep x-type 'qd-real)
+			  (subtypep y-type 'qd-real))
+		     `(make-instance 'qd-real :value (,',qd-op (qd-value ,x)
+							       (qd-value ,y))))
+		    (t
+		     ;; Don't know how to handle this, so give up.
+		     form)))))))
+  (frob two-arg-+ cl:+ add-qd)
+  (frob two-arg-- cl:- sub-qd)
+  (frob two-arg-* cl:* mul-qd)
+  (frob two-arg-/ cl:/ div-qd))
+
+#+cmu
+(macrolet
+    ((frob (name cl-op qd-op cl-qd-op qd-cl-op)
+       `(define-compiler-macro ,name (&whole form x y &environment env)
+	  (flet ((arg-type (arg)
+		   (multiple-value-bind (def-type localp decl)
+		       (ext:variable-information arg env)
+		     (declare (ignore localp))
+		     (when def-type
+		       (cdr (assoc 'type decl))))))
+	    (let ((x-type (arg-type x))
+		  (y-type (arg-type y)))
+	      (cond ((subtypep x-type 'cl:float)
+		     (cond ((subtypep y-type 'cl:number)
+			    `(,',cl-op ,x ,y))
+			   ((subtypep y-type 'qd-real)
+			    (if ,cl-qd-op
+				`(make-instance 'qd-real :value (,',cl-qd-op (cl:float ,x 1d0)
+									     (qd-value ,y)))
+				form))
+			   (t form)))
+		    ((subtypep x-type 'qd-real)
+		     (cond ((subtypep y-type 'cl:float)
+			    (if ,qd-cl-op
+				`(make-instance 'qd-real :value (,',qd-cl-op (qd-value ,x)
+									     (float ,y 1d0)))
+				form))
+			   ((subtypep y-type 'qd-real)
+			    `(make-instance 'qd-real :value (,',qd-op (qd-value ,x)
+								      (qd-value ,y))))
+			   (t form)))
+		    (t
+		     ;; Don't know how to handle this, so give up.
+		     form)))))))
+  (frob two-arg-+ cl:+ add-qd add-d-qd add-qd-d)
+  (frob two-arg-- cl:- sub-qd sub-d-qd sub-qd-d)
+  (frob two-arg-* cl:* mul-qd mul-d-qd mul-qd-d)
+  (frob two-arg-/ cl:/ div-qd nil nil))
   
 
 (defun read-qd-real-or-complex (stream)