From c012f55efda29f09179e921cf148d79deb57616e Mon Sep 17 00:00:00 2001 From: Nick Shipp Date: Sun, 7 May 2017 09:04:01 -0400 Subject: Much maturering of vim configs --- vim/bundle/slimv/slime/swank/abcl.lisp | 847 +++++++ vim/bundle/slimv/slime/swank/allegro.lisp | 1053 +++++++++ vim/bundle/slimv/slime/swank/backend.lisp | 1536 ++++++++++++ vim/bundle/slimv/slime/swank/ccl.lisp | 861 +++++++ vim/bundle/slimv/slime/swank/clasp.lisp | 730 ++++++ vim/bundle/slimv/slime/swank/clisp.lisp | 930 ++++++++ vim/bundle/slimv/slime/swank/cmucl.lisp | 2470 ++++++++++++++++++++ vim/bundle/slimv/slime/swank/corman.lisp | 583 +++++ vim/bundle/slimv/slime/swank/ecl.lisp | 845 +++++++ vim/bundle/slimv/slime/swank/gray.lisp | 170 ++ vim/bundle/slimv/slime/swank/lispworks.lisp | 1018 ++++++++ vim/bundle/slimv/slime/swank/match.lisp | 242 ++ vim/bundle/slimv/slime/swank/mkcl.lisp | 933 ++++++++ vim/bundle/slimv/slime/swank/rpc.lisp | 162 ++ vim/bundle/slimv/slime/swank/sbcl.lisp | 2044 ++++++++++++++++ vim/bundle/slimv/slime/swank/scl.lisp | 1726 ++++++++++++++ .../slimv/slime/swank/source-file-cache.lisp | 136 ++ .../slimv/slime/swank/source-path-parser.lisp | 239 ++ 18 files changed, 16525 insertions(+) create mode 100644 vim/bundle/slimv/slime/swank/abcl.lisp create mode 100644 vim/bundle/slimv/slime/swank/allegro.lisp create mode 100644 vim/bundle/slimv/slime/swank/backend.lisp create mode 100644 vim/bundle/slimv/slime/swank/ccl.lisp create mode 100644 vim/bundle/slimv/slime/swank/clasp.lisp create mode 100644 vim/bundle/slimv/slime/swank/clisp.lisp create mode 100644 vim/bundle/slimv/slime/swank/cmucl.lisp create mode 100644 vim/bundle/slimv/slime/swank/corman.lisp create mode 100644 vim/bundle/slimv/slime/swank/ecl.lisp create mode 100644 vim/bundle/slimv/slime/swank/gray.lisp create mode 100644 vim/bundle/slimv/slime/swank/lispworks.lisp create mode 100644 vim/bundle/slimv/slime/swank/match.lisp create mode 100644 vim/bundle/slimv/slime/swank/mkcl.lisp create mode 100644 vim/bundle/slimv/slime/swank/rpc.lisp create mode 100644 vim/bundle/slimv/slime/swank/sbcl.lisp create mode 100644 vim/bundle/slimv/slime/swank/scl.lisp create mode 100644 vim/bundle/slimv/slime/swank/source-file-cache.lisp create mode 100644 vim/bundle/slimv/slime/swank/source-path-parser.lisp (limited to 'vim/bundle/slimv/slime/swank') diff --git a/vim/bundle/slimv/slime/swank/abcl.lisp b/vim/bundle/slimv/slime/swank/abcl.lisp new file mode 100644 index 0000000..f5764d6 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/abcl.lisp @@ -0,0 +1,847 @@ +;;;; -*- 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. +;;; + +(defpackage swank/abcl + (:use cl swank/backend)) + +(in-package swank/abcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :collect) ;just so that it doesn't spoil the flying letters + (require :pprint) + (require :gray-streams) + (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4)) + 0.22) + () "This file needs ABCL version 0.22 or newer")) + +(defimplementation gray-package-name () + "GRAY-STREAMS") + +;; FIXME: switch to shared Gray stream implementation when bugs are +;; fixed in ABCL. See: http://abcl.org/trac/ticket/373. +(progn + (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)) + +;;; swank-mop + +;;dummies and definition + +(defclass standard-slot-definition ()()) + +;(defun class-finalized-p (class) t) + +(defun slot-definition-documentation (slot) + (declare (ignore slot)) + #+nil (documentation slot 't)) + +(defun slot-definition-type (slot) + (declare (ignore slot)) + t) + +(defun class-prototype (class) + (declare (ignore class)) + nil) + +(defun generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(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) + (declare (ignore class)) + (system::slot-boundp object (slot-definition-name slotdef))) + +(defun slot-value-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-value object (slot-definition-name slotdef))) + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + standard-slot-definition ;;dummy + cl:method + cl:standard-class + #+#.(swank/backend:with-symbol 'compute-applicable-methods-using-classes + 'mop) + mop:compute-applicable-methods-using-classes + ;; standard-class readers + mop:class-default-initargs + mop:class-direct-default-initargs + mop:class-direct-slots + mop:class-direct-subclasses + mop:class-direct-superclasses + mop:eql-specializer + mop:class-finalized-p + mop:finalize-inheritance + cl:class-name + mop:class-precedence-list + class-prototype ;;dummy + class-slots + specializer-direct-methods + ;; eql-specializer accessors + mop::eql-specializer-object + ;; generic function readers + mop:generic-function-argument-precedence-order + generic-function-declarations ;;dummy + mop:generic-function-lambda-list + mop:generic-function-methods + mop:generic-function-method-class + mop:generic-function-method-combination + mop:generic-function-name + ;; method readers + method-generic-function + method-function + mop:method-lambda-list + mop:method-specializers + mop:method-qualifiers + ;; slot readers + mop:slot-definition-allocation + slot-definition-documentation ;;dummy + mop:slot-definition-initargs + mop:slot-definition-initform + mop:slot-definition-initfunction + slot-definition-name + slot-definition-type ;;dummy + mop:slot-definition-readers + mop:slot-definition-writers + slot-boundp-using-class + slot-value-using-class + mop:slot-makunbound-using-class)) + +;;;; TCP Server + + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ext:make-server-socket port)) + +(defimplementation local-port (socket) + (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket)) + +(defimplementation close-socket (socket) + (ext:server-socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (ext:get-socket-stream (ext:socket-accept socket) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +;;;; UTF8 + +;; faster please! +(defimplementation string-to-utf8 (s) + (jbytes-to-octets + (java:jcall + (java:jmethod "java.lang.String" "getBytes" "java.lang.String") + s + "UTF8"))) + +(defimplementation utf8-to-string (u) + (java:jnew + (java:jconstructor "org.armedbear.lisp.SimpleString" + "java.lang.String") + (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String") + (octets-to-jbytes u) + "UTF8"))) + +(defun octets-to-jbytes (octets) + (declare (type octets (simple-array (unsigned-byte 8) (*)))) + (let* ((len (length octets)) + (bytes (java:jnew-array "byte" len))) + (loop for byte across octets + for i from 0 + do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte" + "java.lang.Object" "int" "byte") + "java.lang.relect.Array" + bytes i byte)) + bytes)) + +(defun jbytes-to-octets (jbytes) + (let* ((len (java:jarray-length jbytes)) + (octets (make-array len :element-type '(unsigned-byte 8)))) + (loop for i from 0 below len + for jbyte = (java:jarray-ref jbytes i) + do (setf (aref octets i) jbyte)) + octets)) + +;;;; External formats + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1") + ((:iso-8859-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + (:utf-8 "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + (:euc-jp "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + (:us-ascii "us-ascii") + ((:us-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 + +(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) + (when (and (not present) + (fboundp fun) + (typep (symbol-function fun) + 'standard-generic-function)) + (setq arglist + (mop::generic-function-lambda-list (symbol-function fun)) + present + t)) + (if present arglist :not-available))) + (t :not-available))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form &optional env) + (ext:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,(macroexpand-all form env))))) + (values macro-forms 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))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + ((:variable :macro) + (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 + +;; Copied from swank-sbcl.lisp. +;; +;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*, +;; so we have to make sure that the latter gets run when it was +;; established locally by a user (i.e. changed meanwhile.) +(defun make-invoke-debugger-hook (hook) + (lambda (condition old-hook) + (if *debugger-hook* + (funcall *debugger-hook* condition old-hook) + (funcall hook condition old-hook)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank)) + (*sldb-topframe* + (second (member magic-token (sys:backtrace) + :key (lambda (frame) + (first (sys:frame-to-list frame))))))) + (funcall debugger-loop-fn))) + +(defun backtrace (start end) + "A backtrace without initial SWANK frames." + (let ((backtrace (sys:backtrace))) + (subseq (or (member *sldb-topframe* backtrace) backtrace) + start end))) + +(defun nth-frame (index) + (nth index (backtrace 0 nil))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (backtrace start end))) + +(defimplementation print-frame (frame stream) + (write-string (sys:frame-to-string frame) + stream)) + +;;; Sorry, but can't seem to declare DEFIMPLEMENTATION under FLET. +;;; --ME 20150403 +(defun nth-frame-list (index) + (java:jcall "toLispList" (nth-frame index))) + +(defun match-lambda (operator values) + (jvm::match-lambda-list + (multiple-value-list + (jvm::parse-lambda-list (ext:arglist operator))) + values)) + +(defimplementation frame-locals (index) + (loop + :for id :upfrom 0 + :with frame = (nth-frame-list index) + :with operator = (first frame) + :with values = (rest frame) + :with arglist = (if (and operator (consp values) (not (null values))) + (handler-case + (match-lambda operator values) + (jvm::lambda-list-mismatch (e) + :lambda-list-mismatch)) + :not-available) + :for value :in values + :collecting (list + :name (if (not (keywordp arglist)) + (first (nth id arglist)) + (format nil "arg~A" id)) + :id id + :value value))) + +(defimplementation frame-var-value (index id) + (elt (rest (java:jcall "toLispList" (nth-frame index))) id)) + + +#+nil +(defimplementation disassemble-frame (index) + (disassemble (debugger:frame-function (nth-frame index)))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (or (source-location (nth-frame index)) + `(:error ,(format nil "No source for frame: ~a" frame))))) + +#+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*) + +(defvar *abcl-signaled-conditions*) + +(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 '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)))))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (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 + (and fn 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) + (sys::*source* (make-pathname :device "emacs-buffer" :name buffer)) + (sys::*source-position* position)) + (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)) +|# + +(defgeneric source-location (object)) + +(defmethod source-location ((symbol symbol)) + (when (pathnamep (ext:source-pathname symbol)) + (let ((pos (ext:source-file-position symbol)) + (path (namestring (ext:source-pathname symbol)))) + (cond ((ext:pathname-jar-p path) + `(:location + ;; strip off "jar:file:" = 9 characters + (:zip ,@(split-string (subseq path 9) "!/")) + ;; pos never seems right. Use function name. + (:function-name ,(string symbol)) + (:align t))) + ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer") + ;; conspire with swank-compile-string to keep the buffer + ;; name in a pathname whose device is "emacs-buffer". + `(:location + (:buffer ,(pathname-name (ext:source-pathname symbol))) + (:function-name ,(string symbol)) + (:align t))) + (t + `(:location + (:file ,path) + ,(if pos + (list :position (1+ pos)) + (list :function-name (string symbol))) + (:align t))))))) + +(defmethod source-location ((frame sys::java-stack-frame)) + (destructuring-bind (&key class method file line) (sys:frame-to-list frame) + (declare (ignore method)) + (let ((file (or (find-file-in-path file *source-path*) + (let ((f (format nil "~{~a/~}~a" + (butlast (split-string class "\\.")) + file))) + (find-file-in-path f *source-path*))))) + (and file + `(:location ,file (:line ,line) ()))))) + +(defmethod source-location ((frame sys::lisp-stack-frame)) + (destructuring-bind (operator &rest args) (sys:frame-to-list frame) + (declare (ignore args)) + (etypecase operator + (function (source-location operator)) + (list nil) + (symbol (source-location operator))))) + +(defmethod source-location ((fun function)) + (let ((name (function-name fun))) + (and name (source-location name)))) + +(defun system-property (name) + (java:jstatic "getProperty" "java.lang.System" name)) + +(defun pathname-parent (pathname) + (make-pathname :directory (butlast (pathname-directory pathname)))) + +(defun pathname-absolute-p (pathname) + (eq (car (pathname-directory pathname)) ':absolute)) + +(defun split-string (string regexp) + (coerce + (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String") + string regexp) + 'list)) + +(defun path-separator () + (java:jfield "java.io.File" "pathSeparator")) + +(defun search-path-property (prop-name) + (let ((string (system-property prop-name))) + (and string + (remove nil + (mapcar #'truename + (split-string string (path-separator))))))) + +(defun jdk-source-path () + (let* ((jre-home (truename (system-property "java.home"))) + (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home))) + (truename (probe-file src-zip))) + (and truename (list truename)))) + +(defun class-path () + (append (search-path-property "java.class.path") + (search-path-property "sun.boot.class.path"))) + +(defvar *source-path* + (append (search-path-property "user.dir") + (jdk-source-path) + ;;(list (truename "/scratch/abcl/src")) + ) + "List of directories to search for source files.") + +(defun zipfile-contains-p (zipfile-name entry-name) + (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile" + "java.lang.String") + zipfile-name))) + (java:jcall + (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String") + zipfile entry-name))) + +;; (find-file-in-path "java/lang/String.java" *source-path*) +;; (find-file-in-path "Lisp.java" *source-path*) + +;; Try to find FILENAME in PATH. If found, return a file spec as +;; needed by Emacs. We also look in zip files. +(defun find-file-in-path (filename path) + (labels ((try (dir) + (cond ((not (pathname-type dir)) + (let ((f (probe-file (merge-pathnames filename dir)))) + (and f `(:file ,(namestring f))))) + ((equal (pathname-type dir) "zip") + (try-zip dir)) + (t (error "strange path element: ~s" path)))) + (try-zip (zip) + (let* ((zipfile-name (namestring (truename zip)))) + (and (zipfile-contains-p zipfile-name filename) + `(:dir ,zipfile-name ,filename))))) + (cond ((pathname-absolute-p filename) (probe-file filename)) + (t + (loop for dir in path + if (try dir) return it))))) + +(defimplementation find-definitions (symbol) + (ext:resolve symbol) + (let ((srcloc (source-location symbol))) + (and srcloc `((,symbol ,srcloc))))) + +#| +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 ((o t)) + (let ((parts (sys:inspected-parts o))) + `("The object is of type " ,(symbol-name (type-of o)) "." (:newline) + ,@(if parts + (loop :for (label . value) :in parts + :appending (label-value-line label value)) + (list "No inspectable parts, dumping output of CL:DESCRIBE:" + '(:newline) + (with-output-to-string (desc) (describe o desc))))))) + +(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)) + "#") (: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))))) + +;;; Although by convention toString() is supposed to be a +;;; non-computationally expensive operation this isn't always the +;;; case, so make its computation a user interaction. +(defparameter *to-string-hashtable* (make-hash-table)) +(defmethod emacs-inspect ((o java:java-object)) + (let ((to-string (lambda () + (handler-case + (setf (gethash o *to-string-hashtable*) + (java:jcall "toString" o)) + (t (e) + (setf (gethash o *to-string-hashtable*) + (format nil + "Could not invoke toString(): ~A" + e))))))) + (append + (if (gethash o *to-string-hashtable*) + (label-value-line "toString()" (gethash o *to-string-hashtable*)) + `((:action "[compute toString()]" ,to-string) (:newline))) + (loop :for (label . value) :in (sys:inspected-parts o) + :appending (label-value-line label value))))) + +;;;; Multithreading + +(defimplementation spawn (fn &key name) + (threads:make-thread (lambda () (funcall fn)) :name name)) + +(defvar *thread-plists* (make-hash-table) ; should be a weak table + "A hashtable mapping threads to a plist.") + +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'id) + (setf (getf (gethash thread *thread-plists*) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plists*) 'id)))) + +(defimplementation thread-name (thread) + (threads:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread))) + +(defimplementation make-lock (&key name) + (declare (ignore name)) + (threads:make-thread-lock)) + +(defimplementation call-with-lock-held (lock function) + (threads:with-thread-lock (lock) (funcall function))) + +(defimplementation current-thread () + (threads:current-thread)) + +(defimplementation all-threads () + (copy-list (threads:mapcar-threads #'identity))) + +(defimplementation thread-alive-p (thread) + (member thread (all-threads))) + +(defimplementation interrupt-thread (thread fn) + (threads:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (threads:destroy-thread thread)) + +(defstruct mailbox + (queue '())) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'mailbox) + (setf (getf (gethash thread *thread-plists*) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (threads:synchronized-on mbox + (setf (mailbox-queue mbox) + (nconc (mailbox-queue mbox) (list message))) + (threads:object-notify-all mbox)))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread)))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (threads:synchronized-on 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))) + (when (eq timeout t) (return (values nil t))) + (threads:object-wait mbox 0.3)))))) + +(defimplementation quit-lisp () + (ext:exit)) +;;; +#+#.(swank/backend:with-symbol 'package-local-nicknames 'ext) +(defimplementation package-local-nicknames (package) + (ext:package-local-nicknames package)) diff --git a/vim/bundle/slimv/slime/swank/allegro.lisp b/vim/bundle/slimv/slime/swank/allegro.lisp new file mode 100644 index 0000000..f5918da --- /dev/null +++ b/vim/bundle/slimv/slime/swank/allegro.lisp @@ -0,0 +1,1053 @@ +;;;; -*- 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 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 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)) + (1+ (if (listp start-char) ; HACK + (first start-char) + start-char))))) + ((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 + (car pos) + pos))) + (values file (1+ 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 :position position) + (list :offset *buffer-start-position* 0)))) + (pathname + (make-location + (list :file (namestring (truename pathname))) + (list :position 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) + (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 :position (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 ) +;; (trace ((method ? (+)))) +;; (trace ((labels ))) +;; (trace ((labels (method (+)) ))) +;; 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)) diff --git a/vim/bundle/slimv/slime/swank/backend.lisp b/vim/bundle/slimv/slime/swank/backend.lisp new file mode 100644 index 0000000..81023df --- /dev/null +++ b/vim/bundle/slimv/slime/swank/backend.lisp @@ -0,0 +1,1536 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; +;;; slime-backend.lisp --- SLIME backend interface. +;;; +;;; Created by James Bielman in 2003. Released into the public domain. +;;; +;;;; Frontmatter +;;; +;;; This file defines the functions that must be implemented +;;; separately for each Lisp. Each is declared as a generic function +;;; for which swank-.lisp provides methods. + +(in-package swank/backend) + + +;;;; Metacode + +(defparameter *debug-swank-backend* nil + "If this is true, backends should not catch errors but enter the +debugger where appropriate. Also, they should not perform backtrace +magic but really show every frame including SWANK related ones.") + +(defparameter *interface-functions* '() + "The names of all interface functions.") + +(defparameter *unimplemented-interfaces* '() + "List of interface functions that are not implemented. +DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") + +(defvar *log-output* nil) ; should be nil for image dumpers + +(defmacro definterface (name args documentation &rest default-body) + "Define an interface function for the backend to implement. +A function is defined with NAME, ARGS, and DOCUMENTATION. This +function first looks for a function to call in NAME's property list +that is indicated by 'IMPLEMENTATION; failing that, it looks for a +function indicated by 'DEFAULT. If neither is present, an error is +signaled. + +If a DEFAULT-BODY is supplied, then a function with the same body and +ARGS will be added to NAME's property list as the property indicated +by 'DEFAULT. + +Backends implement these functions using DEFIMPLEMENTATION." + (check-type documentation string "a documentation string") + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (labels ((gen-default-impl () + `(setf (get ',name 'default) (lambda ,args ,@default-body))) + (args-as-list (args) + (destructuring-bind (req opt key rest) (parse-lambda-list args) + `(,@req ,@opt + ,@(loop for k in key append `(,(kw k) ,k)) + ,@(or rest '(()))))) + (parse-lambda-list (args) + (parse args '(&optional &key &rest) + (make-array 4 :initial-element nil))) + (parse (args keywords vars) + (cond ((null args) + (reverse (map 'list #'reverse vars))) + ((member (car args) keywords) + (parse (cdr args) (cdr (member (car args) keywords)) vars)) + (t (push (car args) (aref vars (length keywords))) + (parse (cdr args) keywords vars)))) + (kw (s) (intern (string s) :keyword))) + `(progn + (defun ,name ,args + ,documentation + (let ((f (or (get ',name 'implementation) + (get ',name 'default)))) + (cond (f (apply f ,@(args-as-list args))) + (t (error "~S not implemented" ',name))))) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank/backend)) + ',name))) + +(defmacro defimplementation (name args &body body) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + `(progn + (setf (get ',name 'implementation) + ;; For implicit BLOCK. FLET because of interplay w/ decls. + (flet ((,name ,args ,@body)) #',name)) + (if (member ',name *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',name *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) + ',name)) + +(defun warn-unimplemented-interfaces () + "Warn the user about unimplemented backend features. +The portable code calls this function at startup." + (let ((*print-pretty* t)) + (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>" + (list (sort (copy-list *unimplemented-interfaces*) #'string<))))) + +(defun import-to-swank-mop (symbol-list) + (dolist (sym symbol-list) + (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop))) + (when swank-mop-sym + (unintern swank-mop-sym :swank-mop)) + (import sym :swank-mop) + (export sym :swank-mop)))) + +(defun import-swank-mop-symbols (package except) + "Import the mop symbols from PACKAGE to SWANK-MOP. +EXCEPT is a list of symbol names which should be ignored." + (do-symbols (s :swank-mop) + (unless (member s except :test #'string=) + (let ((real-symbol (find-symbol (string s) package))) + (assert real-symbol () "Symbol ~A not found in package ~A" s package) + (unintern s :swank-mop) + (import real-symbol :swank-mop) + (export real-symbol :swank-mop))))) + +(definterface gray-package-name () + "Return a package-name that contains the Gray stream symbols. +This will be used like so: + (defpackage foo + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)") + + +;;;; Utilities + +(defmacro with-struct ((conc-name &rest names) obj &body body) + "Like with-slots but works only for structs." + (check-type conc-name symbol) + (flet ((reader (slot) + (intern (concatenate 'string + (symbol-name conc-name) + (symbol-name slot)) + (symbol-package conc-name)))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defmacro when-let ((var value) &body body) + `(let ((,var ,value)) + (when ,var ,@body))) + +(defun boolean-to-feature-expression (value) + "Converts a boolean VALUE to a form suitable for testing with #+." + (if value + '(:and) + '(:or))) + +(defun with-symbol (name package) + "Check if a symbol with a given NAME exists in PACKAGE and returns a +form suitable for testing with #+." + (boolean-to-feature-expression + (and (find-package package) + (find-symbol (string name) package)))) + +(defun choose-symbol (package name alt-package alt-name) + "If symbol package:name exists return that symbol, otherwise alt-package:alt-name. + Suitable for use with #." + (or (and (find-package package) + (find-symbol (string name) package)) + (find-symbol (string alt-name) alt-package))) + + +;;;; UFT8 + +(deftype octet () '(unsigned-byte 8)) +(deftype octets () '(simple-array octet (*))) + +;; Helper function. Decode the next N bytes starting from INDEX. +;; Return the decoded char and the new index. +(defun utf8-decode-aux (buffer index limit byte0 n) + (declare (type octets buffer) (fixnum index limit byte0 n)) + (if (< (- limit index) n) + (values nil index) + (do ((i 0 (1+ i)) + (code byte0 (let ((byte (aref buffer (+ index i)))) + (cond ((= (ldb (byte 2 6) byte) #b10) + (+ (ash code 6) (ldb (byte 6 0) byte))) + (t + (error "Invalid encoding")))))) + ((= i n) + (values (cond ((<= code #xff) (code-char code)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point: #x~x" code)) + ((and (< code char-code-limit) + (code-char code))) + (t + (error + "Can't represent code point: #x~x ~ + (char-code-limit is #x~x)" + code char-code-limit))) + (+ index n)))))) + +;; Decode one character in BUFFER starting at INDEX. +;; Return 2 values: the character and the new index. +;; If there aren't enough bytes between INDEX and LIMIT return nil. +(defun utf8-decode (buffer index limit) + (declare (type octets buffer) (fixnum index limit)) + (if (= index limit) + (values nil index) + (let ((b (aref buffer index))) + (if (<= b #x7f) + (values (code-char b) (1+ index)) + (macrolet ((try (marker else) + (let* ((l (integer-length marker)) + (n (- l 2))) + `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) + (utf8-decode-aux buffer (1+ index) limit + (ldb (byte ,(- 8 l) 0) b) + ,n) + ,else)))) + (try #b110 + (try #b1110 + (try #b11110 + (try #b111110 + (try #b1111110 + (error "Invalid encoding"))))))))))) + +;; Decode characters from BUFFER and write them to STRING. +;; Return 2 values: LASTINDEX and LASTSTART where +;; LASTINDEX is the last index in BUFFER that was not decoded +;; and LASTSTART is the last index in STRING not written. +(defun utf8-decode-into (buffer index limit string start end) + (declare (string string) (fixnum index limit start end) (type octets buffer)) + (loop + (cond ((= start end) + (return (values index start))) + (t + (multiple-value-bind (c i) (utf8-decode buffer index limit) + (cond (c + (setf (aref string start) c) + (setq index i) + (setq start (1+ start))) + (t + (return (values index start))))))))) + +(defun default-utf8-to-string (octets) + (let* ((limit (length octets)) + (str (make-string limit))) + (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit) + (if (= i limit) + (if (= limit s) + str + (adjust-array str s)) + (loop + (let ((end (+ (length str) (- limit i)))) + (setq str (adjust-array str end)) + (multiple-value-bind (i2 s2) + (utf8-decode-into octets i limit str s end) + (cond ((= i2 limit) + (return (adjust-array str s2))) + (t + (setq i i2) + (setq s s2)))))))))) + +(defmacro utf8-encode-aux (code buffer start end n) + `(cond ((< (- ,end ,start) ,n) + ,start) + (t + (setf (aref ,buffer ,start) + (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) + (byte ,(- 7 n) 0) + ,(dpb 0 (byte 1 (- 7 n)) #xff))) + ,@(loop for i from 0 upto (- n 2) collect + `(setf (aref ,buffer (+ ,start ,(- n 1 i))) + (dpb (ldb (byte 6 ,(* 6 i)) ,code) + (byte 6 0) + #b10111111))) + (+ ,start ,n)))) + +(defun %utf8-encode (code buffer start end) + (declare (type (unsigned-byte 31) code) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (cond ((<= code #x7f) + (cond ((< start end) + (setf (aref buffer start) code) + (1+ start)) + (t start))) + ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point (surrogate): #x~x" code)) + ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) + ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) + ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) + (t (utf8-encode-aux code buffer start end 6)))) + +(defun utf8-encode (char buffer start end) + (declare (type character char) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (%utf8-encode (char-code char) buffer start end)) + +(defun utf8-encode-into (string start end buffer index limit) + (declare (string string) (type octets buffer) (fixnum start end index limit)) + (loop + (cond ((= start end) + (return (values start index))) + ((= index limit) + (return (values start index))) + (t + (let ((i2 (utf8-encode (char string start) buffer index limit))) + (cond ((= i2 index) + (return (values start index))) + (t + (setq index i2) + (incf start)))))))) + +(defun default-string-to-utf8 (string) + (let* ((len (length string)) + (b (make-array len :element-type 'octet))) + (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len) + (if (= s len) + b + (loop + (let ((limit (+ (length b) (- len s)))) + (setq b (coerce (adjust-array b limit) 'octets)) + (multiple-value-bind (s2 i2) + (utf8-encode-into string s len b i limit) + (cond ((= s2 len) + (return (coerce (adjust-array b i2) 'octets))) + (t + (setq i i2) + (setq s s2)))))))))) + +(definterface string-to-utf8 (string) + "Convert the string STRING to a (simple-array (unsigned-byte 8))" + (default-string-to-utf8 string)) + +(definterface utf8-to-string (octets) + "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string." + (default-utf8-to-string octets)) + + +;;;; TCP server + +(definterface create-socket (host port &key backlog) + "Create a listening TCP socket on interface HOST and port PORT. +BACKLOG queue length for incoming connections.") + +(definterface local-port (socket) + "Return the local port number of SOCKET.") + +(definterface close-socket (socket) + "Close the socket SOCKET.") + +(definterface accept-connection (socket &key external-format + buffering timeout) + "Accept a client connection on the listening socket SOCKET. +Return a stream for the new connection. +If EXTERNAL-FORMAT is nil return a binary stream +otherwise create a character stream. +BUFFERING can be one of: + nil ... no buffering + t ... enable buffering + :line ... enable buffering with automatic flushing on eol.") + +(definterface add-sigio-handler (socket fn) + "Call FN whenever SOCKET is readable.") + +(definterface remove-sigio-handlers (socket) + "Remove all sigio handlers for SOCKET.") + +(definterface add-fd-handler (socket fn) + "Call FN when Lisp is waiting for input and SOCKET is readable.") + +(definterface remove-fd-handlers (socket) + "Remove all fd-handlers for SOCKET.") + +(definterface preferred-communication-style () + "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." + nil) + +(definterface set-stream-timeout (stream timeout) + "Set the 'stream 'timeout. The timeout is either the real number + specifying the timeout in seconds or 'nil for no timeout." + (declare (ignore stream timeout)) + nil) + +;;; Base condition for networking errors. +(define-condition network-error (simple-error) ()) + +(definterface emacs-connected () + "Hook called when the first connection from Emacs is established. +Called from the INIT-FN of the socket server that accepts the +connection. + +This is intended for setting up extra context, e.g. to discover +that the calling thread is the one that interacts with Emacs." + nil) + + +;;;; Unix signals + +(defconstant +sigint+ 2) + +(definterface getpid () + "Return the (Unix) process ID of this superior Lisp.") + +(definterface install-sigint-handler (function) + "Call FUNCTION on SIGINT (instead of invoking the debugger). +Return old signal handler." + (declare (ignore function)) + nil) + +(definterface call-with-user-break-handler (handler function) + "Install the break handler HANDLER while executing FUNCTION." + (let ((old-handler (install-sigint-handler handler))) + (unwind-protect (funcall function) + (install-sigint-handler old-handler)))) + +(definterface quit-lisp () + "Exit the current lisp image.") + +(definterface lisp-implementation-type-name () + "Return a short name for the Lisp implementation." + (lisp-implementation-type)) + +(definterface lisp-implementation-program () + "Return the argv[0] of the running Lisp process, or NIL." + (let ((file (car (command-line-args)))) + (when (and file (probe-file file)) + (namestring (truename file))))) + +(definterface socket-fd (socket-stream) + "Return the file descriptor for SOCKET-STREAM.") + +(definterface make-fd-stream (fd external-format) + "Create a character stream for the file descriptor FD.") + +(definterface dup (fd) + "Duplicate a file descriptor. +If the syscall fails, signal a condition. +See dup(2).") + +(definterface exec-image (image-file args) + "Replace the current process with a new process image. +The new image is created by loading the previously dumped +core file IMAGE-FILE. +ARGS is a list of strings passed as arguments to +the new image. +This is thin wrapper around exec(3).") + +(definterface command-line-args () + "Return a list of strings as passed by the OS." + nil) + + +;; pathnames are sooo useless + +(definterface filename-to-pathname (filename) + "Return a pathname for FILENAME. +A filename in Emacs may for example contain asterisks which should not +be translated to wildcards." + (parse-namestring filename)) + +(definterface pathname-to-filename (pathname) + "Return the filename for PATHNAME." + (namestring pathname)) + +(definterface default-directory () + "Return the default directory." + (directory-namestring (truename *default-pathname-defaults*))) + +(definterface set-default-directory (directory) + "Set the default directory. +This is used to resolve filenames without directory component." + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (default-directory)) + + +(definterface call-with-syntax-hooks (fn) + "Call FN with hooks to handle special syntax." + (funcall fn)) + +(definterface default-readtable-alist () + "Return a suitable initial value for SWANK:*READTABLE-ALIST*." + '()) + + +;;;; Packages + +(definterface package-local-nicknames (package) + "Returns an alist of (local-nickname . actual-package) describing the +nicknames local to the designated package." + (declare (ignore package)) + nil) + +(definterface find-locally-nicknamed-package (name base-package) + "Return the package whose local nickname in BASE-PACKAGE matches NAME. +Return NIL if local nicknames are not implemented or if there is no +such package." + (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal))) + + +;;;; Compilation + +(definterface call-with-compilation-hooks (func) + "Call FUNC with hooks to record compiler conditions.") + +(defmacro with-compilation-hooks ((&rest ignore) &body body) + "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." + (declare (ignore ignore)) + `(call-with-compilation-hooks (lambda () (progn ,@body)))) + +(definterface swank-compile-string (string &key buffer position filename + policy) + "Compile source from STRING. +During compilation, compiler conditions must be trapped and +resignalled as COMPILER-CONDITIONs. + +If supplied, BUFFER and POSITION specify the source location in Emacs. + +Additionally, if POSITION is supplied, it must be added to source +positions reported in compiler conditions. + +If FILENAME is specified it may be used by certain implementations to +rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of +source information. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +Should return T on successful compilation, NIL otherwise. +") + +(definterface swank-compile-file (input-file output-file load-p + external-format + &key policy) + "Compile INPUT-FILE signalling COMPILE-CONDITIONs. +If LOAD-P is true, load the file after compilation. +EXTERNAL-FORMAT is a value returned by find-external-format or +:default. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p +like `compile-file'") + +(deftype severity () + '(member :error :read-error :warning :style-warning :note :redefinition)) + +;; Base condition type for compiler errors, warnings and notes. +(define-condition compiler-condition (condition) + ((original-condition + ;; The original condition thrown by the compiler if appropriate. + ;; May be NIL if a compiler does not report using conditions. + :type (or null condition) + :initarg :original-condition + :accessor original-condition) + + (severity :type severity + :initarg :severity + :accessor severity) + + (message :initarg :message + :accessor message) + + ;; Macro expansion history etc. which may be helpful in some cases + ;; but is often very verbose. + (source-context :initarg :source-context + :type (or null string) + :initform nil + :accessor source-context) + + (references :initarg :references + :initform nil + :accessor references) + + (location :initarg :location + :accessor location))) + +(definterface find-external-format (coding-system) + "Return a \"external file format designator\" for CODING-SYSTEM. +CODING-SYSTEM is Emacs-style coding system name (a string), +e.g. \"latin-1-unix\"." + (if (equal coding-system "iso-latin-1-unix") + :default + nil)) + +(definterface guess-external-format (pathname) + "Detect the external format for the file with name pathname. +Return nil if the file contains no special markers." + ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. + (with-open-file (s pathname :if-does-not-exist nil + :external-format (or (find-external-format "latin-1-unix") + :default)) + (if s + (or (let* ((line (read-line s nil)) + (p (search "-*-" line))) + (when p + (let* ((start (+ p (length "-*-"))) + (end (search "-*-" line :start2 start))) + (when end + (%search-coding line start end))))) + (let* ((len (file-length s)) + (buf (make-string (min len 3000)))) + (file-position s (- len (length buf))) + (read-sequence buf s) + (let ((start (search "Local Variables:" buf :from-end t)) + (end (search "End:" buf :from-end t))) + (and start end (< start end) + (%search-coding buf start end)))))))) + +(defun %search-coding (str start end) + (let ((p (search "coding:" str :start2 start :end2 end))) + (when p + (incf p (length "coding:")) + (loop while (and (< p end) + (member (aref str p) '(#\space #\tab))) + do (incf p)) + (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline))) + str :start p))) + (find-external-format (subseq str p end)))))) + + +;;;; Streams + +(definterface make-output-stream (write-string) + "Return a new character output stream. +The stream calls WRITE-STRING when output is ready.") + +(definterface make-input-stream (read-string) + "Return a new character input stream. +The stream calls READ-STRING when input is needed.") + + +;;;; Documentation + +(definterface arglist (name) + "Return the lambda list for the symbol NAME. NAME can also be +a lisp function object, on lisps which support this. + +The result can be a list or the :not-available keyword if the +arglist cannot be determined." + (declare (ignore name)) + :not-available) + +(defgeneric declaration-arglist (decl-identifier) + (:documentation + "Return the argument list of the declaration specifier belonging to the +declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, +the keyword :NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (decl-identifier) + (case decl-identifier + (dynamic-extent '(&rest variables)) + (ignore '(&rest variables)) + (ignorable '(&rest variables)) + (special '(&rest variables)) + (inline '(&rest function-names)) + (notinline '(&rest function-names)) + (declaration '(&rest names)) + (optimize '(&any compilation-speed debug safety space speed)) + (type '(type-specifier &rest args)) + (ftype '(type-specifier &rest function-names)) + (otherwise + (flet ((typespec-p (symbol) + (member :type (describe-symbol-for-emacs symbol)))) + (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) + '(&rest variables)) + ((and (listp decl-identifier) + (typespec-p (first decl-identifier))) + '(&rest variables)) + (t :not-available))))))) + +(defgeneric type-specifier-arglist (typespec-operator) + (:documentation + "Return the argument list of the type specifier belonging to +TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword +:NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (typespec-operator) + (declare (special *type-specifier-arglists*)) ; defined at end of file. + (typecase typespec-operator + (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) + :not-available)) + (t :not-available)))) + +(definterface type-specifier-p (symbol) + "Determine if SYMBOL is a type-specifier." + (or (documentation symbol 'type) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(definterface function-name (function) + "Return the name of the function object FUNCTION. + +The result is either a symbol, a list, or NIL if no function name is +available." + (declare (ignore function)) + nil) + +(definterface valid-function-name-p (form) + "Is FORM syntactically valid to name a function? + If true, FBOUNDP should not signal a type-error for FORM." + (flet ((length=2 (list) + (and (not (null (cdr list))) (null (cddr list))))) + (or (symbolp form) + (and (consp form) (length=2 form) + (eq (first form) 'setf) (symbolp (second form)))))) + +(definterface macroexpand-all (form &optional env) + "Recursively expand all macros in FORM. +Return the resulting form.") + +(definterface compiler-macroexpand-1 (form &optional env) + "Call the compiler-macro for form. +If FORM is a function call for which a compiler-macro has been +defined, invoke the expander function using *macroexpand-hook* and +return the results and T. Otherwise, return the original form and +NIL." + (let ((fun (and (consp form) + (valid-function-name-p (car form)) + (compiler-macro-function (car form) env)))) + (if fun + (let ((result (funcall *macroexpand-hook* fun form env))) + (values result (not (eq result form)))) + (values form nil)))) + +(definterface compiler-macroexpand (form &optional env) + "Repetitively call `compiler-macroexpand-1'." + (labels ((frob (form expanded) + (multiple-value-bind (new-form newly-expanded) + (compiler-macroexpand-1 form env) + (if newly-expanded + (frob new-form t) + (values new-form expanded))))) + (frob form env))) + +(defmacro with-collected-macro-forms + ((forms &optional result) instrumented-form &body body) + "Collect macro forms by locally binding *MACROEXPAND-HOOK*. + +Evaluates INSTRUMENTED-FORM and collects any forms which undergo +macro-expansion into a list. Then evaluates BODY with FORMS bound to +the list of forms, and RESULT (optionally) bound to the value of +INSTRUMENTED-FORM." + (assert (and (symbolp forms) (not (null forms)))) + (assert (symbolp result)) + (let ((result-symbol (or result (gensym)))) + `(call-with-collected-macro-forms + (lambda (,forms ,result-symbol) + (declare (ignore ,@(and (not result) + `(,result-symbol)))) + ,@body) + (lambda () ,instrumented-form)))) + +(defun call-with-collected-macro-forms (body-fn instrumented-fn) + (let ((return-value nil) + (collected-forms '())) + (let* ((real-macroexpand-hook *macroexpand-hook*) + (*macroexpand-hook* + (lambda (macro-function form environment) + (let ((result (funcall real-macroexpand-hook + macro-function form environment))) + (unless (eq result form) + (push form collected-forms)) + result)))) + (setf return-value (funcall instrumented-fn))) + (funcall body-fn collected-forms return-value))) + +(definterface collect-macro-forms (form &optional env) + "Collect subforms of FORM which undergo (compiler-)macro expansion. +Returns two values: a list of macro forms and a list of compiler macro +forms." + (with-collected-macro-forms (macro-forms expansion) + (ignore-errors (macroexpand-all form env)) + (with-collected-macro-forms (compiler-macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,expansion)))) + (values macro-forms compiler-macro-forms)))) + +(definterface format-string-expand (control-string) + "Expand the format string CONTROL-STRING." + (macroexpand `(formatter ,control-string))) + +(definterface describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. + +The property list has an entry for each interesting aspect of the +symbol. The recognised keys are: + + :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO + :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM + +The value of each property is the corresponding documentation string, +or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys +not listed here (but slime-print-apropos in Emacs must know about +them). + +Properties should be included if and only if they are applicable to +the symbol. For example, only (and all) fbound symbols should include +the :FUNCTION property. + +Example: +\(describe-symbol-for-emacs 'vector) + => (:CLASS :NOT-DOCUMENTED + :TYPE :NOT-DOCUMENTED + :FUNCTION \"Constructs a simple-vector from the given objects.\")") + +(definterface describe-definition (name type) + "Describe the definition NAME of TYPE. +TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. + +Return a documentation string, or NIL if none is available.") + + +;;;; Debugging + +(definterface install-debugger-globally (function) + "Install FUNCTION as the debugger for all threads/processes. This +usually involves setting *DEBUGGER-HOOK* and, if the implementation +permits, hooking into BREAK as well." + (setq *debugger-hook* function)) + +(definterface call-with-debugging-environment (debugger-loop-fn) + "Call DEBUGGER-LOOP-FN in a suitable debugging environment. + +This function is called recursively at each debug level to invoke the +debugger loop. The purpose is to setup any necessary environment for +other debugger callbacks that will be called within the debugger loop. + +For example, this is a reasonable place to compute a backtrace, switch +to safe reader/printer settings, and so on.") + +(definterface call-with-debugger-hook (hook fun) + "Call FUN and use HOOK as debugger hook. HOOK can be NIL. + +HOOK should be called for both BREAK and INVOKE-DEBUGGER." + (let ((*debugger-hook* hook)) + (funcall fun))) + +(define-condition sldb-condition (condition) + ((original-condition + :initarg :original-condition + :accessor original-condition)) + (:report (lambda (condition stream) + (format stream "Condition in debugger code~@[: ~A~]" + (original-condition condition)))) + (:documentation + "Wrapper for conditions that should not be debugged. + +When a condition arises from the internals of the debugger, it is not +desirable to debug it -- we'd risk entering an endless loop trying to +debug the debugger! Instead, such conditions can be reported to the +user without (re)entering the debugger by wrapping them as +`sldb-condition's.")) + +;;; The following functions in this section are supposed to be called +;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. + +(definterface compute-backtrace (start end) + "Returns a backtrace of the condition currently being debugged, +that is an ordered list consisting of frames. ``Ordered list'' +means that an integer I can be mapped back to the i-th frame of this +backtrace. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") + +(definterface print-frame (frame stream) + "Print frame to stream.") + +(definterface frame-restartable-p (frame) + "Is the frame FRAME restartable?. +Return T if `restart-frame' can safely be called on the frame." + (declare (ignore frame)) + nil) + +(definterface frame-source-location (frame-number) + "Return the source location for the frame associated to FRAME-NUMBER.") + +(definterface frame-catch-tags (frame-number) + "Return a list of catch tags for being printed in a debugger stack +frame." + (declare (ignore frame-number)) + '()) + +(definterface frame-locals (frame-number) + "Return a list of ((&key NAME ID VALUE) ...) where each element of +the list represents a local variable in the stack frame associated to +FRAME-NUMBER. + +NAME, a symbol; the name of the local variable. + +ID, an integer; used as primary key for the local variable, unique +relatively to the frame under operation. + +value, an object; the value of the local variable.") + +(definterface frame-var-value (frame-number var-id) + "Return the value of the local variable associated to VAR-ID +relatively to the frame associated to FRAME-NUMBER.") + +(definterface disassemble-frame (frame-number) + "Disassemble the code for the FRAME-NUMBER. +The output should be written to standard output. +FRAME-NUMBER is a non-negative integer.") + +(definterface eval-in-frame (form frame-number) + "Evaluate a Lisp form in the lexical context of a stack frame +in the debugger. + +FRAME-NUMBER must be a positive integer with 0 indicating the +frame which invoked the debugger. + +The return value is the result of evaulating FORM in the +appropriate context.") + +(definterface frame-package (frame-number) + "Return the package corresponding to the frame at FRAME-NUMBER. +Return nil if the backend can't figure it out." + (declare (ignore frame-number)) + nil) + +(definterface frame-call (frame-number) + "Return a string representing a call to the entry point of a frame.") + +(definterface return-from-frame (frame-number form) + "Unwind the stack to the frame FRAME-NUMBER and return the value(s) +produced by evaluating FORM in the frame context to its caller. + +Execute any clean-up code from unwind-protect forms above the frame +during unwinding. + +Return a string describing the error if it's not possible to return +from the frame.") + +(definterface restart-frame (frame-number) + "Restart execution of the frame FRAME-NUMBER with the same arguments +as it was called originally.") + +(definterface print-condition (condition stream) + "Print a condition for display in SLDB." + (princ condition stream)) + +(definterface condition-extras (condition) + "Return a list of extra for the debugger. +The allowed elements are of the form: + (:SHOW-FRAME-SOURCE frame-number) + (:REFERENCES &rest refs) +" + (declare (ignore condition)) + '()) + +(definterface gdb-initial-commands () + "List of gdb commands supposed to be executed first for the + ATTACH-GDB restart." + nil) + +(definterface activate-stepping (frame-number) + "Prepare the frame FRAME-NUMBER for stepping.") + +(definterface sldb-break-on-return (frame-number) + "Set a breakpoint in the frame FRAME-NUMBER.") + +(definterface sldb-break-at-start (symbol) + "Set a breakpoint on the beginning of the function for SYMBOL.") + +(definterface sldb-stepper-condition-p (condition) + "Return true if SLDB was invoked due to a single-stepping condition, +false otherwise. " + (declare (ignore condition)) + nil) + +(definterface sldb-step-into () + "Step into the current single-stepper form.") + +(definterface sldb-step-next () + "Step to the next form in the current function.") + +(definterface sldb-step-out () + "Stop single-stepping temporarily, but resume it once the current function +returns.") + + +;;;; Definition finding + +(defstruct (:location (:type list) :named + (:constructor make-location + (buffer position &optional hints))) + buffer position + ;; Hints is a property list optionally containing: + ;; :snippet SOURCE-TEXT + ;; This is a snippet of the actual source text at the start of + ;; the definition, which could be used in a text search. + hints) + +(defstruct (:error (:type list) :named (:constructor)) message) + +;;; Valid content for BUFFER slot +(defstruct (:file (:type list) :named (:constructor)) name) +(defstruct (:buffer (:type list) :named (:constructor)) name) +(defstruct (:etags-file (:type list) :named (:constructor)) filename) + +;;; Valid content for POSITION slot +(defstruct (:position (:type list) :named (:constructor)) pos) +(defstruct (:tag (:type list) :named (:constructor)) tag1 tag2) + +(defmacro converting-errors-to-error-location (&body body) + "Catches errors during BODY and converts them to an error location." + (let ((gblock (gensym "CONVERTING-ERRORS+"))) + `(block ,gblock + (handler-bind ((error + #'(lambda (e) + (if *debug-swank-backend* + nil ;decline + (return-from ,gblock + (make-error-location e)))))) + ,@body)))) + +(defun make-error-location (datum &rest args) + (cond ((typep datum 'condition) + `(:error ,(format nil "Error: ~A" datum))) + ((symbolp datum) + `(:error ,(format nil "Error: ~A" + (apply #'make-condition datum args)))) + (t + (assert (stringp datum)) + `(:error ,(apply #'format nil datum args))))) + +(definterface find-definitions (name) + "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. + +NAME is a \"definition specifier\". + +DSPEC is a \"definition specifier\" describing the +definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or +\(DEFVAR FOO). + +LOCATION is the source location for the definition.") + +(definterface find-source-location (object) + "Returns the source location of OBJECT, or NIL. + +That is the source location of the underlying datastructure of +OBJECT. E.g. on a STANDARD-OBJECT, the source location of the +respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the +respective DEFSTRUCT definition, and so on." + ;; This returns one source location and not a list of locations. It's + ;; supposed to return the location of the DEFGENERIC definition on + ;; #'SOME-GENERIC-FUNCTION. + (declare (ignore object)) + (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~ + this implementation.")) + +(definterface buffer-first-change (filename) + "Called for effect the first time FILENAME's buffer is modified. +CMUCL/SBCL use this to cache the unmodified file and use the +unmodified text to improve the precision of source locations." + (declare (ignore filename)) + nil) + + + +;;;; XREF + +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface calls-who (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface who-references (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is referenced. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-binds (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is bound. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-sets (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is set. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-macroexpands (macro-name) + "Return the locations where MACRO-NAME (a symbol) is expanded. +See WHO-CALLS for a description of the return value." + (declare (ignore macro-name)) + :not-implemented) + +(definterface who-specializes (class-name) + "Return the locations where CLASS-NAME (a symbol) is specialized. +See WHO-CALLS for a description of the return value." + (declare (ignore class-name)) + :not-implemented) + +;;; Simpler variants. + +(definterface list-callers (function-name) + "List the callers of FUNCTION-NAME. +This function is like WHO-CALLS except that it is expected to use +lower-level means. Whereas WHO-CALLS is usually implemented with +special compiler support, LIST-CALLERS is usually implemented by +groveling for constants in function objects throughout the heap. + +The return value is as for WHO-CALLS.") + +(definterface list-callees (function-name) + "List the functions called by FUNCTION-NAME. +See LIST-CALLERS for a description of the return value.") + + +;;;; Profiling + +;;; The following functions define a minimal profiling interface. + +(definterface profile (fname) + "Marks symbol FNAME for profiling.") + +(definterface profiled-functions () + "Returns a list of profiled functions.") + +(definterface unprofile (fname) + "Marks symbol FNAME as not profiled.") + +(definterface unprofile-all () + "Marks all currently profiled functions as not profiled." + (dolist (f (profiled-functions)) + (unprofile f))) + +(definterface profile-report () + "Prints profile report.") + +(definterface profile-reset () + "Resets profile counters.") + +(definterface profile-package (package callers-p methods) + "Wrap profiling code around all functions in PACKAGE. If a function +is already profiled, then unprofile and reprofile (useful to notice +function redefinition.) + +If CALLERS-P is T names have counts of the most common calling +functions recorded. + +When called with arguments :METHODS T, profile all methods of all +generic functions having names in the given package. Generic functions +themselves, that is, their dispatch functions, are left alone.") + + +;;;; Trace + +(definterface toggle-trace (spec) + "Toggle tracing of the function(s) given with SPEC. +SPEC can be: + (setf NAME) ; a setf function + (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method + (:defgeneric NAME) ; a generic function with all methods + (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. + (:labels TOPLEVEL LOCAL) + (:flet TOPLEVEL LOCAL) ") + + +;;;; Inspector + +(defgeneric emacs-inspect (object) + (:documentation + "Explain to Emacs how to inspect OBJECT. + +Returns a list specifying how to render the object for inspection. + +Every element of the list must be either a string, which will be +inserted into the buffer as is, or a list of the form: + + (:value object &optional format) - Render an inspectable + object. If format is provided it must be a string and will be + rendered in place of the value, otherwise use princ-to-string. + + (:newline) - Render a \\n + + (:action label lambda &key (refresh t)) - Render LABEL (a text + string) which when clicked will call LAMBDA. If REFRESH is + non-NIL the currently inspected object will be re-inspected + after calling the lambda. +")) + +(defmethod emacs-inspect ((object t)) + "Generic method for inspecting any kind of object. + +Since we don't know how to deal with OBJECT we simply dump the +output of CL:DESCRIBE." + `("Type: " (:value ,(type-of object)) (:newline) + "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" + (:newline) (:newline) + ,(with-output-to-string (desc) (describe object desc)))) + +(definterface eval-context (object) + "Return a list of bindings corresponding to OBJECT's slots." + (declare (ignore object)) + '()) + +;;; Utilities for inspector methods. +;;; + +(defun label-value-line (label value &key (newline t)) + "Create a control list which prints \"LABEL: VALUE\" in the inspector. +If NEWLINE is non-NIL a `(:newline)' is added to the result." + (list* (princ-to-string label) ": " `(:value ,value) + (if newline '((:newline)) nil))) + +(defmacro label-value-line* (&rest label-values) + ` (append ,@(loop for (label value) in label-values + collect `(label-value-line ,label ,value)))) + +(definterface describe-primitive-type (object) + "Return a string describing the primitive type of object." + (declare (ignore object)) + "N/A") + + +;;;; Multithreading +;;; +;;; The default implementations are sufficient for non-multiprocessing +;;; implementations. + +(definterface initialize-multiprocessing (continuation) + "Initialize multiprocessing, if necessary and then invoke CONTINUATION. + +Depending on the impleimentaion, this function may never return." + (funcall continuation)) + +(definterface spawn (fn &key name) + "Create a new thread to call FN.") + +(definterface thread-id (thread) + "Return an Emacs-parsable object to identify THREAD. + +Ids should be comparable with equal, i.e.: + (equal (thread-id ) (thread-id )) <==> (eq )" + thread) + +(definterface find-thread (id) + "Return the thread for ID. +ID should be an id previously obtained with THREAD-ID. +Can return nil if the thread no longer exists." + (declare (ignore id)) + (current-thread)) + +(definterface thread-name (thread) + "Return the name of THREAD. +Thread names are short strings meaningful to the user. They do not +have to be unique." + (declare (ignore thread)) + "The One True Thread") + +(definterface thread-status (thread) + "Return a string describing THREAD's state." + (declare (ignore thread)) + "") + +(definterface thread-attributes (thread) + "Return a plist of implementation-dependent attributes for THREAD" + (declare (ignore thread)) + '()) + +(definterface current-thread () + "Return the currently executing thread." + 0) + +(definterface all-threads () + "Return a fresh list of all threads." + '()) + +(definterface thread-alive-p (thread) + "Test if THREAD is termintated." + (member thread (all-threads))) + +(definterface interrupt-thread (thread fn) + "Cause THREAD to execute FN.") + +(definterface kill-thread (thread) + "Terminate THREAD immediately. +Don't execute unwind-protected sections, don't raise conditions. +(Do not pass go, do not collect $200.)" + (declare (ignore thread)) + nil) + +(definterface send (thread object) + "Send OBJECT to thread THREAD." + (declare (ignore thread)) + object) + +(definterface receive (&optional timeout) + "Return the next message from current thread's mailbox." + (receive-if (constantly t) timeout)) + +(definterface receive-if (predicate &optional timeout) + "Return the first message satisfiying PREDICATE.") + +(definterface register-thread (name thread) + "Associate the thread THREAD with the symbol NAME. +The thread can then be retrieved with `find-registered'. +If THREAD is nil delete the association." + (declare (ignore name thread)) + nil) + +(definterface find-registered (name) + "Find the thread that was registered for the symbol NAME. +Return nil if the no thread was registred or if the tread is dead." + (declare (ignore name)) + nil) + +(definterface set-default-initial-binding (var form) + "Initialize special variable VAR by default with FORM. + +Some implementations initialize certain variables in each newly +created thread. This function sets the form which is used to produce +the initial value." + (set var (eval form))) + +;; List of delayed interrupts. +;; This should only have thread-local bindings, so no init form. +(defvar *pending-slime-interrupts*) + +(defun check-slime-interrupts () + "Execute pending interrupts if any. +This should be called periodically in operations which +can take a long time to complete. +Return a boolean indicating whether any interrupts was processed." + (when (and (boundp '*pending-slime-interrupts*) + *pending-slime-interrupts*) + (funcall (pop *pending-slime-interrupts*)) + t)) + +(defvar *interrupt-queued-handler* nil + "Function to call on queued interrupts. +Interrupts get queued when an interrupt occurs while interrupt +handling is disabled. + +Backends can use this function to abort slow operations.") + +(definterface wait-for-input (streams &optional timeout) + "Wait for input on a list of streams. Return those that are ready. +STREAMS is a list of streams +TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams +which are ready (or have reached end-of-file) without waiting. +If TIMEOUT is a number and no streams is ready after TIMEOUT seconds, +return nil. + +Return :interrupt if an interrupt occurs while waiting.") + + +;;;; Locks + +;; Please use locks only in swank-gray.lisp. Locks are too low-level +;; for our taste. + +(definterface make-lock (&key name) + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time +but that thread may hold it more than once." + (declare (ignore name)) + :null-lock) + +(definterface call-with-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (declare (ignore lock) + (type function function)) + (funcall function)) + + +;;;; Weak datastructures + +(definterface make-weak-key-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." + (apply #'make-hash-table args)) + +(definterface make-weak-value-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the values." + (apply #'make-hash-table args)) + +(definterface hash-table-weakness (hashtable) + "Return nil or one of :key :value :key-or-value :key-and-value" + (declare (ignore hashtable)) + nil) + + +;;;; Character names + +(definterface character-completion-set (prefix matchp) + "Return a list of names of characters that match PREFIX." + ;; Handle the standard and semi-standard characters. + (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" + "Linefeed" "Return" "Backspace") + when (funcall matchp prefix name) + collect name)) + + +(defparameter *type-specifier-arglists* + '((and . (&rest type-specifiers)) + (array . (&optional element-type dimension-spec)) + (base-string . (&optional size)) + (bit-vector . (&optional size)) + (complex . (&optional type-specifier)) + (cons . (&optional car-typespec cdr-typespec)) + (double-float . (&optional lower-limit upper-limit)) + (eql . (object)) + (float . (&optional lower-limit upper-limit)) + (function . (&optional arg-typespec value-typespec)) + (integer . (&optional lower-limit upper-limit)) + (long-float . (&optional lower-limit upper-limit)) + (member . (&rest eql-objects)) + (mod . (n)) + (not . (type-specifier)) + (or . (&rest type-specifiers)) + (rational . (&optional lower-limit upper-limit)) + (real . (&optional lower-limit upper-limit)) + (satisfies . (predicate-symbol)) + (short-float . (&optional lower-limit upper-limit)) + (signed-byte . (&optional size)) + (simple-array . (&optional element-type dimension-spec)) + (simple-base-string . (&optional size)) + (simple-bit-vector . (&optional size)) + (simple-string . (&optional size)) + (single-float . (&optional lower-limit upper-limit)) + (simple-vector . (&optional size)) + (string . (&optional size)) + (unsigned-byte . (&optional size)) + (values . (&rest typespecs)) + (vector . (&optional element-type size)) + )) + +;;; Heap dumps + +(definterface save-image (filename &optional restart-function) + "Save a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") + +(definterface background-save-image (filename &key restart-function + completion-function) + "Request saving a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded. +COMPLETION-FUNCTION, if non-nil, should be called after saving the image.") + +(defun deinit-log-output () + ;; Can't hang on to an fd-stream from a previous session. + (setf *log-output* nil)) + + +;;;; Wrapping + +(definterface wrap (spec indicator &key before after replace) + "Intercept future calls to SPEC and surround them in callbacks. + +INDICATOR is a symbol identifying a particular wrapping, and is used +to differentiate between multiple wrappings. + +Implementations intercept calls to SPEC and call, in this order: + +* the BEFORE callback, if it's provided, with a single argument set to + the list of arguments passed to the intercepted call; + +* the original definition of SPEC recursively honouring any wrappings + previously established under different values of INDICATOR. If the + compatible function REPLACE is provided, call that instead. + +* the AFTER callback, if it's provided, with a single set to the list + of values returned by the previous call, or, if that call exited + non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY." + (declare (ignore indicator)) + (assert (symbolp spec) nil + "The default implementation for WRAP allows only simple names") + (assert (null (get spec 'slime-wrap)) nil + "The default implementation for WRAP allows a single wrapping") + (let* ((saved (symbol-function spec)) + (replacement (lambda (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (apply (or replace + saved) args))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally)))))))) + (setf (get spec 'slime-wrap) (list saved replacement)) + (setf (symbol-function spec) replacement)) + spec) + +(definterface unwrap (spec indicator) + "Remove from SPEC any wrappings tagged with INDICATOR." + (if (wrapped-p spec indicator) + (setf (symbol-function spec) (first (get spec 'slime-wrap))) + (cerror "All right, so I did" + "Hmmm, ~a is not correctly wrapped, you probably redefined it" + spec)) + (setf (get spec 'slime-wrap) nil) + spec) + +(definterface wrapped-p (spec indicator) + "Returns true if SPEC is wrapped with INDICATOR." + (declare (ignore indicator)) + (and (symbolp spec) + (let ((prop-value (get spec 'slime-wrap))) + (cond ((and prop-value + (not (eq (second prop-value) + (symbol-function spec)))) + (warn "~a appears to be incorrectly wrapped" spec) + nil) + (prop-value t) + (t nil))))) diff --git a/vim/bundle/slimv/slime/swank/ccl.lisp b/vim/bundle/slimv/slime/swank/ccl.lisp new file mode 100644 index 0000000..66195c5 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/ccl.lisp @@ -0,0 +1,861 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ccl.lisp --- SLIME backend for Clozure CL. +;;; +;;; Copyright (C) 2003, James Bielman +;;; +;;; This program is licensed under the terms of the Lisp Lesser GNU +;;; Public License, known as the LLGPL, and distributed with Clozure CL +;;; as the file "LICENSE". The LLGPL consists of a preamble and the +;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where +;;; these conflict, the preamble takes precedence. +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage swank/ccl + (:use cl swank/backend)) + +(in-package swank/ccl) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (assert (and (= ccl::*openmcl-major-version* 1) + (>= ccl::*openmcl-minor-version* 4)) + () "This file needs CCL version 1.4 or newer")) + +(defimplementation gray-package-name () + "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (multiple-value-bind (ok err) (ignore-errors (require 'xref)) + (unless ok + (warn "~a~%" err)))) + +;;; swank-mop + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + ccl:standard-slot-definition + cl:method + cl:standard-class + ccl:eql-specializer + openmcl-mop:finalize-inheritance + openmcl-mop:compute-applicable-methods-using-classes + ;; standard-class readers + openmcl-mop:class-default-initargs + openmcl-mop:class-direct-default-initargs + openmcl-mop:class-direct-slots + openmcl-mop:class-direct-subclasses + openmcl-mop:class-direct-superclasses + openmcl-mop:class-finalized-p + cl:class-name + openmcl-mop:class-precedence-list + openmcl-mop:class-prototype + openmcl-mop:class-slots + openmcl-mop:specializer-direct-methods + ;; eql-specializer accessors + openmcl-mop:eql-specializer-object + ;; generic function readers + openmcl-mop:generic-function-argument-precedence-order + openmcl-mop:generic-function-declarations + openmcl-mop:generic-function-lambda-list + openmcl-mop:generic-function-methods + openmcl-mop:generic-function-method-class + openmcl-mop:generic-function-method-combination + openmcl-mop:generic-function-name + ;; method readers + openmcl-mop:method-generic-function + openmcl-mop:method-function + openmcl-mop:method-lambda-list + openmcl-mop:method-specializers + openmcl-mop:method-qualifiers + ;; slot readers + openmcl-mop:slot-definition-allocation + openmcl-mop:slot-definition-documentation + openmcl-mop:slot-value-using-class + openmcl-mop:slot-definition-initargs + openmcl-mop:slot-definition-initform + openmcl-mop:slot-definition-initfunction + openmcl-mop:slot-definition-name + openmcl-mop:slot-definition-type + openmcl-mop:slot-definition-readers + openmcl-mop:slot-definition-writers + openmcl-mop:slot-boundp-using-class + openmcl-mop:slot-makunbound-using-class)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ccl:encode-string-to-octets string :external-format :utf-8)) + +(defimplementation utf8-to-string (octets) + (ccl:decode-string-from-octets octets :external-format :utf-8)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ccl:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (ccl:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore buffering timeout)) + (let ((stream-args (and external-format + `(:external-format ,external-format)))) + (ccl:accept-connection socket :wait t :stream-args stream-args))) + +(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"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation socket-fd (stream) + (ccl::ioblock-device (ccl::stream-ioblock stream t))) + +;;; Unix signals + +(defimplementation getpid () + (ccl::getpid)) + +(defimplementation lisp-implementation-type-name () + "ccl") + +;;; Arglist + +(defimplementation arglist (fname) + (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil)) + (ccl:arglist fname)) + (if binding + arglist + :not-available))) + +(defimplementation function-name (function) + (ccl:function-name function)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (let ((flags (ccl:declaration-information decl-identifier))) + (if flags + `(&any ,flags) + (call-next-method)))) + +;;; Compilation + +(defun handle-compiler-warning (condition) + "Resignal a ccl:compiler-warning as swank/backend:compiler-warning." + (signal 'compiler-condition + :original-condition condition + :message (compiler-warning-short-message condition) + :source-context nil + :severity (compiler-warning-severity condition) + :location (source-note-to-source-location + (ccl:compiler-warning-source-note condition) + (lambda () "Unknown source") + (ccl:compiler-warning-function-name condition)))) + +(defgeneric compiler-warning-severity (condition)) +(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning) +(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning) + +(defgeneric compiler-warning-short-message (condition)) + +;; Pretty much the same as ccl:report-compiler-warning but +;; without the source position and function name stuff. +(defmethod compiler-warning-short-message ((c ccl:compiler-warning)) + (with-output-to-string (stream) + (ccl:report-compiler-warning c stream :short t))) + +;; Needed because `ccl:report-compiler-warning' would return +;; "Nonspecific warning". +(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause)) + (princ-to-string c)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((ccl:compiler-warning 'handle-compiler-warning)) + (let ((ccl:*merge-compiler-warnings* nil)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +;; Use a temp file rather than in-core compilation in order to handle +;; eval-when's as compile-time. +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((temp-file-name (ccl:temp-pathname)) + (ccl:*save-source-locations* t)) + (unwind-protect + (progn + (with-open-file (s temp-file-name :direction :output + :if-exists :error :external-format :utf-8) + (write-string string s)) + (let ((binary-filename (compile-temp-file + temp-file-name filename buffer position))) + (delete-file binary-filename))) + (delete-file temp-file-name))))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset) + (compile-file temp-file-name + :load t + :compile-file-original-truename + (or buffer-file-name + (progn + (setf (gethash temp-file-name *temp-file-map*) + buffer-name) + temp-file-name)) + :compile-file-original-buffer-offset (1- offset) + :external-format :utf-8)) + +(defimplementation save-image (filename &optional restart-function) + (ccl:save-application filename :toplevel-function restart-function)) + +;;; Cross-referencing + +(defun xref-locations (relation name &optional inverse) + (delete-duplicates + (mapcan #'find-definitions + (if inverse + (ccl::get-relation relation name :wild :exhaustive t) + (ccl::get-relation relation :wild name :exhaustive t))) + :test 'equal)) + +(defimplementation who-binds (name) + (xref-locations :binds name)) + +(defimplementation who-macroexpands (name) + (xref-locations :macro-calls name t)) + +(defimplementation who-references (name) + (remove-duplicates + (append (xref-locations :references name) + (xref-locations :sets name) + (xref-locations :binds name)) + :test 'equal)) + +(defimplementation who-sets (name) + (xref-locations :sets name)) + +(defimplementation who-calls (name) + (remove-duplicates + (append + (xref-locations :direct-calls name) + (xref-locations :indirect-calls name) + (xref-locations :macro-calls name t)) + :test 'equal)) + +(defimplementation who-specializes (class) + (when (symbolp class) + (setq class (find-class class nil))) + (when class + (delete-duplicates + (mapcar (lambda (m) + (car (find-definitions m))) + (ccl:specializer-direct-methods class)) + :test 'equal))) + +(defimplementation list-callees (name) + (remove-duplicates + (append + (xref-locations :direct-calls name t) + (xref-locations :macro-calls name nil)) + :test 'equal)) + +(defimplementation list-callers (symbol) + (delete-duplicates + (mapcan #'find-definitions (ccl:caller-functions symbol)) + :test #'equal)) + +;;; Profiling (alanr: lifted from swank-clisp) + +(defimplementation profile (fname) + (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-monitor:monitor-all package)) + +;;; Debugging + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(*debugger-hook* nil) + ;; don't let error while printing error take us down + (ccl:*signal-printing-errors* nil)) + (funcall debugger-loop-fn))) + +;; This is called for an async interrupt and is running in a random +;; thread not selected by the user, so don't use thread-local vars +;; such as *emacs-connection*. +(defun find-repl-thread () + (let* ((*break-on-signals* nil) + (conn (swank::default-connection))) + (and (swank::multithreaded-connection-p conn) + (swank::mconn.repl-thread conn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ccl:*break-hook* hook) + (ccl:*select-interactive-process-hook* 'find-repl-thread)) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ccl:*break-hook* function) + (setq ccl:*select-interactive-process-hook* 'find-repl-thread) + ) + +(defun map-backtrace (function &optional + (start-frame-number 0) + end-frame-number) + "Call FUNCTION passing information about each stack frame + from frames START-FRAME-NUMBER to END-FRAME-NUMBER." + (let ((end-frame-number (or end-frame-number most-positive-fixnum))) + (ccl:map-call-frames function + :origin ccl:*top-error-frame* + :start-frame-number start-frame-number + :count (- end-frame-number start-frame-number)))) + +(defimplementation compute-backtrace (start-frame-number end-frame-number) + (let (result) + (map-backtrace (lambda (p context) + (push (list :frame p context) result)) + start-frame-number end-frame-number) + (nreverse result))) + +(defimplementation print-frame (frame stream) + (assert (eq (first frame) :frame)) + (destructuring-bind (p context) (rest frame) + (let ((lfun (ccl:frame-function p context))) + (format stream "(~S" (or (ccl:function-name lfun) lfun)) + (let* ((unavailable (cons nil nil)) + (args (ccl:frame-supplied-arguments p context + :unknown-marker unavailable))) + (declare (dynamic-extent unavailable)) + (if (eq args unavailable) + (format stream " #") + (dolist (arg args) + (if (eq arg unavailable) + (format stream " #") + (format stream " ~s" arg))))) + (format stream ")")))) + +(defmacro with-frame ((p context) frame-number &body body) + `(call/frame ,frame-number (lambda (,p ,context) . ,body))) + +(defun call/frame (frame-number if-found) + (map-backtrace + (lambda (p context) + (return-from call/frame + (funcall if-found p context))) + frame-number)) + +(defimplementation frame-call (frame-number) + (with-frame (p context) frame-number + (with-output-to-string (stream) + (print-frame (list :frame p context) stream)))) + +(defimplementation frame-var-value (frame var) + (with-frame (p context) frame + (cdr (nth var (ccl:frame-named-variables p context))))) + +(defimplementation frame-locals (index) + (with-frame (p context) index + (loop for (name . value) in (ccl:frame-named-variables p context) + collect (list :name name :value value :id 0)))) + +(defimplementation frame-source-location (index) + (with-frame (p context) index + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (if pc + (pc-source-location lfun pc) + (function-source-location lfun))))) + +(defun function-name-package (name) + (etypecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql ccl::traced)) (function-name-package (second name))) + ((cons (eql setf)) (symbol-package (second name))) + ((cons (eql :internal)) (function-name-package (car (last name)))) + ((cons (and symbol (not keyword)) (cons list null)) + (symbol-package (car name))) + (standard-method (function-name-package (ccl:method-name name))))) + +(defimplementation frame-package (frame-number) + (with-frame (p context) frame-number + (let* ((lfun (ccl:frame-function p context)) + (name (ccl:function-name lfun))) + (function-name-package name)))) + +(defimplementation eval-in-frame (form index) + (with-frame (p context) index + (let ((vars (ccl:frame-named-variables p context))) + (eval `(let ,(loop for (var . val) in vars collect `(,var ',val)) + (declare (ignorable ,@(mapcar #'car vars))) + ,form))))) + +(defimplementation return-from-frame (index form) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (with-frame (p context) index + (declare (ignore context)) + (ccl:apply-in-frame p #'values values)))) + +(defimplementation restart-frame (index) + (with-frame (p context) index + (ccl:apply-in-frame p + (ccl:frame-function p context) + (ccl:frame-supplied-arguments p context)))) + +(defimplementation disassemble-frame (the-frame-number) + (with-frame (p context) the-frame-number + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context) + (disassemble lfun)))) + +;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) +;; contains some interesting details: +;; +;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects +;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, +;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end +;; positions are file positions (not character positions). The text will +;; be NIL unless text recording was on at read-time. If the original +;; file is still available, you can force missing source text to be read +;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT. +;; +;; Source-note's are associated with definitions (via record-source-file) +;; and also stored in function objects (including anonymous and nested +;; functions). The former can be retrieved via +;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE. +;; +;; The recording behavior is controlled by the new variable +;; CCL:*SAVE-SOURCE-LOCATIONS*: +;; +;; If NIL, don't store source-notes in function objects, and store only +;; the filename for definitions (the latter only if +;; *record-source-file* is true). +;; +;; If T, store source-notes, including a copy of the original source +;; text, for function objects and definitions (the latter only if +;; *record-source-file* is true). +;; +;; If :NO-TEXT, store source-notes, but without saved text, for +;; function objects and defintions (the latter only if +;; *record-source-file* is true). This is the default. +;; +;; PC to source mapping is controlled by the new variable +;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a +;; compressed table mapping pc offsets to corresponding source locations. +;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) +;; which returns a source-note for the source at offset pc in the +;; function. + +(defun function-source-location (function) + (source-note-to-source-location + (or (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "Function has no source note: ~A" function)) + (ccl:function-name function))) + +(defun pc-source-location (function pc) + (source-note-to-source-location + (or (ccl:find-source-note-at-pc function pc) + (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "No source note at PC: ~a[~d]" function pc)) + (ccl:function-name function))) + +(defun function-name-source-note (fun) + (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function))) + (and defs + (destructuring-bind ((type . name) srcloc . srclocs) (car defs) + (declare (ignore type name srclocs)) + srcloc)))) + +(defun source-note-to-source-location (source if-nil-thunk &optional name) + (labels ((filename-to-buffer (filename) + (cond ((gethash filename *temp-file-map*) + (list :buffer (gethash filename *temp-file-map*))) + ((probe-file filename) + (list :file (ccl:native-translated-namestring + (truename filename)))) + (t (error "File ~s doesn't exist" filename))))) + (handler-case + (cond ((ccl:source-note-p source) + (let* ((full-text (ccl:source-note-text source)) + (file-name (ccl:source-note-filename source)) + (start-pos (ccl:source-note-start-pos source))) + (make-location + (when file-name (filename-to-buffer (pathname file-name))) + (when start-pos (list :position (1+ start-pos))) + (when full-text + (list :snippet (subseq full-text 0 + (min 40 (length full-text)))))))) + ((and source name) + ;; This branch is probably never used + (make-location + (filename-to-buffer source) + (list :function-name (princ-to-string + (if (functionp name) + (ccl:function-name name) + name))))) + (t `(:error ,(funcall if-nil-thunk)))) + (error (c) `(:error ,(princ-to-string c)))))) + +(defun alphatizer-definitions (name) + (let ((alpha (gethash name ccl::*nx1-alphatizers*))) + (and alpha (ccl:find-definition-sources alpha)))) + +(defun p2-definitions (name) + (let ((nx1-op (gethash name ccl::*nx1-operators*))) + (and nx1-op + (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) ) + (and (array-in-bounds-p dispatch nx1-op) + (let ((p2 (aref dispatch nx1-op))) + (and p2 + (ccl:find-definition-sources p2)))))))) + +(defimplementation find-definitions (name) + (let ((defs (append (or (ccl:find-definition-sources name) + (and (symbolp name) + (fboundp name) + (ccl:find-definition-sources + (symbol-function name)))) + (alphatizer-definitions name) + (p2-definitions name)))) + (loop for ((type . name) . sources) in defs + collect (list (definition-name type name) + (source-note-to-source-location + (find-if-not #'null sources) + (lambda () "No source-note available") + name))))) + +(defimplementation find-source-location (obj) + (let* ((defs (ccl:find-definition-sources obj)) + (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal) + (car defs))) + (note (find-if-not #'null (cdr best-def)))) + (when note + (source-note-to-source-location + note + (lambda () "No source note available"))))) + +(defun definition-name (type object) + (case (ccl:definition-type-name type) + (method (ccl:name-of object)) + (t (list (ccl:definition-type-name type) (ccl:name-of object))))) + +;;; Utilities + +(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 + :setf (let ((setf-function-name (ccl:setf-function-spec-name + `(setf ,symbol)))) + (when (fboundp setf-function-name) + (doc 'function setf-function-name)))) + (maybe-push + :type (when (ccl:type-specifier-p symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:setf + (describe (ccl:setf-function-spec-name `(setf ,symbol)))) + (:class + (describe (find-class symbol))) + (:type + (describe (or (find-class symbol nil) symbol))))) + +;; spec ::= (:defmethod {}* ({}*)) +(defun parse-defmethod-spec (spec) + (values (second spec) + (subseq spec 2 (position-if #'consp spec)) + (find-if #'consp (cddr spec)))) + +(defimplementation toggle-trace (spec) + "We currently ignore just about everything." + (let ((what (ecase (first spec) + ((setf) + spec) + ((:defgeneric) + (second spec)) + ((:defmethod) + (multiple-value-bind (name qualifiers specializers) + (parse-defmethod-spec spec) + (find-method (fdefinition name) + qualifiers + specializers)))))) + (cond ((member what (trace) :test #'equal) + (ccl::%untrace what) + (format nil "~S is now untraced." what)) + (t + (ccl:trace-function what) + (format nil "~S is now traced." what))))) + +;;; Macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (ccl:macroexpand-all form env)) + +;;;; Inspection + +(defun comment-type-p (type) + (or (eq type :comment) + (and (consp type) (eq (car type) :comment)))) + +(defmethod emacs-inspect ((o t)) + (let* ((inspector:*inspector-disassembly* t) + (i (inspector:make-inspector o)) + (count (inspector:compute-line-count i))) + (loop for l from 0 below count append + (multiple-value-bind (value label type) (inspector:line-n i l) + (etypecase type + ((member nil :normal) + `(,(or label "") (:value ,value) (:newline))) + ((member :colon) + (label-value-line label value)) + ((member :static) + (list (princ-to-string label) " " `(:value ,value) '(:newline))) + ((satisfies comment-type-p) + (list (princ-to-string label) '(:newline)))))))) + +(defmethod emacs-inspect :around ((o t)) + (if (or (uvector-inspector-p o) + (not (ccl:uvectorp o))) + (call-next-method) + (let ((value (call-next-method))) + (cond ((listp value) + (append value + `((:newline) + (:value ,(make-instance 'uvector-inspector :object o) + "Underlying UVECTOR")))) + (t value))))) + +(defmethod emacs-inspect ((f function)) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(princ-to-string (arglist f)) (:newline)) + (label-value-line "Documentation" (documentation f t)) + (when (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))) + (when (ccl:function-source-note f) + (label-value-line "Source note" + (ccl:function-source-note f))) + (when (typep f 'ccl:compiled-lexical-closure) + (append + (label-value-line "Inner function" (ccl::closure-function f)) + '("Closed over values:" (:newline)) + (loop for (name value) in (ccl::closure-closed-over-values f) + append (label-value-line (format nil " ~a" name) + value)))))) + +(defclass uvector-inspector () + ((object :initarg :object))) + +(defgeneric uvector-inspector-p (object) + (:method ((object t)) nil) + (:method ((object uvector-inspector)) t)) + +(defmethod emacs-inspect ((uv uvector-inspector)) + (with-slots (object) uv + (loop for i below (ccl:uvsize object) append + (label-value-line (princ-to-string i) (ccl:uvref object i))))) + +(defimplementation type-specifier-p (symbol) + (or (ccl:type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Multiprocessing + +(defvar *known-processes* + (make-hash-table :size 20 :weak :key :test #'eq) + "A map from threads to mailboxes.") + +(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (ccl:make-lock "thread mailbox")) + (semaphore (ccl:make-semaphore)) + (queue '() :type list)) + +(defimplementation spawn (fun &key name) + (ccl:process-run-function (or name "Anonymous (Swank)") + fun)) + +(defimplementation thread-id (thread) + (ccl:process-serial-number thread)) + +(defimplementation find-thread (id) + (find id (ccl:all-processes) :key #'ccl:process-serial-number)) + +(defimplementation thread-name (thread) + (ccl:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A" (ccl:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (ccl:process-priority thread))) + +(defimplementation make-lock (&key name) + (ccl:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (ccl:with-lock-grabbed (lock) + (funcall function))) + +(defimplementation current-thread () + ccl:*current-process*) + +(defimplementation all-threads () + (ccl:all-processes)) + +(defimplementation kill-thread (thread) + ;;(ccl:process-kill thread) ; doesn't cut it + (ccl::process-initial-form-exited thread :kill)) + +(defimplementation thread-alive-p (thread) + (not (ccl:process-exhausted-p thread))) + +(defimplementation interrupt-thread (thread function) + (ccl:process-interrupt + thread + (lambda () + (let ((ccl:*top-error-frame* (ccl::%current-exception-frame))) + (funcall function))))) + +(defun mailbox (thread) + (ccl:with-lock-grabbed (*known-processes-lock*) + (or (gethash thread *known-processes*) + (setf (gethash thread *known-processes*) (make-mailbox))))) + +(defimplementation send (thread message) + (assert message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox ccl:*current-process*)) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (ccl:with-lock-grabbed (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1)))) + +(let ((alist '()) + (lock (ccl:make-lock "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (ccl:with-lock-grabbed (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (ccl:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (ccl:with-lock-grabbed (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (eval `(ccl::def-standard-initial-binding ,var ,form))) + +(defimplementation quit-lisp () + (ccl:quit)) + +(defimplementation set-default-directory (directory) + (let ((dir (truename (merge-pathnames directory)))) + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (ccl:cwd dir) + (default-directory))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation hash-table-weakness (hashtable) + (ccl:hash-table-weak-p hashtable)) + +(pushnew 'deinit-log-output ccl:*save-exit-functions*) diff --git a/vim/bundle/slimv/slime/swank/clasp.lisp b/vim/bundle/slimv/slime/swank/clasp.lisp new file mode 100644 index 0000000..3e0c4ef --- /dev/null +++ b/vim/bundle/slimv/slime/swank/clasp.lisp @@ -0,0 +1,730 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-clasp.lisp --- SLIME backend for CLASP. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/clasp + (:use cl swank/backend)) + +(in-package swank/clasp) + + +(defmacro cslime-log (fmt &rest fmt-args) + `(format t ,fmt ,@fmt-args)) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Swank-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-swank-mop-symbols + :clos + `(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) + '(:compute-applicable-methods-using-classes))))) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + ;; CLASP does not provide threads yet. + ;; ECLs swank implementation says that CLOS is not thread safe and + ;; I use ECLs CLOS implementation - this is a worry for the future. + nil + ) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, CLASP uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;;; Unix Integration + +;;; If CLASP is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as CLASP's +;;; main-thread is also the Slime's REPL thread. + +#+clasp-working +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +#+threads +(defun make-interrupt-handler (real-handler) + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler)))) + +#-threads +(defun make-interrupt-handler (real-handler) + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + + +(defimplementation getpid () + (si:getpid)) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (core:quit)) + + + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(progn + (defun poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) + + (defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready)))))) + +) ; #+serve-event (progn ... + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +#-clasp-bytecmp +(defun handle-compiler-message (condition) + ;; CLASP emits lots of noise in compiler-notes, like "Invoking + ;; external command". + (unless (typep condition 'c::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (cmp:compiler-fatal-error :error) + (cmp:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +#-clasp-bytecmp +(defun condition-location (condition) + (let ((file (cmp:compiler-message-file condition)) + (position (cmp:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) + +(defimplementation call-with-compilation-hooks (function) + (funcall function)) +#|| #-clasp-bytecmp + (handler-bind ((c:compiler-message #'handle-compiler-message)) + (funcall function))) +||# + + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file) + ;; Ignore the output-file and generate our own + (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-")))) + (format t "Using tmp-output-file: ~a~%" tmp-output-file) + (multiple-value-bind (fasl warnings-p failure-p) + (with-compilation-hooks () + (compile-file input-file :output-file tmp-output-file + :external-format external-format)) + (values fasl warnings-p + (or failure-p + (when load-p + (not (load fasl)))))))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation swank-compile-string (string &key buffer position filename policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer)))) + (compile-file tmp-file + :source-debug-namestring truename + :source-debug-offset (1- position))))) + (when fasl-file (load fasl-file)) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (core:function-lambda-list name) ;; Uses bc-split + (if foundp arglist :not-available))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos::generic-function-name f)) + (function (ext:compiled-function-name f)))) + +;; FIXME +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* +#+frs si::*frs-base* +#+frs si::*frs-top* + si::*tpl-commands* + si::*tpl-level* +#+frs si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env +#+frs si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)) + ) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun)) + ) + +(defvar *backtrace* '()) + +;;; Commented out; it's not clear this is a good way of doing it. In +;;; particular because it makes errors stemming from this file harder +;;; to debug, and given the "young" age of CLASP's swank backend, that's +;;; a bad idea. + +;; (defun in-swank-package-p (x) +;; (and +;; (symbolp x) +;; (member (symbol-package x) +;; (list #.(find-package :swank) +;; #.(find-package :swank/backend) +;; #.(ignore-errors (find-package :swank-mop)) +;; #.(ignore-errors (find-package :swank-loader)))) +;; t)) + +;; (defun is-swank-source-p (name) +;; (setf name (pathname name)) +;; (pathname-match-p +;; name +;; (make-pathname :defaults swank-loader::*source-directory* +;; :name (pathname-name name) +;; :type (pathname-type name) +;; :version (pathname-version name)))) + +;; (defun is-ignorable-fun-p (x) +;; (or +;; (in-swank-package-p (frame-name x)) +;; (multiple-value-bind (file position) +;; (ignore-errors (si::bc-file (car x))) +;; (declare (ignore position)) +;; (if file (is-swank-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* (or #+#.(swank/backend:with-symbol '*stack-top-hint* 'core) + core:*stack-top-hint* + (ihs-top))) + (*ihs-current* *ihs-top*) +#+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) +#+frs (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + ihs)))) + (declare (special *ihs-current*)) +#+frs (loop for f from *frs-base* until *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (si::fixnump name) + (push name (third x))))))) + (setf *backtrace* (nreverse *backtrace*)) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun frame-function (frame-number) + (let ((x (first (elt *backtrace* frame-number)))) + (etypecase x + (symbol + (and (fboundp x) + (fdefinition x))) + (function + x)))) + +(defimplementation print-frame (frame stream) + (format stream "(~s~{ ~s~})" (function-name (first frame)) + #+#.(swank/backend:with-symbol 'ihs-arguments 'core) + (coerce (core:ihs-arguments (third frame)) 'list) + #-#.(swank/backend:with-symbol 'ihs-arguments 'core) + nil)) + +(defimplementation frame-source-location (frame-number) + (source-location (frame-function frame-number))) + +#+clasp-working +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defun ihs-frame-id (frame-number) + (- (core:ihs-top) frame-number)) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *backtrace* frame-number)) + (env (second frame)) + (locals (loop for x = env then (core:get-parent-environment x) + while x + nconc (loop for name across (core:environment-debug-names x) + for value across (core:environment-debug-values x) + collect (list :name name :id 0 :value value))))) + (nconc + (loop for arg across (core:ihs-arguments (third frame)) + for i from 0 + collect (list :name (intern (format nil "ARG~d" i) #.*package*) + :id 0 + :value arg)) + locals))) + +(defimplementation frame-var-value (frame-number var-number) + (let* ((frame (elt *backtrace* frame-number)) + (env (second frame)) + (args (core:ihs-arguments (third frame)))) + (if (< var-number (length args)) + (svref args var-number) + (elt (frame-locals frame-number) var-number)))) + +#+clasp-working +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function frame-number))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (core:compile-form-and-eval-with-env form env))) + +#+clasp-working +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +#+clasp-working +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + + +;;;; Definitions + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from CLASP point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun translate-location (location) + (make-location (list :file (namestring (ext:source-location-pathname location))) + (list :position (ext:source-location-offset location)) + '(:align t))) + +(defimplementation find-definitions (name) + (loop for kind in ext:*source-location-kinds* + for locations = (ext:source-location name kind) + when locations + nconc (loop for location in locations + collect (list kind (translate-location location))))) + +(defun source-location (object) + (let ((location (ext:source-location object t))) + (when location + (translate-location (car location))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + + +;;;; Profiling + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Threads + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-lock :name name :recursive t)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock)) + (cvar (mp:make-condition-variable)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp: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)) + (mutex (mailbox.mutex mbox))) + (mp:with-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:condition-variable-timedwait (mailbox.cvar mbox) + mutex + 0.2))))) + + ) ; #+threads (progn ... + + +(defmethod emacs-inspect ((object core:cxx-object)) + (let ((encoded (core:encode object))) + (loop for (key . value) in encoded + append (list (string key) ": " (list :value value) (list :newline))))) diff --git a/vim/bundle/slimv/slime/swank/clisp.lisp b/vim/bundle/slimv/slime/swank/clisp.lisp new file mode 100644 index 0000000..27ae688 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/clisp.lisp @@ -0,0 +1,930 @@ +;;;; -*- indent-tabs-mode: nil -*- + +;;;; SWANK support for CLISP. + +;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach + +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License as +;;;; published by the Free Software Foundation; either version 2 of +;;;; the License, or (at your option) any later version. + +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. + +;;;; You should have received a copy of the GNU General Public +;;;; License along with this program; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;;;; MA 02111-1307, USA. + +;;; This is work in progress, but it's already usable. Many things +;;; are adapted from other swank-*.lisp, in particular from +;;; swank-allegro (I don't use allegro at all, but it's the shortest +;;; one and I found Helmut Eller's code there enlightening). + +;;; This code will work better with recent versions of CLISP (say, the +;;; last release or CVS HEAD) while it may not work at all with older +;;; versions. It is reasonable to expect it to work on platforms with +;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like +;;; systems, but also on Win32. This backend uses the portable xref +;;; from the CMU AI repository and metering.lisp from CLOCC [1], which +;;; are conveniently included in SLIME. + +;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ + +(defpackage swank/clisp + (:use cl swank/backend)) + +(in-package swank/clisp) + +(eval-when (:compile-toplevel) + (unless (string< "2.44" (lisp-implementation-version)) + (error "Need at least CLISP version 2.44"))) + +(defimplementation gray-package-name () + "GRAY") + +;;;; if this lisp has the complete CLOS then we use it, otherwise we +;;;; build up a "fake" swank-mop and then override the methods in the +;;;; inspector. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *have-mop* + (and (find-package :clos) + (eql :external + (nth-value 1 (find-symbol (string ':standard-slot-definition) + :clos)))) + "True in those CLISP images which have a complete MOP implementation.")) + +#+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or)) +(progn + (import-swank-mop-symbols :clos '(:slot-definition-documentation)) + + (defun swank-mop:slot-definition-documentation (slot) + (clos::slot-definition-documentation slot))) + +#-#.(cl:if swank/clisp::*have-mop* '(and) '(or)) +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +(let ((getpid (or (find-symbol "PROCESS-ID" :system) + ;; old name prior to 2005-03-01, clisp <= 2.33.2 + (find-symbol "PROGRAM-ID" :system) + #+win32 ; integrated into the above since 2005-02-24 + (and (find-package :win32) ; optional modules/win32 + (find-symbol "GetCurrentProcessId" :win32))))) + (defimplementation getpid () ; a required interface + (cond + (getpid (funcall getpid)) + #+win32 ((ext:getenv "PID")) ; where does that come from? + (t -1)))) + +(defimplementation call-with-user-break-handler (handler function) + (handler-bind ((system::simple-interrupt-condition + (lambda (c) + (declare (ignore c)) + (funcall handler) + (when (find-restart 'socket-status) + (invoke-restart (find-restart 'socket-status))) + (continue)))) + (funcall function))) + +(defimplementation lisp-implementation-type-name () + "clisp") + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) directory) + (namestring (setf *default-pathname-defaults* (ext:default-directory)))) + +(defimplementation filename-to-pathname (string) + (cond ((member :cygwin *features*) + (parse-cygwin-filename string)) + (t (parse-namestring string)))) + +(defun parse-cygwin-filename (string) + (multiple-value-bind (match _ drive absolute) + (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) + (declare (ignore _)) + (assert (and match (if drive absolute t)) () + "Invalid filename syntax: ~a" string) + (let* ((sans-prefix (subseq string (regexp:match-end match))) + (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) + (path (loop for name in path collect + (cond ((equal name "..") ':back) + (t name)))) + (directoryp (or (equal string "") + (find (aref string (1- (length string))) "\\/")))) + (multiple-value-bind (file type) + (cond ((and (not directoryp) (last path)) + (let* ((file (car (last path))) + (pos (position #\. file :from-end t))) + (cond ((and pos (> pos 0)) + (values (subseq file 0 pos) + (subseq file (1+ pos)))) + (t file))))) + (make-pathname :host nil + :device nil + :directory (cons + (if absolute :absolute :relative) + (let ((path (if directoryp + path + (butlast path)))) + (if drive + (cons + (regexp:match-string string drive) + path) + path))) + :name file + :type type))))) + +;;;; UTF + +(defimplementation string-to-utf8 (string) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-to-bytes string enc))) + +(defimplementation utf8-to-string (octets) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-from-bytes octets enc))) + +;;;; TCP Server + +(defimplementation create-socket (host port &key backlog) + (socket:socket-server port :interface host :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:socket-server-port socket)) + +(defimplementation close-socket (socket) + (socket:socket-server-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (socket:socket-accept socket + :buffered buffering ;; XXX may not work if t + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +#-win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout + (socket:socket-status streams 0 0) + (return (loop for (s nil . x) in streams + if x collect s))) + (t + (with-simple-restart (socket-status "Return from socket-status.") + (socket:socket-status streams 0 500000)) + (let ((ready (loop for (s nil . x) in streams + if x collect s))) + (when ready (return ready)))))))) + +#+win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (t + (let ((ready (remove-if-not #'input-available-p streams))) + (when ready (return ready))) + (when timeout (return nil)) + (sleep 0.1))))) + +#+win32 +;; Some facts to remember (for the next time we need to debug this): +;; - interactive-sream-p returns t for socket-streams +;; - listen returns nil for socket-streams +;; - (type-of ) is 'stream +;; - (type-of *terminal-io*) is 'two-way-stream +;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8) +;; - calling socket:socket-status on non sockets signals an error, +;; but seems to mess up something internally. +;; - calling read-char-no-hang on sockets does not signal an error, +;; but seems to mess up something internally. +(defun input-available-p (stream) + (case (stream-element-type stream) + (character + (let ((c (read-char-no-hang stream nil nil))) + (cond ((not c) + nil) + (t + (unread-char c stream) + t)))) + (t + (eq (socket:socket-status (cons stream :input) 0 0) + :input)))) + +;;;; Coding systems + +(defvar *external-format-to-coding-system* + '(((:charset "iso-8859-1" :line-terminator :unix) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ((:charset "iso-8859-1") + "latin-1" "iso-latin-1" "iso-8859-1") + ((:charset "utf-8") "utf-8") + ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") + ((:charset "euc-jp") "euc-jp") + ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") + ((:charset "us-ascii") "us-ascii") + ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((args (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*)))) + (and args (apply #'ext:make-encoding args)))) + + +;;;; Swank functions + +(defimplementation arglist (fname) + (block nil + (or (ignore-errors + (let ((exp (function-lambda-expression fname))) + (and exp (return (second exp))))) + (ignore-errors + (return (ext:arglist fname))) + :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ext:expand-form form)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result ())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push :variable (when (boundp symbol) (doc 'variable))) + (when (fboundp symbol) + (maybe-push + ;; Report WHEN etc. as macros, even though they may be + ;; implemented as special operators. + (if (macro-function symbol) :macro + (typecase (fdefinition symbol) + (generic-function :generic-function) + (function :function) + ;; (type-of 'progn) -> ext:special-operator + (t :special-operator))) + (doc 'function))) + (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) + (get symbol 'system::setf-expander)); defsetf + (maybe-push :setf (doc 'setf))) + (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp + (get symbol 'system::defstruct-description) + (get symbol 'system::deftype-expander)) + (maybe-push :type (doc 'type))) ; even for 'structure + (when (find-class symbol nil) + (maybe-push :class (doc 'type))) + ;; Let this code work compiled in images without FFI + (let ((types (load-time-value + (and (find-package "FFI") + (symbol-value + (find-symbol "*C-TYPE-TABLE*" "FFI")))))) + ;; Use ffi::*c-type-table* so as not to suffer the overhead of + ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols + ;; which are not FFI type names. + (when (and types (nth-value 1 (gethash symbol types))) + ;; Maybe use (case (head (ffi:deparse-c-type))) + ;; to distinguish struct and union types? + (maybe-push :alien-type :not-documented))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable (describe symbol)) + (:macro (describe (macro-function symbol))) + (: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)))) + +(defun fspec-pathname (spec) + (let ((path spec) + type + lines) + (when (consp path) + (psetq type (car path) + path (cadr path) + lines (cddr path))) + (when (and path + (member (pathname-type path) + custom:*compiled-file-types* :test #'equal)) + (setq path + (loop for suffix in custom:*source-file-types* + thereis (probe-file (make-pathname :defaults path + :type suffix))))) + (values path type lines))) + +(defun fspec-location (name fspec) + (multiple-value-bind (file type lines) + (fspec-pathname fspec) + (list (if type (list name type) name) + (cond (file + (multiple-value-bind (truename c) + (ignore-errors (truename file)) + (cond (truename + (make-location + (list :file (namestring truename)) + (if (consp lines) + (list* :line lines) + (list :function-name (string name))) + (when (consp type) + (list :snippet (format nil "~A" type))))) + (t (list :error (princ-to-string c)))))) + (t (list :error + (format nil "No source information available for: ~S" + fspec))))))) + +(defimplementation find-definitions (name) + (mapcar #'(lambda (e) (fspec-location name e)) + (documentation name 'sys::file))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defvar *sldb-backtrace*) + +(defun sldb-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (let* ((modes '((:all-stack-elements 1) + (:all-frames 2) + (:only-lexical-frames 3) + (:only-eval-and-apply-frames 4) + (:only-apply-frames 5))) + (mode (cadr (assoc :all-stack-elements modes)))) + (do ((frames '()) + (last nil frame) + (frame (sys::the-frame) + (sys::frame-up 1 frame mode))) + ((eq frame last) (nreverse frames)) + (unless (boring-frame-p frame) + (push frame frames))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(sys::*break-count* (1+ sys::*break-count*)) + ;;(sys::*driver* debugger-loop-fn) + ;;(sys::*fasoutput-stream* nil) + (*sldb-backtrace* + (let* ((f (sys::the-frame)) + (bt (sldb-backtrace)) + (rest (member f bt))) + (if rest (nthcdr 8 rest) bt)))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index *sldb-backtrace*)) + +(defun boring-frame-p (frame) + (member (frame-type frame) '(stack-value bind-var bind-env + compiled-tagbody compiled-block))) + +(defun frame-to-string (frame) + (with-output-to-string (s) + (sys::describe-frame s frame))) + +(defun frame-type (frame) + ;; FIXME: should bind *print-length* etc. to small values. + (frame-string-type (frame-to-string frame))) + +;; FIXME: they changed the layout in 2.44 and not all patterns have +;; been updated. +(defvar *frame-prefixes* + '(("\\[[0-9]\\+\\] frame binding variables" bind-var) + ("<1> # # # " fun) + ("<2> " 2nd-frame) + )) + +(defun frame-string-type (string) + (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) + *frame-prefixes*))) + +(defimplementation compute-backtrace (start end) + (let* ((bt *sldb-backtrace*) + (len (length bt))) + (loop for f in (subseq bt start (min (or end len) len)) + collect f))) + +(defimplementation print-frame (frame stream) + (let* ((str (frame-to-string frame))) + (write-string (extract-frame-line str) + stream))) + +(defun extract-frame-line (frame-string) + (let ((s frame-string)) + (trim-whitespace + (case (frame-string-type s) + ((eval special-op) + (string-match "EVAL frame .*for form \\(.*\\)" s 1)) + (apply + (string-match "APPLY frame for call \\(.*\\)" s 1)) + ((compiled-fun sys-fun fun) + (extract-function-name s)) + (t s))))) + +(defun extract-function-name (string) + (let ((1st (car (split-frame-string string)))) + (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>") + 1st + 1) + (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1) + 1st))) + +(defun split-frame-string (string) + (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)" + (mapcar #'car *frame-prefixes*)))) + (loop for pos = 0 then (1+ (regexp:match-start match)) + for match = (regexp:match rx string :start pos) + if match collect (subseq string pos (regexp:match-start match)) + else collect (subseq string pos) + while match))) + +(defun string-match (pattern string n) + (let* ((match (nth-value n (regexp:match pattern string)))) + (if match (regexp:match-string string match)))) + +(defimplementation eval-in-frame (form frame-number) + (sys::eval-at (nth-frame frame-number) form)) + +(defimplementation frame-locals (frame-number) + (let ((frame (nth-frame frame-number))) + (loop for i below (%frame-count-vars frame) + collect (list :name (%frame-var-name frame i) + :value (%frame-var-value frame i) + :id 0)))) + +(defimplementation frame-var-value (frame var) + (%frame-var-value (nth-frame frame) var)) + +;;; Interpreter-Variablen-Environment has the shape +;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). + +(defun %frame-count-vars (frame) + (cond ((sys::eval-frame-p frame) + (do ((venv (frame-venv frame) (next-venv venv)) + (count 0 (+ count (/ (1- (length venv)) 2)))) + ((not venv) count))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (length (%parse-stack-values frame))) + (t 0))) + +(defun %frame-var-name (frame i) + (cond ((sys::eval-frame-p frame) + (nth-value 0 (venv-ref (frame-venv frame) i))) + (t (format nil "~D" i)))) + +(defun %frame-var-value (frame i) + (cond ((sys::eval-frame-p frame) + (let ((name (venv-ref (frame-venv frame) i))) + (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) + (if c + (format-sldb-condition c) + v)))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (let ((str (nth i (%parse-stack-values frame)))) + (trim-whitespace (subseq str 2)))) + (t (break "Not implemented")))) + +(defun frame-venv (frame) + (let ((env (sys::eval-at frame '(sys::the-environment)))) + (svref env 0))) + +(defun next-venv (venv) (svref venv (1- (length venv)))) + +(defun venv-ref (env i) + "Reference the Ith binding in ENV. +Return two values: NAME and VALUE" + (let ((idx (* i 2))) + (if (< idx (1- (length env))) + (values (svref env idx) (svref env (1+ idx))) + (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) + +(defun %parse-stack-values (frame) + (labels ((next (fp) (sys::frame-down 1 fp 1)) + (parse (fp accu) + (let ((str (frame-to-string fp))) + (cond ((is-prefix-p "- " str) + (parse (next fp) (cons str accu))) + ((is-prefix-p "<1> " str) + ;;(when (eq (frame-type frame) 'compiled-fun) + ;; (pop accu)) + (dolist (str (cdr (split-frame-string str))) + (when (is-prefix-p "- " str) + (push str accu))) + (nreverse accu)) + (t (parse (next fp) accu)))))) + (parse (next frame) '()))) + +(defun is-prefix-p (regexp string) + (if (regexp:match (concatenate 'string "^" regexp) string) t)) + +(defimplementation return-from-frame (index form) + (sys::return-from-eval-frame (nth-frame index) form)) + +(defimplementation restart-frame (index) + (sys::redo-eval-frame (nth-frame index))) + +(defimplementation frame-source-location (index) + `(:error + ,(format nil "frame-source-location not implemented. (frame: ~A)" + (nth-frame index)))) + +;;;; Profiling + +(defimplementation profile (fname) + (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-monitor:monitor-all package)) + +;;;; Handle compiler conditions (find out location of error etc.) + +(defmacro compile-file-frobbing-notes ((&rest args) &body body) + "Pass ARGS to COMPILE-FILE, send the compiler notes to +*STANDARD-INPUT* and frob them in BODY." + `(let ((*error-output* (make-string-output-stream)) + (*compile-verbose* t)) + (multiple-value-prog1 + (compile-file ,@args) + (handler-case + (with-input-from-string + (*standard-input* (get-output-stream-string *error-output*)) + ,@body) + (sys::simple-end-of-file () nil))))) + +(defvar *orig-c-warn* (symbol-function 'system::c-warn)) +(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) +(defvar *orig-c-error* (symbol-function 'system::c-error)) +(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) + +(defmacro dynamic-flet (names-functions &body body) + "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) +Execute BODY with NAME's function slot set to FUNCTION." + `(ext:letf* ,(loop for (name function) in names-functions + collect `((symbol-function ',name) ,function)) + ,@body)) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) + +(defun compiler-note-location () + "Return the current compiler location." + (let ((lineno1 sys::*compile-file-lineno1*) + (lineno2 sys::*compile-file-lineno2*) + (file sys::*compile-file-truename*)) + (cond ((and file lineno1 lineno2) + (make-location (list ':file (namestring file)) + (list ':line lineno1))) + (*buffer-name* + (make-location (list ':buffer *buffer-name*) + (list ':offset *buffer-offset* 0))) + (t + (list :error "No error location available"))))) + +(defun signal-compiler-warning (cstring args severity orig-fn) + (signal 'compiler-condition + :severity severity + :message (apply #'format nil cstring args) + :location (compiler-note-location)) + (apply orig-fn cstring args)) + +(defun c-warn (cstring &rest args) + (signal-compiler-warning cstring args :warning *orig-c-warn*)) + +(defun c-style-warn (cstring &rest args) + (dynamic-flet ((sys::c-warn *orig-c-warn*)) + (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) + +(defun c-error (&rest args) + (signal 'compiler-condition + :severity :error + :message (apply #'format nil + (if (= (length args) 3) + (cdr args) + args)) + :location (compiler-note-location)) + (apply *orig-c-error* args)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-notification-condition)) + (dynamic-flet ((system::c-warn #'c-warn) + (system::c-style-warn #'c-style-warn) + (system::c-error #'c-error)) + (funcall function)))) + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (princ-to-string condition) + :location (compiler-note-location))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (with-compilation-unit () + (multiple-value-bind (fasl-file warningsp failurep) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values fasl-file warningsp + (or failurep + (and load-p + (not (load fasl-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Portable XREF from the CMU AI repository. + +(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 (fspec-location symbol symbol) xrefs)) + xrefs)) + +(when (find-package :swank-loader) + (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader)) + (lambda () + (let ((home (user-homedir-pathname))) + (and (ext:probe-directory home) + (probe-file (format nil "~A/.swank.lisp" + (namestring (truename home))))))))) + +;;; Don't set *debugger-hook* to nil on break. +(ext:without-package-lock () + (defun break (&optional (format-string "Break") &rest args) + (if (not sys::*use-clcs*) + (progn + (terpri *error-output*) + (apply #'format *error-output* + (concatenate 'string "*** - " format-string) + args) + (funcall ext:*break-driver* t)) + (let ((condition + (make-condition 'simple-condition + :format-control format-string + :format-arguments args)) + ;;(*debugger-hook* nil) + ;; Issue 91 + ) + (ext:with-restarts + ((continue + :report (lambda (stream) + (format stream (sys::text "Return from ~S loop") + 'break)) + ())) + (with-condition-restarts condition (list (find-restart 'continue)) + (invoke-debugger condition))))) + nil)) + +;;;; Inspecting + +(defmethod emacs-inspect ((o t)) + (let* ((*print-array* nil) (*print-pretty* t) + (*print-circle* t) (*print-escape* t) + (*print-lines* custom:*inspect-print-lines*) + (*print-level* custom:*inspect-print-level*) + (*print-length* custom:*inspect-print-length*) + (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) + (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) + (*package* tmp-pack) + (sys::*inspect-unbound-value* (intern "#" tmp-pack))) + (let ((inspection (sys::inspect-backend o))) + (append (list + (format nil "~S~% ~A~{~%~A~}~%" o + (sys::insp-title inspection) + (sys::insp-blurb inspection))) + (loop with count = (sys::insp-num-slots inspection) + for i below count + append (multiple-value-bind (value name) + (funcall (sys::insp-nth-slot inspection) + i) + `((:value ,name) " = " (:value ,value) + (:newline)))))))) + +(defimplementation quit-lisp () + #+lisp=cl (ext:quit) + #-lisp=cl (lisp:quit)) + + +(defimplementation preferred-communication-style () + nil) + +;;; FIXME +;;; +;;; Clisp 2.48 added experimental support for threads. Basically, you +;;; can use :SPAWN now, BUT: +;;; +;;; - there are problems with GC, and threads stuffed into weak +;;; hash-tables as is the case for *THREAD-PLIST-TABLE*. +;;; +;;; See test case at +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429 +;;; +;;; Even though said to be fixed, it's not: +;;; +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443 +;;; +;;; - The DYNAMIC-FLET above is an implementation technique that's +;;; probably not sustainable in light of threads. This got to be +;;; rewritten. +;;; +;;; TCR (2009-07-30) + +#+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) +(progn + (defimplementation spawn (fn &key name) + (mp:make-thread fn :name name)) + + (defvar *thread-plist-table-lock* + (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK")) + + (defvar *thread-plist-table* (make-hash-table :weak :key) + "A hashtable mapping threads to a plist.") + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (mp:with-mutex-lock (*thread-plist-table-lock*) + (or (getf (gethash thread *thread-plist-table*) 'thread-id) + (setf (getf (gethash thread *thread-plist-table*) 'thread-id) + (incf *thread-id-counter*))))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plist-table*) 'thread-id)))) + + (defimplementation thread-name (thread) + ;; To guard against returning #. + (princ-to-string (mp:thread-name thread))) + + (defimplementation thread-status (thread) + (if (thread-alive-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-mutex :name name :recursive-p t)) + + (defimplementation call-with-lock-held (lock function) + (mp:with-mutex-lock (lock) + (funcall function))) + + (defimplementation current-thread () + (mp:current-thread)) + + (defimplementation all-threads () + (mp:list-threads)) + + (defimplementation interrupt-thread (thread fn) + (mp:thread-interrupt thread :function fn)) + + (defimplementation kill-thread (thread) + (mp:thread-interrupt thread :function t)) + + (defimplementation thread-alive-p (thread) + (mp:thread-active-p thread)) + + (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK")) + (defvar *mailboxes* (list)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-lock :name "MAILBOX.LOCK")) + (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-mutex-lock (*mailboxes-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)) + (lock (mailbox.lock mbox))) + (mp:with-mutex-lock (lock) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:exemption-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (lock (mailbox.lock mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-mutex-lock (lock) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2)))))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation save-image (filename &optional restart-function) + (let ((args `(,filename + ,@(if restart-function + `((:init-function ,restart-function)))))) + (apply #'ext:saveinitmem args))) diff --git a/vim/bundle/slimv/slime/swank/cmucl.lisp b/vim/bundle/slimv/slime/swank/cmucl.lisp new file mode 100644 index 0000000..12d4282 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/cmucl.lisp @@ -0,0 +1,2470 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; License: Public Domain +;;; +;;;; Introduction +;;; +;;; This is the CMUCL implementation of the `swank/backend' package. + +(defpackage swank/cmucl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache + fwrappers)) + +(in-package swank/cmucl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (let ((min-version #x20c)) + (assert (>= c:byte-fasl-file-version min-version) + () "This file requires CMUCL version ~x or newer" min-version)) + + (require 'gray-streams)) + + +(import-swank-mop-symbols :pcl '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +;;; UTF8 + +(locally (declare (optimize (ext:inhibit-warnings 3))) + ;; Compile and load the utf8 format, if not already loaded. + (stream::find-external-format :utf-8)) + +(defimplementation string-to-utf8 (string) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:string-to-octets string :external-format ef))) + +(defimplementation utf8-to-string (octets) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:octets-to-string octets :external-format ef))) + + +;;;; TCP server +;;; +;;; In CMUCL we support all communication styles. By default we use +;;; `:SIGIO' because it is the most responsive, but it's somewhat +;;; dangerous: CMUCL is not in general "signal safe", and you don't +;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and +;;; `:SPAWN' are reasonable alternatives. + +(defimplementation preferred-communication-style () + :sigio) + +#-(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (let* ((addr (resolve-hostname host)) + (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) + (ext:htonl addr) + addr))) + (ext:create-inet-listener port :stream :reuse-address t :host addr + :backlog (or backlog 5)))) + +;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. +#+(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (declare (ignore host)) + (ext:create-inet-listener port :stream :reuse-address t)) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (let ((fd (socket-fd socket))) + (sys:invalidate-descriptor fd) + (ext:close-socket fd))) + +(defimplementation accept-connection (socket &key + external-format buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (ext:accept-tcp-connection socket) + (ecase buffering + ((t) :full) + (:line :line) + ((nil) :none)) + external-format)) + +;;;;; Sockets + +(defimplementation socket-fd (socket) + "Return the filedescriptor for the socket represented by SOCKET." + (etypecase socket + (fixnum socket) + (sys:fd-stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of HOSTNAME as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "iso-latin-1-unix") + #+unicode + (:utf-8 "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd buffering external-format) + "Create a new input/output fd-stream for FD." + (cond (external-format + (sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering buffering + :external-format external-format)) + (t + (sys:make-fd-stream fd :input t :output t + :element-type '(unsigned-byte 8) + :buffering buffering)))) + +(defimplementation make-fd-stream (fd external-format) + (make-socket-io-stream fd :full external-format)) + +(defimplementation dup (fd) + (multiple-value-bind (clone error) (unix:unix-dup fd) + (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error))) + clone)) + +(defimplementation command-line-args () + ext:*command-line-strings*) + +(defimplementation exec-image (image-file args) + (multiple-value-bind (ok error) + (unix:unix-execve (car (command-line-args)) + (list* (car (command-line-args)) + "-core" image-file + "-noinit" + args)) + (error "~a" (unix:get-unix-error-msg error)) + ok)) + +;;;;; Signal-driven I/O + +(defimplementation install-sigint-handler (function) + (sys:enable-interrupt :sigint (lambda (signal code scp) + (declare (ignore signal code scp)) + (funcall function)))) + +(defvar *sigio-handlers* '() + "List of (key . function) pairs. +All functions are called on SIGIO, and the key is used for removing +specific functions.") + +(defun reset-sigio-handlers () (setq *sigio-handlers* '())) +;; All file handlers are invalid afer reload. +(pushnew 'reset-sigio-handlers ext:*after-save-initializations*) + +(defun set-sigio-handler () + (sys:enable-interrupt :sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc #'funcall (mapcar #'cdr *sigio-handlers*))) + +(defun fcntl (fd command arg) + "fcntl(2) - manipulate a file descriptor." + (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg) + (cond (ok) + (t (error "fcntl: ~A" (unix:get-unix-error-msg error)))))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (fcntl fd unix:f-setown (unix:unix-getpid)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logior old-flags unix:fasync))) + (assert (not (assoc fd *sigio-handlers*))) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (when (assoc fd *sigio-handlers*) + (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync))) + (sys:invalidate-descriptor fd)) + (assert (not (assoc fd *sigio-handlers*))) + (when (null *sigio-handlers*) + (sys:default-interrupt :sigio)))) + +;;;;; SERVE-EVENT + +(defimplementation add-fd-handler (socket fn) + (let ((fd (socket-fd socket))) + (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn))))) + +(defimplementation remove-fd-handlers (socket) + (sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (let ((ready (remove-if-not #'listen streams))) + (when ready (return ready))) + (when timeout (return nil)) + (multiple-value-bind (in out) (make-pipe) + (let* ((f (constantly t)) + (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams)) + collect (add-one-shot-handler s f)))) + (unwind-protect + (let ((*interrupt-queued-handler* (lambda () + (write-char #\! out)))) + (when (check-slime-interrupts) (return :interrupt)) + (sys:serve-event)) + (mapc #'sys:remove-fd-handler handlers) + (close in) + (close out)))))) + +(defun to-fd-stream (stream) + (etypecase stream + (sys:fd-stream stream) + (synonym-stream + (to-fd-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (to-fd-stream (two-way-stream-input-stream stream))))) + +(defun add-one-shot-handler (stream function) + (let (handler) + (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input + (lambda (fd) + (declare (ignore fd)) + (sys:remove-fd-handler handler) + (funcall function stream)))))) + +(defun make-pipe () + (multiple-value-bind (in out) (unix:unix-pipe) + (values (sys:make-fd-stream in :input t :buffering :none) + (sys:make-fd-stream out :output t :buffering :none)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + "EXT") + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. +NIL if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (clear-xref-info input-file) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (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-start-position* position) + (*buffer-substring* string) + (source-info (list :emacs-buffer buffer + :emacs-buffer-offset position + :emacs-buffer-string string))) + (with-input-from-string (stream string) + (let ((failurep (ext:compile-from-stream stream :source-info + source-info))) + (not failurep)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `SWANK:COMPILER-CONDITION's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (compiler-condition-message condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of CONDITION." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun compiler-condition-message (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe context information for Emacs." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~ + ~@[==>~{~&~A~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. +Return a `location' record, or (:error REASON) on failure." + (if (null context) + (note-error-location) + (with-struct (c::compiler-error-context- file-name + original-source + original-source-path) context + (or (locate-compiler-note file-name original-source + (reverse original-source-path)) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (cond (*compile-file-truename* + (make-location (list :file (unix-truename *compile-file-truename*)) + (list :eof))) + (*buffer-name* + (make-location (list :buffer *buffer-name*) + (list :position *buffer-start-position*))) + (t (list :error "No error location available.")))) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + +;;;; XREF +;;; +;;; Cross-reference support is based on the standard CMUCL `XREF' +;;; package. This package has some caveats: XREF information is +;;; recorded during compilation and not preserved in fasl files, and +;;; XREF recording is disabled by default. Redefining functions can +;;; also cause duplicate references to accumulate, but +;;; `swank-compile-file' will automatically clear out any old records +;;; from the same filename. +;;; +;;; To enable XREF recording, set `c:*record-xref-info*' to true. To +;;; clear out the XREF database call `xref:init-xref-database'. + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls xref:who-calls) +(defxref who-references xref:who-references) +(defxref who-binds xref:who-binds) +(defxref who-sets xref:who-sets) + +;;; More types of XREF information were added since 18e: +;;; + +(defxref who-macroexpands xref:who-macroexpands) +;; XXX +(defimplementation who-specializes (symbol) + (let* ((methods (xref::who-specializes (find-class symbol))) + (locations (mapcar #'method-location methods))) + (mapcar #'list methods locations))) + +(defun xref-results (contexts) + (mapcar (lambda (xref) + (list (xref:xref-context-name xref) + (resolve-xref-location xref))) + contexts)) + +(defun resolve-xref-location (xref) + (let ((name (xref:xref-context-name xref)) + (file (xref:xref-context-file xref)) + (source-path (xref:xref-context-source-path xref))) + (cond ((and file source-path) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (unix-truename file)) + (list :position (1+ position))))) + (file + (make-location (list :file (unix-truename file)) + (list :function-name (string name)))) + (t + `(:error ,(format nil "Unknown source location: ~S ~S ~S " + name file source-path)))))) + +(defun clear-xref-info (namestring) + "Clear XREF notes pertaining to NAMESTRING. +This is a workaround for a CMUCL bug: XREF records are cumulative." + (when c:*record-xref-info* + (let ((filename (truename namestring))) + (dolist (db (list xref::*who-calls* + xref::*who-is-called* + xref::*who-macroexpands* + xref::*who-references* + xref::*who-binds* + xref::*who-sets*)) + (maphash (lambda (target contexts) + ;; XXX update during traversal? + (setf (gethash target db) + (delete filename contexts + :key #'xref:xref-context-file + :test #'equalp))) + db))))) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t)) + (map-cpool (code fun) + (declare (type kernel:code-component code) (type function fun)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data code) + do (funcall fun (kernel:code-header-ref code i)))) + + (callees (fun) + (let ((callees (make-stack))) + (map-cpool (vm::find-code-object fun) + (lambda (o) + (when (kernel:fdefn-p o) + (vector-push-extend (kernel:fdefn-function o) + callees)))) + (coerce callees 'list))) + + (callers (fun) + (declare (function fun)) + (let ((callers (make-stack))) + (ext:gc :full t) + ;; scan :dynamic first to avoid the need for even more gcing + (dolist (space '(:dynamic :read-only :static)) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum header) (ignore size)) + (when (= vm:code-header-type header) + (map-cpool obj + (lambda (c) + (when (and (kernel:fdefn-p c) + (eq (kernel:fdefn-function c) fun)) + (vector-push-extend obj callers)))))) + space) + (ext:gc)) + (coerce callers 'list))) + + (entry-points (code) + (loop for entry = (kernel:%code-entry-points code) + then (kernel::%function-next entry) + while entry + collect entry)) + + (guess-main-entry-point (entry-points) + (or (find-if (lambda (fun) + (ext:valid-function-name-p + (kernel:%function-name fun))) + entry-points) + (car entry-points))) + + (fun-dspec (fun) + (list (kernel:%function-name fun) (function-location fun))) + + (code-dspec (code) + (let ((eps (entry-points code)) + (di (kernel:%code-debug-info code))) + (cond (eps (fun-dspec (guess-main-entry-point eps))) + (di (list (c::debug-info-name di) + (debug-info-function-name-location di))) + (t (list (princ-to-string code) + `(:error "No src-loc available"))))))) + (declare (inline map-cpool)) + + (defimplementation list-callers (symbol) + (mapcar #'code-dspec (callers (coerce symbol 'function) ))) + + (defimplementation list-callees (symbol) + (mapcar #'fun-dspec (callees symbol)))) + +(defun test-list-callers (count) + (let ((funsyms '())) + (do-all-symbols (s) + (when (and (fboundp s) + (functionp (symbol-function s)) + (not (macro-function s)) + (not (special-operator-p s))) + (push s funsyms))) + (let ((len (length funsyms))) + (dotimes (i count) + (let ((sym (nth (random len) funsyms))) + (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym)))))))) + +;; (test-list-callers 100) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the CMUCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. +This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute BODY and return the source-location it returns. +If an error occurs and `*debug-definition-finding*' is false, then +return an error pseudo-location. + +The second return value is NIL if no error occurs, otherwise it is the +condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values `(:error ,(trim-whitespace (princ-to-string c))) + c)))))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for CODE-LOCATION." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for CODE-LOCATION in FILENAME." + (let* ((code-date (di:debug-source-created debug-source)) + (root-number (di:debug-source-root-number debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s root-number))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a CODE-LOCATION from a stream. +This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for DEBUG-INFO. +Function-name source-locations are a fallback for when precise +positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location? +This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream root) + "Return the byte offset of CODE-LOCATION in STREAM. Extract the +toplevel-form-number and form-number from CODE-LOCATION and use that +to find the position of the corresponding form. + +Finish with STREAM positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (- (di:code-location-top-level-form-offset location) + root)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in STREAM. +TLF-NUMBER is the top-level-form number. +FORM-NUMBER is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of CODE-LOCATION in STRING. +See CODE-LOCATION-STREAM-POSITION." + (with-input-from-string (s string) + (code-location-stream-position code-location s 0))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name) + (template-definitions name) + (primitive-definitions name) + (vm-support-routine-definitions name) + )) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; CMUCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the CMUCL manual for more details. + +(defun function-definitions (name) + "Return definitions for NAME in the \"function namespace\", i.e., +regular functions, generic functions, methods and macros. +NAME can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (function? (and (ext:valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (gf-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for FUNCTION." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + +(defun byte-function-location (fun) + "Return the location of the byte-compiled function FUN." + (etypecase fun + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((di (kernel:%code-debug-info (c::byte-function-component fun)))) + (if di + (debug-info-function-name-location di) + `(:error + ,(format nil "Byte-function without debug-info: ~a" fun))))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fun))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is FUNCTION a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that FUNCTION belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + (let ((ctor (struct-constructor dd))) + (cond (ctor + (function-location (coerce ctor 'function))) + (t + (let ((name (kernel:dd-name dd))) + (multiple-value-bind (location foundp) + (ext:info :source-location :defvar name) + (cond (foundp + (resolve-source-location location)) + (t + (error "No location for defstruct: ~S" name))))))))) + +(defun struct-constructor (dd) + "Return the name of the constructor from a defstruct definition." + (let* ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (if (consp constructor) (car constructor) constructor))) + +;;;;;; Generic functions and methods + +(defun gf-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (pcl::generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (pcl::generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (pcl:method-generic-function method)) + (name (pcl:generic-function-name gf)) + (specializers (pcl:method-specializers method)) + (qualifiers (pcl:method-qualifiers method))) + `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers)))) + +(defun method-location (method) + (typecase method + (pcl::standard-accessor-method + (definition-source-location + (cond ((pcl::definition-source method) + method) + (t + (pcl::slot-definition-class + (pcl::accessor-method-slot-definition method)))) + (pcl::accessor-method-slot-name method))) + (t + (function-location (or (pcl::method-fast-function method) + (pcl:method-function method)))))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (kernel::find-class name nil))) + (etypecase class + (null '()) + (kernel::structure-class + (list (list `(defstruct ,name) (dd-location (find-dd name))))) + #+(or) + (conditions::condition-class + (list (list `(define-condition ,name) + (condition-class-location class)))) + (kernel::standard-class + (list (list `(defclass ,name) + (pcl-class-location (find-class name))))) + ((or kernel::built-in-class + conditions::condition-class + kernel:funcallable-structure-class) + (list (list `(class ,name) (class-location class)))))))) + +(defun pcl-class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (pcl:class-name class))) + +;; FIXME: eval used for backward compatibility. +(defun class-location (class) + (declare (type kernel::class class)) + (let ((name (kernel:%class-name class))) + (multiple-value-bind (loc found?) + (let ((x (ignore-errors + (multiple-value-list + (eval `(ext:info :source-location :class ',name)))))) + (values-list x)) + (cond (found? (resolve-source-location loc)) + (`(:error + ,(format nil "No location recorded for class: ~S" name))))))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((slots (conditions::condition-class-slots class)) + (name (conditions::condition-class-name class))) + (cond ((null slots) + `(:error ,(format nil "No location info for condition: ~A" name))) + (t + ;; Find the class via one of its slot-reader methods. + (let* ((slot (first slots)) + (gf (fdefinition + (first (conditions::condition-slot-readers slot))))) + (method-location + (first + (pcl:compute-applicable-methods-using-classes + gf (list (find-class name)))))))))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun source-location-form-numbers (location) + (c::decode-form-numbers (c::form-numbers-form-numbers location))) + +(defun source-location-tlf-number (location) + (nth-value 0 (source-location-form-numbers location))) + +(defun source-location-form-number (location) + (nth-value 1 (source-location-form-numbers location))) + +(defun resolve-file-source-location (location) + (let ((filename (c::file-source-location-pathname location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + (with-open-file (s filename) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:file ,(unix-truename filename)) + `(:position ,(1+ pos))))))) + +(defun resolve-stream-source-location (location) + (let ((info (c::stream-source-location-user-info location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + ;; XXX duplication in frame-source-location + (assert (info-from-emacs-buffer-p info)) + (destructuring-bind (&key emacs-buffer emacs-buffer-string + emacs-buffer-offset) info + (with-input-from-string (s emacs-buffer-string) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-buffer-offset ,pos))))))) + +;; XXX predicates for 18e backward compatibilty. Remove them when +;; we're 19a only. +(defun file-source-location-p (object) + (when (fboundp 'c::file-source-location-p) + (c::file-source-location-p object))) + +(defun stream-source-location-p (object) + (when (fboundp 'c::stream-source-location-p) + (c::stream-source-location-p object))) + +(defun source-location-p (object) + (or (file-source-location-p object) + (stream-source-location-p object))) + +(defun resolve-source-location (location) + (etypecase location + ((satisfies file-source-location-p) + (resolve-file-source-location location)) + ((satisfies stream-source-location-p) + (resolve-stream-source-location location)))) + +(defun definition-source-location (object name) + (let ((source (pcl::definition-source object))) + (etypecase source + (null + `(:error ,(format nil "No source info for: ~A" object))) + ((satisfies source-location-p) + (resolve-source-location source)) + (pathname + (make-name-in-file-location source name)) + (cons + (destructuring-bind ((dg name) pathname) source + (declare (ignore dg)) + (etypecase pathname + (pathname (make-name-in-file-location pathname (string name))) + (null `(:error ,(format nil "Cannot resolve: ~S" source))))))))) + +(defun setf-definitions (name) + (let ((f (or (ext:info :setf :inverse name) + (ext:info :setf :expander name) + (and (symbolp name) + (fboundp `(setf ,name)) + (fdefinition `(setf ,name)))))) + (if f + `(((setf ,name) ,(function-location (cond ((functionp f) f) + ((macro-function f)) + ((fdefinition f))))))))) + +(defun variable-location (symbol) + (multiple-value-bind (location foundp) + ;; XXX for 18e compatibilty. rewrite this when we drop 18e + ;; support. + (ignore-errors (eval `(ext:info :source-location :defvar ',symbol))) + (if (and foundp location) + (resolve-source-location location) + `(:error ,(format nil "No source info for variable ~S" symbol))))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(,(type-of template) + ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + +(defun template-definitions (name) + (let* ((templates (c::backend-template-names c::*backend*)) + (template (gethash name templates))) + (etypecase template + (null) + (c::vop-info + (maybe-make-definition (c::vop-info-generator-function template) + (type-of template) name))))) + +;; for cases like: (%primitive NAME ...) +(defun primitive-definitions (name) + (let ((csym (find-symbol (string name) 'c))) + (and csym + (not (eq csym name)) + (template-definitions csym)))) + +(defun vm-support-routine-definitions (name) + (let ((sr (c::backend-support-routines c::*backend*)) + (name (find-symbol (string name) 'c))) + (and name + (slot-exists-p sr name) + (maybe-make-definition (slot-value sr name) + (find-symbol (string 'vm-support-routine) 'c) + name)))) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unkown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (let ((arglist + (cond ((eval:interpreted-function-p fun) + (eval:interpreted-function-arglist fun)) + ((pcl::generic-function-p fun) + (pcl:generic-function-lambda-list fun)) + ((c::byte-function-or-closure-p fun) + (byte-code-function-arglist fun)) + ((kernel:%function-arglist (kernel:%function-self fun)) + (handler-case (read-arglist fun) + (error () :not-available))) + ;; this should work both for compiled-debug-function + ;; and for interpreted-debug-function + (t + (handler-case (debug-function-arglist + (di::function-debug-function fun)) + (di:unhandled-condition () :not-available)))))) + (check-type arglist (or list (member :not-available))) + arglist)) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((pcl::generic-function-p function) + (pcl::generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. +A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (walker:macroexpand-all form env)) + +(defimplementation compiler-macroexpand-1 (form &optional env) + (ext:compiler-macroexpand-1 form env)) + +(defimplementation compiler-macroexpand (form &optional env) + (ext:compiler-macroexpand form env)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + "cmucl") + +(defimplementation quit-lisp () + (ext::quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (unix:unix-sigsetmask 0) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sldb-condition + :original-condition condition)))) + (unwind-protect + (progn + #+(or)(sys:scrub-control-stack) + (funcall debugger-loop-fn)) + #+(or)(sys:scrub-control-stack) + )))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down 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 (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (cond ((foreign-frame-p frame) (foreign-frame-source-location frame)) + ((code-location-source-location (di:frame-code-location frame)))))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let ((loc (di:frame-code-location frame))) + (remove-if + (lambda (v) + (not (eq (di:debug-variable-validity v loc) :valid))) + (di::debug-function-debug-variables (di:frame-debug-function frame))))) + +(defun debug-var-value (var frame) + (let* ((loc (di:frame-code-location frame)) + (validity (di:debug-variable-validity var loc))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for v across (frame-debug-vars frame) + collect (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (dbg-fun (di:frame-debug-function frame))) + (typecase dbg-fun + (di::compiled-debug-function + (let* ((comp (di::compiled-debug-function-component dbg-fun)) + (dbg-info (kernel:%code-debug-info comp))) + (typecase dbg-info + (c::compiled-debug-info + (find-package (c::compiled-debug-info-package dbg-info))))))))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (string 'find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of CMUCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext) + (let ((*breakpoint-sigcontext* sigcontext) + (*breakpoint-pc* offset)) + (call-next-function))) +(set-fwrappers 'di::handle-breakpoint '()) +(fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:sigcontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:sigcontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; CMUCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (speed 0))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in +;; newer versions of CMUCL (after ~March 2005). +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di))) + (cond (sym (funcall sym sigcontext)) + (t (funcall 'di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +(defimplementation condition-extras (condition) + (typecase condition + (breakpoint + ;; pop up the source buffer + `((:show-frame-source 0))) + (t '()))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + (di::interpreted-debug-function -1) + (di::bogus-debug-function + #-x86 + (let* ((real (di::frame-real-frame (di::frame-up frame))) + (fp (di::frame-pointer real))) + ;;#+(or) + (progn + (format *debug-io* "Frame-real-frame = ~S~%" real) + (format *debug-io* "fp = ~S~%" fp) + (format *debug-io* "lra = ~S~%" + (kernel:stack-ref fp vm::lra-save-offset))) + (values + (sys:int-sap + (- (kernel:get-lisp-obj-address + (kernel:stack-ref fp vm::lra-save-offset)) + (- (ash vm:function-code-offset vm:word-shift) + vm:function-pointer-type))) + 0)) + #+x86 + (let ((fp (di::frame-pointer (di:frame-up frame)))) + (multiple-value-bind (ra ofp) (di::x86-call-context fp) + (declare (ignore ofp)) + (values ra 0)))))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +~8X Stack Pointer +~8X Frame Pointer +~8X Instruction Pointer +~8X Saved Frame Pointer +~8X Saved Instruction Pointer~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + +(defvar *gdb-program-name* + (ext:enumerate-search-list (p "path:gdb") + (when (probe-file p) + (return p)))) + +(defimplementation disassemble-frame (frame-number) + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (cond ((probe-file *gdb-program-name*) + (let ((ip (sys:sap-int (frame-ip frame)))) + (princ (gdb-command "disas 0x~x" ip)))) + (t + (format t "~%[Disassembling bogus frames not implemented]"))))))) + +(defmacro with-temporary-file ((stream filename) &body body) + `(call/temporary-file (lambda (,stream ,filename) . ,body))) + +(defun call/temporary-file (fun) + (let ((name (system::pick-temporary-file-name))) + (unwind-protect + (with-open-file (stream name :direction :output :if-exists :supersede) + (funcall fun stream name)) + (delete-file name)))) + +(defun gdb-command (format-string &rest args) + (let ((str (gdb-exec (format nil + "interpreter-exec mi2 \"attach ~d\"~%~ + interpreter-exec console ~s~%detach" + (getpid) + (apply #'format nil format-string args)))) + (prompt (format nil + #-(and darwin x86) "~%^done~%(gdb) ~%" + #+(and darwin x86) +"~%^done,thread-id=\"1\"~%(gdb) ~%"))) + (subseq str (+ (or (search prompt str) 0) (length prompt))))) + +(defun gdb-exec (cmd) + (with-temporary-file (file filename) + (write-string cmd file) + (force-output file) + (let* ((output (make-string-output-stream)) + ;; gdb on sparc needs to know the executable to find the + ;; symbols. Without this, gdb can't disassemble anything. + ;; NOTE: We assume that the first entry in + ;; lisp::*cmucl-lib* is the bin directory where lisp is + ;; located. If this is not true, we'll have to do + ;; something better to find the lisp executable. + (lisp-path + #+sparc + (list + (namestring + (probe-file + (merge-pathnames "lisp" (car (lisp::parse-unix-search-path + lisp::*cmucl-lib*)))))) + #-sparc + nil) + (proc (ext:run-program *gdb-program-name* + `(,@lisp-path "-batch" "-x" ,filename) + :wait t + :output output))) + (assert (eq (ext:process-status proc) :exited)) + (assert (eq (ext:process-exit-code proc) 0)) + (get-output-stream-string output)))) + +(defun foreign-frame-p (frame) + #-x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (typep (di::frame-debug-function frame) 'di::bogus-debug-function))) + #+x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (multiple-value-bind (pc code) + (di::compute-lra-data-from-pc ip) + (declare (ignore pc)) + (not code))))) + +(defun foreign-frame-source-location (frame) + (let ((ip (sys:sap-int (frame-ip frame)))) + (cond ((probe-file *gdb-program-name*) + (parse-gdb-line-info (gdb-command "info line *0x~x" ip))) + (t `(:error "no srcloc available for ~a" frame))))) + +;; The output of gdb looks like: +;; Line 215 of "../../src/lisp/x86-assem.S" +;; starts at address 0x805318c +;; and ends at 0x805318e . +;; The ../../ are fixed up with the "target:" search list which might +;; be wrong sometimes. +(defun parse-gdb-line-info (string) + (with-input-from-string (*standard-input* string) + (let ((w1 (read-word))) + (cond ((equal w1 "Line") + (let ((line (read-word))) + (assert (equal (read-word) "of")) + (let* ((file (read-from-string (read-word))) + (pathname + (or (probe-file file) + (probe-file (format nil "target:lisp/~a" file)) + file))) + (make-location (list :file (unix-truename pathname)) + (list :line (parse-integer line)))))) + (t + `(:error ,string)))))) + +(defun read-word (&optional (stream *standard-input*)) + (peek-char t stream) + (concatenate 'string (loop until (whitespacep (peek-char nil stream)) + collect (read-char stream)))) + +(defun whitespacep (char) + (member char '(#\space #\newline))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:instance-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp "-TYPE" (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list "-TYPE" "VM") + (apropos-list "-TYPE" "BIGNUM")))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (cmucl-inspect o)))) + +(defun cmucl-inspect (o) + (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (cmucl-inspect o)) + (t + (call-next-method))))) + +(defmethod emacs-inspect ((o kernel:funcallable-instance)) + (append (label-value-line* + (:function (kernel:%funcallable-instance-function o)) + (:lexenv (kernel:%funcallable-instance-lexenv o)) + (:layout (kernel:%funcallable-instance-layout o))) + (cmucl-inspect o))) + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" + (:newline) + , (with-output-to-string (*standard-output*) + (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) + (disassem:disassemble-code-component o)) + ((or + (c::debug-info-p (kernel:%code-debug-info o)) + (consp (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + (c:disassem-byte-component o)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift)))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +#+(or) +(defmethod emacs-inspect ((o array)) + (if (typep o 'simple-array) + (call-next-method) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + +(defmethod emacs-inspect ((o simple-vector)) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (loop for i below (length o) + append (label-value-line i (aref o i))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (declare (optimize (speed 0))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (cmucl-inspect alien)))) + +(defimplementation eval-context (obj) + (cond ((typep (class-of obj) 'structure-class) + (let* ((dd (kernel:layout-info (kernel:layout-of obj))) + (slots (kernel:dd-slots dd))) + (list* (cons '*package* + (symbol-package (if slots + (kernel:dsd-name (car slots)) + (kernel:dd-name dd)))) + (loop for slot in slots collect + (cons (kernel:dsd-name slot) + (funcall (kernel:dsd-accessor slot) obj)))))))) + + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + :methods methods)) + + +;;;; Multiprocessing + +#+mp +(progn + (defimplementation initialize-multiprocessing (continuation) + (mp::init-multi-processing) + (mp:make-process continuation :name "swank") + ;; Threads magic: this never returns! But top-level becomes + ;; available again. + (unless mp::*idle-process* + (mp::startup-idle-and-top-level-loops))) + + (defimplementation spawn (fn &key name) + (mp:make-process fn :name (or name "Anonymous"))) + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (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 (all-threads) + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (mp:process-whostate thread)) + + (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:destroy-process thread)) + + (defvar *mailbox-lock* (mp:make-lock "mailbox lock")) + + (defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock "process mailbox")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock-held (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + + (defimplementation send (thread message) + (check-slime-interrupts) + (let* ((mbox (mailbox thread))) + (mp:with-lock-held ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + + (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-lock-held ((mailbox.mutex 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))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.5 + (lambda () (some test (mailbox.queue mbox))))))) + + + ) ;; #+mp + + + +;;;; GC hooks +;;; +;;; Display GC messages in the echo area to avoid cluttering the +;;; normal output. +;;; + +;; this should probably not be here, but where else? +(defun background-message (message) + (swank::background-message message)) + +(defun print-bytes (nbytes &optional stream) + "Print the number NBYTES to STREAM in KB, MB, or GB units." + (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb)))) + (multiple-value-bind (power name) + (loop for ((p1 n1) (p2 n2)) on names + while n2 do + (when (<= (expt 2 p1) nbytes (1- (expt 2 p2))) + (return (values p1 n1)))) + (cond (name + (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name)) + (t + (format stream "~:D bytes" nbytes)))))) + +(defconstant gc-generations 6) + +#+gencgc +(defun generation-stats () + "Return a string describing the size distribution among the generations." + (let* ((alloc (loop for i below gc-generations + collect (lisp::gencgc-stats i))) + (sum (coerce (reduce #'+ alloc) 'float))) + (format nil "~{~3F~^/~}" + (mapcar (lambda (size) (/ size sum)) + alloc)))) + +(defvar *gc-start-time* 0) + +(defun pre-gc-hook (bytes-in-use) + (setq *gc-start-time* (get-internal-real-time)) + (let ((msg (format nil "[Commencing GC with ~A in use.]" + (print-bytes bytes-in-use)))) + (background-message msg))) + +(defun post-gc-hook (bytes-retained bytes-freed trigger) + (declare (ignore trigger)) + (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*) + internal-time-units-per-second)) + (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]" + (print-bytes bytes-freed) + (print-bytes bytes-retained) + #+gencgc(generation-stats) + #-gencgc"" + seconds))) + (background-message msg))) + +(defun install-gc-hooks () + (setq ext:*gc-notify-before* #'pre-gc-hook) + (setq ext:*gc-notify-after* #'post-gc-hook)) + +(defun remove-gc-hooks () + (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before) + (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after)) + +(defvar *install-gc-hooks* t + "If non-nil install GC hooks") + +(defimplementation emacs-connected () + (when *install-gc-hooks* + (install-gc-hooks))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;;In CMUCL, we have: +;; (trace ) +;; (trace (method ? (+))) +;; (trace :methods t ') ;;to trace all methods of the gf +;; can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + (cond ((fboundp `(method ,@(cdr spec))) + (toggle-trace-aux `(method ,(cdr spec)))) + ;; Man, is this ugly + ((fboundp `(pcl::fast-method ,@(cdr spec))) + (toggle-trace-aux `(pcl::fast-method ,@(cdr spec)))) + (t + (error 'undefined-function :name (cdr spec))))) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))) + ;; doesn't work properly + ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec))) + )) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec)))) + ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec)))))) + (t + fspec))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + + +;;; Save image + +(defimplementation save-image (filename &optional restart-function) + (multiple-value-bind (pid error) (unix:unix-fork) + (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error))) + (cond ((= pid 0) + (apply #'ext:save-lisp + filename + (if restart-function + `(:init-function ,restart-function)))) + (t + (let ((status (waitpid pid))) + (destructuring-bind (&key exited? status &allow-other-keys) status + (assert (and exited? (equal status 0)) () + "Invalid exit status: ~a" status))))))) + +(defun waitpid (pid) + (alien:with-alien ((status c-call:int)) + (let ((code (alien:alien-funcall + (alien:extern-alien + waitpid (alien:function c-call:int c-call:int + (* c-call:int) c-call:int)) + pid (alien:addr status) 0))) + (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg))) + (t (assert (= code pid)) + (decode-wait-status status)))))) + +(defun decode-wait-status (status) + (let ((output (with-output-to-string (s) + (call-program (list (process-status-program) + (format nil "~d" status)) + :output s)))) + (read-from-string output))) + +(defun call-program (args &key output) + (destructuring-bind (program &rest args) args + (let ((process (ext:run-program program args :output output))) + (when (not program) (error "fork failed")) + (unless (and (eq (ext:process-status process) :exited) + (= (ext:process-exit-code process) 0)) + (error "Non-zero exit status"))))) + +(defvar *process-status-program* nil) + +(defun process-status-program () + (or *process-status-program* + (setq *process-status-program* + (compile-process-status-program)))) + +(defun compile-process-status-program () + (let ((infile (system::pick-temporary-file-name + "/tmp/process-status~d~c.c"))) + (with-open-file (stream infile :direction :output :if-exists :supersede) + (format stream " +#include +#include +#include +#include +#include + +#define FLAG(value) (value ? \"t\" : \"nil\") + +int main (int argc, char** argv) { + assert (argc == 2); + { + char* endptr = NULL; + char* arg = argv[1]; + long int status = strtol (arg, &endptr, 10); + assert (endptr != arg && *endptr == '\\0'); + printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\" + \" :stopped? %s :stopsig %d)\\n\", + FLAG(WIFEXITED(status)), WEXITSTATUS(status), + FLAG(WIFSIGNALED(status)), WTERMSIG(status), + FLAG(WCOREDUMP(status)), + FLAG(WIFSTOPPED(status)), WSTOPSIG(status)); + fflush (NULL); + return 0; + } +} +") + (finish-output stream)) + (let* ((outfile (system::pick-temporary-file-name)) + (args (list "cc" "-o" outfile infile))) + (warn "Running cc: ~{~a ~}~%" args) + (call-program args :output t) + (delete-file infile) + outfile))) + +;; FIXME: lisp:unicode-complete introduced in version 20d. +#+#.(swank/backend:with-symbol 'unicode-complete 'lisp) +(defun match-semi-standard (prefix matchp) + ;; Handle the CMUCL's short character names. + (loop for name in lisp::char-name-alist + when (funcall matchp prefix (car name)) + collect (car name))) + +#+#.(swank/backend:with-symbol 'unicode-complete 'lisp) +(defimplementation character-completion-set (prefix matchp) + (let ((names (lisp::unicode-complete prefix))) + ;; Match prefix against semistandard names. If there's a match, + ;; add it to our list of matches. + (let ((semi-standard (match-semi-standard prefix matchp))) + (when semi-standard + (setf names (append semi-standard names)))) + (setf names (mapcar #'string-capitalize names)) + (loop for n in names + when (funcall matchp prefix n) + collect n))) diff --git a/vim/bundle/slimv/slime/swank/corman.lisp b/vim/bundle/slimv/slime/swank/corman.lisp new file mode 100644 index 0000000..80d9ddd --- /dev/null +++ b/vim/bundle/slimv/slime/swank/corman.lisp @@ -0,0 +1,583 @@ +;;; +;;; 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))))) + '("#")) + (: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))))) + '("#")) + (: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)) + "#") (: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)))) diff --git a/vim/bundle/slimv/slime/swank/ecl.lisp b/vim/bundle/slimv/slime/swank/ecl.lisp new file mode 100644 index 0000000..2d19c64 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/ecl.lisp @@ -0,0 +1,845 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ecl.lisp --- SLIME backend for ECL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/ecl + (:use cl swank/backend)) + +(in-package swank/ecl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ecl-version () + (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT))) + (if version + (symbol-value version) + 0))) + (when (< (ecl-version) 100301) + (error "~&IMPORTANT:~% ~ + The version of ECL you're using (~A) is too old.~% ~ + Please upgrade to at least 10.3.1.~% ~ + Sorry for the inconvenience.~%~%" + (lisp-implementation-version)))) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event.fas") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Swank-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-swank-mop-symbols + :clos + (and (< (ecl-version) 121201) + `(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) + '(:compute-applicable-methods-using-classes)))))) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + ;; While ECL does provide threads, some parts of it are not + ;; thread-safe (2010-02-23), including the compiler and CLOS. + nil + ;; ECL on Windows does not provide condition-variables + ;; (or #+(and threads (not windows)) :spawn + ;; nil) + ) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, ECL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;;; Unix Integration + +;;; If ECL is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as ECL's +;;; main-thread is also the Slime's REPL thread. + +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +#+threads +(defun make-interrupt-handler (real-handler) + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler)))) + +#-threads +(defun make-interrupt-handler (real-handler) + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + + +(defimplementation getpid () + (si:getpid)) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (ext:quit)) + + + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(progn + (defun poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) + + (defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready)))))) + +) ; #+serve-event (progn ... + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +#-ecl-bytecmp +(defun handle-compiler-message (condition) + ;; ECL emits lots of noise in compiler-notes, like "Invoking + ;; external command". + (unless (typep condition 'c::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (c:compiler-fatal-error :error) + (c:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +#-ecl-bytecmp +(defun condition-location (condition) + (let ((file (c:compiler-message-file condition)) + (position (c:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) + +(defimplementation call-with-compilation-hooks (function) + #+ecl-bytecmp + (funcall function) + #-ecl-bytecmp + (handler-bind ((c:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (compile-file tmp-file + :load t + :source-truename (or filename + (note-buffer-tmpfile tmp-file buffer)) + :source-offset (1- position)))) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (ext:function-lambda-list name) + (if foundp arglist :not-available))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos:generic-function-name f)) + (function (si:compiled-function-name f)))) + +;; FIXME +;; (defimplementation macroexpand-all (form &optional env) +;; (declare (ignore env)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defvar *backtrace* '()) + +;;; Commented out; it's not clear this is a good way of doing it. In +;;; particular because it makes errors stemming from this file harder +;;; to debug, and given the "young" age of ECL's swank backend, that's +;;; a bad idea. + +;; (defun in-swank-package-p (x) +;; (and +;; (symbolp x) +;; (member (symbol-package x) +;; (list #.(find-package :swank) +;; #.(find-package :swank/backend) +;; #.(ignore-errors (find-package :swank-mop)) +;; #.(ignore-errors (find-package :swank-loader)))) +;; t)) + +;; (defun is-swank-source-p (name) +;; (setf name (pathname name)) +;; (pathname-match-p +;; name +;; (make-pathname :defaults swank-loader::*source-directory* +;; :name (pathname-name name) +;; :type (pathname-type name) +;; :version (pathname-version name)))) + +;; (defun is-ignorable-fun-p (x) +;; (or +;; (in-swank-package-p (frame-name x)) +;; (multiple-value-bind (file position) +;; (ignore-errors (si::bc-file (car x))) +;; (declare (ignore position)) +;; (if file (is-swank-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* (ihs-top)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* until *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (si::fixnump name) + (push name (third x))))))) + (setf *backtrace* (nreverse *backtrace*)) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::bc-file fun) + (when file + (make-file-location file position)))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record (remove-if-not #'consp frame)) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (si::fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (format stream "~A" (first frame))) + +(defimplementation frame-source-location (frame-number) + (nth-value 1 (frame-function (elt *backtrace* frame-number)))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env + (elt *backtrace* frame-number))) + collect (list :name name :id 0 :value value))) + +(defimplementation frame-var-value (frame-number var-number) + (destructuring-bind (name . value) + (elt + (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + var-number) + (declare (ignore name)) + value)) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-with-env form env))) + +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + + +;;;; Definitions + +(defvar +TAGS+ (namestring + (merge-pathnames "TAGS" (translate-logical-pathname "SYS:")))) + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from ECL point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun make-TAGS-location (&rest tags) + (make-location `(:etags-file ,+TAGS+) + `(:tag ,@tags))) + +(defimplementation find-definitions (name) + (let ((annotations (ext:get-annotation name 'si::location :all))) + (cond (annotations + (loop for annotation in annotations + collect (destructuring-bind (dspec file . pos) annotation + `(,dspec ,(make-file-location file pos))))) + (t + (mapcan #'(lambda (type) (find-definitions-by-type name type)) + (classify-definition-name name)))))) + +(defun classify-definition-name (name) + (let ((types '())) + (when (fboundp name) + (cond ((special-operator-p name) + (push :special-operator types)) + ((macro-function name) + (push :macro types)) + ((typep (fdefinition name) 'generic-function) + (push :generic-function types)) + ((si:mangle-name name t) + (push :c-function types)) + (t + (push :lisp-function types)))) + (when (boundp name) + (cond ((constantp name) + (push :constant types)) + (t + (push :global-variable types)))) + types)) + +(defun find-definitions-by-type (name type) + (ecase type + (:lisp-function + (when-let (loc (source-location (fdefinition name))) + (list `((defun ,name) ,loc)))) + (:c-function + (when-let (loc (source-location (fdefinition name))) + (list `((c-source ,name) ,loc)))) + (:generic-function + (loop for method in (clos:generic-function-methods (fdefinition name)) + for specs = (clos:method-specializers method) + for loc = (source-location method) + when loc + collect `((defmethod ,name ,specs) ,loc))) + (:macro + (when-let (loc (source-location (macro-function name))) + (list `((defmacro ,name) ,loc)))) + (:constant + (when-let (loc (source-location name)) + (list `((defconstant ,name) ,loc)))) + (:global-variable + (when-let (loc (source-location name)) + (list `((defvar ,name) ,loc)))) + (:special-operator))) + +;;; FIXME: There ought to be a better way. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun c-function-name-p (name) + (and (symbolp name) (si:mangle-name name t) t)) + (defun c-function-p (object) + (and (functionp object) + (let ((fn-name (function-name object))) + (and fn-name (c-function-name-p fn-name)))))) + +(deftype c-function () + `(satisfies c-function-p)) + +(defun assert-source-directory () + (unless (probe-file #P"SRC:") + (error "ECL's source directory ~A does not exist. ~ + You can specify a different location via the environment ~ + variable `ECLSRCDIR'." + (namestring (translate-logical-pathname #P"SYS:"))))) + +(defun assert-TAGS-file () + (unless (probe-file +TAGS+) + (error "No TAGS file ~A found. It should have been installed with ECL." + +TAGS+))) + +(defun package-names (package) + (cons (package-name package) (package-nicknames package))) + +(defun source-location (object) + (converting-errors-to-error-location + (typecase object + (c-function + (assert-source-directory) + (assert-TAGS-file) + (let ((lisp-name (function-name object))) + (assert lisp-name) + (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t) + (assert flag) + ;; In ECL's code base sometimes the mangled name is used + ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or + ;; @EXT::SYMBOL is used. We cannot predict here, so we just + ;; provide several candidates. + (apply #'make-TAGS-location + c-name + (loop with s = (symbol-name lisp-name) + for p in (package-names (symbol-package lisp-name)) + collect (format nil "~A::~A" p s) + collect (format nil "~(~A::~A~)" p s)))))) + (function + (multiple-value-bind (file pos) (ext:compiled-function-file object) + (cond ((not file) + (return-from source-location nil)) + ((tmpfile-to-buffer file) + (make-buffer-location (tmpfile-to-buffer file) pos)) + (t + (assert (probe-file file)) + (assert (not (minusp pos))) + (make-file-location file pos))))) + (method + ;; FIXME: This will always return NIL at the moment; ECL does not + ;; store debug information for methods yet. + (source-location (clos:method-function object))) + ((member nil t) + (multiple-value-bind (flag c-name) (si:mangle-name object) + (assert flag) + (make-TAGS-location c-name)))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + + +;;;; Profiling + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Threads + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-lock :name name :recursive t)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock)) + (cvar (mp:make-condition-variable)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp: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)) + (mutex (mailbox.mutex mbox))) + (mp:with-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:condition-variable-timedwait (mailbox.cvar mbox) + mutex + 0.2))))) + + ) ; #+threads (progn ... diff --git a/vim/bundle/slimv/slime/swank/gray.lisp b/vim/bundle/slimv/slime/swank/gray.lisp new file mode 100644 index 0000000..b910a78 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/gray.lisp @@ -0,0 +1,170 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-gray.lisp --- Gray stream based IO redirection. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/backend) + +#.(progn + (defvar *gray-stream-symbols* + '(fundamental-character-output-stream + stream-write-char + stream-write-string + stream-fresh-line + stream-force-output + stream-finish-output + + fundamental-character-input-stream + stream-read-char + stream-peek-char + stream-read-line + stream-listen + stream-unread-char + stream-clear-input + stream-line-column + stream-read-char-no-hang)) + nil) + +(defpackage swank/gray + (:use cl swank/backend) + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) + (:export . #.*gray-stream-symbols*)) + +(in-package swank/gray) + +(defclass slime-output-stream (fundamental-character-output-stream) + ((output-fn :initarg :output-fn) + (buffer :initform (make-string 8000)) + (fill-pointer :initform 0) + (column :initform 0) + (lock :initform (make-lock :name "buffer write lock")))) + +(defmacro with-slime-output-stream (stream &body body) + `(with-slots (lock output-fn buffer fill-pointer column) ,stream + (call-with-lock-held lock (lambda () ,@body)))) + +(defmethod stream-write-char ((stream slime-output-stream) char) + (with-slime-output-stream stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (when (char= #\newline char) + (setf column 0)) + (when (= fill-pointer (length buffer)) + (finish-output stream))) + char) + +(defmethod stream-write-string ((stream slime-output-stream) string + &optional start end) + (with-slime-output-stream stream + (let* ((start (or start 0)) + (end (or end (length string))) + (len (length buffer)) + (count (- end start)) + (free (- len fill-pointer))) + (when (>= count free) + (stream-finish-output stream)) + (cond ((< count len) + (replace buffer string :start1 fill-pointer + :start2 start :end2 end) + (incf fill-pointer count)) + (t + (funcall output-fn (subseq string start end)))) + (let ((last-newline (position #\newline string :from-end t + :start start :end end))) + (setf column (if last-newline + (- end last-newline 1) + (+ column count)))))) + string) + +(defmethod stream-line-column ((stream slime-output-stream)) + (with-slime-output-stream stream column)) + +(defmethod stream-finish-output ((stream slime-output-stream)) + (with-slime-output-stream stream + (unless (zerop fill-pointer) + (funcall output-fn (subseq buffer 0 fill-pointer)) + (setf fill-pointer 0))) + nil) + +(defmethod stream-force-output ((stream slime-output-stream)) + (stream-finish-output stream)) + +(defmethod stream-fresh-line ((stream slime-output-stream)) + (with-slime-output-stream stream + (cond ((zerop column) nil) + (t (terpri stream) t)))) + +(defclass slime-input-stream (fundamental-character-input-stream) + ((input-fn :initarg :input-fn) + (buffer :initform "") (index :initform 0) + (lock :initform (make-lock :name "buffer read lock")))) + +(defmethod stream-read-char ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index input-fn) s + (when (= index (length buffer)) + (let ((string (funcall input-fn))) + (cond ((zerop (length string)) + (return-from stream-read-char :eof)) + (t + (setf buffer string) + (setf index 0))))) + (assert (plusp (length buffer))) + (prog1 (aref buffer index) (incf index)))))) + +(defmethod stream-listen ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (< index (length buffer)))))) + +(defmethod stream-unread-char ((s slime-input-stream) char) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (decf index) + (cond ((eql (aref buffer index) char) + (setf (aref buffer index) char)) + (t + (warn "stream-unread-char: ignoring ~S (expected ~S)" + char (aref buffer index))))))) + nil) + +(defmethod stream-clear-input ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (setf buffer "" + index 0)))) + nil) + +(defmethod stream-line-column ((s slime-input-stream)) + nil) + +(defmethod stream-read-char-no-hang ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))))) + + +;;; + +(defimplementation make-output-stream (write-string) + (make-instance 'slime-output-stream :output-fn write-string)) + +(defimplementation make-input-stream (read-string) + (make-instance 'slime-input-stream :input-fn read-string)) diff --git a/vim/bundle/slimv/slime/swank/lispworks.lisp b/vim/bundle/slimv/slime/swank/lispworks.lisp new file mode 100644 index 0000000..d4b656e --- /dev/null +++ b/vim/bundle/slimv/slime/swank/lispworks.lisp @@ -0,0 +1,1018 @@ +;;; -*- 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. +;;; + +(defpackage swank/lispworks + (:use cl swank/backend)) + +(in-package swank/lispworks) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(defimplementation gray-package-name () + "STREAM") + +(import-swank-mop-symbols :clos '(:slot-definition-documentation + :slot-boundp-using-class + :slot-value-using-class + :slot-makunbound-using-class + :eql-specializer + :eql-specializer-object + :compute-applicable-methods-using-classes)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +(defun swank-mop:slot-boundp-using-class (class object slotd) + (clos:slot-boundp-using-class class object + (clos:slot-definition-name slotd))) + +(defun swank-mop:slot-value-using-class (class object slotd) + (clos:slot-value-using-class class object + (clos:slot-definition-name slotd))) + +(defun (setf swank-mop:slot-value-using-class) (value class object slotd) + (setf (clos:slot-value-using-class class object + (clos:slot-definition-name slotd)) + value)) + +(defun swank-mop:slot-makunbound-using-class (class object slotd) + (clos:slot-makunbound-using-class class object + (clos:slot-definition-name slotd))) + +(defun swank-mop:compute-applicable-methods-using-classes (gf classes) + (clos::compute-applicable-methods-from-classes gf classes)) + +;; lispworks doesn't have the eql-specializer class, it represents +;; them as a list of `(EQL ,OBJECT) +(deftype swank-mop:eql-specializer () 'cons) + +(defun swank-mop:eql-specializer-object (eql-spec) + (second eql-spec)) + +(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)))) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ef:encode-lisp-string string '(:utf-8 :eol-style :lf))) + +(defimplementation utf8-to-string (octets) + (ef:decode-external-string octets '(:utf-8 :eol-style :lf))) + +;;; TCP server + +(defimplementation preferred-communication-style () + :spawn) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (comm:socket-stream (comm:socket-stream-socket socket)))) + +(defimplementation create-socket (host port &key backlog) + (multiple-value-bind (socket where errno) + #-(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port :address host + :backlog (or backlog 5)) + #+(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port) + (cond (socket socket) + (t (error 'network-error + :format-control "~A failed: ~A (~D)" + :format-arguments (list where + (list #+unix (lw:get-unix-error errno)) + errno)))))) + +(defimplementation local-port (socket) + (nth-value 1 (comm:get-socket-address (socket-fd socket)))) + +(defimplementation close-socket (socket) + (comm::close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering)) + (let* ((fd (comm::get-fd-from-socket socket))) + (assert (/= fd -1)) + (cond ((not external-format) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8))) + (t + (assert (valid-external-format-p external-format)) + (ecase (first external-format) + ((:latin-1 :ascii) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type 'base-char)) + (:utf-8 + (make-flexi-stream + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8)) + external-format))))))) + +(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 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 + +(defun map-list (function list) + "Map over proper and not proper lists." + (loop for (car . cdr) on list + collect (funcall function car) into result + when (null cdr) return result + when (atom cdr) return (nconc result (funcall function cdr)))) + +(defun replace-strings-with-symbols (tree) + (map-list + (lambda (x) + (typecase x + (list + (replace-strings-with-symbols x)) + (symbol + x) + (string + (intern x)) + (t + (intern (write-to-string x))))) + tree)) + +(defimplementation arglist (symbol-or-function) + (let ((arglist (lw:function-lambda-list symbol-or-function))) + (etypecase arglist + ((member :dont-know) + :not-available) + (list + (replace-strings-with-symbols arglist))))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (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))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; 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)) + (swank:swank-debugger-hook condition *debugger-hook*)) + +(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: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*) + (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." + (flet ((find-named-frame (name) + (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) + name))) + (nth-next-frame frame 1))))) + (or (find-named-frame 'invoke-debugger) + (find-named-frame 'swank::safe-backtrace) + ;; if we can't find a likely top 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) + (kind nil)) + (loop for arg in (dbg::call-frame-arglist frame) + if (eq kind '&rest) + nconc (handler-case + (dbg::dbg-eval arg frame) + (error (e) (list (format nil "<~A>" arg)))) + and do (loop-finish) + else + if (member arg '(&rest &optional &key)) + do (setq kind arg) + else + nconc + (handler-case + (nconc (and (eq kind '&key) + (list (cond ((symbolp arg) + (intern (symbol-name arg) :keyword)) + ((and (consp arg) (symbolp (car arg))) + (intern (symbol-name (car arg)) + :keyword)) + (t (caar arg))))) + (list (dbg::dbg-eval + (cond ((symbolp arg) arg) + ((and (consp arg) (symbolp (car arg))) + (car arg)) + (t (cadar arg))) + frame))) + (error (e) (list (format nil "<~A>" arg))))))) + +(defimplementation print-frame (frame stream) + (cond ((dbg::call-frame-p frame) + (prin1 (cons (dbg::call-frame-function-name frame) + (frame-actual-args frame)) + stream)) + (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 (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))) + (path (and (dbg::call-frame-p frame) + (dbg::call-frame-edit-path frame)))) + (if dspec + (frame-location dspec cname path)))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::dbg-eval form frame))) + +(defun function-name-package (name) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql hcl:subfunction)) + (destructuring-bind (name parent) (cdr name) + (declare (ignore name)) + (function-name-package parent))) + ((cons (eql lw:top-level-form)) nil) + (t nil))) + +(defimplementation frame-package (frame-number) + (let ((frame (nth-frame frame-number))) + (if (dbg::call-frame-p frame) + (function-name-package (dbg::call-frame-function-name 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 edit-path) + (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))) + (path (edit-path-to-cmucl-source-path edit-path))) + (make-dspec-location rdspec location + `(:call-site ,name :edit-path ,path))))) + (t + (list :error (format nil "Source location not available for: ~S" + dspec)))))) + +;; dbg::call-frame-edit-path is not documented but lets assume the +;; binary representation of the integer EDIT-PATH should be +;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the +;; same as cadadddr. Something is odd with the highest bit. +(defun edit-path-to-cmucl-source-path (edit-path) + (and edit-path + (cons 0 + (let ((n -1)) + (loop for i from (1- (integer-length edit-path)) downto 0 + if (logbitp i edit-path) do (incf n) + else collect (prog1 n (setq n 0))))))) + +;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1) + +(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 + &key policy) + (declare (ignore policy)) + (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) + (multiple-value-bind (condition path) + (if (consp c) (values (car c) (cdr c)) (values c nil)) + (funcall fn filename dspec condition path)))))) + +(defun lispworks-severity (condition) + (cond ((not condition) :warning) + (t (etypecase condition + #-(or lispworks4 lispworks5) + (conditions:compiler-note :note) + (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) + (ignore-errors (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) location + (declare (ignore _)) + (make-location `(:buffer ,buffer) + (dspec-function-name-position dspec `(:offset ,offset 0)) + hints))))) + +(defun make-dspec-progenitor-location (dspec location edit-path) + (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 + (if edit-path + (list :edit-path (edit-path-to-cmucl-source-path edit-path)))))) + +(defun signal-error-data-base (database &optional location) + (map-error-database + database + (lambda (filename dspec condition edit-path) + (signal-compiler-condition + (format nil "~A" condition) + (make-dspec-progenitor-location dspec (or location filename) edit-path) + 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) + 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)) + (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-Unix-Lisp (sys:callablep object) + #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) + (sys:compiled-code-p 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))))) + +(defun list-callees-internal (name) + (let ((callees '())) + (system::find-constant$funcallable + 'junk name + :test #'(lambda (junk constant) + (declare (ignore junk)) + (when (and (symbolp constant) + (fboundp constant)) + (pushnew (list 'function constant) callees :test 'equal)) + ;; Return nil so we iterate over all constants. + nil)) + callees)) + +;; 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))) + +;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (cond ((not mp::*multiprocessing*) + (push (list "Initialize SLIME" '() continuation) + mp:*initial-processes*) + (mp:initialize-multiprocessing)) + (t (funcall continuation)))) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name () fn)) + +(defvar *id-lock* (mp:make-lock)) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-lock (*id-lock*) + (or (getf (mp:process-plist thread) 'id) + (setf (getf (mp:process-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (mp:list-all-processes) + :key (lambda (p) (getf (mp:process-plist p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" + (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (mp:list-all-processes)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defimplementation thread-alive-p (thread) + (mp:process-alive-p thread)) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock :name "thread mailbox")) + (queue '() :type list)) + +(defvar *mailbox-lock* (mp:make-lock)) + +(defun mailbox (thread) + (mp:with-lock (*mailbox-lock*) + (or (getf (mp:process-plist thread) 'mailbox) + (setf (getf (mp:process-plist thread) 'mailbox) + (make-mailbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox mp:*current-process*)) + (lock (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (lock "receive-if/try") + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox))))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (mp:with-lock ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(let ((alist '()) + (lock (mp:make-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-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-lock (lock) + (cdr (assoc name alist))))) + + +(defimplementation set-default-initial-binding (var form) + (setq mp:*process-initial-bindings* + (acons var `(eval (quote ,form)) + mp:*process-initial-bindings* ))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :idle (mp:process-idle-time thread))) + + +;;;; 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)) diff --git a/vim/bundle/slimv/slime/swank/match.lisp b/vim/bundle/slimv/slime/swank/match.lisp new file mode 100644 index 0000000..d6200db --- /dev/null +++ b/vim/bundle/slimv/slime/swank/match.lisp @@ -0,0 +1,242 @@ +;; +;; SELECT-MATCH macro (and IN macro) +;; +;; Copyright 1990 Stephen Adams +;; +;; You are free to copy, distribute and make derivative works of this +;; source provided that this copyright notice is displayed near the +;; beginning of the file. No liability is accepted for the +;; correctness or performance of the code. If you modify the code +;; please indicate this fact both at the place of modification and in +;; this copyright message. +;; +;; Stephen Adams +;; Department of Electronics and Computer Science +;; University of Southampton +;; SO9 5NH, UK +;; +;; sra@ecs.soton.ac.uk +;; + +;; +;; Synopsis: +;; +;; (select-match expression +;; (pattern action+)*) +;; +;; --- or --- +;; +;; (select-match expression +;; pattern => expression +;; pattern => expression +;; ...) +;; +;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) +;; | symbol ;matches anything +;; | 'anything ;must be EQUAL +;; | (pattern = pattern) ;both patterns must match +;; | (#'function pattern) ;predicate test +;; | (pattern . pattern) ;cons cell +;; + +;; Example +;; +;; (select-match item +;; (('if e1 e2 e3) 'if-then-else) ;(1) +;; ((#'oddp k) 'an-odd-integer) ;(2) +;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) +;; (other 'anything-else)) ;(4) +;; +;; Notes +;; +;; . Each pattern is tested in turn. The first match is taken. +;; +;; . If no pattern matches, an error is signalled. +;; +;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. +;; numbers, strings, characters, etc.) match things which are EQUAL. +;; +;; . Quoted patterns (which are CONSTANTP) are constants. +;; +;; . Symbols match anything. The symbol is bound to the matched item +;; for the execution of the actions. +;; For example, (SELECT-MATCH '(1 2 3) +;; (1 . X) => X) +;; returns (2 3) because X is bound to the cdr of the candidate. +;; +;; . The two pattern match (p1 = p2) can be used to name parts +;; of the matched structure. For example, (ALL = (HD . TL)) +;; matches a cons cell. ALL is bound to the cons cell, HD to its car +;; and TL to its tail. +;; +;; . A predicate test applies the predicate to the item being matched. +;; If the predicate returns NIL then the match fails. +;; If it returns truth, then the nested pattern is matched. This is +;; often just a symbol like K in the example. +;; +;; . Care should be taken with the domain values for predicate matches. +;; If, in the above eg, item is not an integer, an error would occur +;; during the test. A safer pattern would be +;; (#'integerp (#'oddp k)) +;; This would only test for oddness of the item was an integer. +;; +;; . A single symbol will match anything so it can be used as a default +;; case, like OTHER above. +;; + +(in-package swank/match) + +(defmacro match (expression &body patterns) + `(select-match ,expression ,@patterns)) + +(defmacro select-match (expression &rest patterns) + (let* ((do-let (not (atom expression))) + (key (if do-let (gensym) expression)) + (cbody (expand-select-patterns key patterns)) + (cform `(cond . ,cbody))) + (if do-let + `(let ((,key ,expression)) ,cform) + cform))) + +(defun expand-select-patterns (key patterns) + (if (eq (second patterns) '=>) + (expand-select-patterns-style-2 key patterns) + (expand-select-patterns-style-1 key patterns))) + +(defun expand-select-patterns-style-1 (key patterns) + (if (null patterns) + `((t (error "Case select pattern match failure on ~S" ,key))) + (let* ((pattern (caar patterns)) + (actions (cdar patterns)) + (rest (cdr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-1 key rest)))))) + +(defun expand-select-patterns-style-2 (key patterns) + (cond ((null patterns) + `((t (error "Case select pattern match failure on ~S" ,key)))) + (t (when (or (< (length patterns) 3) + (not (eq (second patterns) '=>))) + (error "Illegal patterns: ~S" patterns)) + (let* ((pattern (first patterns)) + (actions (list (third patterns))) + (rest (cdddr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-2 key rest))))))) + +(defun compile-select-test (key pattern) + (let ((tests (remove t (compile-select-tests key pattern)))) + (cond + ;; note AND does this anyway, but this allows us to tell if + ;; the pattern will always match. + ((null tests) t) + ((= (length tests) 1) (car tests)) + (t `(and . ,tests))))) + +(defun compile-select-tests (key pattern) + (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) + ((symbolp pattern) 'eq) + (t 'equal)) + ,key ,pattern))) + ((symbolp pattern) '(t)) + ((select-double-match? pattern) + (append + (compile-select-tests key (first pattern)) + (compile-select-tests key (third pattern)))) + ((select-predicate? pattern) + (append + `((,(second (first pattern)) ,key)) + (compile-select-tests key (second pattern)))) + ((consp pattern) + (append + `((consp ,key)) + (compile-select-tests (cs-car key) (car + pattern)) + (compile-select-tests (cs-cdr key) (cdr + pattern)))) + (t (error "Illegal select pattern: ~S" pattern)))) + + +(defun compile-select-bindings (key pattern action) + (cond ((constantp pattern) '()) + ((symbolp pattern) + (if (select-in-tree pattern action) + `((,pattern ,key)) + '())) + ((select-double-match? pattern) + (append + (compile-select-bindings key (first pattern) action) + (compile-select-bindings key (third pattern) action))) + ((select-predicate? pattern) + (compile-select-bindings key (second pattern) action)) + ((consp pattern) + (append + (compile-select-bindings (cs-car key) (car pattern) + action) + (compile-select-bindings (cs-cdr key) (cdr pattern) + action))))) + +(defun select-in-tree (atom tree) + (or (eq atom tree) + (if (consp tree) + (or (select-in-tree atom (car tree)) + (select-in-tree atom (cdr tree)))))) + +(defun select-double-match? (pattern) + ;; ( = ) + (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) + (null (cdddr pattern)) + (eq (second pattern) '=))) + +(defun select-predicate? (pattern) + ;; ((function ) ) + (and (consp pattern) + (consp (cdr pattern)) + (null (cddr pattern)) + (consp (first pattern)) + (consp (cdr (first pattern))) + (null (cddr (first pattern))) + (eq (caar pattern) 'function))) + +(defun cs-car (exp) + (cs-car/cdr 'car exp + '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) + (cdar . cadar) (cddr . caddr) + (caaar . caaaar) (caadr . caaadr) (cadar . caadar) + (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) + (cddar . caddar) (cdddr . cadddr)))) + +(defun cs-cdr (exp) + (cs-car/cdr 'cdr exp + '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) + (cdar . cddar) (cddr . cdddr) + (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) + (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) + (cddar . cdddar) (cdddr . cddddr)))) + +(defun cs-car/cdr (op exp table) + (if (and (consp exp) (= (length exp) 2)) + (let ((replacement (assoc (car exp) table))) + (if replacement + `(,(cdr replacement) ,(second exp)) + `(,op ,exp))) + `(,op ,exp))) + +;; (setf c1 '(select-match x (a 1) (b 2 3 4))) +;; (setf c2 '(select-match (car y) +;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ +;; else)))) +;; (setf c3 '(select-match (caddr y) +;; ((all = (x y)) (list x y all)) +;; ((a '= b) (list 'assign a b)) +;; ((#'oddp k) (1+ k))))) + + diff --git a/vim/bundle/slimv/slime/swank/mkcl.lisp b/vim/bundle/slimv/slime/swank/mkcl.lisp new file mode 100644 index 0000000..53696fb --- /dev/null +++ b/vim/bundle/slimv/slime/swank/mkcl.lisp @@ -0,0 +1,933 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-mkcl.lisp --- SLIME backend for MKCL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/mkcl + (:use cl swank/backend)) + +(in-package swank/mkcl) + +;;(declaim (optimize (debug 3))) + +(defvar *tmp*) + +(defimplementation gray-package-name () + '#:gray) + +(eval-when (:compile-toplevel :load-toplevel) + + (swank/backend::import-swank-mop-symbols :clos + ;; '(:eql-specializer + ;; :eql-specializer-object + ;; :generic-function-declarations + ;; :specializer-direct-methods + ;; :compute-applicable-methods-using-classes) + nil + )) + + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (mkcl:octets (si:utf-8 string))) + +(defimplementation utf8-to-string (octets) + (string (si:utf-8 octets))) + + +;;;; TCP Server + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the sb-bsd-sockets package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'sockets)) + + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defun accept (socket) + "Like socket-accept, but retry on EINTR." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t ;; bogus + :input t ;; bogus + :buffering buffering ;; bogus + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format + )) + +(defimplementation preferred-communication-style () + :spawn + ) + +(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"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (si:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, MKCL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + + +;;;; Unix signals + +(defimplementation install-sigint-handler (handler) + (let ((old-handler (symbol-function 'si:terminal-interrupt))) + (setf (symbol-function 'si:terminal-interrupt) + (if (consp handler) + (car handler) + (lambda (&rest args) + (declare (ignore args)) + (funcall handler) + (continue)))) + (list old-handler))) + + +(defimplementation getpid () + (mkcl:getpid)) + +(defimplementation set-default-directory (directory) + (mk-ext::chdir (namestring directory)) + (default-directory)) + +(defimplementation default-directory () + (namestring (mk-ext:getcwd))) + +(defmacro progf (plist &rest forms) + `(let (_vars _vals) + (do ((p ,plist (cddr p))) + ((endp p)) + (push (car p) _vars) + (push (cadr p) _vals)) + (progv _vars _vals ,@forms) + ) + ) + +(defvar *inferior-lisp-sleeping-post* nil) + +(defimplementation quit-lisp () + (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams. + (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*)) + ;;(mk-ext:quit :verbose t) + )) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +#| +(defun handle-compiler-warning (condition) + (signal-compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* + ;; (if compiler::*current-function* + ;; (make-location (list :file *compile-filename*) + ;; (list :function-name + ;; (symbol-name + ;; (slot-value compiler::*current-function* + ;; 'compiler::name)))) + (list :error "No location found.") + ;; ) + ))) +|# + +#| +(defun condition-location (condition) + (let ((file (compiler:compiler-message-file condition)) + (position (compiler:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) +|# + +(defun condition-location (condition) + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* ; + ;; (if compiler::*current-function* ; + ;; (make-location (list :file *compile-filename*) ; + ;; (list :function-name ; + ;; (symbol-name ; + ;; (slot-value compiler::*current-function* ; + ;; 'compiler::name)))) ; + (if (typep condition 'compiler::compiler-message) + (make-location (list :file (namestring (compiler:compiler-message-file condition))) + (list :end-position (compiler:compiler-message-file-end-position condition))) + (list :error "No location found.")) + ) + ) + +(defun handle-compiler-message (condition) + (unless (typep condition 'compiler::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (compiler:compiler-fatal-error :error) + (compiler:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((compiler:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (handler-bind (#| + (compiler::compiler-note + #'(lambda (n) + (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil)) + (compiler::compiler-warning + #'(lambda (w) + (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil)) + (compiler::compiler-error + #'(lambda (e) + (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil)) + |# + ) + (multiple-value-bind (output-truename warnings-p failure-p) + (compile-file input-file :output-file output-file :external-format external-format) + (values output-truename warnings-p + (or failure-p + (and load-p (not (load output-truename)))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (with-input-from-string (s string) + (when position (file-position position)) + (compile-from-stream s))))) + +(defun compile-from-stream (stream) + (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX")) + output-truename + warnings-p + failure-p + ) + (with-open-file (s file :direction :output :if-exists :overwrite) + (do ((line (read-line stream nil) (read-line stream nil))) + ((not line)) + (write-line line s))) + (unwind-protect + (progn + (multiple-value-setq (output-truename warnings-p failure-p) + (compile-file file)) + (and (not failure-p) (load output-truename))) + (when (probe-file file) (delete-file file)) + (when (probe-file output-truename) (delete-file output-truename))))) + + +;;;; Documentation + +(defun grovel-docstring-for-arglist (name type) + (flet ((compute-arglist-offset (docstring) + (when docstring + (let ((pos1 (search "Args: " docstring))) + (if pos1 + (+ pos1 6) + (let ((pos2 (search "Syntax: " docstring))) + (when pos2 + (+ pos2 8)))))))) + (let* ((docstring (si::get-documentation name type)) + (pos (compute-arglist-offset docstring))) + (if pos + (multiple-value-bind (arglist errorp) + (ignore-errors + (values (read-from-string docstring t nil :start pos))) + (if (or errorp (not (listp arglist))) + :not-available + arglist + )) + :not-available )))) + +(defimplementation arglist (name) + (cond ((and (symbolp name) (special-operator-p name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((and (symbolp name) (macro-function name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((or (functionp name) (fboundp name)) + (multiple-value-bind (name fndef) + (if (functionp name) + (values (function-name name) name) + (values name (fdefinition name))) + (let ((fle (function-lambda-expression fndef))) + (case (car fle) + (si:lambda-block (caddr fle)) + (t (typecase fndef + (generic-function (clos::generic-function-lambda-list fndef)) + (compiled-function (grovel-docstring-for-arglist name 'function)) + (function :not-available))))))) + (t :not-available))) + +(defimplementation function-name (f) + (si:compiled-function-name f) + ) + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the walker package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'walker)) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:macroexpand-all form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (dolist (type '(:VARIABLE :FUNCTION :CLASS)) + (let ((doc (describe-definition symbol type))) + (when doc + (setf result (list* type doc result))))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defvar *backtrace* '()) + +(defun in-swank-package-p (x) + (and + (symbolp x) + (member (symbol-package x) + (list #.(find-package :swank) + #.(find-package :swank/backend) + #.(ignore-errors (find-package :swank-mop)) + #.(ignore-errors (find-package :swank-loader)))) + t)) + +(defun is-swank-source-p (name) + (setf name (pathname name)) + #+(or) + (pathname-match-p + name + (make-pathname :defaults swank-loader::*source-directory* + :name (pathname-name name) + :type (pathname-type name) + :version (pathname-version name))) + nil) + +(defun is-ignorable-fun-p (x) + (or + (in-swank-package-p (frame-name x)) + (multiple-value-bind (file position) + (ignore-errors (si::compiled-function-file (car x))) + (declare (ignore position)) + (if file (is-swank-source-p file))))) + +(defmacro find-ihs-top (x) + (declare (ignore x)) + '(si::ihs-top)) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* (;;(*tpl-commands* si::tpl-commands) + (*ihs-base* 0) + (*ihs-top* (find-ihs-top 'call-with-debugging-environment)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*read-suppress* nil) + ;;(*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* to *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (mkcl:fixnump name) + (push name (third x))))))) + (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) + (setf *tmp* *backtrace*) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (*ihs-base* (find-ihs-top 'call-with-debugger-hook))) + (funcall fun))) + +(defimplementation compute-backtrace (start end) + (when (numberp end) + (setf end (min end (length *backtrace*)))) + (loop for f in (subseq *backtrace* start end) + collect f)) + +(defimplementation format-sldb-condition (condition) + "Format a condition for display in SLDB." + ;;(princ-to-string condition) + (format nil "~A~%In thread: ~S" condition mt:*thread*) + ) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::compiled-function-file fun) + (and file (make-location + `(:file ,(if (stringp file) file (namestring file))) + ;;`(:position ,position) + `(:end-position , position))))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record frame) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (mkcl:fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (let ((function (first frame))) + (let ((fname +;;; (cond ((symbolp function) function) +;;; ((si:instancep function) (slot-value function 'name)) +;;; ((compiled-function-p function) +;;; (or (si::compiled-function-name function) 'lambda)) +;;; (t :zombi)) + (si::get-fname function) + )) + (if (eq fname 'si::bytecode) + (format stream "~A [Evaluation of: ~S]" + fname (function-lambda-expression function)) + (format stream "~A" fname) + ) + (when (si::closurep function) + (format stream + ", closure generated from ~A" + (si::get-fname (si:closure-producer function))) + ) + ) + ) + ) + +(defimplementation frame-source-location (frame-number) + (nth-value 1 (frame-function (elt *backtrace* frame-number)))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + with i = 0 + collect (list :name name :id (prog1 i (incf i)) :value value))) + +(defimplementation frame-var-value (frame-number var-id) + (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id))) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-fun (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-in-env form env))) + +#| +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) +|# + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + ; ecl clos support leaves some to be desired + (cond + ((streamp o) + (list* + (format nil "~S is an ordinary stream~%" o) + (append + (list + "Open for " + (cond + ((ignore-errors (interactive-stream-p o)) "Interactive") + ((and (input-stream-p o) (output-stream-p o)) "Input and output") + ((input-stream-p o) "Input") + ((output-stream-p o) "Output")) + `(:newline) `(:newline)) + (label-value-line* + ("Element type" (stream-element-type o)) + ("External format" (stream-external-format o))) + (ignore-errors (label-value-line* + ("Broadcast streams" (broadcast-stream-streams o)))) + (ignore-errors (label-value-line* + ("Concatenated streams" (concatenated-stream-streams o)))) + (ignore-errors (label-value-line* + ("Echo input stream" (echo-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Echo output stream" (echo-stream-output-stream o)))) + (ignore-errors (label-value-line* + ("Output String" (get-output-stream-string o)))) + (ignore-errors (label-value-line* + ("Synonym symbol" (synonym-stream-symbol o)))) + (ignore-errors (label-value-line* + ("Input stream" (two-way-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Output stream" (two-way-stream-output-stream o))))))) + ((si:instancep o) ;;t + (let* ((cl (si:instance-class o)) + (slots (clos::class-slots cl))) + (list* (format nil "~S is an instance of class ~A~%" + o (clos::class-name cl)) + (loop for x in slots append + (let* ((name (clos::slot-definition-name x)) + (value (if (slot-boundp o name) + (clos::slot-value o name) + "Unbound" + ))) + (list + (format nil "~S: " name) + `(:value ,value) + `(:newline))))))) + (t (list (format nil "~A" o))))) + +;;;; Definitions + +(defimplementation find-definitions (name) + (if (fboundp name) + (let ((tmp (find-source-location (symbol-function name)))) + `(((defun ,name) ,tmp))))) + +(defimplementation find-source-location (obj) + (setf *tmp* obj) + (or + (typecase obj + (function + (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj)) + (if (and file pos) + (make-location + `(:file ,(if (stringp file) file (namestring file))) + `(:end-position ,pos) ;; `(:position ,pos) + `(:snippet + ,(with-open-file (s file) + (file-position s pos) + (skip-comments-and-whitespace s) + (read-snippet s)))))))) + `(:error (format nil "Source definition of ~S not found" obj)))) + +;;;; Profiling + + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the profile package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'profile)) + + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) + + +;;;; Threads + +(defvar *thread-id-counter* 0) + +(defvar *thread-id-counter-lock* + (mt:make-lock :name "thread id counter lock")) + +(defun next-thread-id () + (mt:with-lock (*thread-id-counter-lock*) + (incf *thread-id-counter*)) + ) + +(defparameter *thread-id-map* (make-hash-table)) +(defparameter *id-thread-map* (make-hash-table)) + +(defvar *thread-id-map-lock* + (mt:make-lock :name "thread id map lock")) + +(defparameter +default-thread-local-variables+ + '(*macroexpand-hook* + *default-pathname-defaults* + *readtable* + *random-state* + *compile-print* + *compile-verbose* + *load-print* + *load-verbose* + *print-array* + *print-base* + *print-case* + *print-circle* + *print-escape* + *print-gensym* + *print-length* + *print-level* + *print-lines* + *print-miser-width* + *print-pprint-dispatch* + *print-pretty* + *print-radix* + *print-readably* + *print-right-margin* + *read-base* + *read-default-float-format* + *read-eval* + *read-suppress* + )) + +(defun thread-local-default-bindings () + (let (local) + (dolist (var +default-thread-local-variables+ local) + (setq local (acons var (symbol-value var) local)) + ))) + +;; mkcl doesn't have weak pointers +(defimplementation spawn (fn &key name initial-bindings) + (let* ((local-defaults (thread-local-default-bindings)) + (thread + ;;(mt:make-thread :name name) + (mt:make-thread :name name + :initial-bindings (nconc initial-bindings + local-defaults)) + ) + (id (next-thread-id))) + (mt:with-lock (*thread-id-map-lock*) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id)) + (mt:thread-preset + thread + #'(lambda () + (unwind-protect + (progn + ;;(format t "~&Starting thread: ~S.~%" name) (finish-output) + (mt:thread-detach nil) + (funcall fn)) + (progn + ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output) + (mt:with-lock (*thread-id-map-lock*) + (remhash thread *id-thread-map*) + (remhash id *thread-id-map*)) + ;;(format t "~&Finished thread: ~S~%" name) (finish-output) + )))) + (mt:thread-enable thread) + (mt:thread-yield) + thread + )) + +(defimplementation thread-id (thread) + (block thread-id + (mt:with-lock (*thread-id-map-lock*) + (or (gethash thread *id-thread-map*) + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id) + id))))) + +(defimplementation find-thread (id) + (mt:with-lock (*thread-id-map-lock*) + (gethash id *thread-id-map*))) + +(defimplementation thread-name (thread) + (mt:thread-name thread)) + +(defimplementation thread-status (thread) + (if (mt:thread-active-p thread) + "RUNNING" + "STOPPED")) + +(defimplementation make-lock (&key name) + (mt:make-lock :name name :recursive t)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mt:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mt:*thread*) + +(defimplementation all-threads () + (mt:all-threads)) + +(defimplementation interrupt-thread (thread fn) + (mt:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (mt:interrupt-thread thread #'mt:terminate-thread) + ) + +(defimplementation thread-alive-p (thread) + (mt:thread-active-p thread)) + +(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock")) +(defvar *mailboxes* (list)) +(declaim (type list *mailboxes*)) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + locked-by + (mutex (mt:make-lock :name "thread mailbox")) + (semaphore (mt:make-semaphore)) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mt: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) + (handler-case + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) +;; (mt:interrupt-thread +;; thread +;; (lambda () +;; (mt:with-lock (mutex) +;; (setf (mailbox.queue mbox) +;; (nconc (mailbox.queue mbox) (list message)))))) + +;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%" +;; mt:*thread* thread message) (finish-output) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + ;;(format t "*") (finish-output) + (handler-case + (mt:semaphore-signal (mailbox.semaphore mbox)) + (condition (condition) + (format t "Something went bad with semaphore-signal ~A" condition) (finish-output) + ;;(break) + )) + (setf (mailbox.locked-by mbox) nil) + ) + ;;(format t "+") (finish-output) + ) + (condition (condition) + (format t "~&Error in send: ~S~%" condition) (finish-output)) + ) + ) + +;; (defimplementation receive () +;; (block got-mail +;; (let* ((mbox (mailbox mt:*thread*)) +;; (mutex (mailbox.mutex mbox))) +;; (loop +;; (mt:with-lock (mutex) +;; (if (mailbox.queue mbox) +;; (return-from got-mail (pop (mailbox.queue mbox))))) +;; ;;interrupt-thread will halt this if it takes longer than 1sec +;; (sleep 1))))) + + +(defimplementation receive-if (test &optional timeout) + (handler-case + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + got-one) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + ;;(format t "~&: ~S~%" mt:*thread*) (finish-output) + (handler-case + (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2)) + (condition (condition) + (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition) + (finish-output) + nil + ) + ) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (setf (mailbox.locked-by mbox) nil) + ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail)) + (return (car tail)))) + (setf (mailbox.locked-by mbox) nil) + ) + + ;;(format t "/ ~S~%" mt:*thread*) (finish-output) + (when (eq timeout t) (return (values nil t))) +;; (unless got-one +;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%")) + ) + ) + (condition (condition) + (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output) + nil + ) + ) + ) + + +(defmethod stream-finish-output ((stream stream)) + (finish-output stream)) + + +;; + +;;#+windows +(defimplementation doze-in-repl () + (setq *inferior-lisp-sleeping-post* (mt:make-semaphore)) + ;;(loop (sleep 1)) + (mt:semaphore-wait *inferior-lisp-sleeping-post*) + (mk-ext:quit :verbose t) + ) + diff --git a/vim/bundle/slimv/slime/swank/rpc.lisp b/vim/bundle/slimv/slime/swank/rpc.lisp new file mode 100644 index 0000000..e30cc2c --- /dev/null +++ b/vim/bundle/slimv/slime/swank/rpc.lisp @@ -0,0 +1,162 @@ +;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- +;;; +;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. +;;; +;;; Created 2010, Terje Norderhaug +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/rpc) + + +;;;;; Input + +(define-condition swank-reader-error (reader-error) + ((packet :type string :initarg :packet + :reader swank-reader-error.packet) + (cause :type reader-error :initarg :cause + :reader swank-reader-error.cause))) + +(defun read-message (stream package) + (let ((packet (read-packet stream))) + (handler-case (values (read-form packet package)) + (reader-error (c) + (error 'swank-reader-error + :packet packet :cause c))))) + +(defun read-packet (stream) + (let* ((length (parse-header stream)) + (octets (read-chunk stream length))) + (handler-case (swank/backend:utf8-to-string octets) + (error (c) + (error 'swank-reader-error + :packet (asciify octets) + :cause c))))) + +(defun asciify (packet) + (with-output-to-string (*standard-output*) + (loop for code across (etypecase packet + (string (map 'vector #'char-code packet)) + (vector packet)) + do (cond ((<= code #x7f) (write-char (code-char code))) + (t (format t "\\x~x" code)))))) + +(defun parse-header (stream) + (parse-integer (map 'string #'code-char (read-chunk stream 6)) + :radix 16)) + +(defun read-chunk (stream length) + (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) + (count (read-sequence buffer stream))) + (cond ((= count length) + buffer) + ((zerop count) + (error 'end-of-file :stream stream)) + (t + (error "Short read: length=~D count=~D" length count))))) + +(defparameter *validate-input* nil + "Set to true to require input that more strictly conforms to the protocol") + +(defun read-form (string package) + (with-standard-io-syntax + (let ((*package* package)) + (if *validate-input* + (validating-read string) + (read-from-string string))))) + +(defun validating-read (string) + (with-input-from-string (*standard-input* string) + (simple-read))) + +(defun simple-read () + "Read a form that conforms to the protocol, otherwise signal an error." + (let ((c (read-char))) + (case c + (#\( (loop collect (simple-read) + while (ecase (read-char) + (#\) nil) + (#\space t)))) + (#\' `(quote ,(simple-read))) + (t + (cond + ((digit-char-p c) + (parse-integer + (map 'simple-string #'identity + (loop for ch = c then (read-char nil nil) + while (and ch (digit-char-p ch)) + collect ch + finally (unread-char ch))))) + ((or (member c '(#\: #\")) (alpha-char-p c)) + (unread-char c) + (read-preserving-whitespace)) + (t (error "Invalid character ~:c" c))))))) + + +;;;;; Output + +(defun write-message (message package stream) + (let* ((string (prin1-to-string-for-emacs message package)) + (octets (handler-case (swank/backend:string-to-utf8 string) + (error (c) (encoding-error c string)))) + (length (length octets))) + (write-header stream length) + (write-sequence octets stream) + (finish-output stream))) + +;; FIXME: for now just tell emacs that we and an encoding problem. +(defun encoding-error (condition string) + (swank/backend:string-to-utf8 + (prin1-to-string-for-emacs + `(:reader-error + ,(asciify string) + ,(format nil "Error during string-to-utf8: ~a" + (or (ignore-errors (asciify (princ-to-string condition))) + (asciify (princ-to-string (type-of condition)))))) + (find-package :cl)))) + +(defun write-header (stream length) + (declare (type (unsigned-byte 24) length)) + ;;(format *trace-output* "length: ~d (#x~x)~%" length length) + (loop for c across (format nil "~6,'0x" length) + do (write-byte (char-code c) stream))) + +(defun switch-to-double-floats (x) + (typecase x + (double-float x) + (float (coerce x 'double-float)) + (null x) + (list (loop for (x . cdr) on x + collect (switch-to-double-floats x) into result + until (atom cdr) + finally (return (append result (switch-to-double-floats cdr))))) + (t x))) + +(defun prin1-to-string-for-emacs (object package) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* package) + ;; Emacs has only double floats. + (*read-default-float-format* 'double-float)) + (prin1-to-string (switch-to-double-floats object))))) + + +#| TEST/DEMO: + +(defparameter *transport* + (with-output-to-string (out) + (write-message '(:message (hello "world")) *package* out) + (write-message '(:return 5) *package* out) + (write-message '(:emacs-rex NIL) *package* out))) + +*transport* + +(with-input-from-string (in *transport*) + (loop while (peek-char T in NIL) + collect (read-message in *package*))) + +|# diff --git a/vim/bundle/slimv/slime/swank/sbcl.lisp b/vim/bundle/slimv/slime/swank/sbcl.lisp new file mode 100644 index 0000000..b54fcd5 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/sbcl.lisp @@ -0,0 +1,2044 @@ +;;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-sbcl.lisp --- SLIME backend for SBCL. +;;; +;;; Created 2003, Daniel Barlow +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. + +;;; Requires the SB-INTROSPECT contrib. + +;;; Administrivia + +(defpackage swank/sbcl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) + +(in-package swank/sbcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sb-bsd-sockets) + (require 'sb-introspect) + (require 'sb-posix) + (require 'sb-cltl2)) + +(declaim (optimize (debug 2) + (sb-c::insert-step-conditions 0) + (sb-c::insert-debug-catch 0))) + +;;; backwards compability tests + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Generate a form suitable for testing for stepper support (0.9.17) + ;; with #+. + (defun sbcl-with-new-stepper-p () + (with-symbol 'enable-stepping 'sb-impl)) + ;; Ditto for weak hash-tables + (defun sbcl-with-weak-hash-tables () + (with-symbol 'hash-table-weakness 'sb-ext)) + ;; And for xref support (1.0.1) + (defun sbcl-with-xref-p () + (with-symbol 'who-calls 'sb-introspect)) + ;; ... for restart-frame support (1.0.2) + (defun sbcl-with-restart-frame () + (with-symbol 'frame-has-debug-tag-p 'sb-debug)) + ;; ... for :setf :inverse info (1.1.17) + (defun sbcl-with-setf-inverse-meta-info () + (boolean-to-feature-expression + ;; going through FIND-SYMBOL since META-INFO was renamed from + ;; TYPE-INFO in 1.2.10. + (let ((sym (find-symbol "META-INFO" "SB-C"))) + (and sym + (fboundp sym) + (funcall sym :setf :inverse ())))))) + +;;; swank-mop + +(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (sb-pcl::documentation slot t)) + +;; stream support + +(defimplementation gray-package-name () + "SB-GRAY") + +;; Pretty printer calls this, apparently +(defmethod sb-gray:stream-line-length + ((s sb-gray:fundamental-character-input-stream)) + nil) + +;;; Connection info + +(defimplementation lisp-implementation-type-name () + "sbcl") + +;; Declare return type explicitly to shut up STYLE-WARNINGS about +;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below. +(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid)) +(defimplementation getpid () + (sb-posix:getpid)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (sb-ext:string-to-octets string :external-format :utf8)) + +(defimplementation utf8-to-string (octets) + (sb-ext:octets-to-string octets :external-format :utf8)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + (cond + ;; fixme: when SBCL/win32 gains better select() support, remove + ;; this. + ((member :sb-thread *features*) :spawn) + ((member :win32 *features*) nil) + (t :fd-handler))) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-sys:invalidate-descriptor (socket-fd socket)) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket &key + external-format + buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (accept socket) external-format + (ecase buffering + ((t :full) :full) + ((nil :none) :none) + ((:line) :line)))) + + +;; The SIGIO stuff should probably be removed as it's unlikey that +;; anybody uses it. +#-win32 +(progn + (defimplementation install-sigint-handler (function) + (sb-sys:enable-interrupt sb-unix:sigint + (lambda (&rest args) + (declare (ignore args)) + (sb-sys:invoke-interruption + (lambda () + (sb-sys:with-interrupts + (funcall function))))))) + + (defvar *sigio-handlers* '() + "List of (key . fn) pairs to be called on SIGIO.") + + (defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (sb-sys:with-interrupts + (mapc (lambda (handler) + (funcall (the function (cdr handler)))) + *sigio-handlers*))) + + (defun set-sigio-handler () + (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler)) + + (defun enable-sigio-on-fd (fd) + (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async) + (sb-posix::fcntl fd sb-posix::f-setown (getpid)) + (values)) + + (defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (enable-sigio-on-fd fd) + (push (cons fd fn) *sigio-handlers*))) + + (defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)) + (sb-sys:invalidate-descriptor fd)) + (close socket))) + + +(defimplementation add-fd-handler (socket fun) + (let ((fd (socket-fd socket)) + (handler nil)) + (labels ((add () + (setq handler (sb-sys:add-fd-handler fd :input #'run))) + (run (fd) + (sb-sys:remove-fd-handler handler) ; prevent recursion + (unwind-protect + (funcall fun) + (when (sb-unix:unix-fstat fd) ; still open? + (add))))) + (add)))) + +(defimplementation remove-fd-handlers (socket) + (sb-sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (sb-sys:fd-stream-fd socket)))) + +(defimplementation command-line-args () + sb-ext:*posix-argv*) + +(defimplementation dup (fd) + (sb-posix:dup fd)) + +(defvar *wait-for-input-called*) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (when (boundp '*wait-for-input-called*) + (setq *wait-for-input-called* t)) + (let ((*wait-for-input-called* nil)) + (loop + (let ((ready (remove-if-not #'input-ready-p streams))) + (when ready (return ready))) + (when (check-slime-interrupts) + (return :interrupt)) + (when *wait-for-input-called* + (return :interrupt)) + (when timeout + (return nil)) + (sleep 0.1)))) + +(defun fd-stream-input-buffer-empty-p (stream) + (let ((buffer (sb-impl::fd-stream-ibuf stream))) + (or (not buffer) + (= (sb-impl::buffer-head buffer) + (sb-impl::buffer-tail buffer))))) + +#-win32 +(defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl) + (eq :regular (sb-impl::fd-stream-fd-type stream)) + (not (sb-impl::sysread-may-block-p stream)))) + +#+win32 +(progn + (defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream))))) + + (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event) + sb-win32:handle) + + (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event) + sb-alien:int + (event sb-win32:handle)) + + (defconstant +fd-read+ #.(ash 1 0)) + (defconstant +fd-close+ #.(ash 1 5)) + + (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) + sb-alien:int + (fd sb-alien:int) + (handle sb-win32:handle) + (mask sb-alien:long)) + + (sb-alien:load-shared-object "kernel32.dll") + (sb-alien:define-alien-routine ("WaitForSingleObjectEx" + wait-for-single-object-ex) + sb-alien:int + (event sb-win32:handle) + (milliseconds sb-alien:long) + (alertable sb-alien:int)) + + ;; see SB-WIN32:HANDLE-LISTEN + (defun handle-listen (handle) + (sb-alien:with-alien ((avail sb-win32:dword) + (buf (array char #.sb-win32::input-record-size))) + (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil + (sb-alien:alien-sap + (sb-alien:addr avail)) + nil)) + (return-from handle-listen (plusp avail))) + + (unless (zerop (sb-win32:peek-console-input handle + (sb-alien:alien-sap buf) + sb-win32::input-record-size + (sb-alien:alien-sap + (sb-alien:addr avail)))) + (return-from handle-listen (plusp avail)))) + + (let ((event (wsa-create-event))) + (wsa-event-select handle event (logior +fd-read+ +fd-close+)) + (let ((val (wait-for-single-object-ex event 0 0))) + (wsa-close-event event) + (unless (= val -1) + (return-from handle-listen (zerop val))))) + + nil) + + ) + +(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"))) + +;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, +;; 2008-08-22. +(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname))) + +(defimplementation filename-to-pathname (filename) + (sb-ext:parse-native-namestring filename *physical-pathname-host*)) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation set-default-directory (directory) + (let ((directory (truename (merge-pathnames directory)))) + (sb-posix:chdir directory) + (setf *default-pathname-defaults* directory) + (default-directory))) + +(defun make-socket-io-stream (socket external-format buffering) + (let ((args `(,@() + :output t + :input t + :element-type ,(if external-format + 'character + '(unsigned-byte 8)) + :buffering ,buffering + ,@(cond ((and external-format (sb-int:featurep :sb-unicode)) + `(:external-format ,external-format)) + (t '())) + :serve-events ,(eq :fd-handler swank:*communication-style*) + ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS + ;; argument. + :allow-other-keys t))) + (apply #'sb-bsd-sockets:socket-make-stream socket args))) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + + +;;;; Support for SBCL syntax + +;;; SBCL's source code is riddled with #! reader macros. Also symbols +;;; containing `!' have special meaning. We have to work long and +;;; hard to be able to read the source. To deal with #! reader +;;; macros, we use a special readtable. The special symbols are +;;; converted by a condition handler. + +(defun feature-in-list-p (feature list) + (etypecase feature + (symbol (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (feature-in-list-p subfeature list))) + ;; Don't use ECASE since SBCL also has :host-feature, + ;; don't need to handle it or anything else appearing in + ;; the future or in erronous code. + (case (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (destructuring-bind (e) (cdr feature) + (not (subfeature-in-list-p e))))))))) + +(defun shebang-reader (stream sub-character infix-parameter) + (declare (ignore sub-character)) + (when infix-parameter + (error "illegal read syntax: #~D!" infix-parameter)) + (let ((next-char (read-char stream))) + (unless (find next-char "+-") + (error "illegal read syntax: #!~C" next-char)) + ;; When test is not satisfied + ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then + ;; would become "unless test is satisfied".. + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *features*) + not-p + (not not-p))) + ;; Read (and discard) a form from input. + (let ((*read-suppress* t)) + (read stream t nil t)))) + (values)) + +(defvar *shebang-readtable* + (let ((*readtable* (copy-readtable nil))) + (set-dispatch-macro-character #\# #\! + (lambda (s c n) (shebang-reader s c n)) + *readtable*) + *readtable*)) + +(defun shebang-readtable () + *shebang-readtable*) + +(defun sbcl-package-p (package) + (let ((name (package-name package))) + (eql (mismatch "SB-" name) 3))) + +(defun sbcl-source-file-p (filename) + (when filename + (loop for (nil pattern) in (logical-pathname-translations "SYS") + thereis (pathname-match-p filename pattern)))) + +(defun guess-readtable-for-filename (filename) + (if (sbcl-source-file-p filename) + (shebang-readtable) + *readtable*)) + +(defvar *debootstrap-packages* t) + +(defun call-with-debootstrapping (fun) + (handler-bind ((sb-int:bootstrap-package-not-found + #'sb-int:debootstrap-package)) + (funcall fun))) + +(defmacro with-debootstrapping (&body body) + `(call-with-debootstrapping (lambda () ,@body))) + +(defimplementation call-with-syntax-hooks (fn) + (cond ((and *debootstrap-packages* + (sbcl-package-p *package*)) + (with-debootstrapping (funcall fn))) + (t + (funcall fn)))) + +(defimplementation default-readtable-alist () + (let ((readtable (shebang-readtable))) + (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages)) + collect (cons (package-name p) readtable)))) + +;;; Packages + +#+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext) +(defimplementation package-local-nicknames (package) + (sb-ext:package-local-nicknames package)) + +;;; Utilities + +#+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-lambda-list fname)) + +#-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-arglist fname)) + +(defimplementation function-name (f) + (check-type f function) + (sb-impl::%fun-name f)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) + (let* ((flags (sb-cltl2:declaration-information decl-identifier))) + (if flags + ;; Symbols aren't printed with package qualifiers, but the + ;; FLAGS would have to be fully qualified when used inside a + ;; declaration. So we strip those as long as there's no + ;; better way. (FIXME) + `(&any ,@(remove-if-not + #'(lambda (qualifier) + (find-symbol (symbol-name (first qualifier)) :cl)) + flags :key #'ensure-list)) + (call-next-method))))) + +#+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect) +(defmethod type-specifier-arglist :around (typespec-operator) + (multiple-value-bind (arglist foundp) + (sb-introspect:deftype-lambda-list typespec-operator) + (if foundp arglist (call-next-method)))) + +(defimplementation type-specifier-p (symbol) + (or (sb-ext:valid-type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defvar *buffer-name* nil) +(defvar *buffer-tmpfile* nil) +(defvar *buffer-offset*) +(defvar *buffer-substring* nil) + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning. +This traps all compiler conditions at a lower-level than using +C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to +craft our own error messages, which can omit a lot of redundant +information." + (unless (or (eq condition *previous-compiler-condition*)) + ;; First resignal warnings, so that outer handlers -- which may choose to + ;; muffle this -- get a chance to run. + (when (typep condition 'warning) + (signal condition)) + (setq *previous-compiler-condition* condition) + (signal-compiler-condition (real-condition condition) + (sb-c::find-error-context nil)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (etypecase condition + (sb-ext:compiler-note :note) + (sb-c:compiler-error :error) + (reader-error :read-error) + (error :error) + #+#.(swank/backend:with-symbol redefinition-warning + sb-kernel) + (sb-kernel:redefinition-warning + :redefinition) + (style-warning :style-warning) + (warning :warning)) + :references (condition-references condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (compiler-note-location condition context))) + +(defun real-condition (condition) + "Return the encapsulated condition or CONDITION itself." + (typecase condition + (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) + (t condition))) + +(defun condition-references (condition) + (if (typep condition 'sb-int:reference-condition) + (externalize-reference + (sb-int:reference-condition-references condition)))) + +(defun compiler-note-location (condition context) + (flet ((bailout () + (return-from compiler-note-location + (make-error-location "No error location available")))) + (cond (context + (locate-compiler-note + (sb-c::compiler-error-context-file-name context) + (compiler-source-path context) + (sb-c::compiler-error-context-original-source context))) + ((typep condition 'reader-error) + (let* ((stream (stream-error-stream condition)) + (file (pathname stream))) + (unless (open-stream-p stream) + (bailout)) + (if (compiling-from-buffer-p file) + ;; The stream position for e.g. "comma not inside + ;; backquote" is at the character following the + ;; comma, :offset is 0-based, hence the 1-. + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (1- (file-position stream)))) + (progn + (assert (compiling-from-file-p file)) + ;; No 1- because :position is 1-based. + (make-location (list :file (namestring file)) + (list :position (file-position stream))))))) + (t (bailout))))) + +(defun compiling-from-buffer-p (filename) + (and *buffer-name* + ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P + ;; in LOCATE-COMPILER-NOTE, and allows handling nested + ;; compilation from eg. hitting C-C on (eval-when ... (require ..))). + ;; + ;; PROBE-FILE to handle tempfile directory being a symlink. + (pathnamep filename) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (and true1 (equal true1 true2))))) + +(defun compiling-from-file-p (filename) + (and (pathnamep filename) + (or (null *buffer-name*) + (null *buffer-tmpfile*) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (not (and true1 (equal true1 true2))))))) + +(defun compiling-from-generated-code-p (filename source) + (and (eq filename :lisp) (stringp source))) + +(defun locate-compiler-note (file source-path source) + (cond ((compiling-from-buffer-p file) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (source-path-string-position + source-path *buffer-substring*)))) + ((compiling-from-file-p file) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (namestring file)) + (list :position (and position + (1+ position)))))) + ((compiling-from-generated-code-p file source) + (make-location (list :source-form source) + (list :position 1))) + (t + (error "unhandled case in compiler note ~S ~S ~S" + file source-path source)))) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or sb-c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (sb-c::compiler-error-context-enclosing-source error-context) + (sb-c::compiler-error-context-source error-context))) + (and (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]" + enclosing source)))) + +(defun compiler-source-path (context) + "Return the source-path for the current compiler error. +Returns NIL if this cannot be determined by examining internal +compiler state." + (cond ((sb-c::node-p context) + (reverse + (sb-c::source-path-original-source + (sb-c::node-source-path context)))) + ((sb-c::compiler-error-context-p context) + (reverse + (sb-c::compiler-error-context-original-source-path context))))) + +(defimplementation call-with-compilation-hooks (function) + (declare (type function function)) + (handler-bind + ;; N.B. Even though these handlers are called HANDLE-FOO they + ;; actually decline, i.e. the signalling of the original + ;; condition continues upward. + ((sb-c:fatal-compiler-error #'handle-notification-condition) + (sb-c:compiler-error #'handle-notification-condition) + (sb-ext:compiler-note #'handle-notification-condition) + (error #'handle-notification-condition) + (warning #'handle-notification-condition)) + (funcall function))) + +;;; HACK: SBCL 1.2.12 shipped with a bug where +;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there +;;; were no policy restrictions in place. This workaround ensures the +;;; existence of at least one dummy restriction. +(handler-case (sb-ext:restrict-compiler-policy) + (error () (sb-ext:restrict-compiler-policy 'debug))) + +(defun compiler-policy (qualities) + "Return compiler policy qualities present in the QUALITIES alist. +QUALITIES is an alist with (quality . value)" + #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop with policy = (sb-ext:restrict-compiler-policy) + for (quality) in qualities + collect (cons quality + (or (cdr (assoc quality policy)) + 0)))) + +(defun (setf compiler-policy) (policy) + (declare (ignorable policy)) + #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop for (qual . value) in policy + do (sb-ext:restrict-compiler-policy qual value))) + +(defmacro with-compiler-policy (policy &body body) + (let ((current-policy (gensym))) + `(let ((,current-policy (compiler-policy ,policy))) + (setf (compiler-policy) ,policy) + (unwind-protect (progn ,@body) + (setf (compiler-policy) ,current-policy))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (multiple-value-bind (output-file warnings-p failure-p) + (with-compiler-policy policy + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :external-format external-format))) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))) + +;;;; compile-string + +;;; We copy the string to a temporary file in order to get adequate +;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms +;;; which the previous approach using +;;; (compile nil `(lambda () ,(read-from-string string))) +;;; did not provide. + +(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + +(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam) + sb-alien:c-string + (dir sb-alien:c-string) + (prefix sb-alien:c-string)) + +) + +(defun temp-file-name () + "Return a temporary file name to compile strings into." + (tempnam nil nil)) + +(defvar *trap-load-time-warnings* t) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string) + (*buffer-tmpfile* (temp-file-name))) + (labels ((load-it (filename) + (cond (*trap-load-time-warnings* + (with-compilation-hooks () (load filename))) + (t (load filename)))) + (cf () + (with-compiler-policy policy + (with-compilation-unit + (:source-plist (list :emacs-buffer buffer + :emacs-filename filename + :emacs-package (package-name *package*) + :emacs-position position + :emacs-string string) + :source-namestring filename + :allow-other-keys t) + (compile-file *buffer-tmpfile* :external-format :utf-8))))) + (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error + :external-format :utf-8) + (write-string string s)) + (unwind-protect + (multiple-value-bind (output-file warningsp failurep) + (with-compilation-hooks () (cf)) + (declare (ignore warningsp)) + (when output-file + (load-it output-file)) + (not failurep)) + (ignore-errors + (delete-file *buffer-tmpfile*) + (delete-file (compile-file-pathname *buffer-tmpfile*))))))) + +;;;; Definitions + +(defparameter *definition-types* + '(:variable defvar + :constant defconstant + :type deftype + :symbol-macro define-symbol-macro + :macro defmacro + :compiler-macro define-compiler-macro + :function defun + :generic-function defgeneric + :method defmethod + :setf-expander define-setf-expander + :structure defstruct + :condition define-condition + :class defclass + :method-combination define-method-combination + :package defpackage + :transform :deftransform + :optimizer :defoptimizer + :vop :define-vop + :source-transform :define-source-transform + :ir1-convert :def-ir1-translator + :declaration declaim + :alien-type :define-alien-type) + "Map SB-INTROSPECT definition type names to Slime-friendly forms") + +(defun definition-specifier (type) + "Return a pretty specifier for NAME representing a definition of type TYPE." + (getf *definition-types* type)) + +(defun make-dspec (type name source-location) + (list* (definition-specifier type) + name + (sb-introspect::definition-source-description source-location))) + +(defimplementation find-definitions (name) + (loop for type in *definition-types* by #'cddr + for defsrcs = (sb-introspect:find-definition-sources-by-name name type) + append (loop for defsrc in defsrcs collect + (list (make-dspec type name defsrc) + (converting-errors-to-error-location + (definition-source-for-emacs defsrc + type name)))))) + +(defimplementation find-source-location (obj) + (flet ((general-type-of (obj) + (typecase obj + (method :method) + (generic-function :generic-function) + (function :function) + (structure-class :structure-class) + (class :class) + (method-combination :method-combination) + (package :package) + (condition :condition) + (structure-object :structure-object) + (standard-object :standard-object) + (t :thing))) + (to-string (obj) + (typecase obj + ;; Packages are possibly named entities. + (package (princ-to-string obj)) + ((or structure-object standard-object condition) + (with-output-to-string (s) + (print-unreadable-object (obj s :type t :identity t)))) + (t (princ-to-string obj))))) + (converting-errors-to-error-location + (let ((defsrc (sb-introspect:find-definition-source obj))) + (definition-source-for-emacs defsrc + (general-type-of obj) + (to-string obj)))))) + +(defmacro with-definition-source ((&rest names) obj &body body) + "Like with-slots but works only for structs." + (flet ((reader (slot) + ;; Use read-from-string instead of intern so that + ;; conc-name can be a string such as ext:struct- and not + ;; cause errors and not force interning ext::struct- + (read-from-string + (concatenate 'string "sb-introspect:definition-source-" + (string slot))))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defun categorize-definition-source (definition-source) + (with-definition-source (pathname form-path character-offset plist) + definition-source + (let ((file-p (and pathname (probe-file pathname) + (or form-path character-offset)))) + (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) + ((getf plist :emacs-buffer) :buffer) + (file-p :file) + (pathname :file-without-position) + (t :invalid))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun form-number-position (definition-source stream) + (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source))) + (form-number (sb-introspect:definition-source-form-number definition-source))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun file-form-number-position (definition-source) + (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source)) + (filename (sb-introspect:definition-source-pathname definition-source)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (form-number-position definition-source s))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun string-form-number-position (definition-source string) + (with-input-from-string (s string) + (form-number-position definition-source s))) + +(defun definition-source-buffer-location (definition-source) + (with-definition-source (form-path character-offset plist) definition-source + (destructuring-bind (&key emacs-buffer emacs-position emacs-directory + emacs-string &allow-other-keys) + plist + (let ((*readtable* (guess-readtable-for-filename emacs-directory)) + start + end) + (with-debootstrapping + (or + (and form-path + (or + #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) + (setf (values start end) + (and (sb-introspect:definition-source-form-number definition-source) + (string-form-number-position definition-source emacs-string))) + (setf (values start end) + (source-path-string-position form-path emacs-string)))) + (setf start character-offset + end most-positive-fixnum))) + (make-location + `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,start) + `(:snippet + ,(subseq emacs-string + start + (min end (+ start *source-snippet-size*))))))))) + +(defun definition-source-file-location (definition-source) + (with-definition-source (pathname form-path character-offset plist + file-write-date) definition-source + (let* ((namestring (namestring (translate-logical-pathname pathname))) + (pos (or (and form-path + (or + #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) + (and (sb-introspect:definition-source-form-number definition-source) + (ignore-errors (file-form-number-position definition-source))) + (ignore-errors + (source-file-position namestring file-write-date + form-path)))) + character-offset)) + (snippet (source-hint-snippet namestring file-write-date pos))) + (make-location `(:file ,namestring) + ;; /file positions/ in Common Lisp start from + ;; 0, buffer positions in Emacs start from 1. + `(:position ,(1+ pos)) + `(:snippet ,snippet))))) + +(defun definition-source-buffer-and-file-location (definition-source) + (let ((buffer (definition-source-buffer-location definition-source))) + (make-location (list :buffer-and-file + (cadr (location-buffer buffer)) + (namestring (sb-introspect:definition-source-pathname + definition-source))) + (location-position buffer) + (location-hints buffer)))) + +(defun definition-source-for-emacs (definition-source type name) + (with-definition-source (pathname form-path character-offset plist + file-write-date) + definition-source + (ecase (categorize-definition-source definition-source) + (:buffer-and-file + (definition-source-buffer-and-file-location definition-source)) + (:buffer + (definition-source-buffer-location definition-source)) + (:file + (definition-source-file-location definition-source)) + (:file-without-position + (make-location `(:file ,(namestring + (translate-logical-pathname pathname))) + '(:position 1) + (when (eql type :function) + `(:snippet ,(format nil "(defun ~a " + (symbol-name name)))))) + (:invalid + (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ + meaningful information." + type name))))) + +(defun source-file-position (filename write-date form-path) + (let ((source (get-source-code filename write-date)) + (*readtable* (guess-readtable-for-filename filename))) + (with-debootstrapping + (source-path-string-position form-path source)))) + +(defun source-hint-snippet (filename write-date position) + (read-snippet-from-string (get-source-code filename write-date) position)) + +(defun function-source-location (function &optional name) + (declare (type function function)) + (definition-source-for-emacs (sb-introspect:find-definition-source function) + :function + (or name (function-name function)))) + +(defun setf-expander (symbol) + (or + #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info) + (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (sb-int:info :variable :kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (and (setf-expander symbol) + (doc 'setf))) + (maybe-push + :type (if (sb-int:info :type :kind symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol type) + (case type + (:variable + (describe symbol)) + (:function + (describe (symbol-function symbol))) + (:setf + (describe (setf-expander symbol))) + (:class + (describe (find-class symbol))) + (:type + (describe (sb-kernel:values-specifier-type symbol))))) + +#+#.(swank/sbcl::sbcl-with-xref-p) +(progn + (defmacro defxref (name &optional fn-name) + `(defimplementation ,name (what) + (sanitize-xrefs + (mapcar #'source-location-for-xref-data + (,(find-symbol (symbol-name (if fn-name + fn-name + name)) + "SB-INTROSPECT") + what))))) + (defxref who-calls) + (defxref who-binds) + (defxref who-sets) + (defxref who-references) + (defxref who-macroexpands) + #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect) + (defxref who-specializes who-specializes-directly)) + +(defun source-location-for-xref-data (xref-data) + (destructuring-bind (name . defsrc) xref-data + (list name (converting-errors-to-error-location + (definition-source-for-emacs defsrc 'function name))))) + +(defimplementation list-callers (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))) + +(defimplementation list-callees (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))) + +(defun sanitize-xrefs (xrefs) + (remove-duplicates + (remove-if (lambda (f) + (member f (ignored-xref-function-names))) + (loop for entry in xrefs + for name = (car entry) + collect (if (and (consp name) + (member (car name) + '(sb-pcl::fast-method + sb-pcl::slow-method + sb-pcl::method))) + (cons (cons 'defmethod (cdr name)) + (cdr entry)) + entry)) + :key #'car) + :test (lambda (a b) + (and (eq (first a) (first b)) + (equal (second a) (second b)))))) + +(defun ignored-xref-function-names () + #-#.(swank/sbcl::sbcl-with-new-stepper-p) + '(nil sb-c::step-form sb-c::step-values) + #+#.(swank/sbcl::sbcl-with-new-stepper-p) + '(nil)) + +(defun function-dspec (fn) + "Describe where the function FN was defined. +Return a list of the form (NAME LOCATION)." + (let ((name (function-name fn))) + (list name (converting-errors-to-error-location + (function-source-location fn name))))) + +;;; macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (sb-cltl2:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional environment) + (let ((macro-forms '()) + (compiler-macro-forms '()) + (function-quoted-forms '())) + (sb-walker:walk-form + form environment + (lambda (form context environment) + (declare (ignore context)) + (when (and (consp form) + (symbolp (car form))) + (cond ((eq (car form) 'function) + (push (cadr form) function-quoted-forms)) + ((member form function-quoted-forms) + nil) + ((macro-function (car form) environment) + (push form macro-forms)) + ((not (eq form (compiler-macroexpand-1 form environment))) + (push form compiler-macro-forms)))) + form)) + (values macro-forms compiler-macro-forms))) + + +;;; Debugging + +;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger +;;; than just a hook into BREAK. In particular, it'll make +;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather +;;; than the native debugger. That should probably be considered a +;;; feature. + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(sb-int:named-lambda swank-invoke-debugger-hook + (condition old-hook) + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defun set-break-hook (hook) + (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + +(defun call-with-break-hook (hook continuation) + (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall continuation))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (set-break-hook function)) + +(defimplementation condition-extras (condition) + (cond #+#.(swank/sbcl::sbcl-with-new-stepper-p) + ((typep condition 'sb-impl::step-form-condition) + `((:show-frame-source 0))) + ((typep condition 'sb-int:reference-condition) + (let ((refs (sb-int:reference-condition-references condition))) + (if refs + `((:references ,(externalize-reference refs)))))))) + +(defun externalize-reference (ref) + (etypecase ref + (null nil) + (cons (cons (externalize-reference (car ref)) + (externalize-reference (cdr ref)))) + ((or string number) ref) + (symbol + (cond ((eq (symbol-package ref) (symbol-package :test)) + ref) + (t (symbol-name ref)))))) + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let ((*sldb-stack-top* + (if (and (not *debug-swank-backend*) + sb-debug:*stack-top-hint*) + #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + (sb-debug::resolve-stack-top-hint) + #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + sb-debug:*stack-top-hint* + (sb-di:top-frame))) + (sb-debug:*stack-top-hint* nil)) + (handler-bind ((sb-di:debug-condition + (lambda (condition) + (signal 'sldb-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +#+#.(swank/sbcl::sbcl-with-new-stepper-p) +(progn + (defimplementation activate-stepping (frame) + (declare (ignore frame)) + (sb-impl::enable-stepping)) + (defimplementation sldb-stepper-condition-p (condition) + (typep condition 'sb-ext:step-form-condition)) + (defimplementation sldb-step-into () + (invoke-restart 'sb-ext:step-into)) + (defimplementation sldb-step-next () + (invoke-restart 'sb-ext:step-next)) + (defimplementation sldb-step-out () + (invoke-restart 'sb-ext:step-out))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + #+#.(swank/sbcl::sbcl-with-new-stepper-p) + (sb-ext:*stepper-hook* + (lambda (condition) + (typecase condition + (sb-ext:step-form-condition + (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame))) + (sb-impl::invoke-debugger condition))))))) + (handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p) + (sb-ext:step-condition #'sb-impl::invoke-stepper)) + (call-with-break-hook hook fun)))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + "Return a list of frames starting with frame number START and +continuing to frame number END or, if END is nil, the last frame on the +stack." + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (sb-di:frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (sb-debug::print-frame-call frame stream)) + +(defimplementation frame-restartable-p (frame) + #+#.(swank/sbcl::sbcl-with-restart-frame) + (not (null (sb-debug:frame-has-debug-tag-p frame)))) + +(defimplementation frame-call (frame-number) + (multiple-value-bind (name args) + (sb-debug::frame-call (nth-frame frame-number)) + (with-output-to-string (stream) + (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + (let ((*print-length* nil) + (*print-level* nil)) + (prin1 (sb-debug::ensure-printable-object name) stream)) + (let ((args (sb-debug::ensure-printable-object args))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args))))))))) + +;;;; Code-location -> source-location translation + +;;; If debug-block info is avaibale, we determine the file position of +;;; the source-path for a code-location. If the code was compiled +;;; with C-c C-c, we have to search the position in the source string. +;;; If there's no debug-block info, we return the (less precise) +;;; source-location of the corresponding function. + +(defun code-location-source-location (code-location) + (let* ((dsource (sb-di:code-location-debug-source code-location)) + (plist (sb-c::debug-source-plist dsource)) + (package (getf plist :emacs-package)) + (*package* (or (and package + (find-package package)) + *package*))) + (if (getf plist :emacs-buffer) + (emacs-buffer-source-location code-location plist) + #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di) + (ecase (sb-di:debug-source-from dsource) + (:file (file-source-location code-location)) + (:lisp (lisp-source-location code-location))) + #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di) + (if (sb-di:debug-source-namestring dsource) + (file-source-location code-location) + (lisp-source-location code-location))))) + +;;; FIXME: The naming policy of source-location functions is a bit +;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the +;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co +;;; which returns the source location for a _code-location_. +;;; +;;; Maybe these should be named code-location-file-source-location, +;;; etc, turned into generic functions, or something. In the very +;;; least the names should indicate the main entry point vs. helper +;;; status. + +(defun file-source-location (code-location) + (if (code-location-has-debug-block-info-p code-location) + (source-file-source-location code-location) + (fallback-source-location code-location))) + +(defun fallback-source-location (code-location) + (let ((fun (code-location-debug-fun-fun code-location))) + (cond (fun (function-source-location fun)) + (t (error "Cannot find source location for: ~A " code-location))))) + +(defun lisp-source-location (code-location) + (let ((source (prin1-to-string + (sb-debug::code-location-source-form code-location 100))) + (condition swank:*swank-debugger-condition*)) + (if (and (typep condition 'sb-impl::step-form-condition) + (search "SB-IMPL::WITH-STEPPING-ENABLED" source + :test #'char-equal) + (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal)) + ;; The initial form is utterly uninteresting -- and almost + ;; certainly right there in the REPL. + (make-error-location "Stepping...") + (make-location `(:source-form ,source) '(:position 1))))) + +(defun emacs-buffer-source-location (code-location plist) + (if (code-location-has-debug-block-info-p code-location) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string + &allow-other-keys) + plist + (let* ((pos (string-source-position code-location emacs-string)) + (snipped (read-snippet-from-string emacs-string pos))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,pos) + `(:snippet ,snipped)))) + (fallback-source-location code-location))) + +(defun source-file-source-location (code-location) + (let* ((code-date (code-location-debug-source-created code-location)) + (filename (code-location-debug-source-name code-location)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (let* ((pos (stream-source-position code-location s)) + (snippet (read-snippet s pos))) + (make-location `(:file ,filename) + `(:position ,pos) + `(:snippet ,snippet))))))) + +(defun code-location-debug-source-name (code-location) + (namestring (truename (#.(swank/backend:choose-symbol + 'sb-c 'debug-source-name + 'sb-c 'debug-source-namestring) + (sb-di::code-location-debug-source code-location))))) + +(defun code-location-debug-source-created (code-location) + (sb-c::debug-source-created + (sb-di::code-location-debug-source code-location))) + +(defun code-location-debug-fun-fun (code-location) + (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) + +(defun code-location-has-debug-block-info-p (code-location) + (handler-case + (progn (sb-di:code-location-debug-block code-location) + t) + (sb-di:no-debug-blocks () nil))) + +(defun stream-source-position (code-location stream) + (let* ((cloc (sb-debug::maybe-block-start-location code-location)) + (tlf-number (sb-di::code-location-toplevel-form-offset cloc)) + (form-number (sb-di::code-location-form-number cloc))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +(defun string-source-position (code-location string) + (with-input-from-string (s string) + (stream-source-position code-location s))) + +;;; source-path-file-position and friends are in source-path-parser + +(defimplementation frame-source-location (index) + (converting-errors-to-error-location + (code-location-source-location + (sb-di:frame-code-location (nth-frame index))))) + +(defvar *keep-non-valid-locals* nil) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))) + (cond (*keep-non-valid-locals* all-vars) + (t (let ((loc (sb-di:frame-code-location frame))) + (remove-if (lambda (var) + (ecase (sb-di:debug-var-validity var loc) + (:valid nil) + ((:invalid :unknown) t))) + all-vars)))))) + +(defun debug-var-value (var frame location) + (ecase (sb-di:debug-var-validity var location) + (:valid (sb-di:debug-var-value var frame)) + ((:invalid :unknown) ':))) + +(defun debug-var-info (var) + ;; Introduced by SBCL 1.0.49.76. + (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di))) + (when (and s (fboundp s)) + (funcall s var)))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (sb-di:frame-code-location frame)) + (vars (frame-debug-vars frame)) + ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE + ;; specially. + (more-name (or (find-symbol "MORE" :sb-debug) 'more)) + (more-context nil) + (more-count nil) + (more-id 0)) + (when vars + (let ((locals + (loop for v across vars + do (when (eq (sb-di:debug-var-symbol v) more-name) + (incf more-id)) + (case (debug-var-info v) + (:more-context + (setf more-context (debug-var-value v frame loc))) + (:more-count + (setf more-count (debug-var-value v frame loc)))) + collect + (list :name (sb-di:debug-var-symbol v) + :id (sb-di:debug-var-id v) + :value (debug-var-value v frame loc))))) + (when (and more-context more-count) + (setf locals (append locals + (list + (list :name more-name + :id more-id + :value (multiple-value-list + (sb-c:%more-arg-values + more-context + 0 more-count))))))) + locals)))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (vars (frame-debug-vars frame)) + (loc (sb-di:frame-code-location frame)) + (dvar (if (= var (length vars)) + ;; If VAR is out of bounds, it must be the fake var + ;; we made up for &MORE. + (let* ((context-var (find :more-context vars + :key #'debug-var-info)) + (more-context (debug-var-value context-var frame + loc)) + (count-var (find :more-count vars + :key #'debug-var-info)) + (more-count (debug-var-value count-var frame loc))) + (return-from frame-var-value + (multiple-value-list (sb-c:%more-arg-values + more-context + 0 more-count)))) + (aref vars var)))) + (debug-var-value dvar frame loc))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (sb-di:frame-catches (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (let ((frame (nth-frame index))) + (funcall (the function + (sb-di:preprocess-for-eval form + (sb-di:frame-code-location frame))) + frame))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)))) + (when fun + (let ((name (function-name fun))) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql setf) (cons symbol)) (symbol-package (cadr name)))))))) + +#+#.(swank/sbcl::sbcl-with-restart-frame) +(progn + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (sb-debug:unwind-to-frame-and-call frame + (lambda () + (values-list values))))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (when (sb-debug:frame-has-debug-tag-p frame) + (multiple-value-bind (fname args) (sb-debug::frame-call frame) + (multiple-value-bind (fun arglist) + (if (and (sb-int:legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args) + (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) + (sb-debug::frame-args-as-list frame))) + (when (functionp fun) + (sb-debug:unwind-to-frame-and-call + frame + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist))))))) + (format nil "Cannot restart frame: ~S" frame)))) + +;; FIXME: this implementation doesn't unwind the stack before +;; re-invoking the function, but it's better than no implementation at +;; all. +#-#.(swank/sbcl::sbcl-with-restart-frame) +(progn + (defun sb-debug-catch-tag-p (tag) + (and (symbolp tag) + (not (symbol-package tag)) + (string= tag :sb-debug-catch-tag))) + + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index)) + (probe (assoc-if #'sb-debug-catch-tag-p + (sb-di::frame-catches frame)))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (return-from-frame index (sb-debug::frame-call-as-list frame))))) + +;;;;; reference-conditions + +(defimplementation print-condition (condition stream) + (let ((sb-int:*print-condition-references* nil)) + (princ condition stream))) + + +;;;; Profiling + +(defimplementation profile (fname) + (when fname (eval `(sb-profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(sb-profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (sb-profile:unprofile) + "All functions unprofiled.") + +(defimplementation profile-report () + (sb-profile:report)) + +(defimplementation profile-reset () + (sb-profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (sb-profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(sb-profile:profile ,(package-name (find-package package))))) + + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + (cond ((sb-di::indirect-value-cell-p o) + (label-value-line* (:value (sb-kernel:value-cell-ref o)))) + (t + (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) + (list* (string-right-trim '(#\Newline) text) + '(:newline) + (if label + (loop for (l . v) in parts + append (label-value-line l v)) + (loop for value in parts + for i from 0 + append (label-value-line i value)))))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (sb-kernel:widetag-of o))) + (cond ((= header sb-vm:simple-fun-header-widetag) + (label-value-line* + (:name (sb-kernel:%simple-fun-name o)) + (:arglist (sb-kernel:%simple-fun-arglist o)) + (:self (sb-kernel:%simple-fun-self o)) + (:next (sb-kernel:%simple-fun-next o)) + (:type (sb-kernel:%simple-fun-type o)) + (:code (sb-kernel:fun-code-header o)))) + ((= header sb-vm:closure-header-widetag) + (append + (label-value-line :function (sb-kernel:%closure-fun o)) + `("Closed over values:" (:newline)) + (loop for i below (1- (sb-kernel:get-closure-length o)) + append (label-value-line + i (sb-kernel:%closure-index-ref o i))))) + (t (call-next-method o))))) + +(defmethod emacs-inspect ((o sb-kernel:code-component)) + (append + (label-value-line* + (:code-size (sb-kernel:%code-code-size o)) + (:entry-points (sb-kernel:%code-entry-points o)) + (:debug-info (sb-kernel:%code-debug-info o))) + `("Constants:" (:newline)) + (loop for i from sb-vm:code-constants-offset + below + (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words + 'sb-kernel 'get-header-data) + o) + append (label-value-line i (sb-kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((sb-kernel:%code-debug-info o) + (sb-disassem:disassemble-code-component o :stream s)) + (t + (sb-disassem:disassemble-memory + (sb-disassem::align + (+ (logandc2 (sb-kernel:get-lisp-obj-address o) + sb-vm:lowtag-mask) + (* sb-vm:code-constants-offset + sb-vm:n-word-bytes)) + (ash 1 sb-vm:n-lowtag-bits)) + (ash (sb-kernel:%code-code-size o) sb-vm:word-shift) + :stream s))))))) + +(defmethod emacs-inspect ((o sb-ext:weak-pointer)) + (label-value-line* + (:value (sb-ext:weak-pointer-value o)))) + +(defmethod emacs-inspect ((o sb-kernel:fdefn)) + (label-value-line* + (:name (sb-kernel:fdefn-name o)) + (:function (sb-kernel:fdefn-fun o)))) + +(defmethod emacs-inspect :around ((o generic-function)) + (append + (call-next-method) + (label-value-line* + (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o)) + (:initial-methods (sb-pcl::generic-function-initial-methods o)) + ))) + + +;;;; Multiprocessing + +#+(and sb-thread + #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD")) +(progn + (defvar *thread-id-counter* 0) + + (defvar *thread-id-counter-lock* + (sb-thread:make-mutex :name "thread id counter lock")) + + (defun next-thread-id () + (sb-thread:with-mutex (*thread-id-counter-lock*) + (incf *thread-id-counter*))) + + (defparameter *thread-id-map* (make-hash-table)) + + ;; This should be a thread -> id map but as weak keys are not + ;; supported it is id -> map instead. + (defvar *thread-id-map-lock* + (sb-thread:make-mutex :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (sb-thread:make-thread fn :name name)) + + (defimplementation thread-id (thread) + (block thread-id + (sb-thread:with-mutex (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (cond ((null maybe-thread) + ;; the value is gc'd, remove it manually + (remhash id *thread-id-map*)) + ((eq thread maybe-thread) + (return-from thread-id id))))) + ;; lazy numbering + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) + id)))) + + (defimplementation find-thread (id) + (sb-thread:with-mutex (*thread-id-map-lock*) + (let ((thread-pointer (gethash id *thread-id-map*))) + (if thread-pointer + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (if maybe-thread + maybe-thread + ;; the value is gc'd, remove it manually + (progn + (remhash id *thread-id-map*) + nil))) + nil)))) + + (defimplementation thread-name (thread) + ;; sometimes the name is not a string (e.g. NIL) + (princ-to-string (sb-thread:thread-name thread))) + + (defimplementation thread-status (thread) + (if (sb-thread:thread-alive-p thread) + "Running" + "Stopped")) + + (defimplementation make-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (sb-thread:with-recursive-lock (lock) (funcall function))) + + (defimplementation current-thread () + sb-thread:*current-thread*) + + (defimplementation all-threads () + (sb-thread:list-all-threads)) + + (defimplementation interrupt-thread (thread fn) + (sb-thread:interrupt-thread thread fn)) + + (defimplementation kill-thread (thread) + (sb-thread:terminate-thread thread)) + + (defimplementation thread-alive-p (thread) + (sb-thread:thread-alive-p thread)) + + (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (sb-thread:make-mutex)) + (waitqueue (sb-thread:make-waitqueue)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (sb-thread:with-mutex (*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)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + + (defun condition-timed-wait (waitqueue mutex timeout) + (macrolet ((foo () + (cond ((member :sb-lutex *features*) ; Darwin + '(sb-thread:condition-wait waitqueue mutex)) + (t + '(handler-case + (let ((*break-on-signals* nil)) + (sb-sys:with-deadline (:seconds timeout + :override t) + (sb-thread:condition-wait waitqueue mutex) t)) + (sb-ext:timeout () + nil)))))) + (foo))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + (waitq (mailbox.waitqueue mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (sb-thread:with-mutex (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (condition-timed-wait waitq mutex 0.2))))) + + (let ((alist '()) + (mutex (sb-thread:make-mutex :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (sb-thread:with-mutex (mutex) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (sb-thread:thread + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (sb-thread:with-mutex (mutex) + (cdr (assoc name alist))))) + + ;; Workaround for deadlocks between the world-lock and auto-flush-thread + ;; buffer write lock. + ;; + ;; Another alternative would be to grab the world-lock here, but that's less + ;; future-proof, and could introduce other lock-ordering issues in the + ;; future. + ;; + ;; In an ideal world we would just have an :AROUND method on + ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this + ;; file is loaded -- so first we need a dummy definition that will be + ;; overridden by swank-gray.lisp. + #.(unless (find-package 'swank/gray) (make-package 'swank/gray) nil) + (eval-when (:load-toplevel :execute) + (unless (find-package 'swank/gray) (make-package 'swank/gray) nil)) + (defclass swank/gray::slime-output-stream + (sb-gray:fundamental-character-output-stream) + ()) + (defmethod sb-gray:stream-force-output + :around ((stream swank/gray::slime-output-stream)) + (handler-case + (sb-sys:with-deadline (:seconds 0.1) + (call-next-method)) + (sb-sys:deadline-timeout () + nil))) + ) + +(defimplementation quit-lisp () + #+#.(swank/backend:with-symbol 'exit 'sb-ext) + (sb-ext:exit) + #-#.(swank/backend:with-symbol 'exit 'sb-ext) + (progn + #+sb-thread + (dolist (thread (remove (current-thread) (all-threads))) + (ignore-errors (sb-thread:terminate-thread thread))) + (sb-ext:quit))) + + + +;;Trace implementations +;;In SBCL, we have: +;; (trace ) +;; (trace :methods ') ;to trace all methods of the gf +;; (trace (method ? (+))) +;; can be a normal name or a (setf name) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((member fspec (eval '(trace)) :test #'equal) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args)) + (format nil "~S is now traced." fspec)))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defmethod) + (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec))))) + ((:defgeneric) + (toggle-trace-aux (second spec) :methods t)) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee :wherein (list (process-fspec caller))))))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :key args) + #-#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation make-weak-value-hash-table (&rest args) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :value args) + #-#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation hash-table-weakness (hashtable) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (sb-ext:hash-table-weakness hashtable)) + +#-win32 +(defimplementation save-image (filename &optional restart-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (and (sb-posix:wifexited status) + (zerop (sb-posix:wexitstatus status)))))))))) + +#+unix +(progn + (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int + (program sb-alien:c-string) + (argv (* sb-alien:c-string))) + + (defun execv (program args) + "Replace current executable with another one." + (let ((a-args (sb-alien:make-alien sb-alien:c-string + (+ 1 (length args))))) + (unwind-protect + (progn + (loop for index from 0 by 1 + and item in (append args '(nil)) + do (setf (sb-alien:deref a-args index) + item)) + (when (minusp + (sys-execv program a-args)) + (error "execv(3) returned."))) + (sb-alien:free-alien a-args)))) + + (defun runtime-pathname () + #+#.(swank/backend:with-symbol + '*runtime-pathname* 'sb-ext) + sb-ext:*runtime-pathname* + #-#.(swank/backend:with-symbol + '*runtime-pathname* 'sb-ext) + (car sb-ext:*posix-argv*)) + + (defimplementation exec-image (image-file args) + (loop with fd-arg = + (loop for arg in args + and key = "" then arg + when (string-equal key "--swank-fd") + return (parse-integer arg)) + for my-fd from 3 to 1024 + when (/= my-fd fd-arg) + do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))) + (let* ((self-string (pathname-to-filename (runtime-pathname)))) + (execv + self-string + (apply 'list self-string "--core" image-file args))))) + +(defimplementation make-fd-stream (fd external-format) + (sb-sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering :full + :dual-channel-p t + :external-format external-format)) + +#-win32 +(defimplementation background-save-image (filename &key restart-function + completion-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-posix:close pipe-in) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (sb-posix:close pipe-out) + (sb-sys:add-fd-handler + pipe-in :input + (lambda (fd) + (sb-sys:invalidate-descriptor fd) + (sb-posix:close fd) + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (sb-posix:wifexited status)) + (funcall completion-function + (zerop (sb-posix:wexitstatus status)))))))))))) + +(pushnew 'deinit-log-output sb-ext:*save-hooks*) + + +;;;; wrap interface implementation + +(defun sbcl-version>= (&rest subversions) + #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) + (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t)) + #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) + nil) + +(defimplementation wrap (spec indicator &key before after replace) + (when (wrapped-p spec indicator) + (warn "~a already wrapped with indicator ~a, unwrapping first" + spec indicator) + (sb-int:unencapsulate spec indicator)) + (sb-int:encapsulate spec indicator + #-#.(swank/backend:with-symbol 'arg-list 'sb-int) + (lambda (function &rest args) + (sbcl-wrap spec before after replace function args)) + #+#.(swank/backend:with-symbol 'arg-list 'sb-int) + (if (sbcl-version>= 1 1 16) + (lambda () + (sbcl-wrap spec before after replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))) + `(sbcl-wrap ',spec ,before ,after ,replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))))) + +(defimplementation unwrap (spec indicator) + (sb-int:unencapsulate spec indicator)) + +(defimplementation wrapped-p (spec indicator) + (sb-int:encapsulated-p spec indicator)) + +(defun sbcl-wrap (spec before after replace function args) + (declare (ignore spec)) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list (if replace + (funcall replace + args) + (apply function args)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed retlist :exited-non-locally)))))) + +#+#.(swank/backend:with-symbol 'comma-expr 'sb-impl) +(progn + (defmethod sexp-in-bounds-p ((s sb-impl::comma) i) + (= i 1)) + + (defmethod sexp-ref ((s sb-impl::comma) i) + (sb-impl::comma-expr s))) diff --git a/vim/bundle/slimv/slime/swank/scl.lisp b/vim/bundle/slimv/slime/swank/scl.lisp new file mode 100644 index 0000000..7327133 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/scl.lisp @@ -0,0 +1,1726 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; Scieneer Common Lisp code for SLIME. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/scl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) + +(in-package swank/scl) + + + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP server +;;; +;;; SCL only supports the :spawn communication style. +;;; + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (let ((addr (resolve-hostname host))) + (ext:create-inet-listener port :stream :host addr :reuse-address t + :backlog (or backlog 5)))) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (ext:close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (let ((buffering (or buffering :full)) + (fd (socket-fd socket))) + (loop + (let ((ready (sys:wait-until-fd-usable fd :input timeout))) + (unless ready + (error "Timeout accepting connection on socket: ~S~%" socket))) + (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd)))) + (when new-fd + (return (make-socket-io-stream new-fd external-format + (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line))))))))) + +(defimplementation set-stream-timeout (stream timeout) + (check-type timeout (or null real)) + (if (fboundp 'ext::stream-timeout) + (setf (ext::stream-timeout stream) timeout) + (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout) + timeout))) + +;;;;; Sockets + +(defun socket-fd (socket) + "Return the file descriptor for the socket represented by 'socket." + (etypecase socket + (fixnum socket) + (stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of 'hostname as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(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"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd external-format buffering) + "Create a new input/output fd-stream for 'fd." + (cond ((not external-format) + (sys:make-fd-stream fd :input t :output t :buffering buffering + :element-type '(unsigned-byte 8))) + (t + (let* ((stream (sys:make-fd-stream fd :input t :output t + :element-type 'base-char + :buffering buffering + :external-format external-format))) + ;; Ignore character conversion errors. Without this the + ;; communication channel is prone to lockup if a character + ;; conversion error occurs. + (setf (lisp::character-conversion-stream-input-error-value stream) + #\?) + (setf (lisp::character-conversion-stream-output-error-value stream) + #\?) + stream)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + '#:ext) + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. + Nil if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (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-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `swank:compiler-condition's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of 'condition." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. + When Emacs presents the message it already has the source popped up + and the source form highlighted. This makes much of the information in + the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (and enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. + Return a `location' record, or (:error ) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse + (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + + +;;; TODO +(defimplementation who-calls (name) nil) +(defimplementation who-references (name) nil) +(defimplementation who-binds (name) nil) +(defimplementation who-sets (name) nil) +(defimplementation who-specializes (symbol) nil) +(defimplementation who-macroexpands (name) nil) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call 'fn for each constant in 'code's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return 'function's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of 'spaces. FN + receives the object as argument. 'spaces should be a list of the + symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call 'fn for each code component with a fdefn for 'function in its + constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return 'function's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used + for code-object without entry points, i.e., byte compiled + code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun valid-function-name-p (name) + (or (symbolp name) (and (consp name) + (eq (car name) 'setf) + (symbolp (cadr name)) + (not (cddr name))))) + +(defun code-component-entry-points (code) + "Return a list ((name location) ...) of function definitons for + the code omponent 'code." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((name location) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the SCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. + This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute 'body and return the source-location it returns. + If an error occurs and `*debug-definition-finding*' is false, then + return an error pseudo-location. + + The second return value is 'nil if no error occurs, otherwise it is the + condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values (list :error (princ-to-string c)) c)))))) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for 'code-location." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for 'code-location in 'filename." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a 'code-location from a stream. + This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for 'debug-info. + Function-name source-locations are a fallback for when precise + positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of 'debug-source contain an Emacs buffer location? + This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of 'code-location in 'stream. Extract the + toplevel-form-number and form-number from 'code-location and use that + to find the position of the corresponding form. + + Finish with 'stream positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in 'stream. + 'tlf-number is the top-level-form number. + 'form-number is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of 'code-location in 'string. + See 'code-location-stream-position." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; SCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the SCL manual for more details. + +(defun function-definitions (name) + "Return definitions for 'name in the \"function namespace\", i.e., + regular functions, generic functions, methods and macros. + 'name can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for 'function." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function 'fn." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in SCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is 'function a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that 'function belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (clos:generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (clos:generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (clos:method-generic-function method)) + (name (clos:generic-function-name gf)) + (specializers (clos:method-specializers method)) + (qualifiers (clos:method-qualifiers method))) + `(method ,name ,@qualifiers ,specializers + #+nil (clos::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (clos:method-function method))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (find-class name nil))) + (etypecase class + (null '()) + (structure-class + (list (list `(defstruct ,name) + (dd-location (find-dd name))))) + (standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or built-in-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((name (class-name class))) + `(:error ,(format nil "No location info for condition: ~A" name)))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun definition-source-location (object name) + `(:error ,(format nil "No source info for: ~A" object))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse name) + (ext:info :setf :expander name)))) + (if function + (list (list `(setf ,name) + (function-location (coerce function 'function))))))) + + +(defun variable-location (symbol) + `(:error ,(format nil "No source info for variable ~S" symbol))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unknown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (multiple-value-bind (args winp) + (ext:function-arglist fun) + (if winp args :not-available))) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((typep function 'generic-function) + (clos:generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. + A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation pathname-to-filename (pathname) + (ext:unix-namestring pathname nil)) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + (if (eq ext:*case-mode* :upper) "scl" "scl-lower")) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sldb-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down 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 (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of SCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:ucontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:ucontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; SCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol + (symbol-name '#:function-end-breakpoint-values/standard) + :debug-internals))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +#+nil +(defimplementation condition-extras ((c breakpoint)) + ;; simply pop up the source buffer + `((:short-frame-source 0))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +#+nil +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:instance-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:function-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp (symbol-name '#:-type) (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list (symbol-name '#:-type) :vm) + (apropos-list (symbol-name '#:-type) :bignum)))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (scl-inspect o)))) + +(defun scl-inspect (o) + (destructuring-bind (text labeledp . parts) + (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (list* (format nil "~A is a function.~%" o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (- (kernel:get-closure-length o) + (1- vm:closure-info-offset)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (scl-inspect o)) + (t + (call-next-method))))) + + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +(defmethod emacs-inspect ((o array)) + (cond ((kernel:array-header-p o) + (list* (format nil "~A is an array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + (t + (list* (format nil "~A is an simple-array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:length (length o))))))) + +(defmethod emacs-inspect ((o simple-vector)) + (list* (format nil "~A is a vector.~%" o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (unless (eq (array-element-type o) 'nil) + (loop for i below (length o) + append (label-value-line i (aref o i))))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (scl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #+nil :methods #+nil methods)) + + +;;;; Multiprocessing + +(defimplementation spawn (fn &key name) + (thread:thread-create fn :name (or name "Anonymous"))) + +(defvar *thread-id-counter* 0) +(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter")) + +(defimplementation thread-id (thread) + (thread:with-lock-held (*thread-id-counter-lock*) + (or (getf (thread:thread-plist thread) 'id) + (setf (getf (thread:thread-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (block find-thread + (thread:map-over-threads + #'(lambda (thread) + (when (eql (getf (thread:thread-plist thread) 'id) id) + (return-from find-thread thread)))))) + +(defimplementation thread-name (thread) + (princ-to-string (thread:thread-name thread))) + +(defimplementation thread-status (thread) + (let ((dynamic-values (thread::thread-dynamic-values thread))) + (if (zerop dynamic-values) "Exited" "Running"))) + +(defimplementation make-lock (&key name) + (thread:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (thread:with-lock-held (lock) (funcall function))) + +(defimplementation current-thread () + thread:*thread*) + +(defimplementation all-threads () + (let ((all-threads nil)) + (thread:map-over-threads #'(lambda (thread) (push thread all-threads))) + all-threads)) + +(defimplementation interrupt-thread (thread fn) + (thread:thread-interrupt thread #'(lambda () + (sys:with-interrupts + (funcall fn))))) + +(defimplementation kill-thread (thread) + (thread:destroy-thread thread)) + +(defimplementation thread-alive-p (thread) + (not (zerop (thread::thread-dynamic-values thread)))) + +(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil)) + +(defstruct (mailbox) + (lock (thread:make-lock "Thread mailbox" :type :error-check + :interruptible nil) + :type thread:error-check-lock) + (queue '() :type list)) + +(defun mailbox (thread) + "Return 'thread's mailbox." + (sys:without-interrupts + (thread:with-lock-held (*mailbox-lock*) + (or (getf (thread:thread-plist thread) 'mailbox) + (setf (getf (thread:thread-plist thread) 'mailbox) + (make-mailbox)))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox-lock mbox))) + (sys:without-interrupts + (thread:with-lock-held (lock "Mailbox Send") + (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) + (list message))))) + (mp:process-wakeup thread))) + +#+nil +(defimplementation receive () + (receive-if (constantly t))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox thread:*thread*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (sys:without-interrupts + (mp:with-lock-held ((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)))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox))))))) + + + +(defimplementation emacs-connected ()) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;; In SCL, we have: +;; (trace ) +;; (trace (method ? (+))) +;; (trace :methods t ') ;;to trace all methods of the gf +;; can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + nil) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ;; this isn't actually supported + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +;;; Weak datastructures + +;;; Not implemented in SCL. +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) diff --git a/vim/bundle/slimv/slime/swank/source-file-cache.lisp b/vim/bundle/slimv/slime/swank/source-file-cache.lisp new file mode 100644 index 0000000..ac48acf --- /dev/null +++ b/vim/bundle/slimv/slime/swank/source-file-cache.lisp @@ -0,0 +1,136 @@ +;;;; Source-file cache +;;; +;;; To robustly find source locations in CMUCL and SBCL it's useful to +;;; have the exact source code that the loaded code was compiled from. +;;; In this source we can accurately find the right location, and from +;;; that location we can extract a "snippet" of code to show what the +;;; definition looks like. Emacs can use this snippet in a best-match +;;; search to locate the right definition, which works well even if +;;; the buffer has been modified. +;;; +;;; The idea is that if a definition previously started with +;;; `(define-foo bar' then it probably still does. +;;; +;;; Whenever we see that the file on disk has the same +;;; `file-write-date' as a location we're looking for we cache the +;;; whole file inside Lisp. That way we will still have the matching +;;; version even if the file is later modified on disk. If the file is +;;; later recompiled and reloaded then we replace our cache entry. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(defpackage swank/source-file-cache + (:use cl) + (:import-from swank/backend + defimplementation buffer-first-change + guess-external-format + find-external-format) + (:export + get-source-code + source-cache-get ;FIXME: isn't it odd that both are exported? + + *source-snippet-size* + read-snippet + read-snippet-from-string + )) + +(in-package swank/source-file-cache) + +(defvar *cache-sourcecode* t + "When true complete source files are cached. +The cache is used to keep known good copies of the source text which +correspond to the loaded code. Finding definitions is much more +reliable when the exact source is available, so we cache it in case it +gets edited on disk later.") + +(defvar *source-file-cache* (make-hash-table :test 'equal) + "Cache of source file contents. +Maps from truename to source-cache-entry structure.") + +(defstruct (source-cache-entry + (:conc-name source-cache-entry.) + (:constructor make-source-cache-entry (text date))) + text date) + +(defimplementation buffer-first-change (filename) + "Load a file into the cache when the user modifies its buffer. +This is a win if the user then saves the file and tries to M-. into it." + (unless (source-cached-p filename) + (ignore-errors + (source-cache-get filename (file-write-date filename)))) + nil) + +(defun get-source-code (filename code-date) + "Return the source code for FILENAME as written on DATE in a string. +If the exact version cannot be found then return the current one from disk." + (or (source-cache-get filename code-date) + (read-file filename))) + +(defun source-cache-get (filename date) + "Return the source code for FILENAME as written on DATE in a string. +Return NIL if the right version cannot be found." + (when *cache-sourcecode* + (let ((entry (gethash filename *source-file-cache*))) + (cond ((and entry (equal date (source-cache-entry.date entry))) + ;; Cache hit. + (source-cache-entry.text entry)) + ((or (null entry) + (not (equal date (source-cache-entry.date entry)))) + ;; Cache miss. + (if (equal (file-write-date filename) date) + ;; File on disk has the correct version. + (let ((source (read-file filename))) + (setf (gethash filename *source-file-cache*) + (make-source-cache-entry source date)) + source) + nil)))))) + +(defun source-cached-p (filename) + "Is any version of FILENAME in the source cache?" + (if (gethash filename *source-file-cache*) t)) + +(defun read-file (filename) + "Return the entire contents of FILENAME as a string." + (with-open-file (s filename :direction :input + :external-format (or (guess-external-format filename) + (find-external-format "latin-1") + :default)) + (let* ((string (make-string (file-length s))) + (length (read-sequence string s))) + (subseq string 0 length)))) + +;;;; Snippets + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defun read-snippet (stream &optional position) + "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. +If POSITION is given, set the STREAM's file position first." + (when position + (file-position stream position)) + #+sbcl (skip-comments-and-whitespace stream) + (read-upto-n-chars stream *source-snippet-size*)) + +(defun read-snippet-from-string (string &optional position) + (with-input-from-string (s string) + (read-snippet s position))) + +(defun skip-comments-and-whitespace (stream) + (case (peek-char nil stream) + ((#\Space #\Tab #\Newline #\Linefeed #\Page) + (read-char stream) + (skip-comments-and-whitespace stream)) + (#\; + (read-line stream) + (skip-comments-and-whitespace stream)))) + +(defun read-upto-n-chars (stream n) + "Return a string of upto N chars from STREAM." + (let* ((string (make-string n)) + (chars (read-sequence string stream))) + (subseq string 0 chars))) diff --git a/vim/bundle/slimv/slime/swank/source-path-parser.lisp b/vim/bundle/slimv/slime/swank/source-path-parser.lisp new file mode 100644 index 0000000..bb9c35c --- /dev/null +++ b/vim/bundle/slimv/slime/swank/source-path-parser.lisp @@ -0,0 +1,239 @@ +;;;; Source-paths + +;;; CMUCL/SBCL use a data structure called "source-path" to locate +;;; subforms. The compiler assigns a source-path to each form in a +;;; compilation unit. Compiler notes usually contain the source-path +;;; of the error location. +;;; +;;; Compiled code objects don't contain source paths, only the +;;; "toplevel-form-number" and the (sub-) "form-number". To get from +;;; the form-number to the source-path we need the entire toplevel-form +;;; (i.e. we have to read the source code). CMUCL has already some +;;; utilities to do this translation, but we use some extended +;;; versions, because we need more exact position info. Apparently +;;; Hemlock is happy with the position of the toplevel-form; we also +;;; need the position of subforms. +;;; +;;; We use a special readtable to get the positions of the subforms. +;;; The readtable stores the start and end position for each subform in +;;; hashtable for later retrieval. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +;;; Taken from swank-cmucl.lisp, by Helmut Eller + +(defpackage swank/source-path-parser + (:use cl) + (:export + read-source-form + source-path-string-position + source-path-file-position + source-path-source-position + + sexp-in-bounds-p + sexp-ref) + (:shadow ignore-errors)) + +(in-package swank/source-path-parser) + +;; Some test to ensure the required conformance +(let ((rt (copy-readtable nil))) + (assert (or (not (get-macro-character #\space rt)) + (nth-value 1 (get-macro-character #\space rt)))) + (assert (not (get-macro-character #\\ rt)))) + +(eval-when (:compile-toplevel) + (defmacro ignore-errors (&rest forms) + ;;`(progn . ,forms) ; for debugging + `(cl:ignore-errors . ,forms))) + +(defun make-sharpdot-reader (orig-sharpdot-reader) + (lambda (s c n) + ;; We want things like M-. to work regardless of any #.-fu in + ;; the source file that is to be visited. (For instance, when a + ;; file contains #. forms referencing constants that do not + ;; currently exist in the image.) + (ignore-errors (funcall orig-sharpdot-reader s c n)))) + +(defun make-source-recorder (fn source-map) + "Return a macro character function that does the same as FN, but +additionally stores the result together with the stream positions +before and after of calling FN in the hashtable SOURCE-MAP." + (lambda (stream char) + (let ((start (1- (file-position stream))) + (values (multiple-value-list (funcall fn stream char))) + (end (file-position stream))) + #+(or) + (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" + start values end (char-code char) char) + (when values + (destructuring-bind (&optional existing-start &rest existing-end) + (car (gethash (car values) source-map)) + ;; Some macros may return what a sub-call to another macro + ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, + ;; once from #\# and once from #\(. If the saved form + ;; is a subform, don't save it again. + (unless (and existing-start existing-end + (<= start existing-start end) + (<= start existing-end end)) + (push (cons start end) (gethash (car values) source-map))))) + (values-list values)))) + +(defun make-source-recording-readtable (readtable source-map) + (declare (type readtable readtable) (type hash-table source-map)) + "Return a source position recording copy of READTABLE. +The source locations are stored in SOURCE-MAP." + (flet ((install-special-sharpdot-reader (rt) + (let ((fun (ignore-errors + (get-dispatch-macro-character #\# #\. rt)))) + (when fun + (let ((wrapper (make-sharpdot-reader fun))) + (set-dispatch-macro-character #\# #\. wrapper rt))))) + (install-wrappers (rt) + (dotimes (code 128) + (let ((char (code-char code))) + (multiple-value-bind (fun nt) (get-macro-character char rt) + (when fun + (let ((wrapper (make-source-recorder fun source-map))) + (set-macro-character char wrapper nt rt)))))))) + (let ((rt (copy-readtable readtable))) + (install-special-sharpdot-reader rt) + (install-wrappers rt) + rt))) + +;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. +;; Should be possible as we only need the right "list structure" and +;; not the right atoms. +(defun read-and-record-source-map (stream) + "Read the next object from STREAM. +Return the object together with a hashtable that maps +subexpressions of the object to stream positions." + (let* ((source-map (make-hash-table :test #'eq)) + (*readtable* (make-source-recording-readtable *readtable* source-map)) + (*read-suppress* nil) + (start (file-position stream)) + (form (ignore-errors (read stream))) + (end (file-position stream))) + ;; ensure that at least FORM is in the source-map + (unless (gethash form source-map) + (push (cons start end) (gethash form source-map))) + (values form source-map))) + +(defun starts-with-p (string prefix) + (declare (type string string prefix)) + (not (mismatch string prefix + :end1 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun extract-package (line) + (declare (type string line)) + (let ((name (cadr (read-from-string line)))) + (find-package name))) + +#+(or) +(progn + (assert (extract-package "(in-package cl)")) + (assert (extract-package "(cl:in-package cl)")) + (assert (extract-package "(in-package \"CL\")")) + (assert (extract-package "(in-package #:cl)"))) + +;; FIXME: do something cleaner than this. +(defun readtable-for-package (package) + ;; KLUDGE: due to the load order we can't reference the swank + ;; package. + (funcall (read-from-string "swank::guess-buffer-readtable") + (string-upcase (package-name package)))) + +;; Search STREAM for a "(in-package ...)" form. Use that to derive +;; the values for *PACKAGE* and *READTABLE*. +;; +;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends +;; use the same heuristic and to avoid the need to access +;; swank::guess-buffer-readtable from here. +(defun guess-reader-state (stream) + (let* ((point (file-position stream)) + (pkg *package*)) + (file-position stream 0) + (loop for line = (read-line stream nil nil) do + (when (not line) (return)) + (when (or (starts-with-p line "(in-package ") + (starts-with-p line "(cl:in-package ")) + (let ((p (extract-package line))) + (when p (setf pkg p))) + (return))) + (file-position stream point) + (values (readtable-for-package pkg) pkg))) + +(defun skip-whitespace (stream) + (peek-char t stream nil nil)) + +;; Skip over N toplevel forms. +(defun skip-toplevel-forms (n stream) + (let ((*read-suppress* t)) + (dotimes (i n) + (read stream)) + (skip-whitespace stream))) + +(defun read-source-form (n stream) + "Read the Nth toplevel form number with source location recording. +Return the form and the source-map." + (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) + (skip-toplevel-forms n stream) + (read-and-record-source-map stream))) + +(defun source-path-stream-position (path stream) + "Search the source-path PATH in STREAM and return its position." + (check-source-path path) + (destructuring-bind (tlf-number . path) path + (multiple-value-bind (form source-map) (read-source-form tlf-number stream) + (source-path-source-position (cons 0 path) form source-map)))) + +(defun check-source-path (path) + (unless (and (consp path) + (every #'integerp path)) + (error "The source-path ~S is not valid." path))) + +(defun source-path-string-position (path string) + (with-input-from-string (s string) + (source-path-stream-position path s))) + +(defun source-path-file-position (path filename) + ;; We go this long way round, and don't directly operate on the file + ;; stream because FILE-POSITION (used above) is not totally savy even + ;; on file character streams; on SBCL, FILE-POSITION returns the binary + ;; offset, and not the character offset---screwing up on Unicode. + (let ((toplevel-number (first path)) + (buffer)) + (with-open-file (file filename) + (skip-toplevel-forms (1+ toplevel-number) file) + (let ((endpos (file-position file))) + (setq buffer (make-array (list endpos) :element-type 'character + :initial-element #\Space)) + (assert (file-position file 0)) + (read-sequence buffer file :end endpos))) + (source-path-string-position path buffer))) + +(defgeneric sexp-in-bounds-p (sexp i) + (:method ((list list) i) + (< i (loop for e on list + count t))) + (:method ((sexp t) i) nil)) + +(defgeneric sexp-ref (sexp i) + (:method ((s list) i) (elt s i))) + +(defun source-path-source-position (path form source-map) + "Return the start position of PATH from FORM and SOURCE-MAP. All +subforms along the path are considered and the start and end position +of the deepest (i.e. smallest) possible form is returned." + ;; compute all subforms along path + (let ((forms (loop for i in path + for f = form then (if (sexp-in-bounds-p f i) + (sexp-ref f i)) + collect f))) + ;; select the first subform present in source-map + (loop for form in (nreverse forms) + for ((start . end) . rest) = (gethash form source-map) + when (and start end (not rest)) + return (return (values start end))))) -- cgit v1.2.3-54-g00ecf