/[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.19.2.1 by heller, Sat Jan 31 11:40:50 2004 UTC revision 1.153 by heller, Fri Feb 8 14:11:34 2013 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 7  Line 7 
7  ;;; This code has been placed in the Public Domain.  All warranties  ;;; This code has been placed in the Public Domain.  All warranties
8  ;;; are disclaimed.  ;;; are disclaimed.
9  ;;;  ;;;
 ;;;   $Id$  
 ;;;  
10    
11  (in-package :swank)  (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))
16    
17    (import-swank-mop-symbols :clos '(:slot-definition-documentation
18                                      :slot-boundp-using-class
19                                      :slot-value-using-class
20                                      :slot-makunbound-using-class
21                                      :eql-specializer
22                                      :eql-specializer-object
23                                      :compute-applicable-methods-using-classes))
24    
25    (defun swank-mop:slot-definition-documentation (slot)
26      (documentation slot t))
27    
28    (defun swank-mop:slot-boundp-using-class (class object slotd)
29      (clos:slot-boundp-using-class class object
30                                    (clos:slot-definition-name slotd)))
31    
32    (defun swank-mop:slot-value-using-class (class object slotd)
33      (clos:slot-value-using-class class object
34                                   (clos:slot-definition-name slotd)))
35    
36    (defun (setf swank-mop:slot-value-using-class) (value class object slotd)
37      (setf (clos:slot-value-using-class class object
38                                         (clos:slot-definition-name slotd))
39            value))
40    
41    (defun swank-mop:slot-makunbound-using-class (class object slotd)
42      (clos:slot-makunbound-using-class class object
43                                        (clos:slot-definition-name slotd)))
44    
45    (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
46      (clos::compute-applicable-methods-from-classes gf classes))
47    
48    ;; lispworks doesn't have the eql-specializer class, it represents
49    ;; them as a list of `(EQL ,OBJECT)
50    (deftype swank-mop:eql-specializer () 'cons)
51    
52    (defun swank-mop:eql-specializer-object (eql-spec)
53      (second eql-spec))
54    
55    (eval-when (:compile-toplevel :execute :load-toplevel)
56      (defvar *original-defimplementation* (macro-function 'defimplementation))
57      (defmacro defimplementation (&whole whole name args &body body
58                                   &environment env)
59        (declare (ignore args body))
60        `(progn
61           (dspec:record-definition '(defun ,name) (dspec:location)
62                                    :check-redefinition-p nil)
63           ,(funcall *original-defimplementation* whole env))))
64    
65    ;;; UTF8
66    
67  (import  (defimplementation string-to-utf8 (string)
68   '(stream:fundamental-character-output-stream    (ef:encode-lisp-string string '(:utf-8 :eol-style :lf)))
69     stream:stream-write-char  
70     stream:stream-force-output  (defimplementation utf8-to-string (octets)
71     stream:fundamental-character-input-stream    (ef:decode-external-string octets '(:utf-8 :eol-style :lf)))
    stream:stream-read-char  
    stream:stream-listen  
    stream:stream-unread-char  
    stream:stream-clear-input  
    stream:stream-line-column  
    ))  
