dotfiles/emacs/.emacs.d/elpa/slime-20190724.1352/swank/clisp.lisp

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

;;;; SWANK support for CLISP.

;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach

;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License as
;;;; published by the Free Software Foundation; either version 2 of
;;;; the License, or (at your option) any later version.

;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.

;;;; You should have received a copy of the GNU General Public
;;;; License along with this program; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;;;; MA 02111-1307, USA.

;;; This is work in progress, but it's already usable.  Many things
;;; are adapted from other swank-*.lisp, in particular from
;;; swank-allegro (I don't use allegro at all, but it's the shortest
;;; one and I found Helmut Eller's code there enlightening).

;;; This code will work better with recent versions of CLISP (say, the
;;; last release or CVS HEAD) while it may not work at all with older
;;; versions.  It is reasonable to expect it to work on platforms with
;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
;;; systems, but also on Win32.  This backend uses the portable xref
;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
;;; are conveniently included in SLIME.

;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/

(defpackage swank/clisp
  (:use cl swank/backend))

(in-package swank/clisp)

(eval-when (:compile-toplevel)
  (unless (string< "2.44" (lisp-implementation-version))
    (error "Need at least CLISP version 2.44")))

(defimplementation gray-package-name ()
  "GRAY")

;;;; if this lisp has the complete CLOS then we use it, otherwise we
;;;; build up a "fake" swank-mop and then override the methods in the
;;;; inspector.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *have-mop*
    (and (find-package :clos)
         (eql :external
              (nth-value 1 (find-symbol (string ':standard-slot-definition)
                                        :clos))))
    "True in those CLISP images which have a complete MOP implementation."))

