/[slime]/slime/contrib/swank-arglists.lisp
ViewVC logotype

Contents of /slime/contrib/swank-arglists.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.75 - (show annotations)
Mon Aug 13 20:50:34 2012 UTC (20 months, 1 week ago) by sboukarev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.74: +8 -7 lines
* swank-arglists.lisp (extra-keywords/slots): Check for
slot-definition-initfunction being present before calling
slot-definition-initform.
1 ;;; swank-arglists.lisp --- arglist related code ??
2 ;;
3 ;; Authors: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
4 ;; Tobias C. Rittweiler <tcr@freebits.de>
5 ;; and others
6 ;;
7 ;; License: Public Domain
8 ;;
9
10 (in-package :swank)
11
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13 (swank-require :swank-c-p-c))
14
15 ;;;; Utilities
16
17 (defun compose (&rest functions)
18 "Compose FUNCTIONS right-associatively, returning a function"
19 #'(lambda (x)
20 (reduce #'funcall functions :initial-value x :from-end t)))
21
22 (defun length= (seq n)
23 "Test for whether SEQ contains N number of elements. I.e. it's equivalent
24 to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
25 efficiently implemented."
26 (etypecase seq
27 (list (do ((i n (1- i))
28 (list seq (cdr list)))
29 ((or (<= i 0) (null list))
30 (and (zerop i) (null list)))))
31 (sequence (= (length seq) n))))
32
33 (declaim (inline memq))
34 (defun memq (item list)
35 (member item list :test #'eq))
36
37 (defun exactly-one-p (&rest values)
38 "If exactly one value in VALUES is non-NIL, this value is returned.
39 Otherwise NIL is returned."
40 (let ((found nil))
41 (dolist (v values)
42 (when v (if found
43 (return-from exactly-one-p nil)
44 (setq found v))))
45 found))
46
47 (defun valid-operator-symbol-p (symbol)
48 "Is SYMBOL the name of a function, a macro, or a special-operator?"
49 (or (fboundp symbol)
50 (macro-function symbol)
51 (special-operator-p symbol)
52 (member symbol '(declare declaim))))
53
54 (defun function-exists-p (form)
55 (and (valid-function-name-p form)
56 (fboundp form)
57 t))
58
59 (defmacro multiple-value-or (&rest forms)
60 (if (null forms)
61 nil
62 (let ((first (first forms))
63 (rest (rest forms)))
64 `(let* ((values (multiple-value-list ,first))
65 (primary-value (first values)))
66 (if primary-value
67 (values-list values)
68 (multiple-value-or ,@rest))))))
69
70 (defun arglist-available-p (arglist)
71 (not (eql arglist :not-available)))
72
73 (defmacro with-available-arglist ((var &rest more-vars) form &body body)
74 `(multiple-value-bind (,var ,@more-vars) ,form
75 (if (eql ,var :not-available)
76 :not-available
77 (progn ,@body))))
78
79
80 ;;;; Arglist Definition
81
82 (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
83 provided-args ; list of the provided actual arguments
84 required-args ; list of the required arguments
85 optional-args ; list of the optional arguments
86 key-p ; whether &key appeared
87 keyword-args ; list of the keywords
88 rest ; name of the &rest or &body argument (if any)
89 body-p ; whether the rest argument is a &body
90 allow-other-keys-p ; whether &allow-other-keys appeared
91 aux-args ; list of &aux variables
92 any-p ; whether &any appeared
93 any-args ; list of &any arguments [*]
94 known-junk ; &whole, &environment
95 unknown-junk) ; unparsed stuff
96
97 ;;;
98 ;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp,
99 ;;; and is only used to describe certain arglists that cannot be
100 ;;; described in another way.
101 ;;;
102 ;;; &ANY is very similiar to &KEY but while &KEY is based upon
103 ;;; the idea of a plist (key1 value1 key2 value2), &ANY is a
104 ;;; cross between &OPTIONAL, &KEY and *FEATURES* lists:
105 ;;;
106 ;;; a) (&ANY :A :B :C) means that you can provide any (non-null)
107 ;;; set consisting of the keywords `:A', `:B', or `:C' in
108 ;;; the arglist. E.g. (:A) or (:C :B :A).
109 ;;;
110 ;;; (This is not restricted to keywords only, but any self-evaluating
111 ;;; expression is allowed.)
112 ;;;
113 ;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can
114 ;;; provide any (non-null) set consisting of lists where
115 ;;; the CAR of the list is one of `key1', `key2', or `key3'.
116 ;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23))
117 ;;;
118 ;;;
119 ;;; For example, a) let us describe the situations of EVAL-WHEN as
120 ;;;
121 ;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body)
122 ;;;
123 ;;; and b) let us describe the optimization qualifiers that are valid
124 ;;; in the declaration specifier `OPTIMIZE':
125 ;;;
126 ;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...))
127 ;;;
128
129 ;; This is a wrapper object around anything that came from Slime and
130 ;; could not reliably be read.
131 (defstruct (arglist-dummy
132 (:conc-name #:arglist-dummy.)
133 (:constructor make-arglist-dummy (string-representation)))
134 string-representation)
135
136 (defun empty-arg-p (dummy)
137 (and (arglist-dummy-p dummy)
138 (zerop (length (arglist-dummy.string-representation dummy)))))
139
140 (eval-when (:compile-toplevel :load-toplevel :execute)
141 (defparameter +lambda-list-keywords+
142 '(&provided &required &optional &rest &key &any)))
143
144 (defmacro do-decoded-arglist (decoded-arglist &body clauses)
145 (assert (loop for clause in clauses
146 thereis (member (car clause) +lambda-list-keywords+)))
147 (flet ((parse-clauses (clauses)
148 (let* ((size (length +lambda-list-keywords+))
149 (initial (make-hash-table :test #'eq :size size))
150 (main (make-hash-table :test #'eq :size size))
151 (final (make-hash-table :test #'eq :size size)))
152 (loop for clause in clauses
153 for lambda-list-keyword = (first clause)
154 for clause-parameter = (second clause)
155 do
156 (case clause-parameter
157 (:initially
158 (setf (gethash lambda-list-keyword initial) clause))
159 (:finally
160 (setf (gethash lambda-list-keyword final) clause))
161 (t
162 (setf (gethash lambda-list-keyword main) clause)))
163 finally
164 (return (values initial main final)))))
165 (generate-main-clause (clause arglist)
166 (destructure-case clause
167 ((&provided (&optional arg) . body)
168 (let ((gensym (gensym "PROVIDED-ARG+")))
169 `(dolist (,gensym (arglist.provided-args ,arglist))
170 (declare (ignorable ,gensym))
171 (let (,@(when arg `((,arg ,gensym))))
172 ,@body))))
173 ((&required (&optional arg) . body)
174 (let ((gensym (gensym "REQUIRED-ARG+")))
175 `(dolist (,gensym (arglist.required-args ,arglist))
176 (declare (ignorable ,gensym))
177 (let (,@(when arg `((,arg ,gensym))))
178 ,@body))))
179 ((&optional (&optional arg init) . body)
180 (let ((optarg (gensym "OPTIONAL-ARG+")))
181 `(dolist (,optarg (arglist.optional-args ,arglist))
182 (declare (ignorable ,optarg))
183 (let (,@(when arg
184 `((,arg (optional-arg.arg-name ,optarg))))
185 ,@(when init
186 `((,init (optional-arg.default-arg ,optarg)))))
187 ,@body))))
188 ((&key (&optional keyword arg init) . body)
189 (let ((keyarg (gensym "KEY-ARG+")))
190 `(dolist (,keyarg (arglist.keyword-args ,arglist))
191 (declare (ignorable ,keyarg))
192 (let (,@(when keyword
193 `((,keyword (keyword-arg.keyword ,keyarg))))
194 ,@(when arg
195 `((,arg (keyword-arg.arg-name ,keyarg))))
196 ,@(when init
197 `((,init (keyword-arg.default-arg ,keyarg)))))
198 ,@body))))
199 ((&rest (&optional arg body-p) . body)
200 `(when (arglist.rest ,arglist)
201 (let (,@(when arg `((,arg (arglist.rest ,arglist))))
202 ,@(when body-p `((,body-p (arglist.body-p ,arglist)))))
203 ,@body)))
204 ((&any (&optional arg) . body)
205 (let ((gensym (gensym "REQUIRED-ARG+")))
206 `(dolist (,gensym (arglist.any-args ,arglist))
207 (declare (ignorable ,gensym))
208 (let (,@(when arg `((,arg ,gensym))))
209 ,@body)))))))
210 (let ((arglist (gensym "DECODED-ARGLIST+")))
211 (multiple-value-bind (initially-clauses main-clauses finally-clauses)
212 (parse-clauses clauses)
213 `(let ((,arglist ,decoded-arglist))
214 (block do-decoded-arglist
215 ,@(loop for keyword in '(&provided &required
216 &optional &rest &key &any)
217 append (cddr (gethash keyword initially-clauses))
218 collect (let ((clause (gethash keyword main-clauses)))
219 (when clause
220 (generate-main-clause clause arglist)))
221 append (cddr (gethash keyword finally-clauses)))))))))
222
223 ;;;; Arglist Printing
224
225 (defun undummy (x)
226 (if (typep x 'arglist-dummy)
227 (arglist-dummy.string-representation x)
228 (prin1-to-string x)))
229
230 (defun print-decoded-arglist (arglist &key operator provided-args highlight)
231 (macrolet ((space ()
232 ;; Kludge: When OPERATOR is not given, we don't want to
233 ;; print a space for the first argument.
234 `(if (not operator)
235 (setq operator t)
236 (progn (write-char #\space)
237 (pprint-newline :fill))))
238 (with-highlighting ((&key index) &body body)
239 `(if (eql ,index (car highlight))
240 (progn (princ "===> ") ,@body (princ " <==="))
241 (progn ,@body)))
242 (print-arglist-recursively (argl &key index)
243 `(if (eql ,index (car highlight))
244 (print-decoded-arglist ,argl :highlight (cdr highlight))
245 (print-decoded-arglist ,argl))))
246 (let ((index 0))
247 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
248 (when operator
249 (print-arg operator)
250 (pprint-indent :current 1)) ; 1 due to possibly added space
251 (do-decoded-arglist (remove-given-args arglist provided-args)
252 (&provided (arg)
253 (space)
254 (print-arg arg)
255 (incf index))
256 (&required (arg)
257 (space)
258 (if (arglist-p arg)
259 (print-arglist-recursively arg :index index)
260 (with-highlighting (:index index)
261 (print-arg arg)))
262 (incf index))
263 (&optional :initially
264 (when (arglist.optional-args arglist)
265 (space)
266 (princ '&optional)))
267 (&optional (arg init-value)
268 (space)
269 (if (arglist-p arg)
270 (print-arglist-recursively arg :index index)
271 (with-highlighting (:index index)
272 (if (null init-value)
273 (print-arg arg)
274 (format t "~:@<~A ~A~@:>"
275 (undummy arg) (undummy init-value)))))
276 (incf index))
277 (&key :initially
278 (when (arglist.key-p arglist)
279 (space)
280 (princ '&key)))
281 (&key (keyword arg init)
282 (space)
283 (if (arglist-p arg)
284 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
285 (prin1 keyword) (space)
286 (print-arglist-recursively arg :index keyword))
287 (with-highlighting (:index keyword)
288 (cond ((and init (keywordp keyword))
289 (format t "~:@<~A ~A~@:>" keyword (undummy init)))
290 (init
291 (format t "~:@<(~A ..) ~A~@:>"
292 (undummy keyword) (undummy init)))
293 ((not (keywordp keyword))
294 (format t "~:@<(~S ..)~@:>" keyword))
295 (t
296 (princ keyword))))))
297 (&key :finally
298 (when (arglist.allow-other-keys-p arglist)
299 (space)
300 (princ '&allow-other-keys)))
301 (&any :initially
302 (when (arglist.any-p arglist)
303 (space)
304 (princ '&any)))
305 (&any (arg)
306 (space)
307 (print-arg arg))
308 (&rest (args bodyp)
309 (space)
310 (princ (if bodyp '&body '&rest))
311 (space)
312 (if (arglist-p args)
313 (print-arglist-recursively args :index index)
314 (with-highlighting (:index index)
315 (print-arg args))))
316 ;; FIXME: add &UNKNOWN-JUNK?
317 )))))
318
319 (defun print-arg (arg)
320 (let ((arg (if (arglist-dummy-p arg)
321 (arglist-dummy.string-representation arg)
322 arg)))
323 (if (keywordp arg)
324 (prin1 arg)
325 (princ arg))))
326
327 (defun print-decoded-arglist-as-template (decoded-arglist &key
328 (prefix "(") (suffix ")"))
329 (let ((first-p t))
330 (flet ((space ()
331 (unless first-p
332 (write-char #\space))
333 (setq first-p nil))
334 (print-arg-or-pattern (arg)
335 (etypecase arg
336 (symbol (if (keywordp arg) (prin1 arg) (princ arg)))
337 (string (princ arg))
338 (list (princ arg))
339 (arglist-dummy (princ
340 (arglist-dummy.string-representation arg)))
341 (arglist (print-decoded-arglist-as-template arg)))
342 (pprint-newline :fill)))
343 (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
344 (do-decoded-arglist decoded-arglist
345 (&provided ()) ; do nothing; provided args are in the buffer already.
346 (&required (arg)
347 (space) (print-arg-or-pattern arg))
348 (&optional (arg)
349 (space) (princ "[") (print-arg-or-pattern arg) (princ "]"))
350 (&key (keyword arg)
351 (space)
352 (prin1 (if (keywordp keyword) keyword `',keyword))
353 (space)
354 (print-arg-or-pattern arg)
355 (pprint-newline :linear))
356 (&any (arg)
357 (space) (print-arg-or-pattern arg))
358 (&rest (args)
359 (when (or (not (arglist.keyword-args decoded-arglist))
360 (arglist.allow-other-keys-p decoded-arglist))
361 (space)
362 (format t "~A..." args))))))))
363
364 (defvar *arglist-pprint-bindings*
365 '((*print-case* . :downcase)
366 (*print-pretty* . t)
367 (*print-circle* . nil)
368 (*print-readably* . nil)
369 (*print-level* . 10)
370 (*print-length* . 20)
371 (*print-escape* . nil)))
372
373 (defvar *arglist-show-packages* t)
374
375 (defmacro with-arglist-io-syntax (&body body)
376 (let ((package (gensym)))
377 `(let ((,package *package*))
378 (with-standard-io-syntax
379 (let ((*package* (if *arglist-show-packages*
380 *package*
381 ,package)))
382 (with-bindings *arglist-pprint-bindings*
383 ,@body))))))
384
385 (defun decoded-arglist-to-string (decoded-arglist
386 &key operator highlight
387 print-right-margin)
388 (with-output-to-string (*standard-output*)
389 (with-arglist-io-syntax
390 (let ((*print-right-margin* print-right-margin))
391 (print-decoded-arglist decoded-arglist
392 :operator operator
393 :highlight highlight)))))
394
395 (defun decoded-arglist-to-template-string (decoded-arglist
396 &key (prefix "(") (suffix ")"))
397 (with-output-to-string (*standard-output*)
398 (with-arglist-io-syntax
399 (print-decoded-arglist-as-template decoded-arglist
400 :prefix prefix
401 :suffix suffix))))
402
403 ;;;; Arglist Decoding / Encoding
404
405 (defun decode-required-arg (arg)
406 "ARG can be a symbol or a destructuring pattern."
407 (etypecase arg
408 (symbol arg)
409 (arglist-dummy arg)
410 (list (decode-arglist arg))))
411
412 (defun encode-required-arg (arg)
413 (etypecase arg
414 (symbol arg)
415 (arglist (encode-arglist arg))))
416
417 (defstruct (keyword-arg
418 (:conc-name keyword-arg.)
419 (:constructor make-keyword-arg (keyword arg-name default-arg)))
420 keyword
421 arg-name
422 default-arg)
423
424 (defun decode-keyword-arg (arg)
425 "Decode a keyword item of formal argument list.
426 Return three values: keyword, argument name, default arg."
427 (flet ((intern-as-keyword (arg)
428 (intern (etypecase arg
429 (symbol (symbol-name arg))
430 (arglist-dummy (arglist-dummy.string-representation arg)))
431 keyword-package)))
432 (cond ((or (symbolp arg) (arglist-dummy-p arg))
433 (make-keyword-arg (intern-as-keyword arg) arg nil))
434 ((and (consp arg)
435 (consp (car arg)))
436 (make-keyword-arg (caar arg)
437 (decode-required-arg (cadar arg))
438 (cadr arg)))
439 ((consp arg)
440 (make-keyword-arg (intern-as-keyword (car arg))
441 (car arg) (cadr arg)))
442 (t
443 (error "Bad keyword item of formal argument list")))))
444
445 (defun encode-keyword-arg (arg)
446 (cond
447 ((arglist-p (keyword-arg.arg-name arg))
448 ;; Destructuring pattern
449 (let ((keyword/name (list (keyword-arg.keyword arg)
450 (encode-required-arg
451 (keyword-arg.arg-name arg)))))
452 (if (keyword-arg.default-arg arg)
453 (list keyword/name
454 (keyword-arg.default-arg arg))
455 (list keyword/name))))
456 ((eql (intern (symbol-name (keyword-arg.arg-name arg))
457 keyword-package)
458 (keyword-arg.keyword arg))
459 (if (keyword-arg.default-arg arg)
460 (list (keyword-arg.arg-name arg)
461 (keyword-arg.default-arg arg))
462 (keyword-arg.arg-name arg)))
463 (t
464 (let ((keyword/name (list (keyword-arg.keyword arg)
465 (keyword-arg.arg-name arg))))
466 (if (keyword-arg.default-arg arg)
467 (list keyword/name
468 (keyword-arg.default-arg arg))
469 (list keyword/name))))))
470
471 (progn
472 (assert (equalp (decode-keyword-arg 'x)
473 (make-keyword-arg :x 'x nil)))
474 (assert (equalp (decode-keyword-arg '(x t))
475 (make-keyword-arg :x 'x t)))
476 (assert (equalp (decode-keyword-arg '((:x y)))
477 (make-keyword-arg :x 'y nil)))
478 (assert (equalp (decode-keyword-arg '((:x y) t))
479 (make-keyword-arg :x 'y t))))
480
481 ;;; FIXME suppliedp?
482 (defstruct (optional-arg
483 (:conc-name optional-arg.)
484 (:constructor make-optional-arg (arg-name default-arg)))
485 arg-name
486 default-arg)
487
488 (defun decode-optional-arg (arg)
489 "Decode an optional item of a formal argument list.
490 Return an OPTIONAL-ARG structure."
491 (etypecase arg
492 (symbol (make-optional-arg arg nil))
493 (arglist-dummy (make-optional-arg arg nil))
494 (list (make-optional-arg (decode-required-arg (car arg))
495 (cadr arg)))))
496
497 (defun encode-optional-arg (optional-arg)
498 (if (or (optional-arg.default-arg optional-arg)
499 (arglist-p (optional-arg.arg-name optional-arg)))
500 (list (encode-required-arg
501 (optional-arg.arg-name optional-arg))
502 (optional-arg.default-arg optional-arg))
503 (optional-arg.arg-name optional-arg)))
504
505 (progn
506 (assert (equalp (decode-optional-arg 'x)
507 (make-optional-arg 'x nil)))
508 (assert (equalp (decode-optional-arg '(x t))
509 (make-optional-arg 'x t))))
510
511 (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
512
513 (defun decode-arglist (arglist)
514 "Parse the list ARGLIST and return an ARGLIST structure."
515 (etypecase arglist
516 ((eql :not-available) (return-from decode-arglist
517 :not-available))
518 (list))
519 (loop
520 with mode = nil
521 with result = (make-arglist)
522 for arg = (if (consp arglist)
523 (pop arglist)
524 (progn
525 (prog1 arglist
526 (setf mode '&rest
527 arglist nil))))
528 do (cond
529 ((eql mode '&unknown-junk)
530 ;; don't leave this mode -- we don't know how the arglist
531 ;; after unknown lambda-list keywords is interpreted
532 (push arg (arglist.unknown-junk result)))
533 ((eql arg '&allow-other-keys)
534 (setf (arglist.allow-other-keys-p result) t))
535 ((eql arg '&key)
536 (setf (arglist.key-p result) t
537 mode arg))
538 ((memq arg '(&optional &rest &body &aux))
539 (setq mode arg))
540 ((memq arg '(&whole &environment))
541 (setq mode arg)
542 (push arg (arglist.known-junk result)))
543 ((and (symbolp arg)
544 (string= (symbol-name arg) (string '#:&any))) ; may be interned
545 (setf (arglist.any-p result) t) ; in any *package*.
546 (setq mode '&any))
547 ((memq arg lambda-list-keywords)
548 (setq mode '&unknown-junk)
549 (push arg (arglist.unknown-junk result)))
550 (t
551 (ecase mode
552 (&key
553 (push (decode-keyword-arg arg)
554 (arglist.keyword-args result)))
555 (&optional
556 (push (decode-optional-arg arg)
557 (arglist.optional-args result)))
558 (&body
559 (setf (arglist.body-p result) t
560 (arglist.rest result) arg))
561 (&rest
562 (setf (arglist.rest result) arg))
563 (&aux
564 (push (decode-optional-arg arg)
565 (arglist.aux-args result)))
566 ((nil)
567 (push (decode-required-arg arg)
568 (arglist.required-args result)))
569 ((&whole &environment)
570 (setf mode nil)
571 (push arg (arglist.known-junk result)))
572 (&any
573 (push arg (arglist.any-args result))))))
574 until (null arglist)
575 finally (nreversef (arglist.required-args result))
576 finally (nreversef (arglist.optional-args result))
577 finally (nreversef (arglist.keyword-args result))
578 finally (nreversef (arglist.aux-args result))
579 finally (nreversef (arglist.any-args result))
580 finally (nreversef (arglist.known-junk result))
581 finally (nreversef (arglist.unknown-junk result))
582 finally (assert (or (and (not (arglist.key-p result))
583 (not (arglist.any-p result)))
584 (exactly-one-p (arglist.key-p result)
585 (arglist.any-p result))))
586 finally (return result)))
587
588 (defun encode-arglist (decoded-arglist)
589 (append (mapcar #'encode-required-arg
590 (arglist.required-args decoded-arglist))
591 (when (arglist.optional-args decoded-arglist)
592 '(&optional))
593 (mapcar #'encode-optional-arg
594 (arglist.optional-args decoded-arglist))
595 (when (arglist.key-p decoded-arglist)
596 '(&key))
597 (mapcar #'encode-keyword-arg
598 (arglist.keyword-args decoded-arglist))
599 (when (arglist.allow-other-keys-p decoded-arglist)
600 '(&allow-other-keys))
601 (when (arglist.any-args decoded-arglist)
602 `(&any ,@(arglist.any-args decoded-arglist)))
603 (cond ((not (arglist.rest decoded-arglist))
604 '())
605 ((arglist.body-p decoded-arglist)
606 `(&body ,(arglist.rest decoded-arglist)))
607 (t
608 `(&rest ,(arglist.rest decoded-arglist))))
609 (when (arglist.aux-args decoded-arglist)
610 `(&aux ,(arglist.aux-args decoded-arglist)))
611 (arglist.known-junk decoded-arglist)
612 (arglist.unknown-junk decoded-arglist)))
613
614 ;;;; Arglist Enrichment
615
616 (defun arglist-keywords (lambda-list)
617 "Return the list of keywords in ARGLIST.
618 As a secondary value, return whether &allow-other-keys appears."
619 (let ((decoded-arglist (decode-arglist lambda-list)))
620 (values (arglist.keyword-args decoded-arglist)
621 (arglist.allow-other-keys-p decoded-arglist))))
622
623
624 (defun methods-keywords (methods)
625 "Collect all keywords in the arglists of METHODS.
626 As a secondary value, return whether &allow-other-keys appears somewhere."
627 (let ((keywords '())
628 (allow-other-keys nil))
629 (dolist (method methods)
630 (multiple-value-bind (kw aok)
631 (arglist-keywords
632 (swank-mop:method-lambda-list method))
633 (setq keywords (remove-duplicates (append keywords kw)
634 :key #'keyword-arg.keyword)
635 allow-other-keys (or allow-other-keys aok))))
636 (values keywords allow-other-keys)))
637
638 (defun generic-function-keywords (generic-function)
639 "Collect all keywords in the methods of GENERIC-FUNCTION.
640 As a secondary value, return whether &allow-other-keys appears somewhere."
641 (methods-keywords
642 (swank-mop:generic-function-methods generic-function)))
643
644 (defun applicable-methods-keywords (generic-function arguments)
645 "Collect all keywords in the methods of GENERIC-FUNCTION that are
646 applicable for argument of CLASSES. As a secondary value, return
647 whether &allow-other-keys appears somewhere."
648 (methods-keywords
649 (multiple-value-bind (amuc okp)
650 (swank-mop:compute-applicable-methods-using-classes
651 generic-function (mapcar #'class-of arguments))
652 (if okp
653 amuc
654 (compute-applicable-methods generic-function arguments)))))
655
656 (defgeneric extra-keywords (operator &rest args)
657 (:documentation "Return a list of extra keywords of OPERATOR (a
658 symbol) when applied to the (unevaluated) ARGS.
659 As a secondary value, return whether other keys are allowed.
660 As a tertiary value, return the initial sublist of ARGS that was needed
661 to determine the extra keywords."))
662
663 ;;; We make sure that symbol-from-KEYWORD-using keywords come before
664 ;;; symbol-from-arbitrary-package-using keywords. And we sort the
665 ;;; latter according to how their home-packages relate to *PACKAGE*.
666 ;;;
667 ;;; Rationale is to show those key parameters first which make most
668 ;;; sense in the current context. And in particular: to put
669 ;;; implementation-internal stuff last.
670 ;;;
671 ;;; This matters tremendeously on Allegro in combination with
672 ;;; AllegroCache as that does some evil tinkering with initargs,
673 ;;; obfuscating the arglist of MAKE-INSTANCE.
674 ;;;
675
676 (defmethod extra-keywords :around (op &rest args)
677 (declare (ignorable op args))
678 (multiple-value-bind (keywords aok enrichments) (call-next-method)
679 (values (sort-extra-keywords keywords) aok enrichments)))
680
681 (defun make-package-comparator (reference-packages)
682 "Returns a two-argument test function which compares packages
683 according to their used-by relation with REFERENCE-PACKAGES. Packages
684 will be sorted first which appear first in the PACKAGE-USE-LIST of the
685 reference packages."
686 (let ((package-use-table (make-hash-table :test 'eq)))
687 ;; Walk the package dependency graph breadth-fist, and fill
688 ;; PACKAGE-USE-TABLE accordingly.
689 (loop with queue = (copy-list reference-packages)
690 with bfn = 0 ; Breadth-First Number
691 for p = (pop queue)
692 unless (gethash p package-use-table)
693 do (setf (gethash p package-use-table) (shiftf bfn (1+ bfn)))
694 and do (setf queue (nconc queue (copy-list (package-use-list p))))
695 while queue)
696 #'(lambda (p1 p2)
697 (let ((bfn1 (gethash p1 package-use-table))
698 (bfn2 (gethash p2 package-use-table)))
699 (cond ((and bfn1 bfn2) (<= bfn1 bfn2))
700 (bfn1 bfn1)
701 (bfn2 nil) ; p2 is used, p1 not
702 (t (string<= (package-name p1) (package-name p2))))))))
703
704 (defun sort-extra-keywords (kwds)
705 (stable-sort kwds (make-package-comparator (list keyword-package *package*))
706 :key (compose #'symbol-package #'keyword-arg.keyword)))
707
708 (defun keywords-of-operator (operator)
709 "Return a list of KEYWORD-ARGs that OPERATOR accepts.
710 This function is useful for writing EXTRA-KEYWORDS methods for
711 user-defined functions which are declared &ALLOW-OTHER-KEYS and which
712 forward keywords to OPERATOR."
713 (with-available-arglist (arglist) (arglist-from-form (ensure-list operator))
714 (values (arglist.keyword-args arglist)
715 (arglist.allow-other-keys-p arglist))))
716
717 (defmethod extra-keywords (operator &rest args)
718 ;; default method
719 (declare (ignore args))
720 (let ((symbol-function (symbol-function operator)))
721 (if (typep symbol-function 'generic-function)
722 (generic-function-keywords symbol-function)
723 nil)))
724
725 (defun class-from-class-name-form (class-name-form)
726 (when (and (listp class-name-form)
727 (= (length class-name-form) 2)
728 (eq (car class-name-form) 'quote))
729 (let* ((class-name (cadr class-name-form))
730 (class (find-class class-name nil)))
731 (when (and class
732 (not (swank-mop:class-finalized-p class)))
733 ;; Try to finalize the class, which can fail if
734 ;; superclasses are not defined yet
735 (handler-case (swank-mop:finalize-inheritance class)
736 (program-error (c)
737 (declare (ignore c)))))
738 class)))
739
740 (defun extra-keywords/slots (class)
741 (multiple-value-bind (slots allow-other-keys-p)
742 (if (swank-mop:class-finalized-p class)
743 (values (swank-mop:class-slots class) nil)
744 (values (swank-mop:class-direct-slots class) t))
745 (let ((slot-init-keywords
746 (loop for slot in slots append
747 (mapcar (lambda (initarg)
748 (make-keyword-arg
749 initarg
750 (swank-mop:slot-definition-name slot)
751 (and (swank-mop:slot-definition-initfunction slot)
752 (swank-mop:slot-definition-initform slot))))
753 (swank-mop:slot-definition-initargs slot)))))
754 (values slot-init-keywords allow-other-keys-p))))
755
756 (defun extra-keywords/make-instance (operator &rest args)
757 (declare (ignore operator))
758 (unless (null args)
759 (let* ((class-name-form (car args))
760 (class (class-from-class-name-form class-name-form)))
761 (when class
762 (multiple-value-bind (slot-init-keywords class-aokp)
763 (extra-keywords/slots class)
764 (multiple-value-bind (allocate-instance-keywords ai-aokp)
765 (applicable-methods-keywords
766 #'allocate-instance (list class))
767 (multiple-value-bind (initialize-instance-keywords ii-aokp)
768 (ignore-errors
769 (applicable-methods-keywords
770 #'initialize-instance
771 (list (swank-mop:class-prototype class))))
772 (multiple-value-bind (shared-initialize-keywords si-aokp)
773 (ignore-errors
774 (applicable-methods-keywords
775 #'shared-initialize
776 (list (swank-mop:class-prototype class) t)))
777 (values (append slot-init-keywords
778 allocate-instance-keywords
779 initialize-instance-keywords
780 shared-initialize-keywords)
781 (or class-aokp ai-aokp ii-aokp si-aokp)
782 (list class-name-form))))))))))
783
784 (defun extra-keywords/change-class (operator &rest args)
785 (declare (ignore operator))
786 (unless (null args)
787 (let* ((class-name-form (car args))
788 (class (class-from-class-name-form class-name-form)))
789 (when class
790 (multiple-value-bind (slot-init-keywords class-aokp)
791 (extra-keywords/slots class)
792 (declare (ignore class-aokp))
793 (multiple-value-bind (shared-initialize-keywords si-aokp)
794 (ignore-errors
795 (applicable-methods-keywords
796 #'shared-initialize
797 (list (swank-mop:class-prototype class) t)))
798 ;; FIXME: much as it would be nice to include the
799 ;; applicable keywords from
800 ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
801 ;; how to do it: so we punt, always declaring
802 ;; &ALLOW-OTHER-KEYS.
803 (declare (ignore si-aokp))
804 (values (append slot-init-keywords shared-initialize-keywords)
805 t
806 (list class-name-form))))))))
807
808 (defmethod extra-keywords ((operator (eql 'make-instance))
809 &rest args)
810 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
811 (call-next-method)))
812
813 (defmethod extra-keywords ((operator (eql 'make-condition))
814 &rest args)
815 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
816 (call-next-method)))
817
818 (defmethod extra-keywords ((operator (eql 'error))
819 &rest args)
820 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
821 (call-next-method)))
822
823 (defmethod extra-keywords ((operator (eql 'signal))
824 &rest args)
825 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
826 (call-next-method)))
827
828 (defmethod extra-keywords ((operator (eql 'warn))
829 &rest args)
830 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
831 (call-next-method)))
832
833 (defmethod extra-keywords ((operator (eql 'cerror))
834 &rest args)
835 (multiple-value-bind (keywords aok determiners)
836 (apply #'extra-keywords/make-instance operator
837 (cdr args))
838 (if keywords
839 (values keywords aok
840 (cons (car args) determiners))
841 (call-next-method))))
842
843 (defmethod extra-keywords ((operator (eql 'change-class))
844 &rest args)
845 (multiple-value-bind (keywords aok determiners)
846 (apply #'extra-keywords/change-class operator (cdr args))
847 (if keywords
848 (values keywords aok
849 (cons (car args) determiners))
850 (call-next-method))))
851
852 (defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords
853 allow-other-keys-p)
854 "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
855 (when keywords
856 (setf (arglist.key-p decoded-arglist) t)
857 (setf (arglist.keyword-args decoded-arglist)
858 (remove-duplicates
859 (append (arglist.keyword-args decoded-arglist)
860 keywords)
861 :key #'keyword-arg.keyword)))
862 (setf (arglist.allow-other-keys-p decoded-arglist)
863 (or (arglist.allow-other-keys-p decoded-arglist)
864 allow-other-keys-p)))
865
866 (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
867 "Determine extra keywords from the function call FORM, and modify
868 DECODED-ARGLIST to include them. As a secondary return value, return
869 the initial sublist of ARGS that was needed to determine the extra
870 keywords. As a tertiary return value, return whether any enrichment
871 was done."
872 (multiple-value-bind (extra-keywords extra-aok determining-args)
873 (apply #'extra-keywords form)
874 ;; enrich the list of keywords with the extra keywords
875 (enrich-decoded-arglist-with-keywords decoded-arglist
876 extra-keywords extra-aok)
877 (values decoded-arglist
878 determining-args
879 (or extra-keywords extra-aok))))
880
881 (defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
882 (:documentation
883 "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
884 ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
885 If the arglist is not available, return :NOT-AVAILABLE."))
886
887 (defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
888 (with-available-arglist (decoded-arglist)
889 (decode-arglist (arglist operator-form))
890 (enrich-decoded-arglist-with-extra-keywords decoded-arglist
891 (cons operator-form
892 argument-forms))))
893
894 (defmethod compute-enriched-decoded-arglist
895 ((operator-form (eql 'with-open-file)) argument-forms)
896 (declare (ignore argument-forms))
897 (multiple-value-bind (decoded-arglist determining-args)
898 (call-next-method)
899 (let ((first-arg (first (arglist.required-args decoded-arglist)))
900 (open-arglist (compute-enriched-decoded-arglist 'open nil)))
901 (when (and (arglist-p first-arg) (arglist-p open-arglist))
902 (enrich-decoded-arglist-with-keywords
903 first-arg
904 (arglist.keyword-args open-arglist)
905 nil)))
906 (values decoded-arglist determining-args t)))
907
908 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
909 argument-forms)
910 (let ((function-name-form (car argument-forms)))
911 (when (and (listp function-name-form)
912 (length= function-name-form 2)
913 (memq (car function-name-form) '(quote function)))
914 (let ((function-name (cadr function-name-form)))
915 (when (valid-operator-symbol-p function-name)
916 (let ((function-arglist
917 (compute-enriched-decoded-arglist function-name
918 (cdr argument-forms))))
919 (return-from compute-enriched-decoded-arglist
920 (values
921 (make-arglist :required-args
922 (list 'function)
923 :optional-args
924 (append
925 (mapcar #'(lambda (arg)
926 (make-optional-arg arg nil))
927 (arglist.required-args function-arglist))
928 (arglist.optional-args function-arglist))
929 :key-p
930 (arglist.key-p function-arglist)
931 :keyword-args
932 (arglist.keyword-args function-arglist)
933 :rest
934 'args
935 :allow-other-keys-p
936 (arglist.allow-other-keys-p function-arglist))
937 (list function-name-form)
938 t)))))))
939 (call-next-method))
940
941 (defmethod compute-enriched-decoded-arglist
942 ((operator-form (eql 'multiple-value-call)) argument-forms)
943 (compute-enriched-decoded-arglist 'apply argument-forms))
944
945 (defun delete-given-args (decoded-arglist args)
946 "Delete given ARGS from DECODED-ARGLIST."
947 (macrolet ((pop-or-return (list)
948 `(if (null ,list)
949 (return-from do-decoded-arglist)
950 (pop ,list))))
951 (do-decoded-arglist decoded-arglist
952 (&provided ()
953 (assert (eq (pop-or-return args)
954 (pop (arglist.provided-args decoded-arglist)))))
955 (&required ()
956 (pop-or-return args)
957 (pop (arglist.required-args decoded-arglist)))
958 (&optional ()
959 (pop-or-return args)
960 (pop (arglist.optional-args decoded-arglist)))
961 (&key (keyword)
962 ;; N.b. we consider a keyword to be given only when the keyword
963 ;; _and_ a value has been given for it.
964 (loop for (key value) on args by #'cddr
965 when (and (eq keyword key) value)
966 do (setf (arglist.keyword-args decoded-arglist)
967 (remove keyword (arglist.keyword-args decoded-arglist)
968 :key #'keyword-arg.keyword))))))
969 decoded-arglist)
970
971 (defun remove-given-args (decoded-arglist args)
972 ;; FIXME: We actually needa deep copy here.
973 (delete-given-args (copy-arglist decoded-arglist) args))
974
975 ;;;; Arglist Retrieval
976
977 (defun arglist-from-form (form)
978 (if (null form)
979 :not-available
980 (arglist-dispatch (car form) (cdr form))))
981
982 (export 'arglist-dispatch)
983 (defgeneric arglist-dispatch (operator arguments)
984 ;; Default method
985 (:method (operator arguments)
986 (unless (and (symbolp operator) (valid-operator-symbol-p operator))
987 (return-from arglist-dispatch :not-available))
988
989 (multiple-value-bind (decoded-arglist determining-args)
990 (compute-enriched-decoded-arglist operator arguments)
991 (with-available-arglist (arglist) decoded-arglist
992 ;; replace some formal args by determining actual args
993 (setf arglist (delete-given-args arglist determining-args))
994 (setf (arglist.provided-args arglist) determining-args)
995 arglist))))
996
997 (defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments)
998 (match (cons operator arguments)
999 (('defmethod (#'function-exists-p gf-name) . rest)
1000 (let ((gf (fdefinition gf-name)))
1001 (when (typep gf 'generic-function)
1002 (with-available-arglist (arglist) (decode-arglist (arglist gf))
1003 (let ((qualifiers (loop for x in rest
1004 until (or (listp x) (empty-arg-p x))
1005 collect x)))
1006 (return-from arglist-dispatch
1007 (make-arglist :provided-args (cons gf-name qualifiers)
1008 :required-args (list arglist)
1009 :rest "body" :body-p t)))))))
1010 (_)) ; Fall through
1011 (call-next-method))
1012
1013 (defmethod arglist-dispatch ((operator (eql 'define-compiler-macro)) arguments)
1014 (match (cons operator arguments)
1015 (('define-compiler-macro (#'function-exists-p gf-name) . _)
1016 (let ((gf (fdefinition gf-name)))
1017 (with-available-arglist (arglist) (decode-arglist (arglist gf))
1018 (return-from arglist-dispatch
1019 (make-arglist :provided-args (list gf-name)
1020 :required-args (list arglist)
1021 :rest "body" :body-p t)))))
1022 (_)) ; Fall through
1023 (call-next-method))
1024
1025
1026 (defmethod arglist-dispatch ((operator (eql 'eval-when)) arguments)
1027 (declare (ignore arguments))
1028 (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute)))
1029 (make-arglist
1030 :required-args (list (make-arglist :any-p t :any-args eval-when-args))
1031 :rest '#:body :body-p t)))
1032
1033
1034 (defmethod arglist-dispatch ((operator (eql 'declare)) arguments)
1035 (let* ((declaration (cons operator (last arguments)))
1036 (typedecl-arglist (arglist-for-type-declaration declaration)))
1037 (if (arglist-available-p typedecl-arglist)
1038 typedecl-arglist
1039 (match declaration
1040 (('declare ((#'consp typespec) . decl-args))
1041 (with-available-arglist (typespec-arglist)
1042 (decoded-arglist-for-type-specifier typespec)
1043 (make-arglist
1044 :required-args (list (make-arglist
1045 :required-args (list typespec-arglist)
1046 :rest '#:variables)))))
1047 (('declare (decl-identifier . decl-args))
1048 (decoded-arglist-for-declaration decl-identifier decl-args))
1049 (_ (make-arglist :rest '#:declaration-specifiers))))))
1050
1051 (defmethod arglist-dispatch ((operator (eql 'declaim)) arguments)
1052 (arglist-dispatch 'declare arguments))
1053
1054
1055 (defun arglist-for-type-declaration (declaration)
1056 (flet ((%arglist-for-type-declaration (identifier typespec rest-var-name)
1057 (with-available-arglist (typespec-arglist)
1058 (decoded-arglist-for-type-specifier typespec)
1059 (make-arglist
1060 :required-args (list (make-arglist
1061 :provided-args (list identifier)
1062 :required-args (list typespec-arglist)
1063 :rest rest-var-name))))))
1064 (match declaration
1065 (('declare ('type (#'consp typespec) . decl-args))
1066 (%arglist-for-type-declaration 'type typespec '#:variables))
1067 (('declare ('ftype (#'consp typespec) . decl-args))
1068 (%arglist-for-type-declaration 'ftype typespec '#:function-names))
1069 (('declare ((#'consp typespec) . decl-args))
1070 (with-available-arglist (typespec-arglist)
1071 (decoded-arglist-for-type-specifier typespec)
1072 (make-arglist
1073 :required-args (list (make-arglist
1074 :required-args (list typespec-arglist)
1075 :rest '#:variables)))))
1076 (_ :not-available))))
1077
1078 (defun decoded-arglist-for-declaration (decl-identifier decl-args)
1079 (declare (ignore decl-args))
1080 (with-available-arglist (arglist)
1081 (decode-arglist (declaration-arglist decl-identifier))
1082 (setf (arglist.provided-args arglist) (list decl-identifier))
1083 (make-arglist :required-args (list arglist))))
1084
1085 (defun decoded-arglist-for-type-specifier (type-specifier)
1086 (etypecase type-specifier
1087 (arglist-dummy :not-available)
1088 (cons (decoded-arglist-for-type-specifier (car type-specifier)))
1089 (symbol
1090 (with-available-arglist (arglist)
1091 (decode-arglist (type-specifier-arglist type-specifier))
1092 (setf (arglist.provided-args arglist) (list type-specifier))
1093 arglist))))
1094
1095 ;;; Slimefuns
1096
1097 ;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at
1098 ;;; user's point in Emacs. A RAW-FORM looks like
1099 ;;;
1100 ;;; ("FOO" ("BAR" ...) "QUUX" ("ZURP" SWANK::%CURSOR-MARKER%))
1101 ;;;
1102 ;;; The expression before the cursor marker is the expression where
1103 ;;; user's cursor points at. An explicit marker is necessary to
1104 ;;; disambiguate between
1105 ;;;
1106 ;;; ("IF" ("PRED")
1107 ;;; ("F" "X" "Y" %CURSOR-MARKER%))
1108 ;;;
1109 ;;; and
1110 ;;; ("IF" ("PRED")
1111 ;;; ("F" "X" "Y") %CURSOR-MARKER%)
1112
1113 ;;; Notice that for a form like (FOO (BAR |) QUUX), where | denotes
1114 ;;; user's point, the following should be sent ("FOO" ("BAR" ""
1115 ;;; %CURSOR-MARKER%)). Only the forms up to point should be
1116 ;;; considered.
1117
1118 (defslimefun autodoc (raw-form &key print-right-margin)
1119 "Return a list of two elements.
1120 First, a string representing the arglist for the deepest subform in
1121 RAW-FORM that does have an arglist. The highlighted parameter is
1122 wrapped in ===> X <===.
1123
1124 Second, a boolean value telling whether the returned string can be cached."
1125 (handler-bind ((serious-condition
1126 #'(lambda (c)
1127 (unless (debug-on-swank-error)
1128 (let ((*print-right-margin* print-right-margin))
1129 (return-from autodoc
1130 (format nil "Arglist Error: \"~A\"" c)))))))
1131 (with-buffer-syntax ()
1132 (multiple-value-bind (form arglist obj-at-cursor form-path)
1133 (find-subform-with-arglist (parse-raw-form raw-form))
1134 (cond ((boundp-and-interesting obj-at-cursor)
1135 (list (print-variable-to-string obj-at-cursor) nil))
1136 (t
1137 (list
1138 (with-available-arglist (arglist) arglist
1139 (decoded-arglist-to-string
1140 arglist
1141 :print-right-margin print-right-margin
1142 :operator (car form)
1143 :highlight (form-path-to-arglist-path form-path
1144 form
1145 arglist)))
1146 t)))))))
1147
1148 (defun boundp-and-interesting (symbol)
1149 (and symbol
1150 (symbolp symbol)
1151 (boundp symbol)
1152 (not (memq symbol '(cl:t cl:nil)))
1153 (not (keywordp symbol))))
1154
1155 (defun print-variable-to-string (symbol)
1156 "Return a short description of VARIABLE-NAME, or NIL."
1157 (let ((*print-pretty* t) (*print-level* 4)
1158 (*print-length* 10) (*print-lines* 1)
1159 (*print-readably* nil)
1160 (value (symbol-value symbol)))
1161 (call/truncated-output-to-string
1162 75 (lambda (s)
1163 (without-printing-errors (:object value :stream s)
1164 (format s "~A ~A~S" symbol *echo-area-prefix* value))))))
1165
1166
1167 (defslimefun complete-form (raw-form)
1168 "Read FORM-STRING in the current buffer package, then complete it
1169 by adding a template for the missing arguments."
1170 ;; We do not catch errors here because COMPLETE-FORM is an
1171 ;; interactive command, not automatically run in the background like
1172 ;; ARGLIST-FOR-ECHO-AREA.
1173 (with-buffer-syntax ()
1174 (multiple-value-bind (arglist provided-args)
1175 (find-immediately-containing-arglist (parse-raw-form raw-form))
1176 (with-available-arglist (arglist) arglist
1177 (decoded-arglist-to-template-string
1178 (delete-given-args arglist
1179 (remove-if #'empty-arg-p provided-args
1180 :from-end t :count 1))
1181 :prefix "" :suffix "")))))
1182
1183 (defslimefun completions-for-keyword (keyword-string raw-form)
1184 "Return a list of possible completions for KEYWORD-STRING relative
1185 to the context provided by RAW-FORM."
1186 (with-buffer-syntax ()
1187 (let ((arglist (find-immediately-containing-arglist
1188 (parse-raw-form raw-form))))
1189 (when (arglist-available-p arglist)
1190 ;; It would be possible to complete keywords only if we are in
1191 ;; a keyword position, but it is not clear if we want that.
1192 (let* ((keywords
1193 (append (mapcar #'keyword-arg.keyword
1194 (arglist.keyword-args arglist))
1195 (remove-if-not #'keywordp (arglist.any-args arglist))))
1196 (keyword-name
1197 (tokenize-symbol keyword-string))
1198 (matching-keywords
1199 (find-matching-symbols-in-list
1200 keyword-name keywords (make-compound-prefix-matcher #\-)))
1201 (converter (completion-output-symbol-converter keyword-string))
1202 (strings
1203 (mapcar converter
1204 (mapcar #'symbol-name matching-keywords)))
1205 (completion-set
1206 (format-completion-set strings nil "")))
1207 (list completion-set
1208 (longest-compound-prefix completion-set)))))))
1209
1210 (defparameter +cursor-marker+ '%cursor-marker%)
1211
1212 (defun find-subform-with-arglist (form)
1213 "Returns four values:
1214
1215 The appropriate subform of `form' which is closest to the
1216 +CURSOR-MARKER+ and whose operator is valid and has an
1217 arglist. The +CURSOR-MARKER+ is removed from that subform.
1218
1219 Second value is the arglist. Local function and macro definitions
1220 appearing in `form' into account.
1221
1222 Third value is the object in front of +CURSOR-MARKER+.
1223
1224 Fourth value is a form path to that object."
1225 (labels
1226 ((yield-success (form local-ops)
1227 (multiple-value-bind (form obj-at-cursor form-path)
1228 (extract-cursor-marker form)
1229 (values form
1230 (let ((entry (assoc (car form) local-ops :test #'op=)))
1231 (if entry
1232 (decode-arglist (cdr entry))
1233 (arglist-from-form form)))
1234 obj-at-cursor
1235 form-path)))
1236 (yield-failure ()
1237 (values nil :not-available))
1238 (operator-p (operator local-ops)
1239 (or (and (symbolp operator) (valid-operator-symbol-p operator))
1240 (assoc operator local-ops :test #'op=)))
1241 (op= (op1 op2)
1242 (cond ((and (symbolp op1) (symbolp op2))
1243 (eq op1 op2))
1244 ((and (arglist-dummy-p op1) (arglist-dummy-p op2))
1245 (string= (arglist-dummy.string-representation op1)
1246 (arglist-dummy.string-representation op2)))))
1247 (grovel-form (form local-ops)
1248 "Descend FORM top-down, always taking the rightest branch,
1249 until +CURSOR-MARKER+."
1250 (assert (listp form))
1251 (destructuring-bind (operator . args) form
1252 ;; N.b. the user's cursor is at the rightmost, deepest
1253 ;; subform right before +CURSOR-MARKER+.
1254 (let ((last-subform (car (last form)))
1255 (new-ops))
1256 (cond
1257 ((eq last-subform +cursor-marker+)
1258 (if (operator-p operator local-ops)
1259 (yield-success form local-ops)
1260 (yield-failure)))
1261 ((not (operator-p operator local-ops))
1262 (grovel-form last-subform local-ops))
1263 ;; Make sure to pick up the arglists of local
1264 ;; function/macro definitions.
1265 ((setq new-ops (extract-local-op-arglists operator args))
1266 (multiple-value-or (grovel-form last-subform
1267 (nconc new-ops local-ops))
1268 (yield-success form local-ops)))
1269 ;; Some typespecs clash with function names, so we make
1270 ;; sure to bail out early.
1271 ((member operator '(cl:declare cl:declaim))
1272 (yield-success form local-ops))
1273 ;; Mostly uninteresting, hence skip.
1274 ((memq operator '(cl:quote cl:function))
1275 (yield-failure))
1276 (t
1277 (multiple-value-or (grovel-form last-subform local-ops)
1278 (yield-success form local-ops))))))))
1279 (if (null form)
1280 (yield-failure)
1281 (grovel-form form '()))))
1282
1283 (defun extract-cursor-marker (form)
1284 "Returns three values: normalized `form' without +CURSOR-MARKER+,
1285 the object in front of +CURSOR-MARKER+, and a form path to that
1286 object."
1287 (labels ((grovel (form last path)
1288 (let ((result-form))
1289 (loop for (car . cdr) on form do
1290 (cond ((eql car +cursor-marker+)
1291 (decf (first path))
1292 (return-from grovel
1293 (values (nreconc result-form cdr)
1294 last
1295 (nreverse path))))
1296 ((consp car)
1297 (multiple-value-bind (new-car new-last new-path)
1298 (grovel car last (cons 0 path))
1299 (when new-path ; CAR contained cursor-marker?
1300 (return-from grovel
1301 (values (nreconc
1302 (cons new-car result-form) cdr)
1303 new-last
1304 new-path))))))
1305 (push car result-form)
1306 (setq last car)
1307 (incf (first path))
1308 finally
1309 (return-from grovel
1310 (values (nreverse result-form) nil nil))))))
1311 (grovel form nil (list 0))))
1312
1313 (defgeneric extract-local-op-arglists (operator args)
1314 (:documentation
1315 "If the form `(OPERATOR ,@ARGS) is a local operator binding form,
1316 return a list of pairs (OP . ARGLIST) for each locally bound op.")
1317 (:method (operator args)
1318 (declare (ignore operator args))
1319 nil)
1320 ;; FLET
1321 (:method ((operator (eql 'cl:flet)) args)
1322 (let ((defs (first args))
1323 (body (rest args)))
1324 (cond ((null body) nil) ; `(flet ((foo (x) |'
1325 ((atom defs) nil) ; `(flet ,foo (|'
1326 (t (%collect-op/argl-alist defs)))))
1327 ;; LABELS
1328 (:method ((operator (eql 'cl:labels)) args)
1329 ;; Notice that we only have information to "look backward" and
1330 ;; show arglists of previously occuring local functions.
1331 (destructuring-bind (defs . body) args
1332 (unless (or (atom defs) (null body)) ; `(labels ,foo (|'
1333 (let ((current-def (car (last defs))))
1334 (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|'
1335 ((not (null body))
1336 (extract-local-op-arglists 'cl:flet args))
1337 (t
1338 (let ((def.body (cddr current-def)))
1339 (when def.body
1340 (%collect-op/argl-alist defs)))))))))
1341 ;; MACROLET
1342 (:method ((operator (eql 'cl:macrolet)) args)
1343 (extract-local-op-arglists 'cl:labels args)))
1344
1345 (defun %collect-op/argl-alist (defs)
1346 (setq defs (remove-if-not #'(lambda (x)
1347 ;; Well-formed FLET/LABELS def?
1348 (and (consp x) (second x)))
1349 defs))
1350 (loop for (name arglist . nil) in defs
1351 collect (cons name arglist)))
1352
1353 (defun find-immediately-containing-arglist (form)
1354 "Returns the arglist of the subform _immediately_ containing
1355 +CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may
1356 be in a nested arglist \(e.g. `(WITH-OPEN-FILE (<here>'\), and the
1357 arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be
1358 returned in that case."
1359 (flet ((try (form-path form arglist)
1360 (let* ((arglist-path (form-path-to-arglist-path form-path
1361 form
1362 arglist))
1363 (argl (apply #'arglist-ref
1364 arglist
1365 arglist-path))
1366 (args (apply #'provided-arguments-ref
1367 (cdr form)
1368 arglist
1369 arglist-path)))
1370 (when (and (arglist-p argl) (listp args))
1371 (values argl args)))))
1372 (multiple-value-bind (form arglist obj form-path)
1373 (find-subform-with-arglist form)
1374 (declare (ignore obj))
1375 (with-available-arglist (arglist) arglist
1376 ;; First try the form the cursor is in (in case of a normal
1377 ;; form), then try the surrounding form (in case of a nested
1378 ;; macro form).
1379 (multiple-value-or (try form-path form arglist)
1380 (try (butlast form-path) form arglist)
1381 :not-available)))))
1382
1383 (defun form-path-to-arglist-path (form-path form arglist)
1384 "Convert a form path to an arglist path consisting of arglist
1385 indices."
1386 (labels ((convert (path args arglist)
1387 (if (null path)
1388 nil
1389 (let* ((idx (car path))
1390 (idx* (arglist-index idx args arglist))
1391 (arglist* (and idx* (arglist-ref arglist idx*)))
1392 (args* (and idx* (provided-arguments-ref args
1393 arglist
1394 idx*))))
1395 ;; The FORM-PATH may be more detailed than ARGLIST;
1396 ;; consider (defun foo (x y) ...), a form path may
1397 ;; point into the function's lambda-list, but the
1398 ;; arglist of DEFUN won't contain as much information.
1399 ;; So we only recurse if possible.
1400 (cond ((null idx*)
1401 nil)
1402 ((arglist-p arglist*)
1403 (cons idx* (convert (cdr path) args* arglist*)))
1404 (t
1405 (list idx*)))))))
1406 (convert
1407 ;; FORM contains irrelevant operator. Adjust FORM-PATH.
1408 (cond ((null form-path) nil)
1409 ((equal form-path '(0)) nil)
1410 (t
1411 (destructuring-bind (car . cdr) form-path
1412 (cons (1- car) cdr))))
1413 (cdr form)
1414 arglist)))
1415
1416 (defun arglist-index (provided-argument-index provided-arguments arglist)
1417 "Return the arglist index into `arglist' for the parameter belonging
1418 to the argument (NTH `provided-argument-index' `provided-arguments')."
1419 (let ((positional-args# (positional-args-number arglist))
1420 (arg-index provided-argument-index))
1421 (with-struct (arglist. key-p rest) arglist
1422 (cond
1423 ((< arg-index positional-args#) ; required + optional
1424 arg-index)
1425 ((and (not key-p) (not rest)) ; more provided than allowed
1426 nil)
1427 ((not key-p) ; rest + body
1428 (assert (arglist.rest arglist))
1429 positional-args#)
1430 (t ; key
1431 ;; Find last provided &key parameter
1432 (let* ((argument (nth arg-index provided-arguments))
1433 (provided-keys (subseq provided-arguments positional-args#)))
1434 (loop for (key value) on provided-keys by #'cddr
1435 when (eq value argument)
1436 return (match key
1437 (('quote symbol) symbol)
1438 (_ key)))))))))
1439
1440 (defun arglist-ref (arglist &rest indices)
1441 "Returns the parameter in ARGLIST along the INDICIES path. Numbers
1442 represent positional parameters (required, optional), keywords
1443 represent key parameters."
1444 (flet ((ref-positional-arg (arglist index)
1445 (check-type index (integer 0 *))
1446 (with-struct (arglist. provided-args required-args
1447 optional-args rest)
1448 arglist
1449 (loop for args in (list provided-args required-args
1450 (mapcar #'optional-arg.arg-name
1451 optional-args))
1452 for args# = (length args)
1453 if (< index args#)
1454 return (nth index args)
1455 else
1456 do (decf index args#)
1457 finally (return (or rest nil)))))
1458 (ref-keyword-arg (arglist keyword)
1459 ;; keyword argument may be any symbol,
1460 ;; not only from the KEYWORD package.
1461 (let ((keyword (match keyword
1462 (('quote symbol) symbol)
1463 (_ keyword))))
1464 (do-decoded-arglist arglist
1465 (&key (kw arg) (when (eq kw keyword)
1466 (return-from ref-keyword-arg arg)))))
1467 nil))
1468 (dolist (index indices)
1469 (assert (arglist-p arglist))
1470 (setq arglist (if (numberp index)
1471 (ref-positional-arg arglist index)
1472 (ref-keyword-arg arglist index))))
1473 arglist))
1474
1475 (defun provided-arguments-ref (provided-args arglist &rest indices)
1476 "Returns the argument in PROVIDED-ARGUMENT along the INDICES path
1477 relative to ARGLIST."
1478 (check-type arglist arglist)
1479 (flet ((ref (provided-args arglist index)
1480 (if (numberp index)
1481 (nth index provided-args)
1482 (let ((provided-keys (subseq provided-args
1483 (positional-args-number arglist))))
1484 (loop for (key value) on provided-keys
1485 when (eq key index)
1486 return value)))))
1487 (dolist (idx indices)
1488 (setq provided-args (ref provided-args arglist idx))
1489 (setq arglist (arglist-ref arglist idx)))
1490 provided-args))
1491
1492 (defun positional-args-number (arglist)
1493 (+ (length (arglist.provided-args arglist))
1494 (length (arglist.required-args arglist))
1495 (length (arglist.optional-args arglist))))
1496
1497 (defun parse-raw-form (raw-form)
1498 "Parse a RAW-FORM into a Lisp form. I.e. substitute strings by
1499 symbols if already interned. For strings not already interned, use
1500 ARGLIST-DUMMY."
1501 (unless (null raw-form)
1502 (loop for element in raw-form
1503 collect (etypecase element
1504 (string (read-conversatively element))
1505 (list (parse-raw-form element))
1506 (symbol (prog1 element
1507 ;; Comes after list, so ELEMENT can't be NIL.
1508 (assert (eq element +cursor-marker+))))))))
1509
1510 (defun read-conversatively (string)
1511 "Tries to find the symbol that's represented by STRING.
1512
1513 If it can't, this either means that STRING does not represent a
1514 symbol, or that the symbol behind STRING would have to be freshly
1515 interned. Because this function is supposed to be called from the
1516 automatic arglist display stuff from Slime, interning freshly
1517 symbols is a big no-no.
1518
1519 In such a case (that no symbol could be found), an object of type
1520 ARGLIST-DUMMY is returned instead, which works as a placeholder
1521 datum for subsequent logics to rely on."
1522 (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string))
1523 (length (length string))
1524 (type (cond ((zerop length) nil)
1525 ((eql (aref string 0) #\')
1526 :quoted-symbol)
1527 ((search "#'" string :end2 (min length 2))
1528 :sharpquoted-symbol)
1529 ((char= (char string 0) (char string (1- length))
1530 #\")
1531 :string)
1532 (t
1533 :symbol))))
1534 (multiple-value-bind (symbol found?)
1535 (case type
1536 (:symbol (parse-symbol string))
1537 (:quoted-symbol (parse-symbol (subseq string 1)))
1538 (:sharpquoted-symbol (parse-symbol (subseq string 2)))
1539 (:string (values string t))
1540 (t (values string nil)))
1541 (if found?
1542 (ecase type
1543 (:symbol symbol)
1544 (:quoted-symbol `(quote ,symbol))
1545 (:sharpquoted-symbol `(function ,symbol))
1546 (:string (if (> length 1)
1547 (subseq string 1 (1- length))
1548 string)))
1549 (make-arglist-dummy string)))))
1550
1551 (defun test-print-arglist ()
1552 (flet ((test (arglist string)
1553 (let* ((*package* (find-package :swank))
1554 (actual (decoded-arglist-to-string
1555 (decode-arglist arglist)
1556 :print-right-margin 1000)))
1557 (unless (string= actual string)
1558 (warn "Test failed: ~S => ~S~% Expected: ~S"
1559 arglist actual string)))))
1560 (test '(function cons) "(function cons)")
1561 (test '(quote cons) "(quote cons)")
1562 (test '(&key (function #'+)) "(&key (function #'+))")
1563 (test '(&whole x y z) "(y z)")
1564 (test '(x &aux y z) "(x)")
1565 (test '(x &environment env y) "(x y)")
1566 (test '(&key ((function f))) "(&key ((function ..)))")
1567 (test
1568 '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)
1569 "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)")
1570 (test '(declare (optimize &any (speed 1) (safety 1)))
1571 "(declare (optimize &any (speed 1) (safety 1)))")))
1572
1573 (defun test-arglist-ref ()
1574 (macrolet ((soft-assert (form)
1575 `(unless ,form
1576 (warn "Assertion failed: ~S~%" ',form))))
1577 (let ((sample (decode-arglist '(x &key ((:k (y z)))))))
1578 (soft-assert (eq (arglist-ref sample 0) 'x))
1579 (soft-assert (eq (arglist-ref sample :k 0) 'y))
1580 (soft-assert (eq (arglist-ref sample :k 1) 'z))
1581
1582 (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0)
1583 'a))
1584 (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0)
1585 'b))
1586 (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1)
1587 'c)))))
1588
1589 (test-print-arglist)
1590 (test-arglist-ref)
1591
1592 (provide :swank-arglists)

  ViewVC Help
Powered by ViewVC 1.1.5