Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[e90b2f]: src / clos / generic.lsp Maximize Restore History

Download this file

generic.lsp    254 lines (238 with data), 10.3 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
;;;;
;;;; Copyright (c) 1992, Giuseppe Attardi.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "CLOS")
;;; ----------------------------------------------------------------------
;;; DEFGENERIC
;;;
(defmacro defgeneric (&whole whole &rest args)
(multiple-value-bind (function-specifier lambda-list options)
(parse-defgeneric args)
(parse-lambda-list lambda-list)
;; process options
(multiple-value-bind (option-list method-list)
(parse-generic-options options lambda-list)
(let* ((output `(ensure-generic-function ',function-specifier
:delete-methods t ,@option-list)))
(ext:register-with-pde
whole
(if method-list
`(progn
,output
(associate-methods-to-gfun
',function-specifier
,@(loop for m in method-list collect `(defmethod ,function-specifier ,@m))))
output))))))
(defun parse-defgeneric (args)
(declare (si::c-local))
;; (values function-specifier lambda-list options)
(let (function-specifier)
(unless args
(simple-program-error "Illegal defgeneric form: missing generic function name"))
(setq function-specifier (pop args))
(unless args
(simple-program-error "Illegal defgeneric form: missing lambda-list"))
(values function-specifier (first args) (rest args))))
(defun parse-generic-options (options lambda-list)
(declare (si::c-local))
(let* ((processed-options '())
(method-list '())
(declarations '())
arg-list)
(dolist (option options)
(let ((option-name (first option))
option-value)
(cond ((eq option-name :method)
;; We do not need to check the validity of this
;; because DEFMETHOD will do it.
(push (rest option) method-list))
((eq option-name 'declare)
(setf declarations (append (rest option) declarations)))
((member option-name processed-options)
(simple-program-error "Option ~s specified more than once"
option-name))
(t
(push option-name processed-options)
;; We leave much of the type checking for SHARED-INITIALIZE
(setq option-value
(case option-name
(:argument-precedence-order
(rest option))
(:method-combination
(rest option))
((:documentation :generic-function-class :method-class)
(unless (endp (cddr option))
(simple-program-error "Too many arguments for option ~A"
option-name))
(second option))
(otherwise
(simple-program-error "~S is not a legal defgeneric option"
option-name))))
(setf arg-list `(',option-name ',option-value ,@arg-list))))))
(values `(:lambda-list ',lambda-list ,@arg-list
,@(when declarations `(:declarations ',declarations)))
method-list)))
(defun parse-lambda-list (lambda-list &optional post-keyword)
(declare (si::c-local))
(let ((arg (car lambda-list)))
(cond ((null lambda-list))
((eq arg '&AUX)
(simple-program-error "&aux is not allowed in a generic function lambda-list"))
((member arg lambda-list-keywords)
(parse-lambda-list (cdr lambda-list) t))
(post-keyword
;; After a lambda-list-keyword there can be no specializers.
(parse-lambda-list (cdr lambda-list) t))
(t
(if (listp arg)
(simple-program-error "the parameters cannot be specialized in generic function lambda-list")
(parse-lambda-list (cdr lambda-list)))))))
(defun valid-declaration-p (decl)
;(declare (si::c-local))
(unless (eq (first decl) 'OPTIMIZE)
(simple-program-error "The only declaration allowed is optimize"))
(dolist (first (rest decl))
(when (atom first)
(setq first (cons first 3)))
(unless (member (car first) '(SPEED SPACE COMPILATION-SPEED DEBUG SAFETY))
(simple-program-error "The only qualities allowed are speed and space")))
decl)
;;; ----------------------------------------------------------------------
;;; GENERIC FUNCTION (RE)INITIALIZATION PROTOCOL
;;
(defun lambda-list-required-arguments (lambda-list)
(rest (si::process-lambda-list lambda-list t)))
(defmethod shared-initialize ((gfun generic-function) slot-names &rest initargs
&key (lambda-list nil l-l-p)
(argument-precedence-order nil a-o-p)
(documentation nil)
(declarations nil)
(method-class (find-class 'method))
)
(declare (ignore initargs slot-names))
;;
;; Check the validity of several fields.
;;
(when a-o-p
(unless l-l-p
(simple-program-error "Supplied :argument-precedence-order, but :lambda-list is missing"))
(dolist (l (lambda-list-required-arguments lambda-list))
(unless (= (count l argument-precedence-order) 1)
(simple-program-error "The required argument ~A does not appear exactly once in the ARGUMENT-PRECEDENCE-ORDER list ~A"
l argument-precedence-order))))
(unless (every #'valid-declaration-p declarations)
(simple-program-error "Not a valid declaration list: ~A" declarations))
(unless (or (null documentation) (stringp documentation))
(error 'simple-type-error
:format-control "Not a valid documentation object ~"
:format-arguments (list documentation)
:datum documentation
:expected-type '(or null string)))
(unless (si::subclassp method-class (find-class 'method))
(error 'simple-type-error
:format-control "Not a valid method class, ~A"
:format-arguments (list method-class)
:datum method-class
:expected-type 'method))
;;
;; When supplying a new lambda-list, ensure that it is compatible with
;; the old list of methods.
;;
(when (and l-l-p (slot-boundp gfun 'methods))
(unless (every #'(lambda (x)
(congruent-lambda-p lambda-list x))
(mapcar #'method-lambda-list (generic-function-methods gfun)))
(simple-program-error "Cannot replace the lambda list of ~A with ~A because it is incongruent with some of the methods"
gfun lambda-list)))
(call-next-method)
(let ((combination (generic-function-method-combination gfun)))
(unless (typep combination 'method-combination)
(setf (generic-function-method-combination gfun)
(find-method-combination gfun (first combination) (rest combination)))))
(when (and l-l-p (not a-o-p))
(setf (generic-function-argument-precedence-order gfun)
(lambda-list-required-arguments lambda-list)))
(set-generic-function-dispatch gfun)
gfun)
(defmethod shared-initialize ((gfun standard-generic-function) slot-names
&rest initargs)
(declare (ignore initargs slot-names))
(call-next-method)
(when (generic-function-methods gfun)
(compute-g-f-spec-list gfun))
(update-dependents gfun initargs)
gfun)
(defun associate-methods-to-gfun (name &rest methods)
(let ((gfun (fdefinition name)))
(dolist (method methods)
(setf (getf (method-plist method) :method-from-defgeneric-p) t))
gfun))
(defmethod ensure-generic-function-using-class
((gfun generic-function) name &rest args &key
(method-class 'STANDARD-METHOD method-class-p)
(generic-function-class (class-of gfun))
(delete-methods nil))
;; modify the existing object
(setf args (copy-list args))
(remf args :generic-function-class)
(remf args :declare)
(remf args :environment)
(remf args :delete-methods)
;; FIXME! We should check that the class GENERIC-FUNCTION-CLASS is compatible
;; with the old one. In what sense "compatible" is ment, I do not know!
;; (See ANSI DEFGENERIC entry)
(when (symbolp generic-function-class)
(setf generic-function-class (find-class generic-function-class)))
(unless (si::subclassp generic-function-class (find-class 'generic-function))
(error "~A is not a valid :GENERIC-FUNCTION-CLASS argument for ENSURE-GENERIC-FUNCTION."
generic-function-class))
(when (and method-class-p (symbolp method-class))
(setf args (list* :method-class (find-class method-class) args)))
(when delete-methods
(dolist (m (copy-list (generic-function-methods gfun)))
(when (getf (method-plist m) :method-from-defgeneric-p)
(remove-method gfun m))))
(if (eq (class-of gfun) generic-function-class)
(apply #'reinitialize-instance gfun :name name args)
(apply #'change-class gfun generic-function-class :name name args)))
(defmethod ensure-generic-function-using-class
((gfun null) name &rest args &key
(method-class 'STANDARD-METHOD method-class-p)
(generic-function-class 'STANDARD-GENERIC-FUNCTION)
(delete-methods nil))
(declare (ignore delete-methods gfun))
;; else create a new generic function object
(setf args (copy-list args))
(remf args :generic-function-class)
(remf args :declare)
(remf args :environment)
(remf args :delete-methods)
(when (and method-class-p (symbolp generic-function-class))
(setf args (list* :method-class (find-class method-class) args)))
(apply #'make-instance generic-function-class :name name args))
(defun ensure-generic-function (name &rest args &key &allow-other-keys)
(let ((gfun (si::traced-old-definition name)))
(cond ((not (legal-generic-function-name-p name))
(simple-program-error "~A is not a valid generic function name" name))
((not (fboundp name))
(setf (fdefinition name)
(apply #'ensure-generic-function-using-class gfun name args)))
((si::instancep (or gfun (setf gfun (fdefinition name))))
(apply #'ensure-generic-function-using-class gfun name args))
((special-operator-p name)
(simple-program-error "The special operator ~A is not a valid name for a generic function" name))
((macro-function name)
(simple-program-error "The symbol ~A is bound to a macro and is not a valid name for a generic function" name))
((not *clos-booted*)
(setf (fdefinition name)
(apply #'ensure-generic-function-using-class nil name args))
(fdefinition name))
(t
(simple-program-error "The symbol ~A is bound to an ordinary function and is not a valid name for a generic function" name)))))