├── README ├── abcl.lisp ├── allegro.lisp ├── clisp.lisp ├── cmucl.lisp ├── conium.asd ├── conium.lisp ├── corman.lisp ├── ecl.lisp ├── lispworks.lisp ├── metering.lisp ├── openmcl.lisp ├── package.lisp ├── sbcl.lisp ├── scl.lisp ├── source-file-cache.lisp ├── source-path-parser.lisp └── xref.lisp /README: -------------------------------------------------------------------------------- 1 | INTRODUCTION 2 | ============ 3 | 4 | Conium is a portability library for debugger- and compiler-related 5 | tasks in Common Lisp. 6 | 7 | It is fork of SWANK-BACKEND and differs from swank in the following 8 | regards: 9 | 10 | - The swank frontend has been removed, leaving a Lisp library rather 11 | than a socket server. 12 | 13 | - Conium always uses ASDF instead of a manual load script. 14 | 15 | - Code related to threads has been removed. (Use bordeaux-threads instead.) 16 | 17 | - Code related to the MOP has been removed. (Use closer-mop instead.) 18 | 19 | - Code related to gray streams has been removed. (Use 20 | trivial-gray-streams instead.) 21 | 22 | - Code related sockets has been removed. (Use usocket, iolib, or 23 | in Hemlock's case, the connection API instead.) 24 | 25 | - The package SWANK-BACKEND has been renamed to CONIUM. 26 | 27 | 28 | It is currently being maintained by David Lichteblau and retains its 29 | original public domain status. 30 | -------------------------------------------------------------------------------- /abcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- 2 | ;;; 3 | ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME. 4 | ;;; 5 | ;;; Adapted from swank-acl.lisp, Andras Simon, 2004 6 | ;;; 7 | ;;; This code has been placed in the Public Domain. All warranties 8 | ;;; are disclaimed. 9 | ;;; 10 | 11 | (in-package :conium) 12 | 13 | (eval-when (:compile-toplevel :load-toplevel :execute) 14 | (require :collect) ;just so that it doesn't spoil the flying letters 15 | (require :pprint)) 16 | 17 | (defun sys::break (&optional (format-control "BREAK called") 18 | &rest format-arguments) 19 | (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls))) 20 | (with-simple-restart (continue "Return from BREAK.") 21 | (invoke-debugger 22 | (sys::%make-condition 'simple-condition 23 | (list :format-control format-control 24 | :format-arguments format-arguments)))) 25 | nil)) 26 | 27 | (defimplementation make-output-stream (write-string) 28 | (ext:make-slime-output-stream write-string)) 29 | 30 | (defimplementation make-input-stream (read-string) 31 | (ext:make-slime-input-stream read-string 32 | (make-synonym-stream '*standard-output*))) 33 | 34 | (defimplementation call-with-compilation-hooks (function) 35 | (funcall function)) 36 | 37 | ;;dummies and definition 38 | 39 | (defclass standard-slot-definition ()()) 40 | 41 | ;(defun class-finalized-p (class) t) 42 | 43 | (defun slot-definition-documentation (slot) #+nil (documentation slot 't)) 44 | (defun slot-definition-type (slot) t) 45 | (defun class-prototype (class)) 46 | (defun generic-function-declarations (gf)) 47 | (defun specializer-direct-methods (spec) (mop::class-direct-methods spec)) 48 | 49 | (defun slot-definition-name (slot) 50 | (mop::%slot-definition-name slot)) 51 | 52 | (defun class-slots (class) 53 | (mop::%class-slots class)) 54 | 55 | (defun method-generic-function (method) 56 | (mop::%method-generic-function method)) 57 | 58 | (defun method-function (method) 59 | (mop::%method-function method)) 60 | 61 | (defun slot-boundp-using-class (class object slotdef) 62 | (system::slot-boundp object (slot-definition-name slotdef))) 63 | 64 | (defun slot-value-using-class (class object slotdef) 65 | (system::slot-value object (slot-definition-name slotdef))) 66 | 67 | ;;;; Unix signals 68 | 69 | (defimplementation call-without-interrupts (fn) 70 | (funcall fn)) 71 | 72 | (defimplementation getpid () 73 | (handler-case 74 | (let* ((runtime 75 | (java:jstatic "getRuntime" "java.lang.Runtime")) 76 | (command 77 | (java:jnew-array-from-array 78 | "java.lang.String" #("sh" "-c" "echo $PPID"))) 79 | (runtime-exec-jmethod 80 | ;; Complicated because java.lang.Runtime.exec() is 81 | ;; overloaded on a non-primitive type (array of 82 | ;; java.lang.String), so we have to use the actual 83 | ;; parameter instance to get java.lang.Class 84 | (java:jmethod "java.lang.Runtime" "exec" 85 | (java:jcall 86 | (java:jmethod "java.lang.Object" "getClass") 87 | command))) 88 | (process 89 | (java:jcall runtime-exec-jmethod runtime command)) 90 | (output 91 | (java:jcall (java:jmethod "java.lang.Process" "getInputStream") 92 | process))) 93 | (java:jcall (java:jmethod "java.lang.Process" "waitFor") 94 | process) 95 | (loop :with b :do 96 | (setq b 97 | (java:jcall (java:jmethod "java.io.InputStream" "read") 98 | output)) 99 | :until (member b '(-1 #x0a)) ; Either EOF or LF 100 | :collecting (code-char b) :into result 101 | :finally (return 102 | (parse-integer (coerce result 'string))))) 103 | (t () 0))) 104 | 105 | (defimplementation lisp-implementation-type-name () 106 | "armedbear") 107 | 108 | (defimplementation set-default-directory (directory) 109 | (let ((dir (sys::probe-directory directory))) 110 | (when dir (setf *default-pathname-defaults* dir)) 111 | (namestring dir))) 112 | 113 | 114 | ;;;; Misc 115 | 116 | (defimplementation arglist (fun) 117 | (cond ((symbolp fun) 118 | (multiple-value-bind (arglist present) (sys::arglist fun) 119 | (if present arglist :not-available))) 120 | (t :not-available))) 121 | 122 | (defimplementation function-name (function) 123 | (nth-value 2 (function-lambda-expression function))) 124 | 125 | (defimplementation macroexpand-all (form) 126 | (macroexpand form)) 127 | 128 | (defimplementation describe-symbol-for-emacs (symbol) 129 | (let ((result '())) 130 | (flet ((doc (kind &optional (sym symbol)) 131 | (or (documentation sym kind) :not-documented)) 132 | (maybe-push (property value) 133 | (when value 134 | (setf result (list* property value result))))) 135 | (maybe-push 136 | :variable (when (boundp symbol) 137 | (doc 'variable))) 138 | (maybe-push 139 | :function (if (fboundp symbol) 140 | (doc 'function))) 141 | (maybe-push 142 | :class (if (find-class symbol nil) 143 | (doc 'class))) 144 | result))) 145 | 146 | 147 | (defimplementation describe-definition (symbol namespace) 148 | (ecase namespace 149 | (:variable 150 | (describe symbol)) 151 | ((:function :generic-function) 152 | (describe (symbol-function symbol))) 153 | (:class 154 | (describe (find-class symbol))))) 155 | 156 | (defimplementation describe-definition (symbol namespace) 157 | (ecase namespace 158 | (:variable 159 | (describe symbol)) 160 | ((:function :generic-function) 161 | (describe (symbol-function symbol))) 162 | (:class 163 | (describe (find-class symbol))))) 164 | 165 | 166 | ;;;; Debugger 167 | 168 | (defvar *sldb-topframe*) 169 | 170 | (defun backtrace-as-list-ignoring-swank-calls () 171 | (let ((list (ext:backtrace-as-list))) 172 | (subseq list (1+ (or (position (intern "SWANK-DEBUGGER-HOOK" 'swank) list :key 'car) -1))))) 173 | 174 | (defimplementation call-with-debugging-environment (debugger-loop-fn) 175 | (let ((*sldb-topframe* (car (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame))) 176 | (funcall debugger-loop-fn))) 177 | 178 | (defun nth-frame (index) 179 | (nth index (backtrace-as-list-ignoring-swank-calls))) 180 | 181 | (defimplementation compute-backtrace (start end) 182 | (let ((end (or end most-positive-fixnum))) 183 | (loop for f in (subseq (backtrace-as-list-ignoring-swank-calls) start end) 184 | collect f))) 185 | 186 | (defimplementation print-frame (frame stream) 187 | (write-string (string-trim '(#\space #\newline) 188 | (prin1-to-string frame)) 189 | stream)) 190 | 191 | (defimplementation frame-locals (index) 192 | `(,(list :name "??" :id 0 :value "??"))) 193 | 194 | #+nil 195 | (defimplementation disassemble-frame (index) 196 | (disassemble (debugger:frame-function (nth-frame index)))) 197 | 198 | (defimplementation frame-source-location-for-emacs (index) 199 | (list :error (format nil "Cannot find source for frame: ~A" 200 | (nth-frame index)))) 201 | 202 | #+nil 203 | (defimplementation eval-in-frame (form frame-number) 204 | (debugger:eval-form-in-context 205 | form 206 | (debugger:environment-of-frame (nth-frame frame-number)))) 207 | 208 | #+nil 209 | (defimplementation return-from-frame (frame-number form) 210 | (let ((frame (nth-frame frame-number))) 211 | (multiple-value-call #'debugger:frame-return 212 | frame (debugger:eval-form-in-context 213 | form 214 | (debugger:environment-of-frame frame))))) 215 | 216 | ;;; XXX doesn't work for frames with arguments 217 | #+nil 218 | (defimplementation restart-frame (frame-number) 219 | (let ((frame (nth-frame frame-number))) 220 | (debugger:frame-retry frame (debugger:frame-function frame)))) 221 | 222 | ;;;; Compiler hooks 223 | 224 | (defvar *buffer-name* nil) 225 | (defvar *buffer-start-position*) 226 | (defvar *buffer-string*) 227 | (defvar *compile-filename*) 228 | 229 | (in-package :conium) 230 | 231 | (defun handle-compiler-warning (condition) 232 | (let ((loc (when (and jvm::*compile-file-pathname* 233 | system::*source-position*) 234 | (cons jvm::*compile-file-pathname* system::*source-position*)))) 235 | ;; filter condition signaled more than once. 236 | (unless (member condition *abcl-signaled-conditions*) 237 | (push condition *abcl-signaled-conditions*) 238 | (signal (make-condition 239 | 'compiler-condition 240 | :original-condition condition 241 | :severity :warning 242 | :message (format nil "~A" condition) 243 | :location (cond (*buffer-name* 244 | (make-location 245 | (list :buffer *buffer-name*) 246 | (list :offset *buffer-start-position* 0))) 247 | (loc 248 | (destructuring-bind (file . pos) loc 249 | (make-location 250 | (list :file (namestring (truename file))) 251 | (list :position (1+ pos))))) 252 | (t 253 | (make-location 254 | (list :file (namestring *compile-filename*)) 255 | (list :position 1))))))))) 256 | 257 | (defvar *abcl-signaled-conditions*) 258 | 259 | (defimplementation swank-compile-file (input-file output-file 260 | load-p external-format) 261 | (declare (ignore external-format)) 262 | (let ((jvm::*resignal-compiler-warnings* t) 263 | (*abcl-signaled-conditions* nil)) 264 | (handler-bind ((warning #'handle-compiler-warning)) 265 | (let ((*buffer-name* nil) 266 | (*compile-filename* input-file)) 267 | (multiple-value-bind (fn warn fail) 268 | (compile-file input-file :output-file output-file) 269 | (values fn warn 270 | (or fail 271 | (and load-p 272 | (not (load fn)))))))))) 273 | 274 | (defimplementation swank-compile-string (string &key buffer position filename 275 | policy) 276 | (declare (ignore filename policy)) 277 | (let ((jvm::*resignal-compiler-warnings* t) 278 | (*abcl-signaled-conditions* nil)) 279 | (handler-bind ((warning #'handle-compiler-warning)) 280 | (let ((*buffer-name* buffer) 281 | (*buffer-start-position* position) 282 | (*buffer-string* string)) 283 | (funcall (compile nil (read-from-string 284 | (format nil "(~S () ~A)" 'lambda string)))) 285 | t)))) 286 | 287 | #| 288 | ;;;; Definition Finding 289 | 290 | (defun find-fspec-location (fspec type) 291 | (let ((file (excl::fspec-pathname fspec type))) 292 | (etypecase file 293 | (pathname 294 | (let ((start (scm:find-definition-in-file fspec type file))) 295 | (make-location (list :file (namestring (truename file))) 296 | (if start 297 | (list :position (1+ start)) 298 | (list :function-name (string fspec)))))) 299 | ((member :top-level) 300 | (list :error (format nil "Defined at toplevel: ~A" fspec))) 301 | (null 302 | (list :error (format nil "Unkown source location for ~A" fspec)))))) 303 | 304 | (defun fspec-definition-locations (fspec) 305 | (let ((defs (excl::find-multiple-definitions fspec))) 306 | (loop for (fspec type) in defs 307 | collect (list fspec (find-fspec-location fspec type))))) 308 | 309 | (defimplementation find-definitions (symbol) 310 | (fspec-definition-locations symbol)) 311 | 312 | |# 313 | 314 | (defun source-location (symbol) 315 | (when (pathnamep (ext:source-pathname symbol)) 316 | `(((,symbol) 317 | (:location 318 | (:file ,(namestring (ext:source-pathname symbol))) 319 | (:position ,(or (ext:source-file-position symbol) 1)) 320 | (:align t)))))) 321 | 322 | 323 | (defimplementation find-definitions (symbol) 324 | (source-location symbol)) 325 | 326 | #| 327 | Uncomment this if you have patched xref.lisp, as in 328 | http://article.gmane.org/gmane.lisp.slime.devel/2425 329 | Also, make sure that xref.lisp is loaded by modifying the armedbear 330 | part of *sysdep-pathnames* in swank.loader.lisp. 331 | 332 | ;;;; XREF 333 | (setq pxref:*handle-package-forms* '(cl:in-package)) 334 | 335 | (defmacro defxref (name function) 336 | `(defimplementation ,name (name) 337 | (xref-results (,function name)))) 338 | 339 | (defxref who-calls pxref:list-callers) 340 | (defxref who-references pxref:list-readers) 341 | (defxref who-binds pxref:list-setters) 342 | (defxref who-sets pxref:list-setters) 343 | (defxref list-callers pxref:list-callers) 344 | (defxref list-callees pxref:list-callees) 345 | 346 | (defun xref-results (symbols) 347 | (let ((xrefs '())) 348 | (dolist (symbol symbols) 349 | (push (list symbol (cadar (source-location symbol))) xrefs)) 350 | xrefs)) 351 | |# 352 | 353 | ;;;; Inspecting 354 | 355 | (defmethod emacs-inspect ((slot mop::slot-definition)) 356 | `("Name: " (:value ,(mop::%slot-definition-name slot)) 357 | (:newline) 358 | "Documentation:" (:newline) 359 | ,@(when (slot-definition-documentation slot) 360 | `((:value ,(slot-definition-documentation slot)) (:newline))) 361 | "Initialization:" (:newline) 362 | " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline) 363 | " Form: " ,(if (mop::%slot-definition-initfunction slot) 364 | `(:value ,(mop::%slot-definition-initform slot)) 365 | "#") (:newline) 366 | " Function: " (:value ,(mop::%slot-definition-initfunction slot)) 367 | (:newline))) 368 | 369 | (defmethod emacs-inspect ((f function)) 370 | `(,@(when (function-name f) 371 | `("Name: " 372 | ,(princ-to-string (function-name f)) (:newline))) 373 | ,@(multiple-value-bind (args present) 374 | (sys::arglist f) 375 | (when present `("Argument list: " ,(princ-to-string args) (:newline)))) 376 | (:newline) 377 | #+nil,@(when (documentation f t) 378 | `("Documentation:" (:newline) ,(documentation f t) (:newline))) 379 | ,@(when (function-lambda-expression f) 380 | `("Lambda expression:" 381 | (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))) 382 | 383 | #| 384 | 385 | (defmethod emacs-inspect ((o t)) 386 | (let* ((class (class-of o)) 387 | (slots (mop::class-slots class))) 388 | (mapcar (lambda (slot) 389 | (let ((name (mop::slot-definition-name slot))) 390 | (cons (princ-to-string name) 391 | (slot-value o name)))) 392 | slots))) 393 | |# 394 | 395 | (defimplementation quit-lisp () 396 | (ext:exit)) 397 | 398 | ;; WORKAROUND: call/initialize accessors at load time 399 | (let ((c (make-condition 'compiler-condition 400 | :original-condition nil 401 | :severity ':note :message "" :location nil)) 402 | (slots `(severity message short-message references location))) 403 | (dolist (slot slots) 404 | (funcall slot c))) 405 | -------------------------------------------------------------------------------- /allegro.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*- 2 | ;;; 3 | ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME. 4 | ;;; 5 | ;;; Created 2003 6 | ;;; 7 | ;;; This code has been placed in the Public Domain. All warranties 8 | ;;; are disclaimed. 9 | ;;; 10 | 11 | (in-package :conium) 12 | 13 | (eval-when (:compile-toplevel :load-toplevel :execute) 14 | (require :sock) 15 | (require :process)) 16 | 17 | 18 | (defvar *external-format-to-coding-system* 19 | '((:iso-8859-1 20 | "latin-1" "latin-1-unix" "iso-latin-1-unix" 21 | "iso-8859-1" "iso-8859-1-unix") 22 | (:utf-8 "utf-8" "utf-8-unix") 23 | (:euc-jp "euc-jp" "euc-jp-unix") 24 | (:us-ascii "us-ascii" "us-ascii-unix") 25 | (:emacs-mule "emacs-mule" "emacs-mule-unix"))) 26 | 27 | (defimplementation find-external-format (coding-system) 28 | (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 29 | *external-format-to-coding-system*))) 30 | (and e (excl:crlf-base-ef 31 | (excl:find-external-format (car e) 32 | :try-variant t))))) 33 | 34 | (defimplementation format-sldb-condition (c) 35 | (princ-to-string c)) 36 | 37 | (defimplementation call-with-syntax-hooks (fn) 38 | (funcall fn)) 39 | 40 | ;;;; Unix signals 41 | 42 | (defimplementation call-without-interrupts (fn) 43 | (excl:without-interrupts (funcall fn))) 44 | 45 | (defimplementation getpid () 46 | (excl::getpid)) 47 | 48 | (defimplementation lisp-implementation-type-name () 49 | "allegro") 50 | 51 | (defimplementation set-default-directory (directory) 52 | (let* ((dir (namestring (truename (merge-pathnames directory))))) 53 | (setf *default-pathname-defaults* (pathname (excl:chdir dir))) 54 | dir)) 55 | 56 | (defimplementation default-directory () 57 | (namestring (excl:current-directory))) 58 | 59 | ;;;; Misc 60 | 61 | (defimplementation arglist (symbol) 62 | (handler-case (excl:arglist symbol) 63 | (simple-error () :not-available))) 64 | 65 | (defimplementation macroexpand-all (form) 66 | (excl::walk form)) 67 | 68 | (defimplementation describe-symbol-for-emacs (symbol) 69 | (let ((result '())) 70 | (flet ((doc (kind &optional (sym symbol)) 71 | (or (documentation sym kind) :not-documented)) 72 | (maybe-push (property value) 73 | (when value 74 | (setf result (list* property value result))))) 75 | (maybe-push 76 | :variable (when (boundp symbol) 77 | (doc 'variable))) 78 | (maybe-push 79 | :function (if (fboundp symbol) 80 | (doc 'function))) 81 | (maybe-push 82 | :class (if (find-class symbol nil) 83 | (doc 'class))) 84 | result))) 85 | 86 | (defimplementation describe-definition (symbol namespace) 87 | (ecase namespace 88 | (:variable 89 | (describe symbol)) 90 | ((:function :generic-function) 91 | (describe (symbol-function symbol))) 92 | (:class 93 | (describe (find-class symbol))))) 94 | 95 | ;;;; Debugger 96 | 97 | (defvar *sldb-topframe*) 98 | 99 | (defimplementation call-with-debugging-environment (debugger-loop-fn) 100 | (let ((*sldb-topframe* (find-topframe)) 101 | (excl::*break-hook* nil)) 102 | (funcall debugger-loop-fn))) 103 | 104 | (defimplementation sldb-break-at-start (fname) 105 | ;; :print-before is kind of mis-used but we just want to stuff our break form 106 | ;; somewhere. This does not work for setf, :before and :after methods, which 107 | ;; need special syntax in the trace call, see ACL's doc/debugging.htm chapter 10. 108 | (eval `(trace (,fname 109 | :print-before 110 | ((break "Function start breakpoint of ~A" ',fname))))) 111 | `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) 112 | 113 | (defun find-topframe () 114 | (let ((skip-frames 3)) 115 | (do ((f (excl::int-newest-frame) (next-frame f)) 116 | (i 0 (1+ i))) 117 | ((= i skip-frames) f)))) 118 | 119 | (defun next-frame (frame) 120 | (let ((next (excl::int-next-older-frame frame))) 121 | (cond ((not next) nil) 122 | ((debugger:frame-visible-p next) next) 123 | (t (next-frame next))))) 124 | 125 | (defun nth-frame (index) 126 | (do ((frame *sldb-topframe* (next-frame frame)) 127 | (i index (1- i))) 128 | ((zerop i) frame))) 129 | 130 | (defimplementation compute-backtrace (start end) 131 | (let ((end (or end most-positive-fixnum))) 132 | (loop for f = (nth-frame start) then (next-frame f) 133 | for i from start below end 134 | while f collect f))) 135 | 136 | (defimplementation print-frame (frame stream) 137 | (debugger:output-frame stream frame :moderate)) 138 | 139 | (defimplementation frame-locals (index) 140 | (let ((frame (nth-frame index))) 141 | (loop for i from 0 below (debugger:frame-number-vars frame) 142 | collect (list :name (debugger:frame-var-name frame i) 143 | :id 0 144 | :value (debugger:frame-var-value frame i))))) 145 | 146 | (defimplementation frame-var-value (frame var) 147 | (let ((frame (nth-frame frame))) 148 | (debugger:frame-var-value frame var))) 149 | 150 | (defimplementation disassemble-frame (index) 151 | (disassemble (debugger:frame-function (nth-frame index)))) 152 | 153 | (defimplementation frame-source-location-for-emacs (index) 154 | (let* ((frame (nth-frame index)) 155 | (expr (debugger:frame-expression frame)) 156 | (fspec (first expr))) 157 | (second (first (fspec-definition-locations fspec))))) 158 | 159 | (defimplementation eval-in-frame (form frame-number) 160 | (let ((frame (nth-frame frame-number))) 161 | ;; let-bind lexical variables 162 | (let ((vars (loop for i below (debugger:frame-number-vars frame) 163 | for name = (debugger:frame-var-name frame i) 164 | if (symbolp name) 165 | collect `(,name ',(debugger:frame-var-value frame i))))) 166 | (debugger:eval-form-in-context 167 | `(let* ,vars ,form) 168 | (debugger:environment-of-frame frame))))) 169 | 170 | (defimplementation return-from-frame (frame-number form) 171 | (let ((frame (nth-frame frame-number))) 172 | (multiple-value-call #'debugger:frame-return 173 | frame (debugger:eval-form-in-context 174 | form 175 | (debugger:environment-of-frame frame))))) 176 | 177 | (defimplementation frame-restartable-p (frame) 178 | (handler-case (debugger:frame-retryable-p frame) 179 | (serious-condition (c) 180 | (funcall (read-from-string "swank::background-message") 181 | "~a ~a" frame (princ-to-string c)) 182 | nil))) 183 | 184 | (defimplementation restart-frame (frame-number) 185 | (let ((frame (nth-frame frame-number))) 186 | (cond ((debugger:frame-retryable-p frame) 187 | (apply #'debugger:frame-retry frame (debugger:frame-function frame) 188 | (cdr (debugger:frame-expression frame)))) 189 | (t "Frame is not retryable")))) 190 | 191 | ;;;; Compiler hooks 192 | 193 | (defvar *buffer-name* nil) 194 | (defvar *buffer-start-position*) 195 | (defvar *buffer-string*) 196 | (defvar *compile-filename* nil) 197 | 198 | (defun compiler-note-p (object) 199 | (member (type-of object) '(excl::compiler-note compiler::compiler-note))) 200 | 201 | (defun compiler-undefined-functions-called-warning-p (object) 202 | (typep object 'excl:compiler-undefined-functions-called-warning)) 203 | 204 | (deftype compiler-note () 205 | `(satisfies compiler-note-p)) 206 | 207 | (defun signal-compiler-condition (&rest args) 208 | (signal (apply #'make-condition 'compiler-condition args))) 209 | 210 | (defun handle-compiler-warning (condition) 211 | (declare (optimize (debug 3) (speed 0) (space 0))) 212 | (cond ((and (not *buffer-name*) 213 | (compiler-undefined-functions-called-warning-p condition)) 214 | (handle-undefined-functions-warning condition)) 215 | (t 216 | (signal-compiler-condition 217 | :original-condition condition 218 | :severity (etypecase condition 219 | (warning :warning) 220 | (compiler-note :note)) 221 | :message (format nil "~A" condition) 222 | :location (location-for-warning condition))))) 223 | 224 | (defun location-for-warning (condition) 225 | (let ((loc (getf (slot-value condition 'excl::plist) :loc))) 226 | (cond (*buffer-name* 227 | (make-location 228 | (list :buffer *buffer-name*) 229 | (list :offset *buffer-start-position* 0))) 230 | (loc 231 | (destructuring-bind (file . pos) loc 232 | (make-location 233 | (list :file (namestring (truename file))) 234 | (list :position (1+ pos))))) 235 | (t 236 | (list :error "No error location available."))))) 237 | 238 | (defun handle-undefined-functions-warning (condition) 239 | (let ((fargs (slot-value condition 'excl::format-arguments))) 240 | (loop for (fname . pos-file) in (car fargs) do 241 | (loop for (pos file) in pos-file do 242 | (signal-compiler-condition 243 | :original-condition condition 244 | :severity :warning 245 | :message (format nil "Undefined function referenced: ~S" 246 | fname) 247 | :location (make-location (list :file file) 248 | (list :position (1+ pos)))))))) 249 | 250 | (defimplementation call-with-compilation-hooks (function) 251 | (handler-bind ((warning #'handle-compiler-warning) 252 | ;;(compiler-note #'handle-compiler-warning) 253 | ) 254 | (funcall function))) 255 | 256 | (defimplementation swank-compile-file (input-file output-file 257 | load-p external-format) 258 | (with-compilation-hooks () 259 | (let ((*buffer-name* nil) 260 | (*compile-filename* input-file)) 261 | (compile-file *compile-filename* 262 | :output-file output-file 263 | :load-after-compile load-p 264 | :external-format external-format)))) 265 | 266 | (defun call-with-temp-file (fn) 267 | (let ((tmpname (system:make-temp-file-name))) 268 | (unwind-protect 269 | (with-open-file (file tmpname :direction :output :if-exists :error) 270 | (funcall fn file tmpname)) 271 | (delete-file tmpname)))) 272 | 273 | (defun compile-from-temp-file (string) 274 | (call-with-temp-file 275 | (lambda (stream filename) 276 | (write-string string stream) 277 | (finish-output stream) 278 | (multiple-value-bind (binary-filename warnings? failure?) 279 | (excl:without-redefinition-warnings 280 | ;; Suppress Allegro's redefinition warnings; they are 281 | ;; pointless when we are compiling via a temporary 282 | ;; file. 283 | (compile-file filename :load-after-compile t)) 284 | (declare (ignore warnings?)) 285 | (when binary-filename 286 | (delete-file binary-filename)) 287 | (not failure?))))) 288 | 289 | (defimplementation swank-compile-string (string &key buffer position filename 290 | policy) 291 | (declare (ignore policy)) 292 | ;; We store the source buffer in excl::*source-pathname* as a string 293 | ;; of the form ;. Quite ugly encoding, but 294 | ;; the fasl file is corrupted if we use some other datatype. 295 | (with-compilation-hooks () 296 | (let ((*buffer-name* buffer) 297 | (*buffer-start-position* position) 298 | (*buffer-string* string) 299 | (*default-pathname-defaults* 300 | (if filename 301 | (merge-pathnames (pathname filename)) 302 | *default-pathname-defaults*))) 303 | (compile-from-temp-file 304 | (format nil "~S ~S~%~A" 305 | `(in-package ,(package-name *package*)) 306 | `(eval-when (:compile-toplevel :load-toplevel) 307 | (setq excl::*source-pathname* 308 | ',(format nil "~A;~D" buffer position))) 309 | string))))) 310 | 311 | ;;;; Definition Finding 312 | 313 | (defun fspec-primary-name (fspec) 314 | (etypecase fspec 315 | (symbol fspec) 316 | (list (fspec-primary-name (second fspec))))) 317 | 318 | ;; If Emacs uses DOS-style eol conventions, \n\r are considered as a 319 | ;; single character, but file-position counts them as two. Here we do 320 | ;; our own conversion. 321 | (defun count-cr (file pos) 322 | (let* ((bufsize 256) 323 | (type '(unsigned-byte 8)) 324 | (buf (make-array bufsize :element-type type)) 325 | (cr-count 0)) 326 | (with-open-file (stream file :direction :input :element-type type) 327 | (loop for bytes-read = (read-sequence buf stream) do 328 | (incf cr-count (count (char-code #\return) buf 329 | :end (min pos bytes-read))) 330 | (decf pos bytes-read) 331 | (when (<= pos 0) 332 | (return cr-count)))))) 333 | 334 | (defun find-definition-in-file (fspec type file top-level) 335 | (let* ((part 336 | (or (scm::find-definition-in-definition-group 337 | fspec type (scm:section-file :file file) 338 | :top-level top-level) 339 | (scm::find-definition-in-definition-group 340 | (fspec-primary-name fspec) 341 | type (scm:section-file :file file) 342 | :top-level top-level))) 343 | (start (and part 344 | (scm::source-part-start part))) 345 | (pos (if start 346 | (list :position (1+ start)) 347 | (list :function-name (string (fspec-primary-name fspec)))))) 348 | (make-location (list :file (namestring (truename file))) 349 | pos))) 350 | 351 | (defun find-definition-in-buffer (filename) 352 | (let ((pos (position #\; filename :from-end t))) 353 | (make-location 354 | (list :buffer (subseq filename 0 pos)) 355 | (list :offset (parse-integer (subseq filename (1+ pos))) 0)))) 356 | 357 | (defun find-fspec-location (fspec type file top-level) 358 | (etypecase file 359 | (pathname 360 | (find-definition-in-file fspec type file top-level)) 361 | ((member :top-level) 362 | (list :error (format nil "Defined at toplevel: ~A" 363 | (fspec->string fspec)))) 364 | (string 365 | (find-definition-in-buffer file)))) 366 | 367 | (defun fspec->string (fspec) 368 | (etypecase fspec 369 | (symbol (let ((*package* (find-package :keyword))) 370 | (prin1-to-string fspec))) 371 | (list (format nil "(~A ~A)" 372 | (prin1-to-string (first fspec)) 373 | (let ((*package* (find-package :keyword))) 374 | (prin1-to-string (second fspec))))))) 375 | 376 | (defun fspec-definition-locations (fspec) 377 | (cond 378 | ((and (listp fspec) 379 | (eql (car fspec) :top-level-form)) 380 | (destructuring-bind (top-level-form file &optional position) fspec 381 | (declare (ignore top-level-form)) 382 | (list 383 | (list (list nil fspec) 384 | (make-location (list :buffer file) ; FIXME: should use :file 385 | (list :position position) 386 | (list :align t)))))) 387 | ((and (listp fspec) (eq (car fspec) :internal)) 388 | (destructuring-bind (_internal next _n) fspec 389 | (declare (ignore _internal _n)) 390 | (fspec-definition-locations next))) 391 | (t 392 | (let ((defs (excl::find-source-file fspec))) 393 | (when (and (null defs) 394 | (listp fspec) 395 | (string= (car fspec) '#:method)) 396 | ;; If methods are defined in a defgeneric form, the source location is 397 | ;; recorded for the gf but not for the methods. Therefore fall back to 398 | ;; the gf as the likely place of definition. 399 | (setq defs (excl::find-source-file (second fspec)))) 400 | (if (null defs) 401 | (list 402 | (list (list nil fspec) 403 | (list :error 404 | (format nil "Unknown source location for ~A" 405 | (fspec->string fspec))))) 406 | (loop for (fspec type file top-level) in defs 407 | collect (list (list type fspec) 408 | (find-fspec-location fspec type file top-level)))))))) 409 | 410 | (defimplementation find-definitions (symbol) 411 | (fspec-definition-locations symbol)) 412 | 413 | ;;;; XREF 414 | 415 | (defmacro defxref (name relation name1 name2) 416 | `(defimplementation ,name (x) 417 | (xref-result (xref:get-relation ,relation ,name1 ,name2)))) 418 | 419 | (defxref who-calls :calls :wild x) 420 | (defxref calls-who :calls x :wild) 421 | (defxref who-references :uses :wild x) 422 | (defxref who-binds :binds :wild x) 423 | (defxref who-macroexpands :macro-calls :wild x) 424 | (defxref who-sets :sets :wild x) 425 | 426 | (defun xref-result (fspecs) 427 | (loop for fspec in fspecs 428 | append (fspec-definition-locations fspec))) 429 | 430 | ;; list-callers implemented by groveling through all fbound symbols. 431 | ;; Only symbols are considered. Functions in the constant pool are 432 | ;; searched recursively. Closure environments are ignored at the 433 | ;; moment (constants in methods are therefore not found). 434 | 435 | (defun map-function-constants (function fn depth) 436 | "Call FN with the elements of FUNCTION's constant pool." 437 | (do ((i 0 (1+ i)) 438 | (max (excl::function-constant-count function))) 439 | ((= i max)) 440 | (let ((c (excl::function-constant function i))) 441 | (cond ((and (functionp c) 442 | (not (eq c function)) 443 | (plusp depth)) 444 | (map-function-constants c fn (1- depth))) 445 | (t 446 | (funcall fn c)))))) 447 | 448 | (defun in-constants-p (fun symbol) 449 | (map-function-constants fun 450 | (lambda (c) 451 | (when (eq c symbol) 452 | (return-from in-constants-p t))) 453 | 3)) 454 | 455 | (defun function-callers (name) 456 | (let ((callers '())) 457 | (do-all-symbols (sym) 458 | (when (fboundp sym) 459 | (let ((fn (fdefinition sym))) 460 | (when (in-constants-p fn name) 461 | (push sym callers))))) 462 | callers)) 463 | 464 | (defimplementation list-callers (name) 465 | (xref-result (function-callers name))) 466 | 467 | (defimplementation list-callees (name) 468 | (let ((result '())) 469 | (map-function-constants (fdefinition name) 470 | (lambda (c) 471 | (when (fboundp c) 472 | (push c result))) 473 | 2) 474 | (xref-result result))) 475 | 476 | ;;;; Profiling 477 | 478 | ;; Per-function profiling based on description in 479 | ;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#data-collection-control-2 480 | 481 | (defvar *profiled-functions* ()) 482 | (defvar *profile-depth* 0) 483 | 484 | (defmacro with-redirected-y-or-n-p (&body body) 485 | ;; If the profiler is restarted when the data from the previous 486 | ;; session is not reported yet, the user is warned via Y-OR-N-P. 487 | ;; As the CL:Y-OR-N-P question is (for some reason) not directly 488 | ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily 489 | ;; overruled. 490 | `(let* ((pkg (find-package "common-lisp")) 491 | (saved-pdl (excl::package-definition-lock pkg)) 492 | (saved-ynp (symbol-function 'cl:y-or-n-p))) 493 | 494 | (setf (excl::package-definition-lock pkg) nil 495 | (symbol-function 'cl:y-or-n-p) (symbol-function 496 | (find-symbol "y-or-n-p-in-emacs" 497 | "swank"))) 498 | (unwind-protect 499 | (progn ,@body) 500 | 501 | (setf (symbol-function 'cl:y-or-n-p) saved-ynp 502 | (excl::package-definition-lock pkg) saved-pdl)))) 503 | 504 | (defun start-acl-profiler () 505 | (with-redirected-y-or-n-p 506 | (prof:start-profiler :type :time :count t 507 | :start-sampling-p nil :verbose nil))) 508 | (defun acl-profiler-active-p () 509 | (not (eq (prof:profiler-status :verbose nil) :inactive))) 510 | 511 | (defun stop-acl-profiler () 512 | (prof:stop-profiler :verbose nil)) 513 | 514 | (excl:def-fwrapper profile-fwrapper (&rest args) 515 | ;; Ensures sampling is done during the execution of the function, 516 | ;; taking into account recursion. 517 | (declare (ignore args)) 518 | (cond ((zerop *profile-depth*) 519 | (let ((*profile-depth* (1+ *profile-depth*))) 520 | (prof:start-sampling) 521 | (unwind-protect (excl:call-next-fwrapper) 522 | (prof:stop-sampling)))) 523 | (t 524 | (excl:call-next-fwrapper)))) 525 | 526 | (defimplementation profile (fname) 527 | (unless (acl-profiler-active-p) 528 | (start-acl-profiler)) 529 | (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper) 530 | (push fname *profiled-functions*)) 531 | 532 | (defimplementation profiled-functions () 533 | *profiled-functions*) 534 | 535 | (defimplementation unprofile (fname) 536 | (excl:funwrap fname 'profile-fwrapper) 537 | (setq *profiled-functions* (remove fname *profiled-functions*))) 538 | 539 | (defimplementation profile-report () 540 | (prof:show-flat-profile :verbose nil) 541 | (when *profiled-functions* 542 | (start-acl-profiler))) 543 | 544 | (defimplementation profile-reset () 545 | (when (acl-profiler-active-p) 546 | (stop-acl-profiler) 547 | (start-acl-profiler)) 548 | "Reset profiling counters.") 549 | 550 | ;;;; Inspecting 551 | 552 | (excl:without-redefinition-warnings 553 | (defmethod emacs-inspect ((o t)) 554 | (allegro-inspect o))) 555 | 556 | (defmethod emacs-inspect ((o function)) 557 | (allegro-inspect o)) 558 | 559 | (defmethod emacs-inspect ((o standard-object)) 560 | (allegro-inspect o)) 561 | 562 | (defun allegro-inspect (o) 563 | (loop for (d dd) on (inspect::inspect-ctl o) 564 | append (frob-allegro-field-def o d) 565 | until (eq d dd))) 566 | 567 | (defun frob-allegro-field-def (object def) 568 | (with-struct (inspect::field-def- name type access) def 569 | (ecase type 570 | ((:unsigned-word :unsigned-byte :unsigned-natural 571 | :unsigned-long :unsigned-half-long 572 | :unsigned-3byte) 573 | (label-value-line name (inspect::component-ref-v object access type))) 574 | ((:lisp :value :func) 575 | (label-value-line name (inspect::component-ref object access))) 576 | (:indirect 577 | (destructuring-bind (prefix count ref set) access 578 | (declare (ignore set prefix)) 579 | (loop for i below (funcall count object) 580 | append (label-value-line (format nil "~A-~D" name i) 581 | (funcall ref object i)))))))) 582 | 583 | (defimplementation quit-lisp () 584 | (excl:exit 0 :quiet t)) 585 | 586 | 587 | ;;Trace implementations 588 | ;;In Allegro 7.0, we have: 589 | ;; (trace ) 590 | ;; (trace ((method ? (+)))) 591 | ;; (trace ((labels ))) 592 | ;; (trace ((labels (method (+)) ))) 593 | ;; can be a normal name or a (setf name) 594 | 595 | (defimplementation toggle-trace (spec) 596 | (ecase (car spec) 597 | ((setf) 598 | (toggle-trace-aux spec)) 599 | (:defgeneric (toggle-trace-generic-function-methods (second spec))) 600 | ((setf :defmethod :labels :flet) 601 | (toggle-trace-aux (process-fspec-for-allegro spec))) 602 | (:call 603 | (destructuring-bind (caller callee) (cdr spec) 604 | (toggle-trace-aux callee 605 | :inside (list (process-fspec-for-allegro caller))))))) 606 | 607 | (defun tracedp (fspec) 608 | (member fspec (eval '(trace)) :test #'equal)) 609 | 610 | (defun toggle-trace-aux (fspec &rest args) 611 | (cond ((tracedp fspec) 612 | (eval `(untrace ,fspec)) 613 | (format nil "~S is now untraced." fspec)) 614 | (t 615 | (eval `(trace (,fspec ,@args))) 616 | (format nil "~S is now traced." fspec)))) 617 | 618 | (defun toggle-trace-generic-function-methods (name) 619 | (let ((methods (mop:generic-function-methods (fdefinition name)))) 620 | (cond ((tracedp name) 621 | (eval `(untrace ,name)) 622 | (dolist (method methods (format nil "~S is now untraced." name)) 623 | (excl:funtrace (mop:method-function method)))) 624 | (t 625 | (eval `(trace (,name))) 626 | (dolist (method methods (format nil "~S is now traced." name)) 627 | (excl:ftrace (mop:method-function method))))))) 628 | 629 | (defun process-fspec-for-allegro (fspec) 630 | (cond ((consp fspec) 631 | (ecase (first fspec) 632 | ((setf) fspec) 633 | ((:defun :defgeneric) (second fspec)) 634 | ((:defmethod) `(method ,@(rest fspec))) 635 | ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) 636 | ,(third fspec))) 637 | ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) 638 | ,(third fspec))))) 639 | (t 640 | fspec))) 641 | 642 | 643 | ;;;; Weak hashtables 644 | 645 | (defimplementation make-weak-key-hash-table (&rest args) 646 | (apply #'make-hash-table :weak-keys t args)) 647 | 648 | (defimplementation make-weak-value-hash-table (&rest args) 649 | (apply #'make-hash-table :values :weak args)) 650 | 651 | (defimplementation hash-table-weakness (hashtable) 652 | (cond ((excl:hash-table-weak-keys hashtable) :key) 653 | ((eq (excl:hash-table-values hashtable) :weak) :value))) 654 | 655 | 656 | 657 | ;;;; Character names 658 | 659 | (defimplementation character-completion-set (prefix matchp) 660 | (loop for name being the hash-keys of excl::*name-to-char-table* 661 | when (funcall matchp prefix name) 662 | collect (string-capitalize name))) 663 | -------------------------------------------------------------------------------- /clisp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | ;;;; SWANK support for CLISP. 4 | 5 | ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach 6 | 7 | ;;;; This program is free software; you can redistribute it and/or 8 | ;;;; modify it under the terms of the GNU General Public License as 9 | ;;;; published by the Free Software Foundation; either version 2 of 10 | ;;;; the License, or (at your option) any later version. 11 | 12 | ;;;; This program is distributed in the hope that it will be useful, 13 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;;;; GNU General Public License for more details. 16 | 17 | ;;;; You should have received a copy of the GNU General Public 18 | ;;;; License along with this program; if not, write to the Free 19 | ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, 20 | ;;;; MA 02111-1307, USA. 21 | 22 | ;;; This is work in progress, but it's already usable. Many things 23 | ;;; are adapted from other swank-*.lisp, in particular from 24 | ;;; swank-allegro (I don't use allegro at all, but it's the shortest 25 | ;;; one and I found Helmut Eller's code there enlightening). 26 | 27 | ;;; This code will work better with recent versions of CLISP (say, the 28 | ;;; last release or CVS HEAD) while it may not work at all with older 29 | ;;; versions. It is reasonable to expect it to work on platforms with 30 | ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like 31 | ;;; systems, but also on Win32. This backend uses the portable xref 32 | ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which 33 | ;;; are conveniently included in SLIME. 34 | 35 | ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ 36 | 37 | (in-package :conium) 38 | 39 | (eval-when (:compile-toplevel :load-toplevel :execute) 40 | (use-package "GRAY")) 41 | 42 | ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or)) 43 | ;; (progn 44 | ;; (defmacro with-blocked-signals ((&rest signals) &body body) 45 | ;; (ext:with-gensyms ("SIGPROCMASK" ret mask) 46 | ;; `(multiple-value-bind (,ret ,mask) 47 | ;; (linux:sigprocmask-set-n-save 48 | ;; ,linux:SIG_BLOCK 49 | ;; ,(do ((sigset (linux:sigset-empty) 50 | ;; (linux:sigset-add sigset (the fixnum (pop signals))))) 51 | ;; ((null signals) sigset))) 52 | ;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save) 53 | ;; (unwind-protect 54 | ;; (progn ,@body) 55 | ;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil))))) 56 | 57 | ;; (defimplementation call-without-interrupts (fn) 58 | ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))) 59 | 60 | ;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and)) 61 | (defimplementation call-without-interrupts (fn) 62 | (funcall fn)) 63 | 64 | (let ((getpid (or (find-symbol "PROCESS-ID" :system) 65 | ;; old name prior to 2005-03-01, clisp <= 2.33.2 66 | (find-symbol "PROGRAM-ID" :system) 67 | #+win32 ; integrated into the above since 2005-02-24 68 | (and (find-package :win32) ; optional modules/win32 69 | (find-symbol "GetCurrentProcessId" :win32))))) 70 | (defimplementation getpid () ; a required interface 71 | (cond 72 | (getpid (funcall getpid)) 73 | #+win32 ((ext:getenv "PID")) ; where does that come from? 74 | (t -1)))) 75 | 76 | (defimplementation call-with-user-break-handler (handler function) 77 | (handler-bind ((system::simple-interrupt-condition 78 | (lambda (c) 79 | (declare (ignore c)) 80 | (funcall handler) 81 | (when (find-restart 'socket-status) 82 | (invoke-restart (find-restart 'socket-status))) 83 | (continue)))) 84 | (funcall function))) 85 | 86 | (defimplementation lisp-implementation-type-name () 87 | "clisp") 88 | 89 | (defimplementation set-default-directory (directory) 90 | (setf (ext:default-directory) directory) 91 | (namestring (setf *default-pathname-defaults* (ext:default-directory)))) 92 | 93 | (defimplementation filename-to-pathname (string) 94 | (cond ((member :cygwin *features*) 95 | (parse-cygwin-filename string)) 96 | (t (parse-namestring string)))) 97 | 98 | (defun parse-cygwin-filename (string) 99 | (multiple-value-bind (match _ drive absolute) 100 | (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) 101 | (declare (ignore _)) 102 | (assert (and match (if drive absolute t)) () 103 | "Invalid filename syntax: ~a" string) 104 | (let* ((sans-prefix (subseq string (regexp:match-end match))) 105 | (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) 106 | (path (loop for name in path collect 107 | (cond ((equal name "..") ':back) 108 | (t name)))) 109 | (directoryp (or (equal string "") 110 | (find (aref string (1- (length string))) "\\/")))) 111 | (multiple-value-bind (file type) 112 | (cond ((and (not directoryp) (last path)) 113 | (let* ((file (car (last path))) 114 | (pos (position #\. file :from-end t))) 115 | (cond ((and pos (> pos 0)) 116 | (values (subseq file 0 pos) 117 | (subseq file (1+ pos)))) 118 | (t file))))) 119 | (make-pathname :host nil 120 | :device nil 121 | :directory (cons 122 | (if absolute :absolute :relative) 123 | (let ((path (if directoryp 124 | path 125 | (butlast path)))) 126 | (if drive 127 | (cons 128 | (regexp:match-string string drive) 129 | path) 130 | path))) 131 | :name file 132 | :type type))))) 133 | 134 | ;;;; Coding systems 135 | 136 | (defvar *external-format-to-coding-system* 137 | '(((:charset "iso-8859-1" :line-terminator :unix) 138 | "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") 139 | ((:charset "iso-8859-1":latin-1) 140 | "latin-1" "iso-latin-1" "iso-8859-1") 141 | ((:charset "utf-8") "utf-8") 142 | ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") 143 | ((:charset "euc-jp") "euc-jp") 144 | ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") 145 | ((:charset "us-ascii") "us-ascii") 146 | ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) 147 | 148 | (defimplementation find-external-format (coding-system) 149 | (let ((args (car (rassoc-if (lambda (x) 150 | (member coding-system x :test #'equal)) 151 | *external-format-to-coding-system*)))) 152 | (and args (apply #'ext:make-encoding args)))) 153 | 154 | 155 | ;;;; Swank functions 156 | 157 | (defimplementation arglist (fname) 158 | (block nil 159 | (or (ignore-errors 160 | (let ((exp (function-lambda-expression fname))) 161 | (and exp (return (second exp))))) 162 | (ignore-errors 163 | (return (ext:arglist fname))) 164 | :not-available))) 165 | 166 | (defimplementation macroexpand-all (form) 167 | (ext:expand-form form)) 168 | 169 | (defimplementation describe-symbol-for-emacs (symbol) 170 | "Return a plist describing SYMBOL. 171 | Return NIL if the symbol is unbound." 172 | (let ((result ())) 173 | (flet ((doc (kind) 174 | (or (documentation symbol kind) :not-documented)) 175 | (maybe-push (property value) 176 | (when value 177 | (setf result (list* property value result))))) 178 | (maybe-push :variable (when (boundp symbol) (doc 'variable))) 179 | (when (fboundp symbol) 180 | (maybe-push 181 | ;; Report WHEN etc. as macros, even though they may be 182 | ;; implemented as special operators. 183 | (if (macro-function symbol) :macro 184 | (typecase (fdefinition symbol) 185 | (generic-function :generic-function) 186 | (function :function) 187 | ;; (type-of 'progn) -> ext:special-operator 188 | (t :special-operator))) 189 | (doc 'function))) 190 | (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) 191 | (get symbol 'system::setf-expander)); defsetf 192 | (maybe-push :setf (doc 'setf))) 193 | (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp 194 | (get symbol 'system::defstruct-description) 195 | (get symbol 'system::deftype-expander)) 196 | (maybe-push :type (doc 'type))) ; even for 'structure 197 | (when (find-class symbol nil) 198 | (maybe-push :class (doc 'type))) 199 | ;; Let this code work compiled in images without FFI 200 | (let ((types (load-time-value 201 | (and (find-package "FFI") 202 | (symbol-value 203 | (find-symbol "*C-TYPE-TABLE*" "FFI")))))) 204 | ;; Use ffi::*c-type-table* so as not to suffer the overhead of 205 | ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols 206 | ;; which are not FFI type names. 207 | (when (and types (nth-value 1 (gethash symbol types))) 208 | ;; Maybe use (case (head (ffi:deparse-c-type))) 209 | ;; to distinguish struct and union types? 210 | (maybe-push :alien-type :not-documented))) 211 | result))) 212 | 213 | (defimplementation describe-definition (symbol namespace) 214 | (ecase namespace 215 | (:variable (describe symbol)) 216 | (:macro (describe (macro-function symbol))) 217 | (:function (describe (symbol-function symbol))) 218 | (:class (describe (find-class symbol))))) 219 | 220 | (defun fspec-pathname (spec) 221 | (let ((path spec) 222 | type 223 | lines) 224 | (when (consp path) 225 | (psetq type (car path) 226 | path (cadr path) 227 | lines (cddr path))) 228 | (when (and path 229 | (member (pathname-type path) 230 | custom:*compiled-file-types* :test #'equal)) 231 | (setq path 232 | (loop for suffix in custom:*source-file-types* 233 | thereis (probe-file (make-pathname :defaults path 234 | :type suffix))))) 235 | (values path type lines))) 236 | 237 | (defun fspec-location (name fspec) 238 | (multiple-value-bind (file type lines) 239 | (fspec-pathname fspec) 240 | (list (if type (list name type) name) 241 | (cond (file 242 | (multiple-value-bind (truename c) (ignore-errors (truename file)) 243 | (cond (truename 244 | (make-location (list :file (namestring truename)) 245 | (if (consp lines) 246 | (list* :line lines) 247 | (list :function-name (string name))) 248 | (when (consp type) 249 | (list :snippet (format nil "~A" type))))) 250 | (t (list :error (princ-to-string c)))))) 251 | (t (list :error (format nil "No source information available for: ~S" 252 | fspec))))))) 253 | 254 | (defimplementation find-definitions (name) 255 | (mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file))) 256 | 257 | (defun trim-whitespace (string) 258 | (string-trim #(#\newline #\space #\tab) string)) 259 | 260 | (defvar *sldb-backtrace*) 261 | 262 | (eval-when (:compile-toplevel :load-toplevel :execute) 263 | (when (string< "2.44" (lisp-implementation-version)) 264 | (pushnew :clisp-2.44+ *features*))) 265 | 266 | (defun sldb-backtrace () 267 | "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." 268 | (do ((frames '()) 269 | (last nil frame) 270 | (frame (sys::the-frame) 271 | #+clisp-2.44+ (sys::frame-up 1 frame 1) 272 | #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames" 273 | ((eq frame last) (nreverse frames)) 274 | (unless (boring-frame-p frame) 275 | (push frame frames)))) 276 | 277 | (defimplementation call-with-debugging-environment (debugger-loop-fn) 278 | (let* (;;(sys::*break-count* (1+ sys::*break-count*)) 279 | ;;(sys::*driver* debugger-loop-fn) 280 | ;;(sys::*fasoutput-stream* nil) 281 | (*sldb-backtrace* 282 | (nthcdr 3 (member (sys::the-frame) (sldb-backtrace))))) 283 | (funcall debugger-loop-fn))) 284 | 285 | (defun nth-frame (index) 286 | (nth index *sldb-backtrace*)) 287 | 288 | (defun boring-frame-p (frame) 289 | (member (frame-type frame) '(stack-value bind-var bind-env))) 290 | 291 | (defun frame-to-string (frame) 292 | (with-output-to-string (s) 293 | (sys::describe-frame s frame))) 294 | 295 | ;; FIXME: they changed the layout in 2.44 so the frame-to-string & 296 | ;; string-matching silliness no longer works. 297 | (defun frame-type (frame) 298 | ;; FIXME: should bind *print-length* etc. to small values. 299 | (frame-string-type (frame-to-string frame))) 300 | 301 | (defvar *frame-prefixes* 302 | '(("frame binding variables" bind-var) 303 | ("<1> # # # " fun) 322 | ("<2> " 2nd-frame))) 323 | 324 | (defun frame-string-type (string) 325 | (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) 326 | *frame-prefixes*))) 327 | 328 | (defimplementation compute-backtrace (start end) 329 | (let* ((bt *sldb-backtrace*) 330 | (len (length bt))) 331 | (loop for f in (subseq bt start (min (or end len) len)) 332 | collect f))) 333 | 334 | (defimplementation print-frame (frame stream) 335 | (let* ((str (frame-to-string frame))) 336 | (write-string (extract-frame-line str) 337 | stream))) 338 | 339 | (defun extract-frame-line (frame-string) 340 | (let ((s frame-string)) 341 | (trim-whitespace 342 | (case (frame-string-type s) 343 | ((eval special-op) 344 | (string-match "EVAL frame .*for form \\(.*\\)" s 1)) 345 | (apply 346 | (string-match "APPLY frame for call \\(.*\\)" s 1)) 347 | ((compiled-fun sys-fun fun) 348 | (extract-function-name s)) 349 | (t s))))) 350 | 351 | (defun extract-function-name (string) 352 | (let ((1st (car (split-frame-string string)))) 353 | (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>") 354 | 1st 355 | 1) 356 | (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1) 357 | 1st))) 358 | 359 | (defun split-frame-string (string) 360 | (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)" 361 | (mapcar #'car *frame-prefixes*)))) 362 | (loop for pos = 0 then (1+ (regexp:match-start match)) 363 | for match = (regexp:match rx string :start pos) 364 | if match collect (subseq string pos (regexp:match-start match)) 365 | else collect (subseq string pos) 366 | while match))) 367 | 368 | (defun string-match (pattern string n) 369 | (let* ((match (nth-value n (regexp:match pattern string)))) 370 | (if match (regexp:match-string string match)))) 371 | 372 | (defimplementation format-sldb-condition (condition) 373 | (trim-whitespace (princ-to-string condition))) 374 | 375 | (defimplementation eval-in-frame (form frame-number) 376 | (sys::eval-at (nth-frame frame-number) form)) 377 | 378 | (defimplementation frame-locals (frame-number) 379 | (let ((frame (nth-frame frame-number))) 380 | (loop for i below (%frame-count-vars frame) 381 | collect (list :name (%frame-var-name frame i) 382 | :value (%frame-var-value frame i) 383 | :id 0)))) 384 | 385 | (defimplementation frame-var-value (frame var) 386 | (%frame-var-value (nth-frame frame) var)) 387 | 388 | ;;; Interpreter-Variablen-Environment has the shape 389 | ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). 390 | 391 | (defun %frame-count-vars (frame) 392 | (cond ((sys::eval-frame-p frame) 393 | (do ((venv (frame-venv frame) (next-venv venv)) 394 | (count 0 (+ count (/ (1- (length venv)) 2)))) 395 | ((not venv) count))) 396 | ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) 397 | (length (%parse-stack-values frame))) 398 | (t 0))) 399 | 400 | (defun %frame-var-name (frame i) 401 | (cond ((sys::eval-frame-p frame) 402 | (nth-value 0 (venv-ref (frame-venv frame) i))) 403 | (t (format nil "~D" i)))) 404 | 405 | (defun %frame-var-value (frame i) 406 | (cond ((sys::eval-frame-p frame) 407 | (let ((name (venv-ref (frame-venv frame) i))) 408 | (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) 409 | (if c 410 | (format-sldb-condition c) 411 | v)))) 412 | ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) 413 | (let ((str (nth i (%parse-stack-values frame)))) 414 | (trim-whitespace (subseq str 2)))) 415 | (t (break "Not implemented")))) 416 | 417 | (defun frame-venv (frame) 418 | (let ((env (sys::eval-at frame '(sys::the-environment)))) 419 | (svref env 0))) 420 | 421 | (defun next-venv (venv) (svref venv (1- (length venv)))) 422 | 423 | (defun venv-ref (env i) 424 | "Reference the Ith binding in ENV. 425 | Return two values: NAME and VALUE" 426 | (let ((idx (* i 2))) 427 | (if (< idx (1- (length env))) 428 | (values (svref env idx) (svref env (1+ idx))) 429 | (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) 430 | 431 | (defun %parse-stack-values (frame) 432 | (labels ((next (fp) 433 | #+clisp-2.44+ (sys::frame-down 1 fp 1) 434 | #-clisp-2.44+ (sys::frame-down-1 fp 1)) 435 | (parse (fp accu) 436 | (let ((str (frame-to-string fp))) 437 | (cond ((is-prefix-p "- " str) 438 | (parse (next fp) (cons str accu))) 439 | ((is-prefix-p "<1> " str) 440 | ;;(when (eq (frame-type frame) 'compiled-fun) 441 | ;; (pop accu)) 442 | (dolist (str (cdr (split-frame-string str))) 443 | (when (is-prefix-p "- " str) 444 | (push str accu))) 445 | (nreverse accu)) 446 | (t (parse (next fp) accu)))))) 447 | (parse (next frame) '()))) 448 | 449 | (setq *features* (remove :clisp-2.44+ *features*)) 450 | 451 | (defun is-prefix-p (pattern string) 452 | (not (mismatch pattern string :end2 (min (length pattern) 453 | (length string))))) 454 | 455 | (defimplementation return-from-frame (index form) 456 | (sys::return-from-eval-frame (nth-frame index) form)) 457 | 458 | (defimplementation restart-frame (index) 459 | (sys::redo-eval-frame (nth-frame index))) 460 | 461 | (defimplementation frame-source-location-for-emacs (index) 462 | `(:error 463 | ,(format nil "frame-source-location not implemented. (frame: ~A)" 464 | (nth-frame index)))) 465 | 466 | ;;;; Profiling 467 | 468 | (defimplementation profile (fname) 469 | (eval `(mon:monitor ,fname))) ;monitor is a macro 470 | 471 | (defimplementation profiled-functions () 472 | mon:*monitored-functions*) 473 | 474 | (defimplementation unprofile (fname) 475 | (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro 476 | 477 | (defimplementation unprofile-all () 478 | (mon:unmonitor)) 479 | 480 | (defimplementation profile-report () 481 | (mon:report-monitoring)) 482 | 483 | (defimplementation profile-reset () 484 | (mon:reset-all-monitoring)) 485 | 486 | (defimplementation profile-package (package callers-p methods) 487 | (declare (ignore callers-p methods)) 488 | (mon:monitor-all package)) 489 | 490 | ;;;; Handle compiler conditions (find out location of error etc.) 491 | 492 | (defmacro compile-file-frobbing-notes ((&rest args) &body body) 493 | "Pass ARGS to COMPILE-FILE, send the compiler notes to 494 | *STANDARD-INPUT* and frob them in BODY." 495 | `(let ((*error-output* (make-string-output-stream)) 496 | (*compile-verbose* t)) 497 | (multiple-value-prog1 498 | (compile-file ,@args) 499 | (handler-case 500 | (with-input-from-string 501 | (*standard-input* (get-output-stream-string *error-output*)) 502 | ,@body) 503 | (sys::simple-end-of-file () nil))))) 504 | 505 | (defvar *orig-c-warn* (symbol-function 'system::c-warn)) 506 | (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) 507 | (defvar *orig-c-error* (symbol-function 'system::c-error)) 508 | (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) 509 | 510 | (defmacro dynamic-flet (names-functions &body body) 511 | "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) 512 | Execute BODY with NAME's function slot set to FUNCTION." 513 | `(ext:letf* ,(loop for (name function) in names-functions 514 | collect `((symbol-function ',name) ,function)) 515 | ,@body)) 516 | 517 | (defvar *buffer-name* nil) 518 | (defvar *buffer-offset*) 519 | 520 | (defun compiler-note-location () 521 | "Return the current compiler location." 522 | (let ((lineno1 sys::*compile-file-lineno1*) 523 | (lineno2 sys::*compile-file-lineno2*) 524 | (file sys::*compile-file-truename*)) 525 | (cond ((and file lineno1 lineno2) 526 | (make-location (list ':file (namestring file)) 527 | (list ':line lineno1))) 528 | (*buffer-name* 529 | (make-location (list ':buffer *buffer-name*) 530 | (list ':offset *buffer-offset* 0))) 531 | (t 532 | (list :error "No error location available"))))) 533 | 534 | (defun signal-compiler-warning (cstring args severity orig-fn) 535 | (signal (make-condition 'compiler-condition 536 | :severity severity 537 | :message (apply #'format nil cstring args) 538 | :location (compiler-note-location))) 539 | (apply orig-fn cstring args)) 540 | 541 | (defun c-warn (cstring &rest args) 542 | (signal-compiler-warning cstring args :warning *orig-c-warn*)) 543 | 544 | (defun c-style-warn (cstring &rest args) 545 | (dynamic-flet ((sys::c-warn *orig-c-warn*)) 546 | (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) 547 | 548 | (defun c-error (cstring &rest args) 549 | (signal-compiler-warning cstring args :error *orig-c-error*)) 550 | 551 | (defimplementation call-with-compilation-hooks (function) 552 | (handler-bind ((warning #'handle-notification-condition)) 553 | (dynamic-flet ((system::c-warn #'c-warn) 554 | (system::c-style-warn #'c-style-warn) 555 | (system::c-error #'c-error)) 556 | (funcall function)))) 557 | 558 | (defun handle-notification-condition (condition) 559 | "Handle a condition caused by a compiler warning." 560 | (signal (make-condition 'compiler-condition 561 | :original-condition condition 562 | :severity :warning 563 | :message (princ-to-string condition) 564 | :location (compiler-note-location)))) 565 | 566 | (defimplementation swank-compile-file (input-file output-file 567 | load-p external-format) 568 | (with-compilation-hooks () 569 | (with-compilation-unit () 570 | (multiple-value-bind (fasl-file warningsp failurep) 571 | (compile-file input-file 572 | :output-file output-file 573 | :external-format external-format) 574 | (values fasl-file warningsp 575 | (or failurep 576 | (and load-p 577 | (not (load fasl-file))))))))) 578 | 579 | (defimplementation swank-compile-string (string &key buffer position filename 580 | policy) 581 | (declare (ignore filename policy)) 582 | (with-compilation-hooks () 583 | (let ((*buffer-name* buffer) 584 | (*buffer-offset* position)) 585 | (funcall (compile nil (read-from-string 586 | (format nil "(~S () ~A)" 'lambda string)))) 587 | t))) 588 | 589 | ;;;; Portable XREF from the CMU AI repository. 590 | 591 | (setq pxref::*handle-package-forms* '(cl:in-package)) 592 | 593 | (defmacro defxref (name function) 594 | `(defimplementation ,name (name) 595 | (xref-results (,function name)))) 596 | 597 | (defxref who-calls pxref:list-callers) 598 | (defxref who-references pxref:list-readers) 599 | (defxref who-binds pxref:list-setters) 600 | (defxref who-sets pxref:list-setters) 601 | (defxref list-callers pxref:list-callers) 602 | (defxref list-callees pxref:list-callees) 603 | 604 | (defun xref-results (symbols) 605 | (let ((xrefs '())) 606 | (dolist (symbol symbols) 607 | (push (fspec-location symbol symbol) xrefs)) 608 | xrefs)) 609 | 610 | (when (find-package :swank-loader) 611 | (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader)) 612 | (lambda () 613 | (let ((home (user-homedir-pathname))) 614 | (and (ext:probe-directory home) 615 | (probe-file (format nil "~A/.swank.lisp" 616 | (namestring (truename home))))))))) 617 | 618 | ;;; Don't set *debugger-hook* to nil on break. 619 | (ext:without-package-lock () 620 | (defun break (&optional (format-string "Break") &rest args) 621 | (if (not sys::*use-clcs*) 622 | (progn 623 | (terpri *error-output*) 624 | (apply #'format *error-output* 625 | (concatenate 'string "*** - " format-string) 626 | args) 627 | (funcall ext:*break-driver* t)) 628 | (let ((condition 629 | (make-condition 'simple-condition 630 | :format-control format-string 631 | :format-arguments args)) 632 | ;;(*debugger-hook* nil) 633 | ;; Issue 91 634 | ) 635 | (ext:with-restarts 636 | ((continue 637 | :report (lambda (stream) 638 | (format stream (sys::text "Return from ~S loop") 639 | 'break)) 640 | ())) 641 | (with-condition-restarts condition (list (find-restart 'continue)) 642 | (invoke-debugger condition))))) 643 | nil)) 644 | 645 | ;;;; Inspecting 646 | 647 | (defmethod emacs-inspect ((o t)) 648 | (let* ((*print-array* nil) (*print-pretty* t) 649 | (*print-circle* t) (*print-escape* t) 650 | (*print-lines* custom:*inspect-print-lines*) 651 | (*print-level* custom:*inspect-print-level*) 652 | (*print-length* custom:*inspect-print-length*) 653 | (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) 654 | (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) 655 | (*package* tmp-pack) 656 | (sys::*inspect-unbound-value* (intern "#" tmp-pack))) 657 | (let ((inspection (sys::inspect-backend o))) 658 | (append (list 659 | (format nil "~S~% ~A~{~%~A~}~%" o 660 | (sys::insp-title inspection) 661 | (sys::insp-blurb inspection))) 662 | (loop with count = (sys::insp-num-slots inspection) 663 | for i below count 664 | append (multiple-value-bind (value name) 665 | (funcall (sys::insp-nth-slot inspection) 666 | i) 667 | `((:value ,name) " = " (:value ,value) 668 | (:newline)))))))) 669 | 670 | (defimplementation quit-lisp () 671 | #+lisp=cl (ext:quit) 672 | #-lisp=cl (lisp:quit)) 673 | 674 | (defimplementation thread-id (thread) 675 | (declare (ignore thread)) 676 | 0) 677 | 678 | ;;;; Weak hashtables 679 | 680 | (defimplementation make-weak-key-hash-table (&rest args) 681 | (apply #'make-hash-table :weak :key args)) 682 | 683 | (defimplementation make-weak-value-hash-table (&rest args) 684 | (apply #'make-hash-table :weak :value args)) 685 | 686 | (defimplementation save-image (filename &optional restart-function) 687 | (let ((args `(,filename 688 | ,@(if restart-function 689 | `((:init-function ,restart-function)))))) 690 | (apply #'ext:saveinitmem args))) 691 | 692 | ;;; Local Variables: 693 | ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1) 694 | ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1) 695 | ;;; End: 696 | -------------------------------------------------------------------------------- /conium.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp; indent-tabs: nil -*- 2 | 3 | (defsystem :conium 4 | :serial t 5 | ;; add new files to this list: 6 | :components ((:file "package") 7 | (:file "conium") 8 | 9 | #+cmu (:file "source-path-parser") 10 | #+cmu (:file "source-file-cache") 11 | 12 | #+scl (:file "source-path-parser") 13 | #+scl (:file "swank-source-file-cache") 14 | 15 | #+sbcl (:file "source-path-parser") 16 | #+sbcl (:file "source-file-cache") 17 | 18 | #+ccl (:file "metering") 19 | 20 | #+clisp (:file "xref") 21 | #+clisp (:file "metering") 22 | 23 | #+armedbear '("abcl") 24 | 25 | #+ecl (:file "source-path-parser") 26 | #+ecl (:file "source-file-cache") 27 | 28 | #+allegro (:file "allegro") 29 | #+ccl (:file "openmcl") 30 | #+clisp (:file "clisp") 31 | #+ecl (:file "ecl") 32 | #+lispworks (:file "lispworks") 33 | #+sbcl (:file "sbcl") 34 | #+scl (:file "scl")) 35 | :depends-on (:closer-mop)) 36 | -------------------------------------------------------------------------------- /conium.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- 2 | ;;; 3 | ;;; slime-backend.lisp --- SLIME backend interface. 4 | ;;; 5 | ;;; Created by James Bielman in 2003. Released into the public domain. 6 | ;;; 7 | ;;;; Frontmatter 8 | ;;; 9 | ;;; This file defines the functions that must be implemented 10 | ;;; separately for each Lisp. Each is declared as a generic function 11 | ;;; for which swank-.lisp provides methods. 12 | 13 | (in-package :conium) 14 | 15 | 16 | ;;;; Metacode 17 | 18 | (defparameter *interface-functions* '() 19 | "The names of all interface functions.") 20 | 21 | (defparameter *unimplemented-interfaces* '() 22 | "List of interface functions that are not implemented. 23 | DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") 24 | 25 | (defmacro definterface (name args documentation &rest default-body) 26 | "Define an interface function for the backend to implement. 27 | A function is defined with NAME, ARGS, and DOCUMENTATION. This 28 | function first looks for a function to call in NAME's property list 29 | that is indicated by 'IMPLEMENTATION; failing that, it looks for a 30 | function indicated by 'DEFAULT. If neither is present, an error is 31 | signaled. 32 | 33 | If a DEFAULT-BODY is supplied, then a function with the same body and 34 | ARGS will be added to NAME's property list as the property indicated 35 | by 'DEFAULT. 36 | 37 | Backends implement these functions using DEFIMPLEMENTATION." 38 | (check-type documentation string "a documentation string") 39 | (assert (every #'symbolp args) () 40 | "Complex lambda-list not supported: ~S ~S" name args) 41 | (labels ((gen-default-impl () 42 | `(setf (get ',name 'default) (lambda ,args ,@default-body))) 43 | (args-as-list (args) 44 | (destructuring-bind (req opt key rest) (parse-lambda-list args) 45 | `(,@req ,@opt 46 | ,@(loop for k in key append `(,(kw k) ,k)) 47 | ,@(or rest '(()))))) 48 | (parse-lambda-list (args) 49 | (parse args '(&optional &key &rest) 50 | (make-array 4 :initial-element nil))) 51 | (parse (args keywords vars) 52 | (cond ((null args) 53 | (reverse (map 'list #'reverse vars))) 54 | ((member (car args) keywords) 55 | (parse (cdr args) (cdr (member (car args) keywords)) vars)) 56 | (t (push (car args) (aref vars (length keywords))) 57 | (parse (cdr args) keywords vars)))) 58 | (kw (s) (intern (string s) :keyword))) 59 | `(progn 60 | (defun ,name ,args 61 | ,documentation 62 | (let ((f (or (get ',name 'implementation) 63 | (get ',name 'default)))) 64 | (cond (f (apply f ,@(args-as-list args))) 65 | (t (error "~S not implementated" ',name))))) 66 | (pushnew ',name *interface-functions*) 67 | ,(if (null default-body) 68 | `(pushnew ',name *unimplemented-interfaces*) 69 | (gen-default-impl)) 70 | ;; see 71 | (eval-when (:compile-toplevel :load-toplevel :execute) 72 | (export ',name :conium)) 73 | ',name))) 74 | 75 | (defmacro defimplementation (name args &body body) 76 | (assert (every #'symbolp args) () 77 | "Complex lambda-list not supported: ~S ~S" name args) 78 | `(progn 79 | (setf (get ',name 'implementation) (lambda ,args ,@body)) 80 | (if (member ',name *interface-functions*) 81 | (setq *unimplemented-interfaces* 82 | (remove ',name *unimplemented-interfaces*)) 83 | (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) 84 | ',name)) 85 | 86 | (defun warn-unimplemented-interfaces () 87 | "Warn the user about unimplemented backend features. 88 | The portable code calls this function at startup." 89 | (let ((*print-pretty* t)) 90 | (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>" 91 | (list (sort (copy-list *unimplemented-interfaces*) #'string<))))) 92 | 93 | (defun import-from (package symbol-names &optional (to-package *package*)) 94 | "Import the list of SYMBOL-NAMES found in the package PACKAGE." 95 | (dolist (name symbol-names) 96 | (multiple-value-bind (symbol found) (find-symbol (string name) package) 97 | (assert found () "Symbol ~A not found in package ~A" name package) 98 | (import symbol to-package)))) 99 | 100 | 101 | ;;;; Utilities 102 | 103 | (defmacro with-struct ((conc-name &rest names) obj &body body) 104 | "Like with-slots but works only for structs." 105 | (flet ((reader (slot) (intern (concatenate 'string 106 | (symbol-name conc-name) 107 | (symbol-name slot)) 108 | (symbol-package conc-name)))) 109 | (let ((tmp (gensym "OO-"))) 110 | ` (let ((,tmp ,obj)) 111 | (symbol-macrolet 112 | ,(loop for name in names collect 113 | (typecase name 114 | (symbol `(,name (,(reader name) ,tmp))) 115 | (cons `(,(first name) (,(reader (second name)) ,tmp))) 116 | (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) 117 | ,@body))))) 118 | 119 | (defun boolean-to-feature-expression (value) 120 | "Converts a boolean VALUE to a form suitable for testing with #+." 121 | (if value 122 | '(:and) 123 | '(:or))) 124 | 125 | (defun with-symbol (name package) 126 | "Generate a form suitable for testing with #+." 127 | (if (find-symbol (string name) (string package)) 128 | '(:and) 129 | '(:or))) 130 | 131 | 132 | ;;;; Unix signals 133 | 134 | (defconstant +sigint+ 2) 135 | 136 | (definterface call-without-interrupts (fn) 137 | "Call FN in a context where interrupts are disabled." 138 | (funcall fn)) 139 | 140 | (definterface getpid () 141 | "Return the (Unix) process ID of this superior Lisp.") 142 | 143 | (definterface install-sigint-handler (function) 144 | "Call FUNCTION on SIGINT (instead of invoking the debugger). 145 | Return old signal handler." 146 | (declare (ignore function)) 147 | nil) 148 | 149 | (definterface call-with-user-break-handler (handler function) 150 | "Install the break handler HANDLER while executing FUNCTION." 151 | (let ((old-handler (install-sigint-handler handler))) 152 | (unwind-protect (funcall function) 153 | (install-sigint-handler old-handler)))) 154 | 155 | (definterface quit-lisp () 156 | "Exit the current lisp image.") 157 | 158 | (definterface lisp-implementation-type-name () 159 | "Return a short name for the Lisp implementation." 160 | (lisp-implementation-type)) 161 | 162 | 163 | ;; pathnames are sooo useless 164 | 165 | (definterface filename-to-pathname (filename) 166 | "Return a pathname for FILENAME. 167 | A filename in Emacs may for example contain asterisks which should not 168 | be translated to wildcards." 169 | (parse-namestring filename)) 170 | 171 | (definterface pathname-to-filename (pathname) 172 | "Return the filename for PATHNAME." 173 | (namestring pathname)) 174 | 175 | (definterface default-directory () 176 | "Return the default directory." 177 | (directory-namestring (truename *default-pathname-defaults*))) 178 | 179 | (definterface set-default-directory (directory) 180 | "Set the default directory. 181 | This is used to resolve filenames without directory component." 182 | (setf *default-pathname-defaults* (truename (merge-pathnames directory))) 183 | (default-directory)) 184 | 185 | 186 | (definterface call-with-syntax-hooks (fn) 187 | "Call FN with hooks to handle special syntax." 188 | (funcall fn)) 189 | 190 | (definterface default-readtable-alist () 191 | "Return a suitable initial value for SWANK:*READTABLE-ALIST*." 192 | '()) 193 | 194 | 195 | ;;;; Compilation 196 | 197 | (definterface call-with-compilation-hooks (func) 198 | "Call FUNC with hooks to record compiler conditions.") 199 | 200 | (defmacro with-compilation-hooks ((&rest ignore) &body body) 201 | "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." 202 | (declare (ignore ignore)) 203 | `(call-with-compilation-hooks (lambda () (progn ,@body)))) 204 | 205 | (definterface swank-compile-string (string &key buffer position filename 206 | policy) 207 | "Compile source from STRING. 208 | During compilation, compiler conditions must be trapped and 209 | resignalled as COMPILER-CONDITIONs. 210 | 211 | If supplied, BUFFER and POSITION specify the source location in Emacs. 212 | 213 | Additionally, if POSITION is supplied, it must be added to source 214 | positions reported in compiler conditions. 215 | 216 | If FILENAME is specified it may be used by certain implementations to 217 | rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of 218 | source information. 219 | 220 | If POLICY is supplied, and non-NIL, it may be used by certain 221 | implementations to compile with a debug optimization quality of its 222 | value. 223 | 224 | Should return T on successfull compilation, NIL otherwise. 225 | ") 226 | 227 | (definterface swank-compile-file (input-file output-file load-p 228 | external-format) 229 | "Compile INPUT-FILE signalling COMPILE-CONDITIONs. 230 | If LOAD-P is true, load the file after compilation. 231 | EXTERNAL-FORMAT is a value returned by find-external-format or 232 | :default. 233 | 234 | Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p 235 | like `compile-file'") 236 | 237 | (deftype severity () 238 | '(member :error :read-error :warning :style-warning :note)) 239 | 240 | ;; Base condition type for compiler errors, warnings and notes. 241 | (define-condition compiler-condition (condition) 242 | ((original-condition 243 | ;; The original condition thrown by the compiler if appropriate. 244 | ;; May be NIL if a compiler does not report using conditions. 245 | :type (or null condition) 246 | :initarg :original-condition 247 | :accessor original-condition) 248 | 249 | (severity :type severity 250 | :initarg :severity 251 | :accessor severity) 252 | 253 | (message :initarg :message 254 | :accessor message) 255 | 256 | (short-message :initarg :short-message 257 | :initform nil 258 | :accessor short-message) 259 | 260 | (references :initarg :references 261 | :initform nil 262 | :accessor references) 263 | 264 | (location :initarg :location 265 | :accessor location))) 266 | 267 | (definterface find-external-format (coding-system) 268 | "Return a \"external file format designator\" for CODING-SYSTEM. 269 | CODING-SYSTEM is Emacs-style coding system name (a string), 270 | e.g. \"latin-1-unix\"." 271 | (if (equal coding-system "iso-latin-1-unix") 272 | :default 273 | nil)) 274 | 275 | (definterface guess-external-format (pathname) 276 | "Detect the external format for the file with name pathname. 277 | Return nil if the file contains no special markers." 278 | ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. 279 | (with-open-file (s pathname :if-does-not-exist nil 280 | :external-format (or (find-external-format "latin-1-unix") 281 | :default)) 282 | (if s 283 | (or (let* ((line (read-line s nil)) 284 | (p (search "-*-" line))) 285 | (when p 286 | (let* ((start (+ p (length "-*-"))) 287 | (end (search "-*-" line :start2 start))) 288 | (when end 289 | (%search-coding line start end))))) 290 | (let* ((len (file-length s)) 291 | (buf (make-string (min len 3000)))) 292 | (file-position s (- len (length buf))) 293 | (read-sequence buf s) 294 | (let ((start (search "Local Variables:" buf :from-end t)) 295 | (end (search "End:" buf :from-end t))) 296 | (and start end (< start end) 297 | (%search-coding buf start end)))))))) 298 | 299 | (defun %search-coding (str start end) 300 | (let ((p (search "coding:" str :start2 start :end2 end))) 301 | (when p 302 | (incf p (length "coding:")) 303 | (loop while (and (< p end) 304 | (member (aref str p) '(#\space #\tab))) 305 | do (incf p)) 306 | (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline))) 307 | str :start p))) 308 | (find-external-format (subseq str p end)))))) 309 | 310 | 311 | ;;;; Streams 312 | 313 | (definterface make-output-stream (write-string) 314 | "Return a new character output stream. 315 | The stream calls WRITE-STRING when output is ready.") 316 | 317 | (definterface make-input-stream (read-string) 318 | "Return a new character input stream. 319 | The stream calls READ-STRING when input is needed.") 320 | 321 | 322 | ;;;; Documentation 323 | 324 | (definterface arglist (name) 325 | "Return the lambda list for the symbol NAME. NAME can also be 326 | a lisp function object, on lisps which support this. 327 | 328 | The result can be a list or the :not-available keyword if the 329 | arglist cannot be determined." 330 | (declare (ignore name)) 331 | :not-available) 332 | 333 | (defgeneric declaration-arglist (decl-identifier) 334 | (:documentation 335 | "Return the argument list of the declaration specifier belonging to the 336 | declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, 337 | the keyword :NOT-AVAILABLE is returned. 338 | 339 | The different SWANK backends can specialize this generic function to 340 | include implementation-dependend declaration specifiers, or to provide 341 | additional information on the specifiers defined in ANSI Common Lisp.") 342 | (:method (decl-identifier) 343 | (case decl-identifier 344 | (dynamic-extent '(&rest vars)) 345 | (ignore '(&rest vars)) 346 | (ignorable '(&rest vars)) 347 | (special '(&rest vars)) 348 | (inline '(&rest function-names)) 349 | (notinline '(&rest function-name)) 350 | (optimize '(&any compilation-speed debug safety space speed)) 351 | (type '(type-specifier &rest args)) 352 | (ftype '(type-specifier &rest function-names)) 353 | (otherwise 354 | (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol)))) 355 | (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) 356 | '(&rest vars)) 357 | ((and (listp decl-identifier) (typespec-p (first decl-identifier))) 358 | '(&rest vars)) 359 | (t :not-available))))))) 360 | 361 | (defgeneric type-specifier-arglist (typespec-operator) 362 | (:documentation 363 | "Return the argument list of the type specifier belonging to 364 | TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword 365 | :NOT-AVAILABLE is returned. 366 | 367 | The different SWANK backends can specialize this generic function to 368 | include implementation-dependend declaration specifiers, or to provide 369 | additional information on the specifiers defined in ANSI Common Lisp.") 370 | (:method (typespec-operator) 371 | (declare (special *type-specifier-arglists*)) ; defined at end of file. 372 | (typecase typespec-operator 373 | (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) 374 | :not-available)) 375 | (t :not-available)))) 376 | 377 | (definterface function-name (function) 378 | "Return the name of the function object FUNCTION. 379 | 380 | The result is either a symbol, a list, or NIL if no function name is available." 381 | (declare (ignore function)) 382 | nil) 383 | 384 | (definterface macroexpand-all (form) 385 | "Recursively expand all macros in FORM. 386 | Return the resulting form.") 387 | 388 | (definterface compiler-macroexpand-1 (form &optional env) 389 | "Call the compiler-macro for form. 390 | If FORM is a function call for which a compiler-macro has been 391 | defined, invoke the expander function using *macroexpand-hook* and 392 | return the results and T. Otherwise, return the original form and 393 | NIL." 394 | (let ((fun (and (consp form) (compiler-macro-function (car form))))) 395 | (if fun 396 | (let ((result (funcall *macroexpand-hook* fun form env))) 397 | (values result (not (eq result form)))) 398 | (values form nil)))) 399 | 400 | (definterface compiler-macroexpand (form &optional env) 401 | "Repetitively call `compiler-macroexpand-1'." 402 | (labels ((frob (form expanded) 403 | (multiple-value-bind (new-form newly-expanded) 404 | (compiler-macroexpand-1 form env) 405 | (if newly-expanded 406 | (frob new-form t) 407 | (values new-form expanded))))) 408 | (frob form env))) 409 | 410 | (definterface format-string-expand (control-string) 411 | "Expand the format string CONTROL-STRING." 412 | (macroexpand `(formatter ,control-string))) 413 | 414 | (definterface describe-symbol-for-emacs (symbol) 415 | "Return a property list describing SYMBOL. 416 | 417 | The property list has an entry for each interesting aspect of the 418 | symbol. The recognised keys are: 419 | 420 | :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO 421 | :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM 422 | 423 | The value of each property is the corresponding documentation string, 424 | or :NOT-DOCUMENTED. It is legal to include keys not listed here (but 425 | slime-print-apropos in Emacs must know about them). 426 | 427 | Properties should be included if and only if they are applicable to 428 | the symbol. For example, only (and all) fbound symbols should include 429 | the :FUNCTION property. 430 | 431 | Example: 432 | \(describe-symbol-for-emacs 'vector) 433 | => (:CLASS :NOT-DOCUMENTED 434 | :TYPE :NOT-DOCUMENTED 435 | :FUNCTION \"Constructs a simple-vector from the given objects.\")") 436 | 437 | (definterface describe-definition (name type) 438 | "Describe the definition NAME of TYPE. 439 | TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. 440 | 441 | Return a documentation string, or NIL if none is available.") 442 | 443 | 444 | ;;;; Debugging 445 | 446 | (definterface install-debugger-globally (function) 447 | "Install FUNCTION as the debugger for all threads/processes. This 448 | usually involves setting *DEBUGGER-HOOK* and, if the implementation 449 | permits, hooking into BREAK as well." 450 | (setq *debugger-hook* function)) 451 | 452 | (definterface call-with-debugging-environment (debugger-loop-fn) 453 | "Call DEBUGGER-LOOP-FN in a suitable debugging environment. 454 | 455 | This function is called recursively at each debug level to invoke the 456 | debugger loop. The purpose is to setup any necessary environment for 457 | other debugger callbacks that will be called within the debugger loop. 458 | 459 | For example, this is a reasonable place to compute a backtrace, switch 460 | to safe reader/printer settings, and so on.") 461 | 462 | (definterface call-with-debugger-hook (hook fun) 463 | "Call FUN and use HOOK as debugger hook. 464 | 465 | HOOK should be called for both BREAK and INVOKE-DEBUGGER." 466 | (let ((*debugger-hook* hook)) 467 | (funcall fun))) 468 | 469 | (define-condition sldb-condition (condition) 470 | ((original-condition 471 | :initarg :original-condition 472 | :accessor original-condition)) 473 | (:report (lambda (condition stream) 474 | (format stream "Condition in debugger code~@[: ~A~]" 475 | (original-condition condition)))) 476 | (:documentation 477 | "Wrapper for conditions that should not be debugged. 478 | 479 | When a condition arises from the internals of the debugger, it is not 480 | desirable to debug it -- we'd risk entering an endless loop trying to 481 | debug the debugger! Instead, such conditions can be reported to the 482 | user without (re)entering the debugger by wrapping them as 483 | `sldb-condition's.")) 484 | 485 | ;;; The following functions in this section are supposed to be called 486 | ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. 487 | 488 | (definterface compute-backtrace (start end) 489 | "Returns a backtrace of the condition currently being debugged, 490 | that is an ordered list consisting of frames. ``Ordered list'' 491 | means that an integer I can be mapped back to the i-th frame of this 492 | backtrace. 493 | 494 | START and END are zero-based indices constraining the number of frames 495 | returned. Frame zero is defined as the frame which invoked the 496 | debugger. If END is nil, return the frames from START to the end of 497 | the stack.") 498 | 499 | (definterface print-frame (frame stream) 500 | "Print frame to stream.") 501 | 502 | (definterface frame-restartable-p (frame) 503 | "Is the frame FRAME restartable?. 504 | Return T if `restart-frame' can safely be called on the frame." 505 | (declare (ignore frame)) 506 | nil) 507 | 508 | (definterface frame-source-location-for-emacs (frame-number) 509 | "Return the source location for the frame associated to FRAME-NUMBER.") 510 | 511 | (definterface frame-catch-tags (frame-number) 512 | "Return a list of catch tags for being printed in a debugger stack 513 | frame." 514 | (declare (ignore frame-number)) 515 | '()) 516 | 517 | (definterface frame-locals (frame-number) 518 | "Return a list of ((&key NAME ID VALUE) ...) where each element of 519 | the list represents a local variable in the stack frame associated to 520 | FRAME-NUMBER. 521 | 522 | NAME, a symbol; the name of the local variable. 523 | 524 | ID, an integer; used as primary key for the local variable, unique 525 | relatively to the frame under operation. 526 | 527 | value, an object; the value of the local variable.") 528 | 529 | (definterface frame-var-value (frame-number var-id) 530 | "Return the value of the local variable associated to VAR-ID 531 | relatively to the frame associated to FRAME-NUMBER.") 532 | 533 | (definterface disassemble-frame (frame-number) 534 | "Disassemble the code for the FRAME-NUMBER. 535 | The output should be written to standard output. 536 | FRAME-NUMBER is a non-negative integer.") 537 | 538 | (definterface eval-in-frame (form frame-number) 539 | "Evaluate a Lisp form in the lexical context of a stack frame 540 | in the debugger. 541 | 542 | FRAME-NUMBER must be a positive integer with 0 indicating the 543 | frame which invoked the debugger. 544 | 545 | The return value is the result of evaulating FORM in the 546 | appropriate context.") 547 | 548 | (definterface return-from-frame (frame-number form) 549 | "Unwind the stack to the frame FRAME-NUMBER and return the value(s) 550 | produced by evaluating FORM in the frame context to its caller. 551 | 552 | Execute any clean-up code from unwind-protect forms above the frame 553 | during unwinding. 554 | 555 | Return a string describing the error if it's not possible to return 556 | from the frame.") 557 | 558 | (definterface restart-frame (frame-number) 559 | "Restart execution of the frame FRAME-NUMBER with the same arguments 560 | as it was called originally.") 561 | 562 | (definterface format-sldb-condition (condition) 563 | "Format a condition for display in SLDB." 564 | (princ-to-string condition)) 565 | 566 | (definterface condition-extras (condition) 567 | "Return a list of extra for the debugger. 568 | The allowed elements are of the form: 569 | (:SHOW-FRAME-SOURCE frame-number) 570 | (:REFERENCES &rest refs) 571 | " 572 | (declare (ignore condition)) 573 | '()) 574 | 575 | (definterface activate-stepping (frame-number) 576 | "Prepare the frame FRAME-NUMBER for stepping.") 577 | 578 | (definterface sldb-break-on-return (frame-number) 579 | "Set a breakpoint in the frame FRAME-NUMBER.") 580 | 581 | (definterface sldb-break-at-start (symbol) 582 | "Set a breakpoint on the beginning of the function for SYMBOL.") 583 | 584 | (definterface sldb-stepper-condition-p (condition) 585 | "Return true if SLDB was invoked due to a single-stepping condition, 586 | false otherwise. " 587 | (declare (ignore condition)) 588 | nil) 589 | 590 | (definterface sldb-step-into () 591 | "Step into the current single-stepper form.") 592 | 593 | (definterface sldb-step-next () 594 | "Step to the next form in the current function.") 595 | 596 | (definterface sldb-step-out () 597 | "Stop single-stepping temporarily, but resume it once the current function 598 | returns.") 599 | 600 | 601 | ;;;; Definition finding 602 | 603 | (defstruct (:location (:type list) :named 604 | (:constructor make-location 605 | (buffer position &optional hints))) 606 | buffer position 607 | ;; Hints is a property list optionally containing: 608 | ;; :snippet SOURCE-TEXT 609 | ;; This is a snippet of the actual source text at the start of 610 | ;; the definition, which could be used in a text search. 611 | hints) 612 | 613 | (defstruct (:error (:type list) :named (:constructor)) message) 614 | (defstruct (:file (:type list) :named (:constructor)) name) 615 | (defstruct (:buffer (:type list) :named (:constructor)) name) 616 | (defstruct (:position (:type list) :named (:constructor)) pos) 617 | 618 | (definterface find-definitions (name) 619 | "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. 620 | 621 | NAME is a \"definition specifier\". 622 | 623 | DSPEC is a \"definition specifier\" describing the 624 | definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or 625 | \(DEFVAR FOO). 626 | 627 | LOCATION is the source location for the definition.") 628 | 629 | (definterface find-source-location (object) 630 | "Returns the source location of OBJECT, or NIL. 631 | 632 | That is the source location of the underlying datastructure of 633 | OBJECT. E.g. on a STANDARD-OBJECT, the source location of the 634 | respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the 635 | respective DEFSTRUCT definition, and so on." 636 | ;; This returns one source location and not a list of locations. It's 637 | ;; supposed to return the location of the DEFGENERIC definition on 638 | ;; #'SOME-GENERIC-FUNCTION. 639 | ) 640 | 641 | 642 | (definterface buffer-first-change (filename) 643 | "Called for effect the first time FILENAME's buffer is modified." 644 | (declare (ignore filename)) 645 | nil) 646 | 647 | 648 | 649 | ;;;; XREF 650 | 651 | (definterface who-calls (function-name) 652 | "Return the call sites of FUNCTION-NAME (a symbol). 653 | The results is a list ((DSPEC LOCATION) ...).") 654 | 655 | (definterface calls-who (function-name) 656 | "Return the call sites of FUNCTION-NAME (a symbol). 657 | The results is a list ((DSPEC LOCATION) ...).") 658 | 659 | (definterface who-references (variable-name) 660 | "Return the locations where VARIABLE-NAME (a symbol) is referenced. 661 | See WHO-CALLS for a description of the return value.") 662 | 663 | (definterface who-binds (variable-name) 664 | "Return the locations where VARIABLE-NAME (a symbol) is bound. 665 | See WHO-CALLS for a description of the return value.") 666 | 667 | (definterface who-sets (variable-name) 668 | "Return the locations where VARIABLE-NAME (a symbol) is set. 669 | See WHO-CALLS for a description of the return value.") 670 | 671 | (definterface who-macroexpands (macro-name) 672 | "Return the locations where MACRO-NAME (a symbol) is expanded. 673 | See WHO-CALLS for a description of the return value.") 674 | 675 | (definterface who-specializes (class-name) 676 | "Return the locations where CLASS-NAME (a symbol) is specialized. 677 | See WHO-CALLS for a description of the return value.") 678 | 679 | ;;; Simpler variants. 680 | 681 | (definterface list-callers (function-name) 682 | "List the callers of FUNCTION-NAME. 683 | This function is like WHO-CALLS except that it is expected to use 684 | lower-level means. Whereas WHO-CALLS is usually implemented with 685 | special compiler support, LIST-CALLERS is usually implemented by 686 | groveling for constants in function objects throughout the heap. 687 | 688 | The return value is as for WHO-CALLS.") 689 | 690 | (definterface list-callees (function-name) 691 | "List the functions called by FUNCTION-NAME. 692 | See LIST-CALLERS for a description of the return value.") 693 | 694 | 695 | ;;;; Profiling 696 | 697 | ;;; The following functions define a minimal profiling interface. 698 | 699 | (definterface profile (fname) 700 | "Marks symbol FNAME for profiling.") 701 | 702 | (definterface profiled-functions () 703 | "Returns a list of profiled functions.") 704 | 705 | (definterface unprofile (fname) 706 | "Marks symbol FNAME as not profiled.") 707 | 708 | (definterface unprofile-all () 709 | "Marks all currently profiled functions as not profiled." 710 | (dolist (f (profiled-functions)) 711 | (unprofile f))) 712 | 713 | (definterface profile-report () 714 | "Prints profile report.") 715 | 716 | (definterface profile-reset () 717 | "Resets profile counters.") 718 | 719 | (definterface profile-package (package callers-p methods) 720 | "Wrap profiling code around all functions in PACKAGE. If a function 721 | is already profiled, then unprofile and reprofile (useful to notice 722 | function redefinition.) 723 | 724 | If CALLERS-P is T names have counts of the most common calling 725 | functions recorded. 726 | 727 | When called with arguments :METHODS T, profile all methods of all 728 | generic functions having names in the given package. Generic functions 729 | themselves, that is, their dispatch functions, are left alone.") 730 | 731 | 732 | ;;;; Inspector 733 | 734 | (defgeneric emacs-inspect (object) 735 | (:documentation 736 | "Explain to Emacs how to inspect OBJECT. 737 | 738 | Returns a list specifying how to render the object for inspection. 739 | 740 | Every element of the list must be either a string, which will be 741 | inserted into the buffer as is, or a list of the form: 742 | 743 | (:value object &optional format) - Render an inspectable 744 | object. If format is provided it must be a string and will be 745 | rendered in place of the value, otherwise use princ-to-string. 746 | 747 | (:newline) - Render a \\n 748 | 749 | (:action label lambda &key (refresh t)) - Render LABEL (a text 750 | string) which when clicked will call LAMBDA. If REFRESH is 751 | non-NIL the currently inspected object will be re-inspected 752 | after calling the lambda. 753 | ")) 754 | 755 | (defmethod emacs-inspect ((object t)) 756 | "Generic method for inspecting any kind of object. 757 | 758 | Since we don't know how to deal with OBJECT we simply dump the 759 | output of CL:DESCRIBE." 760 | `("Type: " (:value ,(type-of object)) (:newline) 761 | "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" 762 | (:newline) (:newline) 763 | ,(with-output-to-string (desc) (describe object desc)))) 764 | 765 | ;;; Utilities for inspector methods. 766 | ;;; 767 | (defun label-value-line (label value &key (newline t)) 768 | "Create a control list which prints \"LABEL: VALUE\" in the inspector. 769 | If NEWLINE is non-NIL a `(:newline)' is added to the result." 770 | (list* (princ-to-string label) ": " `(:value ,value) 771 | (if newline '((:newline)) nil))) 772 | 773 | (defmacro label-value-line* (&rest label-values) 774 | ` (append ,@(loop for (label value) in label-values 775 | collect `(label-value-line ,label ,value)))) 776 | 777 | (definterface describe-primitive-type (object) 778 | "Return a string describing the primitive type of object." 779 | (declare (ignore object)) 780 | "N/A") 781 | 782 | 783 | (definterface set-default-initial-binding (var form) 784 | "Initialize special variable VAR by default with FORM. 785 | 786 | Some implementations initialize certain variables in each newly 787 | created thread. This function sets the form which is used to produce 788 | the initial value." 789 | (set var (eval form))) 790 | 791 | ;; List of delayed interrupts. 792 | ;; This should only have thread-local bindings, so no init form. 793 | (defvar *pending-slime-interrupts*) 794 | 795 | (defun check-slime-interrupts () 796 | "Execute pending interrupts if any. 797 | This should be called periodically in operations which 798 | can take a long time to complete. 799 | Return a boolean indicating whether any interrupts was processed." 800 | (when (and (boundp '*pending-slime-interrupts*) 801 | *pending-slime-interrupts*) 802 | (funcall (pop *pending-slime-interrupts*)) 803 | t)) 804 | 805 | (defvar *interrupt-queued-handler* nil 806 | "Function to call on queued interrupts. 807 | Interrupts get queued when an interrupt occurs while interrupt 808 | handling is disabled. 809 | 810 | Backends can use this function to abort slow operations.") 811 | 812 | (definterface wait-for-input (streams &optional timeout) 813 | "Wait for input on a list of streams. Return those that are ready. 814 | STREAMS is a list of streams 815 | TIMEOUT nil, t, or real number. If TIMEOUT is t, return 816 | those streams which are ready immediately, without waiting. 817 | If TIMEOUT is a number and no streams is ready after TIMEOUT seconds, 818 | return nil. 819 | 820 | Return :interrupt if an interrupt occurs while waiting." 821 | (assert (member timeout '(nil t))) 822 | (cond #+(or) 823 | ((null (cdr streams)) 824 | (wait-for-one-stream (car streams) timeout)) 825 | (t 826 | (wait-for-streams streams timeout)))) 827 | 828 | (defun wait-for-streams (streams timeout) 829 | (loop 830 | (when (check-slime-interrupts) (return :interrupt)) 831 | (let ((ready (remove-if-not #'stream-readable-p streams))) 832 | (when ready (return ready))) 833 | (when timeout (return nil)) 834 | (sleep 0.1))) 835 | 836 | ;; Note: Usually we can't interrupt PEEK-CHAR cleanly. 837 | (defun wait-for-one-stream (stream timeout) 838 | (ecase timeout 839 | ((nil) 840 | (cond ((check-slime-interrupts) :interrupt) 841 | (t (peek-char nil stream nil nil) 842 | (list stream)))) 843 | ((t) 844 | (let ((c (read-char-no-hang stream nil nil))) 845 | (cond (c 846 | (unread-char c stream) 847 | (list stream)) 848 | (t '())))))) 849 | 850 | (defun stream-readable-p (stream) 851 | (let ((c (read-char-no-hang stream nil :eof))) 852 | (cond ((not c) nil) 853 | ((eq c :eof) t) 854 | (t (unread-char c stream) t)))) 855 | 856 | (definterface toggle-trace (spec) 857 | "Toggle tracing of the function(s) given with SPEC. 858 | SPEC can be: 859 | (setf NAME) ; a setf function 860 | (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method 861 | (:defgeneric NAME) ; a generic function with all methods 862 | (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. 863 | (:labels TOPLEVEL LOCAL) 864 | (:flet TOPLEVEL LOCAL) ") 865 | 866 | 867 | ;;;; Weak datastructures 868 | 869 | (definterface make-weak-key-hash-table (&rest args) 870 | "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." 871 | (apply #'make-hash-table args)) 872 | 873 | (definterface make-weak-value-hash-table (&rest args) 874 | "Like MAKE-HASH-TABLE, but weak w.r.t. the values." 875 | (apply #'make-hash-table args)) 876 | 877 | (definterface hash-table-weakness (hashtable) 878 | "Return nil or one of :key :value :key-or-value :key-and-value" 879 | (declare (ignore hashtable)) 880 | nil) 881 | 882 | 883 | ;;;; Character names 884 | 885 | (definterface character-completion-set (prefix matchp) 886 | "Return a list of names of characters that match PREFIX." 887 | ;; Handle the standard and semi-standard characters. 888 | (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" 889 | "Linefeed" "Return" "Backspace") 890 | when (funcall matchp prefix name) 891 | collect name)) 892 | 893 | 894 | (defparameter *type-specifier-arglists* 895 | '((and . (&rest type-specifiers)) 896 | (array . (&optional element-type dimension-spec)) 897 | (base-string . (&optional size)) 898 | (bit-vector . (&optional size)) 899 | (complex . (&optional type-specifier)) 900 | (cons . (&optional car-typespec cdr-typespec)) 901 | (double-float . (&optional lower-limit upper-limit)) 902 | (eql . (object)) 903 | (float . (&optional lower-limit upper-limit)) 904 | (function . (&optional arg-typespec value-typespec)) 905 | (integer . (&optional lower-limit upper-limit)) 906 | (long-float . (&optional lower-limit upper-limit)) 907 | (member . (&rest eql-objects)) 908 | (mod . (n)) 909 | (not . (type-specifier)) 910 | (or . (&rest type-specifiers)) 911 | (rational . (&optional lower-limit upper-limit)) 912 | (real . (&optional lower-limit upper-limit)) 913 | (satisfies . (predicate-symbol)) 914 | (short-float . (&optional lower-limit upper-limit)) 915 | (signed-byte . (&optional size)) 916 | (simple-array . (&optional element-type dimension-spec)) 917 | (simple-base-string . (&optional size)) 918 | (simple-bit-vector . (&optional size)) 919 | (simple-string . (&optional size)) 920 | (single-float . (&optional lower-limit upper-limit)) 921 | (simple-vector . (&optional size)) 922 | (string . (&optional size)) 923 | (unsigned-byte . (&optional size)) 924 | (values . (&rest typespecs)) 925 | (vector . (&optional element-type size)) 926 | )) 927 | 928 | ;;; Heap dumps 929 | 930 | (definterface save-image (filename &optional restart-function) 931 | "Save a heap image to the file FILENAME. 932 | RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") 933 | 934 | 935 | 936 | -------------------------------------------------------------------------------- /corman.lisp: -------------------------------------------------------------------------------- 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 :conium) 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 | 80 | 81 | (defun named-by-gensym-p (c) 82 | (null (symbol-package (class-name c)))) 83 | 84 | ;;;; swank implementations 85 | 86 | ;;; Debugger 87 | 88 | (defvar *stack-trace* nil) 89 | (defvar *frame-trace* nil) 90 | 91 | (defstruct frame 92 | name function address debug-info variables) 93 | 94 | (defimplementation call-with-debugging-environment (fn) 95 | (let* ((real-stack-trace (cl::stack-trace)) 96 | (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace 97 | :key #'car))) 98 | (*frame-trace* 99 | (let* ((db::*debug-level* (1+ db::*debug-level*)) 100 | (db::*debug-frame-pointer* (db::stash-ebp 101 | (ct:create-foreign-ptr))) 102 | (db::*debug-max-level* (length real-stack-trace)) 103 | (db::*debug-min-level* 1)) 104 | (cdr (member #'cl:invoke-debugger 105 | (cons 106 | (make-frame :function nil) 107 | (loop for i from db::*debug-min-level* 108 | upto db::*debug-max-level* 109 | until (eq (db::get-frame-function i) cl::*top-level*) 110 | collect 111 | (make-frame :function (db::get-frame-function i) 112 | :address (db::get-frame-address i)))) 113 | :key #'frame-function))))) 114 | (funcall fn))) 115 | 116 | (defimplementation compute-backtrace (start end) 117 | (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*))) 118 | collect f)) 119 | 120 | (defimplementation print-frame (frame stream) 121 | (format stream "~S" frame)) 122 | 123 | (defun get-frame-debug-info (frame) 124 | (or (frame-debug-info frame) 125 | (setf (frame-debug-info frame) 126 | (db::prepare-frame-debug-info (frame-function frame) 127 | (frame-address frame))))) 128 | 129 | (defimplementation frame-locals (frame-number) 130 | (let* ((frame (elt *frame-trace* frame-number)) 131 | (info (get-frame-debug-info frame))) 132 | (let ((var-list 133 | (loop for i from 4 below (length info) by 2 134 | collect `(list :name ',(svref info i) :id 0 135 | :value (db::debug-filter ,(svref info i)))))) 136 | (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) 137 | (setf (frame-variables frame) vars))))) 138 | 139 | (defimplementation eval-in-frame (form frame-number) 140 | (let ((frame (elt *frame-trace* frame-number))) 141 | (let ((cl::*compiler-environment* (get-frame-debug-info frame))) 142 | (eval form)))) 143 | 144 | (defimplementation frame-var-value (frame-number var) 145 | (let ((vars (frame-variables (elt *frame-trace* frame-number)))) 146 | (when vars 147 | (second (elt vars var))))) 148 | 149 | (defimplementation frame-source-location-for-emacs (frame-number) 150 | (fspec-location (frame-function (elt *frame-trace* frame-number)))) 151 | 152 | (defun break (&optional (format-control "Break") &rest format-arguments) 153 | (with-simple-restart (continue "Return from BREAK.") 154 | (let ();(*debugger-hook* nil)) 155 | (let ((condition 156 | (make-condition 'simple-condition 157 | :format-control format-control 158 | :format-arguments format-arguments))) 159 | ;;(format *debug-io* ";;; User break: ~A~%" condition) 160 | (invoke-debugger condition)))) 161 | nil) 162 | 163 | ;;; Misc 164 | 165 | (defimplementation preferred-communication-style () 166 | nil) 167 | 168 | (defimplementation getpid () 169 | ccl:*current-process-id*) 170 | 171 | (defimplementation lisp-implementation-type-name () 172 | "cormanlisp") 173 | 174 | (defimplementation quit-lisp () 175 | (sockets:stop-sockets) 176 | (win32:exitprocess 0)) 177 | 178 | (defimplementation set-default-directory (directory) 179 | (setf (ccl:current-directory) directory) 180 | (directory-namestring (setf *default-pathname-defaults* 181 | (truename (merge-pathnames directory))))) 182 | 183 | (defimplementation default-directory () 184 | (directory-namestring (ccl:current-directory))) 185 | 186 | (defimplementation macroexpand-all (form) 187 | (ccl:macroexpand-all form)) 188 | 189 | ;;; Documentation 190 | 191 | (defun fspec-location (fspec) 192 | (when (symbolp fspec) 193 | (setq fspec (symbol-function fspec))) 194 | (let ((file (ccl::function-source-file fspec))) 195 | (if file 196 | (handler-case 197 | (let ((truename (truename 198 | (merge-pathnames file 199 | ccl:*cormanlisp-directory*)))) 200 | (make-location (list :file (namestring truename)) 201 | (if (ccl::function-source-line fspec) 202 | (list :line 203 | (1+ (ccl::function-source-line fspec))) 204 | (list :function-name (princ-to-string 205 | (function-name fspec)))))) 206 | (error (c) (list :error (princ-to-string c)))) 207 | (list :error (format nil "No source information available for ~S" 208 | fspec))))) 209 | 210 | (defimplementation find-definitions (name) 211 | (list (list name (fspec-location name)))) 212 | 213 | (defimplementation arglist (name) 214 | (handler-case 215 | (cond ((and (symbolp name) 216 | (macro-function name)) 217 | (ccl::macro-lambda-list (symbol-function name))) 218 | (t 219 | (when (symbolp name) 220 | (setq name (symbol-function name))) 221 | (if (eq (class-of name) cl::the-class-standard-gf) 222 | (generic-function-lambda-list name) 223 | (ccl:function-lambda-list name)))) 224 | (error () :not-available))) 225 | 226 | (defimplementation function-name (fn) 227 | (handler-case (getf (cl::function-info-list fn) 'cl::function-name) 228 | (error () nil))) 229 | 230 | (defimplementation describe-symbol-for-emacs (symbol) 231 | (let ((result '())) 232 | (flet ((doc (kind &optional (sym symbol)) 233 | (or (documentation sym kind) :not-documented)) 234 | (maybe-push (property value) 235 | (when value 236 | (setf result (list* property value result))))) 237 | (maybe-push 238 | :variable (when (boundp symbol) 239 | (doc 'variable))) 240 | (maybe-push 241 | :function (if (fboundp symbol) 242 | (doc 'function))) 243 | (maybe-push 244 | :class (if (find-class symbol nil) 245 | (doc 'class))) 246 | result))) 247 | 248 | (defimplementation describe-definition (symbol namespace) 249 | (ecase namespace 250 | (:variable 251 | (describe symbol)) 252 | ((:function :generic-function) 253 | (describe (symbol-function symbol))) 254 | (:class 255 | (describe (find-class symbol))))) 256 | 257 | ;;; Compiler 258 | 259 | (defvar *buffer-name* nil) 260 | (defvar *buffer-position*) 261 | (defvar *buffer-string*) 262 | (defvar *compile-filename* nil) 263 | 264 | ;; FIXME 265 | (defimplementation call-with-compilation-hooks (FN) 266 | (handler-bind ((error (lambda (c) 267 | (signal (make-condition 268 | 'compiler-condition 269 | :original-condition c 270 | :severity :warning 271 | :message (format nil "~A" c) 272 | :location 273 | (cond (*buffer-name* 274 | (make-location 275 | (list :buffer *buffer-name*) 276 | (list :offset *buffer-position* 0))) 277 | (*compile-filename* 278 | (make-location 279 | (list :file *compile-filename*) 280 | (list :position 1))) 281 | (t 282 | (list :error "No location")))))))) 283 | (funcall fn))) 284 | 285 | (defimplementation swank-compile-file (input-file output-file 286 | load-p external-format) 287 | (declare (ignore external-format)) 288 | (with-compilation-hooks () 289 | (let ((*buffer-name* nil) 290 | (*compile-filename* input-file)) 291 | (multiple-value-bind (output-file warnings? failure?) 292 | (compile-file input-file :output-file output-file) 293 | (values output-file warnings? 294 | (or failure? (and load-p (load output-file)))))))) 295 | 296 | (defimplementation swank-compile-string (string &key buffer position filename 297 | policy) 298 | (declare (ignore filename policy)) 299 | (with-compilation-hooks () 300 | (let ((*buffer-name* buffer) 301 | (*buffer-position* position) 302 | (*buffer-string* string)) 303 | (funcall (compile nil (read-from-string 304 | (format nil "(~S () ~A)" 'lambda string)))) 305 | t))) 306 | 307 | ;;;; Inspecting 308 | 309 | ;; Hack to make swank.lisp load, at least 310 | (defclass file-stream ()) 311 | 312 | (defun comma-separated (list &optional (callback (lambda (v) 313 | `(:value ,v)))) 314 | (butlast (loop for e in list 315 | collect (funcall callback e) 316 | collect ", "))) 317 | 318 | (defmethod emacs-inspect ((class standard-class)) 319 | `("Name: " (:value ,(class-name class)) 320 | (:newline) 321 | "Super classes: " 322 | ,@(comma-separated (c2mop:class-direct-superclasses class)) 323 | (:newline) 324 | "Direct Slots: " 325 | ,@(comma-separated 326 | (c2mop:class-direct-slots class) 327 | (lambda (slot) 328 | `(:value ,slot ,(princ-to-string (c2mop:slot-definition-name slot))))) 329 | (:newline) 330 | "Effective Slots: " 331 | ,@(if (c2mop:class-finalized-p class) 332 | (comma-separated 333 | (c2mop:class-slots class) 334 | (lambda (slot) 335 | `(:value ,slot ,(princ-to-string 336 | (c2mop:slot-definition-name slot))))) 337 | '("#")) 338 | (:newline) 339 | ,@(when (documentation class t) 340 | `("Documentation:" (:newline) ,(documentation class t) (:newline))) 341 | "Sub classes: " 342 | ,@(comma-separated (c2mop:class-direct-subclasses class) 343 | (lambda (sub) 344 | `(:value ,sub ,(princ-to-string (class-name sub))))) 345 | (:newline) 346 | "Precedence List: " 347 | ,@(if (c2mop:class-finalized-p class) 348 | (comma-separated (c2mop:class-precedence-list class) 349 | (lambda (class) 350 | `(:value ,class ,(princ-to-string (class-name class))))) 351 | '("#")) 352 | (:newline))) 353 | 354 | (defmethod emacs-inspect ((slot cons)) 355 | ;; Inspects slot definitions 356 | (if (eq (car slot) :name) 357 | `("Name: " (:value ,(c2mop:slot-definition-name slot)) 358 | (:newline) 359 | ,@(when (c2mop:slot-definition-documentation slot) 360 | `("Documentation:" (:newline) 361 | (:value ,(c2mop:slot-definition-documentation slot)) 362 | (:newline))) 363 | "Init args: " (:value ,(c2mop:slot-definition-initargs slot)) (:newline) 364 | "Init form: " ,(if (c2mop:slot-definition-initfunction slot) 365 | `(:value ,(c2mop:slot-definition-initform slot)) 366 | "#") (:newline) 367 | "Init function: " (:value ,(c2mop:slot-definition-initfunction slot)) 368 | (:newline)) 369 | (call-next-method))) 370 | 371 | (defmethod emacs-inspect ((pathname pathnames::pathname-internal)) 372 | (list* (if (wild-pathname-p pathname) 373 | "A wild pathname." 374 | "A pathname.") 375 | '(:newline) 376 | (append (label-value-line* 377 | ("Namestring" (namestring pathname)) 378 | ("Host" (pathname-host pathname)) 379 | ("Device" (pathname-device pathname)) 380 | ("Directory" (pathname-directory pathname)) 381 | ("Name" (pathname-name pathname)) 382 | ("Type" (pathname-type pathname)) 383 | ("Version" (pathname-version pathname))) 384 | (unless (or (wild-pathname-p pathname) 385 | (not (probe-file pathname))) 386 | (label-value-line "Truename" (truename pathname)))))) 387 | 388 | (defmethod emacs-inspect ((o t)) 389 | (cond ((cl::structurep o) (inspect-structure o)) 390 | (t (call-next-method)))) 391 | 392 | (defun inspect-structure (o) 393 | (let* ((template (cl::uref o 1)) 394 | (num-slots (cl::struct-template-num-slots template))) 395 | (cond ((symbolp template) 396 | (loop for i below num-slots 397 | append (label-value-line i (cl::uref o (+ 2 i))))) 398 | (t 399 | (loop for i below num-slots 400 | append (label-value-line (elt template (+ 6 (* i 5))) 401 | (cl::uref o (+ 2 i)))))))) 402 | 403 | 404 | ;;; Threads 405 | 406 | (require 'threads) 407 | 408 | (defstruct (mailbox (:conc-name mailbox.)) 409 | thread 410 | (lock (make-instance 'threads:critical-section)) 411 | (queue '() :type list)) 412 | 413 | (defvar *mailbox-lock* (make-instance 'threads:critical-section)) 414 | (defvar *mailboxes* (list)) 415 | 416 | (defmacro with-lock (lock &body body) 417 | `(threads:with-synchronization (threads:cs ,lock) 418 | ,@body)) 419 | 420 | (defimplementation spawn (fun &key name) 421 | (declare (ignore name)) 422 | (th:create-thread 423 | (lambda () 424 | (handler-bind ((serious-condition #'invoke-debugger)) 425 | (unwind-protect (funcall fun) 426 | (with-lock *mailbox-lock* 427 | (setq *mailboxes* (remove cormanlisp:*current-thread-id* 428 | *mailboxes* :key #'mailbox.thread)))))))) 429 | 430 | (defimplementation thread-id (thread) 431 | thread) 432 | 433 | (defimplementation find-thread (thread) 434 | (if (thread-alive-p thread) 435 | thread)) 436 | 437 | (defimplementation thread-alive-p (thread) 438 | (if (threads:thread-handle thread) t nil)) 439 | 440 | (defimplementation current-thread () 441 | cormanlisp:*current-thread-id*) 442 | 443 | ;; XXX implement it 444 | (defimplementation all-threads () 445 | '()) 446 | 447 | ;; XXX something here is broken 448 | (defimplementation kill-thread (thread) 449 | (threads:terminate-thread thread 'killed)) 450 | 451 | (defun mailbox (thread) 452 | (with-lock *mailbox-lock* 453 | (or (find thread *mailboxes* :key #'mailbox.thread) 454 | (let ((mb (make-mailbox :thread thread))) 455 | (push mb *mailboxes*) 456 | mb)))) 457 | 458 | (defimplementation send (thread message) 459 | (let ((mbox (mailbox thread))) 460 | (with-lock (mailbox.lock mbox) 461 | (setf (mailbox.queue mbox) 462 | (nconc (mailbox.queue mbox) (list message)))))) 463 | 464 | (defimplementation receive () 465 | (let ((mbox (mailbox cormanlisp:*current-thread-id*))) 466 | (loop 467 | (with-lock (mailbox.lock mbox) 468 | (when (mailbox.queue mbox) 469 | (return (pop (mailbox.queue mbox))))) 470 | (sleep 0.1)))) 471 | 472 | 473 | ;;; This is probably not good, but it WFM 474 | (in-package :common-lisp) 475 | 476 | (defvar *old-documentation* #'documentation) 477 | (defun documentation (thing &optional (type 'function)) 478 | (if (symbolp thing) 479 | (funcall *old-documentation* thing type) 480 | (values))) 481 | 482 | (defmethod print-object ((restart restart) stream) 483 | (if (or *print-escape* 484 | *print-readably*) 485 | (print-unreadable-object (restart stream :type t :identity t) 486 | (princ (restart-name restart) stream)) 487 | (when (functionp (restart-report-function restart)) 488 | (funcall (restart-report-function restart) stream)))) 489 | -------------------------------------------------------------------------------- /ecl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; swank-ecl.lisp --- SLIME backend for ECL. 4 | ;;; 5 | ;;; This code has been placed in the Public Domain. All warranties 6 | ;;; are disclaimed. 7 | ;;; 8 | 9 | ;;; Administrivia 10 | 11 | (in-package :conium) 12 | 13 | (defvar *tmp*) 14 | 15 | 16 | 17 | ;;;; Unix signals 18 | 19 | (defimplementation install-sigint-handler (handler) 20 | (let ((old-handler (symbol-function 'si:terminal-interrupt))) 21 | (setf (symbol-function 'si:terminal-interrupt) 22 | (if (consp handler) 23 | (car handler) 24 | (lambda (&rest args) 25 | (declare (ignore args)) 26 | (funcall handler) 27 | (continue)))) 28 | (list old-handler))) 29 | 30 | 31 | (defimplementation getpid () 32 | (si:getpid)) 33 | 34 | #+nil 35 | (defimplementation set-default-directory (directory) 36 | (ext::chdir (namestring directory)) 37 | ;; Setting *default-pathname-defaults* to an absolute directory 38 | ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. 39 | (setf *default-pathname-defaults* (ext::getcwd)) 40 | (default-directory)) 41 | 42 | #+nil 43 | (defimplementation default-directory () 44 | (namestring (ext:getcwd))) 45 | 46 | (defimplementation quit-lisp () 47 | (ext:quit)) 48 | 49 | 50 | ;;;; Compilation 51 | 52 | (defvar *buffer-name* nil) 53 | (defvar *buffer-start-position*) 54 | (defvar *buffer-string*) 55 | (defvar *compile-filename*) 56 | 57 | (defun signal-compiler-condition (&rest args) 58 | (signal (apply #'make-condition 'compiler-condition args))) 59 | 60 | (defun handle-compiler-warning (condition) 61 | (signal-compiler-condition 62 | :original-condition condition 63 | :message (format nil "~A" condition) 64 | :severity :warning 65 | :location 66 | (if *buffer-name* 67 | (make-location (list :buffer *buffer-name*) 68 | (list :offset *buffer-start-position* 0)) 69 | ;; ;; compiler::*current-form* 70 | ;; (if compiler::*current-function* 71 | ;; (make-location (list :file *compile-filename*) 72 | ;; (list :function-name 73 | ;; (symbol-name 74 | ;; (slot-value compiler::*current-function* 75 | ;; 'compiler::name)))) 76 | (list :error "No location found.") 77 | ;; ) 78 | ))) 79 | 80 | (defimplementation call-with-compilation-hooks (function) 81 | (handler-bind ((warning #'handle-compiler-warning)) 82 | (funcall function))) 83 | 84 | (defimplementation swank-compile-file (input-file output-file 85 | load-p external-format) 86 | (declare (ignore external-format)) 87 | (with-compilation-hooks () 88 | (let ((*buffer-name* nil) 89 | (*compile-filename* input-file)) 90 | (compile-file input-file :output-file output-file :load t)))) 91 | 92 | (defimplementation swank-compile-string (string &key buffer position filename 93 | policy) 94 | (declare (ignore filename policy)) 95 | (with-compilation-hooks () 96 | (let ((*buffer-name* buffer) 97 | (*buffer-start-position* position) 98 | (*buffer-string* string)) 99 | (with-input-from-string (s string) 100 | (not (nth-value 2 (compile-from-stream s :load t))))))) 101 | 102 | (defun compile-from-stream (stream &rest args) 103 | (let ((file (si::mkstemp "TMP:ECLXXXXXX"))) 104 | (with-open-file (s file :direction :output :if-exists :overwrite) 105 | (do ((line (read-line stream nil) (read-line stream nil))) 106 | ((not line)) 107 | (write-line line s))) 108 | (unwind-protect 109 | (apply #'compile-file file args) 110 | (delete-file file)))) 111 | 112 | 113 | ;;;; Documentation 114 | 115 | (defun grovel-docstring-for-arglist (name type) 116 | (flet ((compute-arglist-offset (docstring) 117 | (when docstring 118 | (let ((pos1 (search "Args: " docstring))) 119 | (if pos1 120 | (+ pos1 6) 121 | (let ((pos2 (search "Syntax: " docstring))) 122 | (when pos2 123 | (+ pos2 8)))))))) 124 | (let* ((docstring (si::get-documentation name type)) 125 | (pos (compute-arglist-offset docstring))) 126 | (if pos 127 | (multiple-value-bind (arglist errorp) 128 | (ignore-errors 129 | (values (read-from-string docstring t nil :start pos))) 130 | (if (or errorp (not (listp arglist))) 131 | :not-available 132 | (cdr arglist))) 133 | :not-available )))) 134 | 135 | (defimplementation arglist (name) 136 | (cond ((special-operator-p name) 137 | (grovel-docstring-for-arglist name 'function)) 138 | ((macro-function name) 139 | (grovel-docstring-for-arglist name 'function)) 140 | ((or (functionp name) (fboundp name)) 141 | (multiple-value-bind (name fndef) 142 | (if (functionp name) 143 | (values (function-name name) name) 144 | (values name (fdefinition name))) 145 | (typecase fndef 146 | (generic-function 147 | (clos::generic-function-lambda-list fndef)) 148 | (compiled-function 149 | (grovel-docstring-for-arglist name 'function)) 150 | (function 151 | (let ((fle (function-lambda-expression fndef))) 152 | (case (car fle) 153 | (si:lambda-block (caddr fle)) 154 | (t :not-available))))))) 155 | (t :not-available))) 156 | 157 | (defimplementation function-name (f) 158 | (si:compiled-function-name f)) 159 | 160 | (defimplementation macroexpand-all (form) 161 | ;;; FIXME! This is not the same as a recursive macroexpansion! 162 | (macroexpand form)) 163 | 164 | (defimplementation describe-symbol-for-emacs (symbol) 165 | (let ((result '())) 166 | (dolist (type '(:VARIABLE :FUNCTION :CLASS)) 167 | (let ((doc (describe-definition symbol type))) 168 | (when doc 169 | (setf result (list* type doc result))))) 170 | result)) 171 | 172 | (defimplementation describe-definition (name type) 173 | (case type 174 | (:variable (documentation name 'variable)) 175 | (:function (documentation name 'function)) 176 | (:class (documentation name 'class)) 177 | (t nil))) 178 | 179 | ;;; Debugging 180 | 181 | (eval-when (:compile-toplevel :load-toplevel :execute) 182 | (import 183 | '(si::*break-env* 184 | si::*ihs-top* 185 | si::*ihs-current* 186 | si::*ihs-base* 187 | si::*frs-base* 188 | si::*frs-top* 189 | si::*tpl-commands* 190 | si::*tpl-level* 191 | si::frs-top 192 | si::ihs-top 193 | si::ihs-fun 194 | si::ihs-env 195 | si::sch-frs-base 196 | si::set-break-env 197 | si::set-current-ihs 198 | si::tpl-commands))) 199 | 200 | (defvar *backtrace* '()) 201 | 202 | (defun in-swank-package-p (x) 203 | (and 204 | (symbolp x) 205 | (member (symbol-package x) 206 | (list #.(find-package :swank) 207 | #.(find-package :conium) 208 | #.(ignore-errors (find-package :swank-mop)) 209 | #.(ignore-errors (find-package :swank-loader)))) 210 | t)) 211 | 212 | (defun is-swank-source-p (name) 213 | (setf name (pathname name)) 214 | (pathname-match-p 215 | name 216 | (make-pathname :defaults swank-loader::*source-directory* 217 | :name (pathname-name name) 218 | :type (pathname-type name) 219 | :version (pathname-version name)))) 220 | 221 | (defun is-ignorable-fun-p (x) 222 | (or 223 | (in-swank-package-p (frame-name x)) 224 | (multiple-value-bind (file position) 225 | (ignore-errors (si::bc-file (car x))) 226 | (declare (ignore position)) 227 | (if file (is-swank-source-p file))))) 228 | 229 | (defimplementation call-with-debugging-environment (debugger-loop-fn) 230 | (declare (type function debugger-loop-fn)) 231 | (let* ((*tpl-commands* si::tpl-commands) 232 | (*ihs-top* (ihs-top 'call-with-debugging-environment)) 233 | (*ihs-current* *ihs-top*) 234 | (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) 235 | (*frs-top* (frs-top)) 236 | (*read-suppress* nil) 237 | (*tpl-level* (1+ *tpl-level*)) 238 | (*backtrace* (loop for ihs from *ihs-base* below *ihs-top* 239 | collect (list (si::ihs-fun ihs) 240 | (si::ihs-env ihs) 241 | nil)))) 242 | (loop for f from *frs-base* until *frs-top* 243 | do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) 244 | (when (plusp i) 245 | (let* ((x (elt *backtrace* i)) 246 | (name (si::frs-tag f))) 247 | (unless (si::fixnump name) 248 | (push name (third x))))))) 249 | (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) 250 | (setf *tmp* *backtrace*) 251 | (set-break-env) 252 | (set-current-ihs) 253 | (let ((*ihs-base* *ihs-top*)) 254 | (funcall debugger-loop-fn)))) 255 | 256 | (defimplementation call-with-debugger-hook (hook fun) 257 | (let ((*debugger-hook* hook) 258 | (*ihs-base*(si::ihs-top 'call-with-debugger-hook))) 259 | (funcall fun))) 260 | 261 | (defimplementation compute-backtrace (start end) 262 | (when (numberp end) 263 | (setf end (min end (length *backtrace*)))) 264 | (loop for f in (subseq *backtrace* start end) 265 | collect f)) 266 | 267 | (defun frame-name (frame) 268 | (let ((x (first frame))) 269 | (if (symbolp x) 270 | x 271 | (function-name x)))) 272 | 273 | (defun function-position (fun) 274 | (multiple-value-bind (file position) 275 | (si::bc-file fun) 276 | (and file (make-location `(:file ,file) `(:position ,position))))) 277 | 278 | (defun frame-function (frame) 279 | (let* ((x (first frame)) 280 | fun position) 281 | (etypecase x 282 | (symbol (and (fboundp x) 283 | (setf fun (fdefinition x) 284 | position (function-position fun)))) 285 | (function (setf fun x position (function-position x)))) 286 | (values fun position))) 287 | 288 | (defun frame-decode-env (frame) 289 | (let ((functions '()) 290 | (blocks '()) 291 | (variables '())) 292 | (dolist (record (second frame)) 293 | (let* ((record0 (car record)) 294 | (record1 (cdr record))) 295 | (cond ((symbolp record0) 296 | (setq variables (acons record0 record1 variables))) 297 | ((not (si::fixnump record0)) 298 | (push record1 functions)) 299 | ((symbolp record1) 300 | (push record1 blocks)) 301 | (t 302 | )))) 303 | (values functions blocks variables))) 304 | 305 | (defimplementation print-frame (frame stream) 306 | (format stream "~A" (first frame))) 307 | 308 | (defimplementation frame-source-location-for-emacs (frame-number) 309 | (nth-value 1 (frame-function (elt *backtrace* frame-number)))) 310 | 311 | (defimplementation frame-catch-tags (frame-number) 312 | (third (elt *backtrace* frame-number))) 313 | 314 | (defimplementation frame-locals (frame-number) 315 | (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) 316 | with i = 0 317 | collect (list :name name :id (prog1 i (incf i)) :value value))) 318 | 319 | (defimplementation frame-var-value (frame-number var-id) 320 | (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) 321 | var-id)) 322 | 323 | (defimplementation disassemble-frame (frame-number) 324 | (let ((fun (frame-fun (elt *backtrace* frame-number)))) 325 | (disassemble fun))) 326 | 327 | (defimplementation eval-in-frame (form frame-number) 328 | (let ((env (second (elt *backtrace* frame-number)))) 329 | (si:eval-with-env form env))) 330 | 331 | ;;;; Inspector 332 | 333 | (defmethod emacs-inspect ((o t)) 334 | ; ecl clos support leaves some to be desired 335 | (cond 336 | ((streamp o) 337 | (list* 338 | (format nil "~S is an ordinary stream~%" o) 339 | (append 340 | (list 341 | "Open for " 342 | (cond 343 | ((ignore-errors (interactive-stream-p o)) "Interactive") 344 | ((and (input-stream-p o) (output-stream-p o)) "Input and output") 345 | ((input-stream-p o) "Input") 346 | ((output-stream-p o) "Output")) 347 | `(:newline) `(:newline)) 348 | (label-value-line* 349 | ("Element type" (stream-element-type o)) 350 | ("External format" (stream-external-format o))) 351 | (ignore-errors (label-value-line* 352 | ("Broadcast streams" (broadcast-stream-streams o)))) 353 | (ignore-errors (label-value-line* 354 | ("Concatenated streams" (concatenated-stream-streams o)))) 355 | (ignore-errors (label-value-line* 356 | ("Echo input stream" (echo-stream-input-stream o)))) 357 | (ignore-errors (label-value-line* 358 | ("Echo output stream" (echo-stream-output-stream o)))) 359 | (ignore-errors (label-value-line* 360 | ("Output String" (get-output-stream-string o)))) 361 | (ignore-errors (label-value-line* 362 | ("Synonym symbol" (synonym-stream-symbol o)))) 363 | (ignore-errors (label-value-line* 364 | ("Input stream" (two-way-stream-input-stream o)))) 365 | (ignore-errors (label-value-line* 366 | ("Output stream" (two-way-stream-output-stream o))))))) 367 | (t 368 | (let* ((cl (si:instance-class o)) 369 | (slots (clos:class-slots cl))) 370 | (list* (format nil "~S is an instance of class ~A~%" 371 | o (clos::class-name cl)) 372 | (loop for x in slots append 373 | (let* ((name (clos:slot-definition-name x)) 374 | (value (clos::slot-value o name))) 375 | (list 376 | (format nil "~S: " name) 377 | `(:value ,value) 378 | `(:newline))))))))) 379 | 380 | ;;;; Definitions 381 | 382 | (defimplementation find-definitions (name) 383 | (if (fboundp name) 384 | (let ((tmp (find-source-location (symbol-function name)))) 385 | `(((defun ,name) ,tmp))))) 386 | 387 | (defimplementation find-source-location (obj) 388 | (setf *tmp* obj) 389 | (or 390 | (typecase obj 391 | (function 392 | (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj)) 393 | (if (and file pos) 394 | (make-location 395 | `(:file ,(namestring file)) 396 | `(:position ,pos) 397 | `(:snippet 398 | ,(with-open-file (s file) 399 | (skip-toplevel-forms pos s) 400 | (skip-comments-and-whitespace s) 401 | (read-snippet s)))))))) 402 | `(:error (format nil "Source definition of ~S not found" obj)))) 403 | 404 | ;;;; Threads 405 | 406 | #+threads 407 | (progn 408 | (defvar *thread-id-counter* 0) 409 | 410 | (defvar *thread-id-counter-lock* 411 | (mp:make-lock :name "thread id counter lock")) 412 | 413 | (defun next-thread-id () 414 | (mp:with-lock (*thread-id-counter-lock*) 415 | (incf *thread-id-counter*))) 416 | 417 | (defparameter *thread-id-map* (make-hash-table)) 418 | (defparameter *id-thread-map* (make-hash-table)) 419 | 420 | (defvar *thread-id-map-lock* 421 | (mp:make-lock :name "thread id map lock")) 422 | 423 | ; ecl doesn't have weak pointers 424 | (defimplementation spawn (fn &key name) 425 | (let ((thread (mp:make-process :name name)) 426 | (id (next-thread-id))) 427 | (mp:process-preset 428 | thread 429 | #'(lambda () 430 | (unwind-protect 431 | (mp:with-lock (*thread-id-map-lock*) 432 | (setf (gethash id *thread-id-map*) thread) 433 | (setf (gethash thread *id-thread-map*) id)) 434 | (funcall fn) 435 | (mp:with-lock (*thread-id-map-lock*) 436 | (remhash thread *id-thread-map*) 437 | (remhash id *thread-id-map*))))) 438 | (mp:process-enable thread))) 439 | 440 | (defimplementation thread-id (thread) 441 | (block thread-id 442 | (mp:with-lock (*thread-id-map-lock*) 443 | (or (gethash thread *id-thread-map*) 444 | (let ((id (next-thread-id))) 445 | (setf (gethash id *thread-id-map*) thread) 446 | (setf (gethash thread *id-thread-map*) id) 447 | id))))) 448 | 449 | (defimplementation find-thread (id) 450 | (mp:with-lock (*thread-id-map-lock*) 451 | (gethash id *thread-id-map*))) 452 | 453 | (defimplementation thread-name (thread) 454 | (mp:process-name thread)) 455 | 456 | (defimplementation thread-status (thread) 457 | (if (mp:process-active-p thread) 458 | "RUNNING" 459 | "STOPPED")) 460 | 461 | (defimplementation make-lock (&key name) 462 | (mp:make-lock :name name)) 463 | 464 | (defimplementation call-with-lock-held (lock function) 465 | (declare (type function function)) 466 | (mp:with-lock (lock) (funcall function))) 467 | 468 | (defimplementation current-thread () 469 | mp:*current-process*) 470 | 471 | (defimplementation all-threads () 472 | (mp:all-processes)) 473 | 474 | (defimplementation interrupt-thread (thread fn) 475 | (mp:interrupt-process thread fn)) 476 | 477 | (defimplementation kill-thread (thread) 478 | (mp:process-kill thread)) 479 | 480 | (defimplementation thread-alive-p (thread) 481 | (mp:process-active-p thread)) 482 | 483 | (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) 484 | 485 | (defstruct (mailbox (:conc-name mailbox.)) 486 | (mutex (mp:make-lock :name "process mailbox")) 487 | (queue '() :type list)) 488 | 489 | (defun mailbox (thread) 490 | "Return THREAD's mailbox." 491 | (mp:with-lock (*mailbox-lock*) 492 | (or (find thread *mailboxes* :key #'mailbox.thread) 493 | (let ((mb (make-mailbox :thread thread))) 494 | (push mb *mailboxes*) 495 | mb)))) 496 | 497 | (defimplementation send (thread message) 498 | (let* ((mbox (mailbox thread)) 499 | (mutex (mailbox.mutex mbox))) 500 | (mp:interrupt-process 501 | thread 502 | (lambda () 503 | (mp:with-lock (mutex) 504 | (setf (mailbox.queue mbox) 505 | (nconc (mailbox.queue mbox) (list message)))))))) 506 | 507 | (defimplementation receive () 508 | (block got-mail 509 | (let* ((mbox (mailbox mp:*current-process*)) 510 | (mutex (mailbox.mutex mbox))) 511 | (loop 512 | (mp:with-lock (mutex) 513 | (if (mailbox.queue mbox) 514 | (return-from got-mail (pop (mailbox.queue mbox))))) 515 | ;interrupt-process will halt this if it takes longer than 1sec 516 | (sleep 1))))) 517 | 518 | (defmethod stream-finish-output ((stream stream)) 519 | (finish-output stream)) 520 | 521 | ) 522 | 523 | -------------------------------------------------------------------------------- /lispworks.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME. 4 | ;;; 5 | ;;; Created 2003, Helmut Eller 6 | ;;; 7 | ;;; This code has been placed in the Public Domain. All warranties 8 | ;;; are disclaimed. 9 | ;;; 10 | 11 | (in-package :conium) 12 | 13 | (eval-when (:compile-toplevel :execute :load-toplevel) 14 | (defvar *original-defimplementation* (macro-function 'defimplementation)) 15 | (defmacro defimplementation (&whole whole name args &body body 16 | &environment env) 17 | (declare (ignore args body)) 18 | `(progn 19 | (dspec:record-definition '(defun ,name) (dspec:location) 20 | :check-redefinition-p nil) 21 | ,(funcall *original-defimplementation* whole env)))) 22 | 23 | (defun make-flexi-stream (stream external-format) 24 | (unless (member :flexi-streams *features*) 25 | (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp." 26 | external-format)) 27 | (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM") 28 | stream 29 | :external-format 30 | (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") 31 | external-format))) 32 | 33 | ;;; Coding Systems 34 | 35 | (defun valid-external-format-p (external-format) 36 | (member external-format *external-format-to-coding-system* 37 | :test #'equal :key #'car)) 38 | 39 | (defvar *external-format-to-coding-system* 40 | '(((:latin-1 :eol-style :lf) 41 | "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") 42 | ((:latin-1) 43 | "latin-1" "iso-latin-1" "iso-8859-1") 44 | ((:utf-8) "utf-8") 45 | ((:utf-8 :eol-style :lf) "utf-8-unix") 46 | ((:euc-jp) "euc-jp") 47 | ((:euc-jp :eol-style :lf) "euc-jp-unix") 48 | ((:ascii) "us-ascii") 49 | ((:ascii :eol-style :lf) "us-ascii-unix"))) 50 | 51 | (defimplementation find-external-format (coding-system) 52 | (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 53 | *external-format-to-coding-system*))) 54 | 55 | ;;; Unix signals 56 | 57 | (defun sigint-handler () 58 | (with-simple-restart (continue "Continue from SIGINT handler.") 59 | (invoke-debugger "SIGINT"))) 60 | 61 | (defun make-sigint-handler (process) 62 | (lambda (&rest args) 63 | (declare (ignore args)) 64 | (mp:process-interrupt process #'sigint-handler))) 65 | 66 | (defun set-sigint-handler () 67 | ;; Set SIGINT handler on Swank request handler thread. 68 | #-win32 69 | (sys::set-signal-handler +sigint+ 70 | (make-sigint-handler mp:*current-process*))) 71 | 72 | #-win32 73 | (defimplementation install-sigint-handler (handler) 74 | (sys::set-signal-handler +sigint+ 75 | (let ((self mp:*current-process*)) 76 | (lambda (&rest args) 77 | (declare (ignore args)) 78 | (mp:process-interrupt self handler))))) 79 | 80 | (defimplementation call-without-interrupts (fn) 81 | (lw:without-interrupts (funcall fn))) 82 | 83 | (defimplementation getpid () 84 | #+win32 (win32:get-current-process-id) 85 | #-win32 (system::getpid)) 86 | 87 | (defimplementation lisp-implementation-type-name () 88 | "lispworks") 89 | 90 | (defimplementation set-default-directory (directory) 91 | (namestring (hcl:change-directory directory))) 92 | 93 | ;;;; Documentation 94 | 95 | (defimplementation arglist (symbol-or-function) 96 | (let ((arglist (lw:function-lambda-list symbol-or-function))) 97 | (etypecase arglist 98 | ((member :dont-know) 99 | :not-available) 100 | (list 101 | arglist)))) 102 | 103 | (defimplementation function-name (function) 104 | (nth-value 2 (function-lambda-expression function))) 105 | 106 | (defimplementation macroexpand-all (form) 107 | (walker:walk-form form)) 108 | 109 | (defun generic-function-p (object) 110 | (typep object 'generic-function)) 111 | 112 | (defimplementation describe-symbol-for-emacs (symbol) 113 | "Return a plist describing SYMBOL. 114 | Return NIL if the symbol is unbound." 115 | (let ((result '())) 116 | (labels ((first-line (string) 117 | (let ((pos (position #\newline string))) 118 | (if (null pos) string (subseq string 0 pos)))) 119 | (doc (kind &optional (sym symbol)) 120 | (let ((string (or (documentation sym kind)))) 121 | (if string 122 | (first-line string) 123 | :not-documented))) 124 | (maybe-push (property value) 125 | (when value 126 | (setf result (list* property value result))))) 127 | (maybe-push 128 | :variable (when (boundp symbol) 129 | (doc 'variable))) 130 | (maybe-push 131 | :generic-function (if (and (fboundp symbol) 132 | (generic-function-p (fdefinition symbol))) 133 | (doc 'function))) 134 | (maybe-push 135 | :function (if (and (fboundp symbol) 136 | (not (generic-function-p (fdefinition symbol)))) 137 | (doc 'function))) 138 | (maybe-push 139 | :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol)))) 140 | (if (fboundp setf-name) 141 | (doc 'setf)))) 142 | (maybe-push 143 | :class (if (find-class symbol nil) 144 | (doc 'class))) 145 | result))) 146 | 147 | (defimplementation describe-definition (symbol type) 148 | (ecase type 149 | (:variable (describe-symbol symbol)) 150 | (:class (describe (find-class symbol))) 151 | ((:function :generic-function) (describe-function symbol)) 152 | (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol)))))) 153 | 154 | (defun describe-function (symbol) 155 | (cond ((fboundp symbol) 156 | (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%" 157 | symbol 158 | (lispworks:function-lambda-list symbol) 159 | (documentation symbol 'function)) 160 | (describe (fdefinition symbol))) 161 | (t (format t "~S is not fbound" symbol)))) 162 | 163 | (defun describe-symbol (sym) 164 | (format t "~A is a symbol in package ~A." sym (symbol-package sym)) 165 | (when (boundp sym) 166 | (format t "~%~%Value: ~A" (symbol-value sym))) 167 | (let ((doc (documentation sym 'variable))) 168 | (when doc 169 | (format t "~%~%Variable documentation:~%~A" doc))) 170 | (when (fboundp sym) 171 | (describe-function sym))) 172 | 173 | ;;; Debugging 174 | 175 | (defclass slime-env (env:environment) 176 | ((debugger-hook :initarg :debugger-hoook))) 177 | 178 | (defun slime-env (hook io-bindings) 179 | (make-instance 'slime-env :name "SLIME Environment" 180 | :io-bindings io-bindings 181 | :debugger-hoook hook)) 182 | 183 | (defmethod env-internals:environment-display-notifier 184 | ((env slime-env) &key restarts condition) 185 | (declare (ignore restarts condition)) 186 | (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*) 187 | ;; nil 188 | ) 189 | 190 | (defmethod env-internals:environment-display-debugger ((env slime-env)) 191 | *debug-io*) 192 | 193 | (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) 194 | (apply (swank-sym :y-or-n-p-in-emacs) msg args)) 195 | 196 | (defimplementation call-with-debugger-hook (hook fun) 197 | (let ((*debugger-hook* hook)) 198 | (env:with-environment ((slime-env hook '())) 199 | (funcall fun)))) 200 | 201 | (defimplementation install-debugger-globally (function) 202 | (setq *debugger-hook* function) 203 | (setf (env:environment) (slime-env function '()))) 204 | 205 | (defvar *sldb-top-frame*) 206 | 207 | (defun interesting-frame-p (frame) 208 | (cond ((or (dbg::call-frame-p frame) 209 | (dbg::derived-call-frame-p frame) 210 | (dbg::foreign-frame-p frame) 211 | (dbg::interpreted-call-frame-p frame)) 212 | t) 213 | ((dbg::catch-frame-p frame) dbg:*print-catch-frames*) 214 | ((dbg::binding-frame-p frame) dbg:*print-binding-frames*) 215 | ((dbg::handler-frame-p frame) dbg:*print-handler-frames*) 216 | ((dbg::restart-frame-p frame) dbg:*print-restart-frames*) 217 | ((dbg::open-frame-p frame) dbg:*print-open-frames*) 218 | (t nil))) 219 | 220 | (defun nth-next-frame (frame n) 221 | "Unwind FRAME N times." 222 | (do ((frame frame (dbg::frame-next frame)) 223 | (i n (if (interesting-frame-p frame) (1- i) i))) 224 | ((or (not frame) 225 | (and (interesting-frame-p frame) (zerop i))) 226 | frame))) 227 | 228 | (defun nth-frame (index) 229 | (nth-next-frame *sldb-top-frame* index)) 230 | 231 | (defun find-top-frame () 232 | "Return the most suitable top-frame for the debugger." 233 | (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*) 234 | (nth-next-frame frame 1))) 235 | ((or (null frame) ; no frame found! 236 | (and (dbg::call-frame-p frame) 237 | (eq (dbg::call-frame-function-name frame) 238 | 'invoke-debugger))) 239 | (nth-next-frame frame 1))) 240 | ;; if we can't find a invoke-debugger frame, take any old frame at the top 241 | (dbg::debugger-stack-current-frame dbg::*debugger-stack*))) 242 | 243 | (defimplementation call-with-debugging-environment (fn) 244 | (dbg::with-debugger-stack () 245 | (let ((*sldb-top-frame* (find-top-frame))) 246 | (funcall fn)))) 247 | 248 | (defimplementation compute-backtrace (start end) 249 | (let ((end (or end most-positive-fixnum)) 250 | (backtrace '())) 251 | (do ((frame (nth-frame start) (dbg::frame-next frame)) 252 | (i start)) 253 | ((or (not frame) (= i end)) (nreverse backtrace)) 254 | (when (interesting-frame-p frame) 255 | (incf i) 256 | (push frame backtrace))))) 257 | 258 | (defun frame-actual-args (frame) 259 | (let ((*break-on-signals* nil)) 260 | (mapcar (lambda (arg) 261 | (case arg 262 | ((&rest &optional &key) arg) 263 | (t 264 | (handler-case (dbg::dbg-eval arg frame) 265 | (error (e) (format nil "<~A>" arg)))))) 266 | (dbg::call-frame-arglist frame)))) 267 | 268 | (defimplementation print-frame (frame stream) 269 | (cond ((dbg::call-frame-p frame) 270 | (format stream "~S ~S" 271 | (dbg::call-frame-function-name frame) 272 | (frame-actual-args frame))) 273 | (t (princ frame stream)))) 274 | 275 | (defun frame-vars (frame) 276 | (first (dbg::frame-locals-format-list frame #'list 75 0))) 277 | 278 | (defimplementation frame-locals (n) 279 | (let ((frame (nth-frame n))) 280 | (if (dbg::call-frame-p frame) 281 | (mapcar (lambda (var) 282 | (destructuring-bind (name value symbol location) var 283 | (declare (ignore name location)) 284 | (list :name symbol :id 0 285 | :value value))) 286 | (frame-vars frame))))) 287 | 288 | (defimplementation frame-var-value (frame var) 289 | (let ((frame (nth-frame frame))) 290 | (destructuring-bind (_n value _s _l) (nth var (frame-vars frame)) 291 | (declare (ignore _n _s _l)) 292 | value))) 293 | 294 | (defimplementation frame-source-location-for-emacs (frame) 295 | (let ((frame (nth-frame frame)) 296 | (callee (if (plusp frame) (nth-frame (1- frame))))) 297 | (if (dbg::call-frame-p frame) 298 | (let ((dspec (dbg::call-frame-function-name frame)) 299 | (cname (and (dbg::call-frame-p callee) 300 | (dbg::call-frame-function-name callee)))) 301 | (if dspec 302 | (frame-location dspec cname)))))) 303 | 304 | (defimplementation eval-in-frame (form frame-number) 305 | (let ((frame (nth-frame frame-number))) 306 | (dbg::dbg-eval form frame))) 307 | 308 | (defimplementation return-from-frame (frame-number form) 309 | (let* ((frame (nth-frame frame-number)) 310 | (return-frame (dbg::find-frame-for-return frame))) 311 | (dbg::dbg-return-from-call-frame frame form return-frame 312 | dbg::*debugger-stack*))) 313 | 314 | (defimplementation restart-frame (frame-number) 315 | (let ((frame (nth-frame frame-number))) 316 | (dbg::restart-frame frame :same-args t))) 317 | 318 | (defimplementation disassemble-frame (frame-number) 319 | (let* ((frame (nth-frame frame-number))) 320 | (when (dbg::call-frame-p frame) 321 | (let ((function (dbg::get-call-frame-function frame))) 322 | (disassemble function))))) 323 | 324 | ;;; Definition finding 325 | 326 | (defun frame-location (dspec callee-name) 327 | (let ((infos (dspec:find-dspec-locations dspec))) 328 | (cond (infos 329 | (destructuring-bind ((rdspec location) &rest _) infos 330 | (declare (ignore _)) 331 | (let ((name (and callee-name (symbolp callee-name) 332 | (string callee-name)))) 333 | (make-dspec-location rdspec location 334 | `(:call-site ,name))))) 335 | (t 336 | (list :error (format nil "Source location not available for: ~S" 337 | dspec)))))) 338 | 339 | (defimplementation find-definitions (name) 340 | (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) 341 | (loop for (dspec location) in locations 342 | collect (list dspec (make-dspec-location dspec location))))) 343 | 344 | 345 | ;;; Compilation 346 | 347 | (defmacro with-swank-compilation-unit ((location &rest options) &body body) 348 | (lw:rebinding (location) 349 | `(let ((compiler::*error-database* '())) 350 | (with-compilation-unit ,options 351 | (multiple-value-prog1 (progn ,@body) 352 | (signal-error-data-base compiler::*error-database* 353 | ,location) 354 | (signal-undefined-functions compiler::*unknown-functions* 355 | ,location)))))) 356 | 357 | (defimplementation swank-compile-file (input-file output-file 358 | load-p external-format) 359 | (with-swank-compilation-unit (input-file) 360 | (compile-file input-file 361 | :output-file output-file 362 | :load load-p 363 | :external-format external-format))) 364 | 365 | (defvar *within-call-with-compilation-hooks* nil 366 | "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") 367 | 368 | (defvar *undefined-functions-hash* nil 369 | "Hash table to map info about undefined functions to pathnames.") 370 | 371 | (lw:defadvice (compile-file compile-file-and-collect-notes :around) 372 | (pathname &rest rest) 373 | (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest) 374 | (when *within-call-with-compilation-hooks* 375 | (maphash (lambda (unfun dspecs) 376 | (dolist (dspec dspecs) 377 | (let ((unfun-info (list unfun dspec))) 378 | (unless (gethash unfun-info *undefined-functions-hash*) 379 | (setf (gethash unfun-info *undefined-functions-hash*) 380 | pathname))))) 381 | compiler::*unknown-functions*)))) 382 | 383 | (defimplementation call-with-compilation-hooks (function) 384 | (let ((compiler::*error-database* '()) 385 | (*undefined-functions-hash* (make-hash-table :test 'equal)) 386 | (*within-call-with-compilation-hooks* t)) 387 | (with-compilation-unit () 388 | (prog1 (funcall function) 389 | (signal-error-data-base compiler::*error-database*) 390 | (signal-undefined-functions compiler::*unknown-functions*))))) 391 | 392 | (defun map-error-database (database fn) 393 | (loop for (filename . defs) in database do 394 | (loop for (dspec . conditions) in defs do 395 | (dolist (c conditions) 396 | (funcall fn filename dspec (if (consp c) (car c) c)))))) 397 | 398 | (defun lispworks-severity (condition) 399 | (cond ((not condition) :warning) 400 | (t (etypecase condition 401 | (error :error) 402 | (style-warning :warning) 403 | (warning :warning))))) 404 | 405 | (defun signal-compiler-condition (message location condition) 406 | (check-type message string) 407 | (signal 408 | (make-instance 'compiler-condition :message message 409 | :severity (lispworks-severity condition) 410 | :location location 411 | :original-condition condition))) 412 | 413 | (defvar *temp-file-format* '(:utf-8 :eol-style :lf)) 414 | 415 | (defun compile-from-temp-file (string filename) 416 | (unwind-protect 417 | (progn 418 | (with-open-file (s filename :direction :output 419 | :if-exists :supersede 420 | :external-format *temp-file-format*) 421 | 422 | (write-string string s) 423 | (finish-output s)) 424 | (multiple-value-bind (binary-filename warnings? failure?) 425 | (compile-file filename :load t 426 | :external-format *temp-file-format*) 427 | (declare (ignore warnings?)) 428 | (when binary-filename 429 | (delete-file binary-filename)) 430 | (not failure?))) 431 | (delete-file filename))) 432 | 433 | (defun dspec-function-name-position (dspec fallback) 434 | (etypecase dspec 435 | (cons (let ((name (dspec:dspec-primary-name dspec))) 436 | (typecase name 437 | ((or symbol string) 438 | (list :function-name (string name))) 439 | (t fallback)))) 440 | (null fallback) 441 | (symbol (list :function-name (string dspec))))) 442 | 443 | (defmacro with-fairly-standard-io-syntax (&body body) 444 | "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*." 445 | (let ((package (gensym)) 446 | (readtable (gensym))) 447 | `(let ((,package *package*) 448 | (,readtable *readtable*)) 449 | (with-standard-io-syntax 450 | (let ((*package* ,package) 451 | (*readtable* ,readtable)) 452 | ,@body))))) 453 | 454 | (defun skip-comments (stream) 455 | (let ((pos0 (file-position stream))) 456 | (cond ((equal (ignore-errors (list (read-delimited-list #\( stream))) 457 | '(())) 458 | (file-position stream (1- (file-position stream)))) 459 | (t (file-position stream pos0))))) 460 | 461 | #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3 462 | (defun dspec-stream-position (stream dspec) 463 | (with-fairly-standard-io-syntax 464 | (loop (let* ((pos (progn (skip-comments stream) (file-position stream))) 465 | (form (read stream nil '#1=#:eof))) 466 | (when (eq form '#1#) 467 | (return nil)) 468 | (labels ((check-dspec (form) 469 | (when (consp form) 470 | (let ((operator (car form))) 471 | (case operator 472 | ((progn) 473 | (mapcar #'check-dspec 474 | (cdr form))) 475 | ((eval-when locally macrolet symbol-macrolet) 476 | (mapcar #'check-dspec 477 | (cddr form))) 478 | ((in-package) 479 | (let ((package (find-package (second form)))) 480 | (when package 481 | (setq *package* package)))) 482 | (otherwise 483 | (let ((form-dspec (dspec:parse-form-dspec form))) 484 | (when (dspec:dspec-equal dspec form-dspec) 485 | (return pos))))))))) 486 | (check-dspec form)))))) 487 | 488 | (defun dspec-file-position (file dspec) 489 | (let* ((*compile-file-pathname* (pathname file)) 490 | (*compile-file-truename* (truename *compile-file-pathname*)) 491 | (*load-pathname* *compile-file-pathname*) 492 | (*load-truename* *compile-file-truename*)) 493 | (with-open-file (stream file) 494 | (let ((pos 495 | #-(or lispworks4.1 lispworks4.2) 496 | (dspec-stream-position stream dspec))) 497 | (if pos 498 | (list :position (1+ pos)) 499 | (dspec-function-name-position dspec `(:position 1))))))) 500 | 501 | (defun emacs-buffer-location-p (location) 502 | (and (consp location) 503 | (eq (car location) :emacs-buffer))) 504 | 505 | (defun make-dspec-location (dspec location &optional hints) 506 | (etypecase location 507 | ((or pathname string) 508 | (multiple-value-bind (file err) 509 | (ignore-errors (namestring (truename location))) 510 | (if err 511 | (list :error (princ-to-string err)) 512 | (make-location `(:file ,file) 513 | (dspec-file-position file dspec) 514 | hints)))) 515 | (symbol 516 | `(:error ,(format nil "Cannot resolve location: ~S" location))) 517 | ((satisfies emacs-buffer-location-p) 518 | (destructuring-bind (_ buffer offset string) location 519 | (declare (ignore _ string)) 520 | (make-location `(:buffer ,buffer) 521 | (dspec-function-name-position dspec `(:offset ,offset 0)) 522 | hints))))) 523 | 524 | (defun make-dspec-progenitor-location (dspec location) 525 | (let ((canon-dspec (dspec:canonicalize-dspec dspec))) 526 | (make-dspec-location 527 | (if canon-dspec 528 | (if (dspec:local-dspec-p canon-dspec) 529 | (dspec:dspec-progenitor canon-dspec) 530 | canon-dspec) 531 | nil) 532 | location))) 533 | 534 | (defun signal-error-data-base (database &optional location) 535 | (map-error-database 536 | database 537 | (lambda (filename dspec condition) 538 | (signal-compiler-condition 539 | (format nil "~A" condition) 540 | (make-dspec-progenitor-location dspec (or location filename)) 541 | condition)))) 542 | 543 | (defun unmangle-unfun (symbol) 544 | "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to 545 | function names like \(SETF GET)." 546 | (cond ((sys::setf-symbol-p symbol) 547 | (sys::setf-pair-from-underlying-name symbol)) 548 | (t symbol))) 549 | 550 | (defun signal-undefined-functions (htab &optional filename) 551 | (maphash (lambda (unfun dspecs) 552 | (dolist (dspec dspecs) 553 | (signal-compiler-condition 554 | (format nil "Undefined function ~A" (unmangle-unfun unfun)) 555 | (make-dspec-progenitor-location dspec 556 | (or filename 557 | (gethash (list unfun dspec) 558 | *undefined-functions-hash*))) 559 | nil))) 560 | htab)) 561 | 562 | (defimplementation swank-compile-string (string &key buffer position filename 563 | policy) 564 | (declare (ignore filename policy)) 565 | (assert buffer) 566 | (assert position) 567 | (let* ((location (list :emacs-buffer buffer position string)) 568 | (tmpname (hcl:make-temp-file nil "lisp"))) 569 | (with-swank-compilation-unit (location) 570 | (compile-from-temp-file 571 | (with-output-to-string (s) 572 | (let ((*print-radix* t)) 573 | (print `(eval-when (:compile-toplevel) 574 | (setq dspec::*location* (list ,@location))) 575 | s)) 576 | (write-string string s)) 577 | tmpname)))) 578 | 579 | ;;; xref 580 | 581 | (defmacro defxref (name function) 582 | `(defimplementation ,name (name) 583 | (xref-results (,function name)))) 584 | 585 | (defxref who-calls hcl:who-calls) 586 | (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too 587 | (defxref calls-who hcl:calls-who) 588 | (defxref list-callers list-callers-internal) 589 | ;; (defxref list-callees list-callees-internal) 590 | 591 | (defun list-callers-internal (name) 592 | (let ((callers (make-array 100 593 | :fill-pointer 0 594 | :adjustable t))) 595 | (hcl:sweep-all-objects 596 | #'(lambda (object) 597 | (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object) 598 | #-Harlequin-PC-Lisp (sys::callablep object) 599 | (system::find-constant$funcallable name object)) 600 | (vector-push-extend object callers)))) 601 | ;; Delay dspec:object-dspec until after sweep-all-objects 602 | ;; to reduce allocation problems. 603 | (loop for object across callers 604 | collect (if (symbolp object) 605 | (list 'function object) 606 | (or (dspec:object-dspec object) object))))) 607 | 608 | ;; only for lispworks 4.2 and above 609 | #-lispworks4.1 610 | (progn 611 | (defxref who-references hcl:who-references) 612 | (defxref who-binds hcl:who-binds) 613 | (defxref who-sets hcl:who-sets)) 614 | 615 | (defimplementation who-specializes (classname) 616 | (let ((methods (clos:class-direct-methods (find-class classname)))) 617 | (xref-results (mapcar #'dspec:object-dspec methods)))) 618 | 619 | (defun xref-results (dspecs) 620 | (flet ((frob-locs (dspec locs) 621 | (cond (locs 622 | (loop for (name loc) in locs 623 | collect (list name (make-dspec-location name loc)))) 624 | (t `((,dspec (:error "Source location not available"))))))) 625 | (loop for dspec in dspecs 626 | append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) 627 | 628 | ;;; Inspector 629 | 630 | (defmethod emacs-inspect ((o t)) 631 | (lispworks-inspect o)) 632 | 633 | (defmethod emacs-inspect ((o function)) 634 | (lispworks-inspect o)) 635 | 636 | ;; FIXME: slot-boundp-using-class in LW works with names so we can't 637 | ;; use our method in swank.lisp. 638 | (defmethod emacs-inspect ((o standard-object)) 639 | (lispworks-inspect o)) 640 | 641 | (defun lispworks-inspect (o) 642 | (multiple-value-bind (names values _getter _setter type) 643 | (lw:get-inspector-values o nil) 644 | (declare (ignore _getter _setter)) 645 | (append 646 | (label-value-line "Type" type) 647 | (loop for name in names 648 | for value in values 649 | append (label-value-line name value))))) 650 | 651 | ;;; Miscellaneous 652 | 653 | (defimplementation quit-lisp () 654 | (lispworks:quit)) 655 | 656 | ;;; Tracing 657 | 658 | (defun parse-fspec (fspec) 659 | "Return a dspec for FSPEC." 660 | (ecase (car fspec) 661 | ((:defmethod) `(method ,(cdr fspec))))) 662 | 663 | (defun tracedp (dspec) 664 | (member dspec (eval '(trace)) :test #'equal)) 665 | 666 | (defun toggle-trace-aux (dspec) 667 | (cond ((tracedp dspec) 668 | (eval `(untrace ,dspec)) 669 | (format nil "~S is now untraced." dspec)) 670 | (t 671 | (eval `(trace (,dspec))) 672 | (format nil "~S is now traced." dspec)))) 673 | 674 | (defimplementation toggle-trace (fspec) 675 | (toggle-trace-aux (parse-fspec fspec))) 676 | 677 | (defimplementation set-default-initial-binding (var form) 678 | (setq mp:*process-initial-bindings* 679 | (acons var `(eval (quote ,form)) 680 | mp:*process-initial-bindings* ))) 681 | 682 | ;;; Some intergration with the lispworks environment 683 | 684 | (defun swank-sym (name) (find-symbol (string name) :swank)) 685 | 686 | 687 | ;;;; Weak hashtables 688 | 689 | (defimplementation make-weak-key-hash-table (&rest args) 690 | (apply #'make-hash-table :weak-kind :key args)) 691 | 692 | (defimplementation make-weak-value-hash-table (&rest args) 693 | (apply #'make-hash-table :weak-kind :value args)) 694 | -------------------------------------------------------------------------------- /openmcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; openmcl-swank.lisp --- SLIME backend for OpenMCL. 4 | ;;; 5 | ;;; Copyright (C) 2003, James Bielman 6 | ;;; 7 | ;;; This program is licensed under the terms of the Lisp Lesser GNU 8 | ;;; Public License, known as the LLGPL, and distributed with OpenMCL 9 | ;;; as the file "LICENSE". The LLGPL consists of a preamble and the 10 | ;;; LGPL, which is distributed with OpenMCL as the file "LGPL". Where 11 | ;;; these conflict, the preamble takes precedence. 12 | ;;; 13 | ;;; The LLGPL is also available online at 14 | ;;; http://opensource.franz.com/preamble.html 15 | 16 | ;;; 17 | ;;; This is the beginning of a Slime backend for OpenMCL. It has been 18 | ;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would 19 | ;;; be interested in hearing the results with other versions. 20 | ;;; 21 | ;;; Additionally, reporting the positions of warnings accurately requires 22 | ;;; a small patch to the OpenMCL file compiler, which may be found at: 23 | ;;; 24 | ;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff 25 | ;;; 26 | ;;; Things that work: 27 | ;;; 28 | ;;; * Evaluation of forms with C-M-x. 29 | ;;; * Compilation of defuns with C-c C-c. 30 | ;;; * File compilation with C-c C-k. 31 | ;;; * Most of the debugger functionality, except EVAL-IN-FRAME, 32 | ;;; FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS. 33 | ;;; * Macroexpanding with C-c RET. 34 | ;;; * Disassembling the symbol at point with C-c M-d. 35 | ;;; * Describing symbol at point with C-c C-d. 36 | ;;; * Compiler warnings are trapped and sent to Emacs using the buffer 37 | ;;; position of the offending top level form. 38 | ;;; * Symbol completion and apropos. 39 | ;;; 40 | ;;; Things that sort of work: 41 | ;;; 42 | ;;; * WHO-CALLS is implemented but is only able to return the file a 43 | ;;; caller is defined in---source location information is not 44 | ;;; available. 45 | ;;; 46 | ;;; Things that aren't done yet: 47 | ;;; 48 | ;;; * Cross-referencing. 49 | ;;; * Due to unimplementation functionality the test suite does not 50 | ;;; run correctly (it hangs upon entering the debugger). 51 | ;;; 52 | 53 | (in-package :conium) 54 | 55 | (eval-when (:compile-toplevel :load-toplevel :execute) 56 | (require 'xref)) 57 | 58 | (defun specializer-name (spec) 59 | (etypecase spec 60 | (cons spec) 61 | (class (class-name spec)) 62 | (ccl::eql-specializer `(eql ,(ccl::eql-specializer-object spec))))) 63 | 64 | #+openmcl-unicode-strings 65 | (defvar *external-format-to-coding-system* 66 | '((:iso-8859-1 67 | "latin-1" "latin-1-unix" "iso-latin-1-unix" 68 | "iso-8859-1" "iso-8859-1-unix") 69 | (:utf-8 "utf-8" "utf-8-unix"))) 70 | 71 | #+openmcl-unicode-strings 72 | (defimplementation find-external-format (coding-system) 73 | (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 74 | *external-format-to-coding-system*))) 75 | 76 | (defimplementation emacs-connected () 77 | (setq ccl::*interactive-abort-process* ccl::*current-process*)) 78 | 79 | ;;; Unix signals 80 | 81 | (defimplementation call-without-interrupts (fn) 82 | (ccl:without-interrupts (funcall fn))) 83 | 84 | (defimplementation getpid () 85 | (ccl::getpid)) 86 | 87 | (defimplementation lisp-implementation-type-name () 88 | "ccl") 89 | 90 | ;;; Evaluation 91 | 92 | (defimplementation arglist (fname) 93 | (arglist% fname)) 94 | 95 | (defmethod arglist% ((f symbol)) 96 | (ccl:arglist f)) 97 | 98 | (defmethod arglist% ((f function)) 99 | (ccl:arglist (ccl:function-name f))) 100 | 101 | (defimplementation function-name (function) 102 | (ccl:function-name function)) 103 | 104 | ;;; Compilation 105 | 106 | (defvar *buffer-offset* nil) 107 | (defvar *buffer-name* nil) 108 | 109 | (defun condition-source-position (condition) 110 | "Return the position in the source file of a compiler condition." 111 | (+ 1 112 | (or *buffer-offset* 0) 113 | ;; alanr sometimes returned stream position nil. 114 | (or (ccl::compiler-warning-stream-position condition) 0))) 115 | 116 | 117 | (defun handle-compiler-warning (condition) 118 | "Construct a compiler note for Emacs from a compiler warning 119 | condition." 120 | (signal (make-condition 121 | 'compiler-condition 122 | :original-condition condition 123 | :message (format nil "~A" condition) 124 | :severity :warning 125 | :location 126 | (let ((position (condition-source-position condition))) 127 | (if *buffer-name* 128 | (make-location 129 | (list :buffer *buffer-name*) 130 | (list :offset position 0) 131 | (list :align t)) 132 | (if (ccl::compiler-warning-file-name condition) 133 | (make-location 134 | (list :file (namestring (truename (ccl::compiler-warning-file-name condition)))) 135 | (list :position position) 136 | (list :align t)))))))) 137 | 138 | (defun temp-file-name () 139 | "Return a temporary file name to compile strings into." 140 | (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr)))) 141 | 142 | (defimplementation call-with-compilation-hooks (function) 143 | (handler-bind ((ccl::compiler-warning 'handle-compiler-warning)) 144 | (funcall function))) 145 | 146 | (defimplementation swank-compile-file (input-file output-file 147 | load-p external-format) 148 | (declare (ignore external-format)) 149 | (with-compilation-hooks () 150 | (let ((*buffer-name* nil) 151 | (*buffer-offset* nil)) 152 | (compile-file input-file 153 | :output-file output-file 154 | :load load-p)))) 155 | 156 | (defun xref-locations (relation name &optional (inverse nil)) 157 | (flet ((function-source-location (entry) 158 | (multiple-value-bind (info name) 159 | (ccl::edit-definition-p 160 | (ccl::%db-key-from-xref-entry entry) 161 | (if (eql (ccl::xref-entry-type entry) 162 | 'macro) 163 | 'function 164 | (ccl::xref-entry-type entry))) 165 | (cond ((not info) 166 | (list :error 167 | (format nil "No source info available for ~A" 168 | (ccl::xref-entry-name entry)))) 169 | ((typep (caar info) 'ccl::method) 170 | `(:location 171 | (:file ,(remove-filename-quoting 172 | (namestring (translate-logical-pathname 173 | (cdr (car info)))))) 174 | (:method 175 | ,(princ-to-string (ccl::method-name (caar info))) 176 | ,(mapcar 'princ-to-string 177 | (mapcar #'specializer-name 178 | (ccl::method-specializers 179 | (caar info)))) 180 | ,@(mapcar 'princ-to-string 181 | (ccl::method-qualifiers (caar info)))) 182 | nil)) 183 | (t 184 | (canonicalize-location (cdr (first info)) name)))))) 185 | (declare (dynamic-extent #'function-source-location)) 186 | (loop for xref in (if inverse 187 | (ccl::get-relation relation name 188 | :wild :exhaustive t) 189 | (ccl::get-relation relation 190 | :wild name :exhaustive t)) 191 | for function = (ccl::xref-entry-name xref) 192 | collect `((function ,function) 193 | ,(function-source-location xref))))) 194 | 195 | (defimplementation who-binds (name) 196 | (xref-locations :binds name)) 197 | 198 | (defimplementation who-macroexpands (name) 199 | (xref-locations :macro-calls name t)) 200 | 201 | (defimplementation who-references (name) 202 | (remove-duplicates 203 | (append (xref-locations :references name) 204 | (xref-locations :sets name) 205 | (xref-locations :binds name)) 206 | :test 'equal)) 207 | 208 | (defimplementation who-sets (name) 209 | (xref-locations :sets name)) 210 | 211 | (defimplementation who-calls (name) 212 | (remove-duplicates 213 | (append 214 | (xref-locations :direct-calls name) 215 | (xref-locations :indirect-calls name) 216 | (xref-locations :macro-calls name t)) 217 | :test 'equal)) 218 | 219 | (defimplementation list-callees (name) 220 | (remove-duplicates 221 | (append 222 | (xref-locations :direct-calls name t) 223 | (xref-locations :macro-calls name nil)) 224 | :test 'equal)) 225 | 226 | (defimplementation who-specializes (class) 227 | (if (symbolp class) (setq class (find-class class))) 228 | (remove-duplicates 229 | (append (mapcar (lambda(m) 230 | (let ((location (function-source-location (ccl::method-function m)))) 231 | (if (eq (car location) :error) 232 | (setq location nil )) 233 | `((method ,(ccl::method-name m) 234 | ,(mapcar #'specializer-name (ccl::method-specializers m)) 235 | ,@(ccl::method-qualifiers m)) 236 | ,location))) 237 | (ccl::%class.direct-methods class)) 238 | (mapcan 'who-specializes (ccl::%class-direct-subclasses class))) 239 | :test 'equal)) 240 | 241 | (defimplementation swank-compile-string (string &key buffer position filename 242 | policy) 243 | (declare (ignore policy)) 244 | (with-compilation-hooks () 245 | (let ((*buffer-name* buffer) 246 | (*buffer-offset* position) 247 | (temp-file-name (temp-file-name))) 248 | (unwind-protect 249 | (progn 250 | (with-open-file (s temp-file-name :direction :output 251 | :if-exists :error) 252 | (write-string string s)) 253 | (let ((binary-filename (compile-temp-file 254 | temp-file-name filename buffer position))) 255 | (delete-file binary-filename))) 256 | (delete-file temp-file-name))))) 257 | 258 | (defvar *temp-file-map* (make-hash-table :test #'equal) 259 | "A mapping from tempfile names to Emacs buffer names.") 260 | 261 | (defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset) 262 | (if (fboundp 'ccl::function-source-note) 263 | (compile-file temp-file-name 264 | :load t 265 | :compile-file-original-truename 266 | (or buffer-file-name 267 | (progn 268 | (setf (gethash temp-file-name *temp-file-map*) 269 | buffer-name) 270 | temp-file-name)) 271 | :compile-file-original-buffer-offset (1- offset)) 272 | (compile-file temp-file-name :load t))) 273 | 274 | ;;; Profiling (alanr: lifted from swank-clisp) 275 | 276 | (defimplementation profile (fname) 277 | (eval `(mon:monitor ,fname))) ;monitor is a macro 278 | 279 | (defimplementation profiled-functions () 280 | mon:*monitored-functions*) 281 | 282 | (defimplementation unprofile (fname) 283 | (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro 284 | 285 | (defimplementation unprofile-all () 286 | (mon:unmonitor)) 287 | 288 | (defimplementation profile-report () 289 | (mon:report-monitoring)) 290 | 291 | (defimplementation profile-reset () 292 | (mon:reset-all-monitoring)) 293 | 294 | (defimplementation profile-package (package callers-p methods) 295 | (declare (ignore callers-p methods)) 296 | (mon:monitor-all package)) 297 | 298 | ;;; Debugging 299 | 300 | (defun openmcl-set-debug-switches () 301 | (setq ccl::*fasl-save-definitions* nil) 302 | (setq ccl::*fasl-save-doc-strings* t) 303 | (setq ccl::*fasl-save-local-symbols* t) 304 | #+ppc (setq ccl::*ppc2-compiler-register-save-label* t) 305 | #+x86-64 (setq ccl::*x862-compiler-register-save-label* t) 306 | (setq ccl::*save-arglist-info* t) 307 | (setq ccl::*save-definitions* nil) 308 | (setq ccl::*save-doc-strings* t) 309 | (setq ccl::*save-local-symbols* t) 310 | (ccl::start-xref)) 311 | 312 | (defvar *sldb-stack-top* nil) 313 | (defvar *sldb-stack-top-hint* nil) 314 | (defvar *break-in-conium* nil) 315 | 316 | (defimplementation call-with-debugging-environment (debugger-loop-fn) 317 | (let* (;;(*debugger-hook* nil) 318 | (*sldb-stack-top* (or *sldb-stack-top-hint* 319 | (guess-stack-top 2))) 320 | (*sldb-stack-top-hint* nil) 321 | ;; don't let error while printing error take us down 322 | (ccl::*signal-printing-errors* nil)) 323 | (funcall debugger-loop-fn))) 324 | 325 | (defimplementation call-with-debugger-hook (hook fun) 326 | (let ((*debugger-hook* hook) 327 | (*break-in-conium* t)) 328 | (funcall fun))) 329 | 330 | (defimplementation install-debugger-globally (function) 331 | (setq *debugger-hook* function) 332 | (setq *break-in-conium* t)) 333 | 334 | (defun backtrace-context () 335 | nil) 336 | 337 | (labels ((error-entry? (frame) 338 | (let ((fun (ccl::cfp-lfun frame))) 339 | (or (eq fun #'ccl::%error) 340 | (eq fun #'ccl::%pascal-functions%))))) 341 | 342 | (defun guess-stack-top (offset) 343 | ;; search the beginning of the stack for some well known functions 344 | (do ((ctx (backtrace-context)) 345 | (result (ccl::%get-frame-ptr)) 346 | (i 0 (1+ i)) 347 | (frame (ccl::%get-frame-ptr) (ccl::parent-frame frame ctx)) 348 | (last nil frame)) 349 | (nil) 350 | (cond ((or (not frame) (or (> i (+ offset 7)))) 351 | (return result)) 352 | ((or (= i offset) (and last (error-entry? last))) 353 | (setq result frame)))))) 354 | 355 | (defun map-backtrace (function &optional 356 | (start-frame-number 0) 357 | (end-frame-number most-positive-fixnum)) 358 | "Call FUNCTION passing information about each stack frame 359 | from frames START-FRAME-NUMBER to END-FRAME-NUMBER." 360 | (let ((context (backtrace-context)) 361 | (frame-number 0) 362 | (top-stack-frame (or *sldb-stack-top* 363 | (ccl::%get-frame-ptr)))) 364 | (do ((p top-stack-frame (ccl::parent-frame p context))) 365 | ((null p)) 366 | (multiple-value-bind (lfun pc) (ccl::cfp-lfun p) 367 | (when lfun 368 | (if (and (>= frame-number start-frame-number) 369 | (< frame-number end-frame-number)) 370 | (funcall function frame-number p context lfun pc)) 371 | (incf frame-number)))))) 372 | 373 | (defun frame-arguments (p context lfun pc) 374 | "Returns a list representing the arguments of a frame." 375 | (multiple-value-bind (args types names) 376 | (ccl::frame-supplied-args p lfun pc nil context) 377 | (loop for value in args 378 | for type in types 379 | for name in names 380 | append (cond ((equal type "keyword") 381 | (list (intern (symbol-name name) "KEYWORD") value)) 382 | (t (list value)))))) 383 | 384 | (defimplementation compute-backtrace (start-frame-number end-frame-number) 385 | (let (result) 386 | (map-backtrace (lambda (frame-number p context lfun pc) 387 | (declare (ignore frame-number)) 388 | (push (list :frame p context lfun pc) 389 | result)) 390 | start-frame-number end-frame-number) 391 | (nreverse result))) 392 | 393 | (defimplementation print-frame (frame stream) 394 | (assert (eq (first frame) :frame)) 395 | (destructuring-bind (p context lfun pc) (rest frame) 396 | (format stream "(~S~{ ~S~})" 397 | (or (ccl::function-name lfun) lfun) 398 | (frame-arguments p context lfun pc)))) 399 | 400 | (defimplementation frame-var-value (frame var) 401 | (block frame-var-value 402 | (map-backtrace 403 | #'(lambda(frame-number p context lfun pc) 404 | (when (= frame frame-number) 405 | (return-from frame-var-value 406 | (multiple-value-bind (total vsp parent-vsp) 407 | (ccl::count-values-in-frame p context) 408 | (loop for count below total 409 | with varcount = -1 410 | for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp)) 411 | when name do (incf varcount) 412 | until (= varcount var) 413 | finally (return value))))))))) 414 | 415 | (defimplementation frame-locals (index) 416 | (block frame-locals 417 | (map-backtrace 418 | (lambda (frame-number p context lfun pc) 419 | (when (= frame-number index) 420 | (multiple-value-bind (count vsp parent-vsp) 421 | (ccl::count-values-in-frame p context) 422 | (let (result) 423 | (dotimes (i count) 424 | (multiple-value-bind (var type name) 425 | (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp) 426 | (declare (ignore type)) 427 | (when name 428 | (push (list 429 | :name name 430 | :id 0 431 | :value (if (typep var 'ccl::value-cell) 432 | (ccl::uvref var 0) 433 | var)) 434 | result)))) 435 | (return-from frame-locals (nreverse result))))))))) 436 | 437 | 438 | #+(or) ;; Doesn't work well on x86-32 439 | (defimplementation frame-catch-tags (index &aux my-frame) 440 | (block frame-catch-tags 441 | (map-backtrace 442 | (lambda (frame-number p context lfun pc) 443 | (declare (ignore pc lfun)) 444 | (if (= frame-number index) 445 | (setq my-frame p) 446 | (when my-frame 447 | (return-from frame-catch-tags 448 | (loop for catch = (ccl::%catch-top (ccl::%current-tcr)) then (ccl::next-catch catch) 449 | while catch 450 | for csp = (ccl::uvref catch 3) ; ppc32::catch-frame.csp-cell) defined in arch.lisp 451 | for tag = (ccl::uvref catch 0) ; ppc32::catch-frame.catch-tag-cell) 452 | until (ccl::%stack< p csp context) 453 | when (ccl::%stack< my-frame csp context) 454 | collect (cond 455 | ((symbolp tag) 456 | tag) 457 | ((and (listp tag) 458 | (typep (car tag) 'restart)) 459 | `(:restart ,(restart-name (car tag))))))))))))) 460 | 461 | (defimplementation disassemble-frame (the-frame-number) 462 | (let ((function-to-disassemble nil)) 463 | (block find-frame 464 | (map-backtrace 465 | (lambda(frame-number p context lfun pc) 466 | (declare (ignore p context pc)) 467 | (when (= frame-number the-frame-number) 468 | (setq function-to-disassemble lfun) 469 | (return-from find-frame))))) 470 | #+ppc (ccl::print-ppc-instructions 471 | *standard-output* 472 | (ccl::function-to-dll-header function-to-disassemble) 473 | nil) 474 | #+x86-64 (ccl::x8664-xdisassemble function-to-disassemble))) 475 | 476 | ;;; 477 | 478 | (defun canonicalize-location (file symbol &optional snippet) 479 | (etypecase file 480 | ((or string pathname) 481 | (multiple-value-bind (truename c) (ignore-errors (namestring (truename file))) 482 | (cond (c (list :error (princ-to-string c))) 483 | (t (make-location (list :file (remove-filename-quoting truename)) 484 | (list :function-name (princ-to-string symbol)) 485 | (if snippet 486 | (list :snippet snippet) 487 | '())))))))) 488 | 489 | (defun remove-filename-quoting (string) 490 | (if (search "\\" string) 491 | (read-from-string (format nil "\"~a\"" string)) 492 | string)) 493 | 494 | (defun maybe-method-location (type) 495 | (when (typep type 'ccl::method) 496 | `((method ,(ccl::method-name type) 497 | ,(mapcar #'specializer-name (ccl::method-specializers type)) 498 | ,@(ccl::method-qualifiers type)) 499 | ,(function-source-location (ccl::method-function type))))) 500 | 501 | (defimplementation find-definitions (symbol) 502 | (let* ((info (ccl::get-source-files-with-types&classes symbol))) 503 | (loop for (type . file) in info 504 | when (not (equal "l1-boot-3" (pathname-name file))) ; alanr: This is a bug - there's nothing in there 505 | collect (or (maybe-method-location type) 506 | (list (list type symbol) 507 | (canonicalize-location file symbol)))))) 508 | 509 | ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) 510 | ;; contains some interesting details: 511 | ;; 512 | ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects 513 | ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, 514 | ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end 515 | ;; positions are file positions (not character positions). The text will 516 | ;; be NIL unless text recording was on at read-time. If the original 517 | ;; file is still available, you can force missing source text to be read 518 | ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT. 519 | ;; 520 | ;; Source-note's are associated with definitions (via record-source-file) 521 | ;; and also stored in function objects (including anonymous and nested 522 | ;; functions). The former can be retrieved via 523 | ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE. 524 | ;; 525 | ;; The recording behavior is controlled by the new variable 526 | ;; CCL:*SAVE-SOURCE-LOCATIONS*: 527 | ;; 528 | ;; If NIL, don't store source-notes in function objects, and store only 529 | ;; the filename for definitions (the latter only if 530 | ;; *record-source-file* is true). 531 | ;; 532 | ;; If T, store source-notes, including a copy of the original source 533 | ;; text, for function objects and definitions (the latter only if 534 | ;; *record-source-file* is true). 535 | ;; 536 | ;; If :NO-TEXT, store source-notes, but without saved text, for 537 | ;; function objects and defintions (the latter only if 538 | ;; *record-source-file* is true). This is the default. 539 | ;; 540 | ;; PC to source mapping is controlled by the new variable 541 | ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a 542 | ;; compressed table mapping pc offsets to corresponding source locations. 543 | ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) 544 | ;; which returns a source-note for the source at offset pc in the 545 | ;; function. 546 | ;; 547 | ;; Currently the only thing that makes use of any of this is the 548 | ;; disassembler. ILISP and current version of Slime still use 549 | ;; backward-compatible functions that deal with filenames only. The plan 550 | ;; is to make Slime, and our IDE, use this eventually. 551 | 552 | #+#.(cl:if (cl:fboundp 'ccl::function-source-note) '(:or) '(:and)) 553 | (progn 554 | (defun function-source-location (function) 555 | (or (car (source-locations function)) 556 | (list :error (format nil "No source info available for ~A" function)))) 557 | 558 | (defun pc-source-location (function pc) 559 | (function-source-location function)) 560 | 561 | ;; source-locations THING => LOCATIONS NAMES 562 | ;; LOCATIONS ... a list of source-locations. Most "specific" first. 563 | ;; NAMES ... a list of names. 564 | (labels ((str (obj) (princ-to-string obj)) 565 | (str* (list) (mapcar #'princ-to-string list)) 566 | (unzip (list) (values (mapcar #'car list) (mapcar #'cdr list))) 567 | (filename (file) (namestring (truename file))) 568 | (src-loc (file pos) 569 | (etypecase file 570 | (null `(:error "No source-file info available")) 571 | ((or string pathname) 572 | (handler-case (make-location `(:file ,(filename file)) pos) 573 | (error (c) `(:error ,(princ-to-string c))))))) 574 | (fallback (thing) 575 | (cond ((functionp thing) 576 | (let ((name (ccl::function-name thing))) 577 | (and (consp name) (eq (car name) :internal) 578 | (ccl::edit-definition-p (second name)))))))) 579 | 580 | ;; FIXME: reorder result, e.g. if THING is a function then return 581 | ;; the locations for type 'function before those with type 582 | ;; 'variable. (Otherwise the debugger jumps to compiler-macros 583 | ;; instead of functions :-) 584 | (defun source-locations (thing) 585 | (multiple-value-bind (files name) (ccl::edit-definition-p thing) 586 | (when (null files) 587 | (multiple-value-setq (files name) (fallback thing))) 588 | (unzip 589 | (loop for (type . file) in files collect 590 | (etypecase type 591 | ((member function macro variable compiler-macro 592 | ccl:defcallback ccl::x8664-vinsn) 593 | (cons (src-loc file (list :function-name (str name))) 594 | (list type name))) 595 | (method 596 | (let* ((met type) 597 | (name (ccl::method-name met)) 598 | (specs (ccl::method-specializers met)) 599 | (specs (mapcar #'specializer-name specs)) 600 | (quals (ccl::method-qualifiers met))) 601 | (cons (src-loc file (list :method (str name) 602 | (str* specs) (str* quals))) 603 | `(method ,name ,@quals ,specs))))))))))) 604 | 605 | #+#.(cl:if (cl:fboundp 'ccl::function-source-note) '(:and) '(:or)) 606 | (progn 607 | (defun function-source-location (function) 608 | (source-note-to-source-location 609 | (ccl:function-source-note function) 610 | (lambda () 611 | (format nil "Function has no source note: ~A" function)))) 612 | 613 | (defun pc-source-location (function pc) 614 | (source-note-to-source-location 615 | (or (ccl:find-source-note-at-pc function pc) 616 | (ccl:function-source-note function)) 617 | (lambda () 618 | (format nil "No source note at PC: ~A:#x~x" function pc)))) 619 | 620 | (defun source-note-to-source-location (note if-nil-thunk) 621 | (labels ((filename-to-buffer (filename) 622 | (cond ((probe-file filename) 623 | (list :file (namestring (truename filename)))) 624 | ((gethash filename *temp-file-map*) 625 | (list :buffer (gethash filename *temp-file-map*))) 626 | (t (error "File ~s doesn't exist" filename))))) 627 | (cond (note 628 | (handler-case 629 | (make-location 630 | (filename-to-buffer (ccl:source-note-filename note)) 631 | (list :position (1+ (ccl:source-note-start-pos note)))) 632 | (error (c) `(:error ,(princ-to-string c))))) 633 | (t `(:error ,(funcall if-nil-thunk)))))) 634 | 635 | (defimplementation find-definitions (symbol) 636 | (loop for (loc . name) in (source-locations symbol) 637 | collect (list name loc))) 638 | 639 | (defgeneric source-locations (thing)) 640 | 641 | (defmethod source-locations ((f function)) 642 | (list (cons (function-source-location f) 643 | (list 'function (ccl:function-name f))))) 644 | 645 | (defmethod source-locations ((s symbol)) 646 | (append 647 | #+(or) 648 | (if (and (fboundp s) 649 | (not (macro-function s)) 650 | (not (special-operator-p s)) 651 | (functionp (symbol-function s))) 652 | (source-locations (symbol-function s))) 653 | (loop for ((type . name) source) in (ccl:find-definition-sources s) 654 | collect (cons (source-note-to-source-location 655 | source (lambda () "No source info available")) 656 | (definition-name type name))))) 657 | 658 | (defgeneric definition-name (type name) 659 | (:method ((type ccl::definition-type) name) 660 | (list (ccl::definition-type-name type) name))) 661 | 662 | (defmethod definition-name ((type ccl::method-definition-type) 663 | (met method)) 664 | `(,(ccl::definition-type-name type) 665 | ,(ccl::method-name met) 666 | ,@(ccl::method-qualifiers met) 667 | ,(mapcar #'specializer-name (ccl::method-specializers met))))) 668 | 669 | (defimplementation frame-source-location-for-emacs (index) 670 | "Return to Emacs the location of the source code for the 671 | function in a debugger frame. In OpenMCL, we are not able to 672 | find the precise position of the frame, but we do attempt to give 673 | at least the filename containing it." 674 | (block frame-source-location-for-emacs 675 | (map-backtrace 676 | (lambda (frame-number p context lfun pc) 677 | (declare (ignore p context)) 678 | (when (and (= frame-number index) lfun) 679 | (return-from frame-source-location-for-emacs 680 | (if pc 681 | (pc-source-location lfun pc) 682 | (function-source-location lfun)))))))) 683 | 684 | (defimplementation eval-in-frame (form index) 685 | (block eval-in-frame 686 | (map-backtrace 687 | (lambda (frame-number p context lfun pc) 688 | (when (= frame-number index) 689 | (multiple-value-bind (count vsp parent-vsp) 690 | (ccl::count-values-in-frame p context) 691 | (let ((bindings nil)) 692 | (dotimes (i count) 693 | (multiple-value-bind (var type name) 694 | (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp) 695 | (declare (ignore type)) 696 | (when name 697 | (push (list name `',var) bindings)) 698 | )) 699 | (return-from eval-in-frame 700 | (eval `(let ,bindings 701 | (declare (ignorable ,@(mapcar 'car bindings))) 702 | ,form))) 703 | ))))))) 704 | 705 | #+ppc 706 | (defimplementation return-from-frame (index form) 707 | (let ((values (multiple-value-list (eval-in-frame form index)))) 708 | (map-backtrace 709 | (lambda (frame-number p context lfun pc) 710 | (declare (ignore context lfun pc)) 711 | (when (= frame-number index) 712 | (ccl::apply-in-frame p #'values values)))))) 713 | 714 | #+ppc 715 | (defimplementation restart-frame (index) 716 | (map-backtrace 717 | (lambda (frame-number p context lfun pc) 718 | (when (= frame-number index) 719 | (ccl::apply-in-frame p lfun 720 | (ccl::frame-supplied-args p lfun pc nil context)))))) 721 | 722 | (let ((ccl::*warn-if-redefine-kernel* nil)) 723 | (ccl::advise 724 | ccl::cbreak-loop 725 | (if *break-in-conium* 726 | (apply #'break-in-conium ccl::arglist) 727 | (:do-it)) 728 | :when :around 729 | :name conium-break)) 730 | 731 | (defun break-in-conium (x y &rest args) 732 | (let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint* 733 | (ccl::%get-frame-ptr)))) 734 | (apply #'cerror y (if args "Break: ~a" x) args))) 735 | 736 | ;;; Utilities 737 | 738 | (defimplementation describe-symbol-for-emacs (symbol) 739 | (let ((result '())) 740 | (flet ((doc (kind &optional (sym symbol)) 741 | (or (documentation sym kind) :not-documented)) 742 | (maybe-push (property value) 743 | (when value 744 | (setf result (list* property value result))))) 745 | (maybe-push 746 | :variable (when (boundp symbol) 747 | (doc 'variable))) 748 | (maybe-push 749 | :function (if (fboundp symbol) 750 | (doc 'function))) 751 | (maybe-push 752 | :setf (let ((setf-function-name (ccl::setf-function-spec-name 753 | `(setf ,symbol)))) 754 | (when (fboundp setf-function-name) 755 | (doc 'function setf-function-name)))) 756 | result))) 757 | 758 | (defimplementation describe-definition (symbol namespace) 759 | (ecase namespace 760 | (:variable 761 | (describe symbol)) 762 | ((:function :generic-function) 763 | (describe (symbol-function symbol))) 764 | (:setf 765 | (describe (ccl::setf-function-spec-name `(setf ,symbol)))) 766 | (:class 767 | (describe (find-class symbol))))) 768 | 769 | (defimplementation toggle-trace (spec) 770 | "We currently ignore just about everything." 771 | (ecase (car spec) 772 | (setf 773 | (ccl:trace-function spec)) 774 | ((:defgeneric) 775 | (ccl:trace-function (second spec))) 776 | ((:defmethod) 777 | (destructuring-bind (name qualifiers specializers) (cdr spec) 778 | (ccl:trace-function 779 | (find-method (fdefinition name) qualifiers specializers))))) 780 | t) 781 | 782 | ;;; XREF 783 | 784 | (defimplementation list-callers (symbol) 785 | (loop for caller in (ccl::callers symbol) 786 | append (multiple-value-bind (info name type specializers modifiers) 787 | (ccl::edit-definition-p caller) 788 | (loop for (nil . file) in info 789 | collect (list (if (eq t type) 790 | name 791 | `(,type ,name ,specializers 792 | ,@modifiers)) 793 | (canonicalize-location file name)))))) 794 | ;;; Macroexpansion 795 | 796 | (defvar *value2tag* (make-hash-table)) 797 | 798 | (do-symbols (s (find-package 'arch)) 799 | (if (and (> (length (symbol-name s)) 7) 800 | (string= (symbol-name s) "SUBTAG-" :end1 7) 801 | (boundp s) 802 | (numberp (symbol-value s)) 803 | (< (symbol-value s) 255)) 804 | (setf (gethash (symbol-value s) *value2tag*) s))) 805 | 806 | #+#.(conium::with-symbol 'macroexpand-all 'ccl) 807 | (defimplementation macroexpand-all (form) 808 | (ccl:macroexpand-all form)) 809 | 810 | ;;;; Inspection 811 | 812 | (defimplementation describe-primitive-type (thing) 813 | (let ((typecode (ccl::typecode thing))) 814 | (if (gethash typecode *value2tag*) 815 | (string (gethash typecode *value2tag*)) 816 | (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) 817 | 818 | (defmethod emacs-inspect ((o t)) 819 | (let* ((i (inspector::make-inspector o)) 820 | (count (inspector::compute-line-count i)) 821 | (lines 822 | (loop 823 | for l below count 824 | for (value label) = (multiple-value-list 825 | (inspector::line-n i l)) 826 | collect (format nil "~(~a~)" (or label l)) 827 | collect " = " 828 | collect `(:value ,value) 829 | collect '(:newline)))) 830 | lines)) 831 | 832 | (defmethod emacs-inspect :around ((o t)) 833 | (if (or (uvector-inspector-p o) 834 | (not (ccl:uvectorp o))) 835 | (call-next-method) 836 | (let ((value (call-next-method))) 837 | (cond ((listp value) 838 | (append value 839 | `((:newline) 840 | (:value ,(make-instance 'uvector-inspector :object o) 841 | "Underlying UVECTOR")))) 842 | (t value))))) 843 | 844 | (defclass uvector-inspector () 845 | ((object :initarg :object))) 846 | 847 | (defgeneric uvector-inspector-p (object) 848 | (:method ((object t)) nil) 849 | (:method ((object uvector-inspector)) t)) 850 | 851 | (defmethod emacs-inspect ((uv uvector-inspector)) 852 | (with-slots (object) uv 853 | (loop for index below (ccl::uvsize object) 854 | collect (format nil "~D: " index) 855 | collect `(:value ,(ccl::uvref object index)) 856 | collect `(:newline)))) 857 | 858 | (defun closure-closed-over-values (closure) 859 | (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure))))) 860 | (loop for n below howmany 861 | collect 862 | (let* ((value (ccl::nth-immediate closure (+ 1 (- howmany n)))) 863 | (map (car (ccl::function-symbol-map (ccl::closure-function closure)))) 864 | (label (or (and map (svref map n)) n)) 865 | (cellp (ccl::closed-over-value-p value))) 866 | (list label (if cellp (ccl::closed-over-value value) value)))))) 867 | 868 | (defmethod emacs-inspect ((c ccl::compiled-lexical-closure)) 869 | (list* 870 | (format nil "A closure: ~a~%" c) 871 | `(,@(if (arglist c) 872 | (list "Its argument list is: " 873 | (funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c))) 874 | ;; FIXME inspector-princ should load earlier 875 | (list "A function of no arguments")) 876 | (:newline) 877 | ,@(when (documentation c t) 878 | `("Documentation:" (:newline) ,(documentation c t) (:newline))) 879 | ,(format nil "Closed over ~a values" (length (closure-closed-over-values c))) 880 | (:newline) 881 | ,@(loop for (name value) in (closure-closed-over-values c) 882 | for count from 1 883 | append 884 | (label-value-line* ((format nil "~2,' d) ~a" count (string name)) value)))))) 885 | 886 | (defimplementation quit-lisp () 887 | (ccl::quit)) 888 | 889 | ;;; Weak datastructures 890 | 891 | (defimplementation make-weak-key-hash-table (&rest args) 892 | (apply #'make-hash-table :weak :key args)) 893 | 894 | (defimplementation make-weak-value-hash-table (&rest args) 895 | (apply #'make-hash-table :weak :value args)) 896 | 897 | (defimplementation hash-table-weakness (hashtable) 898 | (ccl::hash-table-weak-p hashtable)) 899 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp; indent-tabs: nil -*- 2 | 3 | (defpackage :conium 4 | (:use :common-lisp) 5 | (:export #:sldb-condition 6 | #:original-condition 7 | #:compiler-condition 8 | #:message 9 | #:short-message 10 | #:condition 11 | #:severity 12 | #:with-compilation-hooks 13 | #:location 14 | #:location-p 15 | #:location-buffer 16 | #:location-position 17 | #:position-p 18 | #:position-pos 19 | #:print-output-to-string 20 | #:quit-lisp 21 | #:references 22 | #:unbound-slot-filler 23 | #:declaration-arglist 24 | #:type-specifier-arglist 25 | ;; interrupt macro for the backend 26 | #:*pending-slime-interrupts* 27 | #:check-slime-interrupts 28 | #:*interrupt-queued-handler* 29 | ;; inspector related symbols 30 | #:emacs-inspect 31 | #:label-value-line 32 | #:label-value-line* 33 | 34 | #:with-struct 35 | )) 36 | -------------------------------------------------------------------------------- /source-file-cache.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Source-file cache 2 | ;;; 3 | ;;; To robustly find source locations in CMUCL and SBCL it's useful to 4 | ;;; have the exact source code that the loaded code was compiled from. 5 | ;;; In this source we can accurately find the right location, and from 6 | ;;; that location we can extract a "snippet" of code to show what the 7 | ;;; definition looks like. Emacs can use this snippet in a best-match 8 | ;;; search to locate the right definition, which works well even if 9 | ;;; the buffer has been modified. 10 | ;;; 11 | ;;; The idea is that if a definition previously started with 12 | ;;; `(define-foo bar' then it probably still does. 13 | ;;; 14 | ;;; Whenever we see that the file on disk has the same 15 | ;;; `file-write-date' as a location we're looking for we cache the 16 | ;;; whole file inside Lisp. That way we will still have the matching 17 | ;;; version even if the file is later modified on disk. If the file is 18 | ;;; later recompiled and reloaded then we replace our cache entry. 19 | ;;; 20 | ;;; This code has been placed in the Public Domain. All warranties 21 | ;;; are disclaimed. 22 | 23 | (in-package :conium) 24 | 25 | (defvar *cache-sourcecode* t 26 | "When true complete source files are cached. 27 | The cache is used to keep known good copies of the source text which 28 | correspond to the loaded code. Finding definitions is much more 29 | reliable when the exact source is available, so we cache it in case it 30 | gets edited on disk later.") 31 | 32 | (defvar *source-file-cache* (make-hash-table :test 'equal) 33 | "Cache of source file contents. 34 | Maps from truename to source-cache-entry structure.") 35 | 36 | (defstruct (source-cache-entry 37 | (:conc-name source-cache-entry.) 38 | (:constructor make-source-cache-entry (text date))) 39 | text date) 40 | 41 | (defimplementation buffer-first-change (filename) 42 | "Load a file into the cache when the user modifies its buffer. 43 | This is a win if the user then saves the file and tries to M-. into it." 44 | (unless (source-cached-p filename) 45 | (ignore-errors 46 | (source-cache-get filename (file-write-date filename)))) 47 | nil) 48 | 49 | (defun get-source-code (filename code-date) 50 | "Return the source code for FILENAME as written on DATE in a string. 51 | If the exact version cannot be found then return the current one from disk." 52 | (or (source-cache-get filename code-date) 53 | (read-file filename))) 54 | 55 | (defun source-cache-get (filename date) 56 | "Return the source code for FILENAME as written on DATE in a string. 57 | Return NIL if the right version cannot be found." 58 | (when *cache-sourcecode* 59 | (let ((entry (gethash filename *source-file-cache*))) 60 | (cond ((and entry (equal date (source-cache-entry.date entry))) 61 | ;; Cache hit. 62 | (source-cache-entry.text entry)) 63 | ((or (null entry) 64 | (not (equal date (source-cache-entry.date entry)))) 65 | ;; Cache miss. 66 | (if (equal (file-write-date filename) date) 67 | ;; File on disk has the correct version. 68 | (let ((source (read-file filename))) 69 | (setf (gethash filename *source-file-cache*) 70 | (make-source-cache-entry source date)) 71 | source) 72 | nil)))))) 73 | 74 | (defun source-cached-p (filename) 75 | "Is any version of FILENAME in the source cache?" 76 | (if (gethash filename *source-file-cache*) t)) 77 | 78 | (defun read-file (filename) 79 | "Return the entire contents of FILENAME as a string." 80 | (with-open-file (s filename :direction :input 81 | :external-format (or (guess-external-format filename) 82 | (find-external-format "latin-1") 83 | :default)) 84 | (let ((string (make-string (file-length s)))) 85 | (read-sequence string s) 86 | string))) 87 | 88 | ;;;; Snippets 89 | 90 | (defvar *source-snippet-size* 256 91 | "Maximum number of characters in a snippet of source code. 92 | Snippets at the beginning of definitions are used to tell Emacs what 93 | the definitions looks like, so that it can accurately find them by 94 | text search.") 95 | 96 | (defun read-snippet (stream &optional position) 97 | "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. 98 | If POSITION is given, set the STREAM's file position first." 99 | (when position 100 | (file-position stream position)) 101 | #+SBCL (skip-comments-and-whitespace stream) 102 | (read-upto-n-chars stream *source-snippet-size*)) 103 | 104 | (defun skip-comments-and-whitespace (stream) 105 | (case (peek-char nil stream) 106 | ((#\Space #\Tab #\Newline #\Linefeed #\Page) 107 | (read-char stream) 108 | (skip-comments-and-whitespace stream)) 109 | (#\; 110 | (read-line stream) 111 | (skip-comments-and-whitespace stream)))) 112 | 113 | (defun read-upto-n-chars (stream n) 114 | "Return a string of upto N chars from STREAM." 115 | (let* ((string (make-string n)) 116 | (chars (read-sequence string stream))) 117 | (subseq string 0 chars))) 118 | 119 | -------------------------------------------------------------------------------- /source-path-parser.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Source-paths 2 | 3 | ;;; CMUCL/SBCL use a data structure called "source-path" to locate 4 | ;;; subforms. The compiler assigns a source-path to each form in a 5 | ;;; compilation unit. Compiler notes usually contain the source-path 6 | ;;; of the error location. 7 | ;;; 8 | ;;; Compiled code objects don't contain source paths, only the 9 | ;;; "toplevel-form-number" and the (sub-) "form-number". To get from 10 | ;;; the form-number to the source-path we need the entire toplevel-form 11 | ;;; (i.e. we have to read the source code). CMUCL has already some 12 | ;;; utilities to do this translation, but we use some extended 13 | ;;; versions, because we need more exact position info. Apparently 14 | ;;; Hemlock is happy with the position of the toplevel-form; we also 15 | ;;; need the position of subforms. 16 | ;;; 17 | ;;; We use a special readtable to get the positions of the subforms. 18 | ;;; The readtable stores the start and end position for each subform in 19 | ;;; hashtable for later retrieval. 20 | ;;; 21 | ;;; This code has been placed in the Public Domain. All warranties 22 | ;;; are disclaimed. 23 | 24 | ;;; Taken from swank-cmucl.lisp, by Helmut Eller 25 | 26 | (in-package :conium) 27 | 28 | ;; Some test to ensure the required conformance 29 | (let ((rt (copy-readtable nil))) 30 | (assert (or (not (get-macro-character #\space rt)) 31 | (nth-value 1 (get-macro-character #\space rt)))) 32 | (assert (not (get-macro-character #\\ rt)))) 33 | 34 | (defun make-sharpdot-reader (orig-sharpdot-reader) 35 | #'(lambda (s c n) 36 | ;; We want things like M-. to work regardless of any #.-fu in 37 | ;; the source file that is to be visited. (For instance, when a 38 | ;; file contains #. forms referencing constants that do not 39 | ;; currently exist in the image.) 40 | (ignore-errors (funcall orig-sharpdot-reader s c n)))) 41 | 42 | (defun make-source-recorder (fn source-map) 43 | "Return a macro character function that does the same as FN, but 44 | additionally stores the result together with the stream positions 45 | before and after of calling FN in the hashtable SOURCE-MAP." 46 | (declare (type function fn)) 47 | (lambda (stream char) 48 | (let ((start (1- (file-position stream))) 49 | (values (multiple-value-list (funcall fn stream char))) 50 | (end (file-position stream))) 51 | ;(format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" start values end (char-code char) char) 52 | (unless (null values) 53 | (push (cons start end) (gethash (car values) source-map))) 54 | (values-list values)))) 55 | 56 | (defun make-source-recording-readtable (readtable source-map) 57 | "Return a source position recording copy of READTABLE. 58 | The source locations are stored in SOURCE-MAP." 59 | (flet ((install-special-sharpdot-reader (*readtable*) 60 | (let ((old-reader (ignore-errors 61 | (get-dispatch-macro-character #\# #\.)))) 62 | (when old-reader 63 | (set-dispatch-macro-character #\# #\. 64 | (make-sharpdot-reader old-reader)))))) 65 | (let* ((tab (copy-readtable readtable)) 66 | (*readtable* tab)) 67 | (dotimes (code 128) 68 | (let ((char (code-char code))) 69 | (multiple-value-bind (fn term) (get-macro-character char tab) 70 | (when fn 71 | (set-macro-character char (make-source-recorder fn source-map) 72 | term tab))))) 73 | (install-special-sharpdot-reader tab) 74 | tab))) 75 | 76 | (defun read-and-record-source-map (stream) 77 | "Read the next object from STREAM. 78 | Return the object together with a hashtable that maps 79 | subexpressions of the object to stream positions." 80 | (let* ((source-map (make-hash-table :test #'eq)) 81 | (*readtable* (make-source-recording-readtable *readtable* source-map)) 82 | (start (file-position stream)) 83 | (form (read stream)) 84 | (end (file-position stream))) 85 | ;; ensure that at least FORM is in the source-map 86 | (unless (gethash form source-map) 87 | (push (cons start end) (gethash form source-map))) 88 | (values form source-map))) 89 | 90 | (defun skip-toplevel-forms (n stream) 91 | (let ((*read-suppress* t)) 92 | (dotimes (i n) 93 | (read stream)))) 94 | 95 | (defun read-source-form (n stream) 96 | "Read the Nth toplevel form number with source location recording. 97 | Return the form and the source-map." 98 | (skip-toplevel-forms n stream) 99 | (let ((*read-suppress* nil)) 100 | (read-and-record-source-map stream))) 101 | 102 | (defun source-path-stream-position (path stream) 103 | "Search the source-path PATH in STREAM and return its position." 104 | (check-source-path path) 105 | (destructuring-bind (tlf-number . path) path 106 | (multiple-value-bind (form source-map) (read-source-form tlf-number stream) 107 | (source-path-source-position (cons 0 path) form source-map)))) 108 | 109 | (defun check-source-path (path) 110 | (unless (and (consp path) 111 | (every #'integerp path)) 112 | (error "The source-path ~S is not valid." path))) 113 | 114 | (defun source-path-string-position (path string) 115 | (with-input-from-string (s string) 116 | (source-path-stream-position path s))) 117 | 118 | (defun source-path-file-position (path filename) 119 | ;; We go this long way round, and don't directly operate on the file 120 | ;; stream because FILE-POSITION (used above) is not totally savy even 121 | ;; on file character streams; on SBCL, FILE-POSITION returns the binary 122 | ;; offset, and not the character offset---screwing up on Unicode. 123 | (let ((toplevel-number (first path)) 124 | (buffer)) 125 | (with-open-file (file filename) 126 | (skip-toplevel-forms (1+ toplevel-number) file) 127 | (let ((endpos (file-position file))) 128 | (setq buffer (make-array (list endpos) :element-type 'character 129 | :initial-element #\Space)) 130 | (assert (file-position file 0)) 131 | (read-sequence buffer file :end endpos))) 132 | (source-path-string-position path buffer))) 133 | 134 | (defun source-path-source-position (path form source-map) 135 | "Return the start position of PATH from FORM and SOURCE-MAP. All 136 | subforms along the path are considered and the start and end position 137 | of the deepest (i.e. smallest) possible form is returned." 138 | ;; compute all subforms along path 139 | (let ((forms (loop for n in path 140 | for f = form then (nth n f) 141 | collect f))) 142 | ;; select the first subform present in source-map 143 | (loop for form in (reverse forms) 144 | for positions = (gethash form source-map) 145 | until (and positions (null (cdr positions))) 146 | finally (destructuring-bind ((start . end)) positions 147 | (return (values start end)))))) 148 | 149 | --------------------------------------------------------------------------------