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