/[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.128 by heller, Sat Jan 10 12:25:16 2009 UTC revision 1.154 by msimmons, Tue May 14 15:34:03 2013 UTC
# Line 15  Line 15 
15    (import-from :stream *gray-stream-symbols* :swank-backend))    (import-from :stream *gray-stream-symbols* :swank-backend))
16    
17  (import-swank-mop-symbols :clos '(:slot-definition-documentation  (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                                    :eql-specializer
22                                    :eql-specializer-object                                    :eql-specializer-object
23                                    :compute-applicable-methods-using-classes))                                    :compute-applicable-methods-using-classes))
# Line 22  Line 25 
25  (defun swank-mop:slot-definition-documentation (slot)  (defun swank-mop:slot-definition-documentation (slot)
26    (documentation slot t))    (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)  (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
46    (clos::compute-applicable-methods-from-classes gf classes))    (clos::compute-applicable-methods-from-classes gf classes))
47    
# Line 42  Line 62 
62                                  :check-redefinition-p nil)                                  :check-redefinition-p nil)
63         ,(funcall *original-defimplementation* whole env))))         ,(funcall *original-defimplementation* whole env))))
64    
65    ;;; UTF8
66    
67    (defimplementation string-to-utf8 (string)
68      (ef:encode-lisp-string string '(:utf-8 :eol-style :lf)))
69    
70    (defimplementation utf8-to-string (octets)
71      (ef:decode-external-string octets '(:utf-8 :eol-style :lf)))
72    
73  ;;; TCP server  ;;; TCP server
74    
75  (defimplementation preferred-communication-style ()  (defimplementation preferred-communication-style ()
# Line 52  Line 80 
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 (host port)  (defimplementation create-socket (host port &key backlog)
84    (multiple-value-bind (socket where errno)    (multiple-value-bind (socket where errno)
85        #-(or lispworks4.1 (and macosx lispworks4.3))        #-(or lispworks4.1 (and macosx lispworks4.3))
86        (comm::create-tcp-socket-for-service port :address host)        (comm::create-tcp-socket-for-service port :address host
87                                               :backlog (or backlog 5))
88        #+(or lispworks4.1 (and macosx lispworks4.3))        #+(or lispworks4.1 (and macosx lispworks4.3))
89        (comm::create-tcp-socket-for-service port)        (comm::create-tcp-socket-for-service port)
90      (cond (socket socket)      (cond (socket socket)
# Line 76  Line 105 
105    (declare (ignore buffering))    (declare (ignore buffering))
106    (let* ((fd (comm::get-fd-from-socket socket)))    (let* ((fd (comm::get-fd-from-socket socket)))
107      (assert (/= fd -1))      (assert (/= fd -1))
108      (assert (valid-external-format-p external-format))      (cond ((not external-format)
     (cond ((member (first external-format) '(:latin-1 :ascii))  
109             (make-instance 'comm:socket-stream             (make-instance 'comm:socket-stream
110                            :socket fd                            :socket fd
111                            :direction :io                            :direction :io
112                            :read-timeout timeout                            :read-timeout timeout
113                            :element-type 'base-char))                            :element-type '(unsigned-byte 8)))
114            (t            (t
115             (make-flexi-stream             (assert (valid-external-format-p external-format))
116              (make-instance 'comm:socket-stream             (ecase (first external-format)
117                             :socket fd               ((:latin-1 :ascii)
118                             :direction :io                (make-instance 'comm:socket-stream
119                             :read-timeout timeout                               :socket fd
120                             :element-type '(unsigned-byte 8))                               :direction :io
121              external-format)))))                               :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)  (defun make-flexi-stream (stream external-format)
133    (unless (member :flexi-streams *features*)    (unless (member :flexi-streams *features*)
134      (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."      (error "Cannot use external format ~A~
135                without having installed flexi-streams in the inferior-lisp."
136             external-format))             external-format))
137    (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")    (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
138             stream             stream
# Line 111  Line 149 
149  (defvar *external-format-to-coding-system*  (defvar *external-format-to-coding-system*
150    '(((:latin-1 :eol-style :lf)    '(((:latin-1 :eol-style :lf)
151       "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")       "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
152      ((:latin-1)      ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1")
153       "latin-1" "iso-latin-1" "iso-8859-1")      ;;((:utf-8) "utf-8")
     ((:utf-8) "utf-8")  
154      ((:utf-8 :eol-style :lf) "utf-8-unix")      ((:utf-8 :eol-style :lf) "utf-8-unix")
155      ((:euc-jp) "euc-jp")      ;;((:euc-jp) "euc-jp")
156      ((:euc-jp :eol-style :lf) "euc-jp-unix")      ((:euc-jp :eol-style :lf) "euc-jp-unix")
157      ((:ascii) "us-ascii")      ;;((:ascii) "us-ascii")
158      ((:ascii :eol-style :lf) "us-ascii-unix")))      ((:ascii :eol-style :lf) "us-ascii-unix")))
159    
160  (defimplementation find-external-format (coding-system)  (defimplementation find-external-format (coding-system)
# Line 149  Line 186 
186                                 (declare (ignore args))                                 (declare (ignore args))
187                                 (mp:process-interrupt self handler)))))                                 (mp:process-interrupt self handler)))))
188    
 (defimplementation call-without-interrupts (fn)  
   (lw:without-interrupts (funcall fn)))  
   
189  (defimplementation getpid ()  (defimplementation getpid ()
190    #+win32 (win32:get-current-process-id)    #+win32 (win32:get-current-process-id)
191    #-win32 (system::getpid))    #-win32 (system::getpid))
# Line 164  Line 198 
198    
199  ;;;; Documentation  ;;;; 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)  (defimplementation arglist (symbol-or-function)
223    (let ((arglist (lw:function-lambda-list symbol-or-function)))    (let ((arglist (lw:function-lambda-list symbol-or-function)))
224      (etypecase arglist      (etypecase arglist
225        ((member :dont-know)        ((member :dont-know)
226         :not-available)         :not-available)
227        (list        (list
228         arglist))))         (replace-strings-with-symbols arglist)))))
229    
230  (defimplementation function-name (function)  (defimplementation function-name (function)
231    (nth-value 2 (function-lambda-expression function)))    (nth-value 2 (function-lambda-expression function)))
# Line 242  Return NIL if the symbol is unbound." Line 297  Return NIL if the symbol is unbound."
297    (when (fboundp sym)    (when (fboundp sym)
298      (describe-function sym)))      (describe-function sym)))
299    
300    (defimplementation type-specifier-p (symbol)
301      (or (ignore-errors
302           (subtypep nil symbol))
303          (not (eq (type-specifier-arglist symbol) :not-available))))
304    
305  ;;; Debugging  ;;; Debugging
306    
307  (defclass slime-env (env:environment)  (defclass slime-env (env:environment)
# Line 286  Return NIL if the symbol is unbound." Line 346  Return NIL if the symbol is unbound."
346          ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)          ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
347          ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)          ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
348          ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)          ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
         ((dbg::open-frame-p frame) dbg:*print-open-frames*)  
349          (t nil)))          (t nil)))
350    
351  (defun nth-next-frame (frame n)  (defun nth-next-frame (frame n)
# Line 299  Return NIL if the symbol is unbound." Line 358  Return NIL if the symbol is unbound."
358    
359  (defun nth-frame (index)  (defun nth-frame (index)
360    (nth-next-frame *sldb-top-frame* index))    (nth-next-frame *sldb-top-frame* index))
361    
362  (defun find-top-frame ()  (defun find-top-frame ()
363    "Return the most suitable top-frame for the debugger."    "Return the most suitable top-frame for the debugger."
364    (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)    (flet ((find-named-frame (name)
365                    (nth-next-frame frame 1)))             (do ((frame (dbg::debugger-stack-current-frame
366            ((or (null frame)             ; no frame found!                          dbg::*debugger-stack*)
367                 (and (dbg::call-frame-p frame)                         (nth-next-frame frame 1)))
368                      (eq (dbg::call-frame-function-name frame)                 ((or (null frame)        ; no frame found!
369                          'invoke-debugger)))                      (and (dbg::call-frame-p frame)
370             (nth-next-frame frame 1)))                           (eq (dbg::call-frame-function-name frame)
371        ;; if we can't find a invoke-debugger frame, take any old frame at the top                               name)))
372        (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))                  (nth-next-frame frame 1)))))
373        (or (find-named-frame 'invoke-debugger)
374            (find-named-frame (swank-sym :safe-backtrace))
375            ;; if we can't find a likely top frame, take any old frame
376            ;; at the top
377            (dbg::debugger-stack-current-frame dbg::*debugger-stack*))))
378    
379  (defimplementation call-with-debugging-environment (fn)  (defimplementation call-with-debugging-environment (fn)
380    (dbg::with-debugger-stack ()    (dbg::with-debugger-stack ()
# Line 328  Return NIL if the symbol is unbound." Line 392  Return NIL if the symbol is unbound."
392          (push frame backtrace)))))          (push frame backtrace)))))
393    
394  (defun frame-actual-args (frame)  (defun frame-actual-args (frame)
395    (let ((*break-on-signals* nil))    (let ((*break-on-signals* nil)
396      (mapcar (lambda (arg)          (kind nil))
397                (case arg      (loop for arg in (dbg::call-frame-arglist frame)
398                  ((&rest &optional &key) arg)            if (eq kind '&rest)
399                  (t            nconc (handler-case
400                   (handler-case (dbg::dbg-eval arg frame)                      (dbg::dbg-eval arg frame)
401                     (error (e) (format nil "<~A>" arg))))))                    (error (e) (list (format nil "<~A>" arg))))
402              (dbg::call-frame-arglist frame))))            and do (loop-finish)
403              else
404              if (member arg '(&rest &optional &key))
405              do (setq kind arg)
406              else
407              nconc
408              (handler-case
409                  (nconc (and (eq kind '&key)
410                              (list (cond ((symbolp arg)
411                                           (intern (symbol-name arg) :keyword))
412                                          ((and (consp arg) (symbolp (car arg)))
413                                           (intern (symbol-name (car arg))
414                                                   :keyword))
415                                          (t (caar arg)))))
416                         (list (dbg::dbg-eval
417                                (cond ((symbolp arg) arg)
418                                      ((and (consp arg) (symbolp (car arg)))
419                                       (car arg))
420                                      (t (cadar arg)))
421                                frame)))
422                (error (e) (list (format nil "<~A>" arg)))))))
423    
424  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
425    (cond ((dbg::call-frame-p frame)    (cond ((dbg::call-frame-p frame)
426           (format stream "~S ~S"           (prin1 (cons (dbg::call-frame-function-name frame)
427                   (dbg::call-frame-function-name frame)                        (frame-actual-args frame))
428                   (frame-actual-args frame)))                  stream))
429          (t (princ frame stream))))          (t (princ frame stream))))
430    
431  (defun frame-vars (frame)  (defun frame-vars (frame)
# Line 363  Return NIL if the symbol is unbound." Line 447  Return NIL if the symbol is unbound."
447        (declare (ignore _n _s _l))        (declare (ignore _n _s _l))
448        value)))        value)))
449    
450  (defimplementation frame-source-location-for-emacs (frame)  (defimplementation frame-source-location (frame)
451    (let ((frame (nth-frame frame))    (let ((frame (nth-frame frame))
452          (callee (if (plusp frame) (nth-frame (1- frame)))))          (callee (if (plusp frame) (nth-frame (1- frame)))))
453      (if (dbg::call-frame-p frame)      (if (dbg::call-frame-p frame)
454          (let ((dspec (dbg::call-frame-function-name frame))          (let ((dspec (dbg::call-frame-function-name frame))
455                (cname (and (dbg::call-frame-p callee)                (cname (and (dbg::call-frame-p callee)
456                            (dbg::call-frame-function-name callee))))                            (dbg::call-frame-function-name callee)))
457                  (path (and (dbg::call-frame-p frame)
458                             (dbg::call-frame-edit-path frame))))
459            (if dspec            (if dspec
460                (frame-location dspec cname))))))                (frame-location dspec cname path))))))
461    
462  (defimplementation eval-in-frame (form frame-number)  (defimplementation eval-in-frame (form frame-number)
463    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
464      (dbg::dbg-eval form frame)))      (dbg::dbg-eval form frame)))
465    
466    (defun function-name-package (name)
467      (typecase name
468        (null nil)
469        (symbol (symbol-package name))
470        ((cons (eql hcl:subfunction))
471         (destructuring-bind (name parent) (cdr name)
472           (declare (ignore name))
473           (function-name-package parent)))
474        ((cons (eql lw:top-level-form)) nil)
475        (t nil)))
476    
477    (defimplementation frame-package (frame-number)
478      (let ((frame (nth-frame frame-number)))
479        (if (dbg::call-frame-p frame)
480            (function-name-package (dbg::call-frame-function-name frame)))))
481    
482  (defimplementation return-from-frame (frame-number form)  (defimplementation return-from-frame (frame-number form)
483    (let* ((frame (nth-frame frame-number))    (let* ((frame (nth-frame frame-number))
484           (return-frame (dbg::find-frame-for-return frame)))           (return-frame (dbg::find-frame-for-return frame)))
485      (dbg::dbg-return-from-call-frame frame form return-frame      (dbg::dbg-return-from-call-frame frame form return-frame
486                                       dbg::*debugger-stack*)))                                       dbg::*debugger-stack*)))
487    
488  (defimplementation restart-frame (frame-number)  (defimplementation restart-frame (frame-number)
# Line 395  Return NIL if the symbol is unbound." Line 497  Return NIL if the symbol is unbound."
497    
498  ;;; Definition finding  ;;; Definition finding
499    
500  (defun frame-location (dspec callee-name)  (defun frame-location (dspec callee-name edit-path)
501    (let ((infos (dspec:find-dspec-locations dspec)))    (let ((infos (dspec:find-dspec-locations dspec)))
502      (cond (infos      (cond (infos
503             (destructuring-bind ((rdspec location) &rest _) infos             (destructuring-bind ((rdspec location) &rest _) infos
504               (declare (ignore _))               (declare (ignore _))
505               (let ((name (and callee-name (symbolp callee-name)               (let ((name (and callee-name (symbolp callee-name)
506                                (string callee-name))))                                (string callee-name)))
507                 (make-dspec-location rdspec location                     (path (edit-path-to-cmucl-source-path edit-path)))
508                                      `(:call-site ,name)))))                 (make-dspec-location rdspec location
509                                        `(:call-site ,name :edit-path ,path)))))
510            (t            (t
511             (list :error (format nil "Source location not available for: ~S"             (list :error (format nil "Source location not available for: ~S"
512                                  dspec))))))                                  dspec))))))
513    
514    ;; dbg::call-frame-edit-path is not documented but lets assume the
515    ;; binary representation of the integer EDIT-PATH should be
516    ;; interpreted as a sequence of CAR or CDR.  #b1111010 is roughly the
517    ;; same as cadadddr.  Something is odd with the highest bit.
518    (defun edit-path-to-cmucl-source-path (edit-path)
519      (and edit-path
520           (cons 0
521                 (let ((n -1))
522                   (loop for i from (1- (integer-length edit-path)) downto 0
523                         if (logbitp i edit-path) do (incf n)
524                         else collect (prog1 n (setq n 0)))))))
525    
526    ;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
527    
528  (defimplementation find-definitions (name)  (defimplementation find-definitions (name)
529    (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))    (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
530      (loop for (dspec location) in locations      (loop for (dspec location) in locations
# Line 427  Return NIL if the symbol is unbound." Line 544  Return NIL if the symbol is unbound."
544                                         ,location))))))                                         ,location))))))
545    
546  (defimplementation swank-compile-file (input-file output-file  (defimplementation swank-compile-file (input-file output-file
547                                         load-p external-format)                                         load-p external-format
548                                           &key policy)
549      (declare (ignore policy))
550    (with-swank-compilation-unit (input-file)    (with-swank-compilation-unit (input-file)
551      (compile-file input-file      (compile-file input-file
552                    :output-file output-file                    :output-file output-file
# Line 464  Return NIL if the symbol is unbound." Line 583  Return NIL if the symbol is unbound."
583  (defun map-error-database (database fn)  (defun map-error-database (database fn)
584    (loop for (filename . defs) in database do    (loop for (filename . defs) in database do
585          (loop for (dspec . conditions) in defs do          (loop for (dspec . conditions) in defs do
586                (dolist (c conditions)                (dolist (c conditions)
587                  (funcall fn filename dspec (if (consp c) (car c) c))))))                  (multiple-value-bind (condition path)
588                        (if (consp c) (values (car c) (cdr c)) (values c nil))
589                      (funcall fn filename dspec condition path))))))
590    
591  (defun lispworks-severity (condition)  (defun lispworks-severity (condition)
592    (cond ((not condition) :warning)    (cond ((not condition) :warning)
# Line 565  Return NIL if the symbol is unbound." Line 686  Return NIL if the symbol is unbound."
686      (with-open-file (stream file)      (with-open-file (stream file)
687        (let ((pos        (let ((pos
688               #-(or lispworks4.1 lispworks4.2)               #-(or lispworks4.1 lispworks4.2)
689               (dspec-stream-position stream dspec)))               (ignore-errors (dspec-stream-position stream dspec))))
690          (if pos          (if pos
691              (list :position (1+ pos))              (list :position (1+ pos))
692              (dspec-function-name-position dspec `(:position 1)))))))              (dspec-function-name-position dspec `(:position 1)))))))
# Line 587  Return NIL if the symbol is unbound." Line 708  Return NIL if the symbol is unbound."
708      (symbol      (symbol
709       `(:error ,(format nil "Cannot resolve location: ~S" location)))       `(:error ,(format nil "Cannot resolve location: ~S" location)))
710      ((satisfies emacs-buffer-location-p)      ((satisfies emacs-buffer-location-p)
711       (destructuring-bind (_ buffer offset string) location       (destructuring-bind (_ buffer offset) location
712         (declare (ignore _ string))         (declare (ignore _))
713         (make-location `(:buffer ,buffer)         (make-location `(:buffer ,buffer)
714                        (dspec-function-name-position dspec `(:offset ,offset 0))                        (dspec-function-name-position dspec `(:offset ,offset 0))
715                        hints)))))                        hints)))))
716    
717  (defun make-dspec-progenitor-location (dspec location)  (defun make-dspec-progenitor-location (dspec location edit-path)
718    (let ((canon-dspec (dspec:canonicalize-dspec dspec)))    (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
719      (make-dspec-location      (make-dspec-location
720       (if canon-dspec       (if canon-dspec
721           (if (dspec:local-dspec-p canon-dspec)           (if (dspec:local-dspec-p canon-dspec)
722               (dspec:dspec-progenitor canon-dspec)               (dspec:dspec-progenitor canon-dspec)
723             canon-dspec)               canon-dspec)
724         nil)           nil)
725       location)))       location
726         (if edit-path
727             (list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
728    
729  (defun signal-error-data-base (database &optional location)  (defun signal-error-data-base (database &optional location)
730    (map-error-database    (map-error-database
731     database     database
732     (lambda (filename dspec condition)     (lambda (filename dspec condition edit-path)
733       (signal-compiler-condition       (signal-compiler-condition
734        (format nil "~A" condition)        (format nil "~A" condition)
735        (make-dspec-progenitor-location dspec (or location filename))        (make-dspec-progenitor-location dspec (or location filename) edit-path)
736        condition))))        condition))))
737    
738  (defun unmangle-unfun (symbol)  (defun unmangle-unfun (symbol)
# Line 624  function names like \(SETF GET)." Line 747  function names like \(SETF GET)."
747               (dolist (dspec dspecs)               (dolist (dspec dspecs)
748                 (signal-compiler-condition                 (signal-compiler-condition
749                  (format nil "Undefined function ~A" (unmangle-unfun unfun))                  (format nil "Undefined function ~A" (unmangle-unfun unfun))
750                  (make-dspec-progenitor-location dspec                  (make-dspec-progenitor-location
751                                                  (or filename                   dspec
752                                                      (gethash (list unfun dspec)                   (or filename
753                                                               *undefined-functions-hash*)))                       (gethash (list unfun dspec) *undefined-functions-hash*))
754                     nil)
755                  nil)))                  nil)))
756             htab))             htab))
757    
# Line 636  function names like \(SETF GET)." Line 760  function names like \(SETF GET)."
760    (declare (ignore filename policy))    (declare (ignore filename policy))
761    (assert buffer)    (assert buffer)
762    (assert position)    (assert position)
763    (let* ((location (list :emacs-buffer buffer position string))    (let* ((location (list :emacs-buffer buffer position))
764           (tmpname (hcl:make-temp-file nil "lisp")))           (tmpname (hcl:make-temp-file nil "lisp")))
765      (with-swank-compilation-unit (location)      (with-swank-compilation-unit (location)
766        (compile-from-temp-file        (compile-from-temp-file
# Line 658  function names like \(SETF GET)." Line 782  function names like \(SETF GET)."
782  (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
783  (defxref calls-who      hcl:calls-who)  (defxref calls-who      hcl:calls-who)
784  (defxref list-callers   list-callers-internal)  (defxref list-callers   list-callers-internal)
785  ;; (defxref list-callees   list-callees-internal)  (defxref list-callees   list-callees-internal)
786    
787  (defun list-callers-internal (name)  (defun list-callers-internal (name)
788    (let ((callers (make-array 100    (let ((callers (make-array 100
# Line 667  function names like \(SETF GET)." Line 791  function names like \(SETF GET)."
791      (hcl:sweep-all-objects      (hcl:sweep-all-objects
792       #'(lambda (object)       #'(lambda (object)
793           (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)           (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
794                      #-Harlequin-PC-Lisp (sys::callablep object)                      #+Harlequin-Unix-Lisp (sys:callablep object)
795                        #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp)
796                        (sys:compiled-code-p object)
797                      (system::find-constant$funcallable name object))                      (system::find-constant$funcallable name object))
798             (vector-push-extend object callers))))             (vector-push-extend object callers))))
799      ;; Delay dspec:object-dspec until after sweep-all-objects      ;; Delay dspec:object-dspec until after sweep-all-objects
# Line 677  function names like \(SETF GET)." Line 803  function names like \(SETF GET)."
803                        (list 'function object)                        (list 'function object)
804                        (or (dspec:object-dspec object) object)))))                        (or (dspec:object-dspec object) object)))))
805    
806    (defun list-callees-internal (name)
807      (let ((callees '()))
808        (system::find-constant$funcallable
809         'junk name
810         :test #'(lambda (junk constant)
811                   (declare (ignore junk))
812                   (when (and (symbolp constant)
813                              (fboundp constant))
814                     (pushnew (list 'function constant) callees :test 'equal))
815                   ;; Return nil so we iterate over all constants.
816                   nil))
817        callees))
818    
819  ;; only for lispworks 4.2 and above  ;; only for lispworks 4.2 and above
820  #-lispworks4.1  #-lispworks4.1
821  (progn  (progn
# Line 834  function names like \(SETF GET)." Line 973  function names like \(SETF GET)."
973        (setf (mailbox.queue mbox)        (setf (mailbox.queue mbox)
974              (nconc (mailbox.queue mbox) (list message))))))              (nconc (mailbox.queue mbox) (list message))))))
975    
976    (let ((alist '())
977          (lock (mp:make-lock :name "register-thread")))
978    
979      (defimplementation register-thread (name thread)
980        (declare (type symbol name))
981        (mp:with-lock (lock)
982          (etypecase thread
983            (null
984             (setf alist (delete name alist :key #'car)))
985            (mp:process
986             (let ((probe (assoc name alist)))
987               (cond (probe (setf (cdr probe) thread))
988                     (t (setf alist (acons name thread alist))))))))
989        nil)
990    
991      (defimplementation find-registered (name)
992        (mp:with-lock (lock)
993          (cdr (assoc name alist)))))
994    
995    
996  (defimplementation set-default-initial-binding (var form)  (defimplementation set-default-initial-binding (var form)
997    (setq mp:*process-initial-bindings*    (setq mp:*process-initial-bindings*
998          (acons var `(eval (quote ,form))          (acons var `(eval (quote ,form))
999                 mp:*process-initial-bindings* )))                 mp:*process-initial-bindings* )))
1000    
1001    (defimplementation thread-attributes (thread)
1002      (list :priority (mp:process-priority thread)
1003            :idle (mp:process-idle-time thread)))
1004    
1005  ;;; Some intergration with the lispworks environment  ;;; Some intergration with the lispworks environment
1006    
1007  (defun swank-sym (name) (find-symbol (string name) :swank))  (defun swank-sym (name) (find-symbol (string name) :swank))

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

  ViewVC Help
Powered by ViewVC 1.1.5