[slime-cvs] CVS slime
mkoeppe
mkoeppe at common-lisp.net
Mon Jul 24 14:01:15 UTC 2006
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv26329
Modified Files:
swank.lisp
Log Message:
(find-valid-operator-name): New, factored out from
arglist-for-echo-area.
(arglist-for-echo-area): Use it here.
(print-arglist): New, factored out from decoded-arglist-to-string.
Handle recursive arglist structures that arise in destructuring
macro arglists.
(decode-required-arg, encode-required-arg): New, handle
destructuring patterns.
(decode-keyword-arg, encode-keyword-arg, decode-optional-arg)
(encode-optional-arg, decode-arglist, encode-arglist): Use them
here to handle destructuring patterns.
(print-decoded-arglist-as-template): Change interface, handle
destructuring patterns.
(decoded-arglist-to-template-string): Use it here.
(enrich-decoded-arglist-with-keywords): New, factored out from
enrich-decoded-arglist-with-extra-keywords.
(enrich-decoded-arglist-with-extra-keywords): Use it here.
(compute-enriched-decoded-arglist): New generic function, factored
out from arglist-for-insertion, form-completion. Add specialized
method for with-open-file.
(arglist-for-insertion, form-completion): Use it here.
(arglist-ref): New.
(completions-for-keyword): Change interface, handle destructuring
macro arglists.
--- /project/slime/cvsroot/slime/swank.lisp 2006/07/13 20:09:09 1.386
+++ /project/slime/cvsroot/slime/swank.lisp 2006/07/24 14:01:15 1.387
@@ -1378,18 +1378,26 @@
;;;; Arglists
+(defun find-valid-operator-name (names)
+ "As a secondary result, returns its index."
+ (let ((index
+ (position-if (lambda (name)
+ (or (consp name)
+ (valid-operator-name-p name)))
+ names)))
+ (if index
+ (values (elt names index) index)
+ (values nil nil))))
+
(defslimefun arglist-for-echo-area (names &key print-right-margin
print-lines arg-indices)
"Return the arglist for the first function, macro, or special-op in NAMES."
(handler-case
(with-buffer-syntax ()
- (let ((which (position-if (lambda (name)
- (or (consp name)
- (valid-operator-name-p name)))
- names)))
+ (multiple-value-bind (name which)
+ (find-valid-operator-name names)
(when which
- (let ((name (elt names which))
- (arg-index (and arg-indices (elt arg-indices which))))
+ (let ((arg-index (and arg-indices (elt arg-indices which))))
(multiple-value-bind (form operator-name)
(operator-designator-to-form name)
(let ((*print-right-margin* print-right-margin))
@@ -1428,6 +1436,99 @@
'())
(t (cons (car arglist) (clean-arglist (cdr arglist))))))
+(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
+ provided-args ; list of the provided actual arguments
+ required-args ; list of the required arguments
+ optional-args ; list of the optional arguments
+ key-p ; whether &key appeared
+ keyword-args ; list of the keywords
+ rest ; name of the &rest or &body argument (if any)
+ body-p ; whether the rest argument is a &body
+ allow-other-keys-p ; whether &allow-other-keys appeared
+ aux-args ; list of &aux variables
+ known-junk ; &whole, &environment
+ unknown-junk) ; unparsed stuff
+
+(defun print-arglist (arglist &key operator highlight)
+ (let ((index 0)
+ (need-space nil))
+ (labels ((print-arg (arg)
+ (etypecase arg
+ (arglist ; destructuring pattern
+ (print-arglist arg))
+ (optional-arg
+ (princ (encode-optional-arg arg)))
+ (keyword-arg
+ (let ((enc-arg (encode-keyword-arg arg)))
+ (etypecase enc-arg
+ (symbol (princ enc-arg))
+ ((cons symbol)
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (princ (car enc-arg))
+ (write-char #\space)
+ (pprint-fill *standard-output* (cdr enc-arg) nil)))
+ ((cons cons)
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (prin1 (caar enc-arg))
+ (write-char #\space)
+ (print-arg (keyword-arg.arg-name arg)))
+ (unless (null (cdr enc-arg))
+ (write-char #\space))
+ (pprint-fill *standard-output* (cdr enc-arg) nil))))))
+ (t ; required formal or provided actual arg
+ (princ arg))))
+ (print-space ()
+ (ecase need-space
+ ((nil))
+ ((:miser)
+ (write-char #\space)
+ (pprint-newline :miser))
+ ((t)
+ (write-char #\space)
+ (pprint-newline :fill)))
+ (setq need-space t))
+ (print-with-space (obj)
+ (print-space)
+ (print-arg obj))
+ (print-with-highlight (arg &optional (index-ok-p #'=))
+ (print-space)
+ (cond
+ ((and highlight (funcall index-ok-p index highlight))
+ (princ "===> ")
+ (print-arg arg)
+ (princ " <==="))
+ (t
+ (print-arg arg)))
+ (incf index)))
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (when operator
+ (print-with-highlight operator)
+ (setq need-space :miser))
+ (mapc #'print-with-highlight
+ (arglist.provided-args arglist))
+ (mapc #'print-with-highlight
+ (arglist.required-args arglist))
+ (when (arglist.optional-args arglist)
+ (print-with-space '&optional)
+ (mapc #'print-with-highlight
+ (arglist.optional-args arglist)))
+ (when (arglist.key-p arglist)
+ (print-with-space '&key)
+ (mapc #'print-with-space
+ (arglist.keyword-args arglist)))
+ (when (arglist.allow-other-keys-p arglist)
+ (print-with-space '&allow-other-keys))
+ (cond ((not (arglist.rest arglist)))
+ ((arglist.body-p arglist)
+ (print-with-space '&body)
+ (print-with-highlight (arglist.rest arglist) #'<=))
+ (t
+ (print-with-space '&rest)
+ (print-with-highlight (arglist.rest arglist) #'<=)))
+ (mapc #'print-with-space
+ (arglist.unknown-junk arglist))))))
+
(defun decoded-arglist-to-string (arglist package
&key operator print-right-margin
print-lines highlight)
@@ -1443,83 +1544,7 @@
(*print-level* 10) (*print-length* 20)
(*print-right-margin* print-right-margin)
(*print-lines* print-lines))
- (let ((index 0)
- (first-arg t))
- (labels ((print-arg (arg)
- (etypecase arg
- (symbol (princ arg))
- (string (princ arg))
- (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (princ (car arg))
- (unless (null (cdr arg))
- (write-char #\space))
- (pprint-fill *standard-output* (cdr arg) nil)))))
- (print-space ()
- (unless first-arg
- (write-char #\space)
- (pprint-newline :fill))
- (setf first-arg nil))
- (print-with-space (obj)
- (print-space)
- (print-arg obj))
- (print-keyword-arg-with-space (arg)
- (print-space)
- (etypecase arg
- (symbol (princ arg))
- ((cons symbol)
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (princ (car arg))
- (write-char #\space)
- (pprint-fill *standard-output* (cdr arg) nil)))
- ((cons cons)
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (prin1 (caar arg))
- (write-char #\space)
- (princ (cadar arg)))
- (unless (null (cdr arg))
- (write-char #\space))
- (pprint-fill *standard-output* (cdr arg) nil)))))
- (print-with-highlight (arg &optional (index-ok-p #'=)
- (print-fun #'print-arg))
- (print-space)
- (cond
- ((and highlight (funcall index-ok-p index highlight))
- (princ "===> ")
- (funcall print-fun arg)
- (princ " <==="))
- (t
- (funcall print-fun arg)))
- (incf index)))
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (when operator
- (print-with-highlight operator))
- (mapc (lambda (arg)
- (print-with-highlight arg #'= #'princ))
- (arglist.provided-args arglist))
- (mapc #'print-with-highlight
- (arglist.required-args arglist))
- (when (arglist.optional-args arglist)
- (print-with-space '&optional)
- (mapc #'print-with-highlight
- (mapcar #'encode-optional-arg
- (arglist.optional-args arglist))))
- (when (arglist.key-p arglist)
- (print-with-space '&key)
- (mapc #'print-keyword-arg-with-space
- (mapcar #'encode-keyword-arg
- (arglist.keyword-args arglist))))
- (when (arglist.allow-other-keys-p arglist)
- (print-with-space '&allow-other-keys))
- (cond ((not (arglist.rest arglist)))
- ((arglist.body-p arglist)
- (print-with-space '&body)
- (print-with-highlight (arglist.rest arglist) #'<=))
- (t
- (print-with-space '&rest)
- (print-with-highlight (arglist.rest arglist) #'<=)))
- (mapc #'print-with-space
- (arglist.unknown-junk arglist)))))))))
+ (print-arglist arglist :operator operator :highlight highlight)))))
(defslimefun variable-desc-for-echo-area (variable-name)
"Return a short description of VARIABLE-NAME, or NIL."
@@ -1530,6 +1555,17 @@
(*print-length* 10) (*print-circle* t))
(format nil "~A => ~A" sym (symbol-value sym)))))))
+(defun decode-required-arg (arg)
+ "ARG can be a symbol or a destructuring pattern."
+ (etypecase arg
+ (symbol arg)
+ (list (decode-arglist arg))))
+
+(defun encode-required-arg (arg)
+ (etypecase arg
+ (symbol arg)
+ (arglist (encode-arglist arg))))
+
(defstruct (keyword-arg
(:conc-name keyword-arg.)
(:constructor make-keyword-arg (keyword arg-name default-arg)))
@@ -1547,7 +1583,7 @@
((and (consp arg)
(consp (car arg)))
(make-keyword-arg (caar arg)
- (cadar arg)
+ (decode-required-arg (cadar arg))
(cadr arg)))
((consp arg)
(make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
@@ -1557,19 +1593,30 @@
(error "Bad keyword item of formal argument list"))))
(defun encode-keyword-arg (arg)
- (if (eql (intern (symbol-name (keyword-arg.arg-name arg))
- keyword-package)
- (keyword-arg.keyword arg))
- (if (keyword-arg.default-arg arg)
- (list (keyword-arg.arg-name arg)
- (keyword-arg.default-arg arg))
- (keyword-arg.arg-name arg))
- (let ((keyword/name (list (keyword-arg.keyword arg)
- (keyword-arg.arg-name arg))))
- (if (keyword-arg.default-arg arg)
- (list keyword/name
- (keyword-arg.default-arg arg))
- (list keyword/name)))))
+ (cond
+ ((arglist-p (keyword-arg.arg-name arg))
+ ;; Destructuring pattern
+ (let ((keyword/name (list (keyword-arg.keyword arg)
+ (encode-required-arg
+ (keyword-arg.arg-name arg)))))
+ (if (keyword-arg.default-arg arg)
+ (list keyword/name
+ (keyword-arg.default-arg arg))
+ (list keyword/name))))
+ ((eql (intern (symbol-name (keyword-arg.arg-name arg))
+ keyword-package)
+ (keyword-arg.keyword arg))
+ (if (keyword-arg.default-arg arg)
+ (list (keyword-arg.arg-name arg)
+ (keyword-arg.default-arg arg))
+ (keyword-arg.arg-name arg)))
+ (t
+ (let ((keyword/name (list (keyword-arg.keyword arg)
+ (keyword-arg.arg-name arg))))
+ (if (keyword-arg.default-arg arg)
+ (list keyword/name
+ (keyword-arg.default-arg arg))
+ (list keyword/name))))))
(progn
(assert (equalp (decode-keyword-arg 'x)
@@ -1592,11 +1639,14 @@
Return an OPTIONAL-ARG structure."
(etypecase arg
(symbol (make-optional-arg arg nil))
- (list (make-optional-arg (car arg) (cadr arg)))))
+ (list (make-optional-arg (decode-required-arg (car arg))
+ (cadr arg)))))
(defun encode-optional-arg (optional-arg)
- (if (optional-arg.default-arg optional-arg)
- (list (optional-arg.arg-name optional-arg)
+ (if (or (optional-arg.default-arg optional-arg)
+ (arglist-p (optional-arg.arg-name optional-arg)))
+ (list (encode-required-arg
+ (optional-arg.arg-name optional-arg))
(optional-arg.default-arg optional-arg))
(optional-arg.arg-name optional-arg)))
@@ -1606,19 +1656,6 @@
(assert (equalp (decode-optional-arg '(x t))
(make-optional-arg 'x t))))
-(defstruct (arglist (:conc-name arglist.))
- provided-args ; list of the provided actual arguments
- required-args ; list of the required arguments
- optional-args ; list of the optional arguments
- key-p ; whether &key appeared
- keyword-args ; list of the keywords
- rest ; name of the &rest or &body argument (if any)
- body-p ; whether the rest argument is a &body
- allow-other-keys-p ; whether &allow-other-keys appeared
- aux-args ; list of &aux variables
- known-junk ; &whole, &environment
- unknown-junk) ; unparsed stuff
-
(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
(defun decode-arglist (arglist)
@@ -1661,7 +1698,8 @@
(push (decode-optional-arg arg)
(arglist.aux-args result)))
((nil)
- (push arg (arglist.required-args result)))
+ (push (decode-required-arg arg)
+ (arglist.required-args result)))
((&whole &environment)
(setf mode nil)
(push arg (arglist.known-junk result)))))))
@@ -1674,7 +1712,7 @@
result))
(defun encode-arglist (decoded-arglist)
- (append (arglist.required-args decoded-arglist)
+ (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
(when (arglist.optional-args decoded-arglist)
'(&optional))
(mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
@@ -1739,37 +1777,48 @@
(let ((*package* package) (*print-case* :downcase)
(*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
(*print-level* 10) (*print-length* 20))
- (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
- (print-decoded-arglist-as-template decoded-arglist))))))
-
-(defun print-decoded-arglist-as-template (decoded-arglist)
- (let ((first-p t))
- (flet ((space ()
- (unless first-p
- (write-char #\space)
- (pprint-newline :fill))
- (setq first-p nil)))
- (dolist (arg (arglist.required-args decoded-arglist))
- (space)
- (princ arg))
- (dolist (arg (arglist.optional-args decoded-arglist))
- (space)
- (format t "[~A]" (optional-arg.arg-name arg)))
- (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
- (space)
- (let ((arg-name (keyword-arg.arg-name keyword-arg))
- (keyword (keyword-arg.keyword keyword-arg)))
- (format t "~W ~A"
- (if (keywordp keyword) keyword `',keyword)
- arg-name)))
- (when (and (arglist.rest decoded-arglist)
- (or (not (arglist.keyword-args decoded-arglist))
- (arglist.allow-other-keys-p decoded-arglist)))
- (if (arglist.body-p decoded-arglist)
- (pprint-newline :mandatory)
- (space))
- (format t "~A..." (arglist.rest decoded-arglist)))))
- (pprint-newline :fill))
+ (print-decoded-arglist-as-template decoded-arglist
+ :prefix prefix
+ :suffix suffix)))))
+
+(defun print-decoded-arglist-as-template (decoded-arglist &key
+ (prefix "(") (suffix ")"))
+ (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
+ (let ((first-p t))
+ (flet ((space ()
+ (unless first-p
+ (write-char #\space)
+ (pprint-newline :fill))
+ (setq first-p nil))
+ (print-arg-or-pattern (arg)
+ (etypecase arg
+ (symbol (princ arg))
+ (string (princ arg))
[256 lines skipped]
More information about the slime-cvs
mailing list