/[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.64 by msimmons, Tue Dec 21 13:49:30 2004 UTC revision 1.128 by heller, Sat Jan 10 12:25:16 2009 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: lisp; indent-tabs-mode: nil -*-  ;;; -*- indent-tabs-mode: nil -*-
2  ;;;  ;;;
3  ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.  ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
4  ;;;  ;;;
# Line 11  Line 11 
11  (in-package :swank-backend)  (in-package :swank-backend)
12    
13  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
14    (require "comm"))    (require "comm")
15      (import-from :stream *gray-stream-symbols* :swank-backend))
 (import  
  '(stream:fundamental-character-output-stream  
    stream:stream-write-char  
    stream:stream-force-output  
    stream:fundamental-character-input-stream  
    stream:stream-read-char  
    stream:stream-listen  
    stream:stream-unread-char  
    stream:stream-clear-input  
    stream:stream-line-column  
    ))  
16    
17  (import-swank-mop-symbols :clos '(:slot-definition-documentation  (import-swank-mop-symbols :clos '(:slot-definition-documentation
18                                    :eql-specializer                                    :eql-specializer
19                                    :eql-specializer-object))                                    :eql-specializer-object
20                                      :compute-applicable-methods-using-classes))
21    
22  (defun swank-mop:slot-definition-documentation (slot)  (defun swank-mop:slot-definition-documentation (slot)
23    (documentation slot t))    (documentation slot t))
24    
25  ;;;; lispworks doesn't have the eql-specializer class, it represents  (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
26  ;;;; them as a list of `(EQL ,OBJECT)    (clos::compute-applicable-methods-from-classes gf classes))
27    
28    ;; lispworks doesn't have the eql-specializer class, it represents
29    ;; them as a list of `(EQL ,OBJECT)
30  (deftype swank-mop:eql-specializer () 'cons)  (deftype swank-mop:eql-specializer () 'cons)
31    
32  (defun swank-mop:eql-specializer-object (eql-spec)  (defun swank-mop:eql-specializer-object (eql-spec)
33    (second eql-spec))    (second eql-spec))
34    
35  (when (fboundp 'dspec::define-dspec-alias)  (eval-when (:compile-toplevel :execute :load-toplevel)
36    (dspec::define-dspec-alias defimplementation (name args &rest body)    (defvar *original-defimplementation* (macro-function 'defimplementation))
37      `(defmethod ,name ,args ,@body)))    (defmacro defimplementation (&whole whole name args &body body
38                                   &environment env)
39        (declare (ignore args body))
40        `(progn
41           (dspec:record-definition '(defun ,name) (dspec:location)
42                                    :check-redefinition-p nil)
43           ,(funcall *original-defimplementation* whole env))))
44    
45  ;;; TCP server  ;;; TCP server
46    
# Line 73  Line 72 
72    (comm::close-socket (socket-fd socket)))    (comm::close-socket (socket-fd socket)))
73    
74  (defimplementation accept-connection (socket  (defimplementation accept-connection (socket
75                                        &key (external-format :iso-latin-1-unix))                                        &key external-format buffering timeout)
76    (assert (eq external-format :iso-latin-1-unix))    (declare (ignore buffering))
77    (let* ((fd (comm::get-fd-from-socket socket)))    (let* ((fd (comm::get-fd-from-socket socket)))
78      (assert (/= fd -1))      (assert (/= fd -1))
79      (make-instance 'comm:socket-stream :socket fd :direction :io      (assert (valid-external-format-p external-format))
80                     :element-type 'base-char)))      (cond ((member (first external-format) '(:latin-1 :ascii))
81               (make-instance 'comm:socket-stream
82  (defun set-sigint-handler ()                            :socket fd
83    ;; Set SIGINT handler on Swank request handler thread.                            :direction :io
84    #-win32                            :read-timeout timeout
85    (sys::set-signal-handler +sigint+                            :element-type 'base-char))
86                             (make-sigint-handler mp:*current-process*)))            (t
87               (make-flexi-stream
88  (defimplementation emacs-connected ()              (make-instance 'comm:socket-stream
89    (declare (ignore stream))                             :socket fd
90    (when (eq nil (symbol-value                             :direction :io
91                   (find-symbol (string :*communication-style*) :swank)))                             :read-timeout timeout
92      (set-sigint-handler))                             :element-type '(unsigned-byte 8))
93    (let ((lw:*handle-warn-on-redefinition* :warn))              external-format)))))
94      (defmethod env-internals:environment-display-notifier  
95          (env &key restarts condition)  (defun make-flexi-stream (stream external-format)
96        (declare (ignore restarts))    (unless (member :flexi-streams *features*)
97        (funcall (find-symbol (string :swank-debugger-hook) :swank)      (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
98                 condition *debugger-hook*))             external-format))
99      (defmethod env-internals:environment-display-debugger    (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
100          (env)             stream
101        *debug-io*)))             :external-format
102               (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
103  (defimplementation make-stream-interactive (stream)                    external-format)))
104    (let ((lw:*handle-warn-on-redefinition* :warn))  
105      (defmethod stream:stream-soft-force-output  ((o (eql stream)))  ;;; Coding Systems
106        (force-output o))))  
107    (defun valid-external-format-p (external-format)
108      (member external-format *external-format-to-coding-system*
109              :test #'equal :key #'car))
110    
111    (defvar *external-format-to-coding-system*
112      '(((:latin-1 :eol-style :lf)
113         "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
114        ((:latin-1)
115         "latin-1" "iso-latin-1" "iso-8859-1")
116        ((:utf-8) "utf-8")
117        ((:utf-8 :eol-style :lf) "utf-8-unix")
118        ((:euc-jp) "euc-jp")
119        ((:euc-jp :eol-style :lf) "euc-jp-unix")
120        ((:ascii) "us-ascii")
121        ((:ascii :eol-style :lf) "us-ascii-unix")))
122    
123    (defimplementation find-external-format (coding-system)
124      (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
125                      *external-format-to-coding-system*)))
126    
127  ;;; Unix signals  ;;; Unix signals
128    
# Line 117  Line 135 
135      (declare (ignore args))      (declare (ignore args))
136      (mp:process-interrupt process #'sigint-handler)))      (mp:process-interrupt process #'sigint-handler)))
137    
138    (defun set-sigint-handler ()
139      ;; Set SIGINT handler on Swank request handler thread.
140      #-win32
141      (sys::set-signal-handler +sigint+
142                               (make-sigint-handler mp:*current-process*)))
143    
144    #-win32
145    (defimplementation install-sigint-handler (handler)
146      (sys::set-signal-handler +sigint+
147                               (let ((self mp:*current-process*))
148                                 (lambda (&rest args)
149                                   (declare (ignore args))
150                                   (mp:process-interrupt self handler)))))
151    
152  (defimplementation call-without-interrupts (fn)  (defimplementation call-without-interrupts (fn)
153    (lw:without-interrupts (funcall fn)))    (lw:without-interrupts (funcall fn)))
154    
# Line 157  Return NIL if the symbol is unbound." Line 189  Return NIL if the symbol is unbound."
189                 (let ((pos (position #\newline string)))                 (let ((pos (position #\newline string)))
190                   (if (null pos) string (subseq string 0 pos))))                   (if (null pos) string (subseq string 0 pos))))
191               (doc (kind &optional (sym symbol))               (doc (kind &optional (sym symbol))
192                 (let ((string (documentation sym kind)))                 (let ((string (or (documentation sym kind))))
193                   (if string                   (if string
194                       (first-line string)                       (first-line string)
195                       :not-documented)))                       :not-documented)))
# Line 193  Return NIL if the symbol is unbound." Line 225  Return NIL if the symbol is unbound."
225    
226  (defun describe-function (symbol)  (defun describe-function (symbol)
227    (cond ((fboundp symbol)    (cond ((fboundp symbol)
228           (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"           (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
229                   (string-downcase symbol)                   symbol
230                   (mapcar #'string-upcase                   (lispworks:function-lambda-list symbol)
                          (lispworks:function-lambda-list symbol))  
231                   (documentation symbol 'function))                   (documentation symbol 'function))
232           (describe (fdefinition symbol)))           (describe (fdefinition symbol)))
233          (t (format t "~S is not fbound" symbol))))          (t (format t "~S is not fbound" symbol))))
# Line 213  Return NIL if the symbol is unbound." Line 244  Return NIL if the symbol is unbound."
244    
245  ;;; Debugging  ;;; Debugging
246    
247    (defclass slime-env (env:environment)
248      ((debugger-hook :initarg :debugger-hoook)))
249    
250    (defun slime-env (hook io-bindings)
251      (make-instance 'slime-env :name "SLIME Environment"
252                     :io-bindings io-bindings
253                     :debugger-hoook hook))
254    
255    (defmethod env-internals:environment-display-notifier
256        ((env slime-env) &key restarts condition)
257      (declare (ignore restarts condition))
258      (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
259      ;;  nil
260      )
261    
262    (defmethod env-internals:environment-display-debugger ((env slime-env))
263      *debug-io*)
264    
265    (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
266      (apply (swank-sym :y-or-n-p-in-emacs) msg args))
267    
268    (defimplementation call-with-debugger-hook (hook fun)
269      (let ((*debugger-hook* hook))
270        (env:with-environment ((slime-env hook '()))
271          (funcall fun))))
272    
273    (defimplementation install-debugger-globally (function)
274      (setq *debugger-hook* function)
275      (setf (env:environment) (slime-env function '())))
276    
277  (defvar *sldb-top-frame*)  (defvar *sldb-top-frame*)
278    
279  (defun interesting-frame-p (frame)  (defun interesting-frame-p (frame)
# Line 241  Return NIL if the symbol is unbound." Line 302  Return NIL if the symbol is unbound."
302    
303  (defun find-top-frame ()  (defun find-top-frame ()
304    "Return the most suitable top-frame for the debugger."    "Return the most suitable top-frame for the debugger."
305    (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)    (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
306                (nth-next-frame frame 1)))                    (nth-next-frame frame 1)))
307        ((and (dbg::call-frame-p frame)            ((or (null frame)             ; no frame found!
308              (eq (dbg::call-frame-function-name frame)                 (and (dbg::call-frame-p frame)
309                  'invoke-debugger))                      (eq (dbg::call-frame-function-name frame)
310         (nth-next-frame frame 1))))                          'invoke-debugger)))
311               (nth-next-frame frame 1)))
312          ;; if we can't find a invoke-debugger frame, take any old frame at the top
313          (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))
314    
315  (defimplementation call-with-debugging-environment (fn)  (defimplementation call-with-debugging-environment (fn)
316    (dbg::with-debugger-stack ()    (dbg::with-debugger-stack ()
# Line 299  Return NIL if the symbol is unbound." Line 363  Return NIL if the symbol is unbound."
363        (declare (ignore _n _s _l))        (declare (ignore _n _s _l))
364        value)))        value)))
365    
 (defimplementation frame-catch-tags (index)  
   (declare (ignore index))  
   nil)  
   
366  (defimplementation frame-source-location-for-emacs (frame)  (defimplementation frame-source-location-for-emacs (frame)
367    (let ((frame (nth-frame frame))    (let ((frame (nth-frame frame))
368          (callee (if (plusp frame) (nth-frame (1- frame)))))          (callee (if (plusp frame) (nth-frame (1- frame)))))
# Line 327  Return NIL if the symbol is unbound." Line 387  Return NIL if the symbol is unbound."
387    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
388      (dbg::restart-frame frame :same-args t)))      (dbg::restart-frame frame :same-args t)))
389    
390    (defimplementation disassemble-frame (frame-number)
391      (let* ((frame (nth-frame frame-number)))
392        (when (dbg::call-frame-p frame)
393          (let ((function (dbg::get-call-frame-function frame)))
394            (disassemble function)))))
395    
396  ;;; Definition finding  ;;; Definition finding
397    
398  (defun frame-location (dspec callee-name)  (defun frame-location (dspec callee-name)
# Line 354  Return NIL if the symbol is unbound." Line 420  Return NIL if the symbol is unbound."
420    (lw:rebinding (location)    (lw:rebinding (location)
421      `(let ((compiler::*error-database* '()))      `(let ((compiler::*error-database* '()))
422         (with-compilation-unit ,options         (with-compilation-unit ,options
423           ,@body           (multiple-value-prog1 (progn ,@body)
424           (signal-error-data-base compiler::*error-database* ,location)             (signal-error-data-base compiler::*error-database*
425           (signal-undefined-functions compiler::*unknown-functions* ,location)))))                                     ,location)
426               (signal-undefined-functions compiler::*unknown-functions*
427  (defimplementation swank-compile-file (filename load-p)                                         ,location))))))
428    (with-swank-compilation-unit (filename)  
429      (compile-file filename :load load-p)))  (defimplementation swank-compile-file (input-file output-file
430                                           load-p external-format)
431      (with-swank-compilation-unit (input-file)
432        (compile-file input-file
433                      :output-file output-file
434                      :load load-p
435                      :external-format external-format)))
436    
437    (defvar *within-call-with-compilation-hooks* nil
438      "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
439    
440    (defvar *undefined-functions-hash* nil
441      "Hash table to map info about undefined functions to pathnames.")
442    
443    (lw:defadvice (compile-file compile-file-and-collect-notes :around)
444        (pathname &rest rest)
445      (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
446        (when *within-call-with-compilation-hooks*
447          (maphash (lambda (unfun dspecs)
448                     (dolist (dspec dspecs)
449                       (let ((unfun-info (list unfun dspec)))
450                         (unless (gethash unfun-info *undefined-functions-hash*)
451                           (setf (gethash unfun-info *undefined-functions-hash*)
452                                   pathname)))))
453                   compiler::*unknown-functions*))))
454    
455  (defimplementation call-with-compilation-hooks (function)  (defimplementation call-with-compilation-hooks (function)
456    ;; #'pray instead of #'handler-bind    (let ((compiler::*error-database* '())
457    (funcall function))          (*undefined-functions-hash* (make-hash-table :test 'equal))
458            (*within-call-with-compilation-hooks* t))
459        (with-compilation-unit ()
460          (prog1 (funcall function)
461            (signal-error-data-base compiler::*error-database*)
462            (signal-undefined-functions compiler::*unknown-functions*)))))
463    
464  (defun map-error-database (database fn)  (defun map-error-database (database fn)
465    (loop for (filename . defs) in database do    (loop for (filename . defs) in database do
466          (loop for (dspec . conditions) in defs do          (loop for (dspec . conditions) in defs do
467                (dolist (c conditions)                (dolist (c conditions)
468                  (funcall fn filename dspec c)))))                  (funcall fn filename dspec (if (consp c) (car c) c))))))
469    
470  (defun lispworks-severity (condition)  (defun lispworks-severity (condition)
471    (cond ((not condition) :warning)    (cond ((not condition) :warning)
# Line 387  Return NIL if the symbol is unbound." Line 482  Return NIL if the symbol is unbound."
482                    :location location                    :location location
483                    :original-condition condition)))                    :original-condition condition)))
484    
485    (defvar *temp-file-format* '(:utf-8 :eol-style :lf))
486    
487  (defun compile-from-temp-file (string filename)  (defun compile-from-temp-file (string filename)
488    (unwind-protect    (unwind-protect
489         (progn         (progn
490           (with-open-file (s filename :direction :output :if-exists :supersede)           (with-open-file (s filename :direction :output
491                                         :if-exists :supersede
492                                         :external-format *temp-file-format*)
493    
494             (write-string string s)             (write-string string s)
495             (finish-output s))             (finish-output s))
496           (let ((binary-filename (compile-file filename :load t)))           (multiple-value-bind (binary-filename warnings? failure?)
497                 (compile-file filename :load t
498                               :external-format *temp-file-format*)
499               (declare (ignore warnings?))
500             (when binary-filename             (when binary-filename
501               (delete-file binary-filename))))               (delete-file binary-filename))
502               (not failure?)))
503      (delete-file filename)))      (delete-file filename)))
504    
505  (defun dspec-buffer-position (dspec offset)  (defun dspec-function-name-position (dspec fallback)
506    (etypecase dspec    (etypecase dspec
507      (cons (let ((name (dspec:dspec-primary-name dspec)))      (cons (let ((name (dspec:dspec-primary-name dspec)))
508              (typecase name              (typecase name
509                ((or symbol string)                ((or symbol string)
510                 (list :function-name (string name)))                 (list :function-name (string name)))
511                (t (list :position offset)))))                (t fallback))))
512      (null (list :position offset))      (null fallback)
513      (symbol (list :function-name (string dspec)))))      (symbol (list :function-name (string dspec)))))
514    
515  (defmacro with-fairly-standard-io-syntax (&body body)  (defmacro with-fairly-standard-io-syntax (&body body)
# Line 419  Return NIL if the symbol is unbound." Line 523  Return NIL if the symbol is unbound."
523                (*readtable* ,readtable))                (*readtable* ,readtable))
524            ,@body)))))            ,@body)))))
525    
526    (defun skip-comments (stream)
527      (let ((pos0 (file-position stream)))
528        (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
529                      '(()))
530               (file-position stream (1- (file-position stream))))
531              (t (file-position stream pos0)))))
532    
533  #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3  #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
534  (defun dspec-stream-position (stream dspec)  (defun dspec-stream-position (stream dspec)
535    (with-fairly-standard-io-syntax    (with-fairly-standard-io-syntax
536      (loop (let* ((pos (file-position stream))      (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
537                   (form (read stream nil '#1=#:eof)))                   (form (read stream nil '#1=#:eof)))
538              (when (eq form '#1#)              (when (eq form '#1#)
539                (return nil))                (return nil))
# Line 447  Return NIL if the symbol is unbound." Line 558  Return NIL if the symbol is unbound."
558                (check-dspec form))))))                (check-dspec form))))))
559    
560  (defun dspec-file-position (file dspec)  (defun dspec-file-position (file dspec)
561    (with-open-file (stream file)    (let* ((*compile-file-pathname* (pathname file))
562      (let ((pos           (*compile-file-truename* (truename *compile-file-pathname*))
563             #-(or lispworks4.1 lispworks4.2)           (*load-pathname* *compile-file-pathname*)
564             (dspec-stream-position stream dspec)))           (*load-truename* *compile-file-truename*))
565        (if pos      (with-open-file (stream file)
566            (list :position (1+ pos) t)        (let ((pos
567            (dspec-buffer-position dspec 1)))))               #-(or lispworks4.1 lispworks4.2)
568                 (dspec-stream-position stream dspec)))
569            (if pos
570                (list :position (1+ pos))
571                (dspec-function-name-position dspec `(:position 1)))))))
572    
573  (defun emacs-buffer-location-p (location)  (defun emacs-buffer-location-p (location)
574    (and (consp location)    (and (consp location)
# Line 475  Return NIL if the symbol is unbound." Line 590  Return NIL if the symbol is unbound."
590       (destructuring-bind (_ buffer offset string) location       (destructuring-bind (_ buffer offset string) location
591         (declare (ignore _ string))         (declare (ignore _ string))
592         (make-location `(:buffer ,buffer)         (make-location `(:buffer ,buffer)
593                        (dspec-buffer-position dspec offset)                        (dspec-function-name-position dspec `(:offset ,offset 0))
594                        hints)))))                        hints)))))
595    
596  (defun make-dspec-progenitor-location (dspec location)  (defun make-dspec-progenitor-location (dspec location)
# Line 488  Return NIL if the symbol is unbound." Line 603  Return NIL if the symbol is unbound."
603         nil)         nil)
604       location)))       location)))
605    
606  (defun signal-error-data-base (database location)  (defun signal-error-data-base (database &optional location)
607    (map-error-database    (map-error-database
608     database     database
609     (lambda (filename dspec condition)     (lambda (filename dspec condition)
      (declare (ignore filename))  
610       (signal-compiler-condition       (signal-compiler-condition
611        (format nil "~A" condition)        (format nil "~A" condition)
612        (make-dspec-progenitor-location dspec location)        (make-dspec-progenitor-location dspec (or location filename))
613        condition))))        condition))))
614    
615  (defun signal-undefined-functions (htab filename)  (defun unmangle-unfun (symbol)
616      "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
617    function names like \(SETF GET)."
618      (cond ((sys::setf-symbol-p symbol)
619             (sys::setf-pair-from-underlying-name symbol))
620            (t symbol)))
621    
622    (defun signal-undefined-functions (htab &optional filename)
623    (maphash (lambda (unfun dspecs)    (maphash (lambda (unfun dspecs)
624               (dolist (dspec dspecs)               (dolist (dspec dspecs)
625                 (signal-compiler-condition                 (signal-compiler-condition
626                  (format nil "Undefined function ~A" unfun)                  (format nil "Undefined function ~A" (unmangle-unfun unfun))
627                  (make-dspec-progenitor-location dspec filename)                  (make-dspec-progenitor-location dspec
628                                                    (or filename
629                                                        (gethash (list unfun dspec)
630                                                                 *undefined-functions-hash*)))
631                  nil)))                  nil)))
632             htab))             htab))
633    
634  (defimplementation swank-compile-string (string &key buffer position directory)  (defimplementation swank-compile-string (string &key buffer position filename
635    (declare (ignore directory))                                           policy)
636      (declare (ignore filename policy))
637    (assert buffer)    (assert buffer)
638    (assert position)    (assert position)
639    (let* ((location (list :emacs-buffer buffer position string))    (let* ((location (list :emacs-buffer buffer position string))
640           (tmpname (hcl:make-temp-file nil "lisp")))           (tmpname (hcl:make-temp-file nil "lisp")))
641      (with-swank-compilation-unit (location)      (with-swank-compilation-unit (location)
642        (compile-from-temp-file        (compile-from-temp-file
643         (format nil "~S~%~A" `(eval-when (:compile-toplevel)         (with-output-to-string (s)
644                                (setq dspec::*location* (list ,@location)))           (let ((*print-radix* t))
645                 string)             (print `(eval-when (:compile-toplevel)
646                         (setq dspec::*location* (list ,@location)))
647                      s))
648             (write-string string s))
649         tmpname))))         tmpname))))
650    
651  ;;; xref  ;;; xref
# Line 528  Return NIL if the symbol is unbound." Line 656  Return NIL if the symbol is unbound."
656    
657  (defxref who-calls      hcl:who-calls)  (defxref who-calls      hcl:who-calls)
658  (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too  (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
659  (defxref list-callees   hcl:calls-who)  (defxref calls-who      hcl:calls-who)
660  (defxref list-callers   list-callers-internal)  (defxref list-callers   list-callers-internal)
661    ;; (defxref list-callees   list-callees-internal)
662    
663  (defun list-callers-internal (name)  (defun list-callers-internal (name)
664    (let ((callers (make-array 100    (let ((callers (make-array 100
# Line 567  Return NIL if the symbol is unbound." Line 696  Return NIL if the symbol is unbound."
696                   (t `((,dspec (:error "Source location not available")))))))                   (t `((,dspec (:error "Source location not available")))))))
697      (loop for dspec in dspecs      (loop for dspec in dspecs
698            append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))            append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
699    
700  ;;; Inspector  ;;; Inspector
 (defclass lispworks-inspector (inspector)  
   ())  
701    
702  (defimplementation make-default-inspector ()  (defmethod emacs-inspect ((o t))
703    (make-instance 'lispworks-inspector))    (lispworks-inspect o))
704    
705  (defimplementation inspect-for-emacs ((o t) (inspector lispworks-inspector))  (defmethod emacs-inspect ((o function))
   (declare (ignore inspector))  
706    (lispworks-inspect o))    (lispworks-inspect o))
707    
708  (defimplementation inspect-for-emacs ((o function)  ;; FIXME: slot-boundp-using-class in LW works with names so we can't
709                                        (inspector lispworks-inspector))  ;; use our method in swank.lisp.
710    (declare (ignore inspector))  (defmethod emacs-inspect ((o standard-object))
711    (lispworks-inspect o))    (lispworks-inspect o))
712    
713  (defun lispworks-inspect (o)  (defun lispworks-inspect (o)
714    (multiple-value-bind (names values _getter _setter type)    (multiple-value-bind (names values _getter _setter type)
715        (lw:get-inspector-values o nil)        (lw:get-inspector-values o nil)
716      (declare (ignore _getter _setter))      (declare (ignore _getter _setter))
     (values "A value."  
717              (append              (append
718               (label-value-line "Type" type)               (label-value-line "Type" type)
719               (mapcan #'label-value-line names values)))))               (loop for name in names
720                       for value in values
721                       append (label-value-line name value)))))
722    
723  ;;; Miscellaneous  ;;; Miscellaneous
724    
725  (defimplementation quit-lisp ()  (defimplementation quit-lisp ()
726    (lispworks:quit))    (lispworks:quit))
727    
728    ;;; Tracing
729    
730    (defun parse-fspec (fspec)
731      "Return a dspec for FSPEC."
732      (ecase (car fspec)
733        ((:defmethod) `(method ,(cdr fspec)))))
734    
735    (defun tracedp (dspec)
736      (member dspec (eval '(trace)) :test #'equal))
737    
738    (defun toggle-trace-aux (dspec)
739      (cond ((tracedp dspec)
740             (eval `(untrace ,dspec))
741             (format nil "~S is now untraced." dspec))
742            (t
743             (eval `(trace (,dspec)))
744             (format nil "~S is now traced." dspec))))
745    
746    (defimplementation toggle-trace (fspec)
747      (toggle-trace-aux (parse-fspec fspec)))
748    
749  ;;; Multithreading  ;;; Multithreading
750    
751  (defimplementation startup-multiprocessing ()  (defimplementation initialize-multiprocessing (continuation)
752    (mp:initialize-multiprocessing))    (cond ((not mp::*multiprocessing*)
753             (push (list "Initialize SLIME" '() continuation)
754                   mp:*initial-processes*)
755             (mp:initialize-multiprocessing))
756            (t (funcall continuation))))
757    
758  (defimplementation spawn (fn &key name)  (defimplementation spawn (fn &key name)
759    (let ((mp:*process-initial-bindings*    (mp:process-run-function name () fn))
          (remove (find-package :cl)  
                  mp:*process-initial-bindings*  
                  :key (lambda (x) (symbol-package (car x))))))  
     (mp:process-run-function name () fn)))  
760    
761  (defvar *id-lock* (mp:make-lock))  (defvar *id-lock* (mp:make-lock))
762  (defvar *thread-id-counter* 0)  (defvar *thread-id-counter* 0)
# Line 651  Return NIL if the symbol is unbound." Line 800  Return NIL if the symbol is unbound."
800  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
801    (mp:process-alive-p thread))    (mp:process-alive-p thread))
802    
803    (defstruct (mailbox (:conc-name mailbox.))
804      (mutex (mp:make-lock :name "thread mailbox"))
805      (queue '() :type list))
806    
807  (defvar *mailbox-lock* (mp:make-lock))  (defvar *mailbox-lock* (mp:make-lock))
808    
809  (defun mailbox (thread)  (defun mailbox (thread)
810    (mp:with-lock (*mailbox-lock*)    (mp:with-lock (*mailbox-lock*)
811      (or (getf (mp:process-plist thread) 'mailbox)      (or (getf (mp:process-plist thread) 'mailbox)
812          (setf (getf (mp:process-plist thread) 'mailbox)          (setf (getf (mp:process-plist thread) 'mailbox)
813                (mp:make-mailbox)))))                (make-mailbox)))))
814    
815    (defimplementation receive-if (test &optional timeout)
816      (let* ((mbox (mailbox mp:*current-process*))
817             (lock (mailbox.mutex mbox)))
818        (assert (or (not timeout) (eq timeout t)))
819        (loop
820         (check-slime-interrupts)
821         (mp:with-lock (lock "receive-if/try")
822           (let* ((q (mailbox.queue mbox))
823                  (tail (member-if test q)))
824             (when tail
825               (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
826               (return (car tail)))))
827         (when (eq timeout t) (return (values nil t)))
828         (mp:process-wait-with-timeout
829          "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
830    
831    (defimplementation send (thread message)
832      (let ((mbox (mailbox thread)))
833        (mp:with-lock ((mailbox.mutex mbox))
834          (setf (mailbox.queue mbox)
835                (nconc (mailbox.queue mbox) (list message))))))
836    
837    (defimplementation set-default-initial-binding (var form)
838      (setq mp:*process-initial-bindings*
839            (acons var `(eval (quote ,form))
840                   mp:*process-initial-bindings* )))
841    
842  (defimplementation receive ()  ;;; Some intergration with the lispworks environment
843    (mp:mailbox-read (mailbox mp:*current-process*)))  
844    (defun swank-sym (name) (find-symbol (string name) :swank))
845    
846    
847    ;;;; Weak hashtables
848    
849  (defimplementation send (thread object)  (defimplementation make-weak-key-hash-table (&rest args)
850    (mp:mailbox-send (mailbox thread) object))    (apply #'make-hash-table :weak-kind :key args))
851    
852    (defimplementation make-weak-value-hash-table (&rest args)
853      (apply #'make-hash-table :weak-kind :value args))

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

  ViewVC Help
Powered by ViewVC 1.1.5