[mcclim-cvs] CVS update: mcclim/Examples/method-browser.lisp
Andy Hefner
ahefner at common-lisp.net
Sun Mar 6 20:35:41 UTC 2005
Update of /project/mcclim/cvsroot/mcclim/Examples
In directory common-lisp.net:/tmp/cvs-serv2663
Modified Files:
method-browser.lisp
Log Message:
Support for EQL specializers on SBCL and CMUCL.
Date: Sun Mar 6 21:35:40 2005
Author: ahefner
Index: mcclim/Examples/method-browser.lisp
diff -u mcclim/Examples/method-browser.lisp:1.1 mcclim/Examples/method-browser.lisp:1.2
--- mcclim/Examples/method-browser.lisp:1.1 Mon Jan 31 07:24:24 2005
+++ mcclim/Examples/method-browser.lisp Sun Mar 6 21:35:40 2005
@@ -22,7 +22,8 @@
;;; --------------------------------------------------------------------
;;; This is an example of how to write a CLIM application with a
-;;; "normal" GUI. McCLIM can do more than just command lines..
+;;; "normal" GUI, where "normal" is a completely event driven app
+;;; built using gadgets and not using the command-oriented framework.
;;; Running the method-browser:
;;; (clim-demo::run-test 'clim-demo::method-browser)
@@ -45,7 +46,7 @@
;;; * Portable MOP provided by CLIM-MOP package
;;; TODO:
-;;; * EQL specializers (not portable according to AMOP)
+;;; * EQL specializers on implementations other than SBCL/CMUCL
;;; * Nicer, more clever display of methods than simply listing them in a row.
;;; To do this right really involes some nonportable fun and a codewalker.
;;; You could probably write something that just understood the standard
@@ -66,6 +67,28 @@
collect (remove-duplicates (mapcar (lambda (specs) (nth index specs))
specializers)))))
+(defun classp (x)
+ (or (typep x 'cl:class)
+ #+CMU (typep x 'pcl::class)))
+
+(defun eql-specializer-p (x)
+ #+SBCL (typep x 'sb-mop:eql-specializer)
+ #+CMU (typep x 'pcl:eql-specializer))
+
+(defun eql-specializer-object (x)
+ #+SBCL (sb-mop:eql-specializer-object x)
+ #+CMU (pcl::eql-specializer-object x))
+
+(defun compute-applicable-methods-from-specializers (gf specializers)
+ (clim-mop:compute-applicable-methods gf
+ (mapcar (lambda (spec)
+ (cond ((eql-specializer-p spec)
+ (eql-specializer-object spec))
+ ((classp spec)
+ (clim-mop:class-prototype spec))
+ (t (error "Can't compute effective methods, specializer ~A is not understood." spec))))
+ specializers)))
+
;; FIXME: Support EQL specializers.
;; This is hard to do ideally, and I'm not really trying.
;; So we just make sure that T ends up at the head of the list.
@@ -77,8 +100,23 @@
(cond
((eql a (find-class t)) t)
((eql b (find-class t)) nil)
- (t (string< (class-name a)
- (class-name b)))))))
+ ((and (classp a)
+ (classp b))
+ (string< (class-name a)
+ (class-name b)))
+ ((and (eql-specializer-p a)
+ (not (eql-specializer-p b)))
+ nil)
+ ((and (not (eql-specializer-p a))
+ (eql-specializer-p b))
+ t)
+ ((and (eql-specializer-p a)
+ (eql-specializer-p b))
+ (string<
+ (princ-to-string (eql-specializer-object a))
+ (princ-to-string (eql-specializer-object b))))
+ (t (warn "Received specializer of unknown type")
+ nil) ))))
(compute-gf-specializers gf)))
(defun simple-generic-function-lambda-list (gf)
@@ -95,9 +133,10 @@
(defun specializer-pretty-name (spec)
"Pretty print the name of a method specializer"
- (cond ((or (typep spec 'class)
- #+CMU (typep spec 'pcl::class))
+ (cond ((classp spec)
(princ-to-string (class-name spec)))
+ ((eql-specializer-p spec)
+ (format nil "(EQL '~A)" (eql-specializer-object spec)))
(t (princ-to-string spec))))
(defun maybe-find-gf (name)
@@ -274,10 +313,10 @@
"Generates the display of applicable methods in the output-pane"
(when (gf frame)
(let* ((gf (gf frame))
- (methods (clim-mop:compute-applicable-methods-using-classes gf (arg-types frame)))
+ (methods (compute-applicable-methods-from-specializers gf (arg-types frame)))
(combination (clim-mop:generic-function-method-combination gf))
(effective-methods (clim-mop:compute-effective-method gf combination methods))
- (serial-methods (walk-em-form effective-methods)))
+ (serial-methods (walk-em-form effective-methods)))
;; Print the header
(fresh-line)
(with-drawing-options (pane :text-style (make-text-style :sans-serif :bold :large)
More information about the Mcclim-cvs
mailing list