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

;;;
;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
;;;
;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
;;;
;;; License
;;; =======
;;; This software is provided 'as-is', without any express or implied
;;; warranty. In no event will the author be held liable for any damages
;;; arising from the use of this software.
;;;
;;; Permission is granted to anyone to use this software for any purpose,
;;; including commercial applications, and to alter it and redistribute
;;; it freely, subject to the following restrictions:
;;;
;;; 1. The origin of this software must not be misrepresented; you must
;;;    not claim that you wrote the original software. If you use this
;;;    software in a product, an acknowledgment in the product documentation
;;;    would be appreciated but is not required.
;;;
;;; 2. Altered source versions must be plainly marked as such, and must
;;;    not be misrepresented as being the original software.
;;;
;;; 3. This notice may not be removed or altered from any source 
;;;    distribution.
;;;
;;; Notes
;;; =====
;;; You will need CCL 2.51, and you will *definitely* need to patch
;;; CCL with the patches at
;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
;;; will blow up in your face.  You should also follow the
;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
;;;
;;; The only communication style currently supported is NIL.
;;;
;;; Starting CCL inside emacs (with M-x slime) seems to work for me
;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
;;; (sometimes it works, other times it hangs on start or hangs when
;;; initializing WinSock) - starting CCL externally and using M-x
;;; slime-connect always works fine.
;;;
;;; Sometimes CCL gets confused and starts giving you random memory
;;; access violation errors on startup; if this happens, try redumping
;;; your image.
;;;
;;; What works
;;; ==========
;;; * Basic editing and evaluation
;;; * Arglist display
;;; * Compilation
;;; * Loading files
;;; * apropos/describe
;;; * Debugger
;;; * Inspector
;;; 
;;; TODO
;;; ====
;;; * More debugger functionality (missing bits: restart-frame,
;;; return-from-frame, disassemble-frame, activate-stepping,
;;; toggle-trace)
;;; * XREF
;;; * Profiling
;;; * More sophisticated communication styles than NIL
;;;

(in-package :swank/backend)

;;; Pull in various needed bits
(require :composite-streams)
(require :sockets)
(require :winbase)
(require :lp)

(use-package :gs)

;; MOP stuff

(defclass swank-mop:standard-slot-definition ()
  ()
  (:documentation 
   "Dummy class created so that swank.lisp will compile and load."))

(defun named-by-gensym-p (c)
  (null (symbol-package (class-name c))))

(deftype swank-mop:eql-specializer ()
  '(satisfies named-by-gensym-p))

(defun swank-mop:eql-specializer-object (specializer)
  (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
    (loop (multiple-value-bind (more key value)
              (next-entry)
            (unless more (return nil))
            (when (eq specializer value)
              (return key))))))

(defun swank-mop:class-finalized-p (class)
  (declare (ignore class))
  t)

(defun swank-mop:class-prototype (class)
  (make-instance class))

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

(defun swank-mop:generic-function-argument-precedence-order (gf)
  (generic-function-lambda-list gf))

(defun swank-mop:generic-function-method-combination (gf)
  (declare (ignore gf))
  :standard)

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

(defun swank-mop:slot-definition-documentation (slot)
  (declare (ignore slot))
  (getf slot :documentation nil))

(defun swank-mop:slot-definition-type (slot)
  (declare (ignore slot))
  t)

(import-swank-mop-symbols :cl '(;; classes
                                :standard-slot-definition
                                :eql-specializer
                                :eql-specializer-object
                                ;; standard class readers
                                :class-default-initargs
                                :class-direct-default-initargs
                                :class-finalized-p
                                :class-prototype
                                :specializer-direct-methods
                                ;; gf readers
                                :generic-function-argument-precedence-order
                                :generic-function-declarations
                                :generic-function-method-combination
                                ;; method readers
                                ;; slot readers
                                :slot-definition-documentation
                                :slot-definition-type))

;;;; swank implementations

;;; Debugger

(defvar *stack-trace* nil)
(defvar *frame-trace* nil)

(defstruct frame
  name function address debug-info variables)

