+++ /dev/null
-(in-package "SPECIALIZABLE")
-
-(defstruct accept-node
- (name (error "missing name"))
- (children nil)
- (q nil))
-(defun print-accept-tree (tree stream)
- (let (*stack*)
- (declare (special *stack*))
- (labels ((walk (fun node)
- (let ((*stack* (cons node *stack*)))
- (declare (special *stack*))
- (mapc (lambda (x) (walk fun x)) (accept-node-children node)))
- (funcall fun node))
- (stringify (node)
- (case (length *stack*)
- (0 "*/*")
- (1 (format nil "~A/*" (accept-node-name node)))
- (2 (format nil "~A/~A" (accept-node-name (car *stack*)) (accept-node-name node))))))
- (let ((first t))
- (walk
- (lambda (x)
- (let ((q (accept-node-q x)))
- (when q
- (format stream "~:[, ~;~]" first)
- (format stream "~A~:[;q=~A~;~]" (stringify x) (= q 1.0) q)
- (setf first nil))))
- tree)))))
-(defmethod print-object ((o accept-node) s)
- (if (accept-node-name o)
- (call-next-method)
- (pprint-logical-block (s nil)
- (print-unreadable-object (o s :type t)
- (print-accept-tree o s)))))
-
-(defun q (media-type accept-tree)
- (let* ((pos (position #\/ media-type))
- (type (subseq media-type 0 pos))
- (subtype (subseq media-type (1+ pos)))
- (type-node (find type (accept-node-children accept-tree) :key #'accept-node-name :test #'string=))
- (subtype-node (and type-node (find subtype (accept-node-children type-node) :key #'accept-node-name :test #'string=))))
- (or (and subtype-node (accept-node-q subtype-node))
- (and type-node (accept-node-q type-node))
- (accept-node-q accept-tree))))
-
-(defun q-ok (media-type accept-tree)
- (let ((q (q media-type accept-tree)))
- (and q (> q 0) q)))
-
-(defun insert (range q tree)
- (labels ((ensure-node (range tree)
- (cond
- ((null range) tree)
- (t (ensure-node (cdr range)
- (or (find (car range) (accept-node-children tree)
- :key #'accept-node-name :test #'string=)
- (car (push
- (make-accept-node :name (car range))
- (accept-node-children tree)))))))))
- (let ((node (ensure-node range tree)))
- ;; we could choose different behaviour here
- (setf (accept-node-q node) q))
- tree))
-
-(defun parse-accept-string (string)
- (flet ((whitespacep (x)
- (member x '(#\Space #\Tab))))
- (let ((string (remove-if #'whitespacep string))
- (result (make-accept-node :name nil)))
- (cl-ppcre:do-register-groups (type subtype qp q)
- ;; not desperately error-proof
- ("([a-z]*|\\*)/([a-z0-9]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
- (if qp
- (setf q (float (+ (digit-char-p (char q 0))
- (/ (parse-integer q :start 2)
- (expt 10 (- (length q) 2))))))
- (setf q 1.0))
- (let ((range (and (string/= type "*")
- (cons type (and (string/= subtype "*")
- (list subtype))))))
- (insert range q result))))))
-\f
-;;; FIXME: tiebreaker predicate (maybe defaulting to string<)?
-(defclass accept-specializer (extended-specializer)
- ((media-type :initarg :media-type :type string :reader media-type)))
-(defmethod print-object ((o accept-specializer) s)
- (print-unreadable-object (o s :type t)
- (format s "~S" (media-type o))))
-;;; FIXME: would be cute to have sb-pcl:generalizer to inherit from.
-;;; Or maybe specializable:extended-generalizer could handle the NEXT
-;;; functionality?
-(defclass accept-generalizer ()
- ((header :initarg :header :reader header)
- (tree)
- (next :initarg :next :reader next)))
-(defmethod print-object ((o accept-generalizer) s)
- (print-unreadable-object (o s :type t)
- (print-accept-tree (tree o) s)))
-(defmethod tree ((x accept-generalizer))
- (if (slot-boundp x 'tree)
- (slot-value x 'tree)
- (setf (slot-value x 'tree) (parse-accept-string (header x)))))
-(defclass accept-generic-function (specializable-generic-function)
- ()
- (:metaclass sb-mop:funcallable-standard-class))
-
-(define-extended-specializer accept (gf arg)
- (declare (ignore gf))
- (make-instance 'accept-specializer :media-type arg))
-(defmethod sb-pcl:unparse-specializer-using-class
- ((gf accept-generic-function) (specializer accept-specializer))
- `(accept ,(media-type specializer)))
-(defmethod sb-pcl::same-specializer-p
- ((s1 accept-specializer) (s2 accept-specializer))
- (string= (media-type s1) (media-type s2)))
-
-(defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
- (make-instance 'accept-generalizer
- :header (tbnl:header-in :accept arg)
- :next (call-next-method)))
-(defmethod generalizer-equal-hash-key
- ((gf accept-generic-function) (g accept-generalizer))
- `(accept-generalizer ,(header g)))
-(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
- (values (q-ok (media-type s) (tree generalizer)) t))
-(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
- (values nil t))
-(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
- (specializer-accepts-generalizer-p gf s (next generalizer)))
-
-(defmethod specializer-accepts-p ((specializer accept-specializer) obj)
- nil)
-(defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
- (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
-
-(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
- (cond
- ((string= (media-type s1) (media-type s2)) '=)
- (t (let ((q1 (q (media-type s1) (tree generalizer)))
- (q2 (q (media-type s2) (tree generalizer))))
- (cond
- ((= q1 q2) '=)
- ((< q1 q2) '>)
- (t '<))))))
-(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
- '<)
-(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
- '>)
-(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
- (ecase (specializer< gf s2 s1 generalizer)
- ((>) '<)
- ((<) '>)))
-(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
- (specializer< gf s1 s2 (next g)))
-\f
-(defvar *actual-content-type*)
-(defgeneric handle-content-type (x))
-(define-method-combination content-negotiation ()
- ((around (:around))
- (before (:before))
- (primary () :required t)
- (after (:after)))
- (:arguments request)
- (labels ((call-methods (methods)
- (mapcar #'(lambda (method)
- `(call-method ,method))
- methods))
- (transform (primaries)
- (let ((method (car primaries))
- (nexts (cdr primaries)))
- `(make-method
- (progn
- (let ((request-specializer (car (sb-mop:method-specializers ,method))))
- (when (typep request-specializer 'accept-specializer)
- (setf *actual-content-type* (media-type request-specializer))))
- (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
- (wrap (form)
- `(let ((*actual-content-type*))
- (multiple-value-prog1
- ,form
- (handle-content-type ,request)))))
- (let ((form (if (or before after (rest primary))
- `(multiple-value-prog1
- (progn ,@(call-methods before)
- (catch 'content-negotiation (call-method ,(transform primary))))
- ,@(call-methods (reverse after)))
- `(catch 'content-negotiation (call-method ,(transform primary))))))
- (if around
- (wrap `(call-method ,(first around)
- (,@(rest around) (make-method ,form))))
- (wrap form)))))
-(define-method-combination content-negotiation/or ()
- ((around (:around))
- (primary () :required t))
- (:arguments request)
- (labels ((transform/1 (method)
- `(make-method
- (progn
- (let ((s (car (sb-mop:method-specializers ,method))))
- (when (typep s 'accept-specializer)
- (setf *actual-content-type* (media-type s))))
- (call-method ,method))))
- (transform (primaries)
- (mapcar #'(lambda (x) `(call-method ,(transform/1 x)))
- primaries))
- (wrap (form)
- `(let ((*actual-content-type*))
- (multiple-value-prog1
- ,form
- (handle-content-type ,request)))))
- (let ((form (if (rest primary)
- `(or ,@(transform primary))
- `(call-method ,(transform/1 (car primary))))))
- (if around
- (wrap `(call-method ,(first around)
- (,@(rest around) (make-method ,form))))
- (wrap form)))))
-
-(defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
- (make-instance 'accept-generalizer
- :header s
- :next (call-next-method)))
-(defmethod specializer-accepts-p ((s accept-specializer) (string string))
- (q-ok (media-type s) (parse-accept-string string)))
-
-(defmethod handle-content-type ((x tbnl:request))
- (setf (tbnl:content-type*) *actual-content-type*))
-(defmethod handle-content-type ((x string))
- (format t "~&Content-Type: ~A" *actual-content-type*))
-
-(defgeneric respond (request)
- (:generic-function-class accept-generic-function)
- (:method-combination list))
-(defmethod respond list (request)
- t)
-(defmethod respond list ((s string))
- 'string)
-(defmethod respond list ((s (accept "text/html")))
- "text/html")
-(defmethod respond list ((s (accept "audio/mp3")))
- "audio/mp3")
-
-(defgeneric cn-test (request)
- (:generic-function-class accept-generic-function)
- (:method-combination content-negotiation))
-(defmethod cn-test ((request (accept "text/html")))
- 'html)
-(defmethod cn-test ((request (accept "text/plain")))
- 'plain)
-(defmethod cn-test ((request (accept "image/webp")))
- 'webp)
-(defmethod cn-test ((request (accept "audio/mp3")))
- (call-next-method)
- 'mp3)
-(defmethod cn-test :after (request)
- (print 'after))
-
-(defgeneric cn/or-test (request)
- (:generic-function-class accept-generic-function)
- (:method-combination content-negotiation/or))
-
-(defmethod cn/or-test or ((request (accept "audio/mp3")))
- 'mp3)
-(defmethod cn/or-test or ((request (accept "image/webp")))
- 'webp)
-(defmethod cn/or-test :around ((request t))
- (print :around)
- (call-next-method))
+++ /dev/null
-(in-package "SPECIALIZABLE")
-
-;;;; CONS-SPECIALIZER example
-(defclass cons-specializer (extended-specializer)
- ((car :initarg :car :reader %car)))
-(defclass cons-generic-function (specializable-generic-function)
- ()
- (:metaclass sb-mop:funcallable-standard-class))
-
-(define-extended-specializer cons (gf car)
- (make-instance 'cons-specializer :car car))
-(defmethod sb-pcl:unparse-specializer-using-class
- ((gf cons-generic-function) (specializer cons-specializer))
- `(cons ,(%car specializer)))
-(defmethod sb-pcl::same-specializer-p
- ((s1 cons-specializer) (s2 cons-specializer))
- (eql (%car s1) (%car s2)))
-
-;;; FIXME: make a proper generalizer
-(defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
- g)
-(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
- (typecase arg
- ((cons symbol) (car arg))
- (t (call-next-method))))
-(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer cons-specializer) thing)
- (if (eql (%car specializer) thing)
- (values t t)
- (values nil t)))
-(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer sb-mop:specializer) (thing symbol))
- (specializer-accepts-generalizer-p gf specializer (find-class 'cons)))
-
-;;; note: this method operates in full knowledge of the object, and so
-;;; does not require the generic function as an argument.
-(defmethod specializer-accepts-p ((specializer cons-specializer) obj)
- (and (consp obj)
- (eql (car obj) (%car specializer))))
-
-(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 cons-specializer) generalizer)
- (declare (ignore generalizer))
- (if (eql (%car s1) (%car s2))
- '=
- nil))
-(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 class) generalizer)
- (declare (ignore generalizer))
- '<)
-(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
- (declare (ignore generalizer))
- '>)
-(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
- (ecase (specializer< gf s2 s1 generalizer)
- ((<) '>)
- ((>) '<)))
-;;; note: the need for this method is tricky: we need to translate
-;;; from generalizers that our specializers "know" about to those that
-;;; ordinary generic functions and specializers might know about.
-(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer symbol))
- (specializer< gf s1 s2 (find-class 'cons)))
-\f
-;;; tests / examples
-(eval
- '(progn
- (defgeneric walk (form)
- (:generic-function-class cons-generic-function))
- (defmethod walk ((form symbol))
- `(lookup ,form))
- (defmethod walk ((form cons))
- `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
- (defmethod walk ((form (cons quote)))
- (cadr form))
- (defmethod walk ((form (cons let)))
- (let ((bindings (cadr form)))
- `(with-bindings ,bindings ,@(mapcar #'walk (cddr form)))))
-
- (assert (equal (walk t) '(lookup t)))
- (assert (equal (walk nil) '(lookup nil)))
- (assert (equal (walk '(foo bar)) '(call (flookup foo) (list (lookup bar)))))
- (assert (equal (walk '(quote bar)) 'bar))
- (assert (equal (walk '(let foo bar)) '(with-bindings foo (lookup bar))))))
-
-(eval
- '(progn
- (defgeneric multiple-class-specializers (x)
- (:generic-function-class cons-generic-function)
- (:method-combination list))
- (defmethod multiple-class-specializers list ((x t)) 't)
- (defmethod multiple-class-specializers list ((x cons)) 'cons)
- (defmethod multiple-class-specializers list ((x (cons foo))) '(cons foo))
- (defmethod multiple-class-specializers list ((x (cons bar))) '(cons bar))
- (defmethod multiple-class-specializers list ((x list)) 'list)
- (defmethod multiple-class-specializers list ((x null)) 'null)
- (defmethod multiple-class-specializers list ((x (eql nil))) '(eql nil))
-
- (assert (equal (multiple-class-specializers nil) '((eql nil) null list t)))
- (assert (equal (multiple-class-specializers t) '(t)))
- (assert (equal (multiple-class-specializers (cons nil nil)) '(cons list t)))
- (assert (equal (multiple-class-specializers (cons 'foo nil)) '((cons foo) cons list t)))
- (assert (equal (multiple-class-specializers (list 'bar nil t 3)) '((cons bar) cons list t)))))
-
-(eval
- '(progn
- (defgeneric keyword-args (x &key key1)
- (:generic-function-class cons-generic-function))
- (defmethod keyword-args ((x integer) &key key1 key2) (1+ x))
- (defmethod keyword-args ((x float) &key key1 key3) (+ x 2.0))
- (defmethod keyword-args :after ((x double-float) &key &allow-other-keys)
- nil)
- (assert (= (keyword-args 1) 2))
- (assert (= (keyword-args 1 :key1 t) 2))
- (assert (= (keyword-args 1 :key2 t) 2))
- (assert (= (keyword-args 1 :key1 t :key2 t) 2))
- (assert (nth-value 1 (ignore-errors (keyword-args 1 :key1 t :key3 t))))
- (assert (nth-value 1 (ignore-errors (keyword-args 1 :key3 t))))
- (assert (= (keyword-args 1 :key3 t :allow-other-keys t) 2))
-
- (assert (= (keyword-args 1.0) 3.0))
- (assert (= (keyword-args 1.0 :key1 t) 3.0))
- (assert (= (keyword-args 1.0 :key3 t) 3.0))
- (assert (= (keyword-args 1.0 :key1 t :key3 t) 3.0))
- (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key1 t :key2 t))))
- (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key2 t))))
- (assert (= (keyword-args 1.0 :key2 t :allow-other-keys t) 3.0))
-
- (assert (= (keyword-args 1.0d0) 3.0d0))
- (assert (= (keyword-args 1.0d0 :key1 t) 3.0d0))
- (assert (= (keyword-args 1.0d0 :key3 t) 3.0d0))
- (assert (= (keyword-args 1.0d0 :key1 t :key3 t) 3.0d0))
- (assert (= (keyword-args 1.0d0 :key1 t :key2 t) 3.0d0))
- (assert (= (keyword-args 1.0d0 :key2 t) 3.0d0))
- (assert (= (keyword-args 1.0d0 :key2 t :allow-other-keys t) 3.0d0))))
--- /dev/null
+(in-package "SPECIALIZABLE")
+
+(defstruct accept-node
+ (name (error "missing name"))
+ (children nil)
+ (q nil))
+(defun print-accept-tree (tree stream)
+ (let (*stack*)
+ (declare (special *stack*))
+ (labels ((walk (fun node)
+ (let ((*stack* (cons node *stack*)))
+ (declare (special *stack*))
+ (mapc (lambda (x) (walk fun x)) (accept-node-children node)))
+ (funcall fun node))
+ (stringify (node)
+ (case (length *stack*)
+ (0 "*/*")
+ (1 (format nil "~A/*" (accept-node-name node)))
+ (2 (format nil "~A/~A" (accept-node-name (car *stack*)) (accept-node-name node))))))
+ (let ((first t))
+ (walk
+ (lambda (x)
+ (let ((q (accept-node-q x)))
+ (when q
+ (format stream "~:[, ~;~]" first)
+ (format stream "~A~:[;q=~A~;~]" (stringify x) (= q 1.0) q)
+ (setf first nil))))
+ tree)))))
+(defmethod print-object ((o accept-node) s)
+ (if (accept-node-name o)
+ (call-next-method)
+ (pprint-logical-block (s nil)
+ (print-unreadable-object (o s :type t)
+ (print-accept-tree o s)))))
+
+(defun q (media-type accept-tree)
+ (let* ((pos (position #\/ media-type))
+ (type (subseq media-type 0 pos))
+ (subtype (subseq media-type (1+ pos)))
+ (type-node (find type (accept-node-children accept-tree) :key #'accept-node-name :test #'string=))
+ (subtype-node (and type-node (find subtype (accept-node-children type-node) :key #'accept-node-name :test #'string=))))
+ (or (and subtype-node (accept-node-q subtype-node))
+ (and type-node (accept-node-q type-node))
+ (accept-node-q accept-tree))))
+
+(defun q-ok (media-type accept-tree)
+ (let ((q (q media-type accept-tree)))
+ (and q (> q 0) q)))
+
+(defun insert (range q tree)
+ (labels ((ensure-node (range tree)
+ (cond
+ ((null range) tree)
+ (t (ensure-node (cdr range)
+ (or (find (car range) (accept-node-children tree)
+ :key #'accept-node-name :test #'string=)
+ (car (push
+ (make-accept-node :name (car range))
+ (accept-node-children tree)))))))))
+ (let ((node (ensure-node range tree)))
+ ;; we could choose different behaviour here
+ (setf (accept-node-q node) q))
+ tree))
+
+(defun parse-accept-string (string)
+ (flet ((whitespacep (x)
+ (member x '(#\Space #\Tab))))
+ (let ((string (remove-if #'whitespacep string))
+ (result (make-accept-node :name nil)))
+ (cl-ppcre:do-register-groups (type subtype qp q)
+ ;; not desperately error-proof
+ ("([a-z]*|\\*)/([a-z0-9]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
+ (if qp
+ (setf q (float (+ (digit-char-p (char q 0))
+ (/ (parse-integer q :start 2)
+ (expt 10 (- (length q) 2))))))
+ (setf q 1.0))
+ (let ((range (and (string/= type "*")
+ (cons type (and (string/= subtype "*")
+ (list subtype))))))
+ (insert range q result))))))
+\f
+;;; FIXME: tiebreaker predicate (maybe defaulting to string<)?
+(defclass accept-specializer (extended-specializer)
+ ((media-type :initarg :media-type :type string :reader media-type)))
+(defmethod print-object ((o accept-specializer) s)
+ (print-unreadable-object (o s :type t)
+ (format s "~S" (media-type o))))
+;;; FIXME: would be cute to have sb-pcl:generalizer to inherit from.
+;;; Or maybe specializable:extended-generalizer could handle the NEXT
+;;; functionality?
+(defclass accept-generalizer ()
+ ((header :initarg :header :reader header)
+ (tree)
+ (next :initarg :next :reader next)))
+(defmethod print-object ((o accept-generalizer) s)
+ (print-unreadable-object (o s :type t)
+ (print-accept-tree (tree o) s)))
+(defmethod tree ((x accept-generalizer))
+ (if (slot-boundp x 'tree)
+ (slot-value x 'tree)
+ (setf (slot-value x 'tree) (parse-accept-string (header x)))))
+(defclass accept-generic-function (specializable-generic-function)
+ ()
+ (:metaclass sb-mop:funcallable-standard-class))
+
+(define-extended-specializer accept (gf arg)
+ (declare (ignore gf))
+ (make-instance 'accept-specializer :media-type arg))
+(defmethod sb-pcl:unparse-specializer-using-class
+ ((gf accept-generic-function) (specializer accept-specializer))
+ `(accept ,(media-type specializer)))
+(defmethod sb-pcl::same-specializer-p
+ ((s1 accept-specializer) (s2 accept-specializer))
+ (string= (media-type s1) (media-type s2)))
+
+(defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
+ (make-instance 'accept-generalizer
+ :header (tbnl:header-in :accept arg)
+ :next (call-next-method)))
+(defmethod generalizer-equal-hash-key
+ ((gf accept-generic-function) (g accept-generalizer))
+ `(accept-generalizer ,(header g)))
+(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
+ (values (q-ok (media-type s) (tree generalizer)) t))
+(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
+ (values nil t))
+(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
+ (specializer-accepts-generalizer-p gf s (next generalizer)))
+
+(defmethod specializer-accepts-p ((specializer accept-specializer) obj)
+ nil)
+(defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
+ (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
+
+(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
+ (cond
+ ((string= (media-type s1) (media-type s2)) '=)
+ (t (let ((q1 (q (media-type s1) (tree generalizer)))
+ (q2 (q (media-type s2) (tree generalizer))))
+ (cond
+ ((= q1 q2) '=)
+ ((< q1 q2) '>)
+ (t '<))))))
+(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
+ '<)
+(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
+ '>)
+(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
+ (ecase (specializer< gf s2 s1 generalizer)
+ ((>) '<)
+ ((<) '>)))
+(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
+ (specializer< gf s1 s2 (next g)))
+\f
+(defvar *actual-content-type*)
+(defgeneric handle-content-type (x))
+(define-method-combination content-negotiation ()
+ ((around (:around))
+ (before (:before))
+ (primary () :required t)
+ (after (:after)))
+ (:arguments request)
+ (labels ((call-methods (methods)
+ (mapcar #'(lambda (method)
+ `(call-method ,method))
+ methods))
+ (transform (primaries)
+ (let ((method (car primaries))
+ (nexts (cdr primaries)))
+ `(make-method
+ (progn
+ (let ((request-specializer (car (sb-mop:method-specializers ,method))))
+ (when (typep request-specializer 'accept-specializer)
+ (setf *actual-content-type* (media-type request-specializer))))
+ (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
+ (wrap (form)
+ `(let ((*actual-content-type*))
+ (multiple-value-prog1
+ ,form
+ (handle-content-type ,request)))))
+ (let ((form (if (or before after (rest primary))
+ `(multiple-value-prog1
+ (progn ,@(call-methods before)
+ (catch 'content-negotiation (call-method ,(transform primary))))
+ ,@(call-methods (reverse after)))
+ `(catch 'content-negotiation (call-method ,(transform primary))))))
+ (if around
+ (wrap `(call-method ,(first around)
+ (,@(rest around) (make-method ,form))))
+ (wrap form)))))
+(define-method-combination content-negotiation/or ()
+ ((around (:around))
+ (primary () :required t))
+ (:arguments request)
+ (labels ((transform/1 (method)
+ `(make-method
+ (progn
+ (let ((s (car (sb-mop:method-specializers ,method))))
+ (when (typep s 'accept-specializer)
+ (setf *actual-content-type* (media-type s))))
+ (call-method ,method))))
+ (transform (primaries)
+ (mapcar #'(lambda (x) `(call-method ,(transform/1 x)))
+ primaries))
+ (wrap (form)
+ `(let ((*actual-content-type*))
+ (multiple-value-prog1
+ ,form
+ (handle-content-type ,request)))))
+ (let ((form (if (rest primary)
+ `(or ,@(transform primary))
+ `(call-method ,(transform/1 (car primary))))))
+ (if around
+ (wrap `(call-method ,(first around)
+ (,@(rest around) (make-method ,form))))
+ (wrap form)))))
+
+(defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
+ (make-instance 'accept-generalizer
+ :header s
+ :next (call-next-method)))
+(defmethod specializer-accepts-p ((s accept-specializer) (string string))
+ (q-ok (media-type s) (parse-accept-string string)))
+
+(defmethod handle-content-type ((x tbnl:request))
+ (setf (tbnl:content-type*) *actual-content-type*))
+(defmethod handle-content-type ((x string))
+ (format t "~&Content-Type: ~A" *actual-content-type*))
+
+(defgeneric respond (request)
+ (:generic-function-class accept-generic-function)
+ (:method-combination list))
+(defmethod respond list (request)
+ t)
+(defmethod respond list ((s string))
+ 'string)
+(defmethod respond list ((s (accept "text/html")))
+ "text/html")
+(defmethod respond list ((s (accept "audio/mp3")))
+ "audio/mp3")
+
+(defgeneric cn-test (request)
+ (:generic-function-class accept-generic-function)
+ (:method-combination content-negotiation))
+(defmethod cn-test ((request (accept "text/html")))
+ 'html)
+(defmethod cn-test ((request (accept "text/plain")))
+ 'plain)
+(defmethod cn-test ((request (accept "image/webp")))
+ 'webp)
+(defmethod cn-test ((request (accept "audio/mp3")))
+ (call-next-method)
+ 'mp3)
+(defmethod cn-test :after (request)
+ (print 'after))
+
+(defgeneric cn/or-test (request)
+ (:generic-function-class accept-generic-function)
+ (:method-combination content-negotiation/or))
+
+(defmethod cn/or-test or ((request (accept "audio/mp3")))
+ 'mp3)
+(defmethod cn/or-test or ((request (accept "image/webp")))
+ 'webp)
+(defmethod cn/or-test :around ((request t))
+ (print :around)
+ (call-next-method))
--- /dev/null
+(in-package "SPECIALIZABLE")
+
+;;;; CONS-SPECIALIZER example
+(defclass cons-specializer (extended-specializer)
+ ((car :initarg :car :reader %car)))
+(defclass cons-generic-function (specializable-generic-function)
+ ()
+ (:metaclass sb-mop:funcallable-standard-class))
+
+(define-extended-specializer cons (gf car)
+ (make-instance 'cons-specializer :car car))
+(defmethod sb-pcl:unparse-specializer-using-class
+ ((gf cons-generic-function) (specializer cons-specializer))
+ `(cons ,(%car specializer)))
+(defmethod sb-pcl::same-specializer-p
+ ((s1 cons-specializer) (s2 cons-specializer))
+ (eql (%car s1) (%car s2)))
+
+;;; FIXME: make a proper generalizer
+(defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
+ g)
+(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
+ (typecase arg
+ ((cons symbol) (car arg))
+ (t (call-next-method))))
+(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer cons-specializer) thing)
+ (if (eql (%car specializer) thing)
+ (values t t)
+ (values nil t)))
+(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer sb-mop:specializer) (thing symbol))
+ (specializer-accepts-generalizer-p gf specializer (find-class 'cons)))
+
+;;; note: this method operates in full knowledge of the object, and so
+;;; does not require the generic function as an argument.
+(defmethod specializer-accepts-p ((specializer cons-specializer) obj)
+ (and (consp obj)
+ (eql (car obj) (%car specializer))))
+
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 cons-specializer) generalizer)
+ (declare (ignore generalizer))
+ (if (eql (%car s1) (%car s2))
+ '=
+ nil))
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 class) generalizer)
+ (declare (ignore generalizer))
+ '<)
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
+ (declare (ignore generalizer))
+ '>)
+(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
+ (ecase (specializer< gf s2 s1 generalizer)
+ ((<) '>)
+ ((>) '<)))
+;;; note: the need for this method is tricky: we need to translate
+;;; from generalizers that our specializers "know" about to those that
+;;; ordinary generic functions and specializers might know about.
+(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer symbol))
+ (specializer< gf s1 s2 (find-class 'cons)))
+\f
+;;; tests / examples
+(eval
+ '(progn
+ (defgeneric walk (form)
+ (:generic-function-class cons-generic-function))
+ (defmethod walk ((form symbol))
+ `(lookup ,form))
+ (defmethod walk ((form cons))
+ `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
+ (defmethod walk ((form (cons quote)))
+ (cadr form))
+ (defmethod walk ((form (cons let)))
+ (let ((bindings (cadr form)))
+ `(with-bindings ,bindings ,@(mapcar #'walk (cddr form)))))
+
+ (assert (equal (walk t) '(lookup t)))
+ (assert (equal (walk nil) '(lookup nil)))
+ (assert (equal (walk '(foo bar)) '(call (flookup foo) (list (lookup bar)))))
+ (assert (equal (walk '(quote bar)) 'bar))
+ (assert (equal (walk '(let foo bar)) '(with-bindings foo (lookup bar))))))
+
+(eval
+ '(progn
+ (defgeneric multiple-class-specializers (x)
+ (:generic-function-class cons-generic-function)
+ (:method-combination list))
+ (defmethod multiple-class-specializers list ((x t)) 't)
+ (defmethod multiple-class-specializers list ((x cons)) 'cons)
+ (defmethod multiple-class-specializers list ((x (cons foo))) '(cons foo))
+ (defmethod multiple-class-specializers list ((x (cons bar))) '(cons bar))
+ (defmethod multiple-class-specializers list ((x list)) 'list)
+ (defmethod multiple-class-specializers list ((x null)) 'null)
+ (defmethod multiple-class-specializers list ((x (eql nil))) '(eql nil))
+
+ (assert (equal (multiple-class-specializers nil) '((eql nil) null list t)))
+ (assert (equal (multiple-class-specializers t) '(t)))
+ (assert (equal (multiple-class-specializers (cons nil nil)) '(cons list t)))
+ (assert (equal (multiple-class-specializers (cons 'foo nil)) '((cons foo) cons list t)))
+ (assert (equal (multiple-class-specializers (list 'bar nil t 3)) '((cons bar) cons list t)))))
+
+(eval
+ '(progn
+ (defgeneric keyword-args (x &key key1)
+ (:generic-function-class cons-generic-function))
+ (defmethod keyword-args ((x integer) &key key1 key2) (1+ x))
+ (defmethod keyword-args ((x float) &key key1 key3) (+ x 2.0))
+ (defmethod keyword-args :after ((x double-float) &key &allow-other-keys)
+ nil)
+ (assert (= (keyword-args 1) 2))
+ (assert (= (keyword-args 1 :key1 t) 2))
+ (assert (= (keyword-args 1 :key2 t) 2))
+ (assert (= (keyword-args 1 :key1 t :key2 t) 2))
+ (assert (nth-value 1 (ignore-errors (keyword-args 1 :key1 t :key3 t))))
+ (assert (nth-value 1 (ignore-errors (keyword-args 1 :key3 t))))
+ (assert (= (keyword-args 1 :key3 t :allow-other-keys t) 2))
+
+ (assert (= (keyword-args 1.0) 3.0))
+ (assert (= (keyword-args 1.0 :key1 t) 3.0))
+ (assert (= (keyword-args 1.0 :key3 t) 3.0))
+ (assert (= (keyword-args 1.0 :key1 t :key3 t) 3.0))
+ (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key1 t :key2 t))))
+ (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key2 t))))
+ (assert (= (keyword-args 1.0 :key2 t :allow-other-keys t) 3.0))
+
+ (assert (= (keyword-args 1.0d0) 3.0d0))
+ (assert (= (keyword-args 1.0d0 :key1 t) 3.0d0))
+ (assert (= (keyword-args 1.0d0 :key3 t) 3.0d0))
+ (assert (= (keyword-args 1.0d0 :key1 t :key3 t) 3.0d0))
+ (assert (= (keyword-args 1.0d0 :key1 t :key2 t) 3.0d0))
+ (assert (= (keyword-args 1.0d0 :key2 t) 3.0d0))
+ (assert (= (keyword-args 1.0d0 :key2 t :allow-other-keys t) 3.0d0))))
--- /dev/null
+(in-package "SPECIALIZABLE")
+
+(defclass prototype-object ()
+ (;; FIXME: we should add slots at some point
+ (delegations :initarg :delegations :accessor delegations)
+ (roles :initform (make-array 0 :adjustable t :fill-pointer t)
+ :accessor roles)
+ ;; debugging aid
+ (name)))
+(defmethod print-object ((o prototype-object) s)
+ (if (slot-boundp o 'name)
+ (format s "~S" (slot-value o 'name))
+ (print-unreadable-object (o s :type t :identity t)
+ (format s "[~{~S~^, ~}]" (delegations o)))))
+(defun add-delegation (obj del)
+ (push del (delegations obj)))
+(defun remove-delegation (obj)
+ (pop (delegations obj)))
+(defun map-delegations (fun obj)
+ (funcall fun obj)
+ ;; FIXME: should we maintain a table of visited nodes? Should it be
+ ;; topologically sorted? Section 5.3 in PwMD [Salzman & Aldrich]
+ ;; suggests not, at least for now
+ (mapc (lambda (o) (map-delegations fun o)) (delegations obj))
+ nil)
+(defstruct (role (:type list) (:constructor make-role (method argpos)))
+ method argpos)
+(defun add-role (obj role)
+ (let ((pos (role-argpos role))
+ (roles (roles obj)))
+ (unless (< pos (length roles))
+ (dotimes (i (- (1+ pos) (length roles)))
+ (vector-push-extend nil roles)))
+ (pushnew (role-method role) (aref roles pos))))
+(defun remove-role (obj role)
+ (let ((pos (role-argpos role)))
+ (setf (aref (roles obj) pos)
+ (remove (role-method role) (aref (roles obj) pos)))
+ (tagbody
+ start
+ (when (or (= (length (roles obj)) 0)
+ (aref (roles obj) (1- (length (roles obj)))))
+ (go done))
+ (vector-pop (roles obj))
+ (go start)
+ done)))
+(defun map-roles (fun obj)
+ (dotimes (i (length (roles obj)))
+ (dolist (m (aref (roles obj) i))
+ (funcall fun (make-role m i)))))
+(defun find-role (role obj)
+ (when (< (role-argpos role) (length (roles obj)))
+ (find (role-method role) (aref (roles obj) (role-argpos role)))))
+(defmacro do-roles ((rvar form &optional result) &body body)
+ `(progn (map-roles (lambda (,rvar) ,@body) ,form) ,result))
+(defun clone (p)
+ (let ((result (make-instance 'prototype-object
+ :delegations (copy-list (delegations p)))))
+ (do-roles (r p result)
+ (add-role result r))))
+
+;;; redefinition semantics are interesting. We need the INFO here so
+;;; that we can implement specializer-accepts-p, which must be able to
+;;; lookup the particular method/argpos that the specializer
+;;; represents. But we must also be able to redefine methods in a way
+;;; that isn't insane, which I think implies that same-specializer-p
+;;; should ignore the INFO and just use the OBJECT.
+(defclass prototype-specializer (extended-specializer)
+ ((role :accessor prototype-specializer-role)
+ (object :initarg :object :accessor prototype-specializer-object)))
+(defmethod print-object ((o prototype-specializer) s)
+ (print-unreadable-object (o s :type t :identity t)
+ (format s "~S" (prototype-specializer-object o))))
+(defmethod sb-pcl::same-specializer-p
+ ((s1 prototype-specializer) (s2 prototype-specializer))
+ (eql (prototype-specializer-object s1)
+ (prototype-specializer-object s2)))
+(defclass prototype-generic-function (specializable-generic-function)
+ ()
+ (:metaclass sb-mop:funcallable-standard-class))
+(defmethod sb-pcl:make-method-specializers-form
+ ((gf prototype-generic-function) method snames env)
+ (flet ((frob (x)
+ (typecase x
+ (sb-mop:specializer x)
+ (symbol `(make-instance 'prototype-specializer :object ,x))
+ ((cons (eql 'class)) `(find-class ',(cadr x)))
+ ((cons (eql 'eql)) `(sb-mop:intern-eql-specializer ,(cadr x)))
+ (t (error "unexpected specializer name: ~S" x)))))
+ `(list ,@(mapcar #'frob snames))))
+(defmethod sb-pcl:parse-specializer-using-class
+ ((gf prototype-generic-function) name)
+ (make-instance 'prototype-specializer :object name))
+(defmethod sb-pcl:unparse-specializer-using-class
+ ((gf prototype-generic-function) (s prototype-specializer))
+ (let ((object (prototype-specializer-object s)))
+ (if (slot-boundp object 'name)
+ (slot-value object 'name)
+ s)))
+
+(defmethod add-method :after ((gf prototype-generic-function) m)
+ (let ((ss (sb-mop:method-specializers m)))
+ (do* ((i 0 (1+ i))
+ (ss ss (cdr ss))
+ (s (car ss) (car ss)))
+ ((null ss))
+ (when (typep s 'prototype-specializer)
+ (let ((object (prototype-specializer-object s))
+ (role (make-role m i)))
+ (setf (prototype-specializer-role s) role)
+ (add-role object role))))))
+(defmethod remove-method :after ((gf prototype-generic-function) m)
+ (let ((ss (sb-mop:method-specializers m)))
+ (do* ((i 0 (1+ i))
+ (ss ss (cdr ss))
+ (s (car ss) (car ss)))
+ ((null ss))
+ (when (typep s 'prototype-specializer)
+ (let ((object (prototype-specializer-object s))
+ (role (make-role m i)))
+ (setf (prototype-specializer-role s) nil)
+ ;; this is one of the places where the semantics
+ ;; are... dodgy. Removing the method from the generic
+ ;; function, and the role from the object, doesn't affect
+ ;; the roles in any clones. We could potentially use the
+ ;; fact that once removed the method is no longer associated
+ ;; with a generic function? Hm, C-A-M will not consider the
+ ;; removed method for applicability...
+ (remove-role object role))))))
+
+(defmethod generalizer-of-using-class
+ ((gf prototype-generic-function) (object prototype-object))
+ object)
+
+(defmethod specializer-accepts-generalizer-p
+ ((gf prototype-generic-function) (s prototype-specializer) object)
+ (values (specializer-accepts-p s object) t))
+
+(defmethod specializer-accepts-p ((specializer prototype-specializer) object)
+ (cond
+ ((not (typep object 'prototype-object)) nil)
+ ((eql (prototype-specializer-object specializer) /root/) t)
+ (t
+ (let ((role (prototype-specializer-role specializer)))
+ (map-delegations
+ (lambda (o)
+ (when (find-role role o)
+ (return-from specializer-accepts-p t)))
+ object)))))
+
+(defmethod specializer< ((gf prototype-generic-function) (s1 prototype-specializer) (s2 prototype-specializer) g)
+ (let ((o1 (prototype-specializer-object s1))
+ (o2 (prototype-specializer-object s2)))
+ (map-delegations
+ (lambda (o)
+ (cond
+ ((eql o o1) (return-from specializer< '<))
+ ((eql o o2) (return-from specializer< '>))))
+ g)
+ '=))
+
+(defmethod compute-applicable-methods-using-generalizers ((gf prototype-generic-function) generalizers)
+ (values nil nil))
+(defmethod generalizer-equal-hash-key ((gf prototype-generic-function) (g prototype-object))
+ g)
+
+(defmacro defpvar (name value)
+ `(let ((val ,value))
+ (setf (slot-value val 'name) ',name)
+ (defparameter ,name val)))
+
+(defpvar /root/ (make-instance 'prototype-object :delegations nil))
+(defpvar /animal/ (clone /root/))
+(defpvar /fish/ (clone /root/))
+(defpvar /shark/ (clone /root/))
+(defpvar /healthy-shark/ (clone /root/))
+(defpvar /dying-shark/ (clone /root/))
+(add-delegation /fish/ /animal/)
+(add-delegation /shark/ /animal/)
+(add-delegation /shark/ /healthy-shark/)
+(defgeneric encounter (x y)
+ (:generic-function-class prototype-generic-function))
+(defmethod encounter ((x /fish/) (y /healthy-shark/))
+ (format t "~&~A swims away~%" x))
+(defmethod encounter ((x /fish/) (y /animal/))
+ x)
+(defgeneric fight (x y)
+ (:generic-function-class prototype-generic-function))
+(defmethod fight ((x /healthy-shark/) (y /shark/))
+ (remove-delegation x)
+ (add-delegation x /dying-shark/)
+ x)
+(defmethod encounter ((x /healthy-shark/) (y /fish/))
+ (format t "~&~A swallows ~A~%" x y))
+(defmethod encounter ((x /healthy-shark/) (y /shark/))
+ (format t "~&~A fights ~A~%" x y)
+ (fight x y))
--- /dev/null
+(in-package "SPECIALIZABLE")
+
+;;;; SIGNUM-SPECIALIZER example
+(defclass signum-specializer (extended-specializer)
+ ((signum :initarg :signum :reader %signum)))
+(defclass signum-generic-function (specializable-generic-function)
+ ()
+ (:metaclass sb-mop:funcallable-standard-class))
+
+(define-extended-specializer signum (gf signum)
+ (make-instance 'signum-specializer :signum signum))
+(defmethod sb-pcl:unparse-specializer-using-class
+ ((gf signum-generic-function) (specializer signum-specializer))
+ `(signum ,(%signum specializer)))
+(defmethod sb-pcl::same-specializer-p
+ ((s1 signum-specializer) (s2 signum-specializer))
+ (= (%signum s1) (%signum s2)))
+
+(defmethod generalizer-equal-hash-key ((gf signum-generic-function) (g signum-specializer))
+ (%signum g))
+(defmethod generalizer-of-using-class ((gf signum-generic-function) arg)
+ (typecase arg
+ (real (make-instance 'signum-specializer :signum (signum arg)))
+ (t (call-next-method))))
+(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer signum-specializer) (thing signum-specializer))
+ (if (= (%signum specializer) (%signum thing))
+ (values t t)
+ (values nil t)))
+(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer sb-mop:specializer) (thing signum-specializer))
+ (specializer-accepts-generalizer-p gf specializer (class-of (%signum thing))))
+
+;;; note: this method operates in full knowledge of the object, and so
+;;; does not require the generic function as an argument.
+(defmethod specializer-accepts-p ((specializer signum-specializer) obj)
+ (and (realp obj)
+ (= (signum obj) (%signum specializer))))
+
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 signum-specializer) generalizer)
+ (declare (ignore generalizer))
+ (if (= (%signum s1) (%signum s2))
+ '=
+ nil))
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 class) generalizer)
+ (declare (ignore generalizer))
+ '<)
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 sb-mop:eql-specializer) generalizer)
+ (declare (ignore generalizer))
+ '>)
+(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 signum-specializer) generalizer)
+ (ecase (specializer< gf s2 s1 generalizer)
+ ((<) '>)
+ ((>) '<)))
+;;; note: the need for this method is tricky: we need to translate
+;;; from generalizers that our specializers "know" about to those that
+;;; ordinary generic functions and specializers might know about.
+(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer signum-specializer))
+ (specializer< gf s1 s2 (class-of (%signum generalizer))))
+\f
+;;; tests / examples
+(eval
+ '(progn
+ (defgeneric fact (n) (:generic-function-class signum-generic-function))
+ (defmethod fact ((n (signum 0))) 1)
+ (defmethod fact ((n (signum 1))) (* n (fact (1- n))))
+ (assert (eql (fact 6) 720))
+ (assert (eql (fact 6.0) 720.0))
+ (defmethod no-applicable-method ((gf (eql #'fact)) &rest args)
+ 'gotcha)
+ (assert (eql (fact -6) 'gotcha))))
+
+(eval
+ '(progn
+ (defgeneric signum-class-specializers (x)
+ (:generic-function-class signum-generic-function)
+ (:method-combination list))
+ (defmethod signum-class-specializers list ((x float)) 'float)
+ (defmethod signum-class-specializers list ((x integer)) 'integer)
+ (defmethod signum-class-specializers list ((x (signum 1))) 1)
+ (assert (equal (signum-class-specializers 1.0) '(1 float)))
+ (assert (equal (signum-class-specializers 1) '(1 integer)))
+ (assert (equal (signum-class-specializers -1.0) '(float)))
+ (assert (equal (signum-class-specializers -1) '(integer)))))
--- /dev/null
+(in-package "SPECIALIZABLE")
+
+(defclass binding ()
+ ((used :initform nil :accessor used)))
+
+(defun make-env (bindings env)
+ (append bindings env))
+(defun find-binding (env var)
+ (cdr (assoc var env)))
+
+(defun bindings-from-ll (ll)
+ (mapcar (lambda (n) (cons n (make-instance 'binding))) ll))
+
+(define-condition walker-warning (warning)
+ ((env :initarg :env :reader env)
+ (call-stack :initarg :call-stack :reader call-stack)))
+(define-condition unused-variable (walker-warning)
+ ((name :initarg :name :reader name)))
+(define-condition unbound-variable-referenced (walker-warning)
+ ((name :initarg :name :reader name)))
+
+(fmakunbound 'walk)
+(defgeneric walk (form env vars)
+ (:generic-function-class cons-generic-function))
+
+(defmethod walk ((expr cons) env call-stack)
+ (let ((cs (cons expr call-stack)))
+ (when (consp (car expr))
+ (walk (car expr) env cs))
+ (dolist (e (cdr expr))
+ (walk e env (cons e cs)))))
+(defmethod walk ((expr symbol) env call-stack)
+ (if (constantp expr)
+ nil
+ (let ((binding (find-binding env expr)))
+ (if binding
+ (setf (used binding) t)
+ (warn 'unbound-variable-referenced :name expr
+ :env env :call-stack call-stack)))))
+(defmethod walk ((expr t) env call-stack)
+ nil)
+(defmacro with-checked-bindings ((bindings env call-stack) &body body)
+ `(let* ((bindings ,bindings)
+ (,env (make-env bindings ,env)))
+ ,@body
+ (dolist (binding bindings)
+ (unless (used (cdr binding))
+ (warn 'unused-variable :name (car binding)
+ :env ,env :call-stack ,call-stack)))))
+(defmethod walk ((expr (cons lambda)) env call-stack)
+ (let ((lambda-list (cadr expr))
+ (body (cddr expr)))
+ (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+ (dolist (form body)
+ (walk form env (cons form call-stack))))))
+(defmethod walk ((expr (cons multiple-value-bind)) env call-stack)
+ (let ((lambda-list (cadr expr))
+ (value-form (caddr expr))
+ (body (cdddr expr)))
+ (walk value-form env (cons value-form call-stack))
+ (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+ (dolist (form body)
+ (walk form env (cons form call-stack))))))
+(defmethod walk ((expr (cons let)) env call-stack)
+ (flet ((let-binding (x)
+ (walk (cadr x) env (cons (cadr x) call-stack))
+ (cons (car x) (make-instance 'binding))))
+ (with-checked-bindings ((mapcar #'let-binding (cadr expr)) env call-stack)
+ (dolist (form (cddr expr))
+ (walk form env (cons form call-stack))))))
+
+(defun walk/case (expr env call-stack)
+ (typecase expr
+ (symbol
+ (if (constantp expr)
+ nil
+ (let ((binding (find-binding env expr)))
+ (if binding
+ (setf (used binding) t)
+ (warn 'unbound-variable-referenced :name expr
+ :env env :call-stack call-stack)))))
+ ((cons (eql lambda))
+ (let ((lambda-list (cadr expr))
+ (body (cddr expr)))
+ (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+ (dolist (form body)
+ (walk/case form env (cons form call-stack))))))
+ ((cons (eql multiple-value-bind))
+ (let ((lambda-list (cadr expr))
+ (value-form (caddr expr))
+ (body (cdddr expr)))
+ (walk/case value-form env (cons value-form call-stack))
+ (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+ (dolist (form body)
+ (walk/case form env (cons form call-stack))))))
+ ((cons (eql macrolet)))
+ ((cons (eql flet)))
+ ((cons (eql labels)))
+ ((cons (eql symbol-macrolet)))
+ ((cons (eql if)))
+ ((cons (eql progn)))
+ ((cons (eql tagbody)))
+ ((cons (eql return-from)))
+ ((cons (eql multiple-value-call)))
+ ((cons (eql block)))
+ ((cons (eql catch)))
+ ((cons (eql throw)))
+ ((cons (eql let))
+ (with-checked-bindings ((mapcar (lambda (x) (walk/case (cadr x) env (cons (cadr x) call-stack)) (cons (car x) (make-instance 'binding))) (cadr expr)) env call-stack)
+ (dolist (form (cddr expr))
+ (walk/case form env (cons form call-stack)))))
+ (cons
+ (let ((cs (cons expr call-stack)))
+ (when (consp (car expr))
+ (walk/case (car expr) env cs))
+ (dolist (e (cdr expr))
+ (walk/case e env (cons e cs)))))
+ (t)))
+
+(defgeneric walk/meth (expr env call-stack))
+
+(defmethod walk/meth ((expr symbol) env call-stack)
+ (if (constantp expr)
+ nil
+ (let ((binding (find-binding env expr)))
+ (if binding
+ (setf (used binding) t)
+ (warn 'unbound-variable-referenced :name expr
+ :env env :call-stack call-stack)))))
+(defmethod walk/meth ((expr t) env call-stack)
+ nil)
+
+(defmethod walk/meth ((expr cons) env call-stack)
+ (typecase expr
+ ((cons (eql lambda))
+ (let ((lambda-list (cadr expr))
+ (body (cddr expr)))
+ (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+ (dolist (form body)
+ (walk/meth form env (cons form call-stack))))))
+ ((cons (eql multiple-value-bind))
+ (let ((lambda-list (cadr expr))
+ (value-form (caddr expr))
+ (body (cdddr expr)))
+ (walk/meth value-form env (cons value-form call-stack))
+ (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+ (dolist (form body)
+ (walk/meth form env (cons form call-stack))))))
+ ((cons (eql macrolet)))
+ ((cons (eql flet)))
+ ((cons (eql labels)))
+ ((cons (eql symbol-macrolet)))
+ ((cons (eql if)))
+ ((cons (eql progn)))
+ ((cons (eql tagbody)))
+ ((cons (eql return-from)))
+ ((cons (eql multiple-value-call)))
+ ((cons (eql block)))
+ ((cons (eql catch)))
+ ((cons (eql throw)))
+ ((cons (eql let))
+ (with-checked-bindings ((mapcar (lambda (x) (walk/meth (cadr x) env (cons (cadr x) call-stack)) (cons (car x) (make-instance 'binding))) (cadr expr)) env call-stack)
+ (dolist (form (cddr expr))
+ (walk/meth form env (cons form call-stack)))))
+ (t
+ (let ((cs (cons expr call-stack)))
+ (when (consp (car expr))
+ (walk/meth (car expr) env cs))
+ (dolist (e (cdr expr))
+ (walk/meth e env (cons e cs)))))))
+++ /dev/null
-(in-package "SPECIALIZABLE")
-
-(defclass prototype-object ()
- (;; FIXME: we should add slots at some point
- (delegations :initarg :delegations :accessor delegations)
- (roles :initform (make-array 0 :adjustable t :fill-pointer t)
- :accessor roles)
- ;; debugging aid
- (name)))
-(defmethod print-object ((o prototype-object) s)
- (if (slot-boundp o 'name)
- (format s "~S" (slot-value o 'name))
- (print-unreadable-object (o s :type t :identity t)
- (format s "[~{~S~^, ~}]" (delegations o)))))
-(defun add-delegation (obj del)
- (push del (delegations obj)))
-(defun remove-delegation (obj)
- (pop (delegations obj)))
-(defun map-delegations (fun obj)
- (funcall fun obj)
- ;; FIXME: should we maintain a table of visited nodes? Should it be
- ;; topologically sorted? Section 5.3 in PwMD [Salzman & Aldrich]
- ;; suggests not, at least for now
- (mapc (lambda (o) (map-delegations fun o)) (delegations obj))
- nil)
-(defstruct (role (:type list) (:constructor make-role (method argpos)))
- method argpos)
-(defun add-role (obj role)
- (let ((pos (role-argpos role))
- (roles (roles obj)))
- (unless (< pos (length roles))
- (dotimes (i (- (1+ pos) (length roles)))
- (vector-push-extend nil roles)))
- (pushnew (role-method role) (aref roles pos))))
-(defun remove-role (obj role)
- (let ((pos (role-argpos role)))
- (setf (aref (roles obj) pos)
- (remove (role-method role) (aref (roles obj) pos)))
- (tagbody
- start
- (when (or (= (length (roles obj)) 0)
- (aref (roles obj) (1- (length (roles obj)))))
- (go done))
- (vector-pop (roles obj))
- (go start)
- done)))
-(defun map-roles (fun obj)
- (dotimes (i (length (roles obj)))
- (dolist (m (aref (roles obj) i))
- (funcall fun (make-role m i)))))
-(defun find-role (role obj)
- (when (< (role-argpos role) (length (roles obj)))
- (find (role-method role) (aref (roles obj) (role-argpos role)))))
-(defmacro do-roles ((rvar form &optional result) &body body)
- `(progn (map-roles (lambda (,rvar) ,@body) ,form) ,result))
-(defun clone (p)
- (let ((result (make-instance 'prototype-object
- :delegations (copy-list (delegations p)))))
- (do-roles (r p result)
- (add-role result r))))
-
-;;; redefinition semantics are interesting. We need the INFO here so
-;;; that we can implement specializer-accepts-p, which must be able to
-;;; lookup the particular method/argpos that the specializer
-;;; represents. But we must also be able to redefine methods in a way
-;;; that isn't insane, which I think implies that same-specializer-p
-;;; should ignore the INFO and just use the OBJECT.
-(defclass prototype-specializer (extended-specializer)
- ((role :accessor prototype-specializer-role)
- (object :initarg :object :accessor prototype-specializer-object)))
-(defmethod print-object ((o prototype-specializer) s)
- (print-unreadable-object (o s :type t :identity t)
- (format s "~S" (prototype-specializer-object o))))
-(defmethod sb-pcl::same-specializer-p
- ((s1 prototype-specializer) (s2 prototype-specializer))
- (eql (prototype-specializer-object s1)
- (prototype-specializer-object s2)))
-(defclass prototype-generic-function (specializable-generic-function)
- ()
- (:metaclass sb-mop:funcallable-standard-class))
-(defmethod sb-pcl:make-method-specializers-form
- ((gf prototype-generic-function) method snames env)
- (flet ((frob (x)
- (typecase x
- (sb-mop:specializer x)
- (symbol `(make-instance 'prototype-specializer :object ,x))
- ((cons (eql 'class)) `(find-class ',(cadr x)))
- ((cons (eql 'eql)) `(sb-mop:intern-eql-specializer ,(cadr x)))
- (t (error "unexpected specializer name: ~S" x)))))
- `(list ,@(mapcar #'frob snames))))
-(defmethod sb-pcl:parse-specializer-using-class
- ((gf prototype-generic-function) name)
- (make-instance 'prototype-specializer :object name))
-(defmethod sb-pcl:unparse-specializer-using-class
- ((gf prototype-generic-function) (s prototype-specializer))
- (let ((object (prototype-specializer-object s)))
- (if (slot-boundp object 'name)
- (slot-value object 'name)
- s)))
-
-(defmethod add-method :after ((gf prototype-generic-function) m)
- (let ((ss (sb-mop:method-specializers m)))
- (do* ((i 0 (1+ i))
- (ss ss (cdr ss))
- (s (car ss) (car ss)))
- ((null ss))
- (when (typep s 'prototype-specializer)
- (let ((object (prototype-specializer-object s))
- (role (make-role m i)))
- (setf (prototype-specializer-role s) role)
- (add-role object role))))))
-(defmethod remove-method :after ((gf prototype-generic-function) m)
- (let ((ss (sb-mop:method-specializers m)))
- (do* ((i 0 (1+ i))
- (ss ss (cdr ss))
- (s (car ss) (car ss)))
- ((null ss))
- (when (typep s 'prototype-specializer)
- (let ((object (prototype-specializer-object s))
- (role (make-role m i)))
- (setf (prototype-specializer-role s) nil)
- ;; this is one of the places where the semantics
- ;; are... dodgy. Removing the method from the generic
- ;; function, and the role from the object, doesn't affect
- ;; the roles in any clones. We could potentially use the
- ;; fact that once removed the method is no longer associated
- ;; with a generic function? Hm, C-A-M will not consider the
- ;; removed method for applicability...
- (remove-role object role))))))
-
-(defmethod generalizer-of-using-class
- ((gf prototype-generic-function) (object prototype-object))
- object)
-
-(defmethod specializer-accepts-generalizer-p
- ((gf prototype-generic-function) (s prototype-specializer) object)
- (values (specializer-accepts-p s object) t))
-
-(defmethod specializer-accepts-p ((specializer prototype-specializer) object)
- (cond
- ((not (typep object 'prototype-object)) nil)
- ((eql (prototype-specializer-object specializer) /root/) t)
- (t
- (let ((role (prototype-specializer-role specializer)))
- (map-delegations
- (lambda (o)
- (when (find-role role o)
- (return-from specializer-accepts-p t)))
- object)))))
-
-(defmethod specializer< ((gf prototype-generic-function) (s1 prototype-specializer) (s2 prototype-specializer) g)
- (let ((o1 (prototype-specializer-object s1))
- (o2 (prototype-specializer-object s2)))
- (map-delegations
- (lambda (o)
- (cond
- ((eql o o1) (return-from specializer< '<))
- ((eql o o2) (return-from specializer< '>))))
- g)
- '=))
-
-(defmethod compute-applicable-methods-using-generalizers ((gf prototype-generic-function) generalizers)
- (values nil nil))
-(defmethod generalizer-equal-hash-key ((gf prototype-generic-function) (g prototype-object))
- g)
-
-(defmacro defpvar (name value)
- `(let ((val ,value))
- (setf (slot-value val 'name) ',name)
- (defparameter ,name val)))
-
-(defpvar /root/ (make-instance 'prototype-object :delegations nil))
-(defpvar /animal/ (clone /root/))
-(defpvar /fish/ (clone /root/))
-(defpvar /shark/ (clone /root/))
-(defpvar /healthy-shark/ (clone /root/))
-(defpvar /dying-shark/ (clone /root/))
-(add-delegation /fish/ /animal/)
-(add-delegation /shark/ /animal/)
-(add-delegation /shark/ /healthy-shark/)
-(defgeneric encounter (x y)
- (:generic-function-class prototype-generic-function))
-(defmethod encounter ((x /fish/) (y /healthy-shark/))
- (format t "~&~A swims away~%" x))
-(defmethod encounter ((x /fish/) (y /animal/))
- x)
-(defgeneric fight (x y)
- (:generic-function-class prototype-generic-function))
-(defmethod fight ((x /healthy-shark/) (y /shark/))
- (remove-delegation x)
- (add-delegation x /dying-shark/)
- x)
-(defmethod encounter ((x /healthy-shark/) (y /fish/))
- (format t "~&~A swallows ~A~%" x y))
-(defmethod encounter ((x /healthy-shark/) (y /shark/))
- (format t "~&~A fights ~A~%" x y)
- (fight x y))
+++ /dev/null
-(in-package "SPECIALIZABLE")
-
-;;;; SIGNUM-SPECIALIZER example
-(defclass signum-specializer (extended-specializer)
- ((signum :initarg :signum :reader %signum)))
-(defclass signum-generic-function (specializable-generic-function)
- ()
- (:metaclass sb-mop:funcallable-standard-class))
-
-(define-extended-specializer signum (gf signum)
- (make-instance 'signum-specializer :signum signum))
-(defmethod sb-pcl:unparse-specializer-using-class
- ((gf signum-generic-function) (specializer signum-specializer))
- `(signum ,(%signum specializer)))
-(defmethod sb-pcl::same-specializer-p
- ((s1 signum-specializer) (s2 signum-specializer))
- (= (%signum s1) (%signum s2)))
-
-(defmethod generalizer-equal-hash-key ((gf signum-generic-function) (g signum-specializer))
- (%signum g))
-(defmethod generalizer-of-using-class ((gf signum-generic-function) arg)
- (typecase arg
- (real (make-instance 'signum-specializer :signum (signum arg)))
- (t (call-next-method))))
-(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer signum-specializer) (thing signum-specializer))
- (if (= (%signum specializer) (%signum thing))
- (values t t)
- (values nil t)))
-(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer sb-mop:specializer) (thing signum-specializer))
- (specializer-accepts-generalizer-p gf specializer (class-of (%signum thing))))
-
-;;; note: this method operates in full knowledge of the object, and so
-;;; does not require the generic function as an argument.
-(defmethod specializer-accepts-p ((specializer signum-specializer) obj)
- (and (realp obj)
- (= (signum obj) (%signum specializer))))
-
-(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 signum-specializer) generalizer)
- (declare (ignore generalizer))
- (if (= (%signum s1) (%signum s2))
- '=
- nil))
-(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 class) generalizer)
- (declare (ignore generalizer))
- '<)
-(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 sb-mop:eql-specializer) generalizer)
- (declare (ignore generalizer))
- '>)
-(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 signum-specializer) generalizer)
- (ecase (specializer< gf s2 s1 generalizer)
- ((<) '>)
- ((>) '<)))
-;;; note: the need for this method is tricky: we need to translate
-;;; from generalizers that our specializers "know" about to those that
-;;; ordinary generic functions and specializers might know about.
-(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer signum-specializer))
- (specializer< gf s1 s2 (class-of (%signum generalizer))))
-\f
-;;; tests / examples
-(eval
- '(progn
- (defgeneric fact (n) (:generic-function-class signum-generic-function))
- (defmethod fact ((n (signum 0))) 1)
- (defmethod fact ((n (signum 1))) (* n (fact (1- n))))
- (assert (eql (fact 6) 720))
- (assert (eql (fact 6.0) 720.0))
- (defmethod no-applicable-method ((gf (eql #'fact)) &rest args)
- 'gotcha)
- (assert (eql (fact -6) 'gotcha))))
-
-(eval
- '(progn
- (defgeneric signum-class-specializers (x)
- (:generic-function-class signum-generic-function)
- (:method-combination list))
- (defmethod signum-class-specializers list ((x float)) 'float)
- (defmethod signum-class-specializers list ((x integer)) 'integer)
- (defmethod signum-class-specializers list ((x (signum 1))) 1)
- (assert (equal (signum-class-specializers 1.0) '(1 float)))
- (assert (equal (signum-class-specializers 1) '(1 integer)))
- (assert (equal (signum-class-specializers -1.0) '(float)))
- (assert (equal (signum-class-specializers -1) '(integer)))))
:author "Jan Moringen <jmoringe@techfak.uni-bielefeld.de>"
:license "TODO"
:description "Generalized specializers - SBCL only"
- :components ((:file "specializable")))
+ :components ((:module "src"
+ :components ((:file "specializable")))))
+++ /dev/null
-;;; written by David Lichteblau, based on code by Christophe Rhodes,
-;;; Closette, and SBCL
-;;;
-;;; http://www.lichteblau.com/git/?p=specializable.git;a=blob_plain;f=specializable.lisp;hb=eb30d235951c3c1d128811278760f1db36cd336c
-
-(defpackage "SPECIALIZABLE"
- (:use "CL" "SB-EXT")
- (:export "SPECIALIZABLE-GENERIC-FUNCTION" "SPECIALIZABLE-METHOD"
- "EXTENDED-SPECIALIZER"
-
- "SPECIALIZER-ACCEPTS-P" "SPECIALIZER-ACCEPTS-GENERALIZER-P"
- "SPECIALIZER<"
-
- "GENERALIZER-OF-USING-CLASS"
- "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
- "GENERALIZER-EQUAL-HASH-KEY"
-
- "DEFINE-EXTENDED-SPECIALIZER"))
-
-(in-package "SPECIALIZABLE")
-
-(defclass extended-specializer (sb-mop:specializer)
- ;; FIXME: this doesn't actually do quite what I wanted.
- ((direct-methods-table :allocation :class
- :initform nil :accessor direct-methods-table)))
-
-(defmethod sb-mop:add-direct-method ((specializer extended-specializer) method)
- (let* ((table (direct-methods-table specializer))
- (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
- (unless cell
- (setf cell (cons specializer nil))
- (push cell (direct-methods-table specializer)))
- (push method (cdr cell))))
-
-(defmethod sb-mop:remove-direct-method ((specializer extended-specializer) method)
- (let* ((table (direct-methods-table specializer))
- (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
- (setf (cdr cell) (remove method (cdr cell)))))
-
-(defmethod sb-mop:specializer-direct-methods ((specializer extended-specializer))
- (cdr (assoc specializer (direct-methods-table specializer)
- :test #'sb-pcl::same-specializer-p)))
-(defmethod sb-mop:specializer-direct-generic-functions ((specializer extended-specializer))
- (remove-duplicates (mapcar #'sb-mop:method-generic-function (sb-mop:specializer-direct-methods specializer))))
-
-(defclass specializable-generic-function (standard-generic-function)
- ((emf-table :initform (make-hash-table :test 'equal) :reader emf-table)
- (cacheingp :initform t :initarg :cacheingp)
- (single-arg-cacheing-p :initform t :initarg :single-arg-cacheing-p))
- (:metaclass sb-mop:funcallable-standard-class)
- (:default-initargs :method-class (find-class 'specializable-method)))
-
-;;; TODO: we don't use this class yet, but we might do later
-(defclass specializable-method (standard-method) ())
-
-;;; TODO use info?
-(defun extended-specializer-name-p (name)
- (and (symbolp name)
- (get name 'extended-specializer-parser)))
-
-(deftype extended-specializer-name ()
- `(satisfies extended-specializer-name-p))
-
-(defmacro define-extended-specializer (name (gf-var &rest args) &body body)
- ;; FIXME: unparser
- `(setf (get ',name 'extended-specializer-parser)
- (lambda (,gf-var ,@args)
- ,@body)))
-
-;; doesn't work, because we'd have to dump GF into the fasl for the macro
-;; expansion
-;;; (defun intern-extended-specializer (gf sname)
-;;; (destructuring-bind (kind &rest args) sname
-;;; (setf (gethash sname (generic-function-extended-specializers gf))
-;;; (apply (or (get kind 'extended-specializer-parser)
-;;; (error "not declared as an extended specializer name: ~A"
-;;; kind))
-;;; gf
-;;; args))))
-
-(defun make-extended-specializer (sname)
- (destructuring-bind (kind &rest args) sname
- (apply (or (get kind 'extended-specializer-parser)
- (error "not declared as an extended specializer name: ~A"
- kind))
- '|This is not a generic function| ;fixme, see comment above
- args)))
-
-;;; from SBCL:
-
-(defmethod sb-pcl:parse-specializer-using-class
- ((gf specializable-generic-function) (specializer-name t))
- (if (typep specializer-name '(cons extended-specializer-name))
- (make-extended-specializer specializer-name)
- (call-next-method)))
-
-(defmethod sb-pcl:make-method-specializers-form
- ((gf specializable-generic-function) method snames env)
- (declare (ignore method env))
- (flet ((parse (name)
- (cond
- ((typep name 'sb-mop:specializer) name)
- ((symbolp name) `(find-class ',name))
- ((consp name)
- (case (car name)
- (eql `(sb-mop:intern-eql-specializer ,(cadr name)))
- (t `(make-extended-specializer ',name))))
- (t (error "unexpected specializer name")))))
- `(list ,@(mapcar #'parse snames))))
-
-;;; from Closette, changed to use some SBCL functions:
-
-;;; FIXME: this is not actually sufficient argument checking
-(defun required-portion (gf args)
- (let ((number-required
- (sb-pcl::arg-info-number-required (sb-pcl::gf-arg-info gf))))
- (when (< (length args) number-required)
- (error "Too few arguments to generic function ~S." gf))
- (subseq args 0 number-required)))
-
-(defgeneric generalizer-equal-hash-key (generic-function generalizer))
-(defmethod generalizer-equal-hash-key
- ((gf specializable-generic-function) (g class))
- (sb-pcl::class-wrapper g))
-
-(defun first-arg-only-special-case (gf)
- (let ((arg-info (sb-pcl::gf-arg-info gf)))
- (and (slot-value gf 'single-arg-cacheing-p)
- (>= (sb-pcl::arg-info-number-required arg-info) 1)
- (every (lambda (x) (eql x t))
- (cdr (sb-pcl::arg-info-metatypes arg-info))))))
-
-;;; FIXME: in some kind of order, the discriminating function needs to handle:
-;;; - argument count checking;
-;;; - DONE (in effective method) keyword argument validity;
-;;; - DONE flushing the emf cache on method addition/removal
-;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
-;;; - cache thread-safety.
-;;; - speed
-;;; - DONE (in SBCL itself) interaction with TRACE et al.
-(defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
- (cond
- ((not (slot-value gf 'cacheingp))
- (lambda (&rest args)
- (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
- args)))
- (slow-method-lookup-and-call gf args generalizers))))
- ((first-arg-only-special-case gf)
- (lambda (&rest args)
- (let* ((g (generalizer-of-using-class gf (car args)))
- (k (generalizer-equal-hash-key gf g))
- (emfun (gethash k (emf-table gf) nil)))
- (if emfun
- (sb-pcl::invoke-emf emfun args)
- (slow-method-lookup-and-call
- gf args (cons g (mapcar (lambda (x) (generalizer-of-using-class gf x))
- (cdr (required-portion gf args)))))))))
- (t
- (lambda (&rest args)
- (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
- (required-portion gf args)))
- (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
- (emfun (gethash keys (emf-table gf) nil)))
- (if emfun
- (sb-pcl::invoke-emf emfun args)
- (slow-method-lookup-and-call gf args generalizers)))))))
-
-(defmethod reinitialize-instance :after ((gf specializable-generic-function) &key)
- (clrhash (emf-table gf)))
-
-(defun slow-method-lookup (gf args generalizers)
- (multiple-value-bind (applicable-methods definitivep)
- (compute-applicable-methods-using-generalizers gf generalizers)
- (unless definitivep
- (setf applicable-methods (compute-applicable-methods gf args)))
- (values (compute-effective-method-function gf applicable-methods)
- definitivep)))
-
-(defun slow-method-lookup-and-call (gf args generalizers)
- (multiple-value-bind (emf cacheablep)
- (slow-method-lookup gf args generalizers)
- (when cacheablep
- (let ((keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
- (if (first-arg-only-special-case gf)
- (setf (gethash (car keys) (emf-table gf)) emf)
- (setf (gethash keys (emf-table gf)) emf))))
- (sb-pcl::invoke-emf emf args)))
-
-(defun compute-effective-method-function (gf methods)
- (if (null methods)
- (lambda (&rest args) (apply #'no-applicable-method gf args))
- (let* ((mc (sb-mop:generic-function-method-combination gf))
- (sb-pcl::*applicable-methods* methods)
- (em (sb-mop:compute-effective-method gf mc methods)))
- (sb-pcl::make-effective-method-function gf em))))
-
-;; new, not in closette
-(defgeneric generalizer-of-using-class (generic-function object))
-(defmethod generalizer-of-using-class ((generic-function specializable-generic-function) object)
- (class-of object))
-
-(defgeneric specializer-accepts-generalizer-p (gf specializer generalizer))
-(defmethod specializer-accepts-generalizer-p
- ((gf specializable-generic-function) (specializer class) (generalizer class))
- (if (subtypep generalizer specializer)
- (values t t)
- (values nil t)))
-(defmethod specializer-accepts-generalizer-p
- ((gf specializable-generic-function) (specializer sb-mop:eql-specializer) (generalizer class))
- (if (eq generalizer (class-of (sb-mop:eql-specializer-object specializer)))
- (values t nil)
- (values nil t)))
-
-(defgeneric compute-applicable-methods-using-generalizers (gf generalizers))
-(defmethod compute-applicable-methods-using-generalizers
- ((gf specializable-generic-function) generalizers)
- ;; differs from closette
- (let ((result-definitive-p t))
- (flet ((filter (method)
- (every (lambda (s g)
- (multiple-value-bind (acceptsp definitivep)
- (specializer-accepts-generalizer-p gf s g)
- (unless definitivep
- (setf result-definitive-p nil))
- acceptsp))
- (sb-mop:method-specializers method) generalizers))
- (sorter (m1 m2)
- (method-more-specific-p gf m1 m2 generalizers)))
- (values
- (sort
- (copy-list (remove-if-not #'filter (sb-mop:generic-function-methods gf)))
- #'sorter)
- result-definitive-p))))
-
-;; new, not in closette
-(defgeneric specializer-accepts-p (specializer object))
-(defmethod specializer-accepts-p ((specializer class) object)
- (typep object specializer))
-(defmethod specializer-accepts-p ((specializer sb-mop:eql-specializer) object)
- (eq object (sb-mop:eql-specializer-object specializer)))
-
-(defmethod compute-applicable-methods
- ((gf specializable-generic-function) arguments)
- ;; new, not in closette
- (sort
- (copy-list
- (remove-if-not #'(lambda (method)
- (every #'specializer-accepts-p
- (sb-mop:method-specializers method)
- arguments))
- (sb-mop:generic-function-methods gf)))
- (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
- (required-portion gf arguments))))
- (lambda (m1 m2)
- (method-more-specific-p gf m1 m2 generalizers)))))
-
-(defun method-more-specific-p (gf method1 method2 generalizers)
- ;; FIXME: argument precedence order
- (block nil
- (mapc #'(lambda (spec1 spec2 generalizer)
- (ecase (specializer< gf spec1 spec2 generalizer)
- (< (return t))
- (=)
- ((nil > /=) (return nil))))
- (sb-mop:method-specializers method1)
- (sb-mop:method-specializers method2)
- generalizers)
- nil))
-
-;; new, not in closette
-(defgeneric specializer< (gf s1 s2 generalizer))
-(defmethod specializer<
- ((gf specializable-generic-function) (s1 class) (s2 class) (generalizer class))
- (if (eq s1 s2)
- '=
- (let ((cpl (sb-mop:class-precedence-list generalizer)))
- (if (find s2 (cdr (member s1 cpl)))
- '<
- '>))))
-(defmethod specializer<
- ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
- (declare (ignore generalizer))
- (if (eq (sb-mop:eql-specializer-object s1) (sb-mop:eql-specializer-object s2))
- '=
- nil))
-(defmethod specializer< ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 class) generalizer)
- (declare (ignore generalizer))
- '<)
-(defmethod specializer< ((gf specializable-generic-function) (c1 class) (c2 sb-mop:eql-specializer) generalizer)
- (declare (ignore generalizer))
- '>)
--- /dev/null
+;;; written by David Lichteblau, based on code by Christophe Rhodes,
+;;; Closette, and SBCL
+;;;
+;;; http://www.lichteblau.com/git/?p=specializable.git;a=blob_plain;f=specializable.lisp;hb=eb30d235951c3c1d128811278760f1db36cd336c
+
+(defpackage "SPECIALIZABLE"
+ (:use "CL" "SB-EXT")
+ (:export "SPECIALIZABLE-GENERIC-FUNCTION" "SPECIALIZABLE-METHOD"
+ "EXTENDED-SPECIALIZER"
+
+ "SPECIALIZER-ACCEPTS-P" "SPECIALIZER-ACCEPTS-GENERALIZER-P"
+ "SPECIALIZER<"
+
+ "GENERALIZER-OF-USING-CLASS"
+ "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
+ "GENERALIZER-EQUAL-HASH-KEY"
+
+ "DEFINE-EXTENDED-SPECIALIZER"))
+
+(in-package "SPECIALIZABLE")
+
+(defclass extended-specializer (sb-mop:specializer)
+ ;; FIXME: this doesn't actually do quite what I wanted.
+ ((direct-methods-table :allocation :class
+ :initform nil :accessor direct-methods-table)))
+
+(defmethod sb-mop:add-direct-method ((specializer extended-specializer) method)
+ (let* ((table (direct-methods-table specializer))
+ (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
+ (unless cell
+ (setf cell (cons specializer nil))
+ (push cell (direct-methods-table specializer)))
+ (push method (cdr cell))))
+
+(defmethod sb-mop:remove-direct-method ((specializer extended-specializer) method)
+ (let* ((table (direct-methods-table specializer))
+ (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
+ (setf (cdr cell) (remove method (cdr cell)))))
+
+(defmethod sb-mop:specializer-direct-methods ((specializer extended-specializer))
+ (cdr (assoc specializer (direct-methods-table specializer)
+ :test #'sb-pcl::same-specializer-p)))
+(defmethod sb-mop:specializer-direct-generic-functions ((specializer extended-specializer))
+ (remove-duplicates (mapcar #'sb-mop:method-generic-function (sb-mop:specializer-direct-methods specializer))))
+
+(defclass specializable-generic-function (standard-generic-function)
+ ((emf-table :initform (make-hash-table :test 'equal) :reader emf-table)
+ (cacheingp :initform t :initarg :cacheingp)
+ (single-arg-cacheing-p :initform t :initarg :single-arg-cacheing-p))
+ (:metaclass sb-mop:funcallable-standard-class)
+ (:default-initargs :method-class (find-class 'specializable-method)))
+
+;;; TODO: we don't use this class yet, but we might do later
+(defclass specializable-method (standard-method) ())
+
+;;; TODO use info?
+(defun extended-specializer-name-p (name)
+ (and (symbolp name)
+ (get name 'extended-specializer-parser)))
+
+(deftype extended-specializer-name ()
+ `(satisfies extended-specializer-name-p))
+
+(defmacro define-extended-specializer (name (gf-var &rest args) &body body)
+ ;; FIXME: unparser
+ `(setf (get ',name 'extended-specializer-parser)
+ (lambda (,gf-var ,@args)
+ ,@body)))
+
+;; doesn't work, because we'd have to dump GF into the fasl for the macro
+;; expansion
+;;; (defun intern-extended-specializer (gf sname)
+;;; (destructuring-bind (kind &rest args) sname
+;;; (setf (gethash sname (generic-function-extended-specializers gf))
+;;; (apply (or (get kind 'extended-specializer-parser)
+;;; (error "not declared as an extended specializer name: ~A"
+;;; kind))
+;;; gf
+;;; args))))
+
+(defun make-extended-specializer (sname)
+ (destructuring-bind (kind &rest args) sname
+ (apply (or (get kind 'extended-specializer-parser)
+ (error "not declared as an extended specializer name: ~A"
+ kind))
+ '|This is not a generic function| ;fixme, see comment above
+ args)))
+
+;;; from SBCL:
+
+(defmethod sb-pcl:parse-specializer-using-class
+ ((gf specializable-generic-function) (specializer-name t))
+ (if (typep specializer-name '(cons extended-specializer-name))
+ (make-extended-specializer specializer-name)
+ (call-next-method)))
+
+(defmethod sb-pcl:make-method-specializers-form
+ ((gf specializable-generic-function) method snames env)
+ (declare (ignore method env))
+ (flet ((parse (name)
+ (cond
+ ((typep name 'sb-mop:specializer) name)
+ ((symbolp name) `(find-class ',name))
+ ((consp name)
+ (case (car name)
+ (eql `(sb-mop:intern-eql-specializer ,(cadr name)))
+ (t `(make-extended-specializer ',name))))
+ (t (error "unexpected specializer name")))))
+ `(list ,@(mapcar #'parse snames))))
+
+;;; from Closette, changed to use some SBCL functions:
+
+;;; FIXME: this is not actually sufficient argument checking
+(defun required-portion (gf args)
+ (let ((number-required
+ (sb-pcl::arg-info-number-required (sb-pcl::gf-arg-info gf))))
+ (when (< (length args) number-required)
+ (error "Too few arguments to generic function ~S." gf))
+ (subseq args 0 number-required)))
+
+(defgeneric generalizer-equal-hash-key (generic-function generalizer))
+(defmethod generalizer-equal-hash-key
+ ((gf specializable-generic-function) (g class))
+ (sb-pcl::class-wrapper g))
+
+(defun first-arg-only-special-case (gf)
+ (let ((arg-info (sb-pcl::gf-arg-info gf)))
+ (and (slot-value gf 'single-arg-cacheing-p)
+ (>= (sb-pcl::arg-info-number-required arg-info) 1)
+ (every (lambda (x) (eql x t))
+ (cdr (sb-pcl::arg-info-metatypes arg-info))))))
+
+;;; FIXME: in some kind of order, the discriminating function needs to handle:
+;;; - argument count checking;
+;;; - DONE (in effective method) keyword argument validity;
+;;; - DONE flushing the emf cache on method addition/removal
+;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
+;;; - cache thread-safety.
+;;; - speed
+;;; - DONE (in SBCL itself) interaction with TRACE et al.
+(defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
+ (cond
+ ((not (slot-value gf 'cacheingp))
+ (lambda (&rest args)
+ (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
+ args)))
+ (slow-method-lookup-and-call gf args generalizers))))
+ ((first-arg-only-special-case gf)
+ (lambda (&rest args)
+ (let* ((g (generalizer-of-using-class gf (car args)))
+ (k (generalizer-equal-hash-key gf g))
+ (emfun (gethash k (emf-table gf) nil)))
+ (if emfun
+ (sb-pcl::invoke-emf emfun args)
+ (slow-method-lookup-and-call
+ gf args (cons g (mapcar (lambda (x) (generalizer-of-using-class gf x))
+ (cdr (required-portion gf args)))))))))
+ (t
+ (lambda (&rest args)
+ (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
+ (required-portion gf args)))
+ (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
+ (emfun (gethash keys (emf-table gf) nil)))
+ (if emfun
+ (sb-pcl::invoke-emf emfun args)
+ (slow-method-lookup-and-call gf args generalizers)))))))
+
+(defmethod reinitialize-instance :after ((gf specializable-generic-function) &key)
+ (clrhash (emf-table gf)))
+
+(defun slow-method-lookup (gf args generalizers)
+ (multiple-value-bind (applicable-methods definitivep)
+ (compute-applicable-methods-using-generalizers gf generalizers)
+ (unless definitivep
+ (setf applicable-methods (compute-applicable-methods gf args)))
+ (values (compute-effective-method-function gf applicable-methods)
+ definitivep)))
+
+(defun slow-method-lookup-and-call (gf args generalizers)
+ (multiple-value-bind (emf cacheablep)
+ (slow-method-lookup gf args generalizers)
+ (when cacheablep
+ (let ((keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
+ (if (first-arg-only-special-case gf)
+ (setf (gethash (car keys) (emf-table gf)) emf)
+ (setf (gethash keys (emf-table gf)) emf))))
+ (sb-pcl::invoke-emf emf args)))
+
+(defun compute-effective-method-function (gf methods)
+ (if (null methods)
+ (lambda (&rest args) (apply #'no-applicable-method gf args))
+ (let* ((mc (sb-mop:generic-function-method-combination gf))
+ (sb-pcl::*applicable-methods* methods)
+ (em (sb-mop:compute-effective-method gf mc methods)))
+ (sb-pcl::make-effective-method-function gf em))))
+
+;; new, not in closette
+(defgeneric generalizer-of-using-class (generic-function object))
+(defmethod generalizer-of-using-class ((generic-function specializable-generic-function) object)
+ (class-of object))
+
+(defgeneric specializer-accepts-generalizer-p (gf specializer generalizer))
+(defmethod specializer-accepts-generalizer-p
+ ((gf specializable-generic-function) (specializer class) (generalizer class))
+ (if (subtypep generalizer specializer)
+ (values t t)
+ (values nil t)))
+(defmethod specializer-accepts-generalizer-p
+ ((gf specializable-generic-function) (specializer sb-mop:eql-specializer) (generalizer class))
+ (if (eq generalizer (class-of (sb-mop:eql-specializer-object specializer)))
+ (values t nil)
+ (values nil t)))
+
+(defgeneric compute-applicable-methods-using-generalizers (gf generalizers))
+(defmethod compute-applicable-methods-using-generalizers
+ ((gf specializable-generic-function) generalizers)
+ ;; differs from closette
+ (let ((result-definitive-p t))
+ (flet ((filter (method)
+ (every (lambda (s g)
+ (multiple-value-bind (acceptsp definitivep)
+ (specializer-accepts-generalizer-p gf s g)
+ (unless definitivep
+ (setf result-definitive-p nil))
+ acceptsp))
+ (sb-mop:method-specializers method) generalizers))
+ (sorter (m1 m2)
+ (method-more-specific-p gf m1 m2 generalizers)))
+ (values
+ (sort
+ (copy-list (remove-if-not #'filter (sb-mop:generic-function-methods gf)))
+ #'sorter)
+ result-definitive-p))))
+
+;; new, not in closette
+(defgeneric specializer-accepts-p (specializer object))
+(defmethod specializer-accepts-p ((specializer class) object)
+ (typep object specializer))
+(defmethod specializer-accepts-p ((specializer sb-mop:eql-specializer) object)
+ (eq object (sb-mop:eql-specializer-object specializer)))
+
+(defmethod compute-applicable-methods
+ ((gf specializable-generic-function) arguments)
+ ;; new, not in closette
+ (sort
+ (copy-list
+ (remove-if-not #'(lambda (method)
+ (every #'specializer-accepts-p
+ (sb-mop:method-specializers method)
+ arguments))
+ (sb-mop:generic-function-methods gf)))
+ (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
+ (required-portion gf arguments))))
+ (lambda (m1 m2)
+ (method-more-specific-p gf m1 m2 generalizers)))))
+
+(defun method-more-specific-p (gf method1 method2 generalizers)
+ ;; FIXME: argument precedence order
+ (block nil
+ (mapc #'(lambda (spec1 spec2 generalizer)
+ (ecase (specializer< gf spec1 spec2 generalizer)
+ (< (return t))
+ (=)
+ ((nil > /=) (return nil))))
+ (sb-mop:method-specializers method1)
+ (sb-mop:method-specializers method2)
+ generalizers)
+ nil))
+
+;; new, not in closette
+(defgeneric specializer< (gf s1 s2 generalizer))
+(defmethod specializer<
+ ((gf specializable-generic-function) (s1 class) (s2 class) (generalizer class))
+ (if (eq s1 s2)
+ '=
+ (let ((cpl (sb-mop:class-precedence-list generalizer)))
+ (if (find s2 (cdr (member s1 cpl)))
+ '<
+ '>))))
+(defmethod specializer<
+ ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
+ (declare (ignore generalizer))
+ (if (eq (sb-mop:eql-specializer-object s1) (sb-mop:eql-specializer-object s2))
+ '=
+ nil))
+(defmethod specializer< ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 class) generalizer)
+ (declare (ignore generalizer))
+ '<)
+(defmethod specializer< ((gf specializable-generic-function) (c1 class) (c2 sb-mop:eql-specializer) generalizer)
+ (declare (ignore generalizer))
+ '>)
+++ /dev/null
-(in-package "SPECIALIZABLE")
-
-(defclass binding ()
- ((used :initform nil :accessor used)))
-
-(defun make-env (bindings env)
- (append bindings env))
-(defun find-binding (env var)
- (cdr (assoc var env)))
-
-(defun bindings-from-ll (ll)
- (mapcar (lambda (n) (cons n (make-instance 'binding))) ll))
-
-(define-condition walker-warning (warning)
- ((env :initarg :env :reader env)
- (call-stack :initarg :call-stack :reader call-stack)))
-(define-condition unused-variable (walker-warning)
- ((name :initarg :name :reader name)))
-(define-condition unbound-variable-referenced (walker-warning)
- ((name :initarg :name :reader name)))
-
-(fmakunbound 'walk)
-(defgeneric walk (form env vars)
- (:generic-function-class cons-generic-function))
-
-(defmethod walk ((expr cons) env call-stack)
- (let ((cs (cons expr call-stack)))
- (when (consp (car expr))
- (walk (car expr) env cs))
- (dolist (e (cdr expr))
- (walk e env (cons e cs)))))
-(defmethod walk ((expr symbol) env call-stack)
- (if (constantp expr)
- nil
- (let ((binding (find-binding env expr)))
- (if binding
- (setf (used binding) t)
- (warn 'unbound-variable-referenced :name expr
- :env env :call-stack call-stack)))))
-(defmethod walk ((expr t) env call-stack)
- nil)
-(defmacro with-checked-bindings ((bindings env call-stack) &body body)
- `(let* ((bindings ,bindings)
- (,env (make-env bindings ,env)))
- ,@body
- (dolist (binding bindings)
- (unless (used (cdr binding))
- (warn 'unused-variable :name (car binding)
- :env ,env :call-stack ,call-stack)))))
-(defmethod walk ((expr (cons lambda)) env call-stack)
- (let ((lambda-list (cadr expr))
- (body (cddr expr)))
- (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
- (dolist (form body)
- (walk form env (cons form call-stack))))))
-(defmethod walk ((expr (cons multiple-value-bind)) env call-stack)
- (let ((lambda-list (cadr expr))
- (value-form (caddr expr))
- (body (cdddr expr)))
- (walk value-form env (cons value-form call-stack))
- (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
- (dolist (form body)
- (walk form env (cons form call-stack))))))
-(defmethod walk ((expr (cons let)) env call-stack)
- (flet ((let-binding (x)
- (walk (cadr x) env (cons (cadr x) call-stack))
- (cons (car x) (make-instance 'binding))))
- (with-checked-bindings ((mapcar #'let-binding (cadr expr)) env call-stack)
- (dolist (form (cddr expr))
- (walk form env (cons form call-stack))))))
-
-(defun walk/case (expr env call-stack)
- (typecase expr
- (symbol
- (if (constantp expr)
- nil
- (let ((binding (find-binding env expr)))
- (if binding
- (setf (used binding) t)
- (warn 'unbound-variable-referenced :name expr
- :env env :call-stack call-stack)))))
- ((cons (eql lambda))
- (let ((lambda-list (cadr expr))
- (body (cddr expr)))
- (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
- (dolist (form body)
- (walk/case form env (cons form call-stack))))))
- ((cons (eql multiple-value-bind))
- (let ((lambda-list (cadr expr))
- (value-form (caddr expr))
- (body (cdddr expr)))
- (walk/case value-form env (cons value-form call-stack))
- (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
- (dolist (form body)
- (walk/case form env (cons form call-stack))))))
- ((cons (eql macrolet)))
- ((cons (eql flet)))
- ((cons (eql labels)))
- ((cons (eql symbol-macrolet)))
- ((cons (eql if)))
- ((cons (eql progn)))
- ((cons (eql tagbody)))
- ((cons (eql return-from)))
- ((cons (eql multiple-value-call)))
- ((cons (eql block)))
- ((cons (eql catch)))
- ((cons (eql throw)))
- ((cons (eql let))
- (with-checked-bindings ((mapcar (lambda (x) (walk/case (cadr x) env (cons (cadr x) call-stack)) (cons (car x) (make-instance 'binding))) (cadr expr)) env call-stack)
- (dolist (form (cddr expr))
- (walk/case form env (cons form call-stack)))))
- (cons
- (let ((cs (cons expr call-stack)))
- (when (consp (car expr))
- (walk/case (car expr) env cs))
- (dolist (e (cdr expr))
- (walk/case e env (cons e cs)))))
- (t)))
-
-(defgeneric walk/meth (expr env call-stack))
-
-(defmethod walk/meth ((expr symbol) env call-stack)
- (if (constantp expr)
- nil
- (let ((binding (find-binding env expr)))
- (if binding
- (setf (used binding) t)
- (warn 'unbound-variable-referenced :name expr
- :env env :call-stack call-stack)))))
-(defmethod walk/meth ((expr t) env call-stack)
- nil)
-
-(defmethod walk/meth ((expr cons) env call-stack)
- (typecase expr
- ((cons (eql lambda))
- (let ((lambda-list (cadr expr))
- (body (cddr expr)))
- (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
- (dolist (form body)
- (walk/meth form env (cons form call-stack))))))
- ((cons (eql multiple-value-bind))
- (let ((lambda-list (cadr expr))
- (value-form (caddr expr))
- (body (cdddr expr)))
- (walk/meth value-form env (cons value-form call-stack))
- (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
- (dolist (form body)
- (walk/meth form env (cons form call-stack))))))
- ((cons (eql macrolet)))
- ((cons (eql flet)))
- ((cons (eql labels)))
- ((cons (eql symbol-macrolet)))
- ((cons (eql if)))
- ((cons (eql progn)))
- ((cons (eql tagbody)))
- ((cons (eql return-from)))
- ((cons (eql multiple-value-call)))
- ((cons (eql block)))
- ((cons (eql catch)))
- ((cons (eql throw)))
- ((cons (eql let))
- (with-checked-bindings ((mapcar (lambda (x) (walk/meth (cadr x) env (cons (cadr x) call-stack)) (cons (car x) (make-instance 'binding))) (cadr expr)) env call-stack)
- (dolist (form (cddr expr))
- (walk/meth form env (cons form call-stack)))))
- (t
- (let ((cs (cons expr call-stack)))
- (when (consp (car expr))
- (walk/meth (car expr) env cs))
- (dolist (e (cdr expr))
- (walk/meth e env (cons e cs)))))))
projects / specializable.git / commitdiff