/[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.20 by heller, Thu May 27 14:48:19 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 148  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 197  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 216  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 227  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 752  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 768  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.20  
changed lines
  Added in v.1.29

  ViewVC Help
Powered by ViewVC 1.1.5