/[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.146 by heller, Sun Nov 27 21:47:15 2011 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 839  function names like \(SETF GET)." Line 950  function names like \(SETF GET)."
950          (acons var `(eval (quote ,form))          (acons var `(eval (quote ,form))
951                 mp:*process-initial-bindings* )))                 mp:*process-initial-bindings* )))
952    
953    (defimplementation thread-attributes (thread)
954      (list :priority (mp:process-priority thread)
955            :idle (mp:process-idle-time thread)))
956    
957  ;;; Some intergration with the lispworks environment  ;;; Some intergration with the lispworks environment
958    
959  (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.146

  ViewVC Help
Powered by ViewVC 1.1.5