dotemacs

My Emacs configuration
git clone git://git.entf.net/dotemacs
Log | Files | Refs | LICENSE

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)