/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.357 by heller, Tue Jan 17 20:28:57 2006 UTC revision 1.358 by heller, Mon Jan 30 19:07:43 2006 UTC
# Line 1332  Return the package or nil." Line 1332  Return the package or nil."
1332    "Return the arglist for the first function, macro, or special-op in NAMES."    "Return the arglist for the first function, macro, or special-op in NAMES."
1333    (handler-case    (handler-case
1334        (with-buffer-syntax ()        (with-buffer-syntax ()
1335          (let ((name (find-if #'valid-operator-name-p names)))          (let ((name (find-if #'valid-operator-name-p names
1336            (if name (format-arglist-for-echo-area (parse-symbol name) name))))                               :key (lambda (name)
1337                                        (if (consp name) (car name) name)))))
1338              (when name
1339                (if (consp name)
1340                    ;; For now, this means that NAME is a pair of the form
1341                    ;; ("make-instance" . "<class-name>").
1342                    (format-initargs-and-initforms-for-echo-area
1343                     (parse-symbol (cdr name)) (cdr name))
1344                    (format-arglist-for-echo-area (parse-symbol name) name)))))
1345      (error (cond)      (error (cond)
1346        (format nil "ARGLIST: ~A" cond))))        (format nil "ARGLIST: ~A" cond))))
1347    
1348    (defun class-initargs-and-initforms (class-symbol)
1349      "Iterates through the slot definitions of the class named CLASS-SYMBOL and
1350    returns a list of initargs, if any, or of (initarg initform) pairs when both
1351    an initarg and an initform exist."
1352      (loop for slot-def in (swank-mop:class-slots (find-class class-symbol))
1353            nconc
1354            (let ((initargs (car (swank-mop:slot-definition-initargs slot-def))))
1355              (when initargs
1356                (list (if (swank-mop:slot-definition-initfunction slot-def)
1357                          (list initargs
1358                                (swank-mop:slot-definition-initform slot-def))
1359                          initargs))))))
1360    
1361    (defun format-initargs-and-initforms-for-echo-area (class-symbol class-name)
1362      "Return CLASS-NAME's initargs and initforms for display in the echo area."
1363      (handler-case
1364          (arglist-to-string
1365           (list* 'make-instance (concatenate 'string "'" class-name) '&key
1366                  (class-initargs-and-initforms class-symbol))
1367           (symbol-package class-symbol))
1368        (error (msg)
1369          (declare (ignore msg))
1370          ;; The class doesn't exist so we fallback to showing the usual
1371          ;; arglist for MAKE-INSTANCE.
1372          (arglist-for-echo-area '("make-instance")))))
1373    
1374  (defun format-arglist-for-echo-area (symbol name)  (defun format-arglist-for-echo-area (symbol name)
1375    "Return SYMBOL's arglist as string for display in the echo area.    "Return SYMBOL's arglist as string for display in the echo area.
1376  Use the string NAME as operator name."  Use the string NAME as operator name."

Legend:
Removed from v.1.357  
changed lines
  Added in v.1.358

  ViewVC Help
Powered by ViewVC 1.1.5