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(defpackage swank/ecl 12 (:use cl swank/backend)) 13 14(in-package swank/ecl) 15 16(eval-when (:compile-toplevel :load-toplevel :execute) 17 (defun ecl-version () 18 (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT))) 19 (if version 20 (symbol-value version) 21 0))) 22 (when (< (ecl-version) 100301) 23 (error "~&IMPORTANT:~% ~ 24 The version of ECL you're using (~A) is too old.~% ~ 25 Please upgrade to at least 10.3.1.~% ~ 26 Sorry for the inconvenience.~%~%" 27 (lisp-implementation-version)))) 28 29;; Hard dependencies. 30(eval-when (:compile-toplevel :load-toplevel :execute) 31 (require 'sockets)) 32 33;; Soft dependencies. 34(eval-when (:compile-toplevel :load-toplevel :execute) 35 (when (probe-file "sys:profile.fas") 36 (require :profile) 37 (pushnew :profile *features*)) 38 (when (probe-file "sys:serve-event.fas") 39 (require :serve-event) 40 (pushnew :serve-event *features*))) 41 42(declaim (optimize (debug 3))) 43 44;;; Swank-mop 45 46(eval-when (:compile-toplevel :load-toplevel :execute) 47 (import-swank-mop-symbols 48 :clos 49 (and (< (ecl-version) 121201) 50 `(:eql-specializer 51 :eql-specializer-object 52 :generic-function-declarations 53 :specializer-direct-methods 54 ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) 55 '(:compute-applicable-methods-using-classes)))))) 56 57(defimplementation gray-package-name () 58 "GRAY") 59 60 61;;;; UTF8 62 63;;; Convert the string STRING to a (simple-array (unsigned-byte 8)). 64;;; 65;;; string-to-utf8 (string) 66 67;;; Convert the (simple-array (unsigned-byte 8)) OCTETS to a string. 68;;; 69;;; utf8-to-string (octets) 70 71 72;;;; TCP Server 73 74(defun resolve-hostname (name) 75 (car (sb-bsd-sockets:host-ent-addresses 76 (sb-bsd-sockets:get-host-by-name name)))) 77 78(defimplementation create-socket (host port &key backlog) 79 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket 80 :type :stream 81 :protocol :tcp))) 82 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) 83 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) 84 (sb-bsd-sockets:socket-listen socket (or backlog 5)) 85 socket)) 86 87(defimplementation local-port (socket) 88 (nth-value 1 (sb-bsd-sockets:socket-name socket))) 89 90(defimplementation close-socket (socket) 91 (sb-bsd-sockets:socket-close socket)) 92 93(defun accept (socket) 94 "Like socket-accept, but retry on EAGAIN." 95 (loop (handler-case 96 (return (sb-bsd-sockets:socket-accept socket)) 97 (sb-bsd-sockets:interrupted-error ())))) 98 99(defimplementation accept-connection (socket 100 &key external-format 101 buffering timeout) 102 (declare (ignore timeout)) 103 (sb-bsd-sockets:socket-make-stream (accept socket) 104 :output t 105 :input t 106 :buffering (ecase buffering 107 ((t) :full) 108 ((nil) :none) 109 (:line :line)) 110 :element-type (if external-format 111 'character 112 '(unsigned-byte 8)) 113 :external-format external-format)) 114 115;;; Call FN whenever SOCKET is readable. 116;;; 117;;; add-sigio-handler (socket fn) 118 119;;; Remove all sigio handlers for SOCKET. 120;;; 121;;; remove-sigio-handlers (socket) 122 123;;; Call FN when Lisp is waiting for input and SOCKET is readable. 124;;; 125;;; add-fd-handler (socket fn) 126 127;;; Remove all fd-handlers for SOCKET. 128;;; 129;;; remove-fd-handlers (socket) 130 131(defimplementation preferred-communication-style () 132 (cond 133 ((member :threads *features*) :spawn) 134 ((member :windows *features*) nil) 135 (t #|:fd-handler|# nil))) 136 137;;; Set the 'stream 'timeout. The timeout is either the real number 138;;; specifying the timeout in seconds or 'nil for no timeout. 139;;; 140;;; set-stream-timeout (stream timeout) 141 142 143;;; Hook called when the first connection from Emacs is established. 144;;; Called from the INIT-FN of the socket server that accepts the 145;;; connection. 146;;; 147;;; This is intended for setting up extra context, e.g. to discover 148;;; that the calling thread is the one that interacts with Emacs. 149;;; 150;;; emacs-connected () 151 152 153;;;; Unix Integration 154 155(defimplementation getpid () 156 (si:getpid)) 157 158;;; Call FUNCTION on SIGINT (instead of invoking the debugger). 159;;; Return old signal handler. 160;;; 161;;; install-sigint-handler (function) 162 163;;; XXX! 164;;; If ECL is built with thread support, it'll spawn a helper thread 165;;; executing the SIGINT handler. We do not want to BREAK into that 166;;; helper but into the main thread, though. This is coupled with the 167;;; current choice of NIL as communication-style in so far as ECL's 168;;; main-thread is also the Slime's REPL thread. 169 170(defun make-interrupt-handler (real-handler) 171 #+threads 172 (let ((main-thread (find 'si:top-level (mp:all-processes) 173 :key #'mp:process-name))) 174 #'(lambda (&rest args) 175 (declare (ignore args)) 176 (mp:interrupt-process main-thread real-handler))) 177 #-threads 178 #'(lambda (&rest args) 179 (declare (ignore args)) 180 (funcall real-handler))) 181 182(defimplementation call-with-user-break-handler (real-handler function) 183 (let ((old-handler #'si:terminal-interrupt)) 184 (setf (symbol-function 'si:terminal-interrupt) 185 (make-interrupt-handler real-handler)) 186 (unwind-protect (funcall function) 187 (setf (symbol-function 'si:terminal-interrupt) old-handler)))) 188 189(defimplementation quit-lisp () 190 (ext:quit)) 191 192;;; Default implementation is fine. 193;;; 194;;; lisp-implementation-type-name 195;;; lisp-implementation-program 196 197(defimplementation socket-fd (socket) 198 (etypecase socket 199 (fixnum socket) 200 (two-way-stream (socket-fd (two-way-stream-input-stream socket))) 201 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) 202 (file-stream (si:file-stream-fd socket)))) 203 204;;; Create a character stream for the file descriptor FD. This 205;;; interface implementation requires either `ffi:c-inline' or has to 206;;; wait for the exported interface. 207;;; 208;;; make-fd-stream (socket-stream) 209 210;;; Duplicate a file descriptor. If the syscall fails, signal a 211;;; condition. See dup(2). This interface requiers `ffi:c-inline' or 212;;; has to wait for the exported interface. 213;;; 214;;; dup (fd) 215 216;;; Does not apply to ECL which doesn't dump images. 217;;; 218;;; exec-image (image-file args) 219 220(defimplementation command-line-args () 221 (ext:command-args)) 222 223 224;;;; pathnames 225 226;;; Return a pathname for FILENAME. 227;;; A filename in Emacs may for example contain asterisks which should not 228;;; be translated to wildcards. 229;;; 230;;; filename-to-pathname (filename) 231 232;;; Return the filename for PATHNAME. 233;;; 234;;; pathname-to-filename (pathname) 235 236(defimplementation default-directory () 237 (namestring (ext:getcwd))) 238 239(defimplementation set-default-directory (directory) 240 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. 241 (default-directory)) 242 243 244;;; Call FN with hooks to handle special syntax. Can we use it for 245;;; `ffi:c-inline' to be handled as C/C++ code? 246;;; 247;;; call-with-syntax-hooks 248 249;;; Return a suitable initial value for SWANK:*READTABLE-ALIST*. 250;;; 251;;; default-readtable-alist 252 253 254;;;; Packages 255 256#+package-local-nicknames 257(defimplementation package-local-nicknames (package) 258 (ext:package-local-nicknames package)) 259 260 261;;;; Compilation 262 263(defvar *buffer-name* nil) 264(defvar *buffer-start-position*) 265 266(defun signal-compiler-condition (&rest args) 267 (apply #'signal 'compiler-condition args)) 268 269#-ecl-bytecmp 270(defun handle-compiler-message (condition) 271 ;; ECL emits lots of noise in compiler-notes, like "Invoking 272 ;; external command". 273 (unless (typep condition 'c::compiler-note) 274 (signal-compiler-condition 275 :original-condition condition 276 :message (princ-to-string condition) 277 :severity (etypecase condition 278 (c:compiler-fatal-error :error) 279 (c:compiler-error :error) 280 (error :error) 281 (style-warning :style-warning) 282 (warning :warning)) 283 :location (condition-location condition)))) 284 285#-ecl-bytecmp 286(defun condition-location (condition) 287 (let ((file (c:compiler-message-file condition)) 288 (position (c:compiler-message-file-position condition))) 289 (if (and position (not (minusp position))) 290 (if *buffer-name* 291 (make-buffer-location *buffer-name* 292 *buffer-start-position* 293 position) 294 (make-file-location file position)) 295 (make-error-location "No location found.")))) 296 297(defimplementation call-with-compilation-hooks (function) 298 #+ecl-bytecmp 299 (funcall function) 300 #-ecl-bytecmp 301 (handler-bind ((c:compiler-message #'handle-compiler-message)) 302 (funcall function))) 303 304(defvar *tmpfile-map* (make-hash-table :test #'equal)) 305 306(defun note-buffer-tmpfile (tmp-file buffer-name) 307 ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. 308 (let ((tmp-namestring (namestring (truename tmp-file)))) 309 (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) 310 tmp-namestring)) 311 312(defun tmpfile-to-buffer (tmp-file) 313 (gethash tmp-file *tmpfile-map*)) 314 315(defimplementation swank-compile-string 316 (string &key buffer position filename line column policy) 317 (declare (ignore line column policy)) 318 (with-compilation-hooks () 319 (let ((*buffer-name* buffer) ; for compilation hooks 320 (*buffer-start-position* position)) 321 (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-")) 322 (fasl-file) 323 (warnings-p) 324 (failure-p)) 325 (unwind-protect 326 (with-open-file (tmp-stream tmp-file :direction :output 327 :if-exists :supersede) 328 (write-string string tmp-stream) 329 (finish-output tmp-stream) 330 (multiple-value-setq (fasl-file warnings-p failure-p) 331 (compile-file tmp-file 332 :load t 333 :source-truename (or filename 334 (note-buffer-tmpfile tmp-file buffer)) 335 :source-offset (1- position)))) 336 (when (probe-file tmp-file) 337 (delete-file tmp-file)) 338 (when fasl-file 339 (delete-file fasl-file))) 340 (not failure-p))))) 341 342(defimplementation swank-compile-file (input-file output-file 343 load-p external-format 344 &key policy) 345 (declare (ignore policy)) 346 (with-compilation-hooks () 347 (compile-file input-file :output-file output-file 348 :load load-p 349 :external-format external-format))) 350 351(defvar *external-format-to-coding-system* 352 '((:latin-1 353 "latin-1" "latin-1-unix" "iso-latin-1-unix" 354 "iso-8859-1" "iso-8859-1-unix") 355 (:utf-8 "utf-8" "utf-8-unix"))) 356 357(defun external-format (coding-system) 358 (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 359 *external-format-to-coding-system*)) 360 (find coding-system (ext:all-encodings) :test #'string-equal))) 361 362(defimplementation find-external-format (coding-system) 363 #+unicode (external-format coding-system) 364 ;; Without unicode support, ECL uses the one-byte encoding of the 365 ;; underlying OS, and will barf on anything except :DEFAULT. We 366 ;; return NIL here for known multibyte encodings, so 367 ;; SWANK:CREATE-SERVER will barf. 368 #-unicode (let ((xf (external-format coding-system))) 369 (if (member xf '(:utf-8)) 370 nil 371 :default))) 372 373 374;;; Default implementation is fine 375;;; 376;;; guess-external-format 377 378 379;;;; Streams 380 381;;; Implemented in `gray' 382;;; 383;;; make-output-stream 384;;; make-input-stream 385 386 387;;;; Documentation 388 389(defimplementation arglist (name) 390 (multiple-value-bind (arglist foundp) 391 (ext:function-lambda-list name) 392 (if foundp arglist :not-available))) 393 394(defimplementation type-specifier-p (symbol) 395 (or (subtypep nil symbol) 396 (not (eq (type-specifier-arglist symbol) :not-available)))) 397 398(defimplementation function-name (f) 399 (typecase f 400 (generic-function (clos:generic-function-name f)) 401 (function (si:compiled-function-name f)))) 402 403;;; Default implementation is fine (CL). 404;;; 405;;; valid-function-name-p (form) 406 407#+walker 408(defimplementation macroexpand-all (form &optional env) 409 (walker:macroexpand-all form env)) 410 411;;; Default implementation is fine. 412;;; 413;;; compiler-macroexpand-1 414;;; compiler-macroexpand 415 416(defimplementation collect-macro-forms (form &optional env) 417 ;; Currently detects only normal macros, not compiler macros. 418 (declare (ignore env)) 419 (with-collected-macro-forms (macro-forms) 420 (handler-bind ((warning #'muffle-warning)) 421 (ignore-errors 422 (compile nil `(lambda () ,form)))) 423 (values macro-forms nil))) 424 425;;; Expand the format string CONTROL-STRING. 426;;; Default implementation is fine. 427;;; 428;;; format-string-expand 429 430(defimplementation describe-symbol-for-emacs (symbol) 431 (let ((result '())) 432 (flet ((frob (type boundp) 433 (when (funcall boundp symbol) 434 (let ((doc (describe-definition symbol type))) 435 (setf result (list* type doc result)))))) 436 (frob :VARIABLE #'boundp) 437 (frob :FUNCTION #'fboundp) 438 (frob :CLASS (lambda (x) (find-class x nil)))) 439 result)) 440 441(defimplementation describe-definition (name type) 442 (case type 443 (:variable (documentation name 'variable)) 444 (:function (documentation name 'function)) 445 (:class (documentation name 'class)) 446 (t nil))) 447 448 449;;;; Debugging 450 451(eval-when (:compile-toplevel :load-toplevel :execute) 452 (import 453 '(si::*break-env* 454 si::*ihs-top* 455 si::*ihs-current* 456 si::*ihs-base* 457 si::*frs-base* 458 si::*frs-top* 459 si::*tpl-commands* 460 si::*tpl-level* 461 si::frs-top 462 si::ihs-top 463 si::ihs-fun 464 si::ihs-env 465 si::sch-frs-base 466 si::set-break-env 467 si::set-current-ihs 468 si::tpl-commands))) 469 470(defun make-invoke-debugger-hook (hook) 471 (when hook 472 #'(lambda (condition old-hook) 473 ;; Regard *debugger-hook* if set by user. 474 (if *debugger-hook* 475 nil ; decline, *DEBUGGER-HOOK* will be tried next. 476 (funcall hook condition old-hook))))) 477 478(defimplementation install-debugger-globally (function) 479 (setq *debugger-hook* function) 480 (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) 481 482(defimplementation call-with-debugger-hook (hook fun) 483 (let ((*debugger-hook* hook) 484 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) 485 (funcall fun))) 486 487(defvar *backtrace* '()) 488 489(defun in-swank-package-p (x) 490 (and 491 (symbolp x) 492 (member (symbol-package x) 493 (list #.(find-package :swank) 494 #.(find-package :swank/backend) 495 #.(ignore-errors (find-package :swank-mop)) 496 #.(ignore-errors (find-package :swank-loader)))) 497 t)) 498 499(defun is-swank-source-p (name) 500 (setf name (pathname name)) 501 (pathname-match-p 502 name 503 (make-pathname :defaults swank-loader::*source-directory* 504 :name (pathname-name name) 505 :type (pathname-type name) 506 :version (pathname-version name)))) 507 508(defun is-ignorable-fun-p (x) 509 (or 510 (in-swank-package-p (frame-name x)) 511 (multiple-value-bind (file position) 512 (ignore-errors (si::bc-file (car x))) 513 (declare (ignore position)) 514 (if file (is-swank-source-p file))))) 515 516(defimplementation call-with-debugging-environment (debugger-loop-fn) 517 (declare (type function debugger-loop-fn)) 518 (let* ((*ihs-top* (ihs-top)) 519 (*ihs-current* *ihs-top*) 520 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) 521 (*frs-top* (frs-top)) 522 (*tpl-level* (1+ *tpl-level*)) 523 (*backtrace* (loop for ihs from 0 below *ihs-top* 524 collect (list (si::ihs-fun ihs) 525 (si::ihs-env ihs) 526 nil)))) 527 (declare (special *ihs-current*)) 528 (loop for f from *frs-base* until *frs-top* 529 do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) 530 (when (plusp i) 531 (let* ((x (elt *backtrace* i)) 532 (name (si::frs-tag f))) 533 (unless (si::fixnump name) 534 (push name (third x))))))) 535 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) 536 (set-break-env) 537 (set-current-ihs) 538 (let ((*ihs-base* *ihs-top*)) 539 (funcall debugger-loop-fn)))) 540 541(defimplementation compute-backtrace (start end) 542 (subseq *backtrace* start 543 (and (numberp end) 544 (min end (length *backtrace*))))) 545 546(defun frame-name (frame) 547 (let ((x (first frame))) 548 (if (symbolp x) 549 x 550 (function-name x)))) 551 552(defun function-position (fun) 553 (multiple-value-bind (file position) 554 (si::bc-file fun) 555 (when file 556 (make-file-location file position)))) 557 558(defun frame-function (frame) 559 (let* ((x (first frame)) 560 fun position) 561 (etypecase x 562 (symbol (and (fboundp x) 563 (setf fun (fdefinition x) 564 position (function-position fun)))) 565 (function (setf fun x position (function-position x)))) 566 (values fun position))) 567 568(defun frame-decode-env (frame) 569 (let ((functions '()) 570 (blocks '()) 571 (variables '())) 572 (setf frame (si::decode-ihs-env (second frame))) 573 (dolist (record (remove-if-not #'consp frame)) 574 (let* ((record0 (car record)) 575 (record1 (cdr record))) 576 (cond ((or (symbolp record0) (stringp record0)) 577 (setq variables (acons record0 record1 variables))) 578 ((not (si::fixnump record0)) 579 (push record1 functions)) 580 ((symbolp record1) 581 (push record1 blocks)) 582 (t 583 )))) 584 (values functions blocks variables))) 585 586(defimplementation print-frame (frame stream) 587 (format stream "~A" (first frame))) 588 589;;; Is the frame FRAME restartable?. 590;;; Return T if `restart-frame' can safely be called on the frame. 591;;; 592;;; frame-restartable-p (frame) 593 594(defimplementation frame-source-location (frame-number) 595 (let ((frame (elt *backtrace* frame-number))) 596 (or (nth-value 1 (frame-function frame)) 597 (make-error-location "Unknown source location for ~A." (car frame))))) 598 599(defimplementation frame-catch-tags (frame-number) 600 (third (elt *backtrace* frame-number))) 601 602(defimplementation frame-locals (frame-number) 603 (loop for (name . value) in (nth-value 2 (frame-decode-env 604 (elt *backtrace* frame-number))) 605 collect (list :name name :id 0 :value value))) 606 607(defimplementation frame-var-value (frame-number var-number) 608 (destructuring-bind (name . value) 609 (elt 610 (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) 611 var-number) 612 (declare (ignore name)) 613 value)) 614 615(defimplementation disassemble-frame (frame-number) 616 (let ((fun (frame-function (elt *backtrace* frame-number)))) 617 (disassemble fun))) 618 619(defimplementation eval-in-frame (form frame-number) 620 (let ((env (second (elt *backtrace* frame-number)))) 621 (si:eval-with-env form env))) 622 623;;; frame-package 624;;; frame-call 625;;; return-from-frame 626;;; restart-frame 627;;; print-condition 628;;; condition-extras 629 630(defimplementation gdb-initial-commands () 631 ;; These signals are used by the GC. 632 #+linux '("handle SIGPWR noprint nostop" 633 "handle SIGXCPU noprint nostop")) 634 635;;; active-stepping 636;;; sldb-break-on-return 637;;; sldb-break-at-start 638;;; sldb-stepper-condition-p 639;;; sldb-setp-into 640;;; sldb-step-next 641;;; sldb-step-out 642 643 644;;;; Definition finding 645 646(defvar +TAGS+ (namestring 647 (merge-pathnames "TAGS" (translate-logical-pathname "SYS:")))) 648 649(defun make-file-location (file file-position) 650 ;; File positions in CL start at 0, but Emacs' buffer positions 651 ;; start at 1. We specify (:ALIGN T) because the positions comming 652 ;; from ECL point at right after the toplevel form appearing before 653 ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. 654 (make-location `(:file ,(namestring (translate-logical-pathname file))) 655 `(:position ,(1+ file-position)) 656 `(:align t))) 657 658(defun make-buffer-location (buffer-name start-position &optional (offset 0)) 659 (make-location `(:buffer ,buffer-name) 660 `(:offset ,start-position ,offset) 661 `(:align t))) 662 663(defun make-TAGS-location (&rest tags) 664 (make-location `(:etags-file ,+TAGS+) 665 `(:tag ,@tags))) 666 667(defimplementation find-definitions (name) 668 (let ((annotations (ext:get-annotation name 'si::location :all))) 669 (cond (annotations 670 (loop for annotation in annotations 671 collect (destructuring-bind (dspec file . pos) annotation 672 `(,dspec ,(make-file-location file pos))))) 673 (t 674 (mapcan #'(lambda (type) (find-definitions-by-type name type)) 675 (classify-definition-name name)))))) 676 677(defun classify-definition-name (name) 678 (let ((types '())) 679 (when (fboundp name) 680 (cond ((special-operator-p name) 681 (push :special-operator types)) 682 ((macro-function name) 683 (push :macro types)) 684 ((typep (fdefinition name) 'generic-function) 685 (push :generic-function types)) 686 ((si:mangle-name name t) 687 (push :c-function types)) 688 (t 689 (push :lisp-function types)))) 690 (when (boundp name) 691 (cond ((constantp name) 692 (push :constant types)) 693 (t 694 (push :global-variable types)))) 695 types)) 696 697(defun find-definitions-by-type (name type) 698 (ecase type 699 (:lisp-function 700 (when-let (loc (source-location (fdefinition name))) 701 (list `((defun ,name) ,loc)))) 702 (:c-function 703 (when-let (loc (source-location (fdefinition name))) 704 (list `((c-source ,name) ,loc)))) 705 (:generic-function 706 (loop for method in (clos:generic-function-methods (fdefinition name)) 707 for specs = (clos:method-specializers method) 708 for loc = (source-location method) 709 when loc 710 collect `((defmethod ,name ,specs) ,loc))) 711 (:macro 712 (when-let (loc (source-location (macro-function name))) 713 (list `((defmacro ,name) ,loc)))) 714 (:constant 715 (when-let (loc (source-location name)) 716 (list `((defconstant ,name) ,loc)))) 717 (:global-variable 718 (when-let (loc (source-location name)) 719 (list `((defvar ,name) ,loc)))) 720 (:special-operator))) 721 722;;; FIXME: There ought to be a better way. 723(eval-when (:compile-toplevel :load-toplevel :execute) 724 (defun c-function-name-p (name) 725 (and (symbolp name) (si:mangle-name name t) t)) 726 (defun c-function-p (object) 727 (and (functionp object) 728 (let ((fn-name (function-name object))) 729 (and fn-name (c-function-name-p fn-name)))))) 730 731(deftype c-function () 732 `(satisfies c-function-p)) 733 734(defun assert-source-directory () 735 (unless (probe-file #P"SRC:") 736 (error "ECL's source directory ~A does not exist. ~ 737 You can specify a different location via the environment ~ 738 variable `ECLSRCDIR'." 739 (namestring (translate-logical-pathname #P"SYS:"))))) 740 741(defun assert-TAGS-file () 742 (unless (probe-file +TAGS+) 743 (error "No TAGS file ~A found. It should have been installed with ECL." 744 +TAGS+))) 745 746(defun package-names (package) 747 (cons (package-name package) (package-nicknames package))) 748 749(defun source-location (object) 750 (converting-errors-to-error-location 751 (typecase object 752 (c-function 753 (assert-source-directory) 754 (assert-TAGS-file) 755 (let ((lisp-name (function-name object))) 756 (assert lisp-name) 757 (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t) 758 (assert flag) 759 ;; In ECL's code base sometimes the mangled name is used 760 ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or 761 ;; @EXT::SYMBOL is used. We cannot predict here, so we just 762 ;; provide several candidates. 763 (apply #'make-TAGS-location 764 c-name 765 (loop with s = (symbol-name lisp-name) 766 for p in (package-names (symbol-package lisp-name)) 767 collect (format nil "~A::~A" p s) 768 collect (format nil "~(~A::~A~)" p s)))))) 769 (function 770 (multiple-value-bind (file pos) (ext:compiled-function-file object) 771 (cond ((not file) 772 (return-from source-location nil)) 773 ((tmpfile-to-buffer file) 774 (make-buffer-location (tmpfile-to-buffer file) pos)) 775 (t 776 (assert (probe-file file)) 777 (assert (not (minusp pos))) 778 (make-file-location file pos))))) 779 (method 780 ;; FIXME: This will always return NIL at the moment; ECL does not 781 ;; store debug information for methods yet. 782 (source-location (clos:method-function object))) 783 ((member nil t) 784 (multiple-value-bind (flag c-name) (si:mangle-name object) 785 (assert flag) 786 (make-TAGS-location c-name)))))) 787 788(defimplementation find-source-location (object) 789 (or (source-location object) 790 (make-error-location "Source definition of ~S not found." object))) 791 792;;; buffer-first-change 793 794 795;;;; XREF 796 797;;; who-calls 798;;; calls-who 799;;; who-references 800;;; who-binds 801;;; who-sets 802;;; who-macroexpands 803;;; who-specializes 804;;; list-callers 805;;; list-callees 806 807 808;;;; Profiling 809 810;;; XXX: use monitor.lisp (ccl,clisp) 811 812#+profile 813(progn 814 815(defimplementation profile (fname) 816 (when fname (eval `(profile:profile ,fname)))) 817 818(defimplementation unprofile (fname) 819 (when fname (eval `(profile:unprofile ,fname)))) 820 821(defimplementation unprofile-all () 822 (profile:unprofile-all) 823 "All functions unprofiled.") 824 825(defimplementation profile-report () 826 (profile:report)) 827 828(defimplementation profile-reset () 829 (profile:reset) 830 "Reset profiling counters.") 831 832(defimplementation profiled-functions () 833 (profile:profile)) 834 835(defimplementation profile-package (package callers methods) 836 (declare (ignore callers methods)) 837 (eval `(profile:profile ,(package-name (find-package package))))) 838) ; #+profile (progn ... 839 840 841;;;; Trace 842 843;;; Toggle tracing of the function(s) given with SPEC. 844;;; SPEC can be: 845;;; (setf NAME) ; a setf function 846;;; (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method 847;;; (:defgeneric NAME) ; a generic function with all methods 848;;; (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. 849;;; (:labels TOPLEVEL LOCAL) 850;;; (:flet TOPLEVEL LOCAL) 851;;; 852;;; toggle-trace (spec) 853 854 855;;;; Inspector 856 857;;; FIXME: Would be nice if it was possible to inspect objects 858;;; implemented in C. 859 860;;; Return a list of bindings corresponding to OBJECT's slots. 861;;; eval-context (object) 862 863;;; Return a string describing the primitive type of object. 864;;; describe-primitive-type (object) 865 866 867;;;; Multithreading 868 869;;; Not needed in ECL 870;;; 871;;; initialize-multiprocessing 872 873#+threads 874(progn 875 (defvar *thread-id-counter* 0) 876 877 (defparameter *thread-id-map* (make-hash-table)) 878 879 (defvar *thread-id-map-lock* 880 (mp:make-lock :name "thread id map lock")) 881 882 (defimplementation spawn (fn &key name) 883 (mp:process-run-function name fn)) 884 885 (defimplementation thread-id (target-thread) 886 (block thread-id 887 (mp:with-lock (*thread-id-map-lock*) 888 ;; Does TARGET-THREAD have an id already? 889 (maphash (lambda (id thread-pointer) 890 (let ((thread (si:weak-pointer-value thread-pointer))) 891 (cond ((not thread) 892 (remhash id *thread-id-map*)) 893 ((eq thread target-thread) 894 (return-from thread-id id))))) 895 *thread-id-map*) 896 ;; TARGET-THREAD not found in *THREAD-ID-MAP* 897 (let ((id (incf *thread-id-counter*)) 898 (thread-pointer (si:make-weak-pointer target-thread))) 899 (setf (gethash id *thread-id-map*) thread-pointer) 900 id)))) 901 902 (defimplementation find-thread (id) 903 (mp:with-lock (*thread-id-map-lock*) 904 (let* ((thread-ptr (gethash id *thread-id-map*)) 905 (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) 906 (unless thread 907 (remhash id *thread-id-map*)) 908 thread))) 909 910 (defimplementation thread-name (thread) 911 (mp:process-name thread)) 912 913 (defimplementation thread-status (thread) 914 (if (mp:process-active-p thread) 915 "RUNNING" 916 "STOPPED")) 917 918 ;; thread-attributes 919 920 (defimplementation current-thread () 921 mp:*current-process*) 922 923 (defimplementation all-threads () 924 (mp:all-processes)) 925 926 (defimplementation thread-alive-p (thread) 927 (mp:process-active-p thread)) 928 929 (defimplementation interrupt-thread (thread fn) 930 (mp:interrupt-process thread fn)) 931 932 (defimplementation kill-thread (thread) 933 (mp:process-kill thread)) 934 935 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) 936 (defvar *mailboxes* (list)) 937 (declaim (type list *mailboxes*)) 938 939 (defstruct (mailbox (:conc-name mailbox.)) 940 thread 941 (mutex (mp:make-lock)) 942 (cvar (mp:make-condition-variable)) 943 (queue '() :type list)) 944 945 (defun mailbox (thread) 946 "Return THREAD's mailbox." 947 (mp:with-lock (*mailbox-lock*) 948 (or (find thread *mailboxes* :key #'mailbox.thread) 949 (let ((mb (make-mailbox :thread thread))) 950 (push mb *mailboxes*) 951 mb)))) 952 953 (defimplementation send (thread message) 954 (let* ((mbox (mailbox thread)) 955 (mutex (mailbox.mutex mbox))) 956 (mp:with-lock (mutex) 957 (setf (mailbox.queue mbox) 958 (nconc (mailbox.queue mbox) (list message))) 959 (mp:condition-variable-broadcast (mailbox.cvar mbox))))) 960 961 ;; receive 962 963 (defimplementation receive-if (test &optional timeout) 964 (let* ((mbox (mailbox (current-thread))) 965 (mutex (mailbox.mutex mbox))) 966 (assert (or (not timeout) (eq timeout t))) 967 (loop 968 (check-slime-interrupts) 969 (mp:with-lock (mutex) 970 (let* ((q (mailbox.queue mbox)) 971 (tail (member-if test q))) 972 (when tail 973 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) 974 (return (car tail)))) 975 (when (eq timeout t) (return (values nil t))) 976 (mp:condition-variable-wait (mailbox.cvar mbox) mutex))))) 977 978 ;; Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using 979 ;; asynchronous interrupts. 980 ;; 981 ;; Doesn't have to implement this if RECEIVE-IF periodically calls 982 ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient. 983 ;; 984 ;; wake-thread (thread) 985 986 ;; Copied from sbcl.lisp and adjusted to ECL. 987 (let ((alist '()) 988 (mutex (mp:make-lock :name "register-thread"))) 989 990 (defimplementation register-thread (name thread) 991 (declare (type symbol name)) 992 (mp:with-lock (mutex) 993 (etypecase thread 994 (null 995 (setf alist (delete name alist :key #'car))) 996 (mp:process 997 (let ((probe (assoc name alist))) 998 (cond (probe (setf (cdr probe) thread)) 999 (t (setf alist (acons name thread alist)))))))) 1000 nil) 1001 1002 (defimplementation find-registered (name) 1003 (mp:with-lock (mutex) 1004 (cdr (assoc name alist))))) 1005 1006 ;; Not needed in ECL (?). 1007 ;; 1008 ;; set-default-initial-binding (var form) 1009 1010 ) ; #+threads 1011 1012;;; Instead of busy waiting with communication-style NIL, use select() 1013;;; on the sockets' streams. 1014#+serve-event 1015(defimplementation wait-for-input (streams &optional timeout) 1016 (assert (member timeout '(nil t))) 1017 (flet ((poll-streams (streams timeout) 1018 (let* ((serve-event::*descriptor-handlers* 1019 (copy-list serve-event::*descriptor-handlers*)) 1020 (active-fds '()) 1021 (fd-stream-alist 1022 (loop for s in streams 1023 for fd = (socket-fd s) 1024 collect (cons fd s) 1025 do (serve-event:add-fd-handler fd :input 1026 #'(lambda (fd) 1027 (push fd active-fds)))))) 1028 (serve-event:serve-event timeout) 1029 (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))) 1030 (loop 1031 (cond ((check-slime-interrupts) (return :interrupt)) 1032 (timeout (return (poll-streams streams 0))) 1033 (t 1034 (when-let (ready (poll-streams streams 0.2)) 1035 (return ready))))))) 1036 1037#-serve-event 1038(defimplementation wait-for-input (streams &optional timeout) 1039 (assert (member timeout '(nil t))) 1040 (loop 1041 (cond ((check-slime-interrupts) (return :interrupt)) 1042 (timeout (return (remove-if-not #'listen streams))) 1043 (t 1044 (let ((ready (remove-if-not #'listen streams))) 1045 (if ready (return ready)) 1046 (sleep 0.1)))))) 1047 1048 1049;;;; Locks 1050 1051#+threads 1052(defimplementation make-lock (&key name) 1053 (mp:make-lock :name name :recursive t)) 1054 1055(defimplementation call-with-lock-held (lock function) 1056 (declare (type function function)) 1057 (mp:with-lock (lock) (funcall function))) 1058 1059 1060;;;; Weak datastructures 1061 1062;;; XXX: this should work but causes SLIME REPL hang at some point of time. May 1063;;; be ECL or SLIME bug - disabling for now. 1064#+(and ecl-weak-hash (or)) 1065(progn 1066 (defimplementation make-weak-key-hash-table (&rest args) 1067 (apply #'make-hash-table :weakness :key args)) 1068 1069 (defimplementation make-weak-value-hash-table (&rest args) 1070 (apply #'make-hash-table :weakness :value args)) 1071 1072 (defimplementation hash-table-weakness (hashtable) 1073 (ext:hash-table-weakness hashtable))) 1074 1075 1076;;;; Character names 1077 1078;;; Default implementation is fine. 1079;;; 1080;;; character-completion-set (prefix matchp) 1081 1082 1083;;;; Heap dumps 1084 1085;;; Doesn't apply to ECL. 1086;;; 1087;;; save-image (filename &optional restart-function) 1088;;; background-save-image (filename &key restart-function completion-function) 1089 1090 1091;;;; Wrapping 1092 1093;;; Intercept future calls to SPEC and surround them in callbacks. 1094;;; Very much similar to so-called advices for normal functions. 1095;;; 1096;;; wrap (spec indicator &key before after replace) 1097;;; unwrap (spec indicator) 1098;;; wrapped-p (spec indicator) 1099