klimi
/
dotfiles


								;;;; -*- indent-tabs-mode: nil -*-

								;;;

								;;; swank-ecl.lisp --- SLIME backend for ECL.

								;;;

								;;; This code has been placed in the Public Domain.  All warranties

								;;; are disclaimed.

								;;;


								;;; Administrivia


								(defpackage swank/ecl

								  (:use cl swank/backend))


								(in-package swank/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)))


								;;; Swank-mop


								(eval-when (:compile-toplevel :load-toplevel :execute)

								  (import-swank-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 Slime'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 SWANK:*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 swank-compile-string

								    (string &key buffer position filename policy)

								  (declare (ignore policy))

								  (with-compilation-hooks ()

								    (let ((*buffer-name* buffer)        ; for compilation hooks

								          (*buffer-start-position* position))

								      (let ((tmp-file (si:mkstemp "TMP:ecl-swank-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 swank-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

								  ;; SWANK: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 collect-macro-forms (form &optional env)

								  ;; Currently detects only normal macros, not compiler macros.

								  (declare (ignore env))

								  (with-collected-macro-forms (macro-forms)

								    (handler-bind ((warning #'muffle-warning))

								      (ignore-errors

								        (compile nil `(lambda () ,form))))

								    (values macro-forms nil)))


								;;; Expand the format string CONTROL-STRING.

								;;; Default implementation is fine.

								;;;

								;;;   format-string-expand


								(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* '())


								(defun in-swank-package-p (x)

								  (and

								   (symbolp x)

								   (member (symbol-package x)

								           (list #.(find-package :swank)

								                 #.(find-package :swank/backend)

								                 #.(ignore-errors (find-package :swank-mop))

								                 #.(ignore-errors (find-package :swank-loader))))

								   t))


								(defun is-swank-source-p (name)

								  (setf name (pathname name))

								  (pathname-match-p

								   name

								   (make-pathname :defaults swank-loader::*source-directory*

								                  :name (pathname-name name)

								                  :type (pathname-type name)

								                  :version (pathname-version name))))


								(defun is-ignorable-fun-p (x)

								  (or

								   (in-swank-package-p (frame-name x))

								   (multiple-value-bind (file position)

								       (ignore-errors (si::bc-file (car x)))

								     (declare (ignore position))

								     (if file (is-swank-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*)))

								    (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-slime-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)