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

;;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-mezzano.lisp --- SLIME backend for Mezzano
;;;
;;; This code has been placed in the Public Domain.  All warranties are
;;; disclaimed.
;;;

;;; Administrivia

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

(in-package swank/mezzano)

;;; swank-mop

(import-swank-mop-symbols :mezzano.clos '(:class-default-initargs
                                          :class-direct-default-initargs
                                          :specializer-direct-methods
                                          :generic-function-declarations))

(defun swank-mop:specializer-direct-methods (obj)
  (declare (ignore obj))
  '())

(defun swank-mop:generic-function-declarations (gf)
  (declare (ignore gf))
  '())

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

;;;; TCP server

(defclass listen-socket ()
  ((%listener :initarg :listener)))

(defimplementation create-socket (host port &key backlog)
  (make-instance 'listen-socket
                 :listener (mezzano.network.tcp:tcp-listen
                            host
                            port
                            :backlog (or backlog 10))))

(defimplementation local-port (socket)
  (mezzano.network.tcp:tcp-listener-local-port (slot-value socket '%listener)))

(defimplementation close-socket (socket)
  (mezzano.network.tcp:close-tcp-listener (slot-value socket '%listener)))

(defimplementation accept-connection (socket &key external-format
                                             buffering timeout)
  (declare (ignore external-format buffering timeout))
  (loop
    (let ((value (mezzano.network.tcp:tcp-accept (slot-value socket '%listener)
                                                 :wait-p nil)))
      (if value
          (return value)
          ;; Poke standard-input every now and then to keep the console alive.
          (progn (listen)
                 (sleep 0.05))))))

(defimplementation preferred-communication-style ()
  :spawn)

;;;; Unix signals
;;;; ????

(defimplementation getpid ()
  0)

;;;; Compilation

(defun signal-compiler-condition (condition severity)
  (signal 'compiler-condition
          :original-condition condition
          :severity severity
          :message (format nil "~A" condition)
          :location nil))

(defimplementation call-with-compilation-hooks (func)
  (handler-bind
      ((error
        (lambda (c)
          (signal-compiler-condition c :error)))
       (warning
        (lambda (c)
          (signal-compiler-condition c :warning)))
       (style-warning
        (lambda (c)
          (signal-compiler-condition c :style-warning))))
    (funcall func)))

(defimplementation swank-compile-string (string &key buffer position filename
                                                policy)
  (declare (ignore buffer policy))
  (let* ((*load-pathname* (ignore-errors (pathname filename)))
         (*load-truename* (when *load-pathname*
                            (ignore-errors (truename *load-pathname*))))
         (sys.int::*top-level-form-number* `(:position ,position)))
    (with-compilation-hooks ()
      (eval (read-from-string (concatenate 'string "(progn " string " )")))))
  t)

(defimplementation swank-compile-file (input-file output-file load-p
                                                  external-format
                                                  &key policy)
  (with-compilation-hooks ()
    (multiple-value-prog1
        (compile-file input-file
                      :output-file output-file
                      :external-format external-format)
      (when load-p
        (load output-file)))))

(defimplementation find-external-format (coding-system)
  (if (or (equal coding-system "utf-8")
          (equal coding-system "utf-8-unix"))
      :default
      nil))

;;;; Debugging

;; Definitely don't allow this.
(defimplementation install-debugger-globally (function)
  (declare (ignore function))
  nil)

(defvar *current-backtrace*)

(defimplementation call-with-debugging-environment (debugger-loop-fn)
  (let ((*current-backtrace* '()))
    (let ((prev-fp nil))
      (sys.int::map-backtrace
       (lambda (i fp)
         (push (list (1- i) fp prev-fp) *current-backtrace*)
         (setf prev-fp fp))))
    (setf *current-backtrace* (reverse *current-backtrace*))
    ;; Drop the topmost frame, which is finished call to MAP-BACKTRACE.
    (pop *current-backtrace*)
    ;; And the next one for good measure.
    (pop *current-backtrace*)
    (funcall debugger-loop-fn)))

(defimplementation compute-backtrace (start end)
  (subseq *current-backtrace* start end))

(defimplementation print-frame (frame stream)
  (format stream "~S" (sys.int::function-from-frame frame)))

(defimplementation frame-source-location (frame-number)
  (let* ((frame (nth frame-number *current-backtrace*))
         (fn (sys.int::function-from-frame frame)))
    (function-location fn)))

(defimplementation frame-locals (frame-number)
  (loop
     with frame = (nth frame-number *current-backtrace*)
     for (name id location repr) in (sys.int::frame-locals frame)
     collect (list :name name
                   :id id
                   :value (sys.int::read-frame-slot frame location repr))))

(defimplementation frame-var-value (frame-number var-id)
  (let* ((frame (nth frame-number *current-backtrace*))
         (locals (sys.int::frame-locals frame))
         (info (nth var-id locals)))
    (if info
        (destructuring-bind (name id location repr)
            info
          (declare (ignore id))
          (values (sys.int::read-frame-slot frame location repr) name))
        (error "Invalid variable id ~D for frame number ~D."
               var-id frame-number))))

;;;; Definition finding

(defun top-level-form-position (pathname tlf)
  (ignore-errors
    (with-open-file (s pathname)
      (loop
         repeat tlf
         do (with-standard-io-syntax
              (let ((*read-suppress* t)
                    (*read-eval* nil))
                (read s nil))))
      (let ((default (make-pathname :host (pathname-host s))))
        (make-location `(:file ,(enough-namestring s default))
                       `(:position ,(1+ (file-position s))))))))

(defun function-location (function)
  "Return a location object for FUNCTION."
  (let* ((info (sys.int::function-debug-info function))
         (pathname (sys.int::debug-info-source-pathname info))
         (tlf (sys.int::debug-info-source-top-level-form-number info)))
    (cond ((and (consp tlf)
                (eql (first tlf) :position))
           (let ((default (make-pathname :host (pathname-host pathname))))
             (make-location `(:file ,(enough-namestring pathname default))
                            `(:position ,(second tlf)))))
          (t
           (top-level-form-position pathname tlf)))))

(defun method-definition-name (name method)
  `(defmethod ,name
       ,@(mezzano.clos:method-qualifiers method)
     ,(mapcar (lambda (x)
                (typecase x
                  (mezzano.clos:class
                   (mezzano.clos:class-name x))
                  (mezzano.clos:eql-specializer
                   `(eql ,(mezzano.clos:eql-specializer-object x)))
                  (t x)))
              (mezzano.clos:method-specializers method))))

(defimplementation find-definitions (name)
  (let ((result '()))
    (labels
        ((frob-fn (dspec fn)
           (let ((loc (function-location fn)))
             (when loc
               (push (list dspec loc) result))))
         (try-fn (name)
           (when (valid-function-name-p name)
             (when (and (fboundp name)
                        (not (and (symbolp name)
                                  (or (special-operator-p name)
                                      (macro-function name)))))
               (let ((fn (fdefinition name)))
                 (cond ((typep fn 'mezzano.clos:standard-generic-function)
                        (dolist (m (mezzano.clos:generic-function-methods fn))
                          (frob-fn (method-definition-name name m)
                                   (mezzano.clos:method-function m))))
                       (t
                        (frob-fn `(defun ,name) fn)))))
             (when (compiler-macro-function name)
               (frob-fn `(define-compiler-macro ,name)
                        (compiler-macro-function name))))))
      (try-fn name)
      (try-fn `(setf name))
      (try-fn `(sys.int::cas name))
      (when (and (symbolp name)
                 (get name 'sys.int::setf-expander))
        (frob-fn `(define-setf-expander ,name)
                 (get name 'sys.int::setf-expander)))
      (when (and (symbolp name)
                 (macro-function name))
        (frob-fn `(defmacro ,name)
                 (macro-function name))))
    result))

;;;; XREF
;;; Simpler variants.

(defun find-all-frefs ()
  (let ((frefs (make-array 500 :adjustable t :fill-pointer 0))
        (keep-going t))
    (loop
       (when (not keep-going)
         (return))
       (adjust-array frefs (* (array-dimension frefs 0) 2))
       (setf keep-going nil
             (fill-pointer frefs) 0)
       ;; Walk the wired area looking for FREFs.
       (sys.int::walk-area
        :wired
        (lambda (object address size)
          (when (sys.int::function-reference-p object)
            (when (not (vector-push object frefs))
              (setf keep-going t))))))
    (remove-duplicates (coerce frefs 'list))))

(defimplementation list-callers (function-name)
  (let ((fref-for-fn (sys.int::function-reference function-name))
        (callers '()))
    (loop
       for fref in (find-all-frefs)
       for fn = (sys.int::function-reference-function fref)
       for name = (sys.int::function-reference-name fref)
       when fn
       do
         (cond ((typep fn 'standard-generic-function)
                (dolist (m (mezzano.clos:generic-function-methods fn))
                  (let* ((mf (mezzano.clos:method-function m))
                         (mf-frefs (get-all-frefs-in-function mf)))
                    (when (member fref-for-fn mf-frefs)
                      (push `((defmethod ,name
                                  ,@(mezzano.clos:method-qualifiers m)
                                ,(mapcar #'specializer-name
                                         (mezzano.clos:method-specializers m)))
                              ,(function-location mf))
                            callers)))))
               ((member fref-for-fn
                        (get-all-frefs-in-function fn))
                (push `((defun ,name) ,(function-location fn)) callers))))
    callers))

(defun specializer-name (specializer)
  (if (typep specializer 'standard-class)
      (mezzano.clos:class-name specializer)
      specializer))

(defun get-all-frefs-in-function (function)
  (when (sys.int::funcallable-std-instance-p function)
    (setf function (sys.int::funcallable-std-instance-function function)))
  (when (sys.int::closure-p function)
    (setf function (sys.int::%closure-function function)))
  (loop
     for i below (sys.int::function-pool-size function)
     for entry = (sys.int::function-pool-object function i)
     when (sys.int::function-reference-p entry)
     collect entry
     when (compiled-function-p entry) ; closures
     append (get-all-frefs-in-function entry)))

(defimplementation list-callees (function-name)
  (let* ((fn (fdefinition function-name))
         ;; Grovel around in the function's constant pool looking for
         ;; function-references.  These may be for #', but they're
         ;; probably going to be for normal calls.
         ;; TODO: This doesn't work well on interpreted functions or
         ;; funcallable instances.
         (callees (remove-duplicates (get-all-frefs-in-function fn))))
    (loop
       for fref in callees
       for name = (sys.int::function-reference-name fref)
       for fn = (sys.int::function-reference-function fref)
       when fn
       collect `((defun ,name) ,(function-location fn)))))

;;;; Documentation

(defimplementation arglist (name)
  (let ((macro (when (symbolp name)
                 (macro-function name)))
        (fn (if (functionp name)
                name
                (ignore-errors (fdefinition name)))))
    (cond
      (macro
       (get name 'sys.int::macro-lambda-list))
      (fn
       (cond
         ((typep fn 'mezzano.clos:standard-generic-function)
          (mezzano.clos:generic-function-lambda-list fn))
         (t
          (function-lambda-list fn))))
      (t :not-available))))

(defun function-lambda-list (function)
  (sys.int::debug-info-lambda-list
   (sys.int::function-debug-info function)))

(defimplementation type-specifier-p (symbol)
  (cond
    ((or (get symbol 'sys.int::type-expander)
         (get symbol 'sys.int::compound-type)
         (get symbol 'sys.int::type-symbol))
     t)
    (t :not-available)))

(defimplementation function-name (function)
  (sys.int::function-name function))

(defimplementation valid-function-name-p (form)
  "Is FORM syntactically valid to name a function?
   If true, FBOUNDP should not signal a type-error for FORM."
  (flet ((length=2 (list)
           (and (not (null (cdr list))) (null (cddr list)))))
    (or (symbolp form)
        (and (consp form) (length=2 form)
             (or (eq (first form) 'setf)
                 (eq (first form) 'sys.int::cas))
             (symbolp (second form))))))

(defimplementation describe-symbol-for-emacs (symbol)
  (let ((result '()))
    (when (boundp symbol)
      (setf (getf result :variable) nil))
    (when (and (fboundp symbol)
               (not (macro-function symbol)))
      (setf (getf result :function)
            (function-docstring symbol)))
    (when (fboundp `(setf ,symbol))
      (setf (getf result :setf)
            (function-docstring `(setf ,symbol))))
    (when (get symbol 'sys.int::setf-expander)
      (setf (getf result :setf) nil))
    (when (special-operator-p symbol)
      (setf (getf result :special-operator) nil))
    (when (macro-function symbol)
      (setf (getf result :macro) nil))
    (when (compiler-macro-function symbol)
      (setf (getf result :compiler-macro) nil))
    (when (type-specifier-p symbol)
      (setf (getf result :type) nil))
    (when (find-class symbol nil)
      (setf (getf result :class) nil))
    result))

(defun function-docstring (function-name)
  (let* ((definition (fdefinition function-name))
         (debug-info (sys.int::function-debug-info definition)))
    (sys.int::debug-info-docstring debug-info)))

;;;; Multithreading

;; FIXME: This should be a weak table.
(defvar *thread-ids-for-emacs* (make-hash-table))
(defvar *next-thread-id-for-emacs* 0)
(defvar *thread-id-for-emacs-lock* (mezzano.supervisor:make-mutex
                                    "SWANK thread ID table"))

(defimplementation spawn (fn &key name)
  (mezzano.supervisor:make-thread fn :name name))

(defimplementation thread-id (thread)
  (mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*)
    (let ((id (gethash thread *thread-ids-for-emacs*)))
      (when (null id)
        (setf id (incf *next-thread-id-for-emacs*)
              (gethash thread *thread-ids-for-emacs*) id
              (gethash id *thread-ids-for-emacs*) thread))
      id)))

(defimplementation find-thread (id)
  (mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*)
    (gethash id *thread-ids-for-emacs*)))

(defimplementation thread-name (thread)
  (mezzano.supervisor:thread-name thread))

(defimplementation thread-status (thread)
  (format nil "~:(~A~)" (mezzano.supervisor:thread-state thread)))

(defimplementation current-thread ()
  (mezzano.supervisor:current-thread))

(defimplementation all-threads ()
  (mezzano.supervisor:all-threads))

(defimplementation thread-alive-p (thread)
  (not (eql (mezzano.supervisor:thread-state thread) :dead)))

(defimplementation interrupt-thread (thread fn)
  (mezzano.supervisor:establish-thread-foothold thread fn))

(defimplementation kill-thread (thread)
  ;; Documentation says not to execute unwind-protected sections, but there's
  ;; no way to do that.
  ;; And killing threads at arbitrary points without unwinding them is a good
  ;; way to hose the system.
  (mezzano.supervisor:terminate-thread thread))

(defvar *mailbox-lock* (mezzano.supervisor:make-mutex "mailbox lock"))
(defvar *mailboxes* (list))

(defstruct (mailbox (:conc-name mailbox.))
  thread
  (mutex (mezzano.supervisor:make-mutex))
  (queue '() :type list))

(defun mailbox (thread)
  "Return THREAD's mailbox."
  ;; Use weak pointers to avoid holding on to dead threads forever.
  (mezzano.supervisor:with-mutex (*mailbox-lock*)
    ;; Flush forgotten threads.
    (setf *mailboxes*
          (remove-if-not #'sys.int::weak-pointer-value *mailboxes*))
    (loop
       for entry in *mailboxes*
       do
         (multiple-value-bind (key value livep)
             (sys.int::weak-pointer-pair entry)
           (when (eql key thread)
             (return value)))
       finally
         (let ((mb (make-mailbox :thread thread)))
           (push (sys.int::make-weak-pointer thread mb) *mailboxes*)
           (return mb)))))

(defimplementation send (thread message)
  (let* ((mbox (mailbox thread))
         (mutex (mailbox.mutex mbox)))
    (mezzano.supervisor:with-mutex (mutex)
      (setf (mailbox.queue mbox)
            (nconc (mailbox.queue mbox) (list message))))))

(defvar *receive-if-sleep-time* 0.02)

(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)
       (mezzano.supervisor:with-mutex (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))))
       (sleep *receive-if-sleep-time*))))

(defvar *registered-threads* (make-hash-table))
(defvar *registered-threads-lock*
  (mezzano.supervisor:make-mutex "registered threads lock"))

(defimplementation register-thread (name thread)
  (declare (type symbol name))
  (mezzano.supervisor:with-mutex (*registered-threads-lock*)
    (etypecase thread
      (null
       (remhash name *registered-threads*))
      (mezzano.supervisor:thread
       (setf (gethash name *registered-threads*) thread))))
  nil)

(defimplementation find-registered (name)
  (mezzano.supervisor:with-mutex (*registered-threads-lock*)
    (values (gethash name *registered-threads*))))

(defimplementation wait-for-input (streams &optional timeout)
  (loop
       (let ((ready '()))
         (dolist (s streams)
           (when (or (listen s)
                     (and (typep s 'mezzano.network.tcp::tcp-stream)
                          (mezzano.network.tcp::tcp-connection-closed-p s)))
             (push s ready)))
         (when ready
           (return ready))
         (when (check-slime-interrupts)
           (return :interrupt))
         (when timeout
           (return '()))
         (sleep 1)
         (when (numberp timeout)
           (decf timeout 1)
           (when (not (plusp timeout))
             (return '()))))))

;;;;  Locks

(defstruct recursive-lock
  mutex
  (depth 0))

(defimplementation make-lock (&key name)
  (make-recursive-lock
   :mutex (mezzano.supervisor:make-mutex name)))

(defimplementation call-with-lock-held (lock function)
  (cond ((mezzano.supervisor:mutex-held-p
          (recursive-lock-mutex lock))
         (unwind-protect
              (progn (incf (recursive-lock-depth lock))
                     (funcall function))
           (decf (recursive-lock-depth lock))))
        (t
         (mezzano.supervisor:with-mutex ((recursive-lock-mutex lock))
           (multiple-value-prog1
               (funcall function)
             (assert (eql (recursive-lock-depth lock) 0)))))))

;;;; Character names

(defimplementation character-completion-set (prefix matchp)
  ;; TODO: Unicode characters too.
  (loop
     for names in sys.int::*char-name-alist*
     append
       (loop
          for name in (rest names)
          when (funcall matchp prefix name)
          collect name)))

;;;; Inspector

(defmethod emacs-inspect ((o function))
  (case (sys.int::%object-tag o)
    (#.sys.int::+object-tag-function+
     (label-value-line*
      (:name (sys.int::function-name o))
      (:arglist (arglist o))
      (:debug-info (sys.int::function-debug-info o))))
    (#.sys.int::+object-tag-closure+
     (append
      (label-value-line :function (sys.int::%closure-function o))
      `("Closed over values:" (:newline))
      (loop
         for i below (sys.int::%closure-length o)
         append (label-value-line i (sys.int::%closure-value o i)))))
    (t
     (call-next-method))))

(defmethod emacs-inspect ((o sys.int::weak-pointer))
  (label-value-line*
   (:key (sys.int::weak-pointer-key o))
   (:value (sys.int::weak-pointer-value o))))

(defmethod emacs-inspect ((o sys.int::function-reference))
  (label-value-line*
   (:name (sys.int::function-reference-name o))
   (:function (sys.int::function-reference-function o))))

(defmethod emacs-inspect ((object structure-object))
  (let ((class (class-of object)))
    `("Class: " (:value ,class) (:newline)
                ,@(swank::all-slots-for-inspector object))))

(in-package :swank)

(defmethod all-slots-for-inspector ((object structure-object))
  (let* ((class           (class-of object))
         (direct-slots    (swank-mop:class-direct-slots class))
         (effective-slots (swank-mop:class-slots class))
         (longest-slot-name-length
          (loop for slot :in effective-slots
                maximize (length (symbol-name
                                  (swank-mop:slot-definition-name slot)))))
         (checklist
          (reinitialize-checklist
           (ensure-istate-metadata object :checklist
                                   (make-checklist (length effective-slots)))))
         (grouping-kind
          ;; We box the value so we can re-set it.
          (ensure-istate-metadata object :grouping-kind
                                  (box *inspector-slots-default-grouping*)))
         (sort-order
          (ensure-istate-metadata object :sort-order
                                  (box *inspector-slots-default-order*)))
         (sort-predicate (ecase (ref sort-order)
                           (:alphabetically #'string<)
                           (:unsorted (constantly nil))))
         (sorted-slots (sort (copy-seq effective-slots)
                             sort-predicate
                             :key #'swank-mop:slot-definition-name))
         (effective-slots
          (ecase (ref grouping-kind)
            (:all sorted-slots)
            (:inheritance (stable-sort-by-inheritance sorted-slots
                                                      class sort-predicate)))))
    `("--------------------"
      (:newline)
      " Group slots by inheritance "
      (:action ,(ecase (ref grouping-kind)
                       (:all "[ ]")
                       (:inheritance "[X]"))
               ,(lambda ()
                        ;; We have to do this as the order of slots will
                        ;; be sorted differently.
                        (fill (checklist.buttons checklist) nil)
                        (setf (ref grouping-kind)
                              (ecase (ref grouping-kind)
                                (:all :inheritance)
                                (:inheritance :all))))
               :refreshp t)
      (:newline)
      " Sort slots alphabetically  "
      (:action ,(ecase (ref sort-order)
                       (:unsorted "[ ]")
                       (:alphabetically "[X]"))
               ,(lambda ()
                        (fill (checklist.buttons checklist) nil)
                        (setf (ref sort-order)
                              (ecase (ref sort-order)
                                (:unsorted :alphabetically)
                                (:alphabetically :unsorted))))
               :refreshp t)
      (:newline)
      ,@ (case (ref grouping-kind)
           (:all
            `((:newline)
              "All Slots:"
              (:newline)
              ,@(make-slot-listing checklist object class
                                   effective-slots direct-slots
                                   longest-slot-name-length)))
           (:inheritance
            (list-all-slots-by-inheritance checklist object class
                                           effective-slots direct-slots
                                           longest-slot-name-length)))
      (:newline)
      (:action "[set value]"
               ,(lambda ()
                        (do-checklist (idx checklist)
                          (query-and-set-slot class object
                                              (nth idx effective-slots))))
               :refreshp t)
      "  "
      (:action "[make unbound]"
               ,(lambda ()
                        (do-checklist (idx checklist)
                          (swank-mop:slot-makunbound-using-class
                           class object (nth idx effective-slots))))
               :refreshp t)
      (:newline))))