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

Diff of /slime/swank-lispworks.lisp

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

revision 1.128 by heller, Sat Jan 10 12:25:16 2009 UTC revision 1.132 by sboukarev, Wed Sep 2 17:21:15 2009 UTC
# Line 15  Line 15 
15    (import-from :stream *gray-stream-symbols* :swank-backend))    (import-from :stream *gray-stream-symbols* :swank-backend))
16    
17  (import-swank-mop-symbols :clos '(:slot-definition-documentation  (import-swank-mop-symbols :clos '(:slot-definition-documentation
18                                      :slot-boundp-using-class
19                                      :slot-value-using-class
20                                      :slot-makunbound-using-class
21                                    :eql-specializer                                    :eql-specializer
22                                    :eql-specializer-object                                    :eql-specializer-object
23                                    :compute-applicable-methods-using-classes))                                    :compute-applicable-methods-using-classes))
# Line 22  Line 25 
25  (defun swank-mop:slot-definition-documentation (slot)  (defun swank-mop:slot-definition-documentation (slot)
26    (documentation slot t))    (documentation slot t))
27    
28    (defun swank-mop:slot-boundp-using-class (class object slotd)
29      (clos:slot-boundp-using-class class object
30                                    (clos:slot-definition-name slotd)))
31    
32    (defun swank-mop:slot-value-using-class (class object slotd)
33      (clos:slot-value-using-class class object
34                                   (clos:slot-definition-name slotd)))
35    
36    (defun (setf swank-mop:slot-value-using-class) (value class object slotd)
37      (setf (clos:slot-value-using-class class object
38                                         (clos:slot-definition-name slotd))
39            value))
40    
41    (defun swank-mop:slot-makunbound-using-class (class object slotd)
42      (clos:slot-makunbound-using-class class object
43                                        (clos:slot-definition-name slotd)))
44    
45  (defun swank-mop:compute-applicable-methods-using-classes (gf classes)  (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
46    (clos::compute-applicable-methods-from-classes gf classes))    (clos::compute-applicable-methods-from-classes gf classes))
47    
# Line 164  Line 184 
184    
185  ;;;; Documentation  ;;;; Documentation
186    
187    (defun replace-strings-with-symbols (tree)
188      (mapcar (lambda (x)
189                (typecase x
190                  (list
191                   (replace-strings-with-symbols x))
192                  (symbol
193                   x)
194                  (string
195                   (intern x))
196                  (t
197                   (intern (write-to-string x)))))
198              tree))
199    
200  (defimplementation arglist (symbol-or-function)  (defimplementation arglist (symbol-or-function)
201    (let ((arglist (lw:function-lambda-list symbol-or-function)))    (let ((arglist (lw:function-lambda-list symbol-or-function)))
202      (etypecase arglist      (etypecase arglist
203        ((member :dont-know)        ((member :dont-know)
204         :not-available)         :not-available)
205        (list        (list
206         arglist))))         (replace-strings-with-symbols arglist)))))
207    
208  (defimplementation function-name (function)  (defimplementation function-name (function)
209    (nth-value 2 (function-lambda-expression function)))    (nth-value 2 (function-lambda-expression function)))
# Line 363  Return NIL if the symbol is unbound." Line 396  Return NIL if the symbol is unbound."
396        (declare (ignore _n _s _l))        (declare (ignore _n _s _l))
397        value)))        value)))
398    
399  (defimplementation frame-source-location-for-emacs (frame)  (defimplementation frame-source-location (frame)
400    (let ((frame (nth-frame frame))    (let ((frame (nth-frame frame))
401          (callee (if (plusp frame) (nth-frame (1- frame)))))          (callee (if (plusp frame) (nth-frame (1- frame)))))
402      (if (dbg::call-frame-p frame)      (if (dbg::call-frame-p frame)
# Line 839  function names like \(SETF GET)." Line 872  function names like \(SETF GET)."
872          (acons var `(eval (quote ,form))          (acons var `(eval (quote ,form))
873                 mp:*process-initial-bindings* )))                 mp:*process-initial-bindings* )))
874    
875    (defimplementation thread-attributes (thread)
876      (list :priority (mp:process-priority thread)
877            :idle (mp:process-idle-time thread)))
878    
879  ;;; Some intergration with the lispworks environment  ;;; Some intergration with the lispworks environment
880    
881  (defun swank-sym (name) (find-symbol (string name) :swank))  (defun swank-sym (name) (find-symbol (string name) :swank))

Legend:
Removed from v.1.128  
changed lines
  Added in v.1.132

  ViewVC Help
Powered by ViewVC 1.1.5