corman.lisp (19768B)
1 ;;; 2 ;;; slynk-corman.lisp --- Corman Lisp specific code for SLY. 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 SLY 32 ;;; will blow up in your face. You should also follow the 33 ;;; instructions on http://www.grumblesmurf.org/lisp/corman-sly. 34 ;;; 35 ;;; The only communication style currently supported is NIL. 36 ;;; 37 ;;; Starting CCL inside emacs (with M-x sly) 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 ;;; sly-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 :slynk-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 slynk-mop:standard-slot-definition () 80 () 81 (:documentation 82 "Dummy class created so that slynk.lisp will compile and load.")) 83 84 (defun named-by-gensym-p (c) 85 (null (symbol-package (class-name c)))) 86 87 (deftype slynk-mop:eql-specializer () 88 '(satisfies named-by-gensym-p)) 89 90 (defun slynk-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 slynk-mop:class-finalized-p (class) 99 (declare (ignore class)) 100 t) 101 102 (defun slynk-mop:class-prototype (class) 103 (make-instance class)) 104 105 (defun slynk-mop:specializer-direct-methods (obj) 106 (declare (ignore obj)) 107 nil) 108 109 (defun slynk-mop:generic-function-argument-precedence-order (gf) 110 (generic-function-lambda-list gf)) 111 112 (defun slynk-mop:generic-function-method-combination (gf) 113 (declare (ignore gf)) 114 :standard) 115 116 (defun slynk-mop:generic-function-declarations (gf) 117 (declare (ignore gf)) 118 nil) 119 120 (defun slynk-mop:slot-definition-documentation (slot) 121 (declare (ignore slot)) 122 (getf slot :documentation nil)) 123 124 (defun slynk-mop:slot-definition-type (slot) 125 (declare (ignore slot)) 126 t) 127 128 (import-slynk-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 ;;;; slynk 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 slynk-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 slynk-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 slynk.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 (slynk-mop:class-direct-superclasses class)) 408 (:newline) 409 "Direct Slots: " 410 ,@(comma-separated 411 (slynk-mop:class-direct-slots class) 412 (lambda (slot) 413 `(:value ,slot 414 ,(princ-to-string 415 (slynk-mop:slot-definition-name slot))))) 416 (:newline) 417 "Effective Slots: " 418 ,@(if (slynk-mop:class-finalized-p class) 419 (comma-separated 420 (slynk-mop:class-slots class) 421 (lambda (slot) 422 `(:value ,slot ,(princ-to-string 423 (slynk-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 (slynk-mop:class-direct-subclasses class) 430 (lambda (sub) 431 `(:value ,sub ,(princ-to-string (class-name sub))))) 432 (:newline) 433 "Precedence List: " 434 ,@(if (slynk-mop:class-finalized-p class) 435 (comma-separated 436 (slynk-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 ,(slynk-mop:slot-definition-name slot)) 447 (:newline) 448 ,@(when (slynk-mop:slot-definition-documentation slot) 449 `("Documentation:" 450 (:newline) 451 (:value 452 ,(slynk-mop:slot-definition-documentation slot)) 453 (:newline))) 454 "Init args: " (:value 455 ,(slynk-mop:slot-definition-initargs slot)) 456 (:newline) 457 "Init form: " 458 ,(if (slynk-mop:slot-definition-initfunction slot) 459 `(:value ,(slynk-mop:slot-definition-initform slot)) 460 "#<unspecified>") (:newline) 461 "Init function: " 462 (:value ,(slynk-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))))