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

;;;;                  -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
;;;
;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
;;;
;;; Created 2003
;;;
;;; This code has been placed in the Public Domain.  All warranties
;;; are disclaimed.
;;;

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

(in-package swank/allegro)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :sock)
  (require :process)
  #+(version>= 8 2)
  (require 'lldb))

(defimplementation gray-package-name ()
  '#:excl)

;;; swank-mop

(import-swank-mop-symbols :clos '(:slot-definition-documentation))

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


;;;; UTF8

(define-symbol-macro utf8-ef
    (load-time-value
     (excl:crlf-base-ef (excl:find-external-format :utf-8))
     t))

(defimplementation string-to-utf8 (s)
  (excl:string-to-octets s :external-format utf8-ef
                         :null-terminate nil))

(defimplementation utf8-to-string (u)
  (excl:octets-to-string u :external-format utf8-ef))


;;;; TCP Server

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

(defimplementation create-socket (host port &key backlog)
  (socket:make-socket :connect :passive :local-port port
                      :local-host host :reuse-address t
                      :backlog (or backlog 5)))

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

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

(defimplementation accept-connection (socket &key external-format buffering
                                             timeout)
  (declare (ignore buffering timeout))
  (let ((s (socket:accept-connection socket :wait t)))
    (when external-format
      (setf (stream-external-format s) external-format))
    s))

(defimplementation socket-fd (stream)
  (excl::stream-input-handle stream))

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

(defimplementation find-external-format (coding-system)
  (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
                      *external-format-to-coding-system*)))
    (and e (excl:crlf-base-ef
            (excl:find-external-format (car e)
                                       :try-variant t)))))

;;;; Unix signals

(defimplementation getpid ()
  (excl::getpid))

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

(defimplementation set-default-directory (directory)
  (let* ((dir (namestring (truename (merge-pathnames directory)))))
    (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
    dir))

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

;;;; Misc

(defimplementation arglist (symbol)
  (handler-case (excl:arglist symbol)
    (simple-error () :not-available)))

(defimplementation macroexpand-all (form &optional env)
  (declare (ignore env))
  #+(version>= 8 0)
  (excl::walk-form form)
  #-(version>= 8 0)
  (excl::walk 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 type-specifier-p (symbol)
  (or (ignore-errors
       (subtypep nil symbol))
      (not (eq (type-specifier-arglist symbol) :not-available))))

(defimplementation function-name (f)
  (check-type f function)
  (cross-reference::object-to-function-name f))

;;;; Debugger

(defvar *sldb-topframe*)

(defimplementation call-with-debugging-environment (debugger-loop-fn)
  (let ((*sldb-topframe* (find-topframe))
        (excl::*break-hook* nil))
    (funcall debugger-loop-fn)))

(defimplementation sldb-break-at-start (fname)
  ;; :print-before is kind of mis-used but we just want to stuff our
  ;; break form somewhere. This does not work for setf, :before and
  ;; :after methods, which need special syntax in the trace call, see
  ;; ACL's doc/debugging.htm chapter 10.
  (eval `(trace (,fname
                 :print-before
                 ((break "Function start breakpoint of ~A" ',fname)))))
  `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))

(defun find-topframe ()
  (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
                              (find-package :swank)))
        (top-frame (excl::int-newest-frame (excl::current-thread))))
    (loop for frame = top-frame then (next-frame frame)
          for i from 0
          while (and frame (< i 30))
          when (eq (debugger:frame-name frame) magic-symbol)
            return (next-frame frame)
          finally (return top-frame))))

(defun next-frame (frame)
  (let ((next (excl::int-next-older-frame frame)))
    (cond ((not next) nil)
          ((debugger:frame-visible-p next) next)
          (t (next-frame next)))))

(defun nth-frame (index)
  (do ((frame *sldb-topframe* (next-frame frame))
       (i index (1- i)))
      ((zerop i) frame)))

(defimplementation compute-backtrace (start end)
  (let ((end (or end most-positive-fixnum)))
    (loop for f = (nth-frame start) then (next-frame f)
	  for i from start below end
	  while f collect f)))

