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

Diff of /slime/swank.lisp

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

revision 1.499 by mkoeppe, Sat Aug 25 20:04:19 2007 UTC revision 1.500 by trittweiler, Sun Aug 26 23:34:50 2007 UTC
# Line 1491  Return the symbol and a flag indicating Line 1491  Return the symbol and a flag indicating
1491                           (pname              (find-package pname))                           (pname              (find-package pname))
1492                           (t                  package))))                           (t                  package))))
1493        (if package        (if package
1494            (find-symbol sname package)            (multiple-value-bind (symbol flag) (find-symbol sname package)
1495            (values nil nil)))))              (values symbol flag sname package))
1496              (values nil nil nil nil)))))
1497    
1498  (defun parse-symbol-or-lose (string &optional (package *package*))  (defun parse-symbol-or-lose (string &optional (package *package*))
1499    (multiple-value-bind (symbol status) (parse-symbol string package)    (multiple-value-bind (symbol status) (parse-symbol string package)
# Line 1562  For more information about the format of Line 1563  For more information about the format of
1563  ``form specs'', please see PARSE-FORM-SPEC."  ``form specs'', please see PARSE-FORM-SPEC."
1564    (handler-case    (handler-case
1565        (with-buffer-syntax ()        (with-buffer-syntax ()
1566          (multiple-value-bind (form-spec arg-index)          (multiple-value-bind (form-spec arg-index newly-interned-symbols)
1567              (parse-first-valid-form-spec raw-specs arg-indices)              (parse-first-valid-form-spec raw-specs arg-indices)
1568            (when form-spec            (unwind-protect
1569              (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))                 (when form-spec
1570                (unless (eql arglist :not-available)                   (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
1571                  (multiple-value-bind (type operator arguments)                     (unless (eql arglist :not-available)
1572                      (split-form-spec form-spec)                       (multiple-value-bind (type operator arguments)
1573                    (declare (ignore arguments))                           (split-form-spec form-spec)
1574                    (multiple-value-bind (stringified-arglist)                         (declare (ignore arguments))
1575                        (decoded-arglist-to-string                         (multiple-value-bind (stringified-arglist)
1576                         arglist                             (decoded-arglist-to-string
1577                         :operator operator                              arglist
1578                         :print-right-margin print-right-margin                              :operator operator
1579                         :print-lines print-lines                              :print-right-margin print-right-margin
1580                         :highlight (and arg-index                              :print-lines print-lines
1581                                         (not (zerop arg-index))                              :highlight (and arg-index
1582                                         ;; don't highlight the operator                                              (not (zerop arg-index))
1583                                         arg-index))                                              ;; don't highlight the operator
1584                      (case type                                              arg-index))
1585                        (:declaration    (format nil "(declare ~A)" stringified-arglist))                           (case type
1586                        (:type-specifier (format nil "[Typespec] ~A" stringified-arglist))                             (:declaration    (format nil "(declare ~A)" stringified-arglist))
1587                        (t stringified-arglist)))))))))                             (:type-specifier (format nil "[Typespec] ~A" stringified-arglist))
1588                               (t stringified-arglist)))))))
1589                (mapc #'unintern newly-interned-symbols))))
1590      (error (cond)      (error (cond)
1591        (format nil "ARGLIST (error): ~A" cond))        (format nil "ARGLIST (error): ~A" cond))
1592      ))      ))
# Line 1591  For more information about the format of Line 1594  For more information about the format of
1594  (defun parse-form-spec (raw-spec)  (defun parse-form-spec (raw-spec)
1595    "Takes a raw (i.e. unparsed) form spec from SLIME and returns a    "Takes a raw (i.e. unparsed) form spec from SLIME and returns a
1596  proper form spec for further processing within SWANK. Returns NIL  proper form spec for further processing within SWANK. Returns NIL
1597  if RAW-SPEC could not be parsed.  if RAW-SPEC could not be parsed. Symbols that had to be interned
1598    in course of the conversion, are returned as secondary return value.
1599    
1600  A ``raw form spec'' can be either:  A ``raw form spec'' can be either:
1601    
1602    i)   a list of strings representing a Common Lisp form    i)   a list of strings representing a Common Lisp form
1603    
1604    ii)  one of:    ii)  a list of strings as of i), but which additionally
1605           contains other raw form specs
1606    
1607       a)  (:declaration decl-identifier declspec)    iii) one of:
1608    
1609             where DECL-IDENTIFIER is the string representation of a /decl identifier/,       a)  (:declaration declspec)
                  DECLSPEC is the string representation of a /declaration specifier/.  
