Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 59 lines (49 sloc) 2.359 kB
2a8ff71 defgeneric* and defmethod*
Timothy Moore authored
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2001 by
4 ;;; Tim Moore (moore@bricoworks.com)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
95dff8a make all of the package names passed to in-package be lowercase keywo…
Mike McDonald authored
21 (in-package :clim-internals)
2a8ff71 defgeneric* and defmethod*
Timothy Moore authored
22
23 (defun setf-name-p (name)
24 (and (listp name) (eq (car name) 'setf)))
25
9f1c9a3 Changed DEFGENERIC* and DEFMETHOD* to use a private name for the
Timothy Moore authored
26 ;;; Many implementations complain if a defsetf definition and a setf function
27 ;;; exist for the same place. Time to stop fighting that...
28
29 (defun make-setf*-gfn-name (function-name)
30 (let* ((name-sym (cadr function-name)))
31 `(setf ,(intern (format nil ".~A-~A."
32 (symbol-name name-sym)
33 (symbol-name '#:star))
34 (symbol-package name-sym)))))
35
2a8ff71 defgeneric* and defmethod*
Timothy Moore authored
36 (defmacro defgeneric* (fun-name lambda-list &body options)
37 "Defines a SETF* generic function. FUN-NAME is a SETF function
38 name. The last argument is the single argument to the function in a
39 SETF place form; the other arguments are values collected from the
40 SETF new value form."
41 (unless (setf-name-p fun-name)
42 (error "~S is not a valid name for a SETF* generic function." fun-name))
43 (let ((setf-name (cadr fun-name))
44 (args (butlast lambda-list))
9f1c9a3 Changed DEFGENERIC* and DEFMETHOD* to use a private name for the
Timothy Moore authored
45 (place (car (last lambda-list)))
46 (gf (make-setf*-gfn-name fun-name)))
2a8ff71 defgeneric* and defmethod*
Timothy Moore authored
47 `(progn
48 (defsetf ,setf-name (,place) ,args
9f1c9a3 Changed DEFGENERIC* and DEFMETHOD* to use a private name for the
Timothy Moore authored
49 `(funcall #',',gf ,,@args ,,place))
50 (defgeneric ,gf ,lambda-list ,@options))))
2a8ff71 defgeneric* and defmethod*
Timothy Moore authored
51
52 (defmacro defmethod* (name &body body)
53 "Defines a SETF* method. NAME is a SETF function name. Otherwise,
54 like DEFMETHOD except there must exist a corresponding DEFGENERIC* form."
55 (unless (setf-name-p name)
56 (error "~S is not a valid name for a SETF* generic function." name))
9f1c9a3 Changed DEFGENERIC* and DEFMETHOD* to use a private name for the
Timothy Moore authored
57 `(defmethod ,(make-setf*-gfn-name name) ,@body))
2a8ff71 defgeneric* and defmethod*
Timothy Moore authored
58
Something went wrong with that request. Please try again.