(defimplementation call-with-debugging-environment (fn)
  (let* ((real-stack-trace (cl::stack-trace))
         (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
                                     :key #'car)))
         (*frame-trace*
          (let* ((db::*debug-level*         (1+ db::*debug-level*))
                 (db::*debug-frame-pointer* (db::stash-ebp
                                             (ct:create-foreign-ptr)))
                 (db::*debug-max-level*     (length real-stack-trace))
                 (db::*debug-min-level*     1))
            (cdr (member #'cl:invoke-debugger
                         (cons
                          (make-frame :function nil)
                          (loop for i from db::*debug-min-level*
                             upto db::*debug-max-level*
                             until (eq (db::get-frame-function i) 
				       cl::*top-level*)
                             collect
                               (make-frame 
				:function (db::get-frame-function i)
				:address (db::get-frame-address i))))
                         :key #'frame-function)))))
    (funcall fn)))

(defimplementation compute-backtrace (start end)
  (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
	collect f))

(defimplementation print-frame (frame stream)
  (format stream "~S" frame))

(defun get-frame-debug-info (frame)
  (or (frame-debug-info frame)
      (setf (frame-debug-info frame)
	    (db::prepare-frame-debug-info (frame-function frame)
					  (frame-address frame)))))

(defimplementation frame-locals (frame-number)
  (let* ((frame (elt *frame-trace* frame-number))
         (info (get-frame-debug-info frame)))
    (let ((var-list
           (loop for i from 4 below (length info) by 2
              collect `(list :name ',(svref info i) :id 0
                             :value (db::debug-filter ,(svref info i))))))
      (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
        (setf (frame-variables frame) vars)))))

(defimplementation eval-in-frame (form frame-number)
  (let ((frame (elt *frame-trace* frame-number)))
    (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
      (eval form))))

(defimplementation frame-var-value (frame-number var)
  (let ((vars (frame-variables (elt *frame-trace* frame-number))))
    (when vars
      (second (elt vars var)))))

(defimplementation frame-source-location (frame-number)
  (fspec-location (frame-function (elt *frame-trace* frame-number))))

(defun break (&optional (format-control "Break") &rest format-arguments)
  (with-simple-restart (continue "Return from BREAK.")
    (let ();(*debugger-hook* nil))
      (let ((condition 
	     (make-condition 'simple-condition
			     :format-control format-control
			     :format-arguments format-arguments)))
	;;(format *debug-io* ";;; User break: ~A~%" condition)
	(invoke-debugger condition))))
  nil)

;;; Socket communication

(defimplementation create-socket (host port &key backlog)
  (sockets:start-sockets)
  (sockets:make-server-socket :host host :port port))

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

(defimplementation close-socket (socket)
  (close socket))

(defimplementation accept-connection (socket
				      &key external-format buffering timeout)
  (declare (ignore buffering timeout external-format))
  (sockets:make-socket-stream (sockets:accept-socket socket)))

;;; Misc

(defimplementation preferred-communication-style ()
  nil)

(defimplementation getpid ()
  ccl:*current-process-id*)

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

(defimplementation quit-lisp ()
  (sockets:stop-sockets)
  (win32:exitprocess 0))

(defimplementation set-default-directory (directory)
  (setf (ccl:current-directory) directory)
  (directory-namestring (setf *default-pathname-defaults* 
                              (truename (merge-pathnames directory)))))

(defimplementation default-directory ()
  (directory-namestring (ccl:current-directory)))

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

;;; Documentation

(defun fspec-location (fspec)
  (when (symbolp fspec)
    (setq fspec (symbol-function fspec)))
  (let ((file (ccl::function-source-file fspec)))
    (if file
        (handler-case
            (let ((truename (truename
                             (merge-pathnames file
                                              ccl:*cormanlisp-directory*))))
              (make-location (list :file (namestring truename))
                             (if (ccl::function-source-line fspec)
                                 (list :line 
				       (1+ (ccl::function-source-line fspec)))
                                 (list :function-name 
				       (princ-to-string
					(function-name fspec))))))
          (error (c) (list :error (princ-to-string c))))
        (list :error (format nil "No source information available for ~S"
                             fspec)))))

(defimplementation find-definitions (name)
  (list (list name (fspec-location name))))

(defimplementation arglist (name)
  (handler-case
      (cond ((and (symbolp name)
                  (macro-function name))
             (ccl::macro-lambda-list (symbol-function name)))
            (t
             (when (symbolp name)
               (setq name (symbol-function name)))
             (if (eq (class-of name) cl::the-class-standard-gf)
                 (generic-function-lambda-list name)
                 (ccl:function-lambda-list name))))
    (error () :not-available)))

(defimplementation function-name (fn)
  (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
    (error () nil)))

(defimplementation describe-symbol-for-emacs (symbol)
  (let ((result '()))
    (flet ((doc (kind &optional (sym symbol))
             (or (documentation sym kind) :not-documented))
           (maybe-push (property value)
             (when value
               (setf result (list* property value result)))))
      (maybe-push
       :variable (when (boundp symbol)
                   (doc 'variable)))
      (maybe-push
       :function (if (fboundp symbol)
                     (doc 'function)))
      (maybe-push
       :class (if (find-class symbol nil)
                  (doc 'class)))
      result)))

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

;;; Compiler 

(defvar *buffer-name* nil)
(defvar *buffer-position*)
(defvar *buffer-string*)
(defvar *compile-filename* nil)

;; FIXME
(defimplementation call-with-compilation-hooks (FN)
  (handler-bind ((error (lambda (c)
                          (signal 'compiler-condition
                                  :original-condition c
                                  :severity :warning
                                  :message (format nil "~A" c)
                                  :location
                                  (cond (*buffer-name*
                                         (make-location
                                          (list :buffer *buffer-name*)
                                          (list :offset *buffer-position* 0)))
                                        (*compile-filename*
                                         (make-location
                                          (list :file *compile-filename*)
                                          (list :position 1)))
                                        (t
                                         (list :error "No location")))))))
    (funcall fn)))

(defimplementation swank-compile-file (input-file output-file 
				       load-p external-format
                                       &key policy)
  (declare (ignore external-format policy))
  (with-compilation-hooks ()
    (let ((*buffer-name* nil)
	  (*compile-filename* input-file))
      (multiple-value-bind (output-file warnings? failure?)
	  (compile-file input-file :output-file output-file)
	(values output-file warnings?
		(or failure? (and load-p (load output-file))))))))

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

;;;; Inspecting

;; Hack to make swank.lisp load, at least
(defclass file-stream ())

(defun comma-separated (list &optional (callback (lambda (v)
                                                   `(:value ,v))))
  (butlast (loop for e in list
              collect (funcall callback e)
              collect ", ")))

(defmethod emacs-inspect ((class standard-class))
  `("Name: " 
    (:value ,(class-name class))
    (:newline)
    "Super classes: "
    ,@(comma-separated (swank-mop:class-direct-superclasses class))
    (:newline)
    "Direct Slots: "
    ,@(comma-separated
       (swank-mop:class-direct-slots class)
       (lambda (slot)
	 `(:value ,slot 
		  ,(princ-to-string 
		    (swank-mop:slot-definition-name slot)))))
    (:newline)
    "Effective Slots: "
    ,@(if (swank-mop:class-finalized-p class)
	  (comma-separated
	   (swank-mop:class-slots class)
	   (lambda (slot)
	     `(:value ,slot ,(princ-to-string
			      (swank-mop:slot-definition-name slot)))))
	  '("#<N/A (class not finalized)>"))
    (:newline)
    ,@(when (documentation class t)
	    `("Documentation:" (:newline) ,(documentation class t) (:newline)))
    "Sub classes: "
    ,@(comma-separated (swank-mop:class-direct-subclasses class)
		       (lambda (sub)
			 `(:value ,sub ,(princ-to-string (class-name sub)))))
    (:newline)
    "Precedence List: "
    ,@(if (swank-mop:class-finalized-p class)
	  (comma-separated 
	   (swank-mop:class-precedence-list class)
	   (lambda (class)
	     `(:value ,class 
		      ,(princ-to-string (class-name class)))))
	  '("#<N/A (class not finalized)>"))
    (:newline)))

(defmethod emacs-inspect ((slot cons))
  ;; Inspects slot definitions
  (if (eq (car slot) :name)
      `("Name: " (:value ,(swank-mop:slot-definition-name slot))
		 (:newline)
		 ,@(when (swank-mop:slot-definition-documentation slot)
			 `("Documentation:"  
			   (:newline)
			   (:value 
			    ,(swank-mop:slot-definition-documentation slot))
			   (:newline)))
		 "Init args: " (:value 
				,(swank-mop:slot-definition-initargs slot))
		 (:newline)
		 "Init form: "
		 ,(if (swank-mop:slot-definition-initfunction slot)
		      `(:value ,(swank-mop:slot-definition-initform slot))
		      "#<unspecified>") (:newline)
		      "Init function: " 
		      (:value ,(swank-mop:slot-definition-initfunction slot))
		      (:newline))
      (call-next-method)))
  
(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
  (list*  (if (wild-pathname-p pathname)
              "A wild pathname."
              "A pathname.")
	  '(:newline)
          (append (label-value-line*
                   ("Namestring" (namestring pathname))
                   ("Host"       (pathname-host pathname))
                   ("Device"     (pathname-device pathname))
                   ("Directory"  (pathname-directory pathname))
                   ("Name"       (pathname-name pathname))
                   ("Type"       (pathname-type pathname))
                   ("Version"    (pathname-version pathname)))
                  (unless (or (wild-pathname-p pathname)
                              (not (probe-file pathname)))
                    (label-value-line "Truename" (truename pathname))))))

(defmethod emacs-inspect ((o t))
  (cond ((cl::structurep o) (inspect-structure o))
	(t (call-next-method))))

(defun inspect-structure (o)
   (let* ((template (cl::uref o 1))
	  (num-slots (cl::struct-template-num-slots template)))
     (cond ((symbolp template)
	    (loop for i below num-slots
		  append (label-value-line i (cl::uref o (+ 2 i)))))
	   (t
	    (loop for i below num-slots
		  append (label-value-line (elt template (+ 6 (* i 5)))
					   (cl::uref o (+ 2 i))))))))


;;; Threads

(require 'threads)

(defstruct (mailbox (:conc-name mailbox.)) 
  thread
  (lock (make-instance 'threads:critical-section))
  (queue '() :type list))

(defvar *mailbox-lock* (make-instance 'threads:critical-section))
(defvar *mailboxes* (list))

(defmacro with-lock  (lock &body body)
  `(threads:with-synchronization (threads:cs ,lock)
    ,@body))

(defimplementation spawn (fun &key name)
  (declare (ignore name))
  (th:create-thread 
   (lambda ()
     (handler-bind ((serious-condition #'invoke-debugger))
       (unwind-protect (funcall fun)
	 (with-lock *mailbox-lock*
	   (setq *mailboxes* (remove cormanlisp:*current-thread-id*
				     *mailboxes* :key #'mailbox.thread))))))))

(defimplementation thread-id (thread)
  thread)

(defimplementation find-thread (thread)
  (if (thread-alive-p thread)
      thread))

(defimplementation thread-alive-p (thread)
  (if (threads:thread-handle thread) t nil))

(defimplementation current-thread ()
  cormanlisp:*current-thread-id*)

;; XXX implement it
(defimplementation all-threads ()
  '())

;; XXX something here is broken
(defimplementation kill-thread (thread)
  (threads:terminate-thread thread 'killed))

(defun mailbox (thread)
  (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)))
    (with-lock (mailbox.lock mbox)
      (setf (mailbox.queue mbox)
	    (nconc (mailbox.queue mbox) (list message))))))

(defimplementation receive ()
  (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
    (loop 
     (with-lock (mailbox.lock mbox)
       (when (mailbox.queue mbox)
	 (return (pop (mailbox.queue mbox)))))
     (sleep 0.1))))


;;; This is probably not good, but it WFM
(in-package :common-lisp)

(defvar *old-documentation* #'documentation)
(defun documentation (thing &optional (type 'function))
  (if (symbolp thing)
      (funcall *old-documentation* thing type)
      (values)))

(defmethod print-object ((restart restart) stream)
  (if (or *print-escape*
          *print-readably*)
      (print-unreadable-object (restart stream :type t :identity t)
        (princ (restart-name restart) stream))
      (when (functionp (restart-report-function restart))
        (funcall (restart-report-function restart) stream))))