1610    
1611       b)  (:type-specifier typespec-operator typespec)             where DECLSPEC is a raw form spec.
1612    
1613         b)  (:type-specifier typespec)
1614    
1615             where TYPESPEC-OPERATOR is the string representation of the CAR of a /type specifier/,             where TYPESPEC is a raw form spec.
                  TYPESPEC is the string representation of a /type specifier/.  
1616    
      (DECL-IDENTIFIER, and TYPESPEC-OPERATOR are actually redundant (as they're both  
      already provided in DECLSPEC, or TYPESPEC respectively, but this separation  
      allows to check if these raw form specs are valid before the whole spec is READ,  
      and thus all contained symbols interned.)  
1617    
1618  A ``form spec'' is either  A ``form spec'' is either
1619    
# Line 1628  A ``form spec'' is either Line 1629  A ``form spec'' is either
1629    
1630  Examples:  Examples:
1631    
1632    (\"defmethod\")                     =>  (defmethod)    (\"defmethod\")                               =>  (defmethod)
1633    (\"cl:defmethod\")                  =>  (cl:defmethod)    (\"cl:defmethod\")                            =>  (cl:defmethod)
1634    (\"defmethod\" \"print-object\")    =>  (defmethod print-object)    (\"defmethod\" \"print-object\")              =>  (defmethod print-object)
1635    
1636      (\"foo\" (\"bar\" (\"quux\")) \"baz\"         =>  (foo (bar (quux)) baz)
1637    
1638    (:declaration \"optimize\" \"(optimize)\")    =>  ((:declaration optimize))    (:declaration \"optimize\" \"(optimize)\")    =>  ((:declaration optimize))
1639    (:declaration \"type\"     \"(type string)\") =>  ((:declaration type) string)    (:declaration \"type\"     \"(type string)\") =>  ((:declaration type) string)
1640    (:type-specifier \"float\" \"(float)\")       =>  ((:type-specifier float))    (:type-specifier \"float\" \"(float)\")       =>  ((:type-specifier float))
1641    (:type-specifier \"float\" \"(float 0 100)\") =>  ((:type-specifier float) 0 100)    (:type-specifier \"float\" \"(float 0 100)\") =>  ((:type-specifier float) 0 100)
1642  "  "
1643    (flet ((parse-extended-spec (raw-extension-op raw-extension extension-flag)    (flet ((parse-extended-spec (raw-extension extension-flag)
1644             (when (nth-value 1 (parse-symbol raw-extension-op))             (when (and (stringp (first raw-extension)) ; (:DECLARATION (("a" "b" ("c")) "d"))
1645               (let ((extension (read-incomplete-form-from-string raw-extension)))                        (nth-value 1 (parse-symbol (first raw-extension))))
1646                 (unless (recursively-empty-p extension) ; (:DECLARATION "(())") &c.                (multiple-value-bind (extension introduced-symbols)
1647                     (read-form-spec raw-extension)
1648                    (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c.
1649                   (destructuring-bind (identifier &rest args) extension                   (destructuring-bind (identifier &rest args) extension
1650                     `((,extension-flag ,identifier) ,@args)))))))                     (values `((,extension-flag ,identifier) ,@args)
1651                               introduced-symbols)))))))
1652      (when (consp raw-spec)      (when (consp raw-spec)
1653        (destructure-case raw-spec        (destructure-case raw-spec
1654          ((:declaration raw-decl-identifier raw-declspec)          ((:declaration raw-declspec)
1655           (parse-extended-spec raw-decl-identifier raw-declspec :declaration))           (parse-extended-spec raw-declspec :declaration))
1656          ((:type-specifier raw-typespec-op raw-typespec)          ((:type-specifier raw-typespec)
1657           (parse-extended-spec raw-typespec-op raw-typespec :type-specifier))           (parse-extended-spec raw-typespec :type-specifier))
1658          (t          (t
1659           (when (every #'stringp raw-spec)           (when (every #'stringp raw-spec)
1660             (destructuring-bind (raw-operator &rest raw-args) raw-spec             (destructuring-bind (raw-operator &rest raw-args) raw-spec
1661               (multiple-value-bind (operator found?) (parse-symbol raw-operator)               (multiple-value-bind (operator found?) (parse-symbol raw-operator)
1662                 (when (and found? (valid-operator-symbol-p operator))                 (when (and found? (valid-operator-symbol-p operator))
1663                   `(,operator ,@(read-incomplete-form-from-string                   (multiple-value-bind (parsed-args introduced-symbols)
1664                                  (format nil "(~A)"                       (read-form-spec raw-args)
1665                                          (apply #'concatenate 'string raw-args)))))))))))))                     (values `(,operator ,@parsed-args) introduced-symbols)))))))))))
1666    
1667  (defun split-form-spec (spec)  (defun split-form-spec (spec)
1668    "Returns all three relevant information a ``form spec''    "Returns all three relevant information a ``form spec''
# Line 1671  contains: the operator type, the operato Line 1677  contains: the operator type, the operato
1677  (defun parse-first-valid-form-spec (raw-specs &optional arg-indices)  (defun parse-first-valid-form-spec (raw-specs &optional arg-indices)
1678    "Returns the first parsed form spec in RAW-SPECS that can    "Returns the first parsed form spec in RAW-SPECS that can
1679  successfully be parsed. Additionally returns its respective index  successfully be parsed. Additionally returns its respective index
1680  in ARG-INDICES (or NIL.)"  in ARG-INDICES (or NIL.), and all newly interned symbols as tertiary
1681    return value."
1682    (block traversal    (block traversal
1683      (mapc #'(lambda (raw-spec index)      (mapc #'(lambda (raw-spec index)
1684                (let ((spec (parse-form-spec raw-spec)))                (multiple-value-bind (spec symbols) (parse-form-spec raw-spec)
1685                  (when spec (return-from traversal                  (when spec (return-from traversal
1686                               (values spec index)))))                               (values spec index symbols)))))
1687            raw-specs            raw-specs
1688            (append arg-indices '#1=(nil . #1#)))))            (append arg-indices '#1=(nil . #1#)))
1689        nil)) ; found nothing
1690    
1691    (defun read-form-spec (spec)
1692      "Turns the ``raw form spec'' SPEC into a proper Common Lisp form.
1693    
1694    It returns symbols that had to interned for the conversion as
1695    secondary return value."
1696      (when spec
1697        (with-buffer-syntax ()
1698          (call-with-ignored-reader-errors
1699           #'(lambda ()
1700               (let ((result) (newly-interned-symbols))
1701                 (dolist (element spec)
1702                   (etypecase element
1703                     (string
1704                      (multiple-value-bind (symbol found? symbol-name package)
1705                          (parse-symbol element)
1706                        (if found?
1707                            (push symbol result)
1708                            (let ((sexp (read-from-string element)))
1709                              (when (symbolp sexp)
1710                                (push sexp newly-interned-symbols)
1711                                ;; assert that PARSE-SYMBOL didn't parse incorrectly.
1712                                (assert (and (equal symbol-name (symbol-name sexp))
1713                                             (eq package (symbol-package sexp)))))
1714                              (push sexp result)))))
1715                     (cons
1716                      (multiple-value-bind (read-spec interned-symbols)
1717                          (read-form-spec element)
1718                        (push read-spec result)
1719                        (setf newly-interned-symbols
1720                              (append interned-symbols
1721                                      newly-interned-symbols))))))
1722                 (values (nreverse result)
1723                         (nreverse newly-interned-symbols))))))))
1724    
1725    
1726    
1727  (defun clean-arglist (arglist)  (defun clean-arglist (arglist)
# Line 2523  Examples: Line 2566  Examples:
2566    
2567  (defun read-incomplete-form-from-string (form-string)  (defun read-incomplete-form-from-string (form-string)
2568    (with-buffer-syntax ()    (with-buffer-syntax ()
2569      (handler-case      (call-with-ignored-reader-errors
2570          (read-from-string form-string)        #'(lambda ()
2571        (reader-error (c)            (read-from-string form-string)))))
2572          (declare (ignore c))  
2573          nil)  (defun call-with-ignored-reader-errors (thunk)
2574        (stream-error (c)    (declare (type (function () (values &rest t)) thunk))
2575          (declare (ignore c))    (declare (optimize (speed 3) (safety 1)))
2576          nil))))    (handler-case (funcall thunk)
2577        (reader-error (c)
2578          (declare (ignore c))
2579          nil)
2580        (stream-error (c)
2581          (declare (ignore c))
2582          nil)))
2583    
2584  (defslimefun complete-form (form-string)  (defslimefun complete-form (form-string)
2585    "Read FORM-STRING in the current buffer package, then complete it    "Read FORM-STRING in the current buffer package, then complete it
2586  by adding a template for the missing arguments."  by adding a template for the missing arguments."
2587    (let ((form (parse-form-spec form-string)))    (multiple-value-bind (form newly-interned-symbols)
2588      (when (consp form)        (parse-form-spec form-string)
2589        (let ((form-completion (arglist-from-form-spec form)))      (unwind-protect
2590          (unless (eql form-completion :not-available)           (when (consp form)
2591            (return-from complete-form             (let ((form-completion (arglist-from-form-spec form)))
2592              (decoded-arglist-to-template-string form-completion               (unless (eql form-completion :not-available)
2593                                                  *buffer-package*                 (return-from complete-form
2594                                                  :prefix "")))))                   (decoded-arglist-to-template-string form-completion
2595                                                         *buffer-package*
2596                                                         :prefix "")))))
2597          (mapc #'unintern newly-interned-symbols))
2598      :not-available))      :not-available))
2599    
2600    
# Line 2563  by adding a template for the missing arg Line 2614  by adding a template for the missing arg
2614    
2615  (defslimefun completions-for-keyword (raw-specs keyword-string arg-indices)  (defslimefun completions-for-keyword (raw-specs keyword-string arg-indices)
2616    (with-buffer-syntax ()    (with-buffer-syntax ()
2617      (multiple-value-bind (form-spec index)      (multiple-value-bind (form-spec index newly-interned-symbols)
2618          (parse-first-valid-form-spec raw-specs arg-indices)          (parse-first-valid-form-spec raw-specs arg-indices)
2619        (when form-spec        (unwind-protect
2620          (let ((arglist   (arglist-from-form-spec form-spec  :remove-args nil)))             (when form-spec
2621            (unless (eql arglist :not-available)               (let ((arglist   (arglist-from-form-spec form-spec  :remove-args nil)))
2622              (multiple-value-bind (type operator arguments) (split-form-spec form-spec)                 (unless (eql arglist :not-available)
2623                (declare (ignore type arguments))                   (multiple-value-bind (type operator arguments) (split-form-spec form-spec)
2624                (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))                     (declare (ignore type arguments))
2625                       (arglist (apply #'arglist-ref arglist operator indices)))                     (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
2626                  (when (and arglist (arglist-p arglist))                            (arglist (apply #'arglist-ref arglist operator indices)))
2627                    ;; It would be possible to complete keywords only if we                       (when (and arglist (arglist-p arglist))
2628                    ;; are in a keyword position, but it is not clear if we                         ;; It would be possible to complete keywords only if we
2629                    ;; want that.                         ;; are in a keyword position, but it is not clear if we
2630                    (let* ((keywords                         ;; want that.
2631                            (mapcar #'keyword-arg.keyword                         (let* ((keywords
2632                                    (arglist.keyword-args arglist)))                                 (mapcar #'keyword-arg.keyword
2633                           (keyword-name                                         (arglist.keyword-args arglist)))
2634                            (tokenize-symbol keyword-string))                                (keyword-name
2635                           (matching-keywords                                 (tokenize-symbol keyword-string))
2636                            (find-matching-symbols-in-list keyword-name keywords                                (matching-keywords
2637                                                           #'compound-prefix-match))                                 (find-matching-symbols-in-list keyword-name keywords
2638                           (converter (completion-output-symbol-converter keyword-string))                                                                #'compound-prefix-match))
2639                           (strings                                (converter (completion-output-symbol-converter keyword-string))
2640                            (mapcar converter                                (strings
2641                                    (mapcar #'symbol-name matching-keywords)))                                 (mapcar converter
2642                           (completion-set                                         (mapcar #'symbol-name matching-keywords)))
2643                            (format-completion-set strings nil "")))                                (completion-set
2644                      (list completion-set                                 (format-completion-set strings nil "")))
2645                            (longest-compound-prefix completion-set))))))))))))                           (list completion-set
2646                                   (longest-compound-prefix completion-set)))))))))
2647            (mapc #'unintern newly-interned-symbols)))))
2648    
2649    
2650  (defun arglist-to-string (arglist package &key print-right-margin highlight)  (defun arglist-to-string (arglist package &key print-right-margin highlight)

Legend:
Removed from v.1.499  
changed lines
  Added in v.1.500

  ViewVC Help
Powered by ViewVC 1.1.5