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

Diff of /slime/swank.lisp

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

revision 1.504 by trittweiler, Tue Aug 28 20:44:41 2007 UTC revision 1.505 by trittweiler, Tue Aug 28 21:13:57 2007 UTC
# Line 282  recently established one." Line 282  recently established one."
282    (emacs-connected))    (emacs-connected))
283    
284    
285  ;;;; Helper macros  ;;;; Utilities
286    
287    ;;;;; Helper macros
288    
289  (defmacro with-io-redirection ((connection) &body body)  (defmacro with-io-redirection ((connection) &body body)
290    "Execute BODY I/O redirection to CONNECTION.    "Execute BODY I/O redirection to CONNECTION.
# Line 338  The package is deleted before returning. Line 340  The package is deleted before returning.
340       (unwind-protect (progn ,@body)       (unwind-protect (progn ,@body)
341         (delete-package ,var))))         (delete-package ,var))))
342    
343    (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
344      "Just like do-symbols, but makes sure a symbol is visited only once."
345      (let ((seen-ht (gensym "SEEN-HT")))
346        `(let ((,seen-ht (make-hash-table :test #'eq)))
347          (do-symbols (,var ,package ,result-form)
348            (unless (gethash ,var ,seen-ht)
349              (setf (gethash ,var ,seen-ht) t)
350              ,@body)))))
351    
352    
353    ;;;;; Logging
354    
355  (defvar *log-events* nil)  (defvar *log-events* nil)
356  (defvar *log-output* *error-output*)  (defvar *log-output* *error-output*)
357  (defvar *event-history* (make-array 40 :initial-element nil)  (defvar *event-history* (make-array 40 :initial-element nil)
# Line 392  Useful for low level debugging." Line 406  Useful for low level debugging."
406  (defun ascii-char-p (c)  (defun ascii-char-p (c)
407    (<= (char-code c) 127))    (<= (char-code c) 127))
408    
409    
410    ;;;;; Misc
411    
412  (defun length= (seq n)  (defun length= (seq n)
413    "Test for whether SEQ contains N number of elements. I.e. it's equivalent    "Test for whether SEQ contains N number of elements. I.e. it's equivalent
414   to (= (LENGTH SEQ) N), but besides being more concise, it may also be more   to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
# Line 426  Otherwise NIL is returned." Line 443  Otherwise NIL is returned."
443                    (setq found v))))                    (setq found v))))
444      found))      found))
445    
446  (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)  
447    "Just like do-symbols, but makes sure a symbol is visited only once."  ;;;;; Symbols
448    (let ((seen-ht (gensym "SEEN-HT")))  
449      `(let ((,seen-ht (make-hash-table :test #'eq)))  (defun symbol-status (symbol &optional (package (symbol-package symbol)))
450        (do-symbols (,var ,package ,result-form)    "Returns one of
451          (unless (gethash ,var ,seen-ht)  
452            (setf (gethash ,var ,seen-ht) t)    :INTERNAL  if the symbol is _present_ in PACKAGE as an _internal_ symbol,
453            ,@body)))))  
454      :EXTERNAL  if the symbol is _present_ in PACKAGE as an _external_ symbol,
455    
456      :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
457                 but is not _present_ in PACKAGE,
458    
459      or NIL     if SYMBOL is not _accessible_ in PACKAGE.
460    
461    
462    Be aware not to get confused with :INTERNAL and how \"internal
463    symbols\" are defined in the spec; there is a slight mismatch of
464    definition with the Spec and what's commonly meant when talking
465    about internal symbols most times. As the spec says:
466    
467      In a package P, a symbol S is
468    
469         _accessible_  if S is either _present_ in P itself or was
470                       inherited from another package Q (which implies
471                       that S is _external_ in Q.)
472    
473            You can check that with: (AND (SYMBOL-STATUS S P) T)
474    
475    
476         _present_     if either P is the /home package/ of S or S has been
477                       imported into P or exported from P by IMPORT, or
478                       EXPORT respectively.
479    
480                       Or more simply, if S is not _inherited_.
481    
482            You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
483                                       (AND STATUS
484                                            (NOT (EQ STATUS :INHERITED))))
485    
486    
487         _external_    if S is going to be inherited into any package that
488                       /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
489                       DEFPACKAGE.
490    
491                       Note that _external_ implies _present_, since to
492                       make a symbol _external_, you'd have to use EXPORT
493                       which will automatically make the symbol _present_.
494    
495            You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
496    
497    
498         _internal_    if S is _accessible_ but not _external_.
499    
500            You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
501                                       (AND STATUS
502                                            (NOT (EQ STATUS :EXTERNAL))))
503    
504    
505            Notice that this is *different* to
506                                     (EQ (SYMBOL-STATUS S P) :INTERNAL)
507            because what the spec considers _internal_ is split up into two
508            explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
509            CL:FIND-SYMBOL does.
510    
511            The rationale is that most times when you speak about \"internal\"
512            symbols, you're actually not including the symbols inherited
513            from other packages, but only about the symbols directly specific
514            to the package in question.
515    "
516      (when package     ; may be NIL when symbol is completely uninterned.
517        (check-type symbol symbol) (check-type package package)
518        (multiple-value-bind (present-symbol status)
519            (find-symbol (symbol-name symbol) package)
520          (and (eq symbol present-symbol) status))))
521    
522    (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
523      "True if SYMBOL is external in PACKAGE.
524    If PACKAGE is not specified, the home package of SYMBOL is used."
525      (eq (symbol-status symbol package) :external))
526    
527    
528    (defun classify-symbol (symbol)
529      "Returns a list of classifiers that classify SYMBOL according
530    to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a
531    special variable.) The list may contain the following classification
532    keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO,
533    :SPECIAL-OPERATOR, and/or :PACKAGE"
534      (check-type symbol symbol)
535      (let (result)
536        (when (boundp symbol)             (push :boundp result))
537        (when (fboundp symbol)            (push :fboundp result))
538        (when (find-class symbol nil)     (push :class result))
539        (when (macro-function symbol)     (push :macro result))
540        (when (special-operator-p symbol) (push :special-operator result))
541        (when (find-package symbol)       (push :package result))
542        (when (typep (ignore-errors (fdefinition symbol))
543                     'generic-function)
544          (push :generic-function result))
545        result))
546    
547    (defun symbol-classification->string (flags)
548      (format nil "~A~A~A~A~A~A~A"
549              (if (member :boundp flags) "b" "-")
550              (if (member :fboundp flags) "f" "-")
551              (if (member :generic-function flags) "g" "-")
552              (if (member :class flags) "c" "-")
553              (if (member :macro flags) "m" "-")
554              (if (member :special-operator flags) "s" "-")
555              (if (member :package flags) "p" "-")))
556    
557    
558  ;;;; TCP Server  ;;;; TCP Server
# Line 3497  MATCHER is a two-argument predicate." Line 3616  MATCHER is a two-argument predicate."
3616                                   append (package-nicknames package))))))                                   append (package-nicknames package))))))
3617    
3618    
 (defun symbol-status (symbol &optional (package (symbol-package symbol)))  
   "Returns one of  
   
   :INTERNAL  if the symbol is _present_ in PACKAGE as an _internal_ symbol,  
   
   :EXTERNAL  if the symbol is _present_ in PACKAGE as an _external_ symbol,  
   
   :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,  
              but is not _present_ in PACKAGE,  
   
   or NIL     if SYMBOL is not _accessible_ in PACKAGE.  
   
   
 Be aware not to get confused with :INTERNAL and how \"internal  
 symbols\" are defined in the spec; there is a slight mismatch of  
 definition with the Spec and what's commonly meant when talking  
 about internal symbols most times. As the spec says:  
   
   In a package P, a symbol S is  
   
      _accessible_  if S is either _present_ in P itself or was  
                    inherited from another package Q (which implies  
                    that S is _external_ in Q.)  
   
         You can check that with: (AND (SYMBOL-STATUS S P) T)  
   
   
      _present_     if either P is the /home package/ of S or S has been  
                    imported into P or exported from P by IMPORT, or  
                    EXPORT respectively.  
   
                    Or more simply, if S is not _inherited_.  
   
         You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))  
                                    (AND STATUS  
                                         (NOT (EQ STATUS :INHERITED))))  
   
   
      _external_    if S is going to be inherited into any package that  
                    /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or  
                    DEFPACKAGE.  
   
                    Note that _external_ implies _present_, since to  
                    make a symbol _external_, you'd have to use EXPORT  
                    which will automatically make the symbol _present_.  
   
         You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)  
   
   
      _internal_    if S is _accessible_ but not _external_.  
   
         You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))  
                                    (AND STATUS  
                                         (NOT (EQ STATUS :EXTERNAL))))  
   
   
         Notice that this is *different* to  
                                  (EQ (SYMBOL-STATUS S P) :INTERNAL)  
         because what the spec considers _internal_ is split up into two  
         explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,  
         CL:FIND-SYMBOL does.  
   
         The rationale is that most times when you speak about \"internal\"  
         symbols, you're actually not including the symbols inherited  
         from other packages, but only about the symbols directly specific  
         to the package in question.  
 "  
   (when package     ; may be NIL when symbol is completely uninterned.  
     (check-type symbol symbol) (check-type package package)  
     (multiple-value-bind (present-symbol status)  
         (find-symbol (symbol-name symbol) package)  
       (and (eq symbol present-symbol) status))))  
   
 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))  
   "True if SYMBOL is external in PACKAGE.  
 If PACKAGE is not specified, the home package of SYMBOL is used."  
   (eq (symbol-status symbol package) :external))  
   
   
3619  ;; PARSE-COMPLETION-ARGUMENTS return table:  ;; PARSE-COMPLETION-ARGUMENTS return table:
3620  ;;  ;;
3621  ;;  user behaviour |  NAME  | PACKAGE-NAME | PACKAGE  ;;  user behaviour |  NAME  | PACKAGE-NAME | PACKAGE

Legend:
Removed from v.1.504  
changed lines
  Added in v.1.505

  ViewVC Help
Powered by ViewVC 1.1.5