/[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.8 by trittweiler, Sat Oct 24 11:32:18 2009 UTC revision 1.14 by sboukarev, Thu Jan 21 23:21:26 2010 UTC
# Line 52  Line 52 
52    
53  (in-package :swank-backend)  (in-package :swank-backend)
54    
 ;; Backward compatibility  
 (eval-when (:compile-toplevel)  
   (unless (fboundp 'ccl:compute-applicable-methods-using-classes)  
     (compile-file (make-pathname :name "swank-openmcl" :type "lisp" :defaults swank-loader::*source-directory*)  
                   :output-file (make-pathname :name "swank-ccl" :defaults swank-loader::*fasl-directory*)  
                   :verbose t)  
     (invoke-restart (find-restart 'ccl::skip-compile-file))))  
   
55  (eval-when (:compile-toplevel :execute :load-toplevel)  (eval-when (:compile-toplevel :execute :load-toplevel)
56    (assert (and (= ccl::*openmcl-major-version* 1)    (assert (and (= ccl::*openmcl-major-version* 1)
57                 (>= ccl::*openmcl-minor-version* 4))                 (>= ccl::*openmcl-minor-version* 4))
# Line 163  Line 155 
155    
156  ;;; Unix signals  ;;; Unix signals
157    
 (defimplementation call-without-interrupts (fn)  
   ;; This prevents the current thread from being interrupted, but it doesn't  
   ;; keep other threads from running concurrently, so it's not an appropriate  
   ;; replacement for locking.  
   (ccl:without-interrupts (funcall fn)))  
   
158  (defimplementation getpid ()  (defimplementation getpid ()
159    (ccl::getpid))    (ccl::getpid))
160    
# Line 448  Line 434 
434                       (format stream " ~s" arg)))))                       (format stream " ~s" arg)))))
435        (format stream ")"))))        (format stream ")"))))
436    
437    (defmacro with-frame ((p context) frame-number &body body)
438      `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
439    
440    (defimplementation frame-call (frame-number)
441      (with-frame (p context) frame-number
442        (with-output-to-string (stream)
443          (print-frame (list :frame p context) stream))))
444    
445  (defun call/frame (frame-number if-found)  (defun call/frame (frame-number if-found)
446    (map-backtrace    (map-backtrace
447     (lambda (p context)     (lambda (p context)
448       (return-from call/frame       (return-from call/frame
449         (funcall if-found p context)))         (funcall if-found p context)))
450     frame-number))     frame-number))
451    
 (defmacro with-frame ((p context) frame-number &body body)  
   `(call/frame ,frame-number (lambda (,p ,context) . ,body)))  
452    
453  (defimplementation frame-var-value (frame var)  (defimplementation frame-var-value (frame var)
454    (with-frame (p context) frame    (with-frame (p context) frame
# Line 545  Line 537 
537    
538  (defun function-source-location (function)  (defun function-source-location (function)
539    (source-note-to-source-location    (source-note-to-source-location
540     (ccl:function-source-note function)     (or (ccl:function-source-note function)
541           (function-name-source-note function))
542     (lambda ()     (lambda ()
543       (format nil "Function has no source note: ~A" function))       (format nil "Function has no source note: ~A" function))
544     (ccl:function-name function)))     (ccl:function-name function)))
# Line 553  Line 546 
546  (defun pc-source-location (function pc)  (defun pc-source-location (function pc)
547    (source-note-to-source-location    (source-note-to-source-location
548     (or (ccl:find-source-note-at-pc function pc)     (or (ccl:find-source-note-at-pc function pc)
549         (ccl:function-source-note function))         (ccl:function-source-note function)
550           (function-name-source-note function))
551     (lambda ()     (lambda ()
552       (format nil "No source note at PC: ~a[~d]" function pc))       (format nil "No source note at PC: ~a[~d]" function pc))
553     (ccl:function-name function)))     (ccl:function-name function)))
554    
555    (defun function-name-source-note (fun)
556      (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
557        (and defs
558             (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
559               (declare (ignore type name srclocs))
560               srcloc))))
561    
562  (defun source-note-to-source-location (source if-nil-thunk &optional name)  (defun source-note-to-source-location (source if-nil-thunk &optional name)
563    (labels ((filename-to-buffer (filename)    (labels ((filename-to-buffer (filename)
564               (cond ((gethash filename *temp-file-map*)               (cond ((gethash filename *temp-file-map*)
# Line 728  Line 729 
729    (queue '() :type list))    (queue '() :type list))
730    
731  (defimplementation spawn (fun &key name)  (defimplementation spawn (fun &key name)
732    (ccl:process-run-function    (ccl:process-run-function (or name "Anonymous (Swank)")
733     (or name "Anonymous (Swank)")                              fun))
    fun))  
734    
735  (defimplementation thread-id (thread)  (defimplementation thread-id (thread)
736    (ccl:process-serial-number thread))    (ccl:process-serial-number thread))
# Line 761  Line 761 
761    (ccl:all-processes))    (ccl:all-processes))
762    
763  (defimplementation kill-thread (thread)  (defimplementation kill-thread (thread)
764    (ccl:process-kill thread))    ;;(ccl:process-kill thread) ; doesn't cut it
765      (ccl::process-initial-form-exited thread :kill))
766    
767  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
768    (not (ccl:process-exhausted-p thread)))    (not (ccl:process-exhausted-p thread)))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.14

  ViewVC Help
Powered by ViewVC 1.1.5