X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=blobdiff_plain;f=specializable.lisp;fp=specializable.lisp;h=0000000000000000000000000000000000000000;hp=8d01319b1267e28a5da465263fbb8b4df27163c5;hb=9dd8f1378407cae8ec7b6b05a8b3c152bc4a5f9b;hpb=d55ebbbcbd77023c799d8d95dce5d3772aec5841 diff --git a/specializable.lisp b/specializable.lisp deleted file mode 100644 index 8d01319..0000000 --- a/specializable.lisp +++ /dev/null @@ -1,291 +0,0 @@ -;;; 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)) - '>)