(defimplementation print-frame (frame stream)
  (debugger:output-frame stream frame :moderate))

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

(defimplementation frame-var-value (frame var)
  (let ((frame (nth-frame frame)))
    (debugger:frame-var-value frame var)))

(defimplementation disassemble-frame (index)
  (let ((frame (nth-frame index)))
    (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
      (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
      (disassemble (debugger:frame-function frame)))))

(defimplementation frame-source-location (index)
  (let* ((frame (nth-frame index)))
    (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
      (declare (ignore x xx xxx))
      (cond ((and pc
                  #+(version>= 8 2)
                  (pc-source-location fun pc)
                  #-(version>= 8 2)
                  (function-source-location fun)))
            (t ; frames for unbound functions etc end up here
             (cadr (car (fspec-definition-locations
                         (car (debugger:frame-expression frame))))))))))

(defun function-source-location (fun)
  (cadr (car (fspec-definition-locations
              (xref::object-to-function-name fun)))))

#+(version>= 8 2)
(defun pc-source-location (fun pc)
  (let* ((debug-info (excl::function-source-debug-info fun)))
    (cond ((not debug-info)
           (function-source-location fun))
          (t
           (let* ((code-loc (find-if (lambda (c)
                                       (<= (- pc (sys::natural-width))
                                           (let ((x (excl::ldb-code-pc c)))
                                             (or x -1))
                                           pc))
                                     debug-info)))
             (cond ((not code-loc)
                    (ldb-code-to-src-loc (aref debug-info 0)))
                   (t
                    (ldb-code-to-src-loc code-loc))))))))

#+(version>= 8 2)
(defun ldb-code-to-src-loc (code)
  (declare (optimize debug))
  (let* ((func (excl::ldb-code-func code))
         (debug-info (excl::function-source-debug-info func))
         (start (loop for i from (excl::ldb-code-index code) downto 0
                      for bpt = (aref debug-info i)
                      for start = (excl::ldb-code-start-char bpt)
                      when start
                        return (if (listp start)
                                   (first start)
                                   start)))
         (src-file (excl:source-file func)))
    (cond (start
           (buffer-or-file-location src-file start))
          (func
           (let* ((debug-info (excl::function-source-debug-info func))
                  (whole (aref debug-info 0))
                  (paths (source-paths-of (excl::ldb-code-source whole)
                                          (excl::ldb-code-source code)))
                  (path (if paths (longest-common-prefix paths) '()))
                  (start 0))
             (buffer-or-file
              src-file
              (lambda (file)
                (make-location `(:file ,file)
                               `(:source-path (0 . ,path) ,start)))
              (lambda (buffer bstart)
                (make-location `(:buffer ,buffer)
                               `(:source-path (0 . ,path)
                                              ,(+ bstart start)))))))
          (t
           nil))))

(defun longest-common-prefix (sequences)
  (assert sequences)
  (flet ((common-prefix (s1 s2)
           (let ((diff-pos (mismatch s1 s2)))
             (if diff-pos (subseq s1 0 diff-pos) s1))))
    (reduce #'common-prefix sequences)))

(defun source-paths-of (whole part)
  (let ((result '()))
    (labels ((walk (form path)
               (cond ((eq form part)
                      (push (reverse path) result))
                     ((consp form)
                      (loop for i from 0 while (consp form) do
                            (walk (pop form) (cons i path)))))))
      (walk whole '())
      (reverse result))))

(defimplementation eval-in-frame (form frame-number)
  (let ((frame (nth-frame frame-number)))
    ;; let-bind lexical variables
    (let ((vars (loop for i below (debugger:frame-number-vars frame)
                      for name = (debugger:frame-var-name frame i)
                      if (typep name '(and symbol (not null) (not keyword)))
                      collect `(,name ',(debugger:frame-var-value frame i)))))
      (debugger:eval-form-in-context
       `(let* ,vars ,form)
       (debugger:environment-of-frame frame)))))

(defimplementation frame-package (frame-number)
  (let* ((frame (nth-frame frame-number))
         (exp (debugger:frame-expression frame)))
    (typecase exp
      ((cons symbol) (symbol-package (car exp)))
      ((cons (cons (eql :internal) (cons symbol)))
       (symbol-package (cadar exp))))))

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

(defimplementation frame-restartable-p (frame)
  (handler-case (debugger:frame-retryable-p frame)
    (serious-condition (c)
      (funcall (read-from-string "swank::background-message")
               "~a ~a" frame (princ-to-string c))
      nil)))

(defimplementation restart-frame (frame-number)
  (let ((frame (nth-frame frame-number)))
    (cond ((debugger:frame-retryable-p frame)
           (apply #'debugger:frame-retry frame (debugger:frame-function frame)
                  (cdr (debugger:frame-expression frame))))
          (t "Frame is not retryable"))))

;;;; Compiler hooks

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

(defun compiler-note-p (object)
  (member (type-of object) '(excl::compiler-note compiler::compiler-note)))

(defun redefinition-p (condition)
  (and (typep condition 'style-warning)
       (every #'char-equal "redefin" (princ-to-string condition))))

(defun compiler-undefined-functions-called-warning-p (object)
  (typep object 'excl:compiler-undefined-functions-called-warning))

(deftype compiler-note ()
  `(satisfies compiler-note-p))

(deftype redefinition ()
  `(satisfies redefinition-p))

(defun signal-compiler-condition (&rest args)
  (apply #'signal 'compiler-condition args))

(defun handle-compiler-warning (condition)
  (declare (optimize (debug 3) (speed 0) (space 0)))
  (cond ((and #-(version>= 10 0) (not *buffer-name*)
              (compiler-undefined-functions-called-warning-p condition))
         (handle-undefined-functions-warning condition))
        ((and (typep condition 'excl::compiler-note)
              (let ((format (slot-value condition 'excl::format-control)))
                (and (search "Closure" format)
                     (search "will be stack allocated" format))))
         ;; Ignore "Closure <foo> will be stack allocated" notes.
         ;; That occurs often but is usually uninteresting.
         )
        (t
         (signal-compiler-condition
          :original-condition condition
          :severity (etypecase condition
                      (redefinition  :redefinition)
                      (style-warning :style-warning)
                      (warning       :warning)
                      (compiler-note :note)
                      (reader-error  :read-error)
                      (error         :error))
          :message (format nil "~A" condition)
          :location (compiler-warning-location condition)))))

(defun condition-pathname-and-position (condition)
  (let* ((context #+(version>= 10 0)
                  (getf (slot-value condition 'excl::plist)
                        :source-context))
         (location-available (and context
                                  (excl::source-context-start-char context))))
    (cond (location-available
           (values (excl::source-context-pathname context)
                   (when-let (start-char (excl::source-context-start-char context))
                     (let ((position (if (listp start-char) ; HACK
                                         (first start-char)
                                         start-char)))
                       (if (typep condition 'excl::compiler-free-reference-warning)
                           position
                           (1+ position))))))
          ((typep condition 'reader-error)
           (let ((pos  (car (last (slot-value condition 'excl::format-arguments))))
                 (file (pathname (stream-error-stream condition))))
             (when (integerp pos)
               (values file pos))))
          (t
           (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
             (when loc
               (destructuring-bind (file . pos) loc
                 (let ((start (if (consp pos) ; 8.2 and newer
                                  #+(version>= 10 1)
                                  (if (typep condition 'excl::compiler-inconsistent-name-usage-warning)
                                      (second pos)
                                      (first pos))
                                  #-(version>= 10 1)
                                  (first pos)
                                  pos)))
                   (values file start)))))))))

(defun compiler-warning-location (condition)
  (multiple-value-bind (pathname position)
      (condition-pathname-and-position condition)
    (cond (*buffer-name*
           (make-location
            (list :buffer *buffer-name*)
            (if position
                (list :offset 1 (1- position))
                (list :offset *buffer-start-position* 0))))
          (pathname
           (make-location
            (list :file (namestring (truename pathname)))
            #+(version>= 10 1)
            (list :offset 1 position)
            #-(version>= 10 1)
            (list :position (1+ position))))
          (t
           (make-error-location "No error location available.")))))

;; TODO: report it as a bug to Franz that the condition's plist
;; slot contains (:loc nil).
(defun handle-undefined-functions-warning (condition)
  (let ((fargs (slot-value condition 'excl::format-arguments)))
    (loop for (fname . locs) in (car fargs) do
          (dolist (loc locs)
            (multiple-value-bind (pos file) (ecase (length loc)
                                              (2 (values-list loc))
                                              (3 (destructuring-bind
                                                       (start end file) loc
                                                   (declare (ignore end))
                                                   (values start file))))
              (signal-compiler-condition
               :original-condition condition
               :severity :warning
               :message (format nil "Undefined function referenced: ~S"
                                fname)
               :location (make-location (list :file file)
                                        #+(version>= 9 0)
                                        (list :offset 1 pos)
                                        #-(version>= 9 0)
                                        (list :position (1+ pos)))))))))

(defimplementation call-with-compilation-hooks (function)
  (handler-bind ((warning       #'handle-compiler-warning)
                 (compiler-note #'handle-compiler-warning)
                 (reader-error  #'handle-compiler-warning))
    (funcall function)))

(defimplementation swank-compile-file (input-file output-file
                                       load-p external-format
                                       &key policy)
  (declare (ignore policy))
  (handler-case
      (with-compilation-hooks ()
        (let ((*buffer-name* nil)
              (*compile-filename* input-file)
              #+(version>= 8 2)
              (compiler:save-source-level-debug-info-switch t)
              (excl:*load-source-file-info* t)
              #+(version>= 8 2)
              (excl:*load-source-debug-info* t))
          (compile-file *compile-filename*
                        :output-file output-file
                        :load-after-compile load-p
                        :external-format external-format)))
    (reader-error () (values nil nil t))))

(defun call-with-temp-file (fn)
  (let ((tmpname (system:make-temp-file-name)))
    (unwind-protect
         (with-open-file (file tmpname :direction :output :if-exists :error)
           (funcall fn file tmpname))
      (delete-file tmpname))))

(defvar *temp-file-map* (make-hash-table :test #'equal)
  "A mapping from tempfile names to Emacs buffer names.")

(defun write-tracking-preamble (stream file file-offset)
  "Instrument the top of the temporary file to be compiled.

The header tells allegro that any definitions compiled in the temp
file should be found in FILE exactly at FILE-OFFSET.  To get Allegro
to do this, this factors in the length of the inserted header itself."
  (with-standard-io-syntax
    (let* ((*package* (find-package :keyword))
           (source-pathname-form
             `(cl:eval-when (:compile-toplevel :load-toplevel :execute)
                (cl:setq excl::*source-pathname*
                         (pathname ,(sys::frob-source-file file)))))
           (source-pathname-string (write-to-string source-pathname-form))
           (position-form-length-bound 160) ; should be enough for everyone
           (header-length (+ (length source-pathname-string)
                             position-form-length-bound))
           (position-form
             `(cl:eval-when (:compile-toplevel :load-toplevel :execute)
                (cl:setq excl::*partial-source-file-p* ,(- file-offset
                                                           header-length
                                                           1 ; for the newline
                                                           ))))
           (position-form-string (write-to-string position-form))
           (padding-string (make-string (- position-form-length-bound
                                           (length position-form-string))
                                        :initial-element #\;)))
      (write-string source-pathname-string stream)
      (write-string position-form-string stream)
      (write-string padding-string stream)
      (write-char #\newline stream))))

(defun compile-from-temp-file (string buffer offset file)
  (call-with-temp-file
   (lambda (stream filename)
     (when (and file offset (probe-file file))
       (write-tracking-preamble stream file offset))
     (write-string string stream)
     (finish-output stream)
     (multiple-value-bind (binary-filename warnings? failure?)
         (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension
               #+(version>= 8 2)
               (compiler:save-source-level-debug-info-switch t)
               (excl:*redefinition-warnings* nil))
           (compile-file filename))
       (declare (ignore warnings?))
       (when binary-filename
         (let ((excl:*load-source-file-info* t)
               #+(version>= 8 2)
               (excl:*load-source-debug-info* t))
           excl::*source-pathname*
           (load binary-filename))
         (when (and buffer offset (or (not file)
                                      (not (probe-file file))))
           (setf (gethash (pathname stream) *temp-file-map*)
                 (list buffer offset)))
         (delete-file binary-filename))
       (not failure?)))))

(defimplementation swank-compile-string (string &key buffer position filename
                                         policy)
  (declare (ignore policy))
  (handler-case
      (with-compilation-hooks ()
        (let ((*buffer-name* buffer)
              (*buffer-start-position* position)
              (*buffer-string* string))
          (compile-from-temp-file string buffer position filename)))
    (reader-error () nil)))

;;;; Definition Finding

(defun buffer-or-file (file file-fun buffer-fun)
  (let* ((probe (gethash file *temp-file-map*)))
    (cond (probe
           (destructuring-bind (buffer start) probe
             (funcall buffer-fun buffer start)))
          (t (funcall file-fun (namestring (truename file)))))))

(defun buffer-or-file-location (file offset)
  (buffer-or-file file
                  (lambda (filename)
                    (make-location `(:file ,filename)
                                   `(:position ,(1+ offset))))
                  (lambda (buffer start)
                    (make-location `(:buffer ,buffer)
                                   `(:offset ,start ,offset)))))

(defun fspec-primary-name (fspec)
  (etypecase fspec
    (symbol fspec)
    (list (fspec-primary-name (second fspec)))))

(defun find-definition-in-file (fspec type file top-level)
  (let* ((part
          (or (scm::find-definition-in-definition-group
               fspec type (scm:section-file :file file)
               :top-level top-level)
              (scm::find-definition-in-definition-group
               (fspec-primary-name fspec)
               type (scm:section-file :file file)
               :top-level top-level)))
         (start (and part
                     (scm::source-part-start part)))
         (pos (if start
                  (list :offset 1 start)
                  (list :function-name (string (fspec-primary-name fspec))))))
    (make-location (list :file (namestring (truename file)))
                   pos)))

(defun find-fspec-location (fspec type file top-level)
  (handler-case
      (etypecase file
        (pathname
         (let ((probe (gethash file *temp-file-map*)))
           (cond (probe
                  (destructuring-bind (buffer offset) probe
                    (make-location `(:buffer ,buffer)
                                   `(:offset ,offset 0))))
                 (t
                  (find-definition-in-file fspec type file top-level)))))
        ((member :top-level)
         (make-error-location "Defined at toplevel: ~A"
                              (fspec->string fspec))))
    (error (e)
      (make-error-location "Error: ~A" e))))

(defun fspec->string (fspec)
  (typecase fspec
    (symbol (let ((*package* (find-package :keyword)))
              (prin1-to-string fspec)))
    (list (format nil "(~A ~A)"
                  (prin1-to-string (first fspec))
                  (let ((*package* (find-package :keyword)))
                    (prin1-to-string (second fspec)))))
    (t (princ-to-string fspec))))

(defun fspec-definition-locations (fspec)
  (cond
    ((and (listp fspec) (eq (car fspec) :internal))
     (destructuring-bind (_internal next _n) fspec
       (declare (ignore _internal _n))
       (fspec-definition-locations next)))
    (t
     (let ((defs (excl::find-source-file fspec)))
       (when (and (null defs)
                  (listp fspec)
                  (string= (car fspec) '#:method))
         ;; If methods are defined in a defgeneric form, the source location is
         ;; recorded for the gf but not for the methods. Therefore fall back to
         ;; the gf as the likely place of definition.
         (setq defs (excl::find-source-file (second fspec))))
       (if (null defs)
           (list
            (list fspec
                  (make-error-location "Unknown source location for ~A"
                                       (fspec->string fspec))))
           (loop for (fspec type file top-level) in defs collect
                 (list (list type fspec)
                       (find-fspec-location fspec type file top-level))))))))

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

(defimplementation find-source-location (obj)
  (first (rest (first (fspec-definition-locations obj)))))

;;;; XREF

(defmacro defxref (name relation name1 name2)
  `(defimplementation ,name (x)
    (xref-result (xref:get-relation ,relation ,name1 ,name2))))

(defxref who-calls        :calls       :wild x)
(defxref calls-who        :calls       x :wild)
(defxref who-references   :uses        :wild x)
(defxref who-binds        :binds       :wild x)
(defxref who-macroexpands :macro-calls :wild x)
(defxref who-sets         :sets        :wild x)

(defun xref-result (fspecs)
  (loop for fspec in fspecs
        append (fspec-definition-locations fspec)))

;; list-callers implemented by groveling through all fbound symbols.
;; Only symbols are considered.  Functions in the constant pool are
;; searched recursively.  Closure environments are ignored at the
;; moment (constants in methods are therefore not found).

(defun map-function-constants (function fn depth)
  "Call FN with the elements of FUNCTION's constant pool."
  (do ((i 0 (1+ i))
       (max (excl::function-constant-count function)))
      ((= i max))
    (let ((c (excl::function-constant function i)))
      (cond ((and (functionp c)
                  (not (eq c function))
                  (plusp depth))
             (map-function-constants c fn (1- depth)))
            (t
             (funcall fn c))))))

(defun in-constants-p (fun symbol)
  (map-function-constants fun
                          (lambda (c)
                            (when (eq c symbol)
                              (return-from in-constants-p t)))
                          3))

(defun function-callers (name)
  (let ((callers '()))
    (do-all-symbols (sym)
      (when (fboundp sym)
        (let ((fn (fdefinition sym)))
          (when (in-constants-p fn name)
            (push sym callers)))))
    callers))

(defimplementation list-callers (name)
  (xref-result (function-callers name)))

(defimplementation list-callees (name)
  (let ((result '()))
    (map-function-constants (fdefinition name)
                            (lambda (c)
                              (when (fboundp c)
                                (push c result)))
                            2)
    (xref-result result)))

;;;; Profiling

;; Per-function profiling based on description in
;;  http://www.franz.com/support/documentation/8.0/\
;;  doc/runtime-analyzer.htm#data-collection-control-2

(defvar *profiled-functions* ())
(defvar *profile-depth* 0)

(defmacro with-redirected-y-or-n-p (&body body)
  ;; If the profiler is restarted when the data from the previous
  ;; session is not reported yet, the user is warned via Y-OR-N-P.
  ;; As the CL:Y-OR-N-P question is (for some reason) not directly
  ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
  ;; overruled.
  `(let* ((pkg       (find-package :common-lisp))
          (saved-pdl (excl::package-definition-lock pkg))
          (saved-ynp (symbol-function 'cl:y-or-n-p)))
     (setf (excl::package-definition-lock pkg) nil
           (symbol-function 'cl:y-or-n-p)
           (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
     (unwind-protect
          (progn ,@body)
       (setf (symbol-function 'cl:y-or-n-p)      saved-ynp
             (excl::package-definition-lock pkg) saved-pdl))))

(defun start-acl-profiler ()
  (with-redirected-y-or-n-p
      (prof:start-profiler :type :time :count t
                           :start-sampling-p nil :verbose nil)))
(defun acl-profiler-active-p ()
  (not (eq (prof:profiler-status :verbose nil) :inactive)))

(defun stop-acl-profiler ()
  (prof:stop-profiler :verbose nil))

(excl:def-fwrapper profile-fwrapper (&rest args)
  ;; Ensures sampling is done during the execution of the function,
  ;; taking into account recursion.
  (declare (ignore args))
  (cond ((zerop *profile-depth*)
         (let ((*profile-depth* (1+ *profile-depth*)))
           (prof:start-sampling)
           (unwind-protect (excl:call-next-fwrapper)
             (prof:stop-sampling))))
        (t
         (excl:call-next-fwrapper))))

(defimplementation profile (fname)
  (unless (acl-profiler-active-p)
    (start-acl-profiler))
  (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
  (push fname *profiled-functions*))

(defimplementation profiled-functions ()
  *profiled-functions*)

(defimplementation unprofile (fname)
  (excl:funwrap fname 'profile-fwrapper)
  (setq *profiled-functions* (remove fname *profiled-functions*)))

(defimplementation profile-report ()
  (prof:show-flat-profile :verbose nil)
  (when *profiled-functions*
    (start-acl-profiler)))

(defimplementation profile-reset ()
  (when (acl-profiler-active-p)
    (stop-acl-profiler)
    (start-acl-profiler))
  "Reset profiling counters.")

;;;; Inspecting

(excl:without-redefinition-warnings
(defmethod emacs-inspect ((o t))
  (allegro-inspect o)))

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

(defmethod emacs-inspect ((o standard-object))
  (allegro-inspect o))

(defun allegro-inspect (o)
  (loop for (d dd) on (inspect::inspect-ctl o)
        append (frob-allegro-field-def o d)
        until (eq d dd)))

(defun frob-allegro-field-def (object def)
  (with-struct (inspect::field-def- name type access) def
    (ecase type
      ((:unsigned-word :unsigned-byte :unsigned-natural
                       :unsigned-long :unsigned-half-long
                       :unsigned-3byte :unsigned-long32)
       (label-value-line name (inspect::component-ref-v object access type)))
      ((:lisp :value :func)
       (label-value-line name (inspect::component-ref object access)))
      (:indirect
       (destructuring-bind (prefix count ref set) access
         (declare (ignore set prefix))
         (loop for i below (funcall count object)
               append (label-value-line (format nil "~A-~D" name i)
                                        (funcall ref object i))))))))

;;;; Multithreading

(defimplementation initialize-multiprocessing (continuation)
  (mp:start-scheduler)
  (funcall continuation))

(defimplementation spawn (fn &key name)
  (mp:process-run-function name fn))

(defvar *id-lock* (mp:make-process-lock :name "id lock"))
(defvar *thread-id-counter* 0)

(defimplementation thread-id (thread)
  (mp:with-process-lock (*id-lock*)
    (or (getf (mp:process-property-list thread) 'id)
        (setf (getf (mp:process-property-list thread) 'id)
              (incf *thread-id-counter*)))))

(defimplementation find-thread (id)
  (find id mp:*all-processes*
        :key (lambda (p) (getf (mp:process-property-list p) 'id))))

(defimplementation thread-name (thread)
  (mp:process-name thread))

(defimplementation thread-status (thread)
  (princ-to-string (mp:process-whostate thread)))

(defimplementation thread-attributes (thread)
  (list :priority (mp:process-priority thread)
        :times-resumed (mp:process-times-resumed thread)))

(defimplementation make-lock (&key name)
  (mp:make-process-lock :name name))

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

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

(defimplementation all-threads ()
  (copy-list mp:*all-processes*))

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

(defimplementation kill-thread (thread)
  (mp:process-kill thread))

(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))

(defstruct (mailbox (:conc-name mailbox.))
  (lock (mp:make-process-lock :name "process mailbox"))
  (queue '() :type list)
  (gate (mp:make-gate nil)))

(defun mailbox (thread)
  "Return THREAD's mailbox."
  (mp:with-process-lock (*mailbox-lock*)
    (or (getf (mp:process-property-list thread) 'mailbox)
        (setf (getf (mp:process-property-list thread) 'mailbox)
              (make-mailbox)))))

(defimplementation send (thread message)
  (let* ((mbox (mailbox thread)))
    (mp:with-process-lock ((mailbox.lock mbox))
      (setf (mailbox.queue mbox)
            (nconc (mailbox.queue mbox) (list message)))
      (mp:open-gate (mailbox.gate mbox)))))

(defimplementation receive-if (test &optional timeout)
  (let ((mbox (mailbox mp:*current-process*)))
    (assert (or (not timeout) (eq timeout t)))
    (loop
     (check-slime-interrupts)
     (mp:with-process-lock ((mailbox.lock mbox))
       (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)))
         (mp:close-gate (mailbox.gate mbox))))
     (when (eq timeout t) (return (values nil t)))
     (mp:process-wait-with-timeout "receive-if" 0.5
                                   #'mp:gate-open-p (mailbox.gate mbox)))))

(let ((alist '())
      (lock (mp:make-process-lock :name "register-thread")))

  (defimplementation register-thread (name thread)
    (declare (type symbol name))
    (mp:with-process-lock (lock)
      (etypecase thread
        (null
         (setf alist (delete name alist :key #'car)))
        (mp:process
         (let ((probe (assoc name alist)))
           (cond (probe (setf (cdr probe) thread))
                 (t (setf alist (acons name thread alist))))))))
    nil)

  (defimplementation find-registered (name)
    (mp:with-process-lock (lock)
      (cdr (assoc name alist)))))

(defimplementation set-default-initial-binding (var form)
  (push (cons var form)
        #+(version>= 9 0)
        excl:*required-thread-bindings*
        #-(version>= 9 0)
        excl::required-thread-bindings))

(defimplementation quit-lisp ()
  (excl:exit 0 :quiet t))


;;Trace implementations
;;In Allegro 7.0, we have:
;; (trace <name>)
;; (trace ((method <name> <qualifier>? (<specializer>+))))
;; (trace ((labels <name> <label-name>)))
;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
;; <name> can be a normal name or a (setf name)

(defimplementation toggle-trace (spec)
  (ecase (car spec)
    ((setf)
     (toggle-trace-aux spec))
    (:defgeneric (toggle-trace-generic-function-methods (second spec)))
    ((setf :defmethod :labels :flet)
     (toggle-trace-aux (process-fspec-for-allegro spec)))
    (:call
     (destructuring-bind (caller callee) (cdr spec)
       (toggle-trace-aux callee
                         :inside (list (process-fspec-for-allegro caller)))))))

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

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

(defun toggle-trace-generic-function-methods (name)
  (let ((methods (mop:generic-function-methods (fdefinition name))))
    (cond ((tracedp name)
           (eval `(untrace ,name))
           (dolist (method methods (format nil "~S is now untraced." name))
             (excl:funtrace (mop:method-function method))))
          (t
           (eval `(trace (,name)))
           (dolist (method methods (format nil "~S is now traced." name))
             (excl:ftrace (mop:method-function method)))))))

(defun process-fspec-for-allegro (fspec)
  (cond ((consp fspec)
         (ecase (first fspec)
           ((setf) fspec)
           ((:defun :defgeneric) (second fspec))
           ((:defmethod) `(method ,@(rest fspec)))
           ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
                         ,(third fspec)))
           ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
                       ,(third fspec)))))
        (t
         fspec)))


;;;; Weak hashtables

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

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

(defimplementation hash-table-weakness (hashtable)
  (cond ((excl:hash-table-weak-keys hashtable) :key)
        ((eq (excl:hash-table-values hashtable) :weak) :value)))



;;;; Character names

(defimplementation character-completion-set (prefix matchp)
  (loop for name being the hash-keys of excl::*name-to-char-table*
       when (funcall matchp prefix name)
       collect (string-capitalize name)))


;;;; wrap interface implementation

(defimplementation wrap (spec indicator &key before after replace)
  (let ((allegro-spec (process-fspec-for-allegro spec)))
    (excl:fwrap allegro-spec
                indicator
                (excl:def-fwrapper allegro-wrapper (&rest args)
                  (let (retlist completed)
                    (unwind-protect
                         (progn
                           (when before
                             (funcall before args))
                           (setq retlist (multiple-value-list
                                          (if replace
                                              (funcall replace args)
                                              (excl:call-next-fwrapper))))
                           (setq completed t)
                           (values-list retlist))
                      (when after
                        (funcall after (if completed
                                           retlist
                                           :exited-non-locally)))))))
    allegro-spec))

(defimplementation unwrap (spec indicator)
  (let ((allegro-spec (process-fspec-for-allegro spec)))
    (excl:funwrap allegro-spec indicator)
    allegro-spec))

(defimplementation wrapped-p (spec indicator)
  (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator))