Find file
Fetching contributors…
Cannot retrieve contributors at this time
583 lines (499 sloc) 19.2 KB
;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
;;; Copyright (C) 2004, 2005 Espen Wiborg (
;;; 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
;;;, otherwise SLIME
;;; will blow up in your face. You should also follow the
;;; instructions on
;;; 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 ()
"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)
(unless more (return nil))
(when (eq specializer value)
(return key))))))
(defun swank-mop:class-finalized-p (class)
(declare (ignore class))
(defun swank-mop:class-prototype (class)
(make-instance class))
(defun swank-mop:specializer-direct-methods (obj)
(declare (ignore obj))
(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))
(defun swank-mop:generic-function-declarations (gf)
(declare (ignore gf))
(defun swank-mop:slot-definition-documentation (slot)
(declare (ignore slot))
(getf slot :documentation nil))
(defun swank-mop:slot-definition-type (slot)
(declare (ignore slot))
(import-swank-mop-symbols :cl '(;; classes
;; standard class readers
;; gf readers
;; method readers
;; slot readers
;;;; 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)))
(let* ((db::*debug-level* (1+ db::*debug-level*))
(db::*debug-frame-pointer* (db::stash-ebp
(db::*debug-max-level* (length real-stack-trace))
(db::*debug-min-level* 1))
(cdr (member #'cl:invoke-debugger
(make-frame :function nil)
(loop for i from db::*debug-min-level*
upto db::*debug-max-level*
until (eq (db::get-frame-function i)
: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))))
;;; Socket communication
(defimplementation create-socket (host port &key backlog)
(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 ()
(defimplementation getpid ()
(defimplementation lisp-implementation-type-name ()
(defimplementation quit-lisp ()
(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
(let ((truename (truename
(merge-pathnames file
(make-location (list :file (namestring truename))
(if (ccl::function-source-line fspec)
(list :line
(1+ (ccl::function-source-line fspec)))
(list :function-name
(function-name fspec))))))
(error (c) (list :error (princ-to-string c))))
(list :error (format nil "No source information available for ~S"
(defimplementation find-definitions (name)
(list (list name (fspec-location name))))
(defimplementation arglist (name)
(cond ((and (symbolp name)
(macro-function name))
(ccl::macro-lambda-list (symbol-function name)))
(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)))))
:variable (when (boundp symbol)
(doc 'variable)))
:function (if (fboundp symbol)
(doc 'function)))
:class (if (find-class symbol nil)
(doc 'class)))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(describe symbol))
((:function :generic-function)
(describe (symbol-function symbol)))
(describe (find-class symbol)))))
;;; Compiler
(defvar *buffer-name* nil)
(defvar *buffer-position*)
(defvar *buffer-string*)
(defvar *compile-filename* nil)
(defimplementation call-with-compilation-hooks (FN)
(handler-bind ((error (lambda (c)
(signal 'compiler-condition
:original-condition c
:severity :warning
:message (format nil "~A" c)
(cond (*buffer-name*
(list :buffer *buffer-name*)
(list :offset *buffer-position* 0)))
(list :file *compile-filename*)
(list :position 1)))
(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
(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))))
;;;; 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))
"Super classes: "
,@(comma-separated (swank-mop:class-direct-superclasses class))
"Direct Slots: "
(swank-mop:class-direct-slots class)
(lambda (slot)
`(:value ,slot
(swank-mop:slot-definition-name slot)))))
"Effective Slots: "
,@(if (swank-mop:class-finalized-p class)
(swank-mop:class-slots class)
(lambda (slot)
`(:value ,slot ,(princ-to-string
(swank-mop:slot-definition-name slot)))))
'("#<N/A (class not finalized)>"))
,@(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)))))
"Precedence List: "
,@(if (swank-mop:class-finalized-p class)
(swank-mop:class-precedence-list class)
(lambda (class)
`(:value ,class
,(princ-to-string (class-name class)))))
'("#<N/A (class not finalized)>"))
(defmethod emacs-inspect ((slot cons))
;; Inspects slot definitions
(if (eq (car slot) :name)
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
,@(when (swank-mop:slot-definition-documentation slot)
,(swank-mop:slot-definition-documentation slot))
"Init args: " (:value
,(swank-mop:slot-definition-initargs slot))
"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))
(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
(list* (if (wild-pathname-p pathname)
"A wild pathname."
"A pathname.")
(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)))))
(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.))
(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)
(defimplementation spawn (fun &key name)
(declare (ignore name))
(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)
(defimplementation find-thread (thread)
(if (thread-alive-p thread)
(defimplementation thread-alive-p (thread)
(if (threads:thread-handle thread) t nil))
(defimplementation current-thread ()
;; 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*)
(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*)))
(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)
(defmethod print-object ((restart restart) stream)
(if (or *print-escape*
(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))))