Collecting method combination examples
Quote:
> I'm giving a brief talk to a small group of local software colleagues
> who are mostly Java/C++/Python users. The general topic is CLOS
> method dispatch with a particular focus on the concept of method
> combination. The objective is to describe a powerful feature of lisp
> that is not well supported in these other languages.
> I have an example of my own string-cat combination that is used to
> gather strings from various ancestor classes into an informative
> identifier or print-name.
> As part of the talk, in addition to my own example, I would like to
> cite an example other than my own. I would enjoy reading any other
> examples using standard or custom method combinations that you feel
> are interesting and would be willing to post.
> Thanks alot.
There was one posted here a time ago that implemented Eiffel's DBC.
Path: tower.skynet.be!xenon.inbe.net!INbe.net!krypton.inbe.net!INbe.net!news.belnet.be!newsfeed.wirehub.nl!btnet-peer!btnet!newsfeed.ecrc.net!news-DUS.ecrc.net!news.csl-gmbh.net!informatik.tu-muenchen.de!news.muc.de!gauss.muc.de!not-for-mail
Newsgroups: comp.lang.lisp,comp.lang.clos
Subject: Re: DBC in Lisp (was: Stepanov *does* want OOP?)
Date: 11 Oct 1998 03:21:13 +0200
Organization: Private site, Munich, Germany
Lines: 457
NNTP-Posting-Host: localhost.muc.de
X-Server-Date: 11 Oct 1998 01:21:18 GMT
X-Newsreader: Gnus v5.5/XEmacs 20.4 - "Emerald"
Xref: tower.skynet.be comp.lang.lisp:6103 comp.lang.clos:85
[comp.object and comp.eiffel removed since this is no longer relevant]
Quote:
> > style by most authors.) I have appended a simple DBC-library for CLOS
> I have changed it a bit. It now has its own package
> and uses DEFCLASS.
I have reworked it some more and added a tiny amount of documentation
so that others might find it more useful. The main improvements are
that now weakening of preconditions is handled correctly without
having to manually build the disjunction, furthermore
pre-/postconditions and invariants can now be defined as predicates
and an error will be signalled if they evaluate to false.
Matthias
;;; dbc.lisp
;;; Design by Contract in Common Lisp.
;;; =================================
;;; One of the outstanding features of the Eiffel language is that it
;;; supports a concept called Design by Contract. A comprehensive
;;; description is given in
;;;
;;; Object Oriented Software Construction, 2nd ed.
;;; Bertrand Meyer
;;; Prentice Hall PTR, 1997
;;; ISBN 0-13-629155-4
;;;
;;; but the key point of DBC is that the relationship between a class
;;; and its clients is specified by a contract: There are certain
;;; conditions that the caller of a method specialized on a class has
;;; to fulfill so that the method can do its job (the preconditions)
;;; and the method guarantees certain things after its completion (the
;;; postconditions). Furthermore a class may have certain properties
;;; that are always true about that class; these properties are called
;;; invariants.
;;;
;;; This file contains an implementation of DBC for CLOS. Pre- and
;;; postconditions as well as invariants are specified by qualified
;;; methods of type dbc; the usual before, after and around method
;;; combinations are available for these methods as well.
;;;
;;; placed in the public domain. Rainer Joswig added the package
;;; definition and MCL patches. The most recent version of this file
;;; should be available at <http://www.muc.de/~hoelzl>.
;;;
;;; Have fun,
;;; Matthias
;;;
;;;
;;; Change Log.
;;; ==========
;;;
;;; * Initial version.
;;; * Changed handling of pre-/postconditions and invariants to
;;; match Eiffel's behavior more closely. Errors are now signalled
;;; by the method combination.
;;;
;;; 1998-10-11 Rainer Joswig
;;;
;;; * Added package definition.
;;; * Added MCL patches.
;;;
;;; * Added default method for `check-invariant'.
;;; * Removed `(ensure-generic-function 'check-invariant)' from
;;; `define-check-invariant-method'.
;;; * Changed method combination type of `check-invariant' to
;;; standard method combination.
(cl:defpackage "DESIGN-BY-CONTRACT"
(:use "COMMON-LISP")
(:nicknames "DBC")
(:shadow cl:defclass cl:make-instance)
(:export "DBC" "DEFCLASS" "MAKE-INSTANCE"))
(in-package "DBC")
;;; The method combination DBC.
;;; ==========================
(define-method-combination dbc ()
((precondition (:precondition))
(around (:around))
(invariant (:invariant))
(before (:before))
(primary () :required t)
(after (:after))
(postcondition (:postcondition)))
(flet ((call-methods (methods)
(mapcar #'(lambda (method)
`(call-method ,method))
methods)))
(let* ((form (if (or before after (rest primary))
`(multiple-value-prog1
(call-method ,(first primary)
,(rest primary)))
`(call-method ,(first primary))))
(around-form (if around
`(call-method ,(first around)
(make-method ,form)))
form))
(pre-form (if precondition
,around-form
(error "Precondition failure."))
around-form))
(post-form (if postcondition
`(multiple-value-prog1
,pre-form
(error "Postcondition failure.")))
pre-form))
(inv-form (if invariant
`(multiple-value-prog1
(progn
invariant))
(error
"Invariant violation before method call."))
,post-form)
(error
"Invariant violation after method call.")))
post-form)))
inv-form)))
(defun getf-and-remove (name list &optional acc)
"Find NAME in the alist LIST. Returns nil as first value if NAME is
not found, the valus associated with NAME otherwise. The second value
returned is LIST with the first occurence of pair (NAME value)
removed."
(if (null list)
(values nil (reverse acc))
(if (eql (caar list) name)
(values (cadar list) (append (reverse acc) (rest list)))
(getf-and-remove name (rest list) (cons (first list) acc)))))
(defun define-slot-generics (slot)
"Returns a list with the reader and writer generic functions for a slot.
The generic functions have method combination type `dbc'."
(let ((accessor (getf (rest slot) :accessor)))
(let ((reader (or (getf (rest slot) :reader)
accessor))
(writer (or (getf (rest slot) :writer)
(when accessor
`(setf ,accessor)))))
(list (when reader
`(ensure-generic-function
',reader
:lambda-list '(object)
:method-combination #-mcl '(dbc:dbc)
#+mcl (ccl::%find-method-combination nil 'dbc nil)))
(when writer
`(ensure-generic-function
',writer
:lambda-list '(new-value object)
:method-combination #-mcl'(dbc:dbc)
#+mcl (ccl::%find-method-combination nil 'dbc nil)))))))
(defun define-slot-accessor-invariants (class slot)
"Returns a list with method definitions for reader and writer
invariants."
(let ((accessor (getf (rest slot) :accessor)))
(let ((reader (or (getf (rest slot) :reader)
accessor))
(writer (or (getf (rest slot) :writer)
(when accessor
`(setf ,accessor)))))
(list (when reader
`(defmethod ,reader :invariant ((object ,class))
(check-invariant object)))
(when writer
`(defmethod ,writer :invariant (value (object ,class))
(declare (ignore value))
(check-invariant object)))))))
(defun define-check-invariant-method (invariant class)
"Returns a list containing the method on CHECK-INVARIANT specialized
for CLASS and executing INVARIANT."
`((defmethod check-invariant ((class ,class))
(when (funcall ,invariant class)
(call-next-method)))))
(defmacro defclass (&body body)
(destructuring-bind (name supers &optional slots &rest options)
body
(multiple-value-bind (invariant new-options)
(getf-and-remove :invariant options)
`(progn
(apply #'append
(mapcar (lambda (slot)
(define-slot-generics slot))
slots))
'())
(cl:defclass ,name ,supers ,slots
(define-check-invariant-method invariant name))
(apply #'append
(mapcar (lambda (slot)
(define-slot-accessor-invariants
name slot))
slots)))))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defgeneric check-invariant (object)
(:documentation
"Methods on the generic `check-invariant' are used by the dbc
method combination to
...
read more »