[slime-devel] [Patch] Follow-up patch for slime-complete-form
Matthias Koeppe
mkoeppe+slime at mail.math.uni-magdeburg.de
Tue Feb 22 22:20:11 UTC 2005
Hi,
I am sending below a little patch for the new slime-complete-form
functionality.
Cheers,
Matthias
2005-02-22 Matthias Koeppe <mkoeppe at mail.math.uni-magdeburg.de>
* swank.lisp (print-decoded-arglist-as-template): If keyword is
not a keyword symbol, quote it in the template.
(extra-keywords): Return a secondary value (allow-other-keys).
For make-instance, try to finalize the class if it is not
finalized yet (fix for Allegro CL 6.2). If class is not
finalizable, use direct slots instead of slots and indicate that
the keywords are not complete.
(enrich-decoded-arglist-with-extra-keywords): New function, use
the secondary value of extra-keywords.
(arglist-for-insertion, complete-form): Use it here.
* swank-backend.lisp (:swank-mop package): Export
finalize-inheritance.
Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.79
diff -u -p -r1.79 swank-backend.lisp
--- swank-backend.lisp 20 Feb 2005 20:20:39 -0000 1.79
+++ swank-backend.lisp 22 Feb 2005 22:12:32 -0000
@@ -83,7 +83,8 @@
#:slot-definition-readers
#:slot-definition-writers
;; generic function protocol
- #:compute-applicable-methods-using-classes))
+ #:compute-applicable-methods-using-classes
+ #:finalize-inheritance))
(in-package :swank-backend)
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.280
diff -u -p -r1.280 swank.lisp
--- swank.lisp 20 Feb 2005 20:29:14 -0000 1.280
+++ swank.lisp 22 Feb 2005 22:12:34 -0000
@@ -1327,7 +1327,9 @@ whether &allow-other-keys appears somewh
(format t "[~A]" arg))
(dolist (keyword (arglist.keyword-args decoded-arglist))
(space)
- (format t "~W ~A" keyword keyword))
+ (format t "~W ~A"
+ (if (keywordp keyword) keyword `',keyword)
+ keyword))
(when (and (arglist.rest decoded-arglist)
(or (not (arglist.keyword-args decoded-arglist))
(arglist.allow-other-keys-p decoded-arglist)))
@@ -1338,8 +1340,9 @@ whether &allow-other-keys appears somewh
(pprint-newline :fill))
(defgeneric extra-keywords (operator &rest args)
- (:documentation "Return a list of extra keywords of OPERATOR (a symbol)
-when applied to the (unevaluated) ARGS."))
+ (:documentation "Return a list of extra keywords of OPERATOR (a
+symbol) when applied to the (unevaluated) ARGS. As a secondary value,
+return whether other keys are allowed."))
(defmethod extra-keywords (operator &rest args)
;; default method
@@ -1358,20 +1361,44 @@ when applied to the (unevaluated) ARGS."
(eq (car class-name-form) 'quote))
(let* ((class-name (cadr class-name-form))
(class (find-class class-name nil)))
+ (unless (swank-mop:class-finalized-p class)
+ ;; Try to finalize the class, which can fail if
+ ;; superclasses are not defined yet
+ (handler-case (swank-mop:finalize-inheritance class)
+ (program-error (c)
+ (declare (ignore c)))))
(when class
;; We have the case (make-instance 'CLASS ...)
;; with a known CLASS.
- (let ((slot-init-keywords
- (loop for slot in (swank-mop:class-slots class)
- append (swank-mop:slot-definition-initargs slot)))
- (initialize-instance-keywords
- (applicable-methods-keywords #'initialize-instance
- (list class))))
- (return-from extra-keywords
- (append slot-init-keywords
- initialize-instance-keywords))))))))
+ (multiple-value-bind (slots allow-other-keys-p)
+ (if (swank-mop:class-finalized-p class)
+ (values (swank-mop:class-slots class) nil)
+ (values (swank-mop:class-direct-slots class) t))
+ (let ((slot-init-keywords
+ (loop for slot in slots
+ append (swank-mop:slot-definition-initargs slot)))
+ (initialize-instance-keywords
+ (applicable-methods-keywords #'initialize-instance
+ (list class))))
+ (return-from extra-keywords
+ (values (append slot-init-keywords
+ initialize-instance-keywords)
+ allow-other-keys-p)))))))))
(call-next-method))
+(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
+ (multiple-value-bind (extra-keywords extra-aok)
+ (apply #'extra-keywords form)
+ (with-str
+ ;; enrich the list of keywords with the extra keywords
+ (setf (arglist.keyword-args decoded-arglist)
+ (remove-duplicates
+ (append (arglist.keyword-args decoded-arglist)
+ extra-keywords)))
+ (setf (arglist.allow-other-keys-p decoded-arglist)
+ (or (arglist.allow-other-keys-p decoded-arglist) extra-aok)))
+ decoded-arglist)
+
(defslimefun arglist-for-insertion (name)
(with-buffer-syntax ()
(let ((symbol (parse-symbol name)))
@@ -1383,13 +1410,9 @@ when applied to the (unevaluated) ARGS."
((member :not-available)
:not-available)
(list
- (let ((decoded-arglist (decode-arglist arglist))
- (extra-keywords (extra-keywords symbol)))
- ;; enrich the list of keywords with the extra keywords
- (setf (arglist.keyword-args decoded-arglist)
- (remove-duplicates
- (append (arglist.keyword-args decoded-arglist)
- extra-keywords)))
+ (let ((decoded-arglist (decode-arglist arglist)))
+ (enrich-decoded-arglist-with-extra-keywords decoded-arglist
+ (list symbol))
(decoded-arglist-to-template-string decoded-arglist
*buffer-package*))))))
(t
@@ -1426,13 +1449,8 @@ by adding a template for the missing arg
((member :not-available)
:not-available)
(list
- (let ((decoded-arglist (decode-arglist arglist))
- (extra-keywords (apply #'extra-keywords form)))
- ;; enrich the list of keywords with the extra keywords
- (setf (arglist.keyword-args decoded-arglist)
- (remove-duplicates
- (append (arglist.keyword-args decoded-arglist)
- extra-keywords)))
+ (let ((decoded-arglist (decode-arglist arglist)))
+ (enrich-decoded-arglist-with-extra-keywords decoded-arglist form)
;; get rid of formal args already provided
(remove-actual-args decoded-arglist argument-forms)
(return-from complete-form
--
Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe
More information about the slime-devel
mailing list