72    
73  ;;; TCP server  ;;; TCP server
74    
75  (setq *swank-in-background* :spawn)  (defimplementation preferred-communication-style ()
76      :spawn)
77    
78  (defun socket-fd (socket)  (defun socket-fd (socket)
79    (etypecase socket    (etypecase socket
80      (fixnum socket)      (fixnum socket)
81      (comm:socket-stream (comm:socket-stream-socket socket))))      (comm:socket-stream (comm:socket-stream-socket socket))))
82    
83  (defimplementation create-socket (port)  (defimplementation create-socket (host port &key backlog)
84    (multiple-value-bind (socket where errno)    (multiple-value-bind (socket where errno)
85        (comm::create-tcp-socket-for-service port :address "localhost")        #-(or lispworks4.1 (and macosx lispworks4.3))
86          (comm::create-tcp-socket-for-service port :address host
87                                               :backlog (or backlog 5))
88          #+(or lispworks4.1 (and macosx lispworks4.3))
89          (comm::create-tcp-socket-for-service port)
90      (cond (socket socket)      (cond (socket socket)
91            (t (error 'network-error            (t (error 'network-error
92                :format-control "~A failed: ~A (~D)"                :format-control "~A failed: ~A (~D)"
# Line 52  Line 100 
100  (defimplementation close-socket (socket)  (defimplementation close-socket (socket)
101    (comm::close-socket (socket-fd socket)))    (comm::close-socket (socket-fd socket)))
102    
103  (defimplementation accept-connection (socket)  (defimplementation accept-connection (socket
104    (let ((fd (comm::get-fd-from-socket socket)))                                        &key external-format buffering timeout)
105      (declare (ignore buffering))
106      (let* ((fd (comm::get-fd-from-socket socket)))
107      (assert (/= fd -1))      (assert (/= fd -1))
108      (make-instance 'comm:socket-stream :socket fd :direction :io      (cond ((not external-format)
109                     :element-type 'base-char)))             (make-instance 'comm:socket-stream
110                              :socket fd
111  (defimplementation emacs-connected ()                            :direction :io
112    ;; Set SIGINT handler on Swank request handler thread.                            :read-timeout timeout
113    (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*)))                            :element-type '(unsigned-byte 8)))
114              (t
115               (assert (valid-external-format-p external-format))
116               (ecase (first external-format)
117                 ((:latin-1 :ascii)
118                  (make-instance 'comm:socket-stream
119                                 :socket fd
120                                 :direction :io
121                                 :read-timeout timeout
122                                 :element-type 'base-char))
123                 (:utf-8
124                  (make-flexi-stream
125                   (make-instance 'comm:socket-stream
126                                  :socket fd
127                                  :direction :io
128                                  :read-timeout timeout
129                                  :element-type '(unsigned-byte 8))
130                   external-format)))))))
131    
132    (defun make-flexi-stream (stream external-format)
133      (unless (member :flexi-streams *features*)
134        (error "Cannot use external format ~A~
135                without having installed flexi-streams in the inferior-lisp."
136               external-format))
137      (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
138               stream
139               :external-format
140               (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
141                      external-format)))
142    
143    ;;; Coding Systems
144    
145    (defun valid-external-format-p (external-format)
146      (member external-format *external-format-to-coding-system*
147              :test #'equal :key #'car))
148    
149    (defvar *external-format-to-coding-system*
150      '(((:latin-1 :eol-style :lf)
151         "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
152        ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1")
153        ;;((:utf-8) "utf-8")
154        ((:utf-8 :eol-style :lf) "utf-8-unix")
155        ;;((:euc-jp) "euc-jp")
156        ((:euc-jp :eol-style :lf) "euc-jp-unix")
157        ;;((:ascii) "us-ascii")
158        ((:ascii :eol-style :lf) "us-ascii-unix")))
159    
160    (defimplementation find-external-format (coding-system)
161      (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
162                      *external-format-to-coding-system*)))
163    
164  ;;; Unix signals  ;;; Unix signals
165    
# Line 73  Line 172 
172      (declare (ignore args))      (declare (ignore args))
173      (mp:process-interrupt process #'sigint-handler)))      (mp:process-interrupt process #'sigint-handler)))
174    
175  (defmethod call-without-interrupts (fn)  (defun set-sigint-handler ()
176    (lispworks:without-interrupts (funcall fn)))    ;; Set SIGINT handler on Swank request handler thread.
177      #-win32
178  (defmethod getpid ()    (sys::set-signal-handler +sigint+
179    (system::getpid))                             (make-sigint-handler mp:*current-process*)))
180    
181    #-win32
182    (defimplementation install-sigint-handler (handler)
183      (sys::set-signal-handler +sigint+
184                               (let ((self mp:*current-process*))
185                                 (lambda (&rest args)
186                                   (declare (ignore args))
187                                   (mp:process-interrupt self handler)))))
188    
189    (defimplementation getpid ()
190      #+win32 (win32:get-current-process-id)
191      #-win32 (system::getpid))
192    
193    (defimplementation lisp-implementation-type-name ()
194      "lispworks")
195    
196    (defimplementation set-default-directory (directory)
197      (namestring (hcl:change-directory directory)))
198    
199    ;;;; Documentation
200    
201    (defun map-list (function list)
202      "Map over proper and not proper lists."
203      (loop for (car . cdr) on list
204            collect (funcall function car) into result
205            when (null cdr) return result
206            when (atom cdr) return (nconc result (funcall function cdr))))
207    
208    (defun replace-strings-with-symbols (tree)
209      (map-list
210       (lambda (x)
211         (typecase x
212           (list
213            (replace-strings-with-symbols x))
214           (symbol
215            x)
216           (string
217            (intern x))
218           (t
219            (intern (write-to-string x)))))
220       tree))
221    
222    (defimplementation arglist (symbol-or-function)
223      (let ((arglist (lw:function-lambda-list symbol-or-function)))
224        (etypecase arglist
225          ((member :dont-know)
226           :not-available)
227          (list
228           (replace-strings-with-symbols arglist)))))
229    
230  (defimplementation arglist-string (fname)  (defimplementation function-name (function)
231    (format-arglist fname #'lw:function-lambda-list))    (nth-value 2 (function-lambda-expression function)))
232    
233  (defimplementation macroexpand-all (form)  (defimplementation macroexpand-all (form)
234    (walker:walk-form form))    (walker:walk-form form))
235    
236    (defun generic-function-p (object)
237      (typep object 'generic-function))
238    
239  (defimplementation describe-symbol-for-emacs (symbol)  (defimplementation describe-symbol-for-emacs (symbol)
240    "Return a plist describing SYMBOL.    "Return a plist describing SYMBOL.
241  Return NIL if the symbol is unbound."  Return NIL if the symbol is unbound."
# Line 93  Return NIL if the symbol is unbound." Line 244  Return NIL if the symbol is unbound."
244                 (let ((pos (position #\newline string)))                 (let ((pos (position #\newline string)))
245                   (if (null pos) string (subseq string 0 pos))))                   (if (null pos) string (subseq string 0 pos))))
246               (doc (kind &optional (sym symbol))               (doc (kind &optional (sym symbol))
247                 (let ((string (documentation sym kind)))                 (let ((string (or (documentation sym kind))))
248                   (if string                   (if string
249                       (first-line string)                       (first-line string)
250                       :not-documented)))                       :not-documented)))
# Line 104  Return NIL if the symbol is unbound." Line 255  Return NIL if the symbol is unbound."
255         :variable (when (boundp symbol)         :variable (when (boundp symbol)
256                     (doc 'variable)))                     (doc 'variable)))
257        (maybe-push        (maybe-push
258         :function (if (fboundp symbol)         :generic-function (if (and (fboundp symbol)
259                                      (generic-function-p (fdefinition symbol)))
260                                 (doc 'function)))
261          (maybe-push
262           :function (if (and (fboundp symbol)
263                              (not (generic-function-p (fdefinition symbol))))
264                       (doc 'function)))                       (doc 'function)))
265        (maybe-push        (maybe-push
266           :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
267                   (if (fboundp setf-name)
268                       (doc 'setf))))
269          (maybe-push
270         :class (if (find-class symbol nil)         :class (if (find-class symbol nil)
271                    (doc 'class)))                    (doc 'class)))
272        (if result        result)))
           (list* :designator (to-string symbol) result)))))  
273    
274  (defimplementation describe-definition (symbol-name type)  (defimplementation describe-definition (symbol type)
275    (case type    (ecase type
276      ;; FIXME: This should cover all types returned by      (:variable (describe-symbol symbol))
277      ;; DESCRIBE-SYMBOL-FOR-EMACS.      (:class (describe (find-class symbol)))
278      (:function (describe-function symbol-name))))      ((:function :generic-function) (describe-function symbol))
279        (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
280  (defun describe-function (symbol-name)  
281    (with-output-to-string (*standard-output*)  (defun describe-function (symbol)
282      (let ((sym (from-string symbol-name)))    (cond ((fboundp symbol)
283        (cond ((fboundp sym)           (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
284               (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"                   symbol
285                       (string-downcase sym)                   (lispworks:function-lambda-list symbol)
286                       (mapcar #'string-upcase                   (documentation symbol 'function))
287                               (lispworks:function-lambda-list sym))           (describe (fdefinition symbol)))
288                       (documentation sym 'function))          (t (format t "~S is not fbound" symbol))))
              (describe (symbol-function sym)))  
             (t (format t "~S is not fbound" sym))))))  
289    
290  #+(or)  (defun describe-symbol (sym)
 (defimplementation describe-object ((sym symbol) *standard-output*)  
291    (format t "~A is a symbol in package ~A." sym (symbol-package sym))    (format t "~A is a symbol in package ~A." sym (symbol-package sym))
292    (when (boundp sym)    (when (boundp sym)
293      (format t "~%~%Value: ~A" (symbol-value sym)))      (format t "~%~%Value: ~A" (symbol-value sym)))
# Line 139  Return NIL if the symbol is unbound." Line 295  Return NIL if the symbol is unbound."
295      (when doc      (when doc
296        (format t "~%~%Variable documentation:~%~A"  doc)))        (format t "~%~%Variable documentation:~%~A"  doc)))
297    (when (fboundp sym)    (when (fboundp sym)
298      (format t "~%~%(~A~{ ~A~})"      (describe-function sym)))
             (string-downcase sym)  
             (mapcar #'string-upcase  
                     (lispworks:function-lambda-list sym))))  
   (let ((doc (documentation sym 'function)))  
     (when doc (format t "~%~%~A~%"  doc))))  
299    
300  ;;; Debugging  (defimplementation type-specifier-p (symbol)
301      (or (ignore-errors
302           (subtypep nil symbol))
303          (not (eq (type-specifier-arglist symbol) :not-available))))
304    
305  (defvar *sldb-restarts*)  ;;; Debugging
306    
307  (defslimefun sldb-abort ()  (defclass slime-env (env:environment)
308    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    ((debugger-hook :initarg :debugger-hoook)))
309    
310  (defimplementation call-with-debugging-environment (fn)  (defun slime-env (hook io-bindings)
311    (dbg::with-debugger-stack ()    (make-instance 'slime-env :name "SLIME Environment"
312      (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))                   :io-bindings io-bindings
313        (funcall fn))))                   :debugger-hoook hook))
314    
315    (defmethod env-internals:environment-display-notifier
316        ((env slime-env) &key restarts condition)
317      (declare (ignore restarts condition))
318      (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
319      ;;  nil
320      )
321    
322    (defmethod env-internals:environment-display-debugger ((env slime-env))
323      *debug-io*)
324    
325    (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
326      (apply (swank-sym :y-or-n-p-in-emacs) msg args))
327    
328    (defimplementation call-with-debugger-hook (hook fun)
329      (let ((*debugger-hook* hook))
330        (env:with-environment ((slime-env hook '()))
331          (funcall fun))))
332    
333    (defimplementation install-debugger-globally (function)
334      (setq *debugger-hook* function)
335      (setf (env:environment) (slime-env function '())))
336    
337  (defun format-restarts-for-emacs ()  (defvar *sldb-top-frame*)
   (loop for restart in *sldb-restarts*  
         collect (list (princ-to-string (restart-name restart))  
                       (princ-to-string restart))))  
338    
339  (defun interesting-frame-p (frame)  (defun interesting-frame-p (frame)
340    (or (dbg::call-frame-p frame)    (cond ((or (dbg::call-frame-p frame)
341        ;;(dbg::catch-frame-p frame)               (dbg::derived-call-frame-p frame)
342        ))               (dbg::foreign-frame-p frame)
343                 (dbg::interpreted-call-frame-p frame))
344             t)
345            ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
346            ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
347            ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
348            ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
349            (t nil)))
350    
351    (defun nth-next-frame (frame n)
352      "Unwind FRAME N times."
353      (do ((frame frame (dbg::frame-next frame))
354           (i n (if (interesting-frame-p frame) (1- i) i)))
355          ((or (not frame)
356               (and (interesting-frame-p frame) (zerop i)))
357           frame)))
358    
359  (defun nth-frame (index)  (defun nth-frame (index)
360    (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)    (nth-next-frame *sldb-top-frame* index))
361                (dbg::frame-next frame))  
362         (i index (if (interesting-frame-p frame) (1- i) i)))  (defun find-top-frame ()
363        ((and (interesting-frame-p frame) (zerop i)) frame)    "Return the most suitable top-frame for the debugger."
364      (assert frame)))    (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
365                      (nth-next-frame frame 1)))
366              ((or (null frame)             ; no frame found!
367                   (and (dbg::call-frame-p frame)
368                        (eq (dbg::call-frame-function-name frame)
369                            'invoke-debugger)))
370               (nth-next-frame frame 1)))
371          ;; if we can't find a invoke-debugger frame, take any old frame
372          ;; at the top
373          (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))
374    
375    (defimplementation call-with-debugging-environment (fn)
376      (dbg::with-debugger-stack ()
377        (let ((*sldb-top-frame* (find-top-frame)))
378          (funcall fn))))
379    
380  (defun compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
381    (let ((end (or end most-positive-fixnum))    (let ((end (or end most-positive-fixnum))
382          (backtrace '()))          (backtrace '()))
383      (do ((frame (nth-frame start) (dbg::frame-next frame))      (do ((frame (nth-frame start) (dbg::frame-next frame))
# Line 185  Return NIL if the symbol is unbound." Line 387  Return NIL if the symbol is unbound."
387          (incf i)          (incf i)
388          (push frame backtrace)))))          (push frame backtrace)))))
389    
390  (defimplementation backtrace (start end)  (defun frame-actual-args (frame)
391    (flet ((format-frame (f i)    (let ((*break-on-signals* nil)
392             (print-with-frame-label          (kind nil))
393              i (lambda (s)      (loop for arg in (dbg::call-frame-arglist frame)
394                 (cond ((dbg::call-frame-p f)            if (eq kind '&rest)
395                        (format s "~A ~A"            nconc (handler-case
396                                (dbg::call-frame-function-name f)                      (dbg::dbg-eval arg frame)
397                                (dbg::call-frame-arglist f)))                    (error (e) (list (format nil "<~A>" arg))))
398                       (t (princ f s)))))))            and do (loop-finish)
399      (loop for i from start            else
400            for f in (compute-backtrace start end)            if (member arg '(&rest &optional &key))
401            collect (list i (format-frame f i)))))            do (setq kind arg)
402              else
403  (defimplementation debugger-info-for-emacs (start end)            nconc
404    (list (debugger-condition-for-emacs)            (handler-case
405          (format-restarts-for-emacs)                (nconc (and (eq kind '&key)
406          (backtrace start end)))                            (list (cond ((symbolp arg)
407                                           (intern (symbol-name arg) :keyword))
408  (defun nth-restart (index)                                        ((and (consp arg) (symbolp (car arg)))
409    (nth index *sldb-restarts*))                                         (intern (symbol-name (car arg))
410                                                   :keyword))
411                                          (t (caar arg)))))
412                         (list (dbg::dbg-eval
413                                (cond ((symbolp arg) arg)
414                                      ((and (consp arg) (symbolp (car arg)))
415                                       (car arg))
416                                      (t (cadar arg)))
417                                frame)))
418                (error (e) (list (format nil "<~A>" arg)))))))
419    
420    (defimplementation print-frame (frame stream)
421      (cond ((dbg::call-frame-p frame)
422             (prin1 (cons (dbg::call-frame-function-name frame)
423                          (frame-actual-args frame))
424                    stream))
425            (t (princ frame stream))))
426    
427  (defslimefun invoke-nth-restart (index)  (defun frame-vars (frame)
428    (invoke-restart-interactively (nth-restart index)))    (first (dbg::frame-locals-format-list frame #'list 75 0)))
429    
430  (defimplementation frame-locals (n)  (defimplementation frame-locals (n)
431    (let ((frame (nth-frame n)))    (let ((frame (nth-frame n)))
432      (if (dbg::call-frame-p frame)      (if (dbg::call-frame-p frame)
433          (destructuring-bind (vars with)          (mapcar (lambda (var)
434              (dbg::frame-locals-format-list frame #'list 75 0)                    (destructuring-bind (name value symbol location) var
435            (declare (ignore with))                      (declare (ignore name location))
436            (loop for (name value symbol location) in vars                      (list :name symbol :id 0
437                  collect (list :name (to-string symbol) :id 0                            :value value)))
438                                :value-string                  (frame-vars frame)))))
                               (to-string value)))))))  
   
 (defimplementation frame-catch-tags (index)  
   (declare (ignore index))  
   nil)  
439    
440  (defimplementation frame-source-location-for-emacs (frame)  (defimplementation frame-var-value (frame var)
441    (let ((frame (nth-frame frame)))    (let ((frame (nth-frame frame)))
442        (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
443          (declare (ignore _n _s _l))
444          value)))
445    
446    (defimplementation frame-source-location (frame)
447      (let ((frame (nth-frame frame))
448            (callee (if (plusp frame) (nth-frame (1- frame)))))
449      (if (dbg::call-frame-p frame)      (if (dbg::call-frame-p frame)
450          (let ((func (dbg::call-frame-function-name frame)))          (let ((dspec (dbg::call-frame-function-name frame))
451            (if func                (cname (and (dbg::call-frame-p callee)
452                (dspec-source-location func))))))                            (dbg::call-frame-function-name callee)))
453                  (path (and (dbg::call-frame-p frame)
454                             (dbg::call-frame-edit-path frame))))
455              (if dspec
456                  (frame-location dspec cname path))))))
457    
458    (defimplementation eval-in-frame (form frame-number)
459      (let ((frame (nth-frame frame-number)))
460        (dbg::dbg-eval form frame)))
461    
462    (defun function-name-package (name)
463      (typecase name
464        (null nil)
465        (symbol (symbol-package name))
466        ((cons (eql hcl:subfunction))
467         (destructuring-bind (name parent) (cdr name)
468           (declare (ignore name))
469           (function-name-package parent)))
470        ((cons (eql lw:top-level-form)) nil)
471        (t nil)))
472    
473  ;;; Definition finding  (defimplementation frame-package (frame-number)
474      (let ((frame (nth-frame frame-number)))
475        (if (dbg::call-frame-p frame)
476            (function-name-package (dbg::call-frame-function-name frame)))))
477    
478    (defimplementation return-from-frame (frame-number form)
479      (let* ((frame (nth-frame frame-number))
480             (return-frame (dbg::find-frame-for-return frame)))
481        (dbg::dbg-return-from-call-frame frame form return-frame
482                                         dbg::*debugger-stack*)))
483    
484    (defimplementation restart-frame (frame-number)
485      (let ((frame (nth-frame frame-number)))
486        (dbg::restart-frame frame :same-args t)))
487    
488    (defimplementation disassemble-frame (frame-number)
489      (let* ((frame (nth-frame frame-number)))
490        (when (dbg::call-frame-p frame)
491          (let ((function (dbg::get-call-frame-function frame)))
492            (disassemble function)))))
493    
494  (defun dspec-source-location (dspec)  ;;; Definition finding
   (destructuring-bind (first) (dspec-source-locations dspec)  
     first))  
   
 (defun dspec-source-locations (dspec)  
   (let ((locations (dspec:find-dspec-locations dspec)))  
     (cond ((not locations)  
            (list :error (format nil "Cannot find source for ~S" dspec)))  
           (t  
            (loop for (dspec location) in locations  
                  collect (make-dspec-location dspec location))))))  
495    
496  (defimplementation find-function-locations (fname)  (defun frame-location (dspec callee-name edit-path)
497    (dspec-source-locations (from-string fname)))    (let ((infos (dspec:find-dspec-locations dspec)))
498        (cond (infos
499               (destructuring-bind ((rdspec location) &rest _) infos
500                 (declare (ignore _))
501                 (let ((name (and callee-name (symbolp callee-name)
502                                  (string callee-name)))
503                       (path (edit-path-to-cmucl-source-path edit-path)))
504                   (make-dspec-location rdspec location
505                                        `(:call-site ,name :edit-path ,path)))))
506              (t
507               (list :error (format nil "Source location not available for: ~S"
508                                    dspec))))))
509    
510    ;; dbg::call-frame-edit-path is not documented but lets assume the
511    ;; binary representation of the integer EDIT-PATH should be
512    ;; interpreted as a sequence of CAR or CDR.  #b1111010 is roughly the
513    ;; same as cadadddr.  Something is odd with the highest bit.
514    (defun edit-path-to-cmucl-source-path (edit-path)
515      (and edit-path
516           (cons 0
517                 (let ((n -1))
518                   (loop for i from (1- (integer-length edit-path)) downto 0
519                         if (logbitp i edit-path) do (incf n)
520                         else collect (prog1 n (setq n 0)))))))
521    
522    ;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
523    
524    (defimplementation find-definitions (name)
525      (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
526        (loop for (dspec location) in locations
527              collect (list dspec (make-dspec-location dspec location)))))
528    
529    
530  ;;; Compilation  ;;; Compilation
531    
532  (defimplementation compile-file-for-emacs (filename load-p)  (defmacro with-swank-compilation-unit ((location &rest options) &body body)
533    (let ((compiler::*error-database* '()))    (lw:rebinding (location)
534        `(let ((compiler::*error-database* '()))
535           (with-compilation-unit ,options
536             (multiple-value-prog1 (progn ,@body)
537               (signal-error-data-base compiler::*error-database*
538                                       ,location)
539               (signal-undefined-functions compiler::*unknown-functions*
540                                           ,location))))))
541    
542    (defimplementation swank-compile-file (input-file output-file
543                                           load-p external-format
544                                           &key policy)
545      (declare (ignore policy))
546      (with-swank-compilation-unit (input-file)
547        (compile-file input-file
548                      :output-file output-file
549                      :load load-p
550                      :external-format external-format)))
551    
552    (defvar *within-call-with-compilation-hooks* nil
553      "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
554    
555    (defvar *undefined-functions-hash* nil
556      "Hash table to map info about undefined functions to pathnames.")
557    
558    (lw:defadvice (compile-file compile-file-and-collect-notes :around)
559        (pathname &rest rest)
560      (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
561        (when *within-call-with-compilation-hooks*
562          (maphash (lambda (unfun dspecs)
563                     (dolist (dspec dspecs)
564                       (let ((unfun-info (list unfun dspec)))
565                         (unless (gethash unfun-info *undefined-functions-hash*)
566                           (setf (gethash unfun-info *undefined-functions-hash*)
567                                   pathname)))))
568                   compiler::*unknown-functions*))))
569    
570    (defimplementation call-with-compilation-hooks (function)
571      (let ((compiler::*error-database* '())
572            (*undefined-functions-hash* (make-hash-table :test 'equal))
573            (*within-call-with-compilation-hooks* t))
574      (with-compilation-unit ()      (with-compilation-unit ()
575        (compile-file filename :load load-p)        (prog1 (funcall function)
576        (signal-error-data-base compiler::*error-database*)          (signal-error-data-base compiler::*error-database*)
577        (signal-undefined-functions compiler::*unknown-functions* filename))))          (signal-undefined-functions compiler::*unknown-functions*)))))
578    
579  (defun map-error-database (database fn)  (defun map-error-database (database fn)
580    (loop for (filename . defs) in database do    (loop for (filename . defs) in database do
581          (loop for (dspec . conditions) in defs do          (loop for (dspec . conditions) in defs do
582                (dolist (c conditions)                (dolist (c conditions)
583                  (funcall fn filename dspec c)))))                  (multiple-value-bind (condition path)
584                        (if (consp c) (values (car c) (cdr c)) (values c nil))
585                      (funcall fn filename dspec condition path))))))
586    
587  (defun lispworks-severity (condition)  (defun lispworks-severity (condition)
588    (cond ((not condition) :warning)    (cond ((not condition) :warning)
# Line 278  Return NIL if the symbol is unbound." Line 599  Return NIL if the symbol is unbound."
599                    :location location                    :location location
600                    :original-condition condition)))                    :original-condition condition)))
601    
602    (defvar *temp-file-format* '(:utf-8 :eol-style :lf))
603    
604  (defun compile-from-temp-file (string filename)  (defun compile-from-temp-file (string filename)
605    (unwind-protect    (unwind-protect
606         (progn         (progn
607           (with-open-file (s filename :direction :output :if-exists :supersede)           (with-open-file (s filename :direction :output
608                                         :if-exists :supersede
609                                         :external-format *temp-file-format*)
610    
611             (write-string string s)             (write-string string s)
612             (finish-output s))             (finish-output s))
613           (let ((binary-filename (compile-file filename :load t)))           (multiple-value-bind (binary-filename warnings? failure?)
614                 (compile-file filename :load t
615                               :external-format *temp-file-format*)
616               (declare (ignore warnings?))
617             (when binary-filename             (when binary-filename
618               (delete-file binary-filename))))               (delete-file binary-filename))
619               (not failure?)))
620      (delete-file filename)))      (delete-file filename)))
621    
622    (defun dspec-function-name-position (dspec fallback)
 ;; (dspec:dspec-primary-name '(:top-level-form 19))  
   
 (defun dspec-buffer-buffer-position (dspec)  
623    (etypecase dspec    (etypecase dspec
624      (cons (ecase (car dspec)      (cons (let ((name (dspec:dspec-primary-name dspec)))
625              (defun `(:function-name ,(symbol-name (cadr dspec))))              (typecase name
626              (method `(:function-name ,(symbol-name (cadr dspec))))                ((or symbol string)
627              ;; XXX this isn't quite right                 (list :function-name (string name)))
628              (lw:top-level-form `(:source-path ,(cdr dspec) nil))))                (t fallback))))
629      (symbol `(:function-name ,(symbol-name dspec)))))      (null fallback)
630        (symbol (list :function-name (string dspec)))))
631  (defun make-dspec-location (dspec location &optional tmpfile buffer position)  
632    (flet ((from-buffer-p ()  (defmacro with-fairly-standard-io-syntax (&body body)
633             (and (pathnamep location) tmpfile    "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
634                  (pathname-match-p location tmpfile)))    (let ((package (gensym))
635           (filename (pathname)          (readtable (gensym)))
636             (multiple-value-bind (truename condition)      `(let ((,package *package*)
637                 (ignore-errors (truename pathname))             (,readtable *readtable*))
638               (cond (condition        (with-standard-io-syntax
639                      (return-from make-dspec-location          (let ((*package* ,package)
640                        (list :error (format nil "~A" condition))))                (*readtable* ,readtable))
641                     (t (namestring truename)))))            ,@body)))))
642           (function-name (dspec)  
643             (etypecase dspec  (defun skip-comments (stream)
644               (symbol (symbol-name dspec))    (let ((pos0 (file-position stream)))
645               (cons (string (dspec:dspec-primary-name dspec))))))      (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
646      (cond ((from-buffer-p)                    '(()))
647             (make-location `(:buffer ,buffer) `(:position ,position)))             (file-position stream (1- (file-position stream))))
648            (t            (t (file-position stream pos0)))))
649             (etypecase location  
650               ((or pathname string)  #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
651                (make-location `(:file ,(filename location))  (defun dspec-stream-position (stream dspec)
652                               (dspec-buffer-buffer-position dspec)))    (with-fairly-standard-io-syntax
653               ((member :listener)      (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
654                `(:error ,(format nil "Function defined in listener: ~S" dspec)))                   (form (read stream nil '#1=#:eof)))
655               ((member :unknown)              (when (eq form '#1#)
656                `(:error ,(format nil "Function location unkown: ~S" dspec))))                (return nil))
657             ))))              (labels ((check-dspec (form)
658                           (when (consp form)
659                             (let ((operator (car form)))
660                               (case operator
661                                 ((progn)
662                                  (mapcar #'check-dspec
663                                          (cdr form)))
664                                 ((eval-when locally macrolet symbol-macrolet)
665                                  (mapcar #'check-dspec
666                                          (cddr form)))
667                                 ((in-package)
668                                  (let ((package (find-package (second form))))
669                                    (when package
670                                      (setq *package* package))))
671                                 (otherwise
672                                  (let ((form-dspec (dspec:parse-form-dspec form)))
673                                    (when (dspec:dspec-equal dspec form-dspec)
674                                      (return pos)))))))))
675                  (check-dspec form))))))
676    
677    (defun dspec-file-position (file dspec)
678      (let* ((*compile-file-pathname* (pathname file))
679             (*compile-file-truename* (truename *compile-file-pathname*))
680             (*load-pathname* *compile-file-pathname*)
681             (*load-truename* *compile-file-truename*))
682        (with-open-file (stream file)
683          (let ((pos
684                 #-(or lispworks4.1 lispworks4.2)
685                 (ignore-errors (dspec-stream-position stream dspec))))
686            (if pos
687                (list :position (1+ pos))
688                (dspec-function-name-position dspec `(:position 1)))))))
689    
690    (defun emacs-buffer-location-p (location)
691      (and (consp location)
692           (eq (car location) :emacs-buffer)))
693    
694    (defun make-dspec-location (dspec location &optional hints)
695      (etypecase location
696        ((or pathname string)
697         (multiple-value-bind (file err)
698             (ignore-errors (namestring (truename location)))
699           (if err
700               (list :error (princ-to-string err))
701               (make-location `(:file ,file)
702                              (dspec-file-position file dspec)
703                              hints))))
704        (symbol
705         `(:error ,(format nil "Cannot resolve location: ~S" location)))
706        ((satisfies emacs-buffer-location-p)
707         (destructuring-bind (_ buffer offset) location
708           (declare (ignore _))
709           (make-location `(:buffer ,buffer)
710                          (dspec-function-name-position dspec `(:offset ,offset 0))
711                          hints)))))
712    
713    (defun make-dspec-progenitor-location (dspec location edit-path)
714      (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
715        (make-dspec-location
716         (if canon-dspec
717             (if (dspec:local-dspec-p canon-dspec)
718                 (dspec:dspec-progenitor canon-dspec)
719                 canon-dspec)
720             nil)
721         location
722         (if edit-path
723             (list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
724    
725  (defun signal-error-data-base (database &optional tmpfile buffer position)  (defun signal-error-data-base (database &optional location)
726    (map-error-database    (map-error-database
727     database     database
728     (lambda (filename dspec condition)     (lambda (filename dspec condition edit-path)
729       (signal-compiler-condition       (signal-compiler-condition
730        (format nil "~A" condition)        (format nil "~A" condition)
731        (make-dspec-location dspec filename tmpfile buffer position)        (make-dspec-progenitor-location dspec (or location filename) edit-path)
732        condition))))        condition))))
733    
734  (defun signal-undefined-functions (htab filename  (defun unmangle-unfun (symbol)
735                                     &optional tmpfile buffer position)    "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
736    function names like \(SETF GET)."
737      (cond ((sys::setf-symbol-p symbol)
738             (sys::setf-pair-from-underlying-name symbol))
739            (t symbol)))
740    
741    (defun signal-undefined-functions (htab &optional filename)
742    (maphash (lambda (unfun dspecs)    (maphash (lambda (unfun dspecs)
743               (dolist (dspec dspecs)               (dolist (dspec dspecs)
744                 (signal-compiler-condition                 (signal-compiler-condition
745                  (format nil "Undefined function ~A" unfun)                  (format nil "Undefined function ~A" (unmangle-unfun unfun))
746                  (make-dspec-location dspec filename tmpfile buffer position)                  (make-dspec-progenitor-location
747                     dspec
748                     (or filename
749                         (gethash (list unfun dspec) *undefined-functions-hash*))
750                     nil)
751                  nil)))                  nil)))
752             htab))             htab))
753    
754  (defimplementation compile-string-for-emacs (string &key buffer position)  (defimplementation swank-compile-string (string &key buffer position filename
755                                             policy)
756      (declare (ignore filename policy))
757    (assert buffer)    (assert buffer)
758    (assert position)    (assert position)
759    (let ((*package* *buffer-package*)    (let* ((location (list :emacs-buffer buffer position))
760          (compiler::*error-database* '())           (tmpname (hcl:make-temp-file nil "lisp")))
761          (tmpname (hcl:make-temp-file nil "lisp")))      (with-swank-compilation-unit (location)
762      (with-compilation-unit ()        (compile-from-temp-file
763        (compile-from-temp-file string tmpname)         (with-output-to-string (s)
764        (format t "~A~%" compiler:*messages*)           (let ((*print-radix* t))
765        (signal-error-data-base             (print `(eval-when (:compile-toplevel)
766         compiler::*error-database* tmpname buffer position)                       (setq dspec::*location* (list ,@location)))
767        (signal-undefined-functions compiler::*unknown-functions*                    s))
768                                    tmpname tmpname buffer position))))           (write-string string s))
769           tmpname))))
770    
771  ;;; xref  ;;; xref
772    
773  (defun lookup-xrefs (finder name)  (defmacro defxref (name function)
774    (xref-results-for-emacs (funcall finder (from-string name))))    `(defimplementation ,name (name)
775        (xref-results (,function name))))
776  (defimplementation who-calls (function-name)  
777    (lookup-xrefs #'hcl:who-calls function-name))  (defxref who-calls      hcl:who-calls)
778    (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
779  (defimplementation who-references (variable)  (defxref calls-who      hcl:calls-who)
780    (lookup-xrefs #'hcl:who-references variable))  (defxref list-callers   list-callers-internal)
781    (defxref list-callees   list-callees-internal)
782  (defimplementation who-binds (variable)  
783    (lookup-xrefs #'hcl:who-binds variable))  (defun list-callers-internal (name)
784      (let ((callers (make-array 100
785  (defimplementation who-sets (variable)                               :fill-pointer 0
786    (lookup-xrefs #'hcl:who-sets variable))                               :adjustable t)))
787        (hcl:sweep-all-objects
788  (defun xref-results-for-emacs (dspecs)       #'(lambda (object)
789    (let ((xrefs '()))           (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
790      (dolist (dspec dspecs)                      #+Harlequin-Unix-Lisp (sys:callablep object)
791        (loop for (dspec location) in (dspec:find-dspec-locations dspec)                      #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp)
792              do (push (cons (to-string dspec)                      (sys:compiled-code-p object)
793                             (make-dspec-location dspec location))                      (system::find-constant$funcallable name object))
794                       xrefs)))             (vector-push-extend object callers))))
795      (group-xrefs xrefs)))      ;; Delay dspec:object-dspec until after sweep-all-objects
796        ;; to reduce allocation problems.
797        (loop for object across callers
798              collect (if (symbolp object)
799                          (list 'function object)
800                          (or (dspec:object-dspec object) object)))))
801    
802    (defun list-callees-internal (name)
803      (let ((callees '()))
804        (system::find-constant$funcallable
805         'junk name
806         :test #'(lambda (junk constant)
807                   (declare (ignore junk))
808                   (when (and (symbolp constant)
809                              (fboundp constant))
810                     (pushnew (list 'function constant) callees :test 'equal))
811                   ;; Return nil so we iterate over all constants.
812                   nil))
813        callees))
814    
815    ;; only for lispworks 4.2 and above
816    #-lispworks4.1
817    (progn
818      (defxref who-references hcl:who-references)
819      (defxref who-binds      hcl:who-binds)
820      (defxref who-sets       hcl:who-sets))
821    
822    (defimplementation who-specializes (classname)
823      (let ((methods (clos:class-direct-methods (find-class classname))))
824        (xref-results (mapcar #'dspec:object-dspec methods))))
825    
826    (defun xref-results (dspecs)
827      (flet ((frob-locs (dspec locs)
828               (cond (locs
829                      (loop for (name loc) in locs
830                            collect (list name (make-dspec-location name loc))))
831                     (t `((,dspec (:error "Source location not available")))))))
832        (loop for dspec in dspecs
833              append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
834    
835    ;;; Inspector
836    
837    (defmethod emacs-inspect ((o t))
838      (lispworks-inspect o))
839    
840    (defmethod emacs-inspect ((o function))
841      (lispworks-inspect o))
842    
843    ;; FIXME: slot-boundp-using-class in LW works with names so we can't
844    ;; use our method in swank.lisp.
845    (defmethod emacs-inspect ((o standard-object))
846      (lispworks-inspect o))
847    
848    (defun lispworks-inspect (o)
849      (multiple-value-bind (names values _getter _setter type)
850          (lw:get-inspector-values o nil)
851        (declare (ignore _getter _setter))
852                (append
853                 (label-value-line "Type" type)
854                 (loop for name in names
855                       for value in values
856                       append (label-value-line name value)))))
857    
858    ;;; Miscellaneous
859    
860    (defimplementation quit-lisp ()
861      (lispworks:quit))
862    
863    ;;; Tracing
864    
865    (defun parse-fspec (fspec)
866      "Return a dspec for FSPEC."
867      (ecase (car fspec)
868        ((:defmethod) `(method ,(cdr fspec)))))
869    
870    (defun tracedp (dspec)
871      (member dspec (eval '(trace)) :test #'equal))
872    
873    (defun toggle-trace-aux (dspec)
874      (cond ((tracedp dspec)
875             (eval `(untrace ,dspec))
876             (format nil "~S is now untraced." dspec))
877            (t
878             (eval `(trace (,dspec)))
879             (format nil "~S is now traced." dspec))))
880    
881  (defimplementation list-callers (symbol-name)  (defimplementation toggle-trace (fspec)
882    (lookup-xrefs #'hcl:who-calls symbol-name))    (toggle-trace-aux (parse-fspec fspec)))
   
 (defimplementation list-callees (symbol-name)  
   (lookup-xrefs #'hcl:calls-who symbol-name))  
883    
884  ;;; Multithreading  ;;; Multithreading
885    
886  (defimplementation startup-multiprocessing ()  (defimplementation initialize-multiprocessing (continuation)
887    (mp:initialize-multiprocessing))    (cond ((not mp::*multiprocessing*)
888             (push (list "Initialize SLIME" '() continuation)
889                   mp:*initial-processes*)
890             (mp:initialize-multiprocessing))
891            (t (funcall continuation))))
892    
893  (defimplementation spawn (fn &key name)  (defimplementation spawn (fn &key name)
894    (mp:process-run-function name () fn))    (mp:process-run-function name () fn))
895    
896  ;; XXX: shortcut  (defvar *id-lock* (mp:make-lock))
897  (defimplementation thread-id ()  (defvar *thread-id-counter* 0)
   (mp:process-name mp:*current-process*))  
898    
899  (defimplementation thread-name (thread-id)  (defimplementation thread-id (thread)
900    thread-id)    (mp:with-lock (*id-lock*)
901        (or (getf (mp:process-plist thread) 'id)
902            (setf (getf (mp:process-plist thread) 'id)
903                  (incf *thread-id-counter*)))))
904    
905    (defimplementation find-thread (id)
906      (find id (mp:list-all-processes)
907            :key (lambda (p) (getf (mp:process-plist p) 'id))))
908    
909    (defimplementation thread-name (thread)
910      (mp:process-name thread))
911    
912    (defimplementation thread-status (thread)
913      (format nil "~A ~D"
914              (mp:process-whostate thread)
915              (mp:process-priority thread)))
916    
917  (defimplementation make-lock (&key name)  (defimplementation make-lock (&key name)
918    (mp:make-lock :name name))    (mp:make-lock :name name))
# Line 418  Return NIL if the symbol is unbound." Line 923  Return NIL if the symbol is unbound."
923  (defimplementation current-thread ()  (defimplementation current-thread ()
924    mp:*current-process*)    mp:*current-process*)
925    
926    (defimplementation all-threads ()
927      (mp:list-all-processes))
928    
929  (defimplementation interrupt-thread (thread fn)  (defimplementation interrupt-thread (thread fn)
930    (mp:process-interrupt thread fn))    (mp:process-interrupt thread fn))
931    
932    (defimplementation kill-thread (thread)
933      (mp:process-kill thread))
934    
935    (defimplementation thread-alive-p (thread)
936      (mp:process-alive-p thread))
937    
938    (defstruct (mailbox (:conc-name mailbox.))
939      (mutex (mp:make-lock :name "thread mailbox"))
940      (queue '() :type list))
941    
942  (defvar *mailbox-lock* (mp:make-lock))  (defvar *mailbox-lock* (mp:make-lock))
943    
944  (defun mailbox (thread)  (defun mailbox (thread)
945    (mp:with-lock (*mailbox-lock*)    (mp:with-lock (*mailbox-lock*)
946      (or (getf (mp:process-plist thread) 'mailbox)      (or (getf (mp:process-plist thread) 'mailbox)
947          (setf (getf (mp:process-plist thread) 'mailbox)          (setf (getf (mp:process-plist thread) 'mailbox)
948                (mp:make-mailbox)))))                (make-mailbox)))))
949    
950  (defimplementation receive ()  (defimplementation receive-if (test &optional timeout)
951    (mp:mailbox-read (mailbox mp:*current-process*)))    (let* ((mbox (mailbox mp:*current-process*))
952             (lock (mailbox.mutex mbox)))
953        (assert (or (not timeout) (eq timeout t)))
954        (loop
955         (check-slime-interrupts)
956         (mp:with-lock (lock "receive-if/try")
957           (let* ((q (mailbox.queue mbox))
958                  (tail (member-if test q)))
959             (when tail
960               (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
961               (return (car tail)))))
962         (when (eq timeout t) (return (values nil t)))
963         (mp:process-wait-with-timeout
964          "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
965    
966    (defimplementation send (thread message)
967      (let ((mbox (mailbox thread)))
968        (mp:with-lock ((mailbox.mutex mbox))
969          (setf (mailbox.queue mbox)
970                (nconc (mailbox.queue mbox) (list message))))))
971    
972    (let ((alist '())
973          (lock (mp:make-lock :name "register-thread")))
974    
975      (defimplementation register-thread (name thread)
976        (declare (type symbol name))
977        (mp:with-lock (lock)
978          (etypecase thread
979            (null
980             (setf alist (delete name alist :key #'car)))
981            (mp:process
982             (let ((probe (assoc name alist)))
983               (cond (probe (setf (cdr probe) thread))
984                     (t (setf alist (acons name thread alist))))))))
985        nil)
986    
987      (defimplementation find-registered (name)
988        (mp:with-lock (lock)
989          (cdr (assoc name alist)))))
990    
991    
992    (defimplementation set-default-initial-binding (var form)
993      (setq mp:*process-initial-bindings*
994            (acons var `(eval (quote ,form))
995                   mp:*process-initial-bindings* )))
996    
997    (defimplementation thread-attributes (thread)
998      (list :priority (mp:process-priority thread)
999            :idle (mp:process-idle-time thread)))
1000    
1001    ;;; Some intergration with the lispworks environment
1002    
1003    (defun swank-sym (name) (find-symbol (string name) :swank))
1004    
1005    
1006    ;;;; Weak hashtables
1007    
1008  (defimplementation send (thread object)  (defimplementation make-weak-key-hash-table (&rest args)
1009    (mp:mailbox-send (mailbox thread) object))    (apply #'make-hash-table :weak-kind :key args))
1010    
1011    (defimplementation make-weak-value-hash-table (&rest args)
1012      (apply #'make-hash-table :weak-kind :value args))

Legend:
Removed from v.1.19.2.1  
changed lines
  Added in v.1.153

  ViewVC Help
Powered by ViewVC 1.1.5