diff options
Diffstat (limited to 'generic.lisp')
| -rw-r--r-- | generic.lisp | 124 |
1 files changed, 124 insertions, 0 deletions
diff --git a/generic.lisp b/generic.lisp new file mode 100644 index 0000000..d160527 --- /dev/null +++ b/generic.lisp @@ -0,0 +1,124 @@ +;;;; An implementation of a kind of generic function. This is not +;;;; terribly CLOSy, as it does not support inheritance. What we have +;;;; is a method selection routine that works on arbitrary types. +;;;; Some effort has been made to emulate CLOS's primary method +;;;; selection. + +(in-package :def) + +(defvar *genfuns* (make-hash-table :test #'eq) + "Mapping from symbol names to GENFUN instances.") + +(defclass genfun () + ((name + :reader genfun-name + :initarg :name + :type symbol) + (methods + :accessor genfun-methods + :type (or null cons) + :initform nil + :documentation + "A sorted association list, keyed by TYPE SPECIFIER, storing + S-EXPRESSIONS representing the method implementation for that + type. This list is sorted in topological order according the + natural order on the type keys.") + (lambda-list + :reader genfun-lambda-list + :initarg :lambda-list + :type (or null cons) + :documentation + "The lambda list for this generic function") + (docstring + :reader genfun-docstring + :initarg :docstring + :type (or null string)))) + +(defun type-specifier-p (thing) + (ignore-errors + (typep nil thing) + t)) + +(deftype lambda-list-option-term () + '(member cl:&rest cl:&aux cl:&optional cl:&key)) + +(defun expand-generic-function-def (generic) + (let ((vars + (method-sig-vars (genfun-lambda-list generic))) + (types + (gensym "TYPES-"))) + `(defun ,(genfun-name generic) ,(genfun-lambda-list generic) + ,(genfun-docstring generic) + (let ((,types (mapcar #'type-of (list ,@vars)))) + (cond + ,@(loop :for (signature . body) :in (genfun-methods generic) + :collect `((every #'subtypep ,types ',signature) ,@body) :into clauses + :finally + (return (nconc clauses + (list + `(t (error "No implementation of ~s for ~s" + ',(genfun-name generic) + ,types))))))))))) +(defun method-signature (lambda-list) + (loop + :for param :in lambda-list + :until (typep param 'lambda-list-option-term) + :when (and (listp param) (= 2 (length param))) + :do (assert (type-specifier-p (second param)) () + "~s is not a valid type-specifier" + (second param)) + :and :collect (second param) + :else + :collect 't)) + +(defun method-sig-vars (gen-lambda-list) + (loop :for x :in gen-lambda-list + :until (typep x 'lambda-list-option-term) + :collect x)) + +(defun sig-before-p (sig1 sig2) + (let* ((before (mapcar #'subtypep sig1 sig2)) + (after (mapcar #'subtypep sig2 sig1))) + (or (every #'identity before) + (and (find 't before) (find 't after) + (< (position 't before) (position 't after)))))) + +(defun add-meth (gen spec) + (with-slots (methods) gen + (push spec methods) + (setf methods (sort methods #'sig-before-p :key #'car)))) + + +(defun method-lambda-list-matches-generic (mll gll) + (and (= (length mll) (length gll)) + (loop :for m :in mll + :for g :in gll + :for mvar := (if (consp m) (first m) m) + :for gvar := (if (consp g) (first g) g) + :always (string-equal mvar gvar)))) + +(defmacro generic (name lambda-list &optional docstring) + "Define a generic function with optional docstring" + (expand-generic-function-def + (setf (gethash name *genfuns*) + (make-instance 'genfun + :name name + :lambda-list lambda-list + :docstring docstring)))) + +(defmacro method (name lambda-list &body body) + "Define a method on the generic function called NAME, which must exist already." + (let ((gen (gethash name *genfuns*))) + (unless gen + (error "Unknown GENFUN named ~s" name)) + (unless (method-lambda-list-matches-generic lambda-list (genfun-lambda-list gen)) + (error "Method lambda-list ~s does not match generic function ~s" + lambda-list (genfun-lambda-list gen))) + (let* ((sig + (method-signature lambda-list)) + (bound + (assoc sig (genfun-methods gen) :test #'equalp))) + (if bound + (rplacd bound body) + (add-meth gen (cons sig body))) + (expand-generic-function-def gen)))) |