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

Diff of /slime/swank-allegro.lisp

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

revision 1.59 by mbaringer, Fri Sep 17 12:48:39 2004 UTC revision 1.60 by heller, Fri Oct 1 12:16:44 2004 UTC
# Line 2  Line 2 
2  ;;;  ;;;
3  ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.  ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4  ;;;  ;;;
5  ;;; Created 2003, Helmut Eller  ;;; Created 2003
6  ;;;  ;;;
7  ;;; This code has been placed in the Public Domain.  All warranties  ;;; This code has been placed in the Public Domain.  All warranties
8  ;;; are disclaimed. This code was written for "Allegro CL Trial  ;;; are disclaimed. This code was written for "Allegro CL Trial
# Line 29  Line 29 
29    
30  ;;; swank-mop  ;;; swank-mop
31    
32  ;; maybe better change MOP to ACLMOP ?  ;; maybe better change MOP to ACLMOP ?
33  (import-to-swank-mop  ;; CLOS also works in ACL5. --he
34   '( ;; classes  (import-swank-mop-symbols :clos '(:slot-definition-documentation))
    cl:standard-generic-function  
    mop::standard-slot-definition  
    cl:method  
    cl:standard-class  
    mop:eql-specializer  
    ;; standard-class readers  
    mop:class-default-initargs  
    mop:class-direct-default-initargs  
    mop:class-direct-slots  
    mop:class-direct-subclasses  
    mop:class-direct-superclasses  
    mop:class-finalized-p  
    cl:class-name  
    mop:class-precedence-list  
    mop:class-prototype  
    mop:class-slots  
    mop:specializer-direct-methods  
    ;; eql-specializer accessors  
    mop:eql-specializer-object  
    ;; generic function readers  
    mop:generic-function-argument-precedence-order  
    mop:generic-function-declarations  
    mop:generic-function-lambda-list  
    mop:generic-function-methods  
    mop:generic-function-method-class  
    mop:generic-function-method-combination  
    mop:generic-function-name  
    ;; method readers  
    mop:method-generic-function  
    mop:method-function  
    mop:method-lambda-list  
    mop:method-specializers  
    excl::method-qualifiers  
    ;; slot readers  
    mop:slot-definition-allocation  
    mop:slot-definition-initargs  
    mop:slot-definition-initform  
    mop:slot-definition-initfunction  
    mop:slot-definition-name  
    mop:slot-definition-type  
    mop:slot-definition-readers  
    mop:slot-definition-writers))  
35    
36  (defun swank-mop:slot-definition-documentation (slot)  (defun swank-mop:slot-definition-documentation (slot)
37    (documentation slot))    (documentation slot))
# Line 316  Line 274 
274      (symbol (string fspec))      (symbol (string fspec))
275      (list (string (second fspec)))))      (list (string (second fspec)))))
276    
277    (defun find-definition-in-file (fspec type file)
278      (let* ((start (scm:find-definition-in-file fspec type file))
279             (pos (if start
280                      (list :position (1+ start))
281                      (list :function-name (fspec-primary-name fspec)))))
282             (make-location (list :file (namestring (truename file)))
283                            pos)))
284    
285    (defun find-definition-in-buffer (filename)
286      (let ((pos (position #\; filename :from-end t)))
287        (make-location
288         (list :buffer (subseq filename 0 pos))
289         (list :position (parse-integer (subseq filename (1+ pos)))))))
290    
291  (defun find-fspec-location (fspec type)  (defun find-fspec-location (fspec type)
292    (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))    (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))
293      (etypecase file      (etypecase file
294        (pathname        (pathname
295         (let* ((start (scm:find-definition-in-file fspec type file))         (find-definition-in-file fspec type file))
               (pos (if start  
                        (list :position (1+ start))  
                        (list :function-name (fspec-primary-name fspec)))))  
          (make-location (list :file (namestring (truename file)))  
                         pos)))  
296        ((member :top-level)        ((member :top-level)
297         (list :error (format nil "Defined at toplevel: ~A"         (list :error (format nil "Defined at toplevel: ~A"
298                              (fspec->string fspec))))                              (fspec->string fspec))))
299        (string        (string
300         (let ((pos (position #\; file :from-end t)))         (find-definition-in-buffer file))
          (make-location  
           (list :buffer (subseq file 0 pos))  
           (list :position (parse-integer (subseq file (1+ pos)))))))  
301        (null        (null
302         (list :error (if err         (list :error (if err
303                          (princ-to-string err)                          (princ-to-string err)
304                          (format nil "Unknown source location for ~A"                          (format nil "Unknown source location for ~A"
305                                  (fspec->string fspec))))))))                                  (fspec->string fspec)))))
306          (cons
307           (destructuring-bind ((type . filename)) file
308             (assert (member type '(:operator)))
309             (etypecase filename
310               (pathname
311                (find-definition-in-file fspec type filename))
312               (string
313                (find-definition-in-buffer filename))))))))
314    
315  (defun fspec->string (fspec)  (defun fspec->string (fspec)
316    (etypecase fspec    (etypecase fspec
# Line 447  Line 419 
419            `("Name: " (:value ,(function-name f)) (:newline)            `("Name: " (:value ,(function-name f)) (:newline)
420              "Its argument list is: " ,(princ-to-string (arglist f)) (:newline)              "Its argument list is: " ,(princ-to-string (arglist f)) (:newline)
421              "Documentation:" (:newline)              "Documentation:" (:newline)
422              ;; AllegroCL doesn't support (documentation <function-obj> t)              ,(documentation f 'function))))
             ;; so we get the symbol and then its doc  
             ,(documentation (excl::external-fn_symdef f) 'function))))  
423    
424  (defmethod inspect-for-emacs ((class structure-class) (inspector acl-inspector))  (defmethod inspect-for-emacs ((class structure-class) (inspector acl-inspector))
425    (values "A structure class."    (values "A structure class."
# Line 486  Line 456 
456                                 `(:value ,(swank-mop:class-prototype class))                                 `(:value ,(swank-mop:class-prototype class))
457                                 '"N/A (class not finalized)"))))                                 '"N/A (class not finalized)"))))
458    
459  (defmethod inspect-for-emacs ((slot excl::structure-slot-definition) (inspector acl-inspector))  #-:allegro-v5.0
460    (defmethod inspect-for-emacs ((slot excl::structure-slot-definition)
461                                  (inspector acl-inspector))
462    (values "A structure slot."    (values "A structure slot."
463            `("Name: " (:value ,(mop:slot-definition-name slot))            `("Name: " (:value ,(swank-mop:slot-definition-name slot))
464              (:newline)              (:newline)
465              "Documentation:" (:newline)              "Documentation:" (:newline)
466              ,@(when (documentation slot)              ,@(when (documentation slot)

Legend:
Removed from v.1.59  
changed lines
  Added in v.1.60

  ViewVC Help
Powered by ViewVC 1.1.5