abcl.lisp

;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
;;;
;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME. 
;;;
;;; Adapted from swank-acl.lisp, Andras Simon, 2004
;;;
;;; This code has been placed in the Public Domain.  All warranties
;;; are disclaimed. 
;;;  

(in-package :conium)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :collect) ;just so that it doesn't spoil the flying letters
  (require :pprint))

(defun sys::break (&optional (format-control "BREAK called") 
                   &rest format-arguments)
  (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls)))
    (with-simple-restart (continue "Return from BREAK.")
      (invoke-debugger
       (sys::%make-condition 'simple-condition
                             (list :format-control format-control
                                   :format-arguments format-arguments))))
    nil))

(defimplementation make-output-stream (write-string)
  (ext:make-slime-output-stream write-string))

(defimplementation make-input-stream (read-string)
  (ext:make-slime-input-stream read-string  
                               (make-synonym-stream '*standard-output*)))

(defimplementation call-with-compilation-hooks (function)
  (funcall function))

;;dummies and definition

(defclass standard-slot-definition ()())

;(defun class-finalized-p (class) t)

(defun slot-definition-documentation (slot) #+nil (documentation slot 't))
(defun slot-definition-type (slot) t)
(defun class-prototype (class))
(defun generic-function-declarations (gf))
(defun specializer-direct-methods (spec) (mop::class-direct-methods spec))

(defun slot-definition-name (slot)
  (mop::%slot-definition-name slot))

(defun class-slots (class)
  (mop::%class-slots class))

(defun method-generic-function (method)
  (mop::%method-generic-function method))

(defun method-function (method)
  (mop::%method-function method))

(defun slot-boundp-using-class (class object slotdef)
  (system::slot-boundp object (slot-definition-name slotdef)))

(defun slot-value-using-class (class object slotdef)
  (system::slot-value object (slot-definition-name slotdef)))

;;;; Unix signals

(defimplementation call-without-interrupts (fn)
  (funcall fn))

(defimplementation getpid ()
  (handler-case 
      (let* ((runtime 
              (java:jstatic "getRuntime" "java.lang.Runtime"))
             (command
              (java:jnew-array-from-array 
               "java.lang.String" #("sh" "-c" "echo $PPID")))
             (runtime-exec-jmethod 		
              ;; Complicated because java.lang.Runtime.exec() is
              ;; overloaded on a non-primitive type (array of
              ;; java.lang.String), so we have to use the actual
              ;; parameter instance to get java.lang.Class
              (java:jmethod "java.lang.Runtime" "exec" 
                            (java:jcall 
                             (java:jmethod "java.lang.Object" "getClass")
                             command)))
             (process 
              (java:jcall runtime-exec-jmethod runtime command))
             (output 
              (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
                          process)))
         (java:jcall (java:jmethod "java.lang.Process" "waitFor")
                     process)
	 (loop :with b :do 
	    (setq b 
		  (java:jcall (java:jmethod "java.io.InputStream" "read")
			      output))
	    :until (member b '(-1 #x0a))	; Either EOF or LF
	    :collecting (code-char b) :into result
	    :finally (return 
		       (parse-integer (coerce result 'string)))))
    (t () 0))) 

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

(defimplementation set-default-directory (directory)
  (let ((dir (sys::probe-directory directory)))
    (when dir (setf *default-pathname-defaults* dir))
    (namestring dir)))


;;;; Misc

(defimplementation arglist (fun)
  (cond ((symbolp fun)
         (multiple-value-bind (arglist present) (sys::arglist fun)
           (if present arglist :not-available)))
        (t :not-available)))

(defimplementation function-name (function)
  (nth-value 2 (function-lambda-expression function)))

(defimplementation macroexpand-all (form)
  (macroexpand form))

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

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


;;;; Debugger

(defvar *sldb-topframe*)

(defun backtrace-as-list-ignoring-swank-calls ()
  (let ((list (ext:backtrace-as-list)))
    (subseq list (1+ (or (position (intern "SWANK-DEBUGGER-HOOK" 'swank) list :key 'car) -1)))))

(defimplementation call-with-debugging-environment (debugger-loop-fn)
  (let ((*sldb-topframe* (car (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame)))
    (funcall debugger-loop-fn)))

(defun nth-frame (index)
  (nth index (backtrace-as-list-ignoring-swank-calls)))

(defimplementation compute-backtrace (start end)
  (let ((end (or end most-positive-fixnum)))
    (loop for f in (subseq (backtrace-as-list-ignoring-swank-calls) start end)
          collect f)))

(defimplementation print-frame (frame stream)
  (write-string (string-trim '(#\space #\newline)
                             (prin1-to-string frame))
                stream))

(defimplementation frame-locals (index)
  `(,(list :name "??" :id 0 :value "??")))

#+nil
(defimplementation disassemble-frame (index)
  (disassemble (debugger:frame-function (nth-frame index))))

(defimplementation frame-source-location-for-emacs (index)
  (list :error (format nil "Cannot find source for frame: ~A"
                       (nth-frame index))))

#+nil
(defimplementation eval-in-frame (form frame-number)
  (debugger:eval-form-in-context 
   form
   (debugger:environment-of-frame (nth-frame frame-number))))

#+nil
(defimplementation return-from-frame (frame-number form)
  (let ((frame (nth-frame frame-number)))
    (multiple-value-call #'debugger:frame-return 
      frame (debugger:eval-form-in-context 
             form 
             (debugger:environment-of-frame frame)))))
                         
;;; XXX doesn't work for frames with arguments 
#+nil
(defimplementation restart-frame (frame-number)
  (let ((frame (nth-frame frame-number)))
    (debugger:frame-retry frame (debugger:frame-function frame))))
                          
;;;; Compiler hooks

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

(in-package :conium)

(defun handle-compiler-warning (condition)
  (let ((loc (when (and jvm::*compile-file-pathname* 
                        system::*source-position*)
               (cons jvm::*compile-file-pathname* system::*source-position*))))
    ;; filter condition signaled more than once.
    (unless (member condition *abcl-signaled-conditions*) 
      (push condition *abcl-signaled-conditions*) 
      (signal (make-condition
               'compiler-condition
               :original-condition condition
               :severity :warning
               :message (format nil "~A" condition)
               :location (cond (*buffer-name*
                                (make-location 
                                 (list :buffer *buffer-name*)
                                 (list :offset *buffer-start-position* 0)))
                               (loc
                                (destructuring-bind (file . pos) loc
                                  (make-location
                                   (list :file (namestring (truename file)))
                                   (list :position (1+ pos)))))
                               (t  
                                (make-location
                                 (list :file (namestring *compile-filename*))
                                 (list :position 1)))))))))

(defvar *abcl-signaled-conditions*)

(defimplementation swank-compile-file (input-file output-file
                                       load-p external-format)
  (declare (ignore external-format))
  (let ((jvm::*resignal-compiler-warnings* t)
        (*abcl-signaled-conditions* nil))
    (handler-bind ((warning #'handle-compiler-warning))
      (let ((*buffer-name* nil)
            (*compile-filename* input-file))
        (multiple-value-bind (fn warn fail) 
            (compile-file input-file :output-file output-file)
          (values fn warn
                  (or fail 
                      (and load-p 
                           (not (load fn))))))))))

(defimplementation swank-compile-string (string &key buffer position filename
                                         policy)
  (declare (ignore filename policy))
  (let ((jvm::*resignal-compiler-warnings* t)
        (*abcl-signaled-conditions* nil))
    (handler-bind ((warning #'handle-compiler-warning))                 
      (let ((*buffer-name* buffer)
            (*buffer-start-position* position)
            (*buffer-string* string))
        (funcall (compile nil (read-from-string
                               (format nil "(~S () ~A)" 'lambda string))))
        t))))

#|
;;;; Definition Finding

(defun find-fspec-location (fspec type)
  (let ((file (excl::fspec-pathname fspec type)))
    (etypecase file
      (pathname
       (let ((start (scm:find-definition-in-file fspec type file)))
         (make-location (list :file (namestring (truename file)))
                        (if start
                            (list :position (1+ start))
                            (list :function-name (string fspec))))))
      ((member :top-level)
       (list :error (format nil "Defined at toplevel: ~A" fspec)))
      (null 
       (list :error (format nil "Unkown source location for ~A" fspec))))))

(defun fspec-definition-locations (fspec)
  (let ((defs (excl::find-multiple-definitions fspec)))
    (loop for (fspec type) in defs 
          collect (list fspec (find-fspec-location fspec type)))))

(defimplementation find-definitions (symbol)
  (fspec-definition-locations symbol))

|#

(defun source-location (symbol)
  (when (pathnamep (ext:source-pathname symbol))
    `(((,symbol)
       (:location 
        (:file ,(namestring (ext:source-pathname symbol)))
        (:position ,(or (ext:source-file-position symbol) 1))
        (:align t))))))


(defimplementation find-definitions (symbol)
  (source-location symbol))

#| 
Uncomment this if you have patched xref.lisp, as in 
http://article.gmane.org/gmane.lisp.slime.devel/2425
Also, make sure that xref.lisp is loaded by modifying the armedbear
part of *sysdep-pathnames* in swank.loader.lisp. 

;;;; XREF
(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 (list symbol (cadar (source-location symbol))) xrefs))
    xrefs))
|#

;;;; Inspecting

(defmethod emacs-inspect ((slot mop::slot-definition))
          `("Name: " (:value ,(mop::%slot-definition-name slot))
            (:newline)
            "Documentation:" (:newline)
            ,@(when (slot-definition-documentation slot)
                `((:value ,(slot-definition-documentation slot)) (:newline)))
            "Initialization:" (:newline)
            "  Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
            "  Form: "  ,(if (mop::%slot-definition-initfunction slot)
                             `(:value ,(mop::%slot-definition-initform slot))
                             "#<unspecified>") (:newline)
            "  Function: " (:value ,(mop::%slot-definition-initfunction slot))
            (:newline)))

(defmethod emacs-inspect ((f function))
          `(,@(when (function-name f)
                    `("Name: " 
                      ,(princ-to-string (function-name f)) (:newline)))
            ,@(multiple-value-bind (args present) 
                                   (sys::arglist f)
                                   (when present `("Argument list: " ,(princ-to-string args) (:newline))))
            (:newline)
            #+nil,@(when (documentation f t)
                         `("Documentation:" (:newline) ,(documentation f t) (:newline)))
            ,@(when (function-lambda-expression f)
                    `("Lambda expression:" 
                      (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))

#|

(defmethod emacs-inspect ((o t))
  (let* ((class (class-of o))
         (slots (mop::class-slots class)))
            (mapcar (lambda (slot)
                      (let ((name (mop::slot-definition-name slot)))
                        (cons (princ-to-string name)
                              (slot-value o name))))
                    slots)))
|#

(defimplementation quit-lisp ()
  (ext:exit))

;; WORKAROUND: call/initialize accessors at load time
(let ((c (make-condition 'compiler-condition 
                          :original-condition nil
                          :severity ':note :message "" :location nil))
       (slots `(severity message short-message references location)))
   (dolist (slot slots)
     (funcall slot c)))