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

Diff of /slime/swank-corman.lisp

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

revision 1.2 by ewiborg, Tue Jun 7 10:08:03 2005 UTC revision 1.3 by heller, Sun Jul 3 15:51:05 2005 UTC
# Line 182  Line 182 
182    (format stream "~S" frame))    (format stream "~S" frame))
183    
184  (defun get-frame-debug-info (frame)  (defun get-frame-debug-info (frame)
185    (let ((info (frame-debug-info frame)))    (or (frame-debug-info frame)
186      (if info        (setf (frame-debug-info frame)
187          info              (db::prepare-frame-debug-info (frame-function frame)
188          (setf (frame-debug-info frame)                                            (frame-address frame)))))
               (db::prepare-frame-debug-info (frame-function frame)  
                                             (frame-address frame))))))  
189    
190  (defimplementation frame-locals (frame-number)  (defimplementation frame-locals (frame-number)
191    (let* ((frame (elt *frame-trace* frame-number))    (let* ((frame (elt *frame-trace* frame-number))
# Line 255  Line 253 
253                                (truename (merge-pathnames directory)))))                                (truename (merge-pathnames directory)))))
254    
255  (defimplementation default-directory ()  (defimplementation default-directory ()
256    (ccl:current-directory))    (directory-namestring (ccl:current-directory)))
257    
258  (defimplementation macroexpand-all (form)  (defimplementation macroexpand-all (form)
259    (ccl:macroexpand-all form))    (ccl:macroexpand-all form))
# Line 273  Line 271 
271                                                ccl:*cormanlisp-directory*))))                                                ccl:*cormanlisp-directory*))))
272                (make-location (list :file (namestring truename))                (make-location (list :file (namestring truename))
273                               (if (ccl::function-source-line fspec)                               (if (ccl::function-source-line fspec)
274                                   (list :line (ccl::function-source-line fspec))                                   (list :line
275                                           (1+ (ccl::function-source-line fspec)))
276                                   (list :function-name (princ-to-string                                   (list :function-name (princ-to-string
277                                                         (function-name fspec))))))                                                         (function-name fspec))))))
278            (error (c) (list :error (princ-to-string c))))            (error (c) (list :error (princ-to-string c))))
# Line 461  Line 460 
460                                (not (probe-file pathname)))                                (not (probe-file pathname)))
461                      (label-value-line "Truename" (truename pathname))))))                      (label-value-line "Truename" (truename pathname))))))
462    
463    (defimplementation inspect-for-emacs ((o t) (inspector corman-inspector))
464      (cond ((cl::structurep o) (inspect-structure o))
465            (t (call-next-method))))
466    
467    (defun inspect-structure (o)
468      (values
469       (format nil "~A is a structure" o)
470       (let* ((template (cl::uref o 1))
471              (num-slots (cl::struct-template-num-slots template)))
472         (cond ((symbolp template)
473                (loop for i below num-slots
474                      append (label-value-line i (cl::uref o (+ 2 i)))))
475               (t
476                (loop for i below num-slots
477                      append (label-value-line (elt template (+ 6 (* i 5)))
478                                               (cl::uref o (+ 2 i)))))))))
479    
480    
481    ;;; Threads
482    
483    (require 'threads)
484    
485    (defstruct (mailbox (:conc-name mailbox.))
486      thread
487      (lock (make-instance 'threads:critical-section))
488      (queue '() :type list))
489    
490    (defvar *mailbox-lock* (make-instance 'threads:critical-section))
491    (defvar *mailboxes* (list))
492    
493    (defmacro with-lock  (lock &body body)
494      `(threads:with-synchronization (threads:cs ,lock)
495        ,@body))
496    
497    (defimplementation spawn (fun &key name)
498      (declare (ignore name))
499      (threads:create-thread
500       (lambda ()
501         (unwind-protect (funcall fun)
502           (with-lock *mailbox-lock*
503             (setq *mailboxes* (remove cormanlisp:*current-thread-id*
504                                       *mailboxes* :key #'mailbox.thread)))))))
505    
506    (defimplementation thread-id (thread)
507      thread)
508    
509    (defimplementation find-thread (thread)
510      (if (thread-alive-p thread)
511          thread))
512    
513    (defimplementation current-thread ()
514      cormanlisp:*current-thread-id*)
515    
516    ;; XXX implement it
517    (defimplementation all-threads ()
518      '())
519    
520    (defimplementation thread-alive-p (thread)
521      t)
522    
523    ;; XXX something here is broken
524    (defimplementation kill-thread (thread)
525      (threads:terminate-thread thread 'killed))
526    
527    (defun mailbox (thread)
528      (with-lock *mailbox-lock*
529        (or (find thread *mailboxes* :key #'mailbox.thread)
530            (let ((mb (make-mailbox :thread thread)))
531              (push mb *mailboxes*)
532              mb))))
533    
534    (defimplementation send (thread message)
535      (let ((mbox (mailbox thread)))
536        (with-lock (mailbox.lock mbox)
537          (setf (mailbox.queue mbox)
538                (nconc (mailbox.queue mbox) (list message))))))
539    
540    (defimplementation receive ()
541      (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
542        (loop
543         (with-lock (mailbox.lock mbox)
544           (when (mailbox.queue mbox)
545             (return (pop (mailbox.queue mbox)))))
546         (sleep 0.1))))
547    
548    
549  ;;; This is probably not good, but it WFM  ;;; This is probably not good, but it WFM
550  (in-package :common-lisp)  (in-package :common-lisp)
551    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

  ViewVC Help
Powered by ViewVC 1.1.5