1 |
|
;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
|
28 |
|
(in-package :pcl) |
29 |
|
|
30 |
|
;;; |
31 |
|
;;; DEFINE-METHOD-COMBINATION |
32 |
|
;;; |
33 |
|
|
34 |
|
(defmacro define-method-combination (&whole form &rest args) |
35 |
|
(declare (ignore args)) |
36 |
|
(if (and (cddr form) |
37 |
|
(listp (caddr form))) |
38 |
|
(expand-long-defcombin form) |
39 |
|
(expand-short-defcombin form))) |
40 |
|
|
41 |
|
;;; |
42 |
|
;;; Implementation of INVALID-METHOD-ERROR and METHOD-COMBINATION-ERROR |
43 |
|
;;; |
44 |
|
;;; See combin.lisp for rest of the implementation. This method is |
45 |
|
;;; defined here because compute-effective-method is still a function |
46 |
|
;;; in combin.lisp. |
47 |
|
;;; |
48 |
|
(defmethod compute-effective-method :around |
49 |
|
((generic-function generic-function) |
50 |
|
(method-combination method-combination) |
51 |
|
applicable-methods) |
52 |
|
(declare (ignore applicable-methods)) |
53 |
|
(flet ((real-invalid-method-error (method format-string &rest args) |
54 |
|
(declare (ignore method)) |
55 |
|
(apply #'error format-string args)) |
56 |
|
(real-method-combination-error (format-string &rest args) |
57 |
|
(apply #'error format-string args))) |
58 |
|
(let ((*invalid-method-error* #'real-invalid-method-error) |
59 |
|
(*method-combination-error* #'real-method-combination-error)) |
60 |
|
(call-next-method)))) |
61 |
|
|
62 |
|
|
63 |
|
;;; |
64 |
|
;;; STANDARD method combination |
65 |
|
;;; |
66 |
|
;;; The STANDARD method combination type is implemented directly by the class |
67 |
|
;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does |
68 |
|
;;; standard method combination directly and is defined by hand in the file |
69 |
|
;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this |
70 |
|
;;; file for bootstrapping reasons. |
71 |
|
;;; |
72 |
|
;;; A commented out copy of this definition appears in combin.lisp. |
73 |
|
;;; If you change this definition here, be sure to change it there |
74 |
|
;;; also. |
75 |
|
;;; |
76 |
|
(defmethod find-method-combination ((generic-function generic-function) |
77 |
|
(type (eql 'standard)) |
78 |
|
options) |
79 |
|
(when options |
80 |
|
(method-combination-error |
81 |
|
"The method combination type STANDARD accepts no options.")) |
82 |
|
*standard-method-combination*) |
83 |
|
|
84 |
|
|
85 |
|
|
86 |
|
;;; |
87 |
|
;;; short method combinations |
88 |
|
;;; |
89 |
|
;;; Short method combinations all follow the same rule for computing the |
90 |
|
;;; effective method. So, we just implement that rule once. Each short |
91 |
|
;;; method combination object just reads the parameters out of the object |
92 |
|
;;; and runs the same rule. |
93 |
|
;;; |
94 |
|
;;; |
95 |
|
(defclass short-method-combination (standard-method-combination) |
96 |
|
((operator |
97 |
|
:reader short-combination-operator |
98 |
|
:initarg :operator) |
99 |
|
(identity-with-one-argument |
100 |
|
:reader short-combination-identity-with-one-argument |
101 |
|
:initarg :identity-with-one-argument)) |
102 |
|
(:predicate-name short-method-combination-p)) |
103 |
|
|
104 |
|
(defun expand-short-defcombin (whole) |
105 |
|
(let* ((type (cadr whole)) |
106 |
|
(documentation |
107 |
|
(getf (cddr whole) :documentation "")) |
108 |
|
(identity-with-one-arg |
109 |
|
(getf (cddr whole) :identity-with-one-argument nil)) |
110 |
|
(operator |
111 |
|
(getf (cddr whole) :operator type))) |
112 |
|
(make-top-level-form `(define-method-combination ,type) |
113 |
|
'(load eval) |
114 |
|
`(load-short-defcombin |
115 |
|
',type ',operator ',identity-with-one-arg ',documentation)))) |
116 |
|
|
117 |
|
(defun load-short-defcombin (type operator ioa doc) |
118 |
|
(let* ((truename (load-truename)) |
119 |
|
(specializers |
120 |
|
(list (find-class 'generic-function) |
121 |
|
(intern-eql-specializer type) |
122 |
|
*the-class-t*)) |
123 |
|
(old-method |
124 |
|
(get-method #'find-method-combination () specializers nil)) |
125 |
|
(new-method nil)) |
126 |
|
(setq new-method |
127 |
|
(make-instance 'standard-method |
128 |
|
:qualifiers () |
129 |
|
:specializers specializers |
130 |
|
:lambda-list '(generic-function type options) |
131 |
|
:function (lambda (args nms &rest cm-args) |
132 |
|
(declare (ignore nms cm-args)) |
133 |
|
(apply |
134 |
|
(lambda (gf type options) |
135 |
|
(declare (ignore gf)) |
136 |
|
(make-short-method-combination |
137 |
|
type options operator ioa new-method doc)) |
138 |
|
args)) |
139 |
|
:definition-source `((define-method-combination ,type) ,truename))) |
140 |
|
(when old-method |
141 |
|
(remove-method #'find-method-combination old-method)) |
142 |
|
(add-method #'find-method-combination new-method) |
143 |
|
type)) |
144 |
|
|
145 |
|
(defun make-short-method-combination (type options operator ioa method doc) |
146 |
|
(cond ((null options) (setq options '(:most-specific-first))) |
147 |
|
((equal options '(:most-specific-first))) |
148 |
|
((equal options '(:most-specific-last))) |
149 |
|
(t |
150 |
|
(method-combination-error |
151 |
|
"Illegal options to a short method combination type.~%~ |
152 |
|
The method combination type ~S accepts one option which~%~ |
153 |
|
must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." |
154 |
|
type))) |
155 |
|
(make-instance 'short-method-combination |
156 |
|
:type type |
157 |
|
:options options |
158 |
|
:operator operator |
159 |
|
:identity-with-one-argument ioa |
160 |
|
:definition-source method |
161 |
|
:documentation doc)) |
162 |
|
|
163 |
|
(defmethod compute-effective-method ((generic-function generic-function) |
164 |
|
(combin short-method-combination) |
165 |
|
applicable-methods) |
166 |
|
(let ((type (method-combination-type combin)) |
167 |
|
(operator (short-combination-operator combin)) |
168 |
|
(ioa (short-combination-identity-with-one-argument combin)) |
169 |
|
(order (car (method-combination-options combin))) |
170 |
|
(around ()) |
171 |
|
(primary ()) |
172 |
|
(invalid ())) |
173 |
|
(dolist (m applicable-methods) |
174 |
|
(let ((qualifiers (method-qualifiers m))) |
175 |
|
(labels ((lose (method why) |
176 |
|
(invalid-method-error |
177 |
|
method |
178 |
|
"The method ~S ~A.~%~ |
179 |
|
The method combination type ~S was defined with the~%~ |
180 |
|
short form of DEFINE-METHOD-COMBINATION and so requires~%~ |
181 |
|
all methods have either the single qualifier ~S or the~%~ |
182 |
|
single qualifier :AROUND." |
183 |
|
method why type type)) |
184 |
|
(invalid-method (method why) |
185 |
|
(if *in-precompute-effective-methods-p* |
186 |
|
(push method invalid) |
187 |
|
(lose method why)))) |
188 |
|
(cond ((null qualifiers) |
189 |
|
(invalid-method m "has no qualifiers")) |
190 |
|
((cdr qualifiers) |
191 |
|
(invalid-method m "has more than one qualifier")) |
192 |
|
((eq (car qualifiers) :around) |
193 |
|
(push m around)) |
194 |
|
((eq (car qualifiers) type) |
195 |
|
(push m primary)) |
196 |
|
(t |
197 |
|
(invalid-method m "has an illegal qualifier")))))) |
198 |
|
(setq around (nreverse around)) |
199 |
|
(unless (eq order :most-specific-last) |
200 |
|
(setq primary (nreverse primary))) |
201 |
|
(let ((main-method |
202 |
|
(if (and (null (cdr primary)) |
203 |
|
(not (null ioa))) |
204 |
|
`(call-method ,(car primary) ()) |
205 |
|
`(,operator ,@(mapcar (lambda (m) `(call-method ,m ())) |
206 |
|
primary))))) |
207 |
|
(cond (invalid |
208 |
|
`(%invalid-qualifiers ',generic-function ',combin .args. ',invalid)) |
209 |
|
((null primary) |
210 |
|
`(%no-primary-method ',generic-function .args.)) |
211 |
|
((null around) |
212 |
|
main-method) |
213 |
|
(t |
214 |
|
`(call-method ,(car around) |
215 |
|
(,@(cdr around) (make-method ,main-method)))))))) |
216 |
|
|
217 |
|
|
218 |
|
;;; |
219 |
|
;;; long method combinations |
220 |
|
;;; |
221 |
|
;;; |
222 |
|
|
223 |
|
|
224 |
|
(defun expand-long-defcombin (form) |
225 |
|
(let ((type (cadr form)) |
226 |
|
(lambda-list (caddr form)) |
227 |
|
(method-group-specifiers (cadddr form)) |
228 |
|
(body (cddddr form)) |
229 |
|
(arguments-option ()) |
230 |
|
(gf-var nil)) |
231 |
|
(when (and (consp (car body)) (eq (caar body) :arguments)) |
232 |
|
(setq arguments-option (cdr (pop body)))) |
233 |
|
(when (and (consp (car body)) (eq (caar body) :generic-function)) |
234 |
|
(setq gf-var (cadr (pop body)))) |
235 |
|
(multiple-value-bind (documentation function) |
236 |
|
(make-long-method-combination-function |
237 |
|
type lambda-list method-group-specifiers arguments-option gf-var |
238 |
|
body) |
239 |
|
(make-top-level-form `(define-method-combination ,type) |
240 |
|
'(load eval) |
241 |
|
`(load-long-defcombin ',type ',documentation #',function ',arguments-option))))) |
242 |
|
|
243 |
|
(defvar *long-method-combination-functions* (make-hash-table :test #'eq)) |
244 |
|
|
245 |
|
(defun load-long-defcombin (type doc function arguments-lambda-list) |
246 |
|
(let* ((specializers |
247 |
|
(list (find-class 'generic-function) |
248 |
|
(intern-eql-specializer type) |
249 |
|
*the-class-t*)) |
250 |
|
(old-method |
251 |
|
(get-method #'find-method-combination () specializers nil)) |
252 |
|
(new-method |
253 |
|
(make-instance 'standard-method |
254 |
|
:qualifiers () |
255 |
|
:specializers specializers |
256 |
|
:lambda-list '(generic-function type options) |
257 |
|
:function (lambda (args nms &rest cm-args) |
258 |
|
(declare (ignore nms cm-args)) |
259 |
|
(apply |
260 |
|
(lambda (generic-function type options) |
261 |
|
(declare (ignore generic-function)) |
262 |
|
(make-instance 'long-method-combination |
263 |
|
:type type |
264 |
|
:options options |
265 |
|
:function function |
266 |
|
:arguments-lambda-list |
267 |
|
arguments-lambda-list |
268 |
|
:documentation doc)) |
269 |
|
args)) |
270 |
|
:definition-source `((define-method-combination ,type) |
271 |
|
,(load-truename))))) |
272 |
|
(setf (gethash type *long-method-combination-functions*) function) |
273 |
|
(when old-method (remove-method #'find-method-combination old-method)) |
274 |
|
(add-method #'find-method-combination new-method) |
275 |
|
type)) |
276 |
|
|
277 |
|
(defmethod compute-effective-method ((generic-function generic-function) |
278 |
|
(combin long-method-combination) |
279 |
|
applicable-methods) |
280 |
|
(funcall (gethash (method-combination-type combin) |
281 |
|
*long-method-combination-functions*) |
282 |
|
generic-function |
283 |
|
combin |
284 |
|
applicable-methods)) |
285 |
|
|
286 |
|
;;; |
287 |
|
;;; |
288 |
|
;;; |
289 |
|
(defun make-long-method-combination-function |
290 |
|
(type ll method-group-specifiers arguments-option gf-var body) |
291 |
|
(declare (ignore type)) |
292 |
|
(multiple-value-bind (documentation declarations real-body) |
293 |
|
(extract-declarations body) |
294 |
|
|
295 |
|
(let ((wrapped-body |
296 |
|
(wrap-method-group-specifier-bindings method-group-specifiers |
297 |
|
declarations |
298 |
|
real-body))) |
299 |
|
(when gf-var |
300 |
|
(push `(,gf-var .generic-function.) (cadr wrapped-body))) |
301 |
|
|
302 |
|
(when arguments-option |
303 |
|
(setq wrapped-body |
304 |
|
(deal-with-arguments-option wrapped-body arguments-option))) |
305 |
|
|
306 |
|
(when ll |
307 |
|
(setq wrapped-body |
308 |
|
`(apply (lambda ,ll ,wrapped-body) |
309 |
|
(method-combination-options .method-combination.)))) |
310 |
|
|
311 |
|
(values |
312 |
|
documentation |
313 |
|
`(lambda (.generic-function. .method-combination. .applicable-methods.) |
314 |
|
(declare (ignorable .generic-function. .method-combination. |
315 |
|
.applicable-methods.)) |
316 |
|
(block .long-method-combination-function. ,wrapped-body)))))) |
317 |
|
;; |
318 |
|
;; parse-method-group-specifiers parse the method-group-specifiers |
319 |
|
;; |
320 |
|
|
321 |
|
(defun wrap-method-group-specifier-bindings |
322 |
|
(method-group-specifiers declarations real-body) |
323 |
|
(let ((names ()) |
324 |
|
(specializer-caches ()) |
325 |
|
(cond-clauses ()) |
326 |
|
(required-checks ()) |
327 |
|
(order-cleanups ())) |
328 |
|
(dolist (method-group-specifier method-group-specifiers) |
329 |
|
(multiple-value-bind (name tests description order required) |
330 |
|
(parse-method-group-specifier method-group-specifier) |
331 |
|
(declare (ignore description)) |
332 |
|
(let ((specializer-cache (gensym))) |
333 |
|
(push name names) |
334 |
|
(push specializer-cache specializer-caches) |
335 |
|
(push `((or ,@tests) |
336 |
|
(if (and (equal ,specializer-cache .specializers.) |
337 |
|
(not (null .specializers.))) |
338 |
|
(return-from .long-method-combination-function. |
339 |
|
'(error "More than one method of type ~S ~ |
340 |
|
with the same specializers." |
341 |
|
',name)) |
342 |
|
(setq ,specializer-cache .specializers.)) |
343 |
|
(push .method. ,name)) |
344 |
|
cond-clauses) |
345 |
|
(when required |
346 |
|
(push `(when (null ,name) |
347 |
|
(return-from .long-method-combination-function. |
348 |
|
'(error "No ~S methods." ',name))) |
349 |
|
required-checks)) |
350 |
|
(loop (unless (and (constantp order) |
351 |
|
(neq order (setq order (eval order)))) |
352 |
|
(return t))) |
353 |
|
(push (cond ((eq order :most-specific-first) |
354 |
|
`(setq ,name (nreverse ,name))) |
355 |
|
((eq order :most-specific-last) ()) |
356 |
|
(t |
357 |
|
`(ecase ,order |
358 |
|
(:most-specific-first |
359 |
|
(setq ,name (nreverse ,name))) |
360 |
|
(:most-specific-last)))) |
361 |
|
order-cleanups)))) |
362 |
|
`(let (,@(nreverse names) ,@(nreverse specializer-caches)) |
363 |
|
,@declarations |
364 |
|
(dolist (.method. .applicable-methods.) |
365 |
|
(let ((.qualifiers. (method-qualifiers .method.)) |
366 |
|
(.specializers. (method-specializers .method.))) |
367 |
|
(declare (ignorable .qualifiers. .specializers.)) |
368 |
|
(cond ,@(nreverse cond-clauses)))) |
369 |
|
,@(nreverse required-checks) |
370 |
|
,@(nreverse order-cleanups) |
371 |
|
,@real-body))) |
372 |
|
|
373 |
|
(defun parse-method-group-specifier (method-group-specifier) |
374 |
|
;;(declare (values name tests description order required)) |
375 |
|
(loop with name = (pop method-group-specifier) |
376 |
|
for rest on method-group-specifier |
377 |
|
for pattern = (car rest) |
378 |
|
until (memq pattern '(:description :order :required)) |
379 |
|
collect pattern into patterns |
380 |
|
collect (parse-qualifier-pattern name pattern) into tests |
381 |
|
finally |
382 |
|
(return (values name |
383 |
|
tests |
384 |
|
(getf rest :description |
385 |
|
(make-default-method-group-description |
386 |
|
(nreverse patterns))) |
387 |
|
(getf rest :order :most-specific-first) |
388 |
|
(getf rest :required nil))))) |
389 |
|
|
390 |
|
(defun parse-qualifier-pattern (name pattern) |
391 |
|
(cond ((eq pattern '()) `(null .qualifiers.)) |
392 |
|
((eq pattern '*) t) |
393 |
|
((symbolp pattern) `(,pattern .qualifiers.)) |
394 |
|
((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) |
395 |
|
(t (error "In the method group specifier ~S,~%~ |
396 |
|
~S isn't a valid qualifier pattern." |
397 |
|
name pattern)))) |
398 |
|
|
399 |
|
(defun qualifier-check-runtime (pattern qualifiers) |
400 |
|
(loop (cond ((and (null pattern) (null qualifiers)) |
401 |
|
(return t)) |
402 |
|
((eq pattern '*) (return t)) |
403 |
|
((and pattern qualifiers |
404 |
|
(let ((element (car pattern))) |
405 |
|
(or (eq element (car qualifiers)) |
406 |
|
(eq element '*)))) |
407 |
|
(pop pattern) |
408 |
|
(pop qualifiers)) |
409 |
|
(t (return nil))))) |
410 |
|
|
411 |
|
(defun make-default-method-group-description (patterns) |
412 |
|
(if (cdr patterns) |
413 |
|
(format nil |
414 |
|
"methods matching one of the patterns: ~{~S, ~} ~S" |
415 |
|
(butlast patterns) (car (last patterns))) |
416 |
|
(format nil |
417 |
|
"methods matching the pattern: ~S" |
418 |
|
(car patterns)))) |
419 |
|
|
420 |
|
;;; |
421 |
|
;;; Return a form that deals with the :ARGUMENTS lambda-list of a long |
422 |
|
;;; method combination. WRAPPED-BODY is the body of the method |
423 |
|
;;; combination so far, and ARGUMENTS-LAMBDA-LIST is the arguments |
424 |
|
;;; lambda-list of the method combination. |
425 |
|
;;; |
426 |
|
(defun deal-with-arguments-option (wrapped-body arguments-lambda-list) |
427 |
|
(let ((intercept-rebindings |
428 |
|
(loop for arg in arguments-lambda-list |
429 |
|
unless (memq arg lambda-list-keywords) |
430 |
|
collect `(,arg ',arg))) |
431 |
|
(nreq 0) |
432 |
|
(nopt 0) |
433 |
|
whole) |
434 |
|
;; |
435 |
|
;; Count the number of required and optional parameters in |
436 |
|
;; ARGUMENTS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the |
437 |
|
;; name of a &WHOLE parameter, if any. |
438 |
|
(loop with state = 'required |
439 |
|
for arg in arguments-lambda-list do |
440 |
|
(if (memq arg lambda-list-keywords) |
441 |
|
(setq state arg) |
442 |
|
(case state |
443 |
|
(required (incf nreq)) |
444 |
|
(&optional (incf nopt)) |
445 |
|
(&whole (setq whole arg |
446 |
|
state 'required))))) |
447 |
|
;; |
448 |
|
;; This assumes that the WRAPPED-BODY is a let/let* form, and it |
449 |
|
;; injects let-bindings of the form (ARG 'SYM) for all variables |
450 |
|
;; of the argument-lambda-list; SYM is a gensym. |
451 |
|
(assert (memq (first wrapped-body) '(let let*))) |
452 |
|
(setf (second wrapped-body) |
453 |
|
(append intercept-rebindings (second wrapped-body))) |
454 |
|
;; |
455 |
|
;; Be sure to fill out the args lambda list so that it can be too |
456 |
|
;; short if it wants to. |
457 |
|
(unless (or (memq '&rest arguments-lambda-list) |
458 |
|
(memq '&allow-other-keys arguments-lambda-list)) |
459 |
|
(let ((aux (memq '&aux arguments-lambda-list))) |
460 |
|
(setq arguments-lambda-list |
461 |
|
(append (ldiff arguments-lambda-list aux) |
462 |
|
(if (memq '&key arguments-lambda-list) |
463 |
|
'(&allow-other-keys) |
464 |
|
'(&rest .ignore.)) |
465 |
|
aux)))) |
466 |
|
;; |
467 |
|
;; .GENERIC-FUNCTION. is bound to the generic function in the |
468 |
|
;; method combination function, and .GF-ARGS* is bound to the |
469 |
|
;; generic function arguments in effective method functions |
470 |
|
;; created for generic functions having a method combination that |
471 |
|
;; uses :ARGUMENTS. |
472 |
|
;; |
473 |
|
;; The DESTRUCTURING-BIND binds the parameters of the |
474 |
|
;; ARGUMENTS-LAMBDA-LIST to actual generic function arguments. |
475 |
|
;; Because ARGUMENTS-LAMBDA-LIST may be shorter or longer than the |
476 |
|
;; generic function's lambda list, which is only known at run time, |
477 |
|
;; this destructuring has to be done on a slighly modified list of |
478 |
|
;; actual arguments, from which values might be stripped or added. |
479 |
|
;; |
480 |
|
;; Using one of the variable names in the body inserts a symbol |
481 |
|
;; into the effective method, and running the effective method |
482 |
|
;; produces the value of actual argument that is bound to the |
483 |
|
;; symbol. |
484 |
|
`(let ((inner-result. ,wrapped-body) |
485 |
|
(gf-lambda-list (generic-function-lambda-list .generic-function.))) |
486 |
|
`(destructuring-bind ,',arguments-lambda-list |
487 |
|
(frob-combined-method-args |
488 |
|
.gf-args. ',gf-lambda-list |
489 |
|
,',nreq ,',nopt) |
490 |
|
,,(when (memq '.ignore. arguments-lambda-list) |
491 |
|
''(declare (ignore .ignore.))) |
492 |
|
;; If there is a &WHOLE in the arguments-lambda-list, let |
493 |
|
;; it result in the actual arguments of the generic-function |
494 |
|
;; not the frobbed list. |
495 |
|
,,(when whole |
496 |
|
``(setq ,',whole .gf-args.)) |
497 |
|
,inner-result.)))) |
498 |
|
|
499 |
|
;;; |
500 |
|
;;; Partition VALUES into three sections required, optional, and the |
501 |
|
;;; rest, according to required, optional, and other parameters in |
502 |
|
;;; LAMBDA-LIST. Make the required and optional sections NREQ and |
503 |
|
;;; NOPT elements long by discarding values or adding NILs. Value is |
504 |
|
;;; the concatenated list of required and optional sections, and what |
505 |
|
;;; is left as rest from VALUES. |
506 |
|
;;; |
507 |
|
(defun frob-combined-method-args (values lambda-list nreq nopt) |
508 |
|
(loop with section = 'required |
509 |
|
for arg in lambda-list |
510 |
|
if (memq arg lambda-list-keywords) do |
511 |
|
(setq section arg) |
512 |
|
(unless (eq section '&optional) |
513 |
|
(loop-finish)) |
514 |
|
else if (eq section 'required) |
515 |
|
count t into nr |
516 |
|
and collect (pop values) into required |
517 |
|
else if (eq section '&optional) |
518 |
|
count t into no |
519 |
|
and collect (pop values) into optional |
520 |
|
finally |
521 |
|
(flet ((frob (list n m) |
522 |
|
(cond ((> n m) (butlast list (- n m))) |
523 |
|
((< n m) (nconc list (make-list (- m n)))) |
524 |
|
(t list)))) |
525 |
|
(return (nconc (frob required nr nreq) |
526 |
|
(frob optional no nopt) |
527 |
|
values))))) |