Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

569 lines (485 sloc) 20.517 kb
;;;
;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
;;;
;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
;;;
;;; License
;;; =======
;;; This software is provided 'as-is', without any express or implied
;;; warranty. In no event will the author be held liable for any damages
;;; arising from the use of this software.
;;;
;;; Permission is granted to anyone to use this software for any purpose,
;;; including commercial applications, and to alter it and redistribute
;;; it freely, subject to the following restrictions:
;;;
;;; 1. The origin of this software must not be misrepresented; you must
;;; not claim that you wrote the original software. If you use this
;;; software in a product, an acknowledgment in the product documentation
;;; would be appreciated but is not required.
;;;
;;; 2. Altered source versions must be plainly marked as such, and must
;;; not be misrepresented as being the original software.
;;;
;;; 3. This notice may not be removed or altered from any source
;;; distribution.
;;;
;;; Notes
;;; =====
;;; You will need CCL 2.51, and you will *definitely* need to patch
;;; CCL with the patches at
;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
;;; will blow up in your face. You should also follow the
;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
;;;
;;; The only communication style currently supported is NIL.
;;;
;;; Starting CCL inside emacs (with M-x slime) seems to work for me
;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
;;; (sometimes it works, other times it hangs on start or hangs when
;;; initializing WinSock) - starting CCL externally and using M-x
;;; slime-connect always works fine.
;;;
;;; Sometimes CCL gets confused and starts giving you random memory
;;; access violation errors on startup; if this happens, try redumping
;;; your image.
;;;
;;; What works
;;; ==========
;;; * Basic editing and evaluation
;;; * Arglist display
;;; * Compilation
;;; * Loading files
;;; * apropos/describe
;;; * Debugger
;;; * Inspector
;;;
;;; TODO
;;; ====
;;; * More debugger functionality (missing bits: restart-frame,
;;; return-from-frame, disassemble-frame, activate-stepping,
;;; toggle-trace)
;;; * XREF
;;; * Profiling
;;; * More sophisticated communication styles than NIL
;;;
(in-package :swank-backend)
;;; Pull in various needed bits
(require :composite-streams)
(require :sockets)
(require :winbase)
(require :lp)
(use-package :gs)
;; MOP stuff
(defclass swank-mop:standard-slot-definition ()
()
(:documentation "Dummy class created so that swank.lisp will compile and load."))
(defun named-by-gensym-p (c)
(null (symbol-package (class-name c))))
(deftype swank-mop:eql-specializer ()
'(satisfies named-by-gensym-p))
(defun swank-mop:eql-specializer-object (specializer)
(with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
(loop (multiple-value-bind (more key value)
(next-entry)
(unless more (return nil))
(when (eq specializer value)
(return key))))))
(defun swank-mop:class-finalized-p (class)
(declare (ignore class))
t)
(defun swank-mop:class-prototype (class)
(make-instance class))
(defun swank-mop:specializer-direct-methods (obj)
(declare (ignore obj))
nil)
(defun swank-mop:generic-function-argument-precedence-order (gf)
(generic-function-lambda-list gf))
(defun swank-mop:generic-function-method-combination (gf)
(declare (ignore gf))
:standard)
(defun swank-mop:generic-function-declarations (gf)
(declare (ignore gf))
nil)
(defun swank-mop:slot-definition-documentation (slot)
(declare (ignore slot))
(getf slot :documentation nil))
(defun swank-mop:slot-definition-type (slot)
(declare (ignore slot))
t)
(import-swank-mop-symbols :cl '(;; classes
:standard-slot-definition
:eql-specializer
:eql-specializer-object
;; standard class readers
:class-default-initargs
:class-direct-default-initargs
:class-finalized-p
:class-prototype
:specializer-direct-methods
;; gf readers
:generic-function-argument-precedence-order
:generic-function-declarations
:generic-function-method-combination
;; method readers
;; slot readers
:slot-definition-documentation
:slot-definition-type))
;;;; swank implementations
;;; Debugger
(defvar *stack-trace* nil)
(defvar *frame-trace* nil)
(defstruct frame
name function address debug-info variables)
(defimplementation call-with-debugging-environment (fn)
(let* ((real-stack-trace (cl::stack-trace))
(*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
:key #'car)))
(*frame-trace*
(let* ((db::*debug-level* (1+ db::*debug-level*))
(db::*debug-frame-pointer* (db::stash-ebp
(ct:create-foreign-ptr)))
(db::*debug-max-level* (length real-stack-trace))
(db::*debug-min-level* 1))
(cdr (member #'cl:invoke-debugger
(cons
(make-frame :function nil)
(loop for i from db::*debug-min-level*
upto db::*debug-max-level*
until (eq (db::get-frame-function i) cl::*top-level*)
collect
(make-frame :function (db::get-frame-function i)
:address (db::get-frame-address i))))
:key #'frame-function)))))
(funcall fn)))
(defimplementation compute-backtrace (start end)
(loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
collect f))
(defimplementation print-frame (frame stream)
(format stream "~S" frame))
(defun get-frame-debug-info (frame)
(or (frame-debug-info frame)
(setf (frame-debug-info frame)
(db::prepare-frame-debug-info (frame-function frame)
(frame-address frame)))))
(defimplementation frame-locals (frame-number)
(let* ((frame (elt *frame-trace* frame-number))
(info (get-frame-debug-info frame)))
(let ((var-list
(loop for i from 4 below (length info) by 2
collect `(list :name ',(svref info i) :id 0
:value (db::debug-filter ,(svref info i))))))
(let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
(setf (frame-variables frame) vars)))))
(defimplementation eval-in-frame (form frame-number)
(let ((frame (elt *frame-trace* frame-number)))
(let ((cl::*compiler-environment* (get-frame-debug-info frame)))
(eval form))))
(defimplementation frame-var-value (frame-number var)
(let ((vars (frame-variables (elt *frame-trace* frame-number))))
(when vars
(second (elt vars var)))))
(defimplementation frame-source-location (frame-number)
(fspec-location (frame-function (elt *frame-trace* frame-number))))
(defun break (&optional (format-control "Break") &rest format-arguments)
(with-simple-restart (continue "Return from BREAK.")
(let ();(*debugger-hook* nil))
(let ((condition
(make-condition 'simple-condition
:format-control format-control
:format-arguments format-arguments)))
;;(format *debug-io* ";;; User break: ~A~%" condition)
(invoke-debugger condition))))
nil)
;;; Socket communication
(defimplementation create-socket (host port)
(sockets:start-sockets)
(sockets:make-server-socket :host host :port port))
(defimplementation local-port (socket)
(sockets:socket-port socket))
(defimplementation close-socket (socket)
(close socket))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering timeout external-format))
(sockets:make-socket-stream (sockets:accept-socket socket)))
;;; Misc
(defimplementation preferred-communication-style ()
nil)
(defimplementation getpid ()
ccl:*current-process-id*)
(defimplementation lisp-implementation-type-name ()
"cormanlisp")
(defimplementation quit-lisp ()
(sockets:stop-sockets)
(win32:exitprocess 0))
(defimplementation set-default-directory (directory)
(setf (ccl:current-directory) directory)
(directory-namestring (setf *default-pathname-defaults*
(truename (merge-pathnames directory)))))
(defimplementation default-directory ()
(directory-namestring (ccl:current-directory)))
(defimplementation macroexpand-all (form)
(ccl:macroexpand-all form))
;;; Documentation
(defun fspec-location (fspec)
(when (symbolp fspec)
(setq fspec (symbol-function fspec)))
(let ((file (ccl::function-source-file fspec)))
(if file
(handler-case
(let ((truename (truename
(merge-pathnames file
ccl:*cormanlisp-directory*))))
(make-location (list :file (namestring truename))
(if (ccl::function-source-line fspec)
(list :line
(1+ (ccl::function-source-line fspec)))
(list :function-name (princ-to-string
(function-name fspec))))))
(error (c) (list :error (princ-to-string c))))
(list :error (format nil "No source information available for ~S"
fspec)))))
(defimplementation find-definitions (name)
(list (list name (fspec-location name))))
(defimplementation arglist (name)
(handler-case
(cond ((and (symbolp name)
(macro-function name))
(ccl::macro-lambda-list (symbol-function name)))
(t
(when (symbolp name)
(setq name (symbol-function name)))
(if (eq (class-of name) cl::the-class-standard-gf)
(generic-function-lambda-list name)
(ccl:function-lambda-list name))))
(error () :not-available)))
(defimplementation function-name (fn)
(handler-case (getf (cl::function-info-list fn) 'cl::function-name)
(error () nil)))
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind &optional (sym symbol))
(or (documentation sym kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (when (boundp symbol)
(doc 'variable)))
(maybe-push
:function (if (fboundp symbol)
(doc 'function)))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
result)))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(:variable
(describe symbol))
((:function :generic-function)
(describe (symbol-function symbol)))
(:class
(describe (find-class symbol)))))
;;; Compiler
(defvar *buffer-name* nil)
(defvar *buffer-position*)
(defvar *buffer-string*)
(defvar *compile-filename* nil)
;; FIXME
(defimplementation call-with-compilation-hooks (FN)
(handler-bind ((error (lambda (c)
(signal (make-condition
'compiler-condition
:original-condition c
:severity :warning
:message (format nil "~A" c)
:location
(cond (*buffer-name*
(make-location
(list :buffer *buffer-name*)
(list :offset *buffer-position* 0)))
(*compile-filename*
(make-location
(list :file *compile-filename*)
(list :position 1)))
(t
(list :error "No location"))))))))
(funcall fn)))
(defimplementation swank-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore external-format policy))
(with-compilation-hooks ()
(let ((*buffer-name* nil)
(*compile-filename* input-file))
(multiple-value-bind (output-file warnings? failure?)
(compile-file input-file :output-file output-file)
(values output-file warnings?
(or failure? (and load-p (load output-file))))))))
(defimplementation swank-compile-string (string &key buffer position filename
policy)
(declare (ignore filename policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-position* position)
(*buffer-string* string))
(funcall (compile nil (read-from-string
(format nil "(~S () ~A)" 'lambda string))))
t)))
;;;; Inspecting
;; Hack to make swank.lisp load, at least
(defclass file-stream ())
(defun comma-separated (list &optional (callback (lambda (v)
`(:value ,v))))
(butlast (loop for e in list
collect (funcall callback e)
collect ", ")))
(defmethod emacs-inspect ((class standard-class))
`("Name: " (:value ,(class-name class))
(:newline)
"Super classes: "
,@(comma-separated (swank-mop:class-direct-superclasses class))
(:newline)
"Direct Slots: "
,@(comma-separated
(swank-mop:class-direct-slots class)
(lambda (slot)
`(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot)))))
(:newline)
"Effective Slots: "
,@(if (swank-mop:class-finalized-p class)
(comma-separated
(swank-mop:class-slots class)
(lambda (slot)
`(:value ,slot ,(princ-to-string
(swank-mop:slot-definition-name slot)))))
'("#<N/A (class not finalized)>"))
(:newline)
,@(when (documentation class t)
`("Documentation:" (:newline) ,(documentation class t) (:newline)))
"Sub classes: "
,@(comma-separated (swank-mop:class-direct-subclasses class)
(lambda (sub)
`(:value ,sub ,(princ-to-string (class-name sub)))))
(:newline)
"Precedence List: "
,@(if (swank-mop:class-finalized-p class)
(comma-separated (swank-mop:class-precedence-list class)
(lambda (class)
`(:value ,class ,(princ-to-string (class-name class)))))
'("#<N/A (class not finalized)>"))
(:newline)))
(defmethod emacs-inspect ((slot cons))
;; Inspects slot definitions
(if (eq (car slot) :name)
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
(:newline)
,@(when (swank-mop:slot-definition-documentation slot)
`("Documentation:" (:newline)
(:value ,(swank-mop:slot-definition-documentation slot))
(:newline)))
"Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
"Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
`(:value ,(swank-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
"Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
(:newline))
(call-next-method)))
(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
(list* (if (wild-pathname-p pathname)
"A wild pathname."
"A pathname.")
'(:newline)
(append (label-value-line*
("Namestring" (namestring pathname))
("Host" (pathname-host pathname))
("Device" (pathname-device pathname))
("Directory" (pathname-directory pathname))
("Name" (pathname-name pathname))
("Type" (pathname-type pathname))
("Version" (pathname-version pathname)))
(unless (or (wild-pathname-p pathname)
(not (probe-file pathname)))
(label-value-line "Truename" (truename pathname))))))
(defmethod emacs-inspect ((o t))
(cond ((cl::structurep o) (inspect-structure o))
(t (call-next-method))))
(defun inspect-structure (o)
(let* ((template (cl::uref o 1))
(num-slots (cl::struct-template-num-slots template)))
(cond ((symbolp template)
(loop for i below num-slots
append (label-value-line i (cl::uref o (+ 2 i)))))
(t
(loop for i below num-slots
append (label-value-line (elt template (+ 6 (* i 5)))
(cl::uref o (+ 2 i))))))))
;;; Threads
(require 'threads)
(defstruct (mailbox (:conc-name mailbox.))
thread
(lock (make-instance 'threads:critical-section))
(queue '() :type list))
(defvar *mailbox-lock* (make-instance 'threads:critical-section))
(defvar *mailboxes* (list))
(defmacro with-lock (lock &body body)
`(threads:with-synchronization (threads:cs ,lock)
,@body))
(defimplementation spawn (fun &key name)
(declare (ignore name))
(th:create-thread
(lambda ()
(handler-bind ((serious-condition #'invoke-debugger))
(unwind-protect (funcall fun)
(with-lock *mailbox-lock*
(setq *mailboxes* (remove cormanlisp:*current-thread-id*
*mailboxes* :key #'mailbox.thread))))))))
(defimplementation thread-id (thread)
thread)
(defimplementation find-thread (thread)
(if (thread-alive-p thread)
thread))
(defimplementation thread-alive-p (thread)
(if (threads:thread-handle thread) t nil))
(defimplementation current-thread ()
cormanlisp:*current-thread-id*)
;; XXX implement it
(defimplementation all-threads ()
'())
;; XXX something here is broken
(defimplementation kill-thread (thread)
(threads:terminate-thread thread 'killed))
(defun mailbox (thread)
(with-lock *mailbox-lock*
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
(with-lock (mailbox.lock mbox)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message))))))
(defimplementation receive ()
(let ((mbox (mailbox cormanlisp:*current-thread-id*)))
(loop
(with-lock (mailbox.lock mbox)
(when (mailbox.queue mbox)
(return (pop (mailbox.queue mbox)))))
(sleep 0.1))))
;;; This is probably not good, but it WFM
(in-package :common-lisp)
(defvar *old-documentation* #'documentation)
(defun documentation (thing &optional (type 'function))
(if (symbolp thing)
(funcall *old-documentation* thing type)
(values)))
(defmethod print-object ((restart restart) stream)
(if (or *print-escape*
*print-readably*)
(print-unreadable-object (restart stream :type t :identity t)
(princ (restart-name restart) stream))
(when (functionp (restart-report-function restart))
(funcall (restart-report-function restart) stream))))
Jump to Line
Something went wrong with that request. Please try again.