/[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.94 by mbaringer, Mon Feb 4 17:35:03 2008 UTC revision 1.128 by heller, Sat Jan 10 12:25:16 2009 UTC
# Line 32  Line 32 
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 67  Line 73 
73    
74  (defimplementation accept-connection (socket  (defimplementation accept-connection (socket
75                                        &key external-format buffering timeout)                                        &key external-format buffering timeout)
76    (declare (ignore buffering timeout external-format))    (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                (make-instance 'comm:socket-stream
89                               :socket fd
90                               :direction :io
91                               :read-timeout timeout
92                               :element-type '(unsigned-byte 8))
93                external-format)))))
94    
95    (defun make-flexi-stream (stream external-format)
96      (unless (member :flexi-streams *features*)
97        (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
98               external-format))
99      (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
100               stream
101               :external-format
102               (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
103                      external-format)))
104    
105  ;;; Coding Systems  ;;; Coding Systems
106    
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*  (defvar *external-format-to-coding-system*
112    '(((:latin-1 :eol-style :lf)    '(((:latin-1 :eol-style :lf)
113       "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")       "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
# Line 108  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 148  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 184  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 212  Return NIL if the symbol is unbound." Line 252  Return NIL if the symbol is unbound."
252                   :io-bindings io-bindings                   :io-bindings io-bindings
253                   :debugger-hoook hook))                   :debugger-hoook hook))
254    
255  (defmethod env-internals:environment-display-notifier  (defmethod env-internals:environment-display-notifier
256      ((env slime-env) &key restarts condition)      ((env slime-env) &key restarts condition)
257    (declare (ignore restarts))    (declare (ignore restarts condition))
258    (funcall (slot-value env 'debugger-hook) condition *debugger-hook*))    (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
259      ;;  nil
260      )
261    
262  (defmethod env-internals:environment-display-debugger ((env slime-env))  (defmethod env-internals:environment-display-debugger ((env slime-env))
263    *debug-io*)    *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)  (defimplementation call-with-debugger-hook (hook fun)
269    (let ((*debugger-hook* hook))    (let ((*debugger-hook* hook))
270      (env:with-environment ((slime-env hook '()))      (env:with-environment ((slime-env hook '()))
271        (funcall fun))))        (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 314  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 342  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 369  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 external-format)                                         ,location))))))
428    (with-swank-compilation-unit (filename)  
429      (compile-file filename :load load-p :external-format external-format)))  (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  (defvar *within-call-with-compilation-hooks* nil
438    "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")    "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
# Line 408  Return NIL if the symbol is unbound." Line 465  Return NIL if the symbol is unbound."
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 425  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 457  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 494  Return NIL if the symbol is unbound." Line 567  Return NIL if the symbol is unbound."
567               #-(or lispworks4.1 lispworks4.2)               #-(or lispworks4.1 lispworks4.2)
568               (dspec-stream-position stream dspec)))               (dspec-stream-position stream dspec)))
569          (if pos          (if pos
570              (list :position (1+ pos) t)              (list :position (1+ pos))
571              (dspec-buffer-position dspec 1))))))              (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 517  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 558  function names like \(SETF GET)." Line 631  function names like \(SETF GET)."
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))
# Line 624  function names like \(SETF GET)." Line 698  function names like \(SETF GET)."
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 (backend-inspector) ())  
701    
702  (defimplementation make-default-inspector ()  (defmethod emacs-inspect ((o t))
   (make-instance 'lispworks-inspector))  
   
 (defmethod inspect-for-emacs ((o t))  
703    (lispworks-inspect o))    (lispworks-inspect o))
704    
705  (defmethod inspect-for-emacs ((o function))  (defmethod emacs-inspect ((o function))
706    (lispworks-inspect o))    (lispworks-inspect o))
707    
708  ;; FIXME: slot-boundp-using-class in LW works with names so we can't  ;; FIXME: slot-boundp-using-class in LW works with names so we can't
709  ;; use our method in swank.lisp.  ;; use our method in swank.lisp.
710  (defmethod inspect-for-emacs ((o standard-object))  (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               (loop for name in names               (loop for name in names
720                     for value in values                     for value in values
721                     append (label-value-line name value))))))                     append (label-value-line name value)))))
722    
723  ;;; Miscellaneous  ;;; Miscellaneous
724    
# Line 687  function names like \(SETF GET)." Line 756  function names like \(SETF GET)."
756          (t (funcall continuation))))          (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 735  function names like \(SETF GET)." Line 800  function names like \(SETF GET)."
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 ()  (defimplementation receive-if (test &optional timeout)
816    (mp:mailbox-read (mailbox mp:*current-process*)))    (let* ((mbox (mailbox mp:*current-process*))
817             (lock (mailbox.mutex mbox)))
818  (defimplementation send (thread object)      (assert (or (not timeout) (eq timeout t)))
819    (mp:mailbox-send (mailbox thread) object))      (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  ;;; Some intergration with the lispworks environment  ;;; Some intergration with the lispworks environment
843    
844  (defun swank-sym (name) (find-symbol (string name) :swank))  (defun swank-sym (name) (find-symbol (string name) :swank))
   
 (defimplementation emacs-connected ()  
   (when (eq (eval (swank-sym :*communication-style*))  
             nil)  
     (set-sigint-handler))  
   ;; pop up the slime debugger by default  
   (let ((lw:*handle-warn-on-redefinition* :warn))  
     (defmethod env-internals:environment-display-notifier  
         (env &key restarts condition)  
       (declare (ignore restarts))  
       (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*))  
     (defmethod env-internals:environment-display-debugger (env)  
       *debug-io*)))  
   
 (defimplementation make-stream-interactive (stream)  
   (unless (find-method #'stream:stream-soft-force-output nil `((eql ,stream))  
                        nil)  
     (let ((lw:*handle-warn-on-redefinition* :warn))  
       (defmethod stream:stream-soft-force-output  ((o (eql stream)))  
         (force-output o)))))  
   
 (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)  
   (apply (swank-sym :y-or-n-p-in-emacs) msg args))  
845    
846    
847  ;;;; Weak hashtables  ;;;; Weak hashtables

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

  ViewVC Help
Powered by ViewVC 1.1.5