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

Diff of /slime/swank-cmucl.lisp

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

revision 1.104 by heller, Sat May 22 08:14:39 2004 UTC revision 1.105 by lgorrie, Mon Jun 7 18:37:54 2004 UTC
# Line 988  Signal an error if no constructor can be Line 988  Signal an error if no constructor can be
988  (defun genericp (fn)  (defun genericp (fn)
989    (typep fn 'generic-function))    (typep fn 'generic-function))
990    
991    ;;;;;; Types and classes
992    
993    (defun type-definitions (name)
994      "Return `deftype' locations for type NAME."
995      (maybe-make-definition (ext:info :type :expander name) 'deftype name))
996    
997  (defun maybe-make-definition (function kind name)  (defun maybe-make-definition (function kind name)
998      "If FUNCTION is non-nil then return its definition location."
999    (if function    (if function
1000        (list (list `(,kind ,name) (function-location function)))))        (list (list `(,kind ,name) (function-location function)))))
1001    
1002  (defun type-definitions (name)  (defun class-definitions (name)
1003    (maybe-make-definition (ext:info :type :expander name) 'deftype name))    "Return the definition locations for the class called NAME."
1004      (if (symbolp name)
1005          (let ((class (kernel::find-class name nil)))
1006            (etypecase class
1007              (null '())
1008              (kernel::structure-class
1009               (list (list `(defstruct ,name) (dd-location (find-dd name)))))
1010              #+(or)
1011              (conditions::condition-class
1012               (list (list `(define-condition ,name)
1013                           (condition-class-location class))))
1014              (kernel::standard-class
1015               (list (list `(defclass ,name)
1016                           (class-location (find-class name)))))
1017              ((or kernel::built-in-class
1018                   conditions::condition-class
1019                   kernel:funcallable-structure-class)
1020               (list (list `(kernel::define-type-class ,name)
1021                           `(:error
1022                             ,(format nil "No source info for ~A" name)))))))))
1023    
1024    (defun class-location (class)
1025      "Return the `defclass' location for CLASS."
1026      (definition-source-location class (pcl:class-name class)))
1027    
1028  (defun find-dd (name)  (defun find-dd (name)
1029      "Find the defstruct-definition by the name of its structure-class."
1030    (let ((layout (ext:info :type :compiler-layout name)))    (let ((layout (ext:info :type :compiler-layout name)))
1031      (if layout      (if layout
1032          (kernel:layout-info layout))))          (kernel:layout-info layout))))
# Line 1006  Signal an error if no constructor can be Line 1037  Signal an error if no constructor can be
1037      (cond ((null slots)      (cond ((null slots)
1038             `(:error ,(format nil "No location info for condition: ~A" name)))             `(:error ,(format nil "No location info for condition: ~A" name)))
1039            (t            (t
1040               ;; Find the class via one of its slot-reader methods.
1041             (let* ((slot (first slots))             (let* ((slot (first slots))
1042                    (gf (fdefinition                    (gf (fdefinition
1043                         (first (conditions::condition-slot-readers slot)))))                         (first (conditions::condition-slot-readers slot)))))
# Line 1014  Signal an error if no constructor can be Line 1046  Signal an error if no constructor can be
1046                 (pcl:compute-applicable-methods-using-classes                 (pcl:compute-applicable-methods-using-classes
1047                  gf (list (find-class name))))))))))                  gf (list (find-class name))))))))))
1048    
 (defun class-location (class)  
   (definition-source-location class (pcl:class-name class)))  
   
1049  (defun make-name-in-file-location (file string)  (defun make-name-in-file-location (file string)
1050    (multiple-value-bind (filename c)    (multiple-value-bind (filename c)
1051        (ignore-errors        (ignore-errors
# Line 1093  Signal an error if no constructor can be Line 1122  Signal an error if no constructor can be
1122           (etypecase pathname           (etypecase pathname
1123             (pathname (make-name-in-file-location pathname (string name)))             (pathname (make-name-in-file-location pathname (string name)))
1124             (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))             (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
   
 (defun class-definitions (name)  
   (if (symbolp name)  
       (let ((class (kernel::find-class name nil)))  
         (etypecase class  
           (null '())  
           (kernel::structure-class  
            (list (list `(defstruct ,name) (dd-location (find-dd name)))))  
           #+(or)  
           (conditions::condition-class  
            (list (list `(define-condition ,name)  
                        (condition-class-location class))))  
           (kernel::standard-class  
            (list (list `(defclass ,name)  
                        (class-location (find-class name)))))  
           ((or kernel::built-in-class  
                conditions::condition-class  
                kernel:funcallable-structure-class)  
            (list (list `(kernel::define-type-class ,name)  
                        `(:error  
                          ,(format nil "No source info for ~A" name)))))))))  
1125    
1126  (defun setf-definitions (name)  (defun setf-definitions (name)
1127    (let ((function (or (ext:info :setf :inverse name)    (let ((function (or (ext:info :setf :inverse name)
# Line 1682  The `symbol-value' of each element is a Line 1690  The `symbol-value' of each element is a
1690    (eval `(profile:unprofile ,fname)))    (eval `(profile:unprofile ,fname)))
1691    
1692  (defimplementation unprofile-all ()  (defimplementation unprofile-all ()
1693    (eval '(profile:unprofile))    (profile:unprofile)
1694    "All functions unprofiled.")    "All functions unprofiled.")
1695    
1696  (defimplementation profile-report ()  (defimplementation profile-report ()
1697    (eval '(profile:report-time)))    (profile:report-time))
1698    
1699  (defimplementation profile-reset ()  (defimplementation profile-reset ()
1700    (eval '(profile:reset-time))    (profile:reset-time)
1701    "Reset profiling counters.")    "Reset profiling counters.")
1702    
1703  (defimplementation profiled-functions ()  (defimplementation profiled-functions ()
# Line 1698  The `symbol-value' of each element is a Line 1706  The `symbol-value' of each element is a
1706  (defimplementation profile-package (package callers methods)  (defimplementation profile-package (package callers methods)
1707    (profile:profile-all :package package    (profile:profile-all :package package
1708                         :callers-p callers                         :callers-p callers
1709                         :methods methods))                         #-cmu18e :methods #-cmu18e methods))
1710    
1711    
1712  ;;;; Multiprocessing  ;;;; Multiprocessing

Legend:
Removed from v.1.104  
changed lines
  Added in v.1.105

  ViewVC Help
Powered by ViewVC 1.1.5