#+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or))
(progn
  (import-swank-mop-symbols :clos '(:slot-definition-documentation))

  (defun swank-mop:slot-definition-documentation (slot)
    (clos::slot-definition-documentation slot)))

#-#.(cl:if swank/clisp::*have-mop* '(and) '(or))
(defclass swank-mop:standard-slot-definition ()
  ()
  (:documentation
   "Dummy class created so that swank.lisp will compile and load."))

(let ((getpid (or (find-symbol "PROCESS-ID" :system)
                  ;; old name prior to 2005-03-01, clisp <= 2.33.2
                  (find-symbol "PROGRAM-ID" :system)
                  #+win32 ; integrated into the above since 2005-02-24
                  (and (find-package :win32) ; optional modules/win32
                       (find-symbol "GetCurrentProcessId" :win32)))))
  (defimplementation getpid () ; a required interface
    (cond
      (getpid (funcall getpid))
      #+win32 ((ext:getenv "PID")) ; where does that come from?
      (t -1))))

(defimplementation call-with-user-break-handler (handler function)
  (handler-bind ((system::simple-interrupt-condition
                  (lambda (c)
                    (declare (ignore c))
                    (funcall handler)
                    (when (find-restart 'socket-status)
                      (invoke-restart (find-restart 'socket-status)))
                    (continue))))
    (funcall function)))

(defimplementation lisp-implementation-type-name ()
  "clisp")

(defimplementation set-default-directory (directory)
  (setf (ext:default-directory) directory)
  (namestring (setf *default-pathname-defaults* (ext:default-directory))))

(defimplementation filename-to-pathname (string)
  (cond ((member :cygwin *features*)
         (parse-cygwin-filename string))
        (t (parse-namestring string))))

(defun parse-cygwin-filename (string)
  (multiple-value-bind (match _ drive absolute)
      (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
    (declare (ignore _))
    (assert (and match (if drive absolute t)) ()
            "Invalid filename syntax: ~a" string)
    (let* ((sans-prefix (subseq string (regexp:match-end match)))
           (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
           (path (loop for name in path collect
                       (cond ((equal name "..") ':back)
                             (t name))))
           (directoryp (or (equal string "")
                           (find (aref string (1- (length string))) "\\/"))))
      (multiple-value-bind (file type)
          (cond ((and (not directoryp) (last path))
                 (let* ((file (car (last path)))
                        (pos (position #\. file :from-end t)))
                   (cond ((and pos (> pos 0)) 
                          (values (subseq file 0 pos)
                                  (subseq file (1+ pos))))
                         (t file)))))
        (make-pathname :host nil
                       :device nil
                       :directory (cons 
                                   (if absolute :absolute :relative)
                                   (let ((path (if directoryp 
                                                   path 
                                                   (butlast path))))
                                     (if drive
                                         (cons 
                                          (regexp:match-string string drive)
                                          path)
                                         path)))
                       :name file 
                       :type type)))))

;;;; UTF 

(defimplementation string-to-utf8 (string)
  (let ((enc (load-time-value 
              (ext:make-encoding :charset "utf-8" :line-terminator :unix)
              t)))
    (ext:convert-string-to-bytes string enc)))

(defimplementation utf8-to-string (octets)
  (let ((enc (load-time-value 
              (ext:make-encoding :charset "utf-8" :line-terminator :unix)
              t)))
    (ext:convert-string-from-bytes octets enc)))

;;;; TCP Server

(defimplementation create-socket (host port &key backlog)
  (socket:socket-server port :interface host :backlog (or backlog 5)))

(defimplementation local-port (socket)
  (socket:socket-server-port socket))

(defimplementation close-socket (socket)
  (socket:socket-server-close socket))

(defimplementation accept-connection (socket
                                      &key external-format buffering timeout)
  (declare (ignore buffering timeout))
  (socket:socket-accept socket
                        :buffered buffering ;; XXX may not work if t
                        :element-type (if external-format 
                                          'character
                                          '(unsigned-byte 8))
                        :external-format (or external-format :default)))

#-win32
(defimplementation wait-for-input (streams &optional timeout)
  (assert (member timeout '(nil t)))
  (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
    (loop
     (cond ((check-slime-interrupts) (return :interrupt))
           (timeout
            (socket:socket-status streams 0 0)
            (return (loop for (s nil . x) in streams
                          if x collect s)))
           (t
            (with-simple-restart (socket-status "Return from socket-status.")
              (socket:socket-status streams 0 500000))
            (let ((ready (loop for (s nil . x) in streams
                               if x collect s)))
              (when ready (return ready))))))))

#+win32
(defimplementation wait-for-input (streams &optional timeout)
  (assert (member timeout '(nil t)))
  (loop
   (cond ((check-slime-interrupts) (return :interrupt))
         (t
          (let ((ready (remove-if-not #'input-available-p streams)))
            (when ready (return ready)))
          (when timeout (return nil))
          (sleep 0.1)))))

#+win32
;; Some facts to remember (for the next time we need to debug this):
;;  - interactive-sream-p returns t for socket-streams
;;  - listen returns nil for socket-streams
;;  - (type-of <socket-stream>) is 'stream
;;  - (type-of *terminal-io*) is 'two-way-stream
;;  - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8)
;;  - calling socket:socket-status on non sockets signals an error,
;;    but seems to mess up something internally.
;;  - calling read-char-no-hang on sockets does not signal an error,
;;    but seems to mess up something internally.
(defun input-available-p (stream)
  (case (stream-element-type stream)
    (character
     (let ((c (read-char-no-hang stream nil nil)))
       (cond ((not c)
              nil)
             (t
              (unread-char c stream)
              t))))
    (t
     (eq (socket:socket-status (cons stream :input) 0 0)
         :input))))

;;;; Coding systems

(defvar *external-format-to-coding-system*
  '(((:charset "iso-8859-1" :line-terminator :unix)
     "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
    ((:charset "iso-8859-1")
     "latin-1" "iso-latin-1" "iso-8859-1")
    ((:charset "utf-8") "utf-8")
    ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
    ((:charset "euc-jp") "euc-jp")
    ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
    ((:charset "us-ascii") "us-ascii")
    ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))

(defimplementation find-external-format (coding-system)
  (let ((args (car (rassoc-if (lambda (x)
                                (member coding-system x :test #'equal))
                              *external-format-to-coding-system*))))
    (and args (apply #'ext:make-encoding args))))


;;;; Swank functions

(defimplementation arglist (fname)
  (block nil
    (or (ignore-errors
          (let ((exp (function-lambda-expression fname)))
            (and exp (return (second exp)))))
        (ignore-errors
          (return (ext:arglist fname)))
        :not-available)))

(defimplementation macroexpand-all (form &optional env)
  (declare (ignore env))
  (ext:expand-form form))

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

(defimplementation describe-symbol-for-emacs (symbol)
  "Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
  (let ((result ()))
    (flet ((doc (kind)
             (or (documentation symbol kind) :not-documented))
           (maybe-push (property value)
             (when value
               (setf result (list* property value result)))))
      (maybe-push :variable (when (boundp symbol) (doc 'variable)))
      (when (fboundp symbol)
        (maybe-push
         ;; Report WHEN etc. as macros, even though they may be
         ;; implemented as special operators.
         (if (macro-function symbol) :macro
             (typecase (fdefinition symbol)
               (generic-function :generic-function)
               (function         :function)
               ;; (type-of 'progn) -> ext:special-operator
               (t                :special-operator)))
         (doc 'function)))
      (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
                (get symbol 'system::setf-expander)); defsetf
        (maybe-push :setf (doc 'setf)))
      (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
                (get symbol 'system::defstruct-description)
                (get symbol 'system::deftype-expander))
        (maybe-push :type (doc 'type))) ; even for 'structure
      (when (find-class symbol nil)
        (maybe-push :class (doc 'type)))
      ;; Let this code work compiled in images without FFI
      (let ((types (load-time-value
                    (and (find-package "FFI")
                         (symbol-value
                          (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
        ;; Use ffi::*c-type-table* so as not to suffer the overhead of
        ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
        ;; which are not FFI type names.
        (when (and types (nth-value 1 (gethash symbol types)))
          ;; Maybe use (case (head (ffi:deparse-c-type)))
          ;; to distinguish struct and union types?
          (maybe-push :alien-type :not-documented)))
      result)))

(defimplementation describe-definition (symbol namespace)
  (ecase namespace
    (:variable (describe symbol))
    (:macro (describe (macro-function symbol)))
    (:function (describe (symbol-function symbol)))
    (:class (describe (find-class symbol)))))

(defimplementation type-specifier-p (symbol)
  (or (ignore-errors
       (subtypep nil symbol))
      (not (eq (type-specifier-arglist symbol) :not-available))))

(defun fspec-pathname (spec)
  (let ((path spec)
	type
        lines)
    (when (consp path)
      (psetq type (car path)
	     path (cadr path)
             lines (cddr path)))
    (when (and path
               (member (pathname-type path)
                       custom:*compiled-file-types* :test #'equal))
      (setq path
            (loop for suffix in custom:*source-file-types*
               thereis (probe-file (make-pathname :defaults path
                                                  :type suffix)))))
    (values path type lines)))

(defun fspec-location (name fspec)
  (multiple-value-bind (file type lines)
      (fspec-pathname fspec)
    (list (if type (list name type) name)
	  (cond (file
		 (multiple-value-bind (truename c) 
                     (ignore-errors (truename file))
		   (cond (truename
			  (make-location 
                           (list :file (namestring truename))
                           (if (consp lines)
                               (list* :line lines)
                               (list :function-name (string name)))
                           (when (consp type)
                             (list :snippet (format nil "~A" type)))))
			 (t (list :error (princ-to-string c))))))
		(t (list :error 
                         (format nil "No source information available for: ~S"
                                 fspec)))))))

(defimplementation find-definitions (name)
  (mapcar #'(lambda (e) (fspec-location name e)) 
          (documentation name 'sys::file)))

(defun trim-whitespace (string)
  (string-trim #(#\newline #\space #\tab) string))

(defvar *sldb-backtrace*)

(defun sldb-backtrace ()
  "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
  (let* ((modes '((:all-stack-elements 1)
                  (:all-frames 2)
                  (:only-lexical-frames 3)
                  (:only-eval-and-apply-frames 4)
                  (:only-apply-frames 5)))
         (mode (cadr (assoc :all-stack-elements modes))))
    (do ((frames '())
         (last nil frame)
         (frame (sys::the-frame)
                (sys::frame-up 1 frame mode)))
        ((eq frame last) (nreverse frames))
      (unless (boring-frame-p frame)
        (push frame frames)))))

(defimplementation call-with-debugging-environment (debugger-loop-fn)
  (let* (;;(sys::*break-count* (1+ sys::*break-count*))
         ;;(sys::*driver* debugger-loop-fn)
         ;;(sys::*fasoutput-stream* nil)
         (*sldb-backtrace*
          (let* ((f (sys::the-frame))
                 (bt (sldb-backtrace))
                 (rest (member f bt)))
            (if rest (nthcdr 8 rest) bt))))
    (funcall debugger-loop-fn)))

(defun nth-frame (index)
  (nth index *sldb-backtrace*))

(defun boring-frame-p (frame)
  (member (frame-type frame) '(stack-value bind-var bind-env
                               compiled-tagbody compiled-block)))

(defun frame-to-string (frame)
  (with-output-to-string (s)
    (sys::describe-frame s frame)))

(defun frame-type (frame)
  ;; FIXME: should bind *print-length* etc. to small values.
  (frame-string-type (frame-to-string frame)))

;; FIXME: they changed the layout in 2.44 and not all patterns have
;; been updated.
(defvar *frame-prefixes*
  '(("\\[[0-9]\\+\\] frame binding variables" bind-var)
    ("<1> #<compiled-function" compiled-fun)
    ("<1> #<system-function" sys-fun)
    ("<1> #<special-operator" special-op)
    ("EVAL frame" eval)
    ("APPLY frame" apply)
    ("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody)
    ("\\[[0-9]\\+\\] compiled block frame" compiled-block)
    ("block frame" block)
    ("nested block frame" block)
    ("tagbody frame" tagbody)
    ("nested tagbody frame" tagbody)
    ("catch frame" catch)
    ("handler frame" handler)
    ("unwind-protect frame" unwind-protect)
    ("driver frame" driver)
    ("\\[[0-9]\\+\\] frame binding environments" bind-env)
    ("CALLBACK frame" callback)
    ("- " stack-value)
    ("<1> " fun)
    ("<2> " 2nd-frame)
    ))

(defun frame-string-type (string)
  (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
                  *frame-prefixes*)))

(defimplementation compute-backtrace (start end)
  (let* ((bt *sldb-backtrace*)
         (len (length bt)))
    (loop for f in (subseq bt start (min (or end len) len))
          collect f)))

(defimplementation print-frame (frame stream)
  (let* ((str (frame-to-string frame)))
    (write-string (extract-frame-line str)
                  stream)))

(defun extract-frame-line (frame-string)
  (let ((s frame-string))
    (trim-whitespace
     (case (frame-string-type s)
       ((eval special-op)
        (string-match "EVAL frame .*for form \\(.*\\)" s 1))
       (apply
        (string-match "APPLY frame for call \\(.*\\)" s 1))
       ((compiled-fun sys-fun fun)
        (extract-function-name s))
       (t s)))))

(defun extract-function-name (string)
  (let ((1st (car (split-frame-string string))))
    (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
                      1st
                      1)
        (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
        1st)))

(defun split-frame-string (string)
  (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
                    (mapcar #'car *frame-prefixes*))))
    (loop for pos = 0 then (1+ (regexp:match-start match))
          for match = (regexp:match rx string :start pos)
          if match collect (subseq string pos (regexp:match-start match))
          else collect (subseq string pos)
          while match)))

(defun string-match (pattern string n)
  (let* ((match (nth-value n (regexp:match pattern string))))
    (if match (regexp:match-string string match))))

(defimplementation eval-in-frame (form frame-number)
  (sys::eval-at (nth-frame frame-number) form))

(defimplementation frame-locals (frame-number)
  (let ((frame (nth-frame frame-number)))
    (loop for i below (%frame-count-vars frame)
          collect (list :name (%frame-var-name frame i)
                        :value (%frame-var-value frame i)
                        :id 0))))

(defimplementation frame-var-value (frame var)
  (%frame-var-value (nth-frame frame) var))

;;; Interpreter-Variablen-Environment has the shape
;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).

(defun %frame-count-vars (frame)
  (cond ((sys::eval-frame-p frame)
         (do ((venv (frame-venv frame) (next-venv venv))
              (count 0 (+ count (/ (1- (length venv)) 2))))
             ((not venv) count)))
        ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
         (length (%parse-stack-values frame)))
        (t 0)))

(defun %frame-var-name (frame i)
  (cond ((sys::eval-frame-p frame)
         (nth-value 0 (venv-ref (frame-venv frame) i)))
        (t (format nil "~D" i))))

(defun %frame-var-value (frame i)
  (cond ((sys::eval-frame-p frame)
         (let ((name (venv-ref (frame-venv frame) i)))
           (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
             (if c
                 (format-sldb-condition c)
                 v))))
        ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
         (let ((str (nth i (%parse-stack-values frame))))
           (trim-whitespace (subseq str 2))))
        (t (break "Not implemented"))))

(defun frame-venv (frame)
  (let ((env (sys::eval-at frame '(sys::the-environment))))
    (svref env 0)))

(defun next-venv (venv) (svref venv (1- (length venv))))

(defun venv-ref (env i)
  "Reference the Ith binding in ENV.
Return two values: NAME and VALUE"
  (let ((idx (* i 2)))
    (if (< idx (1- (length env)))
        (values (svref env idx) (svref env (1+ idx)))
        (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))

(defun %parse-stack-values (frame)
  (labels ((next (fp) (sys::frame-down 1 fp 1))
           (parse (fp accu)
             (let ((str (frame-to-string fp)))
               (cond ((is-prefix-p "- " str)
                      (parse  (next fp) (cons str accu)))
                     ((is-prefix-p "<1> " str)
                      ;;(when (eq (frame-type frame) 'compiled-fun)
                      ;;  (pop accu))
                      (dolist (str (cdr (split-frame-string str)))
                        (when (is-prefix-p "- " str)
                          (push str accu)))
                      (nreverse accu))
                     (t (parse (next fp) accu))))))
    (parse (next frame) '())))

(defun is-prefix-p (regexp string)
  (if (regexp:match (concatenate 'string "^" regexp) string) t))

(defimplementation return-from-frame (index form)
  (sys::return-from-eval-frame (nth-frame index) form))

(defimplementation restart-frame (index)
  (sys::redo-eval-frame (nth-frame index)))

(defimplementation frame-source-location (index)
  `(:error
    ,(format nil "frame-source-location not implemented. (frame: ~A)"
             (nth-frame index))))

;;;; Profiling

(defimplementation profile (fname)
  (eval `(swank-monitor:monitor ,fname)))         ;monitor is a macro

(defimplementation profiled-functions ()
  swank-monitor:*monitored-functions*)

(defimplementation unprofile (fname)
  (eval `(swank-monitor:unmonitor ,fname)))       ;unmonitor is a macro

(defimplementation unprofile-all ()
  (swank-monitor:unmonitor))

(defimplementation profile-report ()
  (swank-monitor:report-monitoring))

(defimplementation profile-reset ()
  (swank-monitor:reset-all-monitoring))

(defimplementation profile-package (package callers-p methods)
  (declare (ignore callers-p methods))
  (swank-monitor:monitor-all package))

;;;; Handle compiler conditions (find out location of error etc.)

(defmacro compile-file-frobbing-notes ((&rest args) &body body)
  "Pass ARGS to COMPILE-FILE, send the compiler notes to
*STANDARD-INPUT* and frob them in BODY."
  `(let ((*error-output* (make-string-output-stream))
         (*compile-verbose* t))
     (multiple-value-prog1
      (compile-file ,@args)
      (handler-case
       (with-input-from-string
        (*standard-input* (get-output-stream-string *error-output*))
        ,@body)
       (sys::simple-end-of-file () nil)))))

(defvar *orig-c-warn* (symbol-function 'system::c-warn))
(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
(defvar *orig-c-error* (symbol-function 'system::c-error))
(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))

(defmacro dynamic-flet (names-functions &body body)
  "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
Execute BODY with NAME's function slot set to FUNCTION."
  `(ext:letf* ,(loop for (name function) in names-functions
                     collect `((symbol-function ',name) ,function))
    ,@body))

(defvar *buffer-name* nil)
(defvar *buffer-offset*)

(defun compiler-note-location ()
  "Return the current compiler location."
  (let ((lineno1 sys::*compile-file-lineno1*)
        (lineno2 sys::*compile-file-lineno2*)
        (file sys::*compile-file-truename*))
    (cond ((and file lineno1 lineno2)
           (make-location (list ':file (namestring file))
                          (list ':line lineno1)))
          (*buffer-name*
           (make-location (list ':buffer *buffer-name*)
                          (list ':offset *buffer-offset* 0)))
          (t
           (list :error "No error location available")))))

(defun signal-compiler-warning (cstring args severity orig-fn)
  (signal 'compiler-condition
          :severity severity
          :message (apply #'format nil cstring args)
          :location (compiler-note-location))
  (apply orig-fn cstring args))

(defun c-warn (cstring &rest args)
  (signal-compiler-warning cstring args :warning *orig-c-warn*))

(defun c-style-warn (cstring &rest args)
  (dynamic-flet ((sys::c-warn *orig-c-warn*))
    (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))

(defun c-error (&rest args)
  (signal 'compiler-condition
          :severity :error
          :message (apply #'format nil
                          (if (= (length args) 3)
                              (cdr args)
                              args))
          :location (compiler-note-location))
  (apply *orig-c-error* args))

(defimplementation call-with-compilation-hooks (function)
  (handler-bind ((warning #'handle-notification-condition))
    (dynamic-flet ((system::c-warn #'c-warn)
                   (system::c-style-warn #'c-style-warn)
                   (system::c-error #'c-error))
      (funcall function))))

(defun handle-notification-condition (condition)
  "Handle a condition caused by a compiler warning."
  (signal 'compiler-condition
          :original-condition condition
          :severity :warning
          :message (princ-to-string condition)
          :location (compiler-note-location)))

(defimplementation swank-compile-file (input-file output-file
                                       load-p external-format
                                       &key policy)
  (declare (ignore policy))
  (with-compilation-hooks ()
    (with-compilation-unit ()
      (multiple-value-bind (fasl-file warningsp failurep)
          (compile-file input-file 
                        :output-file output-file
                        :external-format external-format)
        (values fasl-file warningsp
                (or failurep 
                    (and load-p 
                         (not (load fasl-file)))))))))

(defimplementation swank-compile-string (string &key buffer position filename
                                         policy)
  (declare (ignore filename policy))
  (with-compilation-hooks ()
    (let ((*buffer-name* buffer)
          (*buffer-offset* position))
      (funcall (compile nil (read-from-string
                             (format nil "(~S () ~A)" 'lambda string))))
      t)))

;;;; Portable XREF from the CMU AI repository.

(setq pxref::*handle-package-forms* '(cl:in-package))

(defmacro defxref (name function)
  `(defimplementation ,name (name)
    (xref-results (,function name))))

(defxref who-calls      pxref:list-callers)
(defxref who-references pxref:list-readers)
(defxref who-binds      pxref:list-setters)
(defxref who-sets       pxref:list-setters)
(defxref list-callers   pxref:list-callers)
(defxref list-callees   pxref:list-callees)

(defun xref-results (symbols)
  (let ((xrefs '()))
    (dolist (symbol symbols)
      (push (fspec-location symbol symbol) xrefs))
    xrefs))

(when (find-package :swank-loader)
  (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
        (lambda ()
          (let ((home (user-homedir-pathname)))
            (and (ext:probe-directory home)
                 (probe-file (format nil "~A/.swank.lisp"
                                     (namestring (truename home)))))))))

;;; Don't set *debugger-hook* to nil on break.
(ext:without-package-lock ()
 (defun break (&optional (format-string "Break") &rest args)
   (if (not sys::*use-clcs*)
       (progn
         (terpri *error-output*)
         (apply #'format *error-output*
                (concatenate 'string "*** - " format-string)
                args)
         (funcall ext:*break-driver* t))
       (let ((condition
              (make-condition 'simple-condition
                              :format-control format-string
                              :format-arguments args))
             ;;(*debugger-hook* nil)
             ;; Issue 91
             )
         (ext:with-restarts
             ((continue
               :report (lambda (stream)
                         (format stream (sys::text "Return from ~S loop")
                                 'break))
               ()))
           (with-condition-restarts condition (list (find-restart 'continue))
                                    (invoke-debugger condition)))))
   nil))

;;;; Inspecting

(defmethod emacs-inspect ((o t))
  (let* ((*print-array* nil) (*print-pretty* t)
         (*print-circle* t) (*print-escape* t)
         (*print-lines* custom:*inspect-print-lines*)
         (*print-level* custom:*inspect-print-level*)
         (*print-length* custom:*inspect-print-length*)
         (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
         (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
         (*package* tmp-pack)
         (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
    (let ((inspection (sys::inspect-backend o)))
      (append (list
               (format nil "~S~% ~A~{~%~A~}~%" o
                      (sys::insp-title inspection)
                      (sys::insp-blurb inspection)))
              (loop with count = (sys::insp-num-slots inspection)
                    for i below count
                    append (multiple-value-bind (value name)
                               (funcall (sys::insp-nth-slot inspection)
                                        i)
                             `((:value ,name) " = " (:value ,value)
                               (:newline))))))))

(defimplementation quit-lisp ()
  #+lisp=cl (ext:quit)
  #-lisp=cl (lisp:quit))


(defimplementation preferred-communication-style ()
  nil)

;;; FIXME
;;;
;;; Clisp 2.48 added experimental support for threads. Basically, you
;;; can use :SPAWN now, BUT:
;;; 
;;;   - there are problems with GC, and threads stuffed into weak
;;;     hash-tables as is the case for *THREAD-PLIST-TABLE*.
;;;
;;;     See test case at
;;;       http://thread.gmane.org/gmane.lisp.clisp.devel/20429
;;;
;;;     Even though said to be fixed, it's not:
;;;
;;;       http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
;;;
;;;   - The DYNAMIC-FLET above is an implementation technique that's
;;;     probably not sustainable in light of threads. This got to be
;;;     rewritten.
;;;
;;; TCR (2009-07-30)

#+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) 
(progn
  (defimplementation spawn (fn &key name)
    (mp:make-thread fn :name name))

  (defvar *thread-plist-table-lock*
    (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))

  (defvar *thread-plist-table* (make-hash-table :weak :key)
    "A hashtable mapping threads to a plist.")

  (defvar *thread-id-counter* 0)

  (defimplementation thread-id (thread)
    (mp:with-mutex-lock (*thread-plist-table-lock*)
      (or (getf (gethash thread *thread-plist-table*) 'thread-id)
          (setf (getf (gethash thread *thread-plist-table*) 'thread-id)
                (incf *thread-id-counter*)))))

  (defimplementation find-thread (id)
    (find id (all-threads)
          :key (lambda (thread)
                 (getf (gethash thread *thread-plist-table*) 'thread-id))))

  (defimplementation thread-name (thread)
    ;; To guard against returning #<UNBOUND>.
    (princ-to-string (mp:thread-name thread)))

  (defimplementation thread-status (thread)
    (if (thread-alive-p thread)
        "RUNNING"
        "STOPPED"))

  (defimplementation make-lock (&key name)
    (mp:make-mutex :name name :recursive-p t))

  (defimplementation call-with-lock-held (lock function)
    (mp:with-mutex-lock (lock)
      (funcall function)))

  (defimplementation current-thread ()
    (mp:current-thread))

  (defimplementation all-threads ()
    (mp:list-threads))

  (defimplementation interrupt-thread (thread fn)
    (mp:thread-interrupt thread :function fn))

  (defimplementation kill-thread (thread)
    (mp:thread-interrupt thread :function t))

  (defimplementation thread-alive-p (thread)
    (mp:thread-active-p thread))

  (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
  (defvar *mailboxes* (list))

  (defstruct (mailbox (:conc-name mailbox.))
    thread
    (lock (make-lock :name "MAILBOX.LOCK"))
    (waitqueue  (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
    (queue '() :type list))

  (defun mailbox (thread)
    "Return THREAD's mailbox."
    (mp:with-mutex-lock (*mailboxes-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))
           (lock (mailbox.lock mbox)))
      (mp:with-mutex-lock (lock)
        (setf (mailbox.queue mbox)
              (nconc (mailbox.queue mbox) (list message)))
        (mp:exemption-broadcast (mailbox.waitqueue mbox)))))

  (defimplementation receive-if (test &optional timeout)
    (let* ((mbox (mailbox (current-thread)))
           (lock (mailbox.lock mbox)))
      (assert (or (not timeout) (eq timeout t)))
      (loop
       (check-slime-interrupts)
       (mp:with-mutex-lock (lock)
         (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:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
 

;;;; Weak hashtables

(defimplementation make-weak-key-hash-table (&rest args)
  (apply #'make-hash-table :weak :key args))

(defimplementation make-weak-value-hash-table (&rest args)
  (apply #'make-hash-table :weak :value args))

(defimplementation save-image (filename &optional restart-function)
  (let ((args `(,filename 
                ,@(if restart-function 
                      `((:init-function ,restart-function))))))
    (apply #'ext:saveinitmem args)))