lispworks.lisp

;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-lispworks.lisp --- LispWorks specific code for SLIME. 
;;;
;;; Created 2003, Helmut Eller
;;;
;;; This code has been placed in the Public Domain.  All warranties
;;; are disclaimed.
;;;

(in-package :conium)

(eval-when (:compile-toplevel :execute :load-toplevel)
  (defvar *original-defimplementation* (macro-function 'defimplementation))
  (defmacro defimplementation (&whole whole name args &body body 
                               &environment env)
    (declare (ignore args body))
    `(progn
       (dspec:record-definition '(defun ,name) (dspec:location)
                                :check-redefinition-p nil)
       ,(funcall *original-defimplementation* whole env))))

(defun make-flexi-stream (stream external-format)
  (unless (member :flexi-streams *features*)
    (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
           external-format))
  (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
           stream
           :external-format
           (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
                  external-format)))

;;; Coding Systems

(defun valid-external-format-p (external-format)
  (member external-format *external-format-to-coding-system*
          :test #'equal :key #'car))

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

(defimplementation find-external-format (coding-system)
  (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
                  *external-format-to-coding-system*)))

;;; Unix signals

(defun sigint-handler ()
  (with-simple-restart  (continue "Continue from SIGINT handler.")
    (invoke-debugger "SIGINT")))

(defun make-sigint-handler (process)
  (lambda (&rest args)
    (declare (ignore args))
    (mp:process-interrupt process #'sigint-handler)))

(defun set-sigint-handler ()
  ;; Set SIGINT handler on Swank request handler thread.
  #-win32
  (sys::set-signal-handler +sigint+ 
                           (make-sigint-handler mp:*current-process*)))

#-win32 
(defimplementation install-sigint-handler (handler)
  (sys::set-signal-handler +sigint+
                           (let ((self mp:*current-process*))
                             (lambda (&rest args)
                               (declare (ignore args))
                               (mp:process-interrupt self handler)))))

(defimplementation call-without-interrupts (fn)
  (lw:without-interrupts (funcall fn)))
  
(defimplementation getpid ()
  #+win32 (win32:get-current-process-id)
  #-win32 (system::getpid))

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

(defimplementation set-default-directory (directory)
  (namestring (hcl:change-directory directory)))

;;;; Documentation

(defimplementation arglist (symbol-or-function)
  (let ((arglist (lw:function-lambda-list symbol-or-function)))
    (etypecase arglist
      ((member :dont-know) 
       :not-available)
      (list
       arglist))))

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

(defimplementation macroexpand-all (form)
  (walker:walk-form form))

(defun generic-function-p (object)
  (typep object 'generic-function))

(defimplementation describe-symbol-for-emacs (symbol)
  "Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
  (let ((result '()))
    (labels ((first-line (string) 
               (let ((pos (position #\newline string)))
                 (if (null pos) string (subseq string 0 pos))))
             (doc (kind &optional (sym symbol))
               (let ((string (or (documentation sym kind))))
                 (if string 
                     (first-line string)
                     :not-documented)))
             (maybe-push (property value)
               (when value
                 (setf result (list* property value result)))))
      (maybe-push
       :variable (when (boundp symbol)
                   (doc 'variable)))
      (maybe-push
       :generic-function (if (and (fboundp symbol)
                                  (generic-function-p (fdefinition symbol)))
                             (doc 'function)))
      (maybe-push
       :function (if (and (fboundp symbol)
                          (not (generic-function-p (fdefinition symbol))))
                     (doc 'function)))
      (maybe-push
       :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
               (if (fboundp setf-name)
                   (doc 'setf))))
      (maybe-push
       :class (if (find-class symbol nil) 
                  (doc 'class)))
      result)))

(defimplementation describe-definition (symbol type)
  (ecase type
    (:variable (describe-symbol symbol))
    (:class (describe (find-class symbol)))
    ((:function :generic-function) (describe-function symbol))
    (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))

(defun describe-function (symbol)
  (cond ((fboundp symbol)
         (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
                 symbol
                 (lispworks:function-lambda-list symbol)
                 (documentation symbol 'function))
         (describe (fdefinition symbol)))
        (t (format t "~S is not fbound" symbol))))

(defun describe-symbol (sym)
  (format t "~A is a symbol in package ~A." sym (symbol-package sym))
  (when (boundp sym)
    (format t "~%~%Value: ~A" (symbol-value sym)))
  (let ((doc (documentation sym 'variable)))
    (when doc 
      (format t "~%~%Variable documentation:~%~A"  doc)))
  (when (fboundp sym)
    (describe-function sym)))

;;; Debugging

(defclass slime-env (env:environment) 
  ((debugger-hook :initarg :debugger-hoook)))

(defun slime-env (hook io-bindings) 
  (make-instance 'slime-env :name "SLIME Environment" 
                 :io-bindings io-bindings
                 :debugger-hoook hook))

(defmethod env-internals:environment-display-notifier 
    ((env slime-env) &key restarts condition)
  (declare (ignore restarts condition))
  (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
  ;;  nil
  )

(defmethod env-internals:environment-display-debugger ((env slime-env))
  *debug-io*)

(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
  (apply (swank-sym :y-or-n-p-in-emacs) msg args))

(defimplementation call-with-debugger-hook (hook fun)
  (let ((*debugger-hook* hook))
    (env:with-environment ((slime-env hook '()))
      (funcall fun))))

(defimplementation install-debugger-globally (function)
  (setq *debugger-hook* function)
  (setf (env:environment) (slime-env function '())))

(defvar *sldb-top-frame*)

(defun interesting-frame-p (frame)
  (cond ((or (dbg::call-frame-p frame)
             (dbg::derived-call-frame-p frame)
             (dbg::foreign-frame-p frame)
             (dbg::interpreted-call-frame-p frame))
         t)
        ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
        ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
        ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
        ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
        ((dbg::open-frame-p frame) dbg:*print-open-frames*)
        (t nil)))

(defun nth-next-frame (frame n)
  "Unwind FRAME N times."
  (do ((frame frame (dbg::frame-next frame))
       (i n (if (interesting-frame-p frame) (1- i) i)))
      ((or (not frame)
           (and (interesting-frame-p frame) (zerop i)))
       frame)))

(defun nth-frame (index)
  (nth-next-frame *sldb-top-frame* index))
           
(defun find-top-frame ()
  "Return the most suitable top-frame for the debugger."
  (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
                  (nth-next-frame frame 1)))
          ((or (null frame)             ; no frame found!
               (and (dbg::call-frame-p frame)
                    (eq (dbg::call-frame-function-name frame) 
                        'invoke-debugger)))
           (nth-next-frame frame 1)))
      ;; if we can't find a invoke-debugger frame, take any old frame at the top
      (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))
  
(defimplementation call-with-debugging-environment (fn)
  (dbg::with-debugger-stack ()
    (let ((*sldb-top-frame* (find-top-frame)))
      (funcall fn))))

(defimplementation compute-backtrace (start end)
  (let ((end (or end most-positive-fixnum))
	(backtrace '()))
    (do ((frame (nth-frame start) (dbg::frame-next frame))
	 (i start))
	((or (not frame) (= i end)) (nreverse backtrace))
      (when (interesting-frame-p frame)
	(incf i)
	(push frame backtrace)))))

(defun frame-actual-args (frame)
  (let ((*break-on-signals* nil))
    (mapcar (lambda (arg)
              (case arg
                ((&rest &optional &key) arg)
                (t
                 (handler-case (dbg::dbg-eval arg frame)
                   (error (e) (format nil "<~A>" arg))))))
            (dbg::call-frame-arglist frame))))

(defimplementation print-frame (frame stream)
  (cond ((dbg::call-frame-p frame)
         (format stream "~S ~S"
                 (dbg::call-frame-function-name frame)
                 (frame-actual-args frame)))
        (t (princ frame stream))))

(defun frame-vars (frame)
  (first (dbg::frame-locals-format-list frame #'list 75 0)))

(defimplementation frame-locals (n)
  (let ((frame (nth-frame n)))
    (if (dbg::call-frame-p frame)
        (mapcar (lambda (var)
                  (destructuring-bind (name value symbol location) var
                    (declare (ignore name location))
                    (list :name symbol :id 0
                          :value value)))
                (frame-vars frame)))))

(defimplementation frame-var-value (frame var)
  (let ((frame (nth-frame frame)))
    (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
      (declare (ignore _n _s _l))
      value)))

(defimplementation frame-source-location-for-emacs (frame)
  (let ((frame (nth-frame frame))
        (callee (if (plusp frame) (nth-frame (1- frame)))))
    (if (dbg::call-frame-p frame)
	(let ((dspec (dbg::call-frame-function-name frame))
              (cname (and (dbg::call-frame-p callee)
                          (dbg::call-frame-function-name callee))))
	  (if dspec
              (frame-location dspec cname))))))

(defimplementation eval-in-frame (form frame-number)
  (let ((frame (nth-frame frame-number)))
    (dbg::dbg-eval form frame)))

(defimplementation return-from-frame (frame-number form)
  (let* ((frame (nth-frame frame-number))
         (return-frame (dbg::find-frame-for-return frame)))
    (dbg::dbg-return-from-call-frame frame form return-frame 
                                     dbg::*debugger-stack*)))

(defimplementation restart-frame (frame-number)
  (let ((frame (nth-frame frame-number)))
    (dbg::restart-frame frame :same-args t)))

(defimplementation disassemble-frame (frame-number)
  (let* ((frame (nth-frame frame-number)))
    (when (dbg::call-frame-p frame)
      (let ((function (dbg::get-call-frame-function frame)))
        (disassemble function)))))

;;; Definition finding

(defun frame-location (dspec callee-name)
  (let ((infos (dspec:find-dspec-locations dspec)))
    (cond (infos 
           (destructuring-bind ((rdspec location) &rest _) infos
             (declare (ignore _))
             (let ((name (and callee-name (symbolp callee-name)
                              (string callee-name))))
               (make-dspec-location rdspec location 
                                    `(:call-site ,name)))))
          (t 
           (list :error (format nil "Source location not available for: ~S" 
                                dspec))))))

