/[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.147 by heller, Fri Jan 6 09:02:43 2012 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))
69    
70    (defimplementation utf8-to-string (octets)
71      (ef:decode-external-string octets :utf-8))
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 286  Return NIL if the symbol is unbound." Line 341  Return NIL if the symbol is unbound."
341          ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)          ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
342          ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)          ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
343          ((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*)  
344          (t nil)))          (t nil)))
345    
346  (defun nth-next-frame (frame n)  (defun nth-next-frame (frame n)
# Line 299  Return NIL if the symbol is unbound." Line 353  Return NIL if the symbol is unbound."
353    
354  (defun nth-frame (index)  (defun nth-frame (index)
355    (nth-next-frame *sldb-top-frame* index))    (nth-next-frame *sldb-top-frame* index))
356    
357  (defun find-top-frame ()  (defun find-top-frame ()
358    "Return the most suitable top-frame for the debugger."    "Return the most suitable top-frame for the debugger."
359    (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)    (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
# Line 328  Return NIL if the symbol is unbound." Line 382  Return NIL if the symbol is unbound."
382          (push frame backtrace)))))          (push frame backtrace)))))
383    
384  (defun frame-actual-args (frame)  (defun frame-actual-args (frame)
385    (let ((*break-on-signals* nil))    (let ((*break-on-signals* nil)
386      (mapcar (lambda (arg)          (kind nil))
387                (case arg      (loop for arg in (dbg::call-frame-arglist frame)
388                  ((&rest &optional &key) arg)            if (eq kind '&rest)
389                  (t            nconc (handler-case
390                   (handler-case (dbg::dbg-eval arg frame)                      (dbg::dbg-eval arg frame)
391                     (error (e) (format nil "<~A>" arg))))))                    (error (e) (list (format nil "<~A>" arg))))
392              (dbg::call-frame-arglist frame))))            and do (loop-finish)
393              else
394              if (member arg '(&rest &optional &key))
395              do (setq kind arg)
396              else
397              nconc
398              (handler-case
399                  (nconc (and (eq kind '&key)
400                              (list (cond ((symbolp arg)
401                                           (intern (symbol-name arg) :keyword))
402                                          ((and (consp arg) (symbolp (car arg)))
403                                           (intern (symbol-name (car arg)) :keyword))
404                                          (t (caar arg)))))
405                         (list (dbg::dbg-eval
406                                (cond ((symbolp arg) arg)
407                                      ((and (consp arg) (symbolp (car arg)))
408                                       (car arg))
409                                      (t (cadar arg)))
410                                frame)))
411                (error (e) (list (format nil "<~A>" arg)))))))
412    
413  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
414    (cond ((dbg::call-frame-p frame)    (cond ((dbg::call-frame-p frame)
415           (format stream "~S ~S"           (prin1 (cons (dbg::call-frame-function-name frame)
416                   (dbg::call-frame-function-name frame)                        (frame-actual-args frame))
417                   (frame-actual-args frame)))                  stream))
418          (t (princ frame stream))))          (t (princ frame stream))))
419    
420  (defun frame-vars (frame)  (defun frame-vars (frame)
# Line 363  Return NIL if the symbol is unbound." Line 436  Return NIL if the symbol is unbound."
436        (declare (ignore _n _s _l))        (declare (ignore _n _s _l))
437        value)))        value)))
438    
439  (defimplementation frame-source-location-for-emacs (frame)  (defimplementation frame-source-location (frame)
440    (let ((frame (nth-frame frame))    (let ((frame (nth-frame frame))
441          (callee (if (plusp frame) (nth-frame (1- frame)))))          (callee (if (plusp frame) (nth-frame (1- frame)))))
442      (if (dbg::call-frame-p frame)      (if (dbg::call-frame-p frame)
443          (let ((dspec (dbg::call-frame-function-name frame))          (let ((dspec (dbg::call-frame-function-name frame))
444                (cname (and (dbg::call-frame-p callee)                (cname (and (dbg::call-frame-p callee)
445                            (dbg::call-frame-function-name callee))))                            (dbg::call-frame-function-name callee)))
446                  (path (and (dbg::call-frame-p frame)
447                             (dbg::call-frame-edit-path frame))))
448            (if dspec            (if dspec
449                (frame-location dspec cname))))))                (frame-location dspec cname path))))))
450    
451  (defimplementation eval-in-frame (form frame-number)  (defimplementation eval-in-frame (form frame-number)
452    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
# Line 395  Return NIL if the symbol is unbound." Line 470  Return NIL if the symbol is unbound."
470    
471  ;;; Definition finding  ;;; Definition finding
472    
473  (defun frame-location (dspec callee-name)  (defun frame-location (dspec callee-name edit-path)
474    (let ((infos (dspec:find-dspec-locations dspec)))    (let ((infos (dspec:find-dspec-locations dspec)))
475      (cond (infos      (cond (infos
476             (destructuring-bind ((rdspec location) &rest _) infos             (destructuring-bind ((rdspec location) &rest _) infos
477               (declare (ignore _))               (declare (ignore _))
478               (let ((name (and callee-name (symbolp callee-name)               (let ((name (and callee-name (symbolp callee-name)
479                                (string callee-name))))                                (string callee-name)))
480                 (make-dspec-location rdspec location                     (path (edit-path-to-cmucl-source-path edit-path)))
481                                      `(:call-site ,name)))))                 (make-dspec-location rdspec location
482                                        `(:call-site ,name :edit-path ,path)))))
483            (t            (t
484             (list :error (format nil "Source location not available for: ~S"             (list :error (format nil "Source location not available for: ~S"
485                                  dspec))))))                                  dspec))))))
486    
487    ;; dbg::call-frame-edit-path is not documented but lets assume the
488    ;; binary representation of the integer EDIT-PATH should be
489    ;; interpreted as a sequence of CAR or CDR.  #b1111010 is roughly the
490    ;; same as cadadddr.  Something is odd with the highest bit.
491    (defun edit-path-to-cmucl-source-path (edit-path)
492      (and edit-path
493           (cons 0
494                 (let ((n -1))
495                   (loop for i from (1- (integer-length edit-path)) downto 0
496                         if (logbitp i edit-path) do (incf n)
497                         else collect (prog1 n (setq n 0)))))))
498    
499    ;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
500    
501  (defimplementation find-definitions (name)  (defimplementation find-definitions (name)
502    (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))    (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
503      (loop for (dspec location) in locations      (loop for (dspec location) in locations
# Line 427  Return NIL if the symbol is unbound." Line 517  Return NIL if the symbol is unbound."
517                                         ,location))))))                                         ,location))))))
518    
519  (defimplementation swank-compile-file (input-file output-file  (defimplementation swank-compile-file (input-file output-file
520                                         load-p external-format)                                         load-p external-format
521                                           &key policy)
522      (declare (ignore policy))
523    (with-swank-compilation-unit (input-file)    (with-swank-compilation-unit (input-file)
524      (compile-file input-file      (compile-file input-file
525                    :output-file output-file                    :output-file output-file
# Line 464  Return NIL if the symbol is unbound." Line 556  Return NIL if the symbol is unbound."
556  (defun map-error-database (database fn)  (defun map-error-database (database fn)
557    (loop for (filename . defs) in database do    (loop for (filename . defs) in database do
558          (loop for (dspec . conditions) in defs do          (loop for (dspec . conditions) in defs do
559                (dolist (c conditions)                (dolist (c conditions)
560                  (funcall fn filename dspec (if (consp c) (car c) c))))))                  (multiple-value-bind (condition path)
561                        (if (consp c) (values (car c) (cdr c)) (values c nil))
562                      (funcall fn filename dspec condition path))))))
563    
564  (defun lispworks-severity (condition)  (defun lispworks-severity (condition)
565    (cond ((not condition) :warning)    (cond ((not condition) :warning)
# Line 593  Return NIL if the symbol is unbound." Line 687  Return NIL if the symbol is unbound."
687                        (dspec-function-name-position dspec `(:offset ,offset 0))                        (dspec-function-name-position dspec `(:offset ,offset 0))
688                        hints)))))                        hints)))))
689    
690  (defun make-dspec-progenitor-location (dspec location)  (defun make-dspec-progenitor-location (dspec location edit-path)
691    (let ((canon-dspec (dspec:canonicalize-dspec dspec)))    (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
692      (make-dspec-location      (make-dspec-location
693       (if canon-dspec       (if canon-dspec
694           (if (dspec:local-dspec-p canon-dspec)           (if (dspec:local-dspec-p canon-dspec)
695               (dspec:dspec-progenitor canon-dspec)               (dspec:dspec-progenitor canon-dspec)
696             canon-dspec)               canon-dspec)
697         nil)           nil)
698       location)))       location
699         (if edit-path
700             (list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
701    
702  (defun signal-error-data-base (database &optional location)  (defun signal-error-data-base (database &optional location)
703    (map-error-database    (map-error-database
704     database     database
705     (lambda (filename dspec condition)     (lambda (filename dspec condition edit-path)
706       (signal-compiler-condition       (signal-compiler-condition
707        (format nil "~A" condition)        (format nil "~A" condition)
708        (make-dspec-progenitor-location dspec (or location filename))        (make-dspec-progenitor-location dspec (or location filename) edit-path)
709        condition))))        condition))))
710    
711  (defun unmangle-unfun (symbol)  (defun unmangle-unfun (symbol)
# Line 624  function names like \(SETF GET)." Line 720  function names like \(SETF GET)."
720               (dolist (dspec dspecs)               (dolist (dspec dspecs)
721                 (signal-compiler-condition                 (signal-compiler-condition
722                  (format nil "Undefined function ~A" (unmangle-unfun unfun))                  (format nil "Undefined function ~A" (unmangle-unfun unfun))
723                  (make-dspec-progenitor-location dspec                  (make-dspec-progenitor-location
724                                                  (or filename                   dspec
725                                                      (gethash (list unfun dspec)                   (or filename
726                                                               *undefined-functions-hash*)))                       (gethash (list unfun dspec) *undefined-functions-hash*))
727                     nil)
728                  nil)))                  nil)))
729             htab))             htab))
730    
# Line 658  function names like \(SETF GET)." Line 755  function names like \(SETF GET)."
755  (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
756  (defxref calls-who      hcl:calls-who)  (defxref calls-who      hcl:calls-who)
757  (defxref list-callers   list-callers-internal)  (defxref list-callers   list-callers-internal)
758  ;; (defxref list-callees   list-callees-internal)  (defxref list-callees   list-callees-internal)
759    
760  (defun list-callers-internal (name)  (defun list-callers-internal (name)
761    (let ((callers (make-array 100    (let ((callers (make-array 100
# Line 667  function names like \(SETF GET)." Line 764  function names like \(SETF GET)."
764      (hcl:sweep-all-objects      (hcl:sweep-all-objects
765       #'(lambda (object)       #'(lambda (object)
766           (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)           (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
767                      #-Harlequin-PC-Lisp (sys::callablep object)                      #+Harlequin-Unix-Lisp (sys:callablep object)
768                        #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) (sys:compiled-code-p object)
769                      (system::find-constant$funcallable name object))                      (system::find-constant$funcallable name object))
770             (vector-push-extend object callers))))             (vector-push-extend object callers))))
771      ;; 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 775  function names like \(SETF GET)."
775                        (list 'function object)                        (list 'function object)
776                        (or (dspec:object-dspec object) object)))))                        (or (dspec:object-dspec object) object)))))
777    
778    (defun list-callees-internal (name)
779      (let ((callees '()))
780        (system::find-constant$funcallable
781         'junk name
782         :test #'(lambda (junk constant)
783                   (declare (ignore junk))
784                   (when (and (symbolp constant)
785                              (fboundp constant))
786                     (pushnew (list 'function constant) callees :test 'equal))
787                   ;; Return nil so we iterate over all constants.
788                   nil))
789        callees))
790    
791  ;; only for lispworks 4.2 and above  ;; only for lispworks 4.2 and above
792  #-lispworks4.1  #-lispworks4.1
793  (progn  (progn
# Line 834  function names like \(SETF GET)." Line 945  function names like \(SETF GET)."
945        (setf (mailbox.queue mbox)        (setf (mailbox.queue mbox)
946              (nconc (mailbox.queue mbox) (list message))))))              (nconc (mailbox.queue mbox) (list message))))))
947    
948    (let ((alist '())
949          (lock (mp:make-lock :name "register-thread")))
950    
951      (defimplementation register-thread (name thread)
952        (declare (type symbol name))
953        (mp:with-lock (lock)
954          (etypecase thread
955            (null
956             (setf alist (delete name alist :key #'car)))
957            (mp:process
958             (let ((probe (assoc name alist)))
959               (cond (probe (setf (cdr probe) thread))
960                     (t (setf alist (acons name thread alist))))))))
961        nil)
962    
963      (defimplementation find-registered (name)
964        (mp:with-lock (lock)
965          (cdr (assoc name alist)))))
966    
967    
968  (defimplementation set-default-initial-binding (var form)  (defimplementation set-default-initial-binding (var form)
969    (setq mp:*process-initial-bindings*    (setq mp:*process-initial-bindings*
970          (acons var `(eval (quote ,form))          (acons var `(eval (quote ,form))
971                 mp:*process-initial-bindings* )))                 mp:*process-initial-bindings* )))
972    
973    (defimplementation thread-attributes (thread)
974      (list :priority (mp:process-priority thread)
975            :idle (mp:process-idle-time thread)))
976    
977  ;;; Some intergration with the lispworks environment  ;;; Some intergration with the lispworks environment
978    
979  (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.147

  ViewVC Help
Powered by ViewVC 1.1.5