1;;; 2;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. 3;;; 4;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org) 5;;; 6;;; License 7;;; ======= 8;;; This software is provided 'as-is', without any express or implied 9;;; warranty. In no event will the author be held liable for any damages 10;;; arising from the use of this software. 11;;; 12;;; Permission is granted to anyone to use this software for any purpose, 13;;; including commercial applications, and to alter it and redistribute 14;;; it freely, subject to the following restrictions: 15;;; 16;;; 1. The origin of this software must not be misrepresented; you must 17;;; not claim that you wrote the original software. If you use this 18;;; software in a product, an acknowledgment in the product documentation 19;;; would be appreciated but is not required. 20;;; 21;;; 2. Altered source versions must be plainly marked as such, and must 22;;; not be misrepresented as being the original software. 23;;; 24;;; 3. This notice may not be removed or altered from any source 25;;; distribution. 26;;; 27;;; Notes 28;;; ===== 29;;; You will need CCL 2.51, and you will *definitely* need to patch 30;;; CCL with the patches at 31;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME 32;;; will blow up in your face. You should also follow the 33;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. 34;;; 35;;; The only communication style currently supported is NIL. 36;;; 37;;; Starting CCL inside emacs (with M-x slime) seems to work for me 38;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 39;;; (sometimes it works, other times it hangs on start or hangs when 40;;; initializing WinSock) - starting CCL externally and using M-x 41;;; slime-connect always works fine. 42;;; 43;;; Sometimes CCL gets confused and starts giving you random memory 44;;; access violation errors on startup; if this happens, try redumping 45;;; your image. 46;;; 47;;; What works 48;;; ========== 49;;; * Basic editing and evaluation 50;;; * Arglist display 51;;; * Compilation 52;;; * Loading files 53;;; * apropos/describe 54;;; * Debugger 55;;; * Inspector 56;;; 57;;; TODO 58;;; ==== 59;;; * More debugger functionality (missing bits: restart-frame, 60;;; return-from-frame, disassemble-frame, activate-stepping, 61;;; toggle-trace) 62;;; * XREF 63;;; * Profiling 64;;; * More sophisticated communication styles than NIL 65;;; 66 67(in-package :swank/backend) 68 69;;; Pull in various needed bits 70(require :composite-streams) 71(require :sockets) 72(require :winbase) 73(require :lp) 74 75(use-package :gs) 76 77;; MOP stuff 78 79(defclass swank-mop:standard-slot-definition () 80 () 81 (:documentation 82 "Dummy class created so that swank.lisp will compile and load.")) 83 84(defun named-by-gensym-p (c) 85 (null (symbol-package (class-name c)))) 86 87(deftype swank-mop:eql-specializer () 88 '(satisfies named-by-gensym-p)) 89 90(defun swank-mop:eql-specializer-object (specializer) 91 (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) 92 (loop (multiple-value-bind (more key value) 93 (next-entry) 94 (unless more (return nil)) 95 (when (eq specializer value) 96 (return key)))))) 97 98(defun swank-mop:class-finalized-p (class) 99 (declare (ignore class)) 100 t) 101 102(defun swank-mop:class-prototype (class) 103 (make-instance class)) 104 105(defun swank-mop:specializer-direct-methods (obj) 106 (declare (ignore obj)) 107 nil) 108 109(defun swank-mop:generic-function-argument-precedence-order (gf) 110 (generic-function-lambda-list gf)) 111 112(defun swank-mop:generic-function-method-combination (gf) 113 (declare (ignore gf)) 114 :standard) 115 116(defun swank-mop:generic-function-declarations (gf) 117 (declare (ignore gf)) 118 nil) 119 120(defun swank-mop:slot-definition-documentation (slot) 121 (declare (ignore slot)) 122 (getf slot :documentation nil)) 123 124(defun swank-mop:slot-definition-type (slot) 125 (declare (ignore slot)) 126 t) 127 128(import-swank-mop-symbols :cl '(;; classes 129 :standard-slot-definition 130 :eql-specializer 131 :eql-specializer-object 132 ;; standard class readers 133 :class-default-initargs 134 :class-direct-default-initargs 135 :class-finalized-p 136 :class-prototype 137 :specializer-direct-methods 138 ;; gf readers 139 :generic-function-argument-precedence-order 140 :generic-function-declarations 141 :generic-function-method-combination 142 ;; method readers 143 ;; slot readers 144 :slot-definition-documentation 145 :slot-definition-type)) 146 147;;;; swank implementations 148 149;;; Debugger 150 151(defvar *stack-trace* nil) 152(defvar *frame-trace* nil) 153 154(defstruct frame 155 name function address debug-info variables) 156 157(defimplementation call-with-debugging-environment (fn) 158 (let* ((real-stack-trace (cl::stack-trace)) 159 (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace 160 :key #'car))) 161 (*frame-trace* 162 (let* ((db::*debug-level* (1+ db::*debug-level*)) 163 (db::*debug-frame-pointer* (db::stash-ebp 164 (ct:create-foreign-ptr))) 165 (db::*debug-max-level* (length real-stack-trace)) 166 (db::*debug-min-level* 1)) 167 (cdr (member #'cl:invoke-debugger 168 (cons 169 (make-frame :function nil) 170 (loop for i from db::*debug-min-level* 171 upto db::*debug-max-level* 172 until (eq (db::get-frame-function i) 173 cl::*top-level*) 174 collect 175 (make-frame 176 :function (db::get-frame-function i) 177 :address (db::get-frame-address i)))) 178 :key #'frame-function))))) 179 (funcall fn))) 180 181(defimplementation compute-backtrace (start end) 182 (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*))) 183 collect f)) 184 185(defimplementation print-frame (frame stream) 186 (format stream "~S" frame)) 187 188(defun get-frame-debug-info (frame) 189 (or (frame-debug-info frame) 190 (setf (frame-debug-info frame) 191 (db::prepare-frame-debug-info (frame-function frame) 192 (frame-address frame))))) 193 194(defimplementation frame-locals (frame-number) 195 (let* ((frame (elt *frame-trace* frame-number)) 196 (info (get-frame-debug-info frame))) 197 (let ((var-list 198 (loop for i from 4 below (length info) by 2 199 collect `(list :name ',(svref info i) :id 0 200 :value (db::debug-filter ,(svref info i)))))) 201 (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) 202 (setf (frame-variables frame) vars))))) 203 204(defimplementation eval-in-frame (form frame-number) 205 (let ((frame (elt *frame-trace* frame-number))) 206 (let ((cl::*compiler-environment* (get-frame-debug-info frame))) 207 (eval form)))) 208 209(defimplementation frame-var-value (frame-number var) 210 (let ((vars (frame-variables (elt *frame-trace* frame-number)))) 211 (when vars 212 (second (elt vars var))))) 213 214(defimplementation frame-source-location (frame-number) 215 (fspec-location (frame-function (elt *frame-trace* frame-number)))) 216 217(defun break (&optional (format-control "Break") &rest format-arguments) 218 (with-simple-restart (continue "Return from BREAK.") 219 (let ();(*debugger-hook* nil)) 220 (let ((condition 221 (make-condition 'simple-condition 222 :format-control format-control 223 :format-arguments format-arguments))) 224 ;;(format *debug-io* ";;; User break: ~A~%" condition) 225 (invoke-debugger condition)))) 226 nil) 227 228;;; Socket communication 229 230(defimplementation create-socket (host port &key backlog) 231 (sockets:start-sockets) 232 (sockets:make-server-socket :host host :port port)) 233 234(defimplementation local-port (socket) 235 (sockets:socket-port socket)) 236 237(defimplementation close-socket (socket) 238 (close socket)) 239 240(defimplementation accept-connection (socket 241 &key external-format buffering timeout) 242 (declare (ignore buffering timeout external-format)) 243 (sockets:make-socket-stream (sockets:accept-socket socket))) 244 245;;; Misc 246 247(defimplementation preferred-communication-style () 248 nil) 249 250(defimplementation getpid () 251 ccl:*current-process-id*) 252 253(defimplementation lisp-implementation-type-name () 254 "cormanlisp") 255 256(defimplementation quit-lisp () 257 (sockets:stop-sockets) 258 (win32:exitprocess 0)) 259 260(defimplementation set-default-directory (directory) 261 (setf (ccl:current-directory) directory) 262 (directory-namestring (setf *default-pathname-defaults* 263 (truename (merge-pathnames directory))))) 264 265(defimplementation default-directory () 266 (directory-namestring (ccl:current-directory))) 267 268(defimplementation macroexpand-all (form &optional env) 269 (declare (ignore env)) 270 (ccl:macroexpand-all form)) 271 272;;; Documentation 273 274(defun fspec-location (fspec) 275 (when (symbolp fspec) 276 (setq fspec (symbol-function fspec))) 277 (let ((file (ccl::function-source-file fspec))) 278 (if file 279 (handler-case 280 (let ((truename (truename 281 (merge-pathnames file 282 ccl:*cormanlisp-directory*)))) 283 (make-location (list :file (namestring truename)) 284 (if (ccl::function-source-line fspec) 285 (list :line 286 (1+ (ccl::function-source-line fspec))) 287 (list :function-name 288 (princ-to-string 289 (function-name fspec)))))) 290 (error (c) (list :error (princ-to-string c)))) 291 (list :error (format nil "No source information available for ~S" 292 fspec))))) 293 294(defimplementation find-definitions (name) 295 (list (list name (fspec-location name)))) 296 297(defimplementation arglist (name) 298 (handler-case 299 (cond ((and (symbolp name) 300 (macro-function name)) 301 (ccl::macro-lambda-list (symbol-function name))) 302 (t 303 (when (symbolp name) 304 (setq name (symbol-function name))) 305 (if (eq (class-of name) cl::the-class-standard-gf) 306 (generic-function-lambda-list name) 307 (ccl:function-lambda-list name)))) 308 (error () :not-available))) 309 310(defimplementation function-name (fn) 311 (handler-case (getf (cl::function-info-list fn) 'cl::function-name) 312 (error () nil))) 313 314(defimplementation describe-symbol-for-emacs (symbol) 315 (let ((result '())) 316 (flet ((doc (kind &optional (sym symbol)) 317 (or (documentation sym kind) :not-documented)) 318 (maybe-push (property value) 319 (when value 320 (setf result (list* property value result))))) 321 (maybe-push 322 :variable (when (boundp symbol) 323 (doc 'variable))) 324 (maybe-push 325 :function (if (fboundp symbol) 326 (doc 'function))) 327 (maybe-push 328 :class (if (find-class symbol nil) 329 (doc 'class))) 330 result))) 331 332(defimplementation describe-definition (symbol namespace) 333 (ecase namespace 334 (:variable 335 (describe symbol)) 336 ((:function :generic-function) 337 (describe (symbol-function symbol))) 338 (:class 339 (describe (find-class symbol))))) 340 341;;; Compiler 342 343(defvar *buffer-name* nil) 344(defvar *buffer-position*) 345(defvar *buffer-string*) 346(defvar *compile-filename* nil) 347 348;; FIXME 349(defimplementation call-with-compilation-hooks (FN) 350 (handler-bind ((error (lambda (c) 351 (signal 'compiler-condition 352 :original-condition c 353 :severity :warning 354 :message (format nil "~A" c) 355 :location 356 (cond (*buffer-name* 357 (make-location 358 (list :buffer *buffer-name*) 359 (list :offset *buffer-position* 0))) 360 (*compile-filename* 361 (make-location 362 (list :file *compile-filename*) 363 (list :position 1))) 364 (t 365 (list :error "No location"))))))) 366 (funcall fn))) 367 368(defimplementation swank-compile-file (input-file output-file 369 load-p external-format 370 &key policy) 371 (declare (ignore external-format policy)) 372 (with-compilation-hooks () 373 (let ((*buffer-name* nil) 374 (*compile-filename* input-file)) 375 (multiple-value-bind (output-file warnings? failure?) 376 (compile-file input-file :output-file output-file) 377 (values output-file warnings? 378 (or failure? (and load-p (load output-file)))))))) 379 380(defimplementation swank-compile-string (string &key buffer position filename 381 line column policy) 382 (declare (ignore filename line column policy)) 383 (with-compilation-hooks () 384 (let ((*buffer-name* buffer) 385 (*buffer-position* position) 386 (*buffer-string* string)) 387 (funcall (compile nil (read-from-string 388 (format nil "(~S () ~A)" 'lambda string)))) 389 t))) 390 391;;;; Inspecting 392 393;; Hack to make swank.lisp load, at least 394(defclass file-stream ()) 395 396(defun comma-separated (list &optional (callback (lambda (v) 397 `(:value ,v)))) 398 (butlast (loop for e in list 399 collect (funcall callback e) 400 collect ", "))) 401 402(defmethod emacs-inspect ((class standard-class)) 403 `("Name: " 404 (:value ,(class-name class)) 405 (:newline) 406 "Super classes: " 407 ,@(comma-separated (swank-mop:class-direct-superclasses class)) 408 (:newline) 409 "Direct Slots: " 410 ,@(comma-separated 411 (swank-mop:class-direct-slots class) 412 (lambda (slot) 413 `(:value ,slot 414 ,(princ-to-string 415 (swank-mop:slot-definition-name slot))))) 416 (:newline) 417 "Effective Slots: " 418 ,@(if (swank-mop:class-finalized-p class) 419 (comma-separated 420 (swank-mop:class-slots class) 421 (lambda (slot) 422 `(:value ,slot ,(princ-to-string 423 (swank-mop:slot-definition-name slot))))) 424 '("#<N/A (class not finalized)>")) 425 (:newline) 426 ,@(when (documentation class t) 427 `("Documentation:" (:newline) ,(documentation class t) (:newline))) 428 "Sub classes: " 429 ,@(comma-separated (swank-mop:class-direct-subclasses class) 430 (lambda (sub) 431 `(:value ,sub ,(princ-to-string (class-name sub))))) 432 (:newline) 433 "Precedence List: " 434 ,@(if (swank-mop:class-finalized-p class) 435 (comma-separated 436 (swank-mop:class-precedence-list class) 437 (lambda (class) 438 `(:value ,class 439 ,(princ-to-string (class-name class))))) 440 '("#<N/A (class not finalized)>")) 441 (:newline))) 442 443(defmethod emacs-inspect ((slot cons)) 444 ;; Inspects slot definitions 445 (if (eq (car slot) :name) 446 `("Name: " (:value ,(swank-mop:slot-definition-name slot)) 447 (:newline) 448 ,@(when (swank-mop:slot-definition-documentation slot) 449 `("Documentation:" 450 (:newline) 451 (:value 452 ,(swank-mop:slot-definition-documentation slot)) 453 (:newline))) 454 "Init args: " (:value 455 ,(swank-mop:slot-definition-initargs slot)) 456 (:newline) 457 "Init form: " 458 ,(if (swank-mop:slot-definition-initfunction slot) 459 `(:value ,(swank-mop:slot-definition-initform slot)) 460 "#<unspecified>") (:newline) 461 "Init function: " 462 (:value ,(swank-mop:slot-definition-initfunction slot)) 463 (:newline)) 464 (call-next-method))) 465 466(defmethod emacs-inspect ((pathname pathnames::pathname-internal)) 467 (list* (if (wild-pathname-p pathname) 468 "A wild pathname." 469 "A pathname.") 470 '(:newline) 471 (append (label-value-line* 472 ("Namestring" (namestring pathname)) 473 ("Host" (pathname-host pathname)) 474 ("Device" (pathname-device pathname)) 475 ("Directory" (pathname-directory pathname)) 476 ("Name" (pathname-name pathname)) 477 ("Type" (pathname-type pathname)) 478 ("Version" (pathname-version pathname))) 479 (unless (or (wild-pathname-p pathname) 480 (not (probe-file pathname))) 481 (label-value-line "Truename" (truename pathname)))))) 482 483(defmethod emacs-inspect ((o t)) 484 (cond ((cl::structurep o) (inspect-structure o)) 485 (t (call-next-method)))) 486 487(defun inspect-structure (o) 488 (let* ((template (cl::uref o 1)) 489 (num-slots (cl::struct-template-num-slots template))) 490 (cond ((symbolp template) 491 (loop for i below num-slots 492 append (label-value-line i (cl::uref o (+ 2 i))))) 493 (t 494 (loop for i below num-slots 495 append (label-value-line (elt template (+ 6 (* i 5))) 496 (cl::uref o (+ 2 i)))))))) 497 498 499;;; Threads 500 501(require 'threads) 502 503(defstruct (mailbox (:conc-name mailbox.)) 504 thread 505 (lock (make-instance 'threads:critical-section)) 506 (queue '() :type list)) 507 508(defvar *mailbox-lock* (make-instance 'threads:critical-section)) 509(defvar *mailboxes* (list)) 510 511(defmacro with-lock (lock &body body) 512 `(threads:with-synchronization (threads:cs ,lock) 513 ,@body)) 514 515(defimplementation spawn (fun &key name) 516 (declare (ignore name)) 517 (th:create-thread 518 (lambda () 519 (handler-bind ((serious-condition #'invoke-debugger)) 520 (unwind-protect (funcall fun) 521 (with-lock *mailbox-lock* 522 (setq *mailboxes* (remove cormanlisp:*current-thread-id* 523 *mailboxes* :key #'mailbox.thread)))))))) 524 525(defimplementation thread-id (thread) 526 thread) 527 528(defimplementation find-thread (thread) 529 (if (thread-alive-p thread) 530 thread)) 531 532(defimplementation thread-alive-p (thread) 533 (if (threads:thread-handle thread) t nil)) 534 535(defimplementation current-thread () 536 cormanlisp:*current-thread-id*) 537 538;; XXX implement it 539(defimplementation all-threads () 540 '()) 541 542;; XXX something here is broken 543(defimplementation kill-thread (thread) 544 (threads:terminate-thread thread 'killed)) 545 546(defun mailbox (thread) 547 (with-lock *mailbox-lock* 548 (or (find thread *mailboxes* :key #'mailbox.thread) 549 (let ((mb (make-mailbox :thread thread))) 550 (push mb *mailboxes*) 551 mb)))) 552 553(defimplementation send (thread message) 554 (let ((mbox (mailbox thread))) 555 (with-lock (mailbox.lock mbox) 556 (setf (mailbox.queue mbox) 557 (nconc (mailbox.queue mbox) (list message)))))) 558 559(defimplementation receive () 560 (let ((mbox (mailbox cormanlisp:*current-thread-id*))) 561 (loop 562 (with-lock (mailbox.lock mbox) 563 (when (mailbox.queue mbox) 564 (return (pop (mailbox.queue mbox))))) 565 (sleep 0.1)))) 566 567 568;;; This is probably not good, but it WFM 569(in-package :common-lisp) 570 571(defvar *old-documentation* #'documentation) 572(defun documentation (thing &optional (type 'function)) 573 (if (symbolp thing) 574 (funcall *old-documentation* thing type) 575 (values))) 576 577(defmethod print-object ((restart restart) stream) 578 (if (or *print-escape* 579 *print-readably*) 580 (print-unreadable-object (restart stream :type t :identity t) 581 (princ (restart-name restart) stream)) 582 (when (functionp (restart-report-function restart)) 583 (funcall (restart-report-function restart) stream)))) 584