(defimplementation find-definitions (name)
  (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
    (loop for (dspec location) in locations
          collect (list dspec (make-dspec-location dspec location)))))


;;; Compilation 

(defmacro with-swank-compilation-unit ((location &rest options) &body body)
  (lw:rebinding (location)
    `(let ((compiler::*error-database* '()))
       (with-compilation-unit ,options
         (multiple-value-prog1 (progn ,@body)
           (signal-error-data-base compiler::*error-database* 
                                   ,location)
           (signal-undefined-functions compiler::*unknown-functions* 
                                       ,location))))))

(defimplementation swank-compile-file (input-file output-file
                                       load-p external-format)
  (with-swank-compilation-unit (input-file)
    (compile-file input-file 
                  :output-file output-file
                  :load load-p 
                  :external-format external-format)))

(defvar *within-call-with-compilation-hooks* nil
  "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")

(defvar *undefined-functions-hash* nil
  "Hash table to map info about undefined functions to pathnames.")

(lw:defadvice (compile-file compile-file-and-collect-notes :around)
    (pathname &rest rest)
  (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
    (when *within-call-with-compilation-hooks*
      (maphash (lambda (unfun dspecs)
                 (dolist (dspec dspecs)
                   (let ((unfun-info (list unfun dspec)))
                     (unless (gethash unfun-info *undefined-functions-hash*)
                       (setf (gethash unfun-info *undefined-functions-hash*)
                               pathname)))))
               compiler::*unknown-functions*))))

(defimplementation call-with-compilation-hooks (function)
  (let ((compiler::*error-database* '())
        (*undefined-functions-hash* (make-hash-table :test 'equal))
        (*within-call-with-compilation-hooks* t))
    (with-compilation-unit ()
      (prog1 (funcall function)
        (signal-error-data-base compiler::*error-database*)
        (signal-undefined-functions compiler::*unknown-functions*)))))

(defun map-error-database (database fn)
  (loop for (filename . defs) in database do
	(loop for (dspec . conditions) in defs do
	      (dolist (c conditions) 
		(funcall fn filename dspec (if (consp c) (car c) c))))))

(defun lispworks-severity (condition)
  (cond ((not condition) :warning)
	(t (etypecase condition
	     (error :error)
	     (style-warning :warning)
	     (warning :warning)))))

(defun signal-compiler-condition (message location condition)
  (check-type message string)
  (signal 
   (make-instance 'compiler-condition :message message 
		  :severity (lispworks-severity condition) 
		  :location location
		  :original-condition condition)))

(defvar *temp-file-format* '(:utf-8 :eol-style :lf))

(defun compile-from-temp-file (string filename)
  (unwind-protect
       (progn
	 (with-open-file (s filename :direction :output
                                     :if-exists :supersede
                                     :external-format *temp-file-format*)

	   (write-string string s)
	   (finish-output s))
         (multiple-value-bind (binary-filename warnings? failure?)
             (compile-file filename :load t
                           :external-format *temp-file-format*)
           (declare (ignore warnings?))
           (when binary-filename
             (delete-file binary-filename))
           (not failure?)))
    (delete-file filename)))

(defun dspec-function-name-position (dspec fallback)
  (etypecase dspec
    (cons (let ((name (dspec:dspec-primary-name dspec)))
            (typecase name
              ((or symbol string) 
               (list :function-name (string name)))
              (t fallback))))
    (null fallback)
    (symbol (list :function-name (string dspec)))))

(defmacro with-fairly-standard-io-syntax (&body body)
  "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
  (let ((package (gensym))
        (readtable (gensym)))
    `(let ((,package *package*)
           (,readtable *readtable*))
      (with-standard-io-syntax
        (let ((*package* ,package)
              (*readtable* ,readtable))
          ,@body)))))

(defun skip-comments (stream)
  (let ((pos0 (file-position stream)))
    (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
                  '(()))
           (file-position stream (1- (file-position stream))))
          (t (file-position stream pos0)))))

#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
(defun dspec-stream-position (stream dspec)
  (with-fairly-standard-io-syntax
    (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
                 (form (read stream nil '#1=#:eof)))
            (when (eq form '#1#)
              (return nil))
            (labels ((check-dspec (form)
                       (when (consp form)
                         (let ((operator (car form)))
                           (case operator
                             ((progn)
                              (mapcar #'check-dspec
                                      (cdr form)))
                             ((eval-when locally macrolet symbol-macrolet)
                              (mapcar #'check-dspec
                                      (cddr form)))
                             ((in-package)
                              (let ((package (find-package (second form))))
                                (when package
                                  (setq *package* package))))
                             (otherwise
                              (let ((form-dspec (dspec:parse-form-dspec form)))
                                (when (dspec:dspec-equal dspec form-dspec)
                                  (return pos)))))))))
              (check-dspec form))))))

(defun dspec-file-position (file dspec)
  (let* ((*compile-file-pathname* (pathname file))
         (*compile-file-truename* (truename *compile-file-pathname*))
         (*load-pathname* *compile-file-pathname*)
         (*load-truename* *compile-file-truename*))
    (with-open-file (stream file)
      (let ((pos 
             #-(or lispworks4.1 lispworks4.2)
             (dspec-stream-position stream dspec)))
        (if pos
            (list :position (1+ pos))
            (dspec-function-name-position dspec `(:position 1)))))))

(defun emacs-buffer-location-p (location)
  (and (consp location)
       (eq (car location) :emacs-buffer)))

(defun make-dspec-location (dspec location &optional hints)
  (etypecase location
    ((or pathname string)
     (multiple-value-bind (file err) 
         (ignore-errors (namestring (truename location)))
       (if err
           (list :error (princ-to-string err))
           (make-location `(:file ,file)
                          (dspec-file-position file dspec)
                          hints))))
    (symbol 
     `(:error ,(format nil "Cannot resolve location: ~S" location)))
    ((satisfies emacs-buffer-location-p)
     (destructuring-bind (_ buffer offset string) location
       (declare (ignore _ string))
       (make-location `(:buffer ,buffer)
                      (dspec-function-name-position dspec `(:offset ,offset 0))
                      hints)))))

(defun make-dspec-progenitor-location (dspec location)
  (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
    (make-dspec-location
     (if canon-dspec
         (if (dspec:local-dspec-p canon-dspec)
             (dspec:dspec-progenitor canon-dspec)
           canon-dspec)
       nil)
     location)))

(defun signal-error-data-base (database &optional location)
  (map-error-database 
   database
   (lambda (filename dspec condition)
     (signal-compiler-condition
      (format nil "~A" condition)
      (make-dspec-progenitor-location dspec (or location filename))
      condition))))

(defun unmangle-unfun (symbol)
  "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
function names like \(SETF GET)."
  (cond ((sys::setf-symbol-p symbol)
         (sys::setf-pair-from-underlying-name symbol))
        (t symbol)))
                    
(defun signal-undefined-functions (htab &optional filename)
  (maphash (lambda (unfun dspecs)
	     (dolist (dspec dspecs)
	       (signal-compiler-condition 
		(format nil "Undefined function ~A" (unmangle-unfun unfun))
		(make-dspec-progenitor-location dspec
                                                (or filename
                                                    (gethash (list unfun dspec)
                                                             *undefined-functions-hash*)))
		nil)))
	   htab))

(defimplementation swank-compile-string (string &key buffer position filename
                                         policy)
  (declare (ignore filename policy))
  (assert buffer)
  (assert position)
  (let* ((location (list :emacs-buffer buffer position string))
         (tmpname (hcl:make-temp-file nil "lisp")))
    (with-swank-compilation-unit (location)
      (compile-from-temp-file 
       (with-output-to-string (s)
         (let ((*print-radix* t))
           (print `(eval-when (:compile-toplevel)
                     (setq dspec::*location* (list ,@location)))
                  s))
         (write-string string s))
       tmpname))))

;;; xref

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

(defxref who-calls      hcl:who-calls)
(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
(defxref calls-who      hcl:calls-who)
(defxref list-callers   list-callers-internal)
;; (defxref list-callees   list-callees-internal)

(defun list-callers-internal (name)
  (let ((callers (make-array 100
                             :fill-pointer 0
                             :adjustable t)))
    (hcl:sweep-all-objects
     #'(lambda (object)
         (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
                    #-Harlequin-PC-Lisp (sys::callablep object)
                    (system::find-constant$funcallable name object))
           (vector-push-extend object callers))))
    ;; Delay dspec:object-dspec until after sweep-all-objects
    ;; to reduce allocation problems.
    (loop for object across callers
          collect (if (symbolp object)
		      (list 'function object)
                      (or (dspec:object-dspec object) object)))))

;; only for lispworks 4.2 and above
#-lispworks4.1
(progn
  (defxref who-references hcl:who-references)
  (defxref who-binds      hcl:who-binds)
  (defxref who-sets       hcl:who-sets))

(defimplementation who-specializes (classname)
  (let ((methods (clos:class-direct-methods (find-class classname))))
    (xref-results (mapcar #'dspec:object-dspec methods))))

(defun xref-results (dspecs)
  (flet ((frob-locs (dspec locs)
           (cond (locs
                  (loop for (name loc) in locs
                        collect (list name (make-dspec-location name loc))))
                 (t `((,dspec (:error "Source location not available")))))))
    (loop for dspec in dspecs
          append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))

;;; Inspector

(defmethod emacs-inspect ((o t))
  (lispworks-inspect o))

(defmethod emacs-inspect ((o function))
  (lispworks-inspect o))

;; FIXME: slot-boundp-using-class in LW works with names so we can't
;; use our method in swank.lisp.
(defmethod emacs-inspect ((o standard-object))
  (lispworks-inspect o))

(defun lispworks-inspect (o)
  (multiple-value-bind (names values _getter _setter type)
      (lw:get-inspector-values o nil)
    (declare (ignore _getter _setter))
            (append 
             (label-value-line "Type" type)
             (loop for name in names
                   for value in values
                   append (label-value-line name value)))))

;;; Miscellaneous

(defimplementation quit-lisp ()
  (lispworks:quit))

;;; Tracing

(defun parse-fspec (fspec)
  "Return a dspec for FSPEC."
  (ecase (car fspec)
    ((:defmethod) `(method ,(cdr fspec)))))

(defun tracedp (dspec) 
  (member dspec (eval '(trace)) :test #'equal))

(defun toggle-trace-aux (dspec)
  (cond ((tracedp dspec)
         (eval `(untrace ,dspec))
         (format nil "~S is now untraced." dspec))
        (t
         (eval `(trace (,dspec)))
         (format nil "~S is now traced." dspec))))

(defimplementation toggle-trace (fspec)
  (toggle-trace-aux (parse-fspec fspec)))

(defimplementation set-default-initial-binding (var form)
  (setq mp:*process-initial-bindings* 
        (acons var `(eval (quote ,form))
               mp:*process-initial-bindings* )))

;;; Some intergration with the lispworks environment

(defun swank-sym (name) (find-symbol (string name) :swank))
      

;;;; Weak hashtables

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

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