157 |
)) |
)) |
158 |
|
|
159 |
|
|
160 |
|
|
161 |
|
;;; FIXME need GCL support for these kernel:* functions |
162 |
|
|
163 |
|
;;; |
164 |
|
;;; |
165 |
;;; |
;;; |
166 |
;;; |
;;; |
167 |
|
;;; ANSI 3.4.2, Generic Function Lambda Lists |
168 |
;;; |
;;; |
169 |
|
|
170 |
|
;(defun parse-generic-function-lambda-list (lambda-list) |
171 |
|
;; This is like kernel:parse-lambda-list, but returns an additional |
172 |
|
;; value AUXP which is true if LAMBDA-LIST contains any &aux keyword. |
173 |
|
; (multiple-value-bind (required optional restp rest keyp keys |
174 |
|
; allow-other-keys-p aux morep |
175 |
|
; more-context more-count) |
176 |
|
; (kernel:parse-lambda-list lambda-list) |
177 |
|
; (values required optional restp rest keyp keys allow-other-keys-p |
178 |
|
; (or aux (member '&aux lambda-list :test #'eq)) aux |
179 |
|
; morep more-context more-count))) |
180 |
|
|
181 |
|
;(defun check-generic-function-lambda-list (function-specifier lambda-list) |
182 |
|
; (multiple-value-bind (required optional restp rest keyp keys |
183 |
|
; allow-other-keys-p auxp aux morep |
184 |
|
; more-context more-count) |
185 |
|
; (parse-generic-function-lambda-list lambda-list) |
186 |
|
; (declare (ignore restp rest keyp aux allow-other-keys-p more-context |
187 |
|
; more-count)) |
188 |
|
; (labels ((lambda-list-error (format-control &rest format-arguments) |
189 |
|
; (simple-program-error "Generic function ~A:~%~?" |
190 |
|
; function-specifier |
191 |
|
; format-control format-arguments)) |
192 |
|
; (check-required-parameter (parameter) |
193 |
|
; (unless (symbolp parameter) |
194 |
|
; (lambda-list-error |
195 |
|
; "Invalid generic function parameter name ~A" |
196 |
|
; parameter))) |
197 |
|
; (check-key-or-optional-parameter (parameter) |
198 |
|
; (unless (or (symbolp parameter) |
199 |
|
; (and (consp parameter) |
200 |
|
; (symbolp (car parameter)))) |
201 |
|
; (lambda-list-error |
202 |
|
; "Invalid generic function parameter name: ~A" |
203 |
|
; parameter)) |
204 |
|
; (when (and (consp parameter) |
205 |
|
; (not (null (cdr parameter)))) |
206 |
|
; (lambda-list-error |
207 |
|
; "Optional and key parameters of generic functions~%~ |
208 |
|
; may not have default values or supplied-p ~ |
209 |
|
; parameters: ~A" parameter)))) |
210 |
|
; (when morep |
211 |
|
; (lambda-list-error |
212 |
|
; "&MORE not allowed in generic function lambda lists")) |
213 |
|
; (when auxp |
214 |
|
; (lambda-list-error |
215 |
|
; "&AUX not allowed in generic function lambda lists")) |
216 |
|
; (mapc #'check-required-parameter required) |
217 |
|
; (mapc #'check-key-or-optional-parameter optional) |
218 |
|
; (mapc #'check-key-or-optional-parameter keys)))) |
219 |
|
|
220 |
(defmacro defgeneric (function-specifier lambda-list &body options) |
(defmacro defgeneric (function-specifier lambda-list &body options) |
221 |
|
; (check-generic-function-lambda-list function-specifier lambda-list) |
222 |
(expand-defgeneric function-specifier lambda-list options)) |
(expand-defgeneric function-specifier lambda-list options)) |
223 |
|
|
224 |
(defun expand-defgeneric (function-specifier lambda-list options) |
(defun expand-defgeneric (function-specifier lambda-list options) |
512 |
(mapcar #'(lambda (r s) (declare (ignore s)) r) |
(mapcar #'(lambda (r s) (declare (ignore s)) r) |
513 |
parameters |
parameters |
514 |
specializers)) |
specializers)) |
515 |
|
(specialized-parameters |
516 |
|
(loop for s in specialized-lambda-list |
517 |
|
for p in required-parameters |
518 |
|
when (listp s) collect p)) |
519 |
(slots (mapcar #'list required-parameters)) |
(slots (mapcar #'list required-parameters)) |
520 |
(calls (list nil)) |
(calls (list nil)) |
|
(parameters-to-reference |
|
|
(make-parameter-references specialized-lambda-list |
|
|
required-parameters |
|
|
declarations |
|
|
method-name |
|
|
specializers)) |
|
521 |
(class-declarations |
(class-declarations |
522 |
`(declare |
`(declare |
523 |
,@(remove nil |
,@(remove nil |
535 |
;; are inserted to communicate the class of the method's |
;; are inserted to communicate the class of the method's |
536 |
;; arguments to the code walk. |
;; arguments to the code walk. |
537 |
`(lambda ,lambda-list |
`(lambda ,lambda-list |
538 |
|
(declare (ignorable ,@specialized-parameters)) |
539 |
,class-declarations |
,class-declarations |
540 |
,@declarations |
,@declarations |
|
(progn ,@parameters-to-reference) |
|
541 |
(block ,(if (listp generic-function-name) |
(block ,(if (listp generic-function-name) |
542 |
(cadr generic-function-name) |
(cadr generic-function-name) |
543 |
generic-function-name) |
generic-function-name) |
552 |
(symbol-package constant-value)))) |
(symbol-package constant-value)))) |
553 |
(list :constant-value constant-value) |
(list :constant-value constant-value) |
554 |
())) |
())) |
555 |
(applyp (dolist (p lambda-list nil) |
(walked-lambda (walk-method-lambda method-lambda |
556 |
(cond ((memq p '(&optional &rest &key)) |
required-parameters env |
557 |
(return t)) |
slots calls))) |
|
((eq p '&aux) |
|
|
(return nil)))))) |
|
|
(multiple-value-bind (walked-lambda call-next-method-p closurep |
|
|
next-method-p-p) |
|
|
(walk-method-lambda method-lambda required-parameters env |
|
|
slots calls) |
|
558 |
(multiple-value-bind (ignore walked-declarations walked-lambda-body) |
(multiple-value-bind (ignore walked-declarations walked-lambda-body) |
559 |
(extract-declarations (cddr walked-lambda)) |
(extract-declarations (cddr walked-lambda)) |
560 |
(declare (ignore ignore)) |
(declare (ignore ignore)) |
|
(when (or next-method-p-p call-next-method-p) |
|
|
(setq plist (list* :needs-next-methods-p 't plist))) |
|
561 |
(when (some #'cdr slots) |
(when (some #'cdr slots) |
562 |
(multiple-value-bind (slot-name-lists call-list) |
(multiple-value-bind (slot-name-lists call-list) |
563 |
(slot-name-lists-from-slots slots calls) |
(slot-name-lists-from-slots slots calls) |
582 |
(values `(lambda (.method-args. .next-methods.) |
(values `(lambda (.method-args. .next-methods.) |
583 |
(simple-lexical-method-functions |
(simple-lexical-method-functions |
584 |
(,lambda-list .method-args. .next-methods. |
(,lambda-list .method-args. .next-methods. |
585 |
:call-next-method-p ,call-next-method-p |
:method-name-declaration ,name-decl) |
|
:next-method-p-p ,next-method-p-p |
|
|
:closurep ,closurep |
|
|
:applyp ,applyp) |
|
586 |
,@walked-declarations |
,@walked-declarations |
587 |
,@walked-lambda-body)) |
,@walked-lambda-body)) |
588 |
`(,@(when plist |
`(,@(when plist |
612 |
(bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) |
(bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) |
613 |
,@body)))) |
,@body)))) |
614 |
|
|
615 |
|
(defun call-no-next-method (method-name-declaration &rest args) |
616 |
|
(destructuring-bind (name qualifiers specializers) |
617 |
|
(car method-name-declaration) |
618 |
|
(let ((method (find-method (gdefinition name) qualifiers specializers))) |
619 |
|
(apply #'no-next-method (method-generic-function method) method args)))) |
620 |
|
|
621 |
(defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body) |
(defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body) |
622 |
`(macrolet ((call-next-method-bind (&body body) |
`(macrolet ((call-next-method-bind (&body body) |
623 |
`(let ((.next-method. (car ,',next-methods)) |
`(let ((.next-method. (car ,',next-methods)) |
624 |
(,',next-methods (cdr ,',next-methods))) |
(,',next-methods (cdr ,',next-methods))) |
625 |
.next-method. ,',next-methods |
.next-method. ,',next-methods |
626 |
,@body)) |
,@body)) |
627 |
(call-next-method-body (cnm-args) |
(call-next-method-body (method-name-declaration cnm-args) |
628 |
`(if .next-method. |
`(if .next-method. |
629 |
(funcall (the function |
(funcall (the function |
630 |
(if (std-instance-p .next-method.) |
(if (std-instance-p .next-method.) |
632 |
.next-method.)) ; for early methods |
.next-method.)) ; for early methods |
633 |
(or ,cnm-args ,',method-args) |
(or ,cnm-args ,',method-args) |
634 |
,',next-methods) |
,',next-methods) |
635 |
(error "No next method."))) |
(apply #'call-no-next-method ',method-name-declaration |
636 |
|
(or ,cnm-args ,',method-args)))) |
637 |
(next-method-p-body () |
(next-method-p-body () |
638 |
`(not (null .next-method.)))) |
`(not (null .next-method.)))) |
639 |
,@body)) |
,@body)) |
856 |
&body body) |
&body body) |
857 |
`(macrolet ((call-next-method-bind (&body body) |
`(macrolet ((call-next-method-bind (&body body) |
858 |
`(let () ,@body)) |
`(let () ,@body)) |
859 |
(call-next-method-body (cnm-args) |
(call-next-method-body (method-name-declaration cnm-args) |
860 |
`(if ,',next-method-call |
`(if ,',next-method-call |
861 |
,(if (and (null ',rest-arg) |
,(if (and (null ',rest-arg) |
862 |
(consp cnm-args) |
(consp cnm-args) |
875 |
,cnm-args) |
,cnm-args) |
876 |
,call) |
,call) |
877 |
,call))) |
,call))) |
878 |
(error "No next method."))) |
,(if (and (null ',rest-arg) |
879 |
|
(consp cnm-args) |
880 |
|
(eq (car cnm-args) 'list)) |
881 |
|
`(call-no-next-method ',method-name-declaration |
882 |
|
,@(cdr cnm-args)) |
883 |
|
`(call-no-next-method ',method-name-declaration |
884 |
|
,@',args |
885 |
|
,@',(when rest-arg |
886 |
|
`(,rest-arg)))))) |
887 |
(next-method-p-body () |
(next-method-p-body () |
888 |
`(not (null ,',next-method-call)))) |
`(not (null ,',next-method-call)))) |
889 |
,@body)) |
,@body)) |
890 |
|
|
891 |
(defmacro bind-lexical-method-functions |
(defmacro bind-lexical-method-functions |
892 |
((&key call-next-method-p next-method-p-p closurep applyp) |
((&key method-name-declaration) ;call-next-method-p next-method-p-p closurep applyp) |
893 |
&body body) |
&body body) |
894 |
(cond ((and (null call-next-method-p) (null next-method-p-p) |
`(call-next-method-bind |
895 |
(null closurep) |
(flet ((call-next-method (&rest cnm-args) |
896 |
(null applyp)) |
(call-next-method-body ,method-name-declaration cnm-args)) |
897 |
`(let () ,@body)) |
(next-method-p () |
898 |
((and (null closurep) |
(next-method-p-body))) |
899 |
(null applyp)) |
,@body))) |
|
;; OK to use MACROLET, and all args are mandatory |
|
|
;; (else APPLYP would be true). |
|
|
`(call-next-method-bind |
|
|
(macrolet ((call-next-method (&rest cnm-args) |
|
|
`(call-next-method-body ,(when cnm-args `(list ,@cnm-args)))) |
|
|
(next-method-p () |
|
|
`(next-method-p-body))) |
|
|
,@body))) |
|
|
(t |
|
|
`(call-next-method-bind |
|
|
(flet (,@(and call-next-method-p |
|
|
'((call-next-method (&rest cnm-args) |
|
|
#+Genera |
|
|
(declare (dbg:invisible-frame :clos-internal)) |
|
|
#+copy-&rest-arg (setq args (copy-list args)) |
|
|
(call-next-method-body cnm-args)))) |
|
|
,@(and next-method-p-p |
|
|
'((next-method-p () |
|
|
(next-method-p-body))))) |
|
|
,@body))))) |
|
900 |
|
|
901 |
(defmacro bind-args ((lambda-list args) &body body) |
(defmacro bind-args ((lambda-list args) &body body) |
902 |
#|| ; Lucid and Allegro don't compile the function inline |
#|| ; Lucid and Allegro don't compile the function inline |
1048 |
(standard-generic-function-p (gdefinition name)) |
(standard-generic-function-p (gdefinition name)) |
1049 |
(funcallable-instance-p (gdefinition name))))) |
(funcallable-instance-p (gdefinition name))))) |
1050 |
|
|
|
(defun make-parameter-references (specialized-lambda-list |
|
|
required-parameters |
|
|
declarations |
|
|
method-name |
|
|
specializers) |
|
|
(flet ((ignoredp (symbol) |
|
|
(dolist (decl (cdar declarations)) |
|
|
(when (and (eq (car decl) 'ignore) |
|
|
(memq symbol (cdr decl))) |
|
|
(return t))))) |
|
|
(gathering ((references (collecting))) |
|
|
(iterate ((s (list-elements specialized-lambda-list)) |
|
|
(p (list-elements required-parameters))) |
|
|
(progn p) |
|
|
(cond ((not (listp s))) |
|
|
((ignoredp (car s)) |
|
|
(warn "In defmethod ~S, there is a~%~ |
|
|
redundant ignore declaration for the parameter ~S." |
|
|
method-name |
|
|
specializers |
|
|
(car s))) |
|
|
(t |
|
|
(gather (car s) references))))))) |
|
1051 |
|
|
1052 |
|
|
1053 |
(defvar *method-function-plist* (make-hash-table :test #'eq)) |
(defvar *method-function-plist* (make-hash-table :test #'eq)) |
1470 |
(lose "the method has ~S optional arguments than the generic function." |
(lose "the method has ~S optional arguments than the generic function." |
1471 |
(compare nopt gf-nopt))) |
(compare nopt gf-nopt))) |
1472 |
(unless (eq (or keysp restp) gf-key/rest-p) |
(unless (eq (or keysp restp) gf-key/rest-p) |
1473 |
(error "the method and generic function differ in whether they accept~%~ |
(lose "the method and generic function differ in whether they accept~%~ |
1474 |
rest or keyword arguments.")) |
rest or keyword arguments.")) |
1475 |
(when (consp gf-keywords) |
(when (consp gf-keywords) |
1476 |
(unless (or (and restp (not keysp)) |
(unless (or (and restp (not keysp)) |