source: trunk/abcl/t/mop-specializer.lisp

Last change on this file was 15638, checked in by Mark Evenson, 21 months ago

Subtypes of MOP:SPECIALIZER discriminator test working on ABCL

File size: 4.6 KB
Line 
1#| After ensuring <file:../abcl-prove.asd> is in ASDF:
2(unless (asdf:make :abcl-prove/closer-mop)
3(asdf:make :quicklisp-abcl)
4(ql:quickload :abcl-prove/closer-mop))
5(asdf:test-system :abcl-prove/closer-mop)
6|#
7
8;;;; N.b. packaging the code for the generic definitions outside the
9;;;; test form is necessary for SBCL to work, but under ABCL means
10;;;; that additional generic function specializers are added each time
11;;;; this file is processed by PROVE changing the results away from
12;;;; what is desired.
13
14;;;; <https://github.com/armedbear/abcl/issues/539>
15;;;; <https://research.gold.ac.uk/id/eprint/6828/1/jucs_14_20_3370_3388_newton.pdf>
16(in-package :closer-common-lisp-user) ;; defined in CLOSER-MOP
17(defclass fixnum>= (specializer)
18  ((number :type fixnum :initarg :number :initform most-negative-fixnum)
19   #+abcl
20   (sys::direct-methods :initform nil :allocation :class)
21   #+sbcl
22   (sb-pcl::direct-methods :initform (cons nil nil) :allocation :class)))
23
24(defmethod make-load-form ((spec fixnum>=) &optional env)
25  (declare (ignore env))
26  #+abcl
27  (make-load-form-saving-slots spec :slot-names '(number))
28  #+(or sbcl ecl)
29  (make-load-form-saving-slots spec))
30
31(defmethod class-name ((f fixnum>=))
32  `(fixnum>= ,(slot-value f 'number)))
33
34(defun fixnum>= (spec n)
35  (and (typep n 'fixnum) (>= n (slot-value spec 'number))))
36
37(defun fixnum>=-compare (spec-a spec-b)
38  (> (slot-value spec-a 'number) (slot-value spec-b 'number)))
39
40(defclass range-generic-function (standard-generic-function)
41  ()
42  (:metaclass closer-mop:funcallable-standard-class)
43  (:default-initargs :method-class (find-class 'standard-method)))
44
45(defmethod compute-applicable-methods-using-classes ((function range-generic-function) classes)
46  (declare (ignore function classes))
47  (values nil nil))
48
49(defmethod compute-applicable-methods ((function range-generic-function) args)
50  (let ((applicable-methods
51          (remove-if-not (lambda (method)
52                           (every #'fixnum>=
53                                  (method-specializers method) args))
54                         (generic-function-methods function))))
55    (values (sort applicable-methods
56                  (lambda (method-a method-b)
57                    (fixnum>=-compare
58                     ;; For simplicity, we only sort the applicable
59                     ;; methods by their first arguments.
60                     (first
61                      (method-specializers method-a))
62                     (first
63                      (method-specializers method-b)))))
64            t)))
65
66   ;;; Unlike the default specializers provided by CL which are parsed
67   ;;;  in `defmethod', a (reader) macro is required for custom
68   ;;;  specializers to be created at compile time.
69(defmacro define-range-method (name lambda-list &body body) 
70  `(defmethod ,name ,(mapcar (lambda (spec)
71                               (if (and (listp spec)
72                                        (second spec)
73                                        (listp (second spec))
74                                        (eql (first (second spec)) 'fixnum>=))
75                                   (list (first spec)
76                                         (make-instance 'fixnum>= :number (second (second spec))))
77                                   spec))
78                      lambda-list)
79     ,@body))
80
81(defgeneric foo (number)
82  (:generic-function-class range-generic-function))
83
84(define-range-method foo ((number (fixnum>= 0)))
85  (list 0))
86
87(define-range-method foo ((number (fixnum>= 10)))
88  (cons 10 (call-next-method)))
89
90(define-range-method foo ((number (fixnum>= 100)))
91  (cons 100 (call-next-method)))
92
93(prove:plan 1)
94(prove:ok
95 (flet ((foo-handling-error (arg)
96          (handler-case (foo arg)
97            #+abcl
98            (simple-error ()
99              'no-applicable-method)
100            #+sbcl
101            (sb-pcl::no-applicable-method-error ()
102              'no-applicable-method))))
103   (let ((result
104           (list
105            (foo-handling-error -1)
106            (foo-handling-error 5.0)
107            (foo-handling-error 5)
108            (foo-handling-error 50)
109            (foo-handling-error 500))))
110     (prove:diag (format nil "result: ~a~%" result))
111     (equalp result
112             `(no-applicable-method
113               no-applicable-method
114               (0)
115               (10 0)
116               (100 10 0)))))
117#|
118(foo -1)                                ; NO-APPLICABLE-METHOD
119
120(foo 5.0)                               ; NO-APPLICABLE-METHOD
121
122(foo 5)                                 ; => (0)
123
124(foo 50)                                ; => (10 0)
125
126(foo 500)                               ; => (100 10 0)
127
128|#
129"Able to get CLOSER-MOP to work on specializer")
130
131(in-package :cl-user)
132
133(prove:finalize)
134
Note: See TracBrowser for help on using the repository browser.