dotemacs

ecl.lisp (35049B)

---

 ;;;; -*- indent-tabs-mode: nil -*-
 ;;;
 ;;; slynk-ecl.lisp --- SLY backend for ECL.
 ;;;
 ;;; This code has been placed in the Public Domain.  All warranties
 ;;; are disclaimed.
 ;;;
 
 ;;; Administrivia
 
 (defpackage slynk-ecl
   (:use cl slynk-backend))
 
 (in-package slynk-ecl)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun ecl-version ()
     (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
       (if version
           (symbol-value version)
           0)))
   (when (< (ecl-version) 100301)
     (error "~&IMPORTANT:~%  ~
               The version of ECL you're using (~A) is too old.~%  ~
               Please upgrade to at least 10.3.1.~%  ~
               Sorry for the inconvenience.~%~%"
            (lisp-implementation-version))))
 
 ;; Hard dependencies.
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (require 'sockets))
 
 ;; Soft dependencies.
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (when (probe-file "sys:profile.fas")
     (require :profile)
     (pushnew :profile *features*))
   (when (probe-file "sys:serve-event.fas")
     (require :serve-event)
     (pushnew :serve-event *features*)))
 
 (declaim (optimize (debug 3)))
 
 ;;; Slynk-mop
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (import-slynk-mop-symbols
    :clos
    (and (< (ecl-version) 121201)
         `(:eql-specializer
           :eql-specializer-object
           :generic-function-declarations
           :specializer-direct-methods
           ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
               '(:compute-applicable-methods-using-classes))))))
 
 (defimplementation gray-package-name ()
   "GRAY")
 
 
 ;;;; UTF8
 
 ;;; Convert the string STRING to a (simple-array (unsigned-byte 8)).
 ;;;
 ;;;   string-to-utf8 (string)
 
 ;;; Convert the (simple-array (unsigned-byte 8)) OCTETS to a string.
 ;;;
 ;;;   utf8-to-string (octets)
 
 
 ;;;; TCP Server
 
 (defun resolve-hostname (name)
   (car (sb-bsd-sockets:host-ent-addresses
         (sb-bsd-sockets:get-host-by-name name))))
 
 (defimplementation create-socket (host port &key backlog)
   (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
 			       :type :stream
 			       :protocol :tcp)))
     (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
     (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
     (sb-bsd-sockets:socket-listen socket (or backlog 5))
     socket))
 
 (defimplementation local-port (socket)
   (nth-value 1 (sb-bsd-sockets:socket-name socket)))
 
 (defimplementation close-socket (socket)
   (sb-bsd-sockets:socket-close socket))
 
 (defun accept (socket)
   "Like socket-accept, but retry on EAGAIN."
   (loop (handler-case
             (return (sb-bsd-sockets:socket-accept socket))
           (sb-bsd-sockets:interrupted-error ()))))
 
 (defimplementation accept-connection (socket
                                       &key external-format
                                       buffering timeout)
   (declare (ignore timeout))
   (sb-bsd-sockets:socket-make-stream (accept socket)
                                      :output t
                                      :input t
                                      :buffering (ecase buffering
                                                   ((t) :full)
                                                   ((nil) :none)
                                                   (:line :line))
                                      :element-type (if external-format
                                                        'character 
                                                        '(unsigned-byte 8))
                                      :external-format external-format))
 
 ;;; Call FN whenever SOCKET is readable.
 ;;;
 ;;;   add-sigio-handler (socket fn)
 
 ;;; Remove all sigio handlers for SOCKET.
 ;;;
 ;;;   remove-sigio-handlers (socket)
 
 ;;; Call FN when Lisp is waiting for input and SOCKET is readable.
 ;;;
 ;;;   add-fd-handler (socket fn)
 
 ;;; Remove all fd-handlers for SOCKET.
 ;;;
 ;;;   remove-fd-handlers (socket)
 
 (defimplementation preferred-communication-style ()
   (cond
     ((member :threads *features*) :spawn)
     ((member :windows *features*) nil)
     (t #|:fd-handler|# nil)))
 
 ;;; Set the 'stream 'timeout.  The timeout is either the real number
 ;;; specifying the timeout in seconds or 'nil for no timeout.
 ;;;
 ;;;   set-stream-timeout (stream timeout)
 
 
 ;;; Hook called when the first connection from Emacs is established.
 ;;; Called from the INIT-FN of the socket server that accepts the
 ;;; connection.
 ;;;
 ;;; This is intended for setting up extra context, e.g. to discover
 ;;; that the calling thread is the one that interacts with Emacs.
 ;;;
 ;;;   emacs-connected ()
 
 
 ;;;; Unix Integration
 
 (defimplementation getpid ()
   (si:getpid))
 
 ;;; Call FUNCTION on SIGINT (instead of invoking the debugger).
 ;;; Return old signal handler.
 ;;;
 ;;;   install-sigint-handler (function)
 
 ;;; XXX!
 ;;; If ECL is built with thread support, it'll spawn a helper thread
 ;;; executing the SIGINT handler. We do not want to BREAK into that
 ;;; helper but into the main thread, though. This is coupled with the
 ;;; current choice of NIL as communication-style in so far as ECL's
 ;;; main-thread is also the Sly's REPL thread.
 
 (defun make-interrupt-handler (real-handler)
   #+threads
   (let ((main-thread (find 'si:top-level (mp:all-processes)
                            :key #'mp:process-name)))
     #'(lambda (&rest args)
         (declare (ignore args))
         (mp:interrupt-process main-thread real-handler)))
   #-threads
   #'(lambda (&rest args)
       (declare (ignore args))
       (funcall real-handler)))
 
 (defimplementation call-with-user-break-handler (real-handler function)
   (let ((old-handler #'si:terminal-interrupt))
     (setf (symbol-function 'si:terminal-interrupt)
           (make-interrupt-handler real-handler))
     (unwind-protect (funcall function)
       (setf (symbol-function 'si:terminal-interrupt) old-handler))))
 
 (defimplementation quit-lisp ()
   (ext:quit))
 
 ;;; Default implementation is fine.
 ;;;
 ;;;   lisp-implementation-type-name
 ;;;   lisp-implementation-program
 
 (defimplementation socket-fd (socket)
   (etypecase socket
     (fixnum socket)
     (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
     (file-stream (si:file-stream-fd socket))))
 
 ;;; Create a character stream for the file descriptor FD. This
 ;;; interface implementation requires either `ffi:c-inline' or has to
 ;;; wait for the exported interface.
 ;;;
 ;;;   make-fd-stream (socket-stream)
 
 ;;; Duplicate a file descriptor. If the syscall fails, signal a
 ;;; condition. See dup(2). This interface requiers `ffi:c-inline' or
 ;;; has to wait for the exported interface.
 ;;;
 ;;;   dup (fd)
 
 ;;; Does not apply to ECL which doesn't dump images.
 ;;;
 ;;;   exec-image (image-file args)
 
 (defimplementation command-line-args ()
   (ext:command-args))
 
 
 ;;;; pathnames
 
 ;;; Return a pathname for FILENAME.
 ;;; A filename in Emacs may for example contain asterisks which should not
 ;;; be translated to wildcards.
 ;;;
 ;;;   filename-to-pathname (filename)
 
 ;;; Return the filename for PATHNAME.
 ;;;
 ;;;   pathname-to-filename (pathname)
 
 (defimplementation default-directory ()
   (namestring (ext:getcwd)))
 
 (defimplementation set-default-directory (directory)
   (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
   (default-directory))
 
 
 ;;; Call FN with hooks to handle special syntax. Can we use it for
 ;;; `ffi:c-inline' to be handled as C/C++ code?
 ;;;
 ;;;   call-with-syntax-hooks
 
 ;;; Return a suitable initial value for SLYNK:*READTABLE-ALIST*.
 ;;;
 ;;;   default-readtable-alist
 
 
 ;;;; Packages
 
 #+package-local-nicknames
 (defimplementation package-local-nicknames (package)
   (ext:package-local-nicknames package))
 
 
 ;;;; Compilation
 
 (defvar *buffer-name* nil)
 (defvar *buffer-start-position*)
 
 (defun signal-compiler-condition (&rest args)
   (apply #'signal 'compiler-condition args))
 
 #-ecl-bytecmp
 (defun handle-compiler-message (condition)
   ;; ECL emits lots of noise in compiler-notes, like "Invoking
   ;; external command".
   (unless (typep condition 'c::compiler-note)
     (signal-compiler-condition
      :original-condition condition
      :message (princ-to-string condition)
      :severity (etypecase condition
                  (c:compiler-fatal-error :error)
                  (c:compiler-error       :error)
                  (error                  :error)
                  (style-warning          :style-warning)
                  (warning                :warning))
      :location (condition-location condition))))
 
 #-ecl-bytecmp
 (defun condition-location (condition)
   (let ((file     (c:compiler-message-file condition))
         (position (c:compiler-message-file-position condition)))
     (if (and position (not (minusp position)))
         (if *buffer-name*
             (make-buffer-location *buffer-name*
                                   *buffer-start-position*
                                   position)
             (make-file-location file position))
         (make-error-location "No location found."))))
 
 (defimplementation call-with-compilation-hooks (function)
   #+ecl-bytecmp
   (funcall function)
   #-ecl-bytecmp
   (handler-bind ((c:compiler-message #'handle-compiler-message))
     (funcall function)))
 
 (defvar *tmpfile-map* (make-hash-table :test #'equal))
 
 (defun note-buffer-tmpfile (tmp-file buffer-name)
   ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
   (let ((tmp-namestring (namestring (truename tmp-file))))
     (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
     tmp-namestring))
 
 (defun tmpfile-to-buffer (tmp-file)
   (gethash tmp-file *tmpfile-map*))
 
 (defimplementation slynk-compile-string
     (string &key buffer position filename line column policy)
   (declare (ignore line column policy))
   (with-compilation-hooks ()
     (let ((*buffer-name* buffer)        ; for compilation hooks
           (*buffer-start-position* position))
       (let ((tmp-file (si:mkstemp "TMP:ecl-slynk-tmpfile-"))
             (fasl-file)
             (warnings-p)
             (failure-p))
         (unwind-protect
              (with-open-file (tmp-stream tmp-file :direction :output
                                          :if-exists :supersede)
                (write-string string tmp-stream)
                (finish-output tmp-stream)
                (multiple-value-setq (fasl-file warnings-p failure-p)
                  (compile-file tmp-file
                                :load t
                                :source-truename (or filename
                                                     (note-buffer-tmpfile tmp-file buffer))
                                :source-offset (1- position))))
           (when (probe-file tmp-file)
             (delete-file tmp-file))
           (when fasl-file
             (delete-file fasl-file)))
         (not failure-p)))))
 
 (defimplementation slynk-compile-file (input-file output-file
                                        load-p external-format
                                        &key policy)
   (declare (ignore policy))
   (with-compilation-hooks ()
     (compile-file input-file :output-file output-file
                   :load load-p
                   :external-format external-format)))
 
 (defvar *external-format-to-coding-system*
   '((:latin-1
      "latin-1" "latin-1-unix" "iso-latin-1-unix"
      "iso-8859-1" "iso-8859-1-unix")
     (:utf-8 "utf-8" "utf-8-unix")))
 
 (defun external-format (coding-system)
   (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
                       *external-format-to-coding-system*))
       (find coding-system (ext:all-encodings) :test #'string-equal)))
 
 (defimplementation find-external-format (coding-system)
   #+unicode (external-format coding-system)
   ;; Without unicode support, ECL uses the one-byte encoding of the
   ;; underlying OS, and will barf on anything except :DEFAULT.  We
   ;; return NIL here for known multibyte encodings, so
   ;; SLYNK:CREATE-SERVER will barf.
   #-unicode (let ((xf (external-format coding-system)))
               (if (member xf '(:utf-8))
                   nil
                   :default)))
 
 
 ;;; Default implementation is fine
 ;;;
 ;;;   guess-external-format
 
 
 ;;;; Streams
 
 ;;; Implemented in `gray'
 ;;;
 ;;;   make-output-stream
 ;;;   make-input-stream
 
 
 ;;;; Documentation
 
 (defimplementation arglist (name)
   (multiple-value-bind (arglist foundp)
       (ext:function-lambda-list name)
     (if foundp arglist :not-available)))
 
 (defimplementation type-specifier-p (symbol)
   (or (subtypep nil symbol)
       (not (eq (type-specifier-arglist symbol) :not-available))))
 
 (defimplementation function-name (f)
   (typecase f
     (generic-function (clos:generic-function-name f))
     (function (si:compiled-function-name f))))
 
 ;;; Default implementation is fine (CL).
 ;;; 
 ;;; valid-function-name-p (form)
 
 #+walker
 (defimplementation macroexpand-all (form &optional env)
   (walker:macroexpand-all form env))
 
 ;;; Default implementation is fine.
 ;;;
 ;;;   compiler-macroexpand-1
 ;;;   compiler-macroexpand
 
 (defimplementation describe-symbol-for-emacs (symbol)
   (let ((result '()))
     (flet ((frob (type boundp)
              (when (funcall boundp symbol)
                (let ((doc (describe-definition symbol type)))
                  (setf result (list* type doc result))))))
       (frob :VARIABLE #'boundp)
       (frob :FUNCTION #'fboundp)
       (frob :CLASS (lambda (x) (find-class x nil))))
     result))
 
 (defimplementation describe-definition (name type)
   (case type
     (:variable (documentation name 'variable))
     (:function (documentation name 'function))
     (:class (documentation name 'class))
     (t nil)))
 
 
 ;;;; Debugging
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (import
    '(si::*break-env*
      si::*ihs-top*
      si::*ihs-current*
      si::*ihs-base*
      si::*frs-base*
      si::*frs-top*
      si::*tpl-commands*
      si::*tpl-level*
      si::frs-top
      si::ihs-top
      si::ihs-fun
      si::ihs-env
      si::sch-frs-base
      si::set-break-env
      si::set-current-ihs
      si::tpl-commands)))
 
 (defun make-invoke-debugger-hook (hook)
   (when hook
     #'(lambda (condition old-hook)
         ;; Regard *debugger-hook* if set by user.
         (if *debugger-hook*
             nil         ; decline, *DEBUGGER-HOOK* will be tried next.
             (funcall hook condition old-hook)))))
 
 (defimplementation install-debugger-globally (function)
   (setq *debugger-hook* function)
   (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
 
 (defimplementation call-with-debugger-hook (hook fun)
   (let ((*debugger-hook* hook)
         (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
     (funcall fun)))
 
 (defvar *backtrace* '())
 
 ;;; Commented out; it's not clear this is a good way of doing it. In
 ;;; particular because it makes errors stemming from this file harder
 ;;; to debug, and given the "young" age of ECL's slynk backend, that's
 ;;; a bad idea.
 ;;;
 ;;; Also before thinking whether to uncomment this consider that SLY
 ;;; might not be loaded with slynk-loader.lisp at all.
 
 ;; (defun in-slynk-package-p (x)
 ;;   (and
 ;;    (symbolp x)
 ;;    (member (symbol-package x)
 ;;            (list #.(find-package :slynk)
 ;;                  #.(find-package :slynk-backend)
 ;;                  #.(ignore-errors (find-package :slynk-mop))
 ;;                  #.(ignore-errors (find-package :slynk-loader))))
 ;;    t))
 
 ;; (defun is-slynk-source-p (name)
 ;;   (setf name (pathname name))
 ;;   (pathname-match-p
 ;;    name
 ;;    (make-pathname :defaults slynk-loader::*source-directory*
 ;;                   :name (pathname-name name)
 ;;                   :type (pathname-type name)
 ;;                   :version (pathname-version name))))
 
 ;; (defun is-ignorable-fun-p (x)
 ;;   (or
 ;;    (in-slynk-package-p (frame-name x))
 ;;    (multiple-value-bind (file position)
 ;;        (ignore-errors (si::bc-file (car x)))
 ;;      (declare (ignore position))
 ;;      (if file (is-slynk-source-p file)))))
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
   (let* ((*ihs-top* (ihs-top))
          (*ihs-current* *ihs-top*)
          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
          (*frs-top* (frs-top))
          (*tpl-level* (1+ *tpl-level*))
          (*backtrace* (loop for ihs from 0 below *ihs-top*
                             collect (list (si::ihs-fun ihs)
                                           (si::ihs-env ihs)
                                           nil))))
     (declare (special *ihs-current*))
     (loop for f from *frs-base* until *frs-top*
           do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
                (when (plusp i)
                  (let* ((x (elt *backtrace* i))
                         (name (si::frs-tag f)))
                    (unless (si::fixnump name)
                      (push name (third x)))))))
     ;; (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
     (setf *backtrace* (nreverse *backtrace*))
     (set-break-env)
     (set-current-ihs)
     (let ((*ihs-base* *ihs-top*))
       (funcall debugger-loop-fn))))
 
 (defimplementation compute-backtrace (start end)
   (subseq *backtrace* start
           (and (numberp end)
                (min end (length *backtrace*)))))
 
 (defun frame-name (frame)
   (let ((x (first frame)))
     (if (symbolp x)
         x
         (function-name x))))
 
 (defun function-position (fun)
   (multiple-value-bind (file position)
       (si::bc-file fun)
     (when file
       (make-file-location file position))))
 
 (defun frame-function (frame)
   (let* ((x (first frame))
          fun position)
     (etypecase x
       (symbol (and (fboundp x)
                    (setf fun (fdefinition x)
                          position (function-position fun))))
       (function (setf fun x position (function-position x))))
     (values fun position)))
 
 (defun frame-decode-env (frame)
   (let ((functions '())
         (blocks '())
         (variables '()))
     (setf frame (si::decode-ihs-env (second frame)))
     (dolist (record (remove-if-not #'consp frame))
       (let* ((record0 (car record))
 	     (record1 (cdr record)))
 	(cond ((or (symbolp record0) (stringp record0))
 	       (setq variables (acons record0 record1 variables)))
 	      ((not (si::fixnump record0))
 	       (push record1 functions))
 	      ((symbolp record1)
 	       (push record1 blocks))
 	      (t
 	       ))))
     (values functions blocks variables)))
 
 (defimplementation print-frame (frame stream)
   (format stream "~A" (first frame)))
 
 ;;; Is the frame FRAME restartable?.
 ;;; Return T if `restart-frame' can safely be called on the frame.
 ;;;
 ;;; frame-restartable-p (frame)
 
 (defimplementation frame-source-location (frame-number)
   (let ((frame (elt *backtrace* frame-number)))
     (or (nth-value 1 (frame-function frame))
         (make-error-location "Unknown source location for ~A." (car frame)))))
 
 (defimplementation frame-catch-tags (frame-number)
   (third (elt *backtrace* frame-number)))
 
 (defimplementation frame-locals (frame-number)
   (loop for (name . value) in (nth-value 2 (frame-decode-env
                                             (elt *backtrace* frame-number)))
         collect (list :name name :id 0 :value value)))
 
 (defimplementation frame-var-value (frame-number var-number)
   (destructuring-bind (name . value)
       (elt
        (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
        var-number)
     (declare (ignore name))
     value))
 
 (defimplementation disassemble-frame (frame-number)
   (let ((fun (frame-function (elt *backtrace* frame-number))))
     (disassemble fun)))
 
 (defimplementation eval-in-frame (form frame-number)
   (let ((env (second (elt *backtrace* frame-number))))
     (si:eval-with-env form env)))
 
 ;;; frame-package
 ;;; frame-call
 ;;; return-from-frame
 ;;; restart-frame
 ;;; print-condition
 ;;; condition-extras
 
 (defimplementation gdb-initial-commands ()
   ;; These signals are used by the GC.
   #+linux '("handle SIGPWR  noprint nostop"
             "handle SIGXCPU noprint nostop"))
 
 ;;; active-stepping
 ;;; sldb-break-on-return
 ;;; sldb-break-at-start
 ;;; sldb-stepper-condition-p
 ;;; sldb-setp-into
 ;;; sldb-step-next
 ;;; sldb-step-out
 
 
 ;;;; Definition finding
 
 (defvar +TAGS+ (namestring
                 (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
 
 (defun make-file-location (file file-position)
   ;; File positions in CL start at 0, but Emacs' buffer positions
   ;; start at 1. We specify (:ALIGN T) because the positions comming
   ;; from ECL point at right after the toplevel form appearing before
   ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
   (make-location `(:file ,(namestring (translate-logical-pathname file)))
                  `(:position ,(1+ file-position))
                  `(:align t)))
 
 (defun make-buffer-location (buffer-name start-position &optional (offset 0))
   (make-location `(:buffer ,buffer-name)
                  `(:offset ,start-position ,offset)
                  `(:align t)))
 
 (defun make-TAGS-location (&rest tags)
   (make-location `(:etags-file ,+TAGS+)
                  `(:tag ,@tags)))
 
 (defimplementation find-definitions (name)
   (let ((annotations (ext:get-annotation name 'si::location :all)))
     (cond (annotations
            (loop for annotation in annotations
                  collect (destructuring-bind (dspec file . pos) annotation
                            `(,dspec ,(make-file-location file pos)))))
           (t
            (mapcan #'(lambda (type) (find-definitions-by-type name type))
                    (classify-definition-name name))))))
 
 (defun classify-definition-name (name)
   (let ((types '()))
     (when (fboundp name)
       (cond ((special-operator-p name)
              (push :special-operator types))
             ((macro-function name)
              (push :macro types))
             ((typep (fdefinition name) 'generic-function)
              (push :generic-function types))
             ((si:mangle-name name t)
              (push :c-function types))
             (t
              (push :lisp-function types))))
     (when (boundp name)
       (cond ((constantp name)
              (push :constant types))
             (t
              (push :global-variable types))))
     types))
 
 (defun find-definitions-by-type (name type)
   (ecase type
     (:lisp-function
      (when-let (loc (source-location (fdefinition name)))
        (list `((defun ,name) ,loc))))
     (:c-function
      (when-let (loc (source-location (fdefinition name)))
        (list `((c-source ,name) ,loc))))
     (:generic-function
      (loop for method in (clos:generic-function-methods (fdefinition name))
            for specs = (clos:method-specializers method)
            for loc   = (source-location method)
            when loc
              collect `((defmethod ,name ,specs) ,loc)))
     (:macro
      (when-let (loc (source-location (macro-function name)))
        (list `((defmacro ,name) ,loc))))
     (:constant
      (when-let (loc (source-location name))
        (list `((defconstant ,name) ,loc))))
     (:global-variable
      (when-let (loc (source-location name))
        (list `((defvar ,name) ,loc))))
     (:special-operator)))
 
 ;;; FIXME: There ought to be a better way.
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun c-function-name-p (name)
     (and (symbolp name) (si:mangle-name name t) t))
   (defun c-function-p (object)
     (and (functionp object)
          (let ((fn-name (function-name object)))
            (and fn-name (c-function-name-p fn-name))))))
 
 (deftype c-function ()
   `(satisfies c-function-p))
 
 (defun assert-source-directory ()
   (unless (probe-file #P"SRC:")
     (error "ECL's source directory ~A does not exist. ~
             You can specify a different location via the environment ~
             variable `ECLSRCDIR'."
            (namestring (translate-logical-pathname #P"SYS:"))))) 
 
 (defun assert-TAGS-file ()
   (unless (probe-file +TAGS+)
     (error "No TAGS file ~A found. It should have been installed with ECL."
            +TAGS+)))
 
 (defun package-names (package)
   (cons (package-name package) (package-nicknames package)))
 
 (defun source-location (object)
   (converting-errors-to-error-location
    (typecase object
      (c-function
       (assert-source-directory)
       (assert-TAGS-file)
       (let ((lisp-name (function-name object)))
         (assert lisp-name)
         (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
           (assert flag)
           ;; In ECL's code base sometimes the mangled name is used
           ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
           ;; @EXT::SYMBOL is used. We cannot predict here, so we just
           ;; provide several candidates.
           (apply #'make-TAGS-location
                  c-name
                  (loop with s = (symbol-name lisp-name)
                        for p in (package-names (symbol-package lisp-name))
                        collect (format nil "~A::~A" p s)
                        collect (format nil "~(~A::~A~)" p s))))))
      (function
       (multiple-value-bind (file pos) (ext:compiled-function-file object)
         (cond ((not file)
                (return-from source-location nil))
               ((tmpfile-to-buffer file)
                (make-buffer-location (tmpfile-to-buffer file) pos))
               (t
                (assert (probe-file file))
                (assert (not (minusp pos)))
                (make-file-location file pos)))))
      (method
       ;; FIXME: This will always return NIL at the moment; ECL does not
       ;; store debug information for methods yet.
       (source-location (clos:method-function object)))
      ((member nil t)
       (multiple-value-bind (flag c-name) (si:mangle-name object)
         (assert flag)
         (make-TAGS-location c-name))))))
 
 (defimplementation find-source-location (object)
   (or (source-location object)
       (make-error-location "Source definition of ~S not found." object)))
 
 ;;; buffer-first-change
 
 
 ;;;; XREF
 
 ;;; who-calls
 ;;; calls-who
 ;;; who-references
 ;;; who-binds
 ;;; who-sets
 ;;; who-macroexpands
 ;;; who-specializes
 ;;; list-callers
 ;;; list-callees
 
 
 ;;;; Profiling
 
 ;;; XXX: use monitor.lisp (ccl,clisp)
 
 #+profile
 (progn
 
 (defimplementation profile (fname)
   (when fname (eval `(profile:profile ,fname))))
 
 (defimplementation unprofile (fname)
   (when fname (eval `(profile:unprofile ,fname))))
 
 (defimplementation unprofile-all ()
   (profile:unprofile-all)
   "All functions unprofiled.")
 
 (defimplementation profile-report ()
   (profile:report))
 
 (defimplementation profile-reset ()
   (profile:reset)
   "Reset profiling counters.")
 
 (defimplementation profiled-functions ()
   (profile:profile))
 
 (defimplementation profile-package (package callers methods)
   (declare (ignore callers methods))
   (eval `(profile:profile ,(package-name (find-package package)))))
 ) ; #+profile (progn ...
 
 
 ;;;; Trace
 
 ;;; Toggle tracing of the function(s) given with SPEC.
 ;;; SPEC can be:
 ;;;  (setf NAME)                            ; a setf function
 ;;;  (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
 ;;;  (:defgeneric NAME)                     ; a generic function with all methods
 ;;;  (:call CALLER CALLEE)                  ; trace calls from CALLER to CALLEE.
 ;;;  (:labels TOPLEVEL LOCAL)
 ;;;  (:flet TOPLEVEL LOCAL) 
 ;;;
 ;;;   toggle-trace (spec)
 
 
 ;;;; Inspector
 
 ;;; FIXME: Would be nice if it was possible to inspect objects
 ;;; implemented in C.
 
 ;;; Return a list of bindings corresponding to OBJECT's slots.
 ;;;   eval-context (object)
 
 ;;; Return a string describing the primitive type of object.
 ;;;   describe-primitive-type (object)
 
 
 ;;;; Multithreading
 
 ;;; Not needed in ECL
 ;;;
 ;;;   initialize-multiprocessing
 
 #+threads
 (progn
   (defvar *thread-id-counter* 0)
 
   (defparameter *thread-id-map* (make-hash-table))
 
   (defvar *thread-id-map-lock*
     (mp:make-lock :name "thread id map lock"))
 
   (defimplementation spawn (fn &key name)
     (mp:process-run-function name fn))
 
   (defimplementation thread-id (target-thread)
     (block thread-id
       (mp:with-lock (*thread-id-map-lock*)
         ;; Does TARGET-THREAD have an id already?
         (maphash (lambda (id thread-pointer)
                    (let ((thread (si:weak-pointer-value thread-pointer)))
                      (cond ((not thread)
                             (remhash id *thread-id-map*))
                            ((eq thread target-thread)
                             (return-from thread-id id)))))
                  *thread-id-map*)
         ;; TARGET-THREAD not found in *THREAD-ID-MAP*
         (let ((id (incf *thread-id-counter*))
               (thread-pointer (si:make-weak-pointer target-thread)))
           (setf (gethash id *thread-id-map*) thread-pointer)
           id))))
 
   (defimplementation find-thread (id)
     (mp:with-lock (*thread-id-map-lock*)
       (let* ((thread-ptr (gethash id *thread-id-map*))
              (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
         (unless thread
           (remhash id *thread-id-map*))
         thread)))
 
   (defimplementation thread-name (thread)
     (mp:process-name thread))
 
   (defimplementation thread-status (thread)
     (if (mp:process-active-p thread)
         "RUNNING"
         "STOPPED"))
 
   ;; thread-attributes
 
   (defimplementation current-thread ()
     mp:*current-process*)
 
   (defimplementation all-threads ()
     (mp:all-processes))
 
   (defimplementation thread-alive-p (thread)
     (mp:process-active-p thread))
 
   (defimplementation interrupt-thread (thread fn)
     (mp:interrupt-process thread fn))
 
   (defimplementation kill-thread (thread)
     (mp:process-kill thread))
 
   (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
   (defvar *mailboxes* (list))
   (declaim (type list *mailboxes*))
 
   (defstruct (mailbox (:conc-name mailbox.))
     thread
     (mutex (mp:make-lock))
     (cvar  (mp:make-condition-variable))
     (queue '() :type list))
 
   (defun mailbox (thread)
     "Return THREAD's mailbox."
     (mp:with-lock (*mailbox-lock*)
       (or (find thread *mailboxes* :key #'mailbox.thread)
           (let ((mb (make-mailbox :thread thread)))
             (push mb *mailboxes*)
             mb))))
 
   (defimplementation send (thread message)
     (let* ((mbox (mailbox thread))
            (mutex (mailbox.mutex mbox)))
       (mp:with-lock (mutex)
         (setf (mailbox.queue mbox)
               (nconc (mailbox.queue mbox) (list message)))
         (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
 
   ;; receive
 
   (defimplementation receive-if (test &optional timeout)
     (let* ((mbox (mailbox (current-thread)))
            (mutex (mailbox.mutex mbox)))
       (assert (or (not timeout) (eq timeout t)))
       (loop
          (check-sly-interrupts)
          (mp:with-lock (mutex)
            (let* ((q (mailbox.queue mbox))
                   (tail (member-if test q)))
              (when tail
                (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
                (return (car tail))))
            (when (eq timeout t) (return (values nil t)))
            (mp:condition-variable-wait (mailbox.cvar mbox) mutex)))))
 
   ;; Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using
   ;; asynchronous interrupts.
   ;;
   ;; Doesn't have to implement this if RECEIVE-IF periodically calls
   ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient.
   ;;
   ;;   wake-thread (thread)
 
   ;; Copied from sbcl.lisp and adjusted to ECL.
   (let ((alist '())
         (mutex (mp:make-lock :name "register-thread")))
 
     (defimplementation register-thread (name thread)
       (declare (type symbol name))
       (mp:with-lock (mutex)
         (etypecase thread
           (null
            (setf alist (delete name alist :key #'car)))
           (mp:process
            (let ((probe (assoc name alist)))
              (cond (probe (setf (cdr probe) thread))
                    (t (setf alist (acons name thread alist))))))))
       nil)
 
     (defimplementation find-registered (name)
       (mp:with-lock (mutex)
         (cdr (assoc name alist)))))
 
   ;; Not needed in ECL (?).
   ;;
   ;;   set-default-initial-binding (var form)
 
   ) ; #+threads
 
 ;;; Instead of busy waiting with communication-style NIL, use select()
 ;;; on the sockets' streams.
 #+serve-event
 (defimplementation wait-for-input (streams &optional timeout)
   (assert (member timeout '(nil t)))
   (flet ((poll-streams (streams timeout)
            (let* ((serve-event::*descriptor-handlers*
                    (copy-list serve-event::*descriptor-handlers*))
                   (active-fds '())
                   (fd-stream-alist
                    (loop for s in streams
                       for fd = (socket-fd s)
                       collect (cons fd s)
                       do (serve-event:add-fd-handler fd :input
                                                      #'(lambda (fd)
                                                          (push fd active-fds))))))
              (serve-event:serve-event timeout)
              (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))))
     (loop
        (cond ((check-slime-interrupts) (return :interrupt))
              (timeout (return (poll-streams streams 0)))
              (t
               (when-let (ready (poll-streams streams 0.2))
                 (return ready)))))))
 
 #-serve-event
 (defimplementation wait-for-input (streams &optional timeout)
   (assert (member timeout '(nil t)))
   (loop
    (cond ((check-slime-interrupts) (return :interrupt))
          (timeout (return (remove-if-not #'listen streams)))
          (t
           (let ((ready (remove-if-not #'listen streams)))
             (if ready (return ready))
             (sleep 0.1))))))
 
 
 ;;;; Locks
 
 #+threads
 (defimplementation make-lock (&key name)
   (mp:make-lock :name name :recursive t))
 
 (defimplementation call-with-lock-held (lock function)
   (declare (type function function))
   (mp:with-lock (lock) (funcall function)))
 
 
 ;;;; Weak datastructures
 
 ;;; XXX: this should work but causes SLIME REPL hang at some point of time. May
 ;;; be ECL or SLIME bug - disabling for now.
 #+(and ecl-weak-hash (or))
 (progn
   (defimplementation make-weak-key-hash-table (&rest args)
     (apply #'make-hash-table :weakness :key args))
 
   (defimplementation make-weak-value-hash-table (&rest args)
     (apply #'make-hash-table :weakness :value args))
 
   (defimplementation hash-table-weakness (hashtable)
     (ext:hash-table-weakness hashtable)))
 
 
 ;;;; Character names
 
 ;;; Default implementation is fine.
 ;;;
 ;;;   character-completion-set (prefix matchp)
 
 
 ;;;; Heap dumps
 
 ;;; Doesn't apply to ECL.
 ;;;
 ;;;   save-image (filename &optional restart-function)
 ;;;   background-save-image (filename &key restart-function completion-function)
 
 
 ;;;; Wrapping
 
 ;;; Intercept future calls to SPEC and surround them in callbacks.
 ;;; Very much similar to so-called advices for normal functions.
 ;;;
 ;;;   wrap (spec indicator &key before after replace)
 ;;;   unwrap (spec indicator)
 ;;;   wrapped-p (spec indicator)