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

Diff of /slime/swank-ccl.lisp

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

revision 1.17 by heller, Fri Mar 5 17:45:26 2010 UTC revision 1.29 by sboukarev, Mon Dec 3 03:43:16 2012 UTC
# Line 23  Line 23 
23  (import-from :ccl *gray-stream-symbols* :swank-backend)  (import-from :ccl *gray-stream-symbols* :swank-backend)
24    
25  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
26    (require 'xref))    (multiple-value-bind (ok err) (ignore-errors (require 'xref))
27        (unless ok
28          (warn "~a~%" err))))
29    
30  ;;; swank-mop  ;;; swank-mop
31    
# Line 82  Line 84 
84    (let ((str (symbol-name sym)))    (let ((str (symbol-name sym)))
85      `(or (find-symbol ,str :swank)      `(or (find-symbol ,str :swank)
86           (error "There is no symbol named ~a in the SWANK package" ,str))))           (error "There is no symbol named ~a in the SWANK package" ,str))))
87    ;;; UTF8
88    
89    (defimplementation string-to-utf8 (string)
90      (ccl:encode-string-to-octets string :external-format :utf-8))
91    
92    (defimplementation utf8-to-string (octets)
93      (ccl:decode-string-from-octets octets :external-format :utf-8))
94    
95  ;;; TCP Server  ;;; TCP Server
96    
97  (defimplementation preferred-communication-style ()  (defimplementation preferred-communication-style ()
98    :spawn)    :spawn)
99    
100  (defimplementation create-socket (host port)  (defimplementation create-socket (host port &key backlog)
101    (ccl:make-socket :connect :passive :local-port port    (ccl:make-socket :connect :passive :local-port port
102                     :local-host host :reuse-address t))                     :local-host host :reuse-address t
103                       :backlog (or backlog 5)))
104    
105  (defimplementation local-port (socket)  (defimplementation local-port (socket)
106    (ccl:local-port socket))    (ccl:local-port socket))
# Line 115  Line 125 
125    (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))    (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
126                    *external-format-to-coding-system*)))                    *external-format-to-coding-system*)))
127    
128    (defimplementation socket-fd (stream)
129      (ccl::ioblock-device (ccl::stream-ioblock stream t)))
130    
131  ;;; Unix signals  ;;; Unix signals
132    
133  (defimplementation getpid ()  (defimplementation getpid ()
# Line 145  Line 158 
158    
159  (defun handle-compiler-warning (condition)  (defun handle-compiler-warning (condition)
160    "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."    "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."
161    (signal (make-condition    (signal 'compiler-condition
162             'compiler-condition            :original-condition condition
163             :original-condition condition            :message (compiler-warning-short-message condition)
164             :message (compiler-warning-short-message condition)            :source-context nil
165             :source-context nil            :severity (compiler-warning-severity condition)
166             :severity (compiler-warning-severity condition)            :location (source-note-to-source-location
167             :location (source-note-to-source-location                       (ccl:compiler-warning-source-note condition)
168                        (ccl:compiler-warning-source-note condition)                       (lambda () "Unknown source")
169                        (lambda () "Unknown source")                       (ccl:compiler-warning-function-name condition))))
                       (ccl:compiler-warning-function-name condition)))))  
170    
171  (defgeneric compiler-warning-severity (condition))  (defgeneric compiler-warning-severity (condition))
172  (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)  (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
# Line 194  Line 206 
206        (unwind-protect        (unwind-protect
207             (progn             (progn
208               (with-open-file (s temp-file-name :direction :output               (with-open-file (s temp-file-name :direction :output
209                                  :if-exists :error)                                  :if-exists :error :external-format :utf-8)
210                 (write-string string s))                 (write-string string s))
211               (let ((binary-filename (compile-temp-file               (let ((binary-filename (compile-temp-file
212                                       temp-file-name filename buffer position)))                                       temp-file-name filename buffer position)))
# Line 213  Line 225 
225                        (setf (gethash temp-file-name *temp-file-map*)                        (setf (gethash temp-file-name *temp-file-map*)
226                              buffer-name)                              buffer-name)
227                        temp-file-name))                        temp-file-name))
228                  :compile-file-original-buffer-offset (1- offset)))                  :compile-file-original-buffer-offset (1- offset)
229                    :external-format :utf-8))
230    
231  (defimplementation save-image (filename &optional restart-function)  (defimplementation save-image (filename &optional restart-function)
232    (ccl:save-application filename :toplevel-function restart-function))    (ccl:save-application filename :toplevel-function restart-function))
# Line 224  Line 237 
237    (delete-duplicates    (delete-duplicates
238     (mapcan #'find-definitions     (mapcan #'find-definitions
239             (if inverse             (if inverse
240               (ccl:get-relation relation name :wild :exhaustive t)               (ccl::get-relation relation name :wild :exhaustive t)
241               (ccl:get-relation relation :wild name :exhaustive t)))               (ccl::get-relation relation :wild name :exhaustive t)))
242     :test 'equal))     :test 'equal))
243    
244  (defimplementation who-binds (name)  (defimplementation who-binds (name)
# Line 300  Line 313 
313    
314  ;;; Debugging  ;;; Debugging
315    
 (defun openmcl-set-debug-switches ()  
   (setq ccl:*fasl-save-definitions* nil)  
   (setq ccl:*fasl-save-doc-strings* t)  
   (setq ccl:*fasl-save-local-symbols* t)  
   (setq ccl:*save-arglist-info* t)  
   (setq ccl:*save-definitions* nil)  
   (setq ccl:*save-doc-strings* t)  
   (setq ccl:*save-local-symbols* t)  
   (ccl:start-xref))  
   
316  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
317    (let* (;;(*debugger-hook* nil)    (let* (;;(*debugger-hook* nil)
318           ;; don't let error while printing error take us down           ;; don't let error while printing error take us down
# Line 320  Line 323 
323  ;; thread not selected by the user, so don't use thread-local vars  ;; thread not selected by the user, so don't use thread-local vars
324  ;; such as *emacs-connection*.  ;; such as *emacs-connection*.
325  (defun find-repl-thread ()  (defun find-repl-thread ()
326    (let* ((conn (funcall (swank-sym default-connection))))    (let* ((*break-on-signals* nil)
327             (conn (funcall (swank-sym default-connection))))
328      (and conn      (and conn
329           (let ((*break-on-signals* nil))           (ignore-errors ;; this errors if no repl-thread
330             (ignore-errors ;; this errors if no repl-thread             (funcall (swank-sym repl-thread) conn)))))
331               (funcall (swank-sym repl-thread) conn))))))  
   
332  (defimplementation call-with-debugger-hook (hook fun)  (defimplementation call-with-debugger-hook (hook fun)
333    (let ((*debugger-hook* hook)    (let ((*debugger-hook* hook)
334          (ccl:*break-hook* hook)          (ccl:*break-hook* hook)
# Line 347  Line 350 
350      (ccl:map-call-frames function      (ccl:map-call-frames function
351                           :origin ccl:*top-error-frame*                           :origin ccl:*top-error-frame*
352                           :start-frame-number start-frame-number                           :start-frame-number start-frame-number
353                           :count (- end-frame-number start-frame-number)                           :count (- end-frame-number start-frame-number))))
                          :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))  
                                     'interesting-frame-p))))  
   
 ;; Exceptions  
 (defvar *interesting-internal-frames* ())  
   
 (defun interesting-frame-p (p context)  
   ;; A frame is interesting if it has at least one external symbol in its name.  
   (labels ((internal (obj)  
              ;; For a symbol, return true if the symbol is internal, i.e. not  
              ;; declared to be external.  For a cons or list, everything  
              ;; must be internal.  For a method, the name must be internal.  
              ;; Nothing else is internal.  
              (typecase obj  
                (cons (and (internal (car obj)) (internal (cdr obj))))  
                (symbol (and (eq (symbol-package obj) (find-package :ccl))  
                             (eq :internal (nth-value 1 (find-symbol (symbol-name obj) :ccl)))  
                             (not (member obj *interesting-internal-frames*))))  
                (method (internal (ccl:method-name obj)))  
                (t nil))))  
     (let* ((lfun (ccl:frame-function p context))  
            (internal-frame-p (internal (ccl:function-name lfun))))  
       #+debug (format t "~S is ~@[not ~]internal~%"  
                       (ccl:function-name lfun)  
                       (not internal-frame-p))  
       (not internal-frame-p))))  
   
354    
355  (defimplementation compute-backtrace (start-frame-number end-frame-number)  (defimplementation compute-backtrace (start-frame-number end-frame-number)
356    (let (result)    (let (result)
# Line 665  Line 641 
641                                   "Underlying UVECTOR"))))                                   "Underlying UVECTOR"))))
642                (t value)))))                (t value)))))
643    
644    (defmethod emacs-inspect ((f function))
645      (append
646       (label-value-line "Name" (function-name f))
647       `("Its argument list is: "
648         ,(princ-to-string (arglist f)) (:newline))
649       (label-value-line "Documentation" (documentation  f t))
650       (when (function-lambda-expression f)
651         (label-value-line "Lambda Expression"
652                           (function-lambda-expression f)))
653       (when (ccl:function-source-note f)
654         (label-value-line "Source note"
655                           (ccl:function-source-note f)))
656       (when (typep f 'ccl:compiled-lexical-closure)
657         (append
658          (label-value-line "Inner function" (ccl::closure-function f))
659          '("Closed over values:" (:newline))
660          (loop for (name value) in (ccl::closure-closed-over-values f)
661                append (label-value-line (format nil " ~a" name)
662                                         value))))))
663    
664  (defclass uvector-inspector ()  (defclass uvector-inspector ()
665    ((object :initarg :object)))    ((object :initarg :object)))
666    
# Line 766  Line 762 
762       (when (eq timeout t) (return (values nil t)))       (when (eq timeout t) (return (values nil t)))
763       (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))       (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
764    
765    (let ((alist '())
766          (lock (ccl:make-lock "register-thread")))
767    
768      (defimplementation register-thread (name thread)
769        (declare (type symbol name))
770        (ccl:with-lock-grabbed (lock)
771          (etypecase thread
772            (null
773             (setf alist (delete name alist :key #'car)))
774            (ccl:process
775             (let ((probe (assoc name alist)))
776               (cond (probe (setf (cdr probe) thread))
777                     (t (setf alist (acons name thread alist))))))))
778        nil)
779    
780      (defimplementation find-registered (name)
781        (ccl:with-lock-grabbed (lock)
782          (cdr (assoc name alist)))))
783    
784  (defimplementation set-default-initial-binding (var form)  (defimplementation set-default-initial-binding (var form)
785    (eval `(ccl::def-standard-initial-binding ,var ,form)))    (eval `(ccl::def-standard-initial-binding ,var ,form)))
786    
# Line 782  Line 797 
797    
798  (defimplementation hash-table-weakness (hashtable)  (defimplementation hash-table-weakness (hashtable)
799    (ccl:hash-table-weak-p hashtable))    (ccl:hash-table-weak-p hashtable))
800    
801    (pushnew 'deinit-log-output ccl:*save-exit-functions*)

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.29

  ViewVC Help
Powered by ViewVC